[jlapack] 09/17: Imported Upstream version 0.8~dfsg
Andreas Tille
tille at debian.org
Fri Jan 29 21:01:20 UTC 2016
This is an automated email from the git hooks/post-receive script.
tille pushed a commit to branch master
in repository jlapack.
commit 3ae79630c32a9249eaeb403102103a48ba4ec673
Author: Andreas Tille <tille at debian.org>
Date: Fri Jan 29 21:46:24 2016 +0100
Imported Upstream version 0.8~dfsg
---
debian/README.source | 10 -
debian/changelog | 5 -
debian/compat | 1 -
debian/control | 27 -
debian/copyright | 68 -
debian/docs | 1 -
debian/get-orig-source | 26 -
debian/libjlapack-java.jlibs | 3 -
debian/patches/series | 2 -
debian/patches/update_README | 70 -
debian/patches/use_f2j_package_libs | 18 -
debian/rules | 26 -
debian/source/format | 1 -
jlapack-3.1.1/CHANGES | 113 +
jlapack-3.1.1/INSTALL | 54 +
jlapack-3.1.1/Makefile | 202 +
jlapack-3.1.1/README | 107 +
jlapack-3.1.1/dist/README | 132 +
jlapack-3.1.1/dist/test_blas1.bat | 3 +
jlapack-3.1.1/dist/test_blas1.sh | 3 +
jlapack-3.1.1/dist/test_blas2.bat | 2 +
jlapack-3.1.1/dist/test_blas2.sh | 3 +
jlapack-3.1.1/dist/test_blas3.bat | 2 +
jlapack-3.1.1/dist/test_blas3.sh | 3 +
jlapack-3.1.1/dist/test_eig.bat | 17 +
jlapack-3.1.1/dist/test_eig.sh | 19 +
jlapack-3.1.1/dist/test_lin.bat | 2 +
jlapack-3.1.1/dist/test_lin.sh | 3 +
jlapack-3.1.1/dist/test_sblas1.bat | 3 +
jlapack-3.1.1/dist/test_sblas1.sh | 3 +
jlapack-3.1.1/dist/test_sblas2.bat | 2 +
jlapack-3.1.1/dist/test_sblas2.sh | 3 +
jlapack-3.1.1/dist/test_sblas3.bat | 2 +
jlapack-3.1.1/dist/test_sblas3.sh | 3 +
jlapack-3.1.1/dist/test_seig.bat | 21 +
jlapack-3.1.1/dist/test_seig.sh | 20 +
jlapack-3.1.1/dist/test_slin.bat | 2 +
jlapack-3.1.1/dist/test_slin.sh | 3 +
jlapack-3.1.1/dist_timing/README | 112 +
jlapack-3.1.1/dist_timing/time_eig_large.bat | 4 +
jlapack-3.1.1/dist_timing/time_eig_large.sh | 6 +
jlapack-3.1.1/dist_timing/time_eig_small.bat | 4 +
jlapack-3.1.1/dist_timing/time_eig_small.sh | 6 +
jlapack-3.1.1/dist_timing/time_lin_large.bat | 6 +
jlapack-3.1.1/dist_timing/time_lin_large.sh | 8 +
jlapack-3.1.1/dist_timing/time_lin_small.bat | 6 +
jlapack-3.1.1/dist_timing/time_lin_small.sh | 8 +
jlapack-3.1.1/dist_timing/time_seig_large.bat | 4 +
jlapack-3.1.1/dist_timing/time_seig_large.sh | 6 +
jlapack-3.1.1/dist_timing/time_seig_small.bat | 4 +
jlapack-3.1.1/dist_timing/time_seig_small.sh | 6 +
jlapack-3.1.1/dist_timing/time_slin_large.bat | 6 +
jlapack-3.1.1/dist_timing/time_slin_large.sh | 8 +
jlapack-3.1.1/dist_timing/time_slin_small.bat | 6 +
jlapack-3.1.1/dist_timing/time_slin_small.sh | 8 +
jlapack-3.1.1/examples/DdotTest.java | 28 +
jlapack-3.1.1/examples/DgesvdTest.java | 22 +
jlapack-3.1.1/examples/DlaruvTest.java | 30 +
jlapack-3.1.1/examples/DstevrTest.java | 102 +
jlapack-3.1.1/examples/DsygvTest.java | 36 +
jlapack-3.1.1/examples/Makefile | 29 +
jlapack-3.1.1/examples/README | 19 +
jlapack-3.1.1/examples/SimpleDdotTest.java | 28 +
jlapack-3.1.1/examples/SimpleDgesvdTest.java | 27 +
jlapack-3.1.1/examples/SimpleDsygvTest.java | 41 +
jlapack-3.1.1/make.def | 217 +
jlapack-3.1.1/src/Makefile | 37 +
jlapack-3.1.1/src/Makefile_javasrc | 34 +
jlapack-3.1.1/src/blas/Makefile | 32 +
jlapack-3.1.1/src/blas/Makefile_javasrc | 28 +
jlapack-3.1.1/src/blas/blas.f | 14379 ++
jlapack-3.1.1/src/blas/verify_all.csh | 7 +
jlapack-3.1.1/src/error_reporting/Makefile | 20 +
jlapack-3.1.1/src/error_reporting/Makefile_javasrc | 19 +
jlapack-3.1.1/src/error_reporting/err.f | 42 +
jlapack-3.1.1/src/lapack/Makefile | 33 +
jlapack-3.1.1/src/lapack/Makefile_javasrc | 32 +
jlapack-3.1.1/src/lapack/lapack.f | 221504 ++++++++++++++++++
jlapack-3.1.1/src/lapack/verify_all.csh | 7 +
jlapack-3.1.1/src/testing/Makefile | 80 +
jlapack-3.1.1/src/testing/Makefile_javasrc | 79 +
jlapack-3.1.1/src/testing/blas1/Makefile | 35 +
jlapack-3.1.1/src/testing/blas1/Makefile_javasrc | 32 +
jlapack-3.1.1/src/testing/blas1/dblat1.f | 769 +
jlapack-3.1.1/src/testing/blas2/Makefile | 37 +
jlapack-3.1.1/src/testing/blas2/Makefile_javasrc | 33 +
jlapack-3.1.1/src/testing/blas2/dblat2.f | 3088 +
jlapack-3.1.1/src/testing/blas2/dblat2.in | 34 +
jlapack-3.1.1/src/testing/blas2/xerbla.f | 58 +
jlapack-3.1.1/src/testing/blas3/Makefile | 37 +
jlapack-3.1.1/src/testing/blas3/Makefile_javasrc | 34 +
jlapack-3.1.1/src/testing/blas3/dblat3.f | 2783 +
jlapack-3.1.1/src/testing/blas3/dblat3.in | 20 +
jlapack-3.1.1/src/testing/blas3/xerbla.f | 60 +
jlapack-3.1.1/src/testing/eig/Makefile | 50 +
jlapack-3.1.1/src/testing/eig/Makefile_javasrc | 45 +
jlapack-3.1.1/src/testing/eig/dbak.in | 130 +
jlapack-3.1.1/src/testing/eig/dbal.in | 215 +
jlapack-3.1.1/src/testing/eig/dbb.in | 12 +
jlapack-3.1.1/src/testing/eig/dec.in | 950 +
jlapack-3.1.1/src/testing/eig/ded.in | 865 +
jlapack-3.1.1/src/testing/eig/dgbak.in | 266 +
jlapack-3.1.1/src/testing/eig/dgbal.in | 304 +
jlapack-3.1.1/src/testing/eig/dgd.in | 86 +
jlapack-3.1.1/src/testing/eig/dgg.in | 15 +
jlapack-3.1.1/src/testing/eig/dsb.in | 9 +
jlapack-3.1.1/src/testing/eig/dsg.in | 13 +
jlapack-3.1.1/src/testing/eig/eigtest.f | 38907 +++
jlapack-3.1.1/src/testing/eig/glm.in | 9 +
jlapack-3.1.1/src/testing/eig/gqr.in | 9 +
jlapack-3.1.1/src/testing/eig/gsv.in | 9 +
jlapack-3.1.1/src/testing/eig/lse.in | 9 +
jlapack-3.1.1/src/testing/eig/nep.in | 16 +
jlapack-3.1.1/src/testing/eig/sep.in | 13 +
jlapack-3.1.1/src/testing/eig/svd.in | 15 +
jlapack-3.1.1/src/testing/eig/xerbla.f | 80 +
jlapack-3.1.1/src/testing/lin/Makefile | 47 +
jlapack-3.1.1/src/testing/lin/Makefile_javasrc | 42 +
jlapack-3.1.1/src/testing/lin/dtest.in | 34 +
jlapack-3.1.1/src/testing/lin/lintest.f | 36290 +++
jlapack-3.1.1/src/testing/lin/xerbla.f | 80 +
jlapack-3.1.1/src/testing/matgen/Makefile | 34 +
jlapack-3.1.1/src/testing/matgen/Makefile_javasrc | 33 +
jlapack-3.1.1/src/testing/matgen/matgen.f | 5512 +
jlapack-3.1.1/src/testing/sblas1/Makefile | 35 +
jlapack-3.1.1/src/testing/sblas1/Makefile_javasrc | 32 +
jlapack-3.1.1/src/testing/sblas1/sblat1.f | 769 +
jlapack-3.1.1/src/testing/sblas2/Makefile | 37 +
jlapack-3.1.1/src/testing/sblas2/Makefile_javasrc | 33 +
jlapack-3.1.1/src/testing/sblas2/sblat2.f | 3088 +
jlapack-3.1.1/src/testing/sblas2/sblat2.in | 34 +
jlapack-3.1.1/src/testing/sblas2/xerbla.f | 58 +
jlapack-3.1.1/src/testing/sblas3/Makefile | 37 +
jlapack-3.1.1/src/testing/sblas3/Makefile_javasrc | 34 +
jlapack-3.1.1/src/testing/sblas3/sblat3.f | 2783 +
jlapack-3.1.1/src/testing/sblas3/sblat3.in | 20 +
jlapack-3.1.1/src/testing/sblas3/xerbla.f | 60 +
jlapack-3.1.1/src/testing/seig/Makefile | 50 +
jlapack-3.1.1/src/testing/seig/Makefile_javasrc | 45 +
jlapack-3.1.1/src/testing/seig/glm.in | 9 +
jlapack-3.1.1/src/testing/seig/gqr.in | 9 +
jlapack-3.1.1/src/testing/seig/gsv.in | 9 +
jlapack-3.1.1/src/testing/seig/lse.in | 9 +
jlapack-3.1.1/src/testing/seig/nep.in | 16 +
jlapack-3.1.1/src/testing/seig/sbak.in | 130 +
jlapack-3.1.1/src/testing/seig/sbal.in | 213 +
jlapack-3.1.1/src/testing/seig/sbb.in | 12 +
jlapack-3.1.1/src/testing/seig/sec.in | 950 +
jlapack-3.1.1/src/testing/seig/sed.in | 865 +
jlapack-3.1.1/src/testing/seig/seigtest.f | 38896 +++
jlapack-3.1.1/src/testing/seig/sep.in | 13 +
jlapack-3.1.1/src/testing/seig/sgbak.in | 266 +
jlapack-3.1.1/src/testing/seig/sgbal.in | 304 +
jlapack-3.1.1/src/testing/seig/sgd.in | 86 +
jlapack-3.1.1/src/testing/seig/sgg.in | 15 +
jlapack-3.1.1/src/testing/seig/ssb.in | 9 +
jlapack-3.1.1/src/testing/seig/ssg.in | 13 +
jlapack-3.1.1/src/testing/seig/svd.in | 15 +
jlapack-3.1.1/src/testing/seig/xerbla.f | 80 +
jlapack-3.1.1/src/testing/slin/Makefile | 47 +
jlapack-3.1.1/src/testing/slin/Makefile_javasrc | 42 +
jlapack-3.1.1/src/testing/slin/slintest.f | 36288 +++
jlapack-3.1.1/src/testing/slin/stest.in | 34 +
jlapack-3.1.1/src/testing/slin/xerbla.f | 80 +
jlapack-3.1.1/src/testing/smatgen/Makefile | 34 +
jlapack-3.1.1/src/testing/smatgen/Makefile_javasrc | 33 +
jlapack-3.1.1/src/testing/smatgen/smatgen.f | 5513 +
jlapack-3.1.1/src/timing/Makefile | 33 +
jlapack-3.1.1/src/timing/eig/Makefile | 54 +
jlapack-3.1.1/src/timing/eig/dgeptim.in | 13 +
jlapack-3.1.1/src/timing/eig/dneptim.in | 12 +
jlapack-3.1.1/src/timing/eig/dseptim.in | 9 +
jlapack-3.1.1/src/timing/eig/dsvdtim.in | 11 +
jlapack-3.1.1/src/timing/eig/eigsrc/Makefile | 24 +
jlapack-3.1.1/src/timing/eig/eigsrc/eigsrc.f | 24989 ++
jlapack-3.1.1/src/timing/eig/eigtime.f | 14694 ++
.../src/timing/eig/input_files_large/DGEPTIM.in | 13 +
.../src/timing/eig/input_files_large/DNEPTIM.in | 12 +
.../src/timing/eig/input_files_large/DSEPTIM.in | 9 +
.../src/timing/eig/input_files_large/DSVDTIM.in | 11 +
jlapack-3.1.1/src/timing/lin/Makefile | 57 +
jlapack-3.1.1/src/timing/lin/dband.in | 17 +
jlapack-3.1.1/src/timing/lin/dblasa.in | 15 +
jlapack-3.1.1/src/timing/lin/dblasb.in | 17 +
jlapack-3.1.1/src/timing/lin/dblasc.in | 17 +
jlapack-3.1.1/src/timing/lin/dtime.in | 29 +
jlapack-3.1.1/src/timing/lin/dtime2.in | 20 +
.../src/timing/lin/input_files_large/DBAND.in | 17 +
.../src/timing/lin/input_files_large/DBLASA.in | 15 +
.../src/timing/lin/input_files_large/DBLASB.in | 17 +
.../src/timing/lin/input_files_large/DBLASC.in | 17 +
.../src/timing/lin/input_files_large/DTIME.in | 31 +
.../src/timing/lin/input_files_large/DTIME2.in | 20 +
jlapack-3.1.1/src/timing/lin/linsrc/Makefile | 24 +
jlapack-3.1.1/src/timing/lin/linsrc/linsrc.f | 5808 +
jlapack-3.1.1/src/timing/lin/lintime.f | 15345 ++
jlapack-3.1.1/src/timing/lin/lsamen.f | 76 +
jlapack-3.1.1/src/timing/seig/Makefile | 54 +
jlapack-3.1.1/src/timing/seig/eigsrc/Makefile | 24 +
jlapack-3.1.1/src/timing/seig/eigsrc/seigsrc.f | 24955 ++
.../src/timing/seig/input_files_large/SGEPTIM.in | 13 +
.../src/timing/seig/input_files_large/SNEPTIM.in | 12 +
.../src/timing/seig/input_files_large/SSEPTIM.in | 9 +
.../src/timing/seig/input_files_large/SSVDTIM.in | 11 +
jlapack-3.1.1/src/timing/seig/seigtime.f | 14655 ++
jlapack-3.1.1/src/timing/seig/sgeptim.in | 13 +
jlapack-3.1.1/src/timing/seig/sneptim.in | 12 +
jlapack-3.1.1/src/timing/seig/sseptim.in | 9 +
jlapack-3.1.1/src/timing/seig/ssvdtim.in | 11 +
jlapack-3.1.1/src/timing/slin/Makefile | 57 +
.../src/timing/slin/input_files_large/SBAND.in | 17 +
.../src/timing/slin/input_files_large/SBLASA.in | 15 +
.../src/timing/slin/input_files_large/SBLASB.in | 17 +
.../src/timing/slin/input_files_large/SBLASC.in | 17 +
.../src/timing/slin/input_files_large/STIME.in | 31 +
.../src/timing/slin/input_files_large/STIME2.in | 20 +
jlapack-3.1.1/src/timing/slin/linsrc/Makefile | 24 +
jlapack-3.1.1/src/timing/slin/linsrc/slinsrc.f | 5488 +
jlapack-3.1.1/src/timing/slin/lsamen.f | 76 +
jlapack-3.1.1/src/timing/slin/sband.in | 17 +
jlapack-3.1.1/src/timing/slin/sblasa.in | 15 +
jlapack-3.1.1/src/timing/slin/sblasb.in | 17 +
jlapack-3.1.1/src/timing/slin/sblasc.in | 17 +
jlapack-3.1.1/src/timing/slin/slintime.f | 15297 ++
jlapack-3.1.1/src/timing/slin/stime.in | 29 +
jlapack-3.1.1/src/timing/slin/stime2.in | 20 +
jlapack-3.1.1/src/util/Makefile | 21 +
jlapack-3.1.1/src/util/README | 8 +
.../EndOfFileWhenStartingReadException.java | 28 +
.../util/org/j_paine/formatter/FormatParser.java | 494 +
.../src/util/org/j_paine/formatter/FormatParser.jj | 220 +
.../j_paine/formatter/FormatParserConstants.java | 42 +
.../formatter/FormatParserTokenManager.java | 408 +
.../src/util/org/j_paine/formatter/Formatter.java | 1735 +
.../util/org/j_paine/formatter/NumberParser.java | 282 +
.../src/util/org/j_paine/formatter/NumberParser.jj | 95 +
.../j_paine/formatter/NumberParserConstants.java | 27 +
.../formatter/NumberParserTokenManager.java | 405 +
.../util/org/j_paine/formatter/ParseException.java | 192 +
.../src/util/org/j_paine/formatter/README | 7 +
.../org/j_paine/formatter/SimpleCharStream.java | 439 +
.../src/util/org/j_paine/formatter/Token.java | 81 +
.../util/org/j_paine/formatter/TokenMgrError.java | 133 +
.../src/util/org/netlib/util/ArraySpec.java | 47 +
jlapack-3.1.1/src/util/org/netlib/util/Dummy.java | 46 +
jlapack-3.1.1/src/util/org/netlib/util/EasyIn.java | 500 +
jlapack-3.1.1/src/util/org/netlib/util/Etime.java | 70 +
.../src/util/org/netlib/util/MatConv.java | 216 +
jlapack-3.1.1/src/util/org/netlib/util/Second.java | 47 +
.../src/util/org/netlib/util/StrictUtil.java | 332 +
.../src/util/org/netlib/util/StringW.java | 27 +
jlapack-3.1.1/src/util/org/netlib/util/Util.java | 531 +
.../src/util/org/netlib/util/booleanW.java | 27 +
.../src/util/org/netlib/util/doubleW.java | 28 +
jlapack-3.1.1/src/util/org/netlib/util/floatW.java | 28 +
jlapack-3.1.1/src/util/org/netlib/util/intW.java | 27 +
256 files changed, 548992 insertions(+), 258 deletions(-)
diff --git a/debian/README.source b/debian/README.source
deleted file mode 100644
index e459ec2..0000000
--- a/debian/README.source
+++ /dev/null
@@ -1,10 +0,0 @@
-jlapack for Debian
-------------------
-
-Code is extracted from CSV as there is no upstream tarball. Due to this, no watch
- file is present.
-A file is removed via get-orig-source target due to incompatibility license.
-This file CJFormat.java is not needed when f2j package is present.
-
-
-
diff --git a/debian/changelog b/debian/changelog
deleted file mode 100644
index 90c60db..0000000
--- a/debian/changelog
+++ /dev/null
@@ -1,5 +0,0 @@
-jlapack (0.8~dfsg-1) unstable; urgency=low
-
- * Initial release (Closes: #665341)
-
- -- Olivier Sallou <osallou at debian.org> Mon, 26 Mar 2012 11:44:58 +0200
diff --git a/debian/compat b/debian/compat
deleted file mode 100644
index 45a4fb7..0000000
--- a/debian/compat
+++ /dev/null
@@ -1 +0,0 @@
-8
diff --git a/debian/control b/debian/control
deleted file mode 100644
index 0eb9ca1..0000000
--- a/debian/control
+++ /dev/null
@@ -1,27 +0,0 @@
-Source: jlapack
-Section: contrib/java
-Priority: optional
-Maintainer: Debian Med Packaging Team <debian-med-packaging at lists.alioth.debian.org>
-DM-Upload-Allowed: yes
-Uploaders: Olivier Sallou <osallou at debian.org>
-Build-Depends: debhelper (>= 8), javahelper (>=0.25), f2j, default-jdk,
- libf2j-java
-Standards-Version: 3.9.3
-Homepage: http://icl.cs.utk.edu/f2j
-Vcs-Svn: svn://svn.debian.org/debian-med/trunk/packages/jlapack/trunk
-Vcs-Browser: http://svn.debian.org/wsvn/debian-med/trunk/packages/jlapack/trunk/
-
-Package: libjlapack-java
-Architecture: all
-Depends: ${shlibs:Depends}, ${misc:Depends}, ${java:Depends}, libf2j-java
-Recommends: ${java:Recommends}
-Description: LAPACK numerical subroutines translated from their Fortran 77 source
- The package provides the LAPACK numerical subroutines translated from their
- subset Fortran 77 source into class files, executable by the Java Virtual
- Machine (JVM) and for use by Java programmers.
- .
- This makes it possible for Java applications or applets, distributed on the
- World Wide Web to use established legacy numerical code that was originally
- written in Fortran.
- The translation is accomplished using a special purpose Fortran-to-Java
- (source-to-source) compiler.
diff --git a/debian/copyright b/debian/copyright
deleted file mode 100644
index 5017dc2..0000000
--- a/debian/copyright
+++ /dev/null
@@ -1,68 +0,0 @@
-Format: http://dep.debian.net/deps/dep5
-Upstream-Name: jlapack
-Source: http://icl.cs.utk.edu/f2j
-
-License: BSD
- Redistribution and use in source and binary forms, with or without
- modification, are permitted provided that the following conditions
- are met:
- 1. Redistributions of source code must retain the above copyright
- notice, this list of conditions and the following disclaimer.
- 2. Redistributions in binary form must reproduce the above copyright
- notice, this list of conditions and the following disclaimer in the
- documentation and/or other materials provided with the distribution.
- 3. Neither the name of the University nor the names of its contributors
- may be used to endorse or promote products derived from this software
- without specific prior written permission.
- .
- THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND
- ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
- IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
- ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE
- FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
- DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS
- OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
- HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
- LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
- OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
- SUCH DAMAGE.
-
-Files: *
-Copyright: 1998-2007 Keith Seymour
-License: BSD
-
-Files: src/util/org/netlib/util/EasyIn.java
-Copyright: 1997 Peter van der Linden
- 1998 Keith Seymour
-License: BSD
-
-Files: src/blas/blas.f
-Copyright: 1978-1993 Lawson, C.L. (JPL)
- 1978-1993 Hanson, R.J. (SNLA)
- 1978-1993 Kincaid, D.R. (U. of Texas)
- 1978-1993 Krogh, F.T. (JPL)
-License: BSD
-
-Files: src/lapack/lapack.f
-Copyright: 2006 Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
-License: BSD
-
-Files: debian/*
-Copyright: 2012 Olivier Sallou <osallou at debian.org>
-License: GPL-2+
- This package 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 package 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, see <http://www.gnu.org/licenses/>
- .
- On Debian systems, the complete text of the GNU General
- Public License version 2 can be found in "/usr/share/common-licenses/GPL-2".
-
diff --git a/debian/docs b/debian/docs
deleted file mode 100644
index bc0b863..0000000
--- a/debian/docs
+++ /dev/null
@@ -1 +0,0 @@
-jlapack-3.1.1/README
diff --git a/debian/get-orig-source b/debian/get-orig-source
deleted file mode 100755
index 5478b88..0000000
--- a/debian/get-orig-source
+++ /dev/null
@@ -1,26 +0,0 @@
-#!/bin/bash
-
-set -e
-
-PKG=`dpkg-parsechangelog | awk '/^Source/ { print $2 }'`
-VERSION=`dpkg-parsechangelog | awk '/^Version/ { print $2 }'| cut -d"-" -f1`
-
-
-mkdir -p ../tarballs
-cd ../tarballs
-
-rm -rf ${PKG}-${VERSION}.orig
-
-cvs -z3 -d:pserver:anonymous at f2j.cvs.sourceforge.net:/cvsroot/f2j export -r jlapack0_8 f2j/jlapack-3.1.1
-
-mv f2j ${PKG}-${VERSION}.orig
-
-
-cd ${PKG}-${VERSION}.orig
-rm -f jlapack-3.1.1/src/util/org/j_paine/formatter/CJFormat.java
-cd ..
-
-rm -f ${PKG}-${VERSION}.orig.tar.gz
-
-tar -czf ${PKG}_${VERSION}.orig.tar.gz ${PKG}-${VERSION}.orig
-rm -rf ${PKG}-${VERSION}.orig
diff --git a/debian/libjlapack-java.jlibs b/debian/libjlapack-java.jlibs
deleted file mode 100644
index 4d83953..0000000
--- a/debian/libjlapack-java.jlibs
+++ /dev/null
@@ -1,3 +0,0 @@
-jlapack-3.1.1/src/lapack/jlapack-lapack.jar
-jlapack-3.1.1/src/blas/jlapack-blas.jar
-jlapack-3.1.1/src/error_reporting/jlapack-xerbla.jar
diff --git a/debian/patches/series b/debian/patches/series
deleted file mode 100644
index 2880465..0000000
--- a/debian/patches/series
+++ /dev/null
@@ -1,2 +0,0 @@
-use_f2j_package_libs
-update_README
diff --git a/debian/patches/update_README b/debian/patches/update_README
deleted file mode 100644
index b31b5c6..0000000
--- a/debian/patches/update_README
+++ /dev/null
@@ -1,70 +0,0 @@
-Subject: remove install part of README and update lib names
-Description: Removal of installation steps and update libraries name
- to match those in package.
-Author: Olivier Sallou <osallou at debian.org>
-Last-Updated: 26-03-2012
---- a/jlapack-3.1.1/README
-+++ b/jlapack-3.1.1/README
-@@ -3,46 +3,13 @@
- May 31, 2007
- ----------------
-
--This directory should contain the following files:
--
-- README - this file
-- INSTALL - installation details
-- CHANGES - what has changed in this version
-- examples - directory containing a few examples of calling JLAPACK
--
- The following jar files should exist:
-
-- blas.jar - the BLAS library
-- blas_simple.jar - the simplified interfaces to BLAS
-- lapack.jar - the LAPACK library
-- lapack_simple.jar - the simplified interfaces to LAPACK
-- xerbla.jar - LAPACK error reporting routine
-+ jlapack-blas.jar - the BLAS library
-+ jlapack-lapack.jar - the LAPACK library
-+ jlapack-xerbla.jar - LAPACK error reporting routine
- f2jutil.jar - utilities required for running f2j translated code
-
--If you downloaded the 'strict' distribution, there will be
--four subdirectories:
--
-- strict_math_lib - calls java.lang.StrictMath instead of java.lang.Math,
-- but the methods are not declared as strictfp
-- strict_fp - methods are declared strictfp, but does not call
-- java.lang.StrictMath
-- strict_both - methods are declared strictfp and calls
-- java.lang.StrictMath
-- plain - not strict
--
--Each of the subdirectories will contain all of the jar files mentioned
--above.
--
--In addition to raw translations of the numerical routines, the blas_simple
--and lapack_simple jar files contain classes that provide a more Java-like
--interface to the underlying numerical functions. There is one such class
--for each numerical routine. The name of the class is simply the function
--name in all caps. For example, the fortran routine 'ddot' is translated
--into two classes: Ddot.java and DDOT.java. Ddot.java contains the actual
--translation of the fortran code while DDOT.java contains only a call to
--the real ddot (Ddot), but provides a more simple interface. Since the
--interface may have to do matrix transposition and copying for some routines,
--it is faster to use the 'raw' numerical routines.
-
- API documentation for the BLAS and LAPACK can be found online at the
- following URL:
-@@ -72,9 +39,9 @@
-
- 5. The appropriate jar files should be in your CLASSPATH.
- f2jutil.jar - should always be included
-- blas.jar - include if calling BLAS routines
-- lapack.jar - include if calling LAPACK routines
-- xerbla.jar - include for LAPACK error handling
-+ jlapack-blas.jar - include if calling BLAS routines
-+ jlapack-lapack.jar - include if calling LAPACK routines
-+ jlapack-xerbla.jar - include for LAPACK error handling
-
- So, if calling LAPACK, you'll want to include all four
- jar files in your CLASSPATH.
diff --git a/debian/patches/use_f2j_package_libs b/debian/patches/use_f2j_package_libs
deleted file mode 100644
index 21e67a8..0000000
--- a/debian/patches/use_f2j_package_libs
+++ /dev/null
@@ -1,18 +0,0 @@
-Subject: use library from f2j package
-Description: update the path to the f2jutil library provided
- by package f2j
-Author: Olivier Sallou <osallou at debian.org>
-Last-Updated: 26-03-2012
---- a/jlapack-3.1.1/src/util/Makefile
-+++ b/jlapack-3.1.1/src/util/Makefile
-@@ -4,8 +4,8 @@
- include $(ROOT)/make.def
-
- $(UTIL_JAR):
-- if test -f $(ROOT)/../util/$(UTIL_JAR); then \
-- cp $(ROOT)/../util/$(UTIL_JAR) .; \
-+ if test -f /usr/share/java/f2jutil.jar; then \
-+ cp /usr/share/java/f2jutil.jar .; \
- else \
- $(MAKE) util_deprecated;\
- fi
diff --git a/debian/rules b/debian/rules
deleted file mode 100755
index 5937fae..0000000
--- a/debian/rules
+++ /dev/null
@@ -1,26 +0,0 @@
-#!/usr/bin/make -f
-# -*- makefile -*-
-
-# Uncomment this to turn on verbose mode.
-#export DH_VERBOSE=1
-
-%:
- dh $@ --with javahelper
-
-override_dh_auto_build:
- cd jlapack-3.1.1 && make lib
- mv jlapack-3.1.1/src/lapack/lapack.jar jlapack-3.1.1/src/lapack/jlapack-lapack.jar
- mv jlapack-3.1.1/src/blas/blas.jar jlapack-3.1.1/src/blas/jlapack-blas.jar
- mv jlapack-3.1.1/src/error_reporting/xerbla.jar jlapack-3.1.1/src/error_reporting/jlapack-xerbla.jar
-
-get-orig-source:
- debian/get-orig-source
-
-
-override_dh_clean:
- cd jlapack-3.1.1 && make clean
- rm -f jlapack-3.1.1/src/lapack/jlapack-lapack.jar
- rm -f jlapack-3.1.1/src/blas/jlapack-lapack.jar
- rm -f jlapack-3.1.1/src/blas/jlapack-blas.jar
- rm -f jlapack-3.1.1/src/error_reporting/jlapack-xerbla.jar
- dh_clean
diff --git a/debian/source/format b/debian/source/format
deleted file mode 100644
index 163aaf8..0000000
--- a/debian/source/format
+++ /dev/null
@@ -1 +0,0 @@
-3.0 (quilt)
diff --git a/jlapack-3.1.1/CHANGES b/jlapack-3.1.1/CHANGES
new file mode 100644
index 0000000..e1f120c
--- /dev/null
+++ b/jlapack-3.1.1/CHANGES
@@ -0,0 +1,113 @@
+---------------------------------------------------------------------------
+JLAPACK 0.8 -- released May 31, 2007
+
+ This is a beta release of JLAPACK based on LAPACK version 3.1.1.
+ The previous translation was based on version 3.0, so there have been
+ many changes to LAPACK since then. See the following for details:
+
+ http://www.netlib.org/lapack/lapack-3.1.0.changes
+ http://www.netlib.org/lapack/lapack-3.1.1.changes
+
+ As with the previous version, there are single and double precision
+ versions of all routines (no complex yet) with different Java strictfp
+ modes available.
+
+ Translation of formatted output in the testers is also improved.
+
+ The single and double precision jar files have been merged.
+
+---------------------------------------------------------------------------
+JLAPACK 0.7 -- released January 31, 2007
+
+ There are several improvements in this release. First, there are
+ now single precision versions of all the BLAS and LAPACK libraries
+ as well as testers. There are versions of the libraries
+ that use Java's strict floating point mode and strict version of
+ the Java math library. Also for this release, there are translations
+ of the LAPACK timing routines.
+
+---------------------------------------------------------------------------
+JLAPACK 0.6-strict -- released December 7, 2006
+
+ This release contains versions of JLAPACK that use Java's strict
+floating-point features. Otherwise, it should be the same as 0.6.
+
+---------------------------------------------------------------------------
+JLAPACK 0.6 -- released January 14, 2002
+
+ Changed the way that variables are declared. f2j now generates variables
+ as local to the method (where possible). This normally gives better
+ performance than using static class variables.
+
+ Fixed a bug in the simplified interfaces. Thanks to Michael DiClemente
+ for the bug report.
+
+---------------------------------------------------------------------------
+JLAPACK 0.5 -- released August 23, 2001
+
+ This version can be generated either as Java source or directly as
+ JVM bytecode. The main change for 0.5 is that the library is based
+ on the LAPACK 3.0 source code.
+
+---------------------------------------------------------------------------
+JLAPACK 0.4 -- unreleased
+
+ This was the first version generated directly as JVM bytecode. This
+ version was never released because it was based on the LAPACK 2.0 sources
+ and we wanted the next release to be based on the LAPACK 3.0 sources.
+
+---------------------------------------------------------------------------
+JLAPACK 0.3a released June 5, 1998
+
+ This is an update to version 0.3, only minor changes have been made.
+
+ This release is reorganized a bit to make life easier on Win 95/NT
+ users. The JLAPACK classes are now all grouped into one ZIP file,
+ much like the core Java classes. So, users should adjust their
+ CLASSPATH to point at the ZIP file instead of jlapack-0.3/classes.
+ The INSTALL file has details.
+
+ Also the source code for the simplified interfaces is now stored in
+ the "ssrc" directory, rather than in "src".
+
+---------------------------------------------------------------------------
+JLAPACK 0.3 released May 22, 1998
+
+ This is the first general release of JLAPACK.
+
+ The major change for this release is that we no longer wrap every
+ scalar in a wrapper. We wrap only those scalars that really need
+ to be wrapped - that is, they are modified in the function/subroutine
+ or in some called function/subroutine. This helps a lot in the BLAS
+ and LAPACK libraries since most scalars are not modified. Of course,
+ this means that the interface is totally different from the previous
+ version.
+
+ This release contains some simplified front-ends to the numerical
+ routines. They should provide a more "Java-like" interface to the
+ underlying functions by accepting row-major 2D arrays and omitting
+ unnecessary parameters such as leading dimension and offset.
+
+ Comments from the original fortran source code are now retained
+ in the Java source.
+
+ This release was compiled with Sun's JDK 1.1.6 on Solaris 2.5 with
+ optimization turned off (using -O didn't seem to help much).
+
+---------------------------------------------------------------------------
+JLAPACK 0.2 released Apr 15, 1998
+
+ This release is organized into packages:
+ org.netlib.blas - BLAS
+ org.netlib.lapack - LAPACK
+ org.netlib.util - utilities needed by f2java-translated programs
+
+ This release was also compiled with optimization on.
+
+---------------------------------------------------------------------------
+JLAPACK 0.1 released Apr 1, 1998
+
+ This is basically an early evaluation version distributed to only
+ a few people.
+
+---------------------------------------------------------------------------
diff --git a/jlapack-3.1.1/INSTALL b/jlapack-3.1.1/INSTALL
new file mode 100644
index 0000000..bd2bdf8
--- /dev/null
+++ b/jlapack-3.1.1/INSTALL
@@ -0,0 +1,54 @@
+
+JLAPACK 0.8 Installation
+
+All you need to do to get started with JLAPACK is set your CLASSPATH.
+
+The following directions are for Solaris (using csh). Other UNIX platforms
+should be very similar. MS-DOS and Windows users should consult their JDK
+documentation to find out how to set the CLASSPATH.
+
+If your CLASSPATH environment variable is already set, append the following
+files to it:
+
+ $JLAPACK_HOME/f2jutil.jar
+ $JLAPACK_HOME/blas.jar
+ $JLAPACK_HOME/lapack.jar
+ $JLAPACK_HOME/xerbla.jar
+
+where JLAPACK_HOME represents the full path of the directory where you have
+JLAPACK installed.
+
+You may omit lapack.jar if you only plan to call BLAS routines, however
+the others should always be used.
+
+If you plan to use the simplified interfaces, you will need to add the
+corresponding jar files to your CLASSPATH:
+
+ $JLAPACK_HOME/blas_simple.jar -- for the simplified BLAS interface
+ $JLAPACK_HOME/lapack_simple.jar -- for the simplified LAPACK interface
+
+ For example, if your jlapack directory is /users/bob/jlapack/ the following
+command would append the appropriate files to your CLASSPATH:
+
+ % setenv CLASSPATH $CLASSPATH":/users/bob/jlapack/f2jutil.jar:/users/bob/jlapack/blas.jar:/users/bob/jlapack/lapack.jar:/users/bob/jlapack/xerbla.jar"
+
+If your CLASSPATH has not been set, you should set it to include the
+current directory as well as the jar files previously mentioned.
+For example:
+
+ % setenv CLASSPATH .:/users/bob/jlapack/f2jutil.jar:/users/bob/jlapack/blas.jar:/users/bob/jlapack/lapack.jar:/users/bob/jlapack/xerbla.jar
+
+There are several basic test files in the $JLAPACK_HOME/examples subdirectory.
+To verify that your CLASSPATH is properly set, attempt to build one of them
+without using the Makefile. For example:
+
+ % javac DdotTest.java
+
+If it compiles without any errors, try running it:
+
+ % java DdotTest
+ Answer = 36.3
+
+If DdotTest.java will not compile, double-check the CLASSPATH setting
+and the location of the class files. Take a look at the Makefile for
+an example of setting up the CLASSPATH.
diff --git a/jlapack-3.1.1/Makefile b/jlapack-3.1.1/Makefile
new file mode 100644
index 0000000..5deaa31
--- /dev/null
+++ b/jlapack-3.1.1/Makefile
@@ -0,0 +1,202 @@
+include make.def
+
+default:
+ @echo ""
+ @echo "JLAPACK (version: $(VERSION))"
+ @echo ""
+ @echo "The possible targets are as follows:"
+ @echo ""
+ @echo "Translated from Fortran directly to bytecode:"
+ @echo " lib - BLAS and LAPACK libraries"
+ @echo " testers - BLAS and LAPACK test routines"
+ @echo " alltests - build and run the test routines"
+ @echo " alldist - a distribution of everything"
+ @echo " libdist - a distribution of the BLAS and LAPACK libraries"
+ @echo " libdist_strict - a distribution of BLAS/LAPACK containing all strictfp versions"
+ @echo " testers_dist - a distribution of the BLAS and LAPACK test routines"
+ @echo " timers - BLAS and LAPACK timing routines"
+ @echo " timers_dist - a distribution of the BLAS and LAPACK timing routines"
+ @echo ""
+ @echo "Translated from Fortran to Java source:"
+ @echo " javasrc - BLAS and LAPACK libraries"
+ @echo " testers_javasrc - BLAS and LAPACK test routines"
+ @echo " alltests_javasrc - build and run the test routines"
+ @echo " libdist_javasrc - a distribution of the BLAS and LAPACK libraries"
+ @echo " libdist_strict_javasrc - a distribution of BLAS/LAPACK containing all strictfp versions"
+ @echo " testers_dist_javasrc - a distribution of the BLAS and LAPACK test routines"
+ @echo ""
+ @echo "Documentation:"
+ @echo " javadoc - documentation in javadoc HTML format"
+ @echo " javadoc_dist - distribution of the documentation"
+ @echo ""
+ @echo "Other:"
+ @echo " clean - remove all jar files, generated code, etc."
+
+alldist:
+ $(MAKE) clean
+ $(MAKE) libdist
+ $(MAKE) almost_clean
+ $(MAKE) libdist_strict
+ $(MAKE) almost_clean
+ $(MAKE) testers_dist
+ $(MAKE) almost_clean
+ $(MAKE) javadoc_dist
+
+lib:
+ cd $(SRCDIR); $(MAKE)
+
+all:
+ cd $(SRCDIR); $(MAKE) all
+
+testers: lib
+ cd $(TESTING_DIR); $(MAKE) testers
+
+matgen:
+ cd $(MATGEN_DIR); $(MAKE)
+
+smatgen:
+ cd $(SMATGEN_DIR); $(MAKE)
+
+timers: lib matgen smatgen
+ cd $(TIMING_DIR); $(MAKE) timers
+
+testers_javasrc: javasrc
+ cd $(TESTING_DIR); $(MAKE) -f Makefile_javasrc testers
+
+alltests: testers
+ cd $(TESTING_DIR); $(MAKE) runtests
+
+alltests_javasrc: testers_javasrc
+ cd $(TESTING_DIR); $(MAKE) -f Makefile_javasrc runtests
+
+javasrc:
+ cd $(SRCDIR); $(MAKE) -f Makefile_javasrc
+
+javadoc: lib
+ mkdir -p doc
+ javadoc -author -sourcepath $(BLAS_OBJ):$(LAPACK_OBJ):$(ERR_OBJ):$(UTIL_F2J_SRC_DIR) -d doc -J-mx256000000 $(UTIL_PACKAGE) $(BLAS_PACKAGE) $(LAPACK_PACKAGE) $(ERR_PACKAGE)
+
+javadoc_dist: javadoc
+ /bin/rm -f $(JAVADOC_DIST_ZIP) $(JAVADOC_DIST_TGZ) $(VERSION)/doc
+ mkdir -p $(VERSION)
+ cd $(VERSION); ln -s ../doc doc
+ $(ZIP) -r9 $(JAVADOC_DIST_ZIP) $(VERSION)/doc
+ $(TAR) $(TARFLAGS) - $(VERSION)/doc | $(GZIP) > $(JAVADOC_DIST_TGZ)
+
+libdist: lib libdist_common
+ $(ZIP) -r9 $(LIBDIST_ZIP) $(VERSION)
+ $(TAR) $(TARFLAGS) - $(VERSION) | $(GZIP) > $(LIBDIST_TGZ)
+
+libdist_javasrc: javasrc libdist_common
+ $(ZIP) -r9 $(LIBDIST_ZIP) $(VERSION)
+ $(TAR) $(TARFLAGS) - $(VERSION) | $(GZIP) > $(LIBDIST_TGZ)
+
+libdist_common:
+ /bin/rm -rf $(VERSION)
+ mkdir -p $(VERSION)/examples
+ cp README INSTALL CHANGES $(VERSION)
+ cp examples/*.java examples/Makefile examples/README $(VERSION)/examples
+ $(MAKE) STRICT_DIR="" libdist_copy_jar_files
+
+libdist_strict:
+ $(MAKE) LIB_TARGET=lib libdist_strict_common
+ $(ZIP) -r9 $(LIBDIST_STRICT_ZIP) $(VERSION)
+ $(TAR) $(TARFLAGS) - $(VERSION) | $(GZIP) > $(LIBDIST_STRICT_TGZ)
+
+libdist_strict_javasrc:
+ $(MAKE) LIB_TARGET=javasrc libdist_strict_common
+ $(ZIP) -r9 $(LIBDIST_STRICT_ZIP) $(VERSION)
+ $(TAR) $(TARFLAGS) - $(VERSION) | $(GZIP) > $(LIBDIST_STRICT_TGZ)
+
+libdist_strict_common:
+ $(MAKE) almost_clean
+ /bin/rm -rf $(VERSION)
+ mkdir -p $(VERSION)/plain
+ mkdir -p $(VERSION)/strict_both
+ mkdir -p $(VERSION)/strict_fp
+ mkdir -p $(VERSION)/strict_math_lib
+ $(MAKE) STATIC=-fb $(LIB_TARGET)
+ $(MAKE) STRICT_DIR=strict_both libdist_copy_jar_files
+ cd src; $(MAKE) clean
+ $(MAKE) STATIC=-fm $(LIB_TARGET)
+ $(MAKE) STRICT_DIR=strict_math_lib libdist_copy_jar_files
+ cd src; $(MAKE) clean
+ $(MAKE) STATIC=-fs $(LIB_TARGET)
+ $(MAKE) STRICT_DIR=strict_fp libdist_copy_jar_files
+ cd src; $(MAKE) clean
+ $(MAKE) $(LIB_TARGET)
+ $(MAKE) STRICT_DIR=plain libdist_copy_jar_files
+ cp README INSTALL CHANGES $(VERSION)
+ mkdir -p $(VERSION)/examples
+ cp examples/*.java examples/Makefile examples/README $(VERSION)/examples
+
+libdist_copy_jar_files:
+ cp $(BLAS_DIR)/$(BLAS_JAR) $(BLAS_DIR)/$(SIMPLE_BLAS_JAR) \
+ $(LAPACK_DIR)/$(LAPACK_JAR) $(LAPACK_DIR)/$(SIMPLE_LAPACK_JAR) \
+ $(UTIL_DIR)/$(UTIL_JAR) $(ERR_DIR)/$(ERR_JAR) $(VERSION)/$(STRICT_DIR)
+
+testers_dist: testers testers_dist_common
+ $(ZIP) -r9 $(TESTERS_DIST_ZIP) $(VERSION)/testing
+ $(TAR) $(TARFLAGS) - $(VERSION)/testing | $(GZIP) > $(TESTERS_DIST_TGZ)
+
+testers_dist_javasrc: testers_javasrc testers_dist_common
+ $(ZIP) -r9 $(TESTERS_DIST_ZIP) $(VERSION)/testing
+ $(TAR) $(TARFLAGS) - $(VERSION)/testing | $(GZIP) > $(TESTERS_DIST_TGZ)
+
+testers_dist_common:
+ /bin/rm -rf $(VERSION)/testing
+ mkdir -p $(VERSION)/testing
+ -/bin/cp $(BLAS2TEST_DIR)/*.in $(BLAS3TEST_DIR)/*.in $(SBLAS2TEST_DIR)/*.in \
+ $(SBLAS3TEST_DIR)/*.in $(LINTEST_DIR)/*.in $(SLINTEST_DIR)/*.in \
+ $(EIGTEST_DIR)/*.in $(SEIGTEST_DIR)/*.in $(VERSION)/testing
+ -/bin/cp $(DISTDIR_TESTING)/*.sh $(DISTDIR_TESTING)/*.bat \
+ $(DISTDIR_TESTING)/README $(VERSION)/testing
+ -ln -s ../../$(BLAS1TEST_DIR)/$(BLAS1TEST_JAR) $(VERSION)/testing/$(BLAS1TEST_JAR)
+ -ln -s ../../$(BLAS2TEST_DIR)/$(BLAS2TEST_JAR) $(VERSION)/testing/$(BLAS2TEST_JAR)
+ -ln -s ../../$(BLAS3TEST_DIR)/$(BLAS3TEST_JAR) $(VERSION)/testing/$(BLAS3TEST_JAR)
+ -ln -s ../../$(SBLAS1TEST_DIR)/$(SBLAS1TEST_JAR) $(VERSION)/testing/$(SBLAS1TEST_JAR)
+ -ln -s ../../$(SBLAS2TEST_DIR)/$(SBLAS2TEST_JAR) $(VERSION)/testing/$(SBLAS2TEST_JAR)
+ -ln -s ../../$(SBLAS3TEST_DIR)/$(SBLAS3TEST_JAR) $(VERSION)/testing/$(SBLAS3TEST_JAR)
+ -ln -s ../../$(MATGEN_DIR)/$(MATGEN_JAR) $(VERSION)/testing/$(MATGEN_JAR)
+ -ln -s ../../$(SMATGEN_DIR)/$(SMATGEN_JAR) $(VERSION)/testing/$(SMATGEN_JAR)
+ -ln -s ../../$(LINTEST_DIR)/$(LINTEST_JAR) $(VERSION)/testing/$(LINTEST_JAR)
+ -ln -s ../../$(SLINTEST_DIR)/$(SLINTEST_JAR) $(VERSION)/testing/$(SLINTEST_JAR)
+ -ln -s ../../$(EIGTEST_DIR)/$(EIGTEST_JAR) $(VERSION)/testing/$(EIGTEST_JAR)
+ -ln -s ../../$(SEIGTEST_DIR)/$(SEIGTEST_JAR) $(VERSION)/testing/$(SEIGTEST_JAR)
+
+timers_dist: timers timers_dist_common
+ $(ZIP) -r9 $(TIMERS_DIST_ZIP) $(VERSION)/timing
+ $(TAR) $(TARFLAGS) - $(VERSION)/timing | $(GZIP) > $(TIMERS_DIST_TGZ)
+
+timers_dist_common:
+ /bin/rm -rf $(VERSION)/timing
+ mkdir -p $(VERSION)/timing/input_files_large
+ -/bin/cp $(LINTIME_DIR)/*.in $(SLINTIME_DIR)/*.in $(EIGTIME_DIR)/*.in \
+ $(SEIGTIME_DIR)/*.in $(VERSION)/timing
+ -/bin/cp $(LINTIME_DIR)/input_files_large/*.in \
+ $(SLINTIME_DIR)/input_files_large/*.in \
+ $(EIGTIME_DIR)/input_files_large/*.in \
+ $(SEIGTIME_DIR)/input_files_large/*.in \
+ $(VERSION)/timing/input_files_large
+ -/bin/cp $(DISTDIR_TIMING)/*.sh $(DISTDIR_TIMING)/*.bat \
+ $(DISTDIR_TIMING)/README $(VERSION)/timing
+ -ln -s ../../$(MATGEN_DIR)/$(MATGEN_JAR) $(VERSION)/timing/$(MATGEN_JAR)
+ -ln -s ../../$(SMATGEN_DIR)/$(SMATGEN_JAR) $(VERSION)/timing/$(SMATGEN_JAR)
+ -ln -s ../../$(LINTIME_DIR)/$(LINTIME_JAR) $(VERSION)/timing/$(LINTIME_JAR)
+ -ln -s ../../$(SLINTIME_DIR)/$(SLINTIME_JAR) $(VERSION)/timing/$(SLINTIME_JAR)
+ -ln -s ../../$(EIGTIME_DIR)/$(EIGTIME_JAR) $(VERSION)/timing/$(EIGTIME_JAR)
+ -ln -s ../../$(SEIGTIME_DIR)/$(SEIGTIME_JAR) $(VERSION)/timing/$(SEIGTIME_JAR)
+
+examples:
+ cd examples; $(MAKE)
+
+almost_clean:
+ cd src; $(MAKE) clean
+ cd examples; $(MAKE) clean
+ /bin/rm -rf doc $(VERSION)
+
+clean: almost_clean
+ /bin/rm -rf $(LIBDIST_ZIP) $(LIBDIST_TGZ) \
+ $(TESTERS_DIST_ZIP) $(TESTERS_DIST_TGZ) $(JAVADOC_DIST_ZIP) \
+ $(JAVADOC_DIST_TGZ) $(TIMERS_DIST_ZIP) $(TIMERS_DIST_TGZ) \
+ $(LIBDIST_STRICT_ZIP) $(LIBDIST_STRICT_TGZ)
diff --git a/jlapack-3.1.1/README b/jlapack-3.1.1/README
new file mode 100644
index 0000000..a295a4b
--- /dev/null
+++ b/jlapack-3.1.1/README
@@ -0,0 +1,107 @@
+
+JLAPACK 0.8
+May 31, 2007
+----------------
+
+This directory should contain the following files:
+
+ README - this file
+ INSTALL - installation details
+ CHANGES - what has changed in this version
+ examples - directory containing a few examples of calling JLAPACK
+
+The following jar files should exist:
+
+ blas.jar - the BLAS library
+ blas_simple.jar - the simplified interfaces to BLAS
+ lapack.jar - the LAPACK library
+ lapack_simple.jar - the simplified interfaces to LAPACK
+ xerbla.jar - LAPACK error reporting routine
+ f2jutil.jar - utilities required for running f2j translated code
+
+If you downloaded the 'strict' distribution, there will be
+four subdirectories:
+
+ strict_math_lib - calls java.lang.StrictMath instead of java.lang.Math,
+ but the methods are not declared as strictfp
+ strict_fp - methods are declared strictfp, but does not call
+ java.lang.StrictMath
+ strict_both - methods are declared strictfp and calls
+ java.lang.StrictMath
+ plain - not strict
+
+Each of the subdirectories will contain all of the jar files mentioned
+above.
+
+In addition to raw translations of the numerical routines, the blas_simple
+and lapack_simple jar files contain classes that provide a more Java-like
+interface to the underlying numerical functions. There is one such class
+for each numerical routine. The name of the class is simply the function
+name in all caps. For example, the fortran routine 'ddot' is translated
+into two classes: Ddot.java and DDOT.java. Ddot.java contains the actual
+translation of the fortran code while DDOT.java contains only a call to
+the real ddot (Ddot), but provides a more simple interface. Since the
+interface may have to do matrix transposition and copying for some routines,
+it is faster to use the 'raw' numerical routines.
+
+API documentation for the BLAS and LAPACK can be found online at the
+following URL:
+
+ http://www.cs.utk.edu/f2j/docs/html/packages.html
+
+NOTES:
+
+1. This release has not been tuned for performance - it is a simple,
+ automatic translation.
+
+2. Some scalars must be wrapped in objects. The wrapper classes are
+ located in the org.netlib.util package. Therefore, your code
+ should contain "import org.netlib.util.*;" to have access to the
+ wrappers.
+
+ In addition, your code should import org.netlib.lapack.Blah or
+ org.netlib.blas.Blah, where Blah represents the routine your
+ code calls. See the files DdotTest.java and DlaruvTest.java
+ for examples.
+
+3. See the warnings on recompilation in the INSTALL file.
+
+4. If you are using a JVM with a JIT complier and encounter a
+ fault in calling JLAPACK, try turning off the JIT and report
+ the problem to f2j at cs.utk.edu.
+
+5. The appropriate jar files should be in your CLASSPATH.
+ f2jutil.jar - should always be included
+ blas.jar - include if calling BLAS routines
+ lapack.jar - include if calling LAPACK routines
+ xerbla.jar - include for LAPACK error handling
+
+ So, if calling LAPACK, you'll want to include all four
+ jar files in your CLASSPATH.
+
+ You may customize your error handling by replacing xerbla.jar
+ with your own error reporting package.
+
+The following two notes only apply to interfacing with the 'raw'
+numerical routines, not the Java style front-ends.
+
+6. All array arguments are followed by an extra "offset" argument.
+ This allows passing array subsections.
+
+7. It is important to keep this in mind when interfacing Java code
+ to the JLAPACK routines: all multidimensional arrays are mapped
+ to one-dimensional arrays in the translated code and the original
+ column-major layout is maintained.
+
+The following note only applies to using the Java style front-ends.
+
+8. When you pass Java 2D arrays to one of the interface routines,
+ it will make a copy of it and convert it into a linearized 1D
+ array to be passed to the underlying numerical routine. If some
+ routine takes two matrices and you pass the same matrix for both
+ arguments, the interface will generate two copies of the same
+ array rather than the single copy that would normally be provided
+ to the underlying routine. Therefore, some inconsistency in the
+ results could occur.
+
+Contact f2j at cs.utk.edu with any questions, comments, or suggestions.
diff --git a/jlapack-3.1.1/dist/README b/jlapack-3.1.1/dist/README
new file mode 100644
index 0000000..99804fc
--- /dev/null
+++ b/jlapack-3.1.1/dist/README
@@ -0,0 +1,132 @@
+JLAPACK 0.8 testing routines README
+May 31, 2007
+
+This directory should contain:
+ README - this file
+
+ Test Scripts for Double Precision:
+ test_blas1.bat - windows batch file to test BLAS level 1
+ test_blas2.bat - windows batch file to test BLAS level 2
+ test_blas3.bat - windows batch file to test BLAS level 3
+ test_eig.bat - windows batch file to test LAPACK linear equation routines
+ test_lin.bat - windows batch file to test LAPACK eigenvalue routines
+ test_blas1.sh - unix shell script to test BLAS level 1
+ test_blas2.sh - unix shell script to test BLAS level 2
+ test_blas3.sh - unix shell script to test BLAS level 3
+ test_eig.sh - unix shell script to test LAPACK linear equation routines
+ test_lin.sh - unix shell script to test LAPACK eigenvalue routines
+
+ Test Scripts for Single Precision:
+ test_sblas1.bat - windows batch file to test BLAS level 1
+ test_sblas2.bat - windows batch file to test BLAS level 2
+ test_sblas3.bat - windows batch file to test BLAS level 3
+ test_seig.bat - windows batch file to test LAPACK linear equation routines
+ test_slin.bat - windows batch file to test LAPACK eigenvalue routines
+ test_sblas1.sh - unix shell script to test BLAS level 1
+ test_sblas2.sh - unix shell script to test BLAS level 2
+ test_sblas3.sh - unix shell script to test BLAS level 3
+ test_seig.sh - unix shell script to test LAPACK linear equation routines
+ test_slin.sh - unix shell script to test LAPACK eigenvalue routines
+
+ Jar Files for Double Precision:
+ dblat1.jar - BLAS level 1 testing code
+ dblat2.jar - BLAS level 2 testing code
+ dblat3.jar - BLAS level 3 testing code
+ eigtest.jar - LAPACK eigenvalue testing code
+ lintest.jar - LAPACK linear equation testing code
+ matgen.jar - support routines for the testers
+
+ Jar Files for Single Precision:
+ sblat1.jar - BLAS level 1 testing code
+ sblat2.jar - BLAS level 2 testing code
+ sblat3.jar - BLAS level 3 testing code
+ seigtest.jar - LAPACK eigenvalue testing code
+ slintest.jar - LAPACK linear equation testing code
+ smatgen.jar - support routines for the testers
+
+ Test Input Files:
+ dblat2.in - Double precision BLAS level 2 input file
+ dblat3.in - Double precision BLAS level 3 input file
+ sblat2.in - Single precision BLAS level 2 input file
+ sblat3.in - Single precision BLAS level 3 input file
+ dtest.in - Double precision linear equation input file
+ stest.in - Single precision linear equation input file
+ dbak.in - eigenvalue input file
+ dbal.in - eigenvalue input file
+ dec.in - eigenvalue input file
+ ded.in - eigenvalue input file
+ dgbak.in - eigenvalue input file
+ dgbal.in - eigenvalue input file
+ dgg.in - eigenvalue input file
+ dsb.in - eigenvalue input file
+ dsg.in - eigenvalue input file
+ glm.in - eigenvalue input file
+ gqr.in - eigenvalue input file
+ gsv.in - eigenvalue input file
+ lse.in - eigenvalue input file
+ nep.in - eigenvalue input file
+ sbak.in - eigenvalue input file
+ sbal.in - eigenvalue input file
+ sbb.in - eigenvalue input file
+ sec.in - eigenvalue input file
+ sed.in - eigenvalue input file
+ sep.in - eigenvalue input file
+ sgbak.in - eigenvalue input file
+ sgbal.in - eigenvalue input file
+ sgd.in - eigenvalue input file
+ sgg.in - eigenvalue input file
+ ssb.in - eigenvalue input file
+ ssg.in - eigenvalue input file
+ svd.in - eigenvalue input file
+
+To run the tests, simply execute the appropriate script, which
+depends on the operating system you are running.
+
+Some of the output is not exactly as the Fortran versions
+would be (e.g. some arrays are printed as "NULL", but that is
+only a limitation of the f2j I/O handling), however this
+does not affect the running of the tests. As long as the
+test results say "All tests passed the threshold", then things
+are fine (see the note below, however).
+
+Test results
+------------
+
+We tested JLAPACK on the following platforms:
+
+-Solaris 9 (sparc), Java version:
+
+ java version "1.5.0_02"
+ Java(TM) 2 Runtime Environment, Standard Edition (build 1.5.0_02-b09)
+ Java HotSpot(TM) Client VM (build 1.5.0_02-b09, mixed mode, sharing)
+
+-Solaris 9 (x86), Java version:
+
+ java version "1.4.2_05"
+ Java(TM) 2 Runtime Environment, Standard Edition (build 1.4.2_05-b04)
+ Java HotSpot(TM) Client VM (build 1.4.2_05-b04, mixed mode)
+
+-Linux x86 (Debian 3.1), Java version:
+
+ java version "1.6.0"
+ Java(TM) SE Runtime Environment (build 1.6.0-b105)
+ Java HotSpot(TM) Client VM (build 1.6.0-b105, mixed mode, sharing)
+
+-Linux x86 (Fedora Core 4), Java version:
+
+ java version "1.4.2"
+ gij (GNU libgcj) version 4.0.0 20050519 (Red Hat 4.0.0-8)
+
+-Mac OS X 10.4.7 (ppc), Java version:
+
+ java version "1.5.0_06"
+ Java(TM) 2 Runtime Environment, Standard Edition (build 1.5.0_06-112)
+ Java HotSpot(TM) Client VM (build 1.5.0_06-64, mixed mode, sharing)
+
+-Win2000 x86 / Sun JDK 1.6
+
+Note: in single precision, the eigenvalue testers will report
+some failures, but they match the failures observed during execution
+of the native Fortran code. For more details, see:
+
+ http://www.netlib.org/lapack/faq.html#1.23
diff --git a/jlapack-3.1.1/dist/test_blas1.bat b/jlapack-3.1.1/dist/test_blas1.bat
new file mode 100644
index 0000000..894f2b4
--- /dev/null
+++ b/jlapack-3.1.1/dist/test_blas1.bat
@@ -0,0 +1,3 @@
+
+
+java -classpath .\dblat1.jar;..\f2jutil.jar;..\blas.jar; org.netlib.blas.testing.Dblat1
diff --git a/jlapack-3.1.1/dist/test_blas1.sh b/jlapack-3.1.1/dist/test_blas1.sh
new file mode 100755
index 0000000..3e15c37
--- /dev/null
+++ b/jlapack-3.1.1/dist/test_blas1.sh
@@ -0,0 +1,3 @@
+#!/bin/sh
+
+java -classpath dblat1.jar:../f2jutil.jar:../blas.jar org.netlib.blas.testing.Dblat1
diff --git a/jlapack-3.1.1/dist/test_blas2.bat b/jlapack-3.1.1/dist/test_blas2.bat
new file mode 100644
index 0000000..94440f7
--- /dev/null
+++ b/jlapack-3.1.1/dist/test_blas2.bat
@@ -0,0 +1,2 @@
+
+java -classpath .\dblat2.jar;..\f2jutil.jar;..\blas.jar; org.netlib.blas.testing.Dblat2 < dblat2.in
diff --git a/jlapack-3.1.1/dist/test_blas2.sh b/jlapack-3.1.1/dist/test_blas2.sh
new file mode 100755
index 0000000..e63dc2e
--- /dev/null
+++ b/jlapack-3.1.1/dist/test_blas2.sh
@@ -0,0 +1,3 @@
+#!/bin/sh
+
+java -classpath dblat2.jar:../f2jutil.jar:../blas.jar org.netlib.blas.testing.Dblat2 < dblat2.in
diff --git a/jlapack-3.1.1/dist/test_blas3.bat b/jlapack-3.1.1/dist/test_blas3.bat
new file mode 100644
index 0000000..d5f3ef7
--- /dev/null
+++ b/jlapack-3.1.1/dist/test_blas3.bat
@@ -0,0 +1,2 @@
+
+java -classpath .\dblat3.jar;..\f2jutil.jar;..\blas.jar; org.netlib.blas.testing.Dblat3 < dblat3.in
diff --git a/jlapack-3.1.1/dist/test_blas3.sh b/jlapack-3.1.1/dist/test_blas3.sh
new file mode 100755
index 0000000..ceaed2f
--- /dev/null
+++ b/jlapack-3.1.1/dist/test_blas3.sh
@@ -0,0 +1,3 @@
+#!/bin/sh
+
+java -classpath dblat3.jar:../f2jutil.jar:../blas.jar org.netlib.blas.testing.Dblat3 < dblat3.in
diff --git a/jlapack-3.1.1/dist/test_eig.bat b/jlapack-3.1.1/dist/test_eig.bat
new file mode 100644
index 0000000..fa1d128
--- /dev/null
+++ b/jlapack-3.1.1/dist/test_eig.bat
@@ -0,0 +1,17 @@
+
+java -classpath .\eigtest.jar;.\matgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar; org.netlib.lapack.testing.eig.Dchkee < dbak.in
+java -classpath .\eigtest.jar;.\matgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar; org.netlib.lapack.testing.eig.Dchkee < dec.in
+java -classpath .\eigtest.jar;.\matgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar; org.netlib.lapack.testing.eig.Dchkee < dgbak.in
+java -classpath .\eigtest.jar;.\matgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar; org.netlib.lapack.testing.eig.Dchkee < dgg.in
+java -classpath .\eigtest.jar;.\matgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar; org.netlib.lapack.testing.eig.Dchkee < dsg.in
+java -classpath .\eigtest.jar;.\matgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar; org.netlib.lapack.testing.eig.Dchkee < gqr.in
+java -classpath .\eigtest.jar;.\matgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar; org.netlib.lapack.testing.eig.Dchkee < lse.in
+java -classpath .\eigtest.jar;.\matgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar; org.netlib.lapack.testing.eig.Dchkee < sep.in
+java -classpath .\eigtest.jar;.\matgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar; org.netlib.lapack.testing.eig.Dchkee < dbal.in
+java -classpath .\eigtest.jar;.\matgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar; org.netlib.lapack.testing.eig.Dchkee < ded.in
+java -classpath .\eigtest.jar;.\matgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar; org.netlib.lapack.testing.eig.Dchkee < dgbal.in
+java -classpath .\eigtest.jar;.\matgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar; org.netlib.lapack.testing.eig.Dchkee < dsb.in
+java -classpath .\eigtest.jar;.\matgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar; org.netlib.lapack.testing.eig.Dchkee < glm.in
+java -classpath .\eigtest.jar;.\matgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar; org.netlib.lapack.testing.eig.Dchkee < gsv.in
+java -classpath .\eigtest.jar;.\matgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar; org.netlib.lapack.testing.eig.Dchkee < nep.in
+java -classpath .\eigtest.jar;.\matgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar; org.netlib.lapack.testing.eig.Dchkee < svd.in
diff --git a/jlapack-3.1.1/dist/test_eig.sh b/jlapack-3.1.1/dist/test_eig.sh
new file mode 100755
index 0000000..47b22b0
--- /dev/null
+++ b/jlapack-3.1.1/dist/test_eig.sh
@@ -0,0 +1,19 @@
+#!/bin/sh
+
+java -classpath eigtest.jar:matgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.testing.eig.Dchkee < dbak.in
+java -classpath eigtest.jar:matgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.testing.eig.Dchkee < dec.in
+java -classpath eigtest.jar:matgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.testing.eig.Dchkee < dgbak.in
+java -classpath eigtest.jar:matgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.testing.eig.Dchkee < dgg.in
+java -classpath eigtest.jar:matgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.testing.eig.Dchkee < dsg.in
+java -classpath eigtest.jar:matgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.testing.eig.Dchkee < gqr.in
+java -classpath eigtest.jar:matgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.testing.eig.Dchkee < lse.in
+java -classpath eigtest.jar:matgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.testing.eig.Dchkee < sep.in
+java -classpath eigtest.jar:matgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.testing.eig.Dchkee < dbal.in
+java -classpath eigtest.jar:matgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.testing.eig.Dchkee < ded.in
+java -classpath eigtest.jar:matgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.testing.eig.Dchkee < dgbal.in
+java -classpath eigtest.jar:matgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.testing.eig.Dchkee < dsb.in
+java -classpath eigtest.jar:matgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.testing.eig.Dchkee < glm.in
+java -classpath eigtest.jar:matgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.testing.eig.Dchkee < gsv.in
+java -classpath eigtest.jar:matgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.testing.eig.Dchkee < nep.in
+java -classpath eigtest.jar:matgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.testing.eig.Dchkee < svd.in
+
diff --git a/jlapack-3.1.1/dist/test_lin.bat b/jlapack-3.1.1/dist/test_lin.bat
new file mode 100644
index 0000000..7f089ca
--- /dev/null
+++ b/jlapack-3.1.1/dist/test_lin.bat
@@ -0,0 +1,2 @@
+
+java -classpath .\lintest.jar;.\matgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar; org.netlib.lapack.testing.lin.Dchkaa < dtest.in
diff --git a/jlapack-3.1.1/dist/test_lin.sh b/jlapack-3.1.1/dist/test_lin.sh
new file mode 100755
index 0000000..9c60520
--- /dev/null
+++ b/jlapack-3.1.1/dist/test_lin.sh
@@ -0,0 +1,3 @@
+#!/bin/sh
+
+java -classpath lintest.jar:matgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.testing.lin.Dchkaa < dtest.in
diff --git a/jlapack-3.1.1/dist/test_sblas1.bat b/jlapack-3.1.1/dist/test_sblas1.bat
new file mode 100644
index 0000000..8b561cd
--- /dev/null
+++ b/jlapack-3.1.1/dist/test_sblas1.bat
@@ -0,0 +1,3 @@
+
+
+java -classpath .\sblat1.jar;..\f2jutil.jar;..\blas.jar; org.netlib.blas.testing.Sblat1
diff --git a/jlapack-3.1.1/dist/test_sblas1.sh b/jlapack-3.1.1/dist/test_sblas1.sh
new file mode 100755
index 0000000..773ef65
--- /dev/null
+++ b/jlapack-3.1.1/dist/test_sblas1.sh
@@ -0,0 +1,3 @@
+#!/bin/sh
+
+java -classpath sblat1.jar:../f2jutil.jar:../blas.jar org.netlib.blas.testing.Sblat1
diff --git a/jlapack-3.1.1/dist/test_sblas2.bat b/jlapack-3.1.1/dist/test_sblas2.bat
new file mode 100644
index 0000000..d9795ae
--- /dev/null
+++ b/jlapack-3.1.1/dist/test_sblas2.bat
@@ -0,0 +1,2 @@
+
+java -classpath .\sblat2.jar;..\f2jutil.jar;..\blas.jar; org.netlib.blas.testing.Sblat2 < sblat2.in
diff --git a/jlapack-3.1.1/dist/test_sblas2.sh b/jlapack-3.1.1/dist/test_sblas2.sh
new file mode 100755
index 0000000..747d31b
--- /dev/null
+++ b/jlapack-3.1.1/dist/test_sblas2.sh
@@ -0,0 +1,3 @@
+#!/bin/sh
+
+java -classpath sblat2.jar:../f2jutil.jar:../blas.jar org.netlib.blas.testing.Sblat2 < sblat2.in
diff --git a/jlapack-3.1.1/dist/test_sblas3.bat b/jlapack-3.1.1/dist/test_sblas3.bat
new file mode 100644
index 0000000..d56aae9
--- /dev/null
+++ b/jlapack-3.1.1/dist/test_sblas3.bat
@@ -0,0 +1,2 @@
+
+java -classpath .\sblat3.jar;..\f2jutil.jar;..\blas.jar; org.netlib.blas.testing.Sblat3 < sblat3.in
diff --git a/jlapack-3.1.1/dist/test_sblas3.sh b/jlapack-3.1.1/dist/test_sblas3.sh
new file mode 100755
index 0000000..8ed9b4f
--- /dev/null
+++ b/jlapack-3.1.1/dist/test_sblas3.sh
@@ -0,0 +1,3 @@
+#!/bin/sh
+
+java -classpath sblat3.jar:../f2jutil.jar:../blas.jar org.netlib.blas.testing.Sblat3 < sblat3.in
diff --git a/jlapack-3.1.1/dist/test_seig.bat b/jlapack-3.1.1/dist/test_seig.bat
new file mode 100644
index 0000000..cd9c085
--- /dev/null
+++ b/jlapack-3.1.1/dist/test_seig.bat
@@ -0,0 +1,21 @@
+
+
+
+java -classpath .\seigtest.jar;.\smatgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar; org.netlib.lapack.testing.eig.Schkee < glm.in
+java -classpath .\seigtest.jar;.\smatgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar; org.netlib.lapack.testing.eig.Schkee < lse.in
+java -classpath .\seigtest.jar;.\smatgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar; org.netlib.lapack.testing.eig.Schkee < sbal.in
+java -classpath .\seigtest.jar;.\smatgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar; org.netlib.lapack.testing.eig.Schkee < sed.in
+java -classpath .\seigtest.jar;.\smatgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar; org.netlib.lapack.testing.eig.Schkee < sgbal.in
+java -classpath .\seigtest.jar;.\smatgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar; org.netlib.lapack.testing.eig.Schkee < ssb.in
+java -classpath .\seigtest.jar;.\smatgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar; org.netlib.lapack.testing.eig.Schkee < gqr.in
+java -classpath .\seigtest.jar;.\smatgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar; org.netlib.lapack.testing.eig.Schkee < nep.in
+java -classpath .\seigtest.jar;.\smatgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar; org.netlib.lapack.testing.eig.Schkee < sbb.in
+java -classpath .\seigtest.jar;.\smatgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar; org.netlib.lapack.testing.eig.Schkee < sep.in
+java -classpath .\seigtest.jar;.\smatgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar; org.netlib.lapack.testing.eig.Schkee < sgd.in
+java -classpath .\seigtest.jar;.\smatgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar; org.netlib.lapack.testing.eig.Schkee < ssg.in
+java -classpath .\seigtest.jar;.\smatgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar; org.netlib.lapack.testing.eig.Schkee < gsv.in
+java -classpath .\seigtest.jar;.\smatgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar; org.netlib.lapack.testing.eig.Schkee < sbak.in
+java -classpath .\seigtest.jar;.\smatgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar; org.netlib.lapack.testing.eig.Schkee < sec.in
+java -classpath .\seigtest.jar;.\smatgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar; org.netlib.lapack.testing.eig.Schkee < sgbak.in
+java -classpath .\seigtest.jar;.\smatgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar; org.netlib.lapack.testing.eig.Schkee < sgg.in
+java -classpath .\seigtest.jar;.\smatgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar; org.netlib.lapack.testing.eig.Schkee < svd.in
diff --git a/jlapack-3.1.1/dist/test_seig.sh b/jlapack-3.1.1/dist/test_seig.sh
new file mode 100755
index 0000000..0cd37dc
--- /dev/null
+++ b/jlapack-3.1.1/dist/test_seig.sh
@@ -0,0 +1,20 @@
+#!/bin/sh
+
+java -classpath seigtest.jar:smatgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.testing.eig.Schkee < glm.in
+java -classpath seigtest.jar:smatgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.testing.eig.Schkee < lse.in
+java -classpath seigtest.jar:smatgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.testing.eig.Schkee < sbal.in
+java -classpath seigtest.jar:smatgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.testing.eig.Schkee < sed.in
+java -classpath seigtest.jar:smatgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.testing.eig.Schkee < sgbal.in
+java -classpath seigtest.jar:smatgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.testing.eig.Schkee < ssb.in
+java -classpath seigtest.jar:smatgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.testing.eig.Schkee < gqr.in
+java -classpath seigtest.jar:smatgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.testing.eig.Schkee < nep.in
+java -classpath seigtest.jar:smatgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.testing.eig.Schkee < sbb.in
+java -classpath seigtest.jar:smatgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.testing.eig.Schkee < sep.in
+java -classpath seigtest.jar:smatgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.testing.eig.Schkee < sgd.in
+java -classpath seigtest.jar:smatgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.testing.eig.Schkee < ssg.in
+java -classpath seigtest.jar:smatgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.testing.eig.Schkee < gsv.in
+java -classpath seigtest.jar:smatgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.testing.eig.Schkee < sbak.in
+java -classpath seigtest.jar:smatgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.testing.eig.Schkee < sec.in
+java -classpath seigtest.jar:smatgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.testing.eig.Schkee < sgbak.in
+java -classpath seigtest.jar:smatgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.testing.eig.Schkee < sgg.in
+java -classpath seigtest.jar:smatgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.testing.eig.Schkee < svd.in
diff --git a/jlapack-3.1.1/dist/test_slin.bat b/jlapack-3.1.1/dist/test_slin.bat
new file mode 100644
index 0000000..716fe0f
--- /dev/null
+++ b/jlapack-3.1.1/dist/test_slin.bat
@@ -0,0 +1,2 @@
+
+java -classpath .\slintest.jar;.\smatgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar; org.netlib.lapack.testing.lin.Schkaa < stest.in
diff --git a/jlapack-3.1.1/dist/test_slin.sh b/jlapack-3.1.1/dist/test_slin.sh
new file mode 100755
index 0000000..5348d10
--- /dev/null
+++ b/jlapack-3.1.1/dist/test_slin.sh
@@ -0,0 +1,3 @@
+#!/bin/sh
+
+java -classpath slintest.jar:smatgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.testing.lin.Schkaa < stest.in
diff --git a/jlapack-3.1.1/dist_timing/README b/jlapack-3.1.1/dist_timing/README
new file mode 100644
index 0000000..1dcea8f
--- /dev/null
+++ b/jlapack-3.1.1/dist_timing/README
@@ -0,0 +1,112 @@
+JLAPACK timing routines README
+May 31, 2007
+
+----
+
+NOTE: the timing routines weren't included in LAPACK 3.1. These are the timing
+ routines from 3.0. I'm not sure if they work with the 3.1 library, but I'm
+ keeping the files here as placeholders to drop in the timing code if it becomes
+ available.
+
+----
+
+This directory should contain:
+ README - this file
+
+ Timing Scripts for Double Precision:
+ time_eig_small.sh - Timer for LAPACK linear equation routines (small matrix sizes)
+ time_eig_small.bat - Windows version of the previous script
+ time_eig_large.sh - Timer for LAPACK linear equation routines (large matrix sizes)
+ time_eig_large.bat - Windows version of the previous script
+ time_lin_small.sh - Timer for LAPACK eigenvalue routines (small matrix sizes)
+ time_lin_small.bat - Windows version of the previous script
+ time_lin_large.sh - Timer for LAPACK eigenvalue routines (large matrix sizes)
+ time_lin_large.bat - Windows version of the previous script
+
+ Timing Scripts for Single Precision:
+ time_seig_small.sh - Timer for LAPACK linear equation routines (small matrix sizes)
+ time_seig_small.bat - Windows version of the previous script
+ time_seig_large.sh - Timer for LAPACK linear equation routines (large matrix sizes)
+ time_seig_large.bat - Windows version of the previous script
+ time_slin_small.sh - Timer for LAPACK eigenvalue routines (small matrix sizes)
+ time_slin_small.bat - Windows version of the previous script
+ time_slin_large.sh - Timer for LAPACK eigenvalue routines (large matrix sizes)
+ time_slin_large.bat - Windows version of the previous script
+
+ Jar Files for Double Precision:
+ eigtime.jar - LAPACK eigenvalue timing code
+ lintime.jar - LAPACK linear equation timing code
+ matgen.jar - support routines for the timers
+
+ Jar Files for Single Precision:
+ seigtime.jar - LAPACK eigenvalue timing code
+ slintime.jar - LAPACK linear equation timing code
+ smatgen.jar - support routines for the timers
+
+ Double Precision Linear Equation Timer Input Files (small sizes):
+ dband.in
+ dblasa.in
+ dblasb.in
+ dblasc.in
+ dtime.in
+ dtime2.in
+
+ Single Precision Linear Equation Timer Input Files (small sizes):
+ sband.in
+ sblasa.in
+ sblasb.in
+ sblasc.in
+ stime.in
+ stime2.in
+
+ Double Precision Eigenvalue Timer Input Files (small sizes):
+ dgeptim.in
+ dseptim.in
+ dneptim.in
+ dsvdtim.in
+
+ Single Precision Eigenvalue Timer Input Files (small sizes):
+ sgeptim.in
+ sseptim.in
+ sneptim.in
+ ssvdtim.in
+
+ The following input files for large matrix sizes are located in the
+ subdirectory named "input_files_large":
+
+ Double Precision Linear Equation Timer Input Files (large sizes):
+ DBAND.in
+ DBLASB.in
+ DTIME.in
+ DBLASA.in
+ DBLASC.in
+ DTIME2.in
+
+ Single Precision Linear Equation Timer Input Files (large sizes):
+ SBAND.in
+ SBLASA.in
+ SBLASB.in
+ SBLASC.in
+ STIME.in
+ STIME2.in
+
+ Double Precision Eigenvalue Timer Input Files (large sizes):
+ DGEPTIM.in
+ DSEPTIM.in
+ DNEPTIM.in
+ DSVDTIM.in
+
+ Single Precision Eigenvalue Timer Input Files (large sizes):
+ SGEPTIM.in
+ SSEPTIM.in
+ SNEPTIM.in
+ SSVDTIM.in
+
+
+To run the timers, simply execute the appropriate script, which
+depends on the operating system you are running.
+
+Some of the output is not exactly as the Fortran versions
+would be (e.g. some arrays are printed as "NULL", but that is
+only a limitation of the f2j I/O handling), however this
+does not affect the running of the timers.
diff --git a/jlapack-3.1.1/dist_timing/time_eig_large.bat b/jlapack-3.1.1/dist_timing/time_eig_large.bat
new file mode 100644
index 0000000..1cb2df0
--- /dev/null
+++ b/jlapack-3.1.1/dist_timing/time_eig_large.bat
@@ -0,0 +1,4 @@
+java -Xmx500M -classpath eigtime.jar;matgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar org.netlib.lapack.timing.eig.Dtimee < input_files_large\DGEPTIM.in
+java -Xmx500M -classpath eigtime.jar;matgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar org.netlib.lapack.timing.eig.Dtimee < input_files_large\DNEPTIM.in
+java -Xmx500M -classpath eigtime.jar;matgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar org.netlib.lapack.timing.eig.Dtimee < input_files_large\DSEPTIM.in
+java -Xmx500M -classpath eigtime.jar;matgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar org.netlib.lapack.timing.eig.Dtimee < input_files_large\DSVDTIM.in
diff --git a/jlapack-3.1.1/dist_timing/time_eig_large.sh b/jlapack-3.1.1/dist_timing/time_eig_large.sh
new file mode 100755
index 0000000..4e5785f
--- /dev/null
+++ b/jlapack-3.1.1/dist_timing/time_eig_large.sh
@@ -0,0 +1,6 @@
+#!/bin/sh
+
+java -Xmx500M -classpath eigtime.jar:matgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.timing.eig.Dtimee < input_files_large/DGEPTIM.in
+java -Xmx500M -classpath eigtime.jar:matgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.timing.eig.Dtimee < input_files_large/DNEPTIM.in
+java -Xmx500M -classpath eigtime.jar:matgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.timing.eig.Dtimee < input_files_large/DSEPTIM.in
+java -Xmx500M -classpath eigtime.jar:matgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.timing.eig.Dtimee < input_files_large/DSVDTIM.in
diff --git a/jlapack-3.1.1/dist_timing/time_eig_small.bat b/jlapack-3.1.1/dist_timing/time_eig_small.bat
new file mode 100644
index 0000000..b8e037f
--- /dev/null
+++ b/jlapack-3.1.1/dist_timing/time_eig_small.bat
@@ -0,0 +1,4 @@
+java -Xmx500M -classpath eigtime.jar;matgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar org.netlib.lapack.timing.eig.Dtimee < dgeptim.in
+java -Xmx500M -classpath eigtime.jar;matgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar org.netlib.lapack.timing.eig.Dtimee < dneptim.in
+java -Xmx500M -classpath eigtime.jar;matgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar org.netlib.lapack.timing.eig.Dtimee < dseptim.in
+java -Xmx500M -classpath eigtime.jar;matgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar org.netlib.lapack.timing.eig.Dtimee < dsvdtim.in
diff --git a/jlapack-3.1.1/dist_timing/time_eig_small.sh b/jlapack-3.1.1/dist_timing/time_eig_small.sh
new file mode 100755
index 0000000..d21f9cb
--- /dev/null
+++ b/jlapack-3.1.1/dist_timing/time_eig_small.sh
@@ -0,0 +1,6 @@
+#!/bin/sh
+
+java -Xmx500M -classpath eigtime.jar:matgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.timing.eig.Dtimee < dgeptim.in
+java -Xmx500M -classpath eigtime.jar:matgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.timing.eig.Dtimee < dneptim.in
+java -Xmx500M -classpath eigtime.jar:matgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.timing.eig.Dtimee < dseptim.in
+java -Xmx500M -classpath eigtime.jar:matgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.timing.eig.Dtimee < dsvdtim.in
diff --git a/jlapack-3.1.1/dist_timing/time_lin_large.bat b/jlapack-3.1.1/dist_timing/time_lin_large.bat
new file mode 100644
index 0000000..a3a1d33
--- /dev/null
+++ b/jlapack-3.1.1/dist_timing/time_lin_large.bat
@@ -0,0 +1,6 @@
+java -Xmx500M -classpath lintime.jar;matgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar org.netlib.lapack.timing.lin.Dtimaa < input_files_large\DBAND.in
+java -Xmx500M -classpath lintime.jar;matgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar org.netlib.lapack.timing.lin.Dtimaa < input_files_large\DBLASA.in
+java -Xmx500M -classpath lintime.jar;matgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar org.netlib.lapack.timing.lin.Dtimaa < input_files_large\DBLASB.in
+java -Xmx500M -classpath lintime.jar;matgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar org.netlib.lapack.timing.lin.Dtimaa < input_files_large\DBLASC.in
+java -Xmx500M -classpath lintime.jar;matgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar org.netlib.lapack.timing.lin.Dtimaa < input_files_large\DTIME.in
+java -Xmx500M -classpath lintime.jar;matgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar org.netlib.lapack.timing.lin.Dtimaa < input_files_large\DTIME2.in
diff --git a/jlapack-3.1.1/dist_timing/time_lin_large.sh b/jlapack-3.1.1/dist_timing/time_lin_large.sh
new file mode 100755
index 0000000..ad11cca
--- /dev/null
+++ b/jlapack-3.1.1/dist_timing/time_lin_large.sh
@@ -0,0 +1,8 @@
+#!/bin/sh
+
+java -Xmx500M -classpath lintime.jar:matgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.timing.lin.Dtimaa < input_files_large/DBAND.in
+java -Xmx500M -classpath lintime.jar:matgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.timing.lin.Dtimaa < input_files_large/DBLASA.in
+java -Xmx500M -classpath lintime.jar:matgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.timing.lin.Dtimaa < input_files_large/DBLASB.in
+java -Xmx500M -classpath lintime.jar:matgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.timing.lin.Dtimaa < input_files_large/DBLASC.in
+java -Xmx500M -classpath lintime.jar:matgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.timing.lin.Dtimaa < input_files_large/DTIME.in
+java -Xmx500M -classpath lintime.jar:matgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.timing.lin.Dtimaa < input_files_large/DTIME2.in
diff --git a/jlapack-3.1.1/dist_timing/time_lin_small.bat b/jlapack-3.1.1/dist_timing/time_lin_small.bat
new file mode 100644
index 0000000..d4306a7
--- /dev/null
+++ b/jlapack-3.1.1/dist_timing/time_lin_small.bat
@@ -0,0 +1,6 @@
+java -Xmx500M -classpath lintime.jar;matgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar org.netlib.lapack.timing.lin.Dtimaa < dband.in
+java -Xmx500M -classpath lintime.jar;matgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar org.netlib.lapack.timing.lin.Dtimaa < dblasa.in
+java -Xmx500M -classpath lintime.jar;matgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar org.netlib.lapack.timing.lin.Dtimaa < dblasb.in
+java -Xmx500M -classpath lintime.jar;matgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar org.netlib.lapack.timing.lin.Dtimaa < dblasc.in
+java -Xmx500M -classpath lintime.jar;matgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar org.netlib.lapack.timing.lin.Dtimaa < dtime.in
+java -Xmx500M -classpath lintime.jar;matgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar org.netlib.lapack.timing.lin.Dtimaa < dtime2.in
diff --git a/jlapack-3.1.1/dist_timing/time_lin_small.sh b/jlapack-3.1.1/dist_timing/time_lin_small.sh
new file mode 100755
index 0000000..6913ec5
--- /dev/null
+++ b/jlapack-3.1.1/dist_timing/time_lin_small.sh
@@ -0,0 +1,8 @@
+#!/bin/sh
+
+java -Xmx500M -classpath lintime.jar:matgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.timing.lin.Dtimaa < dband.in
+java -Xmx500M -classpath lintime.jar:matgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.timing.lin.Dtimaa < dblasa.in
+java -Xmx500M -classpath lintime.jar:matgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.timing.lin.Dtimaa < dblasb.in
+java -Xmx500M -classpath lintime.jar:matgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.timing.lin.Dtimaa < dblasc.in
+java -Xmx500M -classpath lintime.jar:matgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.timing.lin.Dtimaa < dtime.in
+java -Xmx500M -classpath lintime.jar:matgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.timing.lin.Dtimaa < dtime2.in
diff --git a/jlapack-3.1.1/dist_timing/time_seig_large.bat b/jlapack-3.1.1/dist_timing/time_seig_large.bat
new file mode 100644
index 0000000..d496622
--- /dev/null
+++ b/jlapack-3.1.1/dist_timing/time_seig_large.bat
@@ -0,0 +1,4 @@
+java -Xmx500M -classpath seigtime.jar;smatgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar org.netlib.lapack.timing.eig.Stimee < input_files_large\SGEPTIM.in
+java -Xmx500M -classpath seigtime.jar;smatgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar org.netlib.lapack.timing.eig.Stimee < input_files_large\SNEPTIM.in
+java -Xmx500M -classpath seigtime.jar;smatgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar org.netlib.lapack.timing.eig.Stimee < input_files_large\SSEPTIM.in
+java -Xmx500M -classpath seigtime.jar;smatgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar org.netlib.lapack.timing.eig.Stimee < input_files_large\SSVDTIM.in
diff --git a/jlapack-3.1.1/dist_timing/time_seig_large.sh b/jlapack-3.1.1/dist_timing/time_seig_large.sh
new file mode 100755
index 0000000..7778148
--- /dev/null
+++ b/jlapack-3.1.1/dist_timing/time_seig_large.sh
@@ -0,0 +1,6 @@
+#!/bin/sh
+
+java -Xmx500M -classpath seigtime.jar:smatgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.timing.eig.Stimee < input_files_large/SGEPTIM.in
+java -Xmx500M -classpath seigtime.jar:smatgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.timing.eig.Stimee < input_files_large/SNEPTIM.in
+java -Xmx500M -classpath seigtime.jar:smatgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.timing.eig.Stimee < input_files_large/SSEPTIM.in
+java -Xmx500M -classpath seigtime.jar:smatgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.timing.eig.Stimee < input_files_large/SSVDTIM.in
diff --git a/jlapack-3.1.1/dist_timing/time_seig_small.bat b/jlapack-3.1.1/dist_timing/time_seig_small.bat
new file mode 100644
index 0000000..c3fb485
--- /dev/null
+++ b/jlapack-3.1.1/dist_timing/time_seig_small.bat
@@ -0,0 +1,4 @@
+java -Xmx500M -classpath seigtime.jar;smatgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar org.netlib.lapack.timing.eig.Stimee < sgeptim.in
+java -Xmx500M -classpath seigtime.jar;smatgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar org.netlib.lapack.timing.eig.Stimee < sneptim.in
+java -Xmx500M -classpath seigtime.jar;smatgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar org.netlib.lapack.timing.eig.Stimee < sseptim.in
+java -Xmx500M -classpath seigtime.jar;smatgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar org.netlib.lapack.timing.eig.Stimee < ssvdtim.in
diff --git a/jlapack-3.1.1/dist_timing/time_seig_small.sh b/jlapack-3.1.1/dist_timing/time_seig_small.sh
new file mode 100755
index 0000000..5b0b22a
--- /dev/null
+++ b/jlapack-3.1.1/dist_timing/time_seig_small.sh
@@ -0,0 +1,6 @@
+#!/bin/sh
+
+java -Xmx500M -classpath seigtime.jar:smatgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.timing.eig.Stimee < sgeptim.in
+java -Xmx500M -classpath seigtime.jar:smatgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.timing.eig.Stimee < sneptim.in
+java -Xmx500M -classpath seigtime.jar:smatgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.timing.eig.Stimee < sseptim.in
+java -Xmx500M -classpath seigtime.jar:smatgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.timing.eig.Stimee < ssvdtim.in
diff --git a/jlapack-3.1.1/dist_timing/time_slin_large.bat b/jlapack-3.1.1/dist_timing/time_slin_large.bat
new file mode 100644
index 0000000..d58e2ac
--- /dev/null
+++ b/jlapack-3.1.1/dist_timing/time_slin_large.bat
@@ -0,0 +1,6 @@
+java -Xmx500M -classpath slintime.jar;smatgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar org.netlib.lapack.timing.lin.Stimaa < input_files_large\SBAND.in
+java -Xmx500M -classpath slintime.jar;smatgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar org.netlib.lapack.timing.lin.Stimaa < input_files_large\SBLASA.in
+java -Xmx500M -classpath slintime.jar;smatgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar org.netlib.lapack.timing.lin.Stimaa < input_files_large\SBLASB.in
+java -Xmx500M -classpath slintime.jar;smatgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar org.netlib.lapack.timing.lin.Stimaa < input_files_large\SBLASC.in
+java -Xmx500M -classpath slintime.jar;smatgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar org.netlib.lapack.timing.lin.Stimaa < input_files_large\STIME.in
+java -Xmx500M -classpath slintime.jar;smatgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar org.netlib.lapack.timing.lin.Stimaa < input_files_large\STIME2.in
diff --git a/jlapack-3.1.1/dist_timing/time_slin_large.sh b/jlapack-3.1.1/dist_timing/time_slin_large.sh
new file mode 100755
index 0000000..ea5dfeb
--- /dev/null
+++ b/jlapack-3.1.1/dist_timing/time_slin_large.sh
@@ -0,0 +1,8 @@
+#!/bin/sh
+
+java -Xmx500M -classpath slintime.jar:smatgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.timing.lin.Stimaa < input_files_large/SBAND.in
+java -Xmx500M -classpath slintime.jar:smatgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.timing.lin.Stimaa < input_files_large/SBLASA.in
+java -Xmx500M -classpath slintime.jar:smatgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.timing.lin.Stimaa < input_files_large/SBLASB.in
+java -Xmx500M -classpath slintime.jar:smatgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.timing.lin.Stimaa < input_files_large/SBLASC.in
+java -Xmx500M -classpath slintime.jar:smatgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.timing.lin.Stimaa < input_files_large/STIME.in
+java -Xmx500M -classpath slintime.jar:smatgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.timing.lin.Stimaa < input_files_large/STIME2.in
diff --git a/jlapack-3.1.1/dist_timing/time_slin_small.bat b/jlapack-3.1.1/dist_timing/time_slin_small.bat
new file mode 100644
index 0000000..241b7e9
--- /dev/null
+++ b/jlapack-3.1.1/dist_timing/time_slin_small.bat
@@ -0,0 +1,6 @@
+java -Xmx500M -classpath slintime.jar;smatgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar org.netlib.lapack.timing.lin.Stimaa < sband.in
+java -Xmx500M -classpath slintime.jar;smatgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar org.netlib.lapack.timing.lin.Stimaa < sblasa.in
+java -Xmx500M -classpath slintime.jar;smatgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar org.netlib.lapack.timing.lin.Stimaa < sblasb.in
+java -Xmx500M -classpath slintime.jar;smatgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar org.netlib.lapack.timing.lin.Stimaa < sblasc.in
+java -Xmx500M -classpath slintime.jar;smatgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar org.netlib.lapack.timing.lin.Stimaa < stime.in
+java -Xmx500M -classpath slintime.jar;smatgen.jar;..\f2jutil.jar;..\blas.jar;..\lapack.jar org.netlib.lapack.timing.lin.Stimaa < stime2.in
diff --git a/jlapack-3.1.1/dist_timing/time_slin_small.sh b/jlapack-3.1.1/dist_timing/time_slin_small.sh
new file mode 100755
index 0000000..e5fce4b
--- /dev/null
+++ b/jlapack-3.1.1/dist_timing/time_slin_small.sh
@@ -0,0 +1,8 @@
+#!/bin/sh
+
+java -Xmx500M -classpath slintime.jar:smatgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.timing.lin.Stimaa < sband.in
+java -Xmx500M -classpath slintime.jar:smatgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.timing.lin.Stimaa < sblasa.in
+java -Xmx500M -classpath slintime.jar:smatgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.timing.lin.Stimaa < sblasb.in
+java -Xmx500M -classpath slintime.jar:smatgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.timing.lin.Stimaa < sblasc.in
+java -Xmx500M -classpath slintime.jar:smatgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.timing.lin.Stimaa < stime.in
+java -Xmx500M -classpath slintime.jar:smatgen.jar:../f2jutil.jar:../blas.jar:../lapack.jar org.netlib.lapack.timing.lin.Stimaa < stime2.in
diff --git a/jlapack-3.1.1/examples/DdotTest.java b/jlapack-3.1.1/examples/DdotTest.java
new file mode 100644
index 0000000..658cf99
--- /dev/null
+++ b/jlapack-3.1.1/examples/DdotTest.java
@@ -0,0 +1,28 @@
+import org.netlib.util.*;
+import org.netlib.blas.Ddot;
+
+/**
+ * DdotTest - example of calling the Java version of Ddot.
+ *
+ * To compile and run:
+ *
+ * bambam> javac -classpath .:f2jutil.jar:blas.jar DdotTest.java
+ * bambam> java -classpath .:f2jutil.jar:blas.jar DdotTest
+ * Answer = 36.3
+ *
+ **/
+
+public class DdotTest {
+ public static void main(String [] args) {
+ double [] dx = {1.1, 2.2, 3.3, 4.4};
+ double [] dy = {1.1, 2.2, 3.3, 4.4};
+ int incx = 1;
+ int incy = 1;
+ int n = dx.length;
+ double answer;
+
+ answer = Ddot.ddot(n,dx,0,incx,dy,0,incy);
+
+ System.out.println("Answer = " + answer);
+ }
+}
diff --git a/jlapack-3.1.1/examples/DgesvdTest.java b/jlapack-3.1.1/examples/DgesvdTest.java
new file mode 100644
index 0000000..720dc76
--- /dev/null
+++ b/jlapack-3.1.1/examples/DgesvdTest.java
@@ -0,0 +1,22 @@
+import org.netlib.util.*;
+import org.netlib.lapack.Dgesvd;
+
+public class DgesvdTest {
+
+ public static void main(String[] args) {
+ int M = 5;
+ int N = 3;
+ double[]m = {18.91, 14.91, -6.15, -18.15, 27.5, -1.59, -1.59, -2.25, -1.59, -2.25, -1.59, 1.59, 0.0, 1.59, 0.0};
+
+ double[]s = new double[m.length];
+ double[]u = new double[M*M];
+ double[]vt = new double[N*N];
+ double[]work = new double[Math.max(3*Math.min(M,N)+Math.max(M,N),5*Math.min(M,N))];
+ org.netlib.util.intW info = new org.netlib.util.intW(2);
+
+ Dgesvd.dgesvd("A","A",M,N,m, 0,M,s, 0,u, 0,M,vt,
+ 0,N,work, 0,work.length,info);
+
+ System.out.println("info = " + info.val);
+ }
+}
diff --git a/jlapack-3.1.1/examples/DlaruvTest.java b/jlapack-3.1.1/examples/DlaruvTest.java
new file mode 100644
index 0000000..29562c1
--- /dev/null
+++ b/jlapack-3.1.1/examples/DlaruvTest.java
@@ -0,0 +1,30 @@
+import org.netlib.util.*;
+import org.netlib.lapack.Dlaruv;
+
+
+/**
+ * DlaruvTest - example of calling the Java version of Dlaruv (from LAPACK).
+ *
+ * To compile and run:
+ *
+ * bambam> javac -classpath .:f2jutil.jar:blas.jar:lapack.jar DlaruvTest.java
+ * bambam> java -classpath .:f2jutil.jar:blas.jar:lapack.jar:xerbla.jar DlaruvTest
+ * Answer =
+ * 0.5806943866373508 0.7878030027693832 0.22090042246633246 0.7438538655551419 0.2937111564915149 0.19260597967192794 0.46939556457146026 0.903349054003403 0.852466982480923 0.3357901748424048
+ *
+ **/
+
+public class DlaruvTest {
+ public static void main(String [] args) {
+ int [] iseed = {1998, 1999, 2000, 2001};
+ double []x = new double [10];
+ int n = x.length;
+
+ Dlaruv.dlaruv(iseed,0,n,x,0);
+
+ System.out.println("Answer = ");
+ for(int i = 0; i < x.length; i++)
+ System.out.print(x[i] + " ");
+ System.out.println();
+ }
+}
diff --git a/jlapack-3.1.1/examples/DstevrTest.java b/jlapack-3.1.1/examples/DstevrTest.java
new file mode 100644
index 0000000..9e3b6ca
--- /dev/null
+++ b/jlapack-3.1.1/examples/DstevrTest.java
@@ -0,0 +1,102 @@
+import java.lang.*;
+import org.netlib.util.*;
+import org.netlib.lapack.Dstevr;
+
+/**
+ * DstevrTest - example of calling DSTEVR (from LAPACK).
+ *
+ * To compile and run:
+ *
+ * # javac -classpath .:f2jutil.jar:blas.jar:lapack.jar DstevrTest.java
+ * # java -classpath .:f2jutil.jar:blas.jar:lapack.jar DstevrTest
+ * Selected eigenvalues
+ * 3.547002474892091 8.657766989006001
+ * Selected eigenvectors
+ * 0.33875494698229236 0.049369992446919496
+ * 0.8628096883458374 0.3780638984074957
+ * -0.36480280022104183 0.8557817766452163
+ * 0.08788313002203395 -0.3496681903300259
+ **/
+
+public class DstevrTest {
+
+ public static void main (String [] args) {
+
+ double abstol= 0.0d;
+ double vl= 0.0d;
+ double vu= 0.0d;
+ int i= 0;
+ int ifail= 0;
+ int il= 0;
+ intW info= new intW(0);
+ int iu= 0;
+ int j= 0;
+ int liwopt= 0;
+ int lwopt= 0;
+ intW m= new intW(0);
+ int n= 0;
+ double [] d= new double[10];
+ double [] e= new double[10-1];
+ double [] w= new double[10];
+ double [] work= new double[200];
+ double [] z= new double[10 * 5];
+ int [] isuppz= new int[2*10];
+ int [] iwork= new int[100];
+
+ n = 4;
+ il = 2;
+ iu = 3;
+
+ d[0] = 1.0;
+ d[1] = 4.0;
+ d[2] = 9.0;
+ d[3] = 16.0;
+
+ e[0] = 1.0;
+ e[1] = 2.0;
+ e[2] = 3.0;
+
+ abstol = 0.0;
+
+ Dstevr.dstevr("Vectors", "Indices", n, d, 0, e, 0,
+ vl, vu, il, iu, abstol, m, w, 0, z, 0, 10, isuppz, 0,
+ work, 0, 200, iwork, 0, 100, info);
+
+ lwopt = (int)(work[0]);
+ liwopt = iwork[0];
+
+ if(info.val == 0) {
+ System.out.println("Selected eigenvalues");
+ System.out.print("");
+ for(j = 0; j < m.val; j++)
+ System.out.print(w[j] + " ");
+
+ System.out.println();
+
+ System.out.println("Selected eigenvectors");
+ for(i = 0; i < n; i++) {
+ for(j = 0; j < m.val; j++)
+ System.out.print(z[j*10+i] + " ");
+ System.out.println();
+ }
+
+ ifail = 0;
+ }
+ else
+ System.out.println("Failure in DSTEVR. INFO = " + info.val);
+
+ if(200 < lwopt) {
+ System.out.println();
+ System.out.println("Real workspace required = " + lwopt);
+ System.out.println("Real workspace provided = " + 200);
+ }
+
+ if (100 < liwopt) {
+ System.out.println();
+ System.out.println("Integer workspace required = " + liwopt);
+ System.out.println("Integer workspace provided = " + 100);
+ }
+
+ return;
+ }
+}
diff --git a/jlapack-3.1.1/examples/DsygvTest.java b/jlapack-3.1.1/examples/DsygvTest.java
new file mode 100644
index 0000000..7301686
--- /dev/null
+++ b/jlapack-3.1.1/examples/DsygvTest.java
@@ -0,0 +1,36 @@
+import org.netlib.util.*;
+import org.netlib.lapack.Dsygv;
+
+/**
+ * DsygvTest - example of calling the Java version of Dsygv (from LAPACK).
+ *
+ * To compile and run:
+ *
+ * # javac -classpath .:f2jutil.jar:blas.jar:lapack.jar DsygvTest.java
+ * # java -classpath .:f2jutil.jar:blas.jar:lapack.jar:xerbla.jar DsygvTest
+ * on return info = 0
+ *
+ **/
+
+public class DsygvTest {
+
+ public static void main(String[] args) {
+ int itype = 1;
+ String jobz = new String("V");
+ String uplo = new String("U");
+ int n = 3;
+ double []a = {1.0, 2.0, 4.0, 0.0, 3.0, 5.0, 0.0, 0.0, 6.0};
+ int lda = 3;
+ double []b = {2.5298, 0.6405, 0.2091, 0.3798, 2.7833, 0.6808, 0.4611, 0.5678, 2.7942};
+ int ldb = 3;
+ double []w = new double[n];
+ int lwork = 9;
+ double []work = new double[lwork];
+ org.netlib.util.intW info = new org.netlib.util.intW(0);
+
+ Dsygv.dsygv(itype, jobz, uplo, n, a, 0, lda, b, 0,
+ ldb, w, 0, work, 0, lwork, info);
+
+ System.out.println("on return info = " + info.val);
+ }
+}
diff --git a/jlapack-3.1.1/examples/Makefile b/jlapack-3.1.1/examples/Makefile
new file mode 100644
index 0000000..8ef5c38
--- /dev/null
+++ b/jlapack-3.1.1/examples/Makefile
@@ -0,0 +1,29 @@
+JAVAC=javac
+
+BLAS_CLASSPATH=.:../f2jutil.jar:../blas.jar
+SIMPLE_BLAS_CLASSPATH=$(BLAS_CLASSPATH):../blas_simple.jar
+LAPACK_CLASSPATH=$(BLAS_CLASSPATH):../lapack.jar:../xerbla.jar
+SIMPLE_LAPACK_CLASSPATH=$(LAPACK_CLASSPATH):../lapack_simple.jar
+
+all: DdotTest.class SimpleDdotTest.class DgesvdTest.class SimpleDgesvdTest.class \
+ DlaruvTest.class DsygvTest.class DstevrTest.class SimpleDsygvTest.class
+
+DdotTest.class: DdotTest.java
+ $(JAVAC) -classpath $(BLAS_CLASSPATH) DdotTest.java
+SimpleDdotTest.class: SimpleDdotTest.java
+ $(JAVAC) -classpath $(SIMPLE_BLAS_CLASSPATH) SimpleDdotTest.java
+DlaruvTest.class: DlaruvTest.java
+ $(JAVAC) -classpath $(LAPACK_CLASSPATH) DlaruvTest.java
+DsygvTest.class: DsygvTest.java
+ $(JAVAC) -classpath $(LAPACK_CLASSPATH) DsygvTest.java
+DstevrTest.class: DstevrTest.java
+ $(JAVAC) -classpath $(LAPACK_CLASSPATH) DstevrTest.java
+SimpleDsygvTest.class: SimpleDsygvTest.java
+ $(JAVAC) -classpath $(SIMPLE_LAPACK_CLASSPATH) SimpleDsygvTest.java
+DgesvdTest.class: DgesvdTest.java
+ $(JAVAC) -classpath $(LAPACK_CLASSPATH) DgesvdTest.java
+SimpleDgesvdTest.class: SimpleDgesvdTest.java
+ $(JAVAC) -classpath $(SIMPLE_LAPACK_CLASSPATH) SimpleDgesvdTest.java
+
+clean:
+ /bin/rm -f *.class
diff --git a/jlapack-3.1.1/examples/README b/jlapack-3.1.1/examples/README
new file mode 100644
index 0000000..66c7e7c
--- /dev/null
+++ b/jlapack-3.1.1/examples/README
@@ -0,0 +1,19 @@
+
+JLAPACK Examples
+----------------
+
+This directory contains some basic examples showing how to call JLAPACK
+routines. There is no error handling or anything fancy like that.
+Sometimes I don't even initialize the arrays. It's just to show how
+to arrange the calling sequence.
+
+ DdotTest.java - simple example of how to call a BLAS routine
+ SimpleDdotTest.java - example of calling a simplified interface from BLAS
+ DlaruvTest.java - simple example of how to call a LAPACK routine
+ DgesvdTest.java - another LAPACK example
+ DsygvTest.java - another LAPACK example
+ DstevrTest.java - another LAPACK example
+ SimpleDgesvdTest.java - example of calling a simplified interface from LAPACK
+ SimpleDsygvTest.java - example of calling a simplified interface from LAPACK
+
+To build the examples, just do "make" here (after building JLAPACK of course).
diff --git a/jlapack-3.1.1/examples/SimpleDdotTest.java b/jlapack-3.1.1/examples/SimpleDdotTest.java
new file mode 100644
index 0000000..a4ffee1
--- /dev/null
+++ b/jlapack-3.1.1/examples/SimpleDdotTest.java
@@ -0,0 +1,28 @@
+import org.netlib.util.*;
+import org.netlib.blas.DDOT;
+
+/**
+ * SimpleDdotTest - example of calling the simplified version of Ddot.
+ *
+ * To compile and run:
+ *
+ * bambam> javac -classpath .:f2jutil.jar:blas.jar:blas_simple.jar SimpleDdotTest.java
+ * bambam> java -classpath .:f2jutil.jar:blas.jar:blas_simple.jar SimpleDdotTest
+ * Answer = 36.3
+ *
+ **/
+
+public class SimpleDdotTest {
+ public static void main(String [] args) {
+ double [] dx = {1.1, 2.2, 3.3, 4.4};
+ double [] dy = {1.1, 2.2, 3.3, 4.4};
+ int incx = 1;
+ int incy = 1;
+ int n = dx.length;
+ double answer;
+
+ answer = DDOT.DDOT(n,dx,incx,dy,incy);
+
+ System.out.println("Answer = " + answer);
+ }
+}
diff --git a/jlapack-3.1.1/examples/SimpleDgesvdTest.java b/jlapack-3.1.1/examples/SimpleDgesvdTest.java
new file mode 100644
index 0000000..120dddc
--- /dev/null
+++ b/jlapack-3.1.1/examples/SimpleDgesvdTest.java
@@ -0,0 +1,27 @@
+import org.netlib.util.*;
+import org.netlib.lapack.DGESVD;
+
+public class SimpleDgesvdTest {
+
+ public static void main(String[] args) {
+ double[][] m = {
+ {18.91, -1.59, -1.59},
+ {14.91, -1.59, 1.59},
+ {-6.15, -2.25, 0},
+ {-18.15, -1.59, 1.59},
+ {27.5, -2.25, 0}};
+ int M = m.length;
+ int N = m[0].length;
+ double[]s = new double[m.length];
+ double[][]u = new double[M][M];
+ double[][]vt = new double[N][N];
+ double[]work = new double[Math.max(3*Math.min(M,N)+Math.max(M,N),5*Math.min(M,N))];
+ org.netlib.util.intW info = new org.netlib.util.intW(2);
+
+ DGESVD.DGESVD("A", "A", M, N, m, s, u, vt,
+ work, work.length, info);
+
+ System.out.println("info = " + info.val);
+ }
+
+}
diff --git a/jlapack-3.1.1/examples/SimpleDsygvTest.java b/jlapack-3.1.1/examples/SimpleDsygvTest.java
new file mode 100644
index 0000000..f367dce
--- /dev/null
+++ b/jlapack-3.1.1/examples/SimpleDsygvTest.java
@@ -0,0 +1,41 @@
+import org.netlib.util.*;
+import org.netlib.lapack.DSYGV;
+
+/**
+ * SimpleDsygvTest - example of calling the simplified version of DSYGV (from LAPACK).
+ *
+ * To compile and run:
+ *
+ * # javac -classpath .:f2jutil.jar:blas.jar:lapack.jar:lapack_simple.jar:xerbla.jar SimpleDsygvTest.java
+ * # java -classpath .:f2jutil.jar:blas.jar:lapack.jar:lapack_simple.jar:xerbla.jar SimpleDsygvTest
+ * on return info = 0
+ *
+ **/
+
+public class SimpleDsygvTest {
+
+ public static void main(String[] args) {
+ int itype = 1;
+ String jobz = new String("V");
+ String uplo = new String("U");
+ int n = 3;
+ double [][]a = {
+ {1.0, 2.0, 4.0},
+ {0.0, 3.0, 5.0},
+ {0.0, 0.0, 6.0}};
+ int lda = 3;
+ double [][]b = {
+ {2.5298, 0.6405, 0.2091},
+ {0.3798, 2.7833, 0.6808},
+ {0.4611, 0.5678, 2.7942}};
+ int ldb = 3;
+ double []w = new double[n];
+ int lwork = 9;
+ double []work = new double[lwork];
+ org.netlib.util.intW info = new org.netlib.util.intW(0);
+
+ DSYGV.DSYGV(itype, jobz, uplo, n, a, b, w, work, lwork, info);
+
+ System.out.println("on return info = " + info.val);
+ }
+}
diff --git a/jlapack-3.1.1/make.def b/jlapack-3.1.1/make.def
new file mode 100644
index 0000000..4250a84
--- /dev/null
+++ b/jlapack-3.1.1/make.def
@@ -0,0 +1,217 @@
+VERSION=jlapack-0.8
+
+F2J=f2java
+JAVA=java
+MORE_MEM_FLAG=-Xmx500M
+JAVAC=javac -source 1.4 -target 1.4
+JAVAB=javab
+JAR=jar
+# JAR=/usr/bin/jar
+ZIP=zip
+TAR=tar
+TARFLAGS=chvf
+GZIP=gzip
+VERIFY=de.fub.bytecode.verifier.Verifier
+JUSTICE=$$HOME/bin/JustIce.jar
+BCEL=$$HOME/bin/BCEL.jar
+
+# uncomment and set the following to override the user's JFLAGS setting
+# JFLAGS=
+
+# uncomment the following to force all locals to be emitted static
+# STATIC=-vs
+
+SRCDIR=src
+DISTDIR_TESTING=dist
+DISTDIR_TIMING=dist_timing
+OUTDIR=obj
+JAVASRC_OUTDIR=javasrc_obj
+UTIL_JAR=f2jutil.jar
+ERR_JAR=xerbla.jar
+BLAS_JAR=blas.jar
+SIMPLE_BLAS_JAR=blas_simple.jar
+LAPACK_JAR=lapack.jar
+SIMPLE_LAPACK_JAR=lapack_simple.jar
+LIBDIST_ZIP=$(VERSION).zip
+LIBDIST_TGZ=$(VERSION).tgz
+LIBDIST_STRICT_ZIP=$(VERSION)-strict.zip
+LIBDIST_STRICT_TGZ=$(VERSION)-strict.tgz
+TESTERS_DIST_ZIP=$(VERSION)-testers.zip
+TESTERS_DIST_TGZ=$(VERSION)-testers.tgz
+TIMERS_DIST_ZIP=$(VERSION)-timers.zip
+TIMERS_DIST_TGZ=$(VERSION)-timers.tgz
+JAVADOC_DIST_ZIP=$(VERSION)-javadoc.zip
+JAVADOC_DIST_TGZ=$(VERSION)-javadoc.tgz
+BLAS1TEST_JAR=dblat1.jar
+BLAS2TEST_JAR=dblat2.jar
+BLAS3TEST_JAR=dblat3.jar
+SBLAS1TEST_JAR=sblat1.jar
+SBLAS2TEST_JAR=sblat2.jar
+SBLAS3TEST_JAR=sblat3.jar
+EIGTEST_JAR=eigtest.jar
+SEIGTEST_JAR=seigtest.jar
+LINTEST_JAR=lintest.jar
+SLINTEST_JAR=slintest.jar
+MATGEN_JAR=matgen.jar
+SMATGEN_JAR=smatgen.jar
+EIGTIME_JAR=eigtime.jar
+SEIGTIME_JAR=seigtime.jar
+LINTIME_JAR=lintime.jar
+SLINTIME_JAR=slintime.jar
+
+BLAS1TEST_SH=test_blas1.sh
+BLAS2TEST_SH=test_blas2.sh
+BLAS3TEST_SH=test_blas3.sh
+SBLAS1TEST_SH=test_sblas1.sh
+SBLAS2TEST_SH=test_sblas2.sh
+SBLAS3TEST_SH=test_sblas3.sh
+LINTEST_SH=test_lin.sh
+SLINTEST_SH=test_slin.sh
+EIGTEST_SH=test_eig.sh
+SEIGTEST_SH=test_seig.sh
+BLAS1TEST_BAT=test_blas1.bat
+BLAS2TEST_BAT=test_blas2.bat
+BLAS3TEST_BAT=test_blas3.bat
+SBLAS1TEST_BAT=test_sblas1.bat
+SBLAS2TEST_BAT=test_sblas2.bat
+SBLAS3TEST_BAT=test_sblas3.bat
+LINTEST_BAT=test_lin.bat
+SLINTEST_BAT=test_slin.bat
+EIGTEST_BAT=test_eig.bat
+SEIGTEST_BAT=test_seig.bat
+
+UTIL_DIR=$(SRCDIR)/util
+UTIL_F2J_SRC_DIR=../util
+BLAS_DIR=$(SRCDIR)/blas
+ERR_DIR=$(SRCDIR)/error_reporting
+LAPACK_DIR=$(SRCDIR)/lapack
+TESTING_DIR=$(SRCDIR)/testing
+MATGEN_DIR=$(TESTING_DIR)/matgen
+SMATGEN_DIR=$(TESTING_DIR)/smatgen
+EIGTEST_DIR=$(TESTING_DIR)/eig
+SEIGTEST_DIR=$(TESTING_DIR)/seig
+LINTEST_DIR=$(TESTING_DIR)/lin
+SLINTEST_DIR=$(TESTING_DIR)/slin
+BLAS1TEST_DIR=$(TESTING_DIR)/blas1
+BLAS2TEST_DIR=$(TESTING_DIR)/blas2
+BLAS3TEST_DIR=$(TESTING_DIR)/blas3
+SBLAS1TEST_DIR=$(TESTING_DIR)/sblas1
+SBLAS2TEST_DIR=$(TESTING_DIR)/sblas2
+SBLAS3TEST_DIR=$(TESTING_DIR)/sblas3
+TIMING_DIR=$(SRCDIR)/timing
+SIMPLE_DIR=simple
+
+UTIL_OBJ=$(UTIL_DIR)/$(OUTDIR)
+MATGEN_OBJ=$(MATGEN_DIR)/$(OUTDIR)
+SMATGEN_OBJ=$(SMATGEN_DIR)/$(OUTDIR)
+BLAS_OBJ=$(BLAS_DIR)/$(OUTDIR)
+ERR_OBJ=$(ERR_DIR)/$(OUTDIR)
+LAPACK_OBJ=$(LAPACK_DIR)/$(OUTDIR)
+EIGTEST_OBJ=$(EIGTEST_DIR)/$(OUTDIR)
+SEIGTEST_OBJ=$(SEIGTEST_DIR)/$(OUTDIR)
+LINTEST_OBJ=$(LINTEST_DIR)/$(OUTDIR)
+SLINTEST_OBJ=$(SLINTEST_DIR)/$(OUTDIR)
+BLAS1TEST_OBJ=$(BLAS1TEST_DIR)/$(OUTDIR)
+BLAS2TEST_OBJ=$(BLAS2TEST_DIR)/$(OUTDIR)
+BLAS3TEST_OBJ=$(BLAS3TEST_DIR)/$(OUTDIR)
+SBLAS1TEST_OBJ=$(SBLAS1TEST_DIR)/$(OUTDIR)
+SBLAS2TEST_OBJ=$(SBLAS2TEST_DIR)/$(OUTDIR)
+SBLAS3TEST_OBJ=$(SBLAS3TEST_DIR)/$(OUTDIR)
+
+MATGEN_IDX=$(MATGEN_OBJ)/Matgen.f2j
+SMATGEN_IDX=$(SMATGEN_OBJ)/Smatgen.f2j
+BLAS_IDX=$(BLAS_OBJ)/Blas.f2j
+ERR_IDX=$(ERR_OBJ)/Err.f2j
+LAPACK_IDX=$(LAPACK_OBJ)/Lapack.f2j
+EIGTEST_IDX=$(EIGTEST_OBJ)/Eigtest.f2j
+SEIGTEST_IDX=$(SEIGTEST_OBJ)/Seigtest.f2j
+LINTEST_IDX=$(LINTEST_OBJ)/Lintest.f2j
+SLINTEST_IDX=$(SLINTEST_OBJ)/Slintest.f2j
+BLAS1TEST_IDX=$(BLAS1TEST_OBJ)/Dblat1.f2j
+BLAS2TEST_IDX=$(BLAS2TEST_OBJ)/Dblat2.f2j
+BLAS3TEST_IDX=$(BLAS3TEST_OBJ)/Dblat3.f2j
+SBLAS1TEST_IDX=$(SBLAS1TEST_OBJ)/Sblat1.f2j
+SBLAS2TEST_IDX=$(SBLAS2TEST_OBJ)/Sblat2.f2j
+SBLAS3TEST_IDX=$(SBLAS3TEST_OBJ)/Sblat3.f2j
+
+UTIL_PACKAGE=org.netlib.util
+UTIL_PDIR=org/netlib/util
+
+BLAS_PACKAGE=org.netlib.blas
+BLAS_PDIR=org/netlib/blas
+
+ERR_PACKAGE=org.netlib.err
+ERR_PDIR=org/netlib/err
+
+LAPACK_PACKAGE=org.netlib.lapack
+LAPACK_PDIR=org/netlib/lapack
+
+BLASTEST_PACKAGE=org.netlib.blas.testing
+BLASTEST_PDIR=org/netlib/blas/testing
+SBLASTEST_PACKAGE=org.netlib.blas.testing
+SBLASTEST_PDIR=org/netlib/blas/testing
+
+MATGEN_PACKAGE=org.netlib.lapack.testing.matgen
+MATGEN_PDIR=org/netlib/lapack/testing/matgen
+SMATGEN_PACKAGE=org.netlib.lapack.testing.matgen
+SMATGEN_PDIR=org/netlib/lapack/testing/matgen
+
+EIGTEST_PACKAGE=org.netlib.lapack.testing.eig
+EIGTEST_PDIR=org/netlib/lapack/testing/eig
+SEIGTEST_PACKAGE=org.netlib.lapack.testing.eig
+SEIGTEST_PDIR=org/netlib/lapack/testing/eig
+
+LINTEST_PACKAGE=org.netlib.lapack.testing.lin
+LINTEST_PDIR=org/netlib/lapack/testing/lin
+SLINTEST_PACKAGE=org.netlib.lapack.testing.lin
+SLINTEST_PDIR=org/netlib/lapack/testing/lin
+
+EIGTIME_DIR=$(TIMING_DIR)/eig
+SEIGTIME_DIR=$(TIMING_DIR)/seig
+LINTIME_DIR=$(TIMING_DIR)/lin
+SLINTIME_DIR=$(TIMING_DIR)/slin
+
+EIGTIME_OBJ=$(EIGTIME_DIR)/$(OUTDIR)
+SEIGTIME_OBJ=$(SEIGTIME_DIR)/$(OUTDIR)
+LINTIME_OBJ=$(LINTIME_DIR)/$(OUTDIR)
+SLINTIME_OBJ=$(SLINTIME_DIR)/$(OUTDIR)
+
+EIGTIME_IDX=$(EIGTIME_OBJ)/Eigtime.f2j
+SEIGTIME_IDX=$(SEIGTIME_OBJ)/Seigtime.f2j
+LINTIME_IDX=$(LINTIME_OBJ)/Lintime.f2j
+SLINTIME_IDX=$(SLINTIME_OBJ)/Slintime.f2j
+
+EIGTIME_PACKAGE=org.netlib.lapack.timing.eig
+EIGTIME_PDIR=org/netlib/lapack/timing/eig
+SEIGTIME_PACKAGE=org.netlib.lapack.timing.eig
+SEIGTIME_PDIR=org/netlib/lapack/timing/eig
+
+LINTIME_PACKAGE=org.netlib.lapack.timing.lin
+LINTIME_PDIR=org/netlib/lapack/timing/lin
+SLINTIME_PACKAGE=org.netlib.lapack.timing.lin
+SLINTIME_PDIR=org/netlib/lapack/timing/lin
+
+EIGSRC_PACKAGE=org.netlib.lapack.timing.eig.eigsrc
+EIGSRC_PDIR=org/netlib/lapack/timing/eig/eigsrc
+SEIGSRC_PACKAGE=org.netlib.lapack.timing.eig.eigsrc
+SEIGSRC_PDIR=org/netlib/lapack/timing/eig/eigsrc
+
+LINSRC_PACKAGE=org.netlib.lapack.timing.lin.linsrc
+LINSRC_PDIR=org/netlib/lapack/timing/lin/linsrc
+SLINSRC_PACKAGE=org.netlib.lapack.timing.lin.linsrc
+SLINSRC_PDIR=org/netlib/lapack/timing/lin/linsrc
+
+UTIL_CLASSES=$(OUTDIR)/$(UTIL_PDIR)/Dsign.class \
+ $(OUTDIR)/$(UTIL_PDIR)/Dummy.class \
+ $(OUTDIR)/$(UTIL_PDIR)/EasyIn.class \
+ $(OUTDIR)/$(UTIL_PDIR)/Etime.class \
+ $(OUTDIR)/$(UTIL_PDIR)/LAprint.class \
+ $(OUTDIR)/$(UTIL_PDIR)/MatConv.class \
+ $(OUTDIR)/$(UTIL_PDIR)/Second.class \
+ $(OUTDIR)/$(UTIL_PDIR)/StringW.class \
+ $(OUTDIR)/$(UTIL_PDIR)/Util.class \
+ $(OUTDIR)/$(UTIL_PDIR)/Xerbla.class \
+ $(OUTDIR)/$(UTIL_PDIR)/booleanW.class \
+ $(OUTDIR)/$(UTIL_PDIR)/doubleW.class \
+ $(OUTDIR)/$(UTIL_PDIR)/floatW.class \
+ $(OUTDIR)/$(UTIL_PDIR)/intW.class
diff --git a/jlapack-3.1.1/src/Makefile b/jlapack-3.1.1/src/Makefile
new file mode 100644
index 0000000..e0d7665
--- /dev/null
+++ b/jlapack-3.1.1/src/Makefile
@@ -0,0 +1,37 @@
+.PHONY: lib all testers err blas lapack util
+
+ROOT=..
+include $(ROOT)/make.def
+
+lib: util err blas lapack
+
+javasrc:
+ $(MAKE) -f Makefile_javasrc
+
+all: lib testers
+
+testers: err blas lapack
+ cd $(ROOT)/$(TESTING_DIR);$(MAKE)
+
+timers: err blas lapack
+ cd $(ROOT)/$(TIMING_DIR);$(MAKE)
+
+err:
+ cd $(ROOT)/$(ERR_DIR);$(MAKE)
+
+blas: util err
+ cd $(ROOT)/$(BLAS_DIR);$(MAKE)
+
+lapack: util err
+ cd $(ROOT)/$(LAPACK_DIR);$(MAKE)
+
+util:
+ cd $(ROOT)/$(UTIL_DIR);$(MAKE)
+
+clean:
+ cd $(ROOT)/$(ERR_DIR);$(MAKE) clean
+ cd $(ROOT)/$(BLAS_DIR);$(MAKE) clean
+ cd $(ROOT)/$(LAPACK_DIR);$(MAKE) clean
+ cd $(ROOT)/$(TESTING_DIR);$(MAKE) clean
+ cd $(ROOT)/$(TIMING_DIR);$(MAKE) clean
+ cd $(ROOT)/$(UTIL_DIR);$(MAKE) clean
diff --git a/jlapack-3.1.1/src/Makefile_javasrc b/jlapack-3.1.1/src/Makefile_javasrc
new file mode 100644
index 0000000..7c04b48
--- /dev/null
+++ b/jlapack-3.1.1/src/Makefile_javasrc
@@ -0,0 +1,34 @@
+.PHONY: lib all testers err blas lapack util
+
+ROOT=..
+include $(ROOT)/make.def
+
+lib: util err blas lapack
+
+all: lib testers
+
+testers: err blas lapack
+ cd $(ROOT)/$(TESTING_DIR);$(MAKE) -f Makefile_javasrc
+
+timers: err blas lapack
+ cd $(ROOT)/$(TIMING_DIR);$(MAKE) -f Makefile_javasrc
+
+err:
+ cd $(ROOT)/$(ERR_DIR);$(MAKE) -f Makefile_javasrc
+
+blas: util err
+ cd $(ROOT)/$(BLAS_DIR);$(MAKE) -f Makefile_javasrc
+
+lapack: util err blas
+ cd $(ROOT)/$(LAPACK_DIR);$(MAKE) -f Makefile_javasrc
+
+util:
+ cd $(ROOT)/$(UTIL_DIR);$(MAKE)
+
+clean:
+ cd $(ROOT)/$(ERR_DIR);$(MAKE) -f Makefile_javasrc clean
+ cd $(ROOT)/$(BLAS_DIR);$(MAKE) -f Makefile_javasrc clean
+ cd $(ROOT)/$(LAPACK_DIR);$(MAKE) -f Makefile_javasrc clean
+ cd $(ROOT)/$(TESTING_DIR);$(MAKE) -f Makefile_javasrc clean
+ cd $(ROOT)/$(TIMING_DIR);$(MAKE) -f Makefile_javasrc clean
+ cd $(ROOT)/$(UTIL_DIR);$(MAKE) -f Makefile_javasrc clean
diff --git a/jlapack-3.1.1/src/blas/Makefile b/jlapack-3.1.1/src/blas/Makefile
new file mode 100644
index 0000000..c993a26
--- /dev/null
+++ b/jlapack-3.1.1/src/blas/Makefile
@@ -0,0 +1,32 @@
+.SUFFIXES: .f .java
+
+ROOT=../..
+include $(ROOT)/make.def
+
+F2JFLAGS=-c .:$(OUTDIR):$(ROOT)/$(ERR_OBJ) -p $(BLAS_PACKAGE) -o $(OUTDIR) -s -d $(STATIC)
+
+$(BLAS_JAR): $(ROOT)/$(ERR_DIR)/$(ERR_JAR) $(ROOT)/$(UTIL_DIR)/$(UTIL_JAR) blas.f
+ $(F2J) $(F2JFLAGS) blas.f > /dev/null
+ cd $(OUTDIR); $(JAR) cvf ../$(BLAS_JAR) `find . -name "*.class"`
+ mkdir -p $(SIMPLE_DIR)/$(BLAS_PDIR)
+ -cp `find $(OUTDIR)/$(BLAS_PDIR) -name "[A-Z][A-Z]*.java"` $(SIMPLE_DIR)/$(BLAS_PDIR)
+ -$(JAVAC) -classpath .:$(BLAS_JAR):$(SIMPLE_DIR):$(ROOT)/$(UTIL_DIR)/$(UTIL_JAR):$(ROOT)/$(ERR_DIR)/$(ERR_JAR) $(SIMPLE_DIR)/$(BLAS_PDIR)/*.java
+ cd $(SIMPLE_DIR); $(JAR) cvf ../$(SIMPLE_BLAS_JAR) `find . -name "*.class"`
+
+nojar: $(ROOT)/$(ERR_DIR)/$(ERR_JAR) blas.f
+ $(F2J) $(F2JFLAGS) blas.f > /dev/null
+
+$(ROOT)/$(ERR_DIR)/$(ERR_JAR):
+ cd $(ROOT)/$(ERR_DIR);$(MAKE)
+
+javasrc:
+ $(MAKE) -f Makefile_javasrc
+
+$(ROOT)/$(UTIL_DIR)/$(UTIL_JAR):
+ cd $(ROOT)/$(UTIL_DIR); $(MAKE)
+
+verify: $(BLAS_JAR)
+ ./verify_all.csh
+
+clean:
+ /bin/rm -rf *.java *.class *.f2j $(BLAS_JAR) $(SIMPLE_BLAS_JAR) $(OUTDIR) $(JAVASRC_OUTDIR) $(SIMPLE_DIR)
diff --git a/jlapack-3.1.1/src/blas/Makefile_javasrc b/jlapack-3.1.1/src/blas/Makefile_javasrc
new file mode 100644
index 0000000..e14898d
--- /dev/null
+++ b/jlapack-3.1.1/src/blas/Makefile_javasrc
@@ -0,0 +1,28 @@
+.SUFFIXES: .f .java
+
+ROOT=../..
+include $(ROOT)/make.def
+
+$(BLAS_JAR): $(ROOT)/$(UTIL_DIR)/$(UTIL_JAR) $(ROOT)/$(ERR_DIR)/$(ERR_JAR) blas.f
+ $(MAKE) nojar
+ /bin/rm -f `find . -name "*.class"`
+ mkdir -p $(JAVASRC_OUTDIR)
+ $(JAVAC) -classpath $(ROOT)/$(UTIL_DIR)/$(UTIL_JAR):$(ROOT)/$(ERR_DIR)/$(ERR_JAR) -d $(JAVASRC_OUTDIR) $(OUTDIR)/$(BLAS_PDIR)/*.java
+ /bin/rm -f $(JAVASRC_OUTDIR)/$(BLAS_PDIR)/*.old
+ $(JAVAB) $(JAVASRC_OUTDIR)/$(BLAS_PDIR)/*.class
+ mkdir -p $(SIMPLE_DIR)/$(BLAS_PDIR)
+ -mv `find $(JAVASRC_OUTDIR) -name "[A-Z][A-Z]*.class"` $(SIMPLE_DIR)/$(BLAS_PDIR)
+ cd $(JAVASRC_OUTDIR); $(JAR) cvf ../$(BLAS_JAR) `find . -name "*.class"`
+ cd $(SIMPLE_DIR); $(JAR) cvf ../$(SIMPLE_BLAS_JAR) `find . -name "*.class"`
+
+$(ROOT)/$(ERR_DIR)/$(ERR_JAR):
+ cd $(ROOT)/$(ERR_DIR);$(MAKE) -f Makefile_javasrc
+
+$(ROOT)/$(UTIL_DIR)/$(UTIL_JAR):
+ cd $(ROOT)/$(UTIL_DIR); $(MAKE)
+
+verify: $(BLAS_JAR)
+ cd $(JAVASRC_OUTDIR); $(VERIFY) $(BLAS_PDIR)/*.class
+
+clean:
+ /bin/rm -rf *.java *.class *.f2j $(SBLAS_JAR) $(SIMPLE_SBLAS_JAR) $(OUTDIR) $(JAVASRC_OUTDIR) $(SIMPLE_DIR)
diff --git a/jlapack-3.1.1/src/blas/blas.f b/jlapack-3.1.1/src/blas/blas.f
new file mode 100644
index 0000000..a44ec1b
--- /dev/null
+++ b/jlapack-3.1.1/src/blas/blas.f
@@ -0,0 +1,14379 @@
+ DOUBLE PRECISION FUNCTION DASUM(N,DX,INCX)
+* .. Scalar Arguments ..
+ INTEGER INCX,N
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION DX(*)
+* ..
+*
+* Purpose
+* =======
+*
+* takes the sum of the absolute values.
+* jack dongarra, linpack, 3/11/78.
+* modified 3/93 to return if incx .le. 0.
+* modified 12/3/93, array(1) declarations changed to array(*)
+*
+*
+* .. Local Scalars ..
+ DOUBLE PRECISION DTEMP
+ INTEGER I,M,MP1,NINCX
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC DABS,MOD
+* ..
+ DASUM = 0.0d0
+ DTEMP = 0.0d0
+ IF (N.LE.0 .OR. INCX.LE.0) RETURN
+ IF (INCX.EQ.1) GO TO 20
+*
+* code for increment not equal to 1
+*
+ NINCX = N*INCX
+ DO 10 I = 1,NINCX,INCX
+ DTEMP = DTEMP + DABS(DX(I))
+ 10 CONTINUE
+ DASUM = DTEMP
+ RETURN
+*
+* code for increment equal to 1
+*
+*
+* clean-up loop
+*
+ 20 M = MOD(N,6)
+ IF (M.EQ.0) GO TO 40
+ DO 30 I = 1,M
+ DTEMP = DTEMP + DABS(DX(I))
+ 30 CONTINUE
+ IF (N.LT.6) GO TO 60
+ 40 MP1 = M + 1
+ DO 50 I = MP1,N,6
+ DTEMP = DTEMP + DABS(DX(I)) + DABS(DX(I+1)) + DABS(DX(I+2)) +
+ + DABS(DX(I+3)) + DABS(DX(I+4)) + DABS(DX(I+5))
+ 50 CONTINUE
+ 60 DASUM = DTEMP
+ RETURN
+ END
+ SUBROUTINE DAXPY(N,DA,DX,INCX,DY,INCY)
+* .. Scalar Arguments ..
+ DOUBLE PRECISION DA
+ INTEGER INCX,INCY,N
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION DX(*),DY(*)
+* ..
+*
+* Purpose
+* =======
+*
+* constant times a vector plus a vector.
+* uses unrolled loops for increments equal to one.
+* jack dongarra, linpack, 3/11/78.
+* modified 12/3/93, array(1) declarations changed to array(*)
+*
+*
+* .. Local Scalars ..
+ INTEGER I,IX,IY,M,MP1
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MOD
+* ..
+ IF (N.LE.0) RETURN
+ IF (DA.EQ.0.0d0) RETURN
+ IF (INCX.EQ.1 .AND. INCY.EQ.1) GO TO 20
+*
+* code for unequal increments or equal increments
+* not equal to 1
+*
+ IX = 1
+ IY = 1
+ IF (INCX.LT.0) IX = (-N+1)*INCX + 1
+ IF (INCY.LT.0) IY = (-N+1)*INCY + 1
+ DO 10 I = 1,N
+ DY(IY) = DY(IY) + DA*DX(IX)
+ IX = IX + INCX
+ IY = IY + INCY
+ 10 CONTINUE
+ RETURN
+*
+* code for both increments equal to 1
+*
+*
+* clean-up loop
+*
+ 20 M = MOD(N,4)
+ IF (M.EQ.0) GO TO 40
+ DO 30 I = 1,M
+ DY(I) = DY(I) + DA*DX(I)
+ 30 CONTINUE
+ IF (N.LT.4) RETURN
+ 40 MP1 = M + 1
+ DO 50 I = MP1,N,4
+ DY(I) = DY(I) + DA*DX(I)
+ DY(I+1) = DY(I+1) + DA*DX(I+1)
+ DY(I+2) = DY(I+2) + DA*DX(I+2)
+ DY(I+3) = DY(I+3) + DA*DX(I+3)
+ 50 CONTINUE
+ RETURN
+ END
+ SUBROUTINE DCOPY(N,DX,INCX,DY,INCY)
+* .. Scalar Arguments ..
+ INTEGER INCX,INCY,N
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION DX(*),DY(*)
+* ..
+*
+* Purpose
+* =======
+*
+* copies a vector, x, to a vector, y.
+* uses unrolled loops for increments equal to one.
+* jack dongarra, linpack, 3/11/78.
+* modified 12/3/93, array(1) declarations changed to array(*)
+*
+*
+* .. Local Scalars ..
+ INTEGER I,IX,IY,M,MP1
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MOD
+* ..
+ IF (N.LE.0) RETURN
+ IF (INCX.EQ.1 .AND. INCY.EQ.1) GO TO 20
+*
+* code for unequal increments or equal increments
+* not equal to 1
+*
+ IX = 1
+ IY = 1
+ IF (INCX.LT.0) IX = (-N+1)*INCX + 1
+ IF (INCY.LT.0) IY = (-N+1)*INCY + 1
+ DO 10 I = 1,N
+ DY(IY) = DX(IX)
+ IX = IX + INCX
+ IY = IY + INCY
+ 10 CONTINUE
+ RETURN
+*
+* code for both increments equal to 1
+*
+*
+* clean-up loop
+*
+ 20 M = MOD(N,7)
+ IF (M.EQ.0) GO TO 40
+ DO 30 I = 1,M
+ DY(I) = DX(I)
+ 30 CONTINUE
+ IF (N.LT.7) RETURN
+ 40 MP1 = M + 1
+ DO 50 I = MP1,N,7
+ DY(I) = DX(I)
+ DY(I+1) = DX(I+1)
+ DY(I+2) = DX(I+2)
+ DY(I+3) = DX(I+3)
+ DY(I+4) = DX(I+4)
+ DY(I+5) = DX(I+5)
+ DY(I+6) = DX(I+6)
+ 50 CONTINUE
+ RETURN
+ END
+ DOUBLE PRECISION FUNCTION DDOT(N,DX,INCX,DY,INCY)
+* .. Scalar Arguments ..
+ INTEGER INCX,INCY,N
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION DX(*),DY(*)
+* ..
+*
+* Purpose
+* =======
+*
+* forms the dot product of two vectors.
+* uses unrolled loops for increments equal to one.
+* jack dongarra, linpack, 3/11/78.
+* modified 12/3/93, array(1) declarations changed to array(*)
+*
+*
+* .. Local Scalars ..
+ DOUBLE PRECISION DTEMP
+ INTEGER I,IX,IY,M,MP1
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MOD
+* ..
+ DDOT = 0.0d0
+ DTEMP = 0.0d0
+ IF (N.LE.0) RETURN
+ IF (INCX.EQ.1 .AND. INCY.EQ.1) GO TO 20
+*
+* code for unequal increments or equal increments
+* not equal to 1
+*
+ IX = 1
+ IY = 1
+ IF (INCX.LT.0) IX = (-N+1)*INCX + 1
+ IF (INCY.LT.0) IY = (-N+1)*INCY + 1
+ DO 10 I = 1,N
+ DTEMP = DTEMP + DX(IX)*DY(IY)
+ IX = IX + INCX
+ IY = IY + INCY
+ 10 CONTINUE
+ DDOT = DTEMP
+ RETURN
+*
+* code for both increments equal to 1
+*
+*
+* clean-up loop
+*
+ 20 M = MOD(N,5)
+ IF (M.EQ.0) GO TO 40
+ DO 30 I = 1,M
+ DTEMP = DTEMP + DX(I)*DY(I)
+ 30 CONTINUE
+ IF (N.LT.5) GO TO 60
+ 40 MP1 = M + 1
+ DO 50 I = MP1,N,5
+ DTEMP = DTEMP + DX(I)*DY(I) + DX(I+1)*DY(I+1) +
+ + DX(I+2)*DY(I+2) + DX(I+3)*DY(I+3) + DX(I+4)*DY(I+4)
+ 50 CONTINUE
+ 60 DDOT = DTEMP
+ RETURN
+ END
+ SUBROUTINE DGBMV(TRANS,M,N,KL,KU,ALPHA,A,LDA,X,INCX,BETA,Y,INCY)
+* .. Scalar Arguments ..
+ DOUBLE PRECISION ALPHA,BETA
+ INTEGER INCX,INCY,KL,KU,LDA,M,N
+ CHARACTER TRANS
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION A(LDA,*),X(*),Y(*)
+* ..
+*
+* Purpose
+* =======
+*
+* DGBMV performs one of the matrix-vector operations
+*
+* y := alpha*A*x + beta*y, or y := alpha*A'*x + beta*y,
+*
+* where alpha and beta are scalars, x and y are vectors and A is an
+* m by n band matrix, with kl sub-diagonals and ku super-diagonals.
+*
+* Arguments
+* ==========
+*
+* TRANS - CHARACTER*1.
+* On entry, TRANS specifies the operation to be performed as
+* follows:
+*
+* TRANS = 'N' or 'n' y := alpha*A*x + beta*y.
+*
+* TRANS = 'T' or 't' y := alpha*A'*x + beta*y.
+*
+* TRANS = 'C' or 'c' y := alpha*A'*x + beta*y.
+*
+* Unchanged on exit.
+*
+* M - INTEGER.
+* On entry, M specifies the number of rows of the matrix A.
+* M must be at least zero.
+* Unchanged on exit.
+*
+* N - INTEGER.
+* On entry, N specifies the number of columns of the matrix A.
+* N must be at least zero.
+* Unchanged on exit.
+*
+* KL - INTEGER.
+* On entry, KL specifies the number of sub-diagonals of the
+* matrix A. KL must satisfy 0 .le. KL.
+* Unchanged on exit.
+*
+* KU - INTEGER.
+* On entry, KU specifies the number of super-diagonals of the
+* matrix A. KU must satisfy 0 .le. KU.
+* Unchanged on exit.
+*
+* ALPHA - DOUBLE PRECISION.
+* On entry, ALPHA specifies the scalar alpha.
+* Unchanged on exit.
+*
+* A - DOUBLE PRECISION array of DIMENSION ( LDA, n ).
+* Before entry, the leading ( kl + ku + 1 ) by n part of the
+* array A must contain the matrix of coefficients, supplied
+* column by column, with the leading diagonal of the matrix in
+* row ( ku + 1 ) of the array, the first super-diagonal
+* starting at position 2 in row ku, the first sub-diagonal
+* starting at position 1 in row ( ku + 2 ), and so on.
+* Elements in the array A that do not correspond to elements
+* in the band matrix (such as the top left ku by ku triangle)
+* are not referenced.
+* The following program segment will transfer a band matrix
+* from conventional full matrix storage to band storage:
+*
+* DO 20, J = 1, N
+* K = KU + 1 - J
+* DO 10, I = MAX( 1, J - KU ), MIN( M, J + KL )
+* A( K + I, J ) = matrix( I, J )
+* 10 CONTINUE
+* 20 CONTINUE
+*
+* Unchanged on exit.
+*
+* LDA - INTEGER.
+* On entry, LDA specifies the first dimension of A as declared
+* in the calling (sub) program. LDA must be at least
+* ( kl + ku + 1 ).
+* Unchanged on exit.
+*
+* X - DOUBLE PRECISION array of DIMENSION at least
+* ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n'
+* and at least
+* ( 1 + ( m - 1 )*abs( INCX ) ) otherwise.
+* Before entry, the incremented array X must contain the
+* vector x.
+* Unchanged on exit.
+*
+* INCX - INTEGER.
+* On entry, INCX specifies the increment for the elements of
+* X. INCX must not be zero.
+* Unchanged on exit.
+*
+* BETA - DOUBLE PRECISION.
+* On entry, BETA specifies the scalar beta. When BETA is
+* supplied as zero then Y need not be set on input.
+* Unchanged on exit.
+*
+* Y - DOUBLE PRECISION array of DIMENSION at least
+* ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n'
+* and at least
+* ( 1 + ( n - 1 )*abs( INCY ) ) otherwise.
+* Before entry, the incremented array Y must contain the
+* vector y. On exit, Y is overwritten by the updated vector y.
+*
+* INCY - INTEGER.
+* On entry, INCY specifies the increment for the elements of
+* Y. INCY must not be zero.
+* Unchanged on exit.
+*
+*
+* Level 2 Blas routine.
+*
+* -- Written on 22-October-1986.
+* Jack Dongarra, Argonne National Lab.
+* Jeremy Du Croz, Nag Central Office.
+* Sven Hammarling, Nag Central Office.
+* Richard Hanson, Sandia National Labs.
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE,ZERO
+ PARAMETER (ONE=1.0D+0,ZERO=0.0D+0)
+* ..
+* .. Local Scalars ..
+ DOUBLE PRECISION TEMP
+ INTEGER I,INFO,IX,IY,J,JX,JY,K,KUP1,KX,KY,LENX,LENY
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX,MIN
+* ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ IF (.NOT.LSAME(TRANS,'N') .AND. .NOT.LSAME(TRANS,'T') .AND.
+ + .NOT.LSAME(TRANS,'C')) THEN
+ INFO = 1
+ ELSE IF (M.LT.0) THEN
+ INFO = 2
+ ELSE IF (N.LT.0) THEN
+ INFO = 3
+ ELSE IF (KL.LT.0) THEN
+ INFO = 4
+ ELSE IF (KU.LT.0) THEN
+ INFO = 5
+ ELSE IF (LDA.LT. (KL+KU+1)) THEN
+ INFO = 8
+ ELSE IF (INCX.EQ.0) THEN
+ INFO = 10
+ ELSE IF (INCY.EQ.0) THEN
+ INFO = 13
+ END IF
+ IF (INFO.NE.0) THEN
+ CALL XERBLA('DGBMV ',INFO)
+ RETURN
+ END IF
+*
+* Quick return if possible.
+*
+ IF ((M.EQ.0) .OR. (N.EQ.0) .OR.
+ + ((ALPHA.EQ.ZERO).AND. (BETA.EQ.ONE))) RETURN
+*
+* Set LENX and LENY, the lengths of the vectors x and y, and set
+* up the start points in X and Y.
+*
+ IF (LSAME(TRANS,'N')) THEN
+ LENX = N
+ LENY = M
+ ELSE
+ LENX = M
+ LENY = N
+ END IF
+ IF (INCX.GT.0) THEN
+ KX = 1
+ ELSE
+ KX = 1 - (LENX-1)*INCX
+ END IF
+ IF (INCY.GT.0) THEN
+ KY = 1
+ ELSE
+ KY = 1 - (LENY-1)*INCY
+ END IF
+*
+* Start the operations. In this version the elements of A are
+* accessed sequentially with one pass through the band part of A.
+*
+* First form y := beta*y.
+*
+ IF (BETA.NE.ONE) THEN
+ IF (INCY.EQ.1) THEN
+ IF (BETA.EQ.ZERO) THEN
+ DO 10 I = 1,LENY
+ Y(I) = ZERO
+ 10 CONTINUE
+ ELSE
+ DO 20 I = 1,LENY
+ Y(I) = BETA*Y(I)
+ 20 CONTINUE
+ END IF
+ ELSE
+ IY = KY
+ IF (BETA.EQ.ZERO) THEN
+ DO 30 I = 1,LENY
+ Y(IY) = ZERO
+ IY = IY + INCY
+ 30 CONTINUE
+ ELSE
+ DO 40 I = 1,LENY
+ Y(IY) = BETA*Y(IY)
+ IY = IY + INCY
+ 40 CONTINUE
+ END IF
+ END IF
+ END IF
+ IF (ALPHA.EQ.ZERO) RETURN
+ KUP1 = KU + 1
+ IF (LSAME(TRANS,'N')) THEN
+*
+* Form y := alpha*A*x + y.
+*
+ JX = KX
+ IF (INCY.EQ.1) THEN
+ DO 60 J = 1,N
+ IF (X(JX).NE.ZERO) THEN
+ TEMP = ALPHA*X(JX)
+ K = KUP1 - J
+ DO 50 I = MAX(1,J-KU),MIN(M,J+KL)
+ Y(I) = Y(I) + TEMP*A(K+I,J)
+ 50 CONTINUE
+ END IF
+ JX = JX + INCX
+ 60 CONTINUE
+ ELSE
+ DO 80 J = 1,N
+ IF (X(JX).NE.ZERO) THEN
+ TEMP = ALPHA*X(JX)
+ IY = KY
+ K = KUP1 - J
+ DO 70 I = MAX(1,J-KU),MIN(M,J+KL)
+ Y(IY) = Y(IY) + TEMP*A(K+I,J)
+ IY = IY + INCY
+ 70 CONTINUE
+ END IF
+ JX = JX + INCX
+ IF (J.GT.KU) KY = KY + INCY
+ 80 CONTINUE
+ END IF
+ ELSE
+*
+* Form y := alpha*A'*x + y.
+*
+ JY = KY
+ IF (INCX.EQ.1) THEN
+ DO 100 J = 1,N
+ TEMP = ZERO
+ K = KUP1 - J
+ DO 90 I = MAX(1,J-KU),MIN(M,J+KL)
+ TEMP = TEMP + A(K+I,J)*X(I)
+ 90 CONTINUE
+ Y(JY) = Y(JY) + ALPHA*TEMP
+ JY = JY + INCY
+ 100 CONTINUE
+ ELSE
+ DO 120 J = 1,N
+ TEMP = ZERO
+ IX = KX
+ K = KUP1 - J
+ DO 110 I = MAX(1,J-KU),MIN(M,J+KL)
+ TEMP = TEMP + A(K+I,J)*X(IX)
+ IX = IX + INCX
+ 110 CONTINUE
+ Y(JY) = Y(JY) + ALPHA*TEMP
+ JY = JY + INCY
+ IF (J.GT.KU) KX = KX + INCX
+ 120 CONTINUE
+ END IF
+ END IF
+*
+ RETURN
+*
+* End of DGBMV .
+*
+ END
+ SUBROUTINE DGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC)
+* .. Scalar Arguments ..
+ DOUBLE PRECISION ALPHA,BETA
+ INTEGER K,LDA,LDB,LDC,M,N
+ CHARACTER TRANSA,TRANSB
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION A(LDA,*),B(LDB,*),C(LDC,*)
+* ..
+*
+* Purpose
+* =======
+*
+* DGEMM performs one of the matrix-matrix operations
+*
+* C := alpha*op( A )*op( B ) + beta*C,
+*
+* where op( X ) is one of
+*
+* op( X ) = X or op( X ) = X',
+*
+* alpha and beta are scalars, and A, B and C are matrices, with op( A )
+* an m by k matrix, op( B ) a k by n matrix and C an m by n matrix.
+*
+* Arguments
+* ==========
+*
+* TRANSA - CHARACTER*1.
+* On entry, TRANSA specifies the form of op( A ) to be used in
+* the matrix multiplication as follows:
+*
+* TRANSA = 'N' or 'n', op( A ) = A.
+*
+* TRANSA = 'T' or 't', op( A ) = A'.
+*
+* TRANSA = 'C' or 'c', op( A ) = A'.
+*
+* Unchanged on exit.
+*
+* TRANSB - CHARACTER*1.
+* On entry, TRANSB specifies the form of op( B ) to be used in
+* the matrix multiplication as follows:
+*
+* TRANSB = 'N' or 'n', op( B ) = B.
+*
+* TRANSB = 'T' or 't', op( B ) = B'.
+*
+* TRANSB = 'C' or 'c', op( B ) = B'.
+*
+* Unchanged on exit.
+*
+* M - INTEGER.
+* On entry, M specifies the number of rows of the matrix
+* op( A ) and of the matrix C. M must be at least zero.
+* Unchanged on exit.
+*
+* N - INTEGER.
+* On entry, N specifies the number of columns of the matrix
+* op( B ) and the number of columns of the matrix C. N must be
+* at least zero.
+* Unchanged on exit.
+*
+* K - INTEGER.
+* On entry, K specifies the number of columns of the matrix
+* op( A ) and the number of rows of the matrix op( B ). K must
+* be at least zero.
+* Unchanged on exit.
+*
+* ALPHA - DOUBLE PRECISION.
+* On entry, ALPHA specifies the scalar alpha.
+* Unchanged on exit.
+*
+* A - DOUBLE PRECISION array of DIMENSION ( LDA, ka ), where ka is
+* k when TRANSA = 'N' or 'n', and is m otherwise.
+* Before entry with TRANSA = 'N' or 'n', the leading m by k
+* part of the array A must contain the matrix A, otherwise
+* the leading k by m part of the array A must contain the
+* matrix A.
+* Unchanged on exit.
+*
+* LDA - INTEGER.
+* On entry, LDA specifies the first dimension of A as declared
+* in the calling (sub) program. When TRANSA = 'N' or 'n' then
+* LDA must be at least max( 1, m ), otherwise LDA must be at
+* least max( 1, k ).
+* Unchanged on exit.
+*
+* B - DOUBLE PRECISION array of DIMENSION ( LDB, kb ), where kb is
+* n when TRANSB = 'N' or 'n', and is k otherwise.
+* Before entry with TRANSB = 'N' or 'n', the leading k by n
+* part of the array B must contain the matrix B, otherwise
+* the leading n by k part of the array B must contain the
+* matrix B.
+* Unchanged on exit.
+*
+* LDB - INTEGER.
+* On entry, LDB specifies the first dimension of B as declared
+* in the calling (sub) program. When TRANSB = 'N' or 'n' then
+* LDB must be at least max( 1, k ), otherwise LDB must be at
+* least max( 1, n ).
+* Unchanged on exit.
+*
+* BETA - DOUBLE PRECISION.
+* On entry, BETA specifies the scalar beta. When BETA is
+* supplied as zero then C need not be set on input.
+* Unchanged on exit.
+*
+* C - DOUBLE PRECISION array of DIMENSION ( LDC, n ).
+* Before entry, the leading m by n part of the array C must
+* contain the matrix C, except when beta is zero, in which
+* case C need not be set on entry.
+* On exit, the array C is overwritten by the m by n matrix
+* ( alpha*op( A )*op( B ) + beta*C ).
+*
+* LDC - INTEGER.
+* On entry, LDC specifies the first dimension of C as declared
+* in the calling (sub) program. LDC must be at least
+* max( 1, m ).
+* Unchanged on exit.
+*
+*
+* Level 3 Blas routine.
+*
+* -- Written on 8-February-1989.
+* Jack Dongarra, Argonne National Laboratory.
+* Iain Duff, AERE Harwell.
+* Jeremy Du Croz, Numerical Algorithms Group Ltd.
+* Sven Hammarling, Numerical Algorithms Group Ltd.
+*
+*
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Local Scalars ..
+ DOUBLE PRECISION TEMP
+ INTEGER I,INFO,J,L,NCOLA,NROWA,NROWB
+ LOGICAL NOTA,NOTB
+* ..
+* .. Parameters ..
+ DOUBLE PRECISION ONE,ZERO
+ PARAMETER (ONE=1.0D+0,ZERO=0.0D+0)
+* ..
+*
+* Set NOTA and NOTB as true if A and B respectively are not
+* transposed and set NROWA, NCOLA and NROWB as the number of rows
+* and columns of A and the number of rows of B respectively.
+*
+ NOTA = LSAME(TRANSA,'N')
+ NOTB = LSAME(TRANSB,'N')
+ IF (NOTA) THEN
+ NROWA = M
+ NCOLA = K
+ ELSE
+ NROWA = K
+ NCOLA = M
+ END IF
+ IF (NOTB) THEN
+ NROWB = K
+ ELSE
+ NROWB = N
+ END IF
+*
+* Test the input parameters.
+*
+ INFO = 0
+ IF ((.NOT.NOTA) .AND. (.NOT.LSAME(TRANSA,'C')) .AND.
+ + (.NOT.LSAME(TRANSA,'T'))) THEN
+ INFO = 1
+ ELSE IF ((.NOT.NOTB) .AND. (.NOT.LSAME(TRANSB,'C')) .AND.
+ + (.NOT.LSAME(TRANSB,'T'))) THEN
+ INFO = 2
+ ELSE IF (M.LT.0) THEN
+ INFO = 3
+ ELSE IF (N.LT.0) THEN
+ INFO = 4
+ ELSE IF (K.LT.0) THEN
+ INFO = 5
+ ELSE IF (LDA.LT.MAX(1,NROWA)) THEN
+ INFO = 8
+ ELSE IF (LDB.LT.MAX(1,NROWB)) THEN
+ INFO = 10
+ ELSE IF (LDC.LT.MAX(1,M)) THEN
+ INFO = 13
+ END IF
+ IF (INFO.NE.0) THEN
+ CALL XERBLA('DGEMM ',INFO)
+ RETURN
+ END IF
+*
+* Quick return if possible.
+*
+ IF ((M.EQ.0) .OR. (N.EQ.0) .OR.
+ + (((ALPHA.EQ.ZERO).OR. (K.EQ.0)).AND. (BETA.EQ.ONE))) RETURN
+*
+* And if alpha.eq.zero.
+*
+ IF (ALPHA.EQ.ZERO) THEN
+ IF (BETA.EQ.ZERO) THEN
+ DO 20 J = 1,N
+ DO 10 I = 1,M
+ C(I,J) = ZERO
+ 10 CONTINUE
+ 20 CONTINUE
+ ELSE
+ DO 40 J = 1,N
+ DO 30 I = 1,M
+ C(I,J) = BETA*C(I,J)
+ 30 CONTINUE
+ 40 CONTINUE
+ END IF
+ RETURN
+ END IF
+*
+* Start the operations.
+*
+ IF (NOTB) THEN
+ IF (NOTA) THEN
+*
+* Form C := alpha*A*B + beta*C.
+*
+ DO 90 J = 1,N
+ IF (BETA.EQ.ZERO) THEN
+ DO 50 I = 1,M
+ C(I,J) = ZERO
+ 50 CONTINUE
+ ELSE IF (BETA.NE.ONE) THEN
+ DO 60 I = 1,M
+ C(I,J) = BETA*C(I,J)
+ 60 CONTINUE
+ END IF
+ DO 80 L = 1,K
+ IF (B(L,J).NE.ZERO) THEN
+ TEMP = ALPHA*B(L,J)
+ DO 70 I = 1,M
+ C(I,J) = C(I,J) + TEMP*A(I,L)
+ 70 CONTINUE
+ END IF
+ 80 CONTINUE
+ 90 CONTINUE
+ ELSE
+*
+* Form C := alpha*A'*B + beta*C
+*
+ DO 120 J = 1,N
+ DO 110 I = 1,M
+ TEMP = ZERO
+ DO 100 L = 1,K
+ TEMP = TEMP + A(L,I)*B(L,J)
+ 100 CONTINUE
+ IF (BETA.EQ.ZERO) THEN
+ C(I,J) = ALPHA*TEMP
+ ELSE
+ C(I,J) = ALPHA*TEMP + BETA*C(I,J)
+ END IF
+ 110 CONTINUE
+ 120 CONTINUE
+ END IF
+ ELSE
+ IF (NOTA) THEN
+*
+* Form C := alpha*A*B' + beta*C
+*
+ DO 170 J = 1,N
+ IF (BETA.EQ.ZERO) THEN
+ DO 130 I = 1,M
+ C(I,J) = ZERO
+ 130 CONTINUE
+ ELSE IF (BETA.NE.ONE) THEN
+ DO 140 I = 1,M
+ C(I,J) = BETA*C(I,J)
+ 140 CONTINUE
+ END IF
+ DO 160 L = 1,K
+ IF (B(J,L).NE.ZERO) THEN
+ TEMP = ALPHA*B(J,L)
+ DO 150 I = 1,M
+ C(I,J) = C(I,J) + TEMP*A(I,L)
+ 150 CONTINUE
+ END IF
+ 160 CONTINUE
+ 170 CONTINUE
+ ELSE
+*
+* Form C := alpha*A'*B' + beta*C
+*
+ DO 200 J = 1,N
+ DO 190 I = 1,M
+ TEMP = ZERO
+ DO 180 L = 1,K
+ TEMP = TEMP + A(L,I)*B(J,L)
+ 180 CONTINUE
+ IF (BETA.EQ.ZERO) THEN
+ C(I,J) = ALPHA*TEMP
+ ELSE
+ C(I,J) = ALPHA*TEMP + BETA*C(I,J)
+ END IF
+ 190 CONTINUE
+ 200 CONTINUE
+ END IF
+ END IF
+*
+ RETURN
+*
+* End of DGEMM .
+*
+ END
+ SUBROUTINE DGEMV(TRANS,M,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY)
+* .. Scalar Arguments ..
+ DOUBLE PRECISION ALPHA,BETA
+ INTEGER INCX,INCY,LDA,M,N
+ CHARACTER TRANS
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION A(LDA,*),X(*),Y(*)
+* ..
+*
+* Purpose
+* =======
+*
+* DGEMV performs one of the matrix-vector operations
+*
+* y := alpha*A*x + beta*y, or y := alpha*A'*x + beta*y,
+*
+* where alpha and beta are scalars, x and y are vectors and A is an
+* m by n matrix.
+*
+* Arguments
+* ==========
+*
+* TRANS - CHARACTER*1.
+* On entry, TRANS specifies the operation to be performed as
+* follows:
+*
+* TRANS = 'N' or 'n' y := alpha*A*x + beta*y.
+*
+* TRANS = 'T' or 't' y := alpha*A'*x + beta*y.
+*
+* TRANS = 'C' or 'c' y := alpha*A'*x + beta*y.
+*
+* Unchanged on exit.
+*
+* M - INTEGER.
+* On entry, M specifies the number of rows of the matrix A.
+* M must be at least zero.
+* Unchanged on exit.
+*
+* N - INTEGER.
+* On entry, N specifies the number of columns of the matrix A.
+* N must be at least zero.
+* Unchanged on exit.
+*
+* ALPHA - DOUBLE PRECISION.
+* On entry, ALPHA specifies the scalar alpha.
+* Unchanged on exit.
+*
+* A - DOUBLE PRECISION array of DIMENSION ( LDA, n ).
+* Before entry, the leading m by n part of the array A must
+* contain the matrix of coefficients.
+* Unchanged on exit.
+*
+* LDA - INTEGER.
+* On entry, LDA specifies the first dimension of A as declared
+* in the calling (sub) program. LDA must be at least
+* max( 1, m ).
+* Unchanged on exit.
+*
+* X - DOUBLE PRECISION array of DIMENSION at least
+* ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n'
+* and at least
+* ( 1 + ( m - 1 )*abs( INCX ) ) otherwise.
+* Before entry, the incremented array X must contain the
+* vector x.
+* Unchanged on exit.
+*
+* INCX - INTEGER.
+* On entry, INCX specifies the increment for the elements of
+* X. INCX must not be zero.
+* Unchanged on exit.
+*
+* BETA - DOUBLE PRECISION.
+* On entry, BETA specifies the scalar beta. When BETA is
+* supplied as zero then Y need not be set on input.
+* Unchanged on exit.
+*
+* Y - DOUBLE PRECISION array of DIMENSION at least
+* ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n'
+* and at least
+* ( 1 + ( n - 1 )*abs( INCY ) ) otherwise.
+* Before entry with BETA non-zero, the incremented array Y
+* must contain the vector y. On exit, Y is overwritten by the
+* updated vector y.
+*
+* INCY - INTEGER.
+* On entry, INCY specifies the increment for the elements of
+* Y. INCY must not be zero.
+* Unchanged on exit.
+*
+*
+* Level 2 Blas routine.
+*
+* -- Written on 22-October-1986.
+* Jack Dongarra, Argonne National Lab.
+* Jeremy Du Croz, Nag Central Office.
+* Sven Hammarling, Nag Central Office.
+* Richard Hanson, Sandia National Labs.
+*
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE,ZERO
+ PARAMETER (ONE=1.0D+0,ZERO=0.0D+0)
+* ..
+* .. Local Scalars ..
+ DOUBLE PRECISION TEMP
+ INTEGER I,INFO,IX,IY,J,JX,JY,KX,KY,LENX,LENY
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ IF (.NOT.LSAME(TRANS,'N') .AND. .NOT.LSAME(TRANS,'T') .AND.
+ + .NOT.LSAME(TRANS,'C')) THEN
+ INFO = 1
+ ELSE IF (M.LT.0) THEN
+ INFO = 2
+ ELSE IF (N.LT.0) THEN
+ INFO = 3
+ ELSE IF (LDA.LT.MAX(1,M)) THEN
+ INFO = 6
+ ELSE IF (INCX.EQ.0) THEN
+ INFO = 8
+ ELSE IF (INCY.EQ.0) THEN
+ INFO = 11
+ END IF
+ IF (INFO.NE.0) THEN
+ CALL XERBLA('DGEMV ',INFO)
+ RETURN
+ END IF
+*
+* Quick return if possible.
+*
+ IF ((M.EQ.0) .OR. (N.EQ.0) .OR.
+ + ((ALPHA.EQ.ZERO).AND. (BETA.EQ.ONE))) RETURN
+*
+* Set LENX and LENY, the lengths of the vectors x and y, and set
+* up the start points in X and Y.
+*
+ IF (LSAME(TRANS,'N')) THEN
+ LENX = N
+ LENY = M
+ ELSE
+ LENX = M
+ LENY = N
+ END IF
+ IF (INCX.GT.0) THEN
+ KX = 1
+ ELSE
+ KX = 1 - (LENX-1)*INCX
+ END IF
+ IF (INCY.GT.0) THEN
+ KY = 1
+ ELSE
+ KY = 1 - (LENY-1)*INCY
+ END IF
+*
+* Start the operations. In this version the elements of A are
+* accessed sequentially with one pass through A.
+*
+* First form y := beta*y.
+*
+ IF (BETA.NE.ONE) THEN
+ IF (INCY.EQ.1) THEN
+ IF (BETA.EQ.ZERO) THEN
+ DO 10 I = 1,LENY
+ Y(I) = ZERO
+ 10 CONTINUE
+ ELSE
+ DO 20 I = 1,LENY
+ Y(I) = BETA*Y(I)
+ 20 CONTINUE
+ END IF
+ ELSE
+ IY = KY
+ IF (BETA.EQ.ZERO) THEN
+ DO 30 I = 1,LENY
+ Y(IY) = ZERO
+ IY = IY + INCY
+ 30 CONTINUE
+ ELSE
+ DO 40 I = 1,LENY
+ Y(IY) = BETA*Y(IY)
+ IY = IY + INCY
+ 40 CONTINUE
+ END IF
+ END IF
+ END IF
+ IF (ALPHA.EQ.ZERO) RETURN
+ IF (LSAME(TRANS,'N')) THEN
+*
+* Form y := alpha*A*x + y.
+*
+ JX = KX
+ IF (INCY.EQ.1) THEN
+ DO 60 J = 1,N
+ IF (X(JX).NE.ZERO) THEN
+ TEMP = ALPHA*X(JX)
+ DO 50 I = 1,M
+ Y(I) = Y(I) + TEMP*A(I,J)
+ 50 CONTINUE
+ END IF
+ JX = JX + INCX
+ 60 CONTINUE
+ ELSE
+ DO 80 J = 1,N
+ IF (X(JX).NE.ZERO) THEN
+ TEMP = ALPHA*X(JX)
+ IY = KY
+ DO 70 I = 1,M
+ Y(IY) = Y(IY) + TEMP*A(I,J)
+ IY = IY + INCY
+ 70 CONTINUE
+ END IF
+ JX = JX + INCX
+ 80 CONTINUE
+ END IF
+ ELSE
+*
+* Form y := alpha*A'*x + y.
+*
+ JY = KY
+ IF (INCX.EQ.1) THEN
+ DO 100 J = 1,N
+ TEMP = ZERO
+ DO 90 I = 1,M
+ TEMP = TEMP + A(I,J)*X(I)
+ 90 CONTINUE
+ Y(JY) = Y(JY) + ALPHA*TEMP
+ JY = JY + INCY
+ 100 CONTINUE
+ ELSE
+ DO 120 J = 1,N
+ TEMP = ZERO
+ IX = KX
+ DO 110 I = 1,M
+ TEMP = TEMP + A(I,J)*X(IX)
+ IX = IX + INCX
+ 110 CONTINUE
+ Y(JY) = Y(JY) + ALPHA*TEMP
+ JY = JY + INCY
+ 120 CONTINUE
+ END IF
+ END IF
+*
+ RETURN
+*
+* End of DGEMV .
+*
+ END
+ SUBROUTINE DGER(M,N,ALPHA,X,INCX,Y,INCY,A,LDA)
+* .. Scalar Arguments ..
+ DOUBLE PRECISION ALPHA
+ INTEGER INCX,INCY,LDA,M,N
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION A(LDA,*),X(*),Y(*)
+* ..
+*
+* Purpose
+* =======
+*
+* DGER performs the rank 1 operation
+*
+* A := alpha*x*y' + A,
+*
+* where alpha is a scalar, x is an m element vector, y is an n element
+* vector and A is an m by n matrix.
+*
+* Arguments
+* ==========
+*
+* M - INTEGER.
+* On entry, M specifies the number of rows of the matrix A.
+* M must be at least zero.
+* Unchanged on exit.
+*
+* N - INTEGER.
+* On entry, N specifies the number of columns of the matrix A.
+* N must be at least zero.
+* Unchanged on exit.
+*
+* ALPHA - DOUBLE PRECISION.
+* On entry, ALPHA specifies the scalar alpha.
+* Unchanged on exit.
+*
+* X - DOUBLE PRECISION array of dimension at least
+* ( 1 + ( m - 1 )*abs( INCX ) ).
+* Before entry, the incremented array X must contain the m
+* element vector x.
+* Unchanged on exit.
+*
+* INCX - INTEGER.
+* On entry, INCX specifies the increment for the elements of
+* X. INCX must not be zero.
+* Unchanged on exit.
+*
+* Y - DOUBLE PRECISION array of dimension at least
+* ( 1 + ( n - 1 )*abs( INCY ) ).
+* Before entry, the incremented array Y must contain the n
+* element vector y.
+* Unchanged on exit.
+*
+* INCY - INTEGER.
+* On entry, INCY specifies the increment for the elements of
+* Y. INCY must not be zero.
+* Unchanged on exit.
+*
+* A - DOUBLE PRECISION array of DIMENSION ( LDA, n ).
+* Before entry, the leading m by n part of the array A must
+* contain the matrix of coefficients. On exit, A is
+* overwritten by the updated matrix.
+*
+* LDA - INTEGER.
+* On entry, LDA specifies the first dimension of A as declared
+* in the calling (sub) program. LDA must be at least
+* max( 1, m ).
+* Unchanged on exit.
+*
+*
+* Level 2 Blas routine.
+*
+* -- Written on 22-October-1986.
+* Jack Dongarra, Argonne National Lab.
+* Jeremy Du Croz, Nag Central Office.
+* Sven Hammarling, Nag Central Office.
+* Richard Hanson, Sandia National Labs.
+*
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO
+ PARAMETER (ZERO=0.0D+0)
+* ..
+* .. Local Scalars ..
+ DOUBLE PRECISION TEMP
+ INTEGER I,INFO,IX,J,JY,KX
+* ..
+* .. External Subroutines ..
+ EXTERNAL XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ IF (M.LT.0) THEN
+ INFO = 1
+ ELSE IF (N.LT.0) THEN
+ INFO = 2
+ ELSE IF (INCX.EQ.0) THEN
+ INFO = 5
+ ELSE IF (INCY.EQ.0) THEN
+ INFO = 7
+ ELSE IF (LDA.LT.MAX(1,M)) THEN
+ INFO = 9
+ END IF
+ IF (INFO.NE.0) THEN
+ CALL XERBLA('DGER ',INFO)
+ RETURN
+ END IF
+*
+* Quick return if possible.
+*
+ IF ((M.EQ.0) .OR. (N.EQ.0) .OR. (ALPHA.EQ.ZERO)) RETURN
+*
+* Start the operations. In this version the elements of A are
+* accessed sequentially with one pass through A.
+*
+ IF (INCY.GT.0) THEN
+ JY = 1
+ ELSE
+ JY = 1 - (N-1)*INCY
+ END IF
+ IF (INCX.EQ.1) THEN
+ DO 20 J = 1,N
+ IF (Y(JY).NE.ZERO) THEN
+ TEMP = ALPHA*Y(JY)
+ DO 10 I = 1,M
+ A(I,J) = A(I,J) + X(I)*TEMP
+ 10 CONTINUE
+ END IF
+ JY = JY + INCY
+ 20 CONTINUE
+ ELSE
+ IF (INCX.GT.0) THEN
+ KX = 1
+ ELSE
+ KX = 1 - (M-1)*INCX
+ END IF
+ DO 40 J = 1,N
+ IF (Y(JY).NE.ZERO) THEN
+ TEMP = ALPHA*Y(JY)
+ IX = KX
+ DO 30 I = 1,M
+ A(I,J) = A(I,J) + X(IX)*TEMP
+ IX = IX + INCX
+ 30 CONTINUE
+ END IF
+ JY = JY + INCY
+ 40 CONTINUE
+ END IF
+*
+ RETURN
+*
+* End of DGER .
+*
+ END
+ DOUBLE PRECISION FUNCTION DNRM2(N,X,INCX)
+* .. Scalar Arguments ..
+ INTEGER INCX,N
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION X(*)
+* ..
+*
+* Purpose
+* =======
+*
+* DNRM2 returns the euclidean norm of a vector via the function
+* name, so that
+*
+* DNRM2 := sqrt( x'*x )
+*
+*
+* -- This version written on 25-October-1982.
+* Modified on 14-October-1993 to inline the call to DLASSQ.
+* Sven Hammarling, Nag Ltd.
+*
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE,ZERO
+ PARAMETER (ONE=1.0D+0,ZERO=0.0D+0)
+* ..
+* .. Local Scalars ..
+ DOUBLE PRECISION ABSXI,NORM,SCALE,SSQ
+ INTEGER IX
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS,SQRT
+* ..
+ IF (N.LT.1 .OR. INCX.LT.1) THEN
+ NORM = ZERO
+ ELSE IF (N.EQ.1) THEN
+ NORM = ABS(X(1))
+ ELSE
+ SCALE = ZERO
+ SSQ = ONE
+* The following loop is equivalent to this call to the LAPACK
+* auxiliary routine:
+* CALL DLASSQ( N, X, INCX, SCALE, SSQ )
+*
+ DO 10 IX = 1,1 + (N-1)*INCX,INCX
+ IF (X(IX).NE.ZERO) THEN
+ ABSXI = ABS(X(IX))
+ IF (SCALE.LT.ABSXI) THEN
+ SSQ = ONE + SSQ* (SCALE/ABSXI)**2
+ SCALE = ABSXI
+ ELSE
+ SSQ = SSQ + (ABSXI/SCALE)**2
+ END IF
+ END IF
+ 10 CONTINUE
+ NORM = SCALE*SQRT(SSQ)
+ END IF
+*
+ DNRM2 = NORM
+ RETURN
+*
+* End of DNRM2.
+*
+ END
+ SUBROUTINE DROT(N,DX,INCX,DY,INCY,C,S)
+* .. Scalar Arguments ..
+ DOUBLE PRECISION C,S
+ INTEGER INCX,INCY,N
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION DX(*),DY(*)
+* ..
+*
+* Purpose
+* =======
+*
+* applies a plane rotation.
+* jack dongarra, linpack, 3/11/78.
+* modified 12/3/93, array(1) declarations changed to array(*)
+*
+*
+* .. Local Scalars ..
+ DOUBLE PRECISION DTEMP
+ INTEGER I,IX,IY
+* ..
+ IF (N.LE.0) RETURN
+ IF (INCX.EQ.1 .AND. INCY.EQ.1) GO TO 20
+*
+* code for unequal increments or equal increments not equal
+* to 1
+*
+ IX = 1
+ IY = 1
+ IF (INCX.LT.0) IX = (-N+1)*INCX + 1
+ IF (INCY.LT.0) IY = (-N+1)*INCY + 1
+ DO 10 I = 1,N
+ DTEMP = C*DX(IX) + S*DY(IY)
+ DY(IY) = C*DY(IY) - S*DX(IX)
+ DX(IX) = DTEMP
+ IX = IX + INCX
+ IY = IY + INCY
+ 10 CONTINUE
+ RETURN
+*
+* code for both increments equal to 1
+*
+ 20 DO 30 I = 1,N
+ DTEMP = C*DX(I) + S*DY(I)
+ DY(I) = C*DY(I) - S*DX(I)
+ DX(I) = DTEMP
+ 30 CONTINUE
+ RETURN
+ END
+ SUBROUTINE DROTG(DA,DB,C,S)
+* .. Scalar Arguments ..
+ DOUBLE PRECISION C,DA,DB,S
+* ..
+*
+* Purpose
+* =======
+*
+* construct givens plane rotation.
+* jack dongarra, linpack, 3/11/78.
+*
+*
+* .. Local Scalars ..
+ DOUBLE PRECISION R,ROE,SCALE,Z
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC DABS,DSIGN,DSQRT
+* ..
+ ROE = DB
+ IF (DABS(DA).GT.DABS(DB)) ROE = DA
+ SCALE = DABS(DA) + DABS(DB)
+ IF (SCALE.NE.0.0d0) GO TO 10
+ C = 1.0d0
+ S = 0.0d0
+ R = 0.0d0
+ Z = 0.0d0
+ GO TO 20
+ 10 R = SCALE*DSQRT((DA/SCALE)**2+ (DB/SCALE)**2)
+ R = DSIGN(1.0d0,ROE)*R
+ C = DA/R
+ S = DB/R
+ Z = 1.0d0
+ IF (DABS(DA).GT.DABS(DB)) Z = S
+ IF (DABS(DB).GE.DABS(DA) .AND. C.NE.0.0d0) Z = 1.0d0/C
+ 20 DA = R
+ DB = Z
+ RETURN
+ END
+ SUBROUTINE DROTM(N,DX,INCX,DY,INCY,DPARAM)
+* .. Scalar Arguments ..
+ INTEGER INCX,INCY,N
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION DPARAM(5),DX(1),DY(1)
+* ..
+*
+* Purpose
+* =======
+*
+* APPLY THE MODIFIED GIVENS TRANSFORMATION, H, TO THE 2 BY N MATRIX
+*
+* (DX**T) , WHERE **T INDICATES TRANSPOSE. THE ELEMENTS OF DX ARE IN
+* (DY**T)
+*
+* DX(LX+I*INCX), I = 0 TO N-1, WHERE LX = 1 IF INCX .GE. 0, ELSE
+* LX = (-INCX)*N, AND SIMILARLY FOR SY USING LY AND INCY.
+* WITH DPARAM(1)=DFLAG, H HAS ONE OF THE FOLLOWING FORMS..
+*
+* DFLAG=-1.D0 DFLAG=0.D0 DFLAG=1.D0 DFLAG=-2.D0
+*
+* (DH11 DH12) (1.D0 DH12) (DH11 1.D0) (1.D0 0.D0)
+* H=( ) ( ) ( ) ( )
+* (DH21 DH22), (DH21 1.D0), (-1.D0 DH22), (0.D0 1.D0).
+* SEE DROTMG FOR A DESCRIPTION OF DATA STORAGE IN DPARAM.
+*
+* Arguments
+* =========
+*
+* N (input) INTEGER
+* number of elements in input vector(s)
+*
+* DX (input/output) DOUBLE PRECISION array, dimension N
+* double precision vector with 5 elements
+*
+* INCX (input) INTEGER
+* storage spacing between elements of DX
+*
+* DY (input/output) DOUBLE PRECISION array, dimension N
+* double precision vector with N elements
+*
+* INCY (input) INTEGER
+* storage spacing between elements of DY
+*
+* DPARAM (input/output) DOUBLE PRECISION array, dimension 5
+* DPARAM(1)=DFLAG
+* DPARAM(2)=DH11
+* DPARAM(3)=DH21
+* DPARAM(4)=DH12
+* DPARAM(5)=DH22
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ DOUBLE PRECISION DFLAG,DH11,DH12,DH21,DH22,TWO,W,Z,ZERO
+ INTEGER I,KX,KY,NSTEPS
+* ..
+* .. Data statements ..
+ DATA ZERO,TWO/0.D0,2.D0/
+* ..
+*
+ DFLAG = DPARAM(1)
+ IF (N.LE.0 .OR. (DFLAG+TWO.EQ.ZERO)) GO TO 140
+ IF (.NOT. (INCX.EQ.INCY.AND.INCX.GT.0)) GO TO 70
+*
+ NSTEPS = N*INCX
+ IF (DFLAG) 50,10,30
+ 10 CONTINUE
+ DH12 = DPARAM(4)
+ DH21 = DPARAM(3)
+ DO 20 I = 1,NSTEPS,INCX
+ W = DX(I)
+ Z = DY(I)
+ DX(I) = W + Z*DH12
+ DY(I) = W*DH21 + Z
+ 20 CONTINUE
+ GO TO 140
+ 30 CONTINUE
+ DH11 = DPARAM(2)
+ DH22 = DPARAM(5)
+ DO 40 I = 1,NSTEPS,INCX
+ W = DX(I)
+ Z = DY(I)
+ DX(I) = W*DH11 + Z
+ DY(I) = -W + DH22*Z
+ 40 CONTINUE
+ GO TO 140
+ 50 CONTINUE
+ DH11 = DPARAM(2)
+ DH12 = DPARAM(4)
+ DH21 = DPARAM(3)
+ DH22 = DPARAM(5)
+ DO 60 I = 1,NSTEPS,INCX
+ W = DX(I)
+ Z = DY(I)
+ DX(I) = W*DH11 + Z*DH12
+ DY(I) = W*DH21 + Z*DH22
+ 60 CONTINUE
+ GO TO 140
+ 70 CONTINUE
+ KX = 1
+ KY = 1
+ IF (INCX.LT.0) KX = 1 + (1-N)*INCX
+ IF (INCY.LT.0) KY = 1 + (1-N)*INCY
+*
+ IF (DFLAG) 120,80,100
+ 80 CONTINUE
+ DH12 = DPARAM(4)
+ DH21 = DPARAM(3)
+ DO 90 I = 1,N
+ W = DX(KX)
+ Z = DY(KY)
+ DX(KX) = W + Z*DH12
+ DY(KY) = W*DH21 + Z
+ KX = KX + INCX
+ KY = KY + INCY
+ 90 CONTINUE
+ GO TO 140
+ 100 CONTINUE
+ DH11 = DPARAM(2)
+ DH22 = DPARAM(5)
+ DO 110 I = 1,N
+ W = DX(KX)
+ Z = DY(KY)
+ DX(KX) = W*DH11 + Z
+ DY(KY) = -W + DH22*Z
+ KX = KX + INCX
+ KY = KY + INCY
+ 110 CONTINUE
+ GO TO 140
+ 120 CONTINUE
+ DH11 = DPARAM(2)
+ DH12 = DPARAM(4)
+ DH21 = DPARAM(3)
+ DH22 = DPARAM(5)
+ DO 130 I = 1,N
+ W = DX(KX)
+ Z = DY(KY)
+ DX(KX) = W*DH11 + Z*DH12
+ DY(KY) = W*DH21 + Z*DH22
+ KX = KX + INCX
+ KY = KY + INCY
+ 130 CONTINUE
+ 140 CONTINUE
+ RETURN
+ END
+ SUBROUTINE DROTMG(DD1,DD2,DX1,DY1,DPARAM)
+* .. Scalar Arguments ..
+ DOUBLE PRECISION DD1,DD2,DX1,DY1
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION DPARAM(5)
+* ..
+*
+* Purpose
+* =======
+*
+* CONSTRUCT THE MODIFIED GIVENS TRANSFORMATION MATRIX H WHICH ZEROS
+* THE SECOND COMPONENT OF THE 2-VECTOR (DSQRT(DD1)*DX1,DSQRT(DD2)*
+* DY2)**T.
+* WITH DPARAM(1)=DFLAG, H HAS ONE OF THE FOLLOWING FORMS..
+*
+* DFLAG=-1.D0 DFLAG=0.D0 DFLAG=1.D0 DFLAG=-2.D0
+*
+* (DH11 DH12) (1.D0 DH12) (DH11 1.D0) (1.D0 0.D0)
+* H=( ) ( ) ( ) ( )
+* (DH21 DH22), (DH21 1.D0), (-1.D0 DH22), (0.D0 1.D0).
+* LOCATIONS 2-4 OF DPARAM CONTAIN DH11, DH21, DH12, AND DH22
+* RESPECTIVELY. (VALUES OF 1.D0, -1.D0, OR 0.D0 IMPLIED BY THE
+* VALUE OF DPARAM(1) ARE NOT STORED IN DPARAM.)
+*
+* THE VALUES OF GAMSQ AND RGAMSQ SET IN THE DATA STATEMENT MAY BE
+* INEXACT. THIS IS OK AS THEY ARE ONLY USED FOR TESTING THE SIZE
+* OF DD1 AND DD2. ALL ACTUAL SCALING OF DATA IS DONE USING GAM.
+*
+*
+* Arguments
+* =========
+*
+* DD1 (input/output) DOUBLE PRECISION
+*
+* DD2 (input/output) DOUBLE PRECISION
+*
+* DX1 (input/output) DOUBLE PRECISION
+*
+* DY1 (input) DOUBLE PRECISION
+*
+* DPARAM (input/output) DOUBLE PRECISION array, dimension 5
+* DPARAM(1)=DFLAG
+* DPARAM(2)=DH11
+* DPARAM(3)=DH21
+* DPARAM(4)=DH12
+* DPARAM(5)=DH22
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ DOUBLE PRECISION DFLAG,DH11,DH12,DH21,DH22,DP1,DP2,DQ1,DQ2,DTEMP,
+ + DU,GAM,GAMSQ,ONE,RGAMSQ,TWO,ZERO
+ INTEGER IGO
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC DABS
+* ..
+* .. Data statements ..
+*
+ DATA ZERO,ONE,TWO/0.D0,1.D0,2.D0/
+ DATA GAM,GAMSQ,RGAMSQ/4096.D0,16777216.D0,5.9604645D-8/
+* ..
+
+ IF (.NOT.DD1.LT.ZERO) GO TO 10
+* GO ZERO-H-D-AND-DX1..
+ GO TO 60
+ 10 CONTINUE
+* CASE-DD1-NONNEGATIVE
+ DP2 = DD2*DY1
+ IF (.NOT.DP2.EQ.ZERO) GO TO 20
+ DFLAG = -TWO
+ GO TO 260
+* REGULAR-CASE..
+ 20 CONTINUE
+ DP1 = DD1*DX1
+ DQ2 = DP2*DY1
+ DQ1 = DP1*DX1
+*
+ IF (.NOT.DABS(DQ1).GT.DABS(DQ2)) GO TO 40
+ DH21 = -DY1/DX1
+ DH12 = DP2/DP1
+*
+ DU = ONE - DH12*DH21
+*
+ IF (.NOT.DU.LE.ZERO) GO TO 30
+* GO ZERO-H-D-AND-DX1..
+ GO TO 60
+ 30 CONTINUE
+ DFLAG = ZERO
+ DD1 = DD1/DU
+ DD2 = DD2/DU
+ DX1 = DX1*DU
+* GO SCALE-CHECK..
+ GO TO 100
+ 40 CONTINUE
+ IF (.NOT.DQ2.LT.ZERO) GO TO 50
+* GO ZERO-H-D-AND-DX1..
+ GO TO 60
+ 50 CONTINUE
+ DFLAG = ONE
+ DH11 = DP1/DP2
+ DH22 = DX1/DY1
+ DU = ONE + DH11*DH22
+ DTEMP = DD2/DU
+ DD2 = DD1/DU
+ DD1 = DTEMP
+ DX1 = DY1*DU
+* GO SCALE-CHECK
+ GO TO 100
+* PROCEDURE..ZERO-H-D-AND-DX1..
+ 60 CONTINUE
+ DFLAG = -ONE
+ DH11 = ZERO
+ DH12 = ZERO
+ DH21 = ZERO
+ DH22 = ZERO
+*
+ DD1 = ZERO
+ DD2 = ZERO
+ DX1 = ZERO
+* RETURN..
+ GO TO 220
+* PROCEDURE..FIX-H..
+ 70 CONTINUE
+ IF (.NOT.DFLAG.GE.ZERO) GO TO 90
+*
+ IF (.NOT.DFLAG.EQ.ZERO) GO TO 80
+ DH11 = ONE
+ DH22 = ONE
+ DFLAG = -ONE
+ GO TO 90
+ 80 CONTINUE
+ DH21 = -ONE
+ DH12 = ONE
+ DFLAG = -ONE
+ 90 CONTINUE
+ GO TO IGO(120,150,180,210)
+* PROCEDURE..SCALE-CHECK
+ 100 CONTINUE
+ 110 CONTINUE
+ IF (.NOT.DD1.LE.RGAMSQ) GO TO 130
+ IF (DD1.EQ.ZERO) GO TO 160
+ ASSIGN 120 TO IGO
+* FIX-H..
+ GO TO 70
+ 120 CONTINUE
+ DD1 = DD1*GAM**2
+ DX1 = DX1/GAM
+ DH11 = DH11/GAM
+ DH12 = DH12/GAM
+ GO TO 110
+ 130 CONTINUE
+ 140 CONTINUE
+ IF (.NOT.DD1.GE.GAMSQ) GO TO 160
+ ASSIGN 150 TO IGO
+* FIX-H..
+ GO TO 70
+ 150 CONTINUE
+ DD1 = DD1/GAM**2
+ DX1 = DX1*GAM
+ DH11 = DH11*GAM
+ DH12 = DH12*GAM
+ GO TO 140
+ 160 CONTINUE
+ 170 CONTINUE
+ IF (.NOT.DABS(DD2).LE.RGAMSQ) GO TO 190
+ IF (DD2.EQ.ZERO) GO TO 220
+ ASSIGN 180 TO IGO
+* FIX-H..
+ GO TO 70
+ 180 CONTINUE
+ DD2 = DD2*GAM**2
+ DH21 = DH21/GAM
+ DH22 = DH22/GAM
+ GO TO 170
+ 190 CONTINUE
+ 200 CONTINUE
+ IF (.NOT.DABS(DD2).GE.GAMSQ) GO TO 220
+ ASSIGN 210 TO IGO
+* FIX-H..
+ GO TO 70
+ 210 CONTINUE
+ DD2 = DD2/GAM**2
+ DH21 = DH21*GAM
+ DH22 = DH22*GAM
+ GO TO 200
+ 220 CONTINUE
+ IF (DFLAG) 250,230,240
+ 230 CONTINUE
+ DPARAM(3) = DH21
+ DPARAM(4) = DH12
+ GO TO 260
+ 240 CONTINUE
+ DPARAM(2) = DH11
+ DPARAM(5) = DH22
+ GO TO 260
+ 250 CONTINUE
+ DPARAM(2) = DH11
+ DPARAM(3) = DH21
+ DPARAM(4) = DH12
+ DPARAM(5) = DH22
+ 260 CONTINUE
+ DPARAM(1) = DFLAG
+ RETURN
+ END
+ SUBROUTINE DSBMV(UPLO,N,K,ALPHA,A,LDA,X,INCX,BETA,Y,INCY)
+* .. Scalar Arguments ..
+ DOUBLE PRECISION ALPHA,BETA
+ INTEGER INCX,INCY,K,LDA,N
+ CHARACTER UPLO
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION A(LDA,*),X(*),Y(*)
+* ..
+*
+* Purpose
+* =======
+*
+* DSBMV performs the matrix-vector operation
+*
+* y := alpha*A*x + beta*y,
+*
+* where alpha and beta are scalars, x and y are n element vectors and
+* A is an n by n symmetric band matrix, with k super-diagonals.
+*
+* Arguments
+* ==========
+*
+* UPLO - CHARACTER*1.
+* On entry, UPLO specifies whether the upper or lower
+* triangular part of the band matrix A is being supplied as
+* follows:
+*
+* UPLO = 'U' or 'u' The upper triangular part of A is
+* being supplied.
+*
+* UPLO = 'L' or 'l' The lower triangular part of A is
+* being supplied.
+*
+* Unchanged on exit.
+*
+* N - INTEGER.
+* On entry, N specifies the order of the matrix A.
+* N must be at least zero.
+* Unchanged on exit.
+*
+* K - INTEGER.
+* On entry, K specifies the number of super-diagonals of the
+* matrix A. K must satisfy 0 .le. K.
+* Unchanged on exit.
+*
+* ALPHA - DOUBLE PRECISION.
+* On entry, ALPHA specifies the scalar alpha.
+* Unchanged on exit.
+*
+* A - DOUBLE PRECISION array of DIMENSION ( LDA, n ).
+* Before entry with UPLO = 'U' or 'u', the leading ( k + 1 )
+* by n part of the array A must contain the upper triangular
+* band part of the symmetric matrix, supplied column by
+* column, with the leading diagonal of the matrix in row
+* ( k + 1 ) of the array, the first super-diagonal starting at
+* position 2 in row k, and so on. The top left k by k triangle
+* of the array A is not referenced.
+* The following program segment will transfer the upper
+* triangular part of a symmetric band matrix from conventional
+* full matrix storage to band storage:
+*
+* DO 20, J = 1, N
+* M = K + 1 - J
+* DO 10, I = MAX( 1, J - K ), J
+* A( M + I, J ) = matrix( I, J )
+* 10 CONTINUE
+* 20 CONTINUE
+*
+* Before entry with UPLO = 'L' or 'l', the leading ( k + 1 )
+* by n part of the array A must contain the lower triangular
+* band part of the symmetric matrix, supplied column by
+* column, with the leading diagonal of the matrix in row 1 of
+* the array, the first sub-diagonal starting at position 1 in
+* row 2, and so on. The bottom right k by k triangle of the
+* array A is not referenced.
+* The following program segment will transfer the lower
+* triangular part of a symmetric band matrix from conventional
+* full matrix storage to band storage:
+*
+* DO 20, J = 1, N
+* M = 1 - J
+* DO 10, I = J, MIN( N, J + K )
+* A( M + I, J ) = matrix( I, J )
+* 10 CONTINUE
+* 20 CONTINUE
+*
+* Unchanged on exit.
+*
+* LDA - INTEGER.
+* On entry, LDA specifies the first dimension of A as declared
+* in the calling (sub) program. LDA must be at least
+* ( k + 1 ).
+* Unchanged on exit.
+*
+* X - DOUBLE PRECISION array of DIMENSION at least
+* ( 1 + ( n - 1 )*abs( INCX ) ).
+* Before entry, the incremented array X must contain the
+* vector x.
+* Unchanged on exit.
+*
+* INCX - INTEGER.
+* On entry, INCX specifies the increment for the elements of
+* X. INCX must not be zero.
+* Unchanged on exit.
+*
+* BETA - DOUBLE PRECISION.
+* On entry, BETA specifies the scalar beta.
+* Unchanged on exit.
+*
+* Y - DOUBLE PRECISION array of DIMENSION at least
+* ( 1 + ( n - 1 )*abs( INCY ) ).
+* Before entry, the incremented array Y must contain the
+* vector y. On exit, Y is overwritten by the updated vector y.
+*
+* INCY - INTEGER.
+* On entry, INCY specifies the increment for the elements of
+* Y. INCY must not be zero.
+* Unchanged on exit.
+*
+*
+* Level 2 Blas routine.
+*
+* -- Written on 22-October-1986.
+* Jack Dongarra, Argonne National Lab.
+* Jeremy Du Croz, Nag Central Office.
+* Sven Hammarling, Nag Central Office.
+* Richard Hanson, Sandia National Labs.
+*
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE,ZERO
+ PARAMETER (ONE=1.0D+0,ZERO=0.0D+0)
+* ..
+* .. Local Scalars ..
+ DOUBLE PRECISION TEMP1,TEMP2
+ INTEGER I,INFO,IX,IY,J,JX,JY,KPLUS1,KX,KY,L
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX,MIN
+* ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN
+ INFO = 1
+ ELSE IF (N.LT.0) THEN
+ INFO = 2
+ ELSE IF (K.LT.0) THEN
+ INFO = 3
+ ELSE IF (LDA.LT. (K+1)) THEN
+ INFO = 6
+ ELSE IF (INCX.EQ.0) THEN
+ INFO = 8
+ ELSE IF (INCY.EQ.0) THEN
+ INFO = 11
+ END IF
+ IF (INFO.NE.0) THEN
+ CALL XERBLA('DSBMV ',INFO)
+ RETURN
+ END IF
+*
+* Quick return if possible.
+*
+ IF ((N.EQ.0) .OR. ((ALPHA.EQ.ZERO).AND. (BETA.EQ.ONE))) RETURN
+*
+* Set up the start points in X and Y.
+*
+ IF (INCX.GT.0) THEN
+ KX = 1
+ ELSE
+ KX = 1 - (N-1)*INCX
+ END IF
+ IF (INCY.GT.0) THEN
+ KY = 1
+ ELSE
+ KY = 1 - (N-1)*INCY
+ END IF
+*
+* Start the operations. In this version the elements of the array A
+* are accessed sequentially with one pass through A.
+*
+* First form y := beta*y.
+*
+ IF (BETA.NE.ONE) THEN
+ IF (INCY.EQ.1) THEN
+ IF (BETA.EQ.ZERO) THEN
+ DO 10 I = 1,N
+ Y(I) = ZERO
+ 10 CONTINUE
+ ELSE
+ DO 20 I = 1,N
+ Y(I) = BETA*Y(I)
+ 20 CONTINUE
+ END IF
+ ELSE
+ IY = KY
+ IF (BETA.EQ.ZERO) THEN
+ DO 30 I = 1,N
+ Y(IY) = ZERO
+ IY = IY + INCY
+ 30 CONTINUE
+ ELSE
+ DO 40 I = 1,N
+ Y(IY) = BETA*Y(IY)
+ IY = IY + INCY
+ 40 CONTINUE
+ END IF
+ END IF
+ END IF
+ IF (ALPHA.EQ.ZERO) RETURN
+ IF (LSAME(UPLO,'U')) THEN
+*
+* Form y when upper triangle of A is stored.
+*
+ KPLUS1 = K + 1
+ IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
+ DO 60 J = 1,N
+ TEMP1 = ALPHA*X(J)
+ TEMP2 = ZERO
+ L = KPLUS1 - J
+ DO 50 I = MAX(1,J-K),J - 1
+ Y(I) = Y(I) + TEMP1*A(L+I,J)
+ TEMP2 = TEMP2 + A(L+I,J)*X(I)
+ 50 CONTINUE
+ Y(J) = Y(J) + TEMP1*A(KPLUS1,J) + ALPHA*TEMP2
+ 60 CONTINUE
+ ELSE
+ JX = KX
+ JY = KY
+ DO 80 J = 1,N
+ TEMP1 = ALPHA*X(JX)
+ TEMP2 = ZERO
+ IX = KX
+ IY = KY
+ L = KPLUS1 - J
+ DO 70 I = MAX(1,J-K),J - 1
+ Y(IY) = Y(IY) + TEMP1*A(L+I,J)
+ TEMP2 = TEMP2 + A(L+I,J)*X(IX)
+ IX = IX + INCX
+ IY = IY + INCY
+ 70 CONTINUE
+ Y(JY) = Y(JY) + TEMP1*A(KPLUS1,J) + ALPHA*TEMP2
+ JX = JX + INCX
+ JY = JY + INCY
+ IF (J.GT.K) THEN
+ KX = KX + INCX
+ KY = KY + INCY
+ END IF
+ 80 CONTINUE
+ END IF
+ ELSE
+*
+* Form y when lower triangle of A is stored.
+*
+ IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
+ DO 100 J = 1,N
+ TEMP1 = ALPHA*X(J)
+ TEMP2 = ZERO
+ Y(J) = Y(J) + TEMP1*A(1,J)
+ L = 1 - J
+ DO 90 I = J + 1,MIN(N,J+K)
+ Y(I) = Y(I) + TEMP1*A(L+I,J)
+ TEMP2 = TEMP2 + A(L+I,J)*X(I)
+ 90 CONTINUE
+ Y(J) = Y(J) + ALPHA*TEMP2
+ 100 CONTINUE
+ ELSE
+ JX = KX
+ JY = KY
+ DO 120 J = 1,N
+ TEMP1 = ALPHA*X(JX)
+ TEMP2 = ZERO
+ Y(JY) = Y(JY) + TEMP1*A(1,J)
+ L = 1 - J
+ IX = JX
+ IY = JY
+ DO 110 I = J + 1,MIN(N,J+K)
+ IX = IX + INCX
+ IY = IY + INCY
+ Y(IY) = Y(IY) + TEMP1*A(L+I,J)
+ TEMP2 = TEMP2 + A(L+I,J)*X(IX)
+ 110 CONTINUE
+ Y(JY) = Y(JY) + ALPHA*TEMP2
+ JX = JX + INCX
+ JY = JY + INCY
+ 120 CONTINUE
+ END IF
+ END IF
+*
+ RETURN
+*
+* End of DSBMV .
+*
+ END
+ SUBROUTINE DSCAL(N,DA,DX,INCX)
+* .. Scalar Arguments ..
+ DOUBLE PRECISION DA
+ INTEGER INCX,N
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION DX(*)
+* ..
+*
+* Purpose
+* =======
+**
+* scales a vector by a constant.
+* uses unrolled loops for increment equal to one.
+* jack dongarra, linpack, 3/11/78.
+* modified 3/93 to return if incx .le. 0.
+* modified 12/3/93, array(1) declarations changed to array(*)
+*
+*
+* .. Local Scalars ..
+ INTEGER I,M,MP1,NINCX
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MOD
+* ..
+ IF (N.LE.0 .OR. INCX.LE.0) RETURN
+ IF (INCX.EQ.1) GO TO 20
+*
+* code for increment not equal to 1
+*
+ NINCX = N*INCX
+ DO 10 I = 1,NINCX,INCX
+ DX(I) = DA*DX(I)
+ 10 CONTINUE
+ RETURN
+*
+* code for increment equal to 1
+*
+*
+* clean-up loop
+*
+ 20 M = MOD(N,5)
+ IF (M.EQ.0) GO TO 40
+ DO 30 I = 1,M
+ DX(I) = DA*DX(I)
+ 30 CONTINUE
+ IF (N.LT.5) RETURN
+ 40 MP1 = M + 1
+ DO 50 I = MP1,N,5
+ DX(I) = DA*DX(I)
+ DX(I+1) = DA*DX(I+1)
+ DX(I+2) = DA*DX(I+2)
+ DX(I+3) = DA*DX(I+3)
+ DX(I+4) = DA*DX(I+4)
+ 50 CONTINUE
+ RETURN
+ END
+ SUBROUTINE DSPMV(UPLO,N,ALPHA,AP,X,INCX,BETA,Y,INCY)
+* .. Scalar Arguments ..
+ DOUBLE PRECISION ALPHA,BETA
+ INTEGER INCX,INCY,N
+ CHARACTER UPLO
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION AP(*),X(*),Y(*)
+* ..
+*
+* Purpose
+* =======
+*
+* DSPMV performs the matrix-vector operation
+*
+* y := alpha*A*x + beta*y,
+*
+* where alpha and beta are scalars, x and y are n element vectors and
+* A is an n by n symmetric matrix, supplied in packed form.
+*
+* Arguments
+* ==========
+*
+* UPLO - CHARACTER*1.
+* On entry, UPLO specifies whether the upper or lower
+* triangular part of the matrix A is supplied in the packed
+* array AP as follows:
+*
+* UPLO = 'U' or 'u' The upper triangular part of A is
+* supplied in AP.
+*
+* UPLO = 'L' or 'l' The lower triangular part of A is
+* supplied in AP.
+*
+* Unchanged on exit.
+*
+* N - INTEGER.
+* On entry, N specifies the order of the matrix A.
+* N must be at least zero.
+* Unchanged on exit.
+*
+* ALPHA - DOUBLE PRECISION.
+* On entry, ALPHA specifies the scalar alpha.
+* Unchanged on exit.
+*
+* AP - DOUBLE PRECISION array of DIMENSION at least
+* ( ( n*( n + 1 ) )/2 ).
+* Before entry with UPLO = 'U' or 'u', the array AP must
+* contain the upper triangular part of the symmetric matrix
+* packed sequentially, column by column, so that AP( 1 )
+* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 )
+* and a( 2, 2 ) respectively, and so on.
+* Before entry with UPLO = 'L' or 'l', the array AP must
+* contain the lower triangular part of the symmetric matrix
+* packed sequentially, column by column, so that AP( 1 )
+* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 )
+* and a( 3, 1 ) respectively, and so on.
+* Unchanged on exit.
+*
+* X - DOUBLE PRECISION array of dimension at least
+* ( 1 + ( n - 1 )*abs( INCX ) ).
+* Before entry, the incremented array X must contain the n
+* element vector x.
+* Unchanged on exit.
+*
+* INCX - INTEGER.
+* On entry, INCX specifies the increment for the elements of
+* X. INCX must not be zero.
+* Unchanged on exit.
+*
+* BETA - DOUBLE PRECISION.
+* On entry, BETA specifies the scalar beta. When BETA is
+* supplied as zero then Y need not be set on input.
+* Unchanged on exit.
+*
+* Y - DOUBLE PRECISION array of dimension at least
+* ( 1 + ( n - 1 )*abs( INCY ) ).
+* Before entry, the incremented array Y must contain the n
+* element vector y. On exit, Y is overwritten by the updated
+* vector y.
+*
+* INCY - INTEGER.
+* On entry, INCY specifies the increment for the elements of
+* Y. INCY must not be zero.
+* Unchanged on exit.
+*
+*
+* Level 2 Blas routine.
+*
+* -- Written on 22-October-1986.
+* Jack Dongarra, Argonne National Lab.
+* Jeremy Du Croz, Nag Central Office.
+* Sven Hammarling, Nag Central Office.
+* Richard Hanson, Sandia National Labs.
+*
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE,ZERO
+ PARAMETER (ONE=1.0D+0,ZERO=0.0D+0)
+* ..
+* .. Local Scalars ..
+ DOUBLE PRECISION TEMP1,TEMP2
+ INTEGER I,INFO,IX,IY,J,JX,JY,K,KK,KX,KY
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL XERBLA
+* ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN
+ INFO = 1
+ ELSE IF (N.LT.0) THEN
+ INFO = 2
+ ELSE IF (INCX.EQ.0) THEN
+ INFO = 6
+ ELSE IF (INCY.EQ.0) THEN
+ INFO = 9
+ END IF
+ IF (INFO.NE.0) THEN
+ CALL XERBLA('DSPMV ',INFO)
+ RETURN
+ END IF
+*
+* Quick return if possible.
+*
+ IF ((N.EQ.0) .OR. ((ALPHA.EQ.ZERO).AND. (BETA.EQ.ONE))) RETURN
+*
+* Set up the start points in X and Y.
+*
+ IF (INCX.GT.0) THEN
+ KX = 1
+ ELSE
+ KX = 1 - (N-1)*INCX
+ END IF
+ IF (INCY.GT.0) THEN
+ KY = 1
+ ELSE
+ KY = 1 - (N-1)*INCY
+ END IF
+*
+* Start the operations. In this version the elements of the array AP
+* are accessed sequentially with one pass through AP.
+*
+* First form y := beta*y.
+*
+ IF (BETA.NE.ONE) THEN
+ IF (INCY.EQ.1) THEN
+ IF (BETA.EQ.ZERO) THEN
+ DO 10 I = 1,N
+ Y(I) = ZERO
+ 10 CONTINUE
+ ELSE
+ DO 20 I = 1,N
+ Y(I) = BETA*Y(I)
+ 20 CONTINUE
+ END IF
+ ELSE
+ IY = KY
+ IF (BETA.EQ.ZERO) THEN
+ DO 30 I = 1,N
+ Y(IY) = ZERO
+ IY = IY + INCY
+ 30 CONTINUE
+ ELSE
+ DO 40 I = 1,N
+ Y(IY) = BETA*Y(IY)
+ IY = IY + INCY
+ 40 CONTINUE
+ END IF
+ END IF
+ END IF
+ IF (ALPHA.EQ.ZERO) RETURN
+ KK = 1
+ IF (LSAME(UPLO,'U')) THEN
+*
+* Form y when AP contains the upper triangle.
+*
+ IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
+ DO 60 J = 1,N
+ TEMP1 = ALPHA*X(J)
+ TEMP2 = ZERO
+ K = KK
+ DO 50 I = 1,J - 1
+ Y(I) = Y(I) + TEMP1*AP(K)
+ TEMP2 = TEMP2 + AP(K)*X(I)
+ K = K + 1
+ 50 CONTINUE
+ Y(J) = Y(J) + TEMP1*AP(KK+J-1) + ALPHA*TEMP2
+ KK = KK + J
+ 60 CONTINUE
+ ELSE
+ JX = KX
+ JY = KY
+ DO 80 J = 1,N
+ TEMP1 = ALPHA*X(JX)
+ TEMP2 = ZERO
+ IX = KX
+ IY = KY
+ DO 70 K = KK,KK + J - 2
+ Y(IY) = Y(IY) + TEMP1*AP(K)
+ TEMP2 = TEMP2 + AP(K)*X(IX)
+ IX = IX + INCX
+ IY = IY + INCY
+ 70 CONTINUE
+ Y(JY) = Y(JY) + TEMP1*AP(KK+J-1) + ALPHA*TEMP2
+ JX = JX + INCX
+ JY = JY + INCY
+ KK = KK + J
+ 80 CONTINUE
+ END IF
+ ELSE
+*
+* Form y when AP contains the lower triangle.
+*
+ IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
+ DO 100 J = 1,N
+ TEMP1 = ALPHA*X(J)
+ TEMP2 = ZERO
+ Y(J) = Y(J) + TEMP1*AP(KK)
+ K = KK + 1
+ DO 90 I = J + 1,N
+ Y(I) = Y(I) + TEMP1*AP(K)
+ TEMP2 = TEMP2 + AP(K)*X(I)
+ K = K + 1
+ 90 CONTINUE
+ Y(J) = Y(J) + ALPHA*TEMP2
+ KK = KK + (N-J+1)
+ 100 CONTINUE
+ ELSE
+ JX = KX
+ JY = KY
+ DO 120 J = 1,N
+ TEMP1 = ALPHA*X(JX)
+ TEMP2 = ZERO
+ Y(JY) = Y(JY) + TEMP1*AP(KK)
+ IX = JX
+ IY = JY
+ DO 110 K = KK + 1,KK + N - J
+ IX = IX + INCX
+ IY = IY + INCY
+ Y(IY) = Y(IY) + TEMP1*AP(K)
+ TEMP2 = TEMP2 + AP(K)*X(IX)
+ 110 CONTINUE
+ Y(JY) = Y(JY) + ALPHA*TEMP2
+ JX = JX + INCX
+ JY = JY + INCY
+ KK = KK + (N-J+1)
+ 120 CONTINUE
+ END IF
+ END IF
+*
+ RETURN
+*
+* End of DSPMV .
+*
+ END
+ SUBROUTINE DSPR(UPLO,N,ALPHA,X,INCX,AP)
+* .. Scalar Arguments ..
+ DOUBLE PRECISION ALPHA
+ INTEGER INCX,N
+ CHARACTER UPLO
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION AP(*),X(*)
+* ..
+*
+* Purpose
+* =======
+*
+* DSPR performs the symmetric rank 1 operation
+*
+* A := alpha*x*x' + A,
+*
+* where alpha is a real scalar, x is an n element vector and A is an
+* n by n symmetric matrix, supplied in packed form.
+*
+* Arguments
+* ==========
+*
+* UPLO - CHARACTER*1.
+* On entry, UPLO specifies whether the upper or lower
+* triangular part of the matrix A is supplied in the packed
+* array AP as follows:
+*
+* UPLO = 'U' or 'u' The upper triangular part of A is
+* supplied in AP.
+*
+* UPLO = 'L' or 'l' The lower triangular part of A is
+* supplied in AP.
+*
+* Unchanged on exit.
+*
+* N - INTEGER.
+* On entry, N specifies the order of the matrix A.
+* N must be at least zero.
+* Unchanged on exit.
+*
+* ALPHA - DOUBLE PRECISION.
+* On entry, ALPHA specifies the scalar alpha.
+* Unchanged on exit.
+*
+* X - DOUBLE PRECISION array of dimension at least
+* ( 1 + ( n - 1 )*abs( INCX ) ).
+* Before entry, the incremented array X must contain the n
+* element vector x.
+* Unchanged on exit.
+*
+* INCX - INTEGER.
+* On entry, INCX specifies the increment for the elements of
+* X. INCX must not be zero.
+* Unchanged on exit.
+*
+* AP - DOUBLE PRECISION array of DIMENSION at least
+* ( ( n*( n + 1 ) )/2 ).
+* Before entry with UPLO = 'U' or 'u', the array AP must
+* contain the upper triangular part of the symmetric matrix
+* packed sequentially, column by column, so that AP( 1 )
+* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 )
+* and a( 2, 2 ) respectively, and so on. On exit, the array
+* AP is overwritten by the upper triangular part of the
+* updated matrix.
+* Before entry with UPLO = 'L' or 'l', the array AP must
+* contain the lower triangular part of the symmetric matrix
+* packed sequentially, column by column, so that AP( 1 )
+* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 )
+* and a( 3, 1 ) respectively, and so on. On exit, the array
+* AP is overwritten by the lower triangular part of the
+* updated matrix.
+*
+*
+* Level 2 Blas routine.
+*
+* -- Written on 22-October-1986.
+* Jack Dongarra, Argonne National Lab.
+* Jeremy Du Croz, Nag Central Office.
+* Sven Hammarling, Nag Central Office.
+* Richard Hanson, Sandia National Labs.
+*
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO
+ PARAMETER (ZERO=0.0D+0)
+* ..
+* .. Local Scalars ..
+ DOUBLE PRECISION TEMP
+ INTEGER I,INFO,IX,J,JX,K,KK,KX
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL XERBLA
+* ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN
+ INFO = 1
+ ELSE IF (N.LT.0) THEN
+ INFO = 2
+ ELSE IF (INCX.EQ.0) THEN
+ INFO = 5
+ END IF
+ IF (INFO.NE.0) THEN
+ CALL XERBLA('DSPR ',INFO)
+ RETURN
+ END IF
+*
+* Quick return if possible.
+*
+ IF ((N.EQ.0) .OR. (ALPHA.EQ.ZERO)) RETURN
+*
+* Set the start point in X if the increment is not unity.
+*
+ IF (INCX.LE.0) THEN
+ KX = 1 - (N-1)*INCX
+ ELSE IF (INCX.NE.1) THEN
+ KX = 1
+ END IF
+*
+* Start the operations. In this version the elements of the array AP
+* are accessed sequentially with one pass through AP.
+*
+ KK = 1
+ IF (LSAME(UPLO,'U')) THEN
+*
+* Form A when upper triangle is stored in AP.
+*
+ IF (INCX.EQ.1) THEN
+ DO 20 J = 1,N
+ IF (X(J).NE.ZERO) THEN
+ TEMP = ALPHA*X(J)
+ K = KK
+ DO 10 I = 1,J
+ AP(K) = AP(K) + X(I)*TEMP
+ K = K + 1
+ 10 CONTINUE
+ END IF
+ KK = KK + J
+ 20 CONTINUE
+ ELSE
+ JX = KX
+ DO 40 J = 1,N
+ IF (X(JX).NE.ZERO) THEN
+ TEMP = ALPHA*X(JX)
+ IX = KX
+ DO 30 K = KK,KK + J - 1
+ AP(K) = AP(K) + X(IX)*TEMP
+ IX = IX + INCX
+ 30 CONTINUE
+ END IF
+ JX = JX + INCX
+ KK = KK + J
+ 40 CONTINUE
+ END IF
+ ELSE
+*
+* Form A when lower triangle is stored in AP.
+*
+ IF (INCX.EQ.1) THEN
+ DO 60 J = 1,N
+ IF (X(J).NE.ZERO) THEN
+ TEMP = ALPHA*X(J)
+ K = KK
+ DO 50 I = J,N
+ AP(K) = AP(K) + X(I)*TEMP
+ K = K + 1
+ 50 CONTINUE
+ END IF
+ KK = KK + N - J + 1
+ 60 CONTINUE
+ ELSE
+ JX = KX
+ DO 80 J = 1,N
+ IF (X(JX).NE.ZERO) THEN
+ TEMP = ALPHA*X(JX)
+ IX = JX
+ DO 70 K = KK,KK + N - J
+ AP(K) = AP(K) + X(IX)*TEMP
+ IX = IX + INCX
+ 70 CONTINUE
+ END IF
+ JX = JX + INCX
+ KK = KK + N - J + 1
+ 80 CONTINUE
+ END IF
+ END IF
+*
+ RETURN
+*
+* End of DSPR .
+*
+ END
+ SUBROUTINE DSPR2(UPLO,N,ALPHA,X,INCX,Y,INCY,AP)
+* .. Scalar Arguments ..
+ DOUBLE PRECISION ALPHA
+ INTEGER INCX,INCY,N
+ CHARACTER UPLO
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION AP(*),X(*),Y(*)
+* ..
+*
+* Purpose
+* =======
+*
+* DSPR2 performs the symmetric rank 2 operation
+*
+* A := alpha*x*y' + alpha*y*x' + A,
+*
+* where alpha is a scalar, x and y are n element vectors and A is an
+* n by n symmetric matrix, supplied in packed form.
+*
+* Arguments
+* ==========
+*
+* UPLO - CHARACTER*1.
+* On entry, UPLO specifies whether the upper or lower
+* triangular part of the matrix A is supplied in the packed
+* array AP as follows:
+*
+* UPLO = 'U' or 'u' The upper triangular part of A is
+* supplied in AP.
+*
+* UPLO = 'L' or 'l' The lower triangular part of A is
+* supplied in AP.
+*
+* Unchanged on exit.
+*
+* N - INTEGER.
+* On entry, N specifies the order of the matrix A.
+* N must be at least zero.
+* Unchanged on exit.
+*
+* ALPHA - DOUBLE PRECISION.
+* On entry, ALPHA specifies the scalar alpha.
+* Unchanged on exit.
+*
+* X - DOUBLE PRECISION array of dimension at least
+* ( 1 + ( n - 1 )*abs( INCX ) ).
+* Before entry, the incremented array X must contain the n
+* element vector x.
+* Unchanged on exit.
+*
+* INCX - INTEGER.
+* On entry, INCX specifies the increment for the elements of
+* X. INCX must not be zero.
+* Unchanged on exit.
+*
+* Y - DOUBLE PRECISION array of dimension at least
+* ( 1 + ( n - 1 )*abs( INCY ) ).
+* Before entry, the incremented array Y must contain the n
+* element vector y.
+* Unchanged on exit.
+*
+* INCY - INTEGER.
+* On entry, INCY specifies the increment for the elements of
+* Y. INCY must not be zero.
+* Unchanged on exit.
+*
+* AP - DOUBLE PRECISION array of DIMENSION at least
+* ( ( n*( n + 1 ) )/2 ).
+* Before entry with UPLO = 'U' or 'u', the array AP must
+* contain the upper triangular part of the symmetric matrix
+* packed sequentially, column by column, so that AP( 1 )
+* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 )
+* and a( 2, 2 ) respectively, and so on. On exit, the array
+* AP is overwritten by the upper triangular part of the
+* updated matrix.
+* Before entry with UPLO = 'L' or 'l', the array AP must
+* contain the lower triangular part of the symmetric matrix
+* packed sequentially, column by column, so that AP( 1 )
+* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 )
+* and a( 3, 1 ) respectively, and so on. On exit, the array
+* AP is overwritten by the lower triangular part of the
+* updated matrix.
+*
+*
+* Level 2 Blas routine.
+*
+* -- Written on 22-October-1986.
+* Jack Dongarra, Argonne National Lab.
+* Jeremy Du Croz, Nag Central Office.
+* Sven Hammarling, Nag Central Office.
+* Richard Hanson, Sandia National Labs.
+*
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO
+ PARAMETER (ZERO=0.0D+0)
+* ..
+* .. Local Scalars ..
+ DOUBLE PRECISION TEMP1,TEMP2
+ INTEGER I,INFO,IX,IY,J,JX,JY,K,KK,KX,KY
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL XERBLA
+* ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN
+ INFO = 1
+ ELSE IF (N.LT.0) THEN
+ INFO = 2
+ ELSE IF (INCX.EQ.0) THEN
+ INFO = 5
+ ELSE IF (INCY.EQ.0) THEN
+ INFO = 7
+ END IF
+ IF (INFO.NE.0) THEN
+ CALL XERBLA('DSPR2 ',INFO)
+ RETURN
+ END IF
+*
+* Quick return if possible.
+*
+ IF ((N.EQ.0) .OR. (ALPHA.EQ.ZERO)) RETURN
+*
+* Set up the start points in X and Y if the increments are not both
+* unity.
+*
+ IF ((INCX.NE.1) .OR. (INCY.NE.1)) THEN
+ IF (INCX.GT.0) THEN
+ KX = 1
+ ELSE
+ KX = 1 - (N-1)*INCX
+ END IF
+ IF (INCY.GT.0) THEN
+ KY = 1
+ ELSE
+ KY = 1 - (N-1)*INCY
+ END IF
+ JX = KX
+ JY = KY
+ END IF
+*
+* Start the operations. In this version the elements of the array AP
+* are accessed sequentially with one pass through AP.
+*
+ KK = 1
+ IF (LSAME(UPLO,'U')) THEN
+*
+* Form A when upper triangle is stored in AP.
+*
+ IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
+ DO 20 J = 1,N
+ IF ((X(J).NE.ZERO) .OR. (Y(J).NE.ZERO)) THEN
+ TEMP1 = ALPHA*Y(J)
+ TEMP2 = ALPHA*X(J)
+ K = KK
+ DO 10 I = 1,J
+ AP(K) = AP(K) + X(I)*TEMP1 + Y(I)*TEMP2
+ K = K + 1
+ 10 CONTINUE
+ END IF
+ KK = KK + J
+ 20 CONTINUE
+ ELSE
+ DO 40 J = 1,N
+ IF ((X(JX).NE.ZERO) .OR. (Y(JY).NE.ZERO)) THEN
+ TEMP1 = ALPHA*Y(JY)
+ TEMP2 = ALPHA*X(JX)
+ IX = KX
+ IY = KY
+ DO 30 K = KK,KK + J - 1
+ AP(K) = AP(K) + X(IX)*TEMP1 + Y(IY)*TEMP2
+ IX = IX + INCX
+ IY = IY + INCY
+ 30 CONTINUE
+ END IF
+ JX = JX + INCX
+ JY = JY + INCY
+ KK = KK + J
+ 40 CONTINUE
+ END IF
+ ELSE
+*
+* Form A when lower triangle is stored in AP.
+*
+ IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
+ DO 60 J = 1,N
+ IF ((X(J).NE.ZERO) .OR. (Y(J).NE.ZERO)) THEN
+ TEMP1 = ALPHA*Y(J)
+ TEMP2 = ALPHA*X(J)
+ K = KK
+ DO 50 I = J,N
+ AP(K) = AP(K) + X(I)*TEMP1 + Y(I)*TEMP2
+ K = K + 1
+ 50 CONTINUE
+ END IF
+ KK = KK + N - J + 1
+ 60 CONTINUE
+ ELSE
+ DO 80 J = 1,N
+ IF ((X(JX).NE.ZERO) .OR. (Y(JY).NE.ZERO)) THEN
+ TEMP1 = ALPHA*Y(JY)
+ TEMP2 = ALPHA*X(JX)
+ IX = JX
+ IY = JY
+ DO 70 K = KK,KK + N - J
+ AP(K) = AP(K) + X(IX)*TEMP1 + Y(IY)*TEMP2
+ IX = IX + INCX
+ IY = IY + INCY
+ 70 CONTINUE
+ END IF
+ JX = JX + INCX
+ JY = JY + INCY
+ KK = KK + N - J + 1
+ 80 CONTINUE
+ END IF
+ END IF
+*
+ RETURN
+*
+* End of DSPR2 .
+*
+ END
+ SUBROUTINE DSWAP(N,DX,INCX,DY,INCY)
+* .. Scalar Arguments ..
+ INTEGER INCX,INCY,N
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION DX(*),DY(*)
+* ..
+*
+* Purpose
+* =======
+*
+* interchanges two vectors.
+* uses unrolled loops for increments equal one.
+* jack dongarra, linpack, 3/11/78.
+* modified 12/3/93, array(1) declarations changed to array(*)
+*
+*
+* .. Local Scalars ..
+ DOUBLE PRECISION DTEMP
+ INTEGER I,IX,IY,M,MP1
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MOD
+* ..
+ IF (N.LE.0) RETURN
+ IF (INCX.EQ.1 .AND. INCY.EQ.1) GO TO 20
+*
+* code for unequal increments or equal increments not equal
+* to 1
+*
+ IX = 1
+ IY = 1
+ IF (INCX.LT.0) IX = (-N+1)*INCX + 1
+ IF (INCY.LT.0) IY = (-N+1)*INCY + 1
+ DO 10 I = 1,N
+ DTEMP = DX(IX)
+ DX(IX) = DY(IY)
+ DY(IY) = DTEMP
+ IX = IX + INCX
+ IY = IY + INCY
+ 10 CONTINUE
+ RETURN
+*
+* code for both increments equal to 1
+*
+*
+* clean-up loop
+*
+ 20 M = MOD(N,3)
+ IF (M.EQ.0) GO TO 40
+ DO 30 I = 1,M
+ DTEMP = DX(I)
+ DX(I) = DY(I)
+ DY(I) = DTEMP
+ 30 CONTINUE
+ IF (N.LT.3) RETURN
+ 40 MP1 = M + 1
+ DO 50 I = MP1,N,3
+ DTEMP = DX(I)
+ DX(I) = DY(I)
+ DY(I) = DTEMP
+ DTEMP = DX(I+1)
+ DX(I+1) = DY(I+1)
+ DY(I+1) = DTEMP
+ DTEMP = DX(I+2)
+ DX(I+2) = DY(I+2)
+ DY(I+2) = DTEMP
+ 50 CONTINUE
+ RETURN
+ END
+ SUBROUTINE DSYMM(SIDE,UPLO,M,N,ALPHA,A,LDA,B,LDB,BETA,C,LDC)
+* .. Scalar Arguments ..
+ DOUBLE PRECISION ALPHA,BETA
+ INTEGER LDA,LDB,LDC,M,N
+ CHARACTER SIDE,UPLO
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION A(LDA,*),B(LDB,*),C(LDC,*)
+* ..
+*
+* Purpose
+* =======
+*
+* DSYMM performs one of the matrix-matrix operations
+*
+* C := alpha*A*B + beta*C,
+*
+* or
+*
+* C := alpha*B*A + beta*C,
+*
+* where alpha and beta are scalars, A is a symmetric matrix and B and
+* C are m by n matrices.
+*
+* Arguments
+* ==========
+*
+* SIDE - CHARACTER*1.
+* On entry, SIDE specifies whether the symmetric matrix A
+* appears on the left or right in the operation as follows:
+*
+* SIDE = 'L' or 'l' C := alpha*A*B + beta*C,
+*
+* SIDE = 'R' or 'r' C := alpha*B*A + beta*C,
+*
+* Unchanged on exit.
+*
+* UPLO - CHARACTER*1.
+* On entry, UPLO specifies whether the upper or lower
+* triangular part of the symmetric matrix A is to be
+* referenced as follows:
+*
+* UPLO = 'U' or 'u' Only the upper triangular part of the
+* symmetric matrix is to be referenced.
+*
+* UPLO = 'L' or 'l' Only the lower triangular part of the
+* symmetric matrix is to be referenced.
+*
+* Unchanged on exit.
+*
+* M - INTEGER.
+* On entry, M specifies the number of rows of the matrix C.
+* M must be at least zero.
+* Unchanged on exit.
+*
+* N - INTEGER.
+* On entry, N specifies the number of columns of the matrix C.
+* N must be at least zero.
+* Unchanged on exit.
+*
+* ALPHA - DOUBLE PRECISION.
+* On entry, ALPHA specifies the scalar alpha.
+* Unchanged on exit.
+*
+* A - DOUBLE PRECISION array of DIMENSION ( LDA, ka ), where ka is
+* m when SIDE = 'L' or 'l' and is n otherwise.
+* Before entry with SIDE = 'L' or 'l', the m by m part of
+* the array A must contain the symmetric matrix, such that
+* when UPLO = 'U' or 'u', the leading m by m upper triangular
+* part of the array A must contain the upper triangular part
+* of the symmetric matrix and the strictly lower triangular
+* part of A is not referenced, and when UPLO = 'L' or 'l',
+* the leading m by m lower triangular part of the array A
+* must contain the lower triangular part of the symmetric
+* matrix and the strictly upper triangular part of A is not
+* referenced.
+* Before entry with SIDE = 'R' or 'r', the n by n part of
+* the array A must contain the symmetric matrix, such that
+* when UPLO = 'U' or 'u', the leading n by n upper triangular
+* part of the array A must contain the upper triangular part
+* of the symmetric matrix and the strictly lower triangular
+* part of A is not referenced, and when UPLO = 'L' or 'l',
+* the leading n by n lower triangular part of the array A
+* must contain the lower triangular part of the symmetric
+* matrix and the strictly upper triangular part of A is not
+* referenced.
+* Unchanged on exit.
+*
+* LDA - INTEGER.
+* On entry, LDA specifies the first dimension of A as declared
+* in the calling (sub) program. When SIDE = 'L' or 'l' then
+* LDA must be at least max( 1, m ), otherwise LDA must be at
+* least max( 1, n ).
+* Unchanged on exit.
+*
+* B - DOUBLE PRECISION array of DIMENSION ( LDB, n ).
+* Before entry, the leading m by n part of the array B must
+* contain the matrix B.
+* Unchanged on exit.
+*
+* LDB - INTEGER.
+* On entry, LDB specifies the first dimension of B as declared
+* in the calling (sub) program. LDB must be at least
+* max( 1, m ).
+* Unchanged on exit.
+*
+* BETA - DOUBLE PRECISION.
+* On entry, BETA specifies the scalar beta. When BETA is
+* supplied as zero then C need not be set on input.
+* Unchanged on exit.
+*
+* C - DOUBLE PRECISION array of DIMENSION ( LDC, n ).
+* Before entry, the leading m by n part of the array C must
+* contain the matrix C, except when beta is zero, in which
+* case C need not be set on entry.
+* On exit, the array C is overwritten by the m by n updated
+* matrix.
+*
+* LDC - INTEGER.
+* On entry, LDC specifies the first dimension of C as declared
+* in the calling (sub) program. LDC must be at least
+* max( 1, m ).
+* Unchanged on exit.
+*
+*
+* Level 3 Blas routine.
+*
+* -- Written on 8-February-1989.
+* Jack Dongarra, Argonne National Laboratory.
+* Iain Duff, AERE Harwell.
+* Jeremy Du Croz, Numerical Algorithms Group Ltd.
+* Sven Hammarling, Numerical Algorithms Group Ltd.
+*
+*
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Local Scalars ..
+ DOUBLE PRECISION TEMP1,TEMP2
+ INTEGER I,INFO,J,K,NROWA
+ LOGICAL UPPER
+* ..
+* .. Parameters ..
+ DOUBLE PRECISION ONE,ZERO
+ PARAMETER (ONE=1.0D+0,ZERO=0.0D+0)
+* ..
+*
+* Set NROWA as the number of rows of A.
+*
+ IF (LSAME(SIDE,'L')) THEN
+ NROWA = M
+ ELSE
+ NROWA = N
+ END IF
+ UPPER = LSAME(UPLO,'U')
+*
+* Test the input parameters.
+*
+ INFO = 0
+ IF ((.NOT.LSAME(SIDE,'L')) .AND. (.NOT.LSAME(SIDE,'R'))) THEN
+ INFO = 1
+ ELSE IF ((.NOT.UPPER) .AND. (.NOT.LSAME(UPLO,'L'))) THEN
+ INFO = 2
+ ELSE IF (M.LT.0) THEN
+ INFO = 3
+ ELSE IF (N.LT.0) THEN
+ INFO = 4
+ ELSE IF (LDA.LT.MAX(1,NROWA)) THEN
+ INFO = 7
+ ELSE IF (LDB.LT.MAX(1,M)) THEN
+ INFO = 9
+ ELSE IF (LDC.LT.MAX(1,M)) THEN
+ INFO = 12
+ END IF
+ IF (INFO.NE.0) THEN
+ CALL XERBLA('DSYMM ',INFO)
+ RETURN
+ END IF
+*
+* Quick return if possible.
+*
+ IF ((M.EQ.0) .OR. (N.EQ.0) .OR.
+ + ((ALPHA.EQ.ZERO).AND. (BETA.EQ.ONE))) RETURN
+*
+* And when alpha.eq.zero.
+*
+ IF (ALPHA.EQ.ZERO) THEN
+ IF (BETA.EQ.ZERO) THEN
+ DO 20 J = 1,N
+ DO 10 I = 1,M
+ C(I,J) = ZERO
+ 10 CONTINUE
+ 20 CONTINUE
+ ELSE
+ DO 40 J = 1,N
+ DO 30 I = 1,M
+ C(I,J) = BETA*C(I,J)
+ 30 CONTINUE
+ 40 CONTINUE
+ END IF
+ RETURN
+ END IF
+*
+* Start the operations.
+*
+ IF (LSAME(SIDE,'L')) THEN
+*
+* Form C := alpha*A*B + beta*C.
+*
+ IF (UPPER) THEN
+ DO 70 J = 1,N
+ DO 60 I = 1,M
+ TEMP1 = ALPHA*B(I,J)
+ TEMP2 = ZERO
+ DO 50 K = 1,I - 1
+ C(K,J) = C(K,J) + TEMP1*A(K,I)
+ TEMP2 = TEMP2 + B(K,J)*A(K,I)
+ 50 CONTINUE
+ IF (BETA.EQ.ZERO) THEN
+ C(I,J) = TEMP1*A(I,I) + ALPHA*TEMP2
+ ELSE
+ C(I,J) = BETA*C(I,J) + TEMP1*A(I,I) +
+ + ALPHA*TEMP2
+ END IF
+ 60 CONTINUE
+ 70 CONTINUE
+ ELSE
+ DO 100 J = 1,N
+ DO 90 I = M,1,-1
+ TEMP1 = ALPHA*B(I,J)
+ TEMP2 = ZERO
+ DO 80 K = I + 1,M
+ C(K,J) = C(K,J) + TEMP1*A(K,I)
+ TEMP2 = TEMP2 + B(K,J)*A(K,I)
+ 80 CONTINUE
+ IF (BETA.EQ.ZERO) THEN
+ C(I,J) = TEMP1*A(I,I) + ALPHA*TEMP2
+ ELSE
+ C(I,J) = BETA*C(I,J) + TEMP1*A(I,I) +
+ + ALPHA*TEMP2
+ END IF
+ 90 CONTINUE
+ 100 CONTINUE
+ END IF
+ ELSE
+*
+* Form C := alpha*B*A + beta*C.
+*
+ DO 170 J = 1,N
+ TEMP1 = ALPHA*A(J,J)
+ IF (BETA.EQ.ZERO) THEN
+ DO 110 I = 1,M
+ C(I,J) = TEMP1*B(I,J)
+ 110 CONTINUE
+ ELSE
+ DO 120 I = 1,M
+ C(I,J) = BETA*C(I,J) + TEMP1*B(I,J)
+ 120 CONTINUE
+ END IF
+ DO 140 K = 1,J - 1
+ IF (UPPER) THEN
+ TEMP1 = ALPHA*A(K,J)
+ ELSE
+ TEMP1 = ALPHA*A(J,K)
+ END IF
+ DO 130 I = 1,M
+ C(I,J) = C(I,J) + TEMP1*B(I,K)
+ 130 CONTINUE
+ 140 CONTINUE
+ DO 160 K = J + 1,N
+ IF (UPPER) THEN
+ TEMP1 = ALPHA*A(J,K)
+ ELSE
+ TEMP1 = ALPHA*A(K,J)
+ END IF
+ DO 150 I = 1,M
+ C(I,J) = C(I,J) + TEMP1*B(I,K)
+ 150 CONTINUE
+ 160 CONTINUE
+ 170 CONTINUE
+ END IF
+*
+ RETURN
+*
+* End of DSYMM .
+*
+ END
+ SUBROUTINE DSYMV(UPLO,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY)
+* .. Scalar Arguments ..
+ DOUBLE PRECISION ALPHA,BETA
+ INTEGER INCX,INCY,LDA,N
+ CHARACTER UPLO
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION A(LDA,*),X(*),Y(*)
+* ..
+*
+* Purpose
+* =======
+*
+* DSYMV performs the matrix-vector operation
+*
+* y := alpha*A*x + beta*y,
+*
+* where alpha and beta are scalars, x and y are n element vectors and
+* A is an n by n symmetric matrix.
+*
+* Arguments
+* ==========
+*
+* UPLO - CHARACTER*1.
+* On entry, UPLO specifies whether the upper or lower
+* triangular part of the array A is to be referenced as
+* follows:
+*
+* UPLO = 'U' or 'u' Only the upper triangular part of A
+* is to be referenced.
+*
+* UPLO = 'L' or 'l' Only the lower triangular part of A
+* is to be referenced.
+*
+* Unchanged on exit.
+*
+* N - INTEGER.
+* On entry, N specifies the order of the matrix A.
+* N must be at least zero.
+* Unchanged on exit.
+*
+* ALPHA - DOUBLE PRECISION.
+* On entry, ALPHA specifies the scalar alpha.
+* Unchanged on exit.
+*
+* A - DOUBLE PRECISION array of DIMENSION ( LDA, n ).
+* Before entry with UPLO = 'U' or 'u', the leading n by n
+* upper triangular part of the array A must contain the upper
+* triangular part of the symmetric matrix and the strictly
+* lower triangular part of A is not referenced.
+* Before entry with UPLO = 'L' or 'l', the leading n by n
+* lower triangular part of the array A must contain the lower
+* triangular part of the symmetric matrix and the strictly
+* upper triangular part of A is not referenced.
+* Unchanged on exit.
+*
+* LDA - INTEGER.
+* On entry, LDA specifies the first dimension of A as declared
+* in the calling (sub) program. LDA must be at least
+* max( 1, n ).
+* Unchanged on exit.
+*
+* X - DOUBLE PRECISION array of dimension at least
+* ( 1 + ( n - 1 )*abs( INCX ) ).
+* Before entry, the incremented array X must contain the n
+* element vector x.
+* Unchanged on exit.
+*
+* INCX - INTEGER.
+* On entry, INCX specifies the increment for the elements of
+* X. INCX must not be zero.
+* Unchanged on exit.
+*
+* BETA - DOUBLE PRECISION.
+* On entry, BETA specifies the scalar beta. When BETA is
+* supplied as zero then Y need not be set on input.
+* Unchanged on exit.
+*
+* Y - DOUBLE PRECISION array of dimension at least
+* ( 1 + ( n - 1 )*abs( INCY ) ).
+* Before entry, the incremented array Y must contain the n
+* element vector y. On exit, Y is overwritten by the updated
+* vector y.
+*
+* INCY - INTEGER.
+* On entry, INCY specifies the increment for the elements of
+* Y. INCY must not be zero.
+* Unchanged on exit.
+*
+*
+* Level 2 Blas routine.
+*
+* -- Written on 22-October-1986.
+* Jack Dongarra, Argonne National Lab.
+* Jeremy Du Croz, Nag Central Office.
+* Sven Hammarling, Nag Central Office.
+* Richard Hanson, Sandia National Labs.
+*
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE,ZERO
+ PARAMETER (ONE=1.0D+0,ZERO=0.0D+0)
+* ..
+* .. Local Scalars ..
+ DOUBLE PRECISION TEMP1,TEMP2
+ INTEGER I,INFO,IX,IY,J,JX,JY,KX,KY
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN
+ INFO = 1
+ ELSE IF (N.LT.0) THEN
+ INFO = 2
+ ELSE IF (LDA.LT.MAX(1,N)) THEN
+ INFO = 5
+ ELSE IF (INCX.EQ.0) THEN
+ INFO = 7
+ ELSE IF (INCY.EQ.0) THEN
+ INFO = 10
+ END IF
+ IF (INFO.NE.0) THEN
+ CALL XERBLA('DSYMV ',INFO)
+ RETURN
+ END IF
+*
+* Quick return if possible.
+*
+ IF ((N.EQ.0) .OR. ((ALPHA.EQ.ZERO).AND. (BETA.EQ.ONE))) RETURN
+*
+* Set up the start points in X and Y.
+*
+ IF (INCX.GT.0) THEN
+ KX = 1
+ ELSE
+ KX = 1 - (N-1)*INCX
+ END IF
+ IF (INCY.GT.0) THEN
+ KY = 1
+ ELSE
+ KY = 1 - (N-1)*INCY
+ END IF
+*
+* Start the operations. In this version the elements of A are
+* accessed sequentially with one pass through the triangular part
+* of A.
+*
+* First form y := beta*y.
+*
+ IF (BETA.NE.ONE) THEN
+ IF (INCY.EQ.1) THEN
+ IF (BETA.EQ.ZERO) THEN
+ DO 10 I = 1,N
+ Y(I) = ZERO
+ 10 CONTINUE
+ ELSE
+ DO 20 I = 1,N
+ Y(I) = BETA*Y(I)
+ 20 CONTINUE
+ END IF
+ ELSE
+ IY = KY
+ IF (BETA.EQ.ZERO) THEN
+ DO 30 I = 1,N
+ Y(IY) = ZERO
+ IY = IY + INCY
+ 30 CONTINUE
+ ELSE
+ DO 40 I = 1,N
+ Y(IY) = BETA*Y(IY)
+ IY = IY + INCY
+ 40 CONTINUE
+ END IF
+ END IF
+ END IF
+ IF (ALPHA.EQ.ZERO) RETURN
+ IF (LSAME(UPLO,'U')) THEN
+*
+* Form y when A is stored in upper triangle.
+*
+ IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
+ DO 60 J = 1,N
+ TEMP1 = ALPHA*X(J)
+ TEMP2 = ZERO
+ DO 50 I = 1,J - 1
+ Y(I) = Y(I) + TEMP1*A(I,J)
+ TEMP2 = TEMP2 + A(I,J)*X(I)
+ 50 CONTINUE
+ Y(J) = Y(J) + TEMP1*A(J,J) + ALPHA*TEMP2
+ 60 CONTINUE
+ ELSE
+ JX = KX
+ JY = KY
+ DO 80 J = 1,N
+ TEMP1 = ALPHA*X(JX)
+ TEMP2 = ZERO
+ IX = KX
+ IY = KY
+ DO 70 I = 1,J - 1
+ Y(IY) = Y(IY) + TEMP1*A(I,J)
+ TEMP2 = TEMP2 + A(I,J)*X(IX)
+ IX = IX + INCX
+ IY = IY + INCY
+ 70 CONTINUE
+ Y(JY) = Y(JY) + TEMP1*A(J,J) + ALPHA*TEMP2
+ JX = JX + INCX
+ JY = JY + INCY
+ 80 CONTINUE
+ END IF
+ ELSE
+*
+* Form y when A is stored in lower triangle.
+*
+ IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
+ DO 100 J = 1,N
+ TEMP1 = ALPHA*X(J)
+ TEMP2 = ZERO
+ Y(J) = Y(J) + TEMP1*A(J,J)
+ DO 90 I = J + 1,N
+ Y(I) = Y(I) + TEMP1*A(I,J)
+ TEMP2 = TEMP2 + A(I,J)*X(I)
+ 90 CONTINUE
+ Y(J) = Y(J) + ALPHA*TEMP2
+ 100 CONTINUE
+ ELSE
+ JX = KX
+ JY = KY
+ DO 120 J = 1,N
+ TEMP1 = ALPHA*X(JX)
+ TEMP2 = ZERO
+ Y(JY) = Y(JY) + TEMP1*A(J,J)
+ IX = JX
+ IY = JY
+ DO 110 I = J + 1,N
+ IX = IX + INCX
+ IY = IY + INCY
+ Y(IY) = Y(IY) + TEMP1*A(I,J)
+ TEMP2 = TEMP2 + A(I,J)*X(IX)
+ 110 CONTINUE
+ Y(JY) = Y(JY) + ALPHA*TEMP2
+ JX = JX + INCX
+ JY = JY + INCY
+ 120 CONTINUE
+ END IF
+ END IF
+*
+ RETURN
+*
+* End of DSYMV .
+*
+ END
+ SUBROUTINE DSYR(UPLO,N,ALPHA,X,INCX,A,LDA)
+* .. Scalar Arguments ..
+ DOUBLE PRECISION ALPHA
+ INTEGER INCX,LDA,N
+ CHARACTER UPLO
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION A(LDA,*),X(*)
+* ..
+*
+* Purpose
+* =======
+*
+* DSYR performs the symmetric rank 1 operation
+*
+* A := alpha*x*x' + A,
+*
+* where alpha is a real scalar, x is an n element vector and A is an
+* n by n symmetric matrix.
+*
+* Arguments
+* ==========
+*
+* UPLO - CHARACTER*1.
+* On entry, UPLO specifies whether the upper or lower
+* triangular part of the array A is to be referenced as
+* follows:
+*
+* UPLO = 'U' or 'u' Only the upper triangular part of A
+* is to be referenced.
+*
+* UPLO = 'L' or 'l' Only the lower triangular part of A
+* is to be referenced.
+*
+* Unchanged on exit.
+*
+* N - INTEGER.
+* On entry, N specifies the order of the matrix A.
+* N must be at least zero.
+* Unchanged on exit.
+*
+* ALPHA - DOUBLE PRECISION.
+* On entry, ALPHA specifies the scalar alpha.
+* Unchanged on exit.
+*
+* X - DOUBLE PRECISION array of dimension at least
+* ( 1 + ( n - 1 )*abs( INCX ) ).
+* Before entry, the incremented array X must contain the n
+* element vector x.
+* Unchanged on exit.
+*
+* INCX - INTEGER.
+* On entry, INCX specifies the increment for the elements of
+* X. INCX must not be zero.
+* Unchanged on exit.
+*
+* A - DOUBLE PRECISION array of DIMENSION ( LDA, n ).
+* Before entry with UPLO = 'U' or 'u', the leading n by n
+* upper triangular part of the array A must contain the upper
+* triangular part of the symmetric matrix and the strictly
+* lower triangular part of A is not referenced. On exit, the
+* upper triangular part of the array A is overwritten by the
+* upper triangular part of the updated matrix.
+* Before entry with UPLO = 'L' or 'l', the leading n by n
+* lower triangular part of the array A must contain the lower
+* triangular part of the symmetric matrix and the strictly
+* upper triangular part of A is not referenced. On exit, the
+* lower triangular part of the array A is overwritten by the
+* lower triangular part of the updated matrix.
+*
+* LDA - INTEGER.
+* On entry, LDA specifies the first dimension of A as declared
+* in the calling (sub) program. LDA must be at least
+* max( 1, n ).
+* Unchanged on exit.
+*
+*
+* Level 2 Blas routine.
+*
+* -- Written on 22-October-1986.
+* Jack Dongarra, Argonne National Lab.
+* Jeremy Du Croz, Nag Central Office.
+* Sven Hammarling, Nag Central Office.
+* Richard Hanson, Sandia National Labs.
+*
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO
+ PARAMETER (ZERO=0.0D+0)
+* ..
+* .. Local Scalars ..
+ DOUBLE PRECISION TEMP
+ INTEGER I,INFO,IX,J,JX,KX
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN
+ INFO = 1
+ ELSE IF (N.LT.0) THEN
+ INFO = 2
+ ELSE IF (INCX.EQ.0) THEN
+ INFO = 5
+ ELSE IF (LDA.LT.MAX(1,N)) THEN
+ INFO = 7
+ END IF
+ IF (INFO.NE.0) THEN
+ CALL XERBLA('DSYR ',INFO)
+ RETURN
+ END IF
+*
+* Quick return if possible.
+*
+ IF ((N.EQ.0) .OR. (ALPHA.EQ.ZERO)) RETURN
+*
+* Set the start point in X if the increment is not unity.
+*
+ IF (INCX.LE.0) THEN
+ KX = 1 - (N-1)*INCX
+ ELSE IF (INCX.NE.1) THEN
+ KX = 1
+ END IF
+*
+* Start the operations. In this version the elements of A are
+* accessed sequentially with one pass through the triangular part
+* of A.
+*
+ IF (LSAME(UPLO,'U')) THEN
+*
+* Form A when A is stored in upper triangle.
+*
+ IF (INCX.EQ.1) THEN
+ DO 20 J = 1,N
+ IF (X(J).NE.ZERO) THEN
+ TEMP = ALPHA*X(J)
+ DO 10 I = 1,J
+ A(I,J) = A(I,J) + X(I)*TEMP
+ 10 CONTINUE
+ END IF
+ 20 CONTINUE
+ ELSE
+ JX = KX
+ DO 40 J = 1,N
+ IF (X(JX).NE.ZERO) THEN
+ TEMP = ALPHA*X(JX)
+ IX = KX
+ DO 30 I = 1,J
+ A(I,J) = A(I,J) + X(IX)*TEMP
+ IX = IX + INCX
+ 30 CONTINUE
+ END IF
+ JX = JX + INCX
+ 40 CONTINUE
+ END IF
+ ELSE
+*
+* Form A when A is stored in lower triangle.
+*
+ IF (INCX.EQ.1) THEN
+ DO 60 J = 1,N
+ IF (X(J).NE.ZERO) THEN
+ TEMP = ALPHA*X(J)
+ DO 50 I = J,N
+ A(I,J) = A(I,J) + X(I)*TEMP
+ 50 CONTINUE
+ END IF
+ 60 CONTINUE
+ ELSE
+ JX = KX
+ DO 80 J = 1,N
+ IF (X(JX).NE.ZERO) THEN
+ TEMP = ALPHA*X(JX)
+ IX = JX
+ DO 70 I = J,N
+ A(I,J) = A(I,J) + X(IX)*TEMP
+ IX = IX + INCX
+ 70 CONTINUE
+ END IF
+ JX = JX + INCX
+ 80 CONTINUE
+ END IF
+ END IF
+*
+ RETURN
+*
+* End of DSYR .
+*
+ END
+ SUBROUTINE DSYR2(UPLO,N,ALPHA,X,INCX,Y,INCY,A,LDA)
+* .. Scalar Arguments ..
+ DOUBLE PRECISION ALPHA
+ INTEGER INCX,INCY,LDA,N
+ CHARACTER UPLO
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION A(LDA,*),X(*),Y(*)
+* ..
+*
+* Purpose
+* =======
+*
+* DSYR2 performs the symmetric rank 2 operation
+*
+* A := alpha*x*y' + alpha*y*x' + A,
+*
+* where alpha is a scalar, x and y are n element vectors and A is an n
+* by n symmetric matrix.
+*
+* Arguments
+* ==========
+*
+* UPLO - CHARACTER*1.
+* On entry, UPLO specifies whether the upper or lower
+* triangular part of the array A is to be referenced as
+* follows:
+*
+* UPLO = 'U' or 'u' Only the upper triangular part of A
+* is to be referenced.
+*
+* UPLO = 'L' or 'l' Only the lower triangular part of A
+* is to be referenced.
+*
+* Unchanged on exit.
+*
+* N - INTEGER.
+* On entry, N specifies the order of the matrix A.
+* N must be at least zero.
+* Unchanged on exit.
+*
+* ALPHA - DOUBLE PRECISION.
+* On entry, ALPHA specifies the scalar alpha.
+* Unchanged on exit.
+*
+* X - DOUBLE PRECISION array of dimension at least
+* ( 1 + ( n - 1 )*abs( INCX ) ).
+* Before entry, the incremented array X must contain the n
+* element vector x.
+* Unchanged on exit.
+*
+* INCX - INTEGER.
+* On entry, INCX specifies the increment for the elements of
+* X. INCX must not be zero.
+* Unchanged on exit.
+*
+* Y - DOUBLE PRECISION array of dimension at least
+* ( 1 + ( n - 1 )*abs( INCY ) ).
+* Before entry, the incremented array Y must contain the n
+* element vector y.
+* Unchanged on exit.
+*
+* INCY - INTEGER.
+* On entry, INCY specifies the increment for the elements of
+* Y. INCY must not be zero.
+* Unchanged on exit.
+*
+* A - DOUBLE PRECISION array of DIMENSION ( LDA, n ).
+* Before entry with UPLO = 'U' or 'u', the leading n by n
+* upper triangular part of the array A must contain the upper
+* triangular part of the symmetric matrix and the strictly
+* lower triangular part of A is not referenced. On exit, the
+* upper triangular part of the array A is overwritten by the
+* upper triangular part of the updated matrix.
+* Before entry with UPLO = 'L' or 'l', the leading n by n
+* lower triangular part of the array A must contain the lower
+* triangular part of the symmetric matrix and the strictly
+* upper triangular part of A is not referenced. On exit, the
+* lower triangular part of the array A is overwritten by the
+* lower triangular part of the updated matrix.
+*
+* LDA - INTEGER.
+* On entry, LDA specifies the first dimension of A as declared
+* in the calling (sub) program. LDA must be at least
+* max( 1, n ).
+* Unchanged on exit.
+*
+*
+* Level 2 Blas routine.
+*
+* -- Written on 22-October-1986.
+* Jack Dongarra, Argonne National Lab.
+* Jeremy Du Croz, Nag Central Office.
+* Sven Hammarling, Nag Central Office.
+* Richard Hanson, Sandia National Labs.
+*
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO
+ PARAMETER (ZERO=0.0D+0)
+* ..
+* .. Local Scalars ..
+ DOUBLE PRECISION TEMP1,TEMP2
+ INTEGER I,INFO,IX,IY,J,JX,JY,KX,KY
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN
+ INFO = 1
+ ELSE IF (N.LT.0) THEN
+ INFO = 2
+ ELSE IF (INCX.EQ.0) THEN
+ INFO = 5
+ ELSE IF (INCY.EQ.0) THEN
+ INFO = 7
+ ELSE IF (LDA.LT.MAX(1,N)) THEN
+ INFO = 9
+ END IF
+ IF (INFO.NE.0) THEN
+ CALL XERBLA('DSYR2 ',INFO)
+ RETURN
+ END IF
+*
+* Quick return if possible.
+*
+ IF ((N.EQ.0) .OR. (ALPHA.EQ.ZERO)) RETURN
+*
+* Set up the start points in X and Y if the increments are not both
+* unity.
+*
+ IF ((INCX.NE.1) .OR. (INCY.NE.1)) THEN
+ IF (INCX.GT.0) THEN
+ KX = 1
+ ELSE
+ KX = 1 - (N-1)*INCX
+ END IF
+ IF (INCY.GT.0) THEN
+ KY = 1
+ ELSE
+ KY = 1 - (N-1)*INCY
+ END IF
+ JX = KX
+ JY = KY
+ END IF
+*
+* Start the operations. In this version the elements of A are
+* accessed sequentially with one pass through the triangular part
+* of A.
+*
+ IF (LSAME(UPLO,'U')) THEN
+*
+* Form A when A is stored in the upper triangle.
+*
+ IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
+ DO 20 J = 1,N
+ IF ((X(J).NE.ZERO) .OR. (Y(J).NE.ZERO)) THEN
+ TEMP1 = ALPHA*Y(J)
+ TEMP2 = ALPHA*X(J)
+ DO 10 I = 1,J
+ A(I,J) = A(I,J) + X(I)*TEMP1 + Y(I)*TEMP2
+ 10 CONTINUE
+ END IF
+ 20 CONTINUE
+ ELSE
+ DO 40 J = 1,N
+ IF ((X(JX).NE.ZERO) .OR. (Y(JY).NE.ZERO)) THEN
+ TEMP1 = ALPHA*Y(JY)
+ TEMP2 = ALPHA*X(JX)
+ IX = KX
+ IY = KY
+ DO 30 I = 1,J
+ A(I,J) = A(I,J) + X(IX)*TEMP1 + Y(IY)*TEMP2
+ IX = IX + INCX
+ IY = IY + INCY
+ 30 CONTINUE
+ END IF
+ JX = JX + INCX
+ JY = JY + INCY
+ 40 CONTINUE
+ END IF
+ ELSE
+*
+* Form A when A is stored in the lower triangle.
+*
+ IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
+ DO 60 J = 1,N
+ IF ((X(J).NE.ZERO) .OR. (Y(J).NE.ZERO)) THEN
+ TEMP1 = ALPHA*Y(J)
+ TEMP2 = ALPHA*X(J)
+ DO 50 I = J,N
+ A(I,J) = A(I,J) + X(I)*TEMP1 + Y(I)*TEMP2
+ 50 CONTINUE
+ END IF
+ 60 CONTINUE
+ ELSE
+ DO 80 J = 1,N
+ IF ((X(JX).NE.ZERO) .OR. (Y(JY).NE.ZERO)) THEN
+ TEMP1 = ALPHA*Y(JY)
+ TEMP2 = ALPHA*X(JX)
+ IX = JX
+ IY = JY
+ DO 70 I = J,N
+ A(I,J) = A(I,J) + X(IX)*TEMP1 + Y(IY)*TEMP2
+ IX = IX + INCX
+ IY = IY + INCY
+ 70 CONTINUE
+ END IF
+ JX = JX + INCX
+ JY = JY + INCY
+ 80 CONTINUE
+ END IF
+ END IF
+*
+ RETURN
+*
+* End of DSYR2 .
+*
+ END
+ SUBROUTINE DSYR2K(UPLO,TRANS,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC)
+* .. Scalar Arguments ..
+ DOUBLE PRECISION ALPHA,BETA
+ INTEGER K,LDA,LDB,LDC,N
+ CHARACTER TRANS,UPLO
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION A(LDA,*),B(LDB,*),C(LDC,*)
+* ..
+*
+* Purpose
+* =======
+*
+* DSYR2K performs one of the symmetric rank 2k operations
+*
+* C := alpha*A*B' + alpha*B*A' + beta*C,
+*
+* or
+*
+* C := alpha*A'*B + alpha*B'*A + beta*C,
+*
+* where alpha and beta are scalars, C is an n by n symmetric matrix
+* and A and B are n by k matrices in the first case and k by n
+* matrices in the second case.
+*
+* Arguments
+* ==========
+*
+* UPLO - CHARACTER*1.
+* On entry, UPLO specifies whether the upper or lower
+* triangular part of the array C is to be referenced as
+* follows:
+*
+* UPLO = 'U' or 'u' Only the upper triangular part of C
+* is to be referenced.
+*
+* UPLO = 'L' or 'l' Only the lower triangular part of C
+* is to be referenced.
+*
+* Unchanged on exit.
+*
+* TRANS - CHARACTER*1.
+* On entry, TRANS specifies the operation to be performed as
+* follows:
+*
+* TRANS = 'N' or 'n' C := alpha*A*B' + alpha*B*A' +
+* beta*C.
+*
+* TRANS = 'T' or 't' C := alpha*A'*B + alpha*B'*A +
+* beta*C.
+*
+* TRANS = 'C' or 'c' C := alpha*A'*B + alpha*B'*A +
+* beta*C.
+*
+* Unchanged on exit.
+*
+* N - INTEGER.
+* On entry, N specifies the order of the matrix C. N must be
+* at least zero.
+* Unchanged on exit.
+*
+* K - INTEGER.
+* On entry with TRANS = 'N' or 'n', K specifies the number
+* of columns of the matrices A and B, and on entry with
+* TRANS = 'T' or 't' or 'C' or 'c', K specifies the number
+* of rows of the matrices A and B. K must be at least zero.
+* Unchanged on exit.
+*
+* ALPHA - DOUBLE PRECISION.
+* On entry, ALPHA specifies the scalar alpha.
+* Unchanged on exit.
+*
+* A - DOUBLE PRECISION array of DIMENSION ( LDA, ka ), where ka is
+* k when TRANS = 'N' or 'n', and is n otherwise.
+* Before entry with TRANS = 'N' or 'n', the leading n by k
+* part of the array A must contain the matrix A, otherwise
+* the leading k by n part of the array A must contain the
+* matrix A.
+* Unchanged on exit.
+*
+* LDA - INTEGER.
+* On entry, LDA specifies the first dimension of A as declared
+* in the calling (sub) program. When TRANS = 'N' or 'n'
+* then LDA must be at least max( 1, n ), otherwise LDA must
+* be at least max( 1, k ).
+* Unchanged on exit.
+*
+* B - DOUBLE PRECISION array of DIMENSION ( LDB, kb ), where kb is
+* k when TRANS = 'N' or 'n', and is n otherwise.
+* Before entry with TRANS = 'N' or 'n', the leading n by k
+* part of the array B must contain the matrix B, otherwise
+* the leading k by n part of the array B must contain the
+* matrix B.
+* Unchanged on exit.
+*
+* LDB - INTEGER.
+* On entry, LDB specifies the first dimension of B as declared
+* in the calling (sub) program. When TRANS = 'N' or 'n'
+* then LDB must be at least max( 1, n ), otherwise LDB must
+* be at least max( 1, k ).
+* Unchanged on exit.
+*
+* BETA - DOUBLE PRECISION.
+* On entry, BETA specifies the scalar beta.
+* Unchanged on exit.
+*
+* C - DOUBLE PRECISION array of DIMENSION ( LDC, n ).
+* Before entry with UPLO = 'U' or 'u', the leading n by n
+* upper triangular part of the array C must contain the upper
+* triangular part of the symmetric matrix and the strictly
+* lower triangular part of C is not referenced. On exit, the
+* upper triangular part of the array C is overwritten by the
+* upper triangular part of the updated matrix.
+* Before entry with UPLO = 'L' or 'l', the leading n by n
+* lower triangular part of the array C must contain the lower
+* triangular part of the symmetric matrix and the strictly
+* upper triangular part of C is not referenced. On exit, the
+* lower triangular part of the array C is overwritten by the
+* lower triangular part of the updated matrix.
+*
+* LDC - INTEGER.
+* On entry, LDC specifies the first dimension of C as declared
+* in the calling (sub) program. LDC must be at least
+* max( 1, n ).
+* Unchanged on exit.
+*
+*
+* Level 3 Blas routine.
+*
+*
+* -- Written on 8-February-1989.
+* Jack Dongarra, Argonne National Laboratory.
+* Iain Duff, AERE Harwell.
+* Jeremy Du Croz, Numerical Algorithms Group Ltd.
+* Sven Hammarling, Numerical Algorithms Group Ltd.
+*
+*
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Local Scalars ..
+ DOUBLE PRECISION TEMP1,TEMP2
+ INTEGER I,INFO,J,L,NROWA
+ LOGICAL UPPER
+* ..
+* .. Parameters ..
+ DOUBLE PRECISION ONE,ZERO
+ PARAMETER (ONE=1.0D+0,ZERO=0.0D+0)
+* ..
+*
+* Test the input parameters.
+*
+ IF (LSAME(TRANS,'N')) THEN
+ NROWA = N
+ ELSE
+ NROWA = K
+ END IF
+ UPPER = LSAME(UPLO,'U')
+*
+ INFO = 0
+ IF ((.NOT.UPPER) .AND. (.NOT.LSAME(UPLO,'L'))) THEN
+ INFO = 1
+ ELSE IF ((.NOT.LSAME(TRANS,'N')) .AND.
+ + (.NOT.LSAME(TRANS,'T')) .AND.
+ + (.NOT.LSAME(TRANS,'C'))) THEN
+ INFO = 2
+ ELSE IF (N.LT.0) THEN
+ INFO = 3
+ ELSE IF (K.LT.0) THEN
+ INFO = 4
+ ELSE IF (LDA.LT.MAX(1,NROWA)) THEN
+ INFO = 7
+ ELSE IF (LDB.LT.MAX(1,NROWA)) THEN
+ INFO = 9
+ ELSE IF (LDC.LT.MAX(1,N)) THEN
+ INFO = 12
+ END IF
+ IF (INFO.NE.0) THEN
+ CALL XERBLA('DSYR2K',INFO)
+ RETURN
+ END IF
+*
+* Quick return if possible.
+*
+ IF ((N.EQ.0) .OR. (((ALPHA.EQ.ZERO).OR.
+ + (K.EQ.0)).AND. (BETA.EQ.ONE))) RETURN
+*
+* And when alpha.eq.zero.
+*
+ IF (ALPHA.EQ.ZERO) THEN
+ IF (UPPER) THEN
+ IF (BETA.EQ.ZERO) THEN
+ DO 20 J = 1,N
+ DO 10 I = 1,J
+ C(I,J) = ZERO
+ 10 CONTINUE
+ 20 CONTINUE
+ ELSE
+ DO 40 J = 1,N
+ DO 30 I = 1,J
+ C(I,J) = BETA*C(I,J)
+ 30 CONTINUE
+ 40 CONTINUE
+ END IF
+ ELSE
+ IF (BETA.EQ.ZERO) THEN
+ DO 60 J = 1,N
+ DO 50 I = J,N
+ C(I,J) = ZERO
+ 50 CONTINUE
+ 60 CONTINUE
+ ELSE
+ DO 80 J = 1,N
+ DO 70 I = J,N
+ C(I,J) = BETA*C(I,J)
+ 70 CONTINUE
+ 80 CONTINUE
+ END IF
+ END IF
+ RETURN
+ END IF
+*
+* Start the operations.
+*
+ IF (LSAME(TRANS,'N')) THEN
+*
+* Form C := alpha*A*B' + alpha*B*A' + C.
+*
+ IF (UPPER) THEN
+ DO 130 J = 1,N
+ IF (BETA.EQ.ZERO) THEN
+ DO 90 I = 1,J
+ C(I,J) = ZERO
+ 90 CONTINUE
+ ELSE IF (BETA.NE.ONE) THEN
+ DO 100 I = 1,J
+ C(I,J) = BETA*C(I,J)
+ 100 CONTINUE
+ END IF
+ DO 120 L = 1,K
+ IF ((A(J,L).NE.ZERO) .OR. (B(J,L).NE.ZERO)) THEN
+ TEMP1 = ALPHA*B(J,L)
+ TEMP2 = ALPHA*A(J,L)
+ DO 110 I = 1,J
+ C(I,J) = C(I,J) + A(I,L)*TEMP1 +
+ + B(I,L)*TEMP2
+ 110 CONTINUE
+ END IF
+ 120 CONTINUE
+ 130 CONTINUE
+ ELSE
+ DO 180 J = 1,N
+ IF (BETA.EQ.ZERO) THEN
+ DO 140 I = J,N
+ C(I,J) = ZERO
+ 140 CONTINUE
+ ELSE IF (BETA.NE.ONE) THEN
+ DO 150 I = J,N
+ C(I,J) = BETA*C(I,J)
+ 150 CONTINUE
+ END IF
+ DO 170 L = 1,K
+ IF ((A(J,L).NE.ZERO) .OR. (B(J,L).NE.ZERO)) THEN
+ TEMP1 = ALPHA*B(J,L)
+ TEMP2 = ALPHA*A(J,L)
+ DO 160 I = J,N
+ C(I,J) = C(I,J) + A(I,L)*TEMP1 +
+ + B(I,L)*TEMP2
+ 160 CONTINUE
+ END IF
+ 170 CONTINUE
+ 180 CONTINUE
+ END IF
+ ELSE
+*
+* Form C := alpha*A'*B + alpha*B'*A + C.
+*
+ IF (UPPER) THEN
+ DO 210 J = 1,N
+ DO 200 I = 1,J
+ TEMP1 = ZERO
+ TEMP2 = ZERO
+ DO 190 L = 1,K
+ TEMP1 = TEMP1 + A(L,I)*B(L,J)
+ TEMP2 = TEMP2 + B(L,I)*A(L,J)
+ 190 CONTINUE
+ IF (BETA.EQ.ZERO) THEN
+ C(I,J) = ALPHA*TEMP1 + ALPHA*TEMP2
+ ELSE
+ C(I,J) = BETA*C(I,J) + ALPHA*TEMP1 +
+ + ALPHA*TEMP2
+ END IF
+ 200 CONTINUE
+ 210 CONTINUE
+ ELSE
+ DO 240 J = 1,N
+ DO 230 I = J,N
+ TEMP1 = ZERO
+ TEMP2 = ZERO
+ DO 220 L = 1,K
+ TEMP1 = TEMP1 + A(L,I)*B(L,J)
+ TEMP2 = TEMP2 + B(L,I)*A(L,J)
+ 220 CONTINUE
+ IF (BETA.EQ.ZERO) THEN
+ C(I,J) = ALPHA*TEMP1 + ALPHA*TEMP2
+ ELSE
+ C(I,J) = BETA*C(I,J) + ALPHA*TEMP1 +
+ + ALPHA*TEMP2
+ END IF
+ 230 CONTINUE
+ 240 CONTINUE
+ END IF
+ END IF
+*
+ RETURN
+*
+* End of DSYR2K.
+*
+ END
+ SUBROUTINE DSYRK(UPLO,TRANS,N,K,ALPHA,A,LDA,BETA,C,LDC)
+* .. Scalar Arguments ..
+ DOUBLE PRECISION ALPHA,BETA
+ INTEGER K,LDA,LDC,N
+ CHARACTER TRANS,UPLO
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION A(LDA,*),C(LDC,*)
+* ..
+*
+* Purpose
+* =======
+*
+* DSYRK performs one of the symmetric rank k operations
+*
+* C := alpha*A*A' + beta*C,
+*
+* or
+*
+* C := alpha*A'*A + beta*C,
+*
+* where alpha and beta are scalars, C is an n by n symmetric matrix
+* and A is an n by k matrix in the first case and a k by n matrix
+* in the second case.
+*
+* Arguments
+* ==========
+*
+* UPLO - CHARACTER*1.
+* On entry, UPLO specifies whether the upper or lower
+* triangular part of the array C is to be referenced as
+* follows:
+*
+* UPLO = 'U' or 'u' Only the upper triangular part of C
+* is to be referenced.
+*
+* UPLO = 'L' or 'l' Only the lower triangular part of C
+* is to be referenced.
+*
+* Unchanged on exit.
+*
+* TRANS - CHARACTER*1.
+* On entry, TRANS specifies the operation to be performed as
+* follows:
+*
+* TRANS = 'N' or 'n' C := alpha*A*A' + beta*C.
+*
+* TRANS = 'T' or 't' C := alpha*A'*A + beta*C.
+*
+* TRANS = 'C' or 'c' C := alpha*A'*A + beta*C.
+*
+* Unchanged on exit.
+*
+* N - INTEGER.
+* On entry, N specifies the order of the matrix C. N must be
+* at least zero.
+* Unchanged on exit.
+*
+* K - INTEGER.
+* On entry with TRANS = 'N' or 'n', K specifies the number
+* of columns of the matrix A, and on entry with
+* TRANS = 'T' or 't' or 'C' or 'c', K specifies the number
+* of rows of the matrix A. K must be at least zero.
+* Unchanged on exit.
+*
+* ALPHA - DOUBLE PRECISION.
+* On entry, ALPHA specifies the scalar alpha.
+* Unchanged on exit.
+*
+* A - DOUBLE PRECISION array of DIMENSION ( LDA, ka ), where ka is
+* k when TRANS = 'N' or 'n', and is n otherwise.
+* Before entry with TRANS = 'N' or 'n', the leading n by k
+* part of the array A must contain the matrix A, otherwise
+* the leading k by n part of the array A must contain the
+* matrix A.
+* Unchanged on exit.
+*
+* LDA - INTEGER.
+* On entry, LDA specifies the first dimension of A as declared
+* in the calling (sub) program. When TRANS = 'N' or 'n'
+* then LDA must be at least max( 1, n ), otherwise LDA must
+* be at least max( 1, k ).
+* Unchanged on exit.
+*
+* BETA - DOUBLE PRECISION.
+* On entry, BETA specifies the scalar beta.
+* Unchanged on exit.
+*
+* C - DOUBLE PRECISION array of DIMENSION ( LDC, n ).
+* Before entry with UPLO = 'U' or 'u', the leading n by n
+* upper triangular part of the array C must contain the upper
+* triangular part of the symmetric matrix and the strictly
+* lower triangular part of C is not referenced. On exit, the
+* upper triangular part of the array C is overwritten by the
+* upper triangular part of the updated matrix.
+* Before entry with UPLO = 'L' or 'l', the leading n by n
+* lower triangular part of the array C must contain the lower
+* triangular part of the symmetric matrix and the strictly
+* upper triangular part of C is not referenced. On exit, the
+* lower triangular part of the array C is overwritten by the
+* lower triangular part of the updated matrix.
+*
+* LDC - INTEGER.
+* On entry, LDC specifies the first dimension of C as declared
+* in the calling (sub) program. LDC must be at least
+* max( 1, n ).
+* Unchanged on exit.
+*
+*
+* Level 3 Blas routine.
+*
+* -- Written on 8-February-1989.
+* Jack Dongarra, Argonne National Laboratory.
+* Iain Duff, AERE Harwell.
+* Jeremy Du Croz, Numerical Algorithms Group Ltd.
+* Sven Hammarling, Numerical Algorithms Group Ltd.
+*
+*
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Local Scalars ..
+ DOUBLE PRECISION TEMP
+ INTEGER I,INFO,J,L,NROWA
+ LOGICAL UPPER
+* ..
+* .. Parameters ..
+ DOUBLE PRECISION ONE,ZERO
+ PARAMETER (ONE=1.0D+0,ZERO=0.0D+0)
+* ..
+*
+* Test the input parameters.
+*
+ IF (LSAME(TRANS,'N')) THEN
+ NROWA = N
+ ELSE
+ NROWA = K
+ END IF
+ UPPER = LSAME(UPLO,'U')
+*
+ INFO = 0
+ IF ((.NOT.UPPER) .AND. (.NOT.LSAME(UPLO,'L'))) THEN
+ INFO = 1
+ ELSE IF ((.NOT.LSAME(TRANS,'N')) .AND.
+ + (.NOT.LSAME(TRANS,'T')) .AND.
+ + (.NOT.LSAME(TRANS,'C'))) THEN
+ INFO = 2
+ ELSE IF (N.LT.0) THEN
+ INFO = 3
+ ELSE IF (K.LT.0) THEN
+ INFO = 4
+ ELSE IF (LDA.LT.MAX(1,NROWA)) THEN
+ INFO = 7
+ ELSE IF (LDC.LT.MAX(1,N)) THEN
+ INFO = 10
+ END IF
+ IF (INFO.NE.0) THEN
+ CALL XERBLA('DSYRK ',INFO)
+ RETURN
+ END IF
+*
+* Quick return if possible.
+*
+ IF ((N.EQ.0) .OR. (((ALPHA.EQ.ZERO).OR.
+ + (K.EQ.0)).AND. (BETA.EQ.ONE))) RETURN
+*
+* And when alpha.eq.zero.
+*
+ IF (ALPHA.EQ.ZERO) THEN
+ IF (UPPER) THEN
+ IF (BETA.EQ.ZERO) THEN
+ DO 20 J = 1,N
+ DO 10 I = 1,J
+ C(I,J) = ZERO
+ 10 CONTINUE
+ 20 CONTINUE
+ ELSE
+ DO 40 J = 1,N
+ DO 30 I = 1,J
+ C(I,J) = BETA*C(I,J)
+ 30 CONTINUE
+ 40 CONTINUE
+ END IF
+ ELSE
+ IF (BETA.EQ.ZERO) THEN
+ DO 60 J = 1,N
+ DO 50 I = J,N
+ C(I,J) = ZERO
+ 50 CONTINUE
+ 60 CONTINUE
+ ELSE
+ DO 80 J = 1,N
+ DO 70 I = J,N
+ C(I,J) = BETA*C(I,J)
+ 70 CONTINUE
+ 80 CONTINUE
+ END IF
+ END IF
+ RETURN
+ END IF
+*
+* Start the operations.
+*
+ IF (LSAME(TRANS,'N')) THEN
+*
+* Form C := alpha*A*A' + beta*C.
+*
+ IF (UPPER) THEN
+ DO 130 J = 1,N
+ IF (BETA.EQ.ZERO) THEN
+ DO 90 I = 1,J
+ C(I,J) = ZERO
+ 90 CONTINUE
+ ELSE IF (BETA.NE.ONE) THEN
+ DO 100 I = 1,J
+ C(I,J) = BETA*C(I,J)
+ 100 CONTINUE
+ END IF
+ DO 120 L = 1,K
+ IF (A(J,L).NE.ZERO) THEN
+ TEMP = ALPHA*A(J,L)
+ DO 110 I = 1,J
+ C(I,J) = C(I,J) + TEMP*A(I,L)
+ 110 CONTINUE
+ END IF
+ 120 CONTINUE
+ 130 CONTINUE
+ ELSE
+ DO 180 J = 1,N
+ IF (BETA.EQ.ZERO) THEN
+ DO 140 I = J,N
+ C(I,J) = ZERO
+ 140 CONTINUE
+ ELSE IF (BETA.NE.ONE) THEN
+ DO 150 I = J,N
+ C(I,J) = BETA*C(I,J)
+ 150 CONTINUE
+ END IF
+ DO 170 L = 1,K
+ IF (A(J,L).NE.ZERO) THEN
+ TEMP = ALPHA*A(J,L)
+ DO 160 I = J,N
+ C(I,J) = C(I,J) + TEMP*A(I,L)
+ 160 CONTINUE
+ END IF
+ 170 CONTINUE
+ 180 CONTINUE
+ END IF
+ ELSE
+*
+* Form C := alpha*A'*A + beta*C.
+*
+ IF (UPPER) THEN
+ DO 210 J = 1,N
+ DO 200 I = 1,J
+ TEMP = ZERO
+ DO 190 L = 1,K
+ TEMP = TEMP + A(L,I)*A(L,J)
+ 190 CONTINUE
+ IF (BETA.EQ.ZERO) THEN
+ C(I,J) = ALPHA*TEMP
+ ELSE
+ C(I,J) = ALPHA*TEMP + BETA*C(I,J)
+ END IF
+ 200 CONTINUE
+ 210 CONTINUE
+ ELSE
+ DO 240 J = 1,N
+ DO 230 I = J,N
+ TEMP = ZERO
+ DO 220 L = 1,K
+ TEMP = TEMP + A(L,I)*A(L,J)
+ 220 CONTINUE
+ IF (BETA.EQ.ZERO) THEN
+ C(I,J) = ALPHA*TEMP
+ ELSE
+ C(I,J) = ALPHA*TEMP + BETA*C(I,J)
+ END IF
+ 230 CONTINUE
+ 240 CONTINUE
+ END IF
+ END IF
+*
+ RETURN
+*
+* End of DSYRK .
+*
+ END
+ SUBROUTINE DTBMV(UPLO,TRANS,DIAG,N,K,A,LDA,X,INCX)
+* .. Scalar Arguments ..
+ INTEGER INCX,K,LDA,N
+ CHARACTER DIAG,TRANS,UPLO
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION A(LDA,*),X(*)
+* ..
+*
+* Purpose
+* =======
+*
+* DTBMV performs one of the matrix-vector operations
+*
+* x := A*x, or x := A'*x,
+*
+* where x is an n element vector and A is an n by n unit, or non-unit,
+* upper or lower triangular band matrix, with ( k + 1 ) diagonals.
+*
+* Arguments
+* ==========
+*
+* UPLO - CHARACTER*1.
+* On entry, UPLO specifies whether the matrix is an upper or
+* lower triangular matrix as follows:
+*
+* UPLO = 'U' or 'u' A is an upper triangular matrix.
+*
+* UPLO = 'L' or 'l' A is a lower triangular matrix.
+*
+* Unchanged on exit.
+*
+* TRANS - CHARACTER*1.
+* On entry, TRANS specifies the operation to be performed as
+* follows:
+*
+* TRANS = 'N' or 'n' x := A*x.
+*
+* TRANS = 'T' or 't' x := A'*x.
+*
+* TRANS = 'C' or 'c' x := A'*x.
+*
+* Unchanged on exit.
+*
+* DIAG - CHARACTER*1.
+* On entry, DIAG specifies whether or not A is unit
+* triangular as follows:
+*
+* DIAG = 'U' or 'u' A is assumed to be unit triangular.
+*
+* DIAG = 'N' or 'n' A is not assumed to be unit
+* triangular.
+*
+* Unchanged on exit.
+*
+* N - INTEGER.
+* On entry, N specifies the order of the matrix A.
+* N must be at least zero.
+* Unchanged on exit.
+*
+* K - INTEGER.
+* On entry with UPLO = 'U' or 'u', K specifies the number of
+* super-diagonals of the matrix A.
+* On entry with UPLO = 'L' or 'l', K specifies the number of
+* sub-diagonals of the matrix A.
+* K must satisfy 0 .le. K.
+* Unchanged on exit.
+*
+* A - DOUBLE PRECISION array of DIMENSION ( LDA, n ).
+* Before entry with UPLO = 'U' or 'u', the leading ( k + 1 )
+* by n part of the array A must contain the upper triangular
+* band part of the matrix of coefficients, supplied column by
+* column, with the leading diagonal of the matrix in row
+* ( k + 1 ) of the array, the first super-diagonal starting at
+* position 2 in row k, and so on. The top left k by k triangle
+* of the array A is not referenced.
+* The following program segment will transfer an upper
+* triangular band matrix from conventional full matrix storage
+* to band storage:
+*
+* DO 20, J = 1, N
+* M = K + 1 - J
+* DO 10, I = MAX( 1, J - K ), J
+* A( M + I, J ) = matrix( I, J )
+* 10 CONTINUE
+* 20 CONTINUE
+*
+* Before entry with UPLO = 'L' or 'l', the leading ( k + 1 )
+* by n part of the array A must contain the lower triangular
+* band part of the matrix of coefficients, supplied column by
+* column, with the leading diagonal of the matrix in row 1 of
+* the array, the first sub-diagonal starting at position 1 in
+* row 2, and so on. The bottom right k by k triangle of the
+* array A is not referenced.
+* The following program segment will transfer a lower
+* triangular band matrix from conventional full matrix storage
+* to band storage:
+*
+* DO 20, J = 1, N
+* M = 1 - J
+* DO 10, I = J, MIN( N, J + K )
+* A( M + I, J ) = matrix( I, J )
+* 10 CONTINUE
+* 20 CONTINUE
+*
+* Note that when DIAG = 'U' or 'u' the elements of the array A
+* corresponding to the diagonal elements of the matrix are not
+* referenced, but are assumed to be unity.
+* Unchanged on exit.
+*
+* LDA - INTEGER.
+* On entry, LDA specifies the first dimension of A as declared
+* in the calling (sub) program. LDA must be at least
+* ( k + 1 ).
+* Unchanged on exit.
+*
+* X - DOUBLE PRECISION array of dimension at least
+* ( 1 + ( n - 1 )*abs( INCX ) ).
+* Before entry, the incremented array X must contain the n
+* element vector x. On exit, X is overwritten with the
+* tranformed vector x.
+*
+* INCX - INTEGER.
+* On entry, INCX specifies the increment for the elements of
+* X. INCX must not be zero.
+* Unchanged on exit.
+*
+*
+* Level 2 Blas routine.
+*
+* -- Written on 22-October-1986.
+* Jack Dongarra, Argonne National Lab.
+* Jeremy Du Croz, Nag Central Office.
+* Sven Hammarling, Nag Central Office.
+* Richard Hanson, Sandia National Labs.
+*
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO
+ PARAMETER (ZERO=0.0D+0)
+* ..
+* .. Local Scalars ..
+ DOUBLE PRECISION TEMP
+ INTEGER I,INFO,IX,J,JX,KPLUS1,KX,L
+ LOGICAL NOUNIT
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX,MIN
+* ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN
+ INFO = 1
+ ELSE IF (.NOT.LSAME(TRANS,'N') .AND. .NOT.LSAME(TRANS,'T') .AND.
+ + .NOT.LSAME(TRANS,'C')) THEN
+ INFO = 2
+ ELSE IF (.NOT.LSAME(DIAG,'U') .AND. .NOT.LSAME(DIAG,'N')) THEN
+ INFO = 3
+ ELSE IF (N.LT.0) THEN
+ INFO = 4
+ ELSE IF (K.LT.0) THEN
+ INFO = 5
+ ELSE IF (LDA.LT. (K+1)) THEN
+ INFO = 7
+ ELSE IF (INCX.EQ.0) THEN
+ INFO = 9
+ END IF
+ IF (INFO.NE.0) THEN
+ CALL XERBLA('DTBMV ',INFO)
+ RETURN
+ END IF
+*
+* Quick return if possible.
+*
+ IF (N.EQ.0) RETURN
+*
+ NOUNIT = LSAME(DIAG,'N')
+*
+* Set up the start point in X if the increment is not unity. This
+* will be ( N - 1 )*INCX too small for descending loops.
+*
+ IF (INCX.LE.0) THEN
+ KX = 1 - (N-1)*INCX
+ ELSE IF (INCX.NE.1) THEN
+ KX = 1
+ END IF
+*
+* Start the operations. In this version the elements of A are
+* accessed sequentially with one pass through A.
+*
+ IF (LSAME(TRANS,'N')) THEN
+*
+* Form x := A*x.
+*
+ IF (LSAME(UPLO,'U')) THEN
+ KPLUS1 = K + 1
+ IF (INCX.EQ.1) THEN
+ DO 20 J = 1,N
+ IF (X(J).NE.ZERO) THEN
+ TEMP = X(J)
+ L = KPLUS1 - J
+ DO 10 I = MAX(1,J-K),J - 1
+ X(I) = X(I) + TEMP*A(L+I,J)
+ 10 CONTINUE
+ IF (NOUNIT) X(J) = X(J)*A(KPLUS1,J)
+ END IF
+ 20 CONTINUE
+ ELSE
+ JX = KX
+ DO 40 J = 1,N
+ IF (X(JX).NE.ZERO) THEN
+ TEMP = X(JX)
+ IX = KX
+ L = KPLUS1 - J
+ DO 30 I = MAX(1,J-K),J - 1
+ X(IX) = X(IX) + TEMP*A(L+I,J)
+ IX = IX + INCX
+ 30 CONTINUE
+ IF (NOUNIT) X(JX) = X(JX)*A(KPLUS1,J)
+ END IF
+ JX = JX + INCX
+ IF (J.GT.K) KX = KX + INCX
+ 40 CONTINUE
+ END IF
+ ELSE
+ IF (INCX.EQ.1) THEN
+ DO 60 J = N,1,-1
+ IF (X(J).NE.ZERO) THEN
+ TEMP = X(J)
+ L = 1 - J
+ DO 50 I = MIN(N,J+K),J + 1,-1
+ X(I) = X(I) + TEMP*A(L+I,J)
+ 50 CONTINUE
+ IF (NOUNIT) X(J) = X(J)*A(1,J)
+ END IF
+ 60 CONTINUE
+ ELSE
+ KX = KX + (N-1)*INCX
+ JX = KX
+ DO 80 J = N,1,-1
+ IF (X(JX).NE.ZERO) THEN
+ TEMP = X(JX)
+ IX = KX
+ L = 1 - J
+ DO 70 I = MIN(N,J+K),J + 1,-1
+ X(IX) = X(IX) + TEMP*A(L+I,J)
+ IX = IX - INCX
+ 70 CONTINUE
+ IF (NOUNIT) X(JX) = X(JX)*A(1,J)
+ END IF
+ JX = JX - INCX
+ IF ((N-J).GE.K) KX = KX - INCX
+ 80 CONTINUE
+ END IF
+ END IF
+ ELSE
+*
+* Form x := A'*x.
+*
+ IF (LSAME(UPLO,'U')) THEN
+ KPLUS1 = K + 1
+ IF (INCX.EQ.1) THEN
+ DO 100 J = N,1,-1
+ TEMP = X(J)
+ L = KPLUS1 - J
+ IF (NOUNIT) TEMP = TEMP*A(KPLUS1,J)
+ DO 90 I = J - 1,MAX(1,J-K),-1
+ TEMP = TEMP + A(L+I,J)*X(I)
+ 90 CONTINUE
+ X(J) = TEMP
+ 100 CONTINUE
+ ELSE
+ KX = KX + (N-1)*INCX
+ JX = KX
+ DO 120 J = N,1,-1
+ TEMP = X(JX)
+ KX = KX - INCX
+ IX = KX
+ L = KPLUS1 - J
+ IF (NOUNIT) TEMP = TEMP*A(KPLUS1,J)
+ DO 110 I = J - 1,MAX(1,J-K),-1
+ TEMP = TEMP + A(L+I,J)*X(IX)
+ IX = IX - INCX
+ 110 CONTINUE
+ X(JX) = TEMP
+ JX = JX - INCX
+ 120 CONTINUE
+ END IF
+ ELSE
+ IF (INCX.EQ.1) THEN
+ DO 140 J = 1,N
+ TEMP = X(J)
+ L = 1 - J
+ IF (NOUNIT) TEMP = TEMP*A(1,J)
+ DO 130 I = J + 1,MIN(N,J+K)
+ TEMP = TEMP + A(L+I,J)*X(I)
+ 130 CONTINUE
+ X(J) = TEMP
+ 140 CONTINUE
+ ELSE
+ JX = KX
+ DO 160 J = 1,N
+ TEMP = X(JX)
+ KX = KX + INCX
+ IX = KX
+ L = 1 - J
+ IF (NOUNIT) TEMP = TEMP*A(1,J)
+ DO 150 I = J + 1,MIN(N,J+K)
+ TEMP = TEMP + A(L+I,J)*X(IX)
+ IX = IX + INCX
+ 150 CONTINUE
+ X(JX) = TEMP
+ JX = JX + INCX
+ 160 CONTINUE
+ END IF
+ END IF
+ END IF
+*
+ RETURN
+*
+* End of DTBMV .
+*
+ END
+ SUBROUTINE DTBSV(UPLO,TRANS,DIAG,N,K,A,LDA,X,INCX)
+* .. Scalar Arguments ..
+ INTEGER INCX,K,LDA,N
+ CHARACTER DIAG,TRANS,UPLO
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION A(LDA,*),X(*)
+* ..
+*
+* Purpose
+* =======
+*
+* DTBSV solves one of the systems of equations
+*
+* A*x = b, or A'*x = b,
+*
+* where b and x are n element vectors and A is an n by n unit, or
+* non-unit, upper or lower triangular band matrix, with ( k + 1 )
+* diagonals.
+*
+* No test for singularity or near-singularity is included in this
+* routine. Such tests must be performed before calling this routine.
+*
+* Arguments
+* ==========
+*
+* UPLO - CHARACTER*1.
+* On entry, UPLO specifies whether the matrix is an upper or
+* lower triangular matrix as follows:
+*
+* UPLO = 'U' or 'u' A is an upper triangular matrix.
+*
+* UPLO = 'L' or 'l' A is a lower triangular matrix.
+*
+* Unchanged on exit.
+*
+* TRANS - CHARACTER*1.
+* On entry, TRANS specifies the equations to be solved as
+* follows:
+*
+* TRANS = 'N' or 'n' A*x = b.
+*
+* TRANS = 'T' or 't' A'*x = b.
+*
+* TRANS = 'C' or 'c' A'*x = b.
+*
+* Unchanged on exit.
+*
+* DIAG - CHARACTER*1.
+* On entry, DIAG specifies whether or not A is unit
+* triangular as follows:
+*
+* DIAG = 'U' or 'u' A is assumed to be unit triangular.
+*
+* DIAG = 'N' or 'n' A is not assumed to be unit
+* triangular.
+*
+* Unchanged on exit.
+*
+* N - INTEGER.
+* On entry, N specifies the order of the matrix A.
+* N must be at least zero.
+* Unchanged on exit.
+*
+* K - INTEGER.
+* On entry with UPLO = 'U' or 'u', K specifies the number of
+* super-diagonals of the matrix A.
+* On entry with UPLO = 'L' or 'l', K specifies the number of
+* sub-diagonals of the matrix A.
+* K must satisfy 0 .le. K.
+* Unchanged on exit.
+*
+* A - DOUBLE PRECISION array of DIMENSION ( LDA, n ).
+* Before entry with UPLO = 'U' or 'u', the leading ( k + 1 )
+* by n part of the array A must contain the upper triangular
+* band part of the matrix of coefficients, supplied column by
+* column, with the leading diagonal of the matrix in row
+* ( k + 1 ) of the array, the first super-diagonal starting at
+* position 2 in row k, and so on. The top left k by k triangle
+* of the array A is not referenced.
+* The following program segment will transfer an upper
+* triangular band matrix from conventional full matrix storage
+* to band storage:
+*
+* DO 20, J = 1, N
+* M = K + 1 - J
+* DO 10, I = MAX( 1, J - K ), J
+* A( M + I, J ) = matrix( I, J )
+* 10 CONTINUE
+* 20 CONTINUE
+*
+* Before entry with UPLO = 'L' or 'l', the leading ( k + 1 )
+* by n part of the array A must contain the lower triangular
+* band part of the matrix of coefficients, supplied column by
+* column, with the leading diagonal of the matrix in row 1 of
+* the array, the first sub-diagonal starting at position 1 in
+* row 2, and so on. The bottom right k by k triangle of the
+* array A is not referenced.
+* The following program segment will transfer a lower
+* triangular band matrix from conventional full matrix storage
+* to band storage:
+*
+* DO 20, J = 1, N
+* M = 1 - J
+* DO 10, I = J, MIN( N, J + K )
+* A( M + I, J ) = matrix( I, J )
+* 10 CONTINUE
+* 20 CONTINUE
+*
+* Note that when DIAG = 'U' or 'u' the elements of the array A
+* corresponding to the diagonal elements of the matrix are not
+* referenced, but are assumed to be unity.
+* Unchanged on exit.
+*
+* LDA - INTEGER.
+* On entry, LDA specifies the first dimension of A as declared
+* in the calling (sub) program. LDA must be at least
+* ( k + 1 ).
+* Unchanged on exit.
+*
+* X - DOUBLE PRECISION array of dimension at least
+* ( 1 + ( n - 1 )*abs( INCX ) ).
+* Before entry, the incremented array X must contain the n
+* element right-hand side vector b. On exit, X is overwritten
+* with the solution vector x.
+*
+* INCX - INTEGER.
+* On entry, INCX specifies the increment for the elements of
+* X. INCX must not be zero.
+* Unchanged on exit.
+*
+*
+* Level 2 Blas routine.
+*
+* -- Written on 22-October-1986.
+* Jack Dongarra, Argonne National Lab.
+* Jeremy Du Croz, Nag Central Office.
+* Sven Hammarling, Nag Central Office.
+* Richard Hanson, Sandia National Labs.
+*
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO
+ PARAMETER (ZERO=0.0D+0)
+* ..
+* .. Local Scalars ..
+ DOUBLE PRECISION TEMP
+ INTEGER I,INFO,IX,J,JX,KPLUS1,KX,L
+ LOGICAL NOUNIT
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX,MIN
+* ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN
+ INFO = 1
+ ELSE IF (.NOT.LSAME(TRANS,'N') .AND. .NOT.LSAME(TRANS,'T') .AND.
+ + .NOT.LSAME(TRANS,'C')) THEN
+ INFO = 2
+ ELSE IF (.NOT.LSAME(DIAG,'U') .AND. .NOT.LSAME(DIAG,'N')) THEN
+ INFO = 3
+ ELSE IF (N.LT.0) THEN
+ INFO = 4
+ ELSE IF (K.LT.0) THEN
+ INFO = 5
+ ELSE IF (LDA.LT. (K+1)) THEN
+ INFO = 7
+ ELSE IF (INCX.EQ.0) THEN
+ INFO = 9
+ END IF
+ IF (INFO.NE.0) THEN
+ CALL XERBLA('DTBSV ',INFO)
+ RETURN
+ END IF
+*
+* Quick return if possible.
+*
+ IF (N.EQ.0) RETURN
+*
+ NOUNIT = LSAME(DIAG,'N')
+*
+* Set up the start point in X if the increment is not unity. This
+* will be ( N - 1 )*INCX too small for descending loops.
+*
+ IF (INCX.LE.0) THEN
+ KX = 1 - (N-1)*INCX
+ ELSE IF (INCX.NE.1) THEN
+ KX = 1
+ END IF
+*
+* Start the operations. In this version the elements of A are
+* accessed by sequentially with one pass through A.
+*
+ IF (LSAME(TRANS,'N')) THEN
+*
+* Form x := inv( A )*x.
+*
+ IF (LSAME(UPLO,'U')) THEN
+ KPLUS1 = K + 1
+ IF (INCX.EQ.1) THEN
+ DO 20 J = N,1,-1
+ IF (X(J).NE.ZERO) THEN
+ L = KPLUS1 - J
+ IF (NOUNIT) X(J) = X(J)/A(KPLUS1,J)
+ TEMP = X(J)
+ DO 10 I = J - 1,MAX(1,J-K),-1
+ X(I) = X(I) - TEMP*A(L+I,J)
+ 10 CONTINUE
+ END IF
+ 20 CONTINUE
+ ELSE
+ KX = KX + (N-1)*INCX
+ JX = KX
+ DO 40 J = N,1,-1
+ KX = KX - INCX
+ IF (X(JX).NE.ZERO) THEN
+ IX = KX
+ L = KPLUS1 - J
+ IF (NOUNIT) X(JX) = X(JX)/A(KPLUS1,J)
+ TEMP = X(JX)
+ DO 30 I = J - 1,MAX(1,J-K),-1
+ X(IX) = X(IX) - TEMP*A(L+I,J)
+ IX = IX - INCX
+ 30 CONTINUE
+ END IF
+ JX = JX - INCX
+ 40 CONTINUE
+ END IF
+ ELSE
+ IF (INCX.EQ.1) THEN
+ DO 60 J = 1,N
+ IF (X(J).NE.ZERO) THEN
+ L = 1 - J
+ IF (NOUNIT) X(J) = X(J)/A(1,J)
+ TEMP = X(J)
+ DO 50 I = J + 1,MIN(N,J+K)
+ X(I) = X(I) - TEMP*A(L+I,J)
+ 50 CONTINUE
+ END IF
+ 60 CONTINUE
+ ELSE
+ JX = KX
+ DO 80 J = 1,N
+ KX = KX + INCX
+ IF (X(JX).NE.ZERO) THEN
+ IX = KX
+ L = 1 - J
+ IF (NOUNIT) X(JX) = X(JX)/A(1,J)
+ TEMP = X(JX)
+ DO 70 I = J + 1,MIN(N,J+K)
+ X(IX) = X(IX) - TEMP*A(L+I,J)
+ IX = IX + INCX
+ 70 CONTINUE
+ END IF
+ JX = JX + INCX
+ 80 CONTINUE
+ END IF
+ END IF
+ ELSE
+*
+* Form x := inv( A')*x.
+*
+ IF (LSAME(UPLO,'U')) THEN
+ KPLUS1 = K + 1
+ IF (INCX.EQ.1) THEN
+ DO 100 J = 1,N
+ TEMP = X(J)
+ L = KPLUS1 - J
+ DO 90 I = MAX(1,J-K),J - 1
+ TEMP = TEMP - A(L+I,J)*X(I)
+ 90 CONTINUE
+ IF (NOUNIT) TEMP = TEMP/A(KPLUS1,J)
+ X(J) = TEMP
+ 100 CONTINUE
+ ELSE
+ JX = KX
+ DO 120 J = 1,N
+ TEMP = X(JX)
+ IX = KX
+ L = KPLUS1 - J
+ DO 110 I = MAX(1,J-K),J - 1
+ TEMP = TEMP - A(L+I,J)*X(IX)
+ IX = IX + INCX
+ 110 CONTINUE
+ IF (NOUNIT) TEMP = TEMP/A(KPLUS1,J)
+ X(JX) = TEMP
+ JX = JX + INCX
+ IF (J.GT.K) KX = KX + INCX
+ 120 CONTINUE
+ END IF
+ ELSE
+ IF (INCX.EQ.1) THEN
+ DO 140 J = N,1,-1
+ TEMP = X(J)
+ L = 1 - J
+ DO 130 I = MIN(N,J+K),J + 1,-1
+ TEMP = TEMP - A(L+I,J)*X(I)
+ 130 CONTINUE
+ IF (NOUNIT) TEMP = TEMP/A(1,J)
+ X(J) = TEMP
+ 140 CONTINUE
+ ELSE
+ KX = KX + (N-1)*INCX
+ JX = KX
+ DO 160 J = N,1,-1
+ TEMP = X(JX)
+ IX = KX
+ L = 1 - J
+ DO 150 I = MIN(N,J+K),J + 1,-1
+ TEMP = TEMP - A(L+I,J)*X(IX)
+ IX = IX - INCX
+ 150 CONTINUE
+ IF (NOUNIT) TEMP = TEMP/A(1,J)
+ X(JX) = TEMP
+ JX = JX - INCX
+ IF ((N-J).GE.K) KX = KX - INCX
+ 160 CONTINUE
+ END IF
+ END IF
+ END IF
+*
+ RETURN
+*
+* End of DTBSV .
+*
+ END
+ SUBROUTINE DTPMV(UPLO,TRANS,DIAG,N,AP,X,INCX)
+* .. Scalar Arguments ..
+ INTEGER INCX,N
+ CHARACTER DIAG,TRANS,UPLO
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION AP(*),X(*)
+* ..
+*
+* Purpose
+* =======
+*
+* DTPMV performs one of the matrix-vector operations
+*
+* x := A*x, or x := A'*x,
+*
+* where x is an n element vector and A is an n by n unit, or non-unit,
+* upper or lower triangular matrix, supplied in packed form.
+*
+* Arguments
+* ==========
+*
+* UPLO - CHARACTER*1.
+* On entry, UPLO specifies whether the matrix is an upper or
+* lower triangular matrix as follows:
+*
+* UPLO = 'U' or 'u' A is an upper triangular matrix.
+*
+* UPLO = 'L' or 'l' A is a lower triangular matrix.
+*
+* Unchanged on exit.
+*
+* TRANS - CHARACTER*1.
+* On entry, TRANS specifies the operation to be performed as
+* follows:
+*
+* TRANS = 'N' or 'n' x := A*x.
+*
+* TRANS = 'T' or 't' x := A'*x.
+*
+* TRANS = 'C' or 'c' x := A'*x.
+*
+* Unchanged on exit.
+*
+* DIAG - CHARACTER*1.
+* On entry, DIAG specifies whether or not A is unit
+* triangular as follows:
+*
+* DIAG = 'U' or 'u' A is assumed to be unit triangular.
+*
+* DIAG = 'N' or 'n' A is not assumed to be unit
+* triangular.
+*
+* Unchanged on exit.
+*
+* N - INTEGER.
+* On entry, N specifies the order of the matrix A.
+* N must be at least zero.
+* Unchanged on exit.
+*
+* AP - DOUBLE PRECISION array of DIMENSION at least
+* ( ( n*( n + 1 ) )/2 ).
+* Before entry with UPLO = 'U' or 'u', the array AP must
+* contain the upper triangular matrix packed sequentially,
+* column by column, so that AP( 1 ) contains a( 1, 1 ),
+* AP( 2 ) and AP( 3 ) contain a( 1, 2 ) and a( 2, 2 )
+* respectively, and so on.
+* Before entry with UPLO = 'L' or 'l', the array AP must
+* contain the lower triangular matrix packed sequentially,
+* column by column, so that AP( 1 ) contains a( 1, 1 ),
+* AP( 2 ) and AP( 3 ) contain a( 2, 1 ) and a( 3, 1 )
+* respectively, and so on.
+* Note that when DIAG = 'U' or 'u', the diagonal elements of
+* A are not referenced, but are assumed to be unity.
+* Unchanged on exit.
+*
+* X - DOUBLE PRECISION array of dimension at least
+* ( 1 + ( n - 1 )*abs( INCX ) ).
+* Before entry, the incremented array X must contain the n
+* element vector x. On exit, X is overwritten with the
+* tranformed vector x.
+*
+* INCX - INTEGER.
+* On entry, INCX specifies the increment for the elements of
+* X. INCX must not be zero.
+* Unchanged on exit.
+*
+*
+* Level 2 Blas routine.
+*
+* -- Written on 22-October-1986.
+* Jack Dongarra, Argonne National Lab.
+* Jeremy Du Croz, Nag Central Office.
+* Sven Hammarling, Nag Central Office.
+* Richard Hanson, Sandia National Labs.
+*
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO
+ PARAMETER (ZERO=0.0D+0)
+* ..
+* .. Local Scalars ..
+ DOUBLE PRECISION TEMP
+ INTEGER I,INFO,IX,J,JX,K,KK,KX
+ LOGICAL NOUNIT
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL XERBLA
+* ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN
+ INFO = 1
+ ELSE IF (.NOT.LSAME(TRANS,'N') .AND. .NOT.LSAME(TRANS,'T') .AND.
+ + .NOT.LSAME(TRANS,'C')) THEN
+ INFO = 2
+ ELSE IF (.NOT.LSAME(DIAG,'U') .AND. .NOT.LSAME(DIAG,'N')) THEN
+ INFO = 3
+ ELSE IF (N.LT.0) THEN
+ INFO = 4
+ ELSE IF (INCX.EQ.0) THEN
+ INFO = 7
+ END IF
+ IF (INFO.NE.0) THEN
+ CALL XERBLA('DTPMV ',INFO)
+ RETURN
+ END IF
+*
+* Quick return if possible.
+*
+ IF (N.EQ.0) RETURN
+*
+ NOUNIT = LSAME(DIAG,'N')
+*
+* Set up the start point in X if the increment is not unity. This
+* will be ( N - 1 )*INCX too small for descending loops.
+*
+ IF (INCX.LE.0) THEN
+ KX = 1 - (N-1)*INCX
+ ELSE IF (INCX.NE.1) THEN
+ KX = 1
+ END IF
+*
+* Start the operations. In this version the elements of AP are
+* accessed sequentially with one pass through AP.
+*
+ IF (LSAME(TRANS,'N')) THEN
+*
+* Form x:= A*x.
+*
+ IF (LSAME(UPLO,'U')) THEN
+ KK = 1
+ IF (INCX.EQ.1) THEN
+ DO 20 J = 1,N
+ IF (X(J).NE.ZERO) THEN
+ TEMP = X(J)
+ K = KK
+ DO 10 I = 1,J - 1
+ X(I) = X(I) + TEMP*AP(K)
+ K = K + 1
+ 10 CONTINUE
+ IF (NOUNIT) X(J) = X(J)*AP(KK+J-1)
+ END IF
+ KK = KK + J
+ 20 CONTINUE
+ ELSE
+ JX = KX
+ DO 40 J = 1,N
+ IF (X(JX).NE.ZERO) THEN
+ TEMP = X(JX)
+ IX = KX
+ DO 30 K = KK,KK + J - 2
+ X(IX) = X(IX) + TEMP*AP(K)
+ IX = IX + INCX
+ 30 CONTINUE
+ IF (NOUNIT) X(JX) = X(JX)*AP(KK+J-1)
+ END IF
+ JX = JX + INCX
+ KK = KK + J
+ 40 CONTINUE
+ END IF
+ ELSE
+ KK = (N* (N+1))/2
+ IF (INCX.EQ.1) THEN
+ DO 60 J = N,1,-1
+ IF (X(J).NE.ZERO) THEN
+ TEMP = X(J)
+ K = KK
+ DO 50 I = N,J + 1,-1
+ X(I) = X(I) + TEMP*AP(K)
+ K = K - 1
+ 50 CONTINUE
+ IF (NOUNIT) X(J) = X(J)*AP(KK-N+J)
+ END IF
+ KK = KK - (N-J+1)
+ 60 CONTINUE
+ ELSE
+ KX = KX + (N-1)*INCX
+ JX = KX
+ DO 80 J = N,1,-1
+ IF (X(JX).NE.ZERO) THEN
+ TEMP = X(JX)
+ IX = KX
+ DO 70 K = KK,KK - (N- (J+1)),-1
+ X(IX) = X(IX) + TEMP*AP(K)
+ IX = IX - INCX
+ 70 CONTINUE
+ IF (NOUNIT) X(JX) = X(JX)*AP(KK-N+J)
+ END IF
+ JX = JX - INCX
+ KK = KK - (N-J+1)
+ 80 CONTINUE
+ END IF
+ END IF
+ ELSE
+*
+* Form x := A'*x.
+*
+ IF (LSAME(UPLO,'U')) THEN
+ KK = (N* (N+1))/2
+ IF (INCX.EQ.1) THEN
+ DO 100 J = N,1,-1
+ TEMP = X(J)
+ IF (NOUNIT) TEMP = TEMP*AP(KK)
+ K = KK - 1
+ DO 90 I = J - 1,1,-1
+ TEMP = TEMP + AP(K)*X(I)
+ K = K - 1
+ 90 CONTINUE
+ X(J) = TEMP
+ KK = KK - J
+ 100 CONTINUE
+ ELSE
+ JX = KX + (N-1)*INCX
+ DO 120 J = N,1,-1
+ TEMP = X(JX)
+ IX = JX
+ IF (NOUNIT) TEMP = TEMP*AP(KK)
+ DO 110 K = KK - 1,KK - J + 1,-1
+ IX = IX - INCX
+ TEMP = TEMP + AP(K)*X(IX)
+ 110 CONTINUE
+ X(JX) = TEMP
+ JX = JX - INCX
+ KK = KK - J
+ 120 CONTINUE
+ END IF
+ ELSE
+ KK = 1
+ IF (INCX.EQ.1) THEN
+ DO 140 J = 1,N
+ TEMP = X(J)
+ IF (NOUNIT) TEMP = TEMP*AP(KK)
+ K = KK + 1
+ DO 130 I = J + 1,N
+ TEMP = TEMP + AP(K)*X(I)
+ K = K + 1
+ 130 CONTINUE
+ X(J) = TEMP
+ KK = KK + (N-J+1)
+ 140 CONTINUE
+ ELSE
+ JX = KX
+ DO 160 J = 1,N
+ TEMP = X(JX)
+ IX = JX
+ IF (NOUNIT) TEMP = TEMP*AP(KK)
+ DO 150 K = KK + 1,KK + N - J
+ IX = IX + INCX
+ TEMP = TEMP + AP(K)*X(IX)
+ 150 CONTINUE
+ X(JX) = TEMP
+ JX = JX + INCX
+ KK = KK + (N-J+1)
+ 160 CONTINUE
+ END IF
+ END IF
+ END IF
+*
+ RETURN
+*
+* End of DTPMV .
+*
+ END
+ SUBROUTINE DTPSV(UPLO,TRANS,DIAG,N,AP,X,INCX)
+* .. Scalar Arguments ..
+ INTEGER INCX,N
+ CHARACTER DIAG,TRANS,UPLO
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION AP(*),X(*)
+* ..
+*
+* Purpose
+* =======
+*
+* DTPSV solves one of the systems of equations
+*
+* A*x = b, or A'*x = b,
+*
+* where b and x are n element vectors and A is an n by n unit, or
+* non-unit, upper or lower triangular matrix, supplied in packed form.
+*
+* No test for singularity or near-singularity is included in this
+* routine. Such tests must be performed before calling this routine.
+*
+* Arguments
+* ==========
+*
+* UPLO - CHARACTER*1.
+* On entry, UPLO specifies whether the matrix is an upper or
+* lower triangular matrix as follows:
+*
+* UPLO = 'U' or 'u' A is an upper triangular matrix.
+*
+* UPLO = 'L' or 'l' A is a lower triangular matrix.
+*
+* Unchanged on exit.
+*
+* TRANS - CHARACTER*1.
+* On entry, TRANS specifies the equations to be solved as
+* follows:
+*
+* TRANS = 'N' or 'n' A*x = b.
+*
+* TRANS = 'T' or 't' A'*x = b.
+*
+* TRANS = 'C' or 'c' A'*x = b.
+*
+* Unchanged on exit.
+*
+* DIAG - CHARACTER*1.
+* On entry, DIAG specifies whether or not A is unit
+* triangular as follows:
+*
+* DIAG = 'U' or 'u' A is assumed to be unit triangular.
+*
+* DIAG = 'N' or 'n' A is not assumed to be unit
+* triangular.
+*
+* Unchanged on exit.
+*
+* N - INTEGER.
+* On entry, N specifies the order of the matrix A.
+* N must be at least zero.
+* Unchanged on exit.
+*
+* AP - DOUBLE PRECISION array of DIMENSION at least
+* ( ( n*( n + 1 ) )/2 ).
+* Before entry with UPLO = 'U' or 'u', the array AP must
+* contain the upper triangular matrix packed sequentially,
+* column by column, so that AP( 1 ) contains a( 1, 1 ),
+* AP( 2 ) and AP( 3 ) contain a( 1, 2 ) and a( 2, 2 )
+* respectively, and so on.
+* Before entry with UPLO = 'L' or 'l', the array AP must
+* contain the lower triangular matrix packed sequentially,
+* column by column, so that AP( 1 ) contains a( 1, 1 ),
+* AP( 2 ) and AP( 3 ) contain a( 2, 1 ) and a( 3, 1 )
+* respectively, and so on.
+* Note that when DIAG = 'U' or 'u', the diagonal elements of
+* A are not referenced, but are assumed to be unity.
+* Unchanged on exit.
+*
+* X - DOUBLE PRECISION array of dimension at least
+* ( 1 + ( n - 1 )*abs( INCX ) ).
+* Before entry, the incremented array X must contain the n
+* element right-hand side vector b. On exit, X is overwritten
+* with the solution vector x.
+*
+* INCX - INTEGER.
+* On entry, INCX specifies the increment for the elements of
+* X. INCX must not be zero.
+* Unchanged on exit.
+*
+*
+* Level 2 Blas routine.
+*
+* -- Written on 22-October-1986.
+* Jack Dongarra, Argonne National Lab.
+* Jeremy Du Croz, Nag Central Office.
+* Sven Hammarling, Nag Central Office.
+* Richard Hanson, Sandia National Labs.
+*
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO
+ PARAMETER (ZERO=0.0D+0)
+* ..
+* .. Local Scalars ..
+ DOUBLE PRECISION TEMP
+ INTEGER I,INFO,IX,J,JX,K,KK,KX
+ LOGICAL NOUNIT
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL XERBLA
+* ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN
+ INFO = 1
+ ELSE IF (.NOT.LSAME(TRANS,'N') .AND. .NOT.LSAME(TRANS,'T') .AND.
+ + .NOT.LSAME(TRANS,'C')) THEN
+ INFO = 2
+ ELSE IF (.NOT.LSAME(DIAG,'U') .AND. .NOT.LSAME(DIAG,'N')) THEN
+ INFO = 3
+ ELSE IF (N.LT.0) THEN
+ INFO = 4
+ ELSE IF (INCX.EQ.0) THEN
+ INFO = 7
+ END IF
+ IF (INFO.NE.0) THEN
+ CALL XERBLA('DTPSV ',INFO)
+ RETURN
+ END IF
+*
+* Quick return if possible.
+*
+ IF (N.EQ.0) RETURN
+*
+ NOUNIT = LSAME(DIAG,'N')
+*
+* Set up the start point in X if the increment is not unity. This
+* will be ( N - 1 )*INCX too small for descending loops.
+*
+ IF (INCX.LE.0) THEN
+ KX = 1 - (N-1)*INCX
+ ELSE IF (INCX.NE.1) THEN
+ KX = 1
+ END IF
+*
+* Start the operations. In this version the elements of AP are
+* accessed sequentially with one pass through AP.
+*
+ IF (LSAME(TRANS,'N')) THEN
+*
+* Form x := inv( A )*x.
+*
+ IF (LSAME(UPLO,'U')) THEN
+ KK = (N* (N+1))/2
+ IF (INCX.EQ.1) THEN
+ DO 20 J = N,1,-1
+ IF (X(J).NE.ZERO) THEN
+ IF (NOUNIT) X(J) = X(J)/AP(KK)
+ TEMP = X(J)
+ K = KK - 1
+ DO 10 I = J - 1,1,-1
+ X(I) = X(I) - TEMP*AP(K)
+ K = K - 1
+ 10 CONTINUE
+ END IF
+ KK = KK - J
+ 20 CONTINUE
+ ELSE
+ JX = KX + (N-1)*INCX
+ DO 40 J = N,1,-1
+ IF (X(JX).NE.ZERO) THEN
+ IF (NOUNIT) X(JX) = X(JX)/AP(KK)
+ TEMP = X(JX)
+ IX = JX
+ DO 30 K = KK - 1,KK - J + 1,-1
+ IX = IX - INCX
+ X(IX) = X(IX) - TEMP*AP(K)
+ 30 CONTINUE
+ END IF
+ JX = JX - INCX
+ KK = KK - J
+ 40 CONTINUE
+ END IF
+ ELSE
+ KK = 1
+ IF (INCX.EQ.1) THEN
+ DO 60 J = 1,N
+ IF (X(J).NE.ZERO) THEN
+ IF (NOUNIT) X(J) = X(J)/AP(KK)
+ TEMP = X(J)
+ K = KK + 1
+ DO 50 I = J + 1,N
+ X(I) = X(I) - TEMP*AP(K)
+ K = K + 1
+ 50 CONTINUE
+ END IF
+ KK = KK + (N-J+1)
+ 60 CONTINUE
+ ELSE
+ JX = KX
+ DO 80 J = 1,N
+ IF (X(JX).NE.ZERO) THEN
+ IF (NOUNIT) X(JX) = X(JX)/AP(KK)
+ TEMP = X(JX)
+ IX = JX
+ DO 70 K = KK + 1,KK + N - J
+ IX = IX + INCX
+ X(IX) = X(IX) - TEMP*AP(K)
+ 70 CONTINUE
+ END IF
+ JX = JX + INCX
+ KK = KK + (N-J+1)
+ 80 CONTINUE
+ END IF
+ END IF
+ ELSE
+*
+* Form x := inv( A' )*x.
+*
+ IF (LSAME(UPLO,'U')) THEN
+ KK = 1
+ IF (INCX.EQ.1) THEN
+ DO 100 J = 1,N
+ TEMP = X(J)
+ K = KK
+ DO 90 I = 1,J - 1
+ TEMP = TEMP - AP(K)*X(I)
+ K = K + 1
+ 90 CONTINUE
+ IF (NOUNIT) TEMP = TEMP/AP(KK+J-1)
+ X(J) = TEMP
+ KK = KK + J
+ 100 CONTINUE
+ ELSE
+ JX = KX
+ DO 120 J = 1,N
+ TEMP = X(JX)
+ IX = KX
+ DO 110 K = KK,KK + J - 2
+ TEMP = TEMP - AP(K)*X(IX)
+ IX = IX + INCX
+ 110 CONTINUE
+ IF (NOUNIT) TEMP = TEMP/AP(KK+J-1)
+ X(JX) = TEMP
+ JX = JX + INCX
+ KK = KK + J
+ 120 CONTINUE
+ END IF
+ ELSE
+ KK = (N* (N+1))/2
+ IF (INCX.EQ.1) THEN
+ DO 140 J = N,1,-1
+ TEMP = X(J)
+ K = KK
+ DO 130 I = N,J + 1,-1
+ TEMP = TEMP - AP(K)*X(I)
+ K = K - 1
+ 130 CONTINUE
+ IF (NOUNIT) TEMP = TEMP/AP(KK-N+J)
+ X(J) = TEMP
+ KK = KK - (N-J+1)
+ 140 CONTINUE
+ ELSE
+ KX = KX + (N-1)*INCX
+ JX = KX
+ DO 160 J = N,1,-1
+ TEMP = X(JX)
+ IX = KX
+ DO 150 K = KK,KK - (N- (J+1)),-1
+ TEMP = TEMP - AP(K)*X(IX)
+ IX = IX - INCX
+ 150 CONTINUE
+ IF (NOUNIT) TEMP = TEMP/AP(KK-N+J)
+ X(JX) = TEMP
+ JX = JX - INCX
+ KK = KK - (N-J+1)
+ 160 CONTINUE
+ END IF
+ END IF
+ END IF
+*
+ RETURN
+*
+* End of DTPSV .
+*
+ END
+ SUBROUTINE DTRMM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB)
+* .. Scalar Arguments ..
+ DOUBLE PRECISION ALPHA
+ INTEGER LDA,LDB,M,N
+ CHARACTER DIAG,SIDE,TRANSA,UPLO
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION A(LDA,*),B(LDB,*)
+* ..
+*
+* Purpose
+* =======
+*
+* DTRMM performs one of the matrix-matrix operations
+*
+* B := alpha*op( A )*B, or B := alpha*B*op( A ),
+*
+* where alpha is a scalar, B is an m by n matrix, A is a unit, or
+* non-unit, upper or lower triangular matrix and op( A ) is one of
+*
+* op( A ) = A or op( A ) = A'.
+*
+* Arguments
+* ==========
+*
+* SIDE - CHARACTER*1.
+* On entry, SIDE specifies whether op( A ) multiplies B from
+* the left or right as follows:
+*
+* SIDE = 'L' or 'l' B := alpha*op( A )*B.
+*
+* SIDE = 'R' or 'r' B := alpha*B*op( A ).
+*
+* Unchanged on exit.
+*
+* UPLO - CHARACTER*1.
+* On entry, UPLO specifies whether the matrix A is an upper or
+* lower triangular matrix as follows:
+*
+* UPLO = 'U' or 'u' A is an upper triangular matrix.
+*
+* UPLO = 'L' or 'l' A is a lower triangular matrix.
+*
+* Unchanged on exit.
+*
+* TRANSA - CHARACTER*1.
+* On entry, TRANSA specifies the form of op( A ) to be used in
+* the matrix multiplication as follows:
+*
+* TRANSA = 'N' or 'n' op( A ) = A.
+*
+* TRANSA = 'T' or 't' op( A ) = A'.
+*
+* TRANSA = 'C' or 'c' op( A ) = A'.
+*
+* Unchanged on exit.
+*
+* DIAG - CHARACTER*1.
+* On entry, DIAG specifies whether or not A is unit triangular
+* as follows:
+*
+* DIAG = 'U' or 'u' A is assumed to be unit triangular.
+*
+* DIAG = 'N' or 'n' A is not assumed to be unit
+* triangular.
+*
+* Unchanged on exit.
+*
+* M - INTEGER.
+* On entry, M specifies the number of rows of B. M must be at
+* least zero.
+* Unchanged on exit.
+*
+* N - INTEGER.
+* On entry, N specifies the number of columns of B. N must be
+* at least zero.
+* Unchanged on exit.
+*
+* ALPHA - DOUBLE PRECISION.
+* On entry, ALPHA specifies the scalar alpha. When alpha is
+* zero then A is not referenced and B need not be set before
+* entry.
+* Unchanged on exit.
+*
+* A - DOUBLE PRECISION array of DIMENSION ( LDA, k ), where k is m
+* when SIDE = 'L' or 'l' and is n when SIDE = 'R' or 'r'.
+* Before entry with UPLO = 'U' or 'u', the leading k by k
+* upper triangular part of the array A must contain the upper
+* triangular matrix and the strictly lower triangular part of
+* A is not referenced.
+* Before entry with UPLO = 'L' or 'l', the leading k by k
+* lower triangular part of the array A must contain the lower
+* triangular matrix and the strictly upper triangular part of
+* A is not referenced.
+* Note that when DIAG = 'U' or 'u', the diagonal elements of
+* A are not referenced either, but are assumed to be unity.
+* Unchanged on exit.
+*
+* LDA - INTEGER.
+* On entry, LDA specifies the first dimension of A as declared
+* in the calling (sub) program. When SIDE = 'L' or 'l' then
+* LDA must be at least max( 1, m ), when SIDE = 'R' or 'r'
+* then LDA must be at least max( 1, n ).
+* Unchanged on exit.
+*
+* B - DOUBLE PRECISION array of DIMENSION ( LDB, n ).
+* Before entry, the leading m by n part of the array B must
+* contain the matrix B, and on exit is overwritten by the
+* transformed matrix.
+*
+* LDB - INTEGER.
+* On entry, LDB specifies the first dimension of B as declared
+* in the calling (sub) program. LDB must be at least
+* max( 1, m ).
+* Unchanged on exit.
+*
+*
+* Level 3 Blas routine.
+*
+* -- Written on 8-February-1989.
+* Jack Dongarra, Argonne National Laboratory.
+* Iain Duff, AERE Harwell.
+* Jeremy Du Croz, Numerical Algorithms Group Ltd.
+* Sven Hammarling, Numerical Algorithms Group Ltd.
+*
+*
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Local Scalars ..
+ DOUBLE PRECISION TEMP
+ INTEGER I,INFO,J,K,NROWA
+ LOGICAL LSIDE,NOUNIT,UPPER
+* ..
+* .. Parameters ..
+ DOUBLE PRECISION ONE,ZERO
+ PARAMETER (ONE=1.0D+0,ZERO=0.0D+0)
+* ..
+*
+* Test the input parameters.
+*
+ LSIDE = LSAME(SIDE,'L')
+ IF (LSIDE) THEN
+ NROWA = M
+ ELSE
+ NROWA = N
+ END IF
+ NOUNIT = LSAME(DIAG,'N')
+ UPPER = LSAME(UPLO,'U')
+*
+ INFO = 0
+ IF ((.NOT.LSIDE) .AND. (.NOT.LSAME(SIDE,'R'))) THEN
+ INFO = 1
+ ELSE IF ((.NOT.UPPER) .AND. (.NOT.LSAME(UPLO,'L'))) THEN
+ INFO = 2
+ ELSE IF ((.NOT.LSAME(TRANSA,'N')) .AND.
+ + (.NOT.LSAME(TRANSA,'T')) .AND.
+ + (.NOT.LSAME(TRANSA,'C'))) THEN
+ INFO = 3
+ ELSE IF ((.NOT.LSAME(DIAG,'U')) .AND. (.NOT.LSAME(DIAG,'N'))) THEN
+ INFO = 4
+ ELSE IF (M.LT.0) THEN
+ INFO = 5
+ ELSE IF (N.LT.0) THEN
+ INFO = 6
+ ELSE IF (LDA.LT.MAX(1,NROWA)) THEN
+ INFO = 9
+ ELSE IF (LDB.LT.MAX(1,M)) THEN
+ INFO = 11
+ END IF
+ IF (INFO.NE.0) THEN
+ CALL XERBLA('DTRMM ',INFO)
+ RETURN
+ END IF
+*
+* Quick return if possible.
+*
+ IF (N.EQ.0) RETURN
+*
+* And when alpha.eq.zero.
+*
+ IF (ALPHA.EQ.ZERO) THEN
+ DO 20 J = 1,N
+ DO 10 I = 1,M
+ B(I,J) = ZERO
+ 10 CONTINUE
+ 20 CONTINUE
+ RETURN
+ END IF
+*
+* Start the operations.
+*
+ IF (LSIDE) THEN
+ IF (LSAME(TRANSA,'N')) THEN
+*
+* Form B := alpha*A*B.
+*
+ IF (UPPER) THEN
+ DO 50 J = 1,N
+ DO 40 K = 1,M
+ IF (B(K,J).NE.ZERO) THEN
+ TEMP = ALPHA*B(K,J)
+ DO 30 I = 1,K - 1
+ B(I,J) = B(I,J) + TEMP*A(I,K)
+ 30 CONTINUE
+ IF (NOUNIT) TEMP = TEMP*A(K,K)
+ B(K,J) = TEMP
+ END IF
+ 40 CONTINUE
+ 50 CONTINUE
+ ELSE
+ DO 80 J = 1,N
+ DO 70 K = M,1,-1
+ IF (B(K,J).NE.ZERO) THEN
+ TEMP = ALPHA*B(K,J)
+ B(K,J) = TEMP
+ IF (NOUNIT) B(K,J) = B(K,J)*A(K,K)
+ DO 60 I = K + 1,M
+ B(I,J) = B(I,J) + TEMP*A(I,K)
+ 60 CONTINUE
+ END IF
+ 70 CONTINUE
+ 80 CONTINUE
+ END IF
+ ELSE
+*
+* Form B := alpha*A'*B.
+*
+ IF (UPPER) THEN
+ DO 110 J = 1,N
+ DO 100 I = M,1,-1
+ TEMP = B(I,J)
+ IF (NOUNIT) TEMP = TEMP*A(I,I)
+ DO 90 K = 1,I - 1
+ TEMP = TEMP + A(K,I)*B(K,J)
+ 90 CONTINUE
+ B(I,J) = ALPHA*TEMP
+ 100 CONTINUE
+ 110 CONTINUE
+ ELSE
+ DO 140 J = 1,N
+ DO 130 I = 1,M
+ TEMP = B(I,J)
+ IF (NOUNIT) TEMP = TEMP*A(I,I)
+ DO 120 K = I + 1,M
+ TEMP = TEMP + A(K,I)*B(K,J)
+ 120 CONTINUE
+ B(I,J) = ALPHA*TEMP
+ 130 CONTINUE
+ 140 CONTINUE
+ END IF
+ END IF
+ ELSE
+ IF (LSAME(TRANSA,'N')) THEN
+*
+* Form B := alpha*B*A.
+*
+ IF (UPPER) THEN
+ DO 180 J = N,1,-1
+ TEMP = ALPHA
+ IF (NOUNIT) TEMP = TEMP*A(J,J)
+ DO 150 I = 1,M
+ B(I,J) = TEMP*B(I,J)
+ 150 CONTINUE
+ DO 170 K = 1,J - 1
+ IF (A(K,J).NE.ZERO) THEN
+ TEMP = ALPHA*A(K,J)
+ DO 160 I = 1,M
+ B(I,J) = B(I,J) + TEMP*B(I,K)
+ 160 CONTINUE
+ END IF
+ 170 CONTINUE
+ 180 CONTINUE
+ ELSE
+ DO 220 J = 1,N
+ TEMP = ALPHA
+ IF (NOUNIT) TEMP = TEMP*A(J,J)
+ DO 190 I = 1,M
+ B(I,J) = TEMP*B(I,J)
+ 190 CONTINUE
+ DO 210 K = J + 1,N
+ IF (A(K,J).NE.ZERO) THEN
+ TEMP = ALPHA*A(K,J)
+ DO 200 I = 1,M
+ B(I,J) = B(I,J) + TEMP*B(I,K)
+ 200 CONTINUE
+ END IF
+ 210 CONTINUE
+ 220 CONTINUE
+ END IF
+ ELSE
+*
+* Form B := alpha*B*A'.
+*
+ IF (UPPER) THEN
+ DO 260 K = 1,N
+ DO 240 J = 1,K - 1
+ IF (A(J,K).NE.ZERO) THEN
+ TEMP = ALPHA*A(J,K)
+ DO 230 I = 1,M
+ B(I,J) = B(I,J) + TEMP*B(I,K)
+ 230 CONTINUE
+ END IF
+ 240 CONTINUE
+ TEMP = ALPHA
+ IF (NOUNIT) TEMP = TEMP*A(K,K)
+ IF (TEMP.NE.ONE) THEN
+ DO 250 I = 1,M
+ B(I,K) = TEMP*B(I,K)
+ 250 CONTINUE
+ END IF
+ 260 CONTINUE
+ ELSE
+ DO 300 K = N,1,-1
+ DO 280 J = K + 1,N
+ IF (A(J,K).NE.ZERO) THEN
+ TEMP = ALPHA*A(J,K)
+ DO 270 I = 1,M
+ B(I,J) = B(I,J) + TEMP*B(I,K)
+ 270 CONTINUE
+ END IF
+ 280 CONTINUE
+ TEMP = ALPHA
+ IF (NOUNIT) TEMP = TEMP*A(K,K)
+ IF (TEMP.NE.ONE) THEN
+ DO 290 I = 1,M
+ B(I,K) = TEMP*B(I,K)
+ 290 CONTINUE
+ END IF
+ 300 CONTINUE
+ END IF
+ END IF
+ END IF
+*
+ RETURN
+*
+* End of DTRMM .
+*
+ END
+ SUBROUTINE DTRMV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX)
+* .. Scalar Arguments ..
+ INTEGER INCX,LDA,N
+ CHARACTER DIAG,TRANS,UPLO
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION A(LDA,*),X(*)
+* ..
+*
+* Purpose
+* =======
+*
+* DTRMV performs one of the matrix-vector operations
+*
+* x := A*x, or x := A'*x,
+*
+* where x is an n element vector and A is an n by n unit, or non-unit,
+* upper or lower triangular matrix.
+*
+* Arguments
+* ==========
+*
+* UPLO - CHARACTER*1.
+* On entry, UPLO specifies whether the matrix is an upper or
+* lower triangular matrix as follows:
+*
+* UPLO = 'U' or 'u' A is an upper triangular matrix.
+*
+* UPLO = 'L' or 'l' A is a lower triangular matrix.
+*
+* Unchanged on exit.
+*
+* TRANS - CHARACTER*1.
+* On entry, TRANS specifies the operation to be performed as
+* follows:
+*
+* TRANS = 'N' or 'n' x := A*x.
+*
+* TRANS = 'T' or 't' x := A'*x.
+*
+* TRANS = 'C' or 'c' x := A'*x.
+*
+* Unchanged on exit.
+*
+* DIAG - CHARACTER*1.
+* On entry, DIAG specifies whether or not A is unit
+* triangular as follows:
+*
+* DIAG = 'U' or 'u' A is assumed to be unit triangular.
+*
+* DIAG = 'N' or 'n' A is not assumed to be unit
+* triangular.
+*
+* Unchanged on exit.
+*
+* N - INTEGER.
+* On entry, N specifies the order of the matrix A.
+* N must be at least zero.
+* Unchanged on exit.
+*
+* A - DOUBLE PRECISION array of DIMENSION ( LDA, n ).
+* Before entry with UPLO = 'U' or 'u', the leading n by n
+* upper triangular part of the array A must contain the upper
+* triangular matrix and the strictly lower triangular part of
+* A is not referenced.
+* Before entry with UPLO = 'L' or 'l', the leading n by n
+* lower triangular part of the array A must contain the lower
+* triangular matrix and the strictly upper triangular part of
+* A is not referenced.
+* Note that when DIAG = 'U' or 'u', the diagonal elements of
+* A are not referenced either, but are assumed to be unity.
+* Unchanged on exit.
+*
+* LDA - INTEGER.
+* On entry, LDA specifies the first dimension of A as declared
+* in the calling (sub) program. LDA must be at least
+* max( 1, n ).
+* Unchanged on exit.
+*
+* X - DOUBLE PRECISION array of dimension at least
+* ( 1 + ( n - 1 )*abs( INCX ) ).
+* Before entry, the incremented array X must contain the n
+* element vector x. On exit, X is overwritten with the
+* tranformed vector x.
+*
+* INCX - INTEGER.
+* On entry, INCX specifies the increment for the elements of
+* X. INCX must not be zero.
+* Unchanged on exit.
+*
+*
+* Level 2 Blas routine.
+*
+* -- Written on 22-October-1986.
+* Jack Dongarra, Argonne National Lab.
+* Jeremy Du Croz, Nag Central Office.
+* Sven Hammarling, Nag Central Office.
+* Richard Hanson, Sandia National Labs.
+*
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO
+ PARAMETER (ZERO=0.0D+0)
+* ..
+* .. Local Scalars ..
+ DOUBLE PRECISION TEMP
+ INTEGER I,INFO,IX,J,JX,KX
+ LOGICAL NOUNIT
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN
+ INFO = 1
+ ELSE IF (.NOT.LSAME(TRANS,'N') .AND. .NOT.LSAME(TRANS,'T') .AND.
+ + .NOT.LSAME(TRANS,'C')) THEN
+ INFO = 2
+ ELSE IF (.NOT.LSAME(DIAG,'U') .AND. .NOT.LSAME(DIAG,'N')) THEN
+ INFO = 3
+ ELSE IF (N.LT.0) THEN
+ INFO = 4
+ ELSE IF (LDA.LT.MAX(1,N)) THEN
+ INFO = 6
+ ELSE IF (INCX.EQ.0) THEN
+ INFO = 8
+ END IF
+ IF (INFO.NE.0) THEN
+ CALL XERBLA('DTRMV ',INFO)
+ RETURN
+ END IF
+*
+* Quick return if possible.
+*
+ IF (N.EQ.0) RETURN
+*
+ NOUNIT = LSAME(DIAG,'N')
+*
+* Set up the start point in X if the increment is not unity. This
+* will be ( N - 1 )*INCX too small for descending loops.
+*
+ IF (INCX.LE.0) THEN
+ KX = 1 - (N-1)*INCX
+ ELSE IF (INCX.NE.1) THEN
+ KX = 1
+ END IF
+*
+* Start the operations. In this version the elements of A are
+* accessed sequentially with one pass through A.
+*
+ IF (LSAME(TRANS,'N')) THEN
+*
+* Form x := A*x.
+*
+ IF (LSAME(UPLO,'U')) THEN
+ IF (INCX.EQ.1) THEN
+ DO 20 J = 1,N
+ IF (X(J).NE.ZERO) THEN
+ TEMP = X(J)
+ DO 10 I = 1,J - 1
+ X(I) = X(I) + TEMP*A(I,J)
+ 10 CONTINUE
+ IF (NOUNIT) X(J) = X(J)*A(J,J)
+ END IF
+ 20 CONTINUE
+ ELSE
+ JX = KX
+ DO 40 J = 1,N
+ IF (X(JX).NE.ZERO) THEN
+ TEMP = X(JX)
+ IX = KX
+ DO 30 I = 1,J - 1
+ X(IX) = X(IX) + TEMP*A(I,J)
+ IX = IX + INCX
+ 30 CONTINUE
+ IF (NOUNIT) X(JX) = X(JX)*A(J,J)
+ END IF
+ JX = JX + INCX
+ 40 CONTINUE
+ END IF
+ ELSE
+ IF (INCX.EQ.1) THEN
+ DO 60 J = N,1,-1
+ IF (X(J).NE.ZERO) THEN
+ TEMP = X(J)
+ DO 50 I = N,J + 1,-1
+ X(I) = X(I) + TEMP*A(I,J)
+ 50 CONTINUE
+ IF (NOUNIT) X(J) = X(J)*A(J,J)
+ END IF
+ 60 CONTINUE
+ ELSE
+ KX = KX + (N-1)*INCX
+ JX = KX
+ DO 80 J = N,1,-1
+ IF (X(JX).NE.ZERO) THEN
+ TEMP = X(JX)
+ IX = KX
+ DO 70 I = N,J + 1,-1
+ X(IX) = X(IX) + TEMP*A(I,J)
+ IX = IX - INCX
+ 70 CONTINUE
+ IF (NOUNIT) X(JX) = X(JX)*A(J,J)
+ END IF
+ JX = JX - INCX
+ 80 CONTINUE
+ END IF
+ END IF
+ ELSE
+*
+* Form x := A'*x.
+*
+ IF (LSAME(UPLO,'U')) THEN
+ IF (INCX.EQ.1) THEN
+ DO 100 J = N,1,-1
+ TEMP = X(J)
+ IF (NOUNIT) TEMP = TEMP*A(J,J)
+ DO 90 I = J - 1,1,-1
+ TEMP = TEMP + A(I,J)*X(I)
+ 90 CONTINUE
+ X(J) = TEMP
+ 100 CONTINUE
+ ELSE
+ JX = KX + (N-1)*INCX
+ DO 120 J = N,1,-1
+ TEMP = X(JX)
+ IX = JX
+ IF (NOUNIT) TEMP = TEMP*A(J,J)
+ DO 110 I = J - 1,1,-1
+ IX = IX - INCX
+ TEMP = TEMP + A(I,J)*X(IX)
+ 110 CONTINUE
+ X(JX) = TEMP
+ JX = JX - INCX
+ 120 CONTINUE
+ END IF
+ ELSE
+ IF (INCX.EQ.1) THEN
+ DO 140 J = 1,N
+ TEMP = X(J)
+ IF (NOUNIT) TEMP = TEMP*A(J,J)
+ DO 130 I = J + 1,N
+ TEMP = TEMP + A(I,J)*X(I)
+ 130 CONTINUE
+ X(J) = TEMP
+ 140 CONTINUE
+ ELSE
+ JX = KX
+ DO 160 J = 1,N
+ TEMP = X(JX)
+ IX = JX
+ IF (NOUNIT) TEMP = TEMP*A(J,J)
+ DO 150 I = J + 1,N
+ IX = IX + INCX
+ TEMP = TEMP + A(I,J)*X(IX)
+ 150 CONTINUE
+ X(JX) = TEMP
+ JX = JX + INCX
+ 160 CONTINUE
+ END IF
+ END IF
+ END IF
+*
+ RETURN
+*
+* End of DTRMV .
+*
+ END
+ SUBROUTINE DTRSM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB)
+* .. Scalar Arguments ..
+ DOUBLE PRECISION ALPHA
+ INTEGER LDA,LDB,M,N
+ CHARACTER DIAG,SIDE,TRANSA,UPLO
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION A(LDA,*),B(LDB,*)
+* ..
+*
+* Purpose
+* =======
+*
+* DTRSM solves one of the matrix equations
+*
+* op( A )*X = alpha*B, or X*op( A ) = alpha*B,
+*
+* where alpha is a scalar, X and B are m by n matrices, A is a unit, or
+* non-unit, upper or lower triangular matrix and op( A ) is one of
+*
+* op( A ) = A or op( A ) = A'.
+*
+* The matrix X is overwritten on B.
+*
+* Arguments
+* ==========
+*
+* SIDE - CHARACTER*1.
+* On entry, SIDE specifies whether op( A ) appears on the left
+* or right of X as follows:
+*
+* SIDE = 'L' or 'l' op( A )*X = alpha*B.
+*
+* SIDE = 'R' or 'r' X*op( A ) = alpha*B.
+*
+* Unchanged on exit.
+*
+* UPLO - CHARACTER*1.
+* On entry, UPLO specifies whether the matrix A is an upper or
+* lower triangular matrix as follows:
+*
+* UPLO = 'U' or 'u' A is an upper triangular matrix.
+*
+* UPLO = 'L' or 'l' A is a lower triangular matrix.
+*
+* Unchanged on exit.
+*
+* TRANSA - CHARACTER*1.
+* On entry, TRANSA specifies the form of op( A ) to be used in
+* the matrix multiplication as follows:
+*
+* TRANSA = 'N' or 'n' op( A ) = A.
+*
+* TRANSA = 'T' or 't' op( A ) = A'.
+*
+* TRANSA = 'C' or 'c' op( A ) = A'.
+*
+* Unchanged on exit.
+*
+* DIAG - CHARACTER*1.
+* On entry, DIAG specifies whether or not A is unit triangular
+* as follows:
+*
+* DIAG = 'U' or 'u' A is assumed to be unit triangular.
+*
+* DIAG = 'N' or 'n' A is not assumed to be unit
+* triangular.
+*
+* Unchanged on exit.
+*
+* M - INTEGER.
+* On entry, M specifies the number of rows of B. M must be at
+* least zero.
+* Unchanged on exit.
+*
+* N - INTEGER.
+* On entry, N specifies the number of columns of B. N must be
+* at least zero.
+* Unchanged on exit.
+*
+* ALPHA - DOUBLE PRECISION.
+* On entry, ALPHA specifies the scalar alpha. When alpha is
+* zero then A is not referenced and B need not be set before
+* entry.
+* Unchanged on exit.
+*
+* A - DOUBLE PRECISION array of DIMENSION ( LDA, k ), where k is m
+* when SIDE = 'L' or 'l' and is n when SIDE = 'R' or 'r'.
+* Before entry with UPLO = 'U' or 'u', the leading k by k
+* upper triangular part of the array A must contain the upper
+* triangular matrix and the strictly lower triangular part of
+* A is not referenced.
+* Before entry with UPLO = 'L' or 'l', the leading k by k
+* lower triangular part of the array A must contain the lower
+* triangular matrix and the strictly upper triangular part of
+* A is not referenced.
+* Note that when DIAG = 'U' or 'u', the diagonal elements of
+* A are not referenced either, but are assumed to be unity.
+* Unchanged on exit.
+*
+* LDA - INTEGER.
+* On entry, LDA specifies the first dimension of A as declared
+* in the calling (sub) program. When SIDE = 'L' or 'l' then
+* LDA must be at least max( 1, m ), when SIDE = 'R' or 'r'
+* then LDA must be at least max( 1, n ).
+* Unchanged on exit.
+*
+* B - DOUBLE PRECISION array of DIMENSION ( LDB, n ).
+* Before entry, the leading m by n part of the array B must
+* contain the right-hand side matrix B, and on exit is
+* overwritten by the solution matrix X.
+*
+* LDB - INTEGER.
+* On entry, LDB specifies the first dimension of B as declared
+* in the calling (sub) program. LDB must be at least
+* max( 1, m ).
+* Unchanged on exit.
+*
+*
+* Level 3 Blas routine.
+*
+*
+* -- Written on 8-February-1989.
+* Jack Dongarra, Argonne National Laboratory.
+* Iain Duff, AERE Harwell.
+* Jeremy Du Croz, Numerical Algorithms Group Ltd.
+* Sven Hammarling, Numerical Algorithms Group Ltd.
+*
+*
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Local Scalars ..
+ DOUBLE PRECISION TEMP
+ INTEGER I,INFO,J,K,NROWA
+ LOGICAL LSIDE,NOUNIT,UPPER
+* ..
+* .. Parameters ..
+ DOUBLE PRECISION ONE,ZERO
+ PARAMETER (ONE=1.0D+0,ZERO=0.0D+0)
+* ..
+*
+* Test the input parameters.
+*
+ LSIDE = LSAME(SIDE,'L')
+ IF (LSIDE) THEN
+ NROWA = M
+ ELSE
+ NROWA = N
+ END IF
+ NOUNIT = LSAME(DIAG,'N')
+ UPPER = LSAME(UPLO,'U')
+*
+ INFO = 0
+ IF ((.NOT.LSIDE) .AND. (.NOT.LSAME(SIDE,'R'))) THEN
+ INFO = 1
+ ELSE IF ((.NOT.UPPER) .AND. (.NOT.LSAME(UPLO,'L'))) THEN
+ INFO = 2
+ ELSE IF ((.NOT.LSAME(TRANSA,'N')) .AND.
+ + (.NOT.LSAME(TRANSA,'T')) .AND.
+ + (.NOT.LSAME(TRANSA,'C'))) THEN
+ INFO = 3
+ ELSE IF ((.NOT.LSAME(DIAG,'U')) .AND. (.NOT.LSAME(DIAG,'N'))) THEN
+ INFO = 4
+ ELSE IF (M.LT.0) THEN
+ INFO = 5
+ ELSE IF (N.LT.0) THEN
+ INFO = 6
+ ELSE IF (LDA.LT.MAX(1,NROWA)) THEN
+ INFO = 9
+ ELSE IF (LDB.LT.MAX(1,M)) THEN
+ INFO = 11
+ END IF
+ IF (INFO.NE.0) THEN
+ CALL XERBLA('DTRSM ',INFO)
+ RETURN
+ END IF
+*
+* Quick return if possible.
+*
+ IF (N.EQ.0) RETURN
+*
+* And when alpha.eq.zero.
+*
+ IF (ALPHA.EQ.ZERO) THEN
+ DO 20 J = 1,N
+ DO 10 I = 1,M
+ B(I,J) = ZERO
+ 10 CONTINUE
+ 20 CONTINUE
+ RETURN
+ END IF
+*
+* Start the operations.
+*
+ IF (LSIDE) THEN
+ IF (LSAME(TRANSA,'N')) THEN
+*
+* Form B := alpha*inv( A )*B.
+*
+ IF (UPPER) THEN
+ DO 60 J = 1,N
+ IF (ALPHA.NE.ONE) THEN
+ DO 30 I = 1,M
+ B(I,J) = ALPHA*B(I,J)
+ 30 CONTINUE
+ END IF
+ DO 50 K = M,1,-1
+ IF (B(K,J).NE.ZERO) THEN
+ IF (NOUNIT) B(K,J) = B(K,J)/A(K,K)
+ DO 40 I = 1,K - 1
+ B(I,J) = B(I,J) - B(K,J)*A(I,K)
+ 40 CONTINUE
+ END IF
+ 50 CONTINUE
+ 60 CONTINUE
+ ELSE
+ DO 100 J = 1,N
+ IF (ALPHA.NE.ONE) THEN
+ DO 70 I = 1,M
+ B(I,J) = ALPHA*B(I,J)
+ 70 CONTINUE
+ END IF
+ DO 90 K = 1,M
+ IF (B(K,J).NE.ZERO) THEN
+ IF (NOUNIT) B(K,J) = B(K,J)/A(K,K)
+ DO 80 I = K + 1,M
+ B(I,J) = B(I,J) - B(K,J)*A(I,K)
+ 80 CONTINUE
+ END IF
+ 90 CONTINUE
+ 100 CONTINUE
+ END IF
+ ELSE
+*
+* Form B := alpha*inv( A' )*B.
+*
+ IF (UPPER) THEN
+ DO 130 J = 1,N
+ DO 120 I = 1,M
+ TEMP = ALPHA*B(I,J)
+ DO 110 K = 1,I - 1
+ TEMP = TEMP - A(K,I)*B(K,J)
+ 110 CONTINUE
+ IF (NOUNIT) TEMP = TEMP/A(I,I)
+ B(I,J) = TEMP
+ 120 CONTINUE
+ 130 CONTINUE
+ ELSE
+ DO 160 J = 1,N
+ DO 150 I = M,1,-1
+ TEMP = ALPHA*B(I,J)
+ DO 140 K = I + 1,M
+ TEMP = TEMP - A(K,I)*B(K,J)
+ 140 CONTINUE
+ IF (NOUNIT) TEMP = TEMP/A(I,I)
+ B(I,J) = TEMP
+ 150 CONTINUE
+ 160 CONTINUE
+ END IF
+ END IF
+ ELSE
+ IF (LSAME(TRANSA,'N')) THEN
+*
+* Form B := alpha*B*inv( A ).
+*
+ IF (UPPER) THEN
+ DO 210 J = 1,N
+ IF (ALPHA.NE.ONE) THEN
+ DO 170 I = 1,M
+ B(I,J) = ALPHA*B(I,J)
+ 170 CONTINUE
+ END IF
+ DO 190 K = 1,J - 1
+ IF (A(K,J).NE.ZERO) THEN
+ DO 180 I = 1,M
+ B(I,J) = B(I,J) - A(K,J)*B(I,K)
+ 180 CONTINUE
+ END IF
+ 190 CONTINUE
+ IF (NOUNIT) THEN
+ TEMP = ONE/A(J,J)
+ DO 200 I = 1,M
+ B(I,J) = TEMP*B(I,J)
+ 200 CONTINUE
+ END IF
+ 210 CONTINUE
+ ELSE
+ DO 260 J = N,1,-1
+ IF (ALPHA.NE.ONE) THEN
+ DO 220 I = 1,M
+ B(I,J) = ALPHA*B(I,J)
+ 220 CONTINUE
+ END IF
+ DO 240 K = J + 1,N
+ IF (A(K,J).NE.ZERO) THEN
+ DO 230 I = 1,M
+ B(I,J) = B(I,J) - A(K,J)*B(I,K)
+ 230 CONTINUE
+ END IF
+ 240 CONTINUE
+ IF (NOUNIT) THEN
+ TEMP = ONE/A(J,J)
+ DO 250 I = 1,M
+ B(I,J) = TEMP*B(I,J)
+ 250 CONTINUE
+ END IF
+ 260 CONTINUE
+ END IF
+ ELSE
+*
+* Form B := alpha*B*inv( A' ).
+*
+ IF (UPPER) THEN
+ DO 310 K = N,1,-1
+ IF (NOUNIT) THEN
+ TEMP = ONE/A(K,K)
+ DO 270 I = 1,M
+ B(I,K) = TEMP*B(I,K)
+ 270 CONTINUE
+ END IF
+ DO 290 J = 1,K - 1
+ IF (A(J,K).NE.ZERO) THEN
+ TEMP = A(J,K)
+ DO 280 I = 1,M
+ B(I,J) = B(I,J) - TEMP*B(I,K)
+ 280 CONTINUE
+ END IF
+ 290 CONTINUE
+ IF (ALPHA.NE.ONE) THEN
+ DO 300 I = 1,M
+ B(I,K) = ALPHA*B(I,K)
+ 300 CONTINUE
+ END IF
+ 310 CONTINUE
+ ELSE
+ DO 360 K = 1,N
+ IF (NOUNIT) THEN
+ TEMP = ONE/A(K,K)
+ DO 320 I = 1,M
+ B(I,K) = TEMP*B(I,K)
+ 320 CONTINUE
+ END IF
+ DO 340 J = K + 1,N
+ IF (A(J,K).NE.ZERO) THEN
+ TEMP = A(J,K)
+ DO 330 I = 1,M
+ B(I,J) = B(I,J) - TEMP*B(I,K)
+ 330 CONTINUE
+ END IF
+ 340 CONTINUE
+ IF (ALPHA.NE.ONE) THEN
+ DO 350 I = 1,M
+ B(I,K) = ALPHA*B(I,K)
+ 350 CONTINUE
+ END IF
+ 360 CONTINUE
+ END IF
+ END IF
+ END IF
+*
+ RETURN
+*
+* End of DTRSM .
+*
+ END
+ SUBROUTINE DTRSV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX)
+* .. Scalar Arguments ..
+ INTEGER INCX,LDA,N
+ CHARACTER DIAG,TRANS,UPLO
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION A(LDA,*),X(*)
+* ..
+*
+* Purpose
+* =======
+*
+* DTRSV solves one of the systems of equations
+*
+* A*x = b, or A'*x = b,
+*
+* where b and x are n element vectors and A is an n by n unit, or
+* non-unit, upper or lower triangular matrix.
+*
+* No test for singularity or near-singularity is included in this
+* routine. Such tests must be performed before calling this routine.
+*
+* Arguments
+* ==========
+*
+* UPLO - CHARACTER*1.
+* On entry, UPLO specifies whether the matrix is an upper or
+* lower triangular matrix as follows:
+*
+* UPLO = 'U' or 'u' A is an upper triangular matrix.
+*
+* UPLO = 'L' or 'l' A is a lower triangular matrix.
+*
+* Unchanged on exit.
+*
+* TRANS - CHARACTER*1.
+* On entry, TRANS specifies the equations to be solved as
+* follows:
+*
+* TRANS = 'N' or 'n' A*x = b.
+*
+* TRANS = 'T' or 't' A'*x = b.
+*
+* TRANS = 'C' or 'c' A'*x = b.
+*
+* Unchanged on exit.
+*
+* DIAG - CHARACTER*1.
+* On entry, DIAG specifies whether or not A is unit
+* triangular as follows:
+*
+* DIAG = 'U' or 'u' A is assumed to be unit triangular.
+*
+* DIAG = 'N' or 'n' A is not assumed to be unit
+* triangular.
+*
+* Unchanged on exit.
+*
+* N - INTEGER.
+* On entry, N specifies the order of the matrix A.
+* N must be at least zero.
+* Unchanged on exit.
+*
+* A - DOUBLE PRECISION array of DIMENSION ( LDA, n ).
+* Before entry with UPLO = 'U' or 'u', the leading n by n
+* upper triangular part of the array A must contain the upper
+* triangular matrix and the strictly lower triangular part of
+* A is not referenced.
+* Before entry with UPLO = 'L' or 'l', the leading n by n
+* lower triangular part of the array A must contain the lower
+* triangular matrix and the strictly upper triangular part of
+* A is not referenced.
+* Note that when DIAG = 'U' or 'u', the diagonal elements of
+* A are not referenced either, but are assumed to be unity.
+* Unchanged on exit.
+*
+* LDA - INTEGER.
+* On entry, LDA specifies the first dimension of A as declared
+* in the calling (sub) program. LDA must be at least
+* max( 1, n ).
+* Unchanged on exit.
+*
+* X - DOUBLE PRECISION array of dimension at least
+* ( 1 + ( n - 1 )*abs( INCX ) ).
+* Before entry, the incremented array X must contain the n
+* element right-hand side vector b. On exit, X is overwritten
+* with the solution vector x.
+*
+* INCX - INTEGER.
+* On entry, INCX specifies the increment for the elements of
+* X. INCX must not be zero.
+* Unchanged on exit.
+*
+*
+* Level 2 Blas routine.
+*
+* -- Written on 22-October-1986.
+* Jack Dongarra, Argonne National Lab.
+* Jeremy Du Croz, Nag Central Office.
+* Sven Hammarling, Nag Central Office.
+* Richard Hanson, Sandia National Labs.
+*
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO
+ PARAMETER (ZERO=0.0D+0)
+* ..
+* .. Local Scalars ..
+ DOUBLE PRECISION TEMP
+ INTEGER I,INFO,IX,J,JX,KX
+ LOGICAL NOUNIT
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN
+ INFO = 1
+ ELSE IF (.NOT.LSAME(TRANS,'N') .AND. .NOT.LSAME(TRANS,'T') .AND.
+ + .NOT.LSAME(TRANS,'C')) THEN
+ INFO = 2
+ ELSE IF (.NOT.LSAME(DIAG,'U') .AND. .NOT.LSAME(DIAG,'N')) THEN
+ INFO = 3
+ ELSE IF (N.LT.0) THEN
+ INFO = 4
+ ELSE IF (LDA.LT.MAX(1,N)) THEN
+ INFO = 6
+ ELSE IF (INCX.EQ.0) THEN
+ INFO = 8
+ END IF
+ IF (INFO.NE.0) THEN
+ CALL XERBLA('DTRSV ',INFO)
+ RETURN
+ END IF
+*
+* Quick return if possible.
+*
+ IF (N.EQ.0) RETURN
+*
+ NOUNIT = LSAME(DIAG,'N')
+*
+* Set up the start point in X if the increment is not unity. This
+* will be ( N - 1 )*INCX too small for descending loops.
+*
+ IF (INCX.LE.0) THEN
+ KX = 1 - (N-1)*INCX
+ ELSE IF (INCX.NE.1) THEN
+ KX = 1
+ END IF
+*
+* Start the operations. In this version the elements of A are
+* accessed sequentially with one pass through A.
+*
+ IF (LSAME(TRANS,'N')) THEN
+*
+* Form x := inv( A )*x.
+*
+ IF (LSAME(UPLO,'U')) THEN
+ IF (INCX.EQ.1) THEN
+ DO 20 J = N,1,-1
+ IF (X(J).NE.ZERO) THEN
+ IF (NOUNIT) X(J) = X(J)/A(J,J)
+ TEMP = X(J)
+ DO 10 I = J - 1,1,-1
+ X(I) = X(I) - TEMP*A(I,J)
+ 10 CONTINUE
+ END IF
+ 20 CONTINUE
+ ELSE
+ JX = KX + (N-1)*INCX
+ DO 40 J = N,1,-1
+ IF (X(JX).NE.ZERO) THEN
+ IF (NOUNIT) X(JX) = X(JX)/A(J,J)
+ TEMP = X(JX)
+ IX = JX
+ DO 30 I = J - 1,1,-1
+ IX = IX - INCX
+ X(IX) = X(IX) - TEMP*A(I,J)
+ 30 CONTINUE
+ END IF
+ JX = JX - INCX
+ 40 CONTINUE
+ END IF
+ ELSE
+ IF (INCX.EQ.1) THEN
+ DO 60 J = 1,N
+ IF (X(J).NE.ZERO) THEN
+ IF (NOUNIT) X(J) = X(J)/A(J,J)
+ TEMP = X(J)
+ DO 50 I = J + 1,N
+ X(I) = X(I) - TEMP*A(I,J)
+ 50 CONTINUE
+ END IF
+ 60 CONTINUE
+ ELSE
+ JX = KX
+ DO 80 J = 1,N
+ IF (X(JX).NE.ZERO) THEN
+ IF (NOUNIT) X(JX) = X(JX)/A(J,J)
+ TEMP = X(JX)
+ IX = JX
+ DO 70 I = J + 1,N
+ IX = IX + INCX
+ X(IX) = X(IX) - TEMP*A(I,J)
+ 70 CONTINUE
+ END IF
+ JX = JX + INCX
+ 80 CONTINUE
+ END IF
+ END IF
+ ELSE
+*
+* Form x := inv( A' )*x.
+*
+ IF (LSAME(UPLO,'U')) THEN
+ IF (INCX.EQ.1) THEN
+ DO 100 J = 1,N
+ TEMP = X(J)
+ DO 90 I = 1,J - 1
+ TEMP = TEMP - A(I,J)*X(I)
+ 90 CONTINUE
+ IF (NOUNIT) TEMP = TEMP/A(J,J)
+ X(J) = TEMP
+ 100 CONTINUE
+ ELSE
+ JX = KX
+ DO 120 J = 1,N
+ TEMP = X(JX)
+ IX = KX
+ DO 110 I = 1,J - 1
+ TEMP = TEMP - A(I,J)*X(IX)
+ IX = IX + INCX
+ 110 CONTINUE
+ IF (NOUNIT) TEMP = TEMP/A(J,J)
+ X(JX) = TEMP
+ JX = JX + INCX
+ 120 CONTINUE
+ END IF
+ ELSE
+ IF (INCX.EQ.1) THEN
+ DO 140 J = N,1,-1
+ TEMP = X(J)
+ DO 130 I = N,J + 1,-1
+ TEMP = TEMP - A(I,J)*X(I)
+ 130 CONTINUE
+ IF (NOUNIT) TEMP = TEMP/A(J,J)
+ X(J) = TEMP
+ 140 CONTINUE
+ ELSE
+ KX = KX + (N-1)*INCX
+ JX = KX
+ DO 160 J = N,1,-1
+ TEMP = X(JX)
+ IX = KX
+ DO 150 I = N,J + 1,-1
+ TEMP = TEMP - A(I,J)*X(IX)
+ IX = IX - INCX
+ 150 CONTINUE
+ IF (NOUNIT) TEMP = TEMP/A(J,J)
+ X(JX) = TEMP
+ JX = JX - INCX
+ 160 CONTINUE
+ END IF
+ END IF
+ END IF
+*
+ RETURN
+*
+* End of DTRSV .
+*
+ END
+ INTEGER FUNCTION IDAMAX(N,DX,INCX)
+* .. Scalar Arguments ..
+ INTEGER INCX,N
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION DX(*)
+* ..
+*
+* Purpose
+* =======
+*
+* finds the index of element having max. absolute value.
+* jack dongarra, linpack, 3/11/78.
+* modified 3/93 to return if incx .le. 0.
+* modified 12/3/93, array(1) declarations changed to array(*)
+*
+*
+* .. Local Scalars ..
+ DOUBLE PRECISION DMAX
+ INTEGER I,IX
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC DABS
+* ..
+ IDAMAX = 0
+ IF (N.LT.1 .OR. INCX.LE.0) RETURN
+ IDAMAX = 1
+ IF (N.EQ.1) RETURN
+ IF (INCX.EQ.1) GO TO 20
+*
+* code for increment not equal to 1
+*
+ IX = 1
+ DMAX = DABS(DX(1))
+ IX = IX + INCX
+ DO 10 I = 2,N
+ IF (DABS(DX(IX)).LE.DMAX) GO TO 5
+ IDAMAX = I
+ DMAX = DABS(DX(IX))
+ 5 IX = IX + INCX
+ 10 CONTINUE
+ RETURN
+*
+* code for increment equal to 1
+*
+ 20 DMAX = DABS(DX(1))
+ DO 30 I = 2,N
+ IF (DABS(DX(I)).LE.DMAX) GO TO 30
+ IDAMAX = I
+ DMAX = DABS(DX(I))
+ 30 CONTINUE
+ RETURN
+ END
+ INTEGER FUNCTION ISAMAX(N,SX,INCX)
+* .. Scalar Arguments ..
+ INTEGER INCX,N
+* ..
+* .. Array Arguments ..
+ REAL SX(*)
+* ..
+*
+* Purpose
+* =======
+*
+* finds the index of element having max. absolute value.
+* jack dongarra, linpack, 3/11/78.
+* modified 3/93 to return if incx .le. 0.
+* modified 12/3/93, array(1) declarations changed to array(*)
+*
+*
+* .. Local Scalars ..
+ REAL SMAX
+ INTEGER I,IX
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS
+* ..
+ ISAMAX = 0
+ IF (N.LT.1 .OR. INCX.LE.0) RETURN
+ ISAMAX = 1
+ IF (N.EQ.1) RETURN
+ IF (INCX.EQ.1) GO TO 20
+*
+* code for increment not equal to 1
+*
+ IX = 1
+ SMAX = ABS(SX(1))
+ IX = IX + INCX
+ DO 10 I = 2,N
+ IF (ABS(SX(IX)).LE.SMAX) GO TO 5
+ ISAMAX = I
+ SMAX = ABS(SX(IX))
+ 5 IX = IX + INCX
+ 10 CONTINUE
+ RETURN
+*
+* code for increment equal to 1
+*
+ 20 SMAX = ABS(SX(1))
+ DO 30 I = 2,N
+ IF (ABS(SX(I)).LE.SMAX) GO TO 30
+ ISAMAX = I
+ SMAX = ABS(SX(I))
+ 30 CONTINUE
+ RETURN
+ END
+ LOGICAL FUNCTION LSAME(CA,CB)
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER CA,CB
+* ..
+*
+* Purpose
+* =======
+*
+* LSAME returns .TRUE. if CA is the same letter as CB regardless of
+* case.
+*
+* Arguments
+* =========
+*
+* CA (input) CHARACTER*1
+*
+* CB (input) CHARACTER*1
+* CA and CB specify the single characters to be compared.
+*
+* =====================================================================
+*
+* .. Intrinsic Functions ..
+ INTRINSIC ICHAR
+* ..
+* .. Local Scalars ..
+ INTEGER INTA,INTB,ZCODE
+* ..
+*
+* Test if the characters are equal
+*
+ LSAME = CA .EQ. CB
+ IF (LSAME) RETURN
+*
+* Now test for equivalence if both characters are alphabetic.
+*
+ ZCODE = ICHAR('Z')
+*
+* Use 'Z' rather than 'A' so that ASCII can be detected on Prime
+* machines, on which ICHAR returns a value with bit 8 set.
+* ICHAR('A') on Prime machines returns 193 which is the same as
+* ICHAR('A') on an EBCDIC machine.
+*
+ INTA = ICHAR(CA)
+ INTB = ICHAR(CB)
+*
+ IF (ZCODE.EQ.90 .OR. ZCODE.EQ.122) THEN
+*
+* ASCII is assumed - ZCODE is the ASCII code of either lower or
+* upper case 'Z'.
+*
+ IF (INTA.GE.97 .AND. INTA.LE.122) INTA = INTA - 32
+ IF (INTB.GE.97 .AND. INTB.LE.122) INTB = INTB - 32
+*
+ ELSE IF (ZCODE.EQ.233 .OR. ZCODE.EQ.169) THEN
+*
+* EBCDIC is assumed - ZCODE is the EBCDIC code of either lower or
+* upper case 'Z'.
+*
+ IF (INTA.GE.129 .AND. INTA.LE.137 .OR.
+ + INTA.GE.145 .AND. INTA.LE.153 .OR.
+ + INTA.GE.162 .AND. INTA.LE.169) INTA = INTA + 64
+ IF (INTB.GE.129 .AND. INTB.LE.137 .OR.
+ + INTB.GE.145 .AND. INTB.LE.153 .OR.
+ + INTB.GE.162 .AND. INTB.LE.169) INTB = INTB + 64
+*
+ ELSE IF (ZCODE.EQ.218 .OR. ZCODE.EQ.250) THEN
+*
+* ASCII is assumed, on Prime machines - ZCODE is the ASCII code
+* plus 128 of either lower or upper case 'Z'.
+*
+ IF (INTA.GE.225 .AND. INTA.LE.250) INTA = INTA - 32
+ IF (INTB.GE.225 .AND. INTB.LE.250) INTB = INTB - 32
+ END IF
+ LSAME = INTA .EQ. INTB
+*
+* RETURN
+*
+* End of LSAME
+*
+ END
+ REAL FUNCTION SASUM(N,SX,INCX)
+* .. Scalar Arguments ..
+ INTEGER INCX,N
+* ..
+* .. Array Arguments ..
+ REAL SX(*)
+* ..
+*
+* Purpose
+* =======
+*
+* takes the sum of the absolute values.
+* uses unrolled loops for increment equal to one.
+* jack dongarra, linpack, 3/11/78.
+* modified 3/93 to return if incx .le. 0.
+* modified 12/3/93, array(1) declarations changed to array(*)
+*
+*
+
+* .. Local Scalars ..
+ REAL STEMP
+ INTEGER I,M,MP1,NINCX
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS,MOD
+* ..
+ SASUM = 0.0e0
+ STEMP = 0.0e0
+ IF (N.LE.0 .OR. INCX.LE.0) RETURN
+ IF (INCX.EQ.1) GO TO 20
+*
+* code for increment not equal to 1
+*
+ NINCX = N*INCX
+ DO 10 I = 1,NINCX,INCX
+ STEMP = STEMP + ABS(SX(I))
+ 10 CONTINUE
+ SASUM = STEMP
+ RETURN
+*
+* code for increment equal to 1
+*
+*
+* clean-up loop
+*
+ 20 M = MOD(N,6)
+ IF (M.EQ.0) GO TO 40
+ DO 30 I = 1,M
+ STEMP = STEMP + ABS(SX(I))
+ 30 CONTINUE
+ IF (N.LT.6) GO TO 60
+ 40 MP1 = M + 1
+ DO 50 I = MP1,N,6
+ STEMP = STEMP + ABS(SX(I)) + ABS(SX(I+1)) + ABS(SX(I+2)) +
+ + ABS(SX(I+3)) + ABS(SX(I+4)) + ABS(SX(I+5))
+ 50 CONTINUE
+ 60 SASUM = STEMP
+ RETURN
+ END
+ SUBROUTINE SAXPY(N,SA,SX,INCX,SY,INCY)
+* .. Scalar Arguments ..
+ REAL SA
+ INTEGER INCX,INCY,N
+* ..
+* .. Array Arguments ..
+ REAL SX(*),SY(*)
+* ..
+*
+* Purpose
+* =======
+*
+* SAXPY constant times a vector plus a vector.
+* uses unrolled loop for increments equal to one.
+* jack dongarra, linpack, 3/11/78.
+* modified 12/3/93, array(1) declarations changed to array(*)
+*
+*
+* .. Local Scalars ..
+ INTEGER I,IX,IY,M,MP1
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MOD
+* ..
+ IF (N.LE.0) RETURN
+ IF (SA.EQ.0.0) RETURN
+ IF (INCX.EQ.1 .AND. INCY.EQ.1) GO TO 20
+*
+* code for unequal increments or equal increments
+* not equal to 1
+*
+ IX = 1
+ IY = 1
+ IF (INCX.LT.0) IX = (-N+1)*INCX + 1
+ IF (INCY.LT.0) IY = (-N+1)*INCY + 1
+ DO 10 I = 1,N
+ SY(IY) = SY(IY) + SA*SX(IX)
+ IX = IX + INCX
+ IY = IY + INCY
+ 10 CONTINUE
+ RETURN
+*
+* code for both increments equal to 1
+*
+*
+* clean-up loop
+*
+ 20 M = MOD(N,4)
+ IF (M.EQ.0) GO TO 40
+ DO 30 I = 1,M
+ SY(I) = SY(I) + SA*SX(I)
+ 30 CONTINUE
+ IF (N.LT.4) RETURN
+ 40 MP1 = M + 1
+ DO 50 I = MP1,N,4
+ SY(I) = SY(I) + SA*SX(I)
+ SY(I+1) = SY(I+1) + SA*SX(I+1)
+ SY(I+2) = SY(I+2) + SA*SX(I+2)
+ SY(I+3) = SY(I+3) + SA*SX(I+3)
+ 50 CONTINUE
+ RETURN
+ END
+ SUBROUTINE SCOPY(N,SX,INCX,SY,INCY)
+* .. Scalar Arguments ..
+ INTEGER INCX,INCY,N
+* ..
+* .. Array Arguments ..
+ REAL SX(*),SY(*)
+* ..
+*
+* Purpose
+* =======
+*
+* copies a vector, x, to a vector, y.
+* uses unrolled loops for increments equal to 1.
+* jack dongarra, linpack, 3/11/78.
+* modified 12/3/93, array(1) declarations changed to array(*)
+*
+*
+* .. Local Scalars ..
+ INTEGER I,IX,IY,M,MP1
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MOD
+* ..
+ IF (N.LE.0) RETURN
+ IF (INCX.EQ.1 .AND. INCY.EQ.1) GO TO 20
+*
+* code for unequal increments or equal increments
+* not equal to 1
+*
+ IX = 1
+ IY = 1
+ IF (INCX.LT.0) IX = (-N+1)*INCX + 1
+ IF (INCY.LT.0) IY = (-N+1)*INCY + 1
+ DO 10 I = 1,N
+ SY(IY) = SX(IX)
+ IX = IX + INCX
+ IY = IY + INCY
+ 10 CONTINUE
+ RETURN
+*
+* code for both increments equal to 1
+*
+*
+* clean-up loop
+*
+ 20 M = MOD(N,7)
+ IF (M.EQ.0) GO TO 40
+ DO 30 I = 1,M
+ SY(I) = SX(I)
+ 30 CONTINUE
+ IF (N.LT.7) RETURN
+ 40 MP1 = M + 1
+ DO 50 I = MP1,N,7
+ SY(I) = SX(I)
+ SY(I+1) = SX(I+1)
+ SY(I+2) = SX(I+2)
+ SY(I+3) = SX(I+3)
+ SY(I+4) = SX(I+4)
+ SY(I+5) = SX(I+5)
+ SY(I+6) = SX(I+6)
+ 50 CONTINUE
+ RETURN
+ END
+ REAL FUNCTION SDOT(N,SX,INCX,SY,INCY)
+* .. Scalar Arguments ..
+ INTEGER INCX,INCY,N
+* ..
+* .. Array Arguments ..
+ REAL SX(*),SY(*)
+* ..
+*
+* Purpose
+* =======
+*
+* forms the dot product of two vectors.
+* uses unrolled loops for increments equal to one.
+* jack dongarra, linpack, 3/11/78.
+* modified 12/3/93, array(1) declarations changed to array(*)
+*
+*
+
+* .. Local Scalars ..
+ REAL STEMP
+ INTEGER I,IX,IY,M,MP1
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MOD
+* ..
+ STEMP = 0.0e0
+ SDOT = 0.0e0
+ IF (N.LE.0) RETURN
+ IF (INCX.EQ.1 .AND. INCY.EQ.1) GO TO 20
+*
+* code for unequal increments or equal increments
+* not equal to 1
+*
+ IX = 1
+ IY = 1
+ IF (INCX.LT.0) IX = (-N+1)*INCX + 1
+ IF (INCY.LT.0) IY = (-N+1)*INCY + 1
+ DO 10 I = 1,N
+ STEMP = STEMP + SX(IX)*SY(IY)
+ IX = IX + INCX
+ IY = IY + INCY
+ 10 CONTINUE
+ SDOT = STEMP
+ RETURN
+*
+* code for both increments equal to 1
+*
+*
+* clean-up loop
+*
+ 20 M = MOD(N,5)
+ IF (M.EQ.0) GO TO 40
+ DO 30 I = 1,M
+ STEMP = STEMP + SX(I)*SY(I)
+ 30 CONTINUE
+ IF (N.LT.5) GO TO 60
+ 40 MP1 = M + 1
+ DO 50 I = MP1,N,5
+ STEMP = STEMP + SX(I)*SY(I) + SX(I+1)*SY(I+1) +
+ + SX(I+2)*SY(I+2) + SX(I+3)*SY(I+3) + SX(I+4)*SY(I+4)
+ 50 CONTINUE
+ 60 SDOT = STEMP
+ RETURN
+ END
+ REAL FUNCTION SDSDOT(N,SB,SX,INCX,SY,INCY)
+* .. Scalar Arguments ..
+ REAL SB
+ INTEGER INCX,INCY,N
+* ..
+* .. Array Arguments ..
+ REAL SX(*),SY(*)
+* ..
+*
+* PURPOSE
+* =======
+*
+* Compute the inner product of two vectors with extended
+* precision accumulation.
+*
+* Returns S.P. result with dot product accumulated in D.P.
+* SDSDOT = SB + sum for I = 0 to N-1 of SX(LX+I*INCX)*SY(LY+I*INCY),
+* where LX = 1 if INCX .GE. 0, else LX = 1+(1-N)*INCX, and LY is
+* defined in a similar way using INCY.
+*
+* AUTHOR
+* ======
+* Lawson, C. L., (JPL), Hanson, R. J., (SNLA),
+* Kincaid, D. R., (U. of Texas), Krogh, F. T., (JPL)
+*
+* ARGUMENTS
+* =========
+*
+* N (input) INTEGER
+* number of elements in input vector(s)
+*
+* SB (input) REAL
+* single precision scalar to be added to inner product
+*
+* SX (input) REAL array, dimension (N)
+* single precision vector with N elements
+*
+* INCX (input) INTEGER
+* storage spacing between elements of SX
+*
+* SY (input) REAL array, dimension (N)
+* single precision vector with N elements
+*
+* INCY (input) INTEGER
+* storage spacing between elements of SY
+*
+* SDSDOT (output) REAL
+* single precision dot product (SB if N .LE. 0)
+*
+* REFERENCES
+* ==========
+*
+* C. L. Lawson, R. J. Hanson, D. R. Kincaid and F. T.
+* Krogh, Basic linear algebra subprograms for Fortran
+* usage, Algorithm No. 539, Transactions on Mathematical
+* Software 5, 3 (September 1979), pp. 308-323.
+*
+* REVISION HISTORY (YYMMDD)
+* ==========================
+*
+* 791001 DATE WRITTEN
+* 890531 Changed all specific intrinsics to generic. (WRB)
+* 890831 Modified array declarations. (WRB)
+* 890831 REVISION DATE from Version 3.2
+* 891214 Prologue converted to Version 4.0 format. (BAB)
+* 920310 Corrected definition of LX in DESCRIPTION. (WRB)
+* 920501 Reformatted the REFERENCES section. (WRB)
+* 070118 Reformat to LAPACK coding style
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ DOUBLE PRECISION DSDOT
+ INTEGER I,KX,KY,NS
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC DBLE
+* ..
+ DSDOT = SB
+ IF (N.LE.0) GO TO 30
+ IF (INCX.EQ.INCY .AND. INCX.GT.0) GO TO 40
+*
+* Code for unequal or nonpositive increments.
+*
+ KX = 1
+ KY = 1
+ IF (INCX.LT.0) KX = 1 + (1-N)*INCX
+ IF (INCY.LT.0) KY = 1 + (1-N)*INCY
+ DO 10 I = 1,N
+ DSDOT = DSDOT + DBLE(SX(KX))*DBLE(SY(KY))
+ KX = KX + INCX
+ KY = KY + INCY
+ 10 CONTINUE
+ 30 SDSDOT = DSDOT
+ RETURN
+*
+* Code for equal and positive increments.
+*
+ 40 NS = N*INCX
+ DO 50 I = 1,NS,INCX
+ DSDOT = DSDOT + DBLE(SX(I))*DBLE(SY(I))
+ 50 CONTINUE
+ SDSDOT = DSDOT
+ RETURN
+ END
+ SUBROUTINE SGBMV(TRANS,M,N,KL,KU,ALPHA,A,LDA,X,INCX,BETA,Y,INCY)
+* .. Scalar Arguments ..
+ REAL ALPHA,BETA
+ INTEGER INCX,INCY,KL,KU,LDA,M,N
+ CHARACTER TRANS
+* ..
+* .. Array Arguments ..
+ REAL A(LDA,*),X(*),Y(*)
+* ..
+*
+* Purpose
+* =======
+*
+* SGBMV performs one of the matrix-vector operations
+*
+* y := alpha*A*x + beta*y, or y := alpha*A'*x + beta*y,
+*
+* where alpha and beta are scalars, x and y are vectors and A is an
+* m by n band matrix, with kl sub-diagonals and ku super-diagonals.
+*
+* Arguments
+* ==========
+*
+* TRANS - CHARACTER*1.
+* On entry, TRANS specifies the operation to be performed as
+* follows:
+*
+* TRANS = 'N' or 'n' y := alpha*A*x + beta*y.
+*
+* TRANS = 'T' or 't' y := alpha*A'*x + beta*y.
+*
+* TRANS = 'C' or 'c' y := alpha*A'*x + beta*y.
+*
+* Unchanged on exit.
+*
+* M - INTEGER.
+* On entry, M specifies the number of rows of the matrix A.
+* M must be at least zero.
+* Unchanged on exit.
+*
+* N - INTEGER.
+* On entry, N specifies the number of columns of the matrix A.
+* N must be at least zero.
+* Unchanged on exit.
+*
+* KL - INTEGER.
+* On entry, KL specifies the number of sub-diagonals of the
+* matrix A. KL must satisfy 0 .le. KL.
+* Unchanged on exit.
+*
+* KU - INTEGER.
+* On entry, KU specifies the number of super-diagonals of the
+* matrix A. KU must satisfy 0 .le. KU.
+* Unchanged on exit.
+*
+* ALPHA - REAL .
+* On entry, ALPHA specifies the scalar alpha.
+* Unchanged on exit.
+*
+* A - REAL array of DIMENSION ( LDA, n ).
+* Before entry, the leading ( kl + ku + 1 ) by n part of the
+* array A must contain the matrix of coefficients, supplied
+* column by column, with the leading diagonal of the matrix in
+* row ( ku + 1 ) of the array, the first super-diagonal
+* starting at position 2 in row ku, the first sub-diagonal
+* starting at position 1 in row ( ku + 2 ), and so on.
+* Elements in the array A that do not correspond to elements
+* in the band matrix (such as the top left ku by ku triangle)
+* are not referenced.
+* The following program segment will transfer a band matrix
+* from conventional full matrix storage to band storage:
+*
+* DO 20, J = 1, N
+* K = KU + 1 - J
+* DO 10, I = MAX( 1, J - KU ), MIN( M, J + KL )
+* A( K + I, J ) = matrix( I, J )
+* 10 CONTINUE
+* 20 CONTINUE
+*
+* Unchanged on exit.
+*
+* LDA - INTEGER.
+* On entry, LDA specifies the first dimension of A as declared
+* in the calling (sub) program. LDA must be at least
+* ( kl + ku + 1 ).
+* Unchanged on exit.
+*
+* X - REAL array of DIMENSION at least
+* ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n'
+* and at least
+* ( 1 + ( m - 1 )*abs( INCX ) ) otherwise.
+* Before entry, the incremented array X must contain the
+* vector x.
+* Unchanged on exit.
+*
+* INCX - INTEGER.
+* On entry, INCX specifies the increment for the elements of
+* X. INCX must not be zero.
+* Unchanged on exit.
+*
+* BETA - REAL .
+* On entry, BETA specifies the scalar beta. When BETA is
+* supplied as zero then Y need not be set on input.
+* Unchanged on exit.
+*
+* Y - REAL array of DIMENSION at least
+* ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n'
+* and at least
+* ( 1 + ( n - 1 )*abs( INCY ) ) otherwise.
+* Before entry, the incremented array Y must contain the
+* vector y. On exit, Y is overwritten by the updated vector y.
+*
+* INCY - INTEGER.
+* On entry, INCY specifies the increment for the elements of
+* Y. INCY must not be zero.
+* Unchanged on exit.
+*
+*
+* Level 2 Blas routine.
+*
+* -- Written on 22-October-1986.
+* Jack Dongarra, Argonne National Lab.
+* Jeremy Du Croz, Nag Central Office.
+* Sven Hammarling, Nag Central Office.
+* Richard Hanson, Sandia National Labs.
+*
+* .. Parameters ..
+ REAL ONE,ZERO
+ PARAMETER (ONE=1.0E+0,ZERO=0.0E+0)
+* ..
+* .. Local Scalars ..
+ REAL TEMP
+ INTEGER I,INFO,IX,IY,J,JX,JY,K,KUP1,KX,KY,LENX,LENY
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX,MIN
+* ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ IF (.NOT.LSAME(TRANS,'N') .AND. .NOT.LSAME(TRANS,'T') .AND.
+ + .NOT.LSAME(TRANS,'C')) THEN
+ INFO = 1
+ ELSE IF (M.LT.0) THEN
+ INFO = 2
+ ELSE IF (N.LT.0) THEN
+ INFO = 3
+ ELSE IF (KL.LT.0) THEN
+ INFO = 4
+ ELSE IF (KU.LT.0) THEN
+ INFO = 5
+ ELSE IF (LDA.LT. (KL+KU+1)) THEN
+ INFO = 8
+ ELSE IF (INCX.EQ.0) THEN
+ INFO = 10
+ ELSE IF (INCY.EQ.0) THEN
+ INFO = 13
+ END IF
+ IF (INFO.NE.0) THEN
+ CALL XERBLA('SGBMV ',INFO)
+ RETURN
+ END IF
+*
+* Quick return if possible.
+*
+ IF ((M.EQ.0) .OR. (N.EQ.0) .OR.
+ + ((ALPHA.EQ.ZERO).AND. (BETA.EQ.ONE))) RETURN
+*
+* Set LENX and LENY, the lengths of the vectors x and y, and set
+* up the start points in X and Y.
+*
+ IF (LSAME(TRANS,'N')) THEN
+ LENX = N
+ LENY = M
+ ELSE
+ LENX = M
+ LENY = N
+ END IF
+ IF (INCX.GT.0) THEN
+ KX = 1
+ ELSE
+ KX = 1 - (LENX-1)*INCX
+ END IF
+ IF (INCY.GT.0) THEN
+ KY = 1
+ ELSE
+ KY = 1 - (LENY-1)*INCY
+ END IF
+*
+* Start the operations. In this version the elements of A are
+* accessed sequentially with one pass through the band part of A.
+*
+* First form y := beta*y.
+*
+ IF (BETA.NE.ONE) THEN
+ IF (INCY.EQ.1) THEN
+ IF (BETA.EQ.ZERO) THEN
+ DO 10 I = 1,LENY
+ Y(I) = ZERO
+ 10 CONTINUE
+ ELSE
+ DO 20 I = 1,LENY
+ Y(I) = BETA*Y(I)
+ 20 CONTINUE
+ END IF
+ ELSE
+ IY = KY
+ IF (BETA.EQ.ZERO) THEN
+ DO 30 I = 1,LENY
+ Y(IY) = ZERO
+ IY = IY + INCY
+ 30 CONTINUE
+ ELSE
+ DO 40 I = 1,LENY
+ Y(IY) = BETA*Y(IY)
+ IY = IY + INCY
+ 40 CONTINUE
+ END IF
+ END IF
+ END IF
+ IF (ALPHA.EQ.ZERO) RETURN
+ KUP1 = KU + 1
+ IF (LSAME(TRANS,'N')) THEN
+*
+* Form y := alpha*A*x + y.
+*
+ JX = KX
+ IF (INCY.EQ.1) THEN
+ DO 60 J = 1,N
+ IF (X(JX).NE.ZERO) THEN
+ TEMP = ALPHA*X(JX)
+ K = KUP1 - J
+ DO 50 I = MAX(1,J-KU),MIN(M,J+KL)
+ Y(I) = Y(I) + TEMP*A(K+I,J)
+ 50 CONTINUE
+ END IF
+ JX = JX + INCX
+ 60 CONTINUE
+ ELSE
+ DO 80 J = 1,N
+ IF (X(JX).NE.ZERO) THEN
+ TEMP = ALPHA*X(JX)
+ IY = KY
+ K = KUP1 - J
+ DO 70 I = MAX(1,J-KU),MIN(M,J+KL)
+ Y(IY) = Y(IY) + TEMP*A(K+I,J)
+ IY = IY + INCY
+ 70 CONTINUE
+ END IF
+ JX = JX + INCX
+ IF (J.GT.KU) KY = KY + INCY
+ 80 CONTINUE
+ END IF
+ ELSE
+*
+* Form y := alpha*A'*x + y.
+*
+ JY = KY
+ IF (INCX.EQ.1) THEN
+ DO 100 J = 1,N
+ TEMP = ZERO
+ K = KUP1 - J
+ DO 90 I = MAX(1,J-KU),MIN(M,J+KL)
+ TEMP = TEMP + A(K+I,J)*X(I)
+ 90 CONTINUE
+ Y(JY) = Y(JY) + ALPHA*TEMP
+ JY = JY + INCY
+ 100 CONTINUE
+ ELSE
+ DO 120 J = 1,N
+ TEMP = ZERO
+ IX = KX
+ K = KUP1 - J
+ DO 110 I = MAX(1,J-KU),MIN(M,J+KL)
+ TEMP = TEMP + A(K+I,J)*X(IX)
+ IX = IX + INCX
+ 110 CONTINUE
+ Y(JY) = Y(JY) + ALPHA*TEMP
+ JY = JY + INCY
+ IF (J.GT.KU) KX = KX + INCX
+ 120 CONTINUE
+ END IF
+ END IF
+*
+ RETURN
+*
+* End of SGBMV .
+*
+ END
+ SUBROUTINE SGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC)
+* .. Scalar Arguments ..
+ REAL ALPHA,BETA
+ INTEGER K,LDA,LDB,LDC,M,N
+ CHARACTER TRANSA,TRANSB
+* ..
+* .. Array Arguments ..
+ REAL A(LDA,*),B(LDB,*),C(LDC,*)
+* ..
+*
+* Purpose
+* =======
+*
+* SGEMM performs one of the matrix-matrix operations
+*
+* C := alpha*op( A )*op( B ) + beta*C,
+*
+* where op( X ) is one of
+*
+* op( X ) = X or op( X ) = X',
+*
+* alpha and beta are scalars, and A, B and C are matrices, with op( A )
+* an m by k matrix, op( B ) a k by n matrix and C an m by n matrix.
+*
+* Arguments
+* ==========
+*
+* TRANSA - CHARACTER*1.
+* On entry, TRANSA specifies the form of op( A ) to be used in
+* the matrix multiplication as follows:
+*
+* TRANSA = 'N' or 'n', op( A ) = A.
+*
+* TRANSA = 'T' or 't', op( A ) = A'.
+*
+* TRANSA = 'C' or 'c', op( A ) = A'.
+*
+* Unchanged on exit.
+*
+* TRANSB - CHARACTER*1.
+* On entry, TRANSB specifies the form of op( B ) to be used in
+* the matrix multiplication as follows:
+*
+* TRANSB = 'N' or 'n', op( B ) = B.
+*
+* TRANSB = 'T' or 't', op( B ) = B'.
+*
+* TRANSB = 'C' or 'c', op( B ) = B'.
+*
+* Unchanged on exit.
+*
+* M - INTEGER.
+* On entry, M specifies the number of rows of the matrix
+* op( A ) and of the matrix C. M must be at least zero.
+* Unchanged on exit.
+*
+* N - INTEGER.
+* On entry, N specifies the number of columns of the matrix
+* op( B ) and the number of columns of the matrix C. N must be
+* at least zero.
+* Unchanged on exit.
+*
+* K - INTEGER.
+* On entry, K specifies the number of columns of the matrix
+* op( A ) and the number of rows of the matrix op( B ). K must
+* be at least zero.
+* Unchanged on exit.
+*
+* ALPHA - REAL .
+* On entry, ALPHA specifies the scalar alpha.
+* Unchanged on exit.
+*
+* A - REAL array of DIMENSION ( LDA, ka ), where ka is
+* k when TRANSA = 'N' or 'n', and is m otherwise.
+* Before entry with TRANSA = 'N' or 'n', the leading m by k
+* part of the array A must contain the matrix A, otherwise
+* the leading k by m part of the array A must contain the
+* matrix A.
+* Unchanged on exit.
+*
+* LDA - INTEGER.
+* On entry, LDA specifies the first dimension of A as declared
+* in the calling (sub) program. When TRANSA = 'N' or 'n' then
+* LDA must be at least max( 1, m ), otherwise LDA must be at
+* least max( 1, k ).
+* Unchanged on exit.
+*
+* B - REAL array of DIMENSION ( LDB, kb ), where kb is
+* n when TRANSB = 'N' or 'n', and is k otherwise.
+* Before entry with TRANSB = 'N' or 'n', the leading k by n
+* part of the array B must contain the matrix B, otherwise
+* the leading n by k part of the array B must contain the
+* matrix B.
+* Unchanged on exit.
+*
+* LDB - INTEGER.
+* On entry, LDB specifies the first dimension of B as declared
+* in the calling (sub) program. When TRANSB = 'N' or 'n' then
+* LDB must be at least max( 1, k ), otherwise LDB must be at
+* least max( 1, n ).
+* Unchanged on exit.
+*
+* BETA - REAL .
+* On entry, BETA specifies the scalar beta. When BETA is
+* supplied as zero then C need not be set on input.
+* Unchanged on exit.
+*
+* C - REAL array of DIMENSION ( LDC, n ).
+* Before entry, the leading m by n part of the array C must
+* contain the matrix C, except when beta is zero, in which
+* case C need not be set on entry.
+* On exit, the array C is overwritten by the m by n matrix
+* ( alpha*op( A )*op( B ) + beta*C ).
+*
+* LDC - INTEGER.
+* On entry, LDC specifies the first dimension of C as declared
+* in the calling (sub) program. LDC must be at least
+* max( 1, m ).
+* Unchanged on exit.
+*
+*
+* Level 3 Blas routine.
+*
+* -- Written on 8-February-1989.
+* Jack Dongarra, Argonne National Laboratory.
+* Iain Duff, AERE Harwell.
+* Jeremy Du Croz, Numerical Algorithms Group Ltd.
+* Sven Hammarling, Numerical Algorithms Group Ltd.
+*
+*
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Local Scalars ..
+ REAL TEMP
+ INTEGER I,INFO,J,L,NCOLA,NROWA,NROWB
+ LOGICAL NOTA,NOTB
+* ..
+* .. Parameters ..
+ REAL ONE,ZERO
+ PARAMETER (ONE=1.0E+0,ZERO=0.0E+0)
+* ..
+*
+* Set NOTA and NOTB as true if A and B respectively are not
+* transposed and set NROWA, NCOLA and NROWB as the number of rows
+* and columns of A and the number of rows of B respectively.
+*
+ NOTA = LSAME(TRANSA,'N')
+ NOTB = LSAME(TRANSB,'N')
+ IF (NOTA) THEN
+ NROWA = M
+ NCOLA = K
+ ELSE
+ NROWA = K
+ NCOLA = M
+ END IF
+ IF (NOTB) THEN
+ NROWB = K
+ ELSE
+ NROWB = N
+ END IF
+*
+* Test the input parameters.
+*
+ INFO = 0
+ IF ((.NOT.NOTA) .AND. (.NOT.LSAME(TRANSA,'C')) .AND.
+ + (.NOT.LSAME(TRANSA,'T'))) THEN
+ INFO = 1
+ ELSE IF ((.NOT.NOTB) .AND. (.NOT.LSAME(TRANSB,'C')) .AND.
+ + (.NOT.LSAME(TRANSB,'T'))) THEN
+ INFO = 2
+ ELSE IF (M.LT.0) THEN
+ INFO = 3
+ ELSE IF (N.LT.0) THEN
+ INFO = 4
+ ELSE IF (K.LT.0) THEN
+ INFO = 5
+ ELSE IF (LDA.LT.MAX(1,NROWA)) THEN
+ INFO = 8
+ ELSE IF (LDB.LT.MAX(1,NROWB)) THEN
+ INFO = 10
+ ELSE IF (LDC.LT.MAX(1,M)) THEN
+ INFO = 13
+ END IF
+ IF (INFO.NE.0) THEN
+ CALL XERBLA('SGEMM ',INFO)
+ RETURN
+ END IF
+*
+* Quick return if possible.
+*
+ IF ((M.EQ.0) .OR. (N.EQ.0) .OR.
+ + (((ALPHA.EQ.ZERO).OR. (K.EQ.0)).AND. (BETA.EQ.ONE))) RETURN
+*
+* And if alpha.eq.zero.
+*
+ IF (ALPHA.EQ.ZERO) THEN
+ IF (BETA.EQ.ZERO) THEN
+ DO 20 J = 1,N
+ DO 10 I = 1,M
+ C(I,J) = ZERO
+ 10 CONTINUE
+ 20 CONTINUE
+ ELSE
+ DO 40 J = 1,N
+ DO 30 I = 1,M
+ C(I,J) = BETA*C(I,J)
+ 30 CONTINUE
+ 40 CONTINUE
+ END IF
+ RETURN
+ END IF
+*
+* Start the operations.
+*
+ IF (NOTB) THEN
+ IF (NOTA) THEN
+*
+* Form C := alpha*A*B + beta*C.
+*
+ DO 90 J = 1,N
+ IF (BETA.EQ.ZERO) THEN
+ DO 50 I = 1,M
+ C(I,J) = ZERO
+ 50 CONTINUE
+ ELSE IF (BETA.NE.ONE) THEN
+ DO 60 I = 1,M
+ C(I,J) = BETA*C(I,J)
+ 60 CONTINUE
+ END IF
+ DO 80 L = 1,K
+ IF (B(L,J).NE.ZERO) THEN
+ TEMP = ALPHA*B(L,J)
+ DO 70 I = 1,M
+ C(I,J) = C(I,J) + TEMP*A(I,L)
+ 70 CONTINUE
+ END IF
+ 80 CONTINUE
+ 90 CONTINUE
+ ELSE
+*
+* Form C := alpha*A'*B + beta*C
+*
+ DO 120 J = 1,N
+ DO 110 I = 1,M
+ TEMP = ZERO
+ DO 100 L = 1,K
+ TEMP = TEMP + A(L,I)*B(L,J)
+ 100 CONTINUE
+ IF (BETA.EQ.ZERO) THEN
+ C(I,J) = ALPHA*TEMP
+ ELSE
+ C(I,J) = ALPHA*TEMP + BETA*C(I,J)
+ END IF
+ 110 CONTINUE
+ 120 CONTINUE
+ END IF
+ ELSE
+ IF (NOTA) THEN
+*
+* Form C := alpha*A*B' + beta*C
+*
+ DO 170 J = 1,N
+ IF (BETA.EQ.ZERO) THEN
+ DO 130 I = 1,M
+ C(I,J) = ZERO
+ 130 CONTINUE
+ ELSE IF (BETA.NE.ONE) THEN
+ DO 140 I = 1,M
+ C(I,J) = BETA*C(I,J)
+ 140 CONTINUE
+ END IF
+ DO 160 L = 1,K
+ IF (B(J,L).NE.ZERO) THEN
+ TEMP = ALPHA*B(J,L)
+ DO 150 I = 1,M
+ C(I,J) = C(I,J) + TEMP*A(I,L)
+ 150 CONTINUE
+ END IF
+ 160 CONTINUE
+ 170 CONTINUE
+ ELSE
+*
+* Form C := alpha*A'*B' + beta*C
+*
+ DO 200 J = 1,N
+ DO 190 I = 1,M
+ TEMP = ZERO
+ DO 180 L = 1,K
+ TEMP = TEMP + A(L,I)*B(J,L)
+ 180 CONTINUE
+ IF (BETA.EQ.ZERO) THEN
+ C(I,J) = ALPHA*TEMP
+ ELSE
+ C(I,J) = ALPHA*TEMP + BETA*C(I,J)
+ END IF
+ 190 CONTINUE
+ 200 CONTINUE
+ END IF
+ END IF
+*
+ RETURN
+*
+* End of SGEMM .
+*
+ END
+ SUBROUTINE SGEMV(TRANS,M,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY)
+* .. Scalar Arguments ..
+ REAL ALPHA,BETA
+ INTEGER INCX,INCY,LDA,M,N
+ CHARACTER TRANS
+* ..
+* .. Array Arguments ..
+ REAL A(LDA,*),X(*),Y(*)
+* ..
+*
+* Purpose
+* =======
+*
+* SGEMV performs one of the matrix-vector operations
+*
+* y := alpha*A*x + beta*y, or y := alpha*A'*x + beta*y,
+*
+* where alpha and beta are scalars, x and y are vectors and A is an
+* m by n matrix.
+*
+* Arguments
+* ==========
+*
+* TRANS - CHARACTER*1.
+* On entry, TRANS specifies the operation to be performed as
+* follows:
+*
+* TRANS = 'N' or 'n' y := alpha*A*x + beta*y.
+*
+* TRANS = 'T' or 't' y := alpha*A'*x + beta*y.
+*
+* TRANS = 'C' or 'c' y := alpha*A'*x + beta*y.
+*
+* Unchanged on exit.
+*
+* M - INTEGER.
+* On entry, M specifies the number of rows of the matrix A.
+* M must be at least zero.
+* Unchanged on exit.
+*
+* N - INTEGER.
+* On entry, N specifies the number of columns of the matrix A.
+* N must be at least zero.
+* Unchanged on exit.
+*
+* ALPHA - REAL .
+* On entry, ALPHA specifies the scalar alpha.
+* Unchanged on exit.
+*
+* A - REAL array of DIMENSION ( LDA, n ).
+* Before entry, the leading m by n part of the array A must
+* contain the matrix of coefficients.
+* Unchanged on exit.
+*
+* LDA - INTEGER.
+* On entry, LDA specifies the first dimension of A as declared
+* in the calling (sub) program. LDA must be at least
+* max( 1, m ).
+* Unchanged on exit.
+*
+* X - REAL array of DIMENSION at least
+* ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n'
+* and at least
+* ( 1 + ( m - 1 )*abs( INCX ) ) otherwise.
+* Before entry, the incremented array X must contain the
+* vector x.
+* Unchanged on exit.
+*
+* INCX - INTEGER.
+* On entry, INCX specifies the increment for the elements of
+* X. INCX must not be zero.
+* Unchanged on exit.
+*
+* BETA - REAL .
+* On entry, BETA specifies the scalar beta. When BETA is
+* supplied as zero then Y need not be set on input.
+* Unchanged on exit.
+*
+* Y - REAL array of DIMENSION at least
+* ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n'
+* and at least
+* ( 1 + ( n - 1 )*abs( INCY ) ) otherwise.
+* Before entry with BETA non-zero, the incremented array Y
+* must contain the vector y. On exit, Y is overwritten by the
+* updated vector y.
+*
+* INCY - INTEGER.
+* On entry, INCY specifies the increment for the elements of
+* Y. INCY must not be zero.
+* Unchanged on exit.
+*
+*
+* Level 2 Blas routine.
+*
+* -- Written on 22-October-1986.
+* Jack Dongarra, Argonne National Lab.
+* Jeremy Du Croz, Nag Central Office.
+* Sven Hammarling, Nag Central Office.
+* Richard Hanson, Sandia National Labs.
+*
+*
+* .. Parameters ..
+ REAL ONE,ZERO
+ PARAMETER (ONE=1.0E+0,ZERO=0.0E+0)
+* ..
+* .. Local Scalars ..
+ REAL TEMP
+ INTEGER I,INFO,IX,IY,J,JX,JY,KX,KY,LENX,LENY
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ IF (.NOT.LSAME(TRANS,'N') .AND. .NOT.LSAME(TRANS,'T') .AND.
+ + .NOT.LSAME(TRANS,'C')) THEN
+ INFO = 1
+ ELSE IF (M.LT.0) THEN
+ INFO = 2
+ ELSE IF (N.LT.0) THEN
+ INFO = 3
+ ELSE IF (LDA.LT.MAX(1,M)) THEN
+ INFO = 6
+ ELSE IF (INCX.EQ.0) THEN
+ INFO = 8
+ ELSE IF (INCY.EQ.0) THEN
+ INFO = 11
+ END IF
+ IF (INFO.NE.0) THEN
+ CALL XERBLA('SGEMV ',INFO)
+ RETURN
+ END IF
+*
+* Quick return if possible.
+*
+ IF ((M.EQ.0) .OR. (N.EQ.0) .OR.
+ + ((ALPHA.EQ.ZERO).AND. (BETA.EQ.ONE))) RETURN
+*
+* Set LENX and LENY, the lengths of the vectors x and y, and set
+* up the start points in X and Y.
+*
+ IF (LSAME(TRANS,'N')) THEN
+ LENX = N
+ LENY = M
+ ELSE
+ LENX = M
+ LENY = N
+ END IF
+ IF (INCX.GT.0) THEN
+ KX = 1
+ ELSE
+ KX = 1 - (LENX-1)*INCX
+ END IF
+ IF (INCY.GT.0) THEN
+ KY = 1
+ ELSE
+ KY = 1 - (LENY-1)*INCY
+ END IF
+*
+* Start the operations. In this version the elements of A are
+* accessed sequentially with one pass through A.
+*
+* First form y := beta*y.
+*
+ IF (BETA.NE.ONE) THEN
+ IF (INCY.EQ.1) THEN
+ IF (BETA.EQ.ZERO) THEN
+ DO 10 I = 1,LENY
+ Y(I) = ZERO
+ 10 CONTINUE
+ ELSE
+ DO 20 I = 1,LENY
+ Y(I) = BETA*Y(I)
+ 20 CONTINUE
+ END IF
+ ELSE
+ IY = KY
+ IF (BETA.EQ.ZERO) THEN
+ DO 30 I = 1,LENY
+ Y(IY) = ZERO
+ IY = IY + INCY
+ 30 CONTINUE
+ ELSE
+ DO 40 I = 1,LENY
+ Y(IY) = BETA*Y(IY)
+ IY = IY + INCY
+ 40 CONTINUE
+ END IF
+ END IF
+ END IF
+ IF (ALPHA.EQ.ZERO) RETURN
+ IF (LSAME(TRANS,'N')) THEN
+*
+* Form y := alpha*A*x + y.
+*
+ JX = KX
+ IF (INCY.EQ.1) THEN
+ DO 60 J = 1,N
+ IF (X(JX).NE.ZERO) THEN
+ TEMP = ALPHA*X(JX)
+ DO 50 I = 1,M
+ Y(I) = Y(I) + TEMP*A(I,J)
+ 50 CONTINUE
+ END IF
+ JX = JX + INCX
+ 60 CONTINUE
+ ELSE
+ DO 80 J = 1,N
+ IF (X(JX).NE.ZERO) THEN
+ TEMP = ALPHA*X(JX)
+ IY = KY
+ DO 70 I = 1,M
+ Y(IY) = Y(IY) + TEMP*A(I,J)
+ IY = IY + INCY
+ 70 CONTINUE
+ END IF
+ JX = JX + INCX
+ 80 CONTINUE
+ END IF
+ ELSE
+*
+* Form y := alpha*A'*x + y.
+*
+ JY = KY
+ IF (INCX.EQ.1) THEN
+ DO 100 J = 1,N
+ TEMP = ZERO
+ DO 90 I = 1,M
+ TEMP = TEMP + A(I,J)*X(I)
+ 90 CONTINUE
+ Y(JY) = Y(JY) + ALPHA*TEMP
+ JY = JY + INCY
+ 100 CONTINUE
+ ELSE
+ DO 120 J = 1,N
+ TEMP = ZERO
+ IX = KX
+ DO 110 I = 1,M
+ TEMP = TEMP + A(I,J)*X(IX)
+ IX = IX + INCX
+ 110 CONTINUE
+ Y(JY) = Y(JY) + ALPHA*TEMP
+ JY = JY + INCY
+ 120 CONTINUE
+ END IF
+ END IF
+*
+ RETURN
+*
+* End of SGEMV .
+*
+ END
+ SUBROUTINE SGER(M,N,ALPHA,X,INCX,Y,INCY,A,LDA)
+* .. Scalar Arguments ..
+ REAL ALPHA
+ INTEGER INCX,INCY,LDA,M,N
+* ..
+* .. Array Arguments ..
+ REAL A(LDA,*),X(*),Y(*)
+* ..
+*
+* Purpose
+* =======
+*
+* SGER performs the rank 1 operation
+*
+* A := alpha*x*y' + A,
+*
+* where alpha is a scalar, x is an m element vector, y is an n element
+* vector and A is an m by n matrix.
+*
+* Arguments
+* ==========
+*
+* M - INTEGER.
+* On entry, M specifies the number of rows of the matrix A.
+* M must be at least zero.
+* Unchanged on exit.
+*
+* N - INTEGER.
+* On entry, N specifies the number of columns of the matrix A.
+* N must be at least zero.
+* Unchanged on exit.
+*
+* ALPHA - REAL .
+* On entry, ALPHA specifies the scalar alpha.
+* Unchanged on exit.
+*
+* X - REAL array of dimension at least
+* ( 1 + ( m - 1 )*abs( INCX ) ).
+* Before entry, the incremented array X must contain the m
+* element vector x.
+* Unchanged on exit.
+*
+* INCX - INTEGER.
+* On entry, INCX specifies the increment for the elements of
+* X. INCX must not be zero.
+* Unchanged on exit.
+*
+* Y - REAL array of dimension at least
+* ( 1 + ( n - 1 )*abs( INCY ) ).
+* Before entry, the incremented array Y must contain the n
+* element vector y.
+* Unchanged on exit.
+*
+* INCY - INTEGER.
+* On entry, INCY specifies the increment for the elements of
+* Y. INCY must not be zero.
+* Unchanged on exit.
+*
+* A - REAL array of DIMENSION ( LDA, n ).
+* Before entry, the leading m by n part of the array A must
+* contain the matrix of coefficients. On exit, A is
+* overwritten by the updated matrix.
+*
+* LDA - INTEGER.
+* On entry, LDA specifies the first dimension of A as declared
+* in the calling (sub) program. LDA must be at least
+* max( 1, m ).
+* Unchanged on exit.
+*
+*
+* Level 2 Blas routine.
+*
+* -- Written on 22-October-1986.
+* Jack Dongarra, Argonne National Lab.
+* Jeremy Du Croz, Nag Central Office.
+* Sven Hammarling, Nag Central Office.
+* Richard Hanson, Sandia National Labs.
+*
+*
+* .. Parameters ..
+ REAL ZERO
+ PARAMETER (ZERO=0.0E+0)
+* ..
+* .. Local Scalars ..
+ REAL TEMP
+ INTEGER I,INFO,IX,J,JY,KX
+* ..
+* .. External Subroutines ..
+ EXTERNAL XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ IF (M.LT.0) THEN
+ INFO = 1
+ ELSE IF (N.LT.0) THEN
+ INFO = 2
+ ELSE IF (INCX.EQ.0) THEN
+ INFO = 5
+ ELSE IF (INCY.EQ.0) THEN
+ INFO = 7
+ ELSE IF (LDA.LT.MAX(1,M)) THEN
+ INFO = 9
+ END IF
+ IF (INFO.NE.0) THEN
+ CALL XERBLA('SGER ',INFO)
+ RETURN
+ END IF
+*
+* Quick return if possible.
+*
+ IF ((M.EQ.0) .OR. (N.EQ.0) .OR. (ALPHA.EQ.ZERO)) RETURN
+*
+* Start the operations. In this version the elements of A are
+* accessed sequentially with one pass through A.
+*
+ IF (INCY.GT.0) THEN
+ JY = 1
+ ELSE
+ JY = 1 - (N-1)*INCY
+ END IF
+ IF (INCX.EQ.1) THEN
+ DO 20 J = 1,N
+ IF (Y(JY).NE.ZERO) THEN
+ TEMP = ALPHA*Y(JY)
+ DO 10 I = 1,M
+ A(I,J) = A(I,J) + X(I)*TEMP
+ 10 CONTINUE
+ END IF
+ JY = JY + INCY
+ 20 CONTINUE
+ ELSE
+ IF (INCX.GT.0) THEN
+ KX = 1
+ ELSE
+ KX = 1 - (M-1)*INCX
+ END IF
+ DO 40 J = 1,N
+ IF (Y(JY).NE.ZERO) THEN
+ TEMP = ALPHA*Y(JY)
+ IX = KX
+ DO 30 I = 1,M
+ A(I,J) = A(I,J) + X(IX)*TEMP
+ IX = IX + INCX
+ 30 CONTINUE
+ END IF
+ JY = JY + INCY
+ 40 CONTINUE
+ END IF
+*
+ RETURN
+*
+* End of SGER .
+*
+ END
+ REAL FUNCTION SNRM2(N,X,INCX)
+* .. Scalar Arguments ..
+ INTEGER INCX,N
+* ..
+* .. Array Arguments ..
+ REAL X(*)
+* ..
+*
+* Purpose
+* =======
+*
+* SNRM2 returns the euclidean norm of a vector via the function
+* name, so that
+*
+* SNRM2 := sqrt( x'*x ).
+*
+* Further Details
+* ===============
+*
+* -- This version written on 25-October-1982.
+* Modified on 14-October-1993 to inline the call to SLASSQ.
+* Sven Hammarling, Nag Ltd.
+*
+*
+* .. Parameters ..
+ REAL ONE,ZERO
+ PARAMETER (ONE=1.0E+0,ZERO=0.0E+0)
+* ..
+* .. Local Scalars ..
+ REAL ABSXI,NORM,SCALE,SSQ
+ INTEGER IX
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS,SQRT
+* ..
+ IF (N.LT.1 .OR. INCX.LT.1) THEN
+ NORM = ZERO
+ ELSE IF (N.EQ.1) THEN
+ NORM = ABS(X(1))
+ ELSE
+ SCALE = ZERO
+ SSQ = ONE
+* The following loop is equivalent to this call to the LAPACK
+* auxiliary routine:
+* CALL SLASSQ( N, X, INCX, SCALE, SSQ )
+*
+ DO 10 IX = 1,1 + (N-1)*INCX,INCX
+ IF (X(IX).NE.ZERO) THEN
+ ABSXI = ABS(X(IX))
+ IF (SCALE.LT.ABSXI) THEN
+ SSQ = ONE + SSQ* (SCALE/ABSXI)**2
+ SCALE = ABSXI
+ ELSE
+ SSQ = SSQ + (ABSXI/SCALE)**2
+ END IF
+ END IF
+ 10 CONTINUE
+ NORM = SCALE*SQRT(SSQ)
+ END IF
+*
+ SNRM2 = NORM
+ RETURN
+*
+* End of SNRM2.
+*
+ END
+ SUBROUTINE SROT(N,SX,INCX,SY,INCY,C,S)
+* .. Scalar Arguments ..
+ REAL C,S
+ INTEGER INCX,INCY,N
+* ..
+* .. Array Arguments ..
+ REAL SX(*),SY(*)
+* ..
+*
+* Purpose
+* =======
+*
+* applies a plane rotation.
+*
+* Further Details
+* ===============
+*
+* jack dongarra, linpack, 3/11/78.
+* modified 12/3/93, array(1) declarations changed to array(*)
+*
+*
+
+* .. Local Scalars ..
+ REAL STEMP
+ INTEGER I,IX,IY
+* ..
+ IF (N.LE.0) RETURN
+ IF (INCX.EQ.1 .AND. INCY.EQ.1) GO TO 20
+*
+* code for unequal increments or equal increments not equal
+* to 1
+*
+ IX = 1
+ IY = 1
+ IF (INCX.LT.0) IX = (-N+1)*INCX + 1
+ IF (INCY.LT.0) IY = (-N+1)*INCY + 1
+ DO 10 I = 1,N
+ STEMP = C*SX(IX) + S*SY(IY)
+ SY(IY) = C*SY(IY) - S*SX(IX)
+ SX(IX) = STEMP
+ IX = IX + INCX
+ IY = IY + INCY
+ 10 CONTINUE
+ RETURN
+*
+* code for both increments equal to 1
+*
+ 20 DO 30 I = 1,N
+ STEMP = C*SX(I) + S*SY(I)
+ SY(I) = C*SY(I) - S*SX(I)
+ SX(I) = STEMP
+ 30 CONTINUE
+ RETURN
+ END
+ SUBROUTINE SROTG(SA,SB,C,S)
+* .. Scalar Arguments ..
+ REAL C,S,SA,SB
+* ..
+*
+* Purpose
+* =======
+*
+* construct givens plane rotation.
+* jack dongarra, linpack, 3/11/78.
+*
+*
+* .. Local Scalars ..
+ REAL R,ROE,SCALE,Z
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS,SIGN,SQRT
+* ..
+ ROE = SB
+ IF (ABS(SA).GT.ABS(SB)) ROE = SA
+ SCALE = ABS(SA) + ABS(SB)
+ IF (SCALE.NE.0.0) GO TO 10
+ C = 1.0
+ S = 0.0
+ R = 0.0
+ Z = 0.0
+ GO TO 20
+ 10 R = SCALE*SQRT((SA/SCALE)**2+ (SB/SCALE)**2)
+ R = SIGN(1.0,ROE)*R
+ C = SA/R
+ S = SB/R
+ Z = 1.0
+ IF (ABS(SA).GT.ABS(SB)) Z = S
+ IF (ABS(SB).GE.ABS(SA) .AND. C.NE.0.0) Z = 1.0/C
+ 20 SA = R
+ SB = Z
+ RETURN
+ END
+ SUBROUTINE SROTM(N,SX,INCX,SY,INCY,SPARAM)
+* .. Scalar Arguments ..
+ INTEGER INCX,INCY,N
+* ..
+* .. Array Arguments ..
+ REAL SPARAM(5),SX(1),SY(1)
+* ..
+*
+* Purpose
+* =======
+*
+* APPLY THE MODIFIED GIVENS TRANSFORMATION, H, TO THE 2 BY N MATRIX
+*
+* (SX**T) , WHERE **T INDICATES TRANSPOSE. THE ELEMENTS OF SX ARE IN
+* (DX**T)
+*
+* SX(LX+I*INCX), I = 0 TO N-1, WHERE LX = 1 IF INCX .GE. 0, ELSE
+* LX = (-INCX)*N, AND SIMILARLY FOR SY USING USING LY AND INCY.
+* WITH SPARAM(1)=SFLAG, H HAS ONE OF THE FOLLOWING FORMS..
+*
+* SFLAG=-1.E0 SFLAG=0.E0 SFLAG=1.E0 SFLAG=-2.E0
+*
+* (SH11 SH12) (1.E0 SH12) (SH11 1.E0) (1.E0 0.E0)
+* H=( ) ( ) ( ) ( )
+* (SH21 SH22), (SH21 1.E0), (-1.E0 SH22), (0.E0 1.E0).
+* SEE SROTMG FOR A DESCRIPTION OF DATA STORAGE IN SPARAM.
+*
+*
+* Arguments
+* =========
+*
+* N (input) INTEGER
+* number of elements in input vector(s)
+*
+* SX (input/output) REAL array, dimension N
+* double precision vector with 5 elements
+*
+* INCX (input) INTEGER
+* storage spacing between elements of SX
+*
+* SY (input/output) REAL array, dimension N
+* double precision vector with N elements
+*
+* INCY (input) INTEGER
+* storage spacing between elements of SY
+*
+* SPARAM (input/output) REAL array, dimension 5
+* SPARAM(1)=SFLAG
+* SPARAM(2)=SH11
+* SPARAM(3)=SH21
+* SPARAM(4)=SH12
+* SPARAM(5)=SH22
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ REAL SFLAG,SH11,SH12,SH21,SH22,TWO,W,Z,ZERO
+ INTEGER I,KX,KY,NSTEPS
+* ..
+* .. Data statements ..
+ DATA ZERO,TWO/0.E0,2.E0/
+* ..
+*
+ SFLAG = SPARAM(1)
+ IF (N.LE.0 .OR. (SFLAG+TWO.EQ.ZERO)) GO TO 140
+ IF (.NOT. (INCX.EQ.INCY.AND.INCX.GT.0)) GO TO 70
+*
+ NSTEPS = N*INCX
+ IF (SFLAG) 50,10,30
+ 10 CONTINUE
+ SH12 = SPARAM(4)
+ SH21 = SPARAM(3)
+ DO 20 I = 1,NSTEPS,INCX
+ W = SX(I)
+ Z = SY(I)
+ SX(I) = W + Z*SH12
+ SY(I) = W*SH21 + Z
+ 20 CONTINUE
+ GO TO 140
+ 30 CONTINUE
+ SH11 = SPARAM(2)
+ SH22 = SPARAM(5)
+ DO 40 I = 1,NSTEPS,INCX
+ W = SX(I)
+ Z = SY(I)
+ SX(I) = W*SH11 + Z
+ SY(I) = -W + SH22*Z
+ 40 CONTINUE
+ GO TO 140
+ 50 CONTINUE
+ SH11 = SPARAM(2)
+ SH12 = SPARAM(4)
+ SH21 = SPARAM(3)
+ SH22 = SPARAM(5)
+ DO 60 I = 1,NSTEPS,INCX
+ W = SX(I)
+ Z = SY(I)
+ SX(I) = W*SH11 + Z*SH12
+ SY(I) = W*SH21 + Z*SH22
+ 60 CONTINUE
+ GO TO 140
+ 70 CONTINUE
+ KX = 1
+ KY = 1
+ IF (INCX.LT.0) KX = 1 + (1-N)*INCX
+ IF (INCY.LT.0) KY = 1 + (1-N)*INCY
+*
+ IF (SFLAG) 120,80,100
+ 80 CONTINUE
+ SH12 = SPARAM(4)
+ SH21 = SPARAM(3)
+ DO 90 I = 1,N
+ W = SX(KX)
+ Z = SY(KY)
+ SX(KX) = W + Z*SH12
+ SY(KY) = W*SH21 + Z
+ KX = KX + INCX
+ KY = KY + INCY
+ 90 CONTINUE
+ GO TO 140
+ 100 CONTINUE
+ SH11 = SPARAM(2)
+ SH22 = SPARAM(5)
+ DO 110 I = 1,N
+ W = SX(KX)
+ Z = SY(KY)
+ SX(KX) = W*SH11 + Z
+ SY(KY) = -W + SH22*Z
+ KX = KX + INCX
+ KY = KY + INCY
+ 110 CONTINUE
+ GO TO 140
+ 120 CONTINUE
+ SH11 = SPARAM(2)
+ SH12 = SPARAM(4)
+ SH21 = SPARAM(3)
+ SH22 = SPARAM(5)
+ DO 130 I = 1,N
+ W = SX(KX)
+ Z = SY(KY)
+ SX(KX) = W*SH11 + Z*SH12
+ SY(KY) = W*SH21 + Z*SH22
+ KX = KX + INCX
+ KY = KY + INCY
+ 130 CONTINUE
+ 140 CONTINUE
+ RETURN
+ END
+ SUBROUTINE SROTMG(SD1,SD2,SX1,SY1,SPARAM)
+* .. Scalar Arguments ..
+ REAL SD1,SD2,SX1,SY1
+* ..
+* .. Array Arguments ..
+ REAL SPARAM(5)
+* ..
+*
+* Purpose
+* =======
+*
+* CONSTRUCT THE MODIFIED GIVENS TRANSFORMATION MATRIX H WHICH ZEROS
+* THE SECOND COMPONENT OF THE 2-VECTOR (SQRT(SD1)*SX1,SQRT(SD2)*
+* SY2)**T.
+* WITH SPARAM(1)=SFLAG, H HAS ONE OF THE FOLLOWING FORMS..
+*
+* SFLAG=-1.E0 SFLAG=0.E0 SFLAG=1.E0 SFLAG=-2.E0
+*
+* (SH11 SH12) (1.E0 SH12) (SH11 1.E0) (1.E0 0.E0)
+* H=( ) ( ) ( ) ( )
+* (SH21 SH22), (SH21 1.E0), (-1.E0 SH22), (0.E0 1.E0).
+* LOCATIONS 2-4 OF SPARAM CONTAIN SH11,SH21,SH12, AND SH22
+* RESPECTIVELY. (VALUES OF 1.E0, -1.E0, OR 0.E0 IMPLIED BY THE
+* VALUE OF SPARAM(1) ARE NOT STORED IN SPARAM.)
+*
+* THE VALUES OF GAMSQ AND RGAMSQ SET IN THE DATA STATEMENT MAY BE
+* INEXACT. THIS IS OK AS THEY ARE ONLY USED FOR TESTING THE SIZE
+* OF SD1 AND SD2. ALL ACTUAL SCALING OF DATA IS DONE USING GAM.
+*
+*
+* Arguments
+* =========
+*
+*
+* SD1 (input/output) REAL
+*
+* SD2 (input/output) REAL
+*
+* SX1 (input/output) REAL
+*
+* SY1 (input) REAL
+*
+*
+* SPARAM (input/output) REAL array, dimension 5
+* SPARAM(1)=SFLAG
+* SPARAM(2)=SH11
+* SPARAM(3)=SH21
+* SPARAM(4)=SH12
+* SPARAM(5)=SH22
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ REAL GAM,GAMSQ,ONE,RGAMSQ,SFLAG,SH11,SH12,SH21,SH22,SP1,SP2,SQ1,
+ + SQ2,STEMP,SU,TWO,ZERO
+ INTEGER IGO
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS
+* ..
+* .. Data statements ..
+*
+ DATA ZERO,ONE,TWO/0.E0,1.E0,2.E0/
+ DATA GAM,GAMSQ,RGAMSQ/4096.E0,1.67772E7,5.96046E-8/
+* ..
+
+ IF (.NOT.SD1.LT.ZERO) GO TO 10
+* GO ZERO-H-D-AND-SX1..
+ GO TO 60
+ 10 CONTINUE
+* CASE-SD1-NONNEGATIVE
+ SP2 = SD2*SY1
+ IF (.NOT.SP2.EQ.ZERO) GO TO 20
+ SFLAG = -TWO
+ GO TO 260
+* REGULAR-CASE..
+ 20 CONTINUE
+ SP1 = SD1*SX1
+ SQ2 = SP2*SY1
+ SQ1 = SP1*SX1
+*
+ IF (.NOT.ABS(SQ1).GT.ABS(SQ2)) GO TO 40
+ SH21 = -SY1/SX1
+ SH12 = SP2/SP1
+*
+ SU = ONE - SH12*SH21
+*
+ IF (.NOT.SU.LE.ZERO) GO TO 30
+* GO ZERO-H-D-AND-SX1..
+ GO TO 60
+ 30 CONTINUE
+ SFLAG = ZERO
+ SD1 = SD1/SU
+ SD2 = SD2/SU
+ SX1 = SX1*SU
+* GO SCALE-CHECK..
+ GO TO 100
+ 40 CONTINUE
+ IF (.NOT.SQ2.LT.ZERO) GO TO 50
+* GO ZERO-H-D-AND-SX1..
+ GO TO 60
+ 50 CONTINUE
+ SFLAG = ONE
+ SH11 = SP1/SP2
+ SH22 = SX1/SY1
+ SU = ONE + SH11*SH22
+ STEMP = SD2/SU
+ SD2 = SD1/SU
+ SD1 = STEMP
+ SX1 = SY1*SU
+* GO SCALE-CHECK
+ GO TO 100
+* PROCEDURE..ZERO-H-D-AND-SX1..
+ 60 CONTINUE
+ SFLAG = -ONE
+ SH11 = ZERO
+ SH12 = ZERO
+ SH21 = ZERO
+ SH22 = ZERO
+*
+ SD1 = ZERO
+ SD2 = ZERO
+ SX1 = ZERO
+* RETURN..
+ GO TO 220
+* PROCEDURE..FIX-H..
+ 70 CONTINUE
+ IF (.NOT.SFLAG.GE.ZERO) GO TO 90
+*
+ IF (.NOT.SFLAG.EQ.ZERO) GO TO 80
+ SH11 = ONE
+ SH22 = ONE
+ SFLAG = -ONE
+ GO TO 90
+ 80 CONTINUE
+ SH21 = -ONE
+ SH12 = ONE
+ SFLAG = -ONE
+ 90 CONTINUE
+ GO TO IGO(120,150,180,210)
+* PROCEDURE..SCALE-CHECK
+ 100 CONTINUE
+ 110 CONTINUE
+ IF (.NOT.SD1.LE.RGAMSQ) GO TO 130
+ IF (SD1.EQ.ZERO) GO TO 160
+ ASSIGN 120 TO IGO
+* FIX-H..
+ GO TO 70
+ 120 CONTINUE
+ SD1 = SD1*GAM**2
+ SX1 = SX1/GAM
+ SH11 = SH11/GAM
+ SH12 = SH12/GAM
+ GO TO 110
+ 130 CONTINUE
+ 140 CONTINUE
+ IF (.NOT.SD1.GE.GAMSQ) GO TO 160
+ ASSIGN 150 TO IGO
+* FIX-H..
+ GO TO 70
+ 150 CONTINUE
+ SD1 = SD1/GAM**2
+ SX1 = SX1*GAM
+ SH11 = SH11*GAM
+ SH12 = SH12*GAM
+ GO TO 140
+ 160 CONTINUE
+ 170 CONTINUE
+ IF (.NOT.ABS(SD2).LE.RGAMSQ) GO TO 190
+ IF (SD2.EQ.ZERO) GO TO 220
+ ASSIGN 180 TO IGO
+* FIX-H..
+ GO TO 70
+ 180 CONTINUE
+ SD2 = SD2*GAM**2
+ SH21 = SH21/GAM
+ SH22 = SH22/GAM
+ GO TO 170
+ 190 CONTINUE
+ 200 CONTINUE
+ IF (.NOT.ABS(SD2).GE.GAMSQ) GO TO 220
+ ASSIGN 210 TO IGO
+* FIX-H..
+ GO TO 70
+ 210 CONTINUE
+ SD2 = SD2/GAM**2
+ SH21 = SH21*GAM
+ SH22 = SH22*GAM
+ GO TO 200
+ 220 CONTINUE
+ IF (SFLAG) 250,230,240
+ 230 CONTINUE
+ SPARAM(3) = SH21
+ SPARAM(4) = SH12
+ GO TO 260
+ 240 CONTINUE
+ SPARAM(2) = SH11
+ SPARAM(5) = SH22
+ GO TO 260
+ 250 CONTINUE
+ SPARAM(2) = SH11
+ SPARAM(3) = SH21
+ SPARAM(4) = SH12
+ SPARAM(5) = SH22
+ 260 CONTINUE
+ SPARAM(1) = SFLAG
+ RETURN
+ END
+ SUBROUTINE SSBMV(UPLO,N,K,ALPHA,A,LDA,X,INCX,BETA,Y,INCY)
+* .. Scalar Arguments ..
+ REAL ALPHA,BETA
+ INTEGER INCX,INCY,K,LDA,N
+ CHARACTER UPLO
+* ..
+* .. Array Arguments ..
+ REAL A(LDA,*),X(*),Y(*)
+* ..
+*
+* Purpose
+* =======
+*
+* SSBMV performs the matrix-vector operation
+*
+* y := alpha*A*x + beta*y,
+*
+* where alpha and beta are scalars, x and y are n element vectors and
+* A is an n by n symmetric band matrix, with k super-diagonals.
+*
+* Arguments
+* ==========
+*
+* UPLO - CHARACTER*1.
+* On entry, UPLO specifies whether the upper or lower
+* triangular part of the band matrix A is being supplied as
+* follows:
+*
+* UPLO = 'U' or 'u' The upper triangular part of A is
+* being supplied.
+*
+* UPLO = 'L' or 'l' The lower triangular part of A is
+* being supplied.
+*
+* Unchanged on exit.
+*
+* N - INTEGER.
+* On entry, N specifies the order of the matrix A.
+* N must be at least zero.
+* Unchanged on exit.
+*
+* K - INTEGER.
+* On entry, K specifies the number of super-diagonals of the
+* matrix A. K must satisfy 0 .le. K.
+* Unchanged on exit.
+*
+* ALPHA - REAL .
+* On entry, ALPHA specifies the scalar alpha.
+* Unchanged on exit.
+*
+* A - REAL array of DIMENSION ( LDA, n ).
+* Before entry with UPLO = 'U' or 'u', the leading ( k + 1 )
+* by n part of the array A must contain the upper triangular
+* band part of the symmetric matrix, supplied column by
+* column, with the leading diagonal of the matrix in row
+* ( k + 1 ) of the array, the first super-diagonal starting at
+* position 2 in row k, and so on. The top left k by k triangle
+* of the array A is not referenced.
+* The following program segment will transfer the upper
+* triangular part of a symmetric band matrix from conventional
+* full matrix storage to band storage:
+*
+* DO 20, J = 1, N
+* M = K + 1 - J
+* DO 10, I = MAX( 1, J - K ), J
+* A( M + I, J ) = matrix( I, J )
+* 10 CONTINUE
+* 20 CONTINUE
+*
+* Before entry with UPLO = 'L' or 'l', the leading ( k + 1 )
+* by n part of the array A must contain the lower triangular
+* band part of the symmetric matrix, supplied column by
+* column, with the leading diagonal of the matrix in row 1 of
+* the array, the first sub-diagonal starting at position 1 in
+* row 2, and so on. The bottom right k by k triangle of the
+* array A is not referenced.
+* The following program segment will transfer the lower
+* triangular part of a symmetric band matrix from conventional
+* full matrix storage to band storage:
+*
+* DO 20, J = 1, N
+* M = 1 - J
+* DO 10, I = J, MIN( N, J + K )
+* A( M + I, J ) = matrix( I, J )
+* 10 CONTINUE
+* 20 CONTINUE
+*
+* Unchanged on exit.
+*
+* LDA - INTEGER.
+* On entry, LDA specifies the first dimension of A as declared
+* in the calling (sub) program. LDA must be at least
+* ( k + 1 ).
+* Unchanged on exit.
+*
+* X - REAL array of DIMENSION at least
+* ( 1 + ( n - 1 )*abs( INCX ) ).
+* Before entry, the incremented array X must contain the
+* vector x.
+* Unchanged on exit.
+*
+* INCX - INTEGER.
+* On entry, INCX specifies the increment for the elements of
+* X. INCX must not be zero.
+* Unchanged on exit.
+*
+* BETA - REAL .
+* On entry, BETA specifies the scalar beta.
+* Unchanged on exit.
+*
+* Y - REAL array of DIMENSION at least
+* ( 1 + ( n - 1 )*abs( INCY ) ).
+* Before entry, the incremented array Y must contain the
+* vector y. On exit, Y is overwritten by the updated vector y.
+*
+* INCY - INTEGER.
+* On entry, INCY specifies the increment for the elements of
+* Y. INCY must not be zero.
+* Unchanged on exit.
+*
+*
+* Level 2 Blas routine.
+*
+* -- Written on 22-October-1986.
+* Jack Dongarra, Argonne National Lab.
+* Jeremy Du Croz, Nag Central Office.
+* Sven Hammarling, Nag Central Office.
+* Richard Hanson, Sandia National Labs.
+*
+*
+* .. Parameters ..
+ REAL ONE,ZERO
+ PARAMETER (ONE=1.0E+0,ZERO=0.0E+0)
+* ..
+* .. Local Scalars ..
+ REAL TEMP1,TEMP2
+ INTEGER I,INFO,IX,IY,J,JX,JY,KPLUS1,KX,KY,L
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX,MIN
+* ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN
+ INFO = 1
+ ELSE IF (N.LT.0) THEN
+ INFO = 2
+ ELSE IF (K.LT.0) THEN
+ INFO = 3
+ ELSE IF (LDA.LT. (K+1)) THEN
+ INFO = 6
+ ELSE IF (INCX.EQ.0) THEN
+ INFO = 8
+ ELSE IF (INCY.EQ.0) THEN
+ INFO = 11
+ END IF
+ IF (INFO.NE.0) THEN
+ CALL XERBLA('SSBMV ',INFO)
+ RETURN
+ END IF
+*
+* Quick return if possible.
+*
+ IF ((N.EQ.0) .OR. ((ALPHA.EQ.ZERO).AND. (BETA.EQ.ONE))) RETURN
+*
+* Set up the start points in X and Y.
+*
+ IF (INCX.GT.0) THEN
+ KX = 1
+ ELSE
+ KX = 1 - (N-1)*INCX
+ END IF
+ IF (INCY.GT.0) THEN
+ KY = 1
+ ELSE
+ KY = 1 - (N-1)*INCY
+ END IF
+*
+* Start the operations. In this version the elements of the array A
+* are accessed sequentially with one pass through A.
+*
+* First form y := beta*y.
+*
+ IF (BETA.NE.ONE) THEN
+ IF (INCY.EQ.1) THEN
+ IF (BETA.EQ.ZERO) THEN
+ DO 10 I = 1,N
+ Y(I) = ZERO
+ 10 CONTINUE
+ ELSE
+ DO 20 I = 1,N
+ Y(I) = BETA*Y(I)
+ 20 CONTINUE
+ END IF
+ ELSE
+ IY = KY
+ IF (BETA.EQ.ZERO) THEN
+ DO 30 I = 1,N
+ Y(IY) = ZERO
+ IY = IY + INCY
+ 30 CONTINUE
+ ELSE
+ DO 40 I = 1,N
+ Y(IY) = BETA*Y(IY)
+ IY = IY + INCY
+ 40 CONTINUE
+ END IF
+ END IF
+ END IF
+ IF (ALPHA.EQ.ZERO) RETURN
+ IF (LSAME(UPLO,'U')) THEN
+*
+* Form y when upper triangle of A is stored.
+*
+ KPLUS1 = K + 1
+ IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
+ DO 60 J = 1,N
+ TEMP1 = ALPHA*X(J)
+ TEMP2 = ZERO
+ L = KPLUS1 - J
+ DO 50 I = MAX(1,J-K),J - 1
+ Y(I) = Y(I) + TEMP1*A(L+I,J)
+ TEMP2 = TEMP2 + A(L+I,J)*X(I)
+ 50 CONTINUE
+ Y(J) = Y(J) + TEMP1*A(KPLUS1,J) + ALPHA*TEMP2
+ 60 CONTINUE
+ ELSE
+ JX = KX
+ JY = KY
+ DO 80 J = 1,N
+ TEMP1 = ALPHA*X(JX)
+ TEMP2 = ZERO
+ IX = KX
+ IY = KY
+ L = KPLUS1 - J
+ DO 70 I = MAX(1,J-K),J - 1
+ Y(IY) = Y(IY) + TEMP1*A(L+I,J)
+ TEMP2 = TEMP2 + A(L+I,J)*X(IX)
+ IX = IX + INCX
+ IY = IY + INCY
+ 70 CONTINUE
+ Y(JY) = Y(JY) + TEMP1*A(KPLUS1,J) + ALPHA*TEMP2
+ JX = JX + INCX
+ JY = JY + INCY
+ IF (J.GT.K) THEN
+ KX = KX + INCX
+ KY = KY + INCY
+ END IF
+ 80 CONTINUE
+ END IF
+ ELSE
+*
+* Form y when lower triangle of A is stored.
+*
+ IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
+ DO 100 J = 1,N
+ TEMP1 = ALPHA*X(J)
+ TEMP2 = ZERO
+ Y(J) = Y(J) + TEMP1*A(1,J)
+ L = 1 - J
+ DO 90 I = J + 1,MIN(N,J+K)
+ Y(I) = Y(I) + TEMP1*A(L+I,J)
+ TEMP2 = TEMP2 + A(L+I,J)*X(I)
+ 90 CONTINUE
+ Y(J) = Y(J) + ALPHA*TEMP2
+ 100 CONTINUE
+ ELSE
+ JX = KX
+ JY = KY
+ DO 120 J = 1,N
+ TEMP1 = ALPHA*X(JX)
+ TEMP2 = ZERO
+ Y(JY) = Y(JY) + TEMP1*A(1,J)
+ L = 1 - J
+ IX = JX
+ IY = JY
+ DO 110 I = J + 1,MIN(N,J+K)
+ IX = IX + INCX
+ IY = IY + INCY
+ Y(IY) = Y(IY) + TEMP1*A(L+I,J)
+ TEMP2 = TEMP2 + A(L+I,J)*X(IX)
+ 110 CONTINUE
+ Y(JY) = Y(JY) + ALPHA*TEMP2
+ JX = JX + INCX
+ JY = JY + INCY
+ 120 CONTINUE
+ END IF
+ END IF
+*
+ RETURN
+*
+* End of SSBMV .
+*
+ END
+ SUBROUTINE SSCAL(N,SA,SX,INCX)
+* .. Scalar Arguments ..
+ REAL SA
+ INTEGER INCX,N
+* ..
+* .. Array Arguments ..
+ REAL SX(*)
+* ..
+*
+* Purpose
+* =======
+*
+* scales a vector by a constant.
+* uses unrolled loops for increment equal to 1.
+* jack dongarra, linpack, 3/11/78.
+* modified 3/93 to return if incx .le. 0.
+* modified 12/3/93, array(1) declarations changed to array(*)
+*
+*
+* .. Local Scalars ..
+ INTEGER I,M,MP1,NINCX
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MOD
+* ..
+ IF (N.LE.0 .OR. INCX.LE.0) RETURN
+ IF (INCX.EQ.1) GO TO 20
+*
+* code for increment not equal to 1
+*
+ NINCX = N*INCX
+ DO 10 I = 1,NINCX,INCX
+ SX(I) = SA*SX(I)
+ 10 CONTINUE
+ RETURN
+*
+* code for increment equal to 1
+*
+*
+* clean-up loop
+*
+ 20 M = MOD(N,5)
+ IF (M.EQ.0) GO TO 40
+ DO 30 I = 1,M
+ SX(I) = SA*SX(I)
+ 30 CONTINUE
+ IF (N.LT.5) RETURN
+ 40 MP1 = M + 1
+ DO 50 I = MP1,N,5
+ SX(I) = SA*SX(I)
+ SX(I+1) = SA*SX(I+1)
+ SX(I+2) = SA*SX(I+2)
+ SX(I+3) = SA*SX(I+3)
+ SX(I+4) = SA*SX(I+4)
+ 50 CONTINUE
+ RETURN
+ END
+ SUBROUTINE SSPMV(UPLO,N,ALPHA,AP,X,INCX,BETA,Y,INCY)
+* .. Scalar Arguments ..
+ REAL ALPHA,BETA
+ INTEGER INCX,INCY,N
+ CHARACTER UPLO
+* ..
+* .. Array Arguments ..
+ REAL AP(*),X(*),Y(*)
+* ..
+*
+* Purpose
+* =======
+*
+* SSPMV performs the matrix-vector operation
+*
+* y := alpha*A*x + beta*y,
+*
+* where alpha and beta are scalars, x and y are n element vectors and
+* A is an n by n symmetric matrix, supplied in packed form.
+*
+* Arguments
+* ==========
+*
+* UPLO - CHARACTER*1.
+* On entry, UPLO specifies whether the upper or lower
+* triangular part of the matrix A is supplied in the packed
+* array AP as follows:
+*
+* UPLO = 'U' or 'u' The upper triangular part of A is
+* supplied in AP.
+*
+* UPLO = 'L' or 'l' The lower triangular part of A is
+* supplied in AP.
+*
+* Unchanged on exit.
+*
+* N - INTEGER.
+* On entry, N specifies the order of the matrix A.
+* N must be at least zero.
+* Unchanged on exit.
+*
+* ALPHA - REAL .
+* On entry, ALPHA specifies the scalar alpha.
+* Unchanged on exit.
+*
+* AP - REAL array of DIMENSION at least
+* ( ( n*( n + 1 ) )/2 ).
+* Before entry with UPLO = 'U' or 'u', the array AP must
+* contain the upper triangular part of the symmetric matrix
+* packed sequentially, column by column, so that AP( 1 )
+* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 )
+* and a( 2, 2 ) respectively, and so on.
+* Before entry with UPLO = 'L' or 'l', the array AP must
+* contain the lower triangular part of the symmetric matrix
+* packed sequentially, column by column, so that AP( 1 )
+* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 )
+* and a( 3, 1 ) respectively, and so on.
+* Unchanged on exit.
+*
+* X - REAL array of dimension at least
+* ( 1 + ( n - 1 )*abs( INCX ) ).
+* Before entry, the incremented array X must contain the n
+* element vector x.
+* Unchanged on exit.
+*
+* INCX - INTEGER.
+* On entry, INCX specifies the increment for the elements of
+* X. INCX must not be zero.
+* Unchanged on exit.
+*
+* BETA - REAL .
+* On entry, BETA specifies the scalar beta. When BETA is
+* supplied as zero then Y need not be set on input.
+* Unchanged on exit.
+*
+* Y - REAL array of dimension at least
+* ( 1 + ( n - 1 )*abs( INCY ) ).
+* Before entry, the incremented array Y must contain the n
+* element vector y. On exit, Y is overwritten by the updated
+* vector y.
+*
+* INCY - INTEGER.
+* On entry, INCY specifies the increment for the elements of
+* Y. INCY must not be zero.
+* Unchanged on exit.
+*
+*
+* Level 2 Blas routine.
+*
+* -- Written on 22-October-1986.
+* Jack Dongarra, Argonne National Lab.
+* Jeremy Du Croz, Nag Central Office.
+* Sven Hammarling, Nag Central Office.
+* Richard Hanson, Sandia National Labs.
+*
+*
+* .. Parameters ..
+ REAL ONE,ZERO
+ PARAMETER (ONE=1.0E+0,ZERO=0.0E+0)
+* ..
+* .. Local Scalars ..
+ REAL TEMP1,TEMP2
+ INTEGER I,INFO,IX,IY,J,JX,JY,K,KK,KX,KY
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL XERBLA
+* ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN
+ INFO = 1
+ ELSE IF (N.LT.0) THEN
+ INFO = 2
+ ELSE IF (INCX.EQ.0) THEN
+ INFO = 6
+ ELSE IF (INCY.EQ.0) THEN
+ INFO = 9
+ END IF
+ IF (INFO.NE.0) THEN
+ CALL XERBLA('SSPMV ',INFO)
+ RETURN
+ END IF
+*
+* Quick return if possible.
+*
+ IF ((N.EQ.0) .OR. ((ALPHA.EQ.ZERO).AND. (BETA.EQ.ONE))) RETURN
+*
+* Set up the start points in X and Y.
+*
+ IF (INCX.GT.0) THEN
+ KX = 1
+ ELSE
+ KX = 1 - (N-1)*INCX
+ END IF
+ IF (INCY.GT.0) THEN
+ KY = 1
+ ELSE
+ KY = 1 - (N-1)*INCY
+ END IF
+*
+* Start the operations. In this version the elements of the array AP
+* are accessed sequentially with one pass through AP.
+*
+* First form y := beta*y.
+*
+ IF (BETA.NE.ONE) THEN
+ IF (INCY.EQ.1) THEN
+ IF (BETA.EQ.ZERO) THEN
+ DO 10 I = 1,N
+ Y(I) = ZERO
+ 10 CONTINUE
+ ELSE
+ DO 20 I = 1,N
+ Y(I) = BETA*Y(I)
+ 20 CONTINUE
+ END IF
+ ELSE
+ IY = KY
+ IF (BETA.EQ.ZERO) THEN
+ DO 30 I = 1,N
+ Y(IY) = ZERO
+ IY = IY + INCY
+ 30 CONTINUE
+ ELSE
+ DO 40 I = 1,N
+ Y(IY) = BETA*Y(IY)
+ IY = IY + INCY
+ 40 CONTINUE
+ END IF
+ END IF
+ END IF
+ IF (ALPHA.EQ.ZERO) RETURN
+ KK = 1
+ IF (LSAME(UPLO,'U')) THEN
+*
+* Form y when AP contains the upper triangle.
+*
+ IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
+ DO 60 J = 1,N
+ TEMP1 = ALPHA*X(J)
+ TEMP2 = ZERO
+ K = KK
+ DO 50 I = 1,J - 1
+ Y(I) = Y(I) + TEMP1*AP(K)
+ TEMP2 = TEMP2 + AP(K)*X(I)
+ K = K + 1
+ 50 CONTINUE
+ Y(J) = Y(J) + TEMP1*AP(KK+J-1) + ALPHA*TEMP2
+ KK = KK + J
+ 60 CONTINUE
+ ELSE
+ JX = KX
+ JY = KY
+ DO 80 J = 1,N
+ TEMP1 = ALPHA*X(JX)
+ TEMP2 = ZERO
+ IX = KX
+ IY = KY
+ DO 70 K = KK,KK + J - 2
+ Y(IY) = Y(IY) + TEMP1*AP(K)
+ TEMP2 = TEMP2 + AP(K)*X(IX)
+ IX = IX + INCX
+ IY = IY + INCY
+ 70 CONTINUE
+ Y(JY) = Y(JY) + TEMP1*AP(KK+J-1) + ALPHA*TEMP2
+ JX = JX + INCX
+ JY = JY + INCY
+ KK = KK + J
+ 80 CONTINUE
+ END IF
+ ELSE
+*
+* Form y when AP contains the lower triangle.
+*
+ IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
+ DO 100 J = 1,N
+ TEMP1 = ALPHA*X(J)
+ TEMP2 = ZERO
+ Y(J) = Y(J) + TEMP1*AP(KK)
+ K = KK + 1
+ DO 90 I = J + 1,N
+ Y(I) = Y(I) + TEMP1*AP(K)
+ TEMP2 = TEMP2 + AP(K)*X(I)
+ K = K + 1
+ 90 CONTINUE
+ Y(J) = Y(J) + ALPHA*TEMP2
+ KK = KK + (N-J+1)
+ 100 CONTINUE
+ ELSE
+ JX = KX
+ JY = KY
+ DO 120 J = 1,N
+ TEMP1 = ALPHA*X(JX)
+ TEMP2 = ZERO
+ Y(JY) = Y(JY) + TEMP1*AP(KK)
+ IX = JX
+ IY = JY
+ DO 110 K = KK + 1,KK + N - J
+ IX = IX + INCX
+ IY = IY + INCY
+ Y(IY) = Y(IY) + TEMP1*AP(K)
+ TEMP2 = TEMP2 + AP(K)*X(IX)
+ 110 CONTINUE
+ Y(JY) = Y(JY) + ALPHA*TEMP2
+ JX = JX + INCX
+ JY = JY + INCY
+ KK = KK + (N-J+1)
+ 120 CONTINUE
+ END IF
+ END IF
+*
+ RETURN
+*
+* End of SSPMV .
+*
+ END
+ SUBROUTINE SSPR(UPLO,N,ALPHA,X,INCX,AP)
+* .. Scalar Arguments ..
+ REAL ALPHA
+ INTEGER INCX,N
+ CHARACTER UPLO
+* ..
+* .. Array Arguments ..
+ REAL AP(*),X(*)
+* ..
+*
+* Purpose
+* =======
+*
+* SSPR performs the symmetric rank 1 operation
+*
+* A := alpha*x*x' + A,
+*
+* where alpha is a real scalar, x is an n element vector and A is an
+* n by n symmetric matrix, supplied in packed form.
+*
+* Arguments
+* ==========
+*
+* UPLO - CHARACTER*1.
+* On entry, UPLO specifies whether the upper or lower
+* triangular part of the matrix A is supplied in the packed
+* array AP as follows:
+*
+* UPLO = 'U' or 'u' The upper triangular part of A is
+* supplied in AP.
+*
+* UPLO = 'L' or 'l' The lower triangular part of A is
+* supplied in AP.
+*
+* Unchanged on exit.
+*
+* N - INTEGER.
+* On entry, N specifies the order of the matrix A.
+* N must be at least zero.
+* Unchanged on exit.
+*
+* ALPHA - REAL .
+* On entry, ALPHA specifies the scalar alpha.
+* Unchanged on exit.
+*
+* X - REAL array of dimension at least
+* ( 1 + ( n - 1 )*abs( INCX ) ).
+* Before entry, the incremented array X must contain the n
+* element vector x.
+* Unchanged on exit.
+*
+* INCX - INTEGER.
+* On entry, INCX specifies the increment for the elements of
+* X. INCX must not be zero.
+* Unchanged on exit.
+*
+* AP - REAL array of DIMENSION at least
+* ( ( n*( n + 1 ) )/2 ).
+* Before entry with UPLO = 'U' or 'u', the array AP must
+* contain the upper triangular part of the symmetric matrix
+* packed sequentially, column by column, so that AP( 1 )
+* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 )
+* and a( 2, 2 ) respectively, and so on. On exit, the array
+* AP is overwritten by the upper triangular part of the
+* updated matrix.
+* Before entry with UPLO = 'L' or 'l', the array AP must
+* contain the lower triangular part of the symmetric matrix
+* packed sequentially, column by column, so that AP( 1 )
+* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 )
+* and a( 3, 1 ) respectively, and so on. On exit, the array
+* AP is overwritten by the lower triangular part of the
+* updated matrix.
+*
+*
+* Level 2 Blas routine.
+*
+* -- Written on 22-October-1986.
+* Jack Dongarra, Argonne National Lab.
+* Jeremy Du Croz, Nag Central Office.
+* Sven Hammarling, Nag Central Office.
+* Richard Hanson, Sandia National Labs.
+*
+*
+* .. Parameters ..
+ REAL ZERO
+ PARAMETER (ZERO=0.0E+0)
+* ..
+* .. Local Scalars ..
+ REAL TEMP
+ INTEGER I,INFO,IX,J,JX,K,KK,KX
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL XERBLA
+* ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN
+ INFO = 1
+ ELSE IF (N.LT.0) THEN
+ INFO = 2
+ ELSE IF (INCX.EQ.0) THEN
+ INFO = 5
+ END IF
+ IF (INFO.NE.0) THEN
+ CALL XERBLA('SSPR ',INFO)
+ RETURN
+ END IF
+*
+* Quick return if possible.
+*
+ IF ((N.EQ.0) .OR. (ALPHA.EQ.ZERO)) RETURN
+*
+* Set the start point in X if the increment is not unity.
+*
+ IF (INCX.LE.0) THEN
+ KX = 1 - (N-1)*INCX
+ ELSE IF (INCX.NE.1) THEN
+ KX = 1
+ END IF
+*
+* Start the operations. In this version the elements of the array AP
+* are accessed sequentially with one pass through AP.
+*
+ KK = 1
+ IF (LSAME(UPLO,'U')) THEN
+*
+* Form A when upper triangle is stored in AP.
+*
+ IF (INCX.EQ.1) THEN
+ DO 20 J = 1,N
+ IF (X(J).NE.ZERO) THEN
+ TEMP = ALPHA*X(J)
+ K = KK
+ DO 10 I = 1,J
+ AP(K) = AP(K) + X(I)*TEMP
+ K = K + 1
+ 10 CONTINUE
+ END IF
+ KK = KK + J
+ 20 CONTINUE
+ ELSE
+ JX = KX
+ DO 40 J = 1,N
+ IF (X(JX).NE.ZERO) THEN
+ TEMP = ALPHA*X(JX)
+ IX = KX
+ DO 30 K = KK,KK + J - 1
+ AP(K) = AP(K) + X(IX)*TEMP
+ IX = IX + INCX
+ 30 CONTINUE
+ END IF
+ JX = JX + INCX
+ KK = KK + J
+ 40 CONTINUE
+ END IF
+ ELSE
+*
+* Form A when lower triangle is stored in AP.
+*
+ IF (INCX.EQ.1) THEN
+ DO 60 J = 1,N
+ IF (X(J).NE.ZERO) THEN
+ TEMP = ALPHA*X(J)
+ K = KK
+ DO 50 I = J,N
+ AP(K) = AP(K) + X(I)*TEMP
+ K = K + 1
+ 50 CONTINUE
+ END IF
+ KK = KK + N - J + 1
+ 60 CONTINUE
+ ELSE
+ JX = KX
+ DO 80 J = 1,N
+ IF (X(JX).NE.ZERO) THEN
+ TEMP = ALPHA*X(JX)
+ IX = JX
+ DO 70 K = KK,KK + N - J
+ AP(K) = AP(K) + X(IX)*TEMP
+ IX = IX + INCX
+ 70 CONTINUE
+ END IF
+ JX = JX + INCX
+ KK = KK + N - J + 1
+ 80 CONTINUE
+ END IF
+ END IF
+*
+ RETURN
+*
+* End of SSPR .
+*
+ END
+ SUBROUTINE SSPR2(UPLO,N,ALPHA,X,INCX,Y,INCY,AP)
+* .. Scalar Arguments ..
+ REAL ALPHA
+ INTEGER INCX,INCY,N
+ CHARACTER UPLO
+* ..
+* .. Array Arguments ..
+ REAL AP(*),X(*),Y(*)
+* ..
+*
+* Purpose
+* =======
+*
+* SSPR2 performs the symmetric rank 2 operation
+*
+* A := alpha*x*y' + alpha*y*x' + A,
+*
+* where alpha is a scalar, x and y are n element vectors and A is an
+* n by n symmetric matrix, supplied in packed form.
+*
+* Arguments
+* ==========
+*
+* UPLO - CHARACTER*1.
+* On entry, UPLO specifies whether the upper or lower
+* triangular part of the matrix A is supplied in the packed
+* array AP as follows:
+*
+* UPLO = 'U' or 'u' The upper triangular part of A is
+* supplied in AP.
+*
+* UPLO = 'L' or 'l' The lower triangular part of A is
+* supplied in AP.
+*
+* Unchanged on exit.
+*
+* N - INTEGER.
+* On entry, N specifies the order of the matrix A.
+* N must be at least zero.
+* Unchanged on exit.
+*
+* ALPHA - REAL .
+* On entry, ALPHA specifies the scalar alpha.
+* Unchanged on exit.
+*
+* X - REAL array of dimension at least
+* ( 1 + ( n - 1 )*abs( INCX ) ).
+* Before entry, the incremented array X must contain the n
+* element vector x.
+* Unchanged on exit.
+*
+* INCX - INTEGER.
+* On entry, INCX specifies the increment for the elements of
+* X. INCX must not be zero.
+* Unchanged on exit.
+*
+* Y - REAL array of dimension at least
+* ( 1 + ( n - 1 )*abs( INCY ) ).
+* Before entry, the incremented array Y must contain the n
+* element vector y.
+* Unchanged on exit.
+*
+* INCY - INTEGER.
+* On entry, INCY specifies the increment for the elements of
+* Y. INCY must not be zero.
+* Unchanged on exit.
+*
+* AP - REAL array of DIMENSION at least
+* ( ( n*( n + 1 ) )/2 ).
+* Before entry with UPLO = 'U' or 'u', the array AP must
+* contain the upper triangular part of the symmetric matrix
+* packed sequentially, column by column, so that AP( 1 )
+* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 1, 2 )
+* and a( 2, 2 ) respectively, and so on. On exit, the array
+* AP is overwritten by the upper triangular part of the
+* updated matrix.
+* Before entry with UPLO = 'L' or 'l', the array AP must
+* contain the lower triangular part of the symmetric matrix
+* packed sequentially, column by column, so that AP( 1 )
+* contains a( 1, 1 ), AP( 2 ) and AP( 3 ) contain a( 2, 1 )
+* and a( 3, 1 ) respectively, and so on. On exit, the array
+* AP is overwritten by the lower triangular part of the
+* updated matrix.
+*
+*
+* Level 2 Blas routine.
+*
+* -- Written on 22-October-1986.
+* Jack Dongarra, Argonne National Lab.
+* Jeremy Du Croz, Nag Central Office.
+* Sven Hammarling, Nag Central Office.
+* Richard Hanson, Sandia National Labs.
+*
+*
+* .. Parameters ..
+ REAL ZERO
+ PARAMETER (ZERO=0.0E+0)
+* ..
+* .. Local Scalars ..
+ REAL TEMP1,TEMP2
+ INTEGER I,INFO,IX,IY,J,JX,JY,K,KK,KX,KY
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL XERBLA
+* ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN
+ INFO = 1
+ ELSE IF (N.LT.0) THEN
+ INFO = 2
+ ELSE IF (INCX.EQ.0) THEN
+ INFO = 5
+ ELSE IF (INCY.EQ.0) THEN
+ INFO = 7
+ END IF
+ IF (INFO.NE.0) THEN
+ CALL XERBLA('SSPR2 ',INFO)
+ RETURN
+ END IF
+*
+* Quick return if possible.
+*
+ IF ((N.EQ.0) .OR. (ALPHA.EQ.ZERO)) RETURN
+*
+* Set up the start points in X and Y if the increments are not both
+* unity.
+*
+ IF ((INCX.NE.1) .OR. (INCY.NE.1)) THEN
+ IF (INCX.GT.0) THEN
+ KX = 1
+ ELSE
+ KX = 1 - (N-1)*INCX
+ END IF
+ IF (INCY.GT.0) THEN
+ KY = 1
+ ELSE
+ KY = 1 - (N-1)*INCY
+ END IF
+ JX = KX
+ JY = KY
+ END IF
+*
+* Start the operations. In this version the elements of the array AP
+* are accessed sequentially with one pass through AP.
+*
+ KK = 1
+ IF (LSAME(UPLO,'U')) THEN
+*
+* Form A when upper triangle is stored in AP.
+*
+ IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
+ DO 20 J = 1,N
+ IF ((X(J).NE.ZERO) .OR. (Y(J).NE.ZERO)) THEN
+ TEMP1 = ALPHA*Y(J)
+ TEMP2 = ALPHA*X(J)
+ K = KK
+ DO 10 I = 1,J
+ AP(K) = AP(K) + X(I)*TEMP1 + Y(I)*TEMP2
+ K = K + 1
+ 10 CONTINUE
+ END IF
+ KK = KK + J
+ 20 CONTINUE
+ ELSE
+ DO 40 J = 1,N
+ IF ((X(JX).NE.ZERO) .OR. (Y(JY).NE.ZERO)) THEN
+ TEMP1 = ALPHA*Y(JY)
+ TEMP2 = ALPHA*X(JX)
+ IX = KX
+ IY = KY
+ DO 30 K = KK,KK + J - 1
+ AP(K) = AP(K) + X(IX)*TEMP1 + Y(IY)*TEMP2
+ IX = IX + INCX
+ IY = IY + INCY
+ 30 CONTINUE
+ END IF
+ JX = JX + INCX
+ JY = JY + INCY
+ KK = KK + J
+ 40 CONTINUE
+ END IF
+ ELSE
+*
+* Form A when lower triangle is stored in AP.
+*
+ IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
+ DO 60 J = 1,N
+ IF ((X(J).NE.ZERO) .OR. (Y(J).NE.ZERO)) THEN
+ TEMP1 = ALPHA*Y(J)
+ TEMP2 = ALPHA*X(J)
+ K = KK
+ DO 50 I = J,N
+ AP(K) = AP(K) + X(I)*TEMP1 + Y(I)*TEMP2
+ K = K + 1
+ 50 CONTINUE
+ END IF
+ KK = KK + N - J + 1
+ 60 CONTINUE
+ ELSE
+ DO 80 J = 1,N
+ IF ((X(JX).NE.ZERO) .OR. (Y(JY).NE.ZERO)) THEN
+ TEMP1 = ALPHA*Y(JY)
+ TEMP2 = ALPHA*X(JX)
+ IX = JX
+ IY = JY
+ DO 70 K = KK,KK + N - J
+ AP(K) = AP(K) + X(IX)*TEMP1 + Y(IY)*TEMP2
+ IX = IX + INCX
+ IY = IY + INCY
+ 70 CONTINUE
+ END IF
+ JX = JX + INCX
+ JY = JY + INCY
+ KK = KK + N - J + 1
+ 80 CONTINUE
+ END IF
+ END IF
+*
+ RETURN
+*
+* End of SSPR2 .
+*
+ END
+ SUBROUTINE SSWAP(N,SX,INCX,SY,INCY)
+* .. Scalar Arguments ..
+ INTEGER INCX,INCY,N
+* ..
+* .. Array Arguments ..
+ REAL SX(*),SY(*)
+* ..
+*
+* Purpose
+* =======
+*
+* interchanges two vectors.
+* uses unrolled loops for increments equal to 1.
+* jack dongarra, linpack, 3/11/78.
+* modified 12/3/93, array(1) declarations changed to array(*)
+*
+*
+* .. Local Scalars ..
+ REAL STEMP
+ INTEGER I,IX,IY,M,MP1
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MOD
+* ..
+ IF (N.LE.0) RETURN
+ IF (INCX.EQ.1 .AND. INCY.EQ.1) GO TO 20
+*
+* code for unequal increments or equal increments not equal
+* to 1
+*
+ IX = 1
+ IY = 1
+ IF (INCX.LT.0) IX = (-N+1)*INCX + 1
+ IF (INCY.LT.0) IY = (-N+1)*INCY + 1
+ DO 10 I = 1,N
+ STEMP = SX(IX)
+ SX(IX) = SY(IY)
+ SY(IY) = STEMP
+ IX = IX + INCX
+ IY = IY + INCY
+ 10 CONTINUE
+ RETURN
+*
+* code for both increments equal to 1
+*
+*
+* clean-up loop
+*
+ 20 M = MOD(N,3)
+ IF (M.EQ.0) GO TO 40
+ DO 30 I = 1,M
+ STEMP = SX(I)
+ SX(I) = SY(I)
+ SY(I) = STEMP
+ 30 CONTINUE
+ IF (N.LT.3) RETURN
+ 40 MP1 = M + 1
+ DO 50 I = MP1,N,3
+ STEMP = SX(I)
+ SX(I) = SY(I)
+ SY(I) = STEMP
+ STEMP = SX(I+1)
+ SX(I+1) = SY(I+1)
+ SY(I+1) = STEMP
+ STEMP = SX(I+2)
+ SX(I+2) = SY(I+2)
+ SY(I+2) = STEMP
+ 50 CONTINUE
+ RETURN
+ END
+ SUBROUTINE SSYMM(SIDE,UPLO,M,N,ALPHA,A,LDA,B,LDB,BETA,C,LDC)
+* .. Scalar Arguments ..
+ REAL ALPHA,BETA
+ INTEGER LDA,LDB,LDC,M,N
+ CHARACTER SIDE,UPLO
+* ..
+* .. Array Arguments ..
+ REAL A(LDA,*),B(LDB,*),C(LDC,*)
+* ..
+*
+* Purpose
+* =======
+*
+* SSYMM performs one of the matrix-matrix operations
+*
+* C := alpha*A*B + beta*C,
+*
+* or
+*
+* C := alpha*B*A + beta*C,
+*
+* where alpha and beta are scalars, A is a symmetric matrix and B and
+* C are m by n matrices.
+*
+* Arguments
+* ==========
+*
+* SIDE - CHARACTER*1.
+* On entry, SIDE specifies whether the symmetric matrix A
+* appears on the left or right in the operation as follows:
+*
+* SIDE = 'L' or 'l' C := alpha*A*B + beta*C,
+*
+* SIDE = 'R' or 'r' C := alpha*B*A + beta*C,
+*
+* Unchanged on exit.
+*
+* UPLO - CHARACTER*1.
+* On entry, UPLO specifies whether the upper or lower
+* triangular part of the symmetric matrix A is to be
+* referenced as follows:
+*
+* UPLO = 'U' or 'u' Only the upper triangular part of the
+* symmetric matrix is to be referenced.
+*
+* UPLO = 'L' or 'l' Only the lower triangular part of the
+* symmetric matrix is to be referenced.
+*
+* Unchanged on exit.
+*
+* M - INTEGER.
+* On entry, M specifies the number of rows of the matrix C.
+* M must be at least zero.
+* Unchanged on exit.
+*
+* N - INTEGER.
+* On entry, N specifies the number of columns of the matrix C.
+* N must be at least zero.
+* Unchanged on exit.
+*
+* ALPHA - REAL .
+* On entry, ALPHA specifies the scalar alpha.
+* Unchanged on exit.
+*
+* A - REAL array of DIMENSION ( LDA, ka ), where ka is
+* m when SIDE = 'L' or 'l' and is n otherwise.
+* Before entry with SIDE = 'L' or 'l', the m by m part of
+* the array A must contain the symmetric matrix, such that
+* when UPLO = 'U' or 'u', the leading m by m upper triangular
+* part of the array A must contain the upper triangular part
+* of the symmetric matrix and the strictly lower triangular
+* part of A is not referenced, and when UPLO = 'L' or 'l',
+* the leading m by m lower triangular part of the array A
+* must contain the lower triangular part of the symmetric
+* matrix and the strictly upper triangular part of A is not
+* referenced.
+* Before entry with SIDE = 'R' or 'r', the n by n part of
+* the array A must contain the symmetric matrix, such that
+* when UPLO = 'U' or 'u', the leading n by n upper triangular
+* part of the array A must contain the upper triangular part
+* of the symmetric matrix and the strictly lower triangular
+* part of A is not referenced, and when UPLO = 'L' or 'l',
+* the leading n by n lower triangular part of the array A
+* must contain the lower triangular part of the symmetric
+* matrix and the strictly upper triangular part of A is not
+* referenced.
+* Unchanged on exit.
+*
+* LDA - INTEGER.
+* On entry, LDA specifies the first dimension of A as declared
+* in the calling (sub) program. When SIDE = 'L' or 'l' then
+* LDA must be at least max( 1, m ), otherwise LDA must be at
+* least max( 1, n ).
+* Unchanged on exit.
+*
+* B - REAL array of DIMENSION ( LDB, n ).
+* Before entry, the leading m by n part of the array B must
+* contain the matrix B.
+* Unchanged on exit.
+*
+* LDB - INTEGER.
+* On entry, LDB specifies the first dimension of B as declared
+* in the calling (sub) program. LDB must be at least
+* max( 1, m ).
+* Unchanged on exit.
+*
+* BETA - REAL .
+* On entry, BETA specifies the scalar beta. When BETA is
+* supplied as zero then C need not be set on input.
+* Unchanged on exit.
+*
+* C - REAL array of DIMENSION ( LDC, n ).
+* Before entry, the leading m by n part of the array C must
+* contain the matrix C, except when beta is zero, in which
+* case C need not be set on entry.
+* On exit, the array C is overwritten by the m by n updated
+* matrix.
+*
+* LDC - INTEGER.
+* On entry, LDC specifies the first dimension of C as declared
+* in the calling (sub) program. LDC must be at least
+* max( 1, m ).
+* Unchanged on exit.
+*
+*
+* Level 3 Blas routine.
+*
+* -- Written on 8-February-1989.
+* Jack Dongarra, Argonne National Laboratory.
+* Iain Duff, AERE Harwell.
+* Jeremy Du Croz, Numerical Algorithms Group Ltd.
+* Sven Hammarling, Numerical Algorithms Group Ltd.
+*
+*
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Local Scalars ..
+ REAL TEMP1,TEMP2
+ INTEGER I,INFO,J,K,NROWA
+ LOGICAL UPPER
+* ..
+* .. Parameters ..
+ REAL ONE,ZERO
+ PARAMETER (ONE=1.0E+0,ZERO=0.0E+0)
+* ..
+*
+* Set NROWA as the number of rows of A.
+*
+ IF (LSAME(SIDE,'L')) THEN
+ NROWA = M
+ ELSE
+ NROWA = N
+ END IF
+ UPPER = LSAME(UPLO,'U')
+*
+* Test the input parameters.
+*
+ INFO = 0
+ IF ((.NOT.LSAME(SIDE,'L')) .AND. (.NOT.LSAME(SIDE,'R'))) THEN
+ INFO = 1
+ ELSE IF ((.NOT.UPPER) .AND. (.NOT.LSAME(UPLO,'L'))) THEN
+ INFO = 2
+ ELSE IF (M.LT.0) THEN
+ INFO = 3
+ ELSE IF (N.LT.0) THEN
+ INFO = 4
+ ELSE IF (LDA.LT.MAX(1,NROWA)) THEN
+ INFO = 7
+ ELSE IF (LDB.LT.MAX(1,M)) THEN
+ INFO = 9
+ ELSE IF (LDC.LT.MAX(1,M)) THEN
+ INFO = 12
+ END IF
+ IF (INFO.NE.0) THEN
+ CALL XERBLA('SSYMM ',INFO)
+ RETURN
+ END IF
+*
+* Quick return if possible.
+*
+ IF ((M.EQ.0) .OR. (N.EQ.0) .OR.
+ + ((ALPHA.EQ.ZERO).AND. (BETA.EQ.ONE))) RETURN
+*
+* And when alpha.eq.zero.
+*
+ IF (ALPHA.EQ.ZERO) THEN
+ IF (BETA.EQ.ZERO) THEN
+ DO 20 J = 1,N
+ DO 10 I = 1,M
+ C(I,J) = ZERO
+ 10 CONTINUE
+ 20 CONTINUE
+ ELSE
+ DO 40 J = 1,N
+ DO 30 I = 1,M
+ C(I,J) = BETA*C(I,J)
+ 30 CONTINUE
+ 40 CONTINUE
+ END IF
+ RETURN
+ END IF
+*
+* Start the operations.
+*
+ IF (LSAME(SIDE,'L')) THEN
+*
+* Form C := alpha*A*B + beta*C.
+*
+ IF (UPPER) THEN
+ DO 70 J = 1,N
+ DO 60 I = 1,M
+ TEMP1 = ALPHA*B(I,J)
+ TEMP2 = ZERO
+ DO 50 K = 1,I - 1
+ C(K,J) = C(K,J) + TEMP1*A(K,I)
+ TEMP2 = TEMP2 + B(K,J)*A(K,I)
+ 50 CONTINUE
+ IF (BETA.EQ.ZERO) THEN
+ C(I,J) = TEMP1*A(I,I) + ALPHA*TEMP2
+ ELSE
+ C(I,J) = BETA*C(I,J) + TEMP1*A(I,I) +
+ + ALPHA*TEMP2
+ END IF
+ 60 CONTINUE
+ 70 CONTINUE
+ ELSE
+ DO 100 J = 1,N
+ DO 90 I = M,1,-1
+ TEMP1 = ALPHA*B(I,J)
+ TEMP2 = ZERO
+ DO 80 K = I + 1,M
+ C(K,J) = C(K,J) + TEMP1*A(K,I)
+ TEMP2 = TEMP2 + B(K,J)*A(K,I)
+ 80 CONTINUE
+ IF (BETA.EQ.ZERO) THEN
+ C(I,J) = TEMP1*A(I,I) + ALPHA*TEMP2
+ ELSE
+ C(I,J) = BETA*C(I,J) + TEMP1*A(I,I) +
+ + ALPHA*TEMP2
+ END IF
+ 90 CONTINUE
+ 100 CONTINUE
+ END IF
+ ELSE
+*
+* Form C := alpha*B*A + beta*C.
+*
+ DO 170 J = 1,N
+ TEMP1 = ALPHA*A(J,J)
+ IF (BETA.EQ.ZERO) THEN
+ DO 110 I = 1,M
+ C(I,J) = TEMP1*B(I,J)
+ 110 CONTINUE
+ ELSE
+ DO 120 I = 1,M
+ C(I,J) = BETA*C(I,J) + TEMP1*B(I,J)
+ 120 CONTINUE
+ END IF
+ DO 140 K = 1,J - 1
+ IF (UPPER) THEN
+ TEMP1 = ALPHA*A(K,J)
+ ELSE
+ TEMP1 = ALPHA*A(J,K)
+ END IF
+ DO 130 I = 1,M
+ C(I,J) = C(I,J) + TEMP1*B(I,K)
+ 130 CONTINUE
+ 140 CONTINUE
+ DO 160 K = J + 1,N
+ IF (UPPER) THEN
+ TEMP1 = ALPHA*A(J,K)
+ ELSE
+ TEMP1 = ALPHA*A(K,J)
+ END IF
+ DO 150 I = 1,M
+ C(I,J) = C(I,J) + TEMP1*B(I,K)
+ 150 CONTINUE
+ 160 CONTINUE
+ 170 CONTINUE
+ END IF
+*
+ RETURN
+*
+* End of SSYMM .
+*
+ END
+ SUBROUTINE SSYMV(UPLO,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY)
+* .. Scalar Arguments ..
+ REAL ALPHA,BETA
+ INTEGER INCX,INCY,LDA,N
+ CHARACTER UPLO
+* ..
+* .. Array Arguments ..
+ REAL A(LDA,*),X(*),Y(*)
+* ..
+*
+* Purpose
+* =======
+*
+* SSYMV performs the matrix-vector operation
+*
+* y := alpha*A*x + beta*y,
+*
+* where alpha and beta are scalars, x and y are n element vectors and
+* A is an n by n symmetric matrix.
+*
+* Arguments
+* ==========
+*
+* UPLO - CHARACTER*1.
+* On entry, UPLO specifies whether the upper or lower
+* triangular part of the array A is to be referenced as
+* follows:
+*
+* UPLO = 'U' or 'u' Only the upper triangular part of A
+* is to be referenced.
+*
+* UPLO = 'L' or 'l' Only the lower triangular part of A
+* is to be referenced.
+*
+* Unchanged on exit.
+*
+* N - INTEGER.
+* On entry, N specifies the order of the matrix A.
+* N must be at least zero.
+* Unchanged on exit.
+*
+* ALPHA - REAL .
+* On entry, ALPHA specifies the scalar alpha.
+* Unchanged on exit.
+*
+* A - REAL array of DIMENSION ( LDA, n ).
+* Before entry with UPLO = 'U' or 'u', the leading n by n
+* upper triangular part of the array A must contain the upper
+* triangular part of the symmetric matrix and the strictly
+* lower triangular part of A is not referenced.
+* Before entry with UPLO = 'L' or 'l', the leading n by n
+* lower triangular part of the array A must contain the lower
+* triangular part of the symmetric matrix and the strictly
+* upper triangular part of A is not referenced.
+* Unchanged on exit.
+*
+* LDA - INTEGER.
+* On entry, LDA specifies the first dimension of A as declared
+* in the calling (sub) program. LDA must be at least
+* max( 1, n ).
+* Unchanged on exit.
+*
+* X - REAL array of dimension at least
+* ( 1 + ( n - 1 )*abs( INCX ) ).
+* Before entry, the incremented array X must contain the n
+* element vector x.
+* Unchanged on exit.
+*
+* INCX - INTEGER.
+* On entry, INCX specifies the increment for the elements of
+* X. INCX must not be zero.
+* Unchanged on exit.
+*
+* BETA - REAL .
+* On entry, BETA specifies the scalar beta. When BETA is
+* supplied as zero then Y need not be set on input.
+* Unchanged on exit.
+*
+* Y - REAL array of dimension at least
+* ( 1 + ( n - 1 )*abs( INCY ) ).
+* Before entry, the incremented array Y must contain the n
+* element vector y. On exit, Y is overwritten by the updated
+* vector y.
+*
+* INCY - INTEGER.
+* On entry, INCY specifies the increment for the elements of
+* Y. INCY must not be zero.
+* Unchanged on exit.
+*
+*
+* Level 2 Blas routine.
+*
+* -- Written on 22-October-1986.
+* Jack Dongarra, Argonne National Lab.
+* Jeremy Du Croz, Nag Central Office.
+* Sven Hammarling, Nag Central Office.
+* Richard Hanson, Sandia National Labs.
+*
+*
+* .. Parameters ..
+ REAL ONE,ZERO
+ PARAMETER (ONE=1.0E+0,ZERO=0.0E+0)
+* ..
+* .. Local Scalars ..
+ REAL TEMP1,TEMP2
+ INTEGER I,INFO,IX,IY,J,JX,JY,KX,KY
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN
+ INFO = 1
+ ELSE IF (N.LT.0) THEN
+ INFO = 2
+ ELSE IF (LDA.LT.MAX(1,N)) THEN
+ INFO = 5
+ ELSE IF (INCX.EQ.0) THEN
+ INFO = 7
+ ELSE IF (INCY.EQ.0) THEN
+ INFO = 10
+ END IF
+ IF (INFO.NE.0) THEN
+ CALL XERBLA('SSYMV ',INFO)
+ RETURN
+ END IF
+*
+* Quick return if possible.
+*
+ IF ((N.EQ.0) .OR. ((ALPHA.EQ.ZERO).AND. (BETA.EQ.ONE))) RETURN
+*
+* Set up the start points in X and Y.
+*
+ IF (INCX.GT.0) THEN
+ KX = 1
+ ELSE
+ KX = 1 - (N-1)*INCX
+ END IF
+ IF (INCY.GT.0) THEN
+ KY = 1
+ ELSE
+ KY = 1 - (N-1)*INCY
+ END IF
+*
+* Start the operations. In this version the elements of A are
+* accessed sequentially with one pass through the triangular part
+* of A.
+*
+* First form y := beta*y.
+*
+ IF (BETA.NE.ONE) THEN
+ IF (INCY.EQ.1) THEN
+ IF (BETA.EQ.ZERO) THEN
+ DO 10 I = 1,N
+ Y(I) = ZERO
+ 10 CONTINUE
+ ELSE
+ DO 20 I = 1,N
+ Y(I) = BETA*Y(I)
+ 20 CONTINUE
+ END IF
+ ELSE
+ IY = KY
+ IF (BETA.EQ.ZERO) THEN
+ DO 30 I = 1,N
+ Y(IY) = ZERO
+ IY = IY + INCY
+ 30 CONTINUE
+ ELSE
+ DO 40 I = 1,N
+ Y(IY) = BETA*Y(IY)
+ IY = IY + INCY
+ 40 CONTINUE
+ END IF
+ END IF
+ END IF
+ IF (ALPHA.EQ.ZERO) RETURN
+ IF (LSAME(UPLO,'U')) THEN
+*
+* Form y when A is stored in upper triangle.
+*
+ IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
+ DO 60 J = 1,N
+ TEMP1 = ALPHA*X(J)
+ TEMP2 = ZERO
+ DO 50 I = 1,J - 1
+ Y(I) = Y(I) + TEMP1*A(I,J)
+ TEMP2 = TEMP2 + A(I,J)*X(I)
+ 50 CONTINUE
+ Y(J) = Y(J) + TEMP1*A(J,J) + ALPHA*TEMP2
+ 60 CONTINUE
+ ELSE
+ JX = KX
+ JY = KY
+ DO 80 J = 1,N
+ TEMP1 = ALPHA*X(JX)
+ TEMP2 = ZERO
+ IX = KX
+ IY = KY
+ DO 70 I = 1,J - 1
+ Y(IY) = Y(IY) + TEMP1*A(I,J)
+ TEMP2 = TEMP2 + A(I,J)*X(IX)
+ IX = IX + INCX
+ IY = IY + INCY
+ 70 CONTINUE
+ Y(JY) = Y(JY) + TEMP1*A(J,J) + ALPHA*TEMP2
+ JX = JX + INCX
+ JY = JY + INCY
+ 80 CONTINUE
+ END IF
+ ELSE
+*
+* Form y when A is stored in lower triangle.
+*
+ IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
+ DO 100 J = 1,N
+ TEMP1 = ALPHA*X(J)
+ TEMP2 = ZERO
+ Y(J) = Y(J) + TEMP1*A(J,J)
+ DO 90 I = J + 1,N
+ Y(I) = Y(I) + TEMP1*A(I,J)
+ TEMP2 = TEMP2 + A(I,J)*X(I)
+ 90 CONTINUE
+ Y(J) = Y(J) + ALPHA*TEMP2
+ 100 CONTINUE
+ ELSE
+ JX = KX
+ JY = KY
+ DO 120 J = 1,N
+ TEMP1 = ALPHA*X(JX)
+ TEMP2 = ZERO
+ Y(JY) = Y(JY) + TEMP1*A(J,J)
+ IX = JX
+ IY = JY
+ DO 110 I = J + 1,N
+ IX = IX + INCX
+ IY = IY + INCY
+ Y(IY) = Y(IY) + TEMP1*A(I,J)
+ TEMP2 = TEMP2 + A(I,J)*X(IX)
+ 110 CONTINUE
+ Y(JY) = Y(JY) + ALPHA*TEMP2
+ JX = JX + INCX
+ JY = JY + INCY
+ 120 CONTINUE
+ END IF
+ END IF
+*
+ RETURN
+*
+* End of SSYMV .
+*
+ END
+ SUBROUTINE SSYR(UPLO,N,ALPHA,X,INCX,A,LDA)
+* .. Scalar Arguments ..
+ REAL ALPHA
+ INTEGER INCX,LDA,N
+ CHARACTER UPLO
+* ..
+* .. Array Arguments ..
+ REAL A(LDA,*),X(*)
+* ..
+*
+* Purpose
+* =======
+*
+* SSYR performs the symmetric rank 1 operation
+*
+* A := alpha*x*x' + A,
+*
+* where alpha is a real scalar, x is an n element vector and A is an
+* n by n symmetric matrix.
+*
+* Arguments
+* ==========
+*
+* UPLO - CHARACTER*1.
+* On entry, UPLO specifies whether the upper or lower
+* triangular part of the array A is to be referenced as
+* follows:
+*
+* UPLO = 'U' or 'u' Only the upper triangular part of A
+* is to be referenced.
+*
+* UPLO = 'L' or 'l' Only the lower triangular part of A
+* is to be referenced.
+*
+* Unchanged on exit.
+*
+* N - INTEGER.
+* On entry, N specifies the order of the matrix A.
+* N must be at least zero.
+* Unchanged on exit.
+*
+* ALPHA - REAL .
+* On entry, ALPHA specifies the scalar alpha.
+* Unchanged on exit.
+*
+* X - REAL array of dimension at least
+* ( 1 + ( n - 1 )*abs( INCX ) ).
+* Before entry, the incremented array X must contain the n
+* element vector x.
+* Unchanged on exit.
+*
+* INCX - INTEGER.
+* On entry, INCX specifies the increment for the elements of
+* X. INCX must not be zero.
+* Unchanged on exit.
+*
+* A - REAL array of DIMENSION ( LDA, n ).
+* Before entry with UPLO = 'U' or 'u', the leading n by n
+* upper triangular part of the array A must contain the upper
+* triangular part of the symmetric matrix and the strictly
+* lower triangular part of A is not referenced. On exit, the
+* upper triangular part of the array A is overwritten by the
+* upper triangular part of the updated matrix.
+* Before entry with UPLO = 'L' or 'l', the leading n by n
+* lower triangular part of the array A must contain the lower
+* triangular part of the symmetric matrix and the strictly
+* upper triangular part of A is not referenced. On exit, the
+* lower triangular part of the array A is overwritten by the
+* lower triangular part of the updated matrix.
+*
+* LDA - INTEGER.
+* On entry, LDA specifies the first dimension of A as declared
+* in the calling (sub) program. LDA must be at least
+* max( 1, n ).
+* Unchanged on exit.
+*
+*
+* Level 2 Blas routine.
+*
+* -- Written on 22-October-1986.
+* Jack Dongarra, Argonne National Lab.
+* Jeremy Du Croz, Nag Central Office.
+* Sven Hammarling, Nag Central Office.
+* Richard Hanson, Sandia National Labs.
+*
+*
+* .. Parameters ..
+ REAL ZERO
+ PARAMETER (ZERO=0.0E+0)
+* ..
+* .. Local Scalars ..
+ REAL TEMP
+ INTEGER I,INFO,IX,J,JX,KX
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN
+ INFO = 1
+ ELSE IF (N.LT.0) THEN
+ INFO = 2
+ ELSE IF (INCX.EQ.0) THEN
+ INFO = 5
+ ELSE IF (LDA.LT.MAX(1,N)) THEN
+ INFO = 7
+ END IF
+ IF (INFO.NE.0) THEN
+ CALL XERBLA('SSYR ',INFO)
+ RETURN
+ END IF
+*
+* Quick return if possible.
+*
+ IF ((N.EQ.0) .OR. (ALPHA.EQ.ZERO)) RETURN
+*
+* Set the start point in X if the increment is not unity.
+*
+ IF (INCX.LE.0) THEN
+ KX = 1 - (N-1)*INCX
+ ELSE IF (INCX.NE.1) THEN
+ KX = 1
+ END IF
+*
+* Start the operations. In this version the elements of A are
+* accessed sequentially with one pass through the triangular part
+* of A.
+*
+ IF (LSAME(UPLO,'U')) THEN
+*
+* Form A when A is stored in upper triangle.
+*
+ IF (INCX.EQ.1) THEN
+ DO 20 J = 1,N
+ IF (X(J).NE.ZERO) THEN
+ TEMP = ALPHA*X(J)
+ DO 10 I = 1,J
+ A(I,J) = A(I,J) + X(I)*TEMP
+ 10 CONTINUE
+ END IF
+ 20 CONTINUE
+ ELSE
+ JX = KX
+ DO 40 J = 1,N
+ IF (X(JX).NE.ZERO) THEN
+ TEMP = ALPHA*X(JX)
+ IX = KX
+ DO 30 I = 1,J
+ A(I,J) = A(I,J) + X(IX)*TEMP
+ IX = IX + INCX
+ 30 CONTINUE
+ END IF
+ JX = JX + INCX
+ 40 CONTINUE
+ END IF
+ ELSE
+*
+* Form A when A is stored in lower triangle.
+*
+ IF (INCX.EQ.1) THEN
+ DO 60 J = 1,N
+ IF (X(J).NE.ZERO) THEN
+ TEMP = ALPHA*X(J)
+ DO 50 I = J,N
+ A(I,J) = A(I,J) + X(I)*TEMP
+ 50 CONTINUE
+ END IF
+ 60 CONTINUE
+ ELSE
+ JX = KX
+ DO 80 J = 1,N
+ IF (X(JX).NE.ZERO) THEN
+ TEMP = ALPHA*X(JX)
+ IX = JX
+ DO 70 I = J,N
+ A(I,J) = A(I,J) + X(IX)*TEMP
+ IX = IX + INCX
+ 70 CONTINUE
+ END IF
+ JX = JX + INCX
+ 80 CONTINUE
+ END IF
+ END IF
+*
+ RETURN
+*
+* End of SSYR .
+*
+ END
+ SUBROUTINE SSYR2(UPLO,N,ALPHA,X,INCX,Y,INCY,A,LDA)
+* .. Scalar Arguments ..
+ REAL ALPHA
+ INTEGER INCX,INCY,LDA,N
+ CHARACTER UPLO
+* ..
+* .. Array Arguments ..
+ REAL A(LDA,*),X(*),Y(*)
+* ..
+*
+* Purpose
+* =======
+*
+* SSYR2 performs the symmetric rank 2 operation
+*
+* A := alpha*x*y' + alpha*y*x' + A,
+*
+* where alpha is a scalar, x and y are n element vectors and A is an n
+* by n symmetric matrix.
+*
+* Arguments
+* ==========
+*
+* UPLO - CHARACTER*1.
+* On entry, UPLO specifies whether the upper or lower
+* triangular part of the array A is to be referenced as
+* follows:
+*
+* UPLO = 'U' or 'u' Only the upper triangular part of A
+* is to be referenced.
+*
+* UPLO = 'L' or 'l' Only the lower triangular part of A
+* is to be referenced.
+*
+* Unchanged on exit.
+*
+* N - INTEGER.
+* On entry, N specifies the order of the matrix A.
+* N must be at least zero.
+* Unchanged on exit.
+*
+* ALPHA - REAL .
+* On entry, ALPHA specifies the scalar alpha.
+* Unchanged on exit.
+*
+* X - REAL array of dimension at least
+* ( 1 + ( n - 1 )*abs( INCX ) ).
+* Before entry, the incremented array X must contain the n
+* element vector x.
+* Unchanged on exit.
+*
+* INCX - INTEGER.
+* On entry, INCX specifies the increment for the elements of
+* X. INCX must not be zero.
+* Unchanged on exit.
+*
+* Y - REAL array of dimension at least
+* ( 1 + ( n - 1 )*abs( INCY ) ).
+* Before entry, the incremented array Y must contain the n
+* element vector y.
+* Unchanged on exit.
+*
+* INCY - INTEGER.
+* On entry, INCY specifies the increment for the elements of
+* Y. INCY must not be zero.
+* Unchanged on exit.
+*
+* A - REAL array of DIMENSION ( LDA, n ).
+* Before entry with UPLO = 'U' or 'u', the leading n by n
+* upper triangular part of the array A must contain the upper
+* triangular part of the symmetric matrix and the strictly
+* lower triangular part of A is not referenced. On exit, the
+* upper triangular part of the array A is overwritten by the
+* upper triangular part of the updated matrix.
+* Before entry with UPLO = 'L' or 'l', the leading n by n
+* lower triangular part of the array A must contain the lower
+* triangular part of the symmetric matrix and the strictly
+* upper triangular part of A is not referenced. On exit, the
+* lower triangular part of the array A is overwritten by the
+* lower triangular part of the updated matrix.
+*
+* LDA - INTEGER.
+* On entry, LDA specifies the first dimension of A as declared
+* in the calling (sub) program. LDA must be at least
+* max( 1, n ).
+* Unchanged on exit.
+*
+*
+* Level 2 Blas routine.
+*
+* -- Written on 22-October-1986.
+* Jack Dongarra, Argonne National Lab.
+* Jeremy Du Croz, Nag Central Office.
+* Sven Hammarling, Nag Central Office.
+* Richard Hanson, Sandia National Labs.
+*
+*
+* .. Parameters ..
+ REAL ZERO
+ PARAMETER (ZERO=0.0E+0)
+* ..
+* .. Local Scalars ..
+ REAL TEMP1,TEMP2
+ INTEGER I,INFO,IX,IY,J,JX,JY,KX,KY
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN
+ INFO = 1
+ ELSE IF (N.LT.0) THEN
+ INFO = 2
+ ELSE IF (INCX.EQ.0) THEN
+ INFO = 5
+ ELSE IF (INCY.EQ.0) THEN
+ INFO = 7
+ ELSE IF (LDA.LT.MAX(1,N)) THEN
+ INFO = 9
+ END IF
+ IF (INFO.NE.0) THEN
+ CALL XERBLA('SSYR2 ',INFO)
+ RETURN
+ END IF
+*
+* Quick return if possible.
+*
+ IF ((N.EQ.0) .OR. (ALPHA.EQ.ZERO)) RETURN
+*
+* Set up the start points in X and Y if the increments are not both
+* unity.
+*
+ IF ((INCX.NE.1) .OR. (INCY.NE.1)) THEN
+ IF (INCX.GT.0) THEN
+ KX = 1
+ ELSE
+ KX = 1 - (N-1)*INCX
+ END IF
+ IF (INCY.GT.0) THEN
+ KY = 1
+ ELSE
+ KY = 1 - (N-1)*INCY
+ END IF
+ JX = KX
+ JY = KY
+ END IF
+*
+* Start the operations. In this version the elements of A are
+* accessed sequentially with one pass through the triangular part
+* of A.
+*
+ IF (LSAME(UPLO,'U')) THEN
+*
+* Form A when A is stored in the upper triangle.
+*
+ IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
+ DO 20 J = 1,N
+ IF ((X(J).NE.ZERO) .OR. (Y(J).NE.ZERO)) THEN
+ TEMP1 = ALPHA*Y(J)
+ TEMP2 = ALPHA*X(J)
+ DO 10 I = 1,J
+ A(I,J) = A(I,J) + X(I)*TEMP1 + Y(I)*TEMP2
+ 10 CONTINUE
+ END IF
+ 20 CONTINUE
+ ELSE
+ DO 40 J = 1,N
+ IF ((X(JX).NE.ZERO) .OR. (Y(JY).NE.ZERO)) THEN
+ TEMP1 = ALPHA*Y(JY)
+ TEMP2 = ALPHA*X(JX)
+ IX = KX
+ IY = KY
+ DO 30 I = 1,J
+ A(I,J) = A(I,J) + X(IX)*TEMP1 + Y(IY)*TEMP2
+ IX = IX + INCX
+ IY = IY + INCY
+ 30 CONTINUE
+ END IF
+ JX = JX + INCX
+ JY = JY + INCY
+ 40 CONTINUE
+ END IF
+ ELSE
+*
+* Form A when A is stored in the lower triangle.
+*
+ IF ((INCX.EQ.1) .AND. (INCY.EQ.1)) THEN
+ DO 60 J = 1,N
+ IF ((X(J).NE.ZERO) .OR. (Y(J).NE.ZERO)) THEN
+ TEMP1 = ALPHA*Y(J)
+ TEMP2 = ALPHA*X(J)
+ DO 50 I = J,N
+ A(I,J) = A(I,J) + X(I)*TEMP1 + Y(I)*TEMP2
+ 50 CONTINUE
+ END IF
+ 60 CONTINUE
+ ELSE
+ DO 80 J = 1,N
+ IF ((X(JX).NE.ZERO) .OR. (Y(JY).NE.ZERO)) THEN
+ TEMP1 = ALPHA*Y(JY)
+ TEMP2 = ALPHA*X(JX)
+ IX = JX
+ IY = JY
+ DO 70 I = J,N
+ A(I,J) = A(I,J) + X(IX)*TEMP1 + Y(IY)*TEMP2
+ IX = IX + INCX
+ IY = IY + INCY
+ 70 CONTINUE
+ END IF
+ JX = JX + INCX
+ JY = JY + INCY
+ 80 CONTINUE
+ END IF
+ END IF
+*
+ RETURN
+*
+* End of SSYR2 .
+*
+ END
+ SUBROUTINE SSYR2K(UPLO,TRANS,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC)
+* .. Scalar Arguments ..
+ REAL ALPHA,BETA
+ INTEGER K,LDA,LDB,LDC,N
+ CHARACTER TRANS,UPLO
+* ..
+* .. Array Arguments ..
+ REAL A(LDA,*),B(LDB,*),C(LDC,*)
+* ..
+*
+* Purpose
+* =======
+*
+* SSYR2K performs one of the symmetric rank 2k operations
+*
+* C := alpha*A*B' + alpha*B*A' + beta*C,
+*
+* or
+*
+* C := alpha*A'*B + alpha*B'*A + beta*C,
+*
+* where alpha and beta are scalars, C is an n by n symmetric matrix
+* and A and B are n by k matrices in the first case and k by n
+* matrices in the second case.
+*
+* Arguments
+* ==========
+*
+* UPLO - CHARACTER*1.
+* On entry, UPLO specifies whether the upper or lower
+* triangular part of the array C is to be referenced as
+* follows:
+*
+* UPLO = 'U' or 'u' Only the upper triangular part of C
+* is to be referenced.
+*
+* UPLO = 'L' or 'l' Only the lower triangular part of C
+* is to be referenced.
+*
+* Unchanged on exit.
+*
+* TRANS - CHARACTER*1.
+* On entry, TRANS specifies the operation to be performed as
+* follows:
+*
+* TRANS = 'N' or 'n' C := alpha*A*B' + alpha*B*A' +
+* beta*C.
+*
+* TRANS = 'T' or 't' C := alpha*A'*B + alpha*B'*A +
+* beta*C.
+*
+* TRANS = 'C' or 'c' C := alpha*A'*B + alpha*B'*A +
+* beta*C.
+*
+* Unchanged on exit.
+*
+* N - INTEGER.
+* On entry, N specifies the order of the matrix C. N must be
+* at least zero.
+* Unchanged on exit.
+*
+* K - INTEGER.
+* On entry with TRANS = 'N' or 'n', K specifies the number
+* of columns of the matrices A and B, and on entry with
+* TRANS = 'T' or 't' or 'C' or 'c', K specifies the number
+* of rows of the matrices A and B. K must be at least zero.
+* Unchanged on exit.
+*
+* ALPHA - REAL .
+* On entry, ALPHA specifies the scalar alpha.
+* Unchanged on exit.
+*
+* A - REAL array of DIMENSION ( LDA, ka ), where ka is
+* k when TRANS = 'N' or 'n', and is n otherwise.
+* Before entry with TRANS = 'N' or 'n', the leading n by k
+* part of the array A must contain the matrix A, otherwise
+* the leading k by n part of the array A must contain the
+* matrix A.
+* Unchanged on exit.
+*
+* LDA - INTEGER.
+* On entry, LDA specifies the first dimension of A as declared
+* in the calling (sub) program. When TRANS = 'N' or 'n'
+* then LDA must be at least max( 1, n ), otherwise LDA must
+* be at least max( 1, k ).
+* Unchanged on exit.
+*
+* B - REAL array of DIMENSION ( LDB, kb ), where kb is
+* k when TRANS = 'N' or 'n', and is n otherwise.
+* Before entry with TRANS = 'N' or 'n', the leading n by k
+* part of the array B must contain the matrix B, otherwise
+* the leading k by n part of the array B must contain the
+* matrix B.
+* Unchanged on exit.
+*
+* LDB - INTEGER.
+* On entry, LDB specifies the first dimension of B as declared
+* in the calling (sub) program. When TRANS = 'N' or 'n'
+* then LDB must be at least max( 1, n ), otherwise LDB must
+* be at least max( 1, k ).
+* Unchanged on exit.
+*
+* BETA - REAL .
+* On entry, BETA specifies the scalar beta.
+* Unchanged on exit.
+*
+* C - REAL array of DIMENSION ( LDC, n ).
+* Before entry with UPLO = 'U' or 'u', the leading n by n
+* upper triangular part of the array C must contain the upper
+* triangular part of the symmetric matrix and the strictly
+* lower triangular part of C is not referenced. On exit, the
+* upper triangular part of the array C is overwritten by the
+* upper triangular part of the updated matrix.
+* Before entry with UPLO = 'L' or 'l', the leading n by n
+* lower triangular part of the array C must contain the lower
+* triangular part of the symmetric matrix and the strictly
+* upper triangular part of C is not referenced. On exit, the
+* lower triangular part of the array C is overwritten by the
+* lower triangular part of the updated matrix.
+*
+* LDC - INTEGER.
+* On entry, LDC specifies the first dimension of C as declared
+* in the calling (sub) program. LDC must be at least
+* max( 1, n ).
+* Unchanged on exit.
+*
+*
+* Level 3 Blas routine.
+*
+*
+* -- Written on 8-February-1989.
+* Jack Dongarra, Argonne National Laboratory.
+* Iain Duff, AERE Harwell.
+* Jeremy Du Croz, Numerical Algorithms Group Ltd.
+* Sven Hammarling, Numerical Algorithms Group Ltd.
+*
+*
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Local Scalars ..
+ REAL TEMP1,TEMP2
+ INTEGER I,INFO,J,L,NROWA
+ LOGICAL UPPER
+* ..
+* .. Parameters ..
+ REAL ONE,ZERO
+ PARAMETER (ONE=1.0E+0,ZERO=0.0E+0)
+* ..
+*
+* Test the input parameters.
+*
+ IF (LSAME(TRANS,'N')) THEN
+ NROWA = N
+ ELSE
+ NROWA = K
+ END IF
+ UPPER = LSAME(UPLO,'U')
+*
+ INFO = 0
+ IF ((.NOT.UPPER) .AND. (.NOT.LSAME(UPLO,'L'))) THEN
+ INFO = 1
+ ELSE IF ((.NOT.LSAME(TRANS,'N')) .AND.
+ + (.NOT.LSAME(TRANS,'T')) .AND.
+ + (.NOT.LSAME(TRANS,'C'))) THEN
+ INFO = 2
+ ELSE IF (N.LT.0) THEN
+ INFO = 3
+ ELSE IF (K.LT.0) THEN
+ INFO = 4
+ ELSE IF (LDA.LT.MAX(1,NROWA)) THEN
+ INFO = 7
+ ELSE IF (LDB.LT.MAX(1,NROWA)) THEN
+ INFO = 9
+ ELSE IF (LDC.LT.MAX(1,N)) THEN
+ INFO = 12
+ END IF
+ IF (INFO.NE.0) THEN
+ CALL XERBLA('SSYR2K',INFO)
+ RETURN
+ END IF
+*
+* Quick return if possible.
+*
+ IF ((N.EQ.0) .OR. (((ALPHA.EQ.ZERO).OR.
+ + (K.EQ.0)).AND. (BETA.EQ.ONE))) RETURN
+*
+* And when alpha.eq.zero.
+*
+ IF (ALPHA.EQ.ZERO) THEN
+ IF (UPPER) THEN
+ IF (BETA.EQ.ZERO) THEN
+ DO 20 J = 1,N
+ DO 10 I = 1,J
+ C(I,J) = ZERO
+ 10 CONTINUE
+ 20 CONTINUE
+ ELSE
+ DO 40 J = 1,N
+ DO 30 I = 1,J
+ C(I,J) = BETA*C(I,J)
+ 30 CONTINUE
+ 40 CONTINUE
+ END IF
+ ELSE
+ IF (BETA.EQ.ZERO) THEN
+ DO 60 J = 1,N
+ DO 50 I = J,N
+ C(I,J) = ZERO
+ 50 CONTINUE
+ 60 CONTINUE
+ ELSE
+ DO 80 J = 1,N
+ DO 70 I = J,N
+ C(I,J) = BETA*C(I,J)
+ 70 CONTINUE
+ 80 CONTINUE
+ END IF
+ END IF
+ RETURN
+ END IF
+*
+* Start the operations.
+*
+ IF (LSAME(TRANS,'N')) THEN
+*
+* Form C := alpha*A*B' + alpha*B*A' + C.
+*
+ IF (UPPER) THEN
+ DO 130 J = 1,N
+ IF (BETA.EQ.ZERO) THEN
+ DO 90 I = 1,J
+ C(I,J) = ZERO
+ 90 CONTINUE
+ ELSE IF (BETA.NE.ONE) THEN
+ DO 100 I = 1,J
+ C(I,J) = BETA*C(I,J)
+ 100 CONTINUE
+ END IF
+ DO 120 L = 1,K
+ IF ((A(J,L).NE.ZERO) .OR. (B(J,L).NE.ZERO)) THEN
+ TEMP1 = ALPHA*B(J,L)
+ TEMP2 = ALPHA*A(J,L)
+ DO 110 I = 1,J
+ C(I,J) = C(I,J) + A(I,L)*TEMP1 +
+ + B(I,L)*TEMP2
+ 110 CONTINUE
+ END IF
+ 120 CONTINUE
+ 130 CONTINUE
+ ELSE
+ DO 180 J = 1,N
+ IF (BETA.EQ.ZERO) THEN
+ DO 140 I = J,N
+ C(I,J) = ZERO
+ 140 CONTINUE
+ ELSE IF (BETA.NE.ONE) THEN
+ DO 150 I = J,N
+ C(I,J) = BETA*C(I,J)
+ 150 CONTINUE
+ END IF
+ DO 170 L = 1,K
+ IF ((A(J,L).NE.ZERO) .OR. (B(J,L).NE.ZERO)) THEN
+ TEMP1 = ALPHA*B(J,L)
+ TEMP2 = ALPHA*A(J,L)
+ DO 160 I = J,N
+ C(I,J) = C(I,J) + A(I,L)*TEMP1 +
+ + B(I,L)*TEMP2
+ 160 CONTINUE
+ END IF
+ 170 CONTINUE
+ 180 CONTINUE
+ END IF
+ ELSE
+*
+* Form C := alpha*A'*B + alpha*B'*A + C.
+*
+ IF (UPPER) THEN
+ DO 210 J = 1,N
+ DO 200 I = 1,J
+ TEMP1 = ZERO
+ TEMP2 = ZERO
+ DO 190 L = 1,K
+ TEMP1 = TEMP1 + A(L,I)*B(L,J)
+ TEMP2 = TEMP2 + B(L,I)*A(L,J)
+ 190 CONTINUE
+ IF (BETA.EQ.ZERO) THEN
+ C(I,J) = ALPHA*TEMP1 + ALPHA*TEMP2
+ ELSE
+ C(I,J) = BETA*C(I,J) + ALPHA*TEMP1 +
+ + ALPHA*TEMP2
+ END IF
+ 200 CONTINUE
+ 210 CONTINUE
+ ELSE
+ DO 240 J = 1,N
+ DO 230 I = J,N
+ TEMP1 = ZERO
+ TEMP2 = ZERO
+ DO 220 L = 1,K
+ TEMP1 = TEMP1 + A(L,I)*B(L,J)
+ TEMP2 = TEMP2 + B(L,I)*A(L,J)
+ 220 CONTINUE
+ IF (BETA.EQ.ZERO) THEN
+ C(I,J) = ALPHA*TEMP1 + ALPHA*TEMP2
+ ELSE
+ C(I,J) = BETA*C(I,J) + ALPHA*TEMP1 +
+ + ALPHA*TEMP2
+ END IF
+ 230 CONTINUE
+ 240 CONTINUE
+ END IF
+ END IF
+*
+ RETURN
+*
+* End of SSYR2K.
+*
+ END
+ SUBROUTINE SSYRK(UPLO,TRANS,N,K,ALPHA,A,LDA,BETA,C,LDC)
+* .. Scalar Arguments ..
+ REAL ALPHA,BETA
+ INTEGER K,LDA,LDC,N
+ CHARACTER TRANS,UPLO
+* ..
+* .. Array Arguments ..
+ REAL A(LDA,*),C(LDC,*)
+* ..
+*
+* Purpose
+* =======
+*
+* SSYRK performs one of the symmetric rank k operations
+*
+* C := alpha*A*A' + beta*C,
+*
+* or
+*
+* C := alpha*A'*A + beta*C,
+*
+* where alpha and beta are scalars, C is an n by n symmetric matrix
+* and A is an n by k matrix in the first case and a k by n matrix
+* in the second case.
+*
+* Arguments
+* ==========
+*
+* UPLO - CHARACTER*1.
+* On entry, UPLO specifies whether the upper or lower
+* triangular part of the array C is to be referenced as
+* follows:
+*
+* UPLO = 'U' or 'u' Only the upper triangular part of C
+* is to be referenced.
+*
+* UPLO = 'L' or 'l' Only the lower triangular part of C
+* is to be referenced.
+*
+* Unchanged on exit.
+*
+* TRANS - CHARACTER*1.
+* On entry, TRANS specifies the operation to be performed as
+* follows:
+*
+* TRANS = 'N' or 'n' C := alpha*A*A' + beta*C.
+*
+* TRANS = 'T' or 't' C := alpha*A'*A + beta*C.
+*
+* TRANS = 'C' or 'c' C := alpha*A'*A + beta*C.
+*
+* Unchanged on exit.
+*
+* N - INTEGER.
+* On entry, N specifies the order of the matrix C. N must be
+* at least zero.
+* Unchanged on exit.
+*
+* K - INTEGER.
+* On entry with TRANS = 'N' or 'n', K specifies the number
+* of columns of the matrix A, and on entry with
+* TRANS = 'T' or 't' or 'C' or 'c', K specifies the number
+* of rows of the matrix A. K must be at least zero.
+* Unchanged on exit.
+*
+* ALPHA - REAL .
+* On entry, ALPHA specifies the scalar alpha.
+* Unchanged on exit.
+*
+* A - REAL array of DIMENSION ( LDA, ka ), where ka is
+* k when TRANS = 'N' or 'n', and is n otherwise.
+* Before entry with TRANS = 'N' or 'n', the leading n by k
+* part of the array A must contain the matrix A, otherwise
+* the leading k by n part of the array A must contain the
+* matrix A.
+* Unchanged on exit.
+*
+* LDA - INTEGER.
+* On entry, LDA specifies the first dimension of A as declared
+* in the calling (sub) program. When TRANS = 'N' or 'n'
+* then LDA must be at least max( 1, n ), otherwise LDA must
+* be at least max( 1, k ).
+* Unchanged on exit.
+*
+* BETA - REAL .
+* On entry, BETA specifies the scalar beta.
+* Unchanged on exit.
+*
+* C - REAL array of DIMENSION ( LDC, n ).
+* Before entry with UPLO = 'U' or 'u', the leading n by n
+* upper triangular part of the array C must contain the upper
+* triangular part of the symmetric matrix and the strictly
+* lower triangular part of C is not referenced. On exit, the
+* upper triangular part of the array C is overwritten by the
+* upper triangular part of the updated matrix.
+* Before entry with UPLO = 'L' or 'l', the leading n by n
+* lower triangular part of the array C must contain the lower
+* triangular part of the symmetric matrix and the strictly
+* upper triangular part of C is not referenced. On exit, the
+* lower triangular part of the array C is overwritten by the
+* lower triangular part of the updated matrix.
+*
+* LDC - INTEGER.
+* On entry, LDC specifies the first dimension of C as declared
+* in the calling (sub) program. LDC must be at least
+* max( 1, n ).
+* Unchanged on exit.
+*
+*
+* Level 3 Blas routine.
+*
+* -- Written on 8-February-1989.
+* Jack Dongarra, Argonne National Laboratory.
+* Iain Duff, AERE Harwell.
+* Jeremy Du Croz, Numerical Algorithms Group Ltd.
+* Sven Hammarling, Numerical Algorithms Group Ltd.
+*
+*
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Local Scalars ..
+ REAL TEMP
+ INTEGER I,INFO,J,L,NROWA
+ LOGICAL UPPER
+* ..
+* .. Parameters ..
+ REAL ONE,ZERO
+ PARAMETER (ONE=1.0E+0,ZERO=0.0E+0)
+* ..
+*
+* Test the input parameters.
+*
+ IF (LSAME(TRANS,'N')) THEN
+ NROWA = N
+ ELSE
+ NROWA = K
+ END IF
+ UPPER = LSAME(UPLO,'U')
+*
+ INFO = 0
+ IF ((.NOT.UPPER) .AND. (.NOT.LSAME(UPLO,'L'))) THEN
+ INFO = 1
+ ELSE IF ((.NOT.LSAME(TRANS,'N')) .AND.
+ + (.NOT.LSAME(TRANS,'T')) .AND.
+ + (.NOT.LSAME(TRANS,'C'))) THEN
+ INFO = 2
+ ELSE IF (N.LT.0) THEN
+ INFO = 3
+ ELSE IF (K.LT.0) THEN
+ INFO = 4
+ ELSE IF (LDA.LT.MAX(1,NROWA)) THEN
+ INFO = 7
+ ELSE IF (LDC.LT.MAX(1,N)) THEN
+ INFO = 10
+ END IF
+ IF (INFO.NE.0) THEN
+ CALL XERBLA('SSYRK ',INFO)
+ RETURN
+ END IF
+*
+* Quick return if possible.
+*
+ IF ((N.EQ.0) .OR. (((ALPHA.EQ.ZERO).OR.
+ + (K.EQ.0)).AND. (BETA.EQ.ONE))) RETURN
+*
+* And when alpha.eq.zero.
+*
+ IF (ALPHA.EQ.ZERO) THEN
+ IF (UPPER) THEN
+ IF (BETA.EQ.ZERO) THEN
+ DO 20 J = 1,N
+ DO 10 I = 1,J
+ C(I,J) = ZERO
+ 10 CONTINUE
+ 20 CONTINUE
+ ELSE
+ DO 40 J = 1,N
+ DO 30 I = 1,J
+ C(I,J) = BETA*C(I,J)
+ 30 CONTINUE
+ 40 CONTINUE
+ END IF
+ ELSE
+ IF (BETA.EQ.ZERO) THEN
+ DO 60 J = 1,N
+ DO 50 I = J,N
+ C(I,J) = ZERO
+ 50 CONTINUE
+ 60 CONTINUE
+ ELSE
+ DO 80 J = 1,N
+ DO 70 I = J,N
+ C(I,J) = BETA*C(I,J)
+ 70 CONTINUE
+ 80 CONTINUE
+ END IF
+ END IF
+ RETURN
+ END IF
+*
+* Start the operations.
+*
+ IF (LSAME(TRANS,'N')) THEN
+*
+* Form C := alpha*A*A' + beta*C.
+*
+ IF (UPPER) THEN
+ DO 130 J = 1,N
+ IF (BETA.EQ.ZERO) THEN
+ DO 90 I = 1,J
+ C(I,J) = ZERO
+ 90 CONTINUE
+ ELSE IF (BETA.NE.ONE) THEN
+ DO 100 I = 1,J
+ C(I,J) = BETA*C(I,J)
+ 100 CONTINUE
+ END IF
+ DO 120 L = 1,K
+ IF (A(J,L).NE.ZERO) THEN
+ TEMP = ALPHA*A(J,L)
+ DO 110 I = 1,J
+ C(I,J) = C(I,J) + TEMP*A(I,L)
+ 110 CONTINUE
+ END IF
+ 120 CONTINUE
+ 130 CONTINUE
+ ELSE
+ DO 180 J = 1,N
+ IF (BETA.EQ.ZERO) THEN
+ DO 140 I = J,N
+ C(I,J) = ZERO
+ 140 CONTINUE
+ ELSE IF (BETA.NE.ONE) THEN
+ DO 150 I = J,N
+ C(I,J) = BETA*C(I,J)
+ 150 CONTINUE
+ END IF
+ DO 170 L = 1,K
+ IF (A(J,L).NE.ZERO) THEN
+ TEMP = ALPHA*A(J,L)
+ DO 160 I = J,N
+ C(I,J) = C(I,J) + TEMP*A(I,L)
+ 160 CONTINUE
+ END IF
+ 170 CONTINUE
+ 180 CONTINUE
+ END IF
+ ELSE
+*
+* Form C := alpha*A'*A + beta*C.
+*
+ IF (UPPER) THEN
+ DO 210 J = 1,N
+ DO 200 I = 1,J
+ TEMP = ZERO
+ DO 190 L = 1,K
+ TEMP = TEMP + A(L,I)*A(L,J)
+ 190 CONTINUE
+ IF (BETA.EQ.ZERO) THEN
+ C(I,J) = ALPHA*TEMP
+ ELSE
+ C(I,J) = ALPHA*TEMP + BETA*C(I,J)
+ END IF
+ 200 CONTINUE
+ 210 CONTINUE
+ ELSE
+ DO 240 J = 1,N
+ DO 230 I = J,N
+ TEMP = ZERO
+ DO 220 L = 1,K
+ TEMP = TEMP + A(L,I)*A(L,J)
+ 220 CONTINUE
+ IF (BETA.EQ.ZERO) THEN
+ C(I,J) = ALPHA*TEMP
+ ELSE
+ C(I,J) = ALPHA*TEMP + BETA*C(I,J)
+ END IF
+ 230 CONTINUE
+ 240 CONTINUE
+ END IF
+ END IF
+*
+ RETURN
+*
+* End of SSYRK .
+*
+ END
+ SUBROUTINE STBMV(UPLO,TRANS,DIAG,N,K,A,LDA,X,INCX)
+* .. Scalar Arguments ..
+ INTEGER INCX,K,LDA,N
+ CHARACTER DIAG,TRANS,UPLO
+* ..
+* .. Array Arguments ..
+ REAL A(LDA,*),X(*)
+* ..
+*
+* Purpose
+* =======
+*
+* STBMV performs one of the matrix-vector operations
+*
+* x := A*x, or x := A'*x,
+*
+* where x is an n element vector and A is an n by n unit, or non-unit,
+* upper or lower triangular band matrix, with ( k + 1 ) diagonals.
+*
+* Arguments
+* ==========
+*
+* UPLO - CHARACTER*1.
+* On entry, UPLO specifies whether the matrix is an upper or
+* lower triangular matrix as follows:
+*
+* UPLO = 'U' or 'u' A is an upper triangular matrix.
+*
+* UPLO = 'L' or 'l' A is a lower triangular matrix.
+*
+* Unchanged on exit.
+*
+* TRANS - CHARACTER*1.
+* On entry, TRANS specifies the operation to be performed as
+* follows:
+*
+* TRANS = 'N' or 'n' x := A*x.
+*
+* TRANS = 'T' or 't' x := A'*x.
+*
+* TRANS = 'C' or 'c' x := A'*x.
+*
+* Unchanged on exit.
+*
+* DIAG - CHARACTER*1.
+* On entry, DIAG specifies whether or not A is unit
+* triangular as follows:
+*
+* DIAG = 'U' or 'u' A is assumed to be unit triangular.
+*
+* DIAG = 'N' or 'n' A is not assumed to be unit
+* triangular.
+*
+* Unchanged on exit.
+*
+* N - INTEGER.
+* On entry, N specifies the order of the matrix A.
+* N must be at least zero.
+* Unchanged on exit.
+*
+* K - INTEGER.
+* On entry with UPLO = 'U' or 'u', K specifies the number of
+* super-diagonals of the matrix A.
+* On entry with UPLO = 'L' or 'l', K specifies the number of
+* sub-diagonals of the matrix A.
+* K must satisfy 0 .le. K.
+* Unchanged on exit.
+*
+* A - REAL array of DIMENSION ( LDA, n ).
+* Before entry with UPLO = 'U' or 'u', the leading ( k + 1 )
+* by n part of the array A must contain the upper triangular
+* band part of the matrix of coefficients, supplied column by
+* column, with the leading diagonal of the matrix in row
+* ( k + 1 ) of the array, the first super-diagonal starting at
+* position 2 in row k, and so on. The top left k by k triangle
+* of the array A is not referenced.
+* The following program segment will transfer an upper
+* triangular band matrix from conventional full matrix storage
+* to band storage:
+*
+* DO 20, J = 1, N
+* M = K + 1 - J
+* DO 10, I = MAX( 1, J - K ), J
+* A( M + I, J ) = matrix( I, J )
+* 10 CONTINUE
+* 20 CONTINUE
+*
+* Before entry with UPLO = 'L' or 'l', the leading ( k + 1 )
+* by n part of the array A must contain the lower triangular
+* band part of the matrix of coefficients, supplied column by
+* column, with the leading diagonal of the matrix in row 1 of
+* the array, the first sub-diagonal starting at position 1 in
+* row 2, and so on. The bottom right k by k triangle of the
+* array A is not referenced.
+* The following program segment will transfer a lower
+* triangular band matrix from conventional full matrix storage
+* to band storage:
+*
+* DO 20, J = 1, N
+* M = 1 - J
+* DO 10, I = J, MIN( N, J + K )
+* A( M + I, J ) = matrix( I, J )
+* 10 CONTINUE
+* 20 CONTINUE
+*
+* Note that when DIAG = 'U' or 'u' the elements of the array A
+* corresponding to the diagonal elements of the matrix are not
+* referenced, but are assumed to be unity.
+* Unchanged on exit.
+*
+* LDA - INTEGER.
+* On entry, LDA specifies the first dimension of A as declared
+* in the calling (sub) program. LDA must be at least
+* ( k + 1 ).
+* Unchanged on exit.
+*
+* X - REAL array of dimension at least
+* ( 1 + ( n - 1 )*abs( INCX ) ).
+* Before entry, the incremented array X must contain the n
+* element vector x. On exit, X is overwritten with the
+* tranformed vector x.
+*
+* INCX - INTEGER.
+* On entry, INCX specifies the increment for the elements of
+* X. INCX must not be zero.
+* Unchanged on exit.
+*
+*
+* Level 2 Blas routine.
+*
+* -- Written on 22-October-1986.
+* Jack Dongarra, Argonne National Lab.
+* Jeremy Du Croz, Nag Central Office.
+* Sven Hammarling, Nag Central Office.
+* Richard Hanson, Sandia National Labs.
+*
+*
+* .. Parameters ..
+ REAL ZERO
+ PARAMETER (ZERO=0.0E+0)
+* ..
+* .. Local Scalars ..
+ REAL TEMP
+ INTEGER I,INFO,IX,J,JX,KPLUS1,KX,L
+ LOGICAL NOUNIT
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX,MIN
+* ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN
+ INFO = 1
+ ELSE IF (.NOT.LSAME(TRANS,'N') .AND. .NOT.LSAME(TRANS,'T') .AND.
+ + .NOT.LSAME(TRANS,'C')) THEN
+ INFO = 2
+ ELSE IF (.NOT.LSAME(DIAG,'U') .AND. .NOT.LSAME(DIAG,'N')) THEN
+ INFO = 3
+ ELSE IF (N.LT.0) THEN
+ INFO = 4
+ ELSE IF (K.LT.0) THEN
+ INFO = 5
+ ELSE IF (LDA.LT. (K+1)) THEN
+ INFO = 7
+ ELSE IF (INCX.EQ.0) THEN
+ INFO = 9
+ END IF
+ IF (INFO.NE.0) THEN
+ CALL XERBLA('STBMV ',INFO)
+ RETURN
+ END IF
+*
+* Quick return if possible.
+*
+ IF (N.EQ.0) RETURN
+*
+ NOUNIT = LSAME(DIAG,'N')
+*
+* Set up the start point in X if the increment is not unity. This
+* will be ( N - 1 )*INCX too small for descending loops.
+*
+ IF (INCX.LE.0) THEN
+ KX = 1 - (N-1)*INCX
+ ELSE IF (INCX.NE.1) THEN
+ KX = 1
+ END IF
+*
+* Start the operations. In this version the elements of A are
+* accessed sequentially with one pass through A.
+*
+ IF (LSAME(TRANS,'N')) THEN
+*
+* Form x := A*x.
+*
+ IF (LSAME(UPLO,'U')) THEN
+ KPLUS1 = K + 1
+ IF (INCX.EQ.1) THEN
+ DO 20 J = 1,N
+ IF (X(J).NE.ZERO) THEN
+ TEMP = X(J)
+ L = KPLUS1 - J
+ DO 10 I = MAX(1,J-K),J - 1
+ X(I) = X(I) + TEMP*A(L+I,J)
+ 10 CONTINUE
+ IF (NOUNIT) X(J) = X(J)*A(KPLUS1,J)
+ END IF
+ 20 CONTINUE
+ ELSE
+ JX = KX
+ DO 40 J = 1,N
+ IF (X(JX).NE.ZERO) THEN
+ TEMP = X(JX)
+ IX = KX
+ L = KPLUS1 - J
+ DO 30 I = MAX(1,J-K),J - 1
+ X(IX) = X(IX) + TEMP*A(L+I,J)
+ IX = IX + INCX
+ 30 CONTINUE
+ IF (NOUNIT) X(JX) = X(JX)*A(KPLUS1,J)
+ END IF
+ JX = JX + INCX
+ IF (J.GT.K) KX = KX + INCX
+ 40 CONTINUE
+ END IF
+ ELSE
+ IF (INCX.EQ.1) THEN
+ DO 60 J = N,1,-1
+ IF (X(J).NE.ZERO) THEN
+ TEMP = X(J)
+ L = 1 - J
+ DO 50 I = MIN(N,J+K),J + 1,-1
+ X(I) = X(I) + TEMP*A(L+I,J)
+ 50 CONTINUE
+ IF (NOUNIT) X(J) = X(J)*A(1,J)
+ END IF
+ 60 CONTINUE
+ ELSE
+ KX = KX + (N-1)*INCX
+ JX = KX
+ DO 80 J = N,1,-1
+ IF (X(JX).NE.ZERO) THEN
+ TEMP = X(JX)
+ IX = KX
+ L = 1 - J
+ DO 70 I = MIN(N,J+K),J + 1,-1
+ X(IX) = X(IX) + TEMP*A(L+I,J)
+ IX = IX - INCX
+ 70 CONTINUE
+ IF (NOUNIT) X(JX) = X(JX)*A(1,J)
+ END IF
+ JX = JX - INCX
+ IF ((N-J).GE.K) KX = KX - INCX
+ 80 CONTINUE
+ END IF
+ END IF
+ ELSE
+*
+* Form x := A'*x.
+*
+ IF (LSAME(UPLO,'U')) THEN
+ KPLUS1 = K + 1
+ IF (INCX.EQ.1) THEN
+ DO 100 J = N,1,-1
+ TEMP = X(J)
+ L = KPLUS1 - J
+ IF (NOUNIT) TEMP = TEMP*A(KPLUS1,J)
+ DO 90 I = J - 1,MAX(1,J-K),-1
+ TEMP = TEMP + A(L+I,J)*X(I)
+ 90 CONTINUE
+ X(J) = TEMP
+ 100 CONTINUE
+ ELSE
+ KX = KX + (N-1)*INCX
+ JX = KX
+ DO 120 J = N,1,-1
+ TEMP = X(JX)
+ KX = KX - INCX
+ IX = KX
+ L = KPLUS1 - J
+ IF (NOUNIT) TEMP = TEMP*A(KPLUS1,J)
+ DO 110 I = J - 1,MAX(1,J-K),-1
+ TEMP = TEMP + A(L+I,J)*X(IX)
+ IX = IX - INCX
+ 110 CONTINUE
+ X(JX) = TEMP
+ JX = JX - INCX
+ 120 CONTINUE
+ END IF
+ ELSE
+ IF (INCX.EQ.1) THEN
+ DO 140 J = 1,N
+ TEMP = X(J)
+ L = 1 - J
+ IF (NOUNIT) TEMP = TEMP*A(1,J)
+ DO 130 I = J + 1,MIN(N,J+K)
+ TEMP = TEMP + A(L+I,J)*X(I)
+ 130 CONTINUE
+ X(J) = TEMP
+ 140 CONTINUE
+ ELSE
+ JX = KX
+ DO 160 J = 1,N
+ TEMP = X(JX)
+ KX = KX + INCX
+ IX = KX
+ L = 1 - J
+ IF (NOUNIT) TEMP = TEMP*A(1,J)
+ DO 150 I = J + 1,MIN(N,J+K)
+ TEMP = TEMP + A(L+I,J)*X(IX)
+ IX = IX + INCX
+ 150 CONTINUE
+ X(JX) = TEMP
+ JX = JX + INCX
+ 160 CONTINUE
+ END IF
+ END IF
+ END IF
+*
+ RETURN
+*
+* End of STBMV .
+*
+ END
+ SUBROUTINE STBSV(UPLO,TRANS,DIAG,N,K,A,LDA,X,INCX)
+* .. Scalar Arguments ..
+ INTEGER INCX,K,LDA,N
+ CHARACTER DIAG,TRANS,UPLO
+* ..
+* .. Array Arguments ..
+ REAL A(LDA,*),X(*)
+* ..
+*
+* Purpose
+* =======
+*
+* STBSV solves one of the systems of equations
+*
+* A*x = b, or A'*x = b,
+*
+* where b and x are n element vectors and A is an n by n unit, or
+* non-unit, upper or lower triangular band matrix, with ( k + 1 )
+* diagonals.
+*
+* No test for singularity or near-singularity is included in this
+* routine. Such tests must be performed before calling this routine.
+*
+* Arguments
+* ==========
+*
+* UPLO - CHARACTER*1.
+* On entry, UPLO specifies whether the matrix is an upper or
+* lower triangular matrix as follows:
+*
+* UPLO = 'U' or 'u' A is an upper triangular matrix.
+*
+* UPLO = 'L' or 'l' A is a lower triangular matrix.
+*
+* Unchanged on exit.
+*
+* TRANS - CHARACTER*1.
+* On entry, TRANS specifies the equations to be solved as
+* follows:
+*
+* TRANS = 'N' or 'n' A*x = b.
+*
+* TRANS = 'T' or 't' A'*x = b.
+*
+* TRANS = 'C' or 'c' A'*x = b.
+*
+* Unchanged on exit.
+*
+* DIAG - CHARACTER*1.
+* On entry, DIAG specifies whether or not A is unit
+* triangular as follows:
+*
+* DIAG = 'U' or 'u' A is assumed to be unit triangular.
+*
+* DIAG = 'N' or 'n' A is not assumed to be unit
+* triangular.
+*
+* Unchanged on exit.
+*
+* N - INTEGER.
+* On entry, N specifies the order of the matrix A.
+* N must be at least zero.
+* Unchanged on exit.
+*
+* K - INTEGER.
+* On entry with UPLO = 'U' or 'u', K specifies the number of
+* super-diagonals of the matrix A.
+* On entry with UPLO = 'L' or 'l', K specifies the number of
+* sub-diagonals of the matrix A.
+* K must satisfy 0 .le. K.
+* Unchanged on exit.
+*
+* A - REAL array of DIMENSION ( LDA, n ).
+* Before entry with UPLO = 'U' or 'u', the leading ( k + 1 )
+* by n part of the array A must contain the upper triangular
+* band part of the matrix of coefficients, supplied column by
+* column, with the leading diagonal of the matrix in row
+* ( k + 1 ) of the array, the first super-diagonal starting at
+* position 2 in row k, and so on. The top left k by k triangle
+* of the array A is not referenced.
+* The following program segment will transfer an upper
+* triangular band matrix from conventional full matrix storage
+* to band storage:
+*
+* DO 20, J = 1, N
+* M = K + 1 - J
+* DO 10, I = MAX( 1, J - K ), J
+* A( M + I, J ) = matrix( I, J )
+* 10 CONTINUE
+* 20 CONTINUE
+*
+* Before entry with UPLO = 'L' or 'l', the leading ( k + 1 )
+* by n part of the array A must contain the lower triangular
+* band part of the matrix of coefficients, supplied column by
+* column, with the leading diagonal of the matrix in row 1 of
+* the array, the first sub-diagonal starting at position 1 in
+* row 2, and so on. The bottom right k by k triangle of the
+* array A is not referenced.
+* The following program segment will transfer a lower
+* triangular band matrix from conventional full matrix storage
+* to band storage:
+*
+* DO 20, J = 1, N
+* M = 1 - J
+* DO 10, I = J, MIN( N, J + K )
+* A( M + I, J ) = matrix( I, J )
+* 10 CONTINUE
+* 20 CONTINUE
+*
+* Note that when DIAG = 'U' or 'u' the elements of the array A
+* corresponding to the diagonal elements of the matrix are not
+* referenced, but are assumed to be unity.
+* Unchanged on exit.
+*
+* LDA - INTEGER.
+* On entry, LDA specifies the first dimension of A as declared
+* in the calling (sub) program. LDA must be at least
+* ( k + 1 ).
+* Unchanged on exit.
+*
+* X - REAL array of dimension at least
+* ( 1 + ( n - 1 )*abs( INCX ) ).
+* Before entry, the incremented array X must contain the n
+* element right-hand side vector b. On exit, X is overwritten
+* with the solution vector x.
+*
+* INCX - INTEGER.
+* On entry, INCX specifies the increment for the elements of
+* X. INCX must not be zero.
+* Unchanged on exit.
+*
+*
+* Level 2 Blas routine.
+*
+* -- Written on 22-October-1986.
+* Jack Dongarra, Argonne National Lab.
+* Jeremy Du Croz, Nag Central Office.
+* Sven Hammarling, Nag Central Office.
+* Richard Hanson, Sandia National Labs.
+*
+*
+* .. Parameters ..
+ REAL ZERO
+ PARAMETER (ZERO=0.0E+0)
+* ..
+* .. Local Scalars ..
+ REAL TEMP
+ INTEGER I,INFO,IX,J,JX,KPLUS1,KX,L
+ LOGICAL NOUNIT
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX,MIN
+* ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN
+ INFO = 1
+ ELSE IF (.NOT.LSAME(TRANS,'N') .AND. .NOT.LSAME(TRANS,'T') .AND.
+ + .NOT.LSAME(TRANS,'C')) THEN
+ INFO = 2
+ ELSE IF (.NOT.LSAME(DIAG,'U') .AND. .NOT.LSAME(DIAG,'N')) THEN
+ INFO = 3
+ ELSE IF (N.LT.0) THEN
+ INFO = 4
+ ELSE IF (K.LT.0) THEN
+ INFO = 5
+ ELSE IF (LDA.LT. (K+1)) THEN
+ INFO = 7
+ ELSE IF (INCX.EQ.0) THEN
+ INFO = 9
+ END IF
+ IF (INFO.NE.0) THEN
+ CALL XERBLA('STBSV ',INFO)
+ RETURN
+ END IF
+*
+* Quick return if possible.
+*
+ IF (N.EQ.0) RETURN
+*
+ NOUNIT = LSAME(DIAG,'N')
+*
+* Set up the start point in X if the increment is not unity. This
+* will be ( N - 1 )*INCX too small for descending loops.
+*
+ IF (INCX.LE.0) THEN
+ KX = 1 - (N-1)*INCX
+ ELSE IF (INCX.NE.1) THEN
+ KX = 1
+ END IF
+*
+* Start the operations. In this version the elements of A are
+* accessed by sequentially with one pass through A.
+*
+ IF (LSAME(TRANS,'N')) THEN
+*
+* Form x := inv( A )*x.
+*
+ IF (LSAME(UPLO,'U')) THEN
+ KPLUS1 = K + 1
+ IF (INCX.EQ.1) THEN
+ DO 20 J = N,1,-1
+ IF (X(J).NE.ZERO) THEN
+ L = KPLUS1 - J
+ IF (NOUNIT) X(J) = X(J)/A(KPLUS1,J)
+ TEMP = X(J)
+ DO 10 I = J - 1,MAX(1,J-K),-1
+ X(I) = X(I) - TEMP*A(L+I,J)
+ 10 CONTINUE
+ END IF
+ 20 CONTINUE
+ ELSE
+ KX = KX + (N-1)*INCX
+ JX = KX
+ DO 40 J = N,1,-1
+ KX = KX - INCX
+ IF (X(JX).NE.ZERO) THEN
+ IX = KX
+ L = KPLUS1 - J
+ IF (NOUNIT) X(JX) = X(JX)/A(KPLUS1,J)
+ TEMP = X(JX)
+ DO 30 I = J - 1,MAX(1,J-K),-1
+ X(IX) = X(IX) - TEMP*A(L+I,J)
+ IX = IX - INCX
+ 30 CONTINUE
+ END IF
+ JX = JX - INCX
+ 40 CONTINUE
+ END IF
+ ELSE
+ IF (INCX.EQ.1) THEN
+ DO 60 J = 1,N
+ IF (X(J).NE.ZERO) THEN
+ L = 1 - J
+ IF (NOUNIT) X(J) = X(J)/A(1,J)
+ TEMP = X(J)
+ DO 50 I = J + 1,MIN(N,J+K)
+ X(I) = X(I) - TEMP*A(L+I,J)
+ 50 CONTINUE
+ END IF
+ 60 CONTINUE
+ ELSE
+ JX = KX
+ DO 80 J = 1,N
+ KX = KX + INCX
+ IF (X(JX).NE.ZERO) THEN
+ IX = KX
+ L = 1 - J
+ IF (NOUNIT) X(JX) = X(JX)/A(1,J)
+ TEMP = X(JX)
+ DO 70 I = J + 1,MIN(N,J+K)
+ X(IX) = X(IX) - TEMP*A(L+I,J)
+ IX = IX + INCX
+ 70 CONTINUE
+ END IF
+ JX = JX + INCX
+ 80 CONTINUE
+ END IF
+ END IF
+ ELSE
+*
+* Form x := inv( A')*x.
+*
+ IF (LSAME(UPLO,'U')) THEN
+ KPLUS1 = K + 1
+ IF (INCX.EQ.1) THEN
+ DO 100 J = 1,N
+ TEMP = X(J)
+ L = KPLUS1 - J
+ DO 90 I = MAX(1,J-K),J - 1
+ TEMP = TEMP - A(L+I,J)*X(I)
+ 90 CONTINUE
+ IF (NOUNIT) TEMP = TEMP/A(KPLUS1,J)
+ X(J) = TEMP
+ 100 CONTINUE
+ ELSE
+ JX = KX
+ DO 120 J = 1,N
+ TEMP = X(JX)
+ IX = KX
+ L = KPLUS1 - J
+ DO 110 I = MAX(1,J-K),J - 1
+ TEMP = TEMP - A(L+I,J)*X(IX)
+ IX = IX + INCX
+ 110 CONTINUE
+ IF (NOUNIT) TEMP = TEMP/A(KPLUS1,J)
+ X(JX) = TEMP
+ JX = JX + INCX
+ IF (J.GT.K) KX = KX + INCX
+ 120 CONTINUE
+ END IF
+ ELSE
+ IF (INCX.EQ.1) THEN
+ DO 140 J = N,1,-1
+ TEMP = X(J)
+ L = 1 - J
+ DO 130 I = MIN(N,J+K),J + 1,-1
+ TEMP = TEMP - A(L+I,J)*X(I)
+ 130 CONTINUE
+ IF (NOUNIT) TEMP = TEMP/A(1,J)
+ X(J) = TEMP
+ 140 CONTINUE
+ ELSE
+ KX = KX + (N-1)*INCX
+ JX = KX
+ DO 160 J = N,1,-1
+ TEMP = X(JX)
+ IX = KX
+ L = 1 - J
+ DO 150 I = MIN(N,J+K),J + 1,-1
+ TEMP = TEMP - A(L+I,J)*X(IX)
+ IX = IX - INCX
+ 150 CONTINUE
+ IF (NOUNIT) TEMP = TEMP/A(1,J)
+ X(JX) = TEMP
+ JX = JX - INCX
+ IF ((N-J).GE.K) KX = KX - INCX
+ 160 CONTINUE
+ END IF
+ END IF
+ END IF
+*
+ RETURN
+*
+* End of STBSV .
+*
+ END
+ SUBROUTINE STPMV(UPLO,TRANS,DIAG,N,AP,X,INCX)
+* .. Scalar Arguments ..
+ INTEGER INCX,N
+ CHARACTER DIAG,TRANS,UPLO
+* ..
+* .. Array Arguments ..
+ REAL AP(*),X(*)
+* ..
+*
+* Purpose
+* =======
+*
+* STPMV performs one of the matrix-vector operations
+*
+* x := A*x, or x := A'*x,
+*
+* where x is an n element vector and A is an n by n unit, or non-unit,
+* upper or lower triangular matrix, supplied in packed form.
+*
+* Arguments
+* ==========
+*
+* UPLO - CHARACTER*1.
+* On entry, UPLO specifies whether the matrix is an upper or
+* lower triangular matrix as follows:
+*
+* UPLO = 'U' or 'u' A is an upper triangular matrix.
+*
+* UPLO = 'L' or 'l' A is a lower triangular matrix.
+*
+* Unchanged on exit.
+*
+* TRANS - CHARACTER*1.
+* On entry, TRANS specifies the operation to be performed as
+* follows:
+*
+* TRANS = 'N' or 'n' x := A*x.
+*
+* TRANS = 'T' or 't' x := A'*x.
+*
+* TRANS = 'C' or 'c' x := A'*x.
+*
+* Unchanged on exit.
+*
+* DIAG - CHARACTER*1.
+* On entry, DIAG specifies whether or not A is unit
+* triangular as follows:
+*
+* DIAG = 'U' or 'u' A is assumed to be unit triangular.
+*
+* DIAG = 'N' or 'n' A is not assumed to be unit
+* triangular.
+*
+* Unchanged on exit.
+*
+* N - INTEGER.
+* On entry, N specifies the order of the matrix A.
+* N must be at least zero.
+* Unchanged on exit.
+*
+* AP - REAL array of DIMENSION at least
+* ( ( n*( n + 1 ) )/2 ).
+* Before entry with UPLO = 'U' or 'u', the array AP must
+* contain the upper triangular matrix packed sequentially,
+* column by column, so that AP( 1 ) contains a( 1, 1 ),
+* AP( 2 ) and AP( 3 ) contain a( 1, 2 ) and a( 2, 2 )
+* respectively, and so on.
+* Before entry with UPLO = 'L' or 'l', the array AP must
+* contain the lower triangular matrix packed sequentially,
+* column by column, so that AP( 1 ) contains a( 1, 1 ),
+* AP( 2 ) and AP( 3 ) contain a( 2, 1 ) and a( 3, 1 )
+* respectively, and so on.
+* Note that when DIAG = 'U' or 'u', the diagonal elements of
+* A are not referenced, but are assumed to be unity.
+* Unchanged on exit.
+*
+* X - REAL array of dimension at least
+* ( 1 + ( n - 1 )*abs( INCX ) ).
+* Before entry, the incremented array X must contain the n
+* element vector x. On exit, X is overwritten with the
+* tranformed vector x.
+*
+* INCX - INTEGER.
+* On entry, INCX specifies the increment for the elements of
+* X. INCX must not be zero.
+* Unchanged on exit.
+*
+*
+* Level 2 Blas routine.
+*
+* -- Written on 22-October-1986.
+* Jack Dongarra, Argonne National Lab.
+* Jeremy Du Croz, Nag Central Office.
+* Sven Hammarling, Nag Central Office.
+* Richard Hanson, Sandia National Labs.
+*
+*
+* .. Parameters ..
+ REAL ZERO
+ PARAMETER (ZERO=0.0E+0)
+* ..
+* .. Local Scalars ..
+ REAL TEMP
+ INTEGER I,INFO,IX,J,JX,K,KK,KX
+ LOGICAL NOUNIT
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL XERBLA
+* ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN
+ INFO = 1
+ ELSE IF (.NOT.LSAME(TRANS,'N') .AND. .NOT.LSAME(TRANS,'T') .AND.
+ + .NOT.LSAME(TRANS,'C')) THEN
+ INFO = 2
+ ELSE IF (.NOT.LSAME(DIAG,'U') .AND. .NOT.LSAME(DIAG,'N')) THEN
+ INFO = 3
+ ELSE IF (N.LT.0) THEN
+ INFO = 4
+ ELSE IF (INCX.EQ.0) THEN
+ INFO = 7
+ END IF
+ IF (INFO.NE.0) THEN
+ CALL XERBLA('STPMV ',INFO)
+ RETURN
+ END IF
+*
+* Quick return if possible.
+*
+ IF (N.EQ.0) RETURN
+*
+ NOUNIT = LSAME(DIAG,'N')
+*
+* Set up the start point in X if the increment is not unity. This
+* will be ( N - 1 )*INCX too small for descending loops.
+*
+ IF (INCX.LE.0) THEN
+ KX = 1 - (N-1)*INCX
+ ELSE IF (INCX.NE.1) THEN
+ KX = 1
+ END IF
+*
+* Start the operations. In this version the elements of AP are
+* accessed sequentially with one pass through AP.
+*
+ IF (LSAME(TRANS,'N')) THEN
+*
+* Form x:= A*x.
+*
+ IF (LSAME(UPLO,'U')) THEN
+ KK = 1
+ IF (INCX.EQ.1) THEN
+ DO 20 J = 1,N
+ IF (X(J).NE.ZERO) THEN
+ TEMP = X(J)
+ K = KK
+ DO 10 I = 1,J - 1
+ X(I) = X(I) + TEMP*AP(K)
+ K = K + 1
+ 10 CONTINUE
+ IF (NOUNIT) X(J) = X(J)*AP(KK+J-1)
+ END IF
+ KK = KK + J
+ 20 CONTINUE
+ ELSE
+ JX = KX
+ DO 40 J = 1,N
+ IF (X(JX).NE.ZERO) THEN
+ TEMP = X(JX)
+ IX = KX
+ DO 30 K = KK,KK + J - 2
+ X(IX) = X(IX) + TEMP*AP(K)
+ IX = IX + INCX
+ 30 CONTINUE
+ IF (NOUNIT) X(JX) = X(JX)*AP(KK+J-1)
+ END IF
+ JX = JX + INCX
+ KK = KK + J
+ 40 CONTINUE
+ END IF
+ ELSE
+ KK = (N* (N+1))/2
+ IF (INCX.EQ.1) THEN
+ DO 60 J = N,1,-1
+ IF (X(J).NE.ZERO) THEN
+ TEMP = X(J)
+ K = KK
+ DO 50 I = N,J + 1,-1
+ X(I) = X(I) + TEMP*AP(K)
+ K = K - 1
+ 50 CONTINUE
+ IF (NOUNIT) X(J) = X(J)*AP(KK-N+J)
+ END IF
+ KK = KK - (N-J+1)
+ 60 CONTINUE
+ ELSE
+ KX = KX + (N-1)*INCX
+ JX = KX
+ DO 80 J = N,1,-1
+ IF (X(JX).NE.ZERO) THEN
+ TEMP = X(JX)
+ IX = KX
+ DO 70 K = KK,KK - (N- (J+1)),-1
+ X(IX) = X(IX) + TEMP*AP(K)
+ IX = IX - INCX
+ 70 CONTINUE
+ IF (NOUNIT) X(JX) = X(JX)*AP(KK-N+J)
+ END IF
+ JX = JX - INCX
+ KK = KK - (N-J+1)
+ 80 CONTINUE
+ END IF
+ END IF
+ ELSE
+*
+* Form x := A'*x.
+*
+ IF (LSAME(UPLO,'U')) THEN
+ KK = (N* (N+1))/2
+ IF (INCX.EQ.1) THEN
+ DO 100 J = N,1,-1
+ TEMP = X(J)
+ IF (NOUNIT) TEMP = TEMP*AP(KK)
+ K = KK - 1
+ DO 90 I = J - 1,1,-1
+ TEMP = TEMP + AP(K)*X(I)
+ K = K - 1
+ 90 CONTINUE
+ X(J) = TEMP
+ KK = KK - J
+ 100 CONTINUE
+ ELSE
+ JX = KX + (N-1)*INCX
+ DO 120 J = N,1,-1
+ TEMP = X(JX)
+ IX = JX
+ IF (NOUNIT) TEMP = TEMP*AP(KK)
+ DO 110 K = KK - 1,KK - J + 1,-1
+ IX = IX - INCX
+ TEMP = TEMP + AP(K)*X(IX)
+ 110 CONTINUE
+ X(JX) = TEMP
+ JX = JX - INCX
+ KK = KK - J
+ 120 CONTINUE
+ END IF
+ ELSE
+ KK = 1
+ IF (INCX.EQ.1) THEN
+ DO 140 J = 1,N
+ TEMP = X(J)
+ IF (NOUNIT) TEMP = TEMP*AP(KK)
+ K = KK + 1
+ DO 130 I = J + 1,N
+ TEMP = TEMP + AP(K)*X(I)
+ K = K + 1
+ 130 CONTINUE
+ X(J) = TEMP
+ KK = KK + (N-J+1)
+ 140 CONTINUE
+ ELSE
+ JX = KX
+ DO 160 J = 1,N
+ TEMP = X(JX)
+ IX = JX
+ IF (NOUNIT) TEMP = TEMP*AP(KK)
+ DO 150 K = KK + 1,KK + N - J
+ IX = IX + INCX
+ TEMP = TEMP + AP(K)*X(IX)
+ 150 CONTINUE
+ X(JX) = TEMP
+ JX = JX + INCX
+ KK = KK + (N-J+1)
+ 160 CONTINUE
+ END IF
+ END IF
+ END IF
+*
+ RETURN
+*
+* End of STPMV .
+*
+ END
+ SUBROUTINE STPSV(UPLO,TRANS,DIAG,N,AP,X,INCX)
+* .. Scalar Arguments ..
+ INTEGER INCX,N
+ CHARACTER DIAG,TRANS,UPLO
+* ..
+* .. Array Arguments ..
+ REAL AP(*),X(*)
+* ..
+*
+* Purpose
+* =======
+*
+* STPSV solves one of the systems of equations
+*
+* A*x = b, or A'*x = b,
+*
+* where b and x are n element vectors and A is an n by n unit, or
+* non-unit, upper or lower triangular matrix, supplied in packed form.
+*
+* No test for singularity or near-singularity is included in this
+* routine. Such tests must be performed before calling this routine.
+*
+* Arguments
+* ==========
+*
+* UPLO - CHARACTER*1.
+* On entry, UPLO specifies whether the matrix is an upper or
+* lower triangular matrix as follows:
+*
+* UPLO = 'U' or 'u' A is an upper triangular matrix.
+*
+* UPLO = 'L' or 'l' A is a lower triangular matrix.
+*
+* Unchanged on exit.
+*
+* TRANS - CHARACTER*1.
+* On entry, TRANS specifies the equations to be solved as
+* follows:
+*
+* TRANS = 'N' or 'n' A*x = b.
+*
+* TRANS = 'T' or 't' A'*x = b.
+*
+* TRANS = 'C' or 'c' A'*x = b.
+*
+* Unchanged on exit.
+*
+* DIAG - CHARACTER*1.
+* On entry, DIAG specifies whether or not A is unit
+* triangular as follows:
+*
+* DIAG = 'U' or 'u' A is assumed to be unit triangular.
+*
+* DIAG = 'N' or 'n' A is not assumed to be unit
+* triangular.
+*
+* Unchanged on exit.
+*
+* N - INTEGER.
+* On entry, N specifies the order of the matrix A.
+* N must be at least zero.
+* Unchanged on exit.
+*
+* AP - REAL array of DIMENSION at least
+* ( ( n*( n + 1 ) )/2 ).
+* Before entry with UPLO = 'U' or 'u', the array AP must
+* contain the upper triangular matrix packed sequentially,
+* column by column, so that AP( 1 ) contains a( 1, 1 ),
+* AP( 2 ) and AP( 3 ) contain a( 1, 2 ) and a( 2, 2 )
+* respectively, and so on.
+* Before entry with UPLO = 'L' or 'l', the array AP must
+* contain the lower triangular matrix packed sequentially,
+* column by column, so that AP( 1 ) contains a( 1, 1 ),
+* AP( 2 ) and AP( 3 ) contain a( 2, 1 ) and a( 3, 1 )
+* respectively, and so on.
+* Note that when DIAG = 'U' or 'u', the diagonal elements of
+* A are not referenced, but are assumed to be unity.
+* Unchanged on exit.
+*
+* X - REAL array of dimension at least
+* ( 1 + ( n - 1 )*abs( INCX ) ).
+* Before entry, the incremented array X must contain the n
+* element right-hand side vector b. On exit, X is overwritten
+* with the solution vector x.
+*
+* INCX - INTEGER.
+* On entry, INCX specifies the increment for the elements of
+* X. INCX must not be zero.
+* Unchanged on exit.
+*
+*
+* Level 2 Blas routine.
+*
+* -- Written on 22-October-1986.
+* Jack Dongarra, Argonne National Lab.
+* Jeremy Du Croz, Nag Central Office.
+* Sven Hammarling, Nag Central Office.
+* Richard Hanson, Sandia National Labs.
+*
+*
+* .. Parameters ..
+ REAL ZERO
+ PARAMETER (ZERO=0.0E+0)
+* ..
+* .. Local Scalars ..
+ REAL TEMP
+ INTEGER I,INFO,IX,J,JX,K,KK,KX
+ LOGICAL NOUNIT
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL XERBLA
+* ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN
+ INFO = 1
+ ELSE IF (.NOT.LSAME(TRANS,'N') .AND. .NOT.LSAME(TRANS,'T') .AND.
+ + .NOT.LSAME(TRANS,'C')) THEN
+ INFO = 2
+ ELSE IF (.NOT.LSAME(DIAG,'U') .AND. .NOT.LSAME(DIAG,'N')) THEN
+ INFO = 3
+ ELSE IF (N.LT.0) THEN
+ INFO = 4
+ ELSE IF (INCX.EQ.0) THEN
+ INFO = 7
+ END IF
+ IF (INFO.NE.0) THEN
+ CALL XERBLA('STPSV ',INFO)
+ RETURN
+ END IF
+*
+* Quick return if possible.
+*
+ IF (N.EQ.0) RETURN
+*
+ NOUNIT = LSAME(DIAG,'N')
+*
+* Set up the start point in X if the increment is not unity. This
+* will be ( N - 1 )*INCX too small for descending loops.
+*
+ IF (INCX.LE.0) THEN
+ KX = 1 - (N-1)*INCX
+ ELSE IF (INCX.NE.1) THEN
+ KX = 1
+ END IF
+*
+* Start the operations. In this version the elements of AP are
+* accessed sequentially with one pass through AP.
+*
+ IF (LSAME(TRANS,'N')) THEN
+*
+* Form x := inv( A )*x.
+*
+ IF (LSAME(UPLO,'U')) THEN
+ KK = (N* (N+1))/2
+ IF (INCX.EQ.1) THEN
+ DO 20 J = N,1,-1
+ IF (X(J).NE.ZERO) THEN
+ IF (NOUNIT) X(J) = X(J)/AP(KK)
+ TEMP = X(J)
+ K = KK - 1
+ DO 10 I = J - 1,1,-1
+ X(I) = X(I) - TEMP*AP(K)
+ K = K - 1
+ 10 CONTINUE
+ END IF
+ KK = KK - J
+ 20 CONTINUE
+ ELSE
+ JX = KX + (N-1)*INCX
+ DO 40 J = N,1,-1
+ IF (X(JX).NE.ZERO) THEN
+ IF (NOUNIT) X(JX) = X(JX)/AP(KK)
+ TEMP = X(JX)
+ IX = JX
+ DO 30 K = KK - 1,KK - J + 1,-1
+ IX = IX - INCX
+ X(IX) = X(IX) - TEMP*AP(K)
+ 30 CONTINUE
+ END IF
+ JX = JX - INCX
+ KK = KK - J
+ 40 CONTINUE
+ END IF
+ ELSE
+ KK = 1
+ IF (INCX.EQ.1) THEN
+ DO 60 J = 1,N
+ IF (X(J).NE.ZERO) THEN
+ IF (NOUNIT) X(J) = X(J)/AP(KK)
+ TEMP = X(J)
+ K = KK + 1
+ DO 50 I = J + 1,N
+ X(I) = X(I) - TEMP*AP(K)
+ K = K + 1
+ 50 CONTINUE
+ END IF
+ KK = KK + (N-J+1)
+ 60 CONTINUE
+ ELSE
+ JX = KX
+ DO 80 J = 1,N
+ IF (X(JX).NE.ZERO) THEN
+ IF (NOUNIT) X(JX) = X(JX)/AP(KK)
+ TEMP = X(JX)
+ IX = JX
+ DO 70 K = KK + 1,KK + N - J
+ IX = IX + INCX
+ X(IX) = X(IX) - TEMP*AP(K)
+ 70 CONTINUE
+ END IF
+ JX = JX + INCX
+ KK = KK + (N-J+1)
+ 80 CONTINUE
+ END IF
+ END IF
+ ELSE
+*
+* Form x := inv( A' )*x.
+*
+ IF (LSAME(UPLO,'U')) THEN
+ KK = 1
+ IF (INCX.EQ.1) THEN
+ DO 100 J = 1,N
+ TEMP = X(J)
+ K = KK
+ DO 90 I = 1,J - 1
+ TEMP = TEMP - AP(K)*X(I)
+ K = K + 1
+ 90 CONTINUE
+ IF (NOUNIT) TEMP = TEMP/AP(KK+J-1)
+ X(J) = TEMP
+ KK = KK + J
+ 100 CONTINUE
+ ELSE
+ JX = KX
+ DO 120 J = 1,N
+ TEMP = X(JX)
+ IX = KX
+ DO 110 K = KK,KK + J - 2
+ TEMP = TEMP - AP(K)*X(IX)
+ IX = IX + INCX
+ 110 CONTINUE
+ IF (NOUNIT) TEMP = TEMP/AP(KK+J-1)
+ X(JX) = TEMP
+ JX = JX + INCX
+ KK = KK + J
+ 120 CONTINUE
+ END IF
+ ELSE
+ KK = (N* (N+1))/2
+ IF (INCX.EQ.1) THEN
+ DO 140 J = N,1,-1
+ TEMP = X(J)
+ K = KK
+ DO 130 I = N,J + 1,-1
+ TEMP = TEMP - AP(K)*X(I)
+ K = K - 1
+ 130 CONTINUE
+ IF (NOUNIT) TEMP = TEMP/AP(KK-N+J)
+ X(J) = TEMP
+ KK = KK - (N-J+1)
+ 140 CONTINUE
+ ELSE
+ KX = KX + (N-1)*INCX
+ JX = KX
+ DO 160 J = N,1,-1
+ TEMP = X(JX)
+ IX = KX
+ DO 150 K = KK,KK - (N- (J+1)),-1
+ TEMP = TEMP - AP(K)*X(IX)
+ IX = IX - INCX
+ 150 CONTINUE
+ IF (NOUNIT) TEMP = TEMP/AP(KK-N+J)
+ X(JX) = TEMP
+ JX = JX - INCX
+ KK = KK - (N-J+1)
+ 160 CONTINUE
+ END IF
+ END IF
+ END IF
+*
+ RETURN
+*
+* End of STPSV .
+*
+ END
+ SUBROUTINE STRMM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB)
+* .. Scalar Arguments ..
+ REAL ALPHA
+ INTEGER LDA,LDB,M,N
+ CHARACTER DIAG,SIDE,TRANSA,UPLO
+* ..
+* .. Array Arguments ..
+ REAL A(LDA,*),B(LDB,*)
+* ..
+*
+* Purpose
+* =======
+*
+* STRMM performs one of the matrix-matrix operations
+*
+* B := alpha*op( A )*B, or B := alpha*B*op( A ),
+*
+* where alpha is a scalar, B is an m by n matrix, A is a unit, or
+* non-unit, upper or lower triangular matrix and op( A ) is one of
+*
+* op( A ) = A or op( A ) = A'.
+*
+* Arguments
+* ==========
+*
+* SIDE - CHARACTER*1.
+* On entry, SIDE specifies whether op( A ) multiplies B from
+* the left or right as follows:
+*
+* SIDE = 'L' or 'l' B := alpha*op( A )*B.
+*
+* SIDE = 'R' or 'r' B := alpha*B*op( A ).
+*
+* Unchanged on exit.
+*
+* UPLO - CHARACTER*1.
+* On entry, UPLO specifies whether the matrix A is an upper or
+* lower triangular matrix as follows:
+*
+* UPLO = 'U' or 'u' A is an upper triangular matrix.
+*
+* UPLO = 'L' or 'l' A is a lower triangular matrix.
+*
+* Unchanged on exit.
+*
+* TRANSA - CHARACTER*1.
+* On entry, TRANSA specifies the form of op( A ) to be used in
+* the matrix multiplication as follows:
+*
+* TRANSA = 'N' or 'n' op( A ) = A.
+*
+* TRANSA = 'T' or 't' op( A ) = A'.
+*
+* TRANSA = 'C' or 'c' op( A ) = A'.
+*
+* Unchanged on exit.
+*
+* DIAG - CHARACTER*1.
+* On entry, DIAG specifies whether or not A is unit triangular
+* as follows:
+*
+* DIAG = 'U' or 'u' A is assumed to be unit triangular.
+*
+* DIAG = 'N' or 'n' A is not assumed to be unit
+* triangular.
+*
+* Unchanged on exit.
+*
+* M - INTEGER.
+* On entry, M specifies the number of rows of B. M must be at
+* least zero.
+* Unchanged on exit.
+*
+* N - INTEGER.
+* On entry, N specifies the number of columns of B. N must be
+* at least zero.
+* Unchanged on exit.
+*
+* ALPHA - REAL .
+* On entry, ALPHA specifies the scalar alpha. When alpha is
+* zero then A is not referenced and B need not be set before
+* entry.
+* Unchanged on exit.
+*
+* A - REAL array of DIMENSION ( LDA, k ), where k is m
+* when SIDE = 'L' or 'l' and is n when SIDE = 'R' or 'r'.
+* Before entry with UPLO = 'U' or 'u', the leading k by k
+* upper triangular part of the array A must contain the upper
+* triangular matrix and the strictly lower triangular part of
+* A is not referenced.
+* Before entry with UPLO = 'L' or 'l', the leading k by k
+* lower triangular part of the array A must contain the lower
+* triangular matrix and the strictly upper triangular part of
+* A is not referenced.
+* Note that when DIAG = 'U' or 'u', the diagonal elements of
+* A are not referenced either, but are assumed to be unity.
+* Unchanged on exit.
+*
+* LDA - INTEGER.
+* On entry, LDA specifies the first dimension of A as declared
+* in the calling (sub) program. When SIDE = 'L' or 'l' then
+* LDA must be at least max( 1, m ), when SIDE = 'R' or 'r'
+* then LDA must be at least max( 1, n ).
+* Unchanged on exit.
+*
+* B - REAL array of DIMENSION ( LDB, n ).
+* Before entry, the leading m by n part of the array B must
+* contain the matrix B, and on exit is overwritten by the
+* transformed matrix.
+*
+* LDB - INTEGER.
+* On entry, LDB specifies the first dimension of B as declared
+* in the calling (sub) program. LDB must be at least
+* max( 1, m ).
+* Unchanged on exit.
+*
+*
+* Level 3 Blas routine.
+*
+* -- Written on 8-February-1989.
+* Jack Dongarra, Argonne National Laboratory.
+* Iain Duff, AERE Harwell.
+* Jeremy Du Croz, Numerical Algorithms Group Ltd.
+* Sven Hammarling, Numerical Algorithms Group Ltd.
+*
+*
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Local Scalars ..
+ REAL TEMP
+ INTEGER I,INFO,J,K,NROWA
+ LOGICAL LSIDE,NOUNIT,UPPER
+* ..
+* .. Parameters ..
+ REAL ONE,ZERO
+ PARAMETER (ONE=1.0E+0,ZERO=0.0E+0)
+* ..
+*
+* Test the input parameters.
+*
+ LSIDE = LSAME(SIDE,'L')
+ IF (LSIDE) THEN
+ NROWA = M
+ ELSE
+ NROWA = N
+ END IF
+ NOUNIT = LSAME(DIAG,'N')
+ UPPER = LSAME(UPLO,'U')
+*
+ INFO = 0
+ IF ((.NOT.LSIDE) .AND. (.NOT.LSAME(SIDE,'R'))) THEN
+ INFO = 1
+ ELSE IF ((.NOT.UPPER) .AND. (.NOT.LSAME(UPLO,'L'))) THEN
+ INFO = 2
+ ELSE IF ((.NOT.LSAME(TRANSA,'N')) .AND.
+ + (.NOT.LSAME(TRANSA,'T')) .AND.
+ + (.NOT.LSAME(TRANSA,'C'))) THEN
+ INFO = 3
+ ELSE IF ((.NOT.LSAME(DIAG,'U')) .AND. (.NOT.LSAME(DIAG,'N'))) THEN
+ INFO = 4
+ ELSE IF (M.LT.0) THEN
+ INFO = 5
+ ELSE IF (N.LT.0) THEN
+ INFO = 6
+ ELSE IF (LDA.LT.MAX(1,NROWA)) THEN
+ INFO = 9
+ ELSE IF (LDB.LT.MAX(1,M)) THEN
+ INFO = 11
+ END IF
+ IF (INFO.NE.0) THEN
+ CALL XERBLA('STRMM ',INFO)
+ RETURN
+ END IF
+*
+* Quick return if possible.
+*
+ IF (N.EQ.0) RETURN
+*
+* And when alpha.eq.zero.
+*
+ IF (ALPHA.EQ.ZERO) THEN
+ DO 20 J = 1,N
+ DO 10 I = 1,M
+ B(I,J) = ZERO
+ 10 CONTINUE
+ 20 CONTINUE
+ RETURN
+ END IF
+*
+* Start the operations.
+*
+ IF (LSIDE) THEN
+ IF (LSAME(TRANSA,'N')) THEN
+*
+* Form B := alpha*A*B.
+*
+ IF (UPPER) THEN
+ DO 50 J = 1,N
+ DO 40 K = 1,M
+ IF (B(K,J).NE.ZERO) THEN
+ TEMP = ALPHA*B(K,J)
+ DO 30 I = 1,K - 1
+ B(I,J) = B(I,J) + TEMP*A(I,K)
+ 30 CONTINUE
+ IF (NOUNIT) TEMP = TEMP*A(K,K)
+ B(K,J) = TEMP
+ END IF
+ 40 CONTINUE
+ 50 CONTINUE
+ ELSE
+ DO 80 J = 1,N
+ DO 70 K = M,1,-1
+ IF (B(K,J).NE.ZERO) THEN
+ TEMP = ALPHA*B(K,J)
+ B(K,J) = TEMP
+ IF (NOUNIT) B(K,J) = B(K,J)*A(K,K)
+ DO 60 I = K + 1,M
+ B(I,J) = B(I,J) + TEMP*A(I,K)
+ 60 CONTINUE
+ END IF
+ 70 CONTINUE
+ 80 CONTINUE
+ END IF
+ ELSE
+*
+* Form B := alpha*A'*B.
+*
+ IF (UPPER) THEN
+ DO 110 J = 1,N
+ DO 100 I = M,1,-1
+ TEMP = B(I,J)
+ IF (NOUNIT) TEMP = TEMP*A(I,I)
+ DO 90 K = 1,I - 1
+ TEMP = TEMP + A(K,I)*B(K,J)
+ 90 CONTINUE
+ B(I,J) = ALPHA*TEMP
+ 100 CONTINUE
+ 110 CONTINUE
+ ELSE
+ DO 140 J = 1,N
+ DO 130 I = 1,M
+ TEMP = B(I,J)
+ IF (NOUNIT) TEMP = TEMP*A(I,I)
+ DO 120 K = I + 1,M
+ TEMP = TEMP + A(K,I)*B(K,J)
+ 120 CONTINUE
+ B(I,J) = ALPHA*TEMP
+ 130 CONTINUE
+ 140 CONTINUE
+ END IF
+ END IF
+ ELSE
+ IF (LSAME(TRANSA,'N')) THEN
+*
+* Form B := alpha*B*A.
+*
+ IF (UPPER) THEN
+ DO 180 J = N,1,-1
+ TEMP = ALPHA
+ IF (NOUNIT) TEMP = TEMP*A(J,J)
+ DO 150 I = 1,M
+ B(I,J) = TEMP*B(I,J)
+ 150 CONTINUE
+ DO 170 K = 1,J - 1
+ IF (A(K,J).NE.ZERO) THEN
+ TEMP = ALPHA*A(K,J)
+ DO 160 I = 1,M
+ B(I,J) = B(I,J) + TEMP*B(I,K)
+ 160 CONTINUE
+ END IF
+ 170 CONTINUE
+ 180 CONTINUE
+ ELSE
+ DO 220 J = 1,N
+ TEMP = ALPHA
+ IF (NOUNIT) TEMP = TEMP*A(J,J)
+ DO 190 I = 1,M
+ B(I,J) = TEMP*B(I,J)
+ 190 CONTINUE
+ DO 210 K = J + 1,N
+ IF (A(K,J).NE.ZERO) THEN
+ TEMP = ALPHA*A(K,J)
+ DO 200 I = 1,M
+ B(I,J) = B(I,J) + TEMP*B(I,K)
+ 200 CONTINUE
+ END IF
+ 210 CONTINUE
+ 220 CONTINUE
+ END IF
+ ELSE
+*
+* Form B := alpha*B*A'.
+*
+ IF (UPPER) THEN
+ DO 260 K = 1,N
+ DO 240 J = 1,K - 1
+ IF (A(J,K).NE.ZERO) THEN
+ TEMP = ALPHA*A(J,K)
+ DO 230 I = 1,M
+ B(I,J) = B(I,J) + TEMP*B(I,K)
+ 230 CONTINUE
+ END IF
+ 240 CONTINUE
+ TEMP = ALPHA
+ IF (NOUNIT) TEMP = TEMP*A(K,K)
+ IF (TEMP.NE.ONE) THEN
+ DO 250 I = 1,M
+ B(I,K) = TEMP*B(I,K)
+ 250 CONTINUE
+ END IF
+ 260 CONTINUE
+ ELSE
+ DO 300 K = N,1,-1
+ DO 280 J = K + 1,N
+ IF (A(J,K).NE.ZERO) THEN
+ TEMP = ALPHA*A(J,K)
+ DO 270 I = 1,M
+ B(I,J) = B(I,J) + TEMP*B(I,K)
+ 270 CONTINUE
+ END IF
+ 280 CONTINUE
+ TEMP = ALPHA
+ IF (NOUNIT) TEMP = TEMP*A(K,K)
+ IF (TEMP.NE.ONE) THEN
+ DO 290 I = 1,M
+ B(I,K) = TEMP*B(I,K)
+ 290 CONTINUE
+ END IF
+ 300 CONTINUE
+ END IF
+ END IF
+ END IF
+*
+ RETURN
+*
+* End of STRMM .
+*
+ END
+ SUBROUTINE STRMV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX)
+* .. Scalar Arguments ..
+ INTEGER INCX,LDA,N
+ CHARACTER DIAG,TRANS,UPLO
+* ..
+* .. Array Arguments ..
+ REAL A(LDA,*),X(*)
+* ..
+*
+* Purpose
+* =======
+*
+* STRMV performs one of the matrix-vector operations
+*
+* x := A*x, or x := A'*x,
+*
+* where x is an n element vector and A is an n by n unit, or non-unit,
+* upper or lower triangular matrix.
+*
+* Arguments
+* ==========
+*
+* UPLO - CHARACTER*1.
+* On entry, UPLO specifies whether the matrix is an upper or
+* lower triangular matrix as follows:
+*
+* UPLO = 'U' or 'u' A is an upper triangular matrix.
+*
+* UPLO = 'L' or 'l' A is a lower triangular matrix.
+*
+* Unchanged on exit.
+*
+* TRANS - CHARACTER*1.
+* On entry, TRANS specifies the operation to be performed as
+* follows:
+*
+* TRANS = 'N' or 'n' x := A*x.
+*
+* TRANS = 'T' or 't' x := A'*x.
+*
+* TRANS = 'C' or 'c' x := A'*x.
+*
+* Unchanged on exit.
+*
+* DIAG - CHARACTER*1.
+* On entry, DIAG specifies whether or not A is unit
+* triangular as follows:
+*
+* DIAG = 'U' or 'u' A is assumed to be unit triangular.
+*
+* DIAG = 'N' or 'n' A is not assumed to be unit
+* triangular.
+*
+* Unchanged on exit.
+*
+* N - INTEGER.
+* On entry, N specifies the order of the matrix A.
+* N must be at least zero.
+* Unchanged on exit.
+*
+* A - REAL array of DIMENSION ( LDA, n ).
+* Before entry with UPLO = 'U' or 'u', the leading n by n
+* upper triangular part of the array A must contain the upper
+* triangular matrix and the strictly lower triangular part of
+* A is not referenced.
+* Before entry with UPLO = 'L' or 'l', the leading n by n
+* lower triangular part of the array A must contain the lower
+* triangular matrix and the strictly upper triangular part of
+* A is not referenced.
+* Note that when DIAG = 'U' or 'u', the diagonal elements of
+* A are not referenced either, but are assumed to be unity.
+* Unchanged on exit.
+*
+* LDA - INTEGER.
+* On entry, LDA specifies the first dimension of A as declared
+* in the calling (sub) program. LDA must be at least
+* max( 1, n ).
+* Unchanged on exit.
+*
+* X - REAL array of dimension at least
+* ( 1 + ( n - 1 )*abs( INCX ) ).
+* Before entry, the incremented array X must contain the n
+* element vector x. On exit, X is overwritten with the
+* tranformed vector x.
+*
+* INCX - INTEGER.
+* On entry, INCX specifies the increment for the elements of
+* X. INCX must not be zero.
+* Unchanged on exit.
+*
+*
+* Level 2 Blas routine.
+*
+* -- Written on 22-October-1986.
+* Jack Dongarra, Argonne National Lab.
+* Jeremy Du Croz, Nag Central Office.
+* Sven Hammarling, Nag Central Office.
+* Richard Hanson, Sandia National Labs.
+*
+*
+* .. Parameters ..
+ REAL ZERO
+ PARAMETER (ZERO=0.0E+0)
+* ..
+* .. Local Scalars ..
+ REAL TEMP
+ INTEGER I,INFO,IX,J,JX,KX
+ LOGICAL NOUNIT
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN
+ INFO = 1
+ ELSE IF (.NOT.LSAME(TRANS,'N') .AND. .NOT.LSAME(TRANS,'T') .AND.
+ + .NOT.LSAME(TRANS,'C')) THEN
+ INFO = 2
+ ELSE IF (.NOT.LSAME(DIAG,'U') .AND. .NOT.LSAME(DIAG,'N')) THEN
+ INFO = 3
+ ELSE IF (N.LT.0) THEN
+ INFO = 4
+ ELSE IF (LDA.LT.MAX(1,N)) THEN
+ INFO = 6
+ ELSE IF (INCX.EQ.0) THEN
+ INFO = 8
+ END IF
+ IF (INFO.NE.0) THEN
+ CALL XERBLA('STRMV ',INFO)
+ RETURN
+ END IF
+*
+* Quick return if possible.
+*
+ IF (N.EQ.0) RETURN
+*
+ NOUNIT = LSAME(DIAG,'N')
+*
+* Set up the start point in X if the increment is not unity. This
+* will be ( N - 1 )*INCX too small for descending loops.
+*
+ IF (INCX.LE.0) THEN
+ KX = 1 - (N-1)*INCX
+ ELSE IF (INCX.NE.1) THEN
+ KX = 1
+ END IF
+*
+* Start the operations. In this version the elements of A are
+* accessed sequentially with one pass through A.
+*
+ IF (LSAME(TRANS,'N')) THEN
+*
+* Form x := A*x.
+*
+ IF (LSAME(UPLO,'U')) THEN
+ IF (INCX.EQ.1) THEN
+ DO 20 J = 1,N
+ IF (X(J).NE.ZERO) THEN
+ TEMP = X(J)
+ DO 10 I = 1,J - 1
+ X(I) = X(I) + TEMP*A(I,J)
+ 10 CONTINUE
+ IF (NOUNIT) X(J) = X(J)*A(J,J)
+ END IF
+ 20 CONTINUE
+ ELSE
+ JX = KX
+ DO 40 J = 1,N
+ IF (X(JX).NE.ZERO) THEN
+ TEMP = X(JX)
+ IX = KX
+ DO 30 I = 1,J - 1
+ X(IX) = X(IX) + TEMP*A(I,J)
+ IX = IX + INCX
+ 30 CONTINUE
+ IF (NOUNIT) X(JX) = X(JX)*A(J,J)
+ END IF
+ JX = JX + INCX
+ 40 CONTINUE
+ END IF
+ ELSE
+ IF (INCX.EQ.1) THEN
+ DO 60 J = N,1,-1
+ IF (X(J).NE.ZERO) THEN
+ TEMP = X(J)
+ DO 50 I = N,J + 1,-1
+ X(I) = X(I) + TEMP*A(I,J)
+ 50 CONTINUE
+ IF (NOUNIT) X(J) = X(J)*A(J,J)
+ END IF
+ 60 CONTINUE
+ ELSE
+ KX = KX + (N-1)*INCX
+ JX = KX
+ DO 80 J = N,1,-1
+ IF (X(JX).NE.ZERO) THEN
+ TEMP = X(JX)
+ IX = KX
+ DO 70 I = N,J + 1,-1
+ X(IX) = X(IX) + TEMP*A(I,J)
+ IX = IX - INCX
+ 70 CONTINUE
+ IF (NOUNIT) X(JX) = X(JX)*A(J,J)
+ END IF
+ JX = JX - INCX
+ 80 CONTINUE
+ END IF
+ END IF
+ ELSE
+*
+* Form x := A'*x.
+*
+ IF (LSAME(UPLO,'U')) THEN
+ IF (INCX.EQ.1) THEN
+ DO 100 J = N,1,-1
+ TEMP = X(J)
+ IF (NOUNIT) TEMP = TEMP*A(J,J)
+ DO 90 I = J - 1,1,-1
+ TEMP = TEMP + A(I,J)*X(I)
+ 90 CONTINUE
+ X(J) = TEMP
+ 100 CONTINUE
+ ELSE
+ JX = KX + (N-1)*INCX
+ DO 120 J = N,1,-1
+ TEMP = X(JX)
+ IX = JX
+ IF (NOUNIT) TEMP = TEMP*A(J,J)
+ DO 110 I = J - 1,1,-1
+ IX = IX - INCX
+ TEMP = TEMP + A(I,J)*X(IX)
+ 110 CONTINUE
+ X(JX) = TEMP
+ JX = JX - INCX
+ 120 CONTINUE
+ END IF
+ ELSE
+ IF (INCX.EQ.1) THEN
+ DO 140 J = 1,N
+ TEMP = X(J)
+ IF (NOUNIT) TEMP = TEMP*A(J,J)
+ DO 130 I = J + 1,N
+ TEMP = TEMP + A(I,J)*X(I)
+ 130 CONTINUE
+ X(J) = TEMP
+ 140 CONTINUE
+ ELSE
+ JX = KX
+ DO 160 J = 1,N
+ TEMP = X(JX)
+ IX = JX
+ IF (NOUNIT) TEMP = TEMP*A(J,J)
+ DO 150 I = J + 1,N
+ IX = IX + INCX
+ TEMP = TEMP + A(I,J)*X(IX)
+ 150 CONTINUE
+ X(JX) = TEMP
+ JX = JX + INCX
+ 160 CONTINUE
+ END IF
+ END IF
+ END IF
+*
+ RETURN
+*
+* End of STRMV .
+*
+ END
+ SUBROUTINE STRSM(SIDE,UPLO,TRANSA,DIAG,M,N,ALPHA,A,LDA,B,LDB)
+* .. Scalar Arguments ..
+ REAL ALPHA
+ INTEGER LDA,LDB,M,N
+ CHARACTER DIAG,SIDE,TRANSA,UPLO
+* ..
+* .. Array Arguments ..
+ REAL A(LDA,*),B(LDB,*)
+* ..
+*
+* Purpose
+* =======
+*
+* STRSM solves one of the matrix equations
+*
+* op( A )*X = alpha*B, or X*op( A ) = alpha*B,
+*
+* where alpha is a scalar, X and B are m by n matrices, A is a unit, or
+* non-unit, upper or lower triangular matrix and op( A ) is one of
+*
+* op( A ) = A or op( A ) = A'.
+*
+* The matrix X is overwritten on B.
+*
+* Arguments
+* ==========
+*
+* SIDE - CHARACTER*1.
+* On entry, SIDE specifies whether op( A ) appears on the left
+* or right of X as follows:
+*
+* SIDE = 'L' or 'l' op( A )*X = alpha*B.
+*
+* SIDE = 'R' or 'r' X*op( A ) = alpha*B.
+*
+* Unchanged on exit.
+*
+* UPLO - CHARACTER*1.
+* On entry, UPLO specifies whether the matrix A is an upper or
+* lower triangular matrix as follows:
+*
+* UPLO = 'U' or 'u' A is an upper triangular matrix.
+*
+* UPLO = 'L' or 'l' A is a lower triangular matrix.
+*
+* Unchanged on exit.
+*
+* TRANSA - CHARACTER*1.
+* On entry, TRANSA specifies the form of op( A ) to be used in
+* the matrix multiplication as follows:
+*
+* TRANSA = 'N' or 'n' op( A ) = A.
+*
+* TRANSA = 'T' or 't' op( A ) = A'.
+*
+* TRANSA = 'C' or 'c' op( A ) = A'.
+*
+* Unchanged on exit.
+*
+* DIAG - CHARACTER*1.
+* On entry, DIAG specifies whether or not A is unit triangular
+* as follows:
+*
+* DIAG = 'U' or 'u' A is assumed to be unit triangular.
+*
+* DIAG = 'N' or 'n' A is not assumed to be unit
+* triangular.
+*
+* Unchanged on exit.
+*
+* M - INTEGER.
+* On entry, M specifies the number of rows of B. M must be at
+* least zero.
+* Unchanged on exit.
+*
+* N - INTEGER.
+* On entry, N specifies the number of columns of B. N must be
+* at least zero.
+* Unchanged on exit.
+*
+* ALPHA - REAL .
+* On entry, ALPHA specifies the scalar alpha. When alpha is
+* zero then A is not referenced and B need not be set before
+* entry.
+* Unchanged on exit.
+*
+* A - REAL array of DIMENSION ( LDA, k ), where k is m
+* when SIDE = 'L' or 'l' and is n when SIDE = 'R' or 'r'.
+* Before entry with UPLO = 'U' or 'u', the leading k by k
+* upper triangular part of the array A must contain the upper
+* triangular matrix and the strictly lower triangular part of
+* A is not referenced.
+* Before entry with UPLO = 'L' or 'l', the leading k by k
+* lower triangular part of the array A must contain the lower
+* triangular matrix and the strictly upper triangular part of
+* A is not referenced.
+* Note that when DIAG = 'U' or 'u', the diagonal elements of
+* A are not referenced either, but are assumed to be unity.
+* Unchanged on exit.
+*
+* LDA - INTEGER.
+* On entry, LDA specifies the first dimension of A as declared
+* in the calling (sub) program. When SIDE = 'L' or 'l' then
+* LDA must be at least max( 1, m ), when SIDE = 'R' or 'r'
+* then LDA must be at least max( 1, n ).
+* Unchanged on exit.
+*
+* B - REAL array of DIMENSION ( LDB, n ).
+* Before entry, the leading m by n part of the array B must
+* contain the right-hand side matrix B, and on exit is
+* overwritten by the solution matrix X.
+*
+* LDB - INTEGER.
+* On entry, LDB specifies the first dimension of B as declared
+* in the calling (sub) program. LDB must be at least
+* max( 1, m ).
+* Unchanged on exit.
+*
+*
+* Level 3 Blas routine.
+*
+*
+* -- Written on 8-February-1989.
+* Jack Dongarra, Argonne National Laboratory.
+* Iain Duff, AERE Harwell.
+* Jeremy Du Croz, Numerical Algorithms Group Ltd.
+* Sven Hammarling, Numerical Algorithms Group Ltd.
+*
+*
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Local Scalars ..
+ REAL TEMP
+ INTEGER I,INFO,J,K,NROWA
+ LOGICAL LSIDE,NOUNIT,UPPER
+* ..
+* .. Parameters ..
+ REAL ONE,ZERO
+ PARAMETER (ONE=1.0E+0,ZERO=0.0E+0)
+* ..
+*
+* Test the input parameters.
+*
+ LSIDE = LSAME(SIDE,'L')
+ IF (LSIDE) THEN
+ NROWA = M
+ ELSE
+ NROWA = N
+ END IF
+ NOUNIT = LSAME(DIAG,'N')
+ UPPER = LSAME(UPLO,'U')
+*
+ INFO = 0
+ IF ((.NOT.LSIDE) .AND. (.NOT.LSAME(SIDE,'R'))) THEN
+ INFO = 1
+ ELSE IF ((.NOT.UPPER) .AND. (.NOT.LSAME(UPLO,'L'))) THEN
+ INFO = 2
+ ELSE IF ((.NOT.LSAME(TRANSA,'N')) .AND.
+ + (.NOT.LSAME(TRANSA,'T')) .AND.
+ + (.NOT.LSAME(TRANSA,'C'))) THEN
+ INFO = 3
+ ELSE IF ((.NOT.LSAME(DIAG,'U')) .AND. (.NOT.LSAME(DIAG,'N'))) THEN
+ INFO = 4
+ ELSE IF (M.LT.0) THEN
+ INFO = 5
+ ELSE IF (N.LT.0) THEN
+ INFO = 6
+ ELSE IF (LDA.LT.MAX(1,NROWA)) THEN
+ INFO = 9
+ ELSE IF (LDB.LT.MAX(1,M)) THEN
+ INFO = 11
+ END IF
+ IF (INFO.NE.0) THEN
+ CALL XERBLA('STRSM ',INFO)
+ RETURN
+ END IF
+*
+* Quick return if possible.
+*
+ IF (N.EQ.0) RETURN
+*
+* And when alpha.eq.zero.
+*
+ IF (ALPHA.EQ.ZERO) THEN
+ DO 20 J = 1,N
+ DO 10 I = 1,M
+ B(I,J) = ZERO
+ 10 CONTINUE
+ 20 CONTINUE
+ RETURN
+ END IF
+*
+* Start the operations.
+*
+ IF (LSIDE) THEN
+ IF (LSAME(TRANSA,'N')) THEN
+*
+* Form B := alpha*inv( A )*B.
+*
+ IF (UPPER) THEN
+ DO 60 J = 1,N
+ IF (ALPHA.NE.ONE) THEN
+ DO 30 I = 1,M
+ B(I,J) = ALPHA*B(I,J)
+ 30 CONTINUE
+ END IF
+ DO 50 K = M,1,-1
+ IF (B(K,J).NE.ZERO) THEN
+ IF (NOUNIT) B(K,J) = B(K,J)/A(K,K)
+ DO 40 I = 1,K - 1
+ B(I,J) = B(I,J) - B(K,J)*A(I,K)
+ 40 CONTINUE
+ END IF
+ 50 CONTINUE
+ 60 CONTINUE
+ ELSE
+ DO 100 J = 1,N
+ IF (ALPHA.NE.ONE) THEN
+ DO 70 I = 1,M
+ B(I,J) = ALPHA*B(I,J)
+ 70 CONTINUE
+ END IF
+ DO 90 K = 1,M
+ IF (B(K,J).NE.ZERO) THEN
+ IF (NOUNIT) B(K,J) = B(K,J)/A(K,K)
+ DO 80 I = K + 1,M
+ B(I,J) = B(I,J) - B(K,J)*A(I,K)
+ 80 CONTINUE
+ END IF
+ 90 CONTINUE
+ 100 CONTINUE
+ END IF
+ ELSE
+*
+* Form B := alpha*inv( A' )*B.
+*
+ IF (UPPER) THEN
+ DO 130 J = 1,N
+ DO 120 I = 1,M
+ TEMP = ALPHA*B(I,J)
+ DO 110 K = 1,I - 1
+ TEMP = TEMP - A(K,I)*B(K,J)
+ 110 CONTINUE
+ IF (NOUNIT) TEMP = TEMP/A(I,I)
+ B(I,J) = TEMP
+ 120 CONTINUE
+ 130 CONTINUE
+ ELSE
+ DO 160 J = 1,N
+ DO 150 I = M,1,-1
+ TEMP = ALPHA*B(I,J)
+ DO 140 K = I + 1,M
+ TEMP = TEMP - A(K,I)*B(K,J)
+ 140 CONTINUE
+ IF (NOUNIT) TEMP = TEMP/A(I,I)
+ B(I,J) = TEMP
+ 150 CONTINUE
+ 160 CONTINUE
+ END IF
+ END IF
+ ELSE
+ IF (LSAME(TRANSA,'N')) THEN
+*
+* Form B := alpha*B*inv( A ).
+*
+ IF (UPPER) THEN
+ DO 210 J = 1,N
+ IF (ALPHA.NE.ONE) THEN
+ DO 170 I = 1,M
+ B(I,J) = ALPHA*B(I,J)
+ 170 CONTINUE
+ END IF
+ DO 190 K = 1,J - 1
+ IF (A(K,J).NE.ZERO) THEN
+ DO 180 I = 1,M
+ B(I,J) = B(I,J) - A(K,J)*B(I,K)
+ 180 CONTINUE
+ END IF
+ 190 CONTINUE
+ IF (NOUNIT) THEN
+ TEMP = ONE/A(J,J)
+ DO 200 I = 1,M
+ B(I,J) = TEMP*B(I,J)
+ 200 CONTINUE
+ END IF
+ 210 CONTINUE
+ ELSE
+ DO 260 J = N,1,-1
+ IF (ALPHA.NE.ONE) THEN
+ DO 220 I = 1,M
+ B(I,J) = ALPHA*B(I,J)
+ 220 CONTINUE
+ END IF
+ DO 240 K = J + 1,N
+ IF (A(K,J).NE.ZERO) THEN
+ DO 230 I = 1,M
+ B(I,J) = B(I,J) - A(K,J)*B(I,K)
+ 230 CONTINUE
+ END IF
+ 240 CONTINUE
+ IF (NOUNIT) THEN
+ TEMP = ONE/A(J,J)
+ DO 250 I = 1,M
+ B(I,J) = TEMP*B(I,J)
+ 250 CONTINUE
+ END IF
+ 260 CONTINUE
+ END IF
+ ELSE
+*
+* Form B := alpha*B*inv( A' ).
+*
+ IF (UPPER) THEN
+ DO 310 K = N,1,-1
+ IF (NOUNIT) THEN
+ TEMP = ONE/A(K,K)
+ DO 270 I = 1,M
+ B(I,K) = TEMP*B(I,K)
+ 270 CONTINUE
+ END IF
+ DO 290 J = 1,K - 1
+ IF (A(J,K).NE.ZERO) THEN
+ TEMP = A(J,K)
+ DO 280 I = 1,M
+ B(I,J) = B(I,J) - TEMP*B(I,K)
+ 280 CONTINUE
+ END IF
+ 290 CONTINUE
+ IF (ALPHA.NE.ONE) THEN
+ DO 300 I = 1,M
+ B(I,K) = ALPHA*B(I,K)
+ 300 CONTINUE
+ END IF
+ 310 CONTINUE
+ ELSE
+ DO 360 K = 1,N
+ IF (NOUNIT) THEN
+ TEMP = ONE/A(K,K)
+ DO 320 I = 1,M
+ B(I,K) = TEMP*B(I,K)
+ 320 CONTINUE
+ END IF
+ DO 340 J = K + 1,N
+ IF (A(J,K).NE.ZERO) THEN
+ TEMP = A(J,K)
+ DO 330 I = 1,M
+ B(I,J) = B(I,J) - TEMP*B(I,K)
+ 330 CONTINUE
+ END IF
+ 340 CONTINUE
+ IF (ALPHA.NE.ONE) THEN
+ DO 350 I = 1,M
+ B(I,K) = ALPHA*B(I,K)
+ 350 CONTINUE
+ END IF
+ 360 CONTINUE
+ END IF
+ END IF
+ END IF
+*
+ RETURN
+*
+* End of STRSM .
+*
+ END
+ SUBROUTINE STRSV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX)
+* .. Scalar Arguments ..
+ INTEGER INCX,LDA,N
+ CHARACTER DIAG,TRANS,UPLO
+* ..
+* .. Array Arguments ..
+ REAL A(LDA,*),X(*)
+* ..
+*
+* Purpose
+* =======
+*
+* STRSV solves one of the systems of equations
+*
+* A*x = b, or A'*x = b,
+*
+* where b and x are n element vectors and A is an n by n unit, or
+* non-unit, upper or lower triangular matrix.
+*
+* No test for singularity or near-singularity is included in this
+* routine. Such tests must be performed before calling this routine.
+*
+* Arguments
+* ==========
+*
+* UPLO - CHARACTER*1.
+* On entry, UPLO specifies whether the matrix is an upper or
+* lower triangular matrix as follows:
+*
+* UPLO = 'U' or 'u' A is an upper triangular matrix.
+*
+* UPLO = 'L' or 'l' A is a lower triangular matrix.
+*
+* Unchanged on exit.
+*
+* TRANS - CHARACTER*1.
+* On entry, TRANS specifies the equations to be solved as
+* follows:
+*
+* TRANS = 'N' or 'n' A*x = b.
+*
+* TRANS = 'T' or 't' A'*x = b.
+*
+* TRANS = 'C' or 'c' A'*x = b.
+*
+* Unchanged on exit.
+*
+* DIAG - CHARACTER*1.
+* On entry, DIAG specifies whether or not A is unit
+* triangular as follows:
+*
+* DIAG = 'U' or 'u' A is assumed to be unit triangular.
+*
+* DIAG = 'N' or 'n' A is not assumed to be unit
+* triangular.
+*
+* Unchanged on exit.
+*
+* N - INTEGER.
+* On entry, N specifies the order of the matrix A.
+* N must be at least zero.
+* Unchanged on exit.
+*
+* A - REAL array of DIMENSION ( LDA, n ).
+* Before entry with UPLO = 'U' or 'u', the leading n by n
+* upper triangular part of the array A must contain the upper
+* triangular matrix and the strictly lower triangular part of
+* A is not referenced.
+* Before entry with UPLO = 'L' or 'l', the leading n by n
+* lower triangular part of the array A must contain the lower
+* triangular matrix and the strictly upper triangular part of
+* A is not referenced.
+* Note that when DIAG = 'U' or 'u', the diagonal elements of
+* A are not referenced either, but are assumed to be unity.
+* Unchanged on exit.
+*
+* LDA - INTEGER.
+* On entry, LDA specifies the first dimension of A as declared
+* in the calling (sub) program. LDA must be at least
+* max( 1, n ).
+* Unchanged on exit.
+*
+* X - REAL array of dimension at least
+* ( 1 + ( n - 1 )*abs( INCX ) ).
+* Before entry, the incremented array X must contain the n
+* element right-hand side vector b. On exit, X is overwritten
+* with the solution vector x.
+*
+* INCX - INTEGER.
+* On entry, INCX specifies the increment for the elements of
+* X. INCX must not be zero.
+* Unchanged on exit.
+*
+*
+* Level 2 Blas routine.
+*
+* -- Written on 22-October-1986.
+* Jack Dongarra, Argonne National Lab.
+* Jeremy Du Croz, Nag Central Office.
+* Sven Hammarling, Nag Central Office.
+* Richard Hanson, Sandia National Labs.
+*
+*
+* .. Parameters ..
+ REAL ZERO
+ PARAMETER (ZERO=0.0E+0)
+* ..
+* .. Local Scalars ..
+ REAL TEMP
+ INTEGER I,INFO,IX,J,JX,KX
+ LOGICAL NOUNIT
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN
+ INFO = 1
+ ELSE IF (.NOT.LSAME(TRANS,'N') .AND. .NOT.LSAME(TRANS,'T') .AND.
+ + .NOT.LSAME(TRANS,'C')) THEN
+ INFO = 2
+ ELSE IF (.NOT.LSAME(DIAG,'U') .AND. .NOT.LSAME(DIAG,'N')) THEN
+ INFO = 3
+ ELSE IF (N.LT.0) THEN
+ INFO = 4
+ ELSE IF (LDA.LT.MAX(1,N)) THEN
+ INFO = 6
+ ELSE IF (INCX.EQ.0) THEN
+ INFO = 8
+ END IF
+ IF (INFO.NE.0) THEN
+ CALL XERBLA('STRSV ',INFO)
+ RETURN
+ END IF
+*
+* Quick return if possible.
+*
+ IF (N.EQ.0) RETURN
+*
+ NOUNIT = LSAME(DIAG,'N')
+*
+* Set up the start point in X if the increment is not unity. This
+* will be ( N - 1 )*INCX too small for descending loops.
+*
+ IF (INCX.LE.0) THEN
+ KX = 1 - (N-1)*INCX
+ ELSE IF (INCX.NE.1) THEN
+ KX = 1
+ END IF
+*
+* Start the operations. In this version the elements of A are
+* accessed sequentially with one pass through A.
+*
+ IF (LSAME(TRANS,'N')) THEN
+*
+* Form x := inv( A )*x.
+*
+ IF (LSAME(UPLO,'U')) THEN
+ IF (INCX.EQ.1) THEN
+ DO 20 J = N,1,-1
+ IF (X(J).NE.ZERO) THEN
+ IF (NOUNIT) X(J) = X(J)/A(J,J)
+ TEMP = X(J)
+ DO 10 I = J - 1,1,-1
+ X(I) = X(I) - TEMP*A(I,J)
+ 10 CONTINUE
+ END IF
+ 20 CONTINUE
+ ELSE
+ JX = KX + (N-1)*INCX
+ DO 40 J = N,1,-1
+ IF (X(JX).NE.ZERO) THEN
+ IF (NOUNIT) X(JX) = X(JX)/A(J,J)
+ TEMP = X(JX)
+ IX = JX
+ DO 30 I = J - 1,1,-1
+ IX = IX - INCX
+ X(IX) = X(IX) - TEMP*A(I,J)
+ 30 CONTINUE
+ END IF
+ JX = JX - INCX
+ 40 CONTINUE
+ END IF
+ ELSE
+ IF (INCX.EQ.1) THEN
+ DO 60 J = 1,N
+ IF (X(J).NE.ZERO) THEN
+ IF (NOUNIT) X(J) = X(J)/A(J,J)
+ TEMP = X(J)
+ DO 50 I = J + 1,N
+ X(I) = X(I) - TEMP*A(I,J)
+ 50 CONTINUE
+ END IF
+ 60 CONTINUE
+ ELSE
+ JX = KX
+ DO 80 J = 1,N
+ IF (X(JX).NE.ZERO) THEN
+ IF (NOUNIT) X(JX) = X(JX)/A(J,J)
+ TEMP = X(JX)
+ IX = JX
+ DO 70 I = J + 1,N
+ IX = IX + INCX
+ X(IX) = X(IX) - TEMP*A(I,J)
+ 70 CONTINUE
+ END IF
+ JX = JX + INCX
+ 80 CONTINUE
+ END IF
+ END IF
+ ELSE
+*
+* Form x := inv( A' )*x.
+*
+ IF (LSAME(UPLO,'U')) THEN
+ IF (INCX.EQ.1) THEN
+ DO 100 J = 1,N
+ TEMP = X(J)
+ DO 90 I = 1,J - 1
+ TEMP = TEMP - A(I,J)*X(I)
+ 90 CONTINUE
+ IF (NOUNIT) TEMP = TEMP/A(J,J)
+ X(J) = TEMP
+ 100 CONTINUE
+ ELSE
+ JX = KX
+ DO 120 J = 1,N
+ TEMP = X(JX)
+ IX = KX
+ DO 110 I = 1,J - 1
+ TEMP = TEMP - A(I,J)*X(IX)
+ IX = IX + INCX
+ 110 CONTINUE
+ IF (NOUNIT) TEMP = TEMP/A(J,J)
+ X(JX) = TEMP
+ JX = JX + INCX
+ 120 CONTINUE
+ END IF
+ ELSE
+ IF (INCX.EQ.1) THEN
+ DO 140 J = N,1,-1
+ TEMP = X(J)
+ DO 130 I = N,J + 1,-1
+ TEMP = TEMP - A(I,J)*X(I)
+ 130 CONTINUE
+ IF (NOUNIT) TEMP = TEMP/A(J,J)
+ X(J) = TEMP
+ 140 CONTINUE
+ ELSE
+ KX = KX + (N-1)*INCX
+ JX = KX
+ DO 160 J = N,1,-1
+ TEMP = X(JX)
+ IX = KX
+ DO 150 I = N,J + 1,-1
+ TEMP = TEMP - A(I,J)*X(IX)
+ IX = IX - INCX
+ 150 CONTINUE
+ IF (NOUNIT) TEMP = TEMP/A(J,J)
+ X(JX) = TEMP
+ JX = JX - INCX
+ 160 CONTINUE
+ END IF
+ END IF
+ END IF
+*
+ RETURN
+*
+* End of STRSV .
+*
+ END
diff --git a/jlapack-3.1.1/src/blas/verify_all.csh b/jlapack-3.1.1/src/blas/verify_all.csh
new file mode 100755
index 0000000..db42a7f
--- /dev/null
+++ b/jlapack-3.1.1/src/blas/verify_all.csh
@@ -0,0 +1,7 @@
+#!/bin/csh
+
+setenv CPTMP $CLASSPATH":../../error_reporting/xerbla.jar"
+cd obj
+foreach file(org/netlib/blas/*.class)
+ java -classpath $CPTMP de.fub.bytecode.verifier.Verifier $file
+end
diff --git a/jlapack-3.1.1/src/error_reporting/Makefile b/jlapack-3.1.1/src/error_reporting/Makefile
new file mode 100644
index 0000000..73a095e
--- /dev/null
+++ b/jlapack-3.1.1/src/error_reporting/Makefile
@@ -0,0 +1,20 @@
+.SUFFIXES: .f .java
+
+ROOT=../..
+include $(ROOT)/make.def
+
+F2JFLAGS=-c .:$(OUTDIR) -p $(ERR_PACKAGE) -o $(OUTDIR)
+
+$(ROOT)/$(ERR_IDX): err.f
+ $(F2J) $(F2JFLAGS) $? > /dev/null
+ cd $(OUTDIR); $(JAR) cvf ../$(ERR_JAR) `find . -name "*.class"`
+
+nojar: err.f
+ $(F2J) $(F2JFLAGS) $? > /dev/null
+
+
+javasrc:
+ $(MAKE) -f Makefile_javasrc
+
+clean:
+ /bin/rm -rf *.java *.class *.f2j $(OUTDIR) $(JAVASRC_OUTDIR) $(ERR_JAR)
diff --git a/jlapack-3.1.1/src/error_reporting/Makefile_javasrc b/jlapack-3.1.1/src/error_reporting/Makefile_javasrc
new file mode 100644
index 0000000..838b290
--- /dev/null
+++ b/jlapack-3.1.1/src/error_reporting/Makefile_javasrc
@@ -0,0 +1,19 @@
+.SUFFIXES: .f .java
+
+ROOT=../..
+include $(ROOT)/make.def
+
+$(ROOT)/$(ERR_IDX): $(ROOT)/$(UTIL_DIR)/$(UTIL_JAR) err.f
+ $(MAKE) nojar
+ /bin/rm -f `find . -name "*.class"`
+ mkdir -p $(JAVASRC_OUTDIR)
+ $(JAVAC) -classpath $(ROOT)/$(UTIL_DIR)/$(UTIL_JAR) -d $(JAVASRC_OUTDIR) $(OUTDIR)/$(ERR_PDIR)/*.java
+ /bin/rm -f $(JAVASRC_OUTDIR)/$(ERR_PDIR)/*.old
+ $(JAVAB) $(JAVASRC_OUTDIR)/$(ERR_PDIR)/*.class
+ cd $(JAVASRC_OUTDIR); $(JAR) cvf ../$(ERR_JAR) `find . -name "*.class"`
+
+$(ROOT)/$(UTIL_DIR)/$(UTIL_JAR):
+ cd $(ROOT)/$(UTIL_DIR); $(MAKE)
+
+clean:
+ /bin/rm -rf *.java *.class *.f2j $(OUTDIR) $(JAVASRC_OUTDIR) $(ERR_JAR)
diff --git a/jlapack-3.1.1/src/error_reporting/err.f b/jlapack-3.1.1/src/error_reporting/err.f
new file mode 100644
index 0000000..f72e350
--- /dev/null
+++ b/jlapack-3.1.1/src/error_reporting/err.f
@@ -0,0 +1,42 @@
+ SUBROUTINE XERBLA(SRNAME,INFO)
+*
+* -- LAPACK auxiliary routine (preliminary version) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INFO
+ CHARACTER*6 SRNAME
+* ..
+*
+* Purpose
+* =======
+*
+* XERBLA is an error handler for the LAPACK routines.
+* It is called by an LAPACK routine if an input parameter has an
+* invalid value. A message is printed and execution stops.
+*
+* Installers may consider modifying the STOP statement in order to
+* call system-specific exception-handling facilities.
+*
+* Arguments
+* =========
+*
+* SRNAME (input) CHARACTER*6
+* The name of the routine which called XERBLA.
+*
+* INFO (input) INTEGER
+* The position of the invalid parameter in the parameter list
+* of the calling routine.
+*
+*
+ WRITE (*,FMT=9999) SRNAME,INFO
+*
+ STOP
+*
+ 9999 FORMAT (' ** On entry to ',A6,' parameter number ',I2,' had ',
+ + 'an illegal value')
+*
+* End of XERBLA
+*
+ END
diff --git a/jlapack-3.1.1/src/lapack/Makefile b/jlapack-3.1.1/src/lapack/Makefile
new file mode 100644
index 0000000..e08e89b
--- /dev/null
+++ b/jlapack-3.1.1/src/lapack/Makefile
@@ -0,0 +1,33 @@
+.SUFFIXES: .f .java
+
+ROOT=../..
+
+include $(ROOT)/make.def
+
+F2JFLAGS=-c .:$(OUTDIR):$(ROOT)/$(ERR_OBJ):$(ROOT)/$(BLAS_OBJ) -p $(LAPACK_PACKAGE) -o $(OUTDIR) -s -d $(STATIC)
+
+$(ROOT)/$(LAPACK_IDX): $(ROOT)/$(BLAS_DIR)/$(BLAS_JAR) $(ROOT)/$(ERR_DIR)/$(ERR_JAR) lapack.f
+ $(F2J) $(F2JFLAGS) lapack.f > /dev/null
+ cd $(OUTDIR); $(JAR) cvf ../$(LAPACK_JAR) `find . -name "*.class"`
+ mkdir -p $(SIMPLE_DIR)/$(LAPACK_PDIR)
+ -cp `find $(OUTDIR)/$(LAPACK_PDIR) -name "[A-Z][A-Z]*.java"` $(SIMPLE_DIR)/$(LAPACK_PDIR)
+ -$(JAVAC) -classpath .:$(ROOT)/$(BLAS_DIR)/$(BLAS_JAR):$(LAPACK_JAR):$(SIMPLE_DIR):$(ROOT)/$(UTIL_DIR)/$(UTIL_JAR):$(ROOT)/$(ERR_DIR)/$(ERR_JAR) $(SIMPLE_DIR)/$(LAPACK_PDIR)/*.java
+ cd $(SIMPLE_DIR); $(JAR) cvf ../$(SIMPLE_LAPACK_JAR) `find . -name "*.class"`
+
+nojar: $(ROOT)/$(BLAS_DIR)/$(BLAS_JAR) $(ROOT)/$(ERR_DIR)/$(ERR_JAR) lapack.f
+ $(F2J) $(F2JFLAGS) lapack.f > /dev/null
+
+$(ROOT)/$(BLAS_DIR)/$(BLAS_JAR):
+ cd $(ROOT)/$(BLAS_DIR);$(MAKE)
+
+$(ROOT)/$(ERR_DIR)/$(ERR_JAR):
+ cd $(ROOT)/$(ERR_DIR);$(MAKE)
+
+javasrc:
+ $(MAKE) -f Makefile_javasrc
+
+verify: $(LAPACK_JAR)
+ cd $(OUTDIR); $(JAVA) $(MORE_MEM_FLAG) -classpath .:$(JUSTICE):$(BCEL):$(ROOT)/../$(UTIL_DIR)/$(UTIL_JAR):$(ROOT)/../$(ERR_DIR)/$(ERR_JAR):$(ROOT)/../$(BLAS_DIR)/$(BLAS_JAR) $(VERIFY) $(LAPACK_PDIR)/*.class
+
+clean:
+ /bin/rm -rf *.java *.class *.f2j $(SIMPLE_LAPACK_JAR) $(LAPACK_JAR) $(OUTDIR) $(JAVASRC_OUTDIR) $(SIMPLE_DIR)
diff --git a/jlapack-3.1.1/src/lapack/Makefile_javasrc b/jlapack-3.1.1/src/lapack/Makefile_javasrc
new file mode 100644
index 0000000..af8b863
--- /dev/null
+++ b/jlapack-3.1.1/src/lapack/Makefile_javasrc
@@ -0,0 +1,32 @@
+.SUFFIXES: .f .java
+
+ROOT=../..
+
+include $(ROOT)/make.def
+
+$(LAPACK_JAR): $(ROOT)/$(UTIL_DIR)/$(UTIL_JAR) $(ROOT)/$(BLAS_DIR)/$(BLAS_JAR) $(ROOT)/$(ERR_DIR)/$(ERR_JAR) lapack.f
+ $(MAKE) nojar
+ /bin/rm -f `find . -name "*.class"`
+ mkdir -p $(JAVASRC_OUTDIR)
+ $(JAVAC) -J$(MORE_MEM_FLAG) -classpath $(ROOT)/$(UTIL_DIR)/$(UTIL_JAR):$(ROOT)/$(ERR_DIR)/$(ERR_JAR):$(ROOT)/$(BLAS_DIR)/$(BLAS_JAR) -d $(JAVASRC_OUTDIR) $(OUTDIR)/$(LAPACK_PDIR)/*.java
+ /bin/rm -f $(JAVASRC_OUTDIR)/$(LAPACK_PDIR)/*.old
+ $(JAVAB) $(JAVASRC_OUTDIR)/$(LAPACK_PDIR)/*.class
+ mkdir -p $(SIMPLE_DIR)/$(LAPACK_PDIR)
+ -mv `find $(JAVASRC_OUTDIR) -name "[A-Z][A-Z]*.class"` $(SIMPLE_DIR)/$(LAPACK_PDIR)
+ cd $(JAVASRC_OUTDIR); $(JAR) cvf ../$(LAPACK_JAR) `find . -name "*.class"`
+ cd $(SIMPLE_DIR); $(JAR) cvf ../$(SIMPLE_LAPACK_JAR) `find . -name "*.class"`
+
+$(ROOT)/$(UTIL_DIR)/$(UTIL_JAR):
+ cd $(ROOT)/$(UTIL_DIR); $(MAKE)
+
+$(ROOT)/$(BLAS_DIR)/$(BLAS_JAR):
+ cd $(ROOT)/$(BLAS_DIR); $(MAKE) -f Makefile_javasrc
+
+$(ROOT)/$(ERR_DIR)/$(ERR_JAR):
+ cd $(ROOT)/$(ERR_DIR); $(MAKE) -f Makefile_javasrc
+
+verify: $(LAPACK_JAR)
+ cd $(JAVASRC_OUTDIR); $(JAVA) $(MORE_MEM_FLAG) -classpath .:$(JUSTICE):$(BCEL):$(ROOT)/../$(UTIL_DIR)/$(UTIL_JAR):$(ROOT)/../$(ERR_DIR)/$(ERR_JAR):$(ROOT)/../$(BLAS_DIR)/$(BLAS_JAR) $(VERIFY) $(LAPACK_PDIR)/*.class
+
+clean:
+ /bin/rm -rf *.java *.class *.f2j $(LAPACK_JAR) $(OUTDIR) $(JAVASRC_OUTDIR)
diff --git a/jlapack-3.1.1/src/lapack/lapack.f b/jlapack-3.1.1/src/lapack/lapack.f
new file mode 100644
index 0000000..06b648c
--- /dev/null
+++ b/jlapack-3.1.1/src/lapack/lapack.f
@@ -0,0 +1,221504 @@
+ SUBROUTINE DBDSDC( UPLO, COMPQ, N, D, E, U, LDU, VT, LDVT, Q, IQ,
+ $ WORK, IWORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER COMPQ, UPLO
+ INTEGER INFO, LDU, LDVT, N
+* ..
+* .. Array Arguments ..
+ INTEGER IQ( * ), IWORK( * )
+ DOUBLE PRECISION D( * ), E( * ), Q( * ), U( LDU, * ),
+ $ VT( LDVT, * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DBDSDC computes the singular value decomposition (SVD) of a real
+* N-by-N (upper or lower) bidiagonal matrix B: B = U * S * VT,
+* using a divide and conquer method, where S is a diagonal matrix
+* with non-negative diagonal elements (the singular values of B), and
+* U and VT are orthogonal matrices of left and right singular vectors,
+* respectively. DBDSDC can be used to compute all singular values,
+* and optionally, singular vectors or singular vectors in compact form.
+*
+* This code makes very mild assumptions about floating point
+* arithmetic. It will work on machines with a guard digit in
+* add/subtract, or on those binary machines without guard digits
+* which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2.
+* It could conceivably fail on hexadecimal or decimal machines
+* without guard digits, but we know of none. See DLASD3 for details.
+*
+* The code currently calls DLASDQ if singular values only are desired.
+* However, it can be slightly modified to compute singular values
+* using the divide and conquer method.
+*
+* Arguments
+* =========
+*
+* UPLO (input) CHARACTER*1
+* = 'U': B is upper bidiagonal.
+* = 'L': B is lower bidiagonal.
+*
+* COMPQ (input) CHARACTER*1
+* Specifies whether singular vectors are to be computed
+* as follows:
+* = 'N': Compute singular values only;
+* = 'P': Compute singular values and compute singular
+* vectors in compact form;
+* = 'I': Compute singular values and singular vectors.
+*
+* N (input) INTEGER
+* The order of the matrix B. N >= 0.
+*
+* D (input/output) DOUBLE PRECISION array, dimension (N)
+* On entry, the n diagonal elements of the bidiagonal matrix B.
+* On exit, if INFO=0, the singular values of B.
+*
+* E (input/output) DOUBLE PRECISION array, dimension (N-1)
+* On entry, the elements of E contain the offdiagonal
+* elements of the bidiagonal matrix whose SVD is desired.
+* On exit, E has been destroyed.
+*
+* U (output) DOUBLE PRECISION array, dimension (LDU,N)
+* If COMPQ = 'I', then:
+* On exit, if INFO = 0, U contains the left singular vectors
+* of the bidiagonal matrix.
+* For other values of COMPQ, U is not referenced.
+*
+* LDU (input) INTEGER
+* The leading dimension of the array U. LDU >= 1.
+* If singular vectors are desired, then LDU >= max( 1, N ).
+*
+* VT (output) DOUBLE PRECISION array, dimension (LDVT,N)
+* If COMPQ = 'I', then:
+* On exit, if INFO = 0, VT' contains the right singular
+* vectors of the bidiagonal matrix.
+* For other values of COMPQ, VT is not referenced.
+*
+* LDVT (input) INTEGER
+* The leading dimension of the array VT. LDVT >= 1.
+* If singular vectors are desired, then LDVT >= max( 1, N ).
+*
+* Q (output) DOUBLE PRECISION array, dimension (LDQ)
+* If COMPQ = 'P', then:
+* On exit, if INFO = 0, Q and IQ contain the left
+* and right singular vectors in a compact form,
+* requiring O(N log N) space instead of 2*N**2.
+* In particular, Q contains all the DOUBLE PRECISION data in
+* LDQ >= N*(11 + 2*SMLSIZ + 8*INT(LOG_2(N/(SMLSIZ+1))))
+* words of memory, where SMLSIZ is returned by ILAENV and
+* is equal to the maximum size of the subproblems at the
+* bottom of the computation tree (usually about 25).
+* For other values of COMPQ, Q is not referenced.
+*
+* IQ (output) INTEGER array, dimension (LDIQ)
+* If COMPQ = 'P', then:
+* On exit, if INFO = 0, Q and IQ contain the left
+* and right singular vectors in a compact form,
+* requiring O(N log N) space instead of 2*N**2.
+* In particular, IQ contains all INTEGER data in
+* LDIQ >= N*(3 + 3*INT(LOG_2(N/(SMLSIZ+1))))
+* words of memory, where SMLSIZ is returned by ILAENV and
+* is equal to the maximum size of the subproblems at the
+* bottom of the computation tree (usually about 25).
+* For other values of COMPQ, IQ is not referenced.
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
+* If COMPQ = 'N' then LWORK >= (4 * N).
+* If COMPQ = 'P' then LWORK >= (6 * N).
+* If COMPQ = 'I' then LWORK >= (3 * N**2 + 4 * N).
+*
+* IWORK (workspace) INTEGER array, dimension (8*N)
+*
+* INFO (output) INTEGER
+* = 0: successful exit.
+* < 0: if INFO = -i, the i-th argument had an illegal value.
+* > 0: The algorithm failed to compute an singular value.
+* The update process of divide and conquer failed.
+*
+* Further Details
+* ===============
+*
+* Based on contributions by
+* Ming Gu and Huan Ren, Computer Science Division, University of
+* California at Berkeley, USA
+*
+* =====================================================================
+* Changed dimension statement in comment describing E from (N) to
+* (N-1). Sven, 17 Feb 05.
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE, TWO
+ PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER DIFL, DIFR, GIVCOL, GIVNUM, GIVPTR, I, IC,
+ $ ICOMPQ, IERR, II, IS, IU, IUPLO, IVT, J, K, KK,
+ $ MLVL, NM1, NSIZE, PERM, POLES, QSTART, SMLSIZ,
+ $ SMLSZP, SQRE, START, WSTART, Z
+ DOUBLE PRECISION CS, EPS, ORGNRM, P, R, SN
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ILAENV
+ DOUBLE PRECISION DLAMCH, DLANST
+ EXTERNAL LSAME, ILAENV, DLAMCH, DLANST
+* ..
+* .. External Subroutines ..
+ EXTERNAL DCOPY, DLARTG, DLASCL, DLASD0, DLASDA, DLASDQ,
+ $ DLASET, DLASR, DSWAP, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, DBLE, INT, LOG, SIGN
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+*
+ IUPLO = 0
+ IF( LSAME( UPLO, 'U' ) )
+ $ IUPLO = 1
+ IF( LSAME( UPLO, 'L' ) )
+ $ IUPLO = 2
+ IF( LSAME( COMPQ, 'N' ) ) THEN
+ ICOMPQ = 0
+ ELSE IF( LSAME( COMPQ, 'P' ) ) THEN
+ ICOMPQ = 1
+ ELSE IF( LSAME( COMPQ, 'I' ) ) THEN
+ ICOMPQ = 2
+ ELSE
+ ICOMPQ = -1
+ END IF
+ IF( IUPLO.EQ.0 ) THEN
+ INFO = -1
+ ELSE IF( ICOMPQ.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( ( LDU.LT.1 ) .OR. ( ( ICOMPQ.EQ.2 ) .AND. ( LDU.LT.
+ $ N ) ) ) THEN
+ INFO = -7
+ ELSE IF( ( LDVT.LT.1 ) .OR. ( ( ICOMPQ.EQ.2 ) .AND. ( LDVT.LT.
+ $ N ) ) ) THEN
+ INFO = -9
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DBDSDC', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 )
+ $ RETURN
+ SMLSIZ = ILAENV( 9, 'DBDSDC', ' ', 0, 0, 0, 0 )
+ IF( N.EQ.1 ) THEN
+ IF( ICOMPQ.EQ.1 ) THEN
+ Q( 1 ) = SIGN( ONE, D( 1 ) )
+ Q( 1+SMLSIZ*N ) = ONE
+ ELSE IF( ICOMPQ.EQ.2 ) THEN
+ U( 1, 1 ) = SIGN( ONE, D( 1 ) )
+ VT( 1, 1 ) = ONE
+ END IF
+ D( 1 ) = ABS( D( 1 ) )
+ RETURN
+ END IF
+ NM1 = N - 1
+*
+* If matrix lower bidiagonal, rotate to be upper bidiagonal
+* by applying Givens rotations on the left
+*
+ WSTART = 1
+ QSTART = 3
+ IF( ICOMPQ.EQ.1 ) THEN
+ CALL DCOPY( N, D, 1, Q( 1 ), 1 )
+ CALL DCOPY( N-1, E, 1, Q( N+1 ), 1 )
+ END IF
+ IF( IUPLO.EQ.2 ) THEN
+ QSTART = 5
+ WSTART = 2*N - 1
+ DO 10 I = 1, N - 1
+ CALL DLARTG( D( I ), E( I ), CS, SN, R )
+ D( I ) = R
+ E( I ) = SN*D( I+1 )
+ D( I+1 ) = CS*D( I+1 )
+ IF( ICOMPQ.EQ.1 ) THEN
+ Q( I+2*N ) = CS
+ Q( I+3*N ) = SN
+ ELSE IF( ICOMPQ.EQ.2 ) THEN
+ WORK( I ) = CS
+ WORK( NM1+I ) = -SN
+ END IF
+ 10 CONTINUE
+ END IF
+*
+* If ICOMPQ = 0, use DLASDQ to compute the singular values.
+*
+ IF( ICOMPQ.EQ.0 ) THEN
+ CALL DLASDQ( 'U', 0, N, 0, 0, 0, D, E, VT, LDVT, U, LDU, U,
+ $ LDU, WORK( WSTART ), INFO )
+ GO TO 40
+ END IF
+*
+* If N is smaller than the minimum divide size SMLSIZ, then solve
+* the problem with another solver.
+*
+ IF( N.LE.SMLSIZ ) THEN
+ IF( ICOMPQ.EQ.2 ) THEN
+ CALL DLASET( 'A', N, N, ZERO, ONE, U, LDU )
+ CALL DLASET( 'A', N, N, ZERO, ONE, VT, LDVT )
+ CALL DLASDQ( 'U', 0, N, N, N, 0, D, E, VT, LDVT, U, LDU, U,
+ $ LDU, WORK( WSTART ), INFO )
+ ELSE IF( ICOMPQ.EQ.1 ) THEN
+ IU = 1
+ IVT = IU + N
+ CALL DLASET( 'A', N, N, ZERO, ONE, Q( IU+( QSTART-1 )*N ),
+ $ N )
+ CALL DLASET( 'A', N, N, ZERO, ONE, Q( IVT+( QSTART-1 )*N ),
+ $ N )
+ CALL DLASDQ( 'U', 0, N, N, N, 0, D, E,
+ $ Q( IVT+( QSTART-1 )*N ), N,
+ $ Q( IU+( QSTART-1 )*N ), N,
+ $ Q( IU+( QSTART-1 )*N ), N, WORK( WSTART ),
+ $ INFO )
+ END IF
+ GO TO 40
+ END IF
+*
+ IF( ICOMPQ.EQ.2 ) THEN
+ CALL DLASET( 'A', N, N, ZERO, ONE, U, LDU )
+ CALL DLASET( 'A', N, N, ZERO, ONE, VT, LDVT )
+ END IF
+*
+* Scale.
+*
+ ORGNRM = DLANST( 'M', N, D, E )
+ IF( ORGNRM.EQ.ZERO )
+ $ RETURN
+ CALL DLASCL( 'G', 0, 0, ORGNRM, ONE, N, 1, D, N, IERR )
+ CALL DLASCL( 'G', 0, 0, ORGNRM, ONE, NM1, 1, E, NM1, IERR )
+*
+ EPS = DLAMCH( 'Epsilon' )
+*
+ MLVL = INT( LOG( DBLE( N ) / DBLE( SMLSIZ+1 ) ) / LOG( TWO ) ) + 1
+ SMLSZP = SMLSIZ + 1
+*
+ IF( ICOMPQ.EQ.1 ) THEN
+ IU = 1
+ IVT = 1 + SMLSIZ
+ DIFL = IVT + SMLSZP
+ DIFR = DIFL + MLVL
+ Z = DIFR + MLVL*2
+ IC = Z + MLVL
+ IS = IC + 1
+ POLES = IS + 1
+ GIVNUM = POLES + 2*MLVL
+*
+ K = 1
+ GIVPTR = 2
+ PERM = 3
+ GIVCOL = PERM + MLVL
+ END IF
+*
+ DO 20 I = 1, N
+ IF( ABS( D( I ) ).LT.EPS ) THEN
+ D( I ) = SIGN( EPS, D( I ) )
+ END IF
+ 20 CONTINUE
+*
+ START = 1
+ SQRE = 0
+*
+ DO 30 I = 1, NM1
+ IF( ( ABS( E( I ) ).LT.EPS ) .OR. ( I.EQ.NM1 ) ) THEN
+*
+* Subproblem found. First determine its size and then
+* apply divide and conquer on it.
+*
+ IF( I.LT.NM1 ) THEN
+*
+* A subproblem with E(I) small for I < NM1.
+*
+ NSIZE = I - START + 1
+ ELSE IF( ABS( E( I ) ).GE.EPS ) THEN
+*
+* A subproblem with E(NM1) not too small but I = NM1.
+*
+ NSIZE = N - START + 1
+ ELSE
+*
+* A subproblem with E(NM1) small. This implies an
+* 1-by-1 subproblem at D(N). Solve this 1-by-1 problem
+* first.
+*
+ NSIZE = I - START + 1
+ IF( ICOMPQ.EQ.2 ) THEN
+ U( N, N ) = SIGN( ONE, D( N ) )
+ VT( N, N ) = ONE
+ ELSE IF( ICOMPQ.EQ.1 ) THEN
+ Q( N+( QSTART-1 )*N ) = SIGN( ONE, D( N ) )
+ Q( N+( SMLSIZ+QSTART-1 )*N ) = ONE
+ END IF
+ D( N ) = ABS( D( N ) )
+ END IF
+ IF( ICOMPQ.EQ.2 ) THEN
+ CALL DLASD0( NSIZE, SQRE, D( START ), E( START ),
+ $ U( START, START ), LDU, VT( START, START ),
+ $ LDVT, SMLSIZ, IWORK, WORK( WSTART ), INFO )
+ ELSE
+ CALL DLASDA( ICOMPQ, SMLSIZ, NSIZE, SQRE, D( START ),
+ $ E( START ), Q( START+( IU+QSTART-2 )*N ), N,
+ $ Q( START+( IVT+QSTART-2 )*N ),
+ $ IQ( START+K*N ), Q( START+( DIFL+QSTART-2 )*
+ $ N ), Q( START+( DIFR+QSTART-2 )*N ),
+ $ Q( START+( Z+QSTART-2 )*N ),
+ $ Q( START+( POLES+QSTART-2 )*N ),
+ $ IQ( START+GIVPTR*N ), IQ( START+GIVCOL*N ),
+ $ N, IQ( START+PERM*N ),
+ $ Q( START+( GIVNUM+QSTART-2 )*N ),
+ $ Q( START+( IC+QSTART-2 )*N ),
+ $ Q( START+( IS+QSTART-2 )*N ),
+ $ WORK( WSTART ), IWORK, INFO )
+ IF( INFO.NE.0 ) THEN
+ RETURN
+ END IF
+ END IF
+ START = I + 1
+ END IF
+ 30 CONTINUE
+*
+* Unscale
+*
+ CALL DLASCL( 'G', 0, 0, ONE, ORGNRM, N, 1, D, N, IERR )
+ 40 CONTINUE
+*
+* Use Selection Sort to minimize swaps of singular vectors
+*
+ DO 60 II = 2, N
+ I = II - 1
+ KK = I
+ P = D( I )
+ DO 50 J = II, N
+ IF( D( J ).GT.P ) THEN
+ KK = J
+ P = D( J )
+ END IF
+ 50 CONTINUE
+ IF( KK.NE.I ) THEN
+ D( KK ) = D( I )
+ D( I ) = P
+ IF( ICOMPQ.EQ.1 ) THEN
+ IQ( I ) = KK
+ ELSE IF( ICOMPQ.EQ.2 ) THEN
+ CALL DSWAP( N, U( 1, I ), 1, U( 1, KK ), 1 )
+ CALL DSWAP( N, VT( I, 1 ), LDVT, VT( KK, 1 ), LDVT )
+ END IF
+ ELSE IF( ICOMPQ.EQ.1 ) THEN
+ IQ( I ) = I
+ END IF
+ 60 CONTINUE
+*
+* If ICOMPQ = 1, use IQ(N,1) as the indicator for UPLO
+*
+ IF( ICOMPQ.EQ.1 ) THEN
+ IF( IUPLO.EQ.1 ) THEN
+ IQ( N ) = 1
+ ELSE
+ IQ( N ) = 0
+ END IF
+ END IF
+*
+* If B is lower bidiagonal, update U by those Givens rotations
+* which rotated B to be upper bidiagonal
+*
+ IF( ( IUPLO.EQ.2 ) .AND. ( ICOMPQ.EQ.2 ) )
+ $ CALL DLASR( 'L', 'V', 'B', N, N, WORK( 1 ), WORK( N ), U, LDU )
+*
+ RETURN
+*
+* End of DBDSDC
+*
+ END
+ SUBROUTINE DBDSQR( UPLO, N, NCVT, NRU, NCC, D, E, VT, LDVT, U,
+ $ LDU, C, LDC, WORK, INFO )
+*
+* -- LAPACK routine (version 3.1.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* January 2007
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, LDC, LDU, LDVT, N, NCC, NCVT, NRU
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION C( LDC, * ), D( * ), E( * ), U( LDU, * ),
+ $ VT( LDVT, * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DBDSQR computes the singular values and, optionally, the right and/or
+* left singular vectors from the singular value decomposition (SVD) of
+* a real N-by-N (upper or lower) bidiagonal matrix B using the implicit
+* zero-shift QR algorithm. The SVD of B has the form
+*
+* B = Q * S * P**T
+*
+* where S is the diagonal matrix of singular values, Q is an orthogonal
+* matrix of left singular vectors, and P is an orthogonal matrix of
+* right singular vectors. If left singular vectors are requested, this
+* subroutine actually returns U*Q instead of Q, and, if right singular
+* vectors are requested, this subroutine returns P**T*VT instead of
+* P**T, for given real input matrices U and VT. When U and VT are the
+* orthogonal matrices that reduce a general matrix A to bidiagonal
+* form: A = U*B*VT, as computed by DGEBRD, then
+*
+* A = (U*Q) * S * (P**T*VT)
+*
+* is the SVD of A. Optionally, the subroutine may also compute Q**T*C
+* for a given real input matrix C.
+*
+* See "Computing Small Singular Values of Bidiagonal Matrices With
+* Guaranteed High Relative Accuracy," by J. Demmel and W. Kahan,
+* LAPACK Working Note #3 (or SIAM J. Sci. Statist. Comput. vol. 11,
+* no. 5, pp. 873-912, Sept 1990) and
+* "Accurate singular values and differential qd algorithms," by
+* B. Parlett and V. Fernando, Technical Report CPAM-554, Mathematics
+* Department, University of California at Berkeley, July 1992
+* for a detailed description of the algorithm.
+*
+* Arguments
+* =========
+*
+* UPLO (input) CHARACTER*1
+* = 'U': B is upper bidiagonal;
+* = 'L': B is lower bidiagonal.
+*
+* N (input) INTEGER
+* The order of the matrix B. N >= 0.
+*
+* NCVT (input) INTEGER
+* The number of columns of the matrix VT. NCVT >= 0.
+*
+* NRU (input) INTEGER
+* The number of rows of the matrix U. NRU >= 0.
+*
+* NCC (input) INTEGER
+* The number of columns of the matrix C. NCC >= 0.
+*
+* D (input/output) DOUBLE PRECISION array, dimension (N)
+* On entry, the n diagonal elements of the bidiagonal matrix B.
+* On exit, if INFO=0, the singular values of B in decreasing
+* order.
+*
+* E (input/output) DOUBLE PRECISION array, dimension (N-1)
+* On entry, the N-1 offdiagonal elements of the bidiagonal
+* matrix B.
+* On exit, if INFO = 0, E is destroyed; if INFO > 0, D and E
+* will contain the diagonal and superdiagonal elements of a
+* bidiagonal matrix orthogonally equivalent to the one given
+* as input.
+*
+* VT (input/output) DOUBLE PRECISION array, dimension (LDVT, NCVT)
+* On entry, an N-by-NCVT matrix VT.
+* On exit, VT is overwritten by P**T * VT.
+* Not referenced if NCVT = 0.
+*
+* LDVT (input) INTEGER
+* The leading dimension of the array VT.
+* LDVT >= max(1,N) if NCVT > 0; LDVT >= 1 if NCVT = 0.
+*
+* U (input/output) DOUBLE PRECISION array, dimension (LDU, N)
+* On entry, an NRU-by-N matrix U.
+* On exit, U is overwritten by U * Q.
+* Not referenced if NRU = 0.
+*
+* LDU (input) INTEGER
+* The leading dimension of the array U. LDU >= max(1,NRU).
+*
+* C (input/output) DOUBLE PRECISION array, dimension (LDC, NCC)
+* On entry, an N-by-NCC matrix C.
+* On exit, C is overwritten by Q**T * C.
+* Not referenced if NCC = 0.
+*
+* LDC (input) INTEGER
+* The leading dimension of the array C.
+* LDC >= max(1,N) if NCC > 0; LDC >=1 if NCC = 0.
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (2*N)
+* if NCVT = NRU = NCC = 0, (max(1, 4*N)) otherwise
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: If INFO = -i, the i-th argument had an illegal value
+* > 0: the algorithm did not converge; D and E contain the
+* elements of a bidiagonal matrix which is orthogonally
+* similar to the input matrix B; if INFO = i, i
+* elements of E have not converged to zero.
+*
+* Internal Parameters
+* ===================
+*
+* TOLMUL DOUBLE PRECISION, default = max(10,min(100,EPS**(-1/8)))
+* TOLMUL controls the convergence criterion of the QR loop.
+* If it is positive, TOLMUL*EPS is the desired relative
+* precision in the computed singular values.
+* If it is negative, abs(TOLMUL*EPS*sigma_max) is the
+* desired absolute accuracy in the computed singular
+* values (corresponds to relative accuracy
+* abs(TOLMUL*EPS) in the largest singular value.
+* abs(TOLMUL) should be between 1 and 1/EPS, and preferably
+* between 10 (for fast convergence) and .1/EPS
+* (for there to be some accuracy in the results).
+* Default is to lose at either one eighth or 2 of the
+* available decimal digits in each computed singular value
+* (whichever is smaller).
+*
+* MAXITR INTEGER, default = 6
+* MAXITR controls the maximum number of passes of the
+* algorithm through its inner loop. The algorithms stops
+* (and so fails to converge) if the number of passes
+* through the inner loop exceeds MAXITR*N**2.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO
+ PARAMETER ( ZERO = 0.0D0 )
+ DOUBLE PRECISION ONE
+ PARAMETER ( ONE = 1.0D0 )
+ DOUBLE PRECISION NEGONE
+ PARAMETER ( NEGONE = -1.0D0 )
+ DOUBLE PRECISION HNDRTH
+ PARAMETER ( HNDRTH = 0.01D0 )
+ DOUBLE PRECISION TEN
+ PARAMETER ( TEN = 10.0D0 )
+ DOUBLE PRECISION HNDRD
+ PARAMETER ( HNDRD = 100.0D0 )
+ DOUBLE PRECISION MEIGTH
+ PARAMETER ( MEIGTH = -0.125D0 )
+ INTEGER MAXITR
+ PARAMETER ( MAXITR = 6 )
+* ..
+* .. Local Scalars ..
+ LOGICAL LOWER, ROTATE
+ INTEGER I, IDIR, ISUB, ITER, J, LL, LLL, M, MAXIT, NM1,
+ $ NM12, NM13, OLDLL, OLDM
+ DOUBLE PRECISION ABSE, ABSS, COSL, COSR, CS, EPS, F, G, H, MU,
+ $ OLDCS, OLDSN, R, SHIFT, SIGMN, SIGMX, SINL,
+ $ SINR, SLL, SMAX, SMIN, SMINL, SMINOA,
+ $ SN, THRESH, TOL, TOLMUL, UNFL
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ DOUBLE PRECISION DLAMCH
+ EXTERNAL LSAME, DLAMCH
+* ..
+* .. External Subroutines ..
+ EXTERNAL DLARTG, DLAS2, DLASQ1, DLASR, DLASV2, DROT,
+ $ DSCAL, DSWAP, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, DBLE, MAX, MIN, SIGN, SQRT
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ LOWER = LSAME( UPLO, 'L' )
+ IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LOWER ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( NCVT.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( NRU.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( NCC.LT.0 ) THEN
+ INFO = -5
+ ELSE IF( ( NCVT.EQ.0 .AND. LDVT.LT.1 ) .OR.
+ $ ( NCVT.GT.0 .AND. LDVT.LT.MAX( 1, N ) ) ) THEN
+ INFO = -9
+ ELSE IF( LDU.LT.MAX( 1, NRU ) ) THEN
+ INFO = -11
+ ELSE IF( ( NCC.EQ.0 .AND. LDC.LT.1 ) .OR.
+ $ ( NCC.GT.0 .AND. LDC.LT.MAX( 1, N ) ) ) THEN
+ INFO = -13
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DBDSQR', -INFO )
+ RETURN
+ END IF
+ IF( N.EQ.0 )
+ $ RETURN
+ IF( N.EQ.1 )
+ $ GO TO 160
+*
+* ROTATE is true if any singular vectors desired, false otherwise
+*
+ ROTATE = ( NCVT.GT.0 ) .OR. ( NRU.GT.0 ) .OR. ( NCC.GT.0 )
+*
+* If no singular vectors desired, use qd algorithm
+*
+ IF( .NOT.ROTATE ) THEN
+ CALL DLASQ1( N, D, E, WORK, INFO )
+ RETURN
+ END IF
+*
+ NM1 = N - 1
+ NM12 = NM1 + NM1
+ NM13 = NM12 + NM1
+ IDIR = 0
+*
+* Get machine constants
+*
+ EPS = DLAMCH( 'Epsilon' )
+ UNFL = DLAMCH( 'Safe minimum' )
+*
+* If matrix lower bidiagonal, rotate to be upper bidiagonal
+* by applying Givens rotations on the left
+*
+ IF( LOWER ) THEN
+ DO 10 I = 1, N - 1
+ CALL DLARTG( D( I ), E( I ), CS, SN, R )
+ D( I ) = R
+ E( I ) = SN*D( I+1 )
+ D( I+1 ) = CS*D( I+1 )
+ WORK( I ) = CS
+ WORK( NM1+I ) = SN
+ 10 CONTINUE
+*
+* Update singular vectors if desired
+*
+ IF( NRU.GT.0 )
+ $ CALL DLASR( 'R', 'V', 'F', NRU, N, WORK( 1 ), WORK( N ), U,
+ $ LDU )
+ IF( NCC.GT.0 )
+ $ CALL DLASR( 'L', 'V', 'F', N, NCC, WORK( 1 ), WORK( N ), C,
+ $ LDC )
+ END IF
+*
+* Compute singular values to relative accuracy TOL
+* (By setting TOL to be negative, algorithm will compute
+* singular values to absolute accuracy ABS(TOL)*norm(input matrix))
+*
+ TOLMUL = MAX( TEN, MIN( HNDRD, EPS**MEIGTH ) )
+ TOL = TOLMUL*EPS
+*
+* Compute approximate maximum, minimum singular values
+*
+ SMAX = ZERO
+ DO 20 I = 1, N
+ SMAX = MAX( SMAX, ABS( D( I ) ) )
+ 20 CONTINUE
+ DO 30 I = 1, N - 1
+ SMAX = MAX( SMAX, ABS( E( I ) ) )
+ 30 CONTINUE
+ SMINL = ZERO
+ IF( TOL.GE.ZERO ) THEN
+*
+* Relative accuracy desired
+*
+ SMINOA = ABS( D( 1 ) )
+ IF( SMINOA.EQ.ZERO )
+ $ GO TO 50
+ MU = SMINOA
+ DO 40 I = 2, N
+ MU = ABS( D( I ) )*( MU / ( MU+ABS( E( I-1 ) ) ) )
+ SMINOA = MIN( SMINOA, MU )
+ IF( SMINOA.EQ.ZERO )
+ $ GO TO 50
+ 40 CONTINUE
+ 50 CONTINUE
+ SMINOA = SMINOA / SQRT( DBLE( N ) )
+ THRESH = MAX( TOL*SMINOA, MAXITR*N*N*UNFL )
+ ELSE
+*
+* Absolute accuracy desired
+*
+ THRESH = MAX( ABS( TOL )*SMAX, MAXITR*N*N*UNFL )
+ END IF
+*
+* Prepare for main iteration loop for the singular values
+* (MAXIT is the maximum number of passes through the inner
+* loop permitted before nonconvergence signalled.)
+*
+ MAXIT = MAXITR*N*N
+ ITER = 0
+ OLDLL = -1
+ OLDM = -1
+*
+* M points to last element of unconverged part of matrix
+*
+ M = N
+*
+* Begin main iteration loop
+*
+ 60 CONTINUE
+*
+* Check for convergence or exceeding iteration count
+*
+ IF( M.LE.1 )
+ $ GO TO 160
+ IF( ITER.GT.MAXIT )
+ $ GO TO 200
+*
+* Find diagonal block of matrix to work on
+*
+ IF( TOL.LT.ZERO .AND. ABS( D( M ) ).LE.THRESH )
+ $ D( M ) = ZERO
+ SMAX = ABS( D( M ) )
+ SMIN = SMAX
+ DO 70 LLL = 1, M - 1
+ LL = M - LLL
+ ABSS = ABS( D( LL ) )
+ ABSE = ABS( E( LL ) )
+ IF( TOL.LT.ZERO .AND. ABSS.LE.THRESH )
+ $ D( LL ) = ZERO
+ IF( ABSE.LE.THRESH )
+ $ GO TO 80
+ SMIN = MIN( SMIN, ABSS )
+ SMAX = MAX( SMAX, ABSS, ABSE )
+ 70 CONTINUE
+ LL = 0
+ GO TO 90
+ 80 CONTINUE
+ E( LL ) = ZERO
+*
+* Matrix splits since E(LL) = 0
+*
+ IF( LL.EQ.M-1 ) THEN
+*
+* Convergence of bottom singular value, return to top of loop
+*
+ M = M - 1
+ GO TO 60
+ END IF
+ 90 CONTINUE
+ LL = LL + 1
+*
+* E(LL) through E(M-1) are nonzero, E(LL-1) is zero
+*
+ IF( LL.EQ.M-1 ) THEN
+*
+* 2 by 2 block, handle separately
+*
+ CALL DLASV2( D( M-1 ), E( M-1 ), D( M ), SIGMN, SIGMX, SINR,
+ $ COSR, SINL, COSL )
+ D( M-1 ) = SIGMX
+ E( M-1 ) = ZERO
+ D( M ) = SIGMN
+*
+* Compute singular vectors, if desired
+*
+ IF( NCVT.GT.0 )
+ $ CALL DROT( NCVT, VT( M-1, 1 ), LDVT, VT( M, 1 ), LDVT, COSR,
+ $ SINR )
+ IF( NRU.GT.0 )
+ $ CALL DROT( NRU, U( 1, M-1 ), 1, U( 1, M ), 1, COSL, SINL )
+ IF( NCC.GT.0 )
+ $ CALL DROT( NCC, C( M-1, 1 ), LDC, C( M, 1 ), LDC, COSL,
+ $ SINL )
+ M = M - 2
+ GO TO 60
+ END IF
+*
+* If working on new submatrix, choose shift direction
+* (from larger end diagonal element towards smaller)
+*
+ IF( LL.GT.OLDM .OR. M.LT.OLDLL ) THEN
+ IF( ABS( D( LL ) ).GE.ABS( D( M ) ) ) THEN
+*
+* Chase bulge from top (big end) to bottom (small end)
+*
+ IDIR = 1
+ ELSE
+*
+* Chase bulge from bottom (big end) to top (small end)
+*
+ IDIR = 2
+ END IF
+ END IF
+*
+* Apply convergence tests
+*
+ IF( IDIR.EQ.1 ) THEN
+*
+* Run convergence test in forward direction
+* First apply standard test to bottom of matrix
+*
+ IF( ABS( E( M-1 ) ).LE.ABS( TOL )*ABS( D( M ) ) .OR.
+ $ ( TOL.LT.ZERO .AND. ABS( E( M-1 ) ).LE.THRESH ) ) THEN
+ E( M-1 ) = ZERO
+ GO TO 60
+ END IF
+*
+ IF( TOL.GE.ZERO ) THEN
+*
+* If relative accuracy desired,
+* apply convergence criterion forward
+*
+ MU = ABS( D( LL ) )
+ SMINL = MU
+ DO 100 LLL = LL, M - 1
+ IF( ABS( E( LLL ) ).LE.TOL*MU ) THEN
+ E( LLL ) = ZERO
+ GO TO 60
+ END IF
+ MU = ABS( D( LLL+1 ) )*( MU / ( MU+ABS( E( LLL ) ) ) )
+ SMINL = MIN( SMINL, MU )
+ 100 CONTINUE
+ END IF
+*
+ ELSE
+*
+* Run convergence test in backward direction
+* First apply standard test to top of matrix
+*
+ IF( ABS( E( LL ) ).LE.ABS( TOL )*ABS( D( LL ) ) .OR.
+ $ ( TOL.LT.ZERO .AND. ABS( E( LL ) ).LE.THRESH ) ) THEN
+ E( LL ) = ZERO
+ GO TO 60
+ END IF
+*
+ IF( TOL.GE.ZERO ) THEN
+*
+* If relative accuracy desired,
+* apply convergence criterion backward
+*
+ MU = ABS( D( M ) )
+ SMINL = MU
+ DO 110 LLL = M - 1, LL, -1
+ IF( ABS( E( LLL ) ).LE.TOL*MU ) THEN
+ E( LLL ) = ZERO
+ GO TO 60
+ END IF
+ MU = ABS( D( LLL ) )*( MU / ( MU+ABS( E( LLL ) ) ) )
+ SMINL = MIN( SMINL, MU )
+ 110 CONTINUE
+ END IF
+ END IF
+ OLDLL = LL
+ OLDM = M
+*
+* Compute shift. First, test if shifting would ruin relative
+* accuracy, and if so set the shift to zero.
+*
+ IF( TOL.GE.ZERO .AND. N*TOL*( SMINL / SMAX ).LE.
+ $ MAX( EPS, HNDRTH*TOL ) ) THEN
+*
+* Use a zero shift to avoid loss of relative accuracy
+*
+ SHIFT = ZERO
+ ELSE
+*
+* Compute the shift from 2-by-2 block at end of matrix
+*
+ IF( IDIR.EQ.1 ) THEN
+ SLL = ABS( D( LL ) )
+ CALL DLAS2( D( M-1 ), E( M-1 ), D( M ), SHIFT, R )
+ ELSE
+ SLL = ABS( D( M ) )
+ CALL DLAS2( D( LL ), E( LL ), D( LL+1 ), SHIFT, R )
+ END IF
+*
+* Test if shift negligible, and if so set to zero
+*
+ IF( SLL.GT.ZERO ) THEN
+ IF( ( SHIFT / SLL )**2.LT.EPS )
+ $ SHIFT = ZERO
+ END IF
+ END IF
+*
+* Increment iteration count
+*
+ ITER = ITER + M - LL
+*
+* If SHIFT = 0, do simplified QR iteration
+*
+ IF( SHIFT.EQ.ZERO ) THEN
+ IF( IDIR.EQ.1 ) THEN
+*
+* Chase bulge from top to bottom
+* Save cosines and sines for later singular vector updates
+*
+ CS = ONE
+ OLDCS = ONE
+ DO 120 I = LL, M - 1
+ CALL DLARTG( D( I )*CS, E( I ), CS, SN, R )
+ IF( I.GT.LL )
+ $ E( I-1 ) = OLDSN*R
+ CALL DLARTG( OLDCS*R, D( I+1 )*SN, OLDCS, OLDSN, D( I ) )
+ WORK( I-LL+1 ) = CS
+ WORK( I-LL+1+NM1 ) = SN
+ WORK( I-LL+1+NM12 ) = OLDCS
+ WORK( I-LL+1+NM13 ) = OLDSN
+ 120 CONTINUE
+ H = D( M )*CS
+ D( M ) = H*OLDCS
+ E( M-1 ) = H*OLDSN
+*
+* Update singular vectors
+*
+ IF( NCVT.GT.0 )
+ $ CALL DLASR( 'L', 'V', 'F', M-LL+1, NCVT, WORK( 1 ),
+ $ WORK( N ), VT( LL, 1 ), LDVT )
+ IF( NRU.GT.0 )
+ $ CALL DLASR( 'R', 'V', 'F', NRU, M-LL+1, WORK( NM12+1 ),
+ $ WORK( NM13+1 ), U( 1, LL ), LDU )
+ IF( NCC.GT.0 )
+ $ CALL DLASR( 'L', 'V', 'F', M-LL+1, NCC, WORK( NM12+1 ),
+ $ WORK( NM13+1 ), C( LL, 1 ), LDC )
+*
+* Test convergence
+*
+ IF( ABS( E( M-1 ) ).LE.THRESH )
+ $ E( M-1 ) = ZERO
+*
+ ELSE
+*
+* Chase bulge from bottom to top
+* Save cosines and sines for later singular vector updates
+*
+ CS = ONE
+ OLDCS = ONE
+ DO 130 I = M, LL + 1, -1
+ CALL DLARTG( D( I )*CS, E( I-1 ), CS, SN, R )
+ IF( I.LT.M )
+ $ E( I ) = OLDSN*R
+ CALL DLARTG( OLDCS*R, D( I-1 )*SN, OLDCS, OLDSN, D( I ) )
+ WORK( I-LL ) = CS
+ WORK( I-LL+NM1 ) = -SN
+ WORK( I-LL+NM12 ) = OLDCS
+ WORK( I-LL+NM13 ) = -OLDSN
+ 130 CONTINUE
+ H = D( LL )*CS
+ D( LL ) = H*OLDCS
+ E( LL ) = H*OLDSN
+*
+* Update singular vectors
+*
+ IF( NCVT.GT.0 )
+ $ CALL DLASR( 'L', 'V', 'B', M-LL+1, NCVT, WORK( NM12+1 ),
+ $ WORK( NM13+1 ), VT( LL, 1 ), LDVT )
+ IF( NRU.GT.0 )
+ $ CALL DLASR( 'R', 'V', 'B', NRU, M-LL+1, WORK( 1 ),
+ $ WORK( N ), U( 1, LL ), LDU )
+ IF( NCC.GT.0 )
+ $ CALL DLASR( 'L', 'V', 'B', M-LL+1, NCC, WORK( 1 ),
+ $ WORK( N ), C( LL, 1 ), LDC )
+*
+* Test convergence
+*
+ IF( ABS( E( LL ) ).LE.THRESH )
+ $ E( LL ) = ZERO
+ END IF
+ ELSE
+*
+* Use nonzero shift
+*
+ IF( IDIR.EQ.1 ) THEN
+*
+* Chase bulge from top to bottom
+* Save cosines and sines for later singular vector updates
+*
+ F = ( ABS( D( LL ) )-SHIFT )*
+ $ ( SIGN( ONE, D( LL ) )+SHIFT / D( LL ) )
+ G = E( LL )
+ DO 140 I = LL, M - 1
+ CALL DLARTG( F, G, COSR, SINR, R )
+ IF( I.GT.LL )
+ $ E( I-1 ) = R
+ F = COSR*D( I ) + SINR*E( I )
+ E( I ) = COSR*E( I ) - SINR*D( I )
+ G = SINR*D( I+1 )
+ D( I+1 ) = COSR*D( I+1 )
+ CALL DLARTG( F, G, COSL, SINL, R )
+ D( I ) = R
+ F = COSL*E( I ) + SINL*D( I+1 )
+ D( I+1 ) = COSL*D( I+1 ) - SINL*E( I )
+ IF( I.LT.M-1 ) THEN
+ G = SINL*E( I+1 )
+ E( I+1 ) = COSL*E( I+1 )
+ END IF
+ WORK( I-LL+1 ) = COSR
+ WORK( I-LL+1+NM1 ) = SINR
+ WORK( I-LL+1+NM12 ) = COSL
+ WORK( I-LL+1+NM13 ) = SINL
+ 140 CONTINUE
+ E( M-1 ) = F
+*
+* Update singular vectors
+*
+ IF( NCVT.GT.0 )
+ $ CALL DLASR( 'L', 'V', 'F', M-LL+1, NCVT, WORK( 1 ),
+ $ WORK( N ), VT( LL, 1 ), LDVT )
+ IF( NRU.GT.0 )
+ $ CALL DLASR( 'R', 'V', 'F', NRU, M-LL+1, WORK( NM12+1 ),
+ $ WORK( NM13+1 ), U( 1, LL ), LDU )
+ IF( NCC.GT.0 )
+ $ CALL DLASR( 'L', 'V', 'F', M-LL+1, NCC, WORK( NM12+1 ),
+ $ WORK( NM13+1 ), C( LL, 1 ), LDC )
+*
+* Test convergence
+*
+ IF( ABS( E( M-1 ) ).LE.THRESH )
+ $ E( M-1 ) = ZERO
+*
+ ELSE
+*
+* Chase bulge from bottom to top
+* Save cosines and sines for later singular vector updates
+*
+ F = ( ABS( D( M ) )-SHIFT )*( SIGN( ONE, D( M ) )+SHIFT /
+ $ D( M ) )
+ G = E( M-1 )
+ DO 150 I = M, LL + 1, -1
+ CALL DLARTG( F, G, COSR, SINR, R )
+ IF( I.LT.M )
+ $ E( I ) = R
+ F = COSR*D( I ) + SINR*E( I-1 )
+ E( I-1 ) = COSR*E( I-1 ) - SINR*D( I )
+ G = SINR*D( I-1 )
+ D( I-1 ) = COSR*D( I-1 )
+ CALL DLARTG( F, G, COSL, SINL, R )
+ D( I ) = R
+ F = COSL*E( I-1 ) + SINL*D( I-1 )
+ D( I-1 ) = COSL*D( I-1 ) - SINL*E( I-1 )
+ IF( I.GT.LL+1 ) THEN
+ G = SINL*E( I-2 )
+ E( I-2 ) = COSL*E( I-2 )
+ END IF
+ WORK( I-LL ) = COSR
+ WORK( I-LL+NM1 ) = -SINR
+ WORK( I-LL+NM12 ) = COSL
+ WORK( I-LL+NM13 ) = -SINL
+ 150 CONTINUE
+ E( LL ) = F
+*
+* Test convergence
+*
+ IF( ABS( E( LL ) ).LE.THRESH )
+ $ E( LL ) = ZERO
+*
+* Update singular vectors if desired
+*
+ IF( NCVT.GT.0 )
+ $ CALL DLASR( 'L', 'V', 'B', M-LL+1, NCVT, WORK( NM12+1 ),
+ $ WORK( NM13+1 ), VT( LL, 1 ), LDVT )
+ IF( NRU.GT.0 )
+ $ CALL DLASR( 'R', 'V', 'B', NRU, M-LL+1, WORK( 1 ),
+ $ WORK( N ), U( 1, LL ), LDU )
+ IF( NCC.GT.0 )
+ $ CALL DLASR( 'L', 'V', 'B', M-LL+1, NCC, WORK( 1 ),
+ $ WORK( N ), C( LL, 1 ), LDC )
+ END IF
+ END IF
+*
+* QR iteration finished, go back and check convergence
+*
+ GO TO 60
+*
+* All singular values converged, so make them positive
+*
+ 160 CONTINUE
+ DO 170 I = 1, N
+ IF( D( I ).LT.ZERO ) THEN
+ D( I ) = -D( I )
+*
+* Change sign of singular vectors, if desired
+*
+ IF( NCVT.GT.0 )
+ $ CALL DSCAL( NCVT, NEGONE, VT( I, 1 ), LDVT )
+ END IF
+ 170 CONTINUE
+*
+* Sort the singular values into decreasing order (insertion sort on
+* singular values, but only one transposition per singular vector)
+*
+ DO 190 I = 1, N - 1
+*
+* Scan for smallest D(I)
+*
+ ISUB = 1
+ SMIN = D( 1 )
+ DO 180 J = 2, N + 1 - I
+ IF( D( J ).LE.SMIN ) THEN
+ ISUB = J
+ SMIN = D( J )
+ END IF
+ 180 CONTINUE
+ IF( ISUB.NE.N+1-I ) THEN
+*
+* Swap singular values and vectors
+*
+ D( ISUB ) = D( N+1-I )
+ D( N+1-I ) = SMIN
+ IF( NCVT.GT.0 )
+ $ CALL DSWAP( NCVT, VT( ISUB, 1 ), LDVT, VT( N+1-I, 1 ),
+ $ LDVT )
+ IF( NRU.GT.0 )
+ $ CALL DSWAP( NRU, U( 1, ISUB ), 1, U( 1, N+1-I ), 1 )
+ IF( NCC.GT.0 )
+ $ CALL DSWAP( NCC, C( ISUB, 1 ), LDC, C( N+1-I, 1 ), LDC )
+ END IF
+ 190 CONTINUE
+ GO TO 220
+*
+* Maximum number of iterations exceeded, failure to converge
+*
+ 200 CONTINUE
+ INFO = 0
+ DO 210 I = 1, N - 1
+ IF( E( I ).NE.ZERO )
+ $ INFO = INFO + 1
+ 210 CONTINUE
+ 220 CONTINUE
+ RETURN
+*
+* End of DBDSQR
+*
+ END
+ SUBROUTINE DDISNA( JOB, M, N, D, SEP, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER JOB
+ INTEGER INFO, M, N
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION D( * ), SEP( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DDISNA computes the reciprocal condition numbers for the eigenvectors
+* of a real symmetric or complex Hermitian matrix or for the left or
+* right singular vectors of a general m-by-n matrix. The reciprocal
+* condition number is the 'gap' between the corresponding eigenvalue or
+* singular value and the nearest other one.
+*
+* The bound on the error, measured by angle in radians, in the I-th
+* computed vector is given by
+*
+* DLAMCH( 'E' ) * ( ANORM / SEP( I ) )
+*
+* where ANORM = 2-norm(A) = max( abs( D(j) ) ). SEP(I) is not allowed
+* to be smaller than DLAMCH( 'E' )*ANORM in order to limit the size of
+* the error bound.
+*
+* DDISNA may also be used to compute error bounds for eigenvectors of
+* the generalized symmetric definite eigenproblem.
+*
+* Arguments
+* =========
+*
+* JOB (input) CHARACTER*1
+* Specifies for which problem the reciprocal condition numbers
+* should be computed:
+* = 'E': the eigenvectors of a symmetric/Hermitian matrix;
+* = 'L': the left singular vectors of a general matrix;
+* = 'R': the right singular vectors of a general matrix.
+*
+* M (input) INTEGER
+* The number of rows of the matrix. M >= 0.
+*
+* N (input) INTEGER
+* If JOB = 'L' or 'R', the number of columns of the matrix,
+* in which case N >= 0. Ignored if JOB = 'E'.
+*
+* D (input) DOUBLE PRECISION array, dimension (M) if JOB = 'E'
+* dimension (min(M,N)) if JOB = 'L' or 'R'
+* The eigenvalues (if JOB = 'E') or singular values (if JOB =
+* 'L' or 'R') of the matrix, in either increasing or decreasing
+* order. If singular values, they must be non-negative.
+*
+* SEP (output) DOUBLE PRECISION array, dimension (M) if JOB = 'E'
+* dimension (min(M,N)) if JOB = 'L' or 'R'
+* The reciprocal condition numbers of the vectors.
+*
+* INFO (output) INTEGER
+* = 0: successful exit.
+* < 0: if INFO = -i, the i-th argument had an illegal value.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO
+ PARAMETER ( ZERO = 0.0D+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL DECR, EIGEN, INCR, LEFT, RIGHT, SING
+ INTEGER I, K
+ DOUBLE PRECISION ANORM, EPS, NEWGAP, OLDGAP, SAFMIN, THRESH
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ DOUBLE PRECISION DLAMCH
+ EXTERNAL LSAME, DLAMCH
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, MIN
+* ..
+* .. External Subroutines ..
+ EXTERNAL XERBLA
+* ..
+* .. Executable Statements ..
+*
+* Test the input arguments
+*
+ INFO = 0
+ EIGEN = LSAME( JOB, 'E' )
+ LEFT = LSAME( JOB, 'L' )
+ RIGHT = LSAME( JOB, 'R' )
+ SING = LEFT .OR. RIGHT
+ IF( EIGEN ) THEN
+ K = M
+ ELSE IF( SING ) THEN
+ K = MIN( M, N )
+ END IF
+ IF( .NOT.EIGEN .AND. .NOT.SING ) THEN
+ INFO = -1
+ ELSE IF( M.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( K.LT.0 ) THEN
+ INFO = -3
+ ELSE
+ INCR = .TRUE.
+ DECR = .TRUE.
+ DO 10 I = 1, K - 1
+ IF( INCR )
+ $ INCR = INCR .AND. D( I ).LE.D( I+1 )
+ IF( DECR )
+ $ DECR = DECR .AND. D( I ).GE.D( I+1 )
+ 10 CONTINUE
+ IF( SING .AND. K.GT.0 ) THEN
+ IF( INCR )
+ $ INCR = INCR .AND. ZERO.LE.D( 1 )
+ IF( DECR )
+ $ DECR = DECR .AND. D( K ).GE.ZERO
+ END IF
+ IF( .NOT.( INCR .OR. DECR ) )
+ $ INFO = -4
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DDISNA', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( K.EQ.0 )
+ $ RETURN
+*
+* Compute reciprocal condition numbers
+*
+ IF( K.EQ.1 ) THEN
+ SEP( 1 ) = DLAMCH( 'O' )
+ ELSE
+ OLDGAP = ABS( D( 2 )-D( 1 ) )
+ SEP( 1 ) = OLDGAP
+ DO 20 I = 2, K - 1
+ NEWGAP = ABS( D( I+1 )-D( I ) )
+ SEP( I ) = MIN( OLDGAP, NEWGAP )
+ OLDGAP = NEWGAP
+ 20 CONTINUE
+ SEP( K ) = OLDGAP
+ END IF
+ IF( SING ) THEN
+ IF( ( LEFT .AND. M.GT.N ) .OR. ( RIGHT .AND. M.LT.N ) ) THEN
+ IF( INCR )
+ $ SEP( 1 ) = MIN( SEP( 1 ), D( 1 ) )
+ IF( DECR )
+ $ SEP( K ) = MIN( SEP( K ), D( K ) )
+ END IF
+ END IF
+*
+* Ensure that reciprocal condition numbers are not less than
+* threshold, in order to limit the size of the error bound
+*
+ EPS = DLAMCH( 'E' )
+ SAFMIN = DLAMCH( 'S' )
+ ANORM = MAX( ABS( D( 1 ) ), ABS( D( K ) ) )
+ IF( ANORM.EQ.ZERO ) THEN
+ THRESH = EPS
+ ELSE
+ THRESH = MAX( EPS*ANORM, SAFMIN )
+ END IF
+ DO 30 I = 1, K
+ SEP( I ) = MAX( SEP( I ), THRESH )
+ 30 CONTINUE
+*
+ RETURN
+*
+* End of DDISNA
+*
+ END
+ SUBROUTINE DGBBRD( VECT, M, N, NCC, KL, KU, AB, LDAB, D, E, Q,
+ $ LDQ, PT, LDPT, C, LDC, WORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER VECT
+ INTEGER INFO, KL, KU, LDAB, LDC, LDPT, LDQ, M, N, NCC
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION AB( LDAB, * ), C( LDC, * ), D( * ), E( * ),
+ $ PT( LDPT, * ), Q( LDQ, * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DGBBRD reduces a real general m-by-n band matrix A to upper
+* bidiagonal form B by an orthogonal transformation: Q' * A * P = B.
+*
+* The routine computes B, and optionally forms Q or P', or computes
+* Q'*C for a given matrix C.
+*
+* Arguments
+* =========
+*
+* VECT (input) CHARACTER*1
+* Specifies whether or not the matrices Q and P' are to be
+* formed.
+* = 'N': do not form Q or P';
+* = 'Q': form Q only;
+* = 'P': form P' only;
+* = 'B': form both.
+*
+* M (input) INTEGER
+* The number of rows of the matrix A. M >= 0.
+*
+* N (input) INTEGER
+* The number of columns of the matrix A. N >= 0.
+*
+* NCC (input) INTEGER
+* The number of columns of the matrix C. NCC >= 0.
+*
+* KL (input) INTEGER
+* The number of subdiagonals of the matrix A. KL >= 0.
+*
+* KU (input) INTEGER
+* The number of superdiagonals of the matrix A. KU >= 0.
+*
+* AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N)
+* On entry, the m-by-n band matrix A, stored in rows 1 to
+* KL+KU+1. The j-th column of A is stored in the j-th column of
+* the array AB as follows:
+* AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl).
+* On exit, A is overwritten by values generated during the
+* reduction.
+*
+* LDAB (input) INTEGER
+* The leading dimension of the array A. LDAB >= KL+KU+1.
+*
+* D (output) DOUBLE PRECISION array, dimension (min(M,N))
+* The diagonal elements of the bidiagonal matrix B.
+*
+* E (output) DOUBLE PRECISION array, dimension (min(M,N)-1)
+* The superdiagonal elements of the bidiagonal matrix B.
+*
+* Q (output) DOUBLE PRECISION array, dimension (LDQ,M)
+* If VECT = 'Q' or 'B', the m-by-m orthogonal matrix Q.
+* If VECT = 'N' or 'P', the array Q is not referenced.
+*
+* LDQ (input) INTEGER
+* The leading dimension of the array Q.
+* LDQ >= max(1,M) if VECT = 'Q' or 'B'; LDQ >= 1 otherwise.
+*
+* PT (output) DOUBLE PRECISION array, dimension (LDPT,N)
+* If VECT = 'P' or 'B', the n-by-n orthogonal matrix P'.
+* If VECT = 'N' or 'Q', the array PT is not referenced.
+*
+* LDPT (input) INTEGER
+* The leading dimension of the array PT.
+* LDPT >= max(1,N) if VECT = 'P' or 'B'; LDPT >= 1 otherwise.
+*
+* C (input/output) DOUBLE PRECISION array, dimension (LDC,NCC)
+* On entry, an m-by-ncc matrix C.
+* On exit, C is overwritten by Q'*C.
+* C is not referenced if NCC = 0.
+*
+* LDC (input) INTEGER
+* The leading dimension of the array C.
+* LDC >= max(1,M) if NCC > 0; LDC >= 1 if NCC = 0.
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (2*max(M,N))
+*
+* INFO (output) INTEGER
+* = 0: successful exit.
+* < 0: if INFO = -i, the i-th argument had an illegal value.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL WANTB, WANTC, WANTPT, WANTQ
+ INTEGER I, INCA, J, J1, J2, KB, KB1, KK, KLM, KLU1,
+ $ KUN, L, MINMN, ML, ML0, MN, MU, MU0, NR, NRT
+ DOUBLE PRECISION RA, RB, RC, RS
+* ..
+* .. External Subroutines ..
+ EXTERNAL DLARGV, DLARTG, DLARTV, DLASET, DROT, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters
+*
+ WANTB = LSAME( VECT, 'B' )
+ WANTQ = LSAME( VECT, 'Q' ) .OR. WANTB
+ WANTPT = LSAME( VECT, 'P' ) .OR. WANTB
+ WANTC = NCC.GT.0
+ KLU1 = KL + KU + 1
+ INFO = 0
+ IF( .NOT.WANTQ .AND. .NOT.WANTPT .AND. .NOT.LSAME( VECT, 'N' ) )
+ $ THEN
+ INFO = -1
+ ELSE IF( M.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( NCC.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( KL.LT.0 ) THEN
+ INFO = -5
+ ELSE IF( KU.LT.0 ) THEN
+ INFO = -6
+ ELSE IF( LDAB.LT.KLU1 ) THEN
+ INFO = -8
+ ELSE IF( LDQ.LT.1 .OR. WANTQ .AND. LDQ.LT.MAX( 1, M ) ) THEN
+ INFO = -12
+ ELSE IF( LDPT.LT.1 .OR. WANTPT .AND. LDPT.LT.MAX( 1, N ) ) THEN
+ INFO = -14
+ ELSE IF( LDC.LT.1 .OR. WANTC .AND. LDC.LT.MAX( 1, M ) ) THEN
+ INFO = -16
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DGBBRD', -INFO )
+ RETURN
+ END IF
+*
+* Initialize Q and P' to the unit matrix, if needed
+*
+ IF( WANTQ )
+ $ CALL DLASET( 'Full', M, M, ZERO, ONE, Q, LDQ )
+ IF( WANTPT )
+ $ CALL DLASET( 'Full', N, N, ZERO, ONE, PT, LDPT )
+*
+* Quick return if possible.
+*
+ IF( M.EQ.0 .OR. N.EQ.0 )
+ $ RETURN
+*
+ MINMN = MIN( M, N )
+*
+ IF( KL+KU.GT.1 ) THEN
+*
+* Reduce to upper bidiagonal form if KU > 0; if KU = 0, reduce
+* first to lower bidiagonal form and then transform to upper
+* bidiagonal
+*
+ IF( KU.GT.0 ) THEN
+ ML0 = 1
+ MU0 = 2
+ ELSE
+ ML0 = 2
+ MU0 = 1
+ END IF
+*
+* Wherever possible, plane rotations are generated and applied in
+* vector operations of length NR over the index set J1:J2:KLU1.
+*
+* The sines of the plane rotations are stored in WORK(1:max(m,n))
+* and the cosines in WORK(max(m,n)+1:2*max(m,n)).
+*
+ MN = MAX( M, N )
+ KLM = MIN( M-1, KL )
+ KUN = MIN( N-1, KU )
+ KB = KLM + KUN
+ KB1 = KB + 1
+ INCA = KB1*LDAB
+ NR = 0
+ J1 = KLM + 2
+ J2 = 1 - KUN
+*
+ DO 90 I = 1, MINMN
+*
+* Reduce i-th column and i-th row of matrix to bidiagonal form
+*
+ ML = KLM + 1
+ MU = KUN + 1
+ DO 80 KK = 1, KB
+ J1 = J1 + KB
+ J2 = J2 + KB
+*
+* generate plane rotations to annihilate nonzero elements
+* which have been created below the band
+*
+ IF( NR.GT.0 )
+ $ CALL DLARGV( NR, AB( KLU1, J1-KLM-1 ), INCA,
+ $ WORK( J1 ), KB1, WORK( MN+J1 ), KB1 )
+*
+* apply plane rotations from the left
+*
+ DO 10 L = 1, KB
+ IF( J2-KLM+L-1.GT.N ) THEN
+ NRT = NR - 1
+ ELSE
+ NRT = NR
+ END IF
+ IF( NRT.GT.0 )
+ $ CALL DLARTV( NRT, AB( KLU1-L, J1-KLM+L-1 ), INCA,
+ $ AB( KLU1-L+1, J1-KLM+L-1 ), INCA,
+ $ WORK( MN+J1 ), WORK( J1 ), KB1 )
+ 10 CONTINUE
+*
+ IF( ML.GT.ML0 ) THEN
+ IF( ML.LE.M-I+1 ) THEN
+*
+* generate plane rotation to annihilate a(i+ml-1,i)
+* within the band, and apply rotation from the left
+*
+ CALL DLARTG( AB( KU+ML-1, I ), AB( KU+ML, I ),
+ $ WORK( MN+I+ML-1 ), WORK( I+ML-1 ),
+ $ RA )
+ AB( KU+ML-1, I ) = RA
+ IF( I.LT.N )
+ $ CALL DROT( MIN( KU+ML-2, N-I ),
+ $ AB( KU+ML-2, I+1 ), LDAB-1,
+ $ AB( KU+ML-1, I+1 ), LDAB-1,
+ $ WORK( MN+I+ML-1 ), WORK( I+ML-1 ) )
+ END IF
+ NR = NR + 1
+ J1 = J1 - KB1
+ END IF
+*
+ IF( WANTQ ) THEN
+*
+* accumulate product of plane rotations in Q
+*
+ DO 20 J = J1, J2, KB1
+ CALL DROT( M, Q( 1, J-1 ), 1, Q( 1, J ), 1,
+ $ WORK( MN+J ), WORK( J ) )
+ 20 CONTINUE
+ END IF
+*
+ IF( WANTC ) THEN
+*
+* apply plane rotations to C
+*
+ DO 30 J = J1, J2, KB1
+ CALL DROT( NCC, C( J-1, 1 ), LDC, C( J, 1 ), LDC,
+ $ WORK( MN+J ), WORK( J ) )
+ 30 CONTINUE
+ END IF
+*
+ IF( J2+KUN.GT.N ) THEN
+*
+* adjust J2 to keep within the bounds of the matrix
+*
+ NR = NR - 1
+ J2 = J2 - KB1
+ END IF
+*
+ DO 40 J = J1, J2, KB1
+*
+* create nonzero element a(j-1,j+ku) above the band
+* and store it in WORK(n+1:2*n)
+*
+ WORK( J+KUN ) = WORK( J )*AB( 1, J+KUN )
+ AB( 1, J+KUN ) = WORK( MN+J )*AB( 1, J+KUN )
+ 40 CONTINUE
+*
+* generate plane rotations to annihilate nonzero elements
+* which have been generated above the band
+*
+ IF( NR.GT.0 )
+ $ CALL DLARGV( NR, AB( 1, J1+KUN-1 ), INCA,
+ $ WORK( J1+KUN ), KB1, WORK( MN+J1+KUN ),
+ $ KB1 )
+*
+* apply plane rotations from the right
+*
+ DO 50 L = 1, KB
+ IF( J2+L-1.GT.M ) THEN
+ NRT = NR - 1
+ ELSE
+ NRT = NR
+ END IF
+ IF( NRT.GT.0 )
+ $ CALL DLARTV( NRT, AB( L+1, J1+KUN-1 ), INCA,
+ $ AB( L, J1+KUN ), INCA,
+ $ WORK( MN+J1+KUN ), WORK( J1+KUN ),
+ $ KB1 )
+ 50 CONTINUE
+*
+ IF( ML.EQ.ML0 .AND. MU.GT.MU0 ) THEN
+ IF( MU.LE.N-I+1 ) THEN
+*
+* generate plane rotation to annihilate a(i,i+mu-1)
+* within the band, and apply rotation from the right
+*
+ CALL DLARTG( AB( KU-MU+3, I+MU-2 ),
+ $ AB( KU-MU+2, I+MU-1 ),
+ $ WORK( MN+I+MU-1 ), WORK( I+MU-1 ),
+ $ RA )
+ AB( KU-MU+3, I+MU-2 ) = RA
+ CALL DROT( MIN( KL+MU-2, M-I ),
+ $ AB( KU-MU+4, I+MU-2 ), 1,
+ $ AB( KU-MU+3, I+MU-1 ), 1,
+ $ WORK( MN+I+MU-1 ), WORK( I+MU-1 ) )
+ END IF
+ NR = NR + 1
+ J1 = J1 - KB1
+ END IF
+*
+ IF( WANTPT ) THEN
+*
+* accumulate product of plane rotations in P'
+*
+ DO 60 J = J1, J2, KB1
+ CALL DROT( N, PT( J+KUN-1, 1 ), LDPT,
+ $ PT( J+KUN, 1 ), LDPT, WORK( MN+J+KUN ),
+ $ WORK( J+KUN ) )
+ 60 CONTINUE
+ END IF
+*
+ IF( J2+KB.GT.M ) THEN
+*
+* adjust J2 to keep within the bounds of the matrix
+*
+ NR = NR - 1
+ J2 = J2 - KB1
+ END IF
+*
+ DO 70 J = J1, J2, KB1
+*
+* create nonzero element a(j+kl+ku,j+ku-1) below the
+* band and store it in WORK(1:n)
+*
+ WORK( J+KB ) = WORK( J+KUN )*AB( KLU1, J+KUN )
+ AB( KLU1, J+KUN ) = WORK( MN+J+KUN )*AB( KLU1, J+KUN )
+ 70 CONTINUE
+*
+ IF( ML.GT.ML0 ) THEN
+ ML = ML - 1
+ ELSE
+ MU = MU - 1
+ END IF
+ 80 CONTINUE
+ 90 CONTINUE
+ END IF
+*
+ IF( KU.EQ.0 .AND. KL.GT.0 ) THEN
+*
+* A has been reduced to lower bidiagonal form
+*
+* Transform lower bidiagonal form to upper bidiagonal by applying
+* plane rotations from the left, storing diagonal elements in D
+* and off-diagonal elements in E
+*
+ DO 100 I = 1, MIN( M-1, N )
+ CALL DLARTG( AB( 1, I ), AB( 2, I ), RC, RS, RA )
+ D( I ) = RA
+ IF( I.LT.N ) THEN
+ E( I ) = RS*AB( 1, I+1 )
+ AB( 1, I+1 ) = RC*AB( 1, I+1 )
+ END IF
+ IF( WANTQ )
+ $ CALL DROT( M, Q( 1, I ), 1, Q( 1, I+1 ), 1, RC, RS )
+ IF( WANTC )
+ $ CALL DROT( NCC, C( I, 1 ), LDC, C( I+1, 1 ), LDC, RC,
+ $ RS )
+ 100 CONTINUE
+ IF( M.LE.N )
+ $ D( M ) = AB( 1, M )
+ ELSE IF( KU.GT.0 ) THEN
+*
+* A has been reduced to upper bidiagonal form
+*
+ IF( M.LT.N ) THEN
+*
+* Annihilate a(m,m+1) by applying plane rotations from the
+* right, storing diagonal elements in D and off-diagonal
+* elements in E
+*
+ RB = AB( KU, M+1 )
+ DO 110 I = M, 1, -1
+ CALL DLARTG( AB( KU+1, I ), RB, RC, RS, RA )
+ D( I ) = RA
+ IF( I.GT.1 ) THEN
+ RB = -RS*AB( KU, I )
+ E( I-1 ) = RC*AB( KU, I )
+ END IF
+ IF( WANTPT )
+ $ CALL DROT( N, PT( I, 1 ), LDPT, PT( M+1, 1 ), LDPT,
+ $ RC, RS )
+ 110 CONTINUE
+ ELSE
+*
+* Copy off-diagonal elements to E and diagonal elements to D
+*
+ DO 120 I = 1, MINMN - 1
+ E( I ) = AB( KU, I+1 )
+ 120 CONTINUE
+ DO 130 I = 1, MINMN
+ D( I ) = AB( KU+1, I )
+ 130 CONTINUE
+ END IF
+ ELSE
+*
+* A is diagonal. Set elements of E to zero and copy diagonal
+* elements to D.
+*
+ DO 140 I = 1, MINMN - 1
+ E( I ) = ZERO
+ 140 CONTINUE
+ DO 150 I = 1, MINMN
+ D( I ) = AB( 1, I )
+ 150 CONTINUE
+ END IF
+ RETURN
+*
+* End of DGBBRD
+*
+ END
+ SUBROUTINE DGBCON( NORM, N, KL, KU, AB, LDAB, IPIV, ANORM, RCOND,
+ $ WORK, IWORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH.
+*
+* .. Scalar Arguments ..
+ CHARACTER NORM
+ INTEGER INFO, KL, KU, LDAB, N
+ DOUBLE PRECISION ANORM, RCOND
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * ), IWORK( * )
+ DOUBLE PRECISION AB( LDAB, * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DGBCON estimates the reciprocal of the condition number of a real
+* general band matrix A, in either the 1-norm or the infinity-norm,
+* using the LU factorization computed by DGBTRF.
+*
+* An estimate is obtained for norm(inv(A)), and the reciprocal of the
+* condition number is computed as
+* RCOND = 1 / ( norm(A) * norm(inv(A)) ).
+*
+* Arguments
+* =========
+*
+* NORM (input) CHARACTER*1
+* Specifies whether the 1-norm condition number or the
+* infinity-norm condition number is required:
+* = '1' or 'O': 1-norm;
+* = 'I': Infinity-norm.
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* KL (input) INTEGER
+* The number of subdiagonals within the band of A. KL >= 0.
+*
+* KU (input) INTEGER
+* The number of superdiagonals within the band of A. KU >= 0.
+*
+* AB (input) DOUBLE PRECISION array, dimension (LDAB,N)
+* Details of the LU factorization of the band matrix A, as
+* computed by DGBTRF. U is stored as an upper triangular band
+* matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and
+* the multipliers used during the factorization are stored in
+* rows KL+KU+2 to 2*KL+KU+1.
+*
+* LDAB (input) INTEGER
+* The leading dimension of the array AB. LDAB >= 2*KL+KU+1.
+*
+* IPIV (input) INTEGER array, dimension (N)
+* The pivot indices; for 1 <= i <= N, row i of the matrix was
+* interchanged with row IPIV(i).
+*
+* ANORM (input) DOUBLE PRECISION
+* If NORM = '1' or 'O', the 1-norm of the original matrix A.
+* If NORM = 'I', the infinity-norm of the original matrix A.
+*
+* RCOND (output) DOUBLE PRECISION
+* The reciprocal of the condition number of the matrix A,
+* computed as RCOND = 1/(norm(A) * norm(inv(A))).
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (3*N)
+*
+* IWORK (workspace) INTEGER array, dimension (N)
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE, ZERO
+ PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL LNOTI, ONENRM
+ CHARACTER NORMIN
+ INTEGER IX, J, JP, KASE, KASE1, KD, LM
+ DOUBLE PRECISION AINVNM, SCALE, SMLNUM, T
+* ..
+* .. Local Arrays ..
+ INTEGER ISAVE( 3 )
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER IDAMAX
+ DOUBLE PRECISION DDOT, DLAMCH
+ EXTERNAL LSAME, IDAMAX, DDOT, DLAMCH
+* ..
+* .. External Subroutines ..
+ EXTERNAL DAXPY, DLACN2, DLATBS, DRSCL, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MIN
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ ONENRM = NORM.EQ.'1' .OR. LSAME( NORM, 'O' )
+ IF( .NOT.ONENRM .AND. .NOT.LSAME( NORM, 'I' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( KL.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( KU.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( LDAB.LT.2*KL+KU+1 ) THEN
+ INFO = -6
+ ELSE IF( ANORM.LT.ZERO ) THEN
+ INFO = -8
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DGBCON', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ RCOND = ZERO
+ IF( N.EQ.0 ) THEN
+ RCOND = ONE
+ RETURN
+ ELSE IF( ANORM.EQ.ZERO ) THEN
+ RETURN
+ END IF
+*
+ SMLNUM = DLAMCH( 'Safe minimum' )
+*
+* Estimate the norm of inv(A).
+*
+ AINVNM = ZERO
+ NORMIN = 'N'
+ IF( ONENRM ) THEN
+ KASE1 = 1
+ ELSE
+ KASE1 = 2
+ END IF
+ KD = KL + KU + 1
+ LNOTI = KL.GT.0
+ KASE = 0
+ 10 CONTINUE
+ CALL DLACN2( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE, ISAVE )
+ IF( KASE.NE.0 ) THEN
+ IF( KASE.EQ.KASE1 ) THEN
+*
+* Multiply by inv(L).
+*
+ IF( LNOTI ) THEN
+ DO 20 J = 1, N - 1
+ LM = MIN( KL, N-J )
+ JP = IPIV( J )
+ T = WORK( JP )
+ IF( JP.NE.J ) THEN
+ WORK( JP ) = WORK( J )
+ WORK( J ) = T
+ END IF
+ CALL DAXPY( LM, -T, AB( KD+1, J ), 1, WORK( J+1 ), 1 )
+ 20 CONTINUE
+ END IF
+*
+* Multiply by inv(U).
+*
+ CALL DLATBS( 'Upper', 'No transpose', 'Non-unit', NORMIN, N,
+ $ KL+KU, AB, LDAB, WORK, SCALE, WORK( 2*N+1 ),
+ $ INFO )
+ ELSE
+*
+* Multiply by inv(U').
+*
+ CALL DLATBS( 'Upper', 'Transpose', 'Non-unit', NORMIN, N,
+ $ KL+KU, AB, LDAB, WORK, SCALE, WORK( 2*N+1 ),
+ $ INFO )
+*
+* Multiply by inv(L').
+*
+ IF( LNOTI ) THEN
+ DO 30 J = N - 1, 1, -1
+ LM = MIN( KL, N-J )
+ WORK( J ) = WORK( J ) - DDOT( LM, AB( KD+1, J ), 1,
+ $ WORK( J+1 ), 1 )
+ JP = IPIV( J )
+ IF( JP.NE.J ) THEN
+ T = WORK( JP )
+ WORK( JP ) = WORK( J )
+ WORK( J ) = T
+ END IF
+ 30 CONTINUE
+ END IF
+ END IF
+*
+* Divide X by 1/SCALE if doing so will not cause overflow.
+*
+ NORMIN = 'Y'
+ IF( SCALE.NE.ONE ) THEN
+ IX = IDAMAX( N, WORK, 1 )
+ IF( SCALE.LT.ABS( WORK( IX ) )*SMLNUM .OR. SCALE.EQ.ZERO )
+ $ GO TO 40
+ CALL DRSCL( N, SCALE, WORK, 1 )
+ END IF
+ GO TO 10
+ END IF
+*
+* Compute the estimate of the reciprocal condition number.
+*
+ IF( AINVNM.NE.ZERO )
+ $ RCOND = ( ONE / AINVNM ) / ANORM
+*
+ 40 CONTINUE
+ RETURN
+*
+* End of DGBCON
+*
+ END
+ SUBROUTINE DGBEQU( M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND,
+ $ AMAX, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, KL, KU, LDAB, M, N
+ DOUBLE PRECISION AMAX, COLCND, ROWCND
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION AB( LDAB, * ), C( * ), R( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DGBEQU computes row and column scalings intended to equilibrate an
+* M-by-N band matrix A and reduce its condition number. R returns the
+* row scale factors and C the column scale factors, chosen to try to
+* make the largest element in each row and column of the matrix B with
+* elements B(i,j)=R(i)*A(i,j)*C(j) have absolute value 1.
+*
+* R(i) and C(j) are restricted to be between SMLNUM = smallest safe
+* number and BIGNUM = largest safe number. Use of these scaling
+* factors is not guaranteed to reduce the condition number of A but
+* works well in practice.
+*
+* Arguments
+* =========
+*
+* M (input) INTEGER
+* The number of rows of the matrix A. M >= 0.
+*
+* N (input) INTEGER
+* The number of columns of the matrix A. N >= 0.
+*
+* KL (input) INTEGER
+* The number of subdiagonals within the band of A. KL >= 0.
+*
+* KU (input) INTEGER
+* The number of superdiagonals within the band of A. KU >= 0.
+*
+* AB (input) DOUBLE PRECISION array, dimension (LDAB,N)
+* The band matrix A, stored in rows 1 to KL+KU+1. The j-th
+* column of A is stored in the j-th column of the array AB as
+* follows:
+* AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl).
+*
+* LDAB (input) INTEGER
+* The leading dimension of the array AB. LDAB >= KL+KU+1.
+*
+* R (output) DOUBLE PRECISION array, dimension (M)
+* If INFO = 0, or INFO > M, R contains the row scale factors
+* for A.
+*
+* C (output) DOUBLE PRECISION array, dimension (N)
+* If INFO = 0, C contains the column scale factors for A.
+*
+* ROWCND (output) DOUBLE PRECISION
+* If INFO = 0 or INFO > M, ROWCND contains the ratio of the
+* smallest R(i) to the largest R(i). If ROWCND >= 0.1 and
+* AMAX is neither too large nor too small, it is not worth
+* scaling by R.
+*
+* COLCND (output) DOUBLE PRECISION
+* If INFO = 0, COLCND contains the ratio of the smallest
+* C(i) to the largest C(i). If COLCND >= 0.1, it is not
+* worth scaling by C.
+*
+* AMAX (output) DOUBLE PRECISION
+* Absolute value of largest matrix element. If AMAX is very
+* close to overflow or very close to underflow, the matrix
+* should be scaled.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* > 0: if INFO = i, and i is
+* <= M: the i-th row of A is exactly zero
+* > M: the (i-M)-th column of A is exactly zero
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE, ZERO
+ PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, J, KD
+ DOUBLE PRECISION BIGNUM, RCMAX, RCMIN, SMLNUM
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DLAMCH
+ EXTERNAL DLAMCH
+* ..
+* .. External Subroutines ..
+ EXTERNAL XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters
+*
+ INFO = 0
+ IF( M.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( KL.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( KU.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( LDAB.LT.KL+KU+1 ) THEN
+ INFO = -6
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DGBEQU', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( M.EQ.0 .OR. N.EQ.0 ) THEN
+ ROWCND = ONE
+ COLCND = ONE
+ AMAX = ZERO
+ RETURN
+ END IF
+*
+* Get machine constants.
+*
+ SMLNUM = DLAMCH( 'S' )
+ BIGNUM = ONE / SMLNUM
+*
+* Compute row scale factors.
+*
+ DO 10 I = 1, M
+ R( I ) = ZERO
+ 10 CONTINUE
+*
+* Find the maximum element in each row.
+*
+ KD = KU + 1
+ DO 30 J = 1, N
+ DO 20 I = MAX( J-KU, 1 ), MIN( J+KL, M )
+ R( I ) = MAX( R( I ), ABS( AB( KD+I-J, J ) ) )
+ 20 CONTINUE
+ 30 CONTINUE
+*
+* Find the maximum and minimum scale factors.
+*
+ RCMIN = BIGNUM
+ RCMAX = ZERO
+ DO 40 I = 1, M
+ RCMAX = MAX( RCMAX, R( I ) )
+ RCMIN = MIN( RCMIN, R( I ) )
+ 40 CONTINUE
+ AMAX = RCMAX
+*
+ IF( RCMIN.EQ.ZERO ) THEN
+*
+* Find the first zero scale factor and return an error code.
+*
+ DO 50 I = 1, M
+ IF( R( I ).EQ.ZERO ) THEN
+ INFO = I
+ RETURN
+ END IF
+ 50 CONTINUE
+ ELSE
+*
+* Invert the scale factors.
+*
+ DO 60 I = 1, M
+ R( I ) = ONE / MIN( MAX( R( I ), SMLNUM ), BIGNUM )
+ 60 CONTINUE
+*
+* Compute ROWCND = min(R(I)) / max(R(I))
+*
+ ROWCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM )
+ END IF
+*
+* Compute column scale factors
+*
+ DO 70 J = 1, N
+ C( J ) = ZERO
+ 70 CONTINUE
+*
+* Find the maximum element in each column,
+* assuming the row scaling computed above.
+*
+ KD = KU + 1
+ DO 90 J = 1, N
+ DO 80 I = MAX( J-KU, 1 ), MIN( J+KL, M )
+ C( J ) = MAX( C( J ), ABS( AB( KD+I-J, J ) )*R( I ) )
+ 80 CONTINUE
+ 90 CONTINUE
+*
+* Find the maximum and minimum scale factors.
+*
+ RCMIN = BIGNUM
+ RCMAX = ZERO
+ DO 100 J = 1, N
+ RCMIN = MIN( RCMIN, C( J ) )
+ RCMAX = MAX( RCMAX, C( J ) )
+ 100 CONTINUE
+*
+ IF( RCMIN.EQ.ZERO ) THEN
+*
+* Find the first zero scale factor and return an error code.
+*
+ DO 110 J = 1, N
+ IF( C( J ).EQ.ZERO ) THEN
+ INFO = M + J
+ RETURN
+ END IF
+ 110 CONTINUE
+ ELSE
+*
+* Invert the scale factors.
+*
+ DO 120 J = 1, N
+ C( J ) = ONE / MIN( MAX( C( J ), SMLNUM ), BIGNUM )
+ 120 CONTINUE
+*
+* Compute COLCND = min(C(J)) / max(C(J))
+*
+ COLCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM )
+ END IF
+*
+ RETURN
+*
+* End of DGBEQU
+*
+ END
+ SUBROUTINE DGBRFS( TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB,
+ $ IPIV, B, LDB, X, LDX, FERR, BERR, WORK, IWORK,
+ $ INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH.
+*
+* .. Scalar Arguments ..
+ CHARACTER TRANS
+ INTEGER INFO, KL, KU, LDAB, LDAFB, LDB, LDX, N, NRHS
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * ), IWORK( * )
+ DOUBLE PRECISION AB( LDAB, * ), AFB( LDAFB, * ), B( LDB, * ),
+ $ BERR( * ), FERR( * ), WORK( * ), X( LDX, * )
+* ..
+*
+* Purpose
+* =======
+*
+* DGBRFS improves the computed solution to a system of linear
+* equations when the coefficient matrix is banded, and provides
+* error bounds and backward error estimates for the solution.
+*
+* Arguments
+* =========
+*
+* TRANS (input) CHARACTER*1
+* Specifies the form of the system of equations:
+* = 'N': A * X = B (No transpose)
+* = 'T': A**T * X = B (Transpose)
+* = 'C': A**H * X = B (Conjugate transpose = Transpose)
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* KL (input) INTEGER
+* The number of subdiagonals within the band of A. KL >= 0.
+*
+* KU (input) INTEGER
+* The number of superdiagonals within the band of A. KU >= 0.
+*
+* NRHS (input) INTEGER
+* The number of right hand sides, i.e., the number of columns
+* of the matrices B and X. NRHS >= 0.
+*
+* AB (input) DOUBLE PRECISION array, dimension (LDAB,N)
+* The original band matrix A, stored in rows 1 to KL+KU+1.
+* The j-th column of A is stored in the j-th column of the
+* array AB as follows:
+* AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(n,j+kl).
+*
+* LDAB (input) INTEGER
+* The leading dimension of the array AB. LDAB >= KL+KU+1.
+*
+* AFB (input) DOUBLE PRECISION array, dimension (LDAFB,N)
+* Details of the LU factorization of the band matrix A, as
+* computed by DGBTRF. U is stored as an upper triangular band
+* matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and
+* the multipliers used during the factorization are stored in
+* rows KL+KU+2 to 2*KL+KU+1.
+*
+* LDAFB (input) INTEGER
+* The leading dimension of the array AFB. LDAFB >= 2*KL*KU+1.
+*
+* IPIV (input) INTEGER array, dimension (N)
+* The pivot indices from DGBTRF; for 1<=i<=N, row i of the
+* matrix was interchanged with row IPIV(i).
+*
+* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS)
+* The right hand side matrix B.
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. LDB >= max(1,N).
+*
+* X (input/output) DOUBLE PRECISION array, dimension (LDX,NRHS)
+* On entry, the solution matrix X, as computed by DGBTRS.
+* On exit, the improved solution matrix X.
+*
+* LDX (input) INTEGER
+* The leading dimension of the array X. LDX >= max(1,N).
+*
+* FERR (output) DOUBLE PRECISION array, dimension (NRHS)
+* The estimated forward error bound for each solution vector
+* X(j) (the j-th column of the solution matrix X).
+* If XTRUE is the true solution corresponding to X(j), FERR(j)
+* is an estimated upper bound for the magnitude of the largest
+* element in (X(j) - XTRUE) divided by the magnitude of the
+* largest element in X(j). The estimate is as reliable as
+* the estimate for RCOND, and is almost always a slight
+* overestimate of the true error.
+*
+* BERR (output) DOUBLE PRECISION array, dimension (NRHS)
+* The componentwise relative backward error of each solution
+* vector X(j) (i.e., the smallest relative change in
+* any element of A or B that makes X(j) an exact solution).
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (3*N)
+*
+* IWORK (workspace) INTEGER array, dimension (N)
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+*
+* Internal Parameters
+* ===================
+*
+* ITMAX is the maximum number of steps of iterative refinement.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ INTEGER ITMAX
+ PARAMETER ( ITMAX = 5 )
+ DOUBLE PRECISION ZERO
+ PARAMETER ( ZERO = 0.0D+0 )
+ DOUBLE PRECISION ONE
+ PARAMETER ( ONE = 1.0D+0 )
+ DOUBLE PRECISION TWO
+ PARAMETER ( TWO = 2.0D+0 )
+ DOUBLE PRECISION THREE
+ PARAMETER ( THREE = 3.0D+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL NOTRAN
+ CHARACTER TRANST
+ INTEGER COUNT, I, J, K, KASE, KK, NZ
+ DOUBLE PRECISION EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK
+* ..
+* .. Local Arrays ..
+ INTEGER ISAVE( 3 )
+* ..
+* .. External Subroutines ..
+ EXTERNAL DAXPY, DCOPY, DGBMV, DGBTRS, DLACN2, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, MIN
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ DOUBLE PRECISION DLAMCH
+ EXTERNAL LSAME, DLAMCH
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ NOTRAN = LSAME( TRANS, 'N' )
+ IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT.
+ $ LSAME( TRANS, 'C' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( KL.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( KU.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( NRHS.LT.0 ) THEN
+ INFO = -5
+ ELSE IF( LDAB.LT.KL+KU+1 ) THEN
+ INFO = -7
+ ELSE IF( LDAFB.LT.2*KL+KU+1 ) THEN
+ INFO = -9
+ ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -12
+ ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
+ INFO = -14
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DGBRFS', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN
+ DO 10 J = 1, NRHS
+ FERR( J ) = ZERO
+ BERR( J ) = ZERO
+ 10 CONTINUE
+ RETURN
+ END IF
+*
+ IF( NOTRAN ) THEN
+ TRANST = 'T'
+ ELSE
+ TRANST = 'N'
+ END IF
+*
+* NZ = maximum number of nonzero elements in each row of A, plus 1
+*
+ NZ = MIN( KL+KU+2, N+1 )
+ EPS = DLAMCH( 'Epsilon' )
+ SAFMIN = DLAMCH( 'Safe minimum' )
+ SAFE1 = NZ*SAFMIN
+ SAFE2 = SAFE1 / EPS
+*
+* Do for each right hand side
+*
+ DO 140 J = 1, NRHS
+*
+ COUNT = 1
+ LSTRES = THREE
+ 20 CONTINUE
+*
+* Loop until stopping criterion is satisfied.
+*
+* Compute residual R = B - op(A) * X,
+* where op(A) = A, A**T, or A**H, depending on TRANS.
+*
+ CALL DCOPY( N, B( 1, J ), 1, WORK( N+1 ), 1 )
+ CALL DGBMV( TRANS, N, N, KL, KU, -ONE, AB, LDAB, X( 1, J ), 1,
+ $ ONE, WORK( N+1 ), 1 )
+*
+* Compute componentwise relative backward error from formula
+*
+* max(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) )
+*
+* where abs(Z) is the componentwise absolute value of the matrix
+* or vector Z. If the i-th component of the denominator is less
+* than SAFE2, then SAFE1 is added to the i-th components of the
+* numerator and denominator before dividing.
+*
+ DO 30 I = 1, N
+ WORK( I ) = ABS( B( I, J ) )
+ 30 CONTINUE
+*
+* Compute abs(op(A))*abs(X) + abs(B).
+*
+ IF( NOTRAN ) THEN
+ DO 50 K = 1, N
+ KK = KU + 1 - K
+ XK = ABS( X( K, J ) )
+ DO 40 I = MAX( 1, K-KU ), MIN( N, K+KL )
+ WORK( I ) = WORK( I ) + ABS( AB( KK+I, K ) )*XK
+ 40 CONTINUE
+ 50 CONTINUE
+ ELSE
+ DO 70 K = 1, N
+ S = ZERO
+ KK = KU + 1 - K
+ DO 60 I = MAX( 1, K-KU ), MIN( N, K+KL )
+ S = S + ABS( AB( KK+I, K ) )*ABS( X( I, J ) )
+ 60 CONTINUE
+ WORK( K ) = WORK( K ) + S
+ 70 CONTINUE
+ END IF
+ S = ZERO
+ DO 80 I = 1, N
+ IF( WORK( I ).GT.SAFE2 ) THEN
+ S = MAX( S, ABS( WORK( N+I ) ) / WORK( I ) )
+ ELSE
+ S = MAX( S, ( ABS( WORK( N+I ) )+SAFE1 ) /
+ $ ( WORK( I )+SAFE1 ) )
+ END IF
+ 80 CONTINUE
+ BERR( J ) = S
+*
+* Test stopping criterion. Continue iterating if
+* 1) The residual BERR(J) is larger than machine epsilon, and
+* 2) BERR(J) decreased by at least a factor of 2 during the
+* last iteration, and
+* 3) At most ITMAX iterations tried.
+*
+ IF( BERR( J ).GT.EPS .AND. TWO*BERR( J ).LE.LSTRES .AND.
+ $ COUNT.LE.ITMAX ) THEN
+*
+* Update solution and try again.
+*
+ CALL DGBTRS( TRANS, N, KL, KU, 1, AFB, LDAFB, IPIV,
+ $ WORK( N+1 ), N, INFO )
+ CALL DAXPY( N, ONE, WORK( N+1 ), 1, X( 1, J ), 1 )
+ LSTRES = BERR( J )
+ COUNT = COUNT + 1
+ GO TO 20
+ END IF
+*
+* Bound error from formula
+*
+* norm(X - XTRUE) / norm(X) .le. FERR =
+* norm( abs(inv(op(A)))*
+* ( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X)
+*
+* where
+* norm(Z) is the magnitude of the largest component of Z
+* inv(op(A)) is the inverse of op(A)
+* abs(Z) is the componentwise absolute value of the matrix or
+* vector Z
+* NZ is the maximum number of nonzeros in any row of A, plus 1
+* EPS is machine epsilon
+*
+* The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B))
+* is incremented by SAFE1 if the i-th component of
+* abs(op(A))*abs(X) + abs(B) is less than SAFE2.
+*
+* Use DLACN2 to estimate the infinity-norm of the matrix
+* inv(op(A)) * diag(W),
+* where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) )))
+*
+ DO 90 I = 1, N
+ IF( WORK( I ).GT.SAFE2 ) THEN
+ WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I )
+ ELSE
+ WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I ) + SAFE1
+ END IF
+ 90 CONTINUE
+*
+ KASE = 0
+ 100 CONTINUE
+ CALL DLACN2( N, WORK( 2*N+1 ), WORK( N+1 ), IWORK, FERR( J ),
+ $ KASE, ISAVE )
+ IF( KASE.NE.0 ) THEN
+ IF( KASE.EQ.1 ) THEN
+*
+* Multiply by diag(W)*inv(op(A)**T).
+*
+ CALL DGBTRS( TRANST, N, KL, KU, 1, AFB, LDAFB, IPIV,
+ $ WORK( N+1 ), N, INFO )
+ DO 110 I = 1, N
+ WORK( N+I ) = WORK( N+I )*WORK( I )
+ 110 CONTINUE
+ ELSE
+*
+* Multiply by inv(op(A))*diag(W).
+*
+ DO 120 I = 1, N
+ WORK( N+I ) = WORK( N+I )*WORK( I )
+ 120 CONTINUE
+ CALL DGBTRS( TRANS, N, KL, KU, 1, AFB, LDAFB, IPIV,
+ $ WORK( N+1 ), N, INFO )
+ END IF
+ GO TO 100
+ END IF
+*
+* Normalize error.
+*
+ LSTRES = ZERO
+ DO 130 I = 1, N
+ LSTRES = MAX( LSTRES, ABS( X( I, J ) ) )
+ 130 CONTINUE
+ IF( LSTRES.NE.ZERO )
+ $ FERR( J ) = FERR( J ) / LSTRES
+*
+ 140 CONTINUE
+*
+ RETURN
+*
+* End of DGBRFS
+*
+ END
+ SUBROUTINE DGBSV( N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB, INFO )
+*
+* -- LAPACK driver routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, KL, KU, LDAB, LDB, N, NRHS
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ DOUBLE PRECISION AB( LDAB, * ), B( LDB, * )
+* ..
+*
+* Purpose
+* =======
+*
+* DGBSV computes the solution to a real system of linear equations
+* A * X = B, where A is a band matrix of order N with KL subdiagonals
+* and KU superdiagonals, and X and B are N-by-NRHS matrices.
+*
+* The LU decomposition with partial pivoting and row interchanges is
+* used to factor A as A = L * U, where L is a product of permutation
+* and unit lower triangular matrices with KL subdiagonals, and U is
+* upper triangular with KL+KU superdiagonals. The factored form of A
+* is then used to solve the system of equations A * X = B.
+*
+* Arguments
+* =========
+*
+* N (input) INTEGER
+* The number of linear equations, i.e., the order of the
+* matrix A. N >= 0.
+*
+* KL (input) INTEGER
+* The number of subdiagonals within the band of A. KL >= 0.
+*
+* KU (input) INTEGER
+* The number of superdiagonals within the band of A. KU >= 0.
+*
+* NRHS (input) INTEGER
+* The number of right hand sides, i.e., the number of columns
+* of the matrix B. NRHS >= 0.
+*
+* AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N)
+* On entry, the matrix A in band storage, in rows KL+1 to
+* 2*KL+KU+1; rows 1 to KL of the array need not be set.
+* The j-th column of A is stored in the j-th column of the
+* array AB as follows:
+* AB(KL+KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+KL)
+* On exit, details of the factorization: U is stored as an
+* upper triangular band matrix with KL+KU superdiagonals in
+* rows 1 to KL+KU+1, and the multipliers used during the
+* factorization are stored in rows KL+KU+2 to 2*KL+KU+1.
+* See below for further details.
+*
+* LDAB (input) INTEGER
+* The leading dimension of the array AB. LDAB >= 2*KL+KU+1.
+*
+* IPIV (output) INTEGER array, dimension (N)
+* The pivot indices that define the permutation matrix P;
+* row i of the matrix was interchanged with row IPIV(i).
+*
+* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
+* On entry, the N-by-NRHS right hand side matrix B.
+* On exit, if INFO = 0, the N-by-NRHS solution matrix X.
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. LDB >= max(1,N).
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* > 0: if INFO = i, U(i,i) is exactly zero. The factorization
+* has been completed, but the factor U is exactly
+* singular, and the solution has not been computed.
+*
+* Further Details
+* ===============
+*
+* The band storage scheme is illustrated by the following example, when
+* M = N = 6, KL = 2, KU = 1:
+*
+* On entry: On exit:
+*
+* * * * + + + * * * u14 u25 u36
+* * * + + + + * * u13 u24 u35 u46
+* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56
+* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66
+* a21 a32 a43 a54 a65 * m21 m32 m43 m54 m65 *
+* a31 a42 a53 a64 * * m31 m42 m53 m64 * *
+*
+* Array elements marked * are not used by the routine; elements marked
+* + need not be set on entry, but are required by the routine to store
+* elements of U because of fill-in resulting from the row interchanges.
+*
+* =====================================================================
+*
+* .. External Subroutines ..
+ EXTERNAL DGBTRF, DGBTRS, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ IF( N.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( KL.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( KU.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( NRHS.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( LDAB.LT.2*KL+KU+1 ) THEN
+ INFO = -6
+ ELSE IF( LDB.LT.MAX( N, 1 ) ) THEN
+ INFO = -9
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DGBSV ', -INFO )
+ RETURN
+ END IF
+*
+* Compute the LU factorization of the band matrix A.
+*
+ CALL DGBTRF( N, N, KL, KU, AB, LDAB, IPIV, INFO )
+ IF( INFO.EQ.0 ) THEN
+*
+* Solve the system A*X = B, overwriting B with X.
+*
+ CALL DGBTRS( 'No transpose', N, KL, KU, NRHS, AB, LDAB, IPIV,
+ $ B, LDB, INFO )
+ END IF
+ RETURN
+*
+* End of DGBSV
+*
+ END
+ 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 )
+*
+* -- LAPACK driver routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER EQUED, FACT, TRANS
+ INTEGER INFO, KL, KU, LDAB, LDAFB, LDB, LDX, N, NRHS
+ DOUBLE PRECISION RCOND
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * ), IWORK( * )
+ DOUBLE PRECISION AB( LDAB, * ), AFB( LDAFB, * ), B( LDB, * ),
+ $ BERR( * ), C( * ), FERR( * ), R( * ),
+ $ WORK( * ), X( LDX, * )
+* ..
+*
+* Purpose
+* =======
+*
+* DGBSVX uses the LU factorization to compute the solution to a real
+* system of linear equations A * X = B, A**T * X = B, or A**H * X = B,
+* where A is a band matrix of order N with KL subdiagonals and KU
+* superdiagonals, and X and B are N-by-NRHS matrices.
+*
+* Error bounds on the solution and a condition estimate are also
+* provided.
+*
+* Description
+* ===========
+*
+* The following steps are performed by this subroutine:
+*
+* 1. If FACT = 'E', real scaling factors are computed to equilibrate
+* the system:
+* TRANS = 'N': diag(R)*A*diag(C) *inv(diag(C))*X = diag(R)*B
+* TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B
+* TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B
+* Whether or not the system will be equilibrated depends on the
+* scaling of the matrix A, but if equilibration is used, A is
+* overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N')
+* or diag(C)*B (if TRANS = 'T' or 'C').
+*
+* 2. If FACT = 'N' or 'E', the LU decomposition is used to factor the
+* matrix A (after equilibration if FACT = 'E') as
+* A = L * U,
+* where L is a product of permutation and unit lower triangular
+* matrices with KL subdiagonals, and U is upper triangular with
+* KL+KU superdiagonals.
+*
+* 3. If some U(i,i)=0, so that U is exactly singular, then the routine
+* returns with INFO = i. Otherwise, the factored form of A is used
+* to estimate the condition number of the matrix A. If the
+* reciprocal of the condition number is less than machine precision,
+* INFO = N+1 is returned as a warning, but the routine still goes on
+* to solve for X and compute error bounds as described below.
+*
+* 4. The system of equations is solved for X using the factored form
+* of A.
+*
+* 5. Iterative refinement is applied to improve the computed solution
+* matrix and calculate error bounds and backward error estimates
+* for it.
+*
+* 6. If equilibration was used, the matrix X is premultiplied by
+* diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so
+* that it solves the original system before equilibration.
+*
+* Arguments
+* =========
+*
+* FACT (input) CHARACTER*1
+* Specifies whether or not the factored form of the matrix A is
+* supplied on entry, and if not, whether the matrix A should be
+* equilibrated before it is factored.
+* = 'F': On entry, AFB and IPIV contain the factored form of
+* A. If EQUED is not 'N', the matrix A has been
+* equilibrated with scaling factors given by R and C.
+* AB, AFB, and IPIV are not modified.
+* = 'N': The matrix A will be copied to AFB and factored.
+* = 'E': The matrix A will be equilibrated if necessary, then
+* copied to AFB and factored.
+*
+* TRANS (input) CHARACTER*1
+* Specifies the form of the system of equations.
+* = 'N': A * X = B (No transpose)
+* = 'T': A**T * X = B (Transpose)
+* = 'C': A**H * X = B (Transpose)
+*
+* N (input) INTEGER
+* The number of linear equations, i.e., the order of the
+* matrix A. N >= 0.
+*
+* KL (input) INTEGER
+* The number of subdiagonals within the band of A. KL >= 0.
+*
+* KU (input) INTEGER
+* The number of superdiagonals within the band of A. KU >= 0.
+*
+* NRHS (input) INTEGER
+* The number of right hand sides, i.e., the number of columns
+* of the matrices B and X. NRHS >= 0.
+*
+* AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N)
+* On entry, the matrix A in band storage, in rows 1 to KL+KU+1.
+* The j-th column of A is stored in the j-th column of the
+* array AB as follows:
+* AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl)
+*
+* If FACT = 'F' and EQUED is not 'N', then A must have been
+* equilibrated by the scaling factors in R and/or C. AB is not
+* modified if FACT = 'F' or 'N', or if FACT = 'E' and
+* EQUED = 'N' on exit.
+*
+* On exit, if EQUED .ne. 'N', A is scaled as follows:
+* EQUED = 'R': A := diag(R) * A
+* EQUED = 'C': A := A * diag(C)
+* EQUED = 'B': A := diag(R) * A * diag(C).
+*
+* LDAB (input) INTEGER
+* The leading dimension of the array AB. LDAB >= KL+KU+1.
+*
+* AFB (input or output) DOUBLE PRECISION array, dimension (LDAFB,N)
+* If FACT = 'F', then AFB is an input argument and on entry
+* contains details of the LU factorization of the band matrix
+* A, as computed by DGBTRF. U is stored as an upper triangular
+* band matrix with KL+KU superdiagonals in rows 1 to KL+KU+1,
+* and the multipliers used during the factorization are stored
+* in rows KL+KU+2 to 2*KL+KU+1. If EQUED .ne. 'N', then AFB is
+* the factored form of the equilibrated matrix A.
+*
+* If FACT = 'N', then AFB is an output argument and on exit
+* returns details of the LU factorization of A.
+*
+* If FACT = 'E', then AFB is an output argument and on exit
+* returns details of the LU factorization of the equilibrated
+* matrix A (see the description of AB for the form of the
+* equilibrated matrix).
+*
+* LDAFB (input) INTEGER
+* The leading dimension of the array AFB. LDAFB >= 2*KL+KU+1.
+*
+* IPIV (input or output) INTEGER array, dimension (N)
+* If FACT = 'F', then IPIV is an input argument and on entry
+* contains the pivot indices from the factorization A = L*U
+* as computed by DGBTRF; row i of the matrix was interchanged
+* with row IPIV(i).
+*
+* If FACT = 'N', then IPIV is an output argument and on exit
+* contains the pivot indices from the factorization A = L*U
+* of the original matrix A.
+*
+* If FACT = 'E', then IPIV is an output argument and on exit
+* contains the pivot indices from the factorization A = L*U
+* of the equilibrated matrix A.
+*
+* EQUED (input or output) CHARACTER*1
+* Specifies the form of equilibration that was done.
+* = 'N': No equilibration (always true if FACT = 'N').
+* = 'R': Row equilibration, i.e., A has been premultiplied by
+* diag(R).
+* = 'C': Column equilibration, i.e., A has been postmultiplied
+* by diag(C).
+* = 'B': Both row and column equilibration, i.e., A has been
+* replaced by diag(R) * A * diag(C).
+* EQUED is an input argument if FACT = 'F'; otherwise, it is an
+* output argument.
+*
+* R (input or output) DOUBLE PRECISION array, dimension (N)
+* The row scale factors for A. If EQUED = 'R' or 'B', A is
+* multiplied on the left by diag(R); if EQUED = 'N' or 'C', R
+* is not accessed. R is an input argument if FACT = 'F';
+* otherwise, R is an output argument. If FACT = 'F' and
+* EQUED = 'R' or 'B', each element of R must be positive.
+*
+* C (input or output) DOUBLE PRECISION array, dimension (N)
+* The column scale factors for A. If EQUED = 'C' or 'B', A is
+* multiplied on the right by diag(C); if EQUED = 'N' or 'R', C
+* is not accessed. C is an input argument if FACT = 'F';
+* otherwise, C is an output argument. If FACT = 'F' and
+* EQUED = 'C' or 'B', each element of C must be positive.
+*
+* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
+* On entry, the right hand side matrix B.
+* On exit,
+* if EQUED = 'N', B is not modified;
+* if TRANS = 'N' and EQUED = 'R' or 'B', B is overwritten by
+* diag(R)*B;
+* if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', B is
+* overwritten by diag(C)*B.
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. LDB >= max(1,N).
+*
+* X (output) DOUBLE PRECISION array, dimension (LDX,NRHS)
+* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X
+* to the original system of equations. Note that A and B are
+* modified on exit if EQUED .ne. 'N', and the solution to the
+* equilibrated system is inv(diag(C))*X if TRANS = 'N' and
+* EQUED = 'C' or 'B', or inv(diag(R))*X if TRANS = 'T' or 'C'
+* and EQUED = 'R' or 'B'.
+*
+* LDX (input) INTEGER
+* The leading dimension of the array X. LDX >= max(1,N).
+*
+* RCOND (output) DOUBLE PRECISION
+* The estimate of the reciprocal condition number of the matrix
+* A after equilibration (if done). If RCOND is less than the
+* machine precision (in particular, if RCOND = 0), the matrix
+* is singular to working precision. This condition is
+* indicated by a return code of INFO > 0.
+*
+* FERR (output) DOUBLE PRECISION array, dimension (NRHS)
+* The estimated forward error bound for each solution vector
+* X(j) (the j-th column of the solution matrix X).
+* If XTRUE is the true solution corresponding to X(j), FERR(j)
+* is an estimated upper bound for the magnitude of the largest
+* element in (X(j) - XTRUE) divided by the magnitude of the
+* largest element in X(j). The estimate is as reliable as
+* the estimate for RCOND, and is almost always a slight
+* overestimate of the true error.
+*
+* BERR (output) DOUBLE PRECISION array, dimension (NRHS)
+* The componentwise relative backward error of each solution
+* vector X(j) (i.e., the smallest relative change in
+* any element of A or B that makes X(j) an exact solution).
+*
+* WORK (workspace/output) DOUBLE PRECISION array, dimension (3*N)
+* On exit, WORK(1) contains the reciprocal pivot growth
+* factor norm(A)/norm(U). The "max absolute element" norm is
+* used. If WORK(1) is much less than 1, then the stability
+* of the LU factorization of the (equilibrated) matrix A
+* could be poor. This also means that the solution X, condition
+* estimator RCOND, and forward error bound FERR could be
+* unreliable. If factorization fails with 0<INFO<=N, then
+* WORK(1) contains the reciprocal pivot growth factor for the
+* leading INFO columns of A.
+*
+* IWORK (workspace) INTEGER array, dimension (N)
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* > 0: if INFO = i, and i is
+* <= N: U(i,i) is exactly zero. The factorization
+* has been completed, but the factor U is exactly
+* singular, so the solution and error bounds
+* could not be computed. RCOND = 0 is returned.
+* = N+1: U is nonsingular, but RCOND is less than machine
+* precision, meaning that the matrix is singular
+* to working precision. Nevertheless, the
+* solution and error bounds are computed because
+* there are a number of situations where the
+* computed solution can be more accurate than the
+* value of RCOND would suggest.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL COLEQU, EQUIL, NOFACT, NOTRAN, ROWEQU
+ CHARACTER NORM
+ INTEGER I, INFEQU, J, J1, J2
+ DOUBLE PRECISION AMAX, ANORM, BIGNUM, COLCND, RCMAX, RCMIN,
+ $ ROWCND, RPVGRW, SMLNUM
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ DOUBLE PRECISION DLAMCH, DLANGB, DLANTB
+ EXTERNAL LSAME, DLAMCH, DLANGB, DLANTB
+* ..
+* .. External Subroutines ..
+ EXTERNAL DCOPY, DGBCON, DGBEQU, DGBRFS, DGBTRF, DGBTRS,
+ $ DLACPY, DLAQGB, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+ INFO = 0
+ NOFACT = LSAME( FACT, 'N' )
+ EQUIL = LSAME( FACT, 'E' )
+ NOTRAN = LSAME( TRANS, 'N' )
+ IF( NOFACT .OR. EQUIL ) THEN
+ EQUED = 'N'
+ ROWEQU = .FALSE.
+ COLEQU = .FALSE.
+ ELSE
+ ROWEQU = LSAME( EQUED, 'R' ) .OR. LSAME( EQUED, 'B' )
+ COLEQU = LSAME( EQUED, 'C' ) .OR. LSAME( EQUED, 'B' )
+ SMLNUM = DLAMCH( 'Safe minimum' )
+ BIGNUM = ONE / SMLNUM
+ END IF
+*
+* Test the input parameters.
+*
+ IF( .NOT.NOFACT .AND. .NOT.EQUIL .AND. .NOT.LSAME( FACT, 'F' ) )
+ $ THEN
+ INFO = -1
+ ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT.
+ $ LSAME( TRANS, 'C' ) ) THEN
+ INFO = -2
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( KL.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( KU.LT.0 ) THEN
+ INFO = -5
+ ELSE IF( NRHS.LT.0 ) THEN
+ INFO = -6
+ ELSE IF( LDAB.LT.KL+KU+1 ) THEN
+ INFO = -8
+ ELSE IF( LDAFB.LT.2*KL+KU+1 ) THEN
+ INFO = -10
+ ELSE IF( LSAME( FACT, 'F' ) .AND. .NOT.
+ $ ( ROWEQU .OR. COLEQU .OR. LSAME( EQUED, 'N' ) ) ) THEN
+ INFO = -12
+ ELSE
+ IF( ROWEQU ) THEN
+ RCMIN = BIGNUM
+ RCMAX = ZERO
+ DO 10 J = 1, N
+ RCMIN = MIN( RCMIN, R( J ) )
+ RCMAX = MAX( RCMAX, R( J ) )
+ 10 CONTINUE
+ IF( RCMIN.LE.ZERO ) THEN
+ INFO = -13
+ ELSE IF( N.GT.0 ) THEN
+ ROWCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM )
+ ELSE
+ ROWCND = ONE
+ END IF
+ END IF
+ IF( COLEQU .AND. INFO.EQ.0 ) THEN
+ RCMIN = BIGNUM
+ RCMAX = ZERO
+ DO 20 J = 1, N
+ RCMIN = MIN( RCMIN, C( J ) )
+ RCMAX = MAX( RCMAX, C( J ) )
+ 20 CONTINUE
+ IF( RCMIN.LE.ZERO ) THEN
+ INFO = -14
+ ELSE IF( N.GT.0 ) THEN
+ COLCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM )
+ ELSE
+ COLCND = ONE
+ END IF
+ END IF
+ IF( INFO.EQ.0 ) THEN
+ IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -16
+ ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
+ INFO = -18
+ END IF
+ END IF
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DGBSVX', -INFO )
+ RETURN
+ END IF
+*
+ IF( EQUIL ) THEN
+*
+* Compute row and column scalings to equilibrate the matrix A.
+*
+ CALL DGBEQU( N, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND,
+ $ AMAX, INFEQU )
+ IF( INFEQU.EQ.0 ) THEN
+*
+* Equilibrate the matrix.
+*
+ CALL DLAQGB( N, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND,
+ $ AMAX, EQUED )
+ ROWEQU = LSAME( EQUED, 'R' ) .OR. LSAME( EQUED, 'B' )
+ COLEQU = LSAME( EQUED, 'C' ) .OR. LSAME( EQUED, 'B' )
+ END IF
+ END IF
+*
+* Scale the right hand side.
+*
+ IF( NOTRAN ) THEN
+ IF( ROWEQU ) THEN
+ DO 40 J = 1, NRHS
+ DO 30 I = 1, N
+ B( I, J ) = R( I )*B( I, J )
+ 30 CONTINUE
+ 40 CONTINUE
+ END IF
+ ELSE IF( COLEQU ) THEN
+ DO 60 J = 1, NRHS
+ DO 50 I = 1, N
+ B( I, J ) = C( I )*B( I, J )
+ 50 CONTINUE
+ 60 CONTINUE
+ END IF
+*
+ IF( NOFACT .OR. EQUIL ) THEN
+*
+* Compute the LU factorization of the band matrix A.
+*
+ DO 70 J = 1, N
+ J1 = MAX( J-KU, 1 )
+ J2 = MIN( J+KL, N )
+ CALL DCOPY( J2-J1+1, AB( KU+1-J+J1, J ), 1,
+ $ AFB( KL+KU+1-J+J1, J ), 1 )
+ 70 CONTINUE
+*
+ CALL DGBTRF( N, N, KL, KU, AFB, LDAFB, IPIV, INFO )
+*
+* Return if INFO is non-zero.
+*
+ IF( INFO.GT.0 ) THEN
+*
+* Compute the reciprocal pivot growth factor of the
+* leading rank-deficient INFO columns of A.
+*
+ ANORM = ZERO
+ DO 90 J = 1, INFO
+ DO 80 I = MAX( KU+2-J, 1 ), MIN( N+KU+1-J, KL+KU+1 )
+ ANORM = MAX( ANORM, ABS( AB( I, J ) ) )
+ 80 CONTINUE
+ 90 CONTINUE
+ RPVGRW = DLANTB( 'M', 'U', 'N', INFO, MIN( INFO-1, KL+KU ),
+ $ AFB( MAX( 1, KL+KU+2-INFO ), 1 ), LDAFB,
+ $ WORK )
+ IF( RPVGRW.EQ.ZERO ) THEN
+ RPVGRW = ONE
+ ELSE
+ RPVGRW = ANORM / RPVGRW
+ END IF
+ WORK( 1 ) = RPVGRW
+ RCOND = ZERO
+ RETURN
+ END IF
+ END IF
+*
+* Compute the norm of the matrix A and the
+* reciprocal pivot growth factor RPVGRW.
+*
+ IF( NOTRAN ) THEN
+ NORM = '1'
+ ELSE
+ NORM = 'I'
+ END IF
+ ANORM = DLANGB( NORM, N, KL, KU, AB, LDAB, WORK )
+ RPVGRW = DLANTB( 'M', 'U', 'N', N, KL+KU, AFB, LDAFB, WORK )
+ IF( RPVGRW.EQ.ZERO ) THEN
+ RPVGRW = ONE
+ ELSE
+ RPVGRW = DLANGB( 'M', N, KL, KU, AB, LDAB, WORK ) / RPVGRW
+ END IF
+*
+* Compute the reciprocal of the condition number of A.
+*
+ CALL DGBCON( NORM, N, KL, KU, AFB, LDAFB, IPIV, ANORM, RCOND,
+ $ WORK, IWORK, INFO )
+*
+* Compute the solution matrix X.
+*
+ CALL DLACPY( 'Full', N, NRHS, B, LDB, X, LDX )
+ CALL DGBTRS( TRANS, N, KL, KU, NRHS, AFB, LDAFB, IPIV, X, LDX,
+ $ INFO )
+*
+* Use iterative refinement to improve the computed solution and
+* compute error bounds and backward error estimates for it.
+*
+ CALL DGBRFS( TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, IPIV,
+ $ B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO )
+*
+* Transform the solution matrix X to a solution of the original
+* system.
+*
+ IF( NOTRAN ) THEN
+ IF( COLEQU ) THEN
+ DO 110 J = 1, NRHS
+ DO 100 I = 1, N
+ X( I, J ) = C( I )*X( I, J )
+ 100 CONTINUE
+ 110 CONTINUE
+ DO 120 J = 1, NRHS
+ FERR( J ) = FERR( J ) / COLCND
+ 120 CONTINUE
+ END IF
+ ELSE IF( ROWEQU ) THEN
+ DO 140 J = 1, NRHS
+ DO 130 I = 1, N
+ X( I, J ) = R( I )*X( I, J )
+ 130 CONTINUE
+ 140 CONTINUE
+ DO 150 J = 1, NRHS
+ FERR( J ) = FERR( J ) / ROWCND
+ 150 CONTINUE
+ END IF
+*
+* Set INFO = N+1 if the matrix is singular to working precision.
+*
+ IF( RCOND.LT.DLAMCH( 'Epsilon' ) )
+ $ INFO = N + 1
+*
+ WORK( 1 ) = RPVGRW
+ RETURN
+*
+* End of DGBSVX
+*
+ END
+ SUBROUTINE DGBTF2( M, N, KL, KU, AB, LDAB, IPIV, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, KL, KU, LDAB, M, N
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ DOUBLE PRECISION AB( LDAB, * )
+* ..
+*
+* Purpose
+* =======
+*
+* DGBTF2 computes an LU factorization of a real m-by-n band matrix A
+* using partial pivoting with row interchanges.
+*
+* This is the unblocked version of the algorithm, calling Level 2 BLAS.
+*
+* Arguments
+* =========
+*
+* M (input) INTEGER
+* The number of rows of the matrix A. M >= 0.
+*
+* N (input) INTEGER
+* The number of columns of the matrix A. N >= 0.
+*
+* KL (input) INTEGER
+* The number of subdiagonals within the band of A. KL >= 0.
+*
+* KU (input) INTEGER
+* The number of superdiagonals within the band of A. KU >= 0.
+*
+* AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N)
+* On entry, the matrix A in band storage, in rows KL+1 to
+* 2*KL+KU+1; rows 1 to KL of the array need not be set.
+* The j-th column of A is stored in the j-th column of the
+* array AB as follows:
+* AB(kl+ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl)
+*
+* On exit, details of the factorization: U is stored as an
+* upper triangular band matrix with KL+KU superdiagonals in
+* rows 1 to KL+KU+1, and the multipliers used during the
+* factorization are stored in rows KL+KU+2 to 2*KL+KU+1.
+* See below for further details.
+*
+* LDAB (input) INTEGER
+* The leading dimension of the array AB. LDAB >= 2*KL+KU+1.
+*
+* IPIV (output) INTEGER array, dimension (min(M,N))
+* The pivot indices; for 1 <= i <= min(M,N), row i of the
+* matrix was interchanged with row IPIV(i).
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* > 0: if INFO = +i, U(i,i) is exactly zero. The factorization
+* has been completed, but the factor U is exactly
+* singular, and division by zero will occur if it is used
+* to solve a system of equations.
+*
+* Further Details
+* ===============
+*
+* The band storage scheme is illustrated by the following example, when
+* M = N = 6, KL = 2, KU = 1:
+*
+* On entry: On exit:
+*
+* * * * + + + * * * u14 u25 u36
+* * * + + + + * * u13 u24 u35 u46
+* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56
+* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66
+* a21 a32 a43 a54 a65 * m21 m32 m43 m54 m65 *
+* a31 a42 a53 a64 * * m31 m42 m53 m64 * *
+*
+* Array elements marked * are not used by the routine; elements marked
+* + need not be set on entry, but are required by the routine to store
+* elements of U, because of fill-in resulting from the row
+* interchanges.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE, ZERO
+ PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, J, JP, JU, KM, KV
+* ..
+* .. External Functions ..
+ INTEGER IDAMAX
+ EXTERNAL IDAMAX
+* ..
+* .. External Subroutines ..
+ EXTERNAL DGER, DSCAL, DSWAP, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+* KV is the number of superdiagonals in the factor U, allowing for
+* fill-in.
+*
+ KV = KU + KL
+*
+* Test the input parameters.
+*
+ INFO = 0
+ IF( M.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( KL.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( KU.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( LDAB.LT.KL+KV+1 ) THEN
+ INFO = -6
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DGBTF2', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( M.EQ.0 .OR. N.EQ.0 )
+ $ RETURN
+*
+* Gaussian elimination with partial pivoting
+*
+* Set fill-in elements in columns KU+2 to KV to zero.
+*
+ DO 20 J = KU + 2, MIN( KV, N )
+ DO 10 I = KV - J + 2, KL
+ AB( I, J ) = ZERO
+ 10 CONTINUE
+ 20 CONTINUE
+*
+* JU is the index of the last column affected by the current stage
+* of the factorization.
+*
+ JU = 1
+*
+ DO 40 J = 1, MIN( M, N )
+*
+* Set fill-in elements in column J+KV to zero.
+*
+ IF( J+KV.LE.N ) THEN
+ DO 30 I = 1, KL
+ AB( I, J+KV ) = ZERO
+ 30 CONTINUE
+ END IF
+*
+* Find pivot and test for singularity. KM is the number of
+* subdiagonal elements in the current column.
+*
+ KM = MIN( KL, M-J )
+ JP = IDAMAX( KM+1, AB( KV+1, J ), 1 )
+ IPIV( J ) = JP + J - 1
+ IF( AB( KV+JP, J ).NE.ZERO ) THEN
+ JU = MAX( JU, MIN( J+KU+JP-1, N ) )
+*
+* Apply interchange to columns J to JU.
+*
+ IF( JP.NE.1 )
+ $ CALL DSWAP( JU-J+1, AB( KV+JP, J ), LDAB-1,
+ $ AB( KV+1, J ), LDAB-1 )
+*
+ IF( KM.GT.0 ) THEN
+*
+* Compute multipliers.
+*
+ CALL DSCAL( KM, ONE / AB( KV+1, J ), AB( KV+2, J ), 1 )
+*
+* Update trailing submatrix within the band.
+*
+ IF( JU.GT.J )
+ $ CALL DGER( KM, JU-J, -ONE, AB( KV+2, J ), 1,
+ $ AB( KV, J+1 ), LDAB-1, AB( KV+1, J+1 ),
+ $ LDAB-1 )
+ END IF
+ ELSE
+*
+* If pivot is zero, set INFO to the index of the pivot
+* unless a zero pivot has already been found.
+*
+ IF( INFO.EQ.0 )
+ $ INFO = J
+ END IF
+ 40 CONTINUE
+ RETURN
+*
+* End of DGBTF2
+*
+ END
+ SUBROUTINE DGBTRF( M, N, KL, KU, AB, LDAB, IPIV, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, KL, KU, LDAB, M, N
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ DOUBLE PRECISION AB( LDAB, * )
+* ..
+*
+* Purpose
+* =======
+*
+* DGBTRF computes an LU factorization of a real m-by-n band matrix A
+* using partial pivoting with row interchanges.
+*
+* This is the blocked version of the algorithm, calling Level 3 BLAS.
+*
+* Arguments
+* =========
+*
+* M (input) INTEGER
+* The number of rows of the matrix A. M >= 0.
+*
+* N (input) INTEGER
+* The number of columns of the matrix A. N >= 0.
+*
+* KL (input) INTEGER
+* The number of subdiagonals within the band of A. KL >= 0.
+*
+* KU (input) INTEGER
+* The number of superdiagonals within the band of A. KU >= 0.
+*
+* AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N)
+* On entry, the matrix A in band storage, in rows KL+1 to
+* 2*KL+KU+1; rows 1 to KL of the array need not be set.
+* The j-th column of A is stored in the j-th column of the
+* array AB as follows:
+* AB(kl+ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl)
+*
+* On exit, details of the factorization: U is stored as an
+* upper triangular band matrix with KL+KU superdiagonals in
+* rows 1 to KL+KU+1, and the multipliers used during the
+* factorization are stored in rows KL+KU+2 to 2*KL+KU+1.
+* See below for further details.
+*
+* LDAB (input) INTEGER
+* The leading dimension of the array AB. LDAB >= 2*KL+KU+1.
+*
+* IPIV (output) INTEGER array, dimension (min(M,N))
+* The pivot indices; for 1 <= i <= min(M,N), row i of the
+* matrix was interchanged with row IPIV(i).
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* > 0: if INFO = +i, U(i,i) is exactly zero. The factorization
+* has been completed, but the factor U is exactly
+* singular, and division by zero will occur if it is used
+* to solve a system of equations.
+*
+* Further Details
+* ===============
+*
+* The band storage scheme is illustrated by the following example, when
+* M = N = 6, KL = 2, KU = 1:
+*
+* On entry: On exit:
+*
+* * * * + + + * * * u14 u25 u36
+* * * + + + + * * u13 u24 u35 u46
+* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56
+* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66
+* a21 a32 a43 a54 a65 * m21 m32 m43 m54 m65 *
+* a31 a42 a53 a64 * * m31 m42 m53 m64 * *
+*
+* Array elements marked * are not used by the routine; elements marked
+* + need not be set on entry, but are required by the routine to store
+* elements of U because of fill-in resulting from the row interchanges.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE, ZERO
+ PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
+ INTEGER NBMAX, LDWORK
+ PARAMETER ( NBMAX = 64, LDWORK = NBMAX+1 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, I2, I3, II, IP, J, J2, J3, JB, JJ, JM, JP,
+ $ JU, K2, KM, KV, NB, NW
+ DOUBLE PRECISION TEMP
+* ..
+* .. Local Arrays ..
+ DOUBLE PRECISION WORK13( LDWORK, NBMAX ),
+ $ WORK31( LDWORK, NBMAX )
+* ..
+* .. External Functions ..
+ INTEGER IDAMAX, ILAENV
+ EXTERNAL IDAMAX, ILAENV
+* ..
+* .. External Subroutines ..
+ EXTERNAL DCOPY, DGBTF2, DGEMM, DGER, DLASWP, DSCAL,
+ $ DSWAP, DTRSM, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+* KV is the number of superdiagonals in the factor U, allowing for
+* fill-in
+*
+ KV = KU + KL
+*
+* Test the input parameters.
+*
+ INFO = 0
+ IF( M.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( KL.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( KU.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( LDAB.LT.KL+KV+1 ) THEN
+ INFO = -6
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DGBTRF', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( M.EQ.0 .OR. N.EQ.0 )
+ $ RETURN
+*
+* Determine the block size for this environment
+*
+ NB = ILAENV( 1, 'DGBTRF', ' ', M, N, KL, KU )
+*
+* The block size must not exceed the limit set by the size of the
+* local arrays WORK13 and WORK31.
+*
+ NB = MIN( NB, NBMAX )
+*
+ IF( NB.LE.1 .OR. NB.GT.KL ) THEN
+*
+* Use unblocked code
+*
+ CALL DGBTF2( M, N, KL, KU, AB, LDAB, IPIV, INFO )
+ ELSE
+*
+* Use blocked code
+*
+* Zero the superdiagonal elements of the work array WORK13
+*
+ DO 20 J = 1, NB
+ DO 10 I = 1, J - 1
+ WORK13( I, J ) = ZERO
+ 10 CONTINUE
+ 20 CONTINUE
+*
+* Zero the subdiagonal elements of the work array WORK31
+*
+ DO 40 J = 1, NB
+ DO 30 I = J + 1, NB
+ WORK31( I, J ) = ZERO
+ 30 CONTINUE
+ 40 CONTINUE
+*
+* Gaussian elimination with partial pivoting
+*
+* Set fill-in elements in columns KU+2 to KV to zero
+*
+ DO 60 J = KU + 2, MIN( KV, N )
+ DO 50 I = KV - J + 2, KL
+ AB( I, J ) = ZERO
+ 50 CONTINUE
+ 60 CONTINUE
+*
+* JU is the index of the last column affected by the current
+* stage of the factorization
+*
+ JU = 1
+*
+ DO 180 J = 1, MIN( M, N ), NB
+ JB = MIN( NB, MIN( M, N )-J+1 )
+*
+* The active part of the matrix is partitioned
+*
+* A11 A12 A13
+* A21 A22 A23
+* A31 A32 A33
+*
+* Here A11, A21 and A31 denote the current block of JB columns
+* which is about to be factorized. The number of rows in the
+* partitioning are JB, I2, I3 respectively, and the numbers
+* of columns are JB, J2, J3. The superdiagonal elements of A13
+* and the subdiagonal elements of A31 lie outside the band.
+*
+ I2 = MIN( KL-JB, M-J-JB+1 )
+ I3 = MIN( JB, M-J-KL+1 )
+*
+* J2 and J3 are computed after JU has been updated.
+*
+* Factorize the current block of JB columns
+*
+ DO 80 JJ = J, J + JB - 1
+*
+* Set fill-in elements in column JJ+KV to zero
+*
+ IF( JJ+KV.LE.N ) THEN
+ DO 70 I = 1, KL
+ AB( I, JJ+KV ) = ZERO
+ 70 CONTINUE
+ END IF
+*
+* Find pivot and test for singularity. KM is the number of
+* subdiagonal elements in the current column.
+*
+ KM = MIN( KL, M-JJ )
+ JP = IDAMAX( KM+1, AB( KV+1, JJ ), 1 )
+ IPIV( JJ ) = JP + JJ - J
+ IF( AB( KV+JP, JJ ).NE.ZERO ) THEN
+ JU = MAX( JU, MIN( JJ+KU+JP-1, N ) )
+ IF( JP.NE.1 ) THEN
+*
+* Apply interchange to columns J to J+JB-1
+*
+ IF( JP+JJ-1.LT.J+KL ) THEN
+*
+ CALL DSWAP( JB, AB( KV+1+JJ-J, J ), LDAB-1,
+ $ AB( KV+JP+JJ-J, J ), LDAB-1 )
+ ELSE
+*
+* The interchange affects columns J to JJ-1 of A31
+* which are stored in the work array WORK31
+*
+ CALL DSWAP( JJ-J, AB( KV+1+JJ-J, J ), LDAB-1,
+ $ WORK31( JP+JJ-J-KL, 1 ), LDWORK )
+ CALL DSWAP( J+JB-JJ, AB( KV+1, JJ ), LDAB-1,
+ $ AB( KV+JP, JJ ), LDAB-1 )
+ END IF
+ END IF
+*
+* Compute multipliers
+*
+ CALL DSCAL( KM, ONE / AB( KV+1, JJ ), AB( KV+2, JJ ),
+ $ 1 )
+*
+* Update trailing submatrix within the band and within
+* the current block. JM is the index of the last column
+* which needs to be updated.
+*
+ JM = MIN( JU, J+JB-1 )
+ IF( JM.GT.JJ )
+ $ CALL DGER( KM, JM-JJ, -ONE, AB( KV+2, JJ ), 1,
+ $ AB( KV, JJ+1 ), LDAB-1,
+ $ AB( KV+1, JJ+1 ), LDAB-1 )
+ ELSE
+*
+* If pivot is zero, set INFO to the index of the pivot
+* unless a zero pivot has already been found.
+*
+ IF( INFO.EQ.0 )
+ $ INFO = JJ
+ END IF
+*
+* Copy current column of A31 into the work array WORK31
+*
+ NW = MIN( JJ-J+1, I3 )
+ IF( NW.GT.0 )
+ $ CALL DCOPY( NW, AB( KV+KL+1-JJ+J, JJ ), 1,
+ $ WORK31( 1, JJ-J+1 ), 1 )
+ 80 CONTINUE
+ IF( J+JB.LE.N ) THEN
+*
+* Apply the row interchanges to the other blocks.
+*
+ J2 = MIN( JU-J+1, KV ) - JB
+ J3 = MAX( 0, JU-J-KV+1 )
+*
+* Use DLASWP to apply the row interchanges to A12, A22, and
+* A32.
+*
+ CALL DLASWP( J2, AB( KV+1-JB, J+JB ), LDAB-1, 1, JB,
+ $ IPIV( J ), 1 )
+*
+* Adjust the pivot indices.
+*
+ DO 90 I = J, J + JB - 1
+ IPIV( I ) = IPIV( I ) + J - 1
+ 90 CONTINUE
+*
+* Apply the row interchanges to A13, A23, and A33
+* columnwise.
+*
+ K2 = J - 1 + JB + J2
+ DO 110 I = 1, J3
+ JJ = K2 + I
+ DO 100 II = J + I - 1, J + JB - 1
+ IP = IPIV( II )
+ IF( IP.NE.II ) THEN
+ TEMP = AB( KV+1+II-JJ, JJ )
+ AB( KV+1+II-JJ, JJ ) = AB( KV+1+IP-JJ, JJ )
+ AB( KV+1+IP-JJ, JJ ) = TEMP
+ END IF
+ 100 CONTINUE
+ 110 CONTINUE
+*
+* Update the relevant part of the trailing submatrix
+*
+ IF( J2.GT.0 ) THEN
+*
+* Update A12
+*
+ CALL DTRSM( 'Left', 'Lower', 'No transpose', 'Unit',
+ $ JB, J2, ONE, AB( KV+1, J ), LDAB-1,
+ $ AB( KV+1-JB, J+JB ), LDAB-1 )
+*
+ IF( I2.GT.0 ) THEN
+*
+* Update A22
+*
+ CALL DGEMM( 'No transpose', 'No transpose', I2, J2,
+ $ JB, -ONE, AB( KV+1+JB, J ), LDAB-1,
+ $ AB( KV+1-JB, J+JB ), LDAB-1, ONE,
+ $ AB( KV+1, J+JB ), LDAB-1 )
+ END IF
+*
+ IF( I3.GT.0 ) THEN
+*
+* Update A32
+*
+ CALL DGEMM( 'No transpose', 'No transpose', I3, J2,
+ $ JB, -ONE, WORK31, LDWORK,
+ $ AB( KV+1-JB, J+JB ), LDAB-1, ONE,
+ $ AB( KV+KL+1-JB, J+JB ), LDAB-1 )
+ END IF
+ END IF
+*
+ IF( J3.GT.0 ) THEN
+*
+* Copy the lower triangle of A13 into the work array
+* WORK13
+*
+ DO 130 JJ = 1, J3
+ DO 120 II = JJ, JB
+ WORK13( II, JJ ) = AB( II-JJ+1, JJ+J+KV-1 )
+ 120 CONTINUE
+ 130 CONTINUE
+*
+* Update A13 in the work array
+*
+ CALL DTRSM( 'Left', 'Lower', 'No transpose', 'Unit',
+ $ JB, J3, ONE, AB( KV+1, J ), LDAB-1,
+ $ WORK13, LDWORK )
+*
+ IF( I2.GT.0 ) THEN
+*
+* Update A23
+*
+ CALL DGEMM( 'No transpose', 'No transpose', I2, J3,
+ $ JB, -ONE, AB( KV+1+JB, J ), LDAB-1,
+ $ WORK13, LDWORK, ONE, AB( 1+JB, J+KV ),
+ $ LDAB-1 )
+ END IF
+*
+ IF( I3.GT.0 ) THEN
+*
+* Update A33
+*
+ CALL DGEMM( 'No transpose', 'No transpose', I3, J3,
+ $ JB, -ONE, WORK31, LDWORK, WORK13,
+ $ LDWORK, ONE, AB( 1+KL, J+KV ), LDAB-1 )
+ END IF
+*
+* Copy the lower triangle of A13 back into place
+*
+ DO 150 JJ = 1, J3
+ DO 140 II = JJ, JB
+ AB( II-JJ+1, JJ+J+KV-1 ) = WORK13( II, JJ )
+ 140 CONTINUE
+ 150 CONTINUE
+ END IF
+ ELSE
+*
+* Adjust the pivot indices.
+*
+ DO 160 I = J, J + JB - 1
+ IPIV( I ) = IPIV( I ) + J - 1
+ 160 CONTINUE
+ END IF
+*
+* Partially undo the interchanges in the current block to
+* restore the upper triangular form of A31 and copy the upper
+* triangle of A31 back into place
+*
+ DO 170 JJ = J + JB - 1, J, -1
+ JP = IPIV( JJ ) - JJ + 1
+ IF( JP.NE.1 ) THEN
+*
+* Apply interchange to columns J to JJ-1
+*
+ IF( JP+JJ-1.LT.J+KL ) THEN
+*
+* The interchange does not affect A31
+*
+ CALL DSWAP( JJ-J, AB( KV+1+JJ-J, J ), LDAB-1,
+ $ AB( KV+JP+JJ-J, J ), LDAB-1 )
+ ELSE
+*
+* The interchange does affect A31
+*
+ CALL DSWAP( JJ-J, AB( KV+1+JJ-J, J ), LDAB-1,
+ $ WORK31( JP+JJ-J-KL, 1 ), LDWORK )
+ END IF
+ END IF
+*
+* Copy the current column of A31 back into place
+*
+ NW = MIN( I3, JJ-J+1 )
+ IF( NW.GT.0 )
+ $ CALL DCOPY( NW, WORK31( 1, JJ-J+1 ), 1,
+ $ AB( KV+KL+1-JJ+J, JJ ), 1 )
+ 170 CONTINUE
+ 180 CONTINUE
+ END IF
+*
+ RETURN
+*
+* End of DGBTRF
+*
+ END
+ SUBROUTINE DGBTRS( TRANS, N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB,
+ $ INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER TRANS
+ INTEGER INFO, KL, KU, LDAB, LDB, N, NRHS
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ DOUBLE PRECISION AB( LDAB, * ), B( LDB, * )
+* ..
+*
+* Purpose
+* =======
+*
+* DGBTRS solves a system of linear equations
+* A * X = B or A' * X = B
+* with a general band matrix A using the LU factorization computed
+* by DGBTRF.
+*
+* Arguments
+* =========
+*
+* TRANS (input) CHARACTER*1
+* Specifies the form of the system of equations.
+* = 'N': A * X = B (No transpose)
+* = 'T': A'* X = B (Transpose)
+* = 'C': A'* X = B (Conjugate transpose = Transpose)
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* KL (input) INTEGER
+* The number of subdiagonals within the band of A. KL >= 0.
+*
+* KU (input) INTEGER
+* The number of superdiagonals within the band of A. KU >= 0.
+*
+* NRHS (input) INTEGER
+* The number of right hand sides, i.e., the number of columns
+* of the matrix B. NRHS >= 0.
+*
+* AB (input) DOUBLE PRECISION array, dimension (LDAB,N)
+* Details of the LU factorization of the band matrix A, as
+* computed by DGBTRF. U is stored as an upper triangular band
+* matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and
+* the multipliers used during the factorization are stored in
+* rows KL+KU+2 to 2*KL+KU+1.
+*
+* LDAB (input) INTEGER
+* The leading dimension of the array AB. LDAB >= 2*KL+KU+1.
+*
+* IPIV (input) INTEGER array, dimension (N)
+* The pivot indices; for 1 <= i <= N, row i of the matrix was
+* interchanged with row IPIV(i).
+*
+* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
+* On entry, the right hand side matrix B.
+* On exit, the solution matrix X.
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. LDB >= max(1,N).
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE
+ PARAMETER ( ONE = 1.0D+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL LNOTI, NOTRAN
+ INTEGER I, J, KD, L, LM
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL DGEMV, DGER, DSWAP, DTBSV, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ NOTRAN = LSAME( TRANS, 'N' )
+ IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT.
+ $ LSAME( TRANS, 'C' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( KL.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( KU.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( NRHS.LT.0 ) THEN
+ INFO = -5
+ ELSE IF( LDAB.LT.( 2*KL+KU+1 ) ) THEN
+ INFO = -7
+ ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -10
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DGBTRS', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 .OR. NRHS.EQ.0 )
+ $ RETURN
+*
+ KD = KU + KL + 1
+ LNOTI = KL.GT.0
+*
+ IF( NOTRAN ) THEN
+*
+* Solve A*X = B.
+*
+* Solve L*X = B, overwriting B with X.
+*
+* L is represented as a product of permutations and unit lower
+* triangular matrices L = P(1) * L(1) * ... * P(n-1) * L(n-1),
+* where each transformation L(i) is a rank-one modification of
+* the identity matrix.
+*
+ IF( LNOTI ) THEN
+ DO 10 J = 1, N - 1
+ LM = MIN( KL, N-J )
+ L = IPIV( J )
+ IF( L.NE.J )
+ $ CALL DSWAP( NRHS, B( L, 1 ), LDB, B( J, 1 ), LDB )
+ CALL DGER( LM, NRHS, -ONE, AB( KD+1, J ), 1, B( J, 1 ),
+ $ LDB, B( J+1, 1 ), LDB )
+ 10 CONTINUE
+ END IF
+*
+ DO 20 I = 1, NRHS
+*
+* Solve U*X = B, overwriting B with X.
+*
+ CALL DTBSV( 'Upper', 'No transpose', 'Non-unit', N, KL+KU,
+ $ AB, LDAB, B( 1, I ), 1 )
+ 20 CONTINUE
+*
+ ELSE
+*
+* Solve A'*X = B.
+*
+ DO 30 I = 1, NRHS
+*
+* Solve U'*X = B, overwriting B with X.
+*
+ CALL DTBSV( 'Upper', 'Transpose', 'Non-unit', N, KL+KU, AB,
+ $ LDAB, B( 1, I ), 1 )
+ 30 CONTINUE
+*
+* Solve L'*X = B, overwriting B with X.
+*
+ IF( LNOTI ) THEN
+ DO 40 J = N - 1, 1, -1
+ LM = MIN( KL, N-J )
+ CALL DGEMV( 'Transpose', LM, NRHS, -ONE, B( J+1, 1 ),
+ $ LDB, AB( KD+1, J ), 1, ONE, B( J, 1 ), LDB )
+ L = IPIV( J )
+ IF( L.NE.J )
+ $ CALL DSWAP( NRHS, B( L, 1 ), LDB, B( J, 1 ), LDB )
+ 40 CONTINUE
+ END IF
+ END IF
+ RETURN
+*
+* End of DGBTRS
+*
+ END
+ SUBROUTINE DGEBAK( JOB, SIDE, N, ILO, IHI, SCALE, M, V, LDV,
+ $ INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER JOB, SIDE
+ INTEGER IHI, ILO, INFO, LDV, M, N
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION SCALE( * ), V( LDV, * )
+* ..
+*
+* Purpose
+* =======
+*
+* DGEBAK forms the right or left eigenvectors of a real general matrix
+* by backward transformation on the computed eigenvectors of the
+* balanced matrix output by DGEBAL.
+*
+* Arguments
+* =========
+*
+* JOB (input) CHARACTER*1
+* Specifies the type of backward transformation required:
+* = 'N', do nothing, return immediately;
+* = 'P', do backward transformation for permutation only;
+* = 'S', do backward transformation for scaling only;
+* = 'B', do backward transformations for both permutation and
+* scaling.
+* JOB must be the same as the argument JOB supplied to DGEBAL.
+*
+* SIDE (input) CHARACTER*1
+* = 'R': V contains right eigenvectors;
+* = 'L': V contains left eigenvectors.
+*
+* N (input) INTEGER
+* The number of rows of the matrix V. N >= 0.
+*
+* ILO (input) INTEGER
+* IHI (input) INTEGER
+* The integers ILO and IHI determined by DGEBAL.
+* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.
+*
+* SCALE (input) DOUBLE PRECISION array, dimension (N)
+* Details of the permutation and scaling factors, as returned
+* by DGEBAL.
+*
+* M (input) INTEGER
+* The number of columns of the matrix V. M >= 0.
+*
+* V (input/output) DOUBLE PRECISION array, dimension (LDV,M)
+* On entry, the matrix of right or left eigenvectors to be
+* transformed, as returned by DHSEIN or DTREVC.
+* On exit, V is overwritten by the transformed eigenvectors.
+*
+* LDV (input) INTEGER
+* The leading dimension of the array V. LDV >= max(1,N).
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE
+ PARAMETER ( ONE = 1.0D+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL LEFTV, RIGHTV
+ INTEGER I, II, K
+ DOUBLE PRECISION S
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL DSCAL, DSWAP, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+* Decode and Test the input parameters
+*
+ RIGHTV = LSAME( SIDE, 'R' )
+ LEFTV = LSAME( SIDE, 'L' )
+*
+ INFO = 0
+ IF( .NOT.LSAME( JOB, 'N' ) .AND. .NOT.LSAME( JOB, 'P' ) .AND.
+ $ .NOT.LSAME( JOB, 'S' ) .AND. .NOT.LSAME( JOB, 'B' ) ) THEN
+ INFO = -1
+ ELSE IF( .NOT.RIGHTV .AND. .NOT.LEFTV ) THEN
+ INFO = -2
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN
+ INFO = -4
+ ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN
+ INFO = -5
+ ELSE IF( M.LT.0 ) THEN
+ INFO = -7
+ ELSE IF( LDV.LT.MAX( 1, N ) ) THEN
+ INFO = -9
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DGEBAK', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 )
+ $ RETURN
+ IF( M.EQ.0 )
+ $ RETURN
+ IF( LSAME( JOB, 'N' ) )
+ $ RETURN
+*
+ IF( ILO.EQ.IHI )
+ $ GO TO 30
+*
+* Backward balance
+*
+ IF( LSAME( JOB, 'S' ) .OR. LSAME( JOB, 'B' ) ) THEN
+*
+ IF( RIGHTV ) THEN
+ DO 10 I = ILO, IHI
+ S = SCALE( I )
+ CALL DSCAL( M, S, V( I, 1 ), LDV )
+ 10 CONTINUE
+ END IF
+*
+ IF( LEFTV ) THEN
+ DO 20 I = ILO, IHI
+ S = ONE / SCALE( I )
+ CALL DSCAL( M, S, V( I, 1 ), LDV )
+ 20 CONTINUE
+ END IF
+*
+ END IF
+*
+* Backward permutation
+*
+* For I = ILO-1 step -1 until 1,
+* IHI+1 step 1 until N do --
+*
+ 30 CONTINUE
+ IF( LSAME( JOB, 'P' ) .OR. LSAME( JOB, 'B' ) ) THEN
+ IF( RIGHTV ) THEN
+ DO 40 II = 1, N
+ I = II
+ IF( I.GE.ILO .AND. I.LE.IHI )
+ $ GO TO 40
+ IF( I.LT.ILO )
+ $ I = ILO - II
+ K = SCALE( I )
+ IF( K.EQ.I )
+ $ GO TO 40
+ CALL DSWAP( M, V( I, 1 ), LDV, V( K, 1 ), LDV )
+ 40 CONTINUE
+ END IF
+*
+ IF( LEFTV ) THEN
+ DO 50 II = 1, N
+ I = II
+ IF( I.GE.ILO .AND. I.LE.IHI )
+ $ GO TO 50
+ IF( I.LT.ILO )
+ $ I = ILO - II
+ K = SCALE( I )
+ IF( K.EQ.I )
+ $ GO TO 50
+ CALL DSWAP( M, V( I, 1 ), LDV, V( K, 1 ), LDV )
+ 50 CONTINUE
+ END IF
+ END IF
+*
+ RETURN
+*
+* End of DGEBAK
+*
+ END
+ SUBROUTINE DGEBAL( JOB, N, A, LDA, ILO, IHI, SCALE, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER JOB
+ INTEGER IHI, ILO, INFO, LDA, N
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION A( LDA, * ), SCALE( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DGEBAL balances a general real matrix A. This involves, first,
+* permuting A by a similarity transformation to isolate eigenvalues
+* in the first 1 to ILO-1 and last IHI+1 to N elements on the
+* diagonal; and second, applying a diagonal similarity transformation
+* to rows and columns ILO to IHI to make the rows and columns as
+* close in norm as possible. Both steps are optional.
+*
+* Balancing may reduce the 1-norm of the matrix, and improve the
+* accuracy of the computed eigenvalues and/or eigenvectors.
+*
+* Arguments
+* =========
+*
+* JOB (input) CHARACTER*1
+* Specifies the operations to be performed on A:
+* = 'N': none: simply set ILO = 1, IHI = N, SCALE(I) = 1.0
+* for i = 1,...,N;
+* = 'P': permute only;
+* = 'S': scale only;
+* = 'B': both permute and scale.
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+* On entry, the input matrix A.
+* On exit, A is overwritten by the balanced matrix.
+* If JOB = 'N', A is not referenced.
+* See Further Details.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,N).
+*
+* ILO (output) INTEGER
+* IHI (output) INTEGER
+* ILO and IHI are set to integers such that on exit
+* A(i,j) = 0 if i > j and j = 1,...,ILO-1 or I = IHI+1,...,N.
+* If JOB = 'N' or 'S', ILO = 1 and IHI = N.
+*
+* SCALE (output) DOUBLE PRECISION array, dimension (N)
+* Details of the permutations and scaling factors applied to
+* A. If P(j) is the index of the row and column interchanged
+* with row and column j and D(j) is the scaling factor
+* applied to row and column j, then
+* SCALE(j) = P(j) for j = 1,...,ILO-1
+* = D(j) for j = ILO,...,IHI
+* = P(j) for j = IHI+1,...,N.
+* The order in which the interchanges are made is N to IHI+1,
+* then 1 to ILO-1.
+*
+* INFO (output) INTEGER
+* = 0: successful exit.
+* < 0: if INFO = -i, the i-th argument had an illegal value.
+*
+* Further Details
+* ===============
+*
+* The permutations consist of row and column interchanges which put
+* the matrix in the form
+*
+* ( T1 X Y )
+* P A P = ( 0 B Z )
+* ( 0 0 T2 )
+*
+* where T1 and T2 are upper triangular matrices whose eigenvalues lie
+* along the diagonal. The column indices ILO and IHI mark the starting
+* and ending columns of the submatrix B. Balancing consists of applying
+* a diagonal similarity transformation inv(D) * B * D to make the
+* 1-norms of each row of B and its corresponding column nearly equal.
+* The output matrix is
+*
+* ( T1 X*D Y )
+* ( 0 inv(D)*B*D inv(D)*Z ).
+* ( 0 0 T2 )
+*
+* Information about the permutations P and the diagonal matrix D is
+* returned in the vector SCALE.
+*
+* This subroutine is based on the EISPACK routine BALANC.
+*
+* Modified by Tzu-Yi Chen, Computer Science Division, University of
+* California at Berkeley, USA
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+ DOUBLE PRECISION SCLFAC
+ PARAMETER ( SCLFAC = 2.0D+0 )
+ DOUBLE PRECISION FACTOR
+ PARAMETER ( FACTOR = 0.95D+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL NOCONV
+ INTEGER I, ICA, IEXC, IRA, J, K, L, M
+ DOUBLE PRECISION C, CA, F, G, R, RA, S, SFMAX1, SFMAX2, SFMIN1,
+ $ SFMIN2
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER IDAMAX
+ DOUBLE PRECISION DLAMCH
+ EXTERNAL LSAME, IDAMAX, DLAMCH
+* ..
+* .. External Subroutines ..
+ EXTERNAL DSCAL, DSWAP, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters
+*
+ INFO = 0
+ IF( .NOT.LSAME( JOB, 'N' ) .AND. .NOT.LSAME( JOB, 'P' ) .AND.
+ $ .NOT.LSAME( JOB, 'S' ) .AND. .NOT.LSAME( JOB, 'B' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -4
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DGEBAL', -INFO )
+ RETURN
+ END IF
+*
+ K = 1
+ L = N
+*
+ IF( N.EQ.0 )
+ $ GO TO 210
+*
+ IF( LSAME( JOB, 'N' ) ) THEN
+ DO 10 I = 1, N
+ SCALE( I ) = ONE
+ 10 CONTINUE
+ GO TO 210
+ END IF
+*
+ IF( LSAME( JOB, 'S' ) )
+ $ GO TO 120
+*
+* Permutation to isolate eigenvalues if possible
+*
+ GO TO 50
+*
+* Row and column exchange.
+*
+ 20 CONTINUE
+ SCALE( M ) = J
+ IF( J.EQ.M )
+ $ GO TO 30
+*
+ CALL DSWAP( L, A( 1, J ), 1, A( 1, M ), 1 )
+ CALL DSWAP( N-K+1, A( J, K ), LDA, A( M, K ), LDA )
+*
+ 30 CONTINUE
+ GO TO ( 40, 80 )IEXC
+*
+* Search for rows isolating an eigenvalue and push them down.
+*
+ 40 CONTINUE
+ IF( L.EQ.1 )
+ $ GO TO 210
+ L = L - 1
+*
+ 50 CONTINUE
+ DO 70 J = L, 1, -1
+*
+ DO 60 I = 1, L
+ IF( I.EQ.J )
+ $ GO TO 60
+ IF( A( J, I ).NE.ZERO )
+ $ GO TO 70
+ 60 CONTINUE
+*
+ M = L
+ IEXC = 1
+ GO TO 20
+ 70 CONTINUE
+*
+ GO TO 90
+*
+* Search for columns isolating an eigenvalue and push them left.
+*
+ 80 CONTINUE
+ K = K + 1
+*
+ 90 CONTINUE
+ DO 110 J = K, L
+*
+ DO 100 I = K, L
+ IF( I.EQ.J )
+ $ GO TO 100
+ IF( A( I, J ).NE.ZERO )
+ $ GO TO 110
+ 100 CONTINUE
+*
+ M = K
+ IEXC = 2
+ GO TO 20
+ 110 CONTINUE
+*
+ 120 CONTINUE
+ DO 130 I = K, L
+ SCALE( I ) = ONE
+ 130 CONTINUE
+*
+ IF( LSAME( JOB, 'P' ) )
+ $ GO TO 210
+*
+* Balance the submatrix in rows K to L.
+*
+* Iterative loop for norm reduction
+*
+ SFMIN1 = DLAMCH( 'S' ) / DLAMCH( 'P' )
+ SFMAX1 = ONE / SFMIN1
+ SFMIN2 = SFMIN1*SCLFAC
+ SFMAX2 = ONE / SFMIN2
+ 140 CONTINUE
+ NOCONV = .FALSE.
+*
+ DO 200 I = K, L
+ C = ZERO
+ R = ZERO
+*
+ DO 150 J = K, L
+ IF( J.EQ.I )
+ $ GO TO 150
+ C = C + ABS( A( J, I ) )
+ R = R + ABS( A( I, J ) )
+ 150 CONTINUE
+ ICA = IDAMAX( L, A( 1, I ), 1 )
+ CA = ABS( A( ICA, I ) )
+ IRA = IDAMAX( N-K+1, A( I, K ), LDA )
+ RA = ABS( A( I, IRA+K-1 ) )
+*
+* Guard against zero C or R due to underflow.
+*
+ IF( C.EQ.ZERO .OR. R.EQ.ZERO )
+ $ GO TO 200
+ G = R / SCLFAC
+ F = ONE
+ S = C + R
+ 160 CONTINUE
+ IF( C.GE.G .OR. MAX( F, C, CA ).GE.SFMAX2 .OR.
+ $ MIN( R, G, RA ).LE.SFMIN2 )GO TO 170
+ F = F*SCLFAC
+ C = C*SCLFAC
+ CA = CA*SCLFAC
+ R = R / SCLFAC
+ G = G / SCLFAC
+ RA = RA / SCLFAC
+ GO TO 160
+*
+ 170 CONTINUE
+ G = C / SCLFAC
+ 180 CONTINUE
+ IF( G.LT.R .OR. MAX( R, RA ).GE.SFMAX2 .OR.
+ $ MIN( F, C, G, CA ).LE.SFMIN2 )GO TO 190
+ F = F / SCLFAC
+ C = C / SCLFAC
+ G = G / SCLFAC
+ CA = CA / SCLFAC
+ R = R*SCLFAC
+ RA = RA*SCLFAC
+ GO TO 180
+*
+* Now balance.
+*
+ 190 CONTINUE
+ IF( ( C+R ).GE.FACTOR*S )
+ $ GO TO 200
+ IF( F.LT.ONE .AND. SCALE( I ).LT.ONE ) THEN
+ IF( F*SCALE( I ).LE.SFMIN1 )
+ $ GO TO 200
+ END IF
+ IF( F.GT.ONE .AND. SCALE( I ).GT.ONE ) THEN
+ IF( SCALE( I ).GE.SFMAX1 / F )
+ $ GO TO 200
+ END IF
+ G = ONE / F
+ SCALE( I ) = SCALE( I )*F
+ NOCONV = .TRUE.
+*
+ CALL DSCAL( N-K+1, G, A( I, K ), LDA )
+ CALL DSCAL( L, F, A( 1, I ), 1 )
+*
+ 200 CONTINUE
+*
+ IF( NOCONV )
+ $ GO TO 140
+*
+ 210 CONTINUE
+ ILO = K
+ IHI = L
+*
+ RETURN
+*
+* End of DGEBAL
+*
+ END
+ SUBROUTINE DGEBD2( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LDA, M, N
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION A( LDA, * ), D( * ), E( * ), TAUP( * ),
+ $ TAUQ( * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DGEBD2 reduces a real general m by n matrix A to upper or lower
+* bidiagonal form B by an orthogonal transformation: Q' * A * P = B.
+*
+* If m >= n, B is upper bidiagonal; if m < n, B is lower bidiagonal.
+*
+* Arguments
+* =========
+*
+* M (input) INTEGER
+* The number of rows in the matrix A. M >= 0.
+*
+* N (input) INTEGER
+* The number of columns in the matrix A. N >= 0.
+*
+* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+* On entry, the m by n general matrix to be reduced.
+* On exit,
+* if m >= n, the diagonal and the first superdiagonal are
+* overwritten with the upper bidiagonal matrix B; the
+* elements below the diagonal, with the array TAUQ, represent
+* the orthogonal matrix Q as a product of elementary
+* reflectors, and the elements above the first superdiagonal,
+* with the array TAUP, represent the orthogonal matrix P as
+* a product of elementary reflectors;
+* if m < n, the diagonal and the first subdiagonal are
+* overwritten with the lower bidiagonal matrix B; the
+* elements below the first subdiagonal, with the array TAUQ,
+* represent the orthogonal matrix Q as a product of
+* elementary reflectors, and the elements above the diagonal,
+* with the array TAUP, represent the orthogonal matrix P as
+* a product of elementary reflectors.
+* See Further Details.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,M).
+*
+* D (output) DOUBLE PRECISION array, dimension (min(M,N))
+* The diagonal elements of the bidiagonal matrix B:
+* D(i) = A(i,i).
+*
+* E (output) DOUBLE PRECISION array, dimension (min(M,N)-1)
+* The off-diagonal elements of the bidiagonal matrix B:
+* if m >= n, E(i) = A(i,i+1) for i = 1,2,...,n-1;
+* if m < n, E(i) = A(i+1,i) for i = 1,2,...,m-1.
+*
+* TAUQ (output) DOUBLE PRECISION array dimension (min(M,N))
+* The scalar factors of the elementary reflectors which
+* represent the orthogonal matrix Q. See Further Details.
+*
+* TAUP (output) DOUBLE PRECISION array, dimension (min(M,N))
+* The scalar factors of the elementary reflectors which
+* represent the orthogonal matrix P. See Further Details.
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (max(M,N))
+*
+* INFO (output) INTEGER
+* = 0: successful exit.
+* < 0: if INFO = -i, the i-th argument had an illegal value.
+*
+* Further Details
+* ===============
+*
+* The matrices Q and P are represented as products of elementary
+* reflectors:
+*
+* If m >= n,
+*
+* Q = H(1) H(2) . . . H(n) and P = G(1) G(2) . . . G(n-1)
+*
+* Each H(i) and G(i) has the form:
+*
+* H(i) = I - tauq * v * v' and G(i) = I - taup * u * u'
+*
+* where tauq and taup are real scalars, and v and u are real vectors;
+* v(1:i-1) = 0, v(i) = 1, and v(i+1:m) is stored on exit in A(i+1:m,i);
+* u(1:i) = 0, u(i+1) = 1, and u(i+2:n) is stored on exit in A(i,i+2:n);
+* tauq is stored in TAUQ(i) and taup in TAUP(i).
+*
+* If m < n,
+*
+* Q = H(1) H(2) . . . H(m-1) and P = G(1) G(2) . . . G(m)
+*
+* Each H(i) and G(i) has the form:
+*
+* H(i) = I - tauq * v * v' and G(i) = I - taup * u * u'
+*
+* where tauq and taup are real scalars, and v and u are real vectors;
+* v(1:i) = 0, v(i+1) = 1, and v(i+2:m) is stored on exit in A(i+2:m,i);
+* u(1:i-1) = 0, u(i) = 1, and u(i+1:n) is stored on exit in A(i,i+1:n);
+* tauq is stored in TAUQ(i) and taup in TAUP(i).
+*
+* The contents of A on exit are illustrated by the following examples:
+*
+* m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n):
+*
+* ( d e u1 u1 u1 ) ( d u1 u1 u1 u1 u1 )
+* ( v1 d e u2 u2 ) ( e d u2 u2 u2 u2 )
+* ( v1 v2 d e u3 ) ( v1 e d u3 u3 u3 )
+* ( v1 v2 v3 d e ) ( v1 v2 e d u4 u4 )
+* ( v1 v2 v3 v4 d ) ( v1 v2 v3 e d u5 )
+* ( v1 v2 v3 v4 v5 )
+*
+* where d and e denote diagonal and off-diagonal elements of B, vi
+* denotes an element of the vector defining H(i), and ui an element of
+* the vector defining G(i).
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I
+* ..
+* .. External Subroutines ..
+ EXTERNAL DLARF, DLARFG, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters
+*
+ INFO = 0
+ IF( M.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+ INFO = -4
+ END IF
+ IF( INFO.LT.0 ) THEN
+ CALL XERBLA( 'DGEBD2', -INFO )
+ RETURN
+ END IF
+*
+ IF( M.GE.N ) THEN
+*
+* Reduce to upper bidiagonal form
+*
+ DO 10 I = 1, N
+*
+* Generate elementary reflector H(i) to annihilate A(i+1:m,i)
+*
+ CALL DLARFG( M-I+1, A( I, I ), A( MIN( I+1, M ), I ), 1,
+ $ TAUQ( I ) )
+ D( I ) = A( I, I )
+ A( I, I ) = ONE
+*
+* Apply H(i) to A(i:m,i+1:n) from the left
+*
+ IF( I.LT.N )
+ $ CALL DLARF( 'Left', M-I+1, N-I, A( I, I ), 1, TAUQ( I ),
+ $ A( I, I+1 ), LDA, WORK )
+ A( I, I ) = D( I )
+*
+ IF( I.LT.N ) THEN
+*
+* Generate elementary reflector G(i) to annihilate
+* A(i,i+2:n)
+*
+ CALL DLARFG( N-I, A( I, I+1 ), A( I, MIN( I+2, N ) ),
+ $ LDA, TAUP( I ) )
+ E( I ) = A( I, I+1 )
+ A( I, I+1 ) = ONE
+*
+* Apply G(i) to A(i+1:m,i+1:n) from the right
+*
+ CALL DLARF( 'Right', M-I, N-I, A( I, I+1 ), LDA,
+ $ TAUP( I ), A( I+1, I+1 ), LDA, WORK )
+ A( I, I+1 ) = E( I )
+ ELSE
+ TAUP( I ) = ZERO
+ END IF
+ 10 CONTINUE
+ ELSE
+*
+* Reduce to lower bidiagonal form
+*
+ DO 20 I = 1, M
+*
+* Generate elementary reflector G(i) to annihilate A(i,i+1:n)
+*
+ CALL DLARFG( N-I+1, A( I, I ), A( I, MIN( I+1, N ) ), LDA,
+ $ TAUP( I ) )
+ D( I ) = A( I, I )
+ A( I, I ) = ONE
+*
+* Apply G(i) to A(i+1:m,i:n) from the right
+*
+ IF( I.LT.M )
+ $ CALL DLARF( 'Right', M-I, N-I+1, A( I, I ), LDA,
+ $ TAUP( I ), A( I+1, I ), LDA, WORK )
+ A( I, I ) = D( I )
+*
+ IF( I.LT.M ) THEN
+*
+* Generate elementary reflector H(i) to annihilate
+* A(i+2:m,i)
+*
+ CALL DLARFG( M-I, A( I+1, I ), A( MIN( I+2, M ), I ), 1,
+ $ TAUQ( I ) )
+ E( I ) = A( I+1, I )
+ A( I+1, I ) = ONE
+*
+* Apply H(i) to A(i+1:m,i+1:n) from the left
+*
+ CALL DLARF( 'Left', M-I, N-I, A( I+1, I ), 1, TAUQ( I ),
+ $ A( I+1, I+1 ), LDA, WORK )
+ A( I+1, I ) = E( I )
+ ELSE
+ TAUQ( I ) = ZERO
+ END IF
+ 20 CONTINUE
+ END IF
+ RETURN
+*
+* End of DGEBD2
+*
+ END
+ SUBROUTINE DGEBRD( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, LWORK,
+ $ INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LDA, LWORK, M, N
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION A( LDA, * ), D( * ), E( * ), TAUP( * ),
+ $ TAUQ( * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DGEBRD reduces a general real M-by-N matrix A to upper or lower
+* bidiagonal form B by an orthogonal transformation: Q**T * A * P = B.
+*
+* If m >= n, B is upper bidiagonal; if m < n, B is lower bidiagonal.
+*
+* Arguments
+* =========
+*
+* M (input) INTEGER
+* The number of rows in the matrix A. M >= 0.
+*
+* N (input) INTEGER
+* The number of columns in the matrix A. N >= 0.
+*
+* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+* On entry, the M-by-N general matrix to be reduced.
+* On exit,
+* if m >= n, the diagonal and the first superdiagonal are
+* overwritten with the upper bidiagonal matrix B; the
+* elements below the diagonal, with the array TAUQ, represent
+* the orthogonal matrix Q as a product of elementary
+* reflectors, and the elements above the first superdiagonal,
+* with the array TAUP, represent the orthogonal matrix P as
+* a product of elementary reflectors;
+* if m < n, the diagonal and the first subdiagonal are
+* overwritten with the lower bidiagonal matrix B; the
+* elements below the first subdiagonal, with the array TAUQ,
+* represent the orthogonal matrix Q as a product of
+* elementary reflectors, and the elements above the diagonal,
+* with the array TAUP, represent the orthogonal matrix P as
+* a product of elementary reflectors.
+* See Further Details.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,M).
+*
+* D (output) DOUBLE PRECISION array, dimension (min(M,N))
+* The diagonal elements of the bidiagonal matrix B:
+* D(i) = A(i,i).
+*
+* E (output) DOUBLE PRECISION array, dimension (min(M,N)-1)
+* The off-diagonal elements of the bidiagonal matrix B:
+* if m >= n, E(i) = A(i,i+1) for i = 1,2,...,n-1;
+* if m < n, E(i) = A(i+1,i) for i = 1,2,...,m-1.
+*
+* TAUQ (output) DOUBLE PRECISION array dimension (min(M,N))
+* The scalar factors of the elementary reflectors which
+* represent the orthogonal matrix Q. See Further Details.
+*
+* TAUP (output) DOUBLE PRECISION array, dimension (min(M,N))
+* The scalar factors of the elementary reflectors which
+* represent the orthogonal matrix P. See Further Details.
+*
+* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
+* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+* LWORK (input) INTEGER
+* The length of the array WORK. LWORK >= max(1,M,N).
+* For optimum performance LWORK >= (M+N)*NB, where NB
+* is the optimal blocksize.
+*
+* If LWORK = -1, then a workspace query is assumed; the routine
+* only calculates the optimal size of the WORK array, returns
+* this value as the first entry of the WORK array, and no error
+* message related to LWORK is issued by XERBLA.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value.
+*
+* Further Details
+* ===============
+*
+* The matrices Q and P are represented as products of elementary
+* reflectors:
+*
+* If m >= n,
+*
+* Q = H(1) H(2) . . . H(n) and P = G(1) G(2) . . . G(n-1)
+*
+* Each H(i) and G(i) has the form:
+*
+* H(i) = I - tauq * v * v' and G(i) = I - taup * u * u'
+*
+* where tauq and taup are real scalars, and v and u are real vectors;
+* v(1:i-1) = 0, v(i) = 1, and v(i+1:m) is stored on exit in A(i+1:m,i);
+* u(1:i) = 0, u(i+1) = 1, and u(i+2:n) is stored on exit in A(i,i+2:n);
+* tauq is stored in TAUQ(i) and taup in TAUP(i).
+*
+* If m < n,
+*
+* Q = H(1) H(2) . . . H(m-1) and P = G(1) G(2) . . . G(m)
+*
+* Each H(i) and G(i) has the form:
+*
+* H(i) = I - tauq * v * v' and G(i) = I - taup * u * u'
+*
+* where tauq and taup are real scalars, and v and u are real vectors;
+* v(1:i) = 0, v(i+1) = 1, and v(i+2:m) is stored on exit in A(i+2:m,i);
+* u(1:i-1) = 0, u(i) = 1, and u(i+1:n) is stored on exit in A(i,i+1:n);
+* tauq is stored in TAUQ(i) and taup in TAUP(i).
+*
+* The contents of A on exit are illustrated by the following examples:
+*
+* m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n):
+*
+* ( d e u1 u1 u1 ) ( d u1 u1 u1 u1 u1 )
+* ( v1 d e u2 u2 ) ( e d u2 u2 u2 u2 )
+* ( v1 v2 d e u3 ) ( v1 e d u3 u3 u3 )
+* ( v1 v2 v3 d e ) ( v1 v2 e d u4 u4 )
+* ( v1 v2 v3 v4 d ) ( v1 v2 v3 e d u5 )
+* ( v1 v2 v3 v4 v5 )
+*
+* where d and e denote diagonal and off-diagonal elements of B, vi
+* denotes an element of the vector defining H(i), and ui an element of
+* the vector defining G(i).
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE
+ PARAMETER ( ONE = 1.0D+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL LQUERY
+ INTEGER I, IINFO, J, LDWRKX, LDWRKY, LWKOPT, MINMN, NB,
+ $ NBMIN, NX
+ DOUBLE PRECISION WS
+* ..
+* .. External Subroutines ..
+ EXTERNAL DGEBD2, DGEMM, DLABRD, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC DBLE, MAX, MIN
+* ..
+* .. External Functions ..
+ INTEGER ILAENV
+ EXTERNAL ILAENV
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters
+*
+ INFO = 0
+ NB = MAX( 1, ILAENV( 1, 'DGEBRD', ' ', M, N, -1, -1 ) )
+ LWKOPT = ( M+N )*NB
+ WORK( 1 ) = DBLE( LWKOPT )
+ LQUERY = ( LWORK.EQ.-1 )
+ IF( M.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+ INFO = -4
+ ELSE IF( LWORK.LT.MAX( 1, M, N ) .AND. .NOT.LQUERY ) THEN
+ INFO = -10
+ END IF
+ IF( INFO.LT.0 ) THEN
+ CALL XERBLA( 'DGEBRD', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ MINMN = MIN( M, N )
+ IF( MINMN.EQ.0 ) THEN
+ WORK( 1 ) = 1
+ RETURN
+ END IF
+*
+ WS = MAX( M, N )
+ LDWRKX = M
+ LDWRKY = N
+*
+ IF( NB.GT.1 .AND. NB.LT.MINMN ) THEN
+*
+* Set the crossover point NX.
+*
+ NX = MAX( NB, ILAENV( 3, 'DGEBRD', ' ', M, N, -1, -1 ) )
+*
+* Determine when to switch from blocked to unblocked code.
+*
+ IF( NX.LT.MINMN ) THEN
+ WS = ( M+N )*NB
+ IF( LWORK.LT.WS ) THEN
+*
+* Not enough work space for the optimal NB, consider using
+* a smaller block size.
+*
+ NBMIN = ILAENV( 2, 'DGEBRD', ' ', M, N, -1, -1 )
+ IF( LWORK.GE.( M+N )*NBMIN ) THEN
+ NB = LWORK / ( M+N )
+ ELSE
+ NB = 1
+ NX = MINMN
+ END IF
+ END IF
+ END IF
+ ELSE
+ NX = MINMN
+ END IF
+*
+ DO 30 I = 1, MINMN - NX, NB
+*
+* Reduce rows and columns i:i+nb-1 to bidiagonal form and return
+* the matrices X and Y which are needed to update the unreduced
+* part of the matrix
+*
+ CALL DLABRD( M-I+1, N-I+1, NB, A( I, I ), LDA, D( I ), E( I ),
+ $ TAUQ( I ), TAUP( I ), WORK, LDWRKX,
+ $ WORK( LDWRKX*NB+1 ), LDWRKY )
+*
+* Update the trailing submatrix A(i+nb:m,i+nb:n), using an update
+* of the form A := A - V*Y' - X*U'
+*
+ CALL DGEMM( 'No transpose', 'Transpose', M-I-NB+1, N-I-NB+1,
+ $ NB, -ONE, A( I+NB, I ), LDA,
+ $ WORK( LDWRKX*NB+NB+1 ), LDWRKY, ONE,
+ $ A( I+NB, I+NB ), LDA )
+ CALL DGEMM( 'No transpose', 'No transpose', M-I-NB+1, N-I-NB+1,
+ $ NB, -ONE, WORK( NB+1 ), LDWRKX, A( I, I+NB ), LDA,
+ $ ONE, A( I+NB, I+NB ), LDA )
+*
+* Copy diagonal and off-diagonal elements of B back into A
+*
+ IF( M.GE.N ) THEN
+ DO 10 J = I, I + NB - 1
+ A( J, J ) = D( J )
+ A( J, J+1 ) = E( J )
+ 10 CONTINUE
+ ELSE
+ DO 20 J = I, I + NB - 1
+ A( J, J ) = D( J )
+ A( J+1, J ) = E( J )
+ 20 CONTINUE
+ END IF
+ 30 CONTINUE
+*
+* Use unblocked code to reduce the remainder of the matrix
+*
+ CALL DGEBD2( M-I+1, N-I+1, A( I, I ), LDA, D( I ), E( I ),
+ $ TAUQ( I ), TAUP( I ), WORK, IINFO )
+ WORK( 1 ) = WS
+ RETURN
+*
+* End of DGEBRD
+*
+ END
+ SUBROUTINE DGECON( NORM, N, A, LDA, ANORM, RCOND, WORK, IWORK,
+ $ INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH.
+*
+* .. Scalar Arguments ..
+ CHARACTER NORM
+ INTEGER INFO, LDA, N
+ DOUBLE PRECISION ANORM, RCOND
+* ..
+* .. Array Arguments ..
+ INTEGER IWORK( * )
+ DOUBLE PRECISION A( LDA, * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DGECON estimates the reciprocal of the condition number of a general
+* real matrix A, in either the 1-norm or the infinity-norm, using
+* the LU factorization computed by DGETRF.
+*
+* An estimate is obtained for norm(inv(A)), and the reciprocal of the
+* condition number is computed as
+* RCOND = 1 / ( norm(A) * norm(inv(A)) ).
+*
+* Arguments
+* =========
+*
+* NORM (input) CHARACTER*1
+* Specifies whether the 1-norm condition number or the
+* infinity-norm condition number is required:
+* = '1' or 'O': 1-norm;
+* = 'I': Infinity-norm.
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* A (input) DOUBLE PRECISION array, dimension (LDA,N)
+* The factors L and U from the factorization A = P*L*U
+* as computed by DGETRF.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,N).
+*
+* ANORM (input) DOUBLE PRECISION
+* If NORM = '1' or 'O', the 1-norm of the original matrix A.
+* If NORM = 'I', the infinity-norm of the original matrix A.
+*
+* RCOND (output) DOUBLE PRECISION
+* The reciprocal of the condition number of the matrix A,
+* computed as RCOND = 1/(norm(A) * norm(inv(A))).
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (4*N)
+*
+* IWORK (workspace) INTEGER array, dimension (N)
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE, ZERO
+ PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL ONENRM
+ CHARACTER NORMIN
+ INTEGER IX, KASE, KASE1
+ DOUBLE PRECISION AINVNM, SCALE, SL, SMLNUM, SU
+* ..
+* .. Local Arrays ..
+ INTEGER ISAVE( 3 )
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER IDAMAX
+ DOUBLE PRECISION DLAMCH
+ EXTERNAL LSAME, IDAMAX, DLAMCH
+* ..
+* .. External Subroutines ..
+ EXTERNAL DLACN2, DLATRS, DRSCL, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ ONENRM = NORM.EQ.'1' .OR. LSAME( NORM, 'O' )
+ IF( .NOT.ONENRM .AND. .NOT.LSAME( NORM, 'I' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -4
+ ELSE IF( ANORM.LT.ZERO ) THEN
+ INFO = -5
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DGECON', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ RCOND = ZERO
+ IF( N.EQ.0 ) THEN
+ RCOND = ONE
+ RETURN
+ ELSE IF( ANORM.EQ.ZERO ) THEN
+ RETURN
+ END IF
+*
+ SMLNUM = DLAMCH( 'Safe minimum' )
+*
+* Estimate the norm of inv(A).
+*
+ AINVNM = ZERO
+ NORMIN = 'N'
+ IF( ONENRM ) THEN
+ KASE1 = 1
+ ELSE
+ KASE1 = 2
+ END IF
+ KASE = 0
+ 10 CONTINUE
+ CALL DLACN2( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE, ISAVE )
+ IF( KASE.NE.0 ) THEN
+ IF( KASE.EQ.KASE1 ) THEN
+*
+* Multiply by inv(L).
+*
+ CALL DLATRS( 'Lower', 'No transpose', 'Unit', NORMIN, N, A,
+ $ LDA, WORK, SL, WORK( 2*N+1 ), INFO )
+*
+* Multiply by inv(U).
+*
+ CALL DLATRS( 'Upper', 'No transpose', 'Non-unit', NORMIN, N,
+ $ A, LDA, WORK, SU, WORK( 3*N+1 ), INFO )
+ ELSE
+*
+* Multiply by inv(U').
+*
+ CALL DLATRS( 'Upper', 'Transpose', 'Non-unit', NORMIN, N, A,
+ $ LDA, WORK, SU, WORK( 3*N+1 ), INFO )
+*
+* Multiply by inv(L').
+*
+ CALL DLATRS( 'Lower', 'Transpose', 'Unit', NORMIN, N, A,
+ $ LDA, WORK, SL, WORK( 2*N+1 ), INFO )
+ END IF
+*
+* Divide X by 1/(SL*SU) if doing so will not cause overflow.
+*
+ SCALE = SL*SU
+ NORMIN = 'Y'
+ IF( SCALE.NE.ONE ) THEN
+ IX = IDAMAX( N, WORK, 1 )
+ IF( SCALE.LT.ABS( WORK( IX ) )*SMLNUM .OR. SCALE.EQ.ZERO )
+ $ GO TO 20
+ CALL DRSCL( N, SCALE, WORK, 1 )
+ END IF
+ GO TO 10
+ END IF
+*
+* Compute the estimate of the reciprocal condition number.
+*
+ IF( AINVNM.NE.ZERO )
+ $ RCOND = ( ONE / AINVNM ) / ANORM
+*
+ 20 CONTINUE
+ RETURN
+*
+* End of DGECON
+*
+ END
+ SUBROUTINE DGEEQU( M, N, A, LDA, R, C, ROWCND, COLCND, AMAX,
+ $ INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LDA, M, N
+ DOUBLE PRECISION AMAX, COLCND, ROWCND
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION A( LDA, * ), C( * ), R( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DGEEQU computes row and column scalings intended to equilibrate an
+* M-by-N matrix A and reduce its condition number. R returns the row
+* scale factors and C the column scale factors, chosen to try to make
+* the largest element in each row and column of the matrix B with
+* elements B(i,j)=R(i)*A(i,j)*C(j) have absolute value 1.
+*
+* R(i) and C(j) are restricted to be between SMLNUM = smallest safe
+* number and BIGNUM = largest safe number. Use of these scaling
+* factors is not guaranteed to reduce the condition number of A but
+* works well in practice.
+*
+* Arguments
+* =========
+*
+* M (input) INTEGER
+* The number of rows of the matrix A. M >= 0.
+*
+* N (input) INTEGER
+* The number of columns of the matrix A. N >= 0.
+*
+* A (input) DOUBLE PRECISION array, dimension (LDA,N)
+* The M-by-N matrix whose equilibration factors are
+* to be computed.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,M).
+*
+* R (output) DOUBLE PRECISION array, dimension (M)
+* If INFO = 0 or INFO > M, R contains the row scale factors
+* for A.
+*
+* C (output) DOUBLE PRECISION array, dimension (N)
+* If INFO = 0, C contains the column scale factors for A.
+*
+* ROWCND (output) DOUBLE PRECISION
+* If INFO = 0 or INFO > M, ROWCND contains the ratio of the
+* smallest R(i) to the largest R(i). If ROWCND >= 0.1 and
+* AMAX is neither too large nor too small, it is not worth
+* scaling by R.
+*
+* COLCND (output) DOUBLE PRECISION
+* If INFO = 0, COLCND contains the ratio of the smallest
+* C(i) to the largest C(i). If COLCND >= 0.1, it is not
+* worth scaling by C.
+*
+* AMAX (output) DOUBLE PRECISION
+* Absolute value of largest matrix element. If AMAX is very
+* close to overflow or very close to underflow, the matrix
+* should be scaled.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* > 0: if INFO = i, and i is
+* <= M: the i-th row of A is exactly zero
+* > M: the (i-M)-th column of A is exactly zero
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE, ZERO
+ PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, J
+ DOUBLE PRECISION BIGNUM, RCMAX, RCMIN, SMLNUM
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DLAMCH
+ EXTERNAL DLAMCH
+* ..
+* .. External Subroutines ..
+ EXTERNAL XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ IF( M.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+ INFO = -4
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DGEEQU', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( M.EQ.0 .OR. N.EQ.0 ) THEN
+ ROWCND = ONE
+ COLCND = ONE
+ AMAX = ZERO
+ RETURN
+ END IF
+*
+* Get machine constants.
+*
+ SMLNUM = DLAMCH( 'S' )
+ BIGNUM = ONE / SMLNUM
+*
+* Compute row scale factors.
+*
+ DO 10 I = 1, M
+ R( I ) = ZERO
+ 10 CONTINUE
+*
+* Find the maximum element in each row.
+*
+ DO 30 J = 1, N
+ DO 20 I = 1, M
+ R( I ) = MAX( R( I ), ABS( A( I, J ) ) )
+ 20 CONTINUE
+ 30 CONTINUE
+*
+* Find the maximum and minimum scale factors.
+*
+ RCMIN = BIGNUM
+ RCMAX = ZERO
+ DO 40 I = 1, M
+ RCMAX = MAX( RCMAX, R( I ) )
+ RCMIN = MIN( RCMIN, R( I ) )
+ 40 CONTINUE
+ AMAX = RCMAX
+*
+ IF( RCMIN.EQ.ZERO ) THEN
+*
+* Find the first zero scale factor and return an error code.
+*
+ DO 50 I = 1, M
+ IF( R( I ).EQ.ZERO ) THEN
+ INFO = I
+ RETURN
+ END IF
+ 50 CONTINUE
+ ELSE
+*
+* Invert the scale factors.
+*
+ DO 60 I = 1, M
+ R( I ) = ONE / MIN( MAX( R( I ), SMLNUM ), BIGNUM )
+ 60 CONTINUE
+*
+* Compute ROWCND = min(R(I)) / max(R(I))
+*
+ ROWCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM )
+ END IF
+*
+* Compute column scale factors
+*
+ DO 70 J = 1, N
+ C( J ) = ZERO
+ 70 CONTINUE
+*
+* Find the maximum element in each column,
+* assuming the row scaling computed above.
+*
+ DO 90 J = 1, N
+ DO 80 I = 1, M
+ C( J ) = MAX( C( J ), ABS( A( I, J ) )*R( I ) )
+ 80 CONTINUE
+ 90 CONTINUE
+*
+* Find the maximum and minimum scale factors.
+*
+ RCMIN = BIGNUM
+ RCMAX = ZERO
+ DO 100 J = 1, N
+ RCMIN = MIN( RCMIN, C( J ) )
+ RCMAX = MAX( RCMAX, C( J ) )
+ 100 CONTINUE
+*
+ IF( RCMIN.EQ.ZERO ) THEN
+*
+* Find the first zero scale factor and return an error code.
+*
+ DO 110 J = 1, N
+ IF( C( J ).EQ.ZERO ) THEN
+ INFO = M + J
+ RETURN
+ END IF
+ 110 CONTINUE
+ ELSE
+*
+* Invert the scale factors.
+*
+ DO 120 J = 1, N
+ C( J ) = ONE / MIN( MAX( C( J ), SMLNUM ), BIGNUM )
+ 120 CONTINUE
+*
+* Compute COLCND = min(C(J)) / max(C(J))
+*
+ COLCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM )
+ END IF
+*
+ RETURN
+*
+* End of DGEEQU
+*
+ END
+ SUBROUTINE DGEES( JOBVS, SORT, SELECT, N, A, LDA, SDIM, WR, WI,
+ $ VS, LDVS, WORK, LWORK, BWORK, INFO )
+*
+* -- LAPACK driver routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER JOBVS, SORT
+ INTEGER INFO, LDA, LDVS, LWORK, N, SDIM
+* ..
+* .. Array Arguments ..
+ LOGICAL BWORK( * )
+ DOUBLE PRECISION A( LDA, * ), VS( LDVS, * ), WI( * ), WORK( * ),
+ $ WR( * )
+* ..
+* .. Function Arguments ..
+ LOGICAL SELECT
+ EXTERNAL SELECT
+* ..
+*
+* Purpose
+* =======
+*
+* DGEES computes for an N-by-N real nonsymmetric matrix A, the
+* eigenvalues, the real Schur form T, and, optionally, the matrix of
+* Schur vectors Z. This gives the Schur factorization A = Z*T*(Z**T).
+*
+* Optionally, it also orders the eigenvalues on the diagonal of the
+* real Schur form so that selected eigenvalues are at the top left.
+* The leading columns of Z then form an orthonormal basis for the
+* invariant subspace corresponding to the selected eigenvalues.
+*
+* A matrix is in real Schur form if it is upper quasi-triangular with
+* 1-by-1 and 2-by-2 blocks. 2-by-2 blocks will be standardized in the
+* form
+* [ a b ]
+* [ c a ]
+*
+* where b*c < 0. The eigenvalues of such a block are a +- sqrt(bc).
+*
+* Arguments
+* =========
+*
+* JOBVS (input) CHARACTER*1
+* = 'N': Schur vectors are not computed;
+* = 'V': Schur vectors are computed.
+*
+* SORT (input) CHARACTER*1
+* Specifies whether or not to order the eigenvalues on the
+* diagonal of the Schur form.
+* = 'N': Eigenvalues are not ordered;
+* = 'S': Eigenvalues are ordered (see SELECT).
+*
+* SELECT (external procedure) LOGICAL FUNCTION of two DOUBLE PRECISION arguments
+* SELECT must be declared EXTERNAL in the calling subroutine.
+* If SORT = 'S', SELECT is used to select eigenvalues to sort
+* to the top left of the Schur form.
+* If SORT = 'N', SELECT is not referenced.
+* An eigenvalue WR(j)+sqrt(-1)*WI(j) is selected if
+* SELECT(WR(j),WI(j)) is true; i.e., if either one of a complex
+* conjugate pair of eigenvalues is selected, then both complex
+* eigenvalues are selected.
+* Note that a selected complex eigenvalue may no longer
+* satisfy SELECT(WR(j),WI(j)) = .TRUE. after ordering, since
+* ordering may change the value of complex eigenvalues
+* (especially if the eigenvalue is ill-conditioned); in this
+* case INFO is set to N+2 (see INFO below).
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+* On entry, the N-by-N matrix A.
+* On exit, A has been overwritten by its real Schur form T.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,N).
+*
+* SDIM (output) INTEGER
+* If SORT = 'N', SDIM = 0.
+* If SORT = 'S', SDIM = number of eigenvalues (after sorting)
+* for which SELECT is true. (Complex conjugate
+* pairs for which SELECT is true for either
+* eigenvalue count as 2.)
+*
+* WR (output) DOUBLE PRECISION array, dimension (N)
+* WI (output) DOUBLE PRECISION array, dimension (N)
+* WR and WI contain the real and imaginary parts,
+* respectively, of the computed eigenvalues in the same order
+* that they appear on the diagonal of the output Schur form T.
+* Complex conjugate pairs of eigenvalues will appear
+* consecutively with the eigenvalue having the positive
+* imaginary part first.
+*
+* VS (output) DOUBLE PRECISION array, dimension (LDVS,N)
+* If JOBVS = 'V', VS contains the orthogonal matrix Z of Schur
+* vectors.
+* If JOBVS = 'N', VS is not referenced.
+*
+* LDVS (input) INTEGER
+* The leading dimension of the array VS. LDVS >= 1; if
+* JOBVS = 'V', LDVS >= N.
+*
+* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
+* On exit, if INFO = 0, WORK(1) contains the optimal LWORK.
+*
+* LWORK (input) INTEGER
+* The dimension of the array WORK. LWORK >= max(1,3*N).
+* For good performance, LWORK must generally be larger.
+*
+* If LWORK = -1, then a workspace query is assumed; the routine
+* only calculates the optimal size of the WORK array, returns
+* this value as the first entry of the WORK array, and no error
+* message related to LWORK is issued by XERBLA.
+*
+* BWORK (workspace) LOGICAL array, dimension (N)
+* Not referenced if SORT = 'N'.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value.
+* > 0: if INFO = i, and i is
+* <= N: the QR algorithm failed to compute all the
+* eigenvalues; elements 1:ILO-1 and i+1:N of WR and WI
+* contain those eigenvalues which have converged; if
+* JOBVS = 'V', VS contains the matrix which reduces A
+* to its partially converged Schur form.
+* = N+1: the eigenvalues could not be reordered because some
+* eigenvalues were too close to separate (the problem
+* is very ill-conditioned);
+* = N+2: after reordering, roundoff changed values of some
+* complex eigenvalues so that leading eigenvalues in
+* the Schur form no longer satisfy SELECT=.TRUE. This
+* could also be caused by underflow due to scaling.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL CURSL, LASTSL, LQUERY, LST2SL, SCALEA, WANTST,
+ $ WANTVS
+ INTEGER HSWORK, I, I1, I2, IBAL, ICOND, IERR, IEVAL,
+ $ IHI, ILO, INXT, IP, ITAU, IWRK, MAXWRK, MINWRK
+ DOUBLE PRECISION ANRM, BIGNUM, CSCALE, EPS, S, SEP, SMLNUM
+* ..
+* .. Local Arrays ..
+ INTEGER IDUM( 1 )
+ DOUBLE PRECISION DUM( 1 )
+* ..
+* .. External Subroutines ..
+ EXTERNAL DCOPY, DGEBAK, DGEBAL, DGEHRD, DHSEQR, DLACPY,
+ $ DLABAD, DLASCL, DORGHR, DSWAP, DTRSEN, XERBLA
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ILAENV
+ DOUBLE PRECISION DLAMCH, DLANGE
+ EXTERNAL LSAME, ILAENV, DLAMCH, DLANGE
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, SQRT
+* ..
+* .. Executable Statements ..
+*
+* Test the input arguments
+*
+ INFO = 0
+ LQUERY = ( LWORK.EQ.-1 )
+ WANTVS = LSAME( JOBVS, 'V' )
+ WANTST = LSAME( SORT, 'S' )
+ IF( ( .NOT.WANTVS ) .AND. ( .NOT.LSAME( JOBVS, 'N' ) ) ) THEN
+ INFO = -1
+ ELSE IF( ( .NOT.WANTST ) .AND. ( .NOT.LSAME( SORT, 'N' ) ) ) THEN
+ INFO = -2
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -6
+ ELSE IF( LDVS.LT.1 .OR. ( WANTVS .AND. LDVS.LT.N ) ) THEN
+ INFO = -11
+ END IF
+*
+* Compute workspace
+* (Note: Comments in the code beginning "Workspace:" describe the
+* minimal amount of workspace needed at that point in the code,
+* as well as the preferred amount for good performance.
+* NB refers to the optimal block size for the immediately
+* following subroutine, as returned by ILAENV.
+* HSWORK refers to the workspace preferred by DHSEQR, as
+* calculated below. HSWORK is computed assuming ILO=1 and IHI=N,
+* the worst case.)
+*
+ IF( INFO.EQ.0 ) THEN
+ IF( N.EQ.0 ) THEN
+ MINWRK = 1
+ MAXWRK = 1
+ ELSE
+ MAXWRK = 2*N + N*ILAENV( 1, 'DGEHRD', ' ', N, 1, N, 0 )
+ MINWRK = 3*N
+*
+ CALL DHSEQR( 'S', JOBVS, N, 1, N, A, LDA, WR, WI, VS, LDVS,
+ $ WORK, -1, IEVAL )
+ HSWORK = WORK( 1 )
+*
+ IF( .NOT.WANTVS ) THEN
+ MAXWRK = MAX( MAXWRK, N + HSWORK )
+ ELSE
+ MAXWRK = MAX( MAXWRK, 2*N + ( N - 1 )*ILAENV( 1,
+ $ 'DORGHR', ' ', N, 1, N, -1 ) )
+ MAXWRK = MAX( MAXWRK, N + HSWORK )
+ END IF
+ END IF
+ WORK( 1 ) = MAXWRK
+*
+ IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN
+ INFO = -13
+ END IF
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DGEES ', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 ) THEN
+ SDIM = 0
+ RETURN
+ END IF
+*
+* Get machine constants
+*
+ EPS = DLAMCH( 'P' )
+ SMLNUM = DLAMCH( 'S' )
+ BIGNUM = ONE / SMLNUM
+ CALL DLABAD( SMLNUM, BIGNUM )
+ SMLNUM = SQRT( SMLNUM ) / EPS
+ BIGNUM = ONE / SMLNUM
+*
+* Scale A if max element outside range [SMLNUM,BIGNUM]
+*
+ ANRM = DLANGE( 'M', N, N, A, LDA, DUM )
+ SCALEA = .FALSE.
+ IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
+ SCALEA = .TRUE.
+ CSCALE = SMLNUM
+ ELSE IF( ANRM.GT.BIGNUM ) THEN
+ SCALEA = .TRUE.
+ CSCALE = BIGNUM
+ END IF
+ IF( SCALEA )
+ $ CALL DLASCL( 'G', 0, 0, ANRM, CSCALE, N, N, A, LDA, IERR )
+*
+* Permute the matrix to make it more nearly triangular
+* (Workspace: need N)
+*
+ IBAL = 1
+ CALL DGEBAL( 'P', N, A, LDA, ILO, IHI, WORK( IBAL ), IERR )
+*
+* Reduce to upper Hessenberg form
+* (Workspace: need 3*N, prefer 2*N+N*NB)
+*
+ ITAU = N + IBAL
+ IWRK = N + ITAU
+ CALL DGEHRD( N, ILO, IHI, A, LDA, WORK( ITAU ), WORK( IWRK ),
+ $ LWORK-IWRK+1, IERR )
+*
+ IF( WANTVS ) THEN
+*
+* Copy Householder vectors to VS
+*
+ CALL DLACPY( 'L', N, N, A, LDA, VS, LDVS )
+*
+* Generate orthogonal matrix in VS
+* (Workspace: need 3*N-1, prefer 2*N+(N-1)*NB)
+*
+ CALL DORGHR( N, ILO, IHI, VS, LDVS, WORK( ITAU ), WORK( IWRK ),
+ $ LWORK-IWRK+1, IERR )
+ END IF
+*
+ SDIM = 0
+*
+* Perform QR iteration, accumulating Schur vectors in VS if desired
+* (Workspace: need N+1, prefer N+HSWORK (see comments) )
+*
+ IWRK = ITAU
+ CALL DHSEQR( 'S', JOBVS, N, ILO, IHI, A, LDA, WR, WI, VS, LDVS,
+ $ WORK( IWRK ), LWORK-IWRK+1, IEVAL )
+ IF( IEVAL.GT.0 )
+ $ INFO = IEVAL
+*
+* Sort eigenvalues if desired
+*
+ IF( WANTST .AND. INFO.EQ.0 ) THEN
+ IF( SCALEA ) THEN
+ CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, N, 1, WR, N, IERR )
+ CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, N, 1, WI, N, IERR )
+ END IF
+ DO 10 I = 1, N
+ BWORK( I ) = SELECT( WR( I ), WI( I ) )
+ 10 CONTINUE
+*
+* Reorder eigenvalues and transform Schur vectors
+* (Workspace: none needed)
+*
+ CALL DTRSEN( 'N', JOBVS, BWORK, N, A, LDA, VS, LDVS, WR, WI,
+ $ SDIM, S, SEP, WORK( IWRK ), LWORK-IWRK+1, IDUM, 1,
+ $ ICOND )
+ IF( ICOND.GT.0 )
+ $ INFO = N + ICOND
+ END IF
+*
+ IF( WANTVS ) THEN
+*
+* Undo balancing
+* (Workspace: need N)
+*
+ CALL DGEBAK( 'P', 'R', N, ILO, IHI, WORK( IBAL ), N, VS, LDVS,
+ $ IERR )
+ END IF
+*
+ IF( SCALEA ) THEN
+*
+* Undo scaling for the Schur form of A
+*
+ CALL DLASCL( 'H', 0, 0, CSCALE, ANRM, N, N, A, LDA, IERR )
+ CALL DCOPY( N, A, LDA+1, WR, 1 )
+ IF( CSCALE.EQ.SMLNUM ) THEN
+*
+* If scaling back towards underflow, adjust WI if an
+* offdiagonal element of a 2-by-2 block in the Schur form
+* underflows.
+*
+ IF( IEVAL.GT.0 ) THEN
+ I1 = IEVAL + 1
+ I2 = IHI - 1
+ CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, ILO-1, 1, WI,
+ $ MAX( ILO-1, 1 ), IERR )
+ ELSE IF( WANTST ) THEN
+ I1 = 1
+ I2 = N - 1
+ ELSE
+ I1 = ILO
+ I2 = IHI - 1
+ END IF
+ INXT = I1 - 1
+ DO 20 I = I1, I2
+ IF( I.LT.INXT )
+ $ GO TO 20
+ IF( WI( I ).EQ.ZERO ) THEN
+ INXT = I + 1
+ ELSE
+ IF( A( I+1, I ).EQ.ZERO ) THEN
+ WI( I ) = ZERO
+ WI( I+1 ) = ZERO
+ ELSE IF( A( I+1, I ).NE.ZERO .AND. A( I, I+1 ).EQ.
+ $ ZERO ) THEN
+ WI( I ) = ZERO
+ WI( I+1 ) = ZERO
+ IF( I.GT.1 )
+ $ CALL DSWAP( I-1, A( 1, I ), 1, A( 1, I+1 ), 1 )
+ IF( N.GT.I+1 )
+ $ CALL DSWAP( N-I-1, A( I, I+2 ), LDA,
+ $ A( I+1, I+2 ), LDA )
+ IF( WANTVS ) THEN
+ CALL DSWAP( N, VS( 1, I ), 1, VS( 1, I+1 ), 1 )
+ END IF
+ A( I, I+1 ) = A( I+1, I )
+ A( I+1, I ) = ZERO
+ END IF
+ INXT = I + 2
+ END IF
+ 20 CONTINUE
+ END IF
+*
+* Undo scaling for the imaginary part of the eigenvalues
+*
+ CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, N-IEVAL, 1,
+ $ WI( IEVAL+1 ), MAX( N-IEVAL, 1 ), IERR )
+ END IF
+*
+ IF( WANTST .AND. INFO.EQ.0 ) THEN
+*
+* Check if reordering successful
+*
+ LASTSL = .TRUE.
+ LST2SL = .TRUE.
+ SDIM = 0
+ IP = 0
+ DO 30 I = 1, N
+ CURSL = SELECT( WR( I ), WI( I ) )
+ IF( WI( I ).EQ.ZERO ) THEN
+ IF( CURSL )
+ $ SDIM = SDIM + 1
+ IP = 0
+ IF( CURSL .AND. .NOT.LASTSL )
+ $ INFO = N + 2
+ ELSE
+ IF( IP.EQ.1 ) THEN
+*
+* Last eigenvalue of conjugate pair
+*
+ CURSL = CURSL .OR. LASTSL
+ LASTSL = CURSL
+ IF( CURSL )
+ $ SDIM = SDIM + 2
+ IP = -1
+ IF( CURSL .AND. .NOT.LST2SL )
+ $ INFO = N + 2
+ ELSE
+*
+* First eigenvalue of conjugate pair
+*
+ IP = 1
+ END IF
+ END IF
+ LST2SL = LASTSL
+ LASTSL = CURSL
+ 30 CONTINUE
+ END IF
+*
+ WORK( 1 ) = MAXWRK
+ RETURN
+*
+* End of DGEES
+*
+ END
+ SUBROUTINE DGEESX( JOBVS, SORT, SELECT, SENSE, N, A, LDA, SDIM,
+ $ WR, WI, VS, LDVS, RCONDE, RCONDV, WORK, LWORK,
+ $ IWORK, LIWORK, BWORK, INFO )
+*
+* -- LAPACK driver routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER JOBVS, SENSE, SORT
+ INTEGER INFO, LDA, LDVS, LIWORK, LWORK, N, SDIM
+ DOUBLE PRECISION RCONDE, RCONDV
+* ..
+* .. Array Arguments ..
+ LOGICAL BWORK( * )
+ INTEGER IWORK( * )
+ DOUBLE PRECISION A( LDA, * ), VS( LDVS, * ), WI( * ), WORK( * ),
+ $ WR( * )
+* ..
+* .. Function Arguments ..
+ LOGICAL SELECT
+ EXTERNAL SELECT
+* ..
+*
+* Purpose
+* =======
+*
+* DGEESX computes for an N-by-N real nonsymmetric matrix A, the
+* eigenvalues, the real Schur form T, and, optionally, the matrix of
+* Schur vectors Z. This gives the Schur factorization A = Z*T*(Z**T).
+*
+* Optionally, it also orders the eigenvalues on the diagonal of the
+* real Schur form so that selected eigenvalues are at the top left;
+* computes a reciprocal condition number for the average of the
+* selected eigenvalues (RCONDE); and computes a reciprocal condition
+* number for the right invariant subspace corresponding to the
+* selected eigenvalues (RCONDV). The leading columns of Z form an
+* orthonormal basis for this invariant subspace.
+*
+* For further explanation of the reciprocal condition numbers RCONDE
+* and RCONDV, see Section 4.10 of the LAPACK Users' Guide (where
+* these quantities are called s and sep respectively).
+*
+* A real matrix is in real Schur form if it is upper quasi-triangular
+* with 1-by-1 and 2-by-2 blocks. 2-by-2 blocks will be standardized in
+* the form
+* [ a b ]
+* [ c a ]
+*
+* where b*c < 0. The eigenvalues of such a block are a +- sqrt(bc).
+*
+* Arguments
+* =========
+*
+* JOBVS (input) CHARACTER*1
+* = 'N': Schur vectors are not computed;
+* = 'V': Schur vectors are computed.
+*
+* SORT (input) CHARACTER*1
+* Specifies whether or not to order the eigenvalues on the
+* diagonal of the Schur form.
+* = 'N': Eigenvalues are not ordered;
+* = 'S': Eigenvalues are ordered (see SELECT).
+*
+* SELECT (external procedure) LOGICAL FUNCTION of two DOUBLE PRECISION arguments
+* SELECT must be declared EXTERNAL in the calling subroutine.
+* If SORT = 'S', SELECT is used to select eigenvalues to sort
+* to the top left of the Schur form.
+* If SORT = 'N', SELECT is not referenced.
+* An eigenvalue WR(j)+sqrt(-1)*WI(j) is selected if
+* SELECT(WR(j),WI(j)) is true; i.e., if either one of a
+* complex conjugate pair of eigenvalues is selected, then both
+* are. Note that a selected complex eigenvalue may no longer
+* satisfy SELECT(WR(j),WI(j)) = .TRUE. after ordering, since
+* ordering may change the value of complex eigenvalues
+* (especially if the eigenvalue is ill-conditioned); in this
+* case INFO may be set to N+3 (see INFO below).
+*
+* SENSE (input) CHARACTER*1
+* Determines which reciprocal condition numbers are computed.
+* = 'N': None are computed;
+* = 'E': Computed for average of selected eigenvalues only;
+* = 'V': Computed for selected right invariant subspace only;
+* = 'B': Computed for both.
+* If SENSE = 'E', 'V' or 'B', SORT must equal 'S'.
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* A (input/output) DOUBLE PRECISION array, dimension (LDA, N)
+* On entry, the N-by-N matrix A.
+* On exit, A is overwritten by its real Schur form T.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,N).
+*
+* SDIM (output) INTEGER
+* If SORT = 'N', SDIM = 0.
+* If SORT = 'S', SDIM = number of eigenvalues (after sorting)
+* for which SELECT is true. (Complex conjugate
+* pairs for which SELECT is true for either
+* eigenvalue count as 2.)
+*
+* WR (output) DOUBLE PRECISION array, dimension (N)
+* WI (output) DOUBLE PRECISION array, dimension (N)
+* WR and WI contain the real and imaginary parts, respectively,
+* of the computed eigenvalues, in the same order that they
+* appear on the diagonal of the output Schur form T. Complex
+* conjugate pairs of eigenvalues appear consecutively with the
+* eigenvalue having the positive imaginary part first.
+*
+* VS (output) DOUBLE PRECISION array, dimension (LDVS,N)
+* If JOBVS = 'V', VS contains the orthogonal matrix Z of Schur
+* vectors.
+* If JOBVS = 'N', VS is not referenced.
+*
+* LDVS (input) INTEGER
+* The leading dimension of the array VS. LDVS >= 1, and if
+* JOBVS = 'V', LDVS >= N.
+*
+* RCONDE (output) DOUBLE PRECISION
+* If SENSE = 'E' or 'B', RCONDE contains the reciprocal
+* condition number for the average of the selected eigenvalues.
+* Not referenced if SENSE = 'N' or 'V'.
+*
+* RCONDV (output) DOUBLE PRECISION
+* If SENSE = 'V' or 'B', RCONDV contains the reciprocal
+* condition number for the selected right invariant subspace.
+* Not referenced if SENSE = 'N' or 'E'.
+*
+* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
+* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+* LWORK (input) INTEGER
+* The dimension of the array WORK. LWORK >= max(1,3*N).
+* Also, if SENSE = 'E' or 'V' or 'B',
+* LWORK >= N+2*SDIM*(N-SDIM), where SDIM is the number of
+* selected eigenvalues computed by this routine. Note that
+* N+2*SDIM*(N-SDIM) <= N+N*N/2. Note also that an error is only
+* returned if LWORK < max(1,3*N), but if SENSE = 'E' or 'V' or
+* 'B' this may not be large enough.
+* For good performance, LWORK must generally be larger.
+*
+* If LWORK = -1, then a workspace query is assumed; the routine
+* only calculates upper bounds on the optimal sizes of the
+* arrays WORK and IWORK, returns these values as the first
+* entries of the WORK and IWORK arrays, and no error messages
+* related to LWORK or LIWORK are issued by XERBLA.
+*
+* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))
+* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
+*
+* LIWORK (input) INTEGER
+* The dimension of the array IWORK.
+* LIWORK >= 1; if SENSE = 'V' or 'B', LIWORK >= SDIM*(N-SDIM).
+* Note that SDIM*(N-SDIM) <= N*N/4. Note also that an error is
+* only returned if LIWORK < 1, but if SENSE = 'V' or 'B' this
+* may not be large enough.
+*
+* If LIWORK = -1, then a workspace query is assumed; the
+* routine only calculates upper bounds on the optimal sizes of
+* the arrays WORK and IWORK, returns these values as the first
+* entries of the WORK and IWORK arrays, and no error messages
+* related to LWORK or LIWORK are issued by XERBLA.
+*
+* BWORK (workspace) LOGICAL array, dimension (N)
+* Not referenced if SORT = 'N'.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value.
+* > 0: if INFO = i, and i is
+* <= N: the QR algorithm failed to compute all the
+* eigenvalues; elements 1:ILO-1 and i+1:N of WR and WI
+* contain those eigenvalues which have converged; if
+* JOBVS = 'V', VS contains the transformation which
+* reduces A to its partially converged Schur form.
+* = N+1: the eigenvalues could not be reordered because some
+* eigenvalues were too close to separate (the problem
+* is very ill-conditioned);
+* = N+2: after reordering, roundoff changed values of some
+* complex eigenvalues so that leading eigenvalues in
+* the Schur form no longer satisfy SELECT=.TRUE. This
+* could also be caused by underflow due to scaling.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL CURSL, LASTSL, LQUERY, LST2SL, SCALEA, WANTSB,
+ $ WANTSE, WANTSN, WANTST, WANTSV, WANTVS
+ INTEGER HSWORK, I, I1, I2, IBAL, ICOND, IERR, IEVAL,
+ $ IHI, ILO, INXT, IP, ITAU, IWRK, LIWRK, LWRK,
+ $ MAXWRK, MINWRK
+ DOUBLE PRECISION ANRM, BIGNUM, CSCALE, EPS, SMLNUM
+* ..
+* .. Local Arrays ..
+ DOUBLE PRECISION DUM( 1 )
+* ..
+* .. External Subroutines ..
+ EXTERNAL DCOPY, DGEBAK, DGEBAL, DGEHRD, DHSEQR, DLACPY,
+ $ DLASCL, DORGHR, DSWAP, DTRSEN, XERBLA
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ILAENV
+ DOUBLE PRECISION DLAMCH, DLANGE
+ EXTERNAL LSAME, ILAENV, DLABAD, DLAMCH, DLANGE
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, SQRT
+* ..
+* .. Executable Statements ..
+*
+* Test the input arguments
+*
+ INFO = 0
+ WANTVS = LSAME( JOBVS, 'V' )
+ WANTST = LSAME( SORT, 'S' )
+ WANTSN = LSAME( SENSE, 'N' )
+ WANTSE = LSAME( SENSE, 'E' )
+ WANTSV = LSAME( SENSE, 'V' )
+ WANTSB = LSAME( SENSE, 'B' )
+ LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 )
+ IF( ( .NOT.WANTVS ) .AND. ( .NOT.LSAME( JOBVS, 'N' ) ) ) THEN
+ INFO = -1
+ ELSE IF( ( .NOT.WANTST ) .AND. ( .NOT.LSAME( SORT, 'N' ) ) ) THEN
+ INFO = -2
+ ELSE IF( .NOT.( WANTSN .OR. WANTSE .OR. WANTSV .OR. WANTSB ) .OR.
+ $ ( .NOT.WANTST .AND. .NOT.WANTSN ) ) THEN
+ INFO = -4
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -5
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -7
+ ELSE IF( LDVS.LT.1 .OR. ( WANTVS .AND. LDVS.LT.N ) ) THEN
+ INFO = -12
+ END IF
+*
+* Compute workspace
+* (Note: Comments in the code beginning "RWorkspace:" describe the
+* minimal amount of real workspace needed at that point in the
+* code, as well as the preferred amount for good performance.
+* IWorkspace refers to integer workspace.
+* NB refers to the optimal block size for the immediately
+* following subroutine, as returned by ILAENV.
+* HSWORK refers to the workspace preferred by DHSEQR, as
+* calculated below. HSWORK is computed assuming ILO=1 and IHI=N,
+* the worst case.
+* If SENSE = 'E', 'V' or 'B', then the amount of workspace needed
+* depends on SDIM, which is computed by the routine DTRSEN later
+* in the code.)
+*
+ IF( INFO.EQ.0 ) THEN
+ LIWRK = 1
+ IF( N.EQ.0 ) THEN
+ MINWRK = 1
+ LWRK = 1
+ ELSE
+ MAXWRK = 2*N + N*ILAENV( 1, 'DGEHRD', ' ', N, 1, N, 0 )
+ MINWRK = 3*N
+*
+ CALL DHSEQR( 'S', JOBVS, N, 1, N, A, LDA, WR, WI, VS, LDVS,
+ $ WORK, -1, IEVAL )
+ HSWORK = WORK( 1 )
+*
+ IF( .NOT.WANTVS ) THEN
+ MAXWRK = MAX( MAXWRK, N + HSWORK )
+ ELSE
+ MAXWRK = MAX( MAXWRK, 2*N + ( N - 1 )*ILAENV( 1,
+ $ 'DORGHR', ' ', N, 1, N, -1 ) )
+ MAXWRK = MAX( MAXWRK, N + HSWORK )
+ END IF
+ LWRK = MAXWRK
+ IF( .NOT.WANTSN )
+ $ LWRK = MAX( LWRK, N + ( N*N )/2 )
+ IF( WANTSV .OR. WANTSB )
+ $ LIWRK = ( N*N )/4
+ END IF
+ IWORK( 1 ) = LIWRK
+ WORK( 1 ) = LWRK
+*
+ IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN
+ INFO = -16
+ ELSE IF( LIWORK.LT.1 .AND. .NOT.LQUERY ) THEN
+ INFO = -18
+ END IF
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DGEESX', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 ) THEN
+ SDIM = 0
+ RETURN
+ END IF
+*
+* Get machine constants
+*
+ EPS = DLAMCH( 'P' )
+ SMLNUM = DLAMCH( 'S' )
+ BIGNUM = ONE / SMLNUM
+ CALL DLABAD( SMLNUM, BIGNUM )
+ SMLNUM = SQRT( SMLNUM ) / EPS
+ BIGNUM = ONE / SMLNUM
+*
+* Scale A if max element outside range [SMLNUM,BIGNUM]
+*
+ ANRM = DLANGE( 'M', N, N, A, LDA, DUM )
+ SCALEA = .FALSE.
+ IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
+ SCALEA = .TRUE.
+ CSCALE = SMLNUM
+ ELSE IF( ANRM.GT.BIGNUM ) THEN
+ SCALEA = .TRUE.
+ CSCALE = BIGNUM
+ END IF
+ IF( SCALEA )
+ $ CALL DLASCL( 'G', 0, 0, ANRM, CSCALE, N, N, A, LDA, IERR )
+*
+* Permute the matrix to make it more nearly triangular
+* (RWorkspace: need N)
+*
+ IBAL = 1
+ CALL DGEBAL( 'P', N, A, LDA, ILO, IHI, WORK( IBAL ), IERR )
+*
+* Reduce to upper Hessenberg form
+* (RWorkspace: need 3*N, prefer 2*N+N*NB)
+*
+ ITAU = N + IBAL
+ IWRK = N + ITAU
+ CALL DGEHRD( N, ILO, IHI, A, LDA, WORK( ITAU ), WORK( IWRK ),
+ $ LWORK-IWRK+1, IERR )
+*
+ IF( WANTVS ) THEN
+*
+* Copy Householder vectors to VS
+*
+ CALL DLACPY( 'L', N, N, A, LDA, VS, LDVS )
+*
+* Generate orthogonal matrix in VS
+* (RWorkspace: need 3*N-1, prefer 2*N+(N-1)*NB)
+*
+ CALL DORGHR( N, ILO, IHI, VS, LDVS, WORK( ITAU ), WORK( IWRK ),
+ $ LWORK-IWRK+1, IERR )
+ END IF
+*
+ SDIM = 0
+*
+* Perform QR iteration, accumulating Schur vectors in VS if desired
+* (RWorkspace: need N+1, prefer N+HSWORK (see comments) )
+*
+ IWRK = ITAU
+ CALL DHSEQR( 'S', JOBVS, N, ILO, IHI, A, LDA, WR, WI, VS, LDVS,
+ $ WORK( IWRK ), LWORK-IWRK+1, IEVAL )
+ IF( IEVAL.GT.0 )
+ $ INFO = IEVAL
+*
+* Sort eigenvalues if desired
+*
+ IF( WANTST .AND. INFO.EQ.0 ) THEN
+ IF( SCALEA ) THEN
+ CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, N, 1, WR, N, IERR )
+ CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, N, 1, WI, N, IERR )
+ END IF
+ DO 10 I = 1, N
+ BWORK( I ) = SELECT( WR( I ), WI( I ) )
+ 10 CONTINUE
+*
+* Reorder eigenvalues, transform Schur vectors, and compute
+* reciprocal condition numbers
+* (RWorkspace: if SENSE is not 'N', need N+2*SDIM*(N-SDIM)
+* otherwise, need N )
+* (IWorkspace: if SENSE is 'V' or 'B', need SDIM*(N-SDIM)
+* otherwise, need 0 )
+*
+ CALL DTRSEN( SENSE, JOBVS, BWORK, N, A, LDA, VS, LDVS, WR, WI,
+ $ SDIM, RCONDE, RCONDV, WORK( IWRK ), LWORK-IWRK+1,
+ $ IWORK, LIWORK, ICOND )
+ IF( .NOT.WANTSN )
+ $ MAXWRK = MAX( MAXWRK, N+2*SDIM*( N-SDIM ) )
+ IF( ICOND.EQ.-15 ) THEN
+*
+* Not enough real workspace
+*
+ INFO = -16
+ ELSE IF( ICOND.EQ.-17 ) THEN
+*
+* Not enough integer workspace
+*
+ INFO = -18
+ ELSE IF( ICOND.GT.0 ) THEN
+*
+* DTRSEN failed to reorder or to restore standard Schur form
+*
+ INFO = ICOND + N
+ END IF
+ END IF
+*
+ IF( WANTVS ) THEN
+*
+* Undo balancing
+* (RWorkspace: need N)
+*
+ CALL DGEBAK( 'P', 'R', N, ILO, IHI, WORK( IBAL ), N, VS, LDVS,
+ $ IERR )
+ END IF
+*
+ IF( SCALEA ) THEN
+*
+* Undo scaling for the Schur form of A
+*
+ CALL DLASCL( 'H', 0, 0, CSCALE, ANRM, N, N, A, LDA, IERR )
+ CALL DCOPY( N, A, LDA+1, WR, 1 )
+ IF( ( WANTSV .OR. WANTSB ) .AND. INFO.EQ.0 ) THEN
+ DUM( 1 ) = RCONDV
+ CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, 1, 1, DUM, 1, IERR )
+ RCONDV = DUM( 1 )
+ END IF
+ IF( CSCALE.EQ.SMLNUM ) THEN
+*
+* If scaling back towards underflow, adjust WI if an
+* offdiagonal element of a 2-by-2 block in the Schur form
+* underflows.
+*
+ IF( IEVAL.GT.0 ) THEN
+ I1 = IEVAL + 1
+ I2 = IHI - 1
+ CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, ILO-1, 1, WI, N,
+ $ IERR )
+ ELSE IF( WANTST ) THEN
+ I1 = 1
+ I2 = N - 1
+ ELSE
+ I1 = ILO
+ I2 = IHI - 1
+ END IF
+ INXT = I1 - 1
+ DO 20 I = I1, I2
+ IF( I.LT.INXT )
+ $ GO TO 20
+ IF( WI( I ).EQ.ZERO ) THEN
+ INXT = I + 1
+ ELSE
+ IF( A( I+1, I ).EQ.ZERO ) THEN
+ WI( I ) = ZERO
+ WI( I+1 ) = ZERO
+ ELSE IF( A( I+1, I ).NE.ZERO .AND. A( I, I+1 ).EQ.
+ $ ZERO ) THEN
+ WI( I ) = ZERO
+ WI( I+1 ) = ZERO
+ IF( I.GT.1 )
+ $ CALL DSWAP( I-1, A( 1, I ), 1, A( 1, I+1 ), 1 )
+ IF( N.GT.I+1 )
+ $ CALL DSWAP( N-I-1, A( I, I+2 ), LDA,
+ $ A( I+1, I+2 ), LDA )
+ CALL DSWAP( N, VS( 1, I ), 1, VS( 1, I+1 ), 1 )
+ A( I, I+1 ) = A( I+1, I )
+ A( I+1, I ) = ZERO
+ END IF
+ INXT = I + 2
+ END IF
+ 20 CONTINUE
+ END IF
+ CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, N-IEVAL, 1,
+ $ WI( IEVAL+1 ), MAX( N-IEVAL, 1 ), IERR )
+ END IF
+*
+ IF( WANTST .AND. INFO.EQ.0 ) THEN
+*
+* Check if reordering successful
+*
+ LASTSL = .TRUE.
+ LST2SL = .TRUE.
+ SDIM = 0
+ IP = 0
+ DO 30 I = 1, N
+ CURSL = SELECT( WR( I ), WI( I ) )
+ IF( WI( I ).EQ.ZERO ) THEN
+ IF( CURSL )
+ $ SDIM = SDIM + 1
+ IP = 0
+ IF( CURSL .AND. .NOT.LASTSL )
+ $ INFO = N + 2
+ ELSE
+ IF( IP.EQ.1 ) THEN
+*
+* Last eigenvalue of conjugate pair
+*
+ CURSL = CURSL .OR. LASTSL
+ LASTSL = CURSL
+ IF( CURSL )
+ $ SDIM = SDIM + 2
+ IP = -1
+ IF( CURSL .AND. .NOT.LST2SL )
+ $ INFO = N + 2
+ ELSE
+*
+* First eigenvalue of conjugate pair
+*
+ IP = 1
+ END IF
+ END IF
+ LST2SL = LASTSL
+ LASTSL = CURSL
+ 30 CONTINUE
+ END IF
+*
+ WORK( 1 ) = MAXWRK
+ IF( WANTSV .OR. WANTSB ) THEN
+ IWORK( 1 ) = MAX( 1, SDIM*( N-SDIM ) )
+ ELSE
+ IWORK( 1 ) = 1
+ END IF
+*
+ RETURN
+*
+* End of DGEESX
+*
+ END
+ SUBROUTINE DGEEV( JOBVL, JOBVR, N, A, LDA, WR, WI, VL, LDVL, VR,
+ $ LDVR, WORK, LWORK, INFO )
+*
+* -- LAPACK driver routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER JOBVL, JOBVR
+ INTEGER INFO, LDA, LDVL, LDVR, LWORK, N
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION A( LDA, * ), VL( LDVL, * ), VR( LDVR, * ),
+ $ WI( * ), WORK( * ), WR( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DGEEV computes for an N-by-N real nonsymmetric matrix A, the
+* eigenvalues and, optionally, the left and/or right eigenvectors.
+*
+* The right eigenvector v(j) of A satisfies
+* A * v(j) = lambda(j) * v(j)
+* where lambda(j) is its eigenvalue.
+* The left eigenvector u(j) of A satisfies
+* u(j)**H * A = lambda(j) * u(j)**H
+* where u(j)**H denotes the conjugate transpose of u(j).
+*
+* The computed eigenvectors are normalized to have Euclidean norm
+* equal to 1 and largest component real.
+*
+* Arguments
+* =========
+*
+* JOBVL (input) CHARACTER*1
+* = 'N': left eigenvectors of A are not computed;
+* = 'V': left eigenvectors of A are computed.
+*
+* JOBVR (input) CHARACTER*1
+* = 'N': right eigenvectors of A are not computed;
+* = 'V': right eigenvectors of A are computed.
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+* On entry, the N-by-N matrix A.
+* On exit, A has been overwritten.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,N).
+*
+* WR (output) DOUBLE PRECISION array, dimension (N)
+* WI (output) DOUBLE PRECISION array, dimension (N)
+* WR and WI contain the real and imaginary parts,
+* respectively, of the computed eigenvalues. Complex
+* conjugate pairs of eigenvalues appear consecutively
+* with the eigenvalue having the positive imaginary part
+* first.
+*
+* VL (output) DOUBLE PRECISION array, dimension (LDVL,N)
+* If JOBVL = 'V', the left eigenvectors u(j) are stored one
+* after another in the columns of VL, in the same order
+* as their eigenvalues.
+* If JOBVL = 'N', VL is not referenced.
+* If the j-th eigenvalue is real, then u(j) = VL(:,j),
+* the j-th column of VL.
+* If the j-th and (j+1)-st eigenvalues form a complex
+* conjugate pair, then u(j) = VL(:,j) + i*VL(:,j+1) and
+* u(j+1) = VL(:,j) - i*VL(:,j+1).
+*
+* LDVL (input) INTEGER
+* The leading dimension of the array VL. LDVL >= 1; if
+* JOBVL = 'V', LDVL >= N.
+*
+* VR (output) DOUBLE PRECISION array, dimension (LDVR,N)
+* If JOBVR = 'V', the right eigenvectors v(j) are stored one
+* after another in the columns of VR, in the same order
+* as their eigenvalues.
+* If JOBVR = 'N', VR is not referenced.
+* If the j-th eigenvalue is real, then v(j) = VR(:,j),
+* the j-th column of VR.
+* If the j-th and (j+1)-st eigenvalues form a complex
+* conjugate pair, then v(j) = VR(:,j) + i*VR(:,j+1) and
+* v(j+1) = VR(:,j) - i*VR(:,j+1).
+*
+* LDVR (input) INTEGER
+* The leading dimension of the array VR. LDVR >= 1; if
+* JOBVR = 'V', LDVR >= N.
+*
+* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
+* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+* LWORK (input) INTEGER
+* The dimension of the array WORK. LWORK >= max(1,3*N), and
+* if JOBVL = 'V' or JOBVR = 'V', LWORK >= 4*N. For good
+* performance, LWORK must generally be larger.
+*
+* If LWORK = -1, then a workspace query is assumed; the routine
+* only calculates the optimal size of the WORK array, returns
+* this value as the first entry of the WORK array, and no error
+* message related to LWORK is issued by XERBLA.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value.
+* > 0: if INFO = i, the QR algorithm failed to compute all the
+* eigenvalues, and no eigenvectors have been computed;
+* elements i+1:N of WR and WI contain eigenvalues which
+* have converged.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL LQUERY, SCALEA, WANTVL, WANTVR
+ CHARACTER SIDE
+ INTEGER HSWORK, I, IBAL, IERR, IHI, ILO, ITAU, IWRK, K,
+ $ MAXWRK, MINWRK, NOUT
+ DOUBLE PRECISION ANRM, BIGNUM, CS, CSCALE, EPS, R, SCL, SMLNUM,
+ $ SN
+* ..
+* .. Local Arrays ..
+ LOGICAL SELECT( 1 )
+ DOUBLE PRECISION DUM( 1 )
+* ..
+* .. External Subroutines ..
+ EXTERNAL DGEBAK, DGEBAL, DGEHRD, DHSEQR, DLABAD, DLACPY,
+ $ DLARTG, DLASCL, DORGHR, DROT, DSCAL, DTREVC,
+ $ XERBLA
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER IDAMAX, ILAENV
+ DOUBLE PRECISION DLAMCH, DLANGE, DLAPY2, DNRM2
+ EXTERNAL LSAME, IDAMAX, ILAENV, DLAMCH, DLANGE, DLAPY2,
+ $ DNRM2
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, SQRT
+* ..
+* .. Executable Statements ..
+*
+* Test the input arguments
+*
+ INFO = 0
+ LQUERY = ( LWORK.EQ.-1 )
+ WANTVL = LSAME( JOBVL, 'V' )
+ WANTVR = LSAME( JOBVR, 'V' )
+ IF( ( .NOT.WANTVL ) .AND. ( .NOT.LSAME( JOBVL, 'N' ) ) ) THEN
+ INFO = -1
+ ELSE IF( ( .NOT.WANTVR ) .AND. ( .NOT.LSAME( JOBVR, 'N' ) ) ) THEN
+ INFO = -2
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -5
+ ELSE IF( LDVL.LT.1 .OR. ( WANTVL .AND. LDVL.LT.N ) ) THEN
+ INFO = -9
+ ELSE IF( LDVR.LT.1 .OR. ( WANTVR .AND. LDVR.LT.N ) ) THEN
+ INFO = -11
+ END IF
+*
+* Compute workspace
+* (Note: Comments in the code beginning "Workspace:" describe the
+* minimal amount of workspace needed at that point in the code,
+* as well as the preferred amount for good performance.
+* NB refers to the optimal block size for the immediately
+* following subroutine, as returned by ILAENV.
+* HSWORK refers to the workspace preferred by DHSEQR, as
+* calculated below. HSWORK is computed assuming ILO=1 and IHI=N,
+* the worst case.)
+*
+ IF( INFO.EQ.0 ) THEN
+ IF( N.EQ.0 ) THEN
+ MINWRK = 1
+ MAXWRK = 1
+ ELSE
+ MAXWRK = 2*N + N*ILAENV( 1, 'DGEHRD', ' ', N, 1, N, 0 )
+ IF( WANTVL ) THEN
+ MINWRK = 4*N
+ MAXWRK = MAX( MAXWRK, 2*N + ( N - 1 )*ILAENV( 1,
+ $ 'DORGHR', ' ', N, 1, N, -1 ) )
+ CALL DHSEQR( 'S', 'V', N, 1, N, A, LDA, WR, WI, VL, LDVL,
+ $ WORK, -1, INFO )
+ HSWORK = WORK( 1 )
+ MAXWRK = MAX( MAXWRK, N + 1, N + HSWORK )
+ MAXWRK = MAX( MAXWRK, 4*N )
+ ELSE IF( WANTVR ) THEN
+ MINWRK = 4*N
+ MAXWRK = MAX( MAXWRK, 2*N + ( N - 1 )*ILAENV( 1,
+ $ 'DORGHR', ' ', N, 1, N, -1 ) )
+ CALL DHSEQR( 'S', 'V', N, 1, N, A, LDA, WR, WI, VR, LDVR,
+ $ WORK, -1, INFO )
+ HSWORK = WORK( 1 )
+ MAXWRK = MAX( MAXWRK, N + 1, N + HSWORK )
+ MAXWRK = MAX( MAXWRK, 4*N )
+ ELSE
+ MINWRK = 3*N
+ CALL DHSEQR( 'E', 'N', N, 1, N, A, LDA, WR, WI, VR, LDVR,
+ $ WORK, -1, INFO )
+ HSWORK = WORK( 1 )
+ MAXWRK = MAX( MAXWRK, N + 1, N + HSWORK )
+ END IF
+ MAXWRK = MAX( MAXWRK, MINWRK )
+ END IF
+ WORK( 1 ) = MAXWRK
+*
+ IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN
+ INFO = -13
+ END IF
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DGEEV ', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+* Get machine constants
+*
+ EPS = DLAMCH( 'P' )
+ SMLNUM = DLAMCH( 'S' )
+ BIGNUM = ONE / SMLNUM
+ CALL DLABAD( SMLNUM, BIGNUM )
+ SMLNUM = SQRT( SMLNUM ) / EPS
+ BIGNUM = ONE / SMLNUM
+*
+* Scale A if max element outside range [SMLNUM,BIGNUM]
+*
+ ANRM = DLANGE( 'M', N, N, A, LDA, DUM )
+ SCALEA = .FALSE.
+ IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
+ SCALEA = .TRUE.
+ CSCALE = SMLNUM
+ ELSE IF( ANRM.GT.BIGNUM ) THEN
+ SCALEA = .TRUE.
+ CSCALE = BIGNUM
+ END IF
+ IF( SCALEA )
+ $ CALL DLASCL( 'G', 0, 0, ANRM, CSCALE, N, N, A, LDA, IERR )
+*
+* Balance the matrix
+* (Workspace: need N)
+*
+ IBAL = 1
+ CALL DGEBAL( 'B', N, A, LDA, ILO, IHI, WORK( IBAL ), IERR )
+*
+* Reduce to upper Hessenberg form
+* (Workspace: need 3*N, prefer 2*N+N*NB)
+*
+ ITAU = IBAL + N
+ IWRK = ITAU + N
+ CALL DGEHRD( N, ILO, IHI, A, LDA, WORK( ITAU ), WORK( IWRK ),
+ $ LWORK-IWRK+1, IERR )
+*
+ IF( WANTVL ) THEN
+*
+* Want left eigenvectors
+* Copy Householder vectors to VL
+*
+ SIDE = 'L'
+ CALL DLACPY( 'L', N, N, A, LDA, VL, LDVL )
+*
+* Generate orthogonal matrix in VL
+* (Workspace: need 3*N-1, prefer 2*N+(N-1)*NB)
+*
+ CALL DORGHR( N, ILO, IHI, VL, LDVL, WORK( ITAU ), WORK( IWRK ),
+ $ LWORK-IWRK+1, IERR )
+*
+* Perform QR iteration, accumulating Schur vectors in VL
+* (Workspace: need N+1, prefer N+HSWORK (see comments) )
+*
+ IWRK = ITAU
+ CALL DHSEQR( 'S', 'V', N, ILO, IHI, A, LDA, WR, WI, VL, LDVL,
+ $ WORK( IWRK ), LWORK-IWRK+1, INFO )
+*
+ IF( WANTVR ) THEN
+*
+* Want left and right eigenvectors
+* Copy Schur vectors to VR
+*
+ SIDE = 'B'
+ CALL DLACPY( 'F', N, N, VL, LDVL, VR, LDVR )
+ END IF
+*
+ ELSE IF( WANTVR ) THEN
+*
+* Want right eigenvectors
+* Copy Householder vectors to VR
+*
+ SIDE = 'R'
+ CALL DLACPY( 'L', N, N, A, LDA, VR, LDVR )
+*
+* Generate orthogonal matrix in VR
+* (Workspace: need 3*N-1, prefer 2*N+(N-1)*NB)
+*
+ CALL DORGHR( N, ILO, IHI, VR, LDVR, WORK( ITAU ), WORK( IWRK ),
+ $ LWORK-IWRK+1, IERR )
+*
+* Perform QR iteration, accumulating Schur vectors in VR
+* (Workspace: need N+1, prefer N+HSWORK (see comments) )
+*
+ IWRK = ITAU
+ CALL DHSEQR( 'S', 'V', N, ILO, IHI, A, LDA, WR, WI, VR, LDVR,
+ $ WORK( IWRK ), LWORK-IWRK+1, INFO )
+*
+ ELSE
+*
+* Compute eigenvalues only
+* (Workspace: need N+1, prefer N+HSWORK (see comments) )
+*
+ IWRK = ITAU
+ CALL DHSEQR( 'E', 'N', N, ILO, IHI, A, LDA, WR, WI, VR, LDVR,
+ $ WORK( IWRK ), LWORK-IWRK+1, INFO )
+ END IF
+*
+* If INFO > 0 from DHSEQR, then quit
+*
+ IF( INFO.GT.0 )
+ $ GO TO 50
+*
+ IF( WANTVL .OR. WANTVR ) THEN
+*
+* Compute left and/or right eigenvectors
+* (Workspace: need 4*N)
+*
+ CALL DTREVC( SIDE, 'B', SELECT, N, A, LDA, VL, LDVL, VR, LDVR,
+ $ N, NOUT, WORK( IWRK ), IERR )
+ END IF
+*
+ IF( WANTVL ) THEN
+*
+* Undo balancing of left eigenvectors
+* (Workspace: need N)
+*
+ CALL DGEBAK( 'B', 'L', N, ILO, IHI, WORK( IBAL ), N, VL, LDVL,
+ $ IERR )
+*
+* Normalize left eigenvectors and make largest component real
+*
+ DO 20 I = 1, N
+ IF( WI( I ).EQ.ZERO ) THEN
+ SCL = ONE / DNRM2( N, VL( 1, I ), 1 )
+ CALL DSCAL( N, SCL, VL( 1, I ), 1 )
+ ELSE IF( WI( I ).GT.ZERO ) THEN
+ SCL = ONE / DLAPY2( DNRM2( N, VL( 1, I ), 1 ),
+ $ DNRM2( N, VL( 1, I+1 ), 1 ) )
+ CALL DSCAL( N, SCL, VL( 1, I ), 1 )
+ CALL DSCAL( N, SCL, VL( 1, I+1 ), 1 )
+ DO 10 K = 1, N
+ WORK( IWRK+K-1 ) = VL( K, I )**2 + VL( K, I+1 )**2
+ 10 CONTINUE
+ K = IDAMAX( N, WORK( IWRK ), 1 )
+ CALL DLARTG( VL( K, I ), VL( K, I+1 ), CS, SN, R )
+ CALL DROT( N, VL( 1, I ), 1, VL( 1, I+1 ), 1, CS, SN )
+ VL( K, I+1 ) = ZERO
+ END IF
+ 20 CONTINUE
+ END IF
+*
+ IF( WANTVR ) THEN
+*
+* Undo balancing of right eigenvectors
+* (Workspace: need N)
+*
+ CALL DGEBAK( 'B', 'R', N, ILO, IHI, WORK( IBAL ), N, VR, LDVR,
+ $ IERR )
+*
+* Normalize right eigenvectors and make largest component real
+*
+ DO 40 I = 1, N
+ IF( WI( I ).EQ.ZERO ) THEN
+ SCL = ONE / DNRM2( N, VR( 1, I ), 1 )
+ CALL DSCAL( N, SCL, VR( 1, I ), 1 )
+ ELSE IF( WI( I ).GT.ZERO ) THEN
+ SCL = ONE / DLAPY2( DNRM2( N, VR( 1, I ), 1 ),
+ $ DNRM2( N, VR( 1, I+1 ), 1 ) )
+ CALL DSCAL( N, SCL, VR( 1, I ), 1 )
+ CALL DSCAL( N, SCL, VR( 1, I+1 ), 1 )
+ DO 30 K = 1, N
+ WORK( IWRK+K-1 ) = VR( K, I )**2 + VR( K, I+1 )**2
+ 30 CONTINUE
+ K = IDAMAX( N, WORK( IWRK ), 1 )
+ CALL DLARTG( VR( K, I ), VR( K, I+1 ), CS, SN, R )
+ CALL DROT( N, VR( 1, I ), 1, VR( 1, I+1 ), 1, CS, SN )
+ VR( K, I+1 ) = ZERO
+ END IF
+ 40 CONTINUE
+ END IF
+*
+* Undo scaling if necessary
+*
+ 50 CONTINUE
+ IF( SCALEA ) THEN
+ CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, N-INFO, 1, WR( INFO+1 ),
+ $ MAX( N-INFO, 1 ), IERR )
+ CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, N-INFO, 1, WI( INFO+1 ),
+ $ MAX( N-INFO, 1 ), IERR )
+ IF( INFO.GT.0 ) THEN
+ CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, ILO-1, 1, WR, N,
+ $ IERR )
+ CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, ILO-1, 1, WI, N,
+ $ IERR )
+ END IF
+ END IF
+*
+ WORK( 1 ) = MAXWRK
+ RETURN
+*
+* End of DGEEV
+*
+ END
+ 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 )
+*
+* -- LAPACK driver routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER BALANC, JOBVL, JOBVR, SENSE
+ INTEGER IHI, ILO, INFO, LDA, LDVL, LDVR, LWORK, N
+ DOUBLE PRECISION ABNRM
+* ..
+* .. Array Arguments ..
+ INTEGER IWORK( * )
+ DOUBLE PRECISION A( LDA, * ), RCONDE( * ), RCONDV( * ),
+ $ SCALE( * ), VL( LDVL, * ), VR( LDVR, * ),
+ $ WI( * ), WORK( * ), WR( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DGEEVX computes for an N-by-N real nonsymmetric matrix A, the
+* eigenvalues and, optionally, the left and/or right eigenvectors.
+*
+* Optionally also, it computes a balancing transformation to improve
+* the conditioning of the eigenvalues and eigenvectors (ILO, IHI,
+* SCALE, and ABNRM), reciprocal condition numbers for the eigenvalues
+* (RCONDE), and reciprocal condition numbers for the right
+* eigenvectors (RCONDV).
+*
+* The right eigenvector v(j) of A satisfies
+* A * v(j) = lambda(j) * v(j)
+* where lambda(j) is its eigenvalue.
+* The left eigenvector u(j) of A satisfies
+* u(j)**H * A = lambda(j) * u(j)**H
+* where u(j)**H denotes the conjugate transpose of u(j).
+*
+* The computed eigenvectors are normalized to have Euclidean norm
+* equal to 1 and largest component real.
+*
+* Balancing a matrix means permuting the rows and columns to make it
+* more nearly upper triangular, and applying a diagonal similarity
+* transformation D * A * D**(-1), where D is a diagonal matrix, to
+* make its rows and columns closer in norm and the condition numbers
+* of its eigenvalues and eigenvectors smaller. The computed
+* reciprocal condition numbers correspond to the balanced matrix.
+* Permuting rows and columns will not change the condition numbers
+* (in exact arithmetic) but diagonal scaling will. For further
+* explanation of balancing, see section 4.10.2 of the LAPACK
+* Users' Guide.
+*
+* Arguments
+* =========
+*
+* BALANC (input) CHARACTER*1
+* Indicates how the input matrix should be diagonally scaled
+* and/or permuted to improve the conditioning of its
+* eigenvalues.
+* = 'N': Do not diagonally scale or permute;
+* = 'P': Perform permutations to make the matrix more nearly
+* upper triangular. Do not diagonally scale;
+* = 'S': Diagonally scale the matrix, i.e. replace A by
+* D*A*D**(-1), where D is a diagonal matrix chosen
+* to make the rows and columns of A more equal in
+* norm. Do not permute;
+* = 'B': Both diagonally scale and permute A.
+*
+* Computed reciprocal condition numbers will be for the matrix
+* after balancing and/or permuting. Permuting does not change
+* condition numbers (in exact arithmetic), but balancing does.
+*
+* JOBVL (input) CHARACTER*1
+* = 'N': left eigenvectors of A are not computed;
+* = 'V': left eigenvectors of A are computed.
+* If SENSE = 'E' or 'B', JOBVL must = 'V'.
+*
+* JOBVR (input) CHARACTER*1
+* = 'N': right eigenvectors of A are not computed;
+* = 'V': right eigenvectors of A are computed.
+* If SENSE = 'E' or 'B', JOBVR must = 'V'.
+*
+* SENSE (input) CHARACTER*1
+* Determines which reciprocal condition numbers are computed.
+* = 'N': None are computed;
+* = 'E': Computed for eigenvalues only;
+* = 'V': Computed for right eigenvectors only;
+* = 'B': Computed for eigenvalues and right eigenvectors.
+*
+* If SENSE = 'E' or 'B', both left and right eigenvectors
+* must also be computed (JOBVL = 'V' and JOBVR = 'V').
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+* On entry, the N-by-N matrix A.
+* On exit, A has been overwritten. If JOBVL = 'V' or
+* JOBVR = 'V', A contains the real Schur form of the balanced
+* version of the input matrix A.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,N).
+*
+* WR (output) DOUBLE PRECISION array, dimension (N)
+* WI (output) DOUBLE PRECISION array, dimension (N)
+* WR and WI contain the real and imaginary parts,
+* respectively, of the computed eigenvalues. Complex
+* conjugate pairs of eigenvalues will appear consecutively
+* with the eigenvalue having the positive imaginary part
+* first.
+*
+* VL (output) DOUBLE PRECISION array, dimension (LDVL,N)
+* If JOBVL = 'V', the left eigenvectors u(j) are stored one
+* after another in the columns of VL, in the same order
+* as their eigenvalues.
+* If JOBVL = 'N', VL is not referenced.
+* If the j-th eigenvalue is real, then u(j) = VL(:,j),
+* the j-th column of VL.
+* If the j-th and (j+1)-st eigenvalues form a complex
+* conjugate pair, then u(j) = VL(:,j) + i*VL(:,j+1) and
+* u(j+1) = VL(:,j) - i*VL(:,j+1).
+*
+* LDVL (input) INTEGER
+* The leading dimension of the array VL. LDVL >= 1; if
+* JOBVL = 'V', LDVL >= N.
+*
+* VR (output) DOUBLE PRECISION array, dimension (LDVR,N)
+* If JOBVR = 'V', the right eigenvectors v(j) are stored one
+* after another in the columns of VR, in the same order
+* as their eigenvalues.
+* If JOBVR = 'N', VR is not referenced.
+* If the j-th eigenvalue is real, then v(j) = VR(:,j),
+* the j-th column of VR.
+* If the j-th and (j+1)-st eigenvalues form a complex
+* conjugate pair, then v(j) = VR(:,j) + i*VR(:,j+1) and
+* v(j+1) = VR(:,j) - i*VR(:,j+1).
+*
+* LDVR (input) INTEGER
+* The leading dimension of the array VR. LDVR >= 1, and if
+* JOBVR = 'V', LDVR >= N.
+*
+* ILO (output) INTEGER
+* IHI (output) INTEGER
+* ILO and IHI are integer values determined when A was
+* balanced. The balanced A(i,j) = 0 if I > J and
+* J = 1,...,ILO-1 or I = IHI+1,...,N.
+*
+* SCALE (output) DOUBLE PRECISION array, dimension (N)
+* Details of the permutations and scaling factors applied
+* when balancing A. If P(j) is the index of the row and column
+* interchanged with row and column j, and D(j) is the scaling
+* factor applied to row and column j, then
+* SCALE(J) = P(J), for J = 1,...,ILO-1
+* = D(J), for J = ILO,...,IHI
+* = P(J) for J = IHI+1,...,N.
+* The order in which the interchanges are made is N to IHI+1,
+* then 1 to ILO-1.
+*
+* ABNRM (output) DOUBLE PRECISION
+* The one-norm of the balanced matrix (the maximum
+* of the sum of absolute values of elements of any column).
+*
+* RCONDE (output) DOUBLE PRECISION array, dimension (N)
+* RCONDE(j) is the reciprocal condition number of the j-th
+* eigenvalue.
+*
+* RCONDV (output) DOUBLE PRECISION array, dimension (N)
+* RCONDV(j) is the reciprocal condition number of the j-th
+* right eigenvector.
+*
+* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
+* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+* LWORK (input) INTEGER
+* The dimension of the array WORK. If SENSE = 'N' or 'E',
+* LWORK >= max(1,2*N), and if JOBVL = 'V' or JOBVR = 'V',
+* LWORK >= 3*N. If SENSE = 'V' or 'B', LWORK >= N*(N+6).
+* For good performance, LWORK must generally be larger.
+*
+* If LWORK = -1, then a workspace query is assumed; the routine
+* only calculates the optimal size of the WORK array, returns
+* this value as the first entry of the WORK array, and no error
+* message related to LWORK is issued by XERBLA.
+*
+* IWORK (workspace) INTEGER array, dimension (2*N-2)
+* If SENSE = 'N' or 'E', not referenced.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value.
+* > 0: if INFO = i, the QR algorithm failed to compute all the
+* eigenvalues, and no eigenvectors or condition numbers
+* have been computed; elements 1:ILO-1 and i+1:N of WR
+* and WI contain eigenvalues which have converged.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL LQUERY, SCALEA, WANTVL, WANTVR, WNTSNB, WNTSNE,
+ $ WNTSNN, WNTSNV
+ CHARACTER JOB, SIDE
+ INTEGER HSWORK, I, ICOND, IERR, ITAU, IWRK, K, MAXWRK,
+ $ MINWRK, NOUT
+ DOUBLE PRECISION ANRM, BIGNUM, CS, CSCALE, EPS, R, SCL, SMLNUM,
+ $ SN
+* ..
+* .. Local Arrays ..
+ LOGICAL SELECT( 1 )
+ DOUBLE PRECISION DUM( 1 )
+* ..
+* .. External Subroutines ..
+ EXTERNAL DGEBAK, DGEBAL, DGEHRD, DHSEQR, DLABAD, DLACPY,
+ $ DLARTG, DLASCL, DORGHR, DROT, DSCAL, DTREVC,
+ $ DTRSNA, XERBLA
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER IDAMAX, ILAENV
+ DOUBLE PRECISION DLAMCH, DLANGE, DLAPY2, DNRM2
+ EXTERNAL LSAME, IDAMAX, ILAENV, DLAMCH, DLANGE, DLAPY2,
+ $ DNRM2
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, SQRT
+* ..
+* .. Executable Statements ..
+*
+* Test the input arguments
+*
+ INFO = 0
+ LQUERY = ( LWORK.EQ.-1 )
+ WANTVL = LSAME( JOBVL, 'V' )
+ WANTVR = LSAME( JOBVR, 'V' )
+ WNTSNN = LSAME( SENSE, 'N' )
+ WNTSNE = LSAME( SENSE, 'E' )
+ WNTSNV = LSAME( SENSE, 'V' )
+ WNTSNB = LSAME( SENSE, 'B' )
+ IF( .NOT.( LSAME( BALANC, 'N' ) .OR. LSAME( BALANC,
+ $ 'S' ) .OR. LSAME( BALANC, 'P' ) .OR. LSAME( BALANC, 'B' ) ) )
+ $ THEN
+ INFO = -1
+ ELSE IF( ( .NOT.WANTVL ) .AND. ( .NOT.LSAME( JOBVL, 'N' ) ) ) THEN
+ INFO = -2
+ ELSE IF( ( .NOT.WANTVR ) .AND. ( .NOT.LSAME( JOBVR, 'N' ) ) ) THEN
+ INFO = -3
+ ELSE IF( .NOT.( WNTSNN .OR. WNTSNE .OR. WNTSNB .OR. WNTSNV ) .OR.
+ $ ( ( WNTSNE .OR. WNTSNB ) .AND. .NOT.( WANTVL .AND.
+ $ WANTVR ) ) ) THEN
+ INFO = -4
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -5
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -7
+ ELSE IF( LDVL.LT.1 .OR. ( WANTVL .AND. LDVL.LT.N ) ) THEN
+ INFO = -11
+ ELSE IF( LDVR.LT.1 .OR. ( WANTVR .AND. LDVR.LT.N ) ) THEN
+ INFO = -13
+ END IF
+*
+* Compute workspace
+* (Note: Comments in the code beginning "Workspace:" describe the
+* minimal amount of workspace needed at that point in the code,
+* as well as the preferred amount for good performance.
+* NB refers to the optimal block size for the immediately
+* following subroutine, as returned by ILAENV.
+* HSWORK refers to the workspace preferred by DHSEQR, as
+* calculated below. HSWORK is computed assuming ILO=1 and IHI=N,
+* the worst case.)
+*
+ IF( INFO.EQ.0 ) THEN
+ IF( N.EQ.0 ) THEN
+ MINWRK = 1
+ MAXWRK = 1
+ ELSE
+ MAXWRK = N + N*ILAENV( 1, 'DGEHRD', ' ', N, 1, N, 0 )
+*
+ IF( WANTVL ) THEN
+ CALL DHSEQR( 'S', 'V', N, 1, N, A, LDA, WR, WI, VL, LDVL,
+ $ WORK, -1, INFO )
+ ELSE IF( WANTVR ) THEN
+ CALL DHSEQR( 'S', 'V', N, 1, N, A, LDA, WR, WI, VR, LDVR,
+ $ WORK, -1, INFO )
+ ELSE
+ IF( WNTSNN ) THEN
+ CALL DHSEQR( 'E', 'N', N, 1, N, A, LDA, WR, WI, VR,
+ $ LDVR, WORK, -1, INFO )
+ ELSE
+ CALL DHSEQR( 'S', 'N', N, 1, N, A, LDA, WR, WI, VR,
+ $ LDVR, WORK, -1, INFO )
+ END IF
+ END IF
+ HSWORK = WORK( 1 )
+*
+ IF( ( .NOT.WANTVL ) .AND. ( .NOT.WANTVR ) ) THEN
+ MINWRK = 2*N
+ IF( .NOT.WNTSNN )
+ $ MINWRK = MAX( MINWRK, N*N+6*N )
+ MAXWRK = MAX( MAXWRK, HSWORK )
+ IF( .NOT.WNTSNN )
+ $ MAXWRK = MAX( MAXWRK, N*N + 6*N )
+ ELSE
+ MINWRK = 3*N
+ IF( ( .NOT.WNTSNN ) .AND. ( .NOT.WNTSNE ) )
+ $ MINWRK = MAX( MINWRK, N*N + 6*N )
+ MAXWRK = MAX( MAXWRK, HSWORK )
+ MAXWRK = MAX( MAXWRK, N + ( N - 1 )*ILAENV( 1, 'DORGHR',
+ $ ' ', N, 1, N, -1 ) )
+ IF( ( .NOT.WNTSNN ) .AND. ( .NOT.WNTSNE ) )
+ $ MAXWRK = MAX( MAXWRK, N*N + 6*N )
+ MAXWRK = MAX( MAXWRK, 3*N )
+ END IF
+ MAXWRK = MAX( MAXWRK, MINWRK )
+ END IF
+ WORK( 1 ) = MAXWRK
+*
+ IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN
+ INFO = -21
+ END IF
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DGEEVX', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+* Get machine constants
+*
+ EPS = DLAMCH( 'P' )
+ SMLNUM = DLAMCH( 'S' )
+ BIGNUM = ONE / SMLNUM
+ CALL DLABAD( SMLNUM, BIGNUM )
+ SMLNUM = SQRT( SMLNUM ) / EPS
+ BIGNUM = ONE / SMLNUM
+*
+* Scale A if max element outside range [SMLNUM,BIGNUM]
+*
+ ICOND = 0
+ ANRM = DLANGE( 'M', N, N, A, LDA, DUM )
+ SCALEA = .FALSE.
+ IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
+ SCALEA = .TRUE.
+ CSCALE = SMLNUM
+ ELSE IF( ANRM.GT.BIGNUM ) THEN
+ SCALEA = .TRUE.
+ CSCALE = BIGNUM
+ END IF
+ IF( SCALEA )
+ $ CALL DLASCL( 'G', 0, 0, ANRM, CSCALE, N, N, A, LDA, IERR )
+*
+* Balance the matrix and compute ABNRM
+*
+ CALL DGEBAL( BALANC, N, A, LDA, ILO, IHI, SCALE, IERR )
+ ABNRM = DLANGE( '1', N, N, A, LDA, DUM )
+ IF( SCALEA ) THEN
+ DUM( 1 ) = ABNRM
+ CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, 1, 1, DUM, 1, IERR )
+ ABNRM = DUM( 1 )
+ END IF
+*
+* Reduce to upper Hessenberg form
+* (Workspace: need 2*N, prefer N+N*NB)
+*
+ ITAU = 1
+ IWRK = ITAU + N
+ CALL DGEHRD( N, ILO, IHI, A, LDA, WORK( ITAU ), WORK( IWRK ),
+ $ LWORK-IWRK+1, IERR )
+*
+ IF( WANTVL ) THEN
+*
+* Want left eigenvectors
+* Copy Householder vectors to VL
+*
+ SIDE = 'L'
+ CALL DLACPY( 'L', N, N, A, LDA, VL, LDVL )
+*
+* Generate orthogonal matrix in VL
+* (Workspace: need 2*N-1, prefer N+(N-1)*NB)
+*
+ CALL DORGHR( N, ILO, IHI, VL, LDVL, WORK( ITAU ), WORK( IWRK ),
+ $ LWORK-IWRK+1, IERR )
+*
+* Perform QR iteration, accumulating Schur vectors in VL
+* (Workspace: need 1, prefer HSWORK (see comments) )
+*
+ IWRK = ITAU
+ CALL DHSEQR( 'S', 'V', N, ILO, IHI, A, LDA, WR, WI, VL, LDVL,
+ $ WORK( IWRK ), LWORK-IWRK+1, INFO )
+*
+ IF( WANTVR ) THEN
+*
+* Want left and right eigenvectors
+* Copy Schur vectors to VR
+*
+ SIDE = 'B'
+ CALL DLACPY( 'F', N, N, VL, LDVL, VR, LDVR )
+ END IF
+*
+ ELSE IF( WANTVR ) THEN
+*
+* Want right eigenvectors
+* Copy Householder vectors to VR
+*
+ SIDE = 'R'
+ CALL DLACPY( 'L', N, N, A, LDA, VR, LDVR )
+*
+* Generate orthogonal matrix in VR
+* (Workspace: need 2*N-1, prefer N+(N-1)*NB)
+*
+ CALL DORGHR( N, ILO, IHI, VR, LDVR, WORK( ITAU ), WORK( IWRK ),
+ $ LWORK-IWRK+1, IERR )
+*
+* Perform QR iteration, accumulating Schur vectors in VR
+* (Workspace: need 1, prefer HSWORK (see comments) )
+*
+ IWRK = ITAU
+ CALL DHSEQR( 'S', 'V', N, ILO, IHI, A, LDA, WR, WI, VR, LDVR,
+ $ WORK( IWRK ), LWORK-IWRK+1, INFO )
+*
+ ELSE
+*
+* Compute eigenvalues only
+* If condition numbers desired, compute Schur form
+*
+ IF( WNTSNN ) THEN
+ JOB = 'E'
+ ELSE
+ JOB = 'S'
+ END IF
+*
+* (Workspace: need 1, prefer HSWORK (see comments) )
+*
+ IWRK = ITAU
+ CALL DHSEQR( JOB, 'N', N, ILO, IHI, A, LDA, WR, WI, VR, LDVR,
+ $ WORK( IWRK ), LWORK-IWRK+1, INFO )
+ END IF
+*
+* If INFO > 0 from DHSEQR, then quit
+*
+ IF( INFO.GT.0 )
+ $ GO TO 50
+*
+ IF( WANTVL .OR. WANTVR ) THEN
+*
+* Compute left and/or right eigenvectors
+* (Workspace: need 3*N)
+*
+ CALL DTREVC( SIDE, 'B', SELECT, N, A, LDA, VL, LDVL, VR, LDVR,
+ $ N, NOUT, WORK( IWRK ), IERR )
+ END IF
+*
+* Compute condition numbers if desired
+* (Workspace: need N*N+6*N unless SENSE = 'E')
+*
+ IF( .NOT.WNTSNN ) THEN
+ CALL DTRSNA( SENSE, 'A', SELECT, N, A, LDA, VL, LDVL, VR, LDVR,
+ $ RCONDE, RCONDV, N, NOUT, WORK( IWRK ), N, IWORK,
+ $ ICOND )
+ END IF
+*
+ IF( WANTVL ) THEN
+*
+* Undo balancing of left eigenvectors
+*
+ CALL DGEBAK( BALANC, 'L', N, ILO, IHI, SCALE, N, VL, LDVL,
+ $ IERR )
+*
+* Normalize left eigenvectors and make largest component real
+*
+ DO 20 I = 1, N
+ IF( WI( I ).EQ.ZERO ) THEN
+ SCL = ONE / DNRM2( N, VL( 1, I ), 1 )
+ CALL DSCAL( N, SCL, VL( 1, I ), 1 )
+ ELSE IF( WI( I ).GT.ZERO ) THEN
+ SCL = ONE / DLAPY2( DNRM2( N, VL( 1, I ), 1 ),
+ $ DNRM2( N, VL( 1, I+1 ), 1 ) )
+ CALL DSCAL( N, SCL, VL( 1, I ), 1 )
+ CALL DSCAL( N, SCL, VL( 1, I+1 ), 1 )
+ DO 10 K = 1, N
+ WORK( K ) = VL( K, I )**2 + VL( K, I+1 )**2
+ 10 CONTINUE
+ K = IDAMAX( N, WORK, 1 )
+ CALL DLARTG( VL( K, I ), VL( K, I+1 ), CS, SN, R )
+ CALL DROT( N, VL( 1, I ), 1, VL( 1, I+1 ), 1, CS, SN )
+ VL( K, I+1 ) = ZERO
+ END IF
+ 20 CONTINUE
+ END IF
+*
+ IF( WANTVR ) THEN
+*
+* Undo balancing of right eigenvectors
+*
+ CALL DGEBAK( BALANC, 'R', N, ILO, IHI, SCALE, N, VR, LDVR,
+ $ IERR )
+*
+* Normalize right eigenvectors and make largest component real
+*
+ DO 40 I = 1, N
+ IF( WI( I ).EQ.ZERO ) THEN
+ SCL = ONE / DNRM2( N, VR( 1, I ), 1 )
+ CALL DSCAL( N, SCL, VR( 1, I ), 1 )
+ ELSE IF( WI( I ).GT.ZERO ) THEN
+ SCL = ONE / DLAPY2( DNRM2( N, VR( 1, I ), 1 ),
+ $ DNRM2( N, VR( 1, I+1 ), 1 ) )
+ CALL DSCAL( N, SCL, VR( 1, I ), 1 )
+ CALL DSCAL( N, SCL, VR( 1, I+1 ), 1 )
+ DO 30 K = 1, N
+ WORK( K ) = VR( K, I )**2 + VR( K, I+1 )**2
+ 30 CONTINUE
+ K = IDAMAX( N, WORK, 1 )
+ CALL DLARTG( VR( K, I ), VR( K, I+1 ), CS, SN, R )
+ CALL DROT( N, VR( 1, I ), 1, VR( 1, I+1 ), 1, CS, SN )
+ VR( K, I+1 ) = ZERO
+ END IF
+ 40 CONTINUE
+ END IF
+*
+* Undo scaling if necessary
+*
+ 50 CONTINUE
+ IF( SCALEA ) THEN
+ CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, N-INFO, 1, WR( INFO+1 ),
+ $ MAX( N-INFO, 1 ), IERR )
+ CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, N-INFO, 1, WI( INFO+1 ),
+ $ MAX( N-INFO, 1 ), IERR )
+ IF( INFO.EQ.0 ) THEN
+ IF( ( WNTSNV .OR. WNTSNB ) .AND. ICOND.EQ.0 )
+ $ CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, N, 1, RCONDV, N,
+ $ IERR )
+ ELSE
+ CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, ILO-1, 1, WR, N,
+ $ IERR )
+ CALL DLASCL( 'G', 0, 0, CSCALE, ANRM, ILO-1, 1, WI, N,
+ $ IERR )
+ END IF
+ END IF
+*
+ WORK( 1 ) = MAXWRK
+ RETURN
+*
+* End of DGEEVX
+*
+ END
+ SUBROUTINE DGEGS( JOBVSL, JOBVSR, N, A, LDA, B, LDB, ALPHAR,
+ $ ALPHAI, BETA, VSL, LDVSL, VSR, LDVSR, WORK,
+ $ LWORK, INFO )
+*
+* -- LAPACK driver routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER JOBVSL, JOBVSR
+ INTEGER INFO, LDA, LDB, LDVSL, LDVSR, LWORK, N
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION A( LDA, * ), ALPHAI( * ), ALPHAR( * ),
+ $ B( LDB, * ), BETA( * ), VSL( LDVSL, * ),
+ $ VSR( LDVSR, * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* This routine is deprecated and has been replaced by routine DGGES.
+*
+* DGEGS computes the eigenvalues, real Schur form, and, optionally,
+* left and or/right Schur vectors of a real matrix pair (A,B).
+* Given two square matrices A and B, the generalized real Schur
+* factorization has the form
+*
+* A = Q*S*Z**T, B = Q*T*Z**T
+*
+* where Q and Z are orthogonal matrices, T is upper triangular, and S
+* is an upper quasi-triangular matrix with 1-by-1 and 2-by-2 diagonal
+* blocks, the 2-by-2 blocks corresponding to complex conjugate pairs
+* of eigenvalues of (A,B). The columns of Q are the left Schur vectors
+* and the columns of Z are the right Schur vectors.
+*
+* If only the eigenvalues of (A,B) are needed, the driver routine
+* DGEGV should be used instead. See DGEGV for a description of the
+* eigenvalues of the generalized nonsymmetric eigenvalue problem
+* (GNEP).
+*
+* Arguments
+* =========
+*
+* JOBVSL (input) CHARACTER*1
+* = 'N': do not compute the left Schur vectors;
+* = 'V': compute the left Schur vectors (returned in VSL).
+*
+* JOBVSR (input) CHARACTER*1
+* = 'N': do not compute the right Schur vectors;
+* = 'V': compute the right Schur vectors (returned in VSR).
+*
+* N (input) INTEGER
+* The order of the matrices A, B, VSL, and VSR. N >= 0.
+*
+* A (input/output) DOUBLE PRECISION array, dimension (LDA, N)
+* On entry, the matrix A.
+* On exit, the upper quasi-triangular matrix S from the
+* generalized real Schur factorization.
+*
+* LDA (input) INTEGER
+* The leading dimension of A. LDA >= max(1,N).
+*
+* B (input/output) DOUBLE PRECISION array, dimension (LDB, N)
+* On entry, the matrix B.
+* On exit, the upper triangular matrix T from the generalized
+* real Schur factorization.
+*
+* LDB (input) INTEGER
+* The leading dimension of B. LDB >= max(1,N).
+*
+* ALPHAR (output) DOUBLE PRECISION array, dimension (N)
+* The real parts of each scalar alpha defining an eigenvalue
+* of GNEP.
+*
+* ALPHAI (output) DOUBLE PRECISION array, dimension (N)
+* The imaginary parts of each scalar alpha defining an
+* eigenvalue of GNEP. If ALPHAI(j) is zero, then the j-th
+* eigenvalue is real; if positive, then the j-th and (j+1)-st
+* eigenvalues are a complex conjugate pair, with
+* ALPHAI(j+1) = -ALPHAI(j).
+*
+* BETA (output) DOUBLE PRECISION array, dimension (N)
+* The scalars beta that define the eigenvalues of GNEP.
+* Together, the quantities alpha = (ALPHAR(j),ALPHAI(j)) and
+* beta = BETA(j) represent the j-th eigenvalue of the matrix
+* pair (A,B), in one of the forms lambda = alpha/beta or
+* mu = beta/alpha. Since either lambda or mu may overflow,
+* they should not, in general, be computed.
+*
+* VSL (output) DOUBLE PRECISION array, dimension (LDVSL,N)
+* If JOBVSL = 'V', the matrix of left Schur vectors Q.
+* Not referenced if JOBVSL = 'N'.
+*
+* LDVSL (input) INTEGER
+* The leading dimension of the matrix VSL. LDVSL >=1, and
+* if JOBVSL = 'V', LDVSL >= N.
+*
+* VSR (output) DOUBLE PRECISION array, dimension (LDVSR,N)
+* If JOBVSR = 'V', the matrix of right Schur vectors Z.
+* Not referenced if JOBVSR = 'N'.
+*
+* LDVSR (input) INTEGER
+* The leading dimension of the matrix VSR. LDVSR >= 1, and
+* if JOBVSR = 'V', LDVSR >= N.
+*
+* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
+* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+* LWORK (input) INTEGER
+* The dimension of the array WORK. LWORK >= max(1,4*N).
+* For good performance, LWORK must generally be larger.
+* To compute the optimal value of LWORK, call ILAENV to get
+* blocksizes (for DGEQRF, DORMQR, and DORGQR.) Then compute:
+* NB -- MAX of the blocksizes for DGEQRF, DORMQR, and DORGQR
+* The optimal LWORK is 2*N + N*(NB+1).
+*
+* If LWORK = -1, then a workspace query is assumed; the routine
+* only calculates the optimal size of the WORK array, returns
+* this value as the first entry of the WORK array, and no error
+* message related to LWORK is issued by XERBLA.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value.
+* = 1,...,N:
+* The QZ iteration failed. (A,B) are not in Schur
+* form, but ALPHAR(j), ALPHAI(j), and BETA(j) should
+* be correct for j=INFO+1,...,N.
+* > N: errors that usually indicate LAPACK problems:
+* =N+1: error return from DGGBAL
+* =N+2: error return from DGEQRF
+* =N+3: error return from DORMQR
+* =N+4: error return from DORGQR
+* =N+5: error return from DGGHRD
+* =N+6: error return from DHGEQZ (other than failed
+* iteration)
+* =N+7: error return from DGGBAK (computing VSL)
+* =N+8: error return from DGGBAK (computing VSR)
+* =N+9: error return from DLASCL (various places)
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL ILASCL, ILBSCL, ILVSL, ILVSR, LQUERY
+ INTEGER ICOLS, IHI, IINFO, IJOBVL, IJOBVR, ILEFT, ILO,
+ $ IRIGHT, IROWS, ITAU, IWORK, LOPT, LWKMIN,
+ $ LWKOPT, NB, NB1, NB2, NB3
+ DOUBLE PRECISION ANRM, ANRMTO, BIGNUM, BNRM, BNRMTO, EPS,
+ $ SAFMIN, SMLNUM
+* ..
+* .. External Subroutines ..
+ EXTERNAL DGEQRF, DGGBAK, DGGBAL, DGGHRD, DHGEQZ, DLACPY,
+ $ DLASCL, DLASET, DORGQR, DORMQR, XERBLA
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ILAENV
+ DOUBLE PRECISION DLAMCH, DLANGE
+ EXTERNAL LSAME, ILAENV, DLAMCH, DLANGE
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC INT, MAX
+* ..
+* .. Executable Statements ..
+*
+* Decode the input arguments
+*
+ IF( LSAME( JOBVSL, 'N' ) ) THEN
+ IJOBVL = 1
+ ILVSL = .FALSE.
+ ELSE IF( LSAME( JOBVSL, 'V' ) ) THEN
+ IJOBVL = 2
+ ILVSL = .TRUE.
+ ELSE
+ IJOBVL = -1
+ ILVSL = .FALSE.
+ END IF
+*
+ IF( LSAME( JOBVSR, 'N' ) ) THEN
+ IJOBVR = 1
+ ILVSR = .FALSE.
+ ELSE IF( LSAME( JOBVSR, 'V' ) ) THEN
+ IJOBVR = 2
+ ILVSR = .TRUE.
+ ELSE
+ IJOBVR = -1
+ ILVSR = .FALSE.
+ END IF
+*
+* Test the input arguments
+*
+ LWKMIN = MAX( 4*N, 1 )
+ LWKOPT = LWKMIN
+ WORK( 1 ) = LWKOPT
+ LQUERY = ( LWORK.EQ.-1 )
+ INFO = 0
+ IF( IJOBVL.LE.0 ) THEN
+ INFO = -1
+ ELSE IF( IJOBVR.LE.0 ) THEN
+ INFO = -2
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -5
+ ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -7
+ ELSE IF( LDVSL.LT.1 .OR. ( ILVSL .AND. LDVSL.LT.N ) ) THEN
+ INFO = -12
+ ELSE IF( LDVSR.LT.1 .OR. ( ILVSR .AND. LDVSR.LT.N ) ) THEN
+ INFO = -14
+ ELSE IF( LWORK.LT.LWKMIN .AND. .NOT.LQUERY ) THEN
+ INFO = -16
+ END IF
+*
+ IF( INFO.EQ.0 ) THEN
+ NB1 = ILAENV( 1, 'DGEQRF', ' ', N, N, -1, -1 )
+ NB2 = ILAENV( 1, 'DORMQR', ' ', N, N, N, -1 )
+ NB3 = ILAENV( 1, 'DORGQR', ' ', N, N, N, -1 )
+ NB = MAX( NB1, NB2, NB3 )
+ LOPT = 2*N + N*( NB+1 )
+ WORK( 1 ) = LOPT
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DGEGS ', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+* Get machine constants
+*
+ EPS = DLAMCH( 'E' )*DLAMCH( 'B' )
+ SAFMIN = DLAMCH( 'S' )
+ SMLNUM = N*SAFMIN / EPS
+ BIGNUM = ONE / SMLNUM
+*
+* Scale A if max element outside range [SMLNUM,BIGNUM]
+*
+ ANRM = DLANGE( 'M', N, N, A, LDA, WORK )
+ ILASCL = .FALSE.
+ IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
+ ANRMTO = SMLNUM
+ ILASCL = .TRUE.
+ ELSE IF( ANRM.GT.BIGNUM ) THEN
+ ANRMTO = BIGNUM
+ ILASCL = .TRUE.
+ END IF
+*
+ IF( ILASCL ) THEN
+ CALL DLASCL( 'G', -1, -1, ANRM, ANRMTO, N, N, A, LDA, IINFO )
+ IF( IINFO.NE.0 ) THEN
+ INFO = N + 9
+ RETURN
+ END IF
+ END IF
+*
+* Scale B if max element outside range [SMLNUM,BIGNUM]
+*
+ BNRM = DLANGE( 'M', N, N, B, LDB, WORK )
+ ILBSCL = .FALSE.
+ IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN
+ BNRMTO = SMLNUM
+ ILBSCL = .TRUE.
+ ELSE IF( BNRM.GT.BIGNUM ) THEN
+ BNRMTO = BIGNUM
+ ILBSCL = .TRUE.
+ END IF
+*
+ IF( ILBSCL ) THEN
+ CALL DLASCL( 'G', -1, -1, BNRM, BNRMTO, N, N, B, LDB, IINFO )
+ IF( IINFO.NE.0 ) THEN
+ INFO = N + 9
+ RETURN
+ END IF
+ END IF
+*
+* Permute the matrix to make it more nearly triangular
+* Workspace layout: (2*N words -- "work..." not actually used)
+* left_permutation, right_permutation, work...
+*
+ ILEFT = 1
+ IRIGHT = N + 1
+ IWORK = IRIGHT + N
+ CALL DGGBAL( 'P', N, A, LDA, B, LDB, ILO, IHI, WORK( ILEFT ),
+ $ WORK( IRIGHT ), WORK( IWORK ), IINFO )
+ IF( IINFO.NE.0 ) THEN
+ INFO = N + 1
+ GO TO 10
+ END IF
+*
+* Reduce B to triangular form, and initialize VSL and/or VSR
+* Workspace layout: ("work..." must have at least N words)
+* left_permutation, right_permutation, tau, work...
+*
+ IROWS = IHI + 1 - ILO
+ ICOLS = N + 1 - ILO
+ ITAU = IWORK
+ IWORK = ITAU + IROWS
+ CALL DGEQRF( IROWS, ICOLS, B( ILO, ILO ), LDB, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK+1-IWORK, IINFO )
+ IF( IINFO.GE.0 )
+ $ LWKOPT = MAX( LWKOPT, INT( WORK( IWORK ) )+IWORK-1 )
+ IF( IINFO.NE.0 ) THEN
+ INFO = N + 2
+ GO TO 10
+ END IF
+*
+ CALL DORMQR( 'L', 'T', IROWS, ICOLS, IROWS, B( ILO, ILO ), LDB,
+ $ WORK( ITAU ), A( ILO, ILO ), LDA, WORK( IWORK ),
+ $ LWORK+1-IWORK, IINFO )
+ IF( IINFO.GE.0 )
+ $ LWKOPT = MAX( LWKOPT, INT( WORK( IWORK ) )+IWORK-1 )
+ IF( IINFO.NE.0 ) THEN
+ INFO = N + 3
+ GO TO 10
+ END IF
+*
+ IF( ILVSL ) THEN
+ CALL DLASET( 'Full', N, N, ZERO, ONE, VSL, LDVSL )
+ CALL DLACPY( 'L', IROWS-1, IROWS-1, B( ILO+1, ILO ), LDB,
+ $ VSL( ILO+1, ILO ), LDVSL )
+ CALL DORGQR( IROWS, IROWS, IROWS, VSL( ILO, ILO ), LDVSL,
+ $ WORK( ITAU ), WORK( IWORK ), LWORK+1-IWORK,
+ $ IINFO )
+ IF( IINFO.GE.0 )
+ $ LWKOPT = MAX( LWKOPT, INT( WORK( IWORK ) )+IWORK-1 )
+ IF( IINFO.NE.0 ) THEN
+ INFO = N + 4
+ GO TO 10
+ END IF
+ END IF
+*
+ IF( ILVSR )
+ $ CALL DLASET( 'Full', N, N, ZERO, ONE, VSR, LDVSR )
+*
+* Reduce to generalized Hessenberg form
+*
+ CALL DGGHRD( JOBVSL, JOBVSR, N, ILO, IHI, A, LDA, B, LDB, VSL,
+ $ LDVSL, VSR, LDVSR, IINFO )
+ IF( IINFO.NE.0 ) THEN
+ INFO = N + 5
+ GO TO 10
+ END IF
+*
+* Perform QZ algorithm, computing Schur vectors if desired
+* Workspace layout: ("work..." must have at least 1 word)
+* left_permutation, right_permutation, work...
+*
+ IWORK = ITAU
+ CALL DHGEQZ( 'S', JOBVSL, JOBVSR, N, ILO, IHI, A, LDA, B, LDB,
+ $ ALPHAR, ALPHAI, BETA, VSL, LDVSL, VSR, LDVSR,
+ $ WORK( IWORK ), LWORK+1-IWORK, IINFO )
+ IF( IINFO.GE.0 )
+ $ LWKOPT = MAX( LWKOPT, INT( WORK( IWORK ) )+IWORK-1 )
+ IF( IINFO.NE.0 ) THEN
+ IF( IINFO.GT.0 .AND. IINFO.LE.N ) THEN
+ INFO = IINFO
+ ELSE IF( IINFO.GT.N .AND. IINFO.LE.2*N ) THEN
+ INFO = IINFO - N
+ ELSE
+ INFO = N + 6
+ END IF
+ GO TO 10
+ END IF
+*
+* Apply permutation to VSL and VSR
+*
+ IF( ILVSL ) THEN
+ CALL DGGBAK( 'P', 'L', N, ILO, IHI, WORK( ILEFT ),
+ $ WORK( IRIGHT ), N, VSL, LDVSL, IINFO )
+ IF( IINFO.NE.0 ) THEN
+ INFO = N + 7
+ GO TO 10
+ END IF
+ END IF
+ IF( ILVSR ) THEN
+ CALL DGGBAK( 'P', 'R', N, ILO, IHI, WORK( ILEFT ),
+ $ WORK( IRIGHT ), N, VSR, LDVSR, IINFO )
+ IF( IINFO.NE.0 ) THEN
+ INFO = N + 8
+ GO TO 10
+ END IF
+ END IF
+*
+* Undo scaling
+*
+ IF( ILASCL ) THEN
+ CALL DLASCL( 'H', -1, -1, ANRMTO, ANRM, N, N, A, LDA, IINFO )
+ IF( IINFO.NE.0 ) THEN
+ INFO = N + 9
+ RETURN
+ END IF
+ CALL DLASCL( 'G', -1, -1, ANRMTO, ANRM, N, 1, ALPHAR, N,
+ $ IINFO )
+ IF( IINFO.NE.0 ) THEN
+ INFO = N + 9
+ RETURN
+ END IF
+ CALL DLASCL( 'G', -1, -1, ANRMTO, ANRM, N, 1, ALPHAI, N,
+ $ IINFO )
+ IF( IINFO.NE.0 ) THEN
+ INFO = N + 9
+ RETURN
+ END IF
+ END IF
+*
+ IF( ILBSCL ) THEN
+ CALL DLASCL( 'U', -1, -1, BNRMTO, BNRM, N, N, B, LDB, IINFO )
+ IF( IINFO.NE.0 ) THEN
+ INFO = N + 9
+ RETURN
+ END IF
+ CALL DLASCL( 'G', -1, -1, BNRMTO, BNRM, N, 1, BETA, N, IINFO )
+ IF( IINFO.NE.0 ) THEN
+ INFO = N + 9
+ RETURN
+ END IF
+ END IF
+*
+ 10 CONTINUE
+ WORK( 1 ) = LWKOPT
+*
+ RETURN
+*
+* End of DGEGS
+*
+ END
+ SUBROUTINE DGEGV( JOBVL, JOBVR, N, A, LDA, B, LDB, ALPHAR, ALPHAI,
+ $ BETA, VL, LDVL, VR, LDVR, WORK, LWORK, INFO )
+*
+* -- LAPACK driver routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER JOBVL, JOBVR
+ INTEGER INFO, LDA, LDB, LDVL, LDVR, LWORK, N
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION A( LDA, * ), ALPHAI( * ), ALPHAR( * ),
+ $ B( LDB, * ), BETA( * ), VL( LDVL, * ),
+ $ VR( LDVR, * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* This routine is deprecated and has been replaced by routine DGGEV.
+*
+* DGEGV computes the eigenvalues and, optionally, the left and/or right
+* eigenvectors of a real matrix pair (A,B).
+* Given two square matrices A and B,
+* the generalized nonsymmetric eigenvalue problem (GNEP) is to find the
+* eigenvalues lambda and corresponding (non-zero) eigenvectors x such
+* that
+*
+* A*x = lambda*B*x.
+*
+* An alternate form is to find the eigenvalues mu and corresponding
+* eigenvectors y such that
+*
+* mu*A*y = B*y.
+*
+* These two forms are equivalent with mu = 1/lambda and x = y if
+* neither lambda nor mu is zero. In order to deal with the case that
+* lambda or mu is zero or small, two values alpha and beta are returned
+* for each eigenvalue, such that lambda = alpha/beta and
+* mu = beta/alpha.
+*
+* The vectors x and y in the above equations are right eigenvectors of
+* the matrix pair (A,B). Vectors u and v satisfying
+*
+* u**H*A = lambda*u**H*B or mu*v**H*A = v**H*B
+*
+* are left eigenvectors of (A,B).
+*
+* Note: this routine performs "full balancing" on A and B -- see
+* "Further Details", below.
+*
+* Arguments
+* =========
+*
+* JOBVL (input) CHARACTER*1
+* = 'N': do not compute the left generalized eigenvectors;
+* = 'V': compute the left generalized eigenvectors (returned
+* in VL).
+*
+* JOBVR (input) CHARACTER*1
+* = 'N': do not compute the right generalized eigenvectors;
+* = 'V': compute the right generalized eigenvectors (returned
+* in VR).
+*
+* N (input) INTEGER
+* The order of the matrices A, B, VL, and VR. N >= 0.
+*
+* A (input/output) DOUBLE PRECISION array, dimension (LDA, N)
+* On entry, the matrix A.
+* If JOBVL = 'V' or JOBVR = 'V', then on exit A
+* contains the real Schur form of A from the generalized Schur
+* factorization of the pair (A,B) after balancing.
+* If no eigenvectors were computed, then only the diagonal
+* blocks from the Schur form will be correct. See DGGHRD and
+* DHGEQZ for details.
+*
+* LDA (input) INTEGER
+* The leading dimension of A. LDA >= max(1,N).
+*
+* B (input/output) DOUBLE PRECISION array, dimension (LDB, N)
+* On entry, the matrix B.
+* If JOBVL = 'V' or JOBVR = 'V', then on exit B contains the
+* upper triangular matrix obtained from B in the generalized
+* Schur factorization of the pair (A,B) after balancing.
+* If no eigenvectors were computed, then only those elements of
+* B corresponding to the diagonal blocks from the Schur form of
+* A will be correct. See DGGHRD and DHGEQZ for details.
+*
+* LDB (input) INTEGER
+* The leading dimension of B. LDB >= max(1,N).
+*
+* ALPHAR (output) DOUBLE PRECISION array, dimension (N)
+* The real parts of each scalar alpha defining an eigenvalue of
+* GNEP.
+*
+* ALPHAI (output) DOUBLE PRECISION array, dimension (N)
+* The imaginary parts of each scalar alpha defining an
+* eigenvalue of GNEP. If ALPHAI(j) is zero, then the j-th
+* eigenvalue is real; if positive, then the j-th and
+* (j+1)-st eigenvalues are a complex conjugate pair, with
+* ALPHAI(j+1) = -ALPHAI(j).
+*
+* BETA (output) DOUBLE PRECISION array, dimension (N)
+* The scalars beta that define the eigenvalues of GNEP.
+*
+* Together, the quantities alpha = (ALPHAR(j),ALPHAI(j)) and
+* beta = BETA(j) represent the j-th eigenvalue of the matrix
+* pair (A,B), in one of the forms lambda = alpha/beta or
+* mu = beta/alpha. Since either lambda or mu may overflow,
+* they should not, in general, be computed.
+*
+* VL (output) DOUBLE PRECISION array, dimension (LDVL,N)
+* If JOBVL = 'V', the left eigenvectors u(j) are stored
+* in the columns of VL, in the same order as their eigenvalues.
+* If the j-th eigenvalue is real, then u(j) = VL(:,j).
+* If the j-th and (j+1)-st eigenvalues form a complex conjugate
+* pair, then
+* u(j) = VL(:,j) + i*VL(:,j+1)
+* and
+* u(j+1) = VL(:,j) - i*VL(:,j+1).
+*
+* Each eigenvector is scaled so that its largest component has
+* abs(real part) + abs(imag. part) = 1, except for eigenvectors
+* corresponding to an eigenvalue with alpha = beta = 0, which
+* are set to zero.
+* Not referenced if JOBVL = 'N'.
+*
+* LDVL (input) INTEGER
+* The leading dimension of the matrix VL. LDVL >= 1, and
+* if JOBVL = 'V', LDVL >= N.
+*
+* VR (output) DOUBLE PRECISION array, dimension (LDVR,N)
+* If JOBVR = 'V', the right eigenvectors x(j) are stored
+* in the columns of VR, in the same order as their eigenvalues.
+* If the j-th eigenvalue is real, then x(j) = VR(:,j).
+* If the j-th and (j+1)-st eigenvalues form a complex conjugate
+* pair, then
+* x(j) = VR(:,j) + i*VR(:,j+1)
+* and
+* x(j+1) = VR(:,j) - i*VR(:,j+1).
+*
+* Each eigenvector is scaled so that its largest component has
+* abs(real part) + abs(imag. part) = 1, except for eigenvalues
+* corresponding to an eigenvalue with alpha = beta = 0, which
+* are set to zero.
+* Not referenced if JOBVR = 'N'.
+*
+* LDVR (input) INTEGER
+* The leading dimension of the matrix VR. LDVR >= 1, and
+* if JOBVR = 'V', LDVR >= N.
+*
+* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
+* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+* LWORK (input) INTEGER
+* The dimension of the array WORK. LWORK >= max(1,8*N).
+* For good performance, LWORK must generally be larger.
+* To compute the optimal value of LWORK, call ILAENV to get
+* blocksizes (for DGEQRF, DORMQR, and DORGQR.) Then compute:
+* NB -- MAX of the blocksizes for DGEQRF, DORMQR, and DORGQR;
+* The optimal LWORK is:
+* 2*N + MAX( 6*N, N*(NB+1) ).
+*
+* If LWORK = -1, then a workspace query is assumed; the routine
+* only calculates the optimal size of the WORK array, returns
+* this value as the first entry of the WORK array, and no error
+* message related to LWORK is issued by XERBLA.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value.
+* = 1,...,N:
+* The QZ iteration failed. No eigenvectors have been
+* calculated, but ALPHAR(j), ALPHAI(j), and BETA(j)
+* should be correct for j=INFO+1,...,N.
+* > N: errors that usually indicate LAPACK problems:
+* =N+1: error return from DGGBAL
+* =N+2: error return from DGEQRF
+* =N+3: error return from DORMQR
+* =N+4: error return from DORGQR
+* =N+5: error return from DGGHRD
+* =N+6: error return from DHGEQZ (other than failed
+* iteration)
+* =N+7: error return from DTGEVC
+* =N+8: error return from DGGBAK (computing VL)
+* =N+9: error return from DGGBAK (computing VR)
+* =N+10: error return from DLASCL (various calls)
+*
+* Further Details
+* ===============
+*
+* Balancing
+* ---------
+*
+* This driver calls DGGBAL to both permute and scale rows and columns
+* of A and B. The permutations PL and PR are chosen so that PL*A*PR
+* and PL*B*R will be upper triangular except for the diagonal blocks
+* A(i:j,i:j) and B(i:j,i:j), with i and j as close together as
+* possible. The diagonal scaling matrices DL and DR are chosen so
+* that the pair DL*PL*A*PR*DR, DL*PL*B*PR*DR have elements close to
+* one (except for the elements that start out zero.)
+*
+* After the eigenvalues and eigenvectors of the balanced matrices
+* have been computed, DGGBAK transforms the eigenvectors back to what
+* they would have been (in perfect arithmetic) if they had not been
+* balanced.
+*
+* Contents of A and B on Exit
+* -------- -- - --- - -- ----
+*
+* If any eigenvectors are computed (either JOBVL='V' or JOBVR='V' or
+* both), then on exit the arrays A and B will contain the real Schur
+* form[*] of the "balanced" versions of A and B. If no eigenvectors
+* are computed, then only the diagonal blocks will be correct.
+*
+* [*] See DHGEQZ, DGEGS, or read the book "Matrix Computations",
+* by Golub & van Loan, pub. by Johns Hopkins U. Press.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL ILIMIT, ILV, ILVL, ILVR, LQUERY
+ CHARACTER CHTEMP
+ INTEGER ICOLS, IHI, IINFO, IJOBVL, IJOBVR, ILEFT, ILO,
+ $ IN, IRIGHT, IROWS, ITAU, IWORK, JC, JR, LOPT,
+ $ LWKMIN, LWKOPT, NB, NB1, NB2, NB3
+ DOUBLE PRECISION ABSAI, ABSAR, ABSB, ANRM, ANRM1, ANRM2, BNRM,
+ $ BNRM1, BNRM2, EPS, ONEPLS, SAFMAX, SAFMIN,
+ $ SALFAI, SALFAR, SBETA, SCALE, TEMP
+* ..
+* .. Local Arrays ..
+ LOGICAL LDUMMA( 1 )
+* ..
+* .. External Subroutines ..
+ EXTERNAL DGEQRF, DGGBAK, DGGBAL, DGGHRD, DHGEQZ, DLACPY,
+ $ DLASCL, DLASET, DORGQR, DORMQR, DTGEVC, XERBLA
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ILAENV
+ DOUBLE PRECISION DLAMCH, DLANGE
+ EXTERNAL LSAME, ILAENV, DLAMCH, DLANGE
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, INT, MAX
+* ..
+* .. Executable Statements ..
+*
+* Decode the input arguments
+*
+ IF( LSAME( JOBVL, 'N' ) ) THEN
+ IJOBVL = 1
+ ILVL = .FALSE.
+ ELSE IF( LSAME( JOBVL, 'V' ) ) THEN
+ IJOBVL = 2
+ ILVL = .TRUE.
+ ELSE
+ IJOBVL = -1
+ ILVL = .FALSE.
+ END IF
+*
+ IF( LSAME( JOBVR, 'N' ) ) THEN
+ IJOBVR = 1
+ ILVR = .FALSE.
+ ELSE IF( LSAME( JOBVR, 'V' ) ) THEN
+ IJOBVR = 2
+ ILVR = .TRUE.
+ ELSE
+ IJOBVR = -1
+ ILVR = .FALSE.
+ END IF
+ ILV = ILVL .OR. ILVR
+*
+* Test the input arguments
+*
+ LWKMIN = MAX( 8*N, 1 )
+ LWKOPT = LWKMIN
+ WORK( 1 ) = LWKOPT
+ LQUERY = ( LWORK.EQ.-1 )
+ INFO = 0
+ IF( IJOBVL.LE.0 ) THEN
+ INFO = -1
+ ELSE IF( IJOBVR.LE.0 ) THEN
+ INFO = -2
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -5
+ ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -7
+ ELSE IF( LDVL.LT.1 .OR. ( ILVL .AND. LDVL.LT.N ) ) THEN
+ INFO = -12
+ ELSE IF( LDVR.LT.1 .OR. ( ILVR .AND. LDVR.LT.N ) ) THEN
+ INFO = -14
+ ELSE IF( LWORK.LT.LWKMIN .AND. .NOT.LQUERY ) THEN
+ INFO = -16
+ END IF
+*
+ IF( INFO.EQ.0 ) THEN
+ NB1 = ILAENV( 1, 'DGEQRF', ' ', N, N, -1, -1 )
+ NB2 = ILAENV( 1, 'DORMQR', ' ', N, N, N, -1 )
+ NB3 = ILAENV( 1, 'DORGQR', ' ', N, N, N, -1 )
+ NB = MAX( NB1, NB2, NB3 )
+ LOPT = 2*N + MAX( 6*N, N*( NB+1 ) )
+ WORK( 1 ) = LOPT
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DGEGV ', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+* Get machine constants
+*
+ EPS = DLAMCH( 'E' )*DLAMCH( 'B' )
+ SAFMIN = DLAMCH( 'S' )
+ SAFMIN = SAFMIN + SAFMIN
+ SAFMAX = ONE / SAFMIN
+ ONEPLS = ONE + ( 4*EPS )
+*
+* Scale A
+*
+ ANRM = DLANGE( 'M', N, N, A, LDA, WORK )
+ ANRM1 = ANRM
+ ANRM2 = ONE
+ IF( ANRM.LT.ONE ) THEN
+ IF( SAFMAX*ANRM.LT.ONE ) THEN
+ ANRM1 = SAFMIN
+ ANRM2 = SAFMAX*ANRM
+ END IF
+ END IF
+*
+ IF( ANRM.GT.ZERO ) THEN
+ CALL DLASCL( 'G', -1, -1, ANRM, ONE, N, N, A, LDA, IINFO )
+ IF( IINFO.NE.0 ) THEN
+ INFO = N + 10
+ RETURN
+ END IF
+ END IF
+*
+* Scale B
+*
+ BNRM = DLANGE( 'M', N, N, B, LDB, WORK )
+ BNRM1 = BNRM
+ BNRM2 = ONE
+ IF( BNRM.LT.ONE ) THEN
+ IF( SAFMAX*BNRM.LT.ONE ) THEN
+ BNRM1 = SAFMIN
+ BNRM2 = SAFMAX*BNRM
+ END IF
+ END IF
+*
+ IF( BNRM.GT.ZERO ) THEN
+ CALL DLASCL( 'G', -1, -1, BNRM, ONE, N, N, B, LDB, IINFO )
+ IF( IINFO.NE.0 ) THEN
+ INFO = N + 10
+ RETURN
+ END IF
+ END IF
+*
+* Permute the matrix to make it more nearly triangular
+* Workspace layout: (8*N words -- "work" requires 6*N words)
+* left_permutation, right_permutation, work...
+*
+ ILEFT = 1
+ IRIGHT = N + 1
+ IWORK = IRIGHT + N
+ CALL DGGBAL( 'P', N, A, LDA, B, LDB, ILO, IHI, WORK( ILEFT ),
+ $ WORK( IRIGHT ), WORK( IWORK ), IINFO )
+ IF( IINFO.NE.0 ) THEN
+ INFO = N + 1
+ GO TO 120
+ END IF
+*
+* Reduce B to triangular form, and initialize VL and/or VR
+* Workspace layout: ("work..." must have at least N words)
+* left_permutation, right_permutation, tau, work...
+*
+ IROWS = IHI + 1 - ILO
+ IF( ILV ) THEN
+ ICOLS = N + 1 - ILO
+ ELSE
+ ICOLS = IROWS
+ END IF
+ ITAU = IWORK
+ IWORK = ITAU + IROWS
+ CALL DGEQRF( IROWS, ICOLS, B( ILO, ILO ), LDB, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK+1-IWORK, IINFO )
+ IF( IINFO.GE.0 )
+ $ LWKOPT = MAX( LWKOPT, INT( WORK( IWORK ) )+IWORK-1 )
+ IF( IINFO.NE.0 ) THEN
+ INFO = N + 2
+ GO TO 120
+ END IF
+*
+ CALL DORMQR( 'L', 'T', IROWS, ICOLS, IROWS, B( ILO, ILO ), LDB,
+ $ WORK( ITAU ), A( ILO, ILO ), LDA, WORK( IWORK ),
+ $ LWORK+1-IWORK, IINFO )
+ IF( IINFO.GE.0 )
+ $ LWKOPT = MAX( LWKOPT, INT( WORK( IWORK ) )+IWORK-1 )
+ IF( IINFO.NE.0 ) THEN
+ INFO = N + 3
+ GO TO 120
+ END IF
+*
+ IF( ILVL ) THEN
+ CALL DLASET( 'Full', N, N, ZERO, ONE, VL, LDVL )
+ CALL DLACPY( 'L', IROWS-1, IROWS-1, B( ILO+1, ILO ), LDB,
+ $ VL( ILO+1, ILO ), LDVL )
+ CALL DORGQR( IROWS, IROWS, IROWS, VL( ILO, ILO ), LDVL,
+ $ WORK( ITAU ), WORK( IWORK ), LWORK+1-IWORK,
+ $ IINFO )
+ IF( IINFO.GE.0 )
+ $ LWKOPT = MAX( LWKOPT, INT( WORK( IWORK ) )+IWORK-1 )
+ IF( IINFO.NE.0 ) THEN
+ INFO = N + 4
+ GO TO 120
+ END IF
+ END IF
+*
+ IF( ILVR )
+ $ CALL DLASET( 'Full', N, N, ZERO, ONE, VR, LDVR )
+*
+* Reduce to generalized Hessenberg form
+*
+ IF( ILV ) THEN
+*
+* Eigenvectors requested -- work on whole matrix.
+*
+ CALL DGGHRD( JOBVL, JOBVR, N, ILO, IHI, A, LDA, B, LDB, VL,
+ $ LDVL, VR, LDVR, IINFO )
+ ELSE
+ CALL DGGHRD( 'N', 'N', IROWS, 1, IROWS, A( ILO, ILO ), LDA,
+ $ B( ILO, ILO ), LDB, VL, LDVL, VR, LDVR, IINFO )
+ END IF
+ IF( IINFO.NE.0 ) THEN
+ INFO = N + 5
+ GO TO 120
+ END IF
+*
+* Perform QZ algorithm
+* Workspace layout: ("work..." must have at least 1 word)
+* left_permutation, right_permutation, work...
+*
+ IWORK = ITAU
+ IF( ILV ) THEN
+ CHTEMP = 'S'
+ ELSE
+ CHTEMP = 'E'
+ END IF
+ CALL DHGEQZ( CHTEMP, JOBVL, JOBVR, N, ILO, IHI, A, LDA, B, LDB,
+ $ ALPHAR, ALPHAI, BETA, VL, LDVL, VR, LDVR,
+ $ WORK( IWORK ), LWORK+1-IWORK, IINFO )
+ IF( IINFO.GE.0 )
+ $ LWKOPT = MAX( LWKOPT, INT( WORK( IWORK ) )+IWORK-1 )
+ IF( IINFO.NE.0 ) THEN
+ IF( IINFO.GT.0 .AND. IINFO.LE.N ) THEN
+ INFO = IINFO
+ ELSE IF( IINFO.GT.N .AND. IINFO.LE.2*N ) THEN
+ INFO = IINFO - N
+ ELSE
+ INFO = N + 6
+ END IF
+ GO TO 120
+ END IF
+*
+ IF( ILV ) THEN
+*
+* Compute Eigenvectors (DTGEVC requires 6*N words of workspace)
+*
+ IF( ILVL ) THEN
+ IF( ILVR ) THEN
+ CHTEMP = 'B'
+ ELSE
+ CHTEMP = 'L'
+ END IF
+ ELSE
+ CHTEMP = 'R'
+ END IF
+*
+ CALL DTGEVC( CHTEMP, 'B', LDUMMA, N, A, LDA, B, LDB, VL, LDVL,
+ $ VR, LDVR, N, IN, WORK( IWORK ), IINFO )
+ IF( IINFO.NE.0 ) THEN
+ INFO = N + 7
+ GO TO 120
+ END IF
+*
+* Undo balancing on VL and VR, rescale
+*
+ IF( ILVL ) THEN
+ CALL DGGBAK( 'P', 'L', N, ILO, IHI, WORK( ILEFT ),
+ $ WORK( IRIGHT ), N, VL, LDVL, IINFO )
+ IF( IINFO.NE.0 ) THEN
+ INFO = N + 8
+ GO TO 120
+ END IF
+ DO 50 JC = 1, N
+ IF( ALPHAI( JC ).LT.ZERO )
+ $ GO TO 50
+ TEMP = ZERO
+ IF( ALPHAI( JC ).EQ.ZERO ) THEN
+ DO 10 JR = 1, N
+ TEMP = MAX( TEMP, ABS( VL( JR, JC ) ) )
+ 10 CONTINUE
+ ELSE
+ DO 20 JR = 1, N
+ TEMP = MAX( TEMP, ABS( VL( JR, JC ) )+
+ $ ABS( VL( JR, JC+1 ) ) )
+ 20 CONTINUE
+ END IF
+ IF( TEMP.LT.SAFMIN )
+ $ GO TO 50
+ TEMP = ONE / TEMP
+ IF( ALPHAI( JC ).EQ.ZERO ) THEN
+ DO 30 JR = 1, N
+ VL( JR, JC ) = VL( JR, JC )*TEMP
+ 30 CONTINUE
+ ELSE
+ DO 40 JR = 1, N
+ VL( JR, JC ) = VL( JR, JC )*TEMP
+ VL( JR, JC+1 ) = VL( JR, JC+1 )*TEMP
+ 40 CONTINUE
+ END IF
+ 50 CONTINUE
+ END IF
+ IF( ILVR ) THEN
+ CALL DGGBAK( 'P', 'R', N, ILO, IHI, WORK( ILEFT ),
+ $ WORK( IRIGHT ), N, VR, LDVR, IINFO )
+ IF( IINFO.NE.0 ) THEN
+ INFO = N + 9
+ GO TO 120
+ END IF
+ DO 100 JC = 1, N
+ IF( ALPHAI( JC ).LT.ZERO )
+ $ GO TO 100
+ TEMP = ZERO
+ IF( ALPHAI( JC ).EQ.ZERO ) THEN
+ DO 60 JR = 1, N
+ TEMP = MAX( TEMP, ABS( VR( JR, JC ) ) )
+ 60 CONTINUE
+ ELSE
+ DO 70 JR = 1, N
+ TEMP = MAX( TEMP, ABS( VR( JR, JC ) )+
+ $ ABS( VR( JR, JC+1 ) ) )
+ 70 CONTINUE
+ END IF
+ IF( TEMP.LT.SAFMIN )
+ $ GO TO 100
+ TEMP = ONE / TEMP
+ IF( ALPHAI( JC ).EQ.ZERO ) THEN
+ DO 80 JR = 1, N
+ VR( JR, JC ) = VR( JR, JC )*TEMP
+ 80 CONTINUE
+ ELSE
+ DO 90 JR = 1, N
+ VR( JR, JC ) = VR( JR, JC )*TEMP
+ VR( JR, JC+1 ) = VR( JR, JC+1 )*TEMP
+ 90 CONTINUE
+ END IF
+ 100 CONTINUE
+ END IF
+*
+* End of eigenvector calculation
+*
+ END IF
+*
+* Undo scaling in alpha, beta
+*
+* Note: this does not give the alpha and beta for the unscaled
+* problem.
+*
+* Un-scaling is limited to avoid underflow in alpha and beta
+* if they are significant.
+*
+ DO 110 JC = 1, N
+ ABSAR = ABS( ALPHAR( JC ) )
+ ABSAI = ABS( ALPHAI( JC ) )
+ ABSB = ABS( BETA( JC ) )
+ SALFAR = ANRM*ALPHAR( JC )
+ SALFAI = ANRM*ALPHAI( JC )
+ SBETA = BNRM*BETA( JC )
+ ILIMIT = .FALSE.
+ SCALE = ONE
+*
+* Check for significant underflow in ALPHAI
+*
+ IF( ABS( SALFAI ).LT.SAFMIN .AND. ABSAI.GE.
+ $ MAX( SAFMIN, EPS*ABSAR, EPS*ABSB ) ) THEN
+ ILIMIT = .TRUE.
+ SCALE = ( ONEPLS*SAFMIN / ANRM1 ) /
+ $ MAX( ONEPLS*SAFMIN, ANRM2*ABSAI )
+*
+ ELSE IF( SALFAI.EQ.ZERO ) THEN
+*
+* If insignificant underflow in ALPHAI, then make the
+* conjugate eigenvalue real.
+*
+ IF( ALPHAI( JC ).LT.ZERO .AND. JC.GT.1 ) THEN
+ ALPHAI( JC-1 ) = ZERO
+ ELSE IF( ALPHAI( JC ).GT.ZERO .AND. JC.LT.N ) THEN
+ ALPHAI( JC+1 ) = ZERO
+ END IF
+ END IF
+*
+* Check for significant underflow in ALPHAR
+*
+ IF( ABS( SALFAR ).LT.SAFMIN .AND. ABSAR.GE.
+ $ MAX( SAFMIN, EPS*ABSAI, EPS*ABSB ) ) THEN
+ ILIMIT = .TRUE.
+ SCALE = MAX( SCALE, ( ONEPLS*SAFMIN / ANRM1 ) /
+ $ MAX( ONEPLS*SAFMIN, ANRM2*ABSAR ) )
+ END IF
+*
+* Check for significant underflow in BETA
+*
+ IF( ABS( SBETA ).LT.SAFMIN .AND. ABSB.GE.
+ $ MAX( SAFMIN, EPS*ABSAR, EPS*ABSAI ) ) THEN
+ ILIMIT = .TRUE.
+ SCALE = MAX( SCALE, ( ONEPLS*SAFMIN / BNRM1 ) /
+ $ MAX( ONEPLS*SAFMIN, BNRM2*ABSB ) )
+ END IF
+*
+* Check for possible overflow when limiting scaling
+*
+ IF( ILIMIT ) THEN
+ TEMP = ( SCALE*SAFMIN )*MAX( ABS( SALFAR ), ABS( SALFAI ),
+ $ ABS( SBETA ) )
+ IF( TEMP.GT.ONE )
+ $ SCALE = SCALE / TEMP
+ IF( SCALE.LT.ONE )
+ $ ILIMIT = .FALSE.
+ END IF
+*
+* Recompute un-scaled ALPHAR, ALPHAI, BETA if necessary.
+*
+ IF( ILIMIT ) THEN
+ SALFAR = ( SCALE*ALPHAR( JC ) )*ANRM
+ SALFAI = ( SCALE*ALPHAI( JC ) )*ANRM
+ SBETA = ( SCALE*BETA( JC ) )*BNRM
+ END IF
+ ALPHAR( JC ) = SALFAR
+ ALPHAI( JC ) = SALFAI
+ BETA( JC ) = SBETA
+ 110 CONTINUE
+*
+ 120 CONTINUE
+ WORK( 1 ) = LWKOPT
+*
+ RETURN
+*
+* End of DGEGV
+*
+ END
+ SUBROUTINE DGEHD2( N, ILO, IHI, A, LDA, TAU, WORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER IHI, ILO, INFO, LDA, N
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DGEHD2 reduces a real general matrix A to upper Hessenberg form H by
+* an orthogonal similarity transformation: Q' * A * Q = H .
+*
+* Arguments
+* =========
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* ILO (input) INTEGER
+* IHI (input) INTEGER
+* It is assumed that A is already upper triangular in rows
+* and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally
+* set by a previous call to DGEBAL; otherwise they should be
+* set to 1 and N respectively. See Further Details.
+* 1 <= ILO <= IHI <= max(1,N).
+*
+* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+* On entry, the n by n general matrix to be reduced.
+* On exit, the upper triangle and the first subdiagonal of A
+* are overwritten with the upper Hessenberg matrix H, and the
+* elements below the first subdiagonal, with the array TAU,
+* represent the orthogonal matrix Q as a product of elementary
+* reflectors. See Further Details.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,N).
+*
+* TAU (output) DOUBLE PRECISION array, dimension (N-1)
+* The scalar factors of the elementary reflectors (see Further
+* Details).
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (N)
+*
+* INFO (output) INTEGER
+* = 0: successful exit.
+* < 0: if INFO = -i, the i-th argument had an illegal value.
+*
+* Further Details
+* ===============
+*
+* The matrix Q is represented as a product of (ihi-ilo) elementary
+* reflectors
+*
+* Q = H(ilo) H(ilo+1) . . . H(ihi-1).
+*
+* Each H(i) has the form
+*
+* H(i) = I - tau * v * v'
+*
+* where tau is a real scalar, and v is a real vector with
+* v(1:i) = 0, v(i+1) = 1 and v(ihi+1:n) = 0; v(i+2:ihi) is stored on
+* exit in A(i+2:ihi,i), and tau in TAU(i).
+*
+* The contents of A are illustrated by the following example, with
+* n = 7, ilo = 2 and ihi = 6:
+*
+* on entry, on exit,
+*
+* ( a a a a a a a ) ( a a h h h h a )
+* ( a a a a a a ) ( a h h h h a )
+* ( a a a a a a ) ( h h h h h h )
+* ( a a a a a a ) ( v2 h h h h h )
+* ( a a a a a a ) ( v2 v3 h h h h )
+* ( a a a a a a ) ( v2 v3 v4 h h h )
+* ( a ) ( a )
+*
+* where a denotes an element of the original matrix A, h denotes a
+* modified element of the upper Hessenberg matrix H, and vi denotes an
+* element of the vector defining H(i).
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE
+ PARAMETER ( ONE = 1.0D+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I
+ DOUBLE PRECISION AII
+* ..
+* .. External Subroutines ..
+ EXTERNAL DLARF, DLARFG, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters
+*
+ INFO = 0
+ IF( N.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN
+ INFO = -2
+ ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN
+ INFO = -3
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -5
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DGEHD2', -INFO )
+ RETURN
+ END IF
+*
+ DO 10 I = ILO, IHI - 1
+*
+* Compute elementary reflector H(i) to annihilate A(i+2:ihi,i)
+*
+ CALL DLARFG( IHI-I, A( I+1, I ), A( MIN( I+2, N ), I ), 1,
+ $ TAU( I ) )
+ AII = A( I+1, I )
+ A( I+1, I ) = ONE
+*
+* Apply H(i) to A(1:ihi,i+1:ihi) from the right
+*
+ CALL DLARF( 'Right', IHI, IHI-I, A( I+1, I ), 1, TAU( I ),
+ $ A( 1, I+1 ), LDA, WORK )
+*
+* Apply H(i) to A(i+1:ihi,i+1:n) from the left
+*
+ CALL DLARF( 'Left', IHI-I, N-I, A( I+1, I ), 1, TAU( I ),
+ $ A( I+1, I+1 ), LDA, WORK )
+*
+ A( I+1, I ) = AII
+ 10 CONTINUE
+*
+ RETURN
+*
+* End of DGEHD2
+*
+ END
+ SUBROUTINE DGEHRD( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER IHI, ILO, INFO, LDA, LWORK, N
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DGEHRD reduces a real general matrix A to upper Hessenberg form H by
+* an orthogonal similarity transformation: Q' * A * Q = H .
+*
+* Arguments
+* =========
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* ILO (input) INTEGER
+* IHI (input) INTEGER
+* It is assumed that A is already upper triangular in rows
+* and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally
+* set by a previous call to DGEBAL; otherwise they should be
+* set to 1 and N respectively. See Further Details.
+* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.
+*
+* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+* On entry, the N-by-N general matrix to be reduced.
+* On exit, the upper triangle and the first subdiagonal of A
+* are overwritten with the upper Hessenberg matrix H, and the
+* elements below the first subdiagonal, with the array TAU,
+* represent the orthogonal matrix Q as a product of elementary
+* reflectors. See Further Details.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,N).
+*
+* TAU (output) DOUBLE PRECISION array, dimension (N-1)
+* The scalar factors of the elementary reflectors (see Further
+* Details). Elements 1:ILO-1 and IHI:N-1 of TAU are set to
+* zero.
+*
+* WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK)
+* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+* LWORK (input) INTEGER
+* The length of the array WORK. LWORK >= max(1,N).
+* For optimum performance LWORK >= N*NB, where NB is the
+* optimal blocksize.
+*
+* If LWORK = -1, then a workspace query is assumed; the routine
+* only calculates the optimal size of the WORK array, returns
+* this value as the first entry of the WORK array, and no error
+* message related to LWORK is issued by XERBLA.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value.
+*
+* Further Details
+* ===============
+*
+* The matrix Q is represented as a product of (ihi-ilo) elementary
+* reflectors
+*
+* Q = H(ilo) H(ilo+1) . . . H(ihi-1).
+*
+* Each H(i) has the form
+*
+* H(i) = I - tau * v * v'
+*
+* where tau is a real scalar, and v is a real vector with
+* v(1:i) = 0, v(i+1) = 1 and v(ihi+1:n) = 0; v(i+2:ihi) is stored on
+* exit in A(i+2:ihi,i), and tau in TAU(i).
+*
+* The contents of A are illustrated by the following example, with
+* n = 7, ilo = 2 and ihi = 6:
+*
+* on entry, on exit,
+*
+* ( a a a a a a a ) ( a a h h h h a )
+* ( a a a a a a ) ( a h h h h a )
+* ( a a a a a a ) ( h h h h h h )
+* ( a a a a a a ) ( v2 h h h h h )
+* ( a a a a a a ) ( v2 v3 h h h h )
+* ( a a a a a a ) ( v2 v3 v4 h h h )
+* ( a ) ( a )
+*
+* where a denotes an element of the original matrix A, h denotes a
+* modified element of the upper Hessenberg matrix H, and vi denotes an
+* element of the vector defining H(i).
+*
+* This file is a slight modification of LAPACK-3.0's DGEHRD
+* subroutine incorporating improvements proposed by Quintana-Orti and
+* Van de Geijn (2005).
+*
+* =====================================================================
+*
+* .. Parameters ..
+ INTEGER NBMAX, LDT
+ PARAMETER ( NBMAX = 64, LDT = NBMAX+1 )
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D+0,
+ $ ONE = 1.0D+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL LQUERY
+ INTEGER I, IB, IINFO, IWS, J, LDWORK, LWKOPT, NB,
+ $ NBMIN, NH, NX
+ DOUBLE PRECISION EI
+* ..
+* .. Local Arrays ..
+ DOUBLE PRECISION T( LDT, NBMAX )
+* ..
+* .. External Subroutines ..
+ EXTERNAL DAXPY, DGEHD2, DGEMM, DLAHR2, DLARFB, DTRMM,
+ $ XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN
+* ..
+* .. External Functions ..
+ INTEGER ILAENV
+ EXTERNAL ILAENV
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters
+*
+ INFO = 0
+ NB = MIN( NBMAX, ILAENV( 1, 'DGEHRD', ' ', N, ILO, IHI, -1 ) )
+ LWKOPT = N*NB
+ WORK( 1 ) = LWKOPT
+ LQUERY = ( LWORK.EQ.-1 )
+ IF( N.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN
+ INFO = -2
+ ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN
+ INFO = -3
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -5
+ ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN
+ INFO = -8
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DGEHRD', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Set elements 1:ILO-1 and IHI:N-1 of TAU to zero
+*
+ DO 10 I = 1, ILO - 1
+ TAU( I ) = ZERO
+ 10 CONTINUE
+ DO 20 I = MAX( 1, IHI ), N - 1
+ TAU( I ) = ZERO
+ 20 CONTINUE
+*
+* Quick return if possible
+*
+ NH = IHI - ILO + 1
+ IF( NH.LE.1 ) THEN
+ WORK( 1 ) = 1
+ RETURN
+ END IF
+*
+* Determine the block size
+*
+ NB = MIN( NBMAX, ILAENV( 1, 'DGEHRD', ' ', N, ILO, IHI, -1 ) )
+ NBMIN = 2
+ IWS = 1
+ IF( NB.GT.1 .AND. NB.LT.NH ) THEN
+*
+* Determine when to cross over from blocked to unblocked code
+* (last block is always handled by unblocked code)
+*
+ NX = MAX( NB, ILAENV( 3, 'DGEHRD', ' ', N, ILO, IHI, -1 ) )
+ IF( NX.LT.NH ) THEN
+*
+* Determine if workspace is large enough for blocked code
+*
+ IWS = N*NB
+ IF( LWORK.LT.IWS ) THEN
+*
+* Not enough workspace to use optimal NB: determine the
+* minimum value of NB, and reduce NB or force use of
+* unblocked code
+*
+ NBMIN = MAX( 2, ILAENV( 2, 'DGEHRD', ' ', N, ILO, IHI,
+ $ -1 ) )
+ IF( LWORK.GE.N*NBMIN ) THEN
+ NB = LWORK / N
+ ELSE
+ NB = 1
+ END IF
+ END IF
+ END IF
+ END IF
+ LDWORK = N
+*
+ IF( NB.LT.NBMIN .OR. NB.GE.NH ) THEN
+*
+* Use unblocked code below
+*
+ I = ILO
+*
+ ELSE
+*
+* Use blocked code
+*
+ DO 40 I = ILO, IHI - 1 - NX, NB
+ IB = MIN( NB, IHI-I )
+*
+* Reduce columns i:i+ib-1 to Hessenberg form, returning the
+* matrices V and T of the block reflector H = I - V*T*V'
+* which performs the reduction, and also the matrix Y = A*V*T
+*
+ CALL DLAHR2( IHI, I, IB, A( 1, I ), LDA, TAU( I ), T, LDT,
+ $ WORK, LDWORK )
+*
+* Apply the block reflector H to A(1:ihi,i+ib:ihi) from the
+* right, computing A := A - Y * V'. V(i+ib,ib-1) must be set
+* to 1
+*
+ EI = A( I+IB, I+IB-1 )
+ A( I+IB, I+IB-1 ) = ONE
+ CALL DGEMM( 'No transpose', 'Transpose',
+ $ IHI, IHI-I-IB+1,
+ $ IB, -ONE, WORK, LDWORK, A( I+IB, I ), LDA, ONE,
+ $ A( 1, I+IB ), LDA )
+ A( I+IB, I+IB-1 ) = EI
+*
+* Apply the block reflector H to A(1:i,i+1:i+ib-1) from the
+* right
+*
+ CALL DTRMM( 'Right', 'Lower', 'Transpose',
+ $ 'Unit', I, IB-1,
+ $ ONE, A( I+1, I ), LDA, WORK, LDWORK )
+ DO 30 J = 0, IB-2
+ CALL DAXPY( I, -ONE, WORK( LDWORK*J+1 ), 1,
+ $ A( 1, I+J+1 ), 1 )
+ 30 CONTINUE
+*
+* Apply the block reflector H to A(i+1:ihi,i+ib:n) from the
+* left
+*
+ CALL DLARFB( 'Left', 'Transpose', 'Forward',
+ $ 'Columnwise',
+ $ IHI-I, N-I-IB+1, IB, A( I+1, I ), LDA, T, LDT,
+ $ A( I+1, I+IB ), LDA, WORK, LDWORK )
+ 40 CONTINUE
+ END IF
+*
+* Use unblocked code to reduce the rest of the matrix
+*
+ CALL DGEHD2( N, I, IHI, A, LDA, TAU, WORK, IINFO )
+ WORK( 1 ) = IWS
+*
+ RETURN
+*
+* End of DGEHRD
+*
+ END
+ SUBROUTINE DGELQ2( M, N, A, LDA, TAU, WORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LDA, M, N
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DGELQ2 computes an LQ factorization of a real m by n matrix A:
+* A = L * Q.
+*
+* Arguments
+* =========
+*
+* M (input) INTEGER
+* The number of rows of the matrix A. M >= 0.
+*
+* N (input) INTEGER
+* The number of columns of the matrix A. N >= 0.
+*
+* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+* On entry, the m by n matrix A.
+* On exit, the elements on and below the diagonal of the array
+* contain the m by min(m,n) lower trapezoidal matrix L (L is
+* lower triangular if m <= n); the elements above the diagonal,
+* with the array TAU, represent the orthogonal matrix Q as a
+* product of elementary reflectors (see Further Details).
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,M).
+*
+* TAU (output) DOUBLE PRECISION array, dimension (min(M,N))
+* The scalar factors of the elementary reflectors (see Further
+* Details).
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (M)
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+*
+* Further Details
+* ===============
+*
+* The matrix Q is represented as a product of elementary reflectors
+*
+* Q = H(k) . . . H(2) H(1), where k = min(m,n).
+*
+* Each H(i) has the form
+*
+* H(i) = I - tau * v * v'
+*
+* where tau is a real scalar, and v is a real vector with
+* v(1:i-1) = 0 and v(i) = 1; v(i+1:n) is stored on exit in A(i,i+1:n),
+* and tau in TAU(i).
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE
+ PARAMETER ( ONE = 1.0D+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, K
+ DOUBLE PRECISION AII
+* ..
+* .. External Subroutines ..
+ EXTERNAL DLARF, DLARFG, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+* Test the input arguments
+*
+ INFO = 0
+ IF( M.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+ INFO = -4
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DGELQ2', -INFO )
+ RETURN
+ END IF
+*
+ K = MIN( M, N )
+*
+ DO 10 I = 1, K
+*
+* Generate elementary reflector H(i) to annihilate A(i,i+1:n)
+*
+ CALL DLARFG( N-I+1, A( I, I ), A( I, MIN( I+1, N ) ), LDA,
+ $ TAU( I ) )
+ IF( I.LT.M ) THEN
+*
+* Apply H(i) to A(i+1:m,i:n) from the right
+*
+ AII = A( I, I )
+ A( I, I ) = ONE
+ CALL DLARF( 'Right', M-I, N-I+1, A( I, I ), LDA, TAU( I ),
+ $ A( I+1, I ), LDA, WORK )
+ A( I, I ) = AII
+ END IF
+ 10 CONTINUE
+ RETURN
+*
+* End of DGELQ2
+*
+ END
+ SUBROUTINE DGELQF( M, N, A, LDA, TAU, WORK, LWORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LDA, LWORK, M, N
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DGELQF computes an LQ factorization of a real M-by-N matrix A:
+* A = L * Q.
+*
+* Arguments
+* =========
+*
+* M (input) INTEGER
+* The number of rows of the matrix A. M >= 0.
+*
+* N (input) INTEGER
+* The number of columns of the matrix A. N >= 0.
+*
+* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+* On entry, the M-by-N matrix A.
+* On exit, the elements on and below the diagonal of the array
+* contain the m-by-min(m,n) lower trapezoidal matrix L (L is
+* lower triangular if m <= n); the elements above the diagonal,
+* with the array TAU, represent the orthogonal matrix Q as a
+* product of elementary reflectors (see Further Details).
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,M).
+*
+* TAU (output) DOUBLE PRECISION array, dimension (min(M,N))
+* The scalar factors of the elementary reflectors (see Further
+* Details).
+*
+* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
+* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+* LWORK (input) INTEGER
+* The dimension of the array WORK. LWORK >= max(1,M).
+* For optimum performance LWORK >= M*NB, where NB is the
+* optimal blocksize.
+*
+* If LWORK = -1, then a workspace query is assumed; the routine
+* only calculates the optimal size of the WORK array, returns
+* this value as the first entry of the WORK array, and no error
+* message related to LWORK is issued by XERBLA.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+*
+* Further Details
+* ===============
+*
+* The matrix Q is represented as a product of elementary reflectors
+*
+* Q = H(k) . . . H(2) H(1), where k = min(m,n).
+*
+* Each H(i) has the form
+*
+* H(i) = I - tau * v * v'
+*
+* where tau is a real scalar, and v is a real vector with
+* v(1:i-1) = 0 and v(i) = 1; v(i+1:n) is stored on exit in A(i,i+1:n),
+* and tau in TAU(i).
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ LOGICAL LQUERY
+ INTEGER I, IB, IINFO, IWS, K, LDWORK, LWKOPT, NB,
+ $ NBMIN, NX
+* ..
+* .. External Subroutines ..
+ EXTERNAL DGELQ2, DLARFB, DLARFT, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN
+* ..
+* .. External Functions ..
+ INTEGER ILAENV
+ EXTERNAL ILAENV
+* ..
+* .. Executable Statements ..
+*
+* Test the input arguments
+*
+ INFO = 0
+ NB = ILAENV( 1, 'DGELQF', ' ', M, N, -1, -1 )
+ LWKOPT = M*NB
+ WORK( 1 ) = LWKOPT
+ LQUERY = ( LWORK.EQ.-1 )
+ IF( M.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+ INFO = -4
+ ELSE IF( LWORK.LT.MAX( 1, M ) .AND. .NOT.LQUERY ) THEN
+ INFO = -7
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DGELQF', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ K = MIN( M, N )
+ IF( K.EQ.0 ) THEN
+ WORK( 1 ) = 1
+ RETURN
+ END IF
+*
+ NBMIN = 2
+ NX = 0
+ IWS = M
+ IF( NB.GT.1 .AND. NB.LT.K ) THEN
+*
+* Determine when to cross over from blocked to unblocked code.
+*
+ NX = MAX( 0, ILAENV( 3, 'DGELQF', ' ', M, N, -1, -1 ) )
+ IF( NX.LT.K ) THEN
+*
+* Determine if workspace is large enough for blocked code.
+*
+ LDWORK = M
+ IWS = LDWORK*NB
+ IF( LWORK.LT.IWS ) THEN
+*
+* Not enough workspace to use optimal NB: reduce NB and
+* determine the minimum value of NB.
+*
+ NB = LWORK / LDWORK
+ NBMIN = MAX( 2, ILAENV( 2, 'DGELQF', ' ', M, N, -1,
+ $ -1 ) )
+ END IF
+ END IF
+ END IF
+*
+ IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN
+*
+* Use blocked code initially
+*
+ DO 10 I = 1, K - NX, NB
+ IB = MIN( K-I+1, NB )
+*
+* Compute the LQ factorization of the current block
+* A(i:i+ib-1,i:n)
+*
+ CALL DGELQ2( IB, N-I+1, A( I, I ), LDA, TAU( I ), WORK,
+ $ IINFO )
+ IF( I+IB.LE.M ) THEN
+*
+* Form the triangular factor of the block reflector
+* H = H(i) H(i+1) . . . H(i+ib-1)
+*
+ CALL DLARFT( 'Forward', 'Rowwise', N-I+1, IB, A( I, I ),
+ $ LDA, TAU( I ), WORK, LDWORK )
+*
+* Apply H to A(i+ib:m,i:n) from the right
+*
+ CALL DLARFB( 'Right', 'No transpose', 'Forward',
+ $ 'Rowwise', M-I-IB+1, N-I+1, IB, A( I, I ),
+ $ LDA, WORK, LDWORK, A( I+IB, I ), LDA,
+ $ WORK( IB+1 ), LDWORK )
+ END IF
+ 10 CONTINUE
+ ELSE
+ I = 1
+ END IF
+*
+* Use unblocked code to factor the last or only block.
+*
+ IF( I.LE.K )
+ $ CALL DGELQ2( M-I+1, N-I+1, A( I, I ), LDA, TAU( I ), WORK,
+ $ IINFO )
+*
+ WORK( 1 ) = IWS
+ RETURN
+*
+* End of DGELQF
+*
+ END
+ SUBROUTINE DGELS( TRANS, M, N, NRHS, A, LDA, B, LDB, WORK, LWORK,
+ $ INFO )
+*
+* -- LAPACK driver routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER TRANS
+ INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION A( LDA, * ), B( LDB, * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DGELS solves overdetermined or underdetermined real linear systems
+* involving an M-by-N matrix A, or its transpose, using a QR or LQ
+* factorization of A. It is assumed that A has full rank.
+*
+* The following options are provided:
+*
+* 1. If TRANS = 'N' and m >= n: find the least squares solution of
+* an overdetermined system, i.e., solve the least squares problem
+* minimize || B - A*X ||.
+*
+* 2. If TRANS = 'N' and m < n: find the minimum norm solution of
+* an underdetermined system A * X = B.
+*
+* 3. If TRANS = 'T' and m >= n: find the minimum norm solution of
+* an undetermined system A**T * X = B.
+*
+* 4. If TRANS = 'T' and m < n: find the least squares solution of
+* an overdetermined system, i.e., solve the least squares problem
+* minimize || B - A**T * X ||.
+*
+* Several right hand side vectors b and solution vectors x can be
+* handled in a single call; they are stored as the columns of the
+* M-by-NRHS right hand side matrix B and the N-by-NRHS solution
+* matrix X.
+*
+* Arguments
+* =========
+*
+* TRANS (input) CHARACTER*1
+* = 'N': the linear system involves A;
+* = 'T': the linear system involves A**T.
+*
+* M (input) INTEGER
+* The number of rows of the matrix A. M >= 0.
+*
+* N (input) INTEGER
+* The number of columns of the matrix A. N >= 0.
+*
+* NRHS (input) INTEGER
+* The number of right hand sides, i.e., the number of
+* columns of the matrices B and X. NRHS >=0.
+*
+* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+* On entry, the M-by-N matrix A.
+* On exit,
+* if M >= N, A is overwritten by details of its QR
+* factorization as returned by DGEQRF;
+* if M < N, A is overwritten by details of its LQ
+* factorization as returned by DGELQF.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,M).
+*
+* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
+* On entry, the matrix B of right hand side vectors, stored
+* columnwise; B is M-by-NRHS if TRANS = 'N', or N-by-NRHS
+* if TRANS = 'T'.
+* On exit, if INFO = 0, B is overwritten by the solution
+* vectors, stored columnwise:
+* if TRANS = 'N' and m >= n, rows 1 to n of B contain the least
+* squares solution vectors; the residual sum of squares for the
+* solution in each column is given by the sum of squares of
+* elements N+1 to M in that column;
+* if TRANS = 'N' and m < n, rows 1 to N of B contain the
+* minimum norm solution vectors;
+* if TRANS = 'T' and m >= n, rows 1 to M of B contain the
+* minimum norm solution vectors;
+* if TRANS = 'T' and m < n, rows 1 to M of B contain the
+* least squares solution vectors; the residual sum of squares
+* for the solution in each column is given by the sum of
+* squares of elements M+1 to N in that column.
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. LDB >= MAX(1,M,N).
+*
+* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
+* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+* LWORK (input) INTEGER
+* The dimension of the array WORK.
+* LWORK >= max( 1, MN + max( MN, NRHS ) ).
+* For optimal performance,
+* LWORK >= max( 1, MN + max( MN, NRHS )*NB ).
+* where MN = min(M,N) and NB is the optimum block size.
+*
+* If LWORK = -1, then a workspace query is assumed; the routine
+* only calculates the optimal size of the WORK array, returns
+* this value as the first entry of the WORK array, and no error
+* message related to LWORK is issued by XERBLA.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* > 0: if INFO = i, the i-th diagonal element of the
+* triangular factor of A is zero, so that A does not have
+* full rank; the least squares solution could not be
+* computed.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL LQUERY, TPSD
+ INTEGER BROW, I, IASCL, IBSCL, J, MN, NB, SCLLEN, WSIZE
+ DOUBLE PRECISION ANRM, BIGNUM, BNRM, SMLNUM
+* ..
+* .. Local Arrays ..
+ DOUBLE PRECISION RWORK( 1 )
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ILAENV
+ DOUBLE PRECISION DLAMCH, DLANGE
+ EXTERNAL LSAME, ILAENV, DLABAD, DLAMCH, DLANGE
+* ..
+* .. External Subroutines ..
+ EXTERNAL DGELQF, DGEQRF, DLASCL, DLASET, DORMLQ, DORMQR,
+ $ DTRTRS, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC DBLE, MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+* Test the input arguments.
+*
+ INFO = 0
+ MN = MIN( M, N )
+ LQUERY = ( LWORK.EQ.-1 )
+ IF( .NOT.( LSAME( TRANS, 'N' ) .OR. LSAME( TRANS, 'T' ) ) ) THEN
+ INFO = -1
+ ELSE IF( M.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( NRHS.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+ INFO = -6
+ ELSE IF( LDB.LT.MAX( 1, M, N ) ) THEN
+ INFO = -8
+ ELSE IF( LWORK.LT.MAX( 1, MN+MAX( MN, NRHS ) ) .AND. .NOT.LQUERY )
+ $ THEN
+ INFO = -10
+ END IF
+*
+* Figure out optimal block size
+*
+ IF( INFO.EQ.0 .OR. INFO.EQ.-10 ) THEN
+*
+ TPSD = .TRUE.
+ IF( LSAME( TRANS, 'N' ) )
+ $ TPSD = .FALSE.
+*
+ IF( M.GE.N ) THEN
+ NB = ILAENV( 1, 'DGEQRF', ' ', M, N, -1, -1 )
+ IF( TPSD ) THEN
+ NB = MAX( NB, ILAENV( 1, 'DORMQR', 'LN', M, NRHS, N,
+ $ -1 ) )
+ ELSE
+ NB = MAX( NB, ILAENV( 1, 'DORMQR', 'LT', M, NRHS, N,
+ $ -1 ) )
+ END IF
+ ELSE
+ NB = ILAENV( 1, 'DGELQF', ' ', M, N, -1, -1 )
+ IF( TPSD ) THEN
+ NB = MAX( NB, ILAENV( 1, 'DORMLQ', 'LT', N, NRHS, M,
+ $ -1 ) )
+ ELSE
+ NB = MAX( NB, ILAENV( 1, 'DORMLQ', 'LN', N, NRHS, M,
+ $ -1 ) )
+ END IF
+ END IF
+*
+ WSIZE = MAX( 1, MN+MAX( MN, NRHS )*NB )
+ WORK( 1 ) = DBLE( WSIZE )
+*
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DGELS ', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( MIN( M, N, NRHS ).EQ.0 ) THEN
+ CALL DLASET( 'Full', MAX( M, N ), NRHS, ZERO, ZERO, B, LDB )
+ RETURN
+ END IF
+*
+* Get machine parameters
+*
+ SMLNUM = DLAMCH( 'S' ) / DLAMCH( 'P' )
+ BIGNUM = ONE / SMLNUM
+ CALL DLABAD( SMLNUM, BIGNUM )
+*
+* Scale A, B if max element outside range [SMLNUM,BIGNUM]
+*
+ ANRM = DLANGE( 'M', M, N, A, LDA, RWORK )
+ IASCL = 0
+ IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
+*
+* Scale matrix norm up to SMLNUM
+*
+ CALL DLASCL( 'G', 0, 0, ANRM, SMLNUM, M, N, A, LDA, INFO )
+ IASCL = 1
+ ELSE IF( ANRM.GT.BIGNUM ) THEN
+*
+* Scale matrix norm down to BIGNUM
+*
+ CALL DLASCL( 'G', 0, 0, ANRM, BIGNUM, M, N, A, LDA, INFO )
+ IASCL = 2
+ ELSE IF( ANRM.EQ.ZERO ) THEN
+*
+* Matrix all zero. Return zero solution.
+*
+ CALL DLASET( 'F', MAX( M, N ), NRHS, ZERO, ZERO, B, LDB )
+ GO TO 50
+ END IF
+*
+ BROW = M
+ IF( TPSD )
+ $ BROW = N
+ BNRM = DLANGE( 'M', BROW, NRHS, B, LDB, RWORK )
+ IBSCL = 0
+ IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN
+*
+* Scale matrix norm up to SMLNUM
+*
+ CALL DLASCL( 'G', 0, 0, BNRM, SMLNUM, BROW, NRHS, B, LDB,
+ $ INFO )
+ IBSCL = 1
+ ELSE IF( BNRM.GT.BIGNUM ) THEN
+*
+* Scale matrix norm down to BIGNUM
+*
+ CALL DLASCL( 'G', 0, 0, BNRM, BIGNUM, BROW, NRHS, B, LDB,
+ $ INFO )
+ IBSCL = 2
+ END IF
+*
+ IF( M.GE.N ) THEN
+*
+* compute QR factorization of A
+*
+ CALL DGEQRF( M, N, A, LDA, WORK( 1 ), WORK( MN+1 ), LWORK-MN,
+ $ INFO )
+*
+* workspace at least N, optimally N*NB
+*
+ IF( .NOT.TPSD ) THEN
+*
+* Least-Squares Problem min || A * X - B ||
+*
+* B(1:M,1:NRHS) := Q' * B(1:M,1:NRHS)
+*
+ CALL DORMQR( 'Left', 'Transpose', M, NRHS, N, A, LDA,
+ $ WORK( 1 ), B, LDB, WORK( MN+1 ), LWORK-MN,
+ $ INFO )
+*
+* workspace at least NRHS, optimally NRHS*NB
+*
+* B(1:N,1:NRHS) := inv(R) * B(1:N,1:NRHS)
+*
+ CALL DTRTRS( 'Upper', 'No transpose', 'Non-unit', N, NRHS,
+ $ A, LDA, B, LDB, INFO )
+*
+ IF( INFO.GT.0 ) THEN
+ RETURN
+ END IF
+*
+ SCLLEN = N
+*
+ ELSE
+*
+* Overdetermined system of equations A' * X = B
+*
+* B(1:N,1:NRHS) := inv(R') * B(1:N,1:NRHS)
+*
+ CALL DTRTRS( 'Upper', 'Transpose', 'Non-unit', N, NRHS,
+ $ A, LDA, B, LDB, INFO )
+*
+ IF( INFO.GT.0 ) THEN
+ RETURN
+ END IF
+*
+* B(N+1:M,1:NRHS) = ZERO
+*
+ DO 20 J = 1, NRHS
+ DO 10 I = N + 1, M
+ B( I, J ) = ZERO
+ 10 CONTINUE
+ 20 CONTINUE
+*
+* B(1:M,1:NRHS) := Q(1:N,:) * B(1:N,1:NRHS)
+*
+ CALL DORMQR( 'Left', 'No transpose', M, NRHS, N, A, LDA,
+ $ WORK( 1 ), B, LDB, WORK( MN+1 ), LWORK-MN,
+ $ INFO )
+*
+* workspace at least NRHS, optimally NRHS*NB
+*
+ SCLLEN = M
+*
+ END IF
+*
+ ELSE
+*
+* Compute LQ factorization of A
+*
+ CALL DGELQF( M, N, A, LDA, WORK( 1 ), WORK( MN+1 ), LWORK-MN,
+ $ INFO )
+*
+* workspace at least M, optimally M*NB.
+*
+ IF( .NOT.TPSD ) THEN
+*
+* underdetermined system of equations A * X = B
+*
+* B(1:M,1:NRHS) := inv(L) * B(1:M,1:NRHS)
+*
+ CALL DTRTRS( 'Lower', 'No transpose', 'Non-unit', M, NRHS,
+ $ A, LDA, B, LDB, INFO )
+*
+ IF( INFO.GT.0 ) THEN
+ RETURN
+ END IF
+*
+* B(M+1:N,1:NRHS) = 0
+*
+ DO 40 J = 1, NRHS
+ DO 30 I = M + 1, N
+ B( I, J ) = ZERO
+ 30 CONTINUE
+ 40 CONTINUE
+*
+* B(1:N,1:NRHS) := Q(1:N,:)' * B(1:M,1:NRHS)
+*
+ CALL DORMLQ( 'Left', 'Transpose', N, NRHS, M, A, LDA,
+ $ WORK( 1 ), B, LDB, WORK( MN+1 ), LWORK-MN,
+ $ INFO )
+*
+* workspace at least NRHS, optimally NRHS*NB
+*
+ SCLLEN = N
+*
+ ELSE
+*
+* overdetermined system min || A' * X - B ||
+*
+* B(1:N,1:NRHS) := Q * B(1:N,1:NRHS)
+*
+ CALL DORMLQ( 'Left', 'No transpose', N, NRHS, M, A, LDA,
+ $ WORK( 1 ), B, LDB, WORK( MN+1 ), LWORK-MN,
+ $ INFO )
+*
+* workspace at least NRHS, optimally NRHS*NB
+*
+* B(1:M,1:NRHS) := inv(L') * B(1:M,1:NRHS)
+*
+ CALL DTRTRS( 'Lower', 'Transpose', 'Non-unit', M, NRHS,
+ $ A, LDA, B, LDB, INFO )
+*
+ IF( INFO.GT.0 ) THEN
+ RETURN
+ END IF
+*
+ SCLLEN = M
+*
+ END IF
+*
+ END IF
+*
+* Undo scaling
+*
+ IF( IASCL.EQ.1 ) THEN
+ CALL DLASCL( 'G', 0, 0, ANRM, SMLNUM, SCLLEN, NRHS, B, LDB,
+ $ INFO )
+ ELSE IF( IASCL.EQ.2 ) THEN
+ CALL DLASCL( 'G', 0, 0, ANRM, BIGNUM, SCLLEN, NRHS, B, LDB,
+ $ INFO )
+ END IF
+ IF( IBSCL.EQ.1 ) THEN
+ CALL DLASCL( 'G', 0, 0, SMLNUM, BNRM, SCLLEN, NRHS, B, LDB,
+ $ INFO )
+ ELSE IF( IBSCL.EQ.2 ) THEN
+ CALL DLASCL( 'G', 0, 0, BIGNUM, BNRM, SCLLEN, NRHS, B, LDB,
+ $ INFO )
+ END IF
+*
+ 50 CONTINUE
+ WORK( 1 ) = DBLE( WSIZE )
+*
+ RETURN
+*
+* End of DGELS
+*
+ END
+ SUBROUTINE DGELSD( M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK,
+ $ WORK, LWORK, IWORK, INFO )
+*
+* -- LAPACK driver routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS, RANK
+ DOUBLE PRECISION RCOND
+* ..
+* .. Array Arguments ..
+ INTEGER IWORK( * )
+ DOUBLE PRECISION A( LDA, * ), B( LDB, * ), S( * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DGELSD computes the minimum-norm solution to a real linear least
+* squares problem:
+* minimize 2-norm(| b - A*x |)
+* using the singular value decomposition (SVD) of A. A is an M-by-N
+* matrix which may be rank-deficient.
+*
+* Several right hand side vectors b and solution vectors x can be
+* handled in a single call; they are stored as the columns of the
+* M-by-NRHS right hand side matrix B and the N-by-NRHS solution
+* matrix X.
+*
+* The problem is solved in three steps:
+* (1) Reduce the coefficient matrix A to bidiagonal form with
+* Householder transformations, reducing the original problem
+* into a "bidiagonal least squares problem" (BLS)
+* (2) Solve the BLS using a divide and conquer approach.
+* (3) Apply back all the Householder tranformations to solve
+* the original least squares problem.
+*
+* The effective rank of A is determined by treating as zero those
+* singular values which are less than RCOND times the largest singular
+* value.
+*
+* The divide and conquer algorithm makes very mild assumptions about
+* floating point arithmetic. It will work on machines with a guard
+* digit in add/subtract, or on those binary machines without guard
+* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
+* Cray-2. It could conceivably fail on hexadecimal or decimal machines
+* without guard digits, but we know of none.
+*
+* Arguments
+* =========
+*
+* M (input) INTEGER
+* The number of rows of A. M >= 0.
+*
+* N (input) INTEGER
+* The number of columns of A. N >= 0.
+*
+* NRHS (input) INTEGER
+* The number of right hand sides, i.e., the number of columns
+* of the matrices B and X. NRHS >= 0.
+*
+* A (input) DOUBLE PRECISION array, dimension (LDA,N)
+* On entry, the M-by-N matrix A.
+* On exit, A has been destroyed.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,M).
+*
+* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
+* On entry, the M-by-NRHS right hand side matrix B.
+* On exit, B is overwritten by the N-by-NRHS solution
+* matrix X. If m >= n and RANK = n, the residual
+* sum-of-squares for the solution in the i-th column is given
+* by the sum of squares of elements n+1:m in that column.
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. LDB >= max(1,max(M,N)).
+*
+* S (output) DOUBLE PRECISION array, dimension (min(M,N))
+* The singular values of A in decreasing order.
+* The condition number of A in the 2-norm = S(1)/S(min(m,n)).
+*
+* RCOND (input) DOUBLE PRECISION
+* RCOND is used to determine the effective rank of A.
+* Singular values S(i) <= RCOND*S(1) are treated as zero.
+* If RCOND < 0, machine precision is used instead.
+*
+* RANK (output) INTEGER
+* The effective rank of A, i.e., the number of singular values
+* which are greater than RCOND*S(1).
+*
+* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
+* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+* LWORK (input) INTEGER
+* The dimension of the array WORK. LWORK must be at least 1.
+* The exact minimum amount of workspace needed depends on M,
+* N and NRHS. As long as LWORK is at least
+* 12*N + 2*N*SMLSIZ + 8*N*NLVL + N*NRHS + (SMLSIZ+1)**2,
+* if M is greater than or equal to N or
+* 12*M + 2*M*SMLSIZ + 8*M*NLVL + M*NRHS + (SMLSIZ+1)**2,
+* if M is less than N, the code will execute correctly.
+* SMLSIZ is returned by ILAENV and is equal to the maximum
+* size of the subproblems at the bottom of the computation
+* tree (usually about 25), and
+* NLVL = MAX( 0, INT( LOG_2( MIN( M,N )/(SMLSIZ+1) ) ) + 1 )
+* For good performance, LWORK should generally be larger.
+*
+* If LWORK = -1, then a workspace query is assumed; the routine
+* only calculates the optimal size of the WORK array, returns
+* this value as the first entry of the WORK array, and no error
+* message related to LWORK is issued by XERBLA.
+*
+* IWORK (workspace) INTEGER array, dimension (MAX(1,LIWORK))
+* LIWORK >= 3 * MINMN * NLVL + 11 * MINMN,
+* where MINMN = MIN( M,N ).
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value.
+* > 0: the algorithm for computing the SVD failed to converge;
+* if INFO = i, i off-diagonal elements of an intermediate
+* bidiagonal form did not converge to zero.
+*
+* Further Details
+* ===============
+*
+* Based on contributions by
+* Ming Gu and Ren-Cang Li, Computer Science Division, University of
+* California at Berkeley, USA
+* Osni Marques, LBNL/NERSC, USA
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE, TWO
+ PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL LQUERY
+ INTEGER IASCL, IBSCL, IE, IL, ITAU, ITAUP, ITAUQ,
+ $ LDWORK, MAXMN, MAXWRK, MINMN, MINWRK, MM,
+ $ MNTHR, NLVL, NWORK, SMLSIZ, WLALSD
+ DOUBLE PRECISION ANRM, BIGNUM, BNRM, EPS, SFMIN, SMLNUM
+* ..
+* .. External Subroutines ..
+ EXTERNAL DGEBRD, DGELQF, DGEQRF, DLABAD, DLACPY, DLALSD,
+ $ DLASCL, DLASET, DORMBR, DORMLQ, DORMQR, XERBLA
+* ..
+* .. External Functions ..
+ INTEGER ILAENV
+ DOUBLE PRECISION DLAMCH, DLANGE
+ EXTERNAL ILAENV, DLAMCH, DLANGE
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC DBLE, INT, LOG, MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+* Test the input arguments.
+*
+ INFO = 0
+ MINMN = MIN( M, N )
+ MAXMN = MAX( M, N )
+ MNTHR = ILAENV( 6, 'DGELSD', ' ', M, N, NRHS, -1 )
+ LQUERY = ( LWORK.EQ.-1 )
+ IF( M.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( NRHS.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+ INFO = -5
+ ELSE IF( LDB.LT.MAX( 1, MAXMN ) ) THEN
+ INFO = -7
+ END IF
+*
+ SMLSIZ = ILAENV( 9, 'DGELSD', ' ', 0, 0, 0, 0 )
+*
+* Compute workspace.
+* (Note: Comments in the code beginning "Workspace:" describe the
+* minimal amount of workspace needed at that point in the code,
+* as well as the preferred amount for good performance.
+* NB refers to the optimal block size for the immediately
+* following subroutine, as returned by ILAENV.)
+*
+ MINWRK = 1
+ MINMN = MAX( 1, MINMN )
+ NLVL = MAX( INT( LOG( DBLE( MINMN ) / DBLE( SMLSIZ+1 ) ) /
+ $ LOG( TWO ) ) + 1, 0 )
+*
+ IF( INFO.EQ.0 ) THEN
+ MAXWRK = 0
+ MM = M
+ IF( M.GE.N .AND. M.GE.MNTHR ) THEN
+*
+* Path 1a - overdetermined, with many more rows than columns.
+*
+ MM = N
+ MAXWRK = MAX( MAXWRK, N+N*ILAENV( 1, 'DGEQRF', ' ', M, N,
+ $ -1, -1 ) )
+ MAXWRK = MAX( MAXWRK, N+NRHS*
+ $ ILAENV( 1, 'DORMQR', 'LT', M, NRHS, N, -1 ) )
+ END IF
+ IF( M.GE.N ) THEN
+*
+* Path 1 - overdetermined or exactly determined.
+*
+ MAXWRK = MAX( MAXWRK, 3*N+( MM+N )*
+ $ ILAENV( 1, 'DGEBRD', ' ', MM, N, -1, -1 ) )
+ MAXWRK = MAX( MAXWRK, 3*N+NRHS*
+ $ ILAENV( 1, 'DORMBR', 'QLT', MM, NRHS, N, -1 ) )
+ MAXWRK = MAX( MAXWRK, 3*N+( N-1 )*
+ $ ILAENV( 1, 'DORMBR', 'PLN', N, NRHS, N, -1 ) )
+ WLALSD = 9*N+2*N*SMLSIZ+8*N*NLVL+N*NRHS+(SMLSIZ+1)**2
+ MAXWRK = MAX( MAXWRK, 3*N+WLALSD )
+ MINWRK = MAX( 3*N+MM, 3*N+NRHS, 3*N+WLALSD )
+ END IF
+ IF( N.GT.M ) THEN
+ WLALSD = 9*M+2*M*SMLSIZ+8*M*NLVL+M*NRHS+(SMLSIZ+1)**2
+ IF( N.GE.MNTHR ) THEN
+*
+* Path 2a - underdetermined, with many more columns
+* than rows.
+*
+ MAXWRK = M + M*ILAENV( 1, 'DGELQF', ' ', M, N, -1, -1 )
+ MAXWRK = MAX( MAXWRK, M*M+4*M+2*M*
+ $ ILAENV( 1, 'DGEBRD', ' ', M, M, -1, -1 ) )
+ MAXWRK = MAX( MAXWRK, M*M+4*M+NRHS*
+ $ ILAENV( 1, 'DORMBR', 'QLT', M, NRHS, M, -1 ) )
+ MAXWRK = MAX( MAXWRK, M*M+4*M+( M-1 )*
+ $ ILAENV( 1, 'DORMBR', 'PLN', M, NRHS, M, -1 ) )
+ IF( NRHS.GT.1 ) THEN
+ MAXWRK = MAX( MAXWRK, M*M+M+M*NRHS )
+ ELSE
+ MAXWRK = MAX( MAXWRK, M*M+2*M )
+ END IF
+ MAXWRK = MAX( MAXWRK, M+NRHS*
+ $ ILAENV( 1, 'DORMLQ', 'LT', N, NRHS, M, -1 ) )
+ MAXWRK = MAX( MAXWRK, M*M+4*M+WLALSD )
+ ELSE
+*
+* Path 2 - remaining underdetermined cases.
+*
+ MAXWRK = 3*M + ( N+M )*ILAENV( 1, 'DGEBRD', ' ', M, N,
+ $ -1, -1 )
+ MAXWRK = MAX( MAXWRK, 3*M+NRHS*
+ $ ILAENV( 1, 'DORMBR', 'QLT', M, NRHS, N, -1 ) )
+ MAXWRK = MAX( MAXWRK, 3*M+M*
+ $ ILAENV( 1, 'DORMBR', 'PLN', N, NRHS, M, -1 ) )
+ MAXWRK = MAX( MAXWRK, 3*M+WLALSD )
+ END IF
+ MINWRK = MAX( 3*M+NRHS, 3*M+M, 3*M+WLALSD )
+ END IF
+ MINWRK = MIN( MINWRK, MAXWRK )
+ WORK( 1 ) = MAXWRK
+ IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN
+ INFO = -12
+ END IF
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DGELSD', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ GO TO 10
+ END IF
+*
+* Quick return if possible.
+*
+ IF( M.EQ.0 .OR. N.EQ.0 ) THEN
+ RANK = 0
+ RETURN
+ END IF
+*
+* Get machine parameters.
+*
+ EPS = DLAMCH( 'P' )
+ SFMIN = DLAMCH( 'S' )
+ SMLNUM = SFMIN / EPS
+ BIGNUM = ONE / SMLNUM
+ CALL DLABAD( SMLNUM, BIGNUM )
+*
+* Scale A if max entry outside range [SMLNUM,BIGNUM].
+*
+ ANRM = DLANGE( 'M', M, N, A, LDA, WORK )
+ IASCL = 0
+ IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
+*
+* Scale matrix norm up to SMLNUM.
+*
+ CALL DLASCL( 'G', 0, 0, ANRM, SMLNUM, M, N, A, LDA, INFO )
+ IASCL = 1
+ ELSE IF( ANRM.GT.BIGNUM ) THEN
+*
+* Scale matrix norm down to BIGNUM.
+*
+ CALL DLASCL( 'G', 0, 0, ANRM, BIGNUM, M, N, A, LDA, INFO )
+ IASCL = 2
+ ELSE IF( ANRM.EQ.ZERO ) THEN
+*
+* Matrix all zero. Return zero solution.
+*
+ CALL DLASET( 'F', MAX( M, N ), NRHS, ZERO, ZERO, B, LDB )
+ CALL DLASET( 'F', MINMN, 1, ZERO, ZERO, S, 1 )
+ RANK = 0
+ GO TO 10
+ END IF
+*
+* Scale B if max entry outside range [SMLNUM,BIGNUM].
+*
+ BNRM = DLANGE( 'M', M, NRHS, B, LDB, WORK )
+ IBSCL = 0
+ IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN
+*
+* Scale matrix norm up to SMLNUM.
+*
+ CALL DLASCL( 'G', 0, 0, BNRM, SMLNUM, M, NRHS, B, LDB, INFO )
+ IBSCL = 1
+ ELSE IF( BNRM.GT.BIGNUM ) THEN
+*
+* Scale matrix norm down to BIGNUM.
+*
+ CALL DLASCL( 'G', 0, 0, BNRM, BIGNUM, M, NRHS, B, LDB, INFO )
+ IBSCL = 2
+ END IF
+*
+* If M < N make sure certain entries of B are zero.
+*
+ IF( M.LT.N )
+ $ CALL DLASET( 'F', N-M, NRHS, ZERO, ZERO, B( M+1, 1 ), LDB )
+*
+* Overdetermined case.
+*
+ IF( M.GE.N ) THEN
+*
+* Path 1 - overdetermined or exactly determined.
+*
+ MM = M
+ IF( M.GE.MNTHR ) THEN
+*
+* Path 1a - overdetermined, with many more rows than columns.
+*
+ MM = N
+ ITAU = 1
+ NWORK = ITAU + N
+*
+* Compute A=Q*R.
+* (Workspace: need 2*N, prefer N+N*NB)
+*
+ CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ),
+ $ LWORK-NWORK+1, INFO )
+*
+* Multiply B by transpose(Q).
+* (Workspace: need N+NRHS, prefer N+NRHS*NB)
+*
+ CALL DORMQR( 'L', 'T', M, NRHS, N, A, LDA, WORK( ITAU ), B,
+ $ LDB, WORK( NWORK ), LWORK-NWORK+1, INFO )
+*
+* Zero out below R.
+*
+ IF( N.GT.1 ) THEN
+ CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, A( 2, 1 ), LDA )
+ END IF
+ END IF
+*
+ IE = 1
+ ITAUQ = IE + N
+ ITAUP = ITAUQ + N
+ NWORK = ITAUP + N
+*
+* Bidiagonalize R in A.
+* (Workspace: need 3*N+MM, prefer 3*N+(MM+N)*NB)
+*
+ CALL DGEBRD( MM, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ),
+ $ WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1,
+ $ INFO )
+*
+* Multiply B by transpose of left bidiagonalizing vectors of R.
+* (Workspace: need 3*N+NRHS, prefer 3*N+NRHS*NB)
+*
+ CALL DORMBR( 'Q', 'L', 'T', MM, NRHS, N, A, LDA, WORK( ITAUQ ),
+ $ B, LDB, WORK( NWORK ), LWORK-NWORK+1, INFO )
+*
+* Solve the bidiagonal least squares problem.
+*
+ CALL DLALSD( 'U', SMLSIZ, N, NRHS, S, WORK( IE ), B, LDB,
+ $ RCOND, RANK, WORK( NWORK ), IWORK, INFO )
+ IF( INFO.NE.0 ) THEN
+ GO TO 10
+ END IF
+*
+* Multiply B by right bidiagonalizing vectors of R.
+*
+ CALL DORMBR( 'P', 'L', 'N', N, NRHS, N, A, LDA, WORK( ITAUP ),
+ $ B, LDB, WORK( NWORK ), LWORK-NWORK+1, INFO )
+*
+ ELSE IF( N.GE.MNTHR .AND. LWORK.GE.4*M+M*M+
+ $ MAX( M, 2*M-4, NRHS, N-3*M, WLALSD ) ) THEN
+*
+* Path 2a - underdetermined, with many more columns than rows
+* and sufficient workspace for an efficient algorithm.
+*
+ LDWORK = M
+ IF( LWORK.GE.MAX( 4*M+M*LDA+MAX( M, 2*M-4, NRHS, N-3*M ),
+ $ M*LDA+M+M*NRHS, 4*M+M*LDA+WLALSD ) )LDWORK = LDA
+ ITAU = 1
+ NWORK = M + 1
+*
+* Compute A=L*Q.
+* (Workspace: need 2*M, prefer M+M*NB)
+*
+ CALL DGELQF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ),
+ $ LWORK-NWORK+1, INFO )
+ IL = NWORK
+*
+* Copy L to WORK(IL), zeroing out above its diagonal.
+*
+ CALL DLACPY( 'L', M, M, A, LDA, WORK( IL ), LDWORK )
+ CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, WORK( IL+LDWORK ),
+ $ LDWORK )
+ IE = IL + LDWORK*M
+ ITAUQ = IE + M
+ ITAUP = ITAUQ + M
+ NWORK = ITAUP + M
+*
+* Bidiagonalize L in WORK(IL).
+* (Workspace: need M*M+5*M, prefer M*M+4*M+2*M*NB)
+*
+ CALL DGEBRD( M, M, WORK( IL ), LDWORK, S, WORK( IE ),
+ $ WORK( ITAUQ ), WORK( ITAUP ), WORK( NWORK ),
+ $ LWORK-NWORK+1, INFO )
+*
+* Multiply B by transpose of left bidiagonalizing vectors of L.
+* (Workspace: need M*M+4*M+NRHS, prefer M*M+4*M+NRHS*NB)
+*
+ CALL DORMBR( 'Q', 'L', 'T', M, NRHS, M, WORK( IL ), LDWORK,
+ $ WORK( ITAUQ ), B, LDB, WORK( NWORK ),
+ $ LWORK-NWORK+1, INFO )
+*
+* Solve the bidiagonal least squares problem.
+*
+ CALL DLALSD( 'U', SMLSIZ, M, NRHS, S, WORK( IE ), B, LDB,
+ $ RCOND, RANK, WORK( NWORK ), IWORK, INFO )
+ IF( INFO.NE.0 ) THEN
+ GO TO 10
+ END IF
+*
+* Multiply B by right bidiagonalizing vectors of L.
+*
+ CALL DORMBR( 'P', 'L', 'N', M, NRHS, M, WORK( IL ), LDWORK,
+ $ WORK( ITAUP ), B, LDB, WORK( NWORK ),
+ $ LWORK-NWORK+1, INFO )
+*
+* Zero out below first M rows of B.
+*
+ CALL DLASET( 'F', N-M, NRHS, ZERO, ZERO, B( M+1, 1 ), LDB )
+ NWORK = ITAU + M
+*
+* Multiply transpose(Q) by B.
+* (Workspace: need M+NRHS, prefer M+NRHS*NB)
+*
+ CALL DORMLQ( 'L', 'T', N, NRHS, M, A, LDA, WORK( ITAU ), B,
+ $ LDB, WORK( NWORK ), LWORK-NWORK+1, INFO )
+*
+ ELSE
+*
+* Path 2 - remaining underdetermined cases.
+*
+ IE = 1
+ ITAUQ = IE + M
+ ITAUP = ITAUQ + M
+ NWORK = ITAUP + M
+*
+* Bidiagonalize A.
+* (Workspace: need 3*M+N, prefer 3*M+(M+N)*NB)
+*
+ CALL DGEBRD( M, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ),
+ $ WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1,
+ $ INFO )
+*
+* Multiply B by transpose of left bidiagonalizing vectors.
+* (Workspace: need 3*M+NRHS, prefer 3*M+NRHS*NB)
+*
+ CALL DORMBR( 'Q', 'L', 'T', M, NRHS, N, A, LDA, WORK( ITAUQ ),
+ $ B, LDB, WORK( NWORK ), LWORK-NWORK+1, INFO )
+*
+* Solve the bidiagonal least squares problem.
+*
+ CALL DLALSD( 'L', SMLSIZ, M, NRHS, S, WORK( IE ), B, LDB,
+ $ RCOND, RANK, WORK( NWORK ), IWORK, INFO )
+ IF( INFO.NE.0 ) THEN
+ GO TO 10
+ END IF
+*
+* Multiply B by right bidiagonalizing vectors of A.
+*
+ CALL DORMBR( 'P', 'L', 'N', N, NRHS, M, A, LDA, WORK( ITAUP ),
+ $ B, LDB, WORK( NWORK ), LWORK-NWORK+1, INFO )
+*
+ END IF
+*
+* Undo scaling.
+*
+ IF( IASCL.EQ.1 ) THEN
+ CALL DLASCL( 'G', 0, 0, ANRM, SMLNUM, N, NRHS, B, LDB, INFO )
+ CALL DLASCL( 'G', 0, 0, SMLNUM, ANRM, MINMN, 1, S, MINMN,
+ $ INFO )
+ ELSE IF( IASCL.EQ.2 ) THEN
+ CALL DLASCL( 'G', 0, 0, ANRM, BIGNUM, N, NRHS, B, LDB, INFO )
+ CALL DLASCL( 'G', 0, 0, BIGNUM, ANRM, MINMN, 1, S, MINMN,
+ $ INFO )
+ END IF
+ IF( IBSCL.EQ.1 ) THEN
+ CALL DLASCL( 'G', 0, 0, SMLNUM, BNRM, N, NRHS, B, LDB, INFO )
+ ELSE IF( IBSCL.EQ.2 ) THEN
+ CALL DLASCL( 'G', 0, 0, BIGNUM, BNRM, N, NRHS, B, LDB, INFO )
+ END IF
+*
+ 10 CONTINUE
+ WORK( 1 ) = MAXWRK
+ RETURN
+*
+* End of DGELSD
+*
+ END
+ SUBROUTINE DGELSS( M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK,
+ $ WORK, LWORK, INFO )
+*
+* -- LAPACK driver routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS, RANK
+ DOUBLE PRECISION RCOND
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION A( LDA, * ), B( LDB, * ), S( * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DGELSS computes the minimum norm solution to a real linear least
+* squares problem:
+*
+* Minimize 2-norm(| b - A*x |).
+*
+* using the singular value decomposition (SVD) of A. A is an M-by-N
+* matrix which may be rank-deficient.
+*
+* Several right hand side vectors b and solution vectors x can be
+* handled in a single call; they are stored as the columns of the
+* M-by-NRHS right hand side matrix B and the N-by-NRHS solution matrix
+* X.
+*
+* The effective rank of A is determined by treating as zero those
+* singular values which are less than RCOND times the largest singular
+* value.
+*
+* Arguments
+* =========
+*
+* M (input) INTEGER
+* The number of rows of the matrix A. M >= 0.
+*
+* N (input) INTEGER
+* The number of columns of the matrix A. N >= 0.
+*
+* NRHS (input) INTEGER
+* The number of right hand sides, i.e., the number of columns
+* of the matrices B and X. NRHS >= 0.
+*
+* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+* On entry, the M-by-N matrix A.
+* On exit, the first min(m,n) rows of A are overwritten with
+* its right singular vectors, stored rowwise.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,M).
+*
+* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
+* On entry, the M-by-NRHS right hand side matrix B.
+* On exit, B is overwritten by the N-by-NRHS solution
+* matrix X. If m >= n and RANK = n, the residual
+* sum-of-squares for the solution in the i-th column is given
+* by the sum of squares of elements n+1:m in that column.
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. LDB >= max(1,max(M,N)).
+*
+* S (output) DOUBLE PRECISION array, dimension (min(M,N))
+* The singular values of A in decreasing order.
+* The condition number of A in the 2-norm = S(1)/S(min(m,n)).
+*
+* RCOND (input) DOUBLE PRECISION
+* RCOND is used to determine the effective rank of A.
+* Singular values S(i) <= RCOND*S(1) are treated as zero.
+* If RCOND < 0, machine precision is used instead.
+*
+* RANK (output) INTEGER
+* The effective rank of A, i.e., the number of singular values
+* which are greater than RCOND*S(1).
+*
+* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
+* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+* LWORK (input) INTEGER
+* The dimension of the array WORK. LWORK >= 1, and also:
+* LWORK >= 3*min(M,N) + max( 2*min(M,N), max(M,N), NRHS )
+* For good performance, LWORK should generally be larger.
+*
+* If LWORK = -1, then a workspace query is assumed; the routine
+* only calculates the optimal size of the WORK array, returns
+* this value as the first entry of the WORK array, and no error
+* message related to LWORK is issued by XERBLA.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value.
+* > 0: the algorithm for computing the SVD failed to converge;
+* if INFO = i, i off-diagonal elements of an intermediate
+* bidiagonal form did not converge to zero.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL LQUERY
+ INTEGER BDSPAC, BL, CHUNK, I, IASCL, IBSCL, IE, IL,
+ $ ITAU, ITAUP, ITAUQ, IWORK, LDWORK, MAXMN,
+ $ MAXWRK, MINMN, MINWRK, MM, MNTHR
+ DOUBLE PRECISION ANRM, BIGNUM, BNRM, EPS, SFMIN, SMLNUM, THR
+* ..
+* .. Local Arrays ..
+ DOUBLE PRECISION VDUM( 1 )
+* ..
+* .. External Subroutines ..
+ EXTERNAL DBDSQR, DCOPY, DGEBRD, DGELQF, DGEMM, DGEMV,
+ $ DGEQRF, DLABAD, DLACPY, DLASCL, DLASET, DORGBR,
+ $ DORMBR, DORMLQ, DORMQR, DRSCL, XERBLA
+* ..
+* .. External Functions ..
+ INTEGER ILAENV
+ DOUBLE PRECISION DLAMCH, DLANGE
+ EXTERNAL ILAENV, DLAMCH, DLANGE
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+* Test the input arguments
+*
+ INFO = 0
+ MINMN = MIN( M, N )
+ MAXMN = MAX( M, N )
+ LQUERY = ( LWORK.EQ.-1 )
+ IF( M.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( NRHS.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+ INFO = -5
+ ELSE IF( LDB.LT.MAX( 1, MAXMN ) ) THEN
+ INFO = -7
+ END IF
+*
+* Compute workspace
+* (Note: Comments in the code beginning "Workspace:" describe the
+* minimal amount of workspace needed at that point in the code,
+* as well as the preferred amount for good performance.
+* NB refers to the optimal block size for the immediately
+* following subroutine, as returned by ILAENV.)
+*
+ IF( INFO.EQ.0 ) THEN
+ MINWRK = 1
+ MAXWRK = 1
+ IF( MINMN.GT.0 ) THEN
+ MM = M
+ MNTHR = ILAENV( 6, 'DGELSS', ' ', M, N, NRHS, -1 )
+ IF( M.GE.N .AND. M.GE.MNTHR ) THEN
+*
+* Path 1a - overdetermined, with many more rows than
+* columns
+*
+ MM = N
+ MAXWRK = MAX( MAXWRK, N + N*ILAENV( 1, 'DGEQRF', ' ', M,
+ $ N, -1, -1 ) )
+ MAXWRK = MAX( MAXWRK, N + NRHS*ILAENV( 1, 'DORMQR', 'LT',
+ $ M, NRHS, N, -1 ) )
+ END IF
+ IF( M.GE.N ) THEN
+*
+* Path 1 - overdetermined or exactly determined
+*
+* Compute workspace needed for DBDSQR
+*
+ BDSPAC = MAX( 1, 5*N )
+ MAXWRK = MAX( MAXWRK, 3*N + ( MM + N )*ILAENV( 1,
+ $ 'DGEBRD', ' ', MM, N, -1, -1 ) )
+ MAXWRK = MAX( MAXWRK, 3*N + NRHS*ILAENV( 1, 'DORMBR',
+ $ 'QLT', MM, NRHS, N, -1 ) )
+ MAXWRK = MAX( MAXWRK, 3*N + ( N - 1 )*ILAENV( 1,
+ $ 'DORGBR', 'P', N, N, N, -1 ) )
+ MAXWRK = MAX( MAXWRK, BDSPAC )
+ MAXWRK = MAX( MAXWRK, N*NRHS )
+ MINWRK = MAX( 3*N + MM, 3*N + NRHS, BDSPAC )
+ MAXWRK = MAX( MINWRK, MAXWRK )
+ END IF
+ IF( N.GT.M ) THEN
+*
+* Compute workspace needed for DBDSQR
+*
+ BDSPAC = MAX( 1, 5*M )
+ MINWRK = MAX( 3*M+NRHS, 3*M+N, BDSPAC )
+ IF( N.GE.MNTHR ) THEN
+*
+* Path 2a - underdetermined, with many more columns
+* than rows
+*
+ MAXWRK = M + M*ILAENV( 1, 'DGELQF', ' ', M, N, -1,
+ $ -1 )
+ MAXWRK = MAX( MAXWRK, M*M + 4*M + 2*M*ILAENV( 1,
+ $ 'DGEBRD', ' ', M, M, -1, -1 ) )
+ MAXWRK = MAX( MAXWRK, M*M + 4*M + NRHS*ILAENV( 1,
+ $ 'DORMBR', 'QLT', M, NRHS, M, -1 ) )
+ MAXWRK = MAX( MAXWRK, M*M + 4*M +
+ $ ( M - 1 )*ILAENV( 1, 'DORGBR', 'P', M,
+ $ M, M, -1 ) )
+ MAXWRK = MAX( MAXWRK, M*M + M + BDSPAC )
+ IF( NRHS.GT.1 ) THEN
+ MAXWRK = MAX( MAXWRK, M*M + M + M*NRHS )
+ ELSE
+ MAXWRK = MAX( MAXWRK, M*M + 2*M )
+ END IF
+ MAXWRK = MAX( MAXWRK, M + NRHS*ILAENV( 1, 'DORMLQ',
+ $ 'LT', N, NRHS, M, -1 ) )
+ ELSE
+*
+* Path 2 - underdetermined
+*
+ MAXWRK = 3*M + ( N + M )*ILAENV( 1, 'DGEBRD', ' ', M,
+ $ N, -1, -1 )
+ MAXWRK = MAX( MAXWRK, 3*M + NRHS*ILAENV( 1, 'DORMBR',
+ $ 'QLT', M, NRHS, M, -1 ) )
+ MAXWRK = MAX( MAXWRK, 3*M + M*ILAENV( 1, 'DORGBR',
+ $ 'P', M, N, M, -1 ) )
+ MAXWRK = MAX( MAXWRK, BDSPAC )
+ MAXWRK = MAX( MAXWRK, N*NRHS )
+ END IF
+ END IF
+ MAXWRK = MAX( MINWRK, MAXWRK )
+ END IF
+ WORK( 1 ) = MAXWRK
+*
+ IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY )
+ $ INFO = -12
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DGELSS', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( M.EQ.0 .OR. N.EQ.0 ) THEN
+ RANK = 0
+ RETURN
+ END IF
+*
+* Get machine parameters
+*
+ EPS = DLAMCH( 'P' )
+ SFMIN = DLAMCH( 'S' )
+ SMLNUM = SFMIN / EPS
+ BIGNUM = ONE / SMLNUM
+ CALL DLABAD( SMLNUM, BIGNUM )
+*
+* Scale A if max element outside range [SMLNUM,BIGNUM]
+*
+ ANRM = DLANGE( 'M', M, N, A, LDA, WORK )
+ IASCL = 0
+ IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
+*
+* Scale matrix norm up to SMLNUM
+*
+ CALL DLASCL( 'G', 0, 0, ANRM, SMLNUM, M, N, A, LDA, INFO )
+ IASCL = 1
+ ELSE IF( ANRM.GT.BIGNUM ) THEN
+*
+* Scale matrix norm down to BIGNUM
+*
+ CALL DLASCL( 'G', 0, 0, ANRM, BIGNUM, M, N, A, LDA, INFO )
+ IASCL = 2
+ ELSE IF( ANRM.EQ.ZERO ) THEN
+*
+* Matrix all zero. Return zero solution.
+*
+ CALL DLASET( 'F', MAX( M, N ), NRHS, ZERO, ZERO, B, LDB )
+ CALL DLASET( 'F', MINMN, 1, ZERO, ZERO, S, 1 )
+ RANK = 0
+ GO TO 70
+ END IF
+*
+* Scale B if max element outside range [SMLNUM,BIGNUM]
+*
+ BNRM = DLANGE( 'M', M, NRHS, B, LDB, WORK )
+ IBSCL = 0
+ IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN
+*
+* Scale matrix norm up to SMLNUM
+*
+ CALL DLASCL( 'G', 0, 0, BNRM, SMLNUM, M, NRHS, B, LDB, INFO )
+ IBSCL = 1
+ ELSE IF( BNRM.GT.BIGNUM ) THEN
+*
+* Scale matrix norm down to BIGNUM
+*
+ CALL DLASCL( 'G', 0, 0, BNRM, BIGNUM, M, NRHS, B, LDB, INFO )
+ IBSCL = 2
+ END IF
+*
+* Overdetermined case
+*
+ IF( M.GE.N ) THEN
+*
+* Path 1 - overdetermined or exactly determined
+*
+ MM = M
+ IF( M.GE.MNTHR ) THEN
+*
+* Path 1a - overdetermined, with many more rows than columns
+*
+ MM = N
+ ITAU = 1
+ IWORK = ITAU + N
+*
+* Compute A=Q*R
+* (Workspace: need 2*N, prefer N+N*NB)
+*
+ CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), WORK( IWORK ),
+ $ LWORK-IWORK+1, INFO )
+*
+* Multiply B by transpose(Q)
+* (Workspace: need N+NRHS, prefer N+NRHS*NB)
+*
+ CALL DORMQR( 'L', 'T', M, NRHS, N, A, LDA, WORK( ITAU ), B,
+ $ LDB, WORK( IWORK ), LWORK-IWORK+1, INFO )
+*
+* Zero out below R
+*
+ IF( N.GT.1 )
+ $ CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, A( 2, 1 ), LDA )
+ END IF
+*
+ IE = 1
+ ITAUQ = IE + N
+ ITAUP = ITAUQ + N
+ IWORK = ITAUP + N
+*
+* Bidiagonalize R in A
+* (Workspace: need 3*N+MM, prefer 3*N+(MM+N)*NB)
+*
+ CALL DGEBRD( MM, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ),
+ $ WORK( ITAUP ), WORK( IWORK ), LWORK-IWORK+1,
+ $ INFO )
+*
+* Multiply B by transpose of left bidiagonalizing vectors of R
+* (Workspace: need 3*N+NRHS, prefer 3*N+NRHS*NB)
+*
+ CALL DORMBR( 'Q', 'L', 'T', MM, NRHS, N, A, LDA, WORK( ITAUQ ),
+ $ B, LDB, WORK( IWORK ), LWORK-IWORK+1, INFO )
+*
+* Generate right bidiagonalizing vectors of R in A
+* (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB)
+*
+ CALL DORGBR( 'P', N, N, N, A, LDA, WORK( ITAUP ),
+ $ WORK( IWORK ), LWORK-IWORK+1, INFO )
+ IWORK = IE + N
+*
+* Perform bidiagonal QR iteration
+* multiply B by transpose of left singular vectors
+* compute right singular vectors in A
+* (Workspace: need BDSPAC)
+*
+ CALL DBDSQR( 'U', N, N, 0, NRHS, S, WORK( IE ), A, LDA, VDUM,
+ $ 1, B, LDB, WORK( IWORK ), INFO )
+ IF( INFO.NE.0 )
+ $ GO TO 70
+*
+* Multiply B by reciprocals of singular values
+*
+ THR = MAX( RCOND*S( 1 ), SFMIN )
+ IF( RCOND.LT.ZERO )
+ $ THR = MAX( EPS*S( 1 ), SFMIN )
+ RANK = 0
+ DO 10 I = 1, N
+ IF( S( I ).GT.THR ) THEN
+ CALL DRSCL( NRHS, S( I ), B( I, 1 ), LDB )
+ RANK = RANK + 1
+ ELSE
+ CALL DLASET( 'F', 1, NRHS, ZERO, ZERO, B( I, 1 ), LDB )
+ END IF
+ 10 CONTINUE
+*
+* Multiply B by right singular vectors
+* (Workspace: need N, prefer N*NRHS)
+*
+ IF( LWORK.GE.LDB*NRHS .AND. NRHS.GT.1 ) THEN
+ CALL DGEMM( 'T', 'N', N, NRHS, N, ONE, A, LDA, B, LDB, ZERO,
+ $ WORK, LDB )
+ CALL DLACPY( 'G', N, NRHS, WORK, LDB, B, LDB )
+ ELSE IF( NRHS.GT.1 ) THEN
+ CHUNK = LWORK / N
+ DO 20 I = 1, NRHS, CHUNK
+ BL = MIN( NRHS-I+1, CHUNK )
+ CALL DGEMM( 'T', 'N', N, BL, N, ONE, A, LDA, B( 1, I ),
+ $ LDB, ZERO, WORK, N )
+ CALL DLACPY( 'G', N, BL, WORK, N, B( 1, I ), LDB )
+ 20 CONTINUE
+ ELSE
+ CALL DGEMV( 'T', N, N, ONE, A, LDA, B, 1, ZERO, WORK, 1 )
+ CALL DCOPY( N, WORK, 1, B, 1 )
+ END IF
+*
+ ELSE IF( N.GE.MNTHR .AND. LWORK.GE.4*M+M*M+
+ $ MAX( M, 2*M-4, NRHS, N-3*M ) ) THEN
+*
+* Path 2a - underdetermined, with many more columns than rows
+* and sufficient workspace for an efficient algorithm
+*
+ LDWORK = M
+ IF( LWORK.GE.MAX( 4*M+M*LDA+MAX( M, 2*M-4, NRHS, N-3*M ),
+ $ M*LDA+M+M*NRHS ) )LDWORK = LDA
+ ITAU = 1
+ IWORK = M + 1
+*
+* Compute A=L*Q
+* (Workspace: need 2*M, prefer M+M*NB)
+*
+ CALL DGELQF( M, N, A, LDA, WORK( ITAU ), WORK( IWORK ),
+ $ LWORK-IWORK+1, INFO )
+ IL = IWORK
+*
+* Copy L to WORK(IL), zeroing out above it
+*
+ CALL DLACPY( 'L', M, M, A, LDA, WORK( IL ), LDWORK )
+ CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, WORK( IL+LDWORK ),
+ $ LDWORK )
+ IE = IL + LDWORK*M
+ ITAUQ = IE + M
+ ITAUP = ITAUQ + M
+ IWORK = ITAUP + M
+*
+* Bidiagonalize L in WORK(IL)
+* (Workspace: need M*M+5*M, prefer M*M+4*M+2*M*NB)
+*
+ CALL DGEBRD( M, M, WORK( IL ), LDWORK, S, WORK( IE ),
+ $ WORK( ITAUQ ), WORK( ITAUP ), WORK( IWORK ),
+ $ LWORK-IWORK+1, INFO )
+*
+* Multiply B by transpose of left bidiagonalizing vectors of L
+* (Workspace: need M*M+4*M+NRHS, prefer M*M+4*M+NRHS*NB)
+*
+ CALL DORMBR( 'Q', 'L', 'T', M, NRHS, M, WORK( IL ), LDWORK,
+ $ WORK( ITAUQ ), B, LDB, WORK( IWORK ),
+ $ LWORK-IWORK+1, INFO )
+*
+* Generate right bidiagonalizing vectors of R in WORK(IL)
+* (Workspace: need M*M+5*M-1, prefer M*M+4*M+(M-1)*NB)
+*
+ CALL DORGBR( 'P', M, M, M, WORK( IL ), LDWORK, WORK( ITAUP ),
+ $ WORK( IWORK ), LWORK-IWORK+1, INFO )
+ IWORK = IE + M
+*
+* Perform bidiagonal QR iteration,
+* computing right singular vectors of L in WORK(IL) and
+* multiplying B by transpose of left singular vectors
+* (Workspace: need M*M+M+BDSPAC)
+*
+ CALL DBDSQR( 'U', M, M, 0, NRHS, S, WORK( IE ), WORK( IL ),
+ $ LDWORK, A, LDA, B, LDB, WORK( IWORK ), INFO )
+ IF( INFO.NE.0 )
+ $ GO TO 70
+*
+* Multiply B by reciprocals of singular values
+*
+ THR = MAX( RCOND*S( 1 ), SFMIN )
+ IF( RCOND.LT.ZERO )
+ $ THR = MAX( EPS*S( 1 ), SFMIN )
+ RANK = 0
+ DO 30 I = 1, M
+ IF( S( I ).GT.THR ) THEN
+ CALL DRSCL( NRHS, S( I ), B( I, 1 ), LDB )
+ RANK = RANK + 1
+ ELSE
+ CALL DLASET( 'F', 1, NRHS, ZERO, ZERO, B( I, 1 ), LDB )
+ END IF
+ 30 CONTINUE
+ IWORK = IE
+*
+* Multiply B by right singular vectors of L in WORK(IL)
+* (Workspace: need M*M+2*M, prefer M*M+M+M*NRHS)
+*
+ IF( LWORK.GE.LDB*NRHS+IWORK-1 .AND. NRHS.GT.1 ) THEN
+ CALL DGEMM( 'T', 'N', M, NRHS, M, ONE, WORK( IL ), LDWORK,
+ $ B, LDB, ZERO, WORK( IWORK ), LDB )
+ CALL DLACPY( 'G', M, NRHS, WORK( IWORK ), LDB, B, LDB )
+ ELSE IF( NRHS.GT.1 ) THEN
+ CHUNK = ( LWORK-IWORK+1 ) / M
+ DO 40 I = 1, NRHS, CHUNK
+ BL = MIN( NRHS-I+1, CHUNK )
+ CALL DGEMM( 'T', 'N', M, BL, M, ONE, WORK( IL ), LDWORK,
+ $ B( 1, I ), LDB, ZERO, WORK( IWORK ), M )
+ CALL DLACPY( 'G', M, BL, WORK( IWORK ), M, B( 1, I ),
+ $ LDB )
+ 40 CONTINUE
+ ELSE
+ CALL DGEMV( 'T', M, M, ONE, WORK( IL ), LDWORK, B( 1, 1 ),
+ $ 1, ZERO, WORK( IWORK ), 1 )
+ CALL DCOPY( M, WORK( IWORK ), 1, B( 1, 1 ), 1 )
+ END IF
+*
+* Zero out below first M rows of B
+*
+ CALL DLASET( 'F', N-M, NRHS, ZERO, ZERO, B( M+1, 1 ), LDB )
+ IWORK = ITAU + M
+*
+* Multiply transpose(Q) by B
+* (Workspace: need M+NRHS, prefer M+NRHS*NB)
+*
+ CALL DORMLQ( 'L', 'T', N, NRHS, M, A, LDA, WORK( ITAU ), B,
+ $ LDB, WORK( IWORK ), LWORK-IWORK+1, INFO )
+*
+ ELSE
+*
+* Path 2 - remaining underdetermined cases
+*
+ IE = 1
+ ITAUQ = IE + M
+ ITAUP = ITAUQ + M
+ IWORK = ITAUP + M
+*
+* Bidiagonalize A
+* (Workspace: need 3*M+N, prefer 3*M+(M+N)*NB)
+*
+ CALL DGEBRD( M, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ),
+ $ WORK( ITAUP ), WORK( IWORK ), LWORK-IWORK+1,
+ $ INFO )
+*
+* Multiply B by transpose of left bidiagonalizing vectors
+* (Workspace: need 3*M+NRHS, prefer 3*M+NRHS*NB)
+*
+ CALL DORMBR( 'Q', 'L', 'T', M, NRHS, N, A, LDA, WORK( ITAUQ ),
+ $ B, LDB, WORK( IWORK ), LWORK-IWORK+1, INFO )
+*
+* Generate right bidiagonalizing vectors in A
+* (Workspace: need 4*M, prefer 3*M+M*NB)
+*
+ CALL DORGBR( 'P', M, N, M, A, LDA, WORK( ITAUP ),
+ $ WORK( IWORK ), LWORK-IWORK+1, INFO )
+ IWORK = IE + M
+*
+* Perform bidiagonal QR iteration,
+* computing right singular vectors of A in A and
+* multiplying B by transpose of left singular vectors
+* (Workspace: need BDSPAC)
+*
+ CALL DBDSQR( 'L', M, N, 0, NRHS, S, WORK( IE ), A, LDA, VDUM,
+ $ 1, B, LDB, WORK( IWORK ), INFO )
+ IF( INFO.NE.0 )
+ $ GO TO 70
+*
+* Multiply B by reciprocals of singular values
+*
+ THR = MAX( RCOND*S( 1 ), SFMIN )
+ IF( RCOND.LT.ZERO )
+ $ THR = MAX( EPS*S( 1 ), SFMIN )
+ RANK = 0
+ DO 50 I = 1, M
+ IF( S( I ).GT.THR ) THEN
+ CALL DRSCL( NRHS, S( I ), B( I, 1 ), LDB )
+ RANK = RANK + 1
+ ELSE
+ CALL DLASET( 'F', 1, NRHS, ZERO, ZERO, B( I, 1 ), LDB )
+ END IF
+ 50 CONTINUE
+*
+* Multiply B by right singular vectors of A
+* (Workspace: need N, prefer N*NRHS)
+*
+ IF( LWORK.GE.LDB*NRHS .AND. NRHS.GT.1 ) THEN
+ CALL DGEMM( 'T', 'N', N, NRHS, M, ONE, A, LDA, B, LDB, ZERO,
+ $ WORK, LDB )
+ CALL DLACPY( 'F', N, NRHS, WORK, LDB, B, LDB )
+ ELSE IF( NRHS.GT.1 ) THEN
+ CHUNK = LWORK / N
+ DO 60 I = 1, NRHS, CHUNK
+ BL = MIN( NRHS-I+1, CHUNK )
+ CALL DGEMM( 'T', 'N', N, BL, M, ONE, A, LDA, B( 1, I ),
+ $ LDB, ZERO, WORK, N )
+ CALL DLACPY( 'F', N, BL, WORK, N, B( 1, I ), LDB )
+ 60 CONTINUE
+ ELSE
+ CALL DGEMV( 'T', M, N, ONE, A, LDA, B, 1, ZERO, WORK, 1 )
+ CALL DCOPY( N, WORK, 1, B, 1 )
+ END IF
+ END IF
+*
+* Undo scaling
+*
+ IF( IASCL.EQ.1 ) THEN
+ CALL DLASCL( 'G', 0, 0, ANRM, SMLNUM, N, NRHS, B, LDB, INFO )
+ CALL DLASCL( 'G', 0, 0, SMLNUM, ANRM, MINMN, 1, S, MINMN,
+ $ INFO )
+ ELSE IF( IASCL.EQ.2 ) THEN
+ CALL DLASCL( 'G', 0, 0, ANRM, BIGNUM, N, NRHS, B, LDB, INFO )
+ CALL DLASCL( 'G', 0, 0, BIGNUM, ANRM, MINMN, 1, S, MINMN,
+ $ INFO )
+ END IF
+ IF( IBSCL.EQ.1 ) THEN
+ CALL DLASCL( 'G', 0, 0, SMLNUM, BNRM, N, NRHS, B, LDB, INFO )
+ ELSE IF( IBSCL.EQ.2 ) THEN
+ CALL DLASCL( 'G', 0, 0, BIGNUM, BNRM, N, NRHS, B, LDB, INFO )
+ END IF
+*
+ 70 CONTINUE
+ WORK( 1 ) = MAXWRK
+ RETURN
+*
+* End of DGELSS
+*
+ END
+ SUBROUTINE DGELSX( M, N, NRHS, A, LDA, B, LDB, JPVT, RCOND, RANK,
+ $ WORK, INFO )
+*
+* -- LAPACK driver routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LDA, LDB, M, N, NRHS, RANK
+ DOUBLE PRECISION RCOND
+* ..
+* .. Array Arguments ..
+ INTEGER JPVT( * )
+ DOUBLE PRECISION A( LDA, * ), B( LDB, * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* This routine is deprecated and has been replaced by routine DGELSY.
+*
+* DGELSX computes the minimum-norm solution to a real linear least
+* squares problem:
+* minimize || A * X - B ||
+* using a complete orthogonal factorization of A. A is an M-by-N
+* matrix which may be rank-deficient.
+*
+* Several right hand side vectors b and solution vectors x can be
+* handled in a single call; they are stored as the columns of the
+* M-by-NRHS right hand side matrix B and the N-by-NRHS solution
+* matrix X.
+*
+* The routine first computes a QR factorization with column pivoting:
+* A * P = Q * [ R11 R12 ]
+* [ 0 R22 ]
+* with R11 defined as the largest leading submatrix whose estimated
+* condition number is less than 1/RCOND. The order of R11, RANK,
+* is the effective rank of A.
+*
+* Then, R22 is considered to be negligible, and R12 is annihilated
+* by orthogonal transformations from the right, arriving at the
+* complete orthogonal factorization:
+* A * P = Q * [ T11 0 ] * Z
+* [ 0 0 ]
+* The minimum-norm solution is then
+* X = P * Z' [ inv(T11)*Q1'*B ]
+* [ 0 ]
+* where Q1 consists of the first RANK columns of Q.
+*
+* Arguments
+* =========
+*
+* M (input) INTEGER
+* The number of rows of the matrix A. M >= 0.
+*
+* N (input) INTEGER
+* The number of columns of the matrix A. N >= 0.
+*
+* NRHS (input) INTEGER
+* The number of right hand sides, i.e., the number of
+* columns of matrices B and X. NRHS >= 0.
+*
+* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+* On entry, the M-by-N matrix A.
+* On exit, A has been overwritten by details of its
+* complete orthogonal factorization.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,M).
+*
+* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
+* On entry, the M-by-NRHS right hand side matrix B.
+* On exit, the N-by-NRHS solution matrix X.
+* If m >= n and RANK = n, the residual sum-of-squares for
+* the solution in the i-th column is given by the sum of
+* squares of elements N+1:M in that column.
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. LDB >= max(1,M,N).
+*
+* JPVT (input/output) INTEGER array, dimension (N)
+* On entry, if JPVT(i) .ne. 0, the i-th column of A is an
+* initial column, otherwise it is a free column. Before
+* the QR factorization of A, all initial columns are
+* permuted to the leading positions; only the remaining
+* free columns are moved as a result of column pivoting
+* during the factorization.
+* On exit, if JPVT(i) = k, then the i-th column of A*P
+* was the k-th column of A.
+*
+* RCOND (input) DOUBLE PRECISION
+* RCOND is used to determine the effective rank of A, which
+* is defined as the order of the largest leading triangular
+* submatrix R11 in the QR factorization with pivoting of A,
+* whose estimated condition number < 1/RCOND.
+*
+* RANK (output) INTEGER
+* The effective rank of A, i.e., the order of the submatrix
+* R11. This is the same as the order of the submatrix T11
+* in the complete orthogonal factorization of A.
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension
+* (max( min(M,N)+3*N, 2*min(M,N)+NRHS )),
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+*
+* =====================================================================
+*
+* .. Parameters ..
+ INTEGER IMAX, IMIN
+ PARAMETER ( IMAX = 1, IMIN = 2 )
+ DOUBLE PRECISION ZERO, ONE, DONE, NTDONE
+ PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, DONE = ZERO,
+ $ NTDONE = ONE )
+* ..
+* .. Local Scalars ..
+ INTEGER I, IASCL, IBSCL, ISMAX, ISMIN, J, K, MN
+ DOUBLE PRECISION ANRM, BIGNUM, BNRM, C1, C2, S1, S2, SMAX,
+ $ SMAXPR, SMIN, SMINPR, SMLNUM, T1, T2
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DLAMCH, DLANGE
+ EXTERNAL DLAMCH, DLANGE
+* ..
+* .. External Subroutines ..
+ EXTERNAL DGEQPF, DLAIC1, DLASCL, DLASET, DLATZM, DORM2R,
+ $ DTRSM, DTZRQF, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+ MN = MIN( M, N )
+ ISMIN = MN + 1
+ ISMAX = 2*MN + 1
+*
+* Test the input arguments.
+*
+ INFO = 0
+ IF( M.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( NRHS.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+ INFO = -5
+ ELSE IF( LDB.LT.MAX( 1, M, N ) ) THEN
+ INFO = -7
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DGELSX', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( MIN( M, N, NRHS ).EQ.0 ) THEN
+ RANK = 0
+ RETURN
+ END IF
+*
+* Get machine parameters
+*
+ SMLNUM = DLAMCH( 'S' ) / DLAMCH( 'P' )
+ BIGNUM = ONE / SMLNUM
+ CALL DLABAD( SMLNUM, BIGNUM )
+*
+* Scale A, B if max elements outside range [SMLNUM,BIGNUM]
+*
+ ANRM = DLANGE( 'M', M, N, A, LDA, WORK )
+ IASCL = 0
+ IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
+*
+* Scale matrix norm up to SMLNUM
+*
+ CALL DLASCL( 'G', 0, 0, ANRM, SMLNUM, M, N, A, LDA, INFO )
+ IASCL = 1
+ ELSE IF( ANRM.GT.BIGNUM ) THEN
+*
+* Scale matrix norm down to BIGNUM
+*
+ CALL DLASCL( 'G', 0, 0, ANRM, BIGNUM, M, N, A, LDA, INFO )
+ IASCL = 2
+ ELSE IF( ANRM.EQ.ZERO ) THEN
+*
+* Matrix all zero. Return zero solution.
+*
+ CALL DLASET( 'F', MAX( M, N ), NRHS, ZERO, ZERO, B, LDB )
+ RANK = 0
+ GO TO 100
+ END IF
+*
+ BNRM = DLANGE( 'M', M, NRHS, B, LDB, WORK )
+ IBSCL = 0
+ IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN
+*
+* Scale matrix norm up to SMLNUM
+*
+ CALL DLASCL( 'G', 0, 0, BNRM, SMLNUM, M, NRHS, B, LDB, INFO )
+ IBSCL = 1
+ ELSE IF( BNRM.GT.BIGNUM ) THEN
+*
+* Scale matrix norm down to BIGNUM
+*
+ CALL DLASCL( 'G', 0, 0, BNRM, BIGNUM, M, NRHS, B, LDB, INFO )
+ IBSCL = 2
+ END IF
+*
+* Compute QR factorization with column pivoting of A:
+* A * P = Q * R
+*
+ CALL DGEQPF( M, N, A, LDA, JPVT, WORK( 1 ), WORK( MN+1 ), INFO )
+*
+* workspace 3*N. Details of Householder rotations stored
+* in WORK(1:MN).
+*
+* Determine RANK using incremental condition estimation
+*
+ WORK( ISMIN ) = ONE
+ WORK( ISMAX ) = ONE
+ SMAX = ABS( A( 1, 1 ) )
+ SMIN = SMAX
+ IF( ABS( A( 1, 1 ) ).EQ.ZERO ) THEN
+ RANK = 0
+ CALL DLASET( 'F', MAX( M, N ), NRHS, ZERO, ZERO, B, LDB )
+ GO TO 100
+ ELSE
+ RANK = 1
+ END IF
+*
+ 10 CONTINUE
+ IF( RANK.LT.MN ) THEN
+ I = RANK + 1
+ CALL DLAIC1( IMIN, RANK, WORK( ISMIN ), SMIN, A( 1, I ),
+ $ A( I, I ), SMINPR, S1, C1 )
+ CALL DLAIC1( IMAX, RANK, WORK( ISMAX ), SMAX, A( 1, I ),
+ $ A( I, I ), SMAXPR, S2, C2 )
+*
+ IF( SMAXPR*RCOND.LE.SMINPR ) THEN
+ DO 20 I = 1, RANK
+ WORK( ISMIN+I-1 ) = S1*WORK( ISMIN+I-1 )
+ WORK( ISMAX+I-1 ) = S2*WORK( ISMAX+I-1 )
+ 20 CONTINUE
+ WORK( ISMIN+RANK ) = C1
+ WORK( ISMAX+RANK ) = C2
+ SMIN = SMINPR
+ SMAX = SMAXPR
+ RANK = RANK + 1
+ GO TO 10
+ END IF
+ END IF
+*
+* Logically partition R = [ R11 R12 ]
+* [ 0 R22 ]
+* where R11 = R(1:RANK,1:RANK)
+*
+* [R11,R12] = [ T11, 0 ] * Y
+*
+ IF( RANK.LT.N )
+ $ CALL DTZRQF( RANK, N, A, LDA, WORK( MN+1 ), INFO )
+*
+* Details of Householder rotations stored in WORK(MN+1:2*MN)
+*
+* B(1:M,1:NRHS) := Q' * B(1:M,1:NRHS)
+*
+ CALL DORM2R( 'Left', 'Transpose', M, NRHS, MN, A, LDA, WORK( 1 ),
+ $ B, LDB, WORK( 2*MN+1 ), INFO )
+*
+* workspace NRHS
+*
+* B(1:RANK,1:NRHS) := inv(T11) * B(1:RANK,1:NRHS)
+*
+ CALL DTRSM( 'Left', 'Upper', 'No transpose', 'Non-unit', RANK,
+ $ NRHS, ONE, A, LDA, B, LDB )
+*
+ DO 40 I = RANK + 1, N
+ DO 30 J = 1, NRHS
+ B( I, J ) = ZERO
+ 30 CONTINUE
+ 40 CONTINUE
+*
+* B(1:N,1:NRHS) := Y' * B(1:N,1:NRHS)
+*
+ IF( RANK.LT.N ) THEN
+ DO 50 I = 1, RANK
+ CALL DLATZM( 'Left', N-RANK+1, NRHS, A( I, RANK+1 ), LDA,
+ $ WORK( MN+I ), B( I, 1 ), B( RANK+1, 1 ), LDB,
+ $ WORK( 2*MN+1 ) )
+ 50 CONTINUE
+ END IF
+*
+* workspace NRHS
+*
+* B(1:N,1:NRHS) := P * B(1:N,1:NRHS)
+*
+ DO 90 J = 1, NRHS
+ DO 60 I = 1, N
+ WORK( 2*MN+I ) = NTDONE
+ 60 CONTINUE
+ DO 80 I = 1, N
+ IF( WORK( 2*MN+I ).EQ.NTDONE ) THEN
+ IF( JPVT( I ).NE.I ) THEN
+ K = I
+ T1 = B( K, J )
+ T2 = B( JPVT( K ), J )
+ 70 CONTINUE
+ B( JPVT( K ), J ) = T1
+ WORK( 2*MN+K ) = DONE
+ T1 = T2
+ K = JPVT( K )
+ T2 = B( JPVT( K ), J )
+ IF( JPVT( K ).NE.I )
+ $ GO TO 70
+ B( I, J ) = T1
+ WORK( 2*MN+K ) = DONE
+ END IF
+ END IF
+ 80 CONTINUE
+ 90 CONTINUE
+*
+* Undo scaling
+*
+ IF( IASCL.EQ.1 ) THEN
+ CALL DLASCL( 'G', 0, 0, ANRM, SMLNUM, N, NRHS, B, LDB, INFO )
+ CALL DLASCL( 'U', 0, 0, SMLNUM, ANRM, RANK, RANK, A, LDA,
+ $ INFO )
+ ELSE IF( IASCL.EQ.2 ) THEN
+ CALL DLASCL( 'G', 0, 0, ANRM, BIGNUM, N, NRHS, B, LDB, INFO )
+ CALL DLASCL( 'U', 0, 0, BIGNUM, ANRM, RANK, RANK, A, LDA,
+ $ INFO )
+ END IF
+ IF( IBSCL.EQ.1 ) THEN
+ CALL DLASCL( 'G', 0, 0, SMLNUM, BNRM, N, NRHS, B, LDB, INFO )
+ ELSE IF( IBSCL.EQ.2 ) THEN
+ CALL DLASCL( 'G', 0, 0, BIGNUM, BNRM, N, NRHS, B, LDB, INFO )
+ END IF
+*
+ 100 CONTINUE
+*
+ RETURN
+*
+* End of DGELSX
+*
+ END
+ SUBROUTINE DGELSY( M, N, NRHS, A, LDA, B, LDB, JPVT, RCOND, RANK,
+ $ WORK, LWORK, INFO )
+*
+* -- LAPACK driver routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS, RANK
+ DOUBLE PRECISION RCOND
+* ..
+* .. Array Arguments ..
+ INTEGER JPVT( * )
+ DOUBLE PRECISION A( LDA, * ), B( LDB, * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DGELSY computes the minimum-norm solution to a real linear least
+* squares problem:
+* minimize || A * X - B ||
+* using a complete orthogonal factorization of A. A is an M-by-N
+* matrix which may be rank-deficient.
+*
+* Several right hand side vectors b and solution vectors x can be
+* handled in a single call; they are stored as the columns of the
+* M-by-NRHS right hand side matrix B and the N-by-NRHS solution
+* matrix X.
+*
+* The routine first computes a QR factorization with column pivoting:
+* A * P = Q * [ R11 R12 ]
+* [ 0 R22 ]
+* with R11 defined as the largest leading submatrix whose estimated
+* condition number is less than 1/RCOND. The order of R11, RANK,
+* is the effective rank of A.
+*
+* Then, R22 is considered to be negligible, and R12 is annihilated
+* by orthogonal transformations from the right, arriving at the
+* complete orthogonal factorization:
+* A * P = Q * [ T11 0 ] * Z
+* [ 0 0 ]
+* The minimum-norm solution is then
+* X = P * Z' [ inv(T11)*Q1'*B ]
+* [ 0 ]
+* where Q1 consists of the first RANK columns of Q.
+*
+* This routine is basically identical to the original xGELSX except
+* three differences:
+* o The call to the subroutine xGEQPF has been substituted by the
+* the call to the subroutine xGEQP3. This subroutine is a Blas-3
+* version of the QR factorization with column pivoting.
+* o Matrix B (the right hand side) is updated with Blas-3.
+* o The permutation of matrix B (the right hand side) is faster and
+* more simple.
+*
+* Arguments
+* =========
+*
+* M (input) INTEGER
+* The number of rows of the matrix A. M >= 0.
+*
+* N (input) INTEGER
+* The number of columns of the matrix A. N >= 0.
+*
+* NRHS (input) INTEGER
+* The number of right hand sides, i.e., the number of
+* columns of matrices B and X. NRHS >= 0.
+*
+* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+* On entry, the M-by-N matrix A.
+* On exit, A has been overwritten by details of its
+* complete orthogonal factorization.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,M).
+*
+* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
+* On entry, the M-by-NRHS right hand side matrix B.
+* On exit, the N-by-NRHS solution matrix X.
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. LDB >= max(1,M,N).
+*
+* JPVT (input/output) INTEGER array, dimension (N)
+* On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted
+* to the front of AP, otherwise column i is a free column.
+* On exit, if JPVT(i) = k, then the i-th column of AP
+* was the k-th column of A.
+*
+* RCOND (input) DOUBLE PRECISION
+* RCOND is used to determine the effective rank of A, which
+* is defined as the order of the largest leading triangular
+* submatrix R11 in the QR factorization with pivoting of A,
+* whose estimated condition number < 1/RCOND.
+*
+* RANK (output) INTEGER
+* The effective rank of A, i.e., the order of the submatrix
+* R11. This is the same as the order of the submatrix T11
+* in the complete orthogonal factorization of A.
+*
+* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
+* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+* LWORK (input) INTEGER
+* The dimension of the array WORK.
+* The unblocked strategy requires that:
+* LWORK >= MAX( MN+3*N+1, 2*MN+NRHS ),
+* where MN = min( M, N ).
+* The block algorithm requires that:
+* LWORK >= MAX( MN+2*N+NB*(N+1), 2*MN+NB*NRHS ),
+* where NB is an upper bound on the blocksize returned
+* by ILAENV for the routines DGEQP3, DTZRZF, STZRQF, DORMQR,
+* and DORMRZ.
+*
+* If LWORK = -1, then a workspace query is assumed; the routine
+* only calculates the optimal size of the WORK array, returns
+* this value as the first entry of the WORK array, and no error
+* message related to LWORK is issued by XERBLA.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: If INFO = -i, the i-th argument had an illegal value.
+*
+* Further Details
+* ===============
+*
+* Based on contributions by
+* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA
+* E. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain
+* G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain
+*
+* =====================================================================
+*
+* .. Parameters ..
+ INTEGER IMAX, IMIN
+ PARAMETER ( IMAX = 1, IMIN = 2 )
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL LQUERY
+ INTEGER I, IASCL, IBSCL, ISMAX, ISMIN, J, LWKMIN,
+ $ LWKOPT, MN, NB, NB1, NB2, NB3, NB4
+ DOUBLE PRECISION ANRM, BIGNUM, BNRM, C1, C2, S1, S2, SMAX,
+ $ SMAXPR, SMIN, SMINPR, SMLNUM, WSIZE
+* ..
+* .. External Functions ..
+ INTEGER ILAENV
+ DOUBLE PRECISION DLAMCH, DLANGE
+ EXTERNAL ILAENV, DLAMCH, DLANGE
+* ..
+* .. External Subroutines ..
+ EXTERNAL DCOPY, DGEQP3, DLABAD, DLAIC1, DLASCL, DLASET,
+ $ DORMQR, DORMRZ, DTRSM, DTZRZF, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+ MN = MIN( M, N )
+ ISMIN = MN + 1
+ ISMAX = 2*MN + 1
+*
+* Test the input arguments.
+*
+ INFO = 0
+ LQUERY = ( LWORK.EQ.-1 )
+ IF( M.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( NRHS.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+ INFO = -5
+ ELSE IF( LDB.LT.MAX( 1, M, N ) ) THEN
+ INFO = -7
+ END IF
+*
+* Figure out optimal block size
+*
+ IF( INFO.EQ.0 ) THEN
+ IF( MN.EQ.0 .OR. NRHS.EQ.0 ) THEN
+ LWKMIN = 1
+ LWKOPT = 1
+ ELSE
+ NB1 = ILAENV( 1, 'DGEQRF', ' ', M, N, -1, -1 )
+ NB2 = ILAENV( 1, 'DGERQF', ' ', M, N, -1, -1 )
+ NB3 = ILAENV( 1, 'DORMQR', ' ', M, N, NRHS, -1 )
+ NB4 = ILAENV( 1, 'DORMRQ', ' ', M, N, NRHS, -1 )
+ NB = MAX( NB1, NB2, NB3, NB4 )
+ LWKMIN = MN + MAX( 2*MN, N + 1, MN + NRHS )
+ LWKOPT = MAX( LWKMIN,
+ $ MN + 2*N + NB*( N + 1 ), 2*MN + NB*NRHS )
+ END IF
+ WORK( 1 ) = LWKOPT
+*
+ IF( LWORK.LT.LWKMIN .AND. .NOT.LQUERY ) THEN
+ INFO = -12
+ END IF
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DGELSY', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( MN.EQ.0 .OR. NRHS.EQ.0 ) THEN
+ RANK = 0
+ RETURN
+ END IF
+*
+* Get machine parameters
+*
+ SMLNUM = DLAMCH( 'S' ) / DLAMCH( 'P' )
+ BIGNUM = ONE / SMLNUM
+ CALL DLABAD( SMLNUM, BIGNUM )
+*
+* Scale A, B if max entries outside range [SMLNUM,BIGNUM]
+*
+ ANRM = DLANGE( 'M', M, N, A, LDA, WORK )
+ IASCL = 0
+ IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
+*
+* Scale matrix norm up to SMLNUM
+*
+ CALL DLASCL( 'G', 0, 0, ANRM, SMLNUM, M, N, A, LDA, INFO )
+ IASCL = 1
+ ELSE IF( ANRM.GT.BIGNUM ) THEN
+*
+* Scale matrix norm down to BIGNUM
+*
+ CALL DLASCL( 'G', 0, 0, ANRM, BIGNUM, M, N, A, LDA, INFO )
+ IASCL = 2
+ ELSE IF( ANRM.EQ.ZERO ) THEN
+*
+* Matrix all zero. Return zero solution.
+*
+ CALL DLASET( 'F', MAX( M, N ), NRHS, ZERO, ZERO, B, LDB )
+ RANK = 0
+ GO TO 70
+ END IF
+*
+ BNRM = DLANGE( 'M', M, NRHS, B, LDB, WORK )
+ IBSCL = 0
+ IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN
+*
+* Scale matrix norm up to SMLNUM
+*
+ CALL DLASCL( 'G', 0, 0, BNRM, SMLNUM, M, NRHS, B, LDB, INFO )
+ IBSCL = 1
+ ELSE IF( BNRM.GT.BIGNUM ) THEN
+*
+* Scale matrix norm down to BIGNUM
+*
+ CALL DLASCL( 'G', 0, 0, BNRM, BIGNUM, M, NRHS, B, LDB, INFO )
+ IBSCL = 2
+ END IF
+*
+* Compute QR factorization with column pivoting of A:
+* A * P = Q * R
+*
+ CALL DGEQP3( M, N, A, LDA, JPVT, WORK( 1 ), WORK( MN+1 ),
+ $ LWORK-MN, INFO )
+ WSIZE = MN + WORK( MN+1 )
+*
+* workspace: MN+2*N+NB*(N+1).
+* Details of Householder rotations stored in WORK(1:MN).
+*
+* Determine RANK using incremental condition estimation
+*
+ WORK( ISMIN ) = ONE
+ WORK( ISMAX ) = ONE
+ SMAX = ABS( A( 1, 1 ) )
+ SMIN = SMAX
+ IF( ABS( A( 1, 1 ) ).EQ.ZERO ) THEN
+ RANK = 0
+ CALL DLASET( 'F', MAX( M, N ), NRHS, ZERO, ZERO, B, LDB )
+ GO TO 70
+ ELSE
+ RANK = 1
+ END IF
+*
+ 10 CONTINUE
+ IF( RANK.LT.MN ) THEN
+ I = RANK + 1
+ CALL DLAIC1( IMIN, RANK, WORK( ISMIN ), SMIN, A( 1, I ),
+ $ A( I, I ), SMINPR, S1, C1 )
+ CALL DLAIC1( IMAX, RANK, WORK( ISMAX ), SMAX, A( 1, I ),
+ $ A( I, I ), SMAXPR, S2, C2 )
+*
+ IF( SMAXPR*RCOND.LE.SMINPR ) THEN
+ DO 20 I = 1, RANK
+ WORK( ISMIN+I-1 ) = S1*WORK( ISMIN+I-1 )
+ WORK( ISMAX+I-1 ) = S2*WORK( ISMAX+I-1 )
+ 20 CONTINUE
+ WORK( ISMIN+RANK ) = C1
+ WORK( ISMAX+RANK ) = C2
+ SMIN = SMINPR
+ SMAX = SMAXPR
+ RANK = RANK + 1
+ GO TO 10
+ END IF
+ END IF
+*
+* workspace: 3*MN.
+*
+* Logically partition R = [ R11 R12 ]
+* [ 0 R22 ]
+* where R11 = R(1:RANK,1:RANK)
+*
+* [R11,R12] = [ T11, 0 ] * Y
+*
+ IF( RANK.LT.N )
+ $ CALL DTZRZF( RANK, N, A, LDA, WORK( MN+1 ), WORK( 2*MN+1 ),
+ $ LWORK-2*MN, INFO )
+*
+* workspace: 2*MN.
+* Details of Householder rotations stored in WORK(MN+1:2*MN)
+*
+* B(1:M,1:NRHS) := Q' * B(1:M,1:NRHS)
+*
+ CALL DORMQR( 'Left', 'Transpose', M, NRHS, MN, A, LDA, WORK( 1 ),
+ $ B, LDB, WORK( 2*MN+1 ), LWORK-2*MN, INFO )
+ WSIZE = MAX( WSIZE, 2*MN+WORK( 2*MN+1 ) )
+*
+* workspace: 2*MN+NB*NRHS.
+*
+* B(1:RANK,1:NRHS) := inv(T11) * B(1:RANK,1:NRHS)
+*
+ CALL DTRSM( 'Left', 'Upper', 'No transpose', 'Non-unit', RANK,
+ $ NRHS, ONE, A, LDA, B, LDB )
+*
+ DO 40 J = 1, NRHS
+ DO 30 I = RANK + 1, N
+ B( I, J ) = ZERO
+ 30 CONTINUE
+ 40 CONTINUE
+*
+* B(1:N,1:NRHS) := Y' * B(1:N,1:NRHS)
+*
+ IF( RANK.LT.N ) THEN
+ CALL DORMRZ( 'Left', 'Transpose', N, NRHS, RANK, N-RANK, A,
+ $ LDA, WORK( MN+1 ), B, LDB, WORK( 2*MN+1 ),
+ $ LWORK-2*MN, INFO )
+ END IF
+*
+* workspace: 2*MN+NRHS.
+*
+* B(1:N,1:NRHS) := P * B(1:N,1:NRHS)
+*
+ DO 60 J = 1, NRHS
+ DO 50 I = 1, N
+ WORK( JPVT( I ) ) = B( I, J )
+ 50 CONTINUE
+ CALL DCOPY( N, WORK( 1 ), 1, B( 1, J ), 1 )
+ 60 CONTINUE
+*
+* workspace: N.
+*
+* Undo scaling
+*
+ IF( IASCL.EQ.1 ) THEN
+ CALL DLASCL( 'G', 0, 0, ANRM, SMLNUM, N, NRHS, B, LDB, INFO )
+ CALL DLASCL( 'U', 0, 0, SMLNUM, ANRM, RANK, RANK, A, LDA,
+ $ INFO )
+ ELSE IF( IASCL.EQ.2 ) THEN
+ CALL DLASCL( 'G', 0, 0, ANRM, BIGNUM, N, NRHS, B, LDB, INFO )
+ CALL DLASCL( 'U', 0, 0, BIGNUM, ANRM, RANK, RANK, A, LDA,
+ $ INFO )
+ END IF
+ IF( IBSCL.EQ.1 ) THEN
+ CALL DLASCL( 'G', 0, 0, SMLNUM, BNRM, N, NRHS, B, LDB, INFO )
+ ELSE IF( IBSCL.EQ.2 ) THEN
+ CALL DLASCL( 'G', 0, 0, BIGNUM, BNRM, N, NRHS, B, LDB, INFO )
+ END IF
+*
+ 70 CONTINUE
+ WORK( 1 ) = LWKOPT
+*
+ RETURN
+*
+* End of DGELSY
+*
+ END
+ SUBROUTINE DGEQL2( M, N, A, LDA, TAU, WORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LDA, M, N
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DGEQL2 computes a QL factorization of a real m by n matrix A:
+* A = Q * L.
+*
+* Arguments
+* =========
+*
+* M (input) INTEGER
+* The number of rows of the matrix A. M >= 0.
+*
+* N (input) INTEGER
+* The number of columns of the matrix A. N >= 0.
+*
+* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+* On entry, the m by n matrix A.
+* On exit, if m >= n, the lower triangle of the subarray
+* A(m-n+1:m,1:n) contains the n by n lower triangular matrix L;
+* if m <= n, the elements on and below the (n-m)-th
+* superdiagonal contain the m by n lower trapezoidal matrix L;
+* the remaining elements, with the array TAU, represent the
+* orthogonal matrix Q as a product of elementary reflectors
+* (see Further Details).
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,M).
+*
+* TAU (output) DOUBLE PRECISION array, dimension (min(M,N))
+* The scalar factors of the elementary reflectors (see Further
+* Details).
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (N)
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+*
+* Further Details
+* ===============
+*
+* The matrix Q is represented as a product of elementary reflectors
+*
+* Q = H(k) . . . H(2) H(1), where k = min(m,n).
+*
+* Each H(i) has the form
+*
+* H(i) = I - tau * v * v'
+*
+* where tau is a real scalar, and v is a real vector with
+* v(m-k+i+1:m) = 0 and v(m-k+i) = 1; v(1:m-k+i-1) is stored on exit in
+* A(1:m-k+i-1,n-k+i), and tau in TAU(i).
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE
+ PARAMETER ( ONE = 1.0D+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, K
+ DOUBLE PRECISION AII
+* ..
+* .. External Subroutines ..
+ EXTERNAL DLARF, DLARFG, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+* Test the input arguments
+*
+ INFO = 0
+ IF( M.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+ INFO = -4
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DGEQL2', -INFO )
+ RETURN
+ END IF
+*
+ K = MIN( M, N )
+*
+ DO 10 I = K, 1, -1
+*
+* Generate elementary reflector H(i) to annihilate
+* A(1:m-k+i-1,n-k+i)
+*
+ CALL DLARFG( M-K+I, A( M-K+I, N-K+I ), A( 1, N-K+I ), 1,
+ $ TAU( I ) )
+*
+* Apply H(i) to A(1:m-k+i,1:n-k+i-1) from the left
+*
+ AII = A( M-K+I, N-K+I )
+ A( M-K+I, N-K+I ) = ONE
+ CALL DLARF( 'Left', M-K+I, N-K+I-1, A( 1, N-K+I ), 1, TAU( I ),
+ $ A, LDA, WORK )
+ A( M-K+I, N-K+I ) = AII
+ 10 CONTINUE
+ RETURN
+*
+* End of DGEQL2
+*
+ END
+ SUBROUTINE DGEQLF( M, N, A, LDA, TAU, WORK, LWORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LDA, LWORK, M, N
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DGEQLF computes a QL factorization of a real M-by-N matrix A:
+* A = Q * L.
+*
+* Arguments
+* =========
+*
+* M (input) INTEGER
+* The number of rows of the matrix A. M >= 0.
+*
+* N (input) INTEGER
+* The number of columns of the matrix A. N >= 0.
+*
+* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+* On entry, the M-by-N matrix A.
+* On exit,
+* if m >= n, the lower triangle of the subarray
+* A(m-n+1:m,1:n) contains the N-by-N lower triangular matrix L;
+* if m <= n, the elements on and below the (n-m)-th
+* superdiagonal contain the M-by-N lower trapezoidal matrix L;
+* the remaining elements, with the array TAU, represent the
+* orthogonal matrix Q as a product of elementary reflectors
+* (see Further Details).
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,M).
+*
+* TAU (output) DOUBLE PRECISION array, dimension (min(M,N))
+* The scalar factors of the elementary reflectors (see Further
+* Details).
+*
+* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
+* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+* LWORK (input) INTEGER
+* The dimension of the array WORK. LWORK >= max(1,N).
+* For optimum performance LWORK >= N*NB, where NB is the
+* optimal blocksize.
+*
+* If LWORK = -1, then a workspace query is assumed; the routine
+* only calculates the optimal size of the WORK array, returns
+* this value as the first entry of the WORK array, and no error
+* message related to LWORK is issued by XERBLA.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+*
+* Further Details
+* ===============
+*
+* The matrix Q is represented as a product of elementary reflectors
+*
+* Q = H(k) . . . H(2) H(1), where k = min(m,n).
+*
+* Each H(i) has the form
+*
+* H(i) = I - tau * v * v'
+*
+* where tau is a real scalar, and v is a real vector with
+* v(m-k+i+1:m) = 0 and v(m-k+i) = 1; v(1:m-k+i-1) is stored on exit in
+* A(1:m-k+i-1,n-k+i), and tau in TAU(i).
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ LOGICAL LQUERY
+ INTEGER I, IB, IINFO, IWS, K, KI, KK, LDWORK, LWKOPT,
+ $ MU, NB, NBMIN, NU, NX
+* ..
+* .. External Subroutines ..
+ EXTERNAL DGEQL2, DLARFB, DLARFT, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN
+* ..
+* .. External Functions ..
+ INTEGER ILAENV
+ EXTERNAL ILAENV
+* ..
+* .. Executable Statements ..
+*
+* Test the input arguments
+*
+ INFO = 0
+ LQUERY = ( LWORK.EQ.-1 )
+ IF( M.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+ INFO = -4
+ END IF
+*
+ IF( INFO.EQ.0 ) THEN
+ K = MIN( M, N )
+ IF( K.EQ.0 ) THEN
+ LWKOPT = 1
+ ELSE
+ NB = ILAENV( 1, 'DGEQLF', ' ', M, N, -1, -1 )
+ LWKOPT = N*NB
+ END IF
+ WORK( 1 ) = LWKOPT
+*
+ IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN
+ INFO = -7
+ END IF
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DGEQLF', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( K.EQ.0 ) THEN
+ RETURN
+ END IF
+*
+ NBMIN = 2
+ NX = 1
+ IWS = N
+ IF( NB.GT.1 .AND. NB.LT.K ) THEN
+*
+* Determine when to cross over from blocked to unblocked code.
+*
+ NX = MAX( 0, ILAENV( 3, 'DGEQLF', ' ', M, N, -1, -1 ) )
+ IF( NX.LT.K ) THEN
+*
+* Determine if workspace is large enough for blocked code.
+*
+ LDWORK = N
+ IWS = LDWORK*NB
+ IF( LWORK.LT.IWS ) THEN
+*
+* Not enough workspace to use optimal NB: reduce NB and
+* determine the minimum value of NB.
+*
+ NB = LWORK / LDWORK
+ NBMIN = MAX( 2, ILAENV( 2, 'DGEQLF', ' ', M, N, -1,
+ $ -1 ) )
+ END IF
+ END IF
+ END IF
+*
+ IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN
+*
+* Use blocked code initially.
+* The last kk columns are handled by the block method.
+*
+ KI = ( ( K-NX-1 ) / NB )*NB
+ KK = MIN( K, KI+NB )
+*
+ DO 10 I = K - KK + KI + 1, K - KK + 1, -NB
+ IB = MIN( K-I+1, NB )
+*
+* Compute the QL factorization of the current block
+* A(1:m-k+i+ib-1,n-k+i:n-k+i+ib-1)
+*
+ CALL DGEQL2( M-K+I+IB-1, IB, A( 1, N-K+I ), LDA, TAU( I ),
+ $ WORK, IINFO )
+ IF( N-K+I.GT.1 ) THEN
+*
+* Form the triangular factor of the block reflector
+* H = H(i+ib-1) . . . H(i+1) H(i)
+*
+ CALL DLARFT( 'Backward', 'Columnwise', M-K+I+IB-1, IB,
+ $ A( 1, N-K+I ), LDA, TAU( I ), WORK, LDWORK )
+*
+* Apply H' to A(1:m-k+i+ib-1,1:n-k+i-1) from the left
+*
+ CALL DLARFB( 'Left', 'Transpose', 'Backward',
+ $ 'Columnwise', M-K+I+IB-1, N-K+I-1, IB,
+ $ A( 1, N-K+I ), LDA, WORK, LDWORK, A, LDA,
+ $ WORK( IB+1 ), LDWORK )
+ END IF
+ 10 CONTINUE
+ MU = M - K + I + NB - 1
+ NU = N - K + I + NB - 1
+ ELSE
+ MU = M
+ NU = N
+ END IF
+*
+* Use unblocked code to factor the last or only block
+*
+ IF( MU.GT.0 .AND. NU.GT.0 )
+ $ CALL DGEQL2( MU, NU, A, LDA, TAU, WORK, IINFO )
+*
+ WORK( 1 ) = IWS
+ RETURN
+*
+* End of DGEQLF
+*
+ END
+ SUBROUTINE DGEQP3( M, N, A, LDA, JPVT, TAU, WORK, LWORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LDA, LWORK, M, N
+* ..
+* .. Array Arguments ..
+ INTEGER JPVT( * )
+ DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DGEQP3 computes a QR factorization with column pivoting of a
+* matrix A: A*P = Q*R using Level 3 BLAS.
+*
+* Arguments
+* =========
+*
+* M (input) INTEGER
+* The number of rows of the matrix A. M >= 0.
+*
+* N (input) INTEGER
+* The number of columns of the matrix A. N >= 0.
+*
+* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+* On entry, the M-by-N matrix A.
+* On exit, the upper triangle of the array contains the
+* min(M,N)-by-N upper trapezoidal matrix R; the elements below
+* the diagonal, together with the array TAU, represent the
+* orthogonal matrix Q as a product of min(M,N) elementary
+* reflectors.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,M).
+*
+* JPVT (input/output) INTEGER array, dimension (N)
+* On entry, if JPVT(J).ne.0, the J-th column of A is permuted
+* to the front of A*P (a leading column); if JPVT(J)=0,
+* the J-th column of A is a free column.
+* On exit, if JPVT(J)=K, then the J-th column of A*P was the
+* the K-th column of A.
+*
+* TAU (output) DOUBLE PRECISION array, dimension (min(M,N))
+* The scalar factors of the elementary reflectors.
+*
+* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
+* On exit, if INFO=0, WORK(1) returns the optimal LWORK.
+*
+* LWORK (input) INTEGER
+* The dimension of the array WORK. LWORK >= 3*N+1.
+* For optimal performance LWORK >= 2*N+( N+1 )*NB, where NB
+* is the optimal blocksize.
+*
+* If LWORK = -1, then a workspace query is assumed; the routine
+* only calculates the optimal size of the WORK array, returns
+* this value as the first entry of the WORK array, and no error
+* message related to LWORK is issued by XERBLA.
+*
+* INFO (output) INTEGER
+* = 0: successful exit.
+* < 0: if INFO = -i, the i-th argument had an illegal value.
+*
+* Further Details
+* ===============
+*
+* The matrix Q is represented as a product of elementary reflectors
+*
+* Q = H(1) H(2) . . . H(k), where k = min(m,n).
+*
+* Each H(i) has the form
+*
+* H(i) = I - tau * v * v'
+*
+* where tau is a real/complex scalar, and v is a real/complex vector
+* with v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in
+* A(i+1:m,i), and tau in TAU(i).
+*
+* Based on contributions by
+* G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain
+* X. Sun, Computer Science Dept., Duke University, USA
+*
+* =====================================================================
+*
+* .. Parameters ..
+ INTEGER INB, INBMIN, IXOVER
+ PARAMETER ( INB = 1, INBMIN = 2, IXOVER = 3 )
+* ..
+* .. Local Scalars ..
+ LOGICAL LQUERY
+ INTEGER FJB, IWS, J, JB, LWKOPT, MINMN, MINWS, NA, NB,
+ $ NBMIN, NFXD, NX, SM, SMINMN, SN, TOPBMN
+* ..
+* .. External Subroutines ..
+ EXTERNAL DGEQRF, DLAQP2, DLAQPS, DORMQR, DSWAP, XERBLA
+* ..
+* .. External Functions ..
+ INTEGER ILAENV
+ DOUBLE PRECISION DNRM2
+ EXTERNAL ILAENV, DNRM2
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC INT, MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+* Test input arguments
+* ====================
+*
+ INFO = 0
+ LQUERY = ( LWORK.EQ.-1 )
+ IF( M.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+ INFO = -4
+ END IF
+*
+ IF( INFO.EQ.0 ) THEN
+ MINMN = MIN( M, N )
+ IF( MINMN.EQ.0 ) THEN
+ IWS = 1
+ LWKOPT = 1
+ ELSE
+ IWS = 3*N + 1
+ NB = ILAENV( INB, 'DGEQRF', ' ', M, N, -1, -1 )
+ LWKOPT = 2*N + ( N + 1 )*NB
+ END IF
+ WORK( 1 ) = LWKOPT
+*
+ IF( ( LWORK.LT.IWS ) .AND. .NOT.LQUERY ) THEN
+ INFO = -8
+ END IF
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DGEQP3', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible.
+*
+ IF( MINMN.EQ.0 ) THEN
+ RETURN
+ END IF
+*
+* Move initial columns up front.
+*
+ NFXD = 1
+ DO 10 J = 1, N
+ IF( JPVT( J ).NE.0 ) THEN
+ IF( J.NE.NFXD ) THEN
+ CALL DSWAP( M, A( 1, J ), 1, A( 1, NFXD ), 1 )
+ JPVT( J ) = JPVT( NFXD )
+ JPVT( NFXD ) = J
+ ELSE
+ JPVT( J ) = J
+ END IF
+ NFXD = NFXD + 1
+ ELSE
+ JPVT( J ) = J
+ END IF
+ 10 CONTINUE
+ NFXD = NFXD - 1
+*
+* Factorize fixed columns
+* =======================
+*
+* Compute the QR factorization of fixed columns and update
+* remaining columns.
+*
+ IF( NFXD.GT.0 ) THEN
+ NA = MIN( M, NFXD )
+*CC CALL DGEQR2( M, NA, A, LDA, TAU, WORK, INFO )
+ CALL DGEQRF( M, NA, A, LDA, TAU, WORK, LWORK, INFO )
+ IWS = MAX( IWS, INT( WORK( 1 ) ) )
+ IF( NA.LT.N ) THEN
+*CC CALL DORM2R( 'Left', 'Transpose', M, N-NA, NA, A, LDA,
+*CC $ TAU, A( 1, NA+1 ), LDA, WORK, INFO )
+ CALL DORMQR( 'Left', 'Transpose', M, N-NA, NA, A, LDA, TAU,
+ $ A( 1, NA+1 ), LDA, WORK, LWORK, INFO )
+ IWS = MAX( IWS, INT( WORK( 1 ) ) )
+ END IF
+ END IF
+*
+* Factorize free columns
+* ======================
+*
+ IF( NFXD.LT.MINMN ) THEN
+*
+ SM = M - NFXD
+ SN = N - NFXD
+ SMINMN = MINMN - NFXD
+*
+* Determine the block size.
+*
+ NB = ILAENV( INB, 'DGEQRF', ' ', SM, SN, -1, -1 )
+ NBMIN = 2
+ NX = 0
+*
+ IF( ( NB.GT.1 ) .AND. ( NB.LT.SMINMN ) ) THEN
+*
+* Determine when to cross over from blocked to unblocked code.
+*
+ NX = MAX( 0, ILAENV( IXOVER, 'DGEQRF', ' ', SM, SN, -1,
+ $ -1 ) )
+*
+*
+ IF( NX.LT.SMINMN ) THEN
+*
+* Determine if workspace is large enough for blocked code.
+*
+ MINWS = 2*SN + ( SN+1 )*NB
+ IWS = MAX( IWS, MINWS )
+ IF( LWORK.LT.MINWS ) THEN
+*
+* Not enough workspace to use optimal NB: Reduce NB and
+* determine the minimum value of NB.
+*
+ NB = ( LWORK-2*SN ) / ( SN+1 )
+ NBMIN = MAX( 2, ILAENV( INBMIN, 'DGEQRF', ' ', SM, SN,
+ $ -1, -1 ) )
+*
+*
+ END IF
+ END IF
+ END IF
+*
+* Initialize partial column norms. The first N elements of work
+* store the exact column norms.
+*
+ DO 20 J = NFXD + 1, N
+ WORK( J ) = DNRM2( SM, A( NFXD+1, J ), 1 )
+ WORK( N+J ) = WORK( J )
+ 20 CONTINUE
+*
+ IF( ( NB.GE.NBMIN ) .AND. ( NB.LT.SMINMN ) .AND.
+ $ ( NX.LT.SMINMN ) ) THEN
+*
+* Use blocked code initially.
+*
+ J = NFXD + 1
+*
+* Compute factorization: while loop.
+*
+*
+ TOPBMN = MINMN - NX
+ 30 CONTINUE
+ IF( J.LE.TOPBMN ) THEN
+ JB = MIN( NB, TOPBMN-J+1 )
+*
+* Factorize JB columns among columns J:N.
+*
+ CALL DLAQPS( M, N-J+1, J-1, JB, FJB, A( 1, J ), LDA,
+ $ JPVT( J ), TAU( J ), WORK( J ), WORK( N+J ),
+ $ WORK( 2*N+1 ), WORK( 2*N+JB+1 ), N-J+1 )
+*
+ J = J + FJB
+ GO TO 30
+ END IF
+ ELSE
+ J = NFXD + 1
+ END IF
+*
+* Use unblocked code to factor the last or only block.
+*
+*
+ IF( J.LE.MINMN )
+ $ CALL DLAQP2( M, N-J+1, J-1, A( 1, J ), LDA, JPVT( J ),
+ $ TAU( J ), WORK( J ), WORK( N+J ),
+ $ WORK( 2*N+1 ) )
+*
+ END IF
+*
+ WORK( 1 ) = IWS
+ RETURN
+*
+* End of DGEQP3
+*
+ END
+ SUBROUTINE DGEQPF( M, N, A, LDA, JPVT, TAU, WORK, INFO )
+*
+* -- LAPACK deprecated driver routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LDA, M, N
+* ..
+* .. Array Arguments ..
+ INTEGER JPVT( * )
+ DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* This routine is deprecated and has been replaced by routine DGEQP3.
+*
+* DGEQPF computes a QR factorization with column pivoting of a
+* real M-by-N matrix A: A*P = Q*R.
+*
+* Arguments
+* =========
+*
+* M (input) INTEGER
+* The number of rows of the matrix A. M >= 0.
+*
+* N (input) INTEGER
+* The number of columns of the matrix A. N >= 0
+*
+* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+* On entry, the M-by-N matrix A.
+* On exit, the upper triangle of the array contains the
+* min(M,N)-by-N upper triangular matrix R; the elements
+* below the diagonal, together with the array TAU,
+* represent the orthogonal matrix Q as a product of
+* min(m,n) elementary reflectors.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,M).
+*
+* JPVT (input/output) INTEGER array, dimension (N)
+* On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted
+* to the front of A*P (a leading column); if JPVT(i) = 0,
+* the i-th column of A is a free column.
+* On exit, if JPVT(i) = k, then the i-th column of A*P
+* was the k-th column of A.
+*
+* TAU (output) DOUBLE PRECISION array, dimension (min(M,N))
+* The scalar factors of the elementary reflectors.
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (3*N)
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+*
+* Further Details
+* ===============
+*
+* The matrix Q is represented as a product of elementary reflectors
+*
+* Q = H(1) H(2) . . . H(n)
+*
+* Each H(i) has the form
+*
+* H = I - tau * v * v'
+*
+* where tau is a real scalar, and v is a real vector with
+* v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i).
+*
+* The matrix P is represented in jpvt as follows: If
+* jpvt(j) = i
+* then the jth column of P is the ith canonical unit vector.
+*
+* Partial column norm updating strategy modified by
+* Z. Drmac and Z. Bujanovic, Dept. of Mathematics,
+* University of Zagreb, Croatia.
+* June 2006.
+* For more details see LAPACK Working Note 176.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, ITEMP, J, MA, MN, PVT
+ DOUBLE PRECISION AII, TEMP, TEMP2, TOL3Z
+* ..
+* .. External Subroutines ..
+ EXTERNAL DGEQR2, DLARF, DLARFG, DORM2R, DSWAP, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, MIN, SQRT
+* ..
+* .. External Functions ..
+ INTEGER IDAMAX
+ DOUBLE PRECISION DLAMCH, DNRM2
+ EXTERNAL IDAMAX, DLAMCH, DNRM2
+* ..
+* .. Executable Statements ..
+*
+* Test the input arguments
+*
+ INFO = 0
+ IF( M.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+ INFO = -4
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DGEQPF', -INFO )
+ RETURN
+ END IF
+*
+ MN = MIN( M, N )
+ TOL3Z = SQRT(DLAMCH('Epsilon'))
+*
+* Move initial columns up front
+*
+ ITEMP = 1
+ DO 10 I = 1, N
+ IF( JPVT( I ).NE.0 ) THEN
+ IF( I.NE.ITEMP ) THEN
+ CALL DSWAP( M, A( 1, I ), 1, A( 1, ITEMP ), 1 )
+ JPVT( I ) = JPVT( ITEMP )
+ JPVT( ITEMP ) = I
+ ELSE
+ JPVT( I ) = I
+ END IF
+ ITEMP = ITEMP + 1
+ ELSE
+ JPVT( I ) = I
+ END IF
+ 10 CONTINUE
+ ITEMP = ITEMP - 1
+*
+* Compute the QR factorization and update remaining columns
+*
+ IF( ITEMP.GT.0 ) THEN
+ MA = MIN( ITEMP, M )
+ CALL DGEQR2( M, MA, A, LDA, TAU, WORK, INFO )
+ IF( MA.LT.N ) THEN
+ CALL DORM2R( 'Left', 'Transpose', M, N-MA, MA, A, LDA, TAU,
+ $ A( 1, MA+1 ), LDA, WORK, INFO )
+ END IF
+ END IF
+*
+ IF( ITEMP.LT.MN ) THEN
+*
+* Initialize partial column norms. The first n elements of
+* work store the exact column norms.
+*
+ DO 20 I = ITEMP + 1, N
+ WORK( I ) = DNRM2( M-ITEMP, A( ITEMP+1, I ), 1 )
+ WORK( N+I ) = WORK( I )
+ 20 CONTINUE
+*
+* Compute factorization
+*
+ DO 40 I = ITEMP + 1, MN
+*
+* Determine ith pivot column and swap if necessary
+*
+ PVT = ( I-1 ) + IDAMAX( N-I+1, WORK( I ), 1 )
+*
+ IF( PVT.NE.I ) THEN
+ CALL DSWAP( M, A( 1, PVT ), 1, A( 1, I ), 1 )
+ ITEMP = JPVT( PVT )
+ JPVT( PVT ) = JPVT( I )
+ JPVT( I ) = ITEMP
+ WORK( PVT ) = WORK( I )
+ WORK( N+PVT ) = WORK( N+I )
+ END IF
+*
+* Generate elementary reflector H(i)
+*
+ IF( I.LT.M ) THEN
+ CALL DLARFG( M-I+1, A( I, I ), A( I+1, I ), 1, TAU( I ) )
+ ELSE
+ CALL DLARFG( 1, A( M, M ), A( M, M ), 1, TAU( M ) )
+ END IF
+*
+ IF( I.LT.N ) THEN
+*
+* Apply H(i) to A(i:m,i+1:n) from the left
+*
+ AII = A( I, I )
+ A( I, I ) = ONE
+ CALL DLARF( 'LEFT', M-I+1, N-I, A( I, I ), 1, TAU( I ),
+ $ A( I, I+1 ), LDA, WORK( 2*N+1 ) )
+ A( I, I ) = AII
+ END IF
+*
+* Update partial column norms
+*
+ DO 30 J = I + 1, N
+ IF( WORK( J ).NE.ZERO ) THEN
+*
+* NOTE: The following 4 lines follow from the analysis in
+* Lapack Working Note 176.
+*
+ TEMP = ABS( A( I, J ) ) / WORK( J )
+ TEMP = MAX( ZERO, ( ONE+TEMP )*( ONE-TEMP ) )
+ TEMP2 = TEMP*( WORK( J ) / WORK( N+J ) )**2
+ IF( TEMP2 .LE. TOL3Z ) THEN
+ IF( M-I.GT.0 ) THEN
+ WORK( J ) = DNRM2( M-I, A( I+1, J ), 1 )
+ WORK( N+J ) = WORK( J )
+ ELSE
+ WORK( J ) = ZERO
+ WORK( N+J ) = ZERO
+ END IF
+ ELSE
+ WORK( J ) = WORK( J )*SQRT( TEMP )
+ END IF
+ END IF
+ 30 CONTINUE
+*
+ 40 CONTINUE
+ END IF
+ RETURN
+*
+* End of DGEQPF
+*
+ END
+ SUBROUTINE DGEQR2( M, N, A, LDA, TAU, WORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LDA, M, N
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DGEQR2 computes a QR factorization of a real m by n matrix A:
+* A = Q * R.
+*
+* Arguments
+* =========
+*
+* M (input) INTEGER
+* The number of rows of the matrix A. M >= 0.
+*
+* N (input) INTEGER
+* The number of columns of the matrix A. N >= 0.
+*
+* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+* On entry, the m by n matrix A.
+* On exit, the elements on and above the diagonal of the array
+* contain the min(m,n) by n upper trapezoidal matrix R (R is
+* upper triangular if m >= n); the elements below the diagonal,
+* with the array TAU, represent the orthogonal matrix Q as a
+* product of elementary reflectors (see Further Details).
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,M).
+*
+* TAU (output) DOUBLE PRECISION array, dimension (min(M,N))
+* The scalar factors of the elementary reflectors (see Further
+* Details).
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (N)
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+*
+* Further Details
+* ===============
+*
+* The matrix Q is represented as a product of elementary reflectors
+*
+* Q = H(1) H(2) . . . H(k), where k = min(m,n).
+*
+* Each H(i) has the form
+*
+* H(i) = I - tau * v * v'
+*
+* where tau is a real scalar, and v is a real vector with
+* v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i),
+* and tau in TAU(i).
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE
+ PARAMETER ( ONE = 1.0D+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, K
+ DOUBLE PRECISION AII
+* ..
+* .. External Subroutines ..
+ EXTERNAL DLARF, DLARFG, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+* Test the input arguments
+*
+ INFO = 0
+ IF( M.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+ INFO = -4
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DGEQR2', -INFO )
+ RETURN
+ END IF
+*
+ K = MIN( M, N )
+*
+ DO 10 I = 1, K
+*
+* Generate elementary reflector H(i) to annihilate A(i+1:m,i)
+*
+ CALL DLARFG( M-I+1, A( I, I ), A( MIN( I+1, M ), I ), 1,
+ $ TAU( I ) )
+ IF( I.LT.N ) THEN
+*
+* Apply H(i) to A(i:m,i+1:n) from the left
+*
+ AII = A( I, I )
+ A( I, I ) = ONE
+ CALL DLARF( 'Left', M-I+1, N-I, A( I, I ), 1, TAU( I ),
+ $ A( I, I+1 ), LDA, WORK )
+ A( I, I ) = AII
+ END IF
+ 10 CONTINUE
+ RETURN
+*
+* End of DGEQR2
+*
+ END
+ SUBROUTINE DGEQRF( M, N, A, LDA, TAU, WORK, LWORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LDA, LWORK, M, N
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DGEQRF computes a QR factorization of a real M-by-N matrix A:
+* A = Q * R.
+*
+* Arguments
+* =========
+*
+* M (input) INTEGER
+* The number of rows of the matrix A. M >= 0.
+*
+* N (input) INTEGER
+* The number of columns of the matrix A. N >= 0.
+*
+* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+* On entry, the M-by-N matrix A.
+* On exit, the elements on and above the diagonal of the array
+* contain the min(M,N)-by-N upper trapezoidal matrix R (R is
+* upper triangular if m >= n); the elements below the diagonal,
+* with the array TAU, represent the orthogonal matrix Q as a
+* product of min(m,n) elementary reflectors (see Further
+* Details).
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,M).
+*
+* TAU (output) DOUBLE PRECISION array, dimension (min(M,N))
+* The scalar factors of the elementary reflectors (see Further
+* Details).
+*
+* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
+* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+* LWORK (input) INTEGER
+* The dimension of the array WORK. LWORK >= max(1,N).
+* For optimum performance LWORK >= N*NB, where NB is
+* the optimal blocksize.
+*
+* If LWORK = -1, then a workspace query is assumed; the routine
+* only calculates the optimal size of the WORK array, returns
+* this value as the first entry of the WORK array, and no error
+* message related to LWORK is issued by XERBLA.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+*
+* Further Details
+* ===============
+*
+* The matrix Q is represented as a product of elementary reflectors
+*
+* Q = H(1) H(2) . . . H(k), where k = min(m,n).
+*
+* Each H(i) has the form
+*
+* H(i) = I - tau * v * v'
+*
+* where tau is a real scalar, and v is a real vector with
+* v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i),
+* and tau in TAU(i).
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ LOGICAL LQUERY
+ INTEGER I, IB, IINFO, IWS, K, LDWORK, LWKOPT, NB,
+ $ NBMIN, NX
+* ..
+* .. External Subroutines ..
+ EXTERNAL DGEQR2, DLARFB, DLARFT, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN
+* ..
+* .. External Functions ..
+ INTEGER ILAENV
+ EXTERNAL ILAENV
+* ..
+* .. Executable Statements ..
+*
+* Test the input arguments
+*
+ INFO = 0
+ NB = ILAENV( 1, 'DGEQRF', ' ', M, N, -1, -1 )
+ LWKOPT = N*NB
+ WORK( 1 ) = LWKOPT
+ LQUERY = ( LWORK.EQ.-1 )
+ IF( M.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+ INFO = -4
+ ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN
+ INFO = -7
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DGEQRF', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ K = MIN( M, N )
+ IF( K.EQ.0 ) THEN
+ WORK( 1 ) = 1
+ RETURN
+ END IF
+*
+ NBMIN = 2
+ NX = 0
+ IWS = N
+ IF( NB.GT.1 .AND. NB.LT.K ) THEN
+*
+* Determine when to cross over from blocked to unblocked code.
+*
+ NX = MAX( 0, ILAENV( 3, 'DGEQRF', ' ', M, N, -1, -1 ) )
+ IF( NX.LT.K ) THEN
+*
+* Determine if workspace is large enough for blocked code.
+*
+ LDWORK = N
+ IWS = LDWORK*NB
+ IF( LWORK.LT.IWS ) THEN
+*
+* Not enough workspace to use optimal NB: reduce NB and
+* determine the minimum value of NB.
+*
+ NB = LWORK / LDWORK
+ NBMIN = MAX( 2, ILAENV( 2, 'DGEQRF', ' ', M, N, -1,
+ $ -1 ) )
+ END IF
+ END IF
+ END IF
+*
+ IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN
+*
+* Use blocked code initially
+*
+ DO 10 I = 1, K - NX, NB
+ IB = MIN( K-I+1, NB )
+*
+* Compute the QR factorization of the current block
+* A(i:m,i:i+ib-1)
+*
+ CALL DGEQR2( M-I+1, IB, A( I, I ), LDA, TAU( I ), WORK,
+ $ IINFO )
+ IF( I+IB.LE.N ) THEN
+*
+* Form the triangular factor of the block reflector
+* H = H(i) H(i+1) . . . H(i+ib-1)
+*
+ CALL DLARFT( 'Forward', 'Columnwise', M-I+1, IB,
+ $ A( I, I ), LDA, TAU( I ), WORK, LDWORK )
+*
+* Apply H' to A(i:m,i+ib:n) from the left
+*
+ CALL DLARFB( 'Left', 'Transpose', 'Forward',
+ $ 'Columnwise', M-I+1, N-I-IB+1, IB,
+ $ A( I, I ), LDA, WORK, LDWORK, A( I, I+IB ),
+ $ LDA, WORK( IB+1 ), LDWORK )
+ END IF
+ 10 CONTINUE
+ ELSE
+ I = 1
+ END IF
+*
+* Use unblocked code to factor the last or only block.
+*
+ IF( I.LE.K )
+ $ CALL DGEQR2( M-I+1, N-I+1, A( I, I ), LDA, TAU( I ), WORK,
+ $ IINFO )
+*
+ WORK( 1 ) = IWS
+ RETURN
+*
+* End of DGEQRF
+*
+ END
+ SUBROUTINE DGERFS( TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB,
+ $ X, LDX, FERR, BERR, WORK, IWORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH.
+*
+* .. Scalar Arguments ..
+ CHARACTER TRANS
+ INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * ), IWORK( * )
+ DOUBLE PRECISION A( LDA, * ), AF( LDAF, * ), B( LDB, * ),
+ $ BERR( * ), FERR( * ), WORK( * ), X( LDX, * )
+* ..
+*
+* Purpose
+* =======
+*
+* DGERFS improves the computed solution to a system of linear
+* equations and provides error bounds and backward error estimates for
+* the solution.
+*
+* Arguments
+* =========
+*
+* TRANS (input) CHARACTER*1
+* Specifies the form of the system of equations:
+* = 'N': A * X = B (No transpose)
+* = 'T': A**T * X = B (Transpose)
+* = 'C': A**H * X = B (Conjugate transpose = Transpose)
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* NRHS (input) INTEGER
+* The number of right hand sides, i.e., the number of columns
+* of the matrices B and X. NRHS >= 0.
+*
+* A (input) DOUBLE PRECISION array, dimension (LDA,N)
+* The original N-by-N matrix A.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,N).
+*
+* AF (input) DOUBLE PRECISION array, dimension (LDAF,N)
+* The factors L and U from the factorization A = P*L*U
+* as computed by DGETRF.
+*
+* LDAF (input) INTEGER
+* The leading dimension of the array AF. LDAF >= max(1,N).
+*
+* IPIV (input) INTEGER array, dimension (N)
+* The pivot indices from DGETRF; for 1<=i<=N, row i of the
+* matrix was interchanged with row IPIV(i).
+*
+* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS)
+* The right hand side matrix B.
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. LDB >= max(1,N).
+*
+* X (input/output) DOUBLE PRECISION array, dimension (LDX,NRHS)
+* On entry, the solution matrix X, as computed by DGETRS.
+* On exit, the improved solution matrix X.
+*
+* LDX (input) INTEGER
+* The leading dimension of the array X. LDX >= max(1,N).
+*
+* FERR (output) DOUBLE PRECISION array, dimension (NRHS)
+* The estimated forward error bound for each solution vector
+* X(j) (the j-th column of the solution matrix X).
+* If XTRUE is the true solution corresponding to X(j), FERR(j)
+* is an estimated upper bound for the magnitude of the largest
+* element in (X(j) - XTRUE) divided by the magnitude of the
+* largest element in X(j). The estimate is as reliable as
+* the estimate for RCOND, and is almost always a slight
+* overestimate of the true error.
+*
+* BERR (output) DOUBLE PRECISION array, dimension (NRHS)
+* The componentwise relative backward error of each solution
+* vector X(j) (i.e., the smallest relative change in
+* any element of A or B that makes X(j) an exact solution).
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (3*N)
+*
+* IWORK (workspace) INTEGER array, dimension (N)
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+*
+* Internal Parameters
+* ===================
+*
+* ITMAX is the maximum number of steps of iterative refinement.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ INTEGER ITMAX
+ PARAMETER ( ITMAX = 5 )
+ DOUBLE PRECISION ZERO
+ PARAMETER ( ZERO = 0.0D+0 )
+ DOUBLE PRECISION ONE
+ PARAMETER ( ONE = 1.0D+0 )
+ DOUBLE PRECISION TWO
+ PARAMETER ( TWO = 2.0D+0 )
+ DOUBLE PRECISION THREE
+ PARAMETER ( THREE = 3.0D+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL NOTRAN
+ CHARACTER TRANST
+ INTEGER COUNT, I, J, K, KASE, NZ
+ DOUBLE PRECISION EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK
+* ..
+* .. Local Arrays ..
+ INTEGER ISAVE( 3 )
+* ..
+* .. External Subroutines ..
+ EXTERNAL DAXPY, DCOPY, DGEMV, DGETRS, DLACN2, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ DOUBLE PRECISION DLAMCH
+ EXTERNAL LSAME, DLAMCH
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ NOTRAN = LSAME( TRANS, 'N' )
+ IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT.
+ $ LSAME( TRANS, 'C' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( NRHS.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -5
+ ELSE IF( LDAF.LT.MAX( 1, N ) ) THEN
+ INFO = -7
+ ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -10
+ ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
+ INFO = -12
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DGERFS', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN
+ DO 10 J = 1, NRHS
+ FERR( J ) = ZERO
+ BERR( J ) = ZERO
+ 10 CONTINUE
+ RETURN
+ END IF
+*
+ IF( NOTRAN ) THEN
+ TRANST = 'T'
+ ELSE
+ TRANST = 'N'
+ END IF
+*
+* NZ = maximum number of nonzero elements in each row of A, plus 1
+*
+ NZ = N + 1
+ EPS = DLAMCH( 'Epsilon' )
+ SAFMIN = DLAMCH( 'Safe minimum' )
+ SAFE1 = NZ*SAFMIN
+ SAFE2 = SAFE1 / EPS
+*
+* Do for each right hand side
+*
+ DO 140 J = 1, NRHS
+*
+ COUNT = 1
+ LSTRES = THREE
+ 20 CONTINUE
+*
+* Loop until stopping criterion is satisfied.
+*
+* Compute residual R = B - op(A) * X,
+* where op(A) = A, A**T, or A**H, depending on TRANS.
+*
+ CALL DCOPY( N, B( 1, J ), 1, WORK( N+1 ), 1 )
+ CALL DGEMV( TRANS, N, N, -ONE, A, LDA, X( 1, J ), 1, ONE,
+ $ WORK( N+1 ), 1 )
+*
+* Compute componentwise relative backward error from formula
+*
+* max(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) )
+*
+* where abs(Z) is the componentwise absolute value of the matrix
+* or vector Z. If the i-th component of the denominator is less
+* than SAFE2, then SAFE1 is added to the i-th components of the
+* numerator and denominator before dividing.
+*
+ DO 30 I = 1, N
+ WORK( I ) = ABS( B( I, J ) )
+ 30 CONTINUE
+*
+* Compute abs(op(A))*abs(X) + abs(B).
+*
+ IF( NOTRAN ) THEN
+ DO 50 K = 1, N
+ XK = ABS( X( K, J ) )
+ DO 40 I = 1, N
+ WORK( I ) = WORK( I ) + ABS( A( I, K ) )*XK
+ 40 CONTINUE
+ 50 CONTINUE
+ ELSE
+ DO 70 K = 1, N
+ S = ZERO
+ DO 60 I = 1, N
+ S = S + ABS( A( I, K ) )*ABS( X( I, J ) )
+ 60 CONTINUE
+ WORK( K ) = WORK( K ) + S
+ 70 CONTINUE
+ END IF
+ S = ZERO
+ DO 80 I = 1, N
+ IF( WORK( I ).GT.SAFE2 ) THEN
+ S = MAX( S, ABS( WORK( N+I ) ) / WORK( I ) )
+ ELSE
+ S = MAX( S, ( ABS( WORK( N+I ) )+SAFE1 ) /
+ $ ( WORK( I )+SAFE1 ) )
+ END IF
+ 80 CONTINUE
+ BERR( J ) = S
+*
+* Test stopping criterion. Continue iterating if
+* 1) The residual BERR(J) is larger than machine epsilon, and
+* 2) BERR(J) decreased by at least a factor of 2 during the
+* last iteration, and
+* 3) At most ITMAX iterations tried.
+*
+ IF( BERR( J ).GT.EPS .AND. TWO*BERR( J ).LE.LSTRES .AND.
+ $ COUNT.LE.ITMAX ) THEN
+*
+* Update solution and try again.
+*
+ CALL DGETRS( TRANS, N, 1, AF, LDAF, IPIV, WORK( N+1 ), N,
+ $ INFO )
+ CALL DAXPY( N, ONE, WORK( N+1 ), 1, X( 1, J ), 1 )
+ LSTRES = BERR( J )
+ COUNT = COUNT + 1
+ GO TO 20
+ END IF
+*
+* Bound error from formula
+*
+* norm(X - XTRUE) / norm(X) .le. FERR =
+* norm( abs(inv(op(A)))*
+* ( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X)
+*
+* where
+* norm(Z) is the magnitude of the largest component of Z
+* inv(op(A)) is the inverse of op(A)
+* abs(Z) is the componentwise absolute value of the matrix or
+* vector Z
+* NZ is the maximum number of nonzeros in any row of A, plus 1
+* EPS is machine epsilon
+*
+* The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B))
+* is incremented by SAFE1 if the i-th component of
+* abs(op(A))*abs(X) + abs(B) is less than SAFE2.
+*
+* Use DLACN2 to estimate the infinity-norm of the matrix
+* inv(op(A)) * diag(W),
+* where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) )))
+*
+ DO 90 I = 1, N
+ IF( WORK( I ).GT.SAFE2 ) THEN
+ WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I )
+ ELSE
+ WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I ) + SAFE1
+ END IF
+ 90 CONTINUE
+*
+ KASE = 0
+ 100 CONTINUE
+ CALL DLACN2( N, WORK( 2*N+1 ), WORK( N+1 ), IWORK, FERR( J ),
+ $ KASE, ISAVE )
+ IF( KASE.NE.0 ) THEN
+ IF( KASE.EQ.1 ) THEN
+*
+* Multiply by diag(W)*inv(op(A)**T).
+*
+ CALL DGETRS( TRANST, N, 1, AF, LDAF, IPIV, WORK( N+1 ),
+ $ N, INFO )
+ DO 110 I = 1, N
+ WORK( N+I ) = WORK( I )*WORK( N+I )
+ 110 CONTINUE
+ ELSE
+*
+* Multiply by inv(op(A))*diag(W).
+*
+ DO 120 I = 1, N
+ WORK( N+I ) = WORK( I )*WORK( N+I )
+ 120 CONTINUE
+ CALL DGETRS( TRANS, N, 1, AF, LDAF, IPIV, WORK( N+1 ), N,
+ $ INFO )
+ END IF
+ GO TO 100
+ END IF
+*
+* Normalize error.
+*
+ LSTRES = ZERO
+ DO 130 I = 1, N
+ LSTRES = MAX( LSTRES, ABS( X( I, J ) ) )
+ 130 CONTINUE
+ IF( LSTRES.NE.ZERO )
+ $ FERR( J ) = FERR( J ) / LSTRES
+*
+ 140 CONTINUE
+*
+ RETURN
+*
+* End of DGERFS
+*
+ END
+ SUBROUTINE DGERQ2( M, N, A, LDA, TAU, WORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LDA, M, N
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DGERQ2 computes an RQ factorization of a real m by n matrix A:
+* A = R * Q.
+*
+* Arguments
+* =========
+*
+* M (input) INTEGER
+* The number of rows of the matrix A. M >= 0.
+*
+* N (input) INTEGER
+* The number of columns of the matrix A. N >= 0.
+*
+* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+* On entry, the m by n matrix A.
+* On exit, if m <= n, the upper triangle of the subarray
+* A(1:m,n-m+1:n) contains the m by m upper triangular matrix R;
+* if m >= n, the elements on and above the (m-n)-th subdiagonal
+* contain the m by n upper trapezoidal matrix R; the remaining
+* elements, with the array TAU, represent the orthogonal matrix
+* Q as a product of elementary reflectors (see Further
+* Details).
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,M).
+*
+* TAU (output) DOUBLE PRECISION array, dimension (min(M,N))
+* The scalar factors of the elementary reflectors (see Further
+* Details).
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (M)
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+*
+* Further Details
+* ===============
+*
+* The matrix Q is represented as a product of elementary reflectors
+*
+* Q = H(1) H(2) . . . H(k), where k = min(m,n).
+*
+* Each H(i) has the form
+*
+* H(i) = I - tau * v * v'
+*
+* where tau is a real scalar, and v is a real vector with
+* v(n-k+i+1:n) = 0 and v(n-k+i) = 1; v(1:n-k+i-1) is stored on exit in
+* A(m-k+i,1:n-k+i-1), and tau in TAU(i).
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE
+ PARAMETER ( ONE = 1.0D+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, K
+ DOUBLE PRECISION AII
+* ..
+* .. External Subroutines ..
+ EXTERNAL DLARF, DLARFG, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+* Test the input arguments
+*
+ INFO = 0
+ IF( M.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+ INFO = -4
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DGERQ2', -INFO )
+ RETURN
+ END IF
+*
+ K = MIN( M, N )
+*
+ DO 10 I = K, 1, -1
+*
+* Generate elementary reflector H(i) to annihilate
+* A(m-k+i,1:n-k+i-1)
+*
+ CALL DLARFG( N-K+I, A( M-K+I, N-K+I ), A( M-K+I, 1 ), LDA,
+ $ TAU( I ) )
+*
+* Apply H(i) to A(1:m-k+i-1,1:n-k+i) from the right
+*
+ AII = A( M-K+I, N-K+I )
+ A( M-K+I, N-K+I ) = ONE
+ CALL DLARF( 'Right', M-K+I-1, N-K+I, A( M-K+I, 1 ), LDA,
+ $ TAU( I ), A, LDA, WORK )
+ A( M-K+I, N-K+I ) = AII
+ 10 CONTINUE
+ RETURN
+*
+* End of DGERQ2
+*
+ END
+ SUBROUTINE DGERQF( M, N, A, LDA, TAU, WORK, LWORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LDA, LWORK, M, N
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DGERQF computes an RQ factorization of a real M-by-N matrix A:
+* A = R * Q.
+*
+* Arguments
+* =========
+*
+* M (input) INTEGER
+* The number of rows of the matrix A. M >= 0.
+*
+* N (input) INTEGER
+* The number of columns of the matrix A. N >= 0.
+*
+* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+* On entry, the M-by-N matrix A.
+* On exit,
+* if m <= n, the upper triangle of the subarray
+* A(1:m,n-m+1:n) contains the M-by-M upper triangular matrix R;
+* if m >= n, the elements on and above the (m-n)-th subdiagonal
+* contain the M-by-N upper trapezoidal matrix R;
+* the remaining elements, with the array TAU, represent the
+* orthogonal matrix Q as a product of min(m,n) elementary
+* reflectors (see Further Details).
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,M).
+*
+* TAU (output) DOUBLE PRECISION array, dimension (min(M,N))
+* The scalar factors of the elementary reflectors (see Further
+* Details).
+*
+* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
+* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+* LWORK (input) INTEGER
+* The dimension of the array WORK. LWORK >= max(1,M).
+* For optimum performance LWORK >= M*NB, where NB is
+* the optimal blocksize.
+*
+* If LWORK = -1, then a workspace query is assumed; the routine
+* only calculates the optimal size of the WORK array, returns
+* this value as the first entry of the WORK array, and no error
+* message related to LWORK is issued by XERBLA.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+*
+* Further Details
+* ===============
+*
+* The matrix Q is represented as a product of elementary reflectors
+*
+* Q = H(1) H(2) . . . H(k), where k = min(m,n).
+*
+* Each H(i) has the form
+*
+* H(i) = I - tau * v * v'
+*
+* where tau is a real scalar, and v is a real vector with
+* v(n-k+i+1:n) = 0 and v(n-k+i) = 1; v(1:n-k+i-1) is stored on exit in
+* A(m-k+i,1:n-k+i-1), and tau in TAU(i).
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ LOGICAL LQUERY
+ INTEGER I, IB, IINFO, IWS, K, KI, KK, LDWORK, LWKOPT,
+ $ MU, NB, NBMIN, NU, NX
+* ..
+* .. External Subroutines ..
+ EXTERNAL DGERQ2, DLARFB, DLARFT, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN
+* ..
+* .. External Functions ..
+ INTEGER ILAENV
+ EXTERNAL ILAENV
+* ..
+* .. Executable Statements ..
+*
+* Test the input arguments
+*
+ INFO = 0
+ LQUERY = ( LWORK.EQ.-1 )
+ IF( M.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+ INFO = -4
+ END IF
+*
+ IF( INFO.EQ.0 ) THEN
+ K = MIN( M, N )
+ IF( K.EQ.0 ) THEN
+ LWKOPT = 1
+ ELSE
+ NB = ILAENV( 1, 'DGERQF', ' ', M, N, -1, -1 )
+ LWKOPT = M*NB
+ END IF
+ WORK( 1 ) = LWKOPT
+*
+ IF( LWORK.LT.MAX( 1, M ) .AND. .NOT.LQUERY ) THEN
+ INFO = -7
+ END IF
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DGERQF', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( K.EQ.0 ) THEN
+ RETURN
+ END IF
+*
+ NBMIN = 2
+ NX = 1
+ IWS = M
+ IF( NB.GT.1 .AND. NB.LT.K ) THEN
+*
+* Determine when to cross over from blocked to unblocked code.
+*
+ NX = MAX( 0, ILAENV( 3, 'DGERQF', ' ', M, N, -1, -1 ) )
+ IF( NX.LT.K ) THEN
+*
+* Determine if workspace is large enough for blocked code.
+*
+ LDWORK = M
+ IWS = LDWORK*NB
+ IF( LWORK.LT.IWS ) THEN
+*
+* Not enough workspace to use optimal NB: reduce NB and
+* determine the minimum value of NB.
+*
+ NB = LWORK / LDWORK
+ NBMIN = MAX( 2, ILAENV( 2, 'DGERQF', ' ', M, N, -1,
+ $ -1 ) )
+ END IF
+ END IF
+ END IF
+*
+ IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN
+*
+* Use blocked code initially.
+* The last kk rows are handled by the block method.
+*
+ KI = ( ( K-NX-1 ) / NB )*NB
+ KK = MIN( K, KI+NB )
+*
+ DO 10 I = K - KK + KI + 1, K - KK + 1, -NB
+ IB = MIN( K-I+1, NB )
+*
+* Compute the RQ factorization of the current block
+* A(m-k+i:m-k+i+ib-1,1:n-k+i+ib-1)
+*
+ CALL DGERQ2( IB, N-K+I+IB-1, A( M-K+I, 1 ), LDA, TAU( I ),
+ $ WORK, IINFO )
+ IF( M-K+I.GT.1 ) THEN
+*
+* Form the triangular factor of the block reflector
+* H = H(i+ib-1) . . . H(i+1) H(i)
+*
+ CALL DLARFT( 'Backward', 'Rowwise', N-K+I+IB-1, IB,
+ $ A( M-K+I, 1 ), LDA, TAU( I ), WORK, LDWORK )
+*
+* Apply H to A(1:m-k+i-1,1:n-k+i+ib-1) from the right
+*
+ CALL DLARFB( 'Right', 'No transpose', 'Backward',
+ $ 'Rowwise', M-K+I-1, N-K+I+IB-1, IB,
+ $ A( M-K+I, 1 ), LDA, WORK, LDWORK, A, LDA,
+ $ WORK( IB+1 ), LDWORK )
+ END IF
+ 10 CONTINUE
+ MU = M - K + I + NB - 1
+ NU = N - K + I + NB - 1
+ ELSE
+ MU = M
+ NU = N
+ END IF
+*
+* Use unblocked code to factor the last or only block
+*
+ IF( MU.GT.0 .AND. NU.GT.0 )
+ $ CALL DGERQ2( MU, NU, A, LDA, TAU, WORK, IINFO )
+*
+ WORK( 1 ) = IWS
+ RETURN
+*
+* End of DGERQF
+*
+ END
+ SUBROUTINE DGESC2( N, A, LDA, RHS, IPIV, JPIV, SCALE )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER LDA, N
+ DOUBLE PRECISION SCALE
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * ), JPIV( * )
+ DOUBLE PRECISION A( LDA, * ), RHS( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DGESC2 solves a system of linear equations
+*
+* A * X = scale* RHS
+*
+* with a general N-by-N matrix A using the LU factorization with
+* complete pivoting computed by DGETC2.
+*
+* Arguments
+* =========
+*
+* N (input) INTEGER
+* The order of the matrix A.
+*
+* A (input) DOUBLE PRECISION array, dimension (LDA,N)
+* On entry, the LU part of the factorization of the n-by-n
+* matrix A computed by DGETC2: A = P * L * U * Q
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1, N).
+*
+* RHS (input/output) DOUBLE PRECISION array, dimension (N).
+* On entry, the right hand side vector b.
+* On exit, the solution vector X.
+*
+* IPIV (input) INTEGER array, dimension (N).
+* The pivot indices; for 1 <= i <= N, row i of the
+* matrix has been interchanged with row IPIV(i).
+*
+* JPIV (input) INTEGER array, dimension (N).
+* The pivot indices; for 1 <= j <= N, column j of the
+* matrix has been interchanged with column JPIV(j).
+*
+* SCALE (output) DOUBLE PRECISION
+* On exit, SCALE contains the scale factor. SCALE is chosen
+* 0 <= SCALE <= 1 to prevent owerflow in the solution.
+*
+* Further Details
+* ===============
+*
+* Based on contributions by
+* Bo Kagstrom and Peter Poromaa, Department of Computing Science,
+* Umea University, S-901 87 Umea, Sweden.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE, TWO
+ PARAMETER ( ONE = 1.0D+0, TWO = 2.0D+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, J
+ DOUBLE PRECISION BIGNUM, EPS, SMLNUM, TEMP
+* ..
+* .. External Subroutines ..
+ EXTERNAL DLASWP, DSCAL
+* ..
+* .. External Functions ..
+ INTEGER IDAMAX
+ DOUBLE PRECISION DLAMCH
+ EXTERNAL IDAMAX, DLAMCH
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS
+* ..
+* .. Executable Statements ..
+*
+* Set constant to control owerflow
+*
+ EPS = DLAMCH( 'P' )
+ SMLNUM = DLAMCH( 'S' ) / EPS
+ BIGNUM = ONE / SMLNUM
+ CALL DLABAD( SMLNUM, BIGNUM )
+*
+* Apply permutations IPIV to RHS
+*
+ CALL DLASWP( 1, RHS, LDA, 1, N-1, IPIV, 1 )
+*
+* Solve for L part
+*
+ DO 20 I = 1, N - 1
+ DO 10 J = I + 1, N
+ RHS( J ) = RHS( J ) - A( J, I )*RHS( I )
+ 10 CONTINUE
+ 20 CONTINUE
+*
+* Solve for U part
+*
+ SCALE = ONE
+*
+* Check for scaling
+*
+ I = IDAMAX( N, RHS, 1 )
+ IF( TWO*SMLNUM*ABS( RHS( I ) ).GT.ABS( A( N, N ) ) ) THEN
+ TEMP = ( ONE / TWO ) / ABS( RHS( I ) )
+ CALL DSCAL( N, TEMP, RHS( 1 ), 1 )
+ SCALE = SCALE*TEMP
+ END IF
+*
+ DO 40 I = N, 1, -1
+ TEMP = ONE / A( I, I )
+ RHS( I ) = RHS( I )*TEMP
+ DO 30 J = I + 1, N
+ RHS( I ) = RHS( I ) - RHS( J )*( A( I, J )*TEMP )
+ 30 CONTINUE
+ 40 CONTINUE
+*
+* Apply permutations JPIV to the solution (RHS)
+*
+ CALL DLASWP( 1, RHS, LDA, 1, N-1, JPIV, -1 )
+ RETURN
+*
+* End of DGESC2
+*
+ END
+ SUBROUTINE DGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK,
+ $ LWORK, IWORK, INFO )
+*
+* -- LAPACK driver routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER JOBZ
+ INTEGER INFO, LDA, LDU, LDVT, LWORK, M, N
+* ..
+* .. Array Arguments ..
+ INTEGER IWORK( * )
+ DOUBLE PRECISION A( LDA, * ), S( * ), U( LDU, * ),
+ $ VT( LDVT, * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DGESDD computes the singular value decomposition (SVD) of a real
+* M-by-N matrix A, optionally computing the left and right singular
+* vectors. If singular vectors are desired, it uses a
+* divide-and-conquer algorithm.
+*
+* The SVD is written
+*
+* A = U * SIGMA * transpose(V)
+*
+* where SIGMA is an M-by-N matrix which is zero except for its
+* min(m,n) diagonal elements, U is an M-by-M orthogonal matrix, and
+* V is an N-by-N orthogonal matrix. The diagonal elements of SIGMA
+* are the singular values of A; they are real and non-negative, and
+* are returned in descending order. The first min(m,n) columns of
+* U and V are the left and right singular vectors of A.
+*
+* Note that the routine returns VT = V**T, not V.
+*
+* The divide and conquer algorithm makes very mild assumptions about
+* floating point arithmetic. It will work on machines with a guard
+* digit in add/subtract, or on those binary machines without guard
+* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
+* Cray-2. It could conceivably fail on hexadecimal or decimal machines
+* without guard digits, but we know of none.
+*
+* Arguments
+* =========
+*
+* JOBZ (input) CHARACTER*1
+* Specifies options for computing all or part of the matrix U:
+* = 'A': all M columns of U and all N rows of V**T are
+* returned in the arrays U and VT;
+* = 'S': the first min(M,N) columns of U and the first
+* min(M,N) rows of V**T are returned in the arrays U
+* and VT;
+* = 'O': If M >= N, the first N columns of U are overwritten
+* on the array A and all rows of V**T are returned in
+* the array VT;
+* otherwise, all columns of U are returned in the
+* array U and the first M rows of V**T are overwritten
+* in the array A;
+* = 'N': no columns of U or rows of V**T are computed.
+*
+* M (input) INTEGER
+* The number of rows of the input matrix A. M >= 0.
+*
+* N (input) INTEGER
+* The number of columns of the input matrix A. N >= 0.
+*
+* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+* On entry, the M-by-N matrix A.
+* On exit,
+* if JOBZ = 'O', A is overwritten with the first N columns
+* of U (the left singular vectors, stored
+* columnwise) if M >= N;
+* A is overwritten with the first M rows
+* of V**T (the right singular vectors, stored
+* rowwise) otherwise.
+* if JOBZ .ne. 'O', the contents of A are destroyed.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,M).
+*
+* S (output) DOUBLE PRECISION array, dimension (min(M,N))
+* The singular values of A, sorted so that S(i) >= S(i+1).
+*
+* U (output) DOUBLE PRECISION array, dimension (LDU,UCOL)
+* UCOL = M if JOBZ = 'A' or JOBZ = 'O' and M < N;
+* UCOL = min(M,N) if JOBZ = 'S'.
+* If JOBZ = 'A' or JOBZ = 'O' and M < N, U contains the M-by-M
+* orthogonal matrix U;
+* if JOBZ = 'S', U contains the first min(M,N) columns of U
+* (the left singular vectors, stored columnwise);
+* if JOBZ = 'O' and M >= N, or JOBZ = 'N', U is not referenced.
+*
+* LDU (input) INTEGER
+* The leading dimension of the array U. LDU >= 1; if
+* JOBZ = 'S' or 'A' or JOBZ = 'O' and M < N, LDU >= M.
+*
+* VT (output) DOUBLE PRECISION array, dimension (LDVT,N)
+* If JOBZ = 'A' or JOBZ = 'O' and M >= N, VT contains the
+* N-by-N orthogonal matrix V**T;
+* if JOBZ = 'S', VT contains the first min(M,N) rows of
+* V**T (the right singular vectors, stored rowwise);
+* if JOBZ = 'O' and M < N, or JOBZ = 'N', VT is not referenced.
+*
+* LDVT (input) INTEGER
+* The leading dimension of the array VT. LDVT >= 1; if
+* JOBZ = 'A' or JOBZ = 'O' and M >= N, LDVT >= N;
+* if JOBZ = 'S', LDVT >= min(M,N).
+*
+* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
+* On exit, if INFO = 0, WORK(1) returns the optimal LWORK;
+*
+* LWORK (input) INTEGER
+* The dimension of the array WORK. LWORK >= 1.
+* If JOBZ = 'N',
+* LWORK >= 3*min(M,N) + max(max(M,N),7*min(M,N)).
+* If JOBZ = 'O',
+* LWORK >= 3*min(M,N)*min(M,N) +
+* max(max(M,N),5*min(M,N)*min(M,N)+4*min(M,N)).
+* If JOBZ = 'S' or 'A'
+* LWORK >= 3*min(M,N)*min(M,N) +
+* max(max(M,N),4*min(M,N)*min(M,N)+4*min(M,N)).
+* For good performance, LWORK should generally be larger.
+* If LWORK = -1 but other input arguments are legal, WORK(1)
+* returns the optimal LWORK.
+*
+* IWORK (workspace) INTEGER array, dimension (8*min(M,N))
+*
+* INFO (output) INTEGER
+* = 0: successful exit.
+* < 0: if INFO = -i, the i-th argument had an illegal value.
+* > 0: DBDSDC did not converge, updating process failed.
+*
+* Further Details
+* ===============
+*
+* Based on contributions by
+* Ming Gu and Huan Ren, Computer Science Division, University of
+* California at Berkeley, USA
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL LQUERY, WNTQA, WNTQAS, WNTQN, WNTQO, WNTQS
+ INTEGER BDSPAC, BLK, CHUNK, I, IE, IERR, IL,
+ $ IR, ISCL, ITAU, ITAUP, ITAUQ, IU, IVT, LDWKVT,
+ $ LDWRKL, LDWRKR, LDWRKU, MAXWRK, MINMN, MINWRK,
+ $ MNTHR, NWORK, WRKBL
+ DOUBLE PRECISION ANRM, BIGNUM, EPS, SMLNUM
+* ..
+* .. Local Arrays ..
+ INTEGER IDUM( 1 )
+ DOUBLE PRECISION DUM( 1 )
+* ..
+* .. External Subroutines ..
+ EXTERNAL DBDSDC, DGEBRD, DGELQF, DGEMM, DGEQRF, DLACPY,
+ $ DLASCL, DLASET, DORGBR, DORGLQ, DORGQR, DORMBR,
+ $ XERBLA
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ILAENV
+ DOUBLE PRECISION DLAMCH, DLANGE
+ EXTERNAL DLAMCH, DLANGE, ILAENV, LSAME
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC INT, MAX, MIN, SQRT
+* ..
+* .. Executable Statements ..
+*
+* Test the input arguments
+*
+ INFO = 0
+ MINMN = MIN( M, N )
+ WNTQA = LSAME( JOBZ, 'A' )
+ WNTQS = LSAME( JOBZ, 'S' )
+ WNTQAS = WNTQA .OR. WNTQS
+ WNTQO = LSAME( JOBZ, 'O' )
+ WNTQN = LSAME( JOBZ, 'N' )
+ LQUERY = ( LWORK.EQ.-1 )
+*
+ IF( .NOT.( WNTQA .OR. WNTQS .OR. WNTQO .OR. WNTQN ) ) THEN
+ INFO = -1
+ ELSE IF( M.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+ INFO = -5
+ ELSE IF( LDU.LT.1 .OR. ( WNTQAS .AND. LDU.LT.M ) .OR.
+ $ ( WNTQO .AND. M.LT.N .AND. LDU.LT.M ) ) THEN
+ INFO = -8
+ ELSE IF( LDVT.LT.1 .OR. ( WNTQA .AND. LDVT.LT.N ) .OR.
+ $ ( WNTQS .AND. LDVT.LT.MINMN ) .OR.
+ $ ( WNTQO .AND. M.GE.N .AND. LDVT.LT.N ) ) THEN
+ INFO = -10
+ END IF
+*
+* Compute workspace
+* (Note: Comments in the code beginning "Workspace:" describe the
+* minimal amount of workspace needed at that point in the code,
+* as well as the preferred amount for good performance.
+* NB refers to the optimal block size for the immediately
+* following subroutine, as returned by ILAENV.)
+*
+ IF( INFO.EQ.0 ) THEN
+ MINWRK = 1
+ MAXWRK = 1
+ IF( M.GE.N .AND. MINMN.GT.0 ) THEN
+*
+* Compute space needed for DBDSDC
+*
+ MNTHR = INT( MINMN*11.0D0 / 6.0D0 )
+ IF( WNTQN ) THEN
+ BDSPAC = 7*N
+ ELSE
+ BDSPAC = 3*N*N + 4*N
+ END IF
+ IF( M.GE.MNTHR ) THEN
+ IF( WNTQN ) THEN
+*
+* Path 1 (M much larger than N, JOBZ='N')
+*
+ WRKBL = N + N*ILAENV( 1, 'DGEQRF', ' ', M, N, -1,
+ $ -1 )
+ WRKBL = MAX( WRKBL, 3*N+2*N*
+ $ ILAENV( 1, 'DGEBRD', ' ', N, N, -1, -1 ) )
+ MAXWRK = MAX( WRKBL, BDSPAC+N )
+ MINWRK = BDSPAC + N
+ ELSE IF( WNTQO ) THEN
+*
+* Path 2 (M much larger than N, JOBZ='O')
+*
+ WRKBL = N + N*ILAENV( 1, 'DGEQRF', ' ', M, N, -1, -1 )
+ WRKBL = MAX( WRKBL, N+N*ILAENV( 1, 'DORGQR', ' ', M,
+ $ N, N, -1 ) )
+ WRKBL = MAX( WRKBL, 3*N+2*N*
+ $ ILAENV( 1, 'DGEBRD', ' ', N, N, -1, -1 ) )
+ WRKBL = MAX( WRKBL, 3*N+N*
+ $ ILAENV( 1, 'DORMBR', 'QLN', N, N, N, -1 ) )
+ WRKBL = MAX( WRKBL, 3*N+N*
+ $ ILAENV( 1, 'DORMBR', 'PRT', N, N, N, -1 ) )
+ WRKBL = MAX( WRKBL, BDSPAC+3*N )
+ MAXWRK = WRKBL + 2*N*N
+ MINWRK = BDSPAC + 2*N*N + 3*N
+ ELSE IF( WNTQS ) THEN
+*
+* Path 3 (M much larger than N, JOBZ='S')
+*
+ WRKBL = N + N*ILAENV( 1, 'DGEQRF', ' ', M, N, -1, -1 )
+ WRKBL = MAX( WRKBL, N+N*ILAENV( 1, 'DORGQR', ' ', M,
+ $ N, N, -1 ) )
+ WRKBL = MAX( WRKBL, 3*N+2*N*
+ $ ILAENV( 1, 'DGEBRD', ' ', N, N, -1, -1 ) )
+ WRKBL = MAX( WRKBL, 3*N+N*
+ $ ILAENV( 1, 'DORMBR', 'QLN', N, N, N, -1 ) )
+ WRKBL = MAX( WRKBL, 3*N+N*
+ $ ILAENV( 1, 'DORMBR', 'PRT', N, N, N, -1 ) )
+ WRKBL = MAX( WRKBL, BDSPAC+3*N )
+ MAXWRK = WRKBL + N*N
+ MINWRK = BDSPAC + N*N + 3*N
+ ELSE IF( WNTQA ) THEN
+*
+* Path 4 (M much larger than N, JOBZ='A')
+*
+ WRKBL = N + N*ILAENV( 1, 'DGEQRF', ' ', M, N, -1, -1 )
+ WRKBL = MAX( WRKBL, N+M*ILAENV( 1, 'DORGQR', ' ', M,
+ $ M, N, -1 ) )
+ WRKBL = MAX( WRKBL, 3*N+2*N*
+ $ ILAENV( 1, 'DGEBRD', ' ', N, N, -1, -1 ) )
+ WRKBL = MAX( WRKBL, 3*N+N*
+ $ ILAENV( 1, 'DORMBR', 'QLN', N, N, N, -1 ) )
+ WRKBL = MAX( WRKBL, 3*N+N*
+ $ ILAENV( 1, 'DORMBR', 'PRT', N, N, N, -1 ) )
+ WRKBL = MAX( WRKBL, BDSPAC+3*N )
+ MAXWRK = WRKBL + N*N
+ MINWRK = BDSPAC + N*N + 3*N
+ END IF
+ ELSE
+*
+* Path 5 (M at least N, but not much larger)
+*
+ WRKBL = 3*N + ( M+N )*ILAENV( 1, 'DGEBRD', ' ', M, N, -1,
+ $ -1 )
+ IF( WNTQN ) THEN
+ MAXWRK = MAX( WRKBL, BDSPAC+3*N )
+ MINWRK = 3*N + MAX( M, BDSPAC )
+ ELSE IF( WNTQO ) THEN
+ WRKBL = MAX( WRKBL, 3*N+N*
+ $ ILAENV( 1, 'DORMBR', 'QLN', M, N, N, -1 ) )
+ WRKBL = MAX( WRKBL, 3*N+N*
+ $ ILAENV( 1, 'DORMBR', 'PRT', N, N, N, -1 ) )
+ WRKBL = MAX( WRKBL, BDSPAC+3*N )
+ MAXWRK = WRKBL + M*N
+ MINWRK = 3*N + MAX( M, N*N+BDSPAC )
+ ELSE IF( WNTQS ) THEN
+ WRKBL = MAX( WRKBL, 3*N+N*
+ $ ILAENV( 1, 'DORMBR', 'QLN', M, N, N, -1 ) )
+ WRKBL = MAX( WRKBL, 3*N+N*
+ $ ILAENV( 1, 'DORMBR', 'PRT', N, N, N, -1 ) )
+ MAXWRK = MAX( WRKBL, BDSPAC+3*N )
+ MINWRK = 3*N + MAX( M, BDSPAC )
+ ELSE IF( WNTQA ) THEN
+ WRKBL = MAX( WRKBL, 3*N+M*
+ $ ILAENV( 1, 'DORMBR', 'QLN', M, M, N, -1 ) )
+ WRKBL = MAX( WRKBL, 3*N+N*
+ $ ILAENV( 1, 'DORMBR', 'PRT', N, N, N, -1 ) )
+ MAXWRK = MAX( MAXWRK, BDSPAC+3*N )
+ MINWRK = 3*N + MAX( M, BDSPAC )
+ END IF
+ END IF
+ ELSE IF( MINMN.GT.0 ) THEN
+*
+* Compute space needed for DBDSDC
+*
+ MNTHR = INT( MINMN*11.0D0 / 6.0D0 )
+ IF( WNTQN ) THEN
+ BDSPAC = 7*M
+ ELSE
+ BDSPAC = 3*M*M + 4*M
+ END IF
+ IF( N.GE.MNTHR ) THEN
+ IF( WNTQN ) THEN
+*
+* Path 1t (N much larger than M, JOBZ='N')
+*
+ WRKBL = M + M*ILAENV( 1, 'DGELQF', ' ', M, N, -1,
+ $ -1 )
+ WRKBL = MAX( WRKBL, 3*M+2*M*
+ $ ILAENV( 1, 'DGEBRD', ' ', M, M, -1, -1 ) )
+ MAXWRK = MAX( WRKBL, BDSPAC+M )
+ MINWRK = BDSPAC + M
+ ELSE IF( WNTQO ) THEN
+*
+* Path 2t (N much larger than M, JOBZ='O')
+*
+ WRKBL = M + M*ILAENV( 1, 'DGELQF', ' ', M, N, -1, -1 )
+ WRKBL = MAX( WRKBL, M+M*ILAENV( 1, 'DORGLQ', ' ', M,
+ $ N, M, -1 ) )
+ WRKBL = MAX( WRKBL, 3*M+2*M*
+ $ ILAENV( 1, 'DGEBRD', ' ', M, M, -1, -1 ) )
+ WRKBL = MAX( WRKBL, 3*M+M*
+ $ ILAENV( 1, 'DORMBR', 'QLN', M, M, M, -1 ) )
+ WRKBL = MAX( WRKBL, 3*M+M*
+ $ ILAENV( 1, 'DORMBR', 'PRT', M, M, M, -1 ) )
+ WRKBL = MAX( WRKBL, BDSPAC+3*M )
+ MAXWRK = WRKBL + 2*M*M
+ MINWRK = BDSPAC + 2*M*M + 3*M
+ ELSE IF( WNTQS ) THEN
+*
+* Path 3t (N much larger than M, JOBZ='S')
+*
+ WRKBL = M + M*ILAENV( 1, 'DGELQF', ' ', M, N, -1, -1 )
+ WRKBL = MAX( WRKBL, M+M*ILAENV( 1, 'DORGLQ', ' ', M,
+ $ N, M, -1 ) )
+ WRKBL = MAX( WRKBL, 3*M+2*M*
+ $ ILAENV( 1, 'DGEBRD', ' ', M, M, -1, -1 ) )
+ WRKBL = MAX( WRKBL, 3*M+M*
+ $ ILAENV( 1, 'DORMBR', 'QLN', M, M, M, -1 ) )
+ WRKBL = MAX( WRKBL, 3*M+M*
+ $ ILAENV( 1, 'DORMBR', 'PRT', M, M, M, -1 ) )
+ WRKBL = MAX( WRKBL, BDSPAC+3*M )
+ MAXWRK = WRKBL + M*M
+ MINWRK = BDSPAC + M*M + 3*M
+ ELSE IF( WNTQA ) THEN
+*
+* Path 4t (N much larger than M, JOBZ='A')
+*
+ WRKBL = M + M*ILAENV( 1, 'DGELQF', ' ', M, N, -1, -1 )
+ WRKBL = MAX( WRKBL, M+N*ILAENV( 1, 'DORGLQ', ' ', N,
+ $ N, M, -1 ) )
+ WRKBL = MAX( WRKBL, 3*M+2*M*
+ $ ILAENV( 1, 'DGEBRD', ' ', M, M, -1, -1 ) )
+ WRKBL = MAX( WRKBL, 3*M+M*
+ $ ILAENV( 1, 'DORMBR', 'QLN', M, M, M, -1 ) )
+ WRKBL = MAX( WRKBL, 3*M+M*
+ $ ILAENV( 1, 'DORMBR', 'PRT', M, M, M, -1 ) )
+ WRKBL = MAX( WRKBL, BDSPAC+3*M )
+ MAXWRK = WRKBL + M*M
+ MINWRK = BDSPAC + M*M + 3*M
+ END IF
+ ELSE
+*
+* Path 5t (N greater than M, but not much larger)
+*
+ WRKBL = 3*M + ( M+N )*ILAENV( 1, 'DGEBRD', ' ', M, N, -1,
+ $ -1 )
+ IF( WNTQN ) THEN
+ MAXWRK = MAX( WRKBL, BDSPAC+3*M )
+ MINWRK = 3*M + MAX( N, BDSPAC )
+ ELSE IF( WNTQO ) THEN
+ WRKBL = MAX( WRKBL, 3*M+M*
+ $ ILAENV( 1, 'DORMBR', 'QLN', M, M, N, -1 ) )
+ WRKBL = MAX( WRKBL, 3*M+M*
+ $ ILAENV( 1, 'DORMBR', 'PRT', M, N, M, -1 ) )
+ WRKBL = MAX( WRKBL, BDSPAC+3*M )
+ MAXWRK = WRKBL + M*N
+ MINWRK = 3*M + MAX( N, M*M+BDSPAC )
+ ELSE IF( WNTQS ) THEN
+ WRKBL = MAX( WRKBL, 3*M+M*
+ $ ILAENV( 1, 'DORMBR', 'QLN', M, M, N, -1 ) )
+ WRKBL = MAX( WRKBL, 3*M+M*
+ $ ILAENV( 1, 'DORMBR', 'PRT', M, N, M, -1 ) )
+ MAXWRK = MAX( WRKBL, BDSPAC+3*M )
+ MINWRK = 3*M + MAX( N, BDSPAC )
+ ELSE IF( WNTQA ) THEN
+ WRKBL = MAX( WRKBL, 3*M+M*
+ $ ILAENV( 1, 'DORMBR', 'QLN', M, M, N, -1 ) )
+ WRKBL = MAX( WRKBL, 3*M+M*
+ $ ILAENV( 1, 'DORMBR', 'PRT', N, N, M, -1 ) )
+ MAXWRK = MAX( WRKBL, BDSPAC+3*M )
+ MINWRK = 3*M + MAX( N, BDSPAC )
+ END IF
+ END IF
+ END IF
+ MAXWRK = MAX( MAXWRK, MINWRK )
+ WORK( 1 ) = MAXWRK
+*
+ IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN
+ INFO = -12
+ END IF
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DGESDD', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( M.EQ.0 .OR. N.EQ.0 ) THEN
+ RETURN
+ END IF
+*
+* Get machine constants
+*
+ EPS = DLAMCH( 'P' )
+ SMLNUM = SQRT( DLAMCH( 'S' ) ) / EPS
+ BIGNUM = ONE / SMLNUM
+*
+* Scale A if max element outside range [SMLNUM,BIGNUM]
+*
+ ANRM = DLANGE( 'M', M, N, A, LDA, DUM )
+ ISCL = 0
+ IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
+ ISCL = 1
+ CALL DLASCL( 'G', 0, 0, ANRM, SMLNUM, M, N, A, LDA, IERR )
+ ELSE IF( ANRM.GT.BIGNUM ) THEN
+ ISCL = 1
+ CALL DLASCL( 'G', 0, 0, ANRM, BIGNUM, M, N, A, LDA, IERR )
+ END IF
+*
+ IF( M.GE.N ) THEN
+*
+* A has at least as many rows as columns. If A has sufficiently
+* more rows than columns, first reduce using the QR
+* decomposition (if sufficient workspace available)
+*
+ IF( M.GE.MNTHR ) THEN
+*
+ IF( WNTQN ) THEN
+*
+* Path 1 (M much larger than N, JOBZ='N')
+* No singular vectors to be computed
+*
+ ITAU = 1
+ NWORK = ITAU + N
+*
+* Compute A=Q*R
+* (Workspace: need 2*N, prefer N+N*NB)
+*
+ CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ),
+ $ LWORK-NWORK+1, IERR )
+*
+* Zero out below R
+*
+ CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, A( 2, 1 ), LDA )
+ IE = 1
+ ITAUQ = IE + N
+ ITAUP = ITAUQ + N
+ NWORK = ITAUP + N
+*
+* Bidiagonalize R in A
+* (Workspace: need 4*N, prefer 3*N+2*N*NB)
+*
+ CALL DGEBRD( N, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ),
+ $ WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1,
+ $ IERR )
+ NWORK = IE + N
+*
+* Perform bidiagonal SVD, computing singular values only
+* (Workspace: need N+BDSPAC)
+*
+ CALL DBDSDC( 'U', 'N', N, S, WORK( IE ), DUM, 1, DUM, 1,
+ $ DUM, IDUM, WORK( NWORK ), IWORK, INFO )
+*
+ ELSE IF( WNTQO ) THEN
+*
+* Path 2 (M much larger than N, JOBZ = 'O')
+* N left singular vectors to be overwritten on A and
+* N right singular vectors to be computed in VT
+*
+ IR = 1
+*
+* WORK(IR) is LDWRKR by N
+*
+ IF( LWORK.GE.LDA*N+N*N+3*N+BDSPAC ) THEN
+ LDWRKR = LDA
+ ELSE
+ LDWRKR = ( LWORK-N*N-3*N-BDSPAC ) / N
+ END IF
+ ITAU = IR + LDWRKR*N
+ NWORK = ITAU + N
+*
+* Compute A=Q*R
+* (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
+*
+ CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ),
+ $ LWORK-NWORK+1, IERR )
+*
+* Copy R to WORK(IR), zeroing out below it
+*
+ CALL DLACPY( 'U', N, N, A, LDA, WORK( IR ), LDWRKR )
+ CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, WORK( IR+1 ),
+ $ LDWRKR )
+*
+* Generate Q in A
+* (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
+*
+ CALL DORGQR( M, N, N, A, LDA, WORK( ITAU ),
+ $ WORK( NWORK ), LWORK-NWORK+1, IERR )
+ IE = ITAU
+ ITAUQ = IE + N
+ ITAUP = ITAUQ + N
+ NWORK = ITAUP + N
+*
+* Bidiagonalize R in VT, copying result to WORK(IR)
+* (Workspace: need N*N+4*N, prefer N*N+3*N+2*N*NB)
+*
+ CALL DGEBRD( N, N, WORK( IR ), LDWRKR, S, WORK( IE ),
+ $ WORK( ITAUQ ), WORK( ITAUP ), WORK( NWORK ),
+ $ LWORK-NWORK+1, IERR )
+*
+* WORK(IU) is N by N
+*
+ IU = NWORK
+ NWORK = IU + N*N
+*
+* Perform bidiagonal SVD, computing left singular vectors
+* of bidiagonal matrix in WORK(IU) and computing right
+* singular vectors of bidiagonal matrix in VT
+* (Workspace: need N+N*N+BDSPAC)
+*
+ CALL DBDSDC( 'U', 'I', N, S, WORK( IE ), WORK( IU ), N,
+ $ VT, LDVT, DUM, IDUM, WORK( NWORK ), IWORK,
+ $ INFO )
+*
+* Overwrite WORK(IU) by left singular vectors of R
+* and VT by right singular vectors of R
+* (Workspace: need 2*N*N+3*N, prefer 2*N*N+2*N+N*NB)
+*
+ CALL DORMBR( 'Q', 'L', 'N', N, N, N, WORK( IR ), LDWRKR,
+ $ WORK( ITAUQ ), WORK( IU ), N, WORK( NWORK ),
+ $ LWORK-NWORK+1, IERR )
+ CALL DORMBR( 'P', 'R', 'T', N, N, N, WORK( IR ), LDWRKR,
+ $ WORK( ITAUP ), VT, LDVT, WORK( NWORK ),
+ $ LWORK-NWORK+1, IERR )
+*
+* Multiply Q in A by left singular vectors of R in
+* WORK(IU), storing result in WORK(IR) and copying to A
+* (Workspace: need 2*N*N, prefer N*N+M*N)
+*
+ DO 10 I = 1, M, LDWRKR
+ CHUNK = MIN( M-I+1, LDWRKR )
+ CALL DGEMM( 'N', 'N', CHUNK, N, N, ONE, A( I, 1 ),
+ $ LDA, WORK( IU ), N, ZERO, WORK( IR ),
+ $ LDWRKR )
+ CALL DLACPY( 'F', CHUNK, N, WORK( IR ), LDWRKR,
+ $ A( I, 1 ), LDA )
+ 10 CONTINUE
+*
+ ELSE IF( WNTQS ) THEN
+*
+* Path 3 (M much larger than N, JOBZ='S')
+* N left singular vectors to be computed in U and
+* N right singular vectors to be computed in VT
+*
+ IR = 1
+*
+* WORK(IR) is N by N
+*
+ LDWRKR = N
+ ITAU = IR + LDWRKR*N
+ NWORK = ITAU + N
+*
+* Compute A=Q*R
+* (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
+*
+ CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ),
+ $ LWORK-NWORK+1, IERR )
+*
+* Copy R to WORK(IR), zeroing out below it
+*
+ CALL DLACPY( 'U', N, N, A, LDA, WORK( IR ), LDWRKR )
+ CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, WORK( IR+1 ),
+ $ LDWRKR )
+*
+* Generate Q in A
+* (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
+*
+ CALL DORGQR( M, N, N, A, LDA, WORK( ITAU ),
+ $ WORK( NWORK ), LWORK-NWORK+1, IERR )
+ IE = ITAU
+ ITAUQ = IE + N
+ ITAUP = ITAUQ + N
+ NWORK = ITAUP + N
+*
+* Bidiagonalize R in WORK(IR)
+* (Workspace: need N*N+4*N, prefer N*N+3*N+2*N*NB)
+*
+ CALL DGEBRD( N, N, WORK( IR ), LDWRKR, S, WORK( IE ),
+ $ WORK( ITAUQ ), WORK( ITAUP ), WORK( NWORK ),
+ $ LWORK-NWORK+1, IERR )
+*
+* Perform bidiagonal SVD, computing left singular vectors
+* of bidiagoal matrix in U and computing right singular
+* vectors of bidiagonal matrix in VT
+* (Workspace: need N+BDSPAC)
+*
+ CALL DBDSDC( 'U', 'I', N, S, WORK( IE ), U, LDU, VT,
+ $ LDVT, DUM, IDUM, WORK( NWORK ), IWORK,
+ $ INFO )
+*
+* Overwrite U by left singular vectors of R and VT
+* by right singular vectors of R
+* (Workspace: need N*N+3*N, prefer N*N+2*N+N*NB)
+*
+ CALL DORMBR( 'Q', 'L', 'N', N, N, N, WORK( IR ), LDWRKR,
+ $ WORK( ITAUQ ), U, LDU, WORK( NWORK ),
+ $ LWORK-NWORK+1, IERR )
+*
+ CALL DORMBR( 'P', 'R', 'T', N, N, N, WORK( IR ), LDWRKR,
+ $ WORK( ITAUP ), VT, LDVT, WORK( NWORK ),
+ $ LWORK-NWORK+1, IERR )
+*
+* Multiply Q in A by left singular vectors of R in
+* WORK(IR), storing result in U
+* (Workspace: need N*N)
+*
+ CALL DLACPY( 'F', N, N, U, LDU, WORK( IR ), LDWRKR )
+ CALL DGEMM( 'N', 'N', M, N, N, ONE, A, LDA, WORK( IR ),
+ $ LDWRKR, ZERO, U, LDU )
+*
+ ELSE IF( WNTQA ) THEN
+*
+* Path 4 (M much larger than N, JOBZ='A')
+* M left singular vectors to be computed in U and
+* N right singular vectors to be computed in VT
+*
+ IU = 1
+*
+* WORK(IU) is N by N
+*
+ LDWRKU = N
+ ITAU = IU + LDWRKU*N
+ NWORK = ITAU + N
+*
+* Compute A=Q*R, copying result to U
+* (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
+*
+ CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ),
+ $ LWORK-NWORK+1, IERR )
+ CALL DLACPY( 'L', M, N, A, LDA, U, LDU )
+*
+* Generate Q in U
+* (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
+ CALL DORGQR( M, M, N, U, LDU, WORK( ITAU ),
+ $ WORK( NWORK ), LWORK-NWORK+1, IERR )
+*
+* Produce R in A, zeroing out other entries
+*
+ CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, A( 2, 1 ), LDA )
+ IE = ITAU
+ ITAUQ = IE + N
+ ITAUP = ITAUQ + N
+ NWORK = ITAUP + N
+*
+* Bidiagonalize R in A
+* (Workspace: need N*N+4*N, prefer N*N+3*N+2*N*NB)
+*
+ CALL DGEBRD( N, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ),
+ $ WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1,
+ $ IERR )
+*
+* Perform bidiagonal SVD, computing left singular vectors
+* of bidiagonal matrix in WORK(IU) and computing right
+* singular vectors of bidiagonal matrix in VT
+* (Workspace: need N+N*N+BDSPAC)
+*
+ CALL DBDSDC( 'U', 'I', N, S, WORK( IE ), WORK( IU ), N,
+ $ VT, LDVT, DUM, IDUM, WORK( NWORK ), IWORK,
+ $ INFO )
+*
+* Overwrite WORK(IU) by left singular vectors of R and VT
+* by right singular vectors of R
+* (Workspace: need N*N+3*N, prefer N*N+2*N+N*NB)
+*
+ CALL DORMBR( 'Q', 'L', 'N', N, N, N, A, LDA,
+ $ WORK( ITAUQ ), WORK( IU ), LDWRKU,
+ $ WORK( NWORK ), LWORK-NWORK+1, IERR )
+ CALL DORMBR( 'P', 'R', 'T', N, N, N, A, LDA,
+ $ WORK( ITAUP ), VT, LDVT, WORK( NWORK ),
+ $ LWORK-NWORK+1, IERR )
+*
+* Multiply Q in U by left singular vectors of R in
+* WORK(IU), storing result in A
+* (Workspace: need N*N)
+*
+ CALL DGEMM( 'N', 'N', M, N, N, ONE, U, LDU, WORK( IU ),
+ $ LDWRKU, ZERO, A, LDA )
+*
+* Copy left singular vectors of A from A to U
+*
+ CALL DLACPY( 'F', M, N, A, LDA, U, LDU )
+*
+ END IF
+*
+ ELSE
+*
+* M .LT. MNTHR
+*
+* Path 5 (M at least N, but not much larger)
+* Reduce to bidiagonal form without QR decomposition
+*
+ IE = 1
+ ITAUQ = IE + N
+ ITAUP = ITAUQ + N
+ NWORK = ITAUP + N
+*
+* Bidiagonalize A
+* (Workspace: need 3*N+M, prefer 3*N+(M+N)*NB)
+*
+ CALL DGEBRD( M, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ),
+ $ WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1,
+ $ IERR )
+ IF( WNTQN ) THEN
+*
+* Perform bidiagonal SVD, only computing singular values
+* (Workspace: need N+BDSPAC)
+*
+ CALL DBDSDC( 'U', 'N', N, S, WORK( IE ), DUM, 1, DUM, 1,
+ $ DUM, IDUM, WORK( NWORK ), IWORK, INFO )
+ ELSE IF( WNTQO ) THEN
+ IU = NWORK
+ IF( LWORK.GE.M*N+3*N+BDSPAC ) THEN
+*
+* WORK( IU ) is M by N
+*
+ LDWRKU = M
+ NWORK = IU + LDWRKU*N
+ CALL DLASET( 'F', M, N, ZERO, ZERO, WORK( IU ),
+ $ LDWRKU )
+ ELSE
+*
+* WORK( IU ) is N by N
+*
+ LDWRKU = N
+ NWORK = IU + LDWRKU*N
+*
+* WORK(IR) is LDWRKR by N
+*
+ IR = NWORK
+ LDWRKR = ( LWORK-N*N-3*N ) / N
+ END IF
+ NWORK = IU + LDWRKU*N
+*
+* Perform bidiagonal SVD, computing left singular vectors
+* of bidiagonal matrix in WORK(IU) and computing right
+* singular vectors of bidiagonal matrix in VT
+* (Workspace: need N+N*N+BDSPAC)
+*
+ CALL DBDSDC( 'U', 'I', N, S, WORK( IE ), WORK( IU ),
+ $ LDWRKU, VT, LDVT, DUM, IDUM, WORK( NWORK ),
+ $ IWORK, INFO )
+*
+* Overwrite VT by right singular vectors of A
+* (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
+*
+ CALL DORMBR( 'P', 'R', 'T', N, N, N, A, LDA,
+ $ WORK( ITAUP ), VT, LDVT, WORK( NWORK ),
+ $ LWORK-NWORK+1, IERR )
+*
+ IF( LWORK.GE.M*N+3*N+BDSPAC ) THEN
+*
+* Overwrite WORK(IU) by left singular vectors of A
+* (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
+*
+ CALL DORMBR( 'Q', 'L', 'N', M, N, N, A, LDA,
+ $ WORK( ITAUQ ), WORK( IU ), LDWRKU,
+ $ WORK( NWORK ), LWORK-NWORK+1, IERR )
+*
+* Copy left singular vectors of A from WORK(IU) to A
+*
+ CALL DLACPY( 'F', M, N, WORK( IU ), LDWRKU, A, LDA )
+ ELSE
+*
+* Generate Q in A
+* (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
+*
+ CALL DORGBR( 'Q', M, N, N, A, LDA, WORK( ITAUQ ),
+ $ WORK( NWORK ), LWORK-NWORK+1, IERR )
+*
+* Multiply Q in A by left singular vectors of
+* bidiagonal matrix in WORK(IU), storing result in
+* WORK(IR) and copying to A
+* (Workspace: need 2*N*N, prefer N*N+M*N)
+*
+ DO 20 I = 1, M, LDWRKR
+ CHUNK = MIN( M-I+1, LDWRKR )
+ CALL DGEMM( 'N', 'N', CHUNK, N, N, ONE, A( I, 1 ),
+ $ LDA, WORK( IU ), LDWRKU, ZERO,
+ $ WORK( IR ), LDWRKR )
+ CALL DLACPY( 'F', CHUNK, N, WORK( IR ), LDWRKR,
+ $ A( I, 1 ), LDA )
+ 20 CONTINUE
+ END IF
+*
+ ELSE IF( WNTQS ) THEN
+*
+* Perform bidiagonal SVD, computing left singular vectors
+* of bidiagonal matrix in U and computing right singular
+* vectors of bidiagonal matrix in VT
+* (Workspace: need N+BDSPAC)
+*
+ CALL DLASET( 'F', M, N, ZERO, ZERO, U, LDU )
+ CALL DBDSDC( 'U', 'I', N, S, WORK( IE ), U, LDU, VT,
+ $ LDVT, DUM, IDUM, WORK( NWORK ), IWORK,
+ $ INFO )
+*
+* Overwrite U by left singular vectors of A and VT
+* by right singular vectors of A
+* (Workspace: need 3*N, prefer 2*N+N*NB)
+*
+ CALL DORMBR( 'Q', 'L', 'N', M, N, N, A, LDA,
+ $ WORK( ITAUQ ), U, LDU, WORK( NWORK ),
+ $ LWORK-NWORK+1, IERR )
+ CALL DORMBR( 'P', 'R', 'T', N, N, N, A, LDA,
+ $ WORK( ITAUP ), VT, LDVT, WORK( NWORK ),
+ $ LWORK-NWORK+1, IERR )
+ ELSE IF( WNTQA ) THEN
+*
+* Perform bidiagonal SVD, computing left singular vectors
+* of bidiagonal matrix in U and computing right singular
+* vectors of bidiagonal matrix in VT
+* (Workspace: need N+BDSPAC)
+*
+ CALL DLASET( 'F', M, M, ZERO, ZERO, U, LDU )
+ CALL DBDSDC( 'U', 'I', N, S, WORK( IE ), U, LDU, VT,
+ $ LDVT, DUM, IDUM, WORK( NWORK ), IWORK,
+ $ INFO )
+*
+* Set the right corner of U to identity matrix
+*
+ IF( M.GT.N ) THEN
+ CALL DLASET( 'F', M-N, M-N, ZERO, ONE, U( N+1, N+1 ),
+ $ LDU )
+ END IF
+*
+* Overwrite U by left singular vectors of A and VT
+* by right singular vectors of A
+* (Workspace: need N*N+2*N+M, prefer N*N+2*N+M*NB)
+*
+ CALL DORMBR( 'Q', 'L', 'N', M, M, N, A, LDA,
+ $ WORK( ITAUQ ), U, LDU, WORK( NWORK ),
+ $ LWORK-NWORK+1, IERR )
+ CALL DORMBR( 'P', 'R', 'T', N, N, M, A, LDA,
+ $ WORK( ITAUP ), VT, LDVT, WORK( NWORK ),
+ $ LWORK-NWORK+1, IERR )
+ END IF
+*
+ END IF
+*
+ ELSE
+*
+* A has more columns than rows. If A has sufficiently more
+* columns than rows, first reduce using the LQ decomposition (if
+* sufficient workspace available)
+*
+ IF( N.GE.MNTHR ) THEN
+*
+ IF( WNTQN ) THEN
+*
+* Path 1t (N much larger than M, JOBZ='N')
+* No singular vectors to be computed
+*
+ ITAU = 1
+ NWORK = ITAU + M
+*
+* Compute A=L*Q
+* (Workspace: need 2*M, prefer M+M*NB)
+*
+ CALL DGELQF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ),
+ $ LWORK-NWORK+1, IERR )
+*
+* Zero out above L
+*
+ CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, A( 1, 2 ), LDA )
+ IE = 1
+ ITAUQ = IE + M
+ ITAUP = ITAUQ + M
+ NWORK = ITAUP + M
+*
+* Bidiagonalize L in A
+* (Workspace: need 4*M, prefer 3*M+2*M*NB)
+*
+ CALL DGEBRD( M, M, A, LDA, S, WORK( IE ), WORK( ITAUQ ),
+ $ WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1,
+ $ IERR )
+ NWORK = IE + M
+*
+* Perform bidiagonal SVD, computing singular values only
+* (Workspace: need M+BDSPAC)
+*
+ CALL DBDSDC( 'U', 'N', M, S, WORK( IE ), DUM, 1, DUM, 1,
+ $ DUM, IDUM, WORK( NWORK ), IWORK, INFO )
+*
+ ELSE IF( WNTQO ) THEN
+*
+* Path 2t (N much larger than M, JOBZ='O')
+* M right singular vectors to be overwritten on A and
+* M left singular vectors to be computed in U
+*
+ IVT = 1
+*
+* IVT is M by M
+*
+ IL = IVT + M*M
+ IF( LWORK.GE.M*N+M*M+3*M+BDSPAC ) THEN
+*
+* WORK(IL) is M by N
+*
+ LDWRKL = M
+ CHUNK = N
+ ELSE
+ LDWRKL = M
+ CHUNK = ( LWORK-M*M ) / M
+ END IF
+ ITAU = IL + LDWRKL*M
+ NWORK = ITAU + M
+*
+* Compute A=L*Q
+* (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
+*
+ CALL DGELQF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ),
+ $ LWORK-NWORK+1, IERR )
+*
+* Copy L to WORK(IL), zeroing about above it
+*
+ CALL DLACPY( 'L', M, M, A, LDA, WORK( IL ), LDWRKL )
+ CALL DLASET( 'U', M-1, M-1, ZERO, ZERO,
+ $ WORK( IL+LDWRKL ), LDWRKL )
+*
+* Generate Q in A
+* (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
+*
+ CALL DORGLQ( M, N, M, A, LDA, WORK( ITAU ),
+ $ WORK( NWORK ), LWORK-NWORK+1, IERR )
+ IE = ITAU
+ ITAUQ = IE + M
+ ITAUP = ITAUQ + M
+ NWORK = ITAUP + M
+*
+* Bidiagonalize L in WORK(IL)
+* (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB)
+*
+ CALL DGEBRD( M, M, WORK( IL ), LDWRKL, S, WORK( IE ),
+ $ WORK( ITAUQ ), WORK( ITAUP ), WORK( NWORK ),
+ $ LWORK-NWORK+1, IERR )
+*
+* Perform bidiagonal SVD, computing left singular vectors
+* of bidiagonal matrix in U, and computing right singular
+* vectors of bidiagonal matrix in WORK(IVT)
+* (Workspace: need M+M*M+BDSPAC)
+*
+ CALL DBDSDC( 'U', 'I', M, S, WORK( IE ), U, LDU,
+ $ WORK( IVT ), M, DUM, IDUM, WORK( NWORK ),
+ $ IWORK, INFO )
+*
+* Overwrite U by left singular vectors of L and WORK(IVT)
+* by right singular vectors of L
+* (Workspace: need 2*M*M+3*M, prefer 2*M*M+2*M+M*NB)
+*
+ CALL DORMBR( 'Q', 'L', 'N', M, M, M, WORK( IL ), LDWRKL,
+ $ WORK( ITAUQ ), U, LDU, WORK( NWORK ),
+ $ LWORK-NWORK+1, IERR )
+ CALL DORMBR( 'P', 'R', 'T', M, M, M, WORK( IL ), LDWRKL,
+ $ WORK( ITAUP ), WORK( IVT ), M,
+ $ WORK( NWORK ), LWORK-NWORK+1, IERR )
+*
+* Multiply right singular vectors of L in WORK(IVT) by Q
+* in A, storing result in WORK(IL) and copying to A
+* (Workspace: need 2*M*M, prefer M*M+M*N)
+*
+ DO 30 I = 1, N, CHUNK
+ BLK = MIN( N-I+1, CHUNK )
+ CALL DGEMM( 'N', 'N', M, BLK, M, ONE, WORK( IVT ), M,
+ $ A( 1, I ), LDA, ZERO, WORK( IL ), LDWRKL )
+ CALL DLACPY( 'F', M, BLK, WORK( IL ), LDWRKL,
+ $ A( 1, I ), LDA )
+ 30 CONTINUE
+*
+ ELSE IF( WNTQS ) THEN
+*
+* Path 3t (N much larger than M, JOBZ='S')
+* M right singular vectors to be computed in VT and
+* M left singular vectors to be computed in U
+*
+ IL = 1
+*
+* WORK(IL) is M by M
+*
+ LDWRKL = M
+ ITAU = IL + LDWRKL*M
+ NWORK = ITAU + M
+*
+* Compute A=L*Q
+* (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
+*
+ CALL DGELQF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ),
+ $ LWORK-NWORK+1, IERR )
+*
+* Copy L to WORK(IL), zeroing out above it
+*
+ CALL DLACPY( 'L', M, M, A, LDA, WORK( IL ), LDWRKL )
+ CALL DLASET( 'U', M-1, M-1, ZERO, ZERO,
+ $ WORK( IL+LDWRKL ), LDWRKL )
+*
+* Generate Q in A
+* (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
+*
+ CALL DORGLQ( M, N, M, A, LDA, WORK( ITAU ),
+ $ WORK( NWORK ), LWORK-NWORK+1, IERR )
+ IE = ITAU
+ ITAUQ = IE + M
+ ITAUP = ITAUQ + M
+ NWORK = ITAUP + M
+*
+* Bidiagonalize L in WORK(IU), copying result to U
+* (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB)
+*
+ CALL DGEBRD( M, M, WORK( IL ), LDWRKL, S, WORK( IE ),
+ $ WORK( ITAUQ ), WORK( ITAUP ), WORK( NWORK ),
+ $ LWORK-NWORK+1, IERR )
+*
+* Perform bidiagonal SVD, computing left singular vectors
+* of bidiagonal matrix in U and computing right singular
+* vectors of bidiagonal matrix in VT
+* (Workspace: need M+BDSPAC)
+*
+ CALL DBDSDC( 'U', 'I', M, S, WORK( IE ), U, LDU, VT,
+ $ LDVT, DUM, IDUM, WORK( NWORK ), IWORK,
+ $ INFO )
+*
+* Overwrite U by left singular vectors of L and VT
+* by right singular vectors of L
+* (Workspace: need M*M+3*M, prefer M*M+2*M+M*NB)
+*
+ CALL DORMBR( 'Q', 'L', 'N', M, M, M, WORK( IL ), LDWRKL,
+ $ WORK( ITAUQ ), U, LDU, WORK( NWORK ),
+ $ LWORK-NWORK+1, IERR )
+ CALL DORMBR( 'P', 'R', 'T', M, M, M, WORK( IL ), LDWRKL,
+ $ WORK( ITAUP ), VT, LDVT, WORK( NWORK ),
+ $ LWORK-NWORK+1, IERR )
+*
+* Multiply right singular vectors of L in WORK(IL) by
+* Q in A, storing result in VT
+* (Workspace: need M*M)
+*
+ CALL DLACPY( 'F', M, M, VT, LDVT, WORK( IL ), LDWRKL )
+ CALL DGEMM( 'N', 'N', M, N, M, ONE, WORK( IL ), LDWRKL,
+ $ A, LDA, ZERO, VT, LDVT )
+*
+ ELSE IF( WNTQA ) THEN
+*
+* Path 4t (N much larger than M, JOBZ='A')
+* N right singular vectors to be computed in VT and
+* M left singular vectors to be computed in U
+*
+ IVT = 1
+*
+* WORK(IVT) is M by M
+*
+ LDWKVT = M
+ ITAU = IVT + LDWKVT*M
+ NWORK = ITAU + M
+*
+* Compute A=L*Q, copying result to VT
+* (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
+*
+ CALL DGELQF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ),
+ $ LWORK-NWORK+1, IERR )
+ CALL DLACPY( 'U', M, N, A, LDA, VT, LDVT )
+*
+* Generate Q in VT
+* (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
+*
+ CALL DORGLQ( N, N, M, VT, LDVT, WORK( ITAU ),
+ $ WORK( NWORK ), LWORK-NWORK+1, IERR )
+*
+* Produce L in A, zeroing out other entries
+*
+ CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, A( 1, 2 ), LDA )
+ IE = ITAU
+ ITAUQ = IE + M
+ ITAUP = ITAUQ + M
+ NWORK = ITAUP + M
+*
+* Bidiagonalize L in A
+* (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB)
+*
+ CALL DGEBRD( M, M, A, LDA, S, WORK( IE ), WORK( ITAUQ ),
+ $ WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1,
+ $ IERR )
+*
+* Perform bidiagonal SVD, computing left singular vectors
+* of bidiagonal matrix in U and computing right singular
+* vectors of bidiagonal matrix in WORK(IVT)
+* (Workspace: need M+M*M+BDSPAC)
+*
+ CALL DBDSDC( 'U', 'I', M, S, WORK( IE ), U, LDU,
+ $ WORK( IVT ), LDWKVT, DUM, IDUM,
+ $ WORK( NWORK ), IWORK, INFO )
+*
+* Overwrite U by left singular vectors of L and WORK(IVT)
+* by right singular vectors of L
+* (Workspace: need M*M+3*M, prefer M*M+2*M+M*NB)
+*
+ CALL DORMBR( 'Q', 'L', 'N', M, M, M, A, LDA,
+ $ WORK( ITAUQ ), U, LDU, WORK( NWORK ),
+ $ LWORK-NWORK+1, IERR )
+ CALL DORMBR( 'P', 'R', 'T', M, M, M, A, LDA,
+ $ WORK( ITAUP ), WORK( IVT ), LDWKVT,
+ $ WORK( NWORK ), LWORK-NWORK+1, IERR )
+*
+* Multiply right singular vectors of L in WORK(IVT) by
+* Q in VT, storing result in A
+* (Workspace: need M*M)
+*
+ CALL DGEMM( 'N', 'N', M, N, M, ONE, WORK( IVT ), LDWKVT,
+ $ VT, LDVT, ZERO, A, LDA )
+*
+* Copy right singular vectors of A from A to VT
+*
+ CALL DLACPY( 'F', M, N, A, LDA, VT, LDVT )
+*
+ END IF
+*
+ ELSE
+*
+* N .LT. MNTHR
+*
+* Path 5t (N greater than M, but not much larger)
+* Reduce to bidiagonal form without LQ decomposition
+*
+ IE = 1
+ ITAUQ = IE + M
+ ITAUP = ITAUQ + M
+ NWORK = ITAUP + M
+*
+* Bidiagonalize A
+* (Workspace: need 3*M+N, prefer 3*M+(M+N)*NB)
+*
+ CALL DGEBRD( M, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ),
+ $ WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1,
+ $ IERR )
+ IF( WNTQN ) THEN
+*
+* Perform bidiagonal SVD, only computing singular values
+* (Workspace: need M+BDSPAC)
+*
+ CALL DBDSDC( 'L', 'N', M, S, WORK( IE ), DUM, 1, DUM, 1,
+ $ DUM, IDUM, WORK( NWORK ), IWORK, INFO )
+ ELSE IF( WNTQO ) THEN
+ LDWKVT = M
+ IVT = NWORK
+ IF( LWORK.GE.M*N+3*M+BDSPAC ) THEN
+*
+* WORK( IVT ) is M by N
+*
+ CALL DLASET( 'F', M, N, ZERO, ZERO, WORK( IVT ),
+ $ LDWKVT )
+ NWORK = IVT + LDWKVT*N
+ ELSE
+*
+* WORK( IVT ) is M by M
+*
+ NWORK = IVT + LDWKVT*M
+ IL = NWORK
+*
+* WORK(IL) is M by CHUNK
+*
+ CHUNK = ( LWORK-M*M-3*M ) / M
+ END IF
+*
+* Perform bidiagonal SVD, computing left singular vectors
+* of bidiagonal matrix in U and computing right singular
+* vectors of bidiagonal matrix in WORK(IVT)
+* (Workspace: need M*M+BDSPAC)
+*
+ CALL DBDSDC( 'L', 'I', M, S, WORK( IE ), U, LDU,
+ $ WORK( IVT ), LDWKVT, DUM, IDUM,
+ $ WORK( NWORK ), IWORK, INFO )
+*
+* Overwrite U by left singular vectors of A
+* (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
+*
+ CALL DORMBR( 'Q', 'L', 'N', M, M, N, A, LDA,
+ $ WORK( ITAUQ ), U, LDU, WORK( NWORK ),
+ $ LWORK-NWORK+1, IERR )
+*
+ IF( LWORK.GE.M*N+3*M+BDSPAC ) THEN
+*
+* Overwrite WORK(IVT) by left singular vectors of A
+* (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
+*
+ CALL DORMBR( 'P', 'R', 'T', M, N, M, A, LDA,
+ $ WORK( ITAUP ), WORK( IVT ), LDWKVT,
+ $ WORK( NWORK ), LWORK-NWORK+1, IERR )
+*
+* Copy right singular vectors of A from WORK(IVT) to A
+*
+ CALL DLACPY( 'F', M, N, WORK( IVT ), LDWKVT, A, LDA )
+ ELSE
+*
+* Generate P**T in A
+* (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
+*
+ CALL DORGBR( 'P', M, N, M, A, LDA, WORK( ITAUP ),
+ $ WORK( NWORK ), LWORK-NWORK+1, IERR )
+*
+* Multiply Q in A by right singular vectors of
+* bidiagonal matrix in WORK(IVT), storing result in
+* WORK(IL) and copying to A
+* (Workspace: need 2*M*M, prefer M*M+M*N)
+*
+ DO 40 I = 1, N, CHUNK
+ BLK = MIN( N-I+1, CHUNK )
+ CALL DGEMM( 'N', 'N', M, BLK, M, ONE, WORK( IVT ),
+ $ LDWKVT, A( 1, I ), LDA, ZERO,
+ $ WORK( IL ), M )
+ CALL DLACPY( 'F', M, BLK, WORK( IL ), M, A( 1, I ),
+ $ LDA )
+ 40 CONTINUE
+ END IF
+ ELSE IF( WNTQS ) THEN
+*
+* Perform bidiagonal SVD, computing left singular vectors
+* of bidiagonal matrix in U and computing right singular
+* vectors of bidiagonal matrix in VT
+* (Workspace: need M+BDSPAC)
+*
+ CALL DLASET( 'F', M, N, ZERO, ZERO, VT, LDVT )
+ CALL DBDSDC( 'L', 'I', M, S, WORK( IE ), U, LDU, VT,
+ $ LDVT, DUM, IDUM, WORK( NWORK ), IWORK,
+ $ INFO )
+*
+* Overwrite U by left singular vectors of A and VT
+* by right singular vectors of A
+* (Workspace: need 3*M, prefer 2*M+M*NB)
+*
+ CALL DORMBR( 'Q', 'L', 'N', M, M, N, A, LDA,
+ $ WORK( ITAUQ ), U, LDU, WORK( NWORK ),
+ $ LWORK-NWORK+1, IERR )
+ CALL DORMBR( 'P', 'R', 'T', M, N, M, A, LDA,
+ $ WORK( ITAUP ), VT, LDVT, WORK( NWORK ),
+ $ LWORK-NWORK+1, IERR )
+ ELSE IF( WNTQA ) THEN
+*
+* Perform bidiagonal SVD, computing left singular vectors
+* of bidiagonal matrix in U and computing right singular
+* vectors of bidiagonal matrix in VT
+* (Workspace: need M+BDSPAC)
+*
+ CALL DLASET( 'F', N, N, ZERO, ZERO, VT, LDVT )
+ CALL DBDSDC( 'L', 'I', M, S, WORK( IE ), U, LDU, VT,
+ $ LDVT, DUM, IDUM, WORK( NWORK ), IWORK,
+ $ INFO )
+*
+* Set the right corner of VT to identity matrix
+*
+ IF( N.GT.M ) THEN
+ CALL DLASET( 'F', N-M, N-M, ZERO, ONE, VT( M+1, M+1 ),
+ $ LDVT )
+ END IF
+*
+* Overwrite U by left singular vectors of A and VT
+* by right singular vectors of A
+* (Workspace: need 2*M+N, prefer 2*M+N*NB)
+*
+ CALL DORMBR( 'Q', 'L', 'N', M, M, N, A, LDA,
+ $ WORK( ITAUQ ), U, LDU, WORK( NWORK ),
+ $ LWORK-NWORK+1, IERR )
+ CALL DORMBR( 'P', 'R', 'T', N, N, M, A, LDA,
+ $ WORK( ITAUP ), VT, LDVT, WORK( NWORK ),
+ $ LWORK-NWORK+1, IERR )
+ END IF
+*
+ END IF
+*
+ END IF
+*
+* Undo scaling if necessary
+*
+ IF( ISCL.EQ.1 ) THEN
+ IF( ANRM.GT.BIGNUM )
+ $ CALL DLASCL( 'G', 0, 0, BIGNUM, ANRM, MINMN, 1, S, MINMN,
+ $ IERR )
+ IF( ANRM.LT.SMLNUM )
+ $ CALL DLASCL( 'G', 0, 0, SMLNUM, ANRM, MINMN, 1, S, MINMN,
+ $ IERR )
+ END IF
+*
+* Return optimal workspace in WORK(1)
+*
+ WORK( 1 ) = MAXWRK
+*
+ RETURN
+*
+* End of DGESDD
+*
+ END
+ SUBROUTINE DGESV( N, NRHS, A, LDA, IPIV, B, LDB, INFO )
+*
+* -- LAPACK driver routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LDA, LDB, N, NRHS
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ DOUBLE PRECISION A( LDA, * ), B( LDB, * )
+* ..
+*
+* Purpose
+* =======
+*
+* DGESV computes the solution to a real system of linear equations
+* A * X = B,
+* where A is an N-by-N matrix and X and B are N-by-NRHS matrices.
+*
+* The LU decomposition with partial pivoting and row interchanges is
+* used to factor A as
+* A = P * L * U,
+* where P is a permutation matrix, L is unit lower triangular, and U is
+* upper triangular. The factored form of A is then used to solve the
+* system of equations A * X = B.
+*
+* Arguments
+* =========
+*
+* N (input) INTEGER
+* The number of linear equations, i.e., the order of the
+* matrix A. N >= 0.
+*
+* NRHS (input) INTEGER
+* The number of right hand sides, i.e., the number of columns
+* of the matrix B. NRHS >= 0.
+*
+* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+* On entry, the N-by-N coefficient matrix A.
+* On exit, the factors L and U from the factorization
+* A = P*L*U; the unit diagonal elements of L are not stored.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,N).
+*
+* IPIV (output) INTEGER array, dimension (N)
+* The pivot indices that define the permutation matrix P;
+* row i of the matrix was interchanged with row IPIV(i).
+*
+* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
+* On entry, the N-by-NRHS matrix of right hand side matrix B.
+* On exit, if INFO = 0, the N-by-NRHS solution matrix X.
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. LDB >= max(1,N).
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* > 0: if INFO = i, U(i,i) is exactly zero. The factorization
+* has been completed, but the factor U is exactly
+* singular, so the solution could not be computed.
+*
+* =====================================================================
+*
+* .. External Subroutines ..
+ EXTERNAL DGETRF, DGETRS, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ IF( N.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( NRHS.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -4
+ ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -7
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DGESV ', -INFO )
+ RETURN
+ END IF
+*
+* Compute the LU factorization of A.
+*
+ CALL DGETRF( N, N, A, LDA, IPIV, INFO )
+ IF( INFO.EQ.0 ) THEN
+*
+* Solve the system A*X = B, overwriting B with X.
+*
+ CALL DGETRS( 'No transpose', N, NRHS, A, LDA, IPIV, B, LDB,
+ $ INFO )
+ END IF
+ RETURN
+*
+* End of DGESV
+*
+ END
+ SUBROUTINE DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, VT, LDVT,
+ $ WORK, LWORK, INFO )
+*
+* -- LAPACK driver routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER JOBU, JOBVT
+ INTEGER INFO, LDA, LDU, LDVT, LWORK, M, N
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION A( LDA, * ), S( * ), U( LDU, * ),
+ $ VT( LDVT, * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DGESVD computes the singular value decomposition (SVD) of a real
+* M-by-N matrix A, optionally computing the left and/or right singular
+* vectors. The SVD is written
+*
+* A = U * SIGMA * transpose(V)
+*
+* where SIGMA is an M-by-N matrix which is zero except for its
+* min(m,n) diagonal elements, U is an M-by-M orthogonal matrix, and
+* V is an N-by-N orthogonal matrix. The diagonal elements of SIGMA
+* are the singular values of A; they are real and non-negative, and
+* are returned in descending order. The first min(m,n) columns of
+* U and V are the left and right singular vectors of A.
+*
+* Note that the routine returns V**T, not V.
+*
+* Arguments
+* =========
+*
+* JOBU (input) CHARACTER*1
+* Specifies options for computing all or part of the matrix U:
+* = 'A': all M columns of U are returned in array U:
+* = 'S': the first min(m,n) columns of U (the left singular
+* vectors) are returned in the array U;
+* = 'O': the first min(m,n) columns of U (the left singular
+* vectors) are overwritten on the array A;
+* = 'N': no columns of U (no left singular vectors) are
+* computed.
+*
+* JOBVT (input) CHARACTER*1
+* Specifies options for computing all or part of the matrix
+* V**T:
+* = 'A': all N rows of V**T are returned in the array VT;
+* = 'S': the first min(m,n) rows of V**T (the right singular
+* vectors) are returned in the array VT;
+* = 'O': the first min(m,n) rows of V**T (the right singular
+* vectors) are overwritten on the array A;
+* = 'N': no rows of V**T (no right singular vectors) are
+* computed.
+*
+* JOBVT and JOBU cannot both be 'O'.
+*
+* M (input) INTEGER
+* The number of rows of the input matrix A. M >= 0.
+*
+* N (input) INTEGER
+* The number of columns of the input matrix A. N >= 0.
+*
+* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+* On entry, the M-by-N matrix A.
+* On exit,
+* if JOBU = 'O', A is overwritten with the first min(m,n)
+* columns of U (the left singular vectors,
+* stored columnwise);
+* if JOBVT = 'O', A is overwritten with the first min(m,n)
+* rows of V**T (the right singular vectors,
+* stored rowwise);
+* if JOBU .ne. 'O' and JOBVT .ne. 'O', the contents of A
+* are destroyed.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,M).
+*
+* S (output) DOUBLE PRECISION array, dimension (min(M,N))
+* The singular values of A, sorted so that S(i) >= S(i+1).
+*
+* U (output) DOUBLE PRECISION array, dimension (LDU,UCOL)
+* (LDU,M) if JOBU = 'A' or (LDU,min(M,N)) if JOBU = 'S'.
+* If JOBU = 'A', U contains the M-by-M orthogonal matrix U;
+* if JOBU = 'S', U contains the first min(m,n) columns of U
+* (the left singular vectors, stored columnwise);
+* if JOBU = 'N' or 'O', U is not referenced.
+*
+* LDU (input) INTEGER
+* The leading dimension of the array U. LDU >= 1; if
+* JOBU = 'S' or 'A', LDU >= M.
+*
+* VT (output) DOUBLE PRECISION array, dimension (LDVT,N)
+* If JOBVT = 'A', VT contains the N-by-N orthogonal matrix
+* V**T;
+* if JOBVT = 'S', VT contains the first min(m,n) rows of
+* V**T (the right singular vectors, stored rowwise);
+* if JOBVT = 'N' or 'O', VT is not referenced.
+*
+* LDVT (input) INTEGER
+* The leading dimension of the array VT. LDVT >= 1; if
+* JOBVT = 'A', LDVT >= N; if JOBVT = 'S', LDVT >= min(M,N).
+*
+* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
+* On exit, if INFO = 0, WORK(1) returns the optimal LWORK;
+* if INFO > 0, WORK(2:MIN(M,N)) contains the unconverged
+* superdiagonal elements of an upper bidiagonal matrix B
+* whose diagonal is in S (not necessarily sorted). B
+* satisfies A = U * B * VT, so it has the same singular values
+* as A, and singular vectors related by U and VT.
+*
+* LWORK (input) INTEGER
+* The dimension of the array WORK.
+* LWORK >= MAX(1,3*MIN(M,N)+MAX(M,N),5*MIN(M,N)).
+* For good performance, LWORK should generally be larger.
+*
+* If LWORK = -1, then a workspace query is assumed; the routine
+* only calculates the optimal size of the WORK array, returns
+* this value as the first entry of the WORK array, and no error
+* message related to LWORK is issued by XERBLA.
+*
+* INFO (output) INTEGER
+* = 0: successful exit.
+* < 0: if INFO = -i, the i-th argument had an illegal value.
+* > 0: if DBDSQR did not converge, INFO specifies how many
+* superdiagonals of an intermediate bidiagonal form B
+* did not converge to zero. See the description of WORK
+* above for details.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL LQUERY, WNTUA, WNTUAS, WNTUN, WNTUO, WNTUS,
+ $ WNTVA, WNTVAS, WNTVN, WNTVO, WNTVS
+ INTEGER BDSPAC, BLK, CHUNK, I, IE, IERR, IR, ISCL,
+ $ ITAU, ITAUP, ITAUQ, IU, IWORK, LDWRKR, LDWRKU,
+ $ MAXWRK, MINMN, MINWRK, MNTHR, NCU, NCVT, NRU,
+ $ NRVT, WRKBL
+ DOUBLE PRECISION ANRM, BIGNUM, EPS, SMLNUM
+* ..
+* .. Local Arrays ..
+ DOUBLE PRECISION DUM( 1 )
+* ..
+* .. External Subroutines ..
+ EXTERNAL DBDSQR, DGEBRD, DGELQF, DGEMM, DGEQRF, DLACPY,
+ $ DLASCL, DLASET, DORGBR, DORGLQ, DORGQR, DORMBR,
+ $ XERBLA
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ILAENV
+ DOUBLE PRECISION DLAMCH, DLANGE
+ EXTERNAL LSAME, ILAENV, DLAMCH, DLANGE
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN, SQRT
+* ..
+* .. Executable Statements ..
+*
+* Test the input arguments
+*
+ INFO = 0
+ MINMN = MIN( M, N )
+ WNTUA = LSAME( JOBU, 'A' )
+ WNTUS = LSAME( JOBU, 'S' )
+ WNTUAS = WNTUA .OR. WNTUS
+ WNTUO = LSAME( JOBU, 'O' )
+ WNTUN = LSAME( JOBU, 'N' )
+ WNTVA = LSAME( JOBVT, 'A' )
+ WNTVS = LSAME( JOBVT, 'S' )
+ WNTVAS = WNTVA .OR. WNTVS
+ WNTVO = LSAME( JOBVT, 'O' )
+ WNTVN = LSAME( JOBVT, 'N' )
+ LQUERY = ( LWORK.EQ.-1 )
+*
+ IF( .NOT.( WNTUA .OR. WNTUS .OR. WNTUO .OR. WNTUN ) ) THEN
+ INFO = -1
+ ELSE IF( .NOT.( WNTVA .OR. WNTVS .OR. WNTVO .OR. WNTVN ) .OR.
+ $ ( WNTVO .AND. WNTUO ) ) THEN
+ INFO = -2
+ ELSE IF( M.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+ INFO = -6
+ ELSE IF( LDU.LT.1 .OR. ( WNTUAS .AND. LDU.LT.M ) ) THEN
+ INFO = -9
+ ELSE IF( LDVT.LT.1 .OR. ( WNTVA .AND. LDVT.LT.N ) .OR.
+ $ ( WNTVS .AND. LDVT.LT.MINMN ) ) THEN
+ INFO = -11
+ END IF
+*
+* Compute workspace
+* (Note: Comments in the code beginning "Workspace:" describe the
+* minimal amount of workspace needed at that point in the code,
+* as well as the preferred amount for good performance.
+* NB refers to the optimal block size for the immediately
+* following subroutine, as returned by ILAENV.)
+*
+ IF( INFO.EQ.0 ) THEN
+ MINWRK = 1
+ MAXWRK = 1
+ IF( M.GE.N .AND. MINMN.GT.0 ) THEN
+*
+* Compute space needed for DBDSQR
+*
+ MNTHR = ILAENV( 6, 'DGESVD', JOBU // JOBVT, M, N, 0, 0 )
+ BDSPAC = 5*N
+ IF( M.GE.MNTHR ) THEN
+ IF( WNTUN ) THEN
+*
+* Path 1 (M much larger than N, JOBU='N')
+*
+ MAXWRK = N + N*ILAENV( 1, 'DGEQRF', ' ', M, N, -1,
+ $ -1 )
+ MAXWRK = MAX( MAXWRK, 3*N+2*N*
+ $ ILAENV( 1, 'DGEBRD', ' ', N, N, -1, -1 ) )
+ IF( WNTVO .OR. WNTVAS )
+ $ MAXWRK = MAX( MAXWRK, 3*N+( N-1 )*
+ $ ILAENV( 1, 'DORGBR', 'P', N, N, N, -1 ) )
+ MAXWRK = MAX( MAXWRK, BDSPAC )
+ MINWRK = MAX( 4*N, BDSPAC )
+ ELSE IF( WNTUO .AND. WNTVN ) THEN
+*
+* Path 2 (M much larger than N, JOBU='O', JOBVT='N')
+*
+ WRKBL = N + N*ILAENV( 1, 'DGEQRF', ' ', M, N, -1, -1 )
+ WRKBL = MAX( WRKBL, N+N*ILAENV( 1, 'DORGQR', ' ', M,
+ $ N, N, -1 ) )
+ WRKBL = MAX( WRKBL, 3*N+2*N*
+ $ ILAENV( 1, 'DGEBRD', ' ', N, N, -1, -1 ) )
+ WRKBL = MAX( WRKBL, 3*N+N*
+ $ ILAENV( 1, 'DORGBR', 'Q', N, N, N, -1 ) )
+ WRKBL = MAX( WRKBL, BDSPAC )
+ MAXWRK = MAX( N*N+WRKBL, N*N+M*N+N )
+ MINWRK = MAX( 3*N+M, BDSPAC )
+ ELSE IF( WNTUO .AND. WNTVAS ) THEN
+*
+* Path 3 (M much larger than N, JOBU='O', JOBVT='S' or
+* 'A')
+*
+ WRKBL = N + N*ILAENV( 1, 'DGEQRF', ' ', M, N, -1, -1 )
+ WRKBL = MAX( WRKBL, N+N*ILAENV( 1, 'DORGQR', ' ', M,
+ $ N, N, -1 ) )
+ WRKBL = MAX( WRKBL, 3*N+2*N*
+ $ ILAENV( 1, 'DGEBRD', ' ', N, N, -1, -1 ) )
+ WRKBL = MAX( WRKBL, 3*N+N*
+ $ ILAENV( 1, 'DORGBR', 'Q', N, N, N, -1 ) )
+ WRKBL = MAX( WRKBL, 3*N+( N-1 )*
+ $ ILAENV( 1, 'DORGBR', 'P', N, N, N, -1 ) )
+ WRKBL = MAX( WRKBL, BDSPAC )
+ MAXWRK = MAX( N*N+WRKBL, N*N+M*N+N )
+ MINWRK = MAX( 3*N+M, BDSPAC )
+ ELSE IF( WNTUS .AND. WNTVN ) THEN
+*
+* Path 4 (M much larger than N, JOBU='S', JOBVT='N')
+*
+ WRKBL = N + N*ILAENV( 1, 'DGEQRF', ' ', M, N, -1, -1 )
+ WRKBL = MAX( WRKBL, N+N*ILAENV( 1, 'DORGQR', ' ', M,
+ $ N, N, -1 ) )
+ WRKBL = MAX( WRKBL, 3*N+2*N*
+ $ ILAENV( 1, 'DGEBRD', ' ', N, N, -1, -1 ) )
+ WRKBL = MAX( WRKBL, 3*N+N*
+ $ ILAENV( 1, 'DORGBR', 'Q', N, N, N, -1 ) )
+ WRKBL = MAX( WRKBL, BDSPAC )
+ MAXWRK = N*N + WRKBL
+ MINWRK = MAX( 3*N+M, BDSPAC )
+ ELSE IF( WNTUS .AND. WNTVO ) THEN
+*
+* Path 5 (M much larger than N, JOBU='S', JOBVT='O')
+*
+ WRKBL = N + N*ILAENV( 1, 'DGEQRF', ' ', M, N, -1, -1 )
+ WRKBL = MAX( WRKBL, N+N*ILAENV( 1, 'DORGQR', ' ', M,
+ $ N, N, -1 ) )
+ WRKBL = MAX( WRKBL, 3*N+2*N*
+ $ ILAENV( 1, 'DGEBRD', ' ', N, N, -1, -1 ) )
+ WRKBL = MAX( WRKBL, 3*N+N*
+ $ ILAENV( 1, 'DORGBR', 'Q', N, N, N, -1 ) )
+ WRKBL = MAX( WRKBL, 3*N+( N-1 )*
+ $ ILAENV( 1, 'DORGBR', 'P', N, N, N, -1 ) )
+ WRKBL = MAX( WRKBL, BDSPAC )
+ MAXWRK = 2*N*N + WRKBL
+ MINWRK = MAX( 3*N+M, BDSPAC )
+ ELSE IF( WNTUS .AND. WNTVAS ) THEN
+*
+* Path 6 (M much larger than N, JOBU='S', JOBVT='S' or
+* 'A')
+*
+ WRKBL = N + N*ILAENV( 1, 'DGEQRF', ' ', M, N, -1, -1 )
+ WRKBL = MAX( WRKBL, N+N*ILAENV( 1, 'DORGQR', ' ', M,
+ $ N, N, -1 ) )
+ WRKBL = MAX( WRKBL, 3*N+2*N*
+ $ ILAENV( 1, 'DGEBRD', ' ', N, N, -1, -1 ) )
+ WRKBL = MAX( WRKBL, 3*N+N*
+ $ ILAENV( 1, 'DORGBR', 'Q', N, N, N, -1 ) )
+ WRKBL = MAX( WRKBL, 3*N+( N-1 )*
+ $ ILAENV( 1, 'DORGBR', 'P', N, N, N, -1 ) )
+ WRKBL = MAX( WRKBL, BDSPAC )
+ MAXWRK = N*N + WRKBL
+ MINWRK = MAX( 3*N+M, BDSPAC )
+ ELSE IF( WNTUA .AND. WNTVN ) THEN
+*
+* Path 7 (M much larger than N, JOBU='A', JOBVT='N')
+*
+ WRKBL = N + N*ILAENV( 1, 'DGEQRF', ' ', M, N, -1, -1 )
+ WRKBL = MAX( WRKBL, N+M*ILAENV( 1, 'DORGQR', ' ', M,
+ $ M, N, -1 ) )
+ WRKBL = MAX( WRKBL, 3*N+2*N*
+ $ ILAENV( 1, 'DGEBRD', ' ', N, N, -1, -1 ) )
+ WRKBL = MAX( WRKBL, 3*N+N*
+ $ ILAENV( 1, 'DORGBR', 'Q', N, N, N, -1 ) )
+ WRKBL = MAX( WRKBL, BDSPAC )
+ MAXWRK = N*N + WRKBL
+ MINWRK = MAX( 3*N+M, BDSPAC )
+ ELSE IF( WNTUA .AND. WNTVO ) THEN
+*
+* Path 8 (M much larger than N, JOBU='A', JOBVT='O')
+*
+ WRKBL = N + N*ILAENV( 1, 'DGEQRF', ' ', M, N, -1, -1 )
+ WRKBL = MAX( WRKBL, N+M*ILAENV( 1, 'DORGQR', ' ', M,
+ $ M, N, -1 ) )
+ WRKBL = MAX( WRKBL, 3*N+2*N*
+ $ ILAENV( 1, 'DGEBRD', ' ', N, N, -1, -1 ) )
+ WRKBL = MAX( WRKBL, 3*N+N*
+ $ ILAENV( 1, 'DORGBR', 'Q', N, N, N, -1 ) )
+ WRKBL = MAX( WRKBL, 3*N+( N-1 )*
+ $ ILAENV( 1, 'DORGBR', 'P', N, N, N, -1 ) )
+ WRKBL = MAX( WRKBL, BDSPAC )
+ MAXWRK = 2*N*N + WRKBL
+ MINWRK = MAX( 3*N+M, BDSPAC )
+ ELSE IF( WNTUA .AND. WNTVAS ) THEN
+*
+* Path 9 (M much larger than N, JOBU='A', JOBVT='S' or
+* 'A')
+*
+ WRKBL = N + N*ILAENV( 1, 'DGEQRF', ' ', M, N, -1, -1 )
+ WRKBL = MAX( WRKBL, N+M*ILAENV( 1, 'DORGQR', ' ', M,
+ $ M, N, -1 ) )
+ WRKBL = MAX( WRKBL, 3*N+2*N*
+ $ ILAENV( 1, 'DGEBRD', ' ', N, N, -1, -1 ) )
+ WRKBL = MAX( WRKBL, 3*N+N*
+ $ ILAENV( 1, 'DORGBR', 'Q', N, N, N, -1 ) )
+ WRKBL = MAX( WRKBL, 3*N+( N-1 )*
+ $ ILAENV( 1, 'DORGBR', 'P', N, N, N, -1 ) )
+ WRKBL = MAX( WRKBL, BDSPAC )
+ MAXWRK = N*N + WRKBL
+ MINWRK = MAX( 3*N+M, BDSPAC )
+ END IF
+ ELSE
+*
+* Path 10 (M at least N, but not much larger)
+*
+ MAXWRK = 3*N + ( M+N )*ILAENV( 1, 'DGEBRD', ' ', M, N,
+ $ -1, -1 )
+ IF( WNTUS .OR. WNTUO )
+ $ MAXWRK = MAX( MAXWRK, 3*N+N*
+ $ ILAENV( 1, 'DORGBR', 'Q', M, N, N, -1 ) )
+ IF( WNTUA )
+ $ MAXWRK = MAX( MAXWRK, 3*N+M*
+ $ ILAENV( 1, 'DORGBR', 'Q', M, M, N, -1 ) )
+ IF( .NOT.WNTVN )
+ $ MAXWRK = MAX( MAXWRK, 3*N+( N-1 )*
+ $ ILAENV( 1, 'DORGBR', 'P', N, N, N, -1 ) )
+ MAXWRK = MAX( MAXWRK, BDSPAC )
+ MINWRK = MAX( 3*N+M, BDSPAC )
+ END IF
+ ELSE IF( MINMN.GT.0 ) THEN
+*
+* Compute space needed for DBDSQR
+*
+ MNTHR = ILAENV( 6, 'DGESVD', JOBU // JOBVT, M, N, 0, 0 )
+ BDSPAC = 5*M
+ IF( N.GE.MNTHR ) THEN
+ IF( WNTVN ) THEN
+*
+* Path 1t(N much larger than M, JOBVT='N')
+*
+ MAXWRK = M + M*ILAENV( 1, 'DGELQF', ' ', M, N, -1,
+ $ -1 )
+ MAXWRK = MAX( MAXWRK, 3*M+2*M*
+ $ ILAENV( 1, 'DGEBRD', ' ', M, M, -1, -1 ) )
+ IF( WNTUO .OR. WNTUAS )
+ $ MAXWRK = MAX( MAXWRK, 3*M+M*
+ $ ILAENV( 1, 'DORGBR', 'Q', M, M, M, -1 ) )
+ MAXWRK = MAX( MAXWRK, BDSPAC )
+ MINWRK = MAX( 4*M, BDSPAC )
+ ELSE IF( WNTVO .AND. WNTUN ) THEN
+*
+* Path 2t(N much larger than M, JOBU='N', JOBVT='O')
+*
+ WRKBL = M + M*ILAENV( 1, 'DGELQF', ' ', M, N, -1, -1 )
+ WRKBL = MAX( WRKBL, M+M*ILAENV( 1, 'DORGLQ', ' ', M,
+ $ N, M, -1 ) )
+ WRKBL = MAX( WRKBL, 3*M+2*M*
+ $ ILAENV( 1, 'DGEBRD', ' ', M, M, -1, -1 ) )
+ WRKBL = MAX( WRKBL, 3*M+( M-1 )*
+ $ ILAENV( 1, 'DORGBR', 'P', M, M, M, -1 ) )
+ WRKBL = MAX( WRKBL, BDSPAC )
+ MAXWRK = MAX( M*M+WRKBL, M*M+M*N+M )
+ MINWRK = MAX( 3*M+N, BDSPAC )
+ ELSE IF( WNTVO .AND. WNTUAS ) THEN
+*
+* Path 3t(N much larger than M, JOBU='S' or 'A',
+* JOBVT='O')
+*
+ WRKBL = M + M*ILAENV( 1, 'DGELQF', ' ', M, N, -1, -1 )
+ WRKBL = MAX( WRKBL, M+M*ILAENV( 1, 'DORGLQ', ' ', M,
+ $ N, M, -1 ) )
+ WRKBL = MAX( WRKBL, 3*M+2*M*
+ $ ILAENV( 1, 'DGEBRD', ' ', M, M, -1, -1 ) )
+ WRKBL = MAX( WRKBL, 3*M+( M-1 )*
+ $ ILAENV( 1, 'DORGBR', 'P', M, M, M, -1 ) )
+ WRKBL = MAX( WRKBL, 3*M+M*
+ $ ILAENV( 1, 'DORGBR', 'Q', M, M, M, -1 ) )
+ WRKBL = MAX( WRKBL, BDSPAC )
+ MAXWRK = MAX( M*M+WRKBL, M*M+M*N+M )
+ MINWRK = MAX( 3*M+N, BDSPAC )
+ ELSE IF( WNTVS .AND. WNTUN ) THEN
+*
+* Path 4t(N much larger than M, JOBU='N', JOBVT='S')
+*
+ WRKBL = M + M*ILAENV( 1, 'DGELQF', ' ', M, N, -1, -1 )
+ WRKBL = MAX( WRKBL, M+M*ILAENV( 1, 'DORGLQ', ' ', M,
+ $ N, M, -1 ) )
+ WRKBL = MAX( WRKBL, 3*M+2*M*
+ $ ILAENV( 1, 'DGEBRD', ' ', M, M, -1, -1 ) )
+ WRKBL = MAX( WRKBL, 3*M+( M-1 )*
+ $ ILAENV( 1, 'DORGBR', 'P', M, M, M, -1 ) )
+ WRKBL = MAX( WRKBL, BDSPAC )
+ MAXWRK = M*M + WRKBL
+ MINWRK = MAX( 3*M+N, BDSPAC )
+ ELSE IF( WNTVS .AND. WNTUO ) THEN
+*
+* Path 5t(N much larger than M, JOBU='O', JOBVT='S')
+*
+ WRKBL = M + M*ILAENV( 1, 'DGELQF', ' ', M, N, -1, -1 )
+ WRKBL = MAX( WRKBL, M+M*ILAENV( 1, 'DORGLQ', ' ', M,
+ $ N, M, -1 ) )
+ WRKBL = MAX( WRKBL, 3*M+2*M*
+ $ ILAENV( 1, 'DGEBRD', ' ', M, M, -1, -1 ) )
+ WRKBL = MAX( WRKBL, 3*M+( M-1 )*
+ $ ILAENV( 1, 'DORGBR', 'P', M, M, M, -1 ) )
+ WRKBL = MAX( WRKBL, 3*M+M*
+ $ ILAENV( 1, 'DORGBR', 'Q', M, M, M, -1 ) )
+ WRKBL = MAX( WRKBL, BDSPAC )
+ MAXWRK = 2*M*M + WRKBL
+ MINWRK = MAX( 3*M+N, BDSPAC )
+ ELSE IF( WNTVS .AND. WNTUAS ) THEN
+*
+* Path 6t(N much larger than M, JOBU='S' or 'A',
+* JOBVT='S')
+*
+ WRKBL = M + M*ILAENV( 1, 'DGELQF', ' ', M, N, -1, -1 )
+ WRKBL = MAX( WRKBL, M+M*ILAENV( 1, 'DORGLQ', ' ', M,
+ $ N, M, -1 ) )
+ WRKBL = MAX( WRKBL, 3*M+2*M*
+ $ ILAENV( 1, 'DGEBRD', ' ', M, M, -1, -1 ) )
+ WRKBL = MAX( WRKBL, 3*M+( M-1 )*
+ $ ILAENV( 1, 'DORGBR', 'P', M, M, M, -1 ) )
+ WRKBL = MAX( WRKBL, 3*M+M*
+ $ ILAENV( 1, 'DORGBR', 'Q', M, M, M, -1 ) )
+ WRKBL = MAX( WRKBL, BDSPAC )
+ MAXWRK = M*M + WRKBL
+ MINWRK = MAX( 3*M+N, BDSPAC )
+ ELSE IF( WNTVA .AND. WNTUN ) THEN
+*
+* Path 7t(N much larger than M, JOBU='N', JOBVT='A')
+*
+ WRKBL = M + M*ILAENV( 1, 'DGELQF', ' ', M, N, -1, -1 )
+ WRKBL = MAX( WRKBL, M+N*ILAENV( 1, 'DORGLQ', ' ', N,
+ $ N, M, -1 ) )
+ WRKBL = MAX( WRKBL, 3*M+2*M*
+ $ ILAENV( 1, 'DGEBRD', ' ', M, M, -1, -1 ) )
+ WRKBL = MAX( WRKBL, 3*M+( M-1 )*
+ $ ILAENV( 1, 'DORGBR', 'P', M, M, M, -1 ) )
+ WRKBL = MAX( WRKBL, BDSPAC )
+ MAXWRK = M*M + WRKBL
+ MINWRK = MAX( 3*M+N, BDSPAC )
+ ELSE IF( WNTVA .AND. WNTUO ) THEN
+*
+* Path 8t(N much larger than M, JOBU='O', JOBVT='A')
+*
+ WRKBL = M + M*ILAENV( 1, 'DGELQF', ' ', M, N, -1, -1 )
+ WRKBL = MAX( WRKBL, M+N*ILAENV( 1, 'DORGLQ', ' ', N,
+ $ N, M, -1 ) )
+ WRKBL = MAX( WRKBL, 3*M+2*M*
+ $ ILAENV( 1, 'DGEBRD', ' ', M, M, -1, -1 ) )
+ WRKBL = MAX( WRKBL, 3*M+( M-1 )*
+ $ ILAENV( 1, 'DORGBR', 'P', M, M, M, -1 ) )
+ WRKBL = MAX( WRKBL, 3*M+M*
+ $ ILAENV( 1, 'DORGBR', 'Q', M, M, M, -1 ) )
+ WRKBL = MAX( WRKBL, BDSPAC )
+ MAXWRK = 2*M*M + WRKBL
+ MINWRK = MAX( 3*M+N, BDSPAC )
+ ELSE IF( WNTVA .AND. WNTUAS ) THEN
+*
+* Path 9t(N much larger than M, JOBU='S' or 'A',
+* JOBVT='A')
+*
+ WRKBL = M + M*ILAENV( 1, 'DGELQF', ' ', M, N, -1, -1 )
+ WRKBL = MAX( WRKBL, M+N*ILAENV( 1, 'DORGLQ', ' ', N,
+ $ N, M, -1 ) )
+ WRKBL = MAX( WRKBL, 3*M+2*M*
+ $ ILAENV( 1, 'DGEBRD', ' ', M, M, -1, -1 ) )
+ WRKBL = MAX( WRKBL, 3*M+( M-1 )*
+ $ ILAENV( 1, 'DORGBR', 'P', M, M, M, -1 ) )
+ WRKBL = MAX( WRKBL, 3*M+M*
+ $ ILAENV( 1, 'DORGBR', 'Q', M, M, M, -1 ) )
+ WRKBL = MAX( WRKBL, BDSPAC )
+ MAXWRK = M*M + WRKBL
+ MINWRK = MAX( 3*M+N, BDSPAC )
+ END IF
+ ELSE
+*
+* Path 10t(N greater than M, but not much larger)
+*
+ MAXWRK = 3*M + ( M+N )*ILAENV( 1, 'DGEBRD', ' ', M, N,
+ $ -1, -1 )
+ IF( WNTVS .OR. WNTVO )
+ $ MAXWRK = MAX( MAXWRK, 3*M+M*
+ $ ILAENV( 1, 'DORGBR', 'P', M, N, M, -1 ) )
+ IF( WNTVA )
+ $ MAXWRK = MAX( MAXWRK, 3*M+N*
+ $ ILAENV( 1, 'DORGBR', 'P', N, N, M, -1 ) )
+ IF( .NOT.WNTUN )
+ $ MAXWRK = MAX( MAXWRK, 3*M+( M-1 )*
+ $ ILAENV( 1, 'DORGBR', 'Q', M, M, M, -1 ) )
+ MAXWRK = MAX( MAXWRK, BDSPAC )
+ MINWRK = MAX( 3*M+N, BDSPAC )
+ END IF
+ END IF
+ MAXWRK = MAX( MAXWRK, MINWRK )
+ WORK( 1 ) = MAXWRK
+*
+ IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN
+ INFO = -13
+ END IF
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DGESVD', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( M.EQ.0 .OR. N.EQ.0 ) THEN
+ RETURN
+ END IF
+*
+* Get machine constants
+*
+ EPS = DLAMCH( 'P' )
+ SMLNUM = SQRT( DLAMCH( 'S' ) ) / EPS
+ BIGNUM = ONE / SMLNUM
+*
+* Scale A if max element outside range [SMLNUM,BIGNUM]
+*
+ ANRM = DLANGE( 'M', M, N, A, LDA, DUM )
+ ISCL = 0
+ IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
+ ISCL = 1
+ CALL DLASCL( 'G', 0, 0, ANRM, SMLNUM, M, N, A, LDA, IERR )
+ ELSE IF( ANRM.GT.BIGNUM ) THEN
+ ISCL = 1
+ CALL DLASCL( 'G', 0, 0, ANRM, BIGNUM, M, N, A, LDA, IERR )
+ END IF
+*
+ IF( M.GE.N ) THEN
+*
+* A has at least as many rows as columns. If A has sufficiently
+* more rows than columns, first reduce using the QR
+* decomposition (if sufficient workspace available)
+*
+ IF( M.GE.MNTHR ) THEN
+*
+ IF( WNTUN ) THEN
+*
+* Path 1 (M much larger than N, JOBU='N')
+* No left singular vectors to be computed
+*
+ ITAU = 1
+ IWORK = ITAU + N
+*
+* Compute A=Q*R
+* (Workspace: need 2*N, prefer N+N*NB)
+*
+ CALL DGEQRF( M, N, A, LDA, WORK( ITAU ), WORK( IWORK ),
+ $ LWORK-IWORK+1, IERR )
+*
+* Zero out below R
+*
+ CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, A( 2, 1 ), LDA )
+ IE = 1
+ ITAUQ = IE + N
+ ITAUP = ITAUQ + N
+ IWORK = ITAUP + N
+*
+* Bidiagonalize R in A
+* (Workspace: need 4*N, prefer 3*N+2*N*NB)
+*
+ CALL DGEBRD( N, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ),
+ $ WORK( ITAUP ), WORK( IWORK ), LWORK-IWORK+1,
+ $ IERR )
+ NCVT = 0
+ IF( WNTVO .OR. WNTVAS ) THEN
+*
+* If right singular vectors desired, generate P'.
+* (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB)
+*
+ CALL DORGBR( 'P', N, N, N, A, LDA, WORK( ITAUP ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ NCVT = N
+ END IF
+ IWORK = IE + N
+*
+* Perform bidiagonal QR iteration, computing right
+* singular vectors of A in A if desired
+* (Workspace: need BDSPAC)
+*
+ CALL DBDSQR( 'U', N, NCVT, 0, 0, S, WORK( IE ), A, LDA,
+ $ DUM, 1, DUM, 1, WORK( IWORK ), INFO )
+*
+* If right singular vectors desired in VT, copy them there
+*
+ IF( WNTVAS )
+ $ CALL DLACPY( 'F', N, N, A, LDA, VT, LDVT )
+*
+ ELSE IF( WNTUO .AND. WNTVN ) THEN
+*
+* Path 2 (M much larger than N, JOBU='O', JOBVT='N')
+* N left singular vectors to be overwritten on A and
+* no right singular vectors to be computed
+*
+ IF( LWORK.GE.N*N+MAX( 4*N, BDSPAC ) ) THEN
+*
+* Sufficient workspace for a fast algorithm
+*
+ IR = 1
+ IF( LWORK.GE.MAX( WRKBL, LDA*N+N )+LDA*N ) THEN
+*
+* WORK(IU) is LDA by N, WORK(IR) is LDA by N
+*
+ LDWRKU = LDA
+ LDWRKR = LDA
+ ELSE IF( LWORK.GE.MAX( WRKBL, LDA*N+N )+N*N ) THEN
+*
+* WORK(IU) is LDA by N, WORK(IR) is N by N
+*
+ LDWRKU = LDA
+ LDWRKR = N
+ ELSE
+*
+* WORK(IU) is LDWRKU by N, WORK(IR) is N by N
+*
+ LDWRKU = ( LWORK-N*N-N ) / N
+ LDWRKR = N
+ END IF
+ ITAU = IR + LDWRKR*N
+ IWORK = ITAU + N
+*
+* Compute A=Q*R
+* (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
+*
+ CALL DGEQRF( M, N, A, LDA, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+* Copy R to WORK(IR) and zero out below it
+*
+ CALL DLACPY( 'U', N, N, A, LDA, WORK( IR ), LDWRKR )
+ CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, WORK( IR+1 ),
+ $ LDWRKR )
+*
+* Generate Q in A
+* (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
+*
+ CALL DORGQR( M, N, N, A, LDA, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ IE = ITAU
+ ITAUQ = IE + N
+ ITAUP = ITAUQ + N
+ IWORK = ITAUP + N
+*
+* Bidiagonalize R in WORK(IR)
+* (Workspace: need N*N+4*N, prefer N*N+3*N+2*N*NB)
+*
+ CALL DGEBRD( N, N, WORK( IR ), LDWRKR, S, WORK( IE ),
+ $ WORK( ITAUQ ), WORK( ITAUP ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+* Generate left vectors bidiagonalizing R
+* (Workspace: need N*N+4*N, prefer N*N+3*N+N*NB)
+*
+ CALL DORGBR( 'Q', N, N, N, WORK( IR ), LDWRKR,
+ $ WORK( ITAUQ ), WORK( IWORK ),
+ $ LWORK-IWORK+1, IERR )
+ IWORK = IE + N
+*
+* Perform bidiagonal QR iteration, computing left
+* singular vectors of R in WORK(IR)
+* (Workspace: need N*N+BDSPAC)
+*
+ CALL DBDSQR( 'U', N, 0, N, 0, S, WORK( IE ), DUM, 1,
+ $ WORK( IR ), LDWRKR, DUM, 1,
+ $ WORK( IWORK ), INFO )
+ IU = IE + N
+*
+* Multiply Q in A by left singular vectors of R in
+* WORK(IR), storing result in WORK(IU) and copying to A
+* (Workspace: need N*N+2*N, prefer N*N+M*N+N)
+*
+ DO 10 I = 1, M, LDWRKU
+ CHUNK = MIN( M-I+1, LDWRKU )
+ CALL DGEMM( 'N', 'N', CHUNK, N, N, ONE, A( I, 1 ),
+ $ LDA, WORK( IR ), LDWRKR, ZERO,
+ $ WORK( IU ), LDWRKU )
+ CALL DLACPY( 'F', CHUNK, N, WORK( IU ), LDWRKU,
+ $ A( I, 1 ), LDA )
+ 10 CONTINUE
+*
+ ELSE
+*
+* Insufficient workspace for a fast algorithm
+*
+ IE = 1
+ ITAUQ = IE + N
+ ITAUP = ITAUQ + N
+ IWORK = ITAUP + N
+*
+* Bidiagonalize A
+* (Workspace: need 3*N+M, prefer 3*N+(M+N)*NB)
+*
+ CALL DGEBRD( M, N, A, LDA, S, WORK( IE ),
+ $ WORK( ITAUQ ), WORK( ITAUP ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+* Generate left vectors bidiagonalizing A
+* (Workspace: need 4*N, prefer 3*N+N*NB)
+*
+ CALL DORGBR( 'Q', M, N, N, A, LDA, WORK( ITAUQ ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ IWORK = IE + N
+*
+* Perform bidiagonal QR iteration, computing left
+* singular vectors of A in A
+* (Workspace: need BDSPAC)
+*
+ CALL DBDSQR( 'U', N, 0, M, 0, S, WORK( IE ), DUM, 1,
+ $ A, LDA, DUM, 1, WORK( IWORK ), INFO )
+*
+ END IF
+*
+ ELSE IF( WNTUO .AND. WNTVAS ) THEN
+*
+* Path 3 (M much larger than N, JOBU='O', JOBVT='S' or 'A')
+* N left singular vectors to be overwritten on A and
+* N right singular vectors to be computed in VT
+*
+ IF( LWORK.GE.N*N+MAX( 4*N, BDSPAC ) ) THEN
+*
+* Sufficient workspace for a fast algorithm
+*
+ IR = 1
+ IF( LWORK.GE.MAX( WRKBL, LDA*N+N )+LDA*N ) THEN
+*
+* WORK(IU) is LDA by N and WORK(IR) is LDA by N
+*
+ LDWRKU = LDA
+ LDWRKR = LDA
+ ELSE IF( LWORK.GE.MAX( WRKBL, LDA*N+N )+N*N ) THEN
+*
+* WORK(IU) is LDA by N and WORK(IR) is N by N
+*
+ LDWRKU = LDA
+ LDWRKR = N
+ ELSE
+*
+* WORK(IU) is LDWRKU by N and WORK(IR) is N by N
+*
+ LDWRKU = ( LWORK-N*N-N ) / N
+ LDWRKR = N
+ END IF
+ ITAU = IR + LDWRKR*N
+ IWORK = ITAU + N
+*
+* Compute A=Q*R
+* (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
+*
+ CALL DGEQRF( M, N, A, LDA, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+* Copy R to VT, zeroing out below it
+*
+ CALL DLACPY( 'U', N, N, A, LDA, VT, LDVT )
+ IF( N.GT.1 )
+ $ CALL DLASET( 'L', N-1, N-1, ZERO, ZERO,
+ $ VT( 2, 1 ), LDVT )
+*
+* Generate Q in A
+* (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
+*
+ CALL DORGQR( M, N, N, A, LDA, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ IE = ITAU
+ ITAUQ = IE + N
+ ITAUP = ITAUQ + N
+ IWORK = ITAUP + N
+*
+* Bidiagonalize R in VT, copying result to WORK(IR)
+* (Workspace: need N*N+4*N, prefer N*N+3*N+2*N*NB)
+*
+ CALL DGEBRD( N, N, VT, LDVT, S, WORK( IE ),
+ $ WORK( ITAUQ ), WORK( ITAUP ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ CALL DLACPY( 'L', N, N, VT, LDVT, WORK( IR ), LDWRKR )
+*
+* Generate left vectors bidiagonalizing R in WORK(IR)
+* (Workspace: need N*N+4*N, prefer N*N+3*N+N*NB)
+*
+ CALL DORGBR( 'Q', N, N, N, WORK( IR ), LDWRKR,
+ $ WORK( ITAUQ ), WORK( IWORK ),
+ $ LWORK-IWORK+1, IERR )
+*
+* Generate right vectors bidiagonalizing R in VT
+* (Workspace: need N*N+4*N-1, prefer N*N+3*N+(N-1)*NB)
+*
+ CALL DORGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ IWORK = IE + N
+*
+* Perform bidiagonal QR iteration, computing left
+* singular vectors of R in WORK(IR) and computing right
+* singular vectors of R in VT
+* (Workspace: need N*N+BDSPAC)
+*
+ CALL DBDSQR( 'U', N, N, N, 0, S, WORK( IE ), VT, LDVT,
+ $ WORK( IR ), LDWRKR, DUM, 1,
+ $ WORK( IWORK ), INFO )
+ IU = IE + N
+*
+* Multiply Q in A by left singular vectors of R in
+* WORK(IR), storing result in WORK(IU) and copying to A
+* (Workspace: need N*N+2*N, prefer N*N+M*N+N)
+*
+ DO 20 I = 1, M, LDWRKU
+ CHUNK = MIN( M-I+1, LDWRKU )
+ CALL DGEMM( 'N', 'N', CHUNK, N, N, ONE, A( I, 1 ),
+ $ LDA, WORK( IR ), LDWRKR, ZERO,
+ $ WORK( IU ), LDWRKU )
+ CALL DLACPY( 'F', CHUNK, N, WORK( IU ), LDWRKU,
+ $ A( I, 1 ), LDA )
+ 20 CONTINUE
+*
+ ELSE
+*
+* Insufficient workspace for a fast algorithm
+*
+ ITAU = 1
+ IWORK = ITAU + N
+*
+* Compute A=Q*R
+* (Workspace: need 2*N, prefer N+N*NB)
+*
+ CALL DGEQRF( M, N, A, LDA, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+* Copy R to VT, zeroing out below it
+*
+ CALL DLACPY( 'U', N, N, A, LDA, VT, LDVT )
+ IF( N.GT.1 )
+ $ CALL DLASET( 'L', N-1, N-1, ZERO, ZERO,
+ $ VT( 2, 1 ), LDVT )
+*
+* Generate Q in A
+* (Workspace: need 2*N, prefer N+N*NB)
+*
+ CALL DORGQR( M, N, N, A, LDA, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ IE = ITAU
+ ITAUQ = IE + N
+ ITAUP = ITAUQ + N
+ IWORK = ITAUP + N
+*
+* Bidiagonalize R in VT
+* (Workspace: need 4*N, prefer 3*N+2*N*NB)
+*
+ CALL DGEBRD( N, N, VT, LDVT, S, WORK( IE ),
+ $ WORK( ITAUQ ), WORK( ITAUP ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+* Multiply Q in A by left vectors bidiagonalizing R
+* (Workspace: need 3*N+M, prefer 3*N+M*NB)
+*
+ CALL DORMBR( 'Q', 'R', 'N', M, N, N, VT, LDVT,
+ $ WORK( ITAUQ ), A, LDA, WORK( IWORK ),
+ $ LWORK-IWORK+1, IERR )
+*
+* Generate right vectors bidiagonalizing R in VT
+* (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB)
+*
+ CALL DORGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ IWORK = IE + N
+*
+* Perform bidiagonal QR iteration, computing left
+* singular vectors of A in A and computing right
+* singular vectors of A in VT
+* (Workspace: need BDSPAC)
+*
+ CALL DBDSQR( 'U', N, N, M, 0, S, WORK( IE ), VT, LDVT,
+ $ A, LDA, DUM, 1, WORK( IWORK ), INFO )
+*
+ END IF
+*
+ ELSE IF( WNTUS ) THEN
+*
+ IF( WNTVN ) THEN
+*
+* Path 4 (M much larger than N, JOBU='S', JOBVT='N')
+* N left singular vectors to be computed in U and
+* no right singular vectors to be computed
+*
+ IF( LWORK.GE.N*N+MAX( 4*N, BDSPAC ) ) THEN
+*
+* Sufficient workspace for a fast algorithm
+*
+ IR = 1
+ IF( LWORK.GE.WRKBL+LDA*N ) THEN
+*
+* WORK(IR) is LDA by N
+*
+ LDWRKR = LDA
+ ELSE
+*
+* WORK(IR) is N by N
+*
+ LDWRKR = N
+ END IF
+ ITAU = IR + LDWRKR*N
+ IWORK = ITAU + N
+*
+* Compute A=Q*R
+* (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
+*
+ CALL DGEQRF( M, N, A, LDA, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+* Copy R to WORK(IR), zeroing out below it
+*
+ CALL DLACPY( 'U', N, N, A, LDA, WORK( IR ),
+ $ LDWRKR )
+ CALL DLASET( 'L', N-1, N-1, ZERO, ZERO,
+ $ WORK( IR+1 ), LDWRKR )
+*
+* Generate Q in A
+* (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
+*
+ CALL DORGQR( M, N, N, A, LDA, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ IE = ITAU
+ ITAUQ = IE + N
+ ITAUP = ITAUQ + N
+ IWORK = ITAUP + N
+*
+* Bidiagonalize R in WORK(IR)
+* (Workspace: need N*N+4*N, prefer N*N+3*N+2*N*NB)
+*
+ CALL DGEBRD( N, N, WORK( IR ), LDWRKR, S,
+ $ WORK( IE ), WORK( ITAUQ ),
+ $ WORK( ITAUP ), WORK( IWORK ),
+ $ LWORK-IWORK+1, IERR )
+*
+* Generate left vectors bidiagonalizing R in WORK(IR)
+* (Workspace: need N*N+4*N, prefer N*N+3*N+N*NB)
+*
+ CALL DORGBR( 'Q', N, N, N, WORK( IR ), LDWRKR,
+ $ WORK( ITAUQ ), WORK( IWORK ),
+ $ LWORK-IWORK+1, IERR )
+ IWORK = IE + N
+*
+* Perform bidiagonal QR iteration, computing left
+* singular vectors of R in WORK(IR)
+* (Workspace: need N*N+BDSPAC)
+*
+ CALL DBDSQR( 'U', N, 0, N, 0, S, WORK( IE ), DUM,
+ $ 1, WORK( IR ), LDWRKR, DUM, 1,
+ $ WORK( IWORK ), INFO )
+*
+* Multiply Q in A by left singular vectors of R in
+* WORK(IR), storing result in U
+* (Workspace: need N*N)
+*
+ CALL DGEMM( 'N', 'N', M, N, N, ONE, A, LDA,
+ $ WORK( IR ), LDWRKR, ZERO, U, LDU )
+*
+ ELSE
+*
+* Insufficient workspace for a fast algorithm
+*
+ ITAU = 1
+ IWORK = ITAU + N
+*
+* Compute A=Q*R, copying result to U
+* (Workspace: need 2*N, prefer N+N*NB)
+*
+ CALL DGEQRF( M, N, A, LDA, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ CALL DLACPY( 'L', M, N, A, LDA, U, LDU )
+*
+* Generate Q in U
+* (Workspace: need 2*N, prefer N+N*NB)
+*
+ CALL DORGQR( M, N, N, U, LDU, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ IE = ITAU
+ ITAUQ = IE + N
+ ITAUP = ITAUQ + N
+ IWORK = ITAUP + N
+*
+* Zero out below R in A
+*
+ CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, A( 2, 1 ),
+ $ LDA )
+*
+* Bidiagonalize R in A
+* (Workspace: need 4*N, prefer 3*N+2*N*NB)
+*
+ CALL DGEBRD( N, N, A, LDA, S, WORK( IE ),
+ $ WORK( ITAUQ ), WORK( ITAUP ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+* Multiply Q in U by left vectors bidiagonalizing R
+* (Workspace: need 3*N+M, prefer 3*N+M*NB)
+*
+ CALL DORMBR( 'Q', 'R', 'N', M, N, N, A, LDA,
+ $ WORK( ITAUQ ), U, LDU, WORK( IWORK ),
+ $ LWORK-IWORK+1, IERR )
+ IWORK = IE + N
+*
+* Perform bidiagonal QR iteration, computing left
+* singular vectors of A in U
+* (Workspace: need BDSPAC)
+*
+ CALL DBDSQR( 'U', N, 0, M, 0, S, WORK( IE ), DUM,
+ $ 1, U, LDU, DUM, 1, WORK( IWORK ),
+ $ INFO )
+*
+ END IF
+*
+ ELSE IF( WNTVO ) THEN
+*
+* Path 5 (M much larger than N, JOBU='S', JOBVT='O')
+* N left singular vectors to be computed in U and
+* N right singular vectors to be overwritten on A
+*
+ IF( LWORK.GE.2*N*N+MAX( 4*N, BDSPAC ) ) THEN
+*
+* Sufficient workspace for a fast algorithm
+*
+ IU = 1
+ IF( LWORK.GE.WRKBL+2*LDA*N ) THEN
+*
+* WORK(IU) is LDA by N and WORK(IR) is LDA by N
+*
+ LDWRKU = LDA
+ IR = IU + LDWRKU*N
+ LDWRKR = LDA
+ ELSE IF( LWORK.GE.WRKBL+( LDA+N )*N ) THEN
+*
+* WORK(IU) is LDA by N and WORK(IR) is N by N
+*
+ LDWRKU = LDA
+ IR = IU + LDWRKU*N
+ LDWRKR = N
+ ELSE
+*
+* WORK(IU) is N by N and WORK(IR) is N by N
+*
+ LDWRKU = N
+ IR = IU + LDWRKU*N
+ LDWRKR = N
+ END IF
+ ITAU = IR + LDWRKR*N
+ IWORK = ITAU + N
+*
+* Compute A=Q*R
+* (Workspace: need 2*N*N+2*N, prefer 2*N*N+N+N*NB)
+*
+ CALL DGEQRF( M, N, A, LDA, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+* Copy R to WORK(IU), zeroing out below it
+*
+ CALL DLACPY( 'U', N, N, A, LDA, WORK( IU ),
+ $ LDWRKU )
+ CALL DLASET( 'L', N-1, N-1, ZERO, ZERO,
+ $ WORK( IU+1 ), LDWRKU )
+*
+* Generate Q in A
+* (Workspace: need 2*N*N+2*N, prefer 2*N*N+N+N*NB)
+*
+ CALL DORGQR( M, N, N, A, LDA, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ IE = ITAU
+ ITAUQ = IE + N
+ ITAUP = ITAUQ + N
+ IWORK = ITAUP + N
+*
+* Bidiagonalize R in WORK(IU), copying result to
+* WORK(IR)
+* (Workspace: need 2*N*N+4*N,
+* prefer 2*N*N+3*N+2*N*NB)
+*
+ CALL DGEBRD( N, N, WORK( IU ), LDWRKU, S,
+ $ WORK( IE ), WORK( ITAUQ ),
+ $ WORK( ITAUP ), WORK( IWORK ),
+ $ LWORK-IWORK+1, IERR )
+ CALL DLACPY( 'U', N, N, WORK( IU ), LDWRKU,
+ $ WORK( IR ), LDWRKR )
+*
+* Generate left bidiagonalizing vectors in WORK(IU)
+* (Workspace: need 2*N*N+4*N, prefer 2*N*N+3*N+N*NB)
+*
+ CALL DORGBR( 'Q', N, N, N, WORK( IU ), LDWRKU,
+ $ WORK( ITAUQ ), WORK( IWORK ),
+ $ LWORK-IWORK+1, IERR )
+*
+* Generate right bidiagonalizing vectors in WORK(IR)
+* (Workspace: need 2*N*N+4*N-1,
+* prefer 2*N*N+3*N+(N-1)*NB)
+*
+ CALL DORGBR( 'P', N, N, N, WORK( IR ), LDWRKR,
+ $ WORK( ITAUP ), WORK( IWORK ),
+ $ LWORK-IWORK+1, IERR )
+ IWORK = IE + N
+*
+* Perform bidiagonal QR iteration, computing left
+* singular vectors of R in WORK(IU) and computing
+* right singular vectors of R in WORK(IR)
+* (Workspace: need 2*N*N+BDSPAC)
+*
+ CALL DBDSQR( 'U', N, N, N, 0, S, WORK( IE ),
+ $ WORK( IR ), LDWRKR, WORK( IU ),
+ $ LDWRKU, DUM, 1, WORK( IWORK ), INFO )
+*
+* Multiply Q in A by left singular vectors of R in
+* WORK(IU), storing result in U
+* (Workspace: need N*N)
+*
+ CALL DGEMM( 'N', 'N', M, N, N, ONE, A, LDA,
+ $ WORK( IU ), LDWRKU, ZERO, U, LDU )
+*
+* Copy right singular vectors of R to A
+* (Workspace: need N*N)
+*
+ CALL DLACPY( 'F', N, N, WORK( IR ), LDWRKR, A,
+ $ LDA )
+*
+ ELSE
+*
+* Insufficient workspace for a fast algorithm
+*
+ ITAU = 1
+ IWORK = ITAU + N
+*
+* Compute A=Q*R, copying result to U
+* (Workspace: need 2*N, prefer N+N*NB)
+*
+ CALL DGEQRF( M, N, A, LDA, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ CALL DLACPY( 'L', M, N, A, LDA, U, LDU )
+*
+* Generate Q in U
+* (Workspace: need 2*N, prefer N+N*NB)
+*
+ CALL DORGQR( M, N, N, U, LDU, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ IE = ITAU
+ ITAUQ = IE + N
+ ITAUP = ITAUQ + N
+ IWORK = ITAUP + N
+*
+* Zero out below R in A
+*
+ CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, A( 2, 1 ),
+ $ LDA )
+*
+* Bidiagonalize R in A
+* (Workspace: need 4*N, prefer 3*N+2*N*NB)
+*
+ CALL DGEBRD( N, N, A, LDA, S, WORK( IE ),
+ $ WORK( ITAUQ ), WORK( ITAUP ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+* Multiply Q in U by left vectors bidiagonalizing R
+* (Workspace: need 3*N+M, prefer 3*N+M*NB)
+*
+ CALL DORMBR( 'Q', 'R', 'N', M, N, N, A, LDA,
+ $ WORK( ITAUQ ), U, LDU, WORK( IWORK ),
+ $ LWORK-IWORK+1, IERR )
+*
+* Generate right vectors bidiagonalizing R in A
+* (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB)
+*
+ CALL DORGBR( 'P', N, N, N, A, LDA, WORK( ITAUP ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ IWORK = IE + N
+*
+* Perform bidiagonal QR iteration, computing left
+* singular vectors of A in U and computing right
+* singular vectors of A in A
+* (Workspace: need BDSPAC)
+*
+ CALL DBDSQR( 'U', N, N, M, 0, S, WORK( IE ), A,
+ $ LDA, U, LDU, DUM, 1, WORK( IWORK ),
+ $ INFO )
+*
+ END IF
+*
+ ELSE IF( WNTVAS ) THEN
+*
+* Path 6 (M much larger than N, JOBU='S', JOBVT='S'
+* or 'A')
+* N left singular vectors to be computed in U and
+* N right singular vectors to be computed in VT
+*
+ IF( LWORK.GE.N*N+MAX( 4*N, BDSPAC ) ) THEN
+*
+* Sufficient workspace for a fast algorithm
+*
+ IU = 1
+ IF( LWORK.GE.WRKBL+LDA*N ) THEN
+*
+* WORK(IU) is LDA by N
+*
+ LDWRKU = LDA
+ ELSE
+*
+* WORK(IU) is N by N
+*
+ LDWRKU = N
+ END IF
+ ITAU = IU + LDWRKU*N
+ IWORK = ITAU + N
+*
+* Compute A=Q*R
+* (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
+*
+ CALL DGEQRF( M, N, A, LDA, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+* Copy R to WORK(IU), zeroing out below it
+*
+ CALL DLACPY( 'U', N, N, A, LDA, WORK( IU ),
+ $ LDWRKU )
+ CALL DLASET( 'L', N-1, N-1, ZERO, ZERO,
+ $ WORK( IU+1 ), LDWRKU )
+*
+* Generate Q in A
+* (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
+*
+ CALL DORGQR( M, N, N, A, LDA, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ IE = ITAU
+ ITAUQ = IE + N
+ ITAUP = ITAUQ + N
+ IWORK = ITAUP + N
+*
+* Bidiagonalize R in WORK(IU), copying result to VT
+* (Workspace: need N*N+4*N, prefer N*N+3*N+2*N*NB)
+*
+ CALL DGEBRD( N, N, WORK( IU ), LDWRKU, S,
+ $ WORK( IE ), WORK( ITAUQ ),
+ $ WORK( ITAUP ), WORK( IWORK ),
+ $ LWORK-IWORK+1, IERR )
+ CALL DLACPY( 'U', N, N, WORK( IU ), LDWRKU, VT,
+ $ LDVT )
+*
+* Generate left bidiagonalizing vectors in WORK(IU)
+* (Workspace: need N*N+4*N, prefer N*N+3*N+N*NB)
+*
+ CALL DORGBR( 'Q', N, N, N, WORK( IU ), LDWRKU,
+ $ WORK( ITAUQ ), WORK( IWORK ),
+ $ LWORK-IWORK+1, IERR )
+*
+* Generate right bidiagonalizing vectors in VT
+* (Workspace: need N*N+4*N-1,
+* prefer N*N+3*N+(N-1)*NB)
+*
+ CALL DORGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ IWORK = IE + N
+*
+* Perform bidiagonal QR iteration, computing left
+* singular vectors of R in WORK(IU) and computing
+* right singular vectors of R in VT
+* (Workspace: need N*N+BDSPAC)
+*
+ CALL DBDSQR( 'U', N, N, N, 0, S, WORK( IE ), VT,
+ $ LDVT, WORK( IU ), LDWRKU, DUM, 1,
+ $ WORK( IWORK ), INFO )
+*
+* Multiply Q in A by left singular vectors of R in
+* WORK(IU), storing result in U
+* (Workspace: need N*N)
+*
+ CALL DGEMM( 'N', 'N', M, N, N, ONE, A, LDA,
+ $ WORK( IU ), LDWRKU, ZERO, U, LDU )
+*
+ ELSE
+*
+* Insufficient workspace for a fast algorithm
+*
+ ITAU = 1
+ IWORK = ITAU + N
+*
+* Compute A=Q*R, copying result to U
+* (Workspace: need 2*N, prefer N+N*NB)
+*
+ CALL DGEQRF( M, N, A, LDA, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ CALL DLACPY( 'L', M, N, A, LDA, U, LDU )
+*
+* Generate Q in U
+* (Workspace: need 2*N, prefer N+N*NB)
+*
+ CALL DORGQR( M, N, N, U, LDU, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+* Copy R to VT, zeroing out below it
+*
+ CALL DLACPY( 'U', N, N, A, LDA, VT, LDVT )
+ IF( N.GT.1 )
+ $ CALL DLASET( 'L', N-1, N-1, ZERO, ZERO,
+ $ VT( 2, 1 ), LDVT )
+ IE = ITAU
+ ITAUQ = IE + N
+ ITAUP = ITAUQ + N
+ IWORK = ITAUP + N
+*
+* Bidiagonalize R in VT
+* (Workspace: need 4*N, prefer 3*N+2*N*NB)
+*
+ CALL DGEBRD( N, N, VT, LDVT, S, WORK( IE ),
+ $ WORK( ITAUQ ), WORK( ITAUP ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+* Multiply Q in U by left bidiagonalizing vectors
+* in VT
+* (Workspace: need 3*N+M, prefer 3*N+M*NB)
+*
+ CALL DORMBR( 'Q', 'R', 'N', M, N, N, VT, LDVT,
+ $ WORK( ITAUQ ), U, LDU, WORK( IWORK ),
+ $ LWORK-IWORK+1, IERR )
+*
+* Generate right bidiagonalizing vectors in VT
+* (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB)
+*
+ CALL DORGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ IWORK = IE + N
+*
+* Perform bidiagonal QR iteration, computing left
+* singular vectors of A in U and computing right
+* singular vectors of A in VT
+* (Workspace: need BDSPAC)
+*
+ CALL DBDSQR( 'U', N, N, M, 0, S, WORK( IE ), VT,
+ $ LDVT, U, LDU, DUM, 1, WORK( IWORK ),
+ $ INFO )
+*
+ END IF
+*
+ END IF
+*
+ ELSE IF( WNTUA ) THEN
+*
+ IF( WNTVN ) THEN
+*
+* Path 7 (M much larger than N, JOBU='A', JOBVT='N')
+* M left singular vectors to be computed in U and
+* no right singular vectors to be computed
+*
+ IF( LWORK.GE.N*N+MAX( N+M, 4*N, BDSPAC ) ) THEN
+*
+* Sufficient workspace for a fast algorithm
+*
+ IR = 1
+ IF( LWORK.GE.WRKBL+LDA*N ) THEN
+*
+* WORK(IR) is LDA by N
+*
+ LDWRKR = LDA
+ ELSE
+*
+* WORK(IR) is N by N
+*
+ LDWRKR = N
+ END IF
+ ITAU = IR + LDWRKR*N
+ IWORK = ITAU + N
+*
+* Compute A=Q*R, copying result to U
+* (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
+*
+ CALL DGEQRF( M, N, A, LDA, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ CALL DLACPY( 'L', M, N, A, LDA, U, LDU )
+*
+* Copy R to WORK(IR), zeroing out below it
+*
+ CALL DLACPY( 'U', N, N, A, LDA, WORK( IR ),
+ $ LDWRKR )
+ CALL DLASET( 'L', N-1, N-1, ZERO, ZERO,
+ $ WORK( IR+1 ), LDWRKR )
+*
+* Generate Q in U
+* (Workspace: need N*N+N+M, prefer N*N+N+M*NB)
+*
+ CALL DORGQR( M, M, N, U, LDU, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ IE = ITAU
+ ITAUQ = IE + N
+ ITAUP = ITAUQ + N
+ IWORK = ITAUP + N
+*
+* Bidiagonalize R in WORK(IR)
+* (Workspace: need N*N+4*N, prefer N*N+3*N+2*N*NB)
+*
+ CALL DGEBRD( N, N, WORK( IR ), LDWRKR, S,
+ $ WORK( IE ), WORK( ITAUQ ),
+ $ WORK( ITAUP ), WORK( IWORK ),
+ $ LWORK-IWORK+1, IERR )
+*
+* Generate left bidiagonalizing vectors in WORK(IR)
+* (Workspace: need N*N+4*N, prefer N*N+3*N+N*NB)
+*
+ CALL DORGBR( 'Q', N, N, N, WORK( IR ), LDWRKR,
+ $ WORK( ITAUQ ), WORK( IWORK ),
+ $ LWORK-IWORK+1, IERR )
+ IWORK = IE + N
+*
+* Perform bidiagonal QR iteration, computing left
+* singular vectors of R in WORK(IR)
+* (Workspace: need N*N+BDSPAC)
+*
+ CALL DBDSQR( 'U', N, 0, N, 0, S, WORK( IE ), DUM,
+ $ 1, WORK( IR ), LDWRKR, DUM, 1,
+ $ WORK( IWORK ), INFO )
+*
+* Multiply Q in U by left singular vectors of R in
+* WORK(IR), storing result in A
+* (Workspace: need N*N)
+*
+ CALL DGEMM( 'N', 'N', M, N, N, ONE, U, LDU,
+ $ WORK( IR ), LDWRKR, ZERO, A, LDA )
+*
+* Copy left singular vectors of A from A to U
+*
+ CALL DLACPY( 'F', M, N, A, LDA, U, LDU )
+*
+ ELSE
+*
+* Insufficient workspace for a fast algorithm
+*
+ ITAU = 1
+ IWORK = ITAU + N
+*
+* Compute A=Q*R, copying result to U
+* (Workspace: need 2*N, prefer N+N*NB)
+*
+ CALL DGEQRF( M, N, A, LDA, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ CALL DLACPY( 'L', M, N, A, LDA, U, LDU )
+*
+* Generate Q in U
+* (Workspace: need N+M, prefer N+M*NB)
+*
+ CALL DORGQR( M, M, N, U, LDU, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ IE = ITAU
+ ITAUQ = IE + N
+ ITAUP = ITAUQ + N
+ IWORK = ITAUP + N
+*
+* Zero out below R in A
+*
+ CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, A( 2, 1 ),
+ $ LDA )
+*
+* Bidiagonalize R in A
+* (Workspace: need 4*N, prefer 3*N+2*N*NB)
+*
+ CALL DGEBRD( N, N, A, LDA, S, WORK( IE ),
+ $ WORK( ITAUQ ), WORK( ITAUP ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+* Multiply Q in U by left bidiagonalizing vectors
+* in A
+* (Workspace: need 3*N+M, prefer 3*N+M*NB)
+*
+ CALL DORMBR( 'Q', 'R', 'N', M, N, N, A, LDA,
+ $ WORK( ITAUQ ), U, LDU, WORK( IWORK ),
+ $ LWORK-IWORK+1, IERR )
+ IWORK = IE + N
+*
+* Perform bidiagonal QR iteration, computing left
+* singular vectors of A in U
+* (Workspace: need BDSPAC)
+*
+ CALL DBDSQR( 'U', N, 0, M, 0, S, WORK( IE ), DUM,
+ $ 1, U, LDU, DUM, 1, WORK( IWORK ),
+ $ INFO )
+*
+ END IF
+*
+ ELSE IF( WNTVO ) THEN
+*
+* Path 8 (M much larger than N, JOBU='A', JOBVT='O')
+* M left singular vectors to be computed in U and
+* N right singular vectors to be overwritten on A
+*
+ IF( LWORK.GE.2*N*N+MAX( N+M, 4*N, BDSPAC ) ) THEN
+*
+* Sufficient workspace for a fast algorithm
+*
+ IU = 1
+ IF( LWORK.GE.WRKBL+2*LDA*N ) THEN
+*
+* WORK(IU) is LDA by N and WORK(IR) is LDA by N
+*
+ LDWRKU = LDA
+ IR = IU + LDWRKU*N
+ LDWRKR = LDA
+ ELSE IF( LWORK.GE.WRKBL+( LDA+N )*N ) THEN
+*
+* WORK(IU) is LDA by N and WORK(IR) is N by N
+*
+ LDWRKU = LDA
+ IR = IU + LDWRKU*N
+ LDWRKR = N
+ ELSE
+*
+* WORK(IU) is N by N and WORK(IR) is N by N
+*
+ LDWRKU = N
+ IR = IU + LDWRKU*N
+ LDWRKR = N
+ END IF
+ ITAU = IR + LDWRKR*N
+ IWORK = ITAU + N
+*
+* Compute A=Q*R, copying result to U
+* (Workspace: need 2*N*N+2*N, prefer 2*N*N+N+N*NB)
+*
+ CALL DGEQRF( M, N, A, LDA, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ CALL DLACPY( 'L', M, N, A, LDA, U, LDU )
+*
+* Generate Q in U
+* (Workspace: need 2*N*N+N+M, prefer 2*N*N+N+M*NB)
+*
+ CALL DORGQR( M, M, N, U, LDU, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+* Copy R to WORK(IU), zeroing out below it
+*
+ CALL DLACPY( 'U', N, N, A, LDA, WORK( IU ),
+ $ LDWRKU )
+ CALL DLASET( 'L', N-1, N-1, ZERO, ZERO,
+ $ WORK( IU+1 ), LDWRKU )
+ IE = ITAU
+ ITAUQ = IE + N
+ ITAUP = ITAUQ + N
+ IWORK = ITAUP + N
+*
+* Bidiagonalize R in WORK(IU), copying result to
+* WORK(IR)
+* (Workspace: need 2*N*N+4*N,
+* prefer 2*N*N+3*N+2*N*NB)
+*
+ CALL DGEBRD( N, N, WORK( IU ), LDWRKU, S,
+ $ WORK( IE ), WORK( ITAUQ ),
+ $ WORK( ITAUP ), WORK( IWORK ),
+ $ LWORK-IWORK+1, IERR )
+ CALL DLACPY( 'U', N, N, WORK( IU ), LDWRKU,
+ $ WORK( IR ), LDWRKR )
+*
+* Generate left bidiagonalizing vectors in WORK(IU)
+* (Workspace: need 2*N*N+4*N, prefer 2*N*N+3*N+N*NB)
+*
+ CALL DORGBR( 'Q', N, N, N, WORK( IU ), LDWRKU,
+ $ WORK( ITAUQ ), WORK( IWORK ),
+ $ LWORK-IWORK+1, IERR )
+*
+* Generate right bidiagonalizing vectors in WORK(IR)
+* (Workspace: need 2*N*N+4*N-1,
+* prefer 2*N*N+3*N+(N-1)*NB)
+*
+ CALL DORGBR( 'P', N, N, N, WORK( IR ), LDWRKR,
+ $ WORK( ITAUP ), WORK( IWORK ),
+ $ LWORK-IWORK+1, IERR )
+ IWORK = IE + N
+*
+* Perform bidiagonal QR iteration, computing left
+* singular vectors of R in WORK(IU) and computing
+* right singular vectors of R in WORK(IR)
+* (Workspace: need 2*N*N+BDSPAC)
+*
+ CALL DBDSQR( 'U', N, N, N, 0, S, WORK( IE ),
+ $ WORK( IR ), LDWRKR, WORK( IU ),
+ $ LDWRKU, DUM, 1, WORK( IWORK ), INFO )
+*
+* Multiply Q in U by left singular vectors of R in
+* WORK(IU), storing result in A
+* (Workspace: need N*N)
+*
+ CALL DGEMM( 'N', 'N', M, N, N, ONE, U, LDU,
+ $ WORK( IU ), LDWRKU, ZERO, A, LDA )
+*
+* Copy left singular vectors of A from A to U
+*
+ CALL DLACPY( 'F', M, N, A, LDA, U, LDU )
+*
+* Copy right singular vectors of R from WORK(IR) to A
+*
+ CALL DLACPY( 'F', N, N, WORK( IR ), LDWRKR, A,
+ $ LDA )
+*
+ ELSE
+*
+* Insufficient workspace for a fast algorithm
+*
+ ITAU = 1
+ IWORK = ITAU + N
+*
+* Compute A=Q*R, copying result to U
+* (Workspace: need 2*N, prefer N+N*NB)
+*
+ CALL DGEQRF( M, N, A, LDA, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ CALL DLACPY( 'L', M, N, A, LDA, U, LDU )
+*
+* Generate Q in U
+* (Workspace: need N+M, prefer N+M*NB)
+*
+ CALL DORGQR( M, M, N, U, LDU, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ IE = ITAU
+ ITAUQ = IE + N
+ ITAUP = ITAUQ + N
+ IWORK = ITAUP + N
+*
+* Zero out below R in A
+*
+ CALL DLASET( 'L', N-1, N-1, ZERO, ZERO, A( 2, 1 ),
+ $ LDA )
+*
+* Bidiagonalize R in A
+* (Workspace: need 4*N, prefer 3*N+2*N*NB)
+*
+ CALL DGEBRD( N, N, A, LDA, S, WORK( IE ),
+ $ WORK( ITAUQ ), WORK( ITAUP ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+* Multiply Q in U by left bidiagonalizing vectors
+* in A
+* (Workspace: need 3*N+M, prefer 3*N+M*NB)
+*
+ CALL DORMBR( 'Q', 'R', 'N', M, N, N, A, LDA,
+ $ WORK( ITAUQ ), U, LDU, WORK( IWORK ),
+ $ LWORK-IWORK+1, IERR )
+*
+* Generate right bidiagonalizing vectors in A
+* (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB)
+*
+ CALL DORGBR( 'P', N, N, N, A, LDA, WORK( ITAUP ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ IWORK = IE + N
+*
+* Perform bidiagonal QR iteration, computing left
+* singular vectors of A in U and computing right
+* singular vectors of A in A
+* (Workspace: need BDSPAC)
+*
+ CALL DBDSQR( 'U', N, N, M, 0, S, WORK( IE ), A,
+ $ LDA, U, LDU, DUM, 1, WORK( IWORK ),
+ $ INFO )
+*
+ END IF
+*
+ ELSE IF( WNTVAS ) THEN
+*
+* Path 9 (M much larger than N, JOBU='A', JOBVT='S'
+* or 'A')
+* M left singular vectors to be computed in U and
+* N right singular vectors to be computed in VT
+*
+ IF( LWORK.GE.N*N+MAX( N+M, 4*N, BDSPAC ) ) THEN
+*
+* Sufficient workspace for a fast algorithm
+*
+ IU = 1
+ IF( LWORK.GE.WRKBL+LDA*N ) THEN
+*
+* WORK(IU) is LDA by N
+*
+ LDWRKU = LDA
+ ELSE
+*
+* WORK(IU) is N by N
+*
+ LDWRKU = N
+ END IF
+ ITAU = IU + LDWRKU*N
+ IWORK = ITAU + N
+*
+* Compute A=Q*R, copying result to U
+* (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
+*
+ CALL DGEQRF( M, N, A, LDA, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ CALL DLACPY( 'L', M, N, A, LDA, U, LDU )
+*
+* Generate Q in U
+* (Workspace: need N*N+N+M, prefer N*N+N+M*NB)
+*
+ CALL DORGQR( M, M, N, U, LDU, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+* Copy R to WORK(IU), zeroing out below it
+*
+ CALL DLACPY( 'U', N, N, A, LDA, WORK( IU ),
+ $ LDWRKU )
+ CALL DLASET( 'L', N-1, N-1, ZERO, ZERO,
+ $ WORK( IU+1 ), LDWRKU )
+ IE = ITAU
+ ITAUQ = IE + N
+ ITAUP = ITAUQ + N
+ IWORK = ITAUP + N
+*
+* Bidiagonalize R in WORK(IU), copying result to VT
+* (Workspace: need N*N+4*N, prefer N*N+3*N+2*N*NB)
+*
+ CALL DGEBRD( N, N, WORK( IU ), LDWRKU, S,
+ $ WORK( IE ), WORK( ITAUQ ),
+ $ WORK( ITAUP ), WORK( IWORK ),
+ $ LWORK-IWORK+1, IERR )
+ CALL DLACPY( 'U', N, N, WORK( IU ), LDWRKU, VT,
+ $ LDVT )
+*
+* Generate left bidiagonalizing vectors in WORK(IU)
+* (Workspace: need N*N+4*N, prefer N*N+3*N+N*NB)
+*
+ CALL DORGBR( 'Q', N, N, N, WORK( IU ), LDWRKU,
+ $ WORK( ITAUQ ), WORK( IWORK ),
+ $ LWORK-IWORK+1, IERR )
+*
+* Generate right bidiagonalizing vectors in VT
+* (Workspace: need N*N+4*N-1,
+* prefer N*N+3*N+(N-1)*NB)
+*
+ CALL DORGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ IWORK = IE + N
+*
+* Perform bidiagonal QR iteration, computing left
+* singular vectors of R in WORK(IU) and computing
+* right singular vectors of R in VT
+* (Workspace: need N*N+BDSPAC)
+*
+ CALL DBDSQR( 'U', N, N, N, 0, S, WORK( IE ), VT,
+ $ LDVT, WORK( IU ), LDWRKU, DUM, 1,
+ $ WORK( IWORK ), INFO )
+*
+* Multiply Q in U by left singular vectors of R in
+* WORK(IU), storing result in A
+* (Workspace: need N*N)
+*
+ CALL DGEMM( 'N', 'N', M, N, N, ONE, U, LDU,
+ $ WORK( IU ), LDWRKU, ZERO, A, LDA )
+*
+* Copy left singular vectors of A from A to U
+*
+ CALL DLACPY( 'F', M, N, A, LDA, U, LDU )
+*
+ ELSE
+*
+* Insufficient workspace for a fast algorithm
+*
+ ITAU = 1
+ IWORK = ITAU + N
+*
+* Compute A=Q*R, copying result to U
+* (Workspace: need 2*N, prefer N+N*NB)
+*
+ CALL DGEQRF( M, N, A, LDA, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ CALL DLACPY( 'L', M, N, A, LDA, U, LDU )
+*
+* Generate Q in U
+* (Workspace: need N+M, prefer N+M*NB)
+*
+ CALL DORGQR( M, M, N, U, LDU, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+* Copy R from A to VT, zeroing out below it
+*
+ CALL DLACPY( 'U', N, N, A, LDA, VT, LDVT )
+ IF( N.GT.1 )
+ $ CALL DLASET( 'L', N-1, N-1, ZERO, ZERO,
+ $ VT( 2, 1 ), LDVT )
+ IE = ITAU
+ ITAUQ = IE + N
+ ITAUP = ITAUQ + N
+ IWORK = ITAUP + N
+*
+* Bidiagonalize R in VT
+* (Workspace: need 4*N, prefer 3*N+2*N*NB)
+*
+ CALL DGEBRD( N, N, VT, LDVT, S, WORK( IE ),
+ $ WORK( ITAUQ ), WORK( ITAUP ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+* Multiply Q in U by left bidiagonalizing vectors
+* in VT
+* (Workspace: need 3*N+M, prefer 3*N+M*NB)
+*
+ CALL DORMBR( 'Q', 'R', 'N', M, N, N, VT, LDVT,
+ $ WORK( ITAUQ ), U, LDU, WORK( IWORK ),
+ $ LWORK-IWORK+1, IERR )
+*
+* Generate right bidiagonalizing vectors in VT
+* (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB)
+*
+ CALL DORGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ IWORK = IE + N
+*
+* Perform bidiagonal QR iteration, computing left
+* singular vectors of A in U and computing right
+* singular vectors of A in VT
+* (Workspace: need BDSPAC)
+*
+ CALL DBDSQR( 'U', N, N, M, 0, S, WORK( IE ), VT,
+ $ LDVT, U, LDU, DUM, 1, WORK( IWORK ),
+ $ INFO )
+*
+ END IF
+*
+ END IF
+*
+ END IF
+*
+ ELSE
+*
+* M .LT. MNTHR
+*
+* Path 10 (M at least N, but not much larger)
+* Reduce to bidiagonal form without QR decomposition
+*
+ IE = 1
+ ITAUQ = IE + N
+ ITAUP = ITAUQ + N
+ IWORK = ITAUP + N
+*
+* Bidiagonalize A
+* (Workspace: need 3*N+M, prefer 3*N+(M+N)*NB)
+*
+ CALL DGEBRD( M, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ),
+ $ WORK( ITAUP ), WORK( IWORK ), LWORK-IWORK+1,
+ $ IERR )
+ IF( WNTUAS ) THEN
+*
+* If left singular vectors desired in U, copy result to U
+* and generate left bidiagonalizing vectors in U
+* (Workspace: need 3*N+NCU, prefer 3*N+NCU*NB)
+*
+ CALL DLACPY( 'L', M, N, A, LDA, U, LDU )
+ IF( WNTUS )
+ $ NCU = N
+ IF( WNTUA )
+ $ NCU = M
+ CALL DORGBR( 'Q', M, NCU, N, U, LDU, WORK( ITAUQ ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ END IF
+ IF( WNTVAS ) THEN
+*
+* If right singular vectors desired in VT, copy result to
+* VT and generate right bidiagonalizing vectors in VT
+* (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB)
+*
+ CALL DLACPY( 'U', N, N, A, LDA, VT, LDVT )
+ CALL DORGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ END IF
+ IF( WNTUO ) THEN
+*
+* If left singular vectors desired in A, generate left
+* bidiagonalizing vectors in A
+* (Workspace: need 4*N, prefer 3*N+N*NB)
+*
+ CALL DORGBR( 'Q', M, N, N, A, LDA, WORK( ITAUQ ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ END IF
+ IF( WNTVO ) THEN
+*
+* If right singular vectors desired in A, generate right
+* bidiagonalizing vectors in A
+* (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB)
+*
+ CALL DORGBR( 'P', N, N, N, A, LDA, WORK( ITAUP ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ END IF
+ IWORK = IE + N
+ IF( WNTUAS .OR. WNTUO )
+ $ NRU = M
+ IF( WNTUN )
+ $ NRU = 0
+ IF( WNTVAS .OR. WNTVO )
+ $ NCVT = N
+ IF( WNTVN )
+ $ NCVT = 0
+ IF( ( .NOT.WNTUO ) .AND. ( .NOT.WNTVO ) ) THEN
+*
+* Perform bidiagonal QR iteration, if desired, computing
+* left singular vectors in U and computing right singular
+* vectors in VT
+* (Workspace: need BDSPAC)
+*
+ CALL DBDSQR( 'U', N, NCVT, NRU, 0, S, WORK( IE ), VT,
+ $ LDVT, U, LDU, DUM, 1, WORK( IWORK ), INFO )
+ ELSE IF( ( .NOT.WNTUO ) .AND. WNTVO ) THEN
+*
+* Perform bidiagonal QR iteration, if desired, computing
+* left singular vectors in U and computing right singular
+* vectors in A
+* (Workspace: need BDSPAC)
+*
+ CALL DBDSQR( 'U', N, NCVT, NRU, 0, S, WORK( IE ), A, LDA,
+ $ U, LDU, DUM, 1, WORK( IWORK ), INFO )
+ ELSE
+*
+* Perform bidiagonal QR iteration, if desired, computing
+* left singular vectors in A and computing right singular
+* vectors in VT
+* (Workspace: need BDSPAC)
+*
+ CALL DBDSQR( 'U', N, NCVT, NRU, 0, S, WORK( IE ), VT,
+ $ LDVT, A, LDA, DUM, 1, WORK( IWORK ), INFO )
+ END IF
+*
+ END IF
+*
+ ELSE
+*
+* A has more columns than rows. If A has sufficiently more
+* columns than rows, first reduce using the LQ decomposition (if
+* sufficient workspace available)
+*
+ IF( N.GE.MNTHR ) THEN
+*
+ IF( WNTVN ) THEN
+*
+* Path 1t(N much larger than M, JOBVT='N')
+* No right singular vectors to be computed
+*
+ ITAU = 1
+ IWORK = ITAU + M
+*
+* Compute A=L*Q
+* (Workspace: need 2*M, prefer M+M*NB)
+*
+ CALL DGELQF( M, N, A, LDA, WORK( ITAU ), WORK( IWORK ),
+ $ LWORK-IWORK+1, IERR )
+*
+* Zero out above L
+*
+ CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, A( 1, 2 ), LDA )
+ IE = 1
+ ITAUQ = IE + M
+ ITAUP = ITAUQ + M
+ IWORK = ITAUP + M
+*
+* Bidiagonalize L in A
+* (Workspace: need 4*M, prefer 3*M+2*M*NB)
+*
+ CALL DGEBRD( M, M, A, LDA, S, WORK( IE ), WORK( ITAUQ ),
+ $ WORK( ITAUP ), WORK( IWORK ), LWORK-IWORK+1,
+ $ IERR )
+ IF( WNTUO .OR. WNTUAS ) THEN
+*
+* If left singular vectors desired, generate Q
+* (Workspace: need 4*M, prefer 3*M+M*NB)
+*
+ CALL DORGBR( 'Q', M, M, M, A, LDA, WORK( ITAUQ ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ END IF
+ IWORK = IE + M
+ NRU = 0
+ IF( WNTUO .OR. WNTUAS )
+ $ NRU = M
+*
+* Perform bidiagonal QR iteration, computing left singular
+* vectors of A in A if desired
+* (Workspace: need BDSPAC)
+*
+ CALL DBDSQR( 'U', M, 0, NRU, 0, S, WORK( IE ), DUM, 1, A,
+ $ LDA, DUM, 1, WORK( IWORK ), INFO )
+*
+* If left singular vectors desired in U, copy them there
+*
+ IF( WNTUAS )
+ $ CALL DLACPY( 'F', M, M, A, LDA, U, LDU )
+*
+ ELSE IF( WNTVO .AND. WNTUN ) THEN
+*
+* Path 2t(N much larger than M, JOBU='N', JOBVT='O')
+* M right singular vectors to be overwritten on A and
+* no left singular vectors to be computed
+*
+ IF( LWORK.GE.M*M+MAX( 4*M, BDSPAC ) ) THEN
+*
+* Sufficient workspace for a fast algorithm
+*
+ IR = 1
+ IF( LWORK.GE.MAX( WRKBL, LDA*N+M )+LDA*M ) THEN
+*
+* WORK(IU) is LDA by N and WORK(IR) is LDA by M
+*
+ LDWRKU = LDA
+ CHUNK = N
+ LDWRKR = LDA
+ ELSE IF( LWORK.GE.MAX( WRKBL, LDA*N+M )+M*M ) THEN
+*
+* WORK(IU) is LDA by N and WORK(IR) is M by M
+*
+ LDWRKU = LDA
+ CHUNK = N
+ LDWRKR = M
+ ELSE
+*
+* WORK(IU) is M by CHUNK and WORK(IR) is M by M
+*
+ LDWRKU = M
+ CHUNK = ( LWORK-M*M-M ) / M
+ LDWRKR = M
+ END IF
+ ITAU = IR + LDWRKR*M
+ IWORK = ITAU + M
+*
+* Compute A=L*Q
+* (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
+*
+ CALL DGELQF( M, N, A, LDA, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+* Copy L to WORK(IR) and zero out above it
+*
+ CALL DLACPY( 'L', M, M, A, LDA, WORK( IR ), LDWRKR )
+ CALL DLASET( 'U', M-1, M-1, ZERO, ZERO,
+ $ WORK( IR+LDWRKR ), LDWRKR )
+*
+* Generate Q in A
+* (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
+*
+ CALL DORGLQ( M, N, M, A, LDA, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ IE = ITAU
+ ITAUQ = IE + M
+ ITAUP = ITAUQ + M
+ IWORK = ITAUP + M
+*
+* Bidiagonalize L in WORK(IR)
+* (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB)
+*
+ CALL DGEBRD( M, M, WORK( IR ), LDWRKR, S, WORK( IE ),
+ $ WORK( ITAUQ ), WORK( ITAUP ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+* Generate right vectors bidiagonalizing L
+* (Workspace: need M*M+4*M-1, prefer M*M+3*M+(M-1)*NB)
+*
+ CALL DORGBR( 'P', M, M, M, WORK( IR ), LDWRKR,
+ $ WORK( ITAUP ), WORK( IWORK ),
+ $ LWORK-IWORK+1, IERR )
+ IWORK = IE + M
+*
+* Perform bidiagonal QR iteration, computing right
+* singular vectors of L in WORK(IR)
+* (Workspace: need M*M+BDSPAC)
+*
+ CALL DBDSQR( 'U', M, M, 0, 0, S, WORK( IE ),
+ $ WORK( IR ), LDWRKR, DUM, 1, DUM, 1,
+ $ WORK( IWORK ), INFO )
+ IU = IE + M
+*
+* Multiply right singular vectors of L in WORK(IR) by Q
+* in A, storing result in WORK(IU) and copying to A
+* (Workspace: need M*M+2*M, prefer M*M+M*N+M)
+*
+ DO 30 I = 1, N, CHUNK
+ BLK = MIN( N-I+1, CHUNK )
+ CALL DGEMM( 'N', 'N', M, BLK, M, ONE, WORK( IR ),
+ $ LDWRKR, A( 1, I ), LDA, ZERO,
+ $ WORK( IU ), LDWRKU )
+ CALL DLACPY( 'F', M, BLK, WORK( IU ), LDWRKU,
+ $ A( 1, I ), LDA )
+ 30 CONTINUE
+*
+ ELSE
+*
+* Insufficient workspace for a fast algorithm
+*
+ IE = 1
+ ITAUQ = IE + M
+ ITAUP = ITAUQ + M
+ IWORK = ITAUP + M
+*
+* Bidiagonalize A
+* (Workspace: need 3*M+N, prefer 3*M+(M+N)*NB)
+*
+ CALL DGEBRD( M, N, A, LDA, S, WORK( IE ),
+ $ WORK( ITAUQ ), WORK( ITAUP ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+* Generate right vectors bidiagonalizing A
+* (Workspace: need 4*M, prefer 3*M+M*NB)
+*
+ CALL DORGBR( 'P', M, N, M, A, LDA, WORK( ITAUP ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ IWORK = IE + M
+*
+* Perform bidiagonal QR iteration, computing right
+* singular vectors of A in A
+* (Workspace: need BDSPAC)
+*
+ CALL DBDSQR( 'L', M, N, 0, 0, S, WORK( IE ), A, LDA,
+ $ DUM, 1, DUM, 1, WORK( IWORK ), INFO )
+*
+ END IF
+*
+ ELSE IF( WNTVO .AND. WNTUAS ) THEN
+*
+* Path 3t(N much larger than M, JOBU='S' or 'A', JOBVT='O')
+* M right singular vectors to be overwritten on A and
+* M left singular vectors to be computed in U
+*
+ IF( LWORK.GE.M*M+MAX( 4*M, BDSPAC ) ) THEN
+*
+* Sufficient workspace for a fast algorithm
+*
+ IR = 1
+ IF( LWORK.GE.MAX( WRKBL, LDA*N+M )+LDA*M ) THEN
+*
+* WORK(IU) is LDA by N and WORK(IR) is LDA by M
+*
+ LDWRKU = LDA
+ CHUNK = N
+ LDWRKR = LDA
+ ELSE IF( LWORK.GE.MAX( WRKBL, LDA*N+M )+M*M ) THEN
+*
+* WORK(IU) is LDA by N and WORK(IR) is M by M
+*
+ LDWRKU = LDA
+ CHUNK = N
+ LDWRKR = M
+ ELSE
+*
+* WORK(IU) is M by CHUNK and WORK(IR) is M by M
+*
+ LDWRKU = M
+ CHUNK = ( LWORK-M*M-M ) / M
+ LDWRKR = M
+ END IF
+ ITAU = IR + LDWRKR*M
+ IWORK = ITAU + M
+*
+* Compute A=L*Q
+* (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
+*
+ CALL DGELQF( M, N, A, LDA, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+* Copy L to U, zeroing about above it
+*
+ CALL DLACPY( 'L', M, M, A, LDA, U, LDU )
+ CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, U( 1, 2 ),
+ $ LDU )
+*
+* Generate Q in A
+* (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
+*
+ CALL DORGLQ( M, N, M, A, LDA, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ IE = ITAU
+ ITAUQ = IE + M
+ ITAUP = ITAUQ + M
+ IWORK = ITAUP + M
+*
+* Bidiagonalize L in U, copying result to WORK(IR)
+* (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB)
+*
+ CALL DGEBRD( M, M, U, LDU, S, WORK( IE ),
+ $ WORK( ITAUQ ), WORK( ITAUP ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ CALL DLACPY( 'U', M, M, U, LDU, WORK( IR ), LDWRKR )
+*
+* Generate right vectors bidiagonalizing L in WORK(IR)
+* (Workspace: need M*M+4*M-1, prefer M*M+3*M+(M-1)*NB)
+*
+ CALL DORGBR( 'P', M, M, M, WORK( IR ), LDWRKR,
+ $ WORK( ITAUP ), WORK( IWORK ),
+ $ LWORK-IWORK+1, IERR )
+*
+* Generate left vectors bidiagonalizing L in U
+* (Workspace: need M*M+4*M, prefer M*M+3*M+M*NB)
+*
+ CALL DORGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ IWORK = IE + M
+*
+* Perform bidiagonal QR iteration, computing left
+* singular vectors of L in U, and computing right
+* singular vectors of L in WORK(IR)
+* (Workspace: need M*M+BDSPAC)
+*
+ CALL DBDSQR( 'U', M, M, M, 0, S, WORK( IE ),
+ $ WORK( IR ), LDWRKR, U, LDU, DUM, 1,
+ $ WORK( IWORK ), INFO )
+ IU = IE + M
+*
+* Multiply right singular vectors of L in WORK(IR) by Q
+* in A, storing result in WORK(IU) and copying to A
+* (Workspace: need M*M+2*M, prefer M*M+M*N+M))
+*
+ DO 40 I = 1, N, CHUNK
+ BLK = MIN( N-I+1, CHUNK )
+ CALL DGEMM( 'N', 'N', M, BLK, M, ONE, WORK( IR ),
+ $ LDWRKR, A( 1, I ), LDA, ZERO,
+ $ WORK( IU ), LDWRKU )
+ CALL DLACPY( 'F', M, BLK, WORK( IU ), LDWRKU,
+ $ A( 1, I ), LDA )
+ 40 CONTINUE
+*
+ ELSE
+*
+* Insufficient workspace for a fast algorithm
+*
+ ITAU = 1
+ IWORK = ITAU + M
+*
+* Compute A=L*Q
+* (Workspace: need 2*M, prefer M+M*NB)
+*
+ CALL DGELQF( M, N, A, LDA, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+* Copy L to U, zeroing out above it
+*
+ CALL DLACPY( 'L', M, M, A, LDA, U, LDU )
+ CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, U( 1, 2 ),
+ $ LDU )
+*
+* Generate Q in A
+* (Workspace: need 2*M, prefer M+M*NB)
+*
+ CALL DORGLQ( M, N, M, A, LDA, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ IE = ITAU
+ ITAUQ = IE + M
+ ITAUP = ITAUQ + M
+ IWORK = ITAUP + M
+*
+* Bidiagonalize L in U
+* (Workspace: need 4*M, prefer 3*M+2*M*NB)
+*
+ CALL DGEBRD( M, M, U, LDU, S, WORK( IE ),
+ $ WORK( ITAUQ ), WORK( ITAUP ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+* Multiply right vectors bidiagonalizing L by Q in A
+* (Workspace: need 3*M+N, prefer 3*M+N*NB)
+*
+ CALL DORMBR( 'P', 'L', 'T', M, N, M, U, LDU,
+ $ WORK( ITAUP ), A, LDA, WORK( IWORK ),
+ $ LWORK-IWORK+1, IERR )
+*
+* Generate left vectors bidiagonalizing L in U
+* (Workspace: need 4*M, prefer 3*M+M*NB)
+*
+ CALL DORGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ IWORK = IE + M
+*
+* Perform bidiagonal QR iteration, computing left
+* singular vectors of A in U and computing right
+* singular vectors of A in A
+* (Workspace: need BDSPAC)
+*
+ CALL DBDSQR( 'U', M, N, M, 0, S, WORK( IE ), A, LDA,
+ $ U, LDU, DUM, 1, WORK( IWORK ), INFO )
+*
+ END IF
+*
+ ELSE IF( WNTVS ) THEN
+*
+ IF( WNTUN ) THEN
+*
+* Path 4t(N much larger than M, JOBU='N', JOBVT='S')
+* M right singular vectors to be computed in VT and
+* no left singular vectors to be computed
+*
+ IF( LWORK.GE.M*M+MAX( 4*M, BDSPAC ) ) THEN
+*
+* Sufficient workspace for a fast algorithm
+*
+ IR = 1
+ IF( LWORK.GE.WRKBL+LDA*M ) THEN
+*
+* WORK(IR) is LDA by M
+*
+ LDWRKR = LDA
+ ELSE
+*
+* WORK(IR) is M by M
+*
+ LDWRKR = M
+ END IF
+ ITAU = IR + LDWRKR*M
+ IWORK = ITAU + M
+*
+* Compute A=L*Q
+* (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
+*
+ CALL DGELQF( M, N, A, LDA, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+* Copy L to WORK(IR), zeroing out above it
+*
+ CALL DLACPY( 'L', M, M, A, LDA, WORK( IR ),
+ $ LDWRKR )
+ CALL DLASET( 'U', M-1, M-1, ZERO, ZERO,
+ $ WORK( IR+LDWRKR ), LDWRKR )
+*
+* Generate Q in A
+* (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
+*
+ CALL DORGLQ( M, N, M, A, LDA, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ IE = ITAU
+ ITAUQ = IE + M
+ ITAUP = ITAUQ + M
+ IWORK = ITAUP + M
+*
+* Bidiagonalize L in WORK(IR)
+* (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB)
+*
+ CALL DGEBRD( M, M, WORK( IR ), LDWRKR, S,
+ $ WORK( IE ), WORK( ITAUQ ),
+ $ WORK( ITAUP ), WORK( IWORK ),
+ $ LWORK-IWORK+1, IERR )
+*
+* Generate right vectors bidiagonalizing L in
+* WORK(IR)
+* (Workspace: need M*M+4*M, prefer M*M+3*M+(M-1)*NB)
+*
+ CALL DORGBR( 'P', M, M, M, WORK( IR ), LDWRKR,
+ $ WORK( ITAUP ), WORK( IWORK ),
+ $ LWORK-IWORK+1, IERR )
+ IWORK = IE + M
+*
+* Perform bidiagonal QR iteration, computing right
+* singular vectors of L in WORK(IR)
+* (Workspace: need M*M+BDSPAC)
+*
+ CALL DBDSQR( 'U', M, M, 0, 0, S, WORK( IE ),
+ $ WORK( IR ), LDWRKR, DUM, 1, DUM, 1,
+ $ WORK( IWORK ), INFO )
+*
+* Multiply right singular vectors of L in WORK(IR) by
+* Q in A, storing result in VT
+* (Workspace: need M*M)
+*
+ CALL DGEMM( 'N', 'N', M, N, M, ONE, WORK( IR ),
+ $ LDWRKR, A, LDA, ZERO, VT, LDVT )
+*
+ ELSE
+*
+* Insufficient workspace for a fast algorithm
+*
+ ITAU = 1
+ IWORK = ITAU + M
+*
+* Compute A=L*Q
+* (Workspace: need 2*M, prefer M+M*NB)
+*
+ CALL DGELQF( M, N, A, LDA, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+* Copy result to VT
+*
+ CALL DLACPY( 'U', M, N, A, LDA, VT, LDVT )
+*
+* Generate Q in VT
+* (Workspace: need 2*M, prefer M+M*NB)
+*
+ CALL DORGLQ( M, N, M, VT, LDVT, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ IE = ITAU
+ ITAUQ = IE + M
+ ITAUP = ITAUQ + M
+ IWORK = ITAUP + M
+*
+* Zero out above L in A
+*
+ CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, A( 1, 2 ),
+ $ LDA )
+*
+* Bidiagonalize L in A
+* (Workspace: need 4*M, prefer 3*M+2*M*NB)
+*
+ CALL DGEBRD( M, M, A, LDA, S, WORK( IE ),
+ $ WORK( ITAUQ ), WORK( ITAUP ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+* Multiply right vectors bidiagonalizing L by Q in VT
+* (Workspace: need 3*M+N, prefer 3*M+N*NB)
+*
+ CALL DORMBR( 'P', 'L', 'T', M, N, M, A, LDA,
+ $ WORK( ITAUP ), VT, LDVT,
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ IWORK = IE + M
+*
+* Perform bidiagonal QR iteration, computing right
+* singular vectors of A in VT
+* (Workspace: need BDSPAC)
+*
+ CALL DBDSQR( 'U', M, N, 0, 0, S, WORK( IE ), VT,
+ $ LDVT, DUM, 1, DUM, 1, WORK( IWORK ),
+ $ INFO )
+*
+ END IF
+*
+ ELSE IF( WNTUO ) THEN
+*
+* Path 5t(N much larger than M, JOBU='O', JOBVT='S')
+* M right singular vectors to be computed in VT and
+* M left singular vectors to be overwritten on A
+*
+ IF( LWORK.GE.2*M*M+MAX( 4*M, BDSPAC ) ) THEN
+*
+* Sufficient workspace for a fast algorithm
+*
+ IU = 1
+ IF( LWORK.GE.WRKBL+2*LDA*M ) THEN
+*
+* WORK(IU) is LDA by M and WORK(IR) is LDA by M
+*
+ LDWRKU = LDA
+ IR = IU + LDWRKU*M
+ LDWRKR = LDA
+ ELSE IF( LWORK.GE.WRKBL+( LDA+M )*M ) THEN
+*
+* WORK(IU) is LDA by M and WORK(IR) is M by M
+*
+ LDWRKU = LDA
+ IR = IU + LDWRKU*M
+ LDWRKR = M
+ ELSE
+*
+* WORK(IU) is M by M and WORK(IR) is M by M
+*
+ LDWRKU = M
+ IR = IU + LDWRKU*M
+ LDWRKR = M
+ END IF
+ ITAU = IR + LDWRKR*M
+ IWORK = ITAU + M
+*
+* Compute A=L*Q
+* (Workspace: need 2*M*M+2*M, prefer 2*M*M+M+M*NB)
+*
+ CALL DGELQF( M, N, A, LDA, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+* Copy L to WORK(IU), zeroing out below it
+*
+ CALL DLACPY( 'L', M, M, A, LDA, WORK( IU ),
+ $ LDWRKU )
+ CALL DLASET( 'U', M-1, M-1, ZERO, ZERO,
+ $ WORK( IU+LDWRKU ), LDWRKU )
+*
+* Generate Q in A
+* (Workspace: need 2*M*M+2*M, prefer 2*M*M+M+M*NB)
+*
+ CALL DORGLQ( M, N, M, A, LDA, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ IE = ITAU
+ ITAUQ = IE + M
+ ITAUP = ITAUQ + M
+ IWORK = ITAUP + M
+*
+* Bidiagonalize L in WORK(IU), copying result to
+* WORK(IR)
+* (Workspace: need 2*M*M+4*M,
+* prefer 2*M*M+3*M+2*M*NB)
+*
+ CALL DGEBRD( M, M, WORK( IU ), LDWRKU, S,
+ $ WORK( IE ), WORK( ITAUQ ),
+ $ WORK( ITAUP ), WORK( IWORK ),
+ $ LWORK-IWORK+1, IERR )
+ CALL DLACPY( 'L', M, M, WORK( IU ), LDWRKU,
+ $ WORK( IR ), LDWRKR )
+*
+* Generate right bidiagonalizing vectors in WORK(IU)
+* (Workspace: need 2*M*M+4*M-1,
+* prefer 2*M*M+3*M+(M-1)*NB)
+*
+ CALL DORGBR( 'P', M, M, M, WORK( IU ), LDWRKU,
+ $ WORK( ITAUP ), WORK( IWORK ),
+ $ LWORK-IWORK+1, IERR )
+*
+* Generate left bidiagonalizing vectors in WORK(IR)
+* (Workspace: need 2*M*M+4*M, prefer 2*M*M+3*M+M*NB)
+*
+ CALL DORGBR( 'Q', M, M, M, WORK( IR ), LDWRKR,
+ $ WORK( ITAUQ ), WORK( IWORK ),
+ $ LWORK-IWORK+1, IERR )
+ IWORK = IE + M
+*
+* Perform bidiagonal QR iteration, computing left
+* singular vectors of L in WORK(IR) and computing
+* right singular vectors of L in WORK(IU)
+* (Workspace: need 2*M*M+BDSPAC)
+*
+ CALL DBDSQR( 'U', M, M, M, 0, S, WORK( IE ),
+ $ WORK( IU ), LDWRKU, WORK( IR ),
+ $ LDWRKR, DUM, 1, WORK( IWORK ), INFO )
+*
+* Multiply right singular vectors of L in WORK(IU) by
+* Q in A, storing result in VT
+* (Workspace: need M*M)
+*
+ CALL DGEMM( 'N', 'N', M, N, M, ONE, WORK( IU ),
+ $ LDWRKU, A, LDA, ZERO, VT, LDVT )
+*
+* Copy left singular vectors of L to A
+* (Workspace: need M*M)
+*
+ CALL DLACPY( 'F', M, M, WORK( IR ), LDWRKR, A,
+ $ LDA )
+*
+ ELSE
+*
+* Insufficient workspace for a fast algorithm
+*
+ ITAU = 1
+ IWORK = ITAU + M
+*
+* Compute A=L*Q, copying result to VT
+* (Workspace: need 2*M, prefer M+M*NB)
+*
+ CALL DGELQF( M, N, A, LDA, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ CALL DLACPY( 'U', M, N, A, LDA, VT, LDVT )
+*
+* Generate Q in VT
+* (Workspace: need 2*M, prefer M+M*NB)
+*
+ CALL DORGLQ( M, N, M, VT, LDVT, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ IE = ITAU
+ ITAUQ = IE + M
+ ITAUP = ITAUQ + M
+ IWORK = ITAUP + M
+*
+* Zero out above L in A
+*
+ CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, A( 1, 2 ),
+ $ LDA )
+*
+* Bidiagonalize L in A
+* (Workspace: need 4*M, prefer 3*M+2*M*NB)
+*
+ CALL DGEBRD( M, M, A, LDA, S, WORK( IE ),
+ $ WORK( ITAUQ ), WORK( ITAUP ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+* Multiply right vectors bidiagonalizing L by Q in VT
+* (Workspace: need 3*M+N, prefer 3*M+N*NB)
+*
+ CALL DORMBR( 'P', 'L', 'T', M, N, M, A, LDA,
+ $ WORK( ITAUP ), VT, LDVT,
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+* Generate left bidiagonalizing vectors of L in A
+* (Workspace: need 4*M, prefer 3*M+M*NB)
+*
+ CALL DORGBR( 'Q', M, M, M, A, LDA, WORK( ITAUQ ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ IWORK = IE + M
+*
+* Perform bidiagonal QR iteration, compute left
+* singular vectors of A in A and compute right
+* singular vectors of A in VT
+* (Workspace: need BDSPAC)
+*
+ CALL DBDSQR( 'U', M, N, M, 0, S, WORK( IE ), VT,
+ $ LDVT, A, LDA, DUM, 1, WORK( IWORK ),
+ $ INFO )
+*
+ END IF
+*
+ ELSE IF( WNTUAS ) THEN
+*
+* Path 6t(N much larger than M, JOBU='S' or 'A',
+* JOBVT='S')
+* M right singular vectors to be computed in VT and
+* M left singular vectors to be computed in U
+*
+ IF( LWORK.GE.M*M+MAX( 4*M, BDSPAC ) ) THEN
+*
+* Sufficient workspace for a fast algorithm
+*
+ IU = 1
+ IF( LWORK.GE.WRKBL+LDA*M ) THEN
+*
+* WORK(IU) is LDA by N
+*
+ LDWRKU = LDA
+ ELSE
+*
+* WORK(IU) is LDA by M
+*
+ LDWRKU = M
+ END IF
+ ITAU = IU + LDWRKU*M
+ IWORK = ITAU + M
+*
+* Compute A=L*Q
+* (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
+*
+ CALL DGELQF( M, N, A, LDA, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+* Copy L to WORK(IU), zeroing out above it
+*
+ CALL DLACPY( 'L', M, M, A, LDA, WORK( IU ),
+ $ LDWRKU )
+ CALL DLASET( 'U', M-1, M-1, ZERO, ZERO,
+ $ WORK( IU+LDWRKU ), LDWRKU )
+*
+* Generate Q in A
+* (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
+*
+ CALL DORGLQ( M, N, M, A, LDA, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ IE = ITAU
+ ITAUQ = IE + M
+ ITAUP = ITAUQ + M
+ IWORK = ITAUP + M
+*
+* Bidiagonalize L in WORK(IU), copying result to U
+* (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB)
+*
+ CALL DGEBRD( M, M, WORK( IU ), LDWRKU, S,
+ $ WORK( IE ), WORK( ITAUQ ),
+ $ WORK( ITAUP ), WORK( IWORK ),
+ $ LWORK-IWORK+1, IERR )
+ CALL DLACPY( 'L', M, M, WORK( IU ), LDWRKU, U,
+ $ LDU )
+*
+* Generate right bidiagonalizing vectors in WORK(IU)
+* (Workspace: need M*M+4*M-1,
+* prefer M*M+3*M+(M-1)*NB)
+*
+ CALL DORGBR( 'P', M, M, M, WORK( IU ), LDWRKU,
+ $ WORK( ITAUP ), WORK( IWORK ),
+ $ LWORK-IWORK+1, IERR )
+*
+* Generate left bidiagonalizing vectors in U
+* (Workspace: need M*M+4*M, prefer M*M+3*M+M*NB)
+*
+ CALL DORGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ IWORK = IE + M
+*
+* Perform bidiagonal QR iteration, computing left
+* singular vectors of L in U and computing right
+* singular vectors of L in WORK(IU)
+* (Workspace: need M*M+BDSPAC)
+*
+ CALL DBDSQR( 'U', M, M, M, 0, S, WORK( IE ),
+ $ WORK( IU ), LDWRKU, U, LDU, DUM, 1,
+ $ WORK( IWORK ), INFO )
+*
+* Multiply right singular vectors of L in WORK(IU) by
+* Q in A, storing result in VT
+* (Workspace: need M*M)
+*
+ CALL DGEMM( 'N', 'N', M, N, M, ONE, WORK( IU ),
+ $ LDWRKU, A, LDA, ZERO, VT, LDVT )
+*
+ ELSE
+*
+* Insufficient workspace for a fast algorithm
+*
+ ITAU = 1
+ IWORK = ITAU + M
+*
+* Compute A=L*Q, copying result to VT
+* (Workspace: need 2*M, prefer M+M*NB)
+*
+ CALL DGELQF( M, N, A, LDA, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ CALL DLACPY( 'U', M, N, A, LDA, VT, LDVT )
+*
+* Generate Q in VT
+* (Workspace: need 2*M, prefer M+M*NB)
+*
+ CALL DORGLQ( M, N, M, VT, LDVT, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+* Copy L to U, zeroing out above it
+*
+ CALL DLACPY( 'L', M, M, A, LDA, U, LDU )
+ CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, U( 1, 2 ),
+ $ LDU )
+ IE = ITAU
+ ITAUQ = IE + M
+ ITAUP = ITAUQ + M
+ IWORK = ITAUP + M
+*
+* Bidiagonalize L in U
+* (Workspace: need 4*M, prefer 3*M+2*M*NB)
+*
+ CALL DGEBRD( M, M, U, LDU, S, WORK( IE ),
+ $ WORK( ITAUQ ), WORK( ITAUP ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+* Multiply right bidiagonalizing vectors in U by Q
+* in VT
+* (Workspace: need 3*M+N, prefer 3*M+N*NB)
+*
+ CALL DORMBR( 'P', 'L', 'T', M, N, M, U, LDU,
+ $ WORK( ITAUP ), VT, LDVT,
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+* Generate left bidiagonalizing vectors in U
+* (Workspace: need 4*M, prefer 3*M+M*NB)
+*
+ CALL DORGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ IWORK = IE + M
+*
+* Perform bidiagonal QR iteration, computing left
+* singular vectors of A in U and computing right
+* singular vectors of A in VT
+* (Workspace: need BDSPAC)
+*
+ CALL DBDSQR( 'U', M, N, M, 0, S, WORK( IE ), VT,
+ $ LDVT, U, LDU, DUM, 1, WORK( IWORK ),
+ $ INFO )
+*
+ END IF
+*
+ END IF
+*
+ ELSE IF( WNTVA ) THEN
+*
+ IF( WNTUN ) THEN
+*
+* Path 7t(N much larger than M, JOBU='N', JOBVT='A')
+* N right singular vectors to be computed in VT and
+* no left singular vectors to be computed
+*
+ IF( LWORK.GE.M*M+MAX( N+M, 4*M, BDSPAC ) ) THEN
+*
+* Sufficient workspace for a fast algorithm
+*
+ IR = 1
+ IF( LWORK.GE.WRKBL+LDA*M ) THEN
+*
+* WORK(IR) is LDA by M
+*
+ LDWRKR = LDA
+ ELSE
+*
+* WORK(IR) is M by M
+*
+ LDWRKR = M
+ END IF
+ ITAU = IR + LDWRKR*M
+ IWORK = ITAU + M
+*
+* Compute A=L*Q, copying result to VT
+* (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
+*
+ CALL DGELQF( M, N, A, LDA, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ CALL DLACPY( 'U', M, N, A, LDA, VT, LDVT )
+*
+* Copy L to WORK(IR), zeroing out above it
+*
+ CALL DLACPY( 'L', M, M, A, LDA, WORK( IR ),
+ $ LDWRKR )
+ CALL DLASET( 'U', M-1, M-1, ZERO, ZERO,
+ $ WORK( IR+LDWRKR ), LDWRKR )
+*
+* Generate Q in VT
+* (Workspace: need M*M+M+N, prefer M*M+M+N*NB)
+*
+ CALL DORGLQ( N, N, M, VT, LDVT, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ IE = ITAU
+ ITAUQ = IE + M
+ ITAUP = ITAUQ + M
+ IWORK = ITAUP + M
+*
+* Bidiagonalize L in WORK(IR)
+* (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB)
+*
+ CALL DGEBRD( M, M, WORK( IR ), LDWRKR, S,
+ $ WORK( IE ), WORK( ITAUQ ),
+ $ WORK( ITAUP ), WORK( IWORK ),
+ $ LWORK-IWORK+1, IERR )
+*
+* Generate right bidiagonalizing vectors in WORK(IR)
+* (Workspace: need M*M+4*M-1,
+* prefer M*M+3*M+(M-1)*NB)
+*
+ CALL DORGBR( 'P', M, M, M, WORK( IR ), LDWRKR,
+ $ WORK( ITAUP ), WORK( IWORK ),
+ $ LWORK-IWORK+1, IERR )
+ IWORK = IE + M
+*
+* Perform bidiagonal QR iteration, computing right
+* singular vectors of L in WORK(IR)
+* (Workspace: need M*M+BDSPAC)
+*
+ CALL DBDSQR( 'U', M, M, 0, 0, S, WORK( IE ),
+ $ WORK( IR ), LDWRKR, DUM, 1, DUM, 1,
+ $ WORK( IWORK ), INFO )
+*
+* Multiply right singular vectors of L in WORK(IR) by
+* Q in VT, storing result in A
+* (Workspace: need M*M)
+*
+ CALL DGEMM( 'N', 'N', M, N, M, ONE, WORK( IR ),
+ $ LDWRKR, VT, LDVT, ZERO, A, LDA )
+*
+* Copy right singular vectors of A from A to VT
+*
+ CALL DLACPY( 'F', M, N, A, LDA, VT, LDVT )
+*
+ ELSE
+*
+* Insufficient workspace for a fast algorithm
+*
+ ITAU = 1
+ IWORK = ITAU + M
+*
+* Compute A=L*Q, copying result to VT
+* (Workspace: need 2*M, prefer M+M*NB)
+*
+ CALL DGELQF( M, N, A, LDA, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ CALL DLACPY( 'U', M, N, A, LDA, VT, LDVT )
+*
+* Generate Q in VT
+* (Workspace: need M+N, prefer M+N*NB)
+*
+ CALL DORGLQ( N, N, M, VT, LDVT, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ IE = ITAU
+ ITAUQ = IE + M
+ ITAUP = ITAUQ + M
+ IWORK = ITAUP + M
+*
+* Zero out above L in A
+*
+ CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, A( 1, 2 ),
+ $ LDA )
+*
+* Bidiagonalize L in A
+* (Workspace: need 4*M, prefer 3*M+2*M*NB)
+*
+ CALL DGEBRD( M, M, A, LDA, S, WORK( IE ),
+ $ WORK( ITAUQ ), WORK( ITAUP ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+* Multiply right bidiagonalizing vectors in A by Q
+* in VT
+* (Workspace: need 3*M+N, prefer 3*M+N*NB)
+*
+ CALL DORMBR( 'P', 'L', 'T', M, N, M, A, LDA,
+ $ WORK( ITAUP ), VT, LDVT,
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ IWORK = IE + M
+*
+* Perform bidiagonal QR iteration, computing right
+* singular vectors of A in VT
+* (Workspace: need BDSPAC)
+*
+ CALL DBDSQR( 'U', M, N, 0, 0, S, WORK( IE ), VT,
+ $ LDVT, DUM, 1, DUM, 1, WORK( IWORK ),
+ $ INFO )
+*
+ END IF
+*
+ ELSE IF( WNTUO ) THEN
+*
+* Path 8t(N much larger than M, JOBU='O', JOBVT='A')
+* N right singular vectors to be computed in VT and
+* M left singular vectors to be overwritten on A
+*
+ IF( LWORK.GE.2*M*M+MAX( N+M, 4*M, BDSPAC ) ) THEN
+*
+* Sufficient workspace for a fast algorithm
+*
+ IU = 1
+ IF( LWORK.GE.WRKBL+2*LDA*M ) THEN
+*
+* WORK(IU) is LDA by M and WORK(IR) is LDA by M
+*
+ LDWRKU = LDA
+ IR = IU + LDWRKU*M
+ LDWRKR = LDA
+ ELSE IF( LWORK.GE.WRKBL+( LDA+M )*M ) THEN
+*
+* WORK(IU) is LDA by M and WORK(IR) is M by M
+*
+ LDWRKU = LDA
+ IR = IU + LDWRKU*M
+ LDWRKR = M
+ ELSE
+*
+* WORK(IU) is M by M and WORK(IR) is M by M
+*
+ LDWRKU = M
+ IR = IU + LDWRKU*M
+ LDWRKR = M
+ END IF
+ ITAU = IR + LDWRKR*M
+ IWORK = ITAU + M
+*
+* Compute A=L*Q, copying result to VT
+* (Workspace: need 2*M*M+2*M, prefer 2*M*M+M+M*NB)
+*
+ CALL DGELQF( M, N, A, LDA, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ CALL DLACPY( 'U', M, N, A, LDA, VT, LDVT )
+*
+* Generate Q in VT
+* (Workspace: need 2*M*M+M+N, prefer 2*M*M+M+N*NB)
+*
+ CALL DORGLQ( N, N, M, VT, LDVT, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+* Copy L to WORK(IU), zeroing out above it
+*
+ CALL DLACPY( 'L', M, M, A, LDA, WORK( IU ),
+ $ LDWRKU )
+ CALL DLASET( 'U', M-1, M-1, ZERO, ZERO,
+ $ WORK( IU+LDWRKU ), LDWRKU )
+ IE = ITAU
+ ITAUQ = IE + M
+ ITAUP = ITAUQ + M
+ IWORK = ITAUP + M
+*
+* Bidiagonalize L in WORK(IU), copying result to
+* WORK(IR)
+* (Workspace: need 2*M*M+4*M,
+* prefer 2*M*M+3*M+2*M*NB)
+*
+ CALL DGEBRD( M, M, WORK( IU ), LDWRKU, S,
+ $ WORK( IE ), WORK( ITAUQ ),
+ $ WORK( ITAUP ), WORK( IWORK ),
+ $ LWORK-IWORK+1, IERR )
+ CALL DLACPY( 'L', M, M, WORK( IU ), LDWRKU,
+ $ WORK( IR ), LDWRKR )
+*
+* Generate right bidiagonalizing vectors in WORK(IU)
+* (Workspace: need 2*M*M+4*M-1,
+* prefer 2*M*M+3*M+(M-1)*NB)
+*
+ CALL DORGBR( 'P', M, M, M, WORK( IU ), LDWRKU,
+ $ WORK( ITAUP ), WORK( IWORK ),
+ $ LWORK-IWORK+1, IERR )
+*
+* Generate left bidiagonalizing vectors in WORK(IR)
+* (Workspace: need 2*M*M+4*M, prefer 2*M*M+3*M+M*NB)
+*
+ CALL DORGBR( 'Q', M, M, M, WORK( IR ), LDWRKR,
+ $ WORK( ITAUQ ), WORK( IWORK ),
+ $ LWORK-IWORK+1, IERR )
+ IWORK = IE + M
+*
+* Perform bidiagonal QR iteration, computing left
+* singular vectors of L in WORK(IR) and computing
+* right singular vectors of L in WORK(IU)
+* (Workspace: need 2*M*M+BDSPAC)
+*
+ CALL DBDSQR( 'U', M, M, M, 0, S, WORK( IE ),
+ $ WORK( IU ), LDWRKU, WORK( IR ),
+ $ LDWRKR, DUM, 1, WORK( IWORK ), INFO )
+*
+* Multiply right singular vectors of L in WORK(IU) by
+* Q in VT, storing result in A
+* (Workspace: need M*M)
+*
+ CALL DGEMM( 'N', 'N', M, N, M, ONE, WORK( IU ),
+ $ LDWRKU, VT, LDVT, ZERO, A, LDA )
+*
+* Copy right singular vectors of A from A to VT
+*
+ CALL DLACPY( 'F', M, N, A, LDA, VT, LDVT )
+*
+* Copy left singular vectors of A from WORK(IR) to A
+*
+ CALL DLACPY( 'F', M, M, WORK( IR ), LDWRKR, A,
+ $ LDA )
+*
+ ELSE
+*
+* Insufficient workspace for a fast algorithm
+*
+ ITAU = 1
+ IWORK = ITAU + M
+*
+* Compute A=L*Q, copying result to VT
+* (Workspace: need 2*M, prefer M+M*NB)
+*
+ CALL DGELQF( M, N, A, LDA, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ CALL DLACPY( 'U', M, N, A, LDA, VT, LDVT )
+*
+* Generate Q in VT
+* (Workspace: need M+N, prefer M+N*NB)
+*
+ CALL DORGLQ( N, N, M, VT, LDVT, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ IE = ITAU
+ ITAUQ = IE + M
+ ITAUP = ITAUQ + M
+ IWORK = ITAUP + M
+*
+* Zero out above L in A
+*
+ CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, A( 1, 2 ),
+ $ LDA )
+*
+* Bidiagonalize L in A
+* (Workspace: need 4*M, prefer 3*M+2*M*NB)
+*
+ CALL DGEBRD( M, M, A, LDA, S, WORK( IE ),
+ $ WORK( ITAUQ ), WORK( ITAUP ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+* Multiply right bidiagonalizing vectors in A by Q
+* in VT
+* (Workspace: need 3*M+N, prefer 3*M+N*NB)
+*
+ CALL DORMBR( 'P', 'L', 'T', M, N, M, A, LDA,
+ $ WORK( ITAUP ), VT, LDVT,
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+* Generate left bidiagonalizing vectors in A
+* (Workspace: need 4*M, prefer 3*M+M*NB)
+*
+ CALL DORGBR( 'Q', M, M, M, A, LDA, WORK( ITAUQ ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ IWORK = IE + M
+*
+* Perform bidiagonal QR iteration, computing left
+* singular vectors of A in A and computing right
+* singular vectors of A in VT
+* (Workspace: need BDSPAC)
+*
+ CALL DBDSQR( 'U', M, N, M, 0, S, WORK( IE ), VT,
+ $ LDVT, A, LDA, DUM, 1, WORK( IWORK ),
+ $ INFO )
+*
+ END IF
+*
+ ELSE IF( WNTUAS ) THEN
+*
+* Path 9t(N much larger than M, JOBU='S' or 'A',
+* JOBVT='A')
+* N right singular vectors to be computed in VT and
+* M left singular vectors to be computed in U
+*
+ IF( LWORK.GE.M*M+MAX( N+M, 4*M, BDSPAC ) ) THEN
+*
+* Sufficient workspace for a fast algorithm
+*
+ IU = 1
+ IF( LWORK.GE.WRKBL+LDA*M ) THEN
+*
+* WORK(IU) is LDA by M
+*
+ LDWRKU = LDA
+ ELSE
+*
+* WORK(IU) is M by M
+*
+ LDWRKU = M
+ END IF
+ ITAU = IU + LDWRKU*M
+ IWORK = ITAU + M
+*
+* Compute A=L*Q, copying result to VT
+* (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
+*
+ CALL DGELQF( M, N, A, LDA, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ CALL DLACPY( 'U', M, N, A, LDA, VT, LDVT )
+*
+* Generate Q in VT
+* (Workspace: need M*M+M+N, prefer M*M+M+N*NB)
+*
+ CALL DORGLQ( N, N, M, VT, LDVT, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+* Copy L to WORK(IU), zeroing out above it
+*
+ CALL DLACPY( 'L', M, M, A, LDA, WORK( IU ),
+ $ LDWRKU )
+ CALL DLASET( 'U', M-1, M-1, ZERO, ZERO,
+ $ WORK( IU+LDWRKU ), LDWRKU )
+ IE = ITAU
+ ITAUQ = IE + M
+ ITAUP = ITAUQ + M
+ IWORK = ITAUP + M
+*
+* Bidiagonalize L in WORK(IU), copying result to U
+* (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB)
+*
+ CALL DGEBRD( M, M, WORK( IU ), LDWRKU, S,
+ $ WORK( IE ), WORK( ITAUQ ),
+ $ WORK( ITAUP ), WORK( IWORK ),
+ $ LWORK-IWORK+1, IERR )
+ CALL DLACPY( 'L', M, M, WORK( IU ), LDWRKU, U,
+ $ LDU )
+*
+* Generate right bidiagonalizing vectors in WORK(IU)
+* (Workspace: need M*M+4*M, prefer M*M+3*M+(M-1)*NB)
+*
+ CALL DORGBR( 'P', M, M, M, WORK( IU ), LDWRKU,
+ $ WORK( ITAUP ), WORK( IWORK ),
+ $ LWORK-IWORK+1, IERR )
+*
+* Generate left bidiagonalizing vectors in U
+* (Workspace: need M*M+4*M, prefer M*M+3*M+M*NB)
+*
+ CALL DORGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ IWORK = IE + M
+*
+* Perform bidiagonal QR iteration, computing left
+* singular vectors of L in U and computing right
+* singular vectors of L in WORK(IU)
+* (Workspace: need M*M+BDSPAC)
+*
+ CALL DBDSQR( 'U', M, M, M, 0, S, WORK( IE ),
+ $ WORK( IU ), LDWRKU, U, LDU, DUM, 1,
+ $ WORK( IWORK ), INFO )
+*
+* Multiply right singular vectors of L in WORK(IU) by
+* Q in VT, storing result in A
+* (Workspace: need M*M)
+*
+ CALL DGEMM( 'N', 'N', M, N, M, ONE, WORK( IU ),
+ $ LDWRKU, VT, LDVT, ZERO, A, LDA )
+*
+* Copy right singular vectors of A from A to VT
+*
+ CALL DLACPY( 'F', M, N, A, LDA, VT, LDVT )
+*
+ ELSE
+*
+* Insufficient workspace for a fast algorithm
+*
+ ITAU = 1
+ IWORK = ITAU + M
+*
+* Compute A=L*Q, copying result to VT
+* (Workspace: need 2*M, prefer M+M*NB)
+*
+ CALL DGELQF( M, N, A, LDA, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ CALL DLACPY( 'U', M, N, A, LDA, VT, LDVT )
+*
+* Generate Q in VT
+* (Workspace: need M+N, prefer M+N*NB)
+*
+ CALL DORGLQ( N, N, M, VT, LDVT, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+* Copy L to U, zeroing out above it
+*
+ CALL DLACPY( 'L', M, M, A, LDA, U, LDU )
+ CALL DLASET( 'U', M-1, M-1, ZERO, ZERO, U( 1, 2 ),
+ $ LDU )
+ IE = ITAU
+ ITAUQ = IE + M
+ ITAUP = ITAUQ + M
+ IWORK = ITAUP + M
+*
+* Bidiagonalize L in U
+* (Workspace: need 4*M, prefer 3*M+2*M*NB)
+*
+ CALL DGEBRD( M, M, U, LDU, S, WORK( IE ),
+ $ WORK( ITAUQ ), WORK( ITAUP ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+* Multiply right bidiagonalizing vectors in U by Q
+* in VT
+* (Workspace: need 3*M+N, prefer 3*M+N*NB)
+*
+ CALL DORMBR( 'P', 'L', 'T', M, N, M, U, LDU,
+ $ WORK( ITAUP ), VT, LDVT,
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+* Generate left bidiagonalizing vectors in U
+* (Workspace: need 4*M, prefer 3*M+M*NB)
+*
+ CALL DORGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ IWORK = IE + M
+*
+* Perform bidiagonal QR iteration, computing left
+* singular vectors of A in U and computing right
+* singular vectors of A in VT
+* (Workspace: need BDSPAC)
+*
+ CALL DBDSQR( 'U', M, N, M, 0, S, WORK( IE ), VT,
+ $ LDVT, U, LDU, DUM, 1, WORK( IWORK ),
+ $ INFO )
+*
+ END IF
+*
+ END IF
+*
+ END IF
+*
+ ELSE
+*
+* N .LT. MNTHR
+*
+* Path 10t(N greater than M, but not much larger)
+* Reduce to bidiagonal form without LQ decomposition
+*
+ IE = 1
+ ITAUQ = IE + M
+ ITAUP = ITAUQ + M
+ IWORK = ITAUP + M
+*
+* Bidiagonalize A
+* (Workspace: need 3*M+N, prefer 3*M+(M+N)*NB)
+*
+ CALL DGEBRD( M, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ),
+ $ WORK( ITAUP ), WORK( IWORK ), LWORK-IWORK+1,
+ $ IERR )
+ IF( WNTUAS ) THEN
+*
+* If left singular vectors desired in U, copy result to U
+* and generate left bidiagonalizing vectors in U
+* (Workspace: need 4*M-1, prefer 3*M+(M-1)*NB)
+*
+ CALL DLACPY( 'L', M, M, A, LDA, U, LDU )
+ CALL DORGBR( 'Q', M, M, N, U, LDU, WORK( ITAUQ ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ END IF
+ IF( WNTVAS ) THEN
+*
+* If right singular vectors desired in VT, copy result to
+* VT and generate right bidiagonalizing vectors in VT
+* (Workspace: need 3*M+NRVT, prefer 3*M+NRVT*NB)
+*
+ CALL DLACPY( 'U', M, N, A, LDA, VT, LDVT )
+ IF( WNTVA )
+ $ NRVT = N
+ IF( WNTVS )
+ $ NRVT = M
+ CALL DORGBR( 'P', NRVT, N, M, VT, LDVT, WORK( ITAUP ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ END IF
+ IF( WNTUO ) THEN
+*
+* If left singular vectors desired in A, generate left
+* bidiagonalizing vectors in A
+* (Workspace: need 4*M-1, prefer 3*M+(M-1)*NB)
+*
+ CALL DORGBR( 'Q', M, M, N, A, LDA, WORK( ITAUQ ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ END IF
+ IF( WNTVO ) THEN
+*
+* If right singular vectors desired in A, generate right
+* bidiagonalizing vectors in A
+* (Workspace: need 4*M, prefer 3*M+M*NB)
+*
+ CALL DORGBR( 'P', M, N, M, A, LDA, WORK( ITAUP ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ END IF
+ IWORK = IE + M
+ IF( WNTUAS .OR. WNTUO )
+ $ NRU = M
+ IF( WNTUN )
+ $ NRU = 0
+ IF( WNTVAS .OR. WNTVO )
+ $ NCVT = N
+ IF( WNTVN )
+ $ NCVT = 0
+ IF( ( .NOT.WNTUO ) .AND. ( .NOT.WNTVO ) ) THEN
+*
+* Perform bidiagonal QR iteration, if desired, computing
+* left singular vectors in U and computing right singular
+* vectors in VT
+* (Workspace: need BDSPAC)
+*
+ CALL DBDSQR( 'L', M, NCVT, NRU, 0, S, WORK( IE ), VT,
+ $ LDVT, U, LDU, DUM, 1, WORK( IWORK ), INFO )
+ ELSE IF( ( .NOT.WNTUO ) .AND. WNTVO ) THEN
+*
+* Perform bidiagonal QR iteration, if desired, computing
+* left singular vectors in U and computing right singular
+* vectors in A
+* (Workspace: need BDSPAC)
+*
+ CALL DBDSQR( 'L', M, NCVT, NRU, 0, S, WORK( IE ), A, LDA,
+ $ U, LDU, DUM, 1, WORK( IWORK ), INFO )
+ ELSE
+*
+* Perform bidiagonal QR iteration, if desired, computing
+* left singular vectors in A and computing right singular
+* vectors in VT
+* (Workspace: need BDSPAC)
+*
+ CALL DBDSQR( 'L', M, NCVT, NRU, 0, S, WORK( IE ), VT,
+ $ LDVT, A, LDA, DUM, 1, WORK( IWORK ), INFO )
+ END IF
+*
+ END IF
+*
+ END IF
+*
+* If DBDSQR failed to converge, copy unconverged superdiagonals
+* to WORK( 2:MINMN )
+*
+ IF( INFO.NE.0 ) THEN
+ IF( IE.GT.2 ) THEN
+ DO 50 I = 1, MINMN - 1
+ WORK( I+1 ) = WORK( I+IE-1 )
+ 50 CONTINUE
+ END IF
+ IF( IE.LT.2 ) THEN
+ DO 60 I = MINMN - 1, 1, -1
+ WORK( I+1 ) = WORK( I+IE-1 )
+ 60 CONTINUE
+ END IF
+ END IF
+*
+* Undo scaling if necessary
+*
+ IF( ISCL.EQ.1 ) THEN
+ IF( ANRM.GT.BIGNUM )
+ $ CALL DLASCL( 'G', 0, 0, BIGNUM, ANRM, MINMN, 1, S, MINMN,
+ $ IERR )
+ IF( INFO.NE.0 .AND. ANRM.GT.BIGNUM )
+ $ CALL DLASCL( 'G', 0, 0, BIGNUM, ANRM, MINMN-1, 1, WORK( 2 ),
+ $ MINMN, IERR )
+ IF( ANRM.LT.SMLNUM )
+ $ CALL DLASCL( 'G', 0, 0, SMLNUM, ANRM, MINMN, 1, S, MINMN,
+ $ IERR )
+ IF( INFO.NE.0 .AND. ANRM.LT.SMLNUM )
+ $ CALL DLASCL( 'G', 0, 0, SMLNUM, ANRM, MINMN-1, 1, WORK( 2 ),
+ $ MINMN, IERR )
+ END IF
+*
+* Return optimal workspace in WORK(1)
+*
+ WORK( 1 ) = MAXWRK
+*
+ RETURN
+*
+* End of DGESVD
+*
+ END
+ SUBROUTINE DGESVX( FACT, TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV,
+ $ EQUED, R, C, B, LDB, X, LDX, RCOND, FERR, BERR,
+ $ WORK, IWORK, INFO )
+*
+* -- LAPACK driver routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER EQUED, FACT, TRANS
+ INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS
+ DOUBLE PRECISION RCOND
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * ), IWORK( * )
+ DOUBLE PRECISION A( LDA, * ), AF( LDAF, * ), B( LDB, * ),
+ $ BERR( * ), C( * ), FERR( * ), R( * ),
+ $ WORK( * ), X( LDX, * )
+* ..
+*
+* Purpose
+* =======
+*
+* DGESVX uses the LU factorization to compute the solution to a real
+* system of linear equations
+* A * X = B,
+* where A is an N-by-N matrix and X and B are N-by-NRHS matrices.
+*
+* Error bounds on the solution and a condition estimate are also
+* provided.
+*
+* Description
+* ===========
+*
+* The following steps are performed:
+*
+* 1. If FACT = 'E', real scaling factors are computed to equilibrate
+* the system:
+* TRANS = 'N': diag(R)*A*diag(C) *inv(diag(C))*X = diag(R)*B
+* TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B
+* TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B
+* Whether or not the system will be equilibrated depends on the
+* scaling of the matrix A, but if equilibration is used, A is
+* overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N')
+* or diag(C)*B (if TRANS = 'T' or 'C').
+*
+* 2. If FACT = 'N' or 'E', the LU decomposition is used to factor the
+* matrix A (after equilibration if FACT = 'E') as
+* A = P * L * U,
+* where P is a permutation matrix, L is a unit lower triangular
+* matrix, and U is upper triangular.
+*
+* 3. If some U(i,i)=0, so that U is exactly singular, then the routine
+* returns with INFO = i. Otherwise, the factored form of A is used
+* to estimate the condition number of the matrix A. If the
+* reciprocal of the condition number is less than machine precision,
+* INFO = N+1 is returned as a warning, but the routine still goes on
+* to solve for X and compute error bounds as described below.
+*
+* 4. The system of equations is solved for X using the factored form
+* of A.
+*
+* 5. Iterative refinement is applied to improve the computed solution
+* matrix and calculate error bounds and backward error estimates
+* for it.
+*
+* 6. If equilibration was used, the matrix X is premultiplied by
+* diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so
+* that it solves the original system before equilibration.
+*
+* Arguments
+* =========
+*
+* FACT (input) CHARACTER*1
+* Specifies whether or not the factored form of the matrix A is
+* supplied on entry, and if not, whether the matrix A should be
+* equilibrated before it is factored.
+* = 'F': On entry, AF and IPIV contain the factored form of A.
+* If EQUED is not 'N', the matrix A has been
+* equilibrated with scaling factors given by R and C.
+* A, AF, and IPIV are not modified.
+* = 'N': The matrix A will be copied to AF and factored.
+* = 'E': The matrix A will be equilibrated if necessary, then
+* copied to AF and factored.
+*
+* TRANS (input) CHARACTER*1
+* Specifies the form of the system of equations:
+* = 'N': A * X = B (No transpose)
+* = 'T': A**T * X = B (Transpose)
+* = 'C': A**H * X = B (Transpose)
+*
+* N (input) INTEGER
+* The number of linear equations, i.e., the order of the
+* matrix A. N >= 0.
+*
+* NRHS (input) INTEGER
+* The number of right hand sides, i.e., the number of columns
+* of the matrices B and X. NRHS >= 0.
+*
+* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+* On entry, the N-by-N matrix A. If FACT = 'F' and EQUED is
+* not 'N', then A must have been equilibrated by the scaling
+* factors in R and/or C. A is not modified if FACT = 'F' or
+* 'N', or if FACT = 'E' and EQUED = 'N' on exit.
+*
+* On exit, if EQUED .ne. 'N', A is scaled as follows:
+* EQUED = 'R': A := diag(R) * A
+* EQUED = 'C': A := A * diag(C)
+* EQUED = 'B': A := diag(R) * A * diag(C).
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,N).
+*
+* AF (input or output) DOUBLE PRECISION array, dimension (LDAF,N)
+* If FACT = 'F', then AF is an input argument and on entry
+* contains the factors L and U from the factorization
+* A = P*L*U as computed by DGETRF. If EQUED .ne. 'N', then
+* AF is the factored form of the equilibrated matrix A.
+*
+* If FACT = 'N', then AF is an output argument and on exit
+* returns the factors L and U from the factorization A = P*L*U
+* of the original matrix A.
+*
+* If FACT = 'E', then AF is an output argument and on exit
+* returns the factors L and U from the factorization A = P*L*U
+* of the equilibrated matrix A (see the description of A for
+* the form of the equilibrated matrix).
+*
+* LDAF (input) INTEGER
+* The leading dimension of the array AF. LDAF >= max(1,N).
+*
+* IPIV (input or output) INTEGER array, dimension (N)
+* If FACT = 'F', then IPIV is an input argument and on entry
+* contains the pivot indices from the factorization A = P*L*U
+* as computed by DGETRF; row i of the matrix was interchanged
+* with row IPIV(i).
+*
+* If FACT = 'N', then IPIV is an output argument and on exit
+* contains the pivot indices from the factorization A = P*L*U
+* of the original matrix A.
+*
+* If FACT = 'E', then IPIV is an output argument and on exit
+* contains the pivot indices from the factorization A = P*L*U
+* of the equilibrated matrix A.
+*
+* EQUED (input or output) CHARACTER*1
+* Specifies the form of equilibration that was done.
+* = 'N': No equilibration (always true if FACT = 'N').
+* = 'R': Row equilibration, i.e., A has been premultiplied by
+* diag(R).
+* = 'C': Column equilibration, i.e., A has been postmultiplied
+* by diag(C).
+* = 'B': Both row and column equilibration, i.e., A has been
+* replaced by diag(R) * A * diag(C).
+* EQUED is an input argument if FACT = 'F'; otherwise, it is an
+* output argument.
+*
+* R (input or output) DOUBLE PRECISION array, dimension (N)
+* The row scale factors for A. If EQUED = 'R' or 'B', A is
+* multiplied on the left by diag(R); if EQUED = 'N' or 'C', R
+* is not accessed. R is an input argument if FACT = 'F';
+* otherwise, R is an output argument. If FACT = 'F' and
+* EQUED = 'R' or 'B', each element of R must be positive.
+*
+* C (input or output) DOUBLE PRECISION array, dimension (N)
+* The column scale factors for A. If EQUED = 'C' or 'B', A is
+* multiplied on the right by diag(C); if EQUED = 'N' or 'R', C
+* is not accessed. C is an input argument if FACT = 'F';
+* otherwise, C is an output argument. If FACT = 'F' and
+* EQUED = 'C' or 'B', each element of C must be positive.
+*
+* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
+* On entry, the N-by-NRHS right hand side matrix B.
+* On exit,
+* if EQUED = 'N', B is not modified;
+* if TRANS = 'N' and EQUED = 'R' or 'B', B is overwritten by
+* diag(R)*B;
+* if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', B is
+* overwritten by diag(C)*B.
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. LDB >= max(1,N).
+*
+* X (output) DOUBLE PRECISION array, dimension (LDX,NRHS)
+* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X
+* to the original system of equations. Note that A and B are
+* modified on exit if EQUED .ne. 'N', and the solution to the
+* equilibrated system is inv(diag(C))*X if TRANS = 'N' and
+* EQUED = 'C' or 'B', or inv(diag(R))*X if TRANS = 'T' or 'C'
+* and EQUED = 'R' or 'B'.
+*
+* LDX (input) INTEGER
+* The leading dimension of the array X. LDX >= max(1,N).
+*
+* RCOND (output) DOUBLE PRECISION
+* The estimate of the reciprocal condition number of the matrix
+* A after equilibration (if done). If RCOND is less than the
+* machine precision (in particular, if RCOND = 0), the matrix
+* is singular to working precision. This condition is
+* indicated by a return code of INFO > 0.
+*
+* FERR (output) DOUBLE PRECISION array, dimension (NRHS)
+* The estimated forward error bound for each solution vector
+* X(j) (the j-th column of the solution matrix X).
+* If XTRUE is the true solution corresponding to X(j), FERR(j)
+* is an estimated upper bound for the magnitude of the largest
+* element in (X(j) - XTRUE) divided by the magnitude of the
+* largest element in X(j). The estimate is as reliable as
+* the estimate for RCOND, and is almost always a slight
+* overestimate of the true error.
+*
+* BERR (output) DOUBLE PRECISION array, dimension (NRHS)
+* The componentwise relative backward error of each solution
+* vector X(j) (i.e., the smallest relative change in
+* any element of A or B that makes X(j) an exact solution).
+*
+* WORK (workspace/output) DOUBLE PRECISION array, dimension (4*N)
+* On exit, WORK(1) contains the reciprocal pivot growth
+* factor norm(A)/norm(U). The "max absolute element" norm is
+* used. If WORK(1) is much less than 1, then the stability
+* of the LU factorization of the (equilibrated) matrix A
+* could be poor. This also means that the solution X, condition
+* estimator RCOND, and forward error bound FERR could be
+* unreliable. If factorization fails with 0<INFO<=N, then
+* WORK(1) contains the reciprocal pivot growth factor for the
+* leading INFO columns of A.
+*
+* IWORK (workspace) INTEGER array, dimension (N)
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* > 0: if INFO = i, and i is
+* <= N: U(i,i) is exactly zero. The factorization has
+* been completed, but the factor U is exactly
+* singular, so the solution and error bounds
+* could not be computed. RCOND = 0 is returned.
+* = N+1: U is nonsingular, but RCOND is less than machine
+* precision, meaning that the matrix is singular
+* to working precision. Nevertheless, the
+* solution and error bounds are computed because
+* there are a number of situations where the
+* computed solution can be more accurate than the
+* value of RCOND would suggest.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL COLEQU, EQUIL, NOFACT, NOTRAN, ROWEQU
+ CHARACTER NORM
+ INTEGER I, INFEQU, J
+ DOUBLE PRECISION AMAX, ANORM, BIGNUM, COLCND, RCMAX, RCMIN,
+ $ ROWCND, RPVGRW, SMLNUM
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ DOUBLE PRECISION DLAMCH, DLANGE, DLANTR
+ EXTERNAL LSAME, DLAMCH, DLANGE, DLANTR
+* ..
+* .. External Subroutines ..
+ EXTERNAL DGECON, DGEEQU, DGERFS, DGETRF, DGETRS, DLACPY,
+ $ DLAQGE, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+ INFO = 0
+ NOFACT = LSAME( FACT, 'N' )
+ EQUIL = LSAME( FACT, 'E' )
+ NOTRAN = LSAME( TRANS, 'N' )
+ IF( NOFACT .OR. EQUIL ) THEN
+ EQUED = 'N'
+ ROWEQU = .FALSE.
+ COLEQU = .FALSE.
+ ELSE
+ ROWEQU = LSAME( EQUED, 'R' ) .OR. LSAME( EQUED, 'B' )
+ COLEQU = LSAME( EQUED, 'C' ) .OR. LSAME( EQUED, 'B' )
+ SMLNUM = DLAMCH( 'Safe minimum' )
+ BIGNUM = ONE / SMLNUM
+ END IF
+*
+* Test the input parameters.
+*
+ IF( .NOT.NOFACT .AND. .NOT.EQUIL .AND. .NOT.LSAME( FACT, 'F' ) )
+ $ THEN
+ INFO = -1
+ ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT.
+ $ LSAME( TRANS, 'C' ) ) THEN
+ INFO = -2
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( NRHS.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -6
+ ELSE IF( LDAF.LT.MAX( 1, N ) ) THEN
+ INFO = -8
+ ELSE IF( LSAME( FACT, 'F' ) .AND. .NOT.
+ $ ( ROWEQU .OR. COLEQU .OR. LSAME( EQUED, 'N' ) ) ) THEN
+ INFO = -10
+ ELSE
+ IF( ROWEQU ) THEN
+ RCMIN = BIGNUM
+ RCMAX = ZERO
+ DO 10 J = 1, N
+ RCMIN = MIN( RCMIN, R( J ) )
+ RCMAX = MAX( RCMAX, R( J ) )
+ 10 CONTINUE
+ IF( RCMIN.LE.ZERO ) THEN
+ INFO = -11
+ ELSE IF( N.GT.0 ) THEN
+ ROWCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM )
+ ELSE
+ ROWCND = ONE
+ END IF
+ END IF
+ IF( COLEQU .AND. INFO.EQ.0 ) THEN
+ RCMIN = BIGNUM
+ RCMAX = ZERO
+ DO 20 J = 1, N
+ RCMIN = MIN( RCMIN, C( J ) )
+ RCMAX = MAX( RCMAX, C( J ) )
+ 20 CONTINUE
+ IF( RCMIN.LE.ZERO ) THEN
+ INFO = -12
+ ELSE IF( N.GT.0 ) THEN
+ COLCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM )
+ ELSE
+ COLCND = ONE
+ END IF
+ END IF
+ IF( INFO.EQ.0 ) THEN
+ IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -14
+ ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
+ INFO = -16
+ END IF
+ END IF
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DGESVX', -INFO )
+ RETURN
+ END IF
+*
+ IF( EQUIL ) THEN
+*
+* Compute row and column scalings to equilibrate the matrix A.
+*
+ CALL DGEEQU( N, N, A, LDA, R, C, ROWCND, COLCND, AMAX, INFEQU )
+ IF( INFEQU.EQ.0 ) THEN
+*
+* Equilibrate the matrix.
+*
+ CALL DLAQGE( N, N, A, LDA, R, C, ROWCND, COLCND, AMAX,
+ $ EQUED )
+ ROWEQU = LSAME( EQUED, 'R' ) .OR. LSAME( EQUED, 'B' )
+ COLEQU = LSAME( EQUED, 'C' ) .OR. LSAME( EQUED, 'B' )
+ END IF
+ END IF
+*
+* Scale the right hand side.
+*
+ IF( NOTRAN ) THEN
+ IF( ROWEQU ) THEN
+ DO 40 J = 1, NRHS
+ DO 30 I = 1, N
+ B( I, J ) = R( I )*B( I, J )
+ 30 CONTINUE
+ 40 CONTINUE
+ END IF
+ ELSE IF( COLEQU ) THEN
+ DO 60 J = 1, NRHS
+ DO 50 I = 1, N
+ B( I, J ) = C( I )*B( I, J )
+ 50 CONTINUE
+ 60 CONTINUE
+ END IF
+*
+ IF( NOFACT .OR. EQUIL ) THEN
+*
+* Compute the LU factorization of A.
+*
+ CALL DLACPY( 'Full', N, N, A, LDA, AF, LDAF )
+ CALL DGETRF( N, N, AF, LDAF, IPIV, INFO )
+*
+* Return if INFO is non-zero.
+*
+ IF( INFO.GT.0 ) THEN
+*
+* Compute the reciprocal pivot growth factor of the
+* leading rank-deficient INFO columns of A.
+*
+ RPVGRW = DLANTR( 'M', 'U', 'N', INFO, INFO, AF, LDAF,
+ $ WORK )
+ IF( RPVGRW.EQ.ZERO ) THEN
+ RPVGRW = ONE
+ ELSE
+ RPVGRW = DLANGE( 'M', N, INFO, A, LDA, WORK ) / RPVGRW
+ END IF
+ WORK( 1 ) = RPVGRW
+ RCOND = ZERO
+ RETURN
+ END IF
+ END IF
+*
+* Compute the norm of the matrix A and the
+* reciprocal pivot growth factor RPVGRW.
+*
+ IF( NOTRAN ) THEN
+ NORM = '1'
+ ELSE
+ NORM = 'I'
+ END IF
+ ANORM = DLANGE( NORM, N, N, A, LDA, WORK )
+ RPVGRW = DLANTR( 'M', 'U', 'N', N, N, AF, LDAF, WORK )
+ IF( RPVGRW.EQ.ZERO ) THEN
+ RPVGRW = ONE
+ ELSE
+ RPVGRW = DLANGE( 'M', N, N, A, LDA, WORK ) / RPVGRW
+ END IF
+*
+* Compute the reciprocal of the condition number of A.
+*
+ CALL DGECON( NORM, N, AF, LDAF, ANORM, RCOND, WORK, IWORK, INFO )
+*
+* Compute the solution matrix X.
+*
+ CALL DLACPY( 'Full', N, NRHS, B, LDB, X, LDX )
+ CALL DGETRS( TRANS, N, NRHS, AF, LDAF, IPIV, X, LDX, INFO )
+*
+* Use iterative refinement to improve the computed solution and
+* compute error bounds and backward error estimates for it.
+*
+ CALL DGERFS( TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, X,
+ $ LDX, FERR, BERR, WORK, IWORK, INFO )
+*
+* Transform the solution matrix X to a solution of the original
+* system.
+*
+ IF( NOTRAN ) THEN
+ IF( COLEQU ) THEN
+ DO 80 J = 1, NRHS
+ DO 70 I = 1, N
+ X( I, J ) = C( I )*X( I, J )
+ 70 CONTINUE
+ 80 CONTINUE
+ DO 90 J = 1, NRHS
+ FERR( J ) = FERR( J ) / COLCND
+ 90 CONTINUE
+ END IF
+ ELSE IF( ROWEQU ) THEN
+ DO 110 J = 1, NRHS
+ DO 100 I = 1, N
+ X( I, J ) = R( I )*X( I, J )
+ 100 CONTINUE
+ 110 CONTINUE
+ DO 120 J = 1, NRHS
+ FERR( J ) = FERR( J ) / ROWCND
+ 120 CONTINUE
+ END IF
+*
+ WORK( 1 ) = RPVGRW
+*
+* Set INFO = N+1 if the matrix is singular to working precision.
+*
+ IF( RCOND.LT.DLAMCH( 'Epsilon' ) )
+ $ INFO = N + 1
+ RETURN
+*
+* End of DGESVX
+*
+ END
+ SUBROUTINE DGETC2( N, A, LDA, IPIV, JPIV, INFO )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LDA, N
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * ), JPIV( * )
+ DOUBLE PRECISION A( LDA, * )
+* ..
+*
+* Purpose
+* =======
+*
+* DGETC2 computes an LU factorization with complete pivoting of the
+* n-by-n matrix A. The factorization has the form A = P * L * U * Q,
+* where P and Q are permutation matrices, L is lower triangular with
+* unit diagonal elements and U is upper triangular.
+*
+* This is the Level 2 BLAS algorithm.
+*
+* Arguments
+* =========
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* A (input/output) DOUBLE PRECISION array, dimension (LDA, N)
+* On entry, the n-by-n matrix A to be factored.
+* On exit, the factors L and U from the factorization
+* A = P*L*U*Q; the unit diagonal elements of L are not stored.
+* If U(k, k) appears to be less than SMIN, U(k, k) is given the
+* value of SMIN, i.e., giving a nonsingular perturbed system.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,N).
+*
+* IPIV (output) INTEGER array, dimension(N).
+* The pivot indices; for 1 <= i <= N, row i of the
+* matrix has been interchanged with row IPIV(i).
+*
+* JPIV (output) INTEGER array, dimension(N).
+* The pivot indices; for 1 <= j <= N, column j of the
+* matrix has been interchanged with column JPIV(j).
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* > 0: if INFO = k, U(k, k) is likely to produce owerflow if
+* we try to solve for x in Ax = b. So U is perturbed to
+* avoid the overflow.
+*
+* Further Details
+* ===============
+*
+* Based on contributions by
+* Bo Kagstrom and Peter Poromaa, Department of Computing Science,
+* Umea University, S-901 87 Umea, Sweden.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, IP, IPV, J, JP, JPV
+ DOUBLE PRECISION BIGNUM, EPS, SMIN, SMLNUM, XMAX
+* ..
+* .. External Subroutines ..
+ EXTERNAL DGER, DSWAP
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DLAMCH
+ EXTERNAL DLAMCH
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX
+* ..
+* .. Executable Statements ..
+*
+* Set constants to control overflow
+*
+ INFO = 0
+ EPS = DLAMCH( 'P' )
+ SMLNUM = DLAMCH( 'S' ) / EPS
+ BIGNUM = ONE / SMLNUM
+ CALL DLABAD( SMLNUM, BIGNUM )
+*
+* Factorize A using complete pivoting.
+* Set pivots less than SMIN to SMIN.
+*
+ DO 40 I = 1, N - 1
+*
+* Find max element in matrix A
+*
+ XMAX = ZERO
+ DO 20 IP = I, N
+ DO 10 JP = I, N
+ IF( ABS( A( IP, JP ) ).GE.XMAX ) THEN
+ XMAX = ABS( A( IP, JP ) )
+ IPV = IP
+ JPV = JP
+ END IF
+ 10 CONTINUE
+ 20 CONTINUE
+ IF( I.EQ.1 )
+ $ SMIN = MAX( EPS*XMAX, SMLNUM )
+*
+* Swap rows
+*
+ IF( IPV.NE.I )
+ $ CALL DSWAP( N, A( IPV, 1 ), LDA, A( I, 1 ), LDA )
+ IPIV( I ) = IPV
+*
+* Swap columns
+*
+ IF( JPV.NE.I )
+ $ CALL DSWAP( N, A( 1, JPV ), 1, A( 1, I ), 1 )
+ JPIV( I ) = JPV
+*
+* Check for singularity
+*
+ IF( ABS( A( I, I ) ).LT.SMIN ) THEN
+ INFO = I
+ A( I, I ) = SMIN
+ END IF
+ DO 30 J = I + 1, N
+ A( J, I ) = A( J, I ) / A( I, I )
+ 30 CONTINUE
+ CALL DGER( N-I, N-I, -ONE, A( I+1, I ), 1, A( I, I+1 ), LDA,
+ $ A( I+1, I+1 ), LDA )
+ 40 CONTINUE
+*
+ IF( ABS( A( N, N ) ).LT.SMIN ) THEN
+ INFO = N
+ A( N, N ) = SMIN
+ END IF
+*
+ RETURN
+*
+* End of DGETC2
+*
+ END
+ SUBROUTINE DGETF2( M, N, A, LDA, IPIV, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LDA, M, N
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ DOUBLE PRECISION A( LDA, * )
+* ..
+*
+* Purpose
+* =======
+*
+* DGETF2 computes an LU factorization of a general m-by-n matrix A
+* using partial pivoting with row interchanges.
+*
+* The factorization has the form
+* A = P * L * U
+* where P is a permutation matrix, L is lower triangular with unit
+* diagonal elements (lower trapezoidal if m > n), and U is upper
+* triangular (upper trapezoidal if m < n).
+*
+* This is the right-looking Level 2 BLAS version of the algorithm.
+*
+* Arguments
+* =========
+*
+* M (input) INTEGER
+* The number of rows of the matrix A. M >= 0.
+*
+* N (input) INTEGER
+* The number of columns of the matrix A. N >= 0.
+*
+* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+* On entry, the m by n matrix to be factored.
+* On exit, the factors L and U from the factorization
+* A = P*L*U; the unit diagonal elements of L are not stored.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,M).
+*
+* IPIV (output) INTEGER array, dimension (min(M,N))
+* The pivot indices; for 1 <= i <= min(M,N), row i of the
+* matrix was interchanged with row IPIV(i).
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -k, the k-th argument had an illegal value
+* > 0: if INFO = k, U(k,k) is exactly zero. The factorization
+* has been completed, but the factor U is exactly
+* singular, and division by zero will occur if it is used
+* to solve a system of equations.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE, ZERO
+ PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
+* ..
+* .. Local Scalars ..
+ DOUBLE PRECISION SFMIN
+ INTEGER I, J, JP
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DLAMCH
+ INTEGER IDAMAX
+ EXTERNAL DLAMCH, IDAMAX
+* ..
+* .. External Subroutines ..
+ EXTERNAL DGER, DSCAL, DSWAP, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ IF( M.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+ INFO = -4
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DGETF2', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( M.EQ.0 .OR. N.EQ.0 )
+ $ RETURN
+*
+* Compute machine safe minimum
+*
+ SFMIN = DLAMCH('S')
+*
+ DO 10 J = 1, MIN( M, N )
+*
+* Find pivot and test for singularity.
+*
+ JP = J - 1 + IDAMAX( M-J+1, A( J, J ), 1 )
+ IPIV( J ) = JP
+ IF( A( JP, J ).NE.ZERO ) THEN
+*
+* Apply the interchange to columns 1:N.
+*
+ IF( JP.NE.J )
+ $ CALL DSWAP( N, A( J, 1 ), LDA, A( JP, 1 ), LDA )
+*
+* Compute elements J+1:M of J-th column.
+*
+ IF( J.LT.M ) THEN
+ IF( ABS(A( J, J )) .GE. SFMIN ) THEN
+ CALL DSCAL( M-J, ONE / A( J, J ), A( J+1, J ), 1 )
+ ELSE
+ DO 20 I = 1, M-J
+ A( J+I, J ) = A( J+I, J ) / A( J, J )
+ 20 CONTINUE
+ END IF
+ END IF
+*
+ ELSE IF( INFO.EQ.0 ) THEN
+*
+ INFO = J
+ END IF
+*
+ IF( J.LT.MIN( M, N ) ) THEN
+*
+* Update trailing submatrix.
+*
+ CALL DGER( M-J, N-J, -ONE, A( J+1, J ), 1, A( J, J+1 ), LDA,
+ $ A( J+1, J+1 ), LDA )
+ END IF
+ 10 CONTINUE
+ RETURN
+*
+* End of DGETF2
+*
+ END
+ SUBROUTINE DGETRF( M, N, A, LDA, IPIV, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LDA, M, N
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ DOUBLE PRECISION A( LDA, * )
+* ..
+*
+* Purpose
+* =======
+*
+* DGETRF computes an LU factorization of a general M-by-N matrix A
+* using partial pivoting with row interchanges.
+*
+* The factorization has the form
+* A = P * L * U
+* where P is a permutation matrix, L is lower triangular with unit
+* diagonal elements (lower trapezoidal if m > n), and U is upper
+* triangular (upper trapezoidal if m < n).
+*
+* This is the right-looking Level 3 BLAS version of the algorithm.
+*
+* Arguments
+* =========
+*
+* M (input) INTEGER
+* The number of rows of the matrix A. M >= 0.
+*
+* N (input) INTEGER
+* The number of columns of the matrix A. N >= 0.
+*
+* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+* On entry, the M-by-N matrix to be factored.
+* On exit, the factors L and U from the factorization
+* A = P*L*U; the unit diagonal elements of L are not stored.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,M).
+*
+* IPIV (output) INTEGER array, dimension (min(M,N))
+* The pivot indices; for 1 <= i <= min(M,N), row i of the
+* matrix was interchanged with row IPIV(i).
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* > 0: if INFO = i, U(i,i) is exactly zero. The factorization
+* has been completed, but the factor U is exactly
+* singular, and division by zero will occur if it is used
+* to solve a system of equations.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE
+ PARAMETER ( ONE = 1.0D+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, IINFO, J, JB, NB
+* ..
+* .. External Subroutines ..
+ EXTERNAL DGEMM, DGETF2, DLASWP, DTRSM, XERBLA
+* ..
+* .. External Functions ..
+ INTEGER ILAENV
+ EXTERNAL ILAENV
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ IF( M.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+ INFO = -4
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DGETRF', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( M.EQ.0 .OR. N.EQ.0 )
+ $ RETURN
+*
+* Determine the block size for this environment.
+*
+ NB = ILAENV( 1, 'DGETRF', ' ', M, N, -1, -1 )
+ IF( NB.LE.1 .OR. NB.GE.MIN( M, N ) ) THEN
+*
+* Use unblocked code.
+*
+ CALL DGETF2( M, N, A, LDA, IPIV, INFO )
+ ELSE
+*
+* Use blocked code.
+*
+ DO 20 J = 1, MIN( M, N ), NB
+ JB = MIN( MIN( M, N )-J+1, NB )
+*
+* Factor diagonal and subdiagonal blocks and test for exact
+* singularity.
+*
+ CALL DGETF2( M-J+1, JB, A( J, J ), LDA, IPIV( J ), IINFO )
+*
+* Adjust INFO and the pivot indices.
+*
+ IF( INFO.EQ.0 .AND. IINFO.GT.0 )
+ $ INFO = IINFO + J - 1
+ DO 10 I = J, MIN( M, J+JB-1 )
+ IPIV( I ) = J - 1 + IPIV( I )
+ 10 CONTINUE
+*
+* Apply interchanges to columns 1:J-1.
+*
+ CALL DLASWP( J-1, A, LDA, J, J+JB-1, IPIV, 1 )
+*
+ IF( J+JB.LE.N ) THEN
+*
+* Apply interchanges to columns J+JB:N.
+*
+ CALL DLASWP( N-J-JB+1, A( 1, J+JB ), LDA, J, J+JB-1,
+ $ IPIV, 1 )
+*
+* Compute block row of U.
+*
+ CALL DTRSM( 'Left', 'Lower', 'No transpose', 'Unit', JB,
+ $ N-J-JB+1, ONE, A( J, J ), LDA, A( J, J+JB ),
+ $ LDA )
+ IF( J+JB.LE.M ) THEN
+*
+* Update trailing submatrix.
+*
+ CALL DGEMM( 'No transpose', 'No transpose', M-J-JB+1,
+ $ N-J-JB+1, JB, -ONE, A( J+JB, J ), LDA,
+ $ A( J, J+JB ), LDA, ONE, A( J+JB, J+JB ),
+ $ LDA )
+ END IF
+ END IF
+ 20 CONTINUE
+ END IF
+ RETURN
+*
+* End of DGETRF
+*
+ END
+ SUBROUTINE DGETRI( N, A, LDA, IPIV, WORK, LWORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LDA, LWORK, N
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ DOUBLE PRECISION A( LDA, * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DGETRI computes the inverse of a matrix using the LU factorization
+* computed by DGETRF.
+*
+* This method inverts U and then computes inv(A) by solving the system
+* inv(A)*L = inv(U) for inv(A).
+*
+* Arguments
+* =========
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+* On entry, the factors L and U from the factorization
+* A = P*L*U as computed by DGETRF.
+* On exit, if INFO = 0, the inverse of the original matrix A.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,N).
+*
+* IPIV (input) INTEGER array, dimension (N)
+* The pivot indices from DGETRF; for 1<=i<=N, row i of the
+* matrix was interchanged with row IPIV(i).
+*
+* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
+* On exit, if INFO=0, then WORK(1) returns the optimal LWORK.
+*
+* LWORK (input) INTEGER
+* The dimension of the array WORK. LWORK >= max(1,N).
+* For optimal performance LWORK >= N*NB, where NB is
+* the optimal blocksize returned by ILAENV.
+*
+* If LWORK = -1, then a workspace query is assumed; the routine
+* only calculates the optimal size of the WORK array, returns
+* this value as the first entry of the WORK array, and no error
+* message related to LWORK is issued by XERBLA.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* > 0: if INFO = i, U(i,i) is exactly zero; the matrix is
+* singular and its inverse could not be computed.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL LQUERY
+ INTEGER I, IWS, J, JB, JJ, JP, LDWORK, LWKOPT, NB,
+ $ NBMIN, NN
+* ..
+* .. External Functions ..
+ INTEGER ILAENV
+ EXTERNAL ILAENV
+* ..
+* .. External Subroutines ..
+ EXTERNAL DGEMM, DGEMV, DSWAP, DTRSM, DTRTRI, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ NB = ILAENV( 1, 'DGETRI', ' ', N, -1, -1, -1 )
+ LWKOPT = N*NB
+ WORK( 1 ) = LWKOPT
+ LQUERY = ( LWORK.EQ.-1 )
+ IF( N.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -3
+ ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN
+ INFO = -6
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DGETRI', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+* Form inv(U). If INFO > 0 from DTRTRI, then U is singular,
+* and the inverse is not computed.
+*
+ CALL DTRTRI( 'Upper', 'Non-unit', N, A, LDA, INFO )
+ IF( INFO.GT.0 )
+ $ RETURN
+*
+ NBMIN = 2
+ LDWORK = N
+ IF( NB.GT.1 .AND. NB.LT.N ) THEN
+ IWS = MAX( LDWORK*NB, 1 )
+ IF( LWORK.LT.IWS ) THEN
+ NB = LWORK / LDWORK
+ NBMIN = MAX( 2, ILAENV( 2, 'DGETRI', ' ', N, -1, -1, -1 ) )
+ END IF
+ ELSE
+ IWS = N
+ END IF
+*
+* Solve the equation inv(A)*L = inv(U) for inv(A).
+*
+ IF( NB.LT.NBMIN .OR. NB.GE.N ) THEN
+*
+* Use unblocked code.
+*
+ DO 20 J = N, 1, -1
+*
+* Copy current column of L to WORK and replace with zeros.
+*
+ DO 10 I = J + 1, N
+ WORK( I ) = A( I, J )
+ A( I, J ) = ZERO
+ 10 CONTINUE
+*
+* Compute current column of inv(A).
+*
+ IF( J.LT.N )
+ $ CALL DGEMV( 'No transpose', N, N-J, -ONE, A( 1, J+1 ),
+ $ LDA, WORK( J+1 ), 1, ONE, A( 1, J ), 1 )
+ 20 CONTINUE
+ ELSE
+*
+* Use blocked code.
+*
+ NN = ( ( N-1 ) / NB )*NB + 1
+ DO 50 J = NN, 1, -NB
+ JB = MIN( NB, N-J+1 )
+*
+* Copy current block column of L to WORK and replace with
+* zeros.
+*
+ DO 40 JJ = J, J + JB - 1
+ DO 30 I = JJ + 1, N
+ WORK( I+( JJ-J )*LDWORK ) = A( I, JJ )
+ A( I, JJ ) = ZERO
+ 30 CONTINUE
+ 40 CONTINUE
+*
+* Compute current block column of inv(A).
+*
+ IF( J+JB.LE.N )
+ $ CALL DGEMM( 'No transpose', 'No transpose', N, JB,
+ $ N-J-JB+1, -ONE, A( 1, J+JB ), LDA,
+ $ WORK( J+JB ), LDWORK, ONE, A( 1, J ), LDA )
+ CALL DTRSM( 'Right', 'Lower', 'No transpose', 'Unit', N, JB,
+ $ ONE, WORK( J ), LDWORK, A( 1, J ), LDA )
+ 50 CONTINUE
+ END IF
+*
+* Apply column interchanges.
+*
+ DO 60 J = N - 1, 1, -1
+ JP = IPIV( J )
+ IF( JP.NE.J )
+ $ CALL DSWAP( N, A( 1, J ), 1, A( 1, JP ), 1 )
+ 60 CONTINUE
+*
+ WORK( 1 ) = IWS
+ RETURN
+*
+* End of DGETRI
+*
+ END
+ SUBROUTINE DGETRS( TRANS, N, NRHS, A, LDA, IPIV, B, LDB, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER TRANS
+ INTEGER INFO, LDA, LDB, N, NRHS
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ DOUBLE PRECISION A( LDA, * ), B( LDB, * )
+* ..
+*
+* Purpose
+* =======
+*
+* DGETRS solves a system of linear equations
+* A * X = B or A' * X = B
+* with a general N-by-N matrix A using the LU factorization computed
+* by DGETRF.
+*
+* Arguments
+* =========
+*
+* TRANS (input) CHARACTER*1
+* Specifies the form of the system of equations:
+* = 'N': A * X = B (No transpose)
+* = 'T': A'* X = B (Transpose)
+* = 'C': A'* X = B (Conjugate transpose = Transpose)
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* NRHS (input) INTEGER
+* The number of right hand sides, i.e., the number of columns
+* of the matrix B. NRHS >= 0.
+*
+* A (input) DOUBLE PRECISION array, dimension (LDA,N)
+* The factors L and U from the factorization A = P*L*U
+* as computed by DGETRF.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,N).
+*
+* IPIV (input) INTEGER array, dimension (N)
+* The pivot indices from DGETRF; for 1<=i<=N, row i of the
+* matrix was interchanged with row IPIV(i).
+*
+* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
+* On entry, the right hand side matrix B.
+* On exit, the solution matrix X.
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. LDB >= max(1,N).
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE
+ PARAMETER ( ONE = 1.0D+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL NOTRAN
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL DLASWP, DTRSM, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ NOTRAN = LSAME( TRANS, 'N' )
+ IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT.
+ $ LSAME( TRANS, 'C' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( NRHS.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -5
+ ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -8
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DGETRS', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 .OR. NRHS.EQ.0 )
+ $ RETURN
+*
+ IF( NOTRAN ) THEN
+*
+* Solve A * X = B.
+*
+* Apply row interchanges to the right hand sides.
+*
+ CALL DLASWP( NRHS, B, LDB, 1, N, IPIV, 1 )
+*
+* Solve L*X = B, overwriting B with X.
+*
+ CALL DTRSM( 'Left', 'Lower', 'No transpose', 'Unit', N, NRHS,
+ $ ONE, A, LDA, B, LDB )
+*
+* Solve U*X = B, overwriting B with X.
+*
+ CALL DTRSM( 'Left', 'Upper', 'No transpose', 'Non-unit', N,
+ $ NRHS, ONE, A, LDA, B, LDB )
+ ELSE
+*
+* Solve A' * X = B.
+*
+* Solve U'*X = B, overwriting B with X.
+*
+ CALL DTRSM( 'Left', 'Upper', 'Transpose', 'Non-unit', N, NRHS,
+ $ ONE, A, LDA, B, LDB )
+*
+* Solve L'*X = B, overwriting B with X.
+*
+ CALL DTRSM( 'Left', 'Lower', 'Transpose', 'Unit', N, NRHS, ONE,
+ $ A, LDA, B, LDB )
+*
+* Apply row interchanges to the solution vectors.
+*
+ CALL DLASWP( NRHS, B, LDB, 1, N, IPIV, -1 )
+ END IF
+*
+ RETURN
+*
+* End of DGETRS
+*
+ END
+ SUBROUTINE DGGBAK( JOB, SIDE, N, ILO, IHI, LSCALE, RSCALE, M, V,
+ $ LDV, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER JOB, SIDE
+ INTEGER IHI, ILO, INFO, LDV, M, N
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION LSCALE( * ), RSCALE( * ), V( LDV, * )
+* ..
+*
+* Purpose
+* =======
+*
+* DGGBAK forms the right or left eigenvectors of a real generalized
+* eigenvalue problem A*x = lambda*B*x, by backward transformation on
+* the computed eigenvectors of the balanced pair of matrices output by
+* DGGBAL.
+*
+* Arguments
+* =========
+*
+* JOB (input) CHARACTER*1
+* Specifies the type of backward transformation required:
+* = 'N': do nothing, return immediately;
+* = 'P': do backward transformation for permutation only;
+* = 'S': do backward transformation for scaling only;
+* = 'B': do backward transformations for both permutation and
+* scaling.
+* JOB must be the same as the argument JOB supplied to DGGBAL.
+*
+* SIDE (input) CHARACTER*1
+* = 'R': V contains right eigenvectors;
+* = 'L': V contains left eigenvectors.
+*
+* N (input) INTEGER
+* The number of rows of the matrix V. N >= 0.
+*
+* ILO (input) INTEGER
+* IHI (input) INTEGER
+* The integers ILO and IHI determined by DGGBAL.
+* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.
+*
+* LSCALE (input) DOUBLE PRECISION array, dimension (N)
+* Details of the permutations and/or scaling factors applied
+* to the left side of A and B, as returned by DGGBAL.
+*
+* RSCALE (input) DOUBLE PRECISION array, dimension (N)
+* Details of the permutations and/or scaling factors applied
+* to the right side of A and B, as returned by DGGBAL.
+*
+* M (input) INTEGER
+* The number of columns of the matrix V. M >= 0.
+*
+* V (input/output) DOUBLE PRECISION array, dimension (LDV,M)
+* On entry, the matrix of right or left eigenvectors to be
+* transformed, as returned by DTGEVC.
+* On exit, V is overwritten by the transformed eigenvectors.
+*
+* LDV (input) INTEGER
+* The leading dimension of the matrix V. LDV >= max(1,N).
+*
+* INFO (output) INTEGER
+* = 0: successful exit.
+* < 0: if INFO = -i, the i-th argument had an illegal value.
+*
+* Further Details
+* ===============
+*
+* See R.C. Ward, Balancing the generalized eigenvalue problem,
+* SIAM J. Sci. Stat. Comp. 2 (1981), 141-152.
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ LOGICAL LEFTV, RIGHTV
+ INTEGER I, K
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL DSCAL, DSWAP, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters
+*
+ RIGHTV = LSAME( SIDE, 'R' )
+ LEFTV = LSAME( SIDE, 'L' )
+*
+ INFO = 0
+ IF( .NOT.LSAME( JOB, 'N' ) .AND. .NOT.LSAME( JOB, 'P' ) .AND.
+ $ .NOT.LSAME( JOB, 'S' ) .AND. .NOT.LSAME( JOB, 'B' ) ) THEN
+ INFO = -1
+ ELSE IF( .NOT.RIGHTV .AND. .NOT.LEFTV ) THEN
+ INFO = -2
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( ILO.LT.1 ) THEN
+ INFO = -4
+ ELSE IF( N.EQ.0 .AND. IHI.EQ.0 .AND. ILO.NE.1 ) THEN
+ INFO = -4
+ ELSE IF( N.GT.0 .AND. ( IHI.LT.ILO .OR. IHI.GT.MAX( 1, N ) ) )
+ $ THEN
+ INFO = -5
+ ELSE IF( N.EQ.0 .AND. ILO.EQ.1 .AND. IHI.NE.0 ) THEN
+ INFO = -5
+ ELSE IF( M.LT.0 ) THEN
+ INFO = -8
+ ELSE IF( LDV.LT.MAX( 1, N ) ) THEN
+ INFO = -10
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DGGBAK', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 )
+ $ RETURN
+ IF( M.EQ.0 )
+ $ RETURN
+ IF( LSAME( JOB, 'N' ) )
+ $ RETURN
+*
+ IF( ILO.EQ.IHI )
+ $ GO TO 30
+*
+* Backward balance
+*
+ IF( LSAME( JOB, 'S' ) .OR. LSAME( JOB, 'B' ) ) THEN
+*
+* Backward transformation on right eigenvectors
+*
+ IF( RIGHTV ) THEN
+ DO 10 I = ILO, IHI
+ CALL DSCAL( M, RSCALE( I ), V( I, 1 ), LDV )
+ 10 CONTINUE
+ END IF
+*
+* Backward transformation on left eigenvectors
+*
+ IF( LEFTV ) THEN
+ DO 20 I = ILO, IHI
+ CALL DSCAL( M, LSCALE( I ), V( I, 1 ), LDV )
+ 20 CONTINUE
+ END IF
+ END IF
+*
+* Backward permutation
+*
+ 30 CONTINUE
+ IF( LSAME( JOB, 'P' ) .OR. LSAME( JOB, 'B' ) ) THEN
+*
+* Backward permutation on right eigenvectors
+*
+ IF( RIGHTV ) THEN
+ IF( ILO.EQ.1 )
+ $ GO TO 50
+*
+ DO 40 I = ILO - 1, 1, -1
+ K = RSCALE( I )
+ IF( K.EQ.I )
+ $ GO TO 40
+ CALL DSWAP( M, V( I, 1 ), LDV, V( K, 1 ), LDV )
+ 40 CONTINUE
+*
+ 50 CONTINUE
+ IF( IHI.EQ.N )
+ $ GO TO 70
+ DO 60 I = IHI + 1, N
+ K = RSCALE( I )
+ IF( K.EQ.I )
+ $ GO TO 60
+ CALL DSWAP( M, V( I, 1 ), LDV, V( K, 1 ), LDV )
+ 60 CONTINUE
+ END IF
+*
+* Backward permutation on left eigenvectors
+*
+ 70 CONTINUE
+ IF( LEFTV ) THEN
+ IF( ILO.EQ.1 )
+ $ GO TO 90
+ DO 80 I = ILO - 1, 1, -1
+ K = LSCALE( I )
+ IF( K.EQ.I )
+ $ GO TO 80
+ CALL DSWAP( M, V( I, 1 ), LDV, V( K, 1 ), LDV )
+ 80 CONTINUE
+*
+ 90 CONTINUE
+ IF( IHI.EQ.N )
+ $ GO TO 110
+ DO 100 I = IHI + 1, N
+ K = LSCALE( I )
+ IF( K.EQ.I )
+ $ GO TO 100
+ CALL DSWAP( M, V( I, 1 ), LDV, V( K, 1 ), LDV )
+ 100 CONTINUE
+ END IF
+ END IF
+*
+ 110 CONTINUE
+*
+ RETURN
+*
+* End of DGGBAK
+*
+ END
+ SUBROUTINE DGGBAL( JOB, N, A, LDA, B, LDB, ILO, IHI, LSCALE,
+ $ RSCALE, WORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER JOB
+ INTEGER IHI, ILO, INFO, LDA, LDB, N
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION A( LDA, * ), B( LDB, * ), LSCALE( * ),
+ $ RSCALE( * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DGGBAL balances a pair of general real matrices (A,B). This
+* involves, first, permuting A and B by similarity transformations to
+* isolate eigenvalues in the first 1 to ILO$-$1 and last IHI+1 to N
+* elements on the diagonal; and second, applying a diagonal similarity
+* transformation to rows and columns ILO to IHI to make the rows
+* and columns as close in norm as possible. Both steps are optional.
+*
+* Balancing may reduce the 1-norm of the matrices, and improve the
+* accuracy of the computed eigenvalues and/or eigenvectors in the
+* generalized eigenvalue problem A*x = lambda*B*x.
+*
+* Arguments
+* =========
+*
+* JOB (input) CHARACTER*1
+* Specifies the operations to be performed on A and B:
+* = 'N': none: simply set ILO = 1, IHI = N, LSCALE(I) = 1.0
+* and RSCALE(I) = 1.0 for i = 1,...,N.
+* = 'P': permute only;
+* = 'S': scale only;
+* = 'B': both permute and scale.
+*
+* N (input) INTEGER
+* The order of the matrices A and B. N >= 0.
+*
+* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+* On entry, the input matrix A.
+* On exit, A is overwritten by the balanced matrix.
+* If JOB = 'N', A is not referenced.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,N).
+*
+* B (input/output) DOUBLE PRECISION array, dimension (LDB,N)
+* On entry, the input matrix B.
+* On exit, B is overwritten by the balanced matrix.
+* If JOB = 'N', B is not referenced.
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. LDB >= max(1,N).
+*
+* ILO (output) INTEGER
+* IHI (output) INTEGER
+* ILO and IHI are set to integers such that on exit
+* A(i,j) = 0 and B(i,j) = 0 if i > j and
+* j = 1,...,ILO-1 or i = IHI+1,...,N.
+* If JOB = 'N' or 'S', ILO = 1 and IHI = N.
+*
+* LSCALE (output) DOUBLE PRECISION array, dimension (N)
+* Details of the permutations and scaling factors applied
+* to the left side of A and B. If P(j) is the index of the
+* row interchanged with row j, and D(j)
+* is the scaling factor applied to row j, then
+* LSCALE(j) = P(j) for J = 1,...,ILO-1
+* = D(j) for J = ILO,...,IHI
+* = P(j) for J = IHI+1,...,N.
+* The order in which the interchanges are made is N to IHI+1,
+* then 1 to ILO-1.
+*
+* RSCALE (output) DOUBLE PRECISION array, dimension (N)
+* Details of the permutations and scaling factors applied
+* to the right side of A and B. If P(j) is the index of the
+* column interchanged with column j, and D(j)
+* is the scaling factor applied to column j, then
+* LSCALE(j) = P(j) for J = 1,...,ILO-1
+* = D(j) for J = ILO,...,IHI
+* = P(j) for J = IHI+1,...,N.
+* The order in which the interchanges are made is N to IHI+1,
+* then 1 to ILO-1.
+*
+* WORK (workspace) REAL array, dimension (lwork)
+* lwork must be at least max(1,6*N) when JOB = 'S' or 'B', and
+* at least 1 when JOB = 'N' or 'P'.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value.
+*
+* Further Details
+* ===============
+*
+* See R.C. WARD, Balancing the generalized eigenvalue problem,
+* SIAM J. Sci. Stat. Comp. 2 (1981), 141-152.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, HALF, ONE
+ PARAMETER ( ZERO = 0.0D+0, HALF = 0.5D+0, ONE = 1.0D+0 )
+ DOUBLE PRECISION THREE, SCLFAC
+ PARAMETER ( THREE = 3.0D+0, SCLFAC = 1.0D+1 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, ICAB, IFLOW, IP1, IR, IRAB, IT, J, JC, JP1,
+ $ K, KOUNT, L, LCAB, LM1, LRAB, LSFMAX, LSFMIN,
+ $ M, NR, NRP2
+ DOUBLE PRECISION ALPHA, BASL, BETA, CAB, CMAX, COEF, COEF2,
+ $ COEF5, COR, EW, EWC, GAMMA, PGAMMA, RAB, SFMAX,
+ $ SFMIN, SUM, T, TA, TB, TC
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER IDAMAX
+ DOUBLE PRECISION DDOT, DLAMCH
+ EXTERNAL LSAME, IDAMAX, DDOT, DLAMCH
+* ..
+* .. External Subroutines ..
+ EXTERNAL DAXPY, DSCAL, DSWAP, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, DBLE, INT, LOG10, MAX, MIN, SIGN
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters
+*
+ INFO = 0
+ IF( .NOT.LSAME( JOB, 'N' ) .AND. .NOT.LSAME( JOB, 'P' ) .AND.
+ $ .NOT.LSAME( JOB, 'S' ) .AND. .NOT.LSAME( JOB, 'B' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -4
+ ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -6
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DGGBAL', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 ) THEN
+ ILO = 1
+ IHI = N
+ RETURN
+ END IF
+*
+ IF( N.EQ.1 ) THEN
+ ILO = 1
+ IHI = N
+ LSCALE( 1 ) = ONE
+ RSCALE( 1 ) = ONE
+ RETURN
+ END IF
+*
+ IF( LSAME( JOB, 'N' ) ) THEN
+ ILO = 1
+ IHI = N
+ DO 10 I = 1, N
+ LSCALE( I ) = ONE
+ RSCALE( I ) = ONE
+ 10 CONTINUE
+ RETURN
+ END IF
+*
+ K = 1
+ L = N
+ IF( LSAME( JOB, 'S' ) )
+ $ GO TO 190
+*
+ GO TO 30
+*
+* Permute the matrices A and B to isolate the eigenvalues.
+*
+* Find row with one nonzero in columns 1 through L
+*
+ 20 CONTINUE
+ L = LM1
+ IF( L.NE.1 )
+ $ GO TO 30
+*
+ RSCALE( 1 ) = ONE
+ LSCALE( 1 ) = ONE
+ GO TO 190
+*
+ 30 CONTINUE
+ LM1 = L - 1
+ DO 80 I = L, 1, -1
+ DO 40 J = 1, LM1
+ JP1 = J + 1
+ IF( A( I, J ).NE.ZERO .OR. B( I, J ).NE.ZERO )
+ $ GO TO 50
+ 40 CONTINUE
+ J = L
+ GO TO 70
+*
+ 50 CONTINUE
+ DO 60 J = JP1, L
+ IF( A( I, J ).NE.ZERO .OR. B( I, J ).NE.ZERO )
+ $ GO TO 80
+ 60 CONTINUE
+ J = JP1 - 1
+*
+ 70 CONTINUE
+ M = L
+ IFLOW = 1
+ GO TO 160
+ 80 CONTINUE
+ GO TO 100
+*
+* Find column with one nonzero in rows K through N
+*
+ 90 CONTINUE
+ K = K + 1
+*
+ 100 CONTINUE
+ DO 150 J = K, L
+ DO 110 I = K, LM1
+ IP1 = I + 1
+ IF( A( I, J ).NE.ZERO .OR. B( I, J ).NE.ZERO )
+ $ GO TO 120
+ 110 CONTINUE
+ I = L
+ GO TO 140
+ 120 CONTINUE
+ DO 130 I = IP1, L
+ IF( A( I, J ).NE.ZERO .OR. B( I, J ).NE.ZERO )
+ $ GO TO 150
+ 130 CONTINUE
+ I = IP1 - 1
+ 140 CONTINUE
+ M = K
+ IFLOW = 2
+ GO TO 160
+ 150 CONTINUE
+ GO TO 190
+*
+* Permute rows M and I
+*
+ 160 CONTINUE
+ LSCALE( M ) = I
+ IF( I.EQ.M )
+ $ GO TO 170
+ CALL DSWAP( N-K+1, A( I, K ), LDA, A( M, K ), LDA )
+ CALL DSWAP( N-K+1, B( I, K ), LDB, B( M, K ), LDB )
+*
+* Permute columns M and J
+*
+ 170 CONTINUE
+ RSCALE( M ) = J
+ IF( J.EQ.M )
+ $ GO TO 180
+ CALL DSWAP( L, A( 1, J ), 1, A( 1, M ), 1 )
+ CALL DSWAP( L, B( 1, J ), 1, B( 1, M ), 1 )
+*
+ 180 CONTINUE
+ GO TO ( 20, 90 )IFLOW
+*
+ 190 CONTINUE
+ ILO = K
+ IHI = L
+*
+ IF( LSAME( JOB, 'P' ) ) THEN
+ DO 195 I = ILO, IHI
+ LSCALE( I ) = ONE
+ RSCALE( I ) = ONE
+ 195 CONTINUE
+ RETURN
+ END IF
+*
+ IF( ILO.EQ.IHI )
+ $ RETURN
+*
+* Balance the submatrix in rows ILO to IHI.
+*
+ NR = IHI - ILO + 1
+ DO 200 I = ILO, IHI
+ RSCALE( I ) = ZERO
+ LSCALE( I ) = ZERO
+*
+ WORK( I ) = ZERO
+ WORK( I+N ) = ZERO
+ WORK( I+2*N ) = ZERO
+ WORK( I+3*N ) = ZERO
+ WORK( I+4*N ) = ZERO
+ WORK( I+5*N ) = ZERO
+ 200 CONTINUE
+*
+* Compute right side vector in resulting linear equations
+*
+ BASL = LOG10( SCLFAC )
+ DO 240 I = ILO, IHI
+ DO 230 J = ILO, IHI
+ TB = B( I, J )
+ TA = A( I, J )
+ IF( TA.EQ.ZERO )
+ $ GO TO 210
+ TA = LOG10( ABS( TA ) ) / BASL
+ 210 CONTINUE
+ IF( TB.EQ.ZERO )
+ $ GO TO 220
+ TB = LOG10( ABS( TB ) ) / BASL
+ 220 CONTINUE
+ WORK( I+4*N ) = WORK( I+4*N ) - TA - TB
+ WORK( J+5*N ) = WORK( J+5*N ) - TA - TB
+ 230 CONTINUE
+ 240 CONTINUE
+*
+ COEF = ONE / DBLE( 2*NR )
+ COEF2 = COEF*COEF
+ COEF5 = HALF*COEF2
+ NRP2 = NR + 2
+ BETA = ZERO
+ IT = 1
+*
+* Start generalized conjugate gradient iteration
+*
+ 250 CONTINUE
+*
+ GAMMA = DDOT( NR, WORK( ILO+4*N ), 1, WORK( ILO+4*N ), 1 ) +
+ $ DDOT( NR, WORK( ILO+5*N ), 1, WORK( ILO+5*N ), 1 )
+*
+ EW = ZERO
+ EWC = ZERO
+ DO 260 I = ILO, IHI
+ EW = EW + WORK( I+4*N )
+ EWC = EWC + WORK( I+5*N )
+ 260 CONTINUE
+*
+ GAMMA = COEF*GAMMA - COEF2*( EW**2+EWC**2 ) - COEF5*( EW-EWC )**2
+ IF( GAMMA.EQ.ZERO )
+ $ GO TO 350
+ IF( IT.NE.1 )
+ $ BETA = GAMMA / PGAMMA
+ T = COEF5*( EWC-THREE*EW )
+ TC = COEF5*( EW-THREE*EWC )
+*
+ CALL DSCAL( NR, BETA, WORK( ILO ), 1 )
+ CALL DSCAL( NR, BETA, WORK( ILO+N ), 1 )
+*
+ CALL DAXPY( NR, COEF, WORK( ILO+4*N ), 1, WORK( ILO+N ), 1 )
+ CALL DAXPY( NR, COEF, WORK( ILO+5*N ), 1, WORK( ILO ), 1 )
+*
+ DO 270 I = ILO, IHI
+ WORK( I ) = WORK( I ) + TC
+ WORK( I+N ) = WORK( I+N ) + T
+ 270 CONTINUE
+*
+* Apply matrix to vector
+*
+ DO 300 I = ILO, IHI
+ KOUNT = 0
+ SUM = ZERO
+ DO 290 J = ILO, IHI
+ IF( A( I, J ).EQ.ZERO )
+ $ GO TO 280
+ KOUNT = KOUNT + 1
+ SUM = SUM + WORK( J )
+ 280 CONTINUE
+ IF( B( I, J ).EQ.ZERO )
+ $ GO TO 290
+ KOUNT = KOUNT + 1
+ SUM = SUM + WORK( J )
+ 290 CONTINUE
+ WORK( I+2*N ) = DBLE( KOUNT )*WORK( I+N ) + SUM
+ 300 CONTINUE
+*
+ DO 330 J = ILO, IHI
+ KOUNT = 0
+ SUM = ZERO
+ DO 320 I = ILO, IHI
+ IF( A( I, J ).EQ.ZERO )
+ $ GO TO 310
+ KOUNT = KOUNT + 1
+ SUM = SUM + WORK( I+N )
+ 310 CONTINUE
+ IF( B( I, J ).EQ.ZERO )
+ $ GO TO 320
+ KOUNT = KOUNT + 1
+ SUM = SUM + WORK( I+N )
+ 320 CONTINUE
+ WORK( J+3*N ) = DBLE( KOUNT )*WORK( J ) + SUM
+ 330 CONTINUE
+*
+ SUM = DDOT( NR, WORK( ILO+N ), 1, WORK( ILO+2*N ), 1 ) +
+ $ DDOT( NR, WORK( ILO ), 1, WORK( ILO+3*N ), 1 )
+ ALPHA = GAMMA / SUM
+*
+* Determine correction to current iteration
+*
+ CMAX = ZERO
+ DO 340 I = ILO, IHI
+ COR = ALPHA*WORK( I+N )
+ IF( ABS( COR ).GT.CMAX )
+ $ CMAX = ABS( COR )
+ LSCALE( I ) = LSCALE( I ) + COR
+ COR = ALPHA*WORK( I )
+ IF( ABS( COR ).GT.CMAX )
+ $ CMAX = ABS( COR )
+ RSCALE( I ) = RSCALE( I ) + COR
+ 340 CONTINUE
+ IF( CMAX.LT.HALF )
+ $ GO TO 350
+*
+ CALL DAXPY( NR, -ALPHA, WORK( ILO+2*N ), 1, WORK( ILO+4*N ), 1 )
+ CALL DAXPY( NR, -ALPHA, WORK( ILO+3*N ), 1, WORK( ILO+5*N ), 1 )
+*
+ PGAMMA = GAMMA
+ IT = IT + 1
+ IF( IT.LE.NRP2 )
+ $ GO TO 250
+*
+* End generalized conjugate gradient iteration
+*
+ 350 CONTINUE
+ SFMIN = DLAMCH( 'S' )
+ SFMAX = ONE / SFMIN
+ LSFMIN = INT( LOG10( SFMIN ) / BASL+ONE )
+ LSFMAX = INT( LOG10( SFMAX ) / BASL )
+ DO 360 I = ILO, IHI
+ IRAB = IDAMAX( N-ILO+1, A( I, ILO ), LDA )
+ RAB = ABS( A( I, IRAB+ILO-1 ) )
+ IRAB = IDAMAX( N-ILO+1, B( I, ILO ), LDB )
+ RAB = MAX( RAB, ABS( B( I, IRAB+ILO-1 ) ) )
+ LRAB = INT( LOG10( RAB+SFMIN ) / BASL+ONE )
+ IR = LSCALE( I ) + SIGN( HALF, LSCALE( I ) )
+ IR = MIN( MAX( IR, LSFMIN ), LSFMAX, LSFMAX-LRAB )
+ LSCALE( I ) = SCLFAC**IR
+ ICAB = IDAMAX( IHI, A( 1, I ), 1 )
+ CAB = ABS( A( ICAB, I ) )
+ ICAB = IDAMAX( IHI, B( 1, I ), 1 )
+ CAB = MAX( CAB, ABS( B( ICAB, I ) ) )
+ LCAB = INT( LOG10( CAB+SFMIN ) / BASL+ONE )
+ JC = RSCALE( I ) + SIGN( HALF, RSCALE( I ) )
+ JC = MIN( MAX( JC, LSFMIN ), LSFMAX, LSFMAX-LCAB )
+ RSCALE( I ) = SCLFAC**JC
+ 360 CONTINUE
+*
+* Row scaling of matrices A and B
+*
+ DO 370 I = ILO, IHI
+ CALL DSCAL( N-ILO+1, LSCALE( I ), A( I, ILO ), LDA )
+ CALL DSCAL( N-ILO+1, LSCALE( I ), B( I, ILO ), LDB )
+ 370 CONTINUE
+*
+* Column scaling of matrices A and B
+*
+ DO 380 J = ILO, IHI
+ CALL DSCAL( IHI, RSCALE( J ), A( 1, J ), 1 )
+ CALL DSCAL( IHI, RSCALE( J ), B( 1, J ), 1 )
+ 380 CONTINUE
+*
+ RETURN
+*
+* End of DGGBAL
+*
+ END
+ SUBROUTINE DGGES( JOBVSL, JOBVSR, SORT, SELCTG, N, A, LDA, B, LDB,
+ $ SDIM, ALPHAR, ALPHAI, BETA, VSL, LDVSL, VSR,
+ $ LDVSR, WORK, LWORK, BWORK, INFO )
+*
+* -- LAPACK driver routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER JOBVSL, JOBVSR, SORT
+ INTEGER INFO, LDA, LDB, LDVSL, LDVSR, LWORK, N, SDIM
+* ..
+* .. Array Arguments ..
+ LOGICAL BWORK( * )
+ DOUBLE PRECISION A( LDA, * ), ALPHAI( * ), ALPHAR( * ),
+ $ B( LDB, * ), BETA( * ), VSL( LDVSL, * ),
+ $ VSR( LDVSR, * ), WORK( * )
+* ..
+* .. Function Arguments ..
+ LOGICAL SELCTG
+ EXTERNAL SELCTG
+* ..
+*
+* Purpose
+* =======
+*
+* DGGES computes for a pair of N-by-N real nonsymmetric matrices (A,B),
+* the generalized eigenvalues, the generalized real Schur form (S,T),
+* optionally, the left and/or right matrices of Schur vectors (VSL and
+* VSR). This gives the generalized Schur factorization
+*
+* (A,B) = ( (VSL)*S*(VSR)**T, (VSL)*T*(VSR)**T )
+*
+* Optionally, it also orders the eigenvalues so that a selected cluster
+* of eigenvalues appears in the leading diagonal blocks of the upper
+* quasi-triangular matrix S and the upper triangular matrix T.The
+* leading columns of VSL and VSR then form an orthonormal basis for the
+* corresponding left and right eigenspaces (deflating subspaces).
+*
+* (If only the generalized eigenvalues are needed, use the driver
+* DGGEV instead, which is faster.)
+*
+* A generalized eigenvalue for a pair of matrices (A,B) is a scalar w
+* or a ratio alpha/beta = w, such that A - w*B is singular. It is
+* usually represented as the pair (alpha,beta), as there is a
+* reasonable interpretation for beta=0 or both being zero.
+*
+* A pair of matrices (S,T) is in generalized real Schur form if T is
+* upper triangular with non-negative diagonal and S is block upper
+* triangular with 1-by-1 and 2-by-2 blocks. 1-by-1 blocks correspond
+* to real generalized eigenvalues, while 2-by-2 blocks of S will be
+* "standardized" by making the corresponding elements of T have the
+* form:
+* [ a 0 ]
+* [ 0 b ]
+*
+* and the pair of corresponding 2-by-2 blocks in S and T will have a
+* complex conjugate pair of generalized eigenvalues.
+*
+*
+* Arguments
+* =========
+*
+* JOBVSL (input) CHARACTER*1
+* = 'N': do not compute the left Schur vectors;
+* = 'V': compute the left Schur vectors.
+*
+* JOBVSR (input) CHARACTER*1
+* = 'N': do not compute the right Schur vectors;
+* = 'V': compute the right Schur vectors.
+*
+* SORT (input) CHARACTER*1
+* Specifies whether or not to order the eigenvalues on the
+* diagonal of the generalized Schur form.
+* = 'N': Eigenvalues are not ordered;
+* = 'S': Eigenvalues are ordered (see SELCTG);
+*
+* SELCTG (external procedure) LOGICAL FUNCTION of three DOUBLE PRECISION arguments
+* SELCTG must be declared EXTERNAL in the calling subroutine.
+* If SORT = 'N', SELCTG is not referenced.
+* If SORT = 'S', SELCTG is used to select eigenvalues to sort
+* to the top left of the Schur form.
+* An eigenvalue (ALPHAR(j)+ALPHAI(j))/BETA(j) is selected if
+* SELCTG(ALPHAR(j),ALPHAI(j),BETA(j)) is true; i.e. if either
+* one of a complex conjugate pair of eigenvalues is selected,
+* then both complex eigenvalues are selected.
+*
+* Note that in the ill-conditioned case, a selected complex
+* eigenvalue may no longer satisfy SELCTG(ALPHAR(j),ALPHAI(j),
+* BETA(j)) = .TRUE. after ordering. INFO is to be set to N+2
+* in this case.
+*
+* N (input) INTEGER
+* The order of the matrices A, B, VSL, and VSR. N >= 0.
+*
+* A (input/output) DOUBLE PRECISION array, dimension (LDA, N)
+* On entry, the first of the pair of matrices.
+* On exit, A has been overwritten by its generalized Schur
+* form S.
+*
+* LDA (input) INTEGER
+* The leading dimension of A. LDA >= max(1,N).
+*
+* B (input/output) DOUBLE PRECISION array, dimension (LDB, N)
+* On entry, the second of the pair of matrices.
+* On exit, B has been overwritten by its generalized Schur
+* form T.
+*
+* LDB (input) INTEGER
+* The leading dimension of B. LDB >= max(1,N).
+*
+* SDIM (output) INTEGER
+* If SORT = 'N', SDIM = 0.
+* If SORT = 'S', SDIM = number of eigenvalues (after sorting)
+* for which SELCTG is true. (Complex conjugate pairs for which
+* SELCTG is true for either eigenvalue count as 2.)
+*
+* ALPHAR (output) DOUBLE PRECISION array, dimension (N)
+* ALPHAI (output) DOUBLE PRECISION array, dimension (N)
+* BETA (output) DOUBLE PRECISION array, dimension (N)
+* On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, will
+* be the generalized eigenvalues. ALPHAR(j) + ALPHAI(j)*i,
+* and BETA(j),j=1,...,N are the diagonals of the complex Schur
+* form (S,T) that would result if the 2-by-2 diagonal blocks of
+* the real Schur form of (A,B) were further reduced to
+* triangular form using 2-by-2 complex unitary transformations.
+* If ALPHAI(j) is zero, then the j-th eigenvalue is real; if
+* positive, then the j-th and (j+1)-st eigenvalues are a
+* complex conjugate pair, with ALPHAI(j+1) negative.
+*
+* Note: the quotients ALPHAR(j)/BETA(j) and ALPHAI(j)/BETA(j)
+* may easily over- or underflow, and BETA(j) may even be zero.
+* Thus, the user should avoid naively computing the ratio.
+* However, ALPHAR and ALPHAI will be always less than and
+* usually comparable with norm(A) in magnitude, and BETA always
+* less than and usually comparable with norm(B).
+*
+* VSL (output) DOUBLE PRECISION array, dimension (LDVSL,N)
+* If JOBVSL = 'V', VSL will contain the left Schur vectors.
+* Not referenced if JOBVSL = 'N'.
+*
+* LDVSL (input) INTEGER
+* The leading dimension of the matrix VSL. LDVSL >=1, and
+* if JOBVSL = 'V', LDVSL >= N.
+*
+* VSR (output) DOUBLE PRECISION array, dimension (LDVSR,N)
+* If JOBVSR = 'V', VSR will contain the right Schur vectors.
+* Not referenced if JOBVSR = 'N'.
+*
+* LDVSR (input) INTEGER
+* The leading dimension of the matrix VSR. LDVSR >= 1, and
+* if JOBVSR = 'V', LDVSR >= N.
+*
+* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
+* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+* LWORK (input) INTEGER
+* The dimension of the array WORK.
+* If N = 0, LWORK >= 1, else LWORK >= 8*N+16.
+* For good performance , LWORK must generally be larger.
+*
+* If LWORK = -1, then a workspace query is assumed; the routine
+* only calculates the optimal size of the WORK array, returns
+* this value as the first entry of the WORK array, and no error
+* message related to LWORK is issued by XERBLA.
+*
+* BWORK (workspace) LOGICAL array, dimension (N)
+* Not referenced if SORT = 'N'.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value.
+* = 1,...,N:
+* The QZ iteration failed. (A,B) are not in Schur
+* form, but ALPHAR(j), ALPHAI(j), and BETA(j) should
+* be correct for j=INFO+1,...,N.
+* > N: =N+1: other than QZ iteration failed in DHGEQZ.
+* =N+2: after reordering, roundoff changed values of
+* some complex eigenvalues so that leading
+* eigenvalues in the Generalized Schur form no
+* longer satisfy SELCTG=.TRUE. This could also
+* be caused due to scaling.
+* =N+3: reordering failed in DTGSEN.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL CURSL, ILASCL, ILBSCL, ILVSL, ILVSR, LASTSL,
+ $ LQUERY, LST2SL, WANTST
+ INTEGER I, ICOLS, IERR, IHI, IJOBVL, IJOBVR, ILEFT,
+ $ ILO, IP, IRIGHT, IROWS, ITAU, IWRK, MAXWRK,
+ $ MINWRK
+ DOUBLE PRECISION ANRM, ANRMTO, BIGNUM, BNRM, BNRMTO, EPS, PVSL,
+ $ PVSR, SAFMAX, SAFMIN, SMLNUM
+* ..
+* .. Local Arrays ..
+ INTEGER IDUM( 1 )
+ DOUBLE PRECISION DIF( 2 )
+* ..
+* .. External Subroutines ..
+ EXTERNAL DGEQRF, DGGBAK, DGGBAL, DGGHRD, DHGEQZ, DLABAD,
+ $ DLACPY, DLASCL, DLASET, DORGQR, DORMQR, DTGSEN,
+ $ XERBLA
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ILAENV
+ DOUBLE PRECISION DLAMCH, DLANGE
+ EXTERNAL LSAME, ILAENV, DLAMCH, DLANGE
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, SQRT
+* ..
+* .. Executable Statements ..
+*
+* Decode the input arguments
+*
+ IF( LSAME( JOBVSL, 'N' ) ) THEN
+ IJOBVL = 1
+ ILVSL = .FALSE.
+ ELSE IF( LSAME( JOBVSL, 'V' ) ) THEN
+ IJOBVL = 2
+ ILVSL = .TRUE.
+ ELSE
+ IJOBVL = -1
+ ILVSL = .FALSE.
+ END IF
+*
+ IF( LSAME( JOBVSR, 'N' ) ) THEN
+ IJOBVR = 1
+ ILVSR = .FALSE.
+ ELSE IF( LSAME( JOBVSR, 'V' ) ) THEN
+ IJOBVR = 2
+ ILVSR = .TRUE.
+ ELSE
+ IJOBVR = -1
+ ILVSR = .FALSE.
+ END IF
+*
+ WANTST = LSAME( SORT, 'S' )
+*
+* Test the input arguments
+*
+ INFO = 0
+ LQUERY = ( LWORK.EQ.-1 )
+ IF( IJOBVL.LE.0 ) THEN
+ INFO = -1
+ ELSE IF( IJOBVR.LE.0 ) THEN
+ INFO = -2
+ ELSE IF( ( .NOT.WANTST ) .AND. ( .NOT.LSAME( SORT, 'N' ) ) ) THEN
+ INFO = -3
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -5
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -7
+ ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -9
+ ELSE IF( LDVSL.LT.1 .OR. ( ILVSL .AND. LDVSL.LT.N ) ) THEN
+ INFO = -15
+ ELSE IF( LDVSR.LT.1 .OR. ( ILVSR .AND. LDVSR.LT.N ) ) THEN
+ INFO = -17
+ END IF
+*
+* Compute workspace
+* (Note: Comments in the code beginning "Workspace:" describe the
+* minimal amount of workspace needed at that point in the code,
+* as well as the preferred amount for good performance.
+* NB refers to the optimal block size for the immediately
+* following subroutine, as returned by ILAENV.)
+*
+ IF( INFO.EQ.0 ) THEN
+ IF( N.GT.0 )THEN
+ MINWRK = MAX( 8*N, 6*N + 16 )
+ MAXWRK = MINWRK - N +
+ $ N*ILAENV( 1, 'DGEQRF', ' ', N, 1, N, 0 )
+ MAXWRK = MAX( MAXWRK, MINWRK - N +
+ $ N*ILAENV( 1, 'DORMQR', ' ', N, 1, N, -1 ) )
+ IF( ILVSL ) THEN
+ MAXWRK = MAX( MAXWRK, MINWRK - N +
+ $ N*ILAENV( 1, 'DORGQR', ' ', N, 1, N, -1 ) )
+ END IF
+ ELSE
+ MINWRK = 1
+ MAXWRK = 1
+ END IF
+ WORK( 1 ) = MAXWRK
+*
+ IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY )
+ $ INFO = -19
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DGGES ', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 ) THEN
+ SDIM = 0
+ RETURN
+ END IF
+*
+* Get machine constants
+*
+ EPS = DLAMCH( 'P' )
+ SAFMIN = DLAMCH( 'S' )
+ SAFMAX = ONE / SAFMIN
+ CALL DLABAD( SAFMIN, SAFMAX )
+ SMLNUM = SQRT( SAFMIN ) / EPS
+ BIGNUM = ONE / SMLNUM
+*
+* Scale A if max element outside range [SMLNUM,BIGNUM]
+*
+ ANRM = DLANGE( 'M', N, N, A, LDA, WORK )
+ ILASCL = .FALSE.
+ IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
+ ANRMTO = SMLNUM
+ ILASCL = .TRUE.
+ ELSE IF( ANRM.GT.BIGNUM ) THEN
+ ANRMTO = BIGNUM
+ ILASCL = .TRUE.
+ END IF
+ IF( ILASCL )
+ $ CALL DLASCL( 'G', 0, 0, ANRM, ANRMTO, N, N, A, LDA, IERR )
+*
+* Scale B if max element outside range [SMLNUM,BIGNUM]
+*
+ BNRM = DLANGE( 'M', N, N, B, LDB, WORK )
+ ILBSCL = .FALSE.
+ IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN
+ BNRMTO = SMLNUM
+ ILBSCL = .TRUE.
+ ELSE IF( BNRM.GT.BIGNUM ) THEN
+ BNRMTO = BIGNUM
+ ILBSCL = .TRUE.
+ END IF
+ IF( ILBSCL )
+ $ CALL DLASCL( 'G', 0, 0, BNRM, BNRMTO, N, N, B, LDB, IERR )
+*
+* Permute the matrix to make it more nearly triangular
+* (Workspace: need 6*N + 2*N space for storing balancing factors)
+*
+ ILEFT = 1
+ IRIGHT = N + 1
+ IWRK = IRIGHT + N
+ CALL DGGBAL( 'P', N, A, LDA, B, LDB, ILO, IHI, WORK( ILEFT ),
+ $ WORK( IRIGHT ), WORK( IWRK ), IERR )
+*
+* Reduce B to triangular form (QR decomposition of B)
+* (Workspace: need N, prefer N*NB)
+*
+ IROWS = IHI + 1 - ILO
+ ICOLS = N + 1 - ILO
+ ITAU = IWRK
+ IWRK = ITAU + IROWS
+ CALL DGEQRF( IROWS, ICOLS, B( ILO, ILO ), LDB, WORK( ITAU ),
+ $ WORK( IWRK ), LWORK+1-IWRK, IERR )
+*
+* Apply the orthogonal transformation to matrix A
+* (Workspace: need N, prefer N*NB)
+*
+ CALL DORMQR( 'L', 'T', IROWS, ICOLS, IROWS, B( ILO, ILO ), LDB,
+ $ WORK( ITAU ), A( ILO, ILO ), LDA, WORK( IWRK ),
+ $ LWORK+1-IWRK, IERR )
+*
+* Initialize VSL
+* (Workspace: need N, prefer N*NB)
+*
+ IF( ILVSL ) THEN
+ CALL DLASET( 'Full', N, N, ZERO, ONE, VSL, LDVSL )
+ IF( IROWS.GT.1 ) THEN
+ CALL DLACPY( 'L', IROWS-1, IROWS-1, B( ILO+1, ILO ), LDB,
+ $ VSL( ILO+1, ILO ), LDVSL )
+ END IF
+ CALL DORGQR( IROWS, IROWS, IROWS, VSL( ILO, ILO ), LDVSL,
+ $ WORK( ITAU ), WORK( IWRK ), LWORK+1-IWRK, IERR )
+ END IF
+*
+* Initialize VSR
+*
+ IF( ILVSR )
+ $ CALL DLASET( 'Full', N, N, ZERO, ONE, VSR, LDVSR )
+*
+* Reduce to generalized Hessenberg form
+* (Workspace: none needed)
+*
+ CALL DGGHRD( JOBVSL, JOBVSR, N, ILO, IHI, A, LDA, B, LDB, VSL,
+ $ LDVSL, VSR, LDVSR, IERR )
+*
+* Perform QZ algorithm, computing Schur vectors if desired
+* (Workspace: need N)
+*
+ IWRK = ITAU
+ CALL DHGEQZ( 'S', JOBVSL, JOBVSR, N, ILO, IHI, A, LDA, B, LDB,
+ $ ALPHAR, ALPHAI, BETA, VSL, LDVSL, VSR, LDVSR,
+ $ WORK( IWRK ), LWORK+1-IWRK, IERR )
+ IF( IERR.NE.0 ) THEN
+ IF( IERR.GT.0 .AND. IERR.LE.N ) THEN
+ INFO = IERR
+ ELSE IF( IERR.GT.N .AND. IERR.LE.2*N ) THEN
+ INFO = IERR - N
+ ELSE
+ INFO = N + 1
+ END IF
+ GO TO 50
+ END IF
+*
+* Sort eigenvalues ALPHA/BETA if desired
+* (Workspace: need 4*N+16 )
+*
+ SDIM = 0
+ IF( WANTST ) THEN
+*
+* Undo scaling on eigenvalues before SELCTGing
+*
+ IF( ILASCL ) THEN
+ CALL DLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHAR, N,
+ $ IERR )
+ CALL DLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHAI, N,
+ $ IERR )
+ END IF
+ IF( ILBSCL )
+ $ CALL DLASCL( 'G', 0, 0, BNRMTO, BNRM, N, 1, BETA, N, IERR )
+*
+* Select eigenvalues
+*
+ DO 10 I = 1, N
+ BWORK( I ) = SELCTG( ALPHAR( I ), ALPHAI( I ), BETA( I ) )
+ 10 CONTINUE
+*
+ CALL DTGSEN( 0, ILVSL, ILVSR, BWORK, N, A, LDA, B, LDB, ALPHAR,
+ $ ALPHAI, BETA, VSL, LDVSL, VSR, LDVSR, SDIM, PVSL,
+ $ PVSR, DIF, WORK( IWRK ), LWORK-IWRK+1, IDUM, 1,
+ $ IERR )
+ IF( IERR.EQ.1 )
+ $ INFO = N + 3
+*
+ END IF
+*
+* Apply back-permutation to VSL and VSR
+* (Workspace: none needed)
+*
+ IF( ILVSL )
+ $ CALL DGGBAK( 'P', 'L', N, ILO, IHI, WORK( ILEFT ),
+ $ WORK( IRIGHT ), N, VSL, LDVSL, IERR )
+*
+ IF( ILVSR )
+ $ CALL DGGBAK( 'P', 'R', N, ILO, IHI, WORK( ILEFT ),
+ $ WORK( IRIGHT ), N, VSR, LDVSR, IERR )
+*
+* Check if unscaling would cause over/underflow, if so, rescale
+* (ALPHAR(I),ALPHAI(I),BETA(I)) so BETA(I) is on the order of
+* B(I,I) and ALPHAR(I) and ALPHAI(I) are on the order of A(I,I)
+*
+ IF( ILASCL ) THEN
+ DO 20 I = 1, N
+ IF( ALPHAI( I ).NE.ZERO ) THEN
+ IF( ( ALPHAR( I ) / SAFMAX ).GT.( ANRMTO / ANRM ) .OR.
+ $ ( SAFMIN / ALPHAR( I ) ).GT.( ANRM / ANRMTO ) ) THEN
+ WORK( 1 ) = ABS( A( I, I ) / ALPHAR( I ) )
+ BETA( I ) = BETA( I )*WORK( 1 )
+ ALPHAR( I ) = ALPHAR( I )*WORK( 1 )
+ ALPHAI( I ) = ALPHAI( I )*WORK( 1 )
+ ELSE IF( ( ALPHAI( I ) / SAFMAX ).GT.
+ $ ( ANRMTO / ANRM ) .OR.
+ $ ( SAFMIN / ALPHAI( I ) ).GT.( ANRM / ANRMTO ) )
+ $ THEN
+ WORK( 1 ) = ABS( A( I, I+1 ) / ALPHAI( I ) )
+ BETA( I ) = BETA( I )*WORK( 1 )
+ ALPHAR( I ) = ALPHAR( I )*WORK( 1 )
+ ALPHAI( I ) = ALPHAI( I )*WORK( 1 )
+ END IF
+ END IF
+ 20 CONTINUE
+ END IF
+*
+ IF( ILBSCL ) THEN
+ DO 30 I = 1, N
+ IF( ALPHAI( I ).NE.ZERO ) THEN
+ IF( ( BETA( I ) / SAFMAX ).GT.( BNRMTO / BNRM ) .OR.
+ $ ( SAFMIN / BETA( I ) ).GT.( BNRM / BNRMTO ) ) THEN
+ WORK( 1 ) = ABS( B( I, I ) / BETA( I ) )
+ BETA( I ) = BETA( I )*WORK( 1 )
+ ALPHAR( I ) = ALPHAR( I )*WORK( 1 )
+ ALPHAI( I ) = ALPHAI( I )*WORK( 1 )
+ END IF
+ END IF
+ 30 CONTINUE
+ END IF
+*
+* Undo scaling
+*
+ IF( ILASCL ) THEN
+ CALL DLASCL( 'H', 0, 0, ANRMTO, ANRM, N, N, A, LDA, IERR )
+ CALL DLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHAR, N, IERR )
+ CALL DLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHAI, N, IERR )
+ END IF
+*
+ IF( ILBSCL ) THEN
+ CALL DLASCL( 'U', 0, 0, BNRMTO, BNRM, N, N, B, LDB, IERR )
+ CALL DLASCL( 'G', 0, 0, BNRMTO, BNRM, N, 1, BETA, N, IERR )
+ END IF
+*
+ IF( WANTST ) THEN
+*
+* Check if reordering is correct
+*
+ LASTSL = .TRUE.
+ LST2SL = .TRUE.
+ SDIM = 0
+ IP = 0
+ DO 40 I = 1, N
+ CURSL = SELCTG( ALPHAR( I ), ALPHAI( I ), BETA( I ) )
+ IF( ALPHAI( I ).EQ.ZERO ) THEN
+ IF( CURSL )
+ $ SDIM = SDIM + 1
+ IP = 0
+ IF( CURSL .AND. .NOT.LASTSL )
+ $ INFO = N + 2
+ ELSE
+ IF( IP.EQ.1 ) THEN
+*
+* Last eigenvalue of conjugate pair
+*
+ CURSL = CURSL .OR. LASTSL
+ LASTSL = CURSL
+ IF( CURSL )
+ $ SDIM = SDIM + 2
+ IP = -1
+ IF( CURSL .AND. .NOT.LST2SL )
+ $ INFO = N + 2
+ ELSE
+*
+* First eigenvalue of conjugate pair
+*
+ IP = 1
+ END IF
+ END IF
+ LST2SL = LASTSL
+ LASTSL = CURSL
+ 40 CONTINUE
+*
+ END IF
+*
+ 50 CONTINUE
+*
+ WORK( 1 ) = MAXWRK
+*
+ RETURN
+*
+* End of DGGES
+*
+ END
+ 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 )
+*
+* -- LAPACK driver routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER JOBVSL, JOBVSR, SENSE, SORT
+ INTEGER INFO, LDA, LDB, LDVSL, LDVSR, LIWORK, LWORK, N,
+ $ SDIM
+* ..
+* .. Array Arguments ..
+ LOGICAL BWORK( * )
+ INTEGER IWORK( * )
+ DOUBLE PRECISION A( LDA, * ), ALPHAI( * ), ALPHAR( * ),
+ $ B( LDB, * ), BETA( * ), RCONDE( 2 ),
+ $ RCONDV( 2 ), VSL( LDVSL, * ), VSR( LDVSR, * ),
+ $ WORK( * )
+* ..
+* .. Function Arguments ..
+ LOGICAL SELCTG
+ EXTERNAL SELCTG
+* ..
+*
+* Purpose
+* =======
+*
+* DGGESX computes for a pair of N-by-N real nonsymmetric matrices
+* (A,B), the generalized eigenvalues, the real Schur form (S,T), and,
+* optionally, the left and/or right matrices of Schur vectors (VSL and
+* VSR). This gives the generalized Schur factorization
+*
+* (A,B) = ( (VSL) S (VSR)**T, (VSL) T (VSR)**T )
+*
+* Optionally, it also orders the eigenvalues so that a selected cluster
+* of eigenvalues appears in the leading diagonal blocks of the upper
+* quasi-triangular matrix S and the upper triangular matrix T; computes
+* a reciprocal condition number for the average of the selected
+* eigenvalues (RCONDE); and computes a reciprocal condition number for
+* the right and left deflating subspaces corresponding to the selected
+* eigenvalues (RCONDV). The leading columns of VSL and VSR then form
+* an orthonormal basis for the corresponding left and right eigenspaces
+* (deflating subspaces).
+*
+* A generalized eigenvalue for a pair of matrices (A,B) is a scalar w
+* or a ratio alpha/beta = w, such that A - w*B is singular. It is
+* usually represented as the pair (alpha,beta), as there is a
+* reasonable interpretation for beta=0 or for both being zero.
+*
+* A pair of matrices (S,T) is in generalized real Schur form if T is
+* upper triangular with non-negative diagonal and S is block upper
+* triangular with 1-by-1 and 2-by-2 blocks. 1-by-1 blocks correspond
+* to real generalized eigenvalues, while 2-by-2 blocks of S will be
+* "standardized" by making the corresponding elements of T have the
+* form:
+* [ a 0 ]
+* [ 0 b ]
+*
+* and the pair of corresponding 2-by-2 blocks in S and T will have a
+* complex conjugate pair of generalized eigenvalues.
+*
+*
+* Arguments
+* =========
+*
+* JOBVSL (input) CHARACTER*1
+* = 'N': do not compute the left Schur vectors;
+* = 'V': compute the left Schur vectors.
+*
+* JOBVSR (input) CHARACTER*1
+* = 'N': do not compute the right Schur vectors;
+* = 'V': compute the right Schur vectors.
+*
+* SORT (input) CHARACTER*1
+* Specifies whether or not to order the eigenvalues on the
+* diagonal of the generalized Schur form.
+* = 'N': Eigenvalues are not ordered;
+* = 'S': Eigenvalues are ordered (see SELCTG).
+*
+* SELCTG (external procedure) LOGICAL FUNCTION of three DOUBLE PRECISION arguments
+* SELCTG must be declared EXTERNAL in the calling subroutine.
+* If SORT = 'N', SELCTG is not referenced.
+* If SORT = 'S', SELCTG is used to select eigenvalues to sort
+* to the top left of the Schur form.
+* An eigenvalue (ALPHAR(j)+ALPHAI(j))/BETA(j) is selected if
+* SELCTG(ALPHAR(j),ALPHAI(j),BETA(j)) is true; i.e. if either
+* one of a complex conjugate pair of eigenvalues is selected,
+* then both complex eigenvalues are selected.
+* Note that a selected complex eigenvalue may no longer satisfy
+* SELCTG(ALPHAR(j),ALPHAI(j),BETA(j)) = .TRUE. after ordering,
+* since ordering may change the value of complex eigenvalues
+* (especially if the eigenvalue is ill-conditioned), in this
+* case INFO is set to N+3.
+*
+* SENSE (input) CHARACTER*1
+* Determines which reciprocal condition numbers are computed.
+* = 'N' : None are computed;
+* = 'E' : Computed for average of selected eigenvalues only;
+* = 'V' : Computed for selected deflating subspaces only;
+* = 'B' : Computed for both.
+* If SENSE = 'E', 'V', or 'B', SORT must equal 'S'.
+*
+* N (input) INTEGER
+* The order of the matrices A, B, VSL, and VSR. N >= 0.
+*
+* A (input/output) DOUBLE PRECISION array, dimension (LDA, N)
+* On entry, the first of the pair of matrices.
+* On exit, A has been overwritten by its generalized Schur
+* form S.
+*
+* LDA (input) INTEGER
+* The leading dimension of A. LDA >= max(1,N).
+*
+* B (input/output) DOUBLE PRECISION array, dimension (LDB, N)
+* On entry, the second of the pair of matrices.
+* On exit, B has been overwritten by its generalized Schur
+* form T.
+*
+* LDB (input) INTEGER
+* The leading dimension of B. LDB >= max(1,N).
+*
+* SDIM (output) INTEGER
+* If SORT = 'N', SDIM = 0.
+* If SORT = 'S', SDIM = number of eigenvalues (after sorting)
+* for which SELCTG is true. (Complex conjugate pairs for which
+* SELCTG is true for either eigenvalue count as 2.)
+*
+* ALPHAR (output) DOUBLE PRECISION array, dimension (N)
+* ALPHAI (output) DOUBLE PRECISION array, dimension (N)
+* BETA (output) DOUBLE PRECISION array, dimension (N)
+* On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, will
+* be the generalized eigenvalues. ALPHAR(j) + ALPHAI(j)*i
+* and BETA(j),j=1,...,N are the diagonals of the complex Schur
+* form (S,T) that would result if the 2-by-2 diagonal blocks of
+* the real Schur form of (A,B) were further reduced to
+* triangular form using 2-by-2 complex unitary transformations.
+* If ALPHAI(j) is zero, then the j-th eigenvalue is real; if
+* positive, then the j-th and (j+1)-st eigenvalues are a
+* complex conjugate pair, with ALPHAI(j+1) negative.
+*
+* Note: the quotients ALPHAR(j)/BETA(j) and ALPHAI(j)/BETA(j)
+* may easily over- or underflow, and BETA(j) may even be zero.
+* Thus, the user should avoid naively computing the ratio.
+* However, ALPHAR and ALPHAI will be always less than and
+* usually comparable with norm(A) in magnitude, and BETA always
+* less than and usually comparable with norm(B).
+*
+* VSL (output) DOUBLE PRECISION array, dimension (LDVSL,N)
+* If JOBVSL = 'V', VSL will contain the left Schur vectors.
+* Not referenced if JOBVSL = 'N'.
+*
+* LDVSL (input) INTEGER
+* The leading dimension of the matrix VSL. LDVSL >=1, and
+* if JOBVSL = 'V', LDVSL >= N.
+*
+* VSR (output) DOUBLE PRECISION array, dimension (LDVSR,N)
+* If JOBVSR = 'V', VSR will contain the right Schur vectors.
+* Not referenced if JOBVSR = 'N'.
+*
+* LDVSR (input) INTEGER
+* The leading dimension of the matrix VSR. LDVSR >= 1, and
+* if JOBVSR = 'V', LDVSR >= N.
+*
+* RCONDE (output) DOUBLE PRECISION array, dimension ( 2 )
+* If SENSE = 'E' or 'B', RCONDE(1) and RCONDE(2) contain the
+* reciprocal condition numbers for the average of the selected
+* eigenvalues.
+* Not referenced if SENSE = 'N' or 'V'.
+*
+* RCONDV (output) DOUBLE PRECISION array, dimension ( 2 )
+* If SENSE = 'V' or 'B', RCONDV(1) and RCONDV(2) contain the
+* reciprocal condition numbers for the selected deflating
+* subspaces.
+* Not referenced if SENSE = 'N' or 'E'.
+*
+* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
+* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+* LWORK (input) INTEGER
+* The dimension of the array WORK.
+* If N = 0, LWORK >= 1, else if SENSE = 'E', 'V', or 'B',
+* LWORK >= max( 8*N, 6*N+16, 2*SDIM*(N-SDIM) ), else
+* LWORK >= max( 8*N, 6*N+16 ).
+* Note that 2*SDIM*(N-SDIM) <= N*N/2.
+* Note also that an error is only returned if
+* LWORK < max( 8*N, 6*N+16), but if SENSE = 'E' or 'V' or 'B'
+* this may not be large enough.
+*
+* If LWORK = -1, then a workspace query is assumed; the routine
+* only calculates the bound on the optimal size of the WORK
+* array and the minimum size of the IWORK array, returns these
+* values as the first entries of the WORK and IWORK arrays, and
+* no error message related to LWORK or LIWORK is issued by
+* XERBLA.
+*
+* IWORK (workspace) INTEGER array, dimension (MAX(1,LIWORK))
+* On exit, if INFO = 0, IWORK(1) returns the minimum LIWORK.
+*
+* LIWORK (input) INTEGER
+* The dimension of the array IWORK.
+* If SENSE = 'N' or N = 0, LIWORK >= 1, otherwise
+* LIWORK >= N+6.
+*
+* If LIWORK = -1, then a workspace query is assumed; the
+* routine only calculates the bound on the optimal size of the
+* WORK array and the minimum size of the IWORK array, returns
+* these values as the first entries of the WORK and IWORK
+* arrays, and no error message related to LWORK or LIWORK is
+* issued by XERBLA.
+*
+* BWORK (workspace) LOGICAL array, dimension (N)
+* Not referenced if SORT = 'N'.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value.
+* = 1,...,N:
+* The QZ iteration failed. (A,B) are not in Schur
+* form, but ALPHAR(j), ALPHAI(j), and BETA(j) should
+* be correct for j=INFO+1,...,N.
+* > N: =N+1: other than QZ iteration failed in DHGEQZ
+* =N+2: after reordering, roundoff changed values of
+* some complex eigenvalues so that leading
+* eigenvalues in the Generalized Schur form no
+* longer satisfy SELCTG=.TRUE. This could also
+* be caused due to scaling.
+* =N+3: reordering failed in DTGSEN.
+*
+* Further details
+* ===============
+*
+* An approximate (asymptotic) bound on the average absolute error of
+* the selected eigenvalues is
+*
+* EPS * norm((A, B)) / RCONDE( 1 ).
+*
+* An approximate (asymptotic) bound on the maximum angular error in
+* the computed deflating subspaces is
+*
+* EPS * norm((A, B)) / RCONDV( 2 ).
+*
+* See LAPACK User's Guide, section 4.11 for more information.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL CURSL, ILASCL, ILBSCL, ILVSL, ILVSR, LASTSL,
+ $ LQUERY, LST2SL, WANTSB, WANTSE, WANTSN, WANTST,
+ $ WANTSV
+ INTEGER I, ICOLS, IERR, IHI, IJOB, IJOBVL, IJOBVR,
+ $ ILEFT, ILO, IP, IRIGHT, IROWS, ITAU, IWRK,
+ $ LIWMIN, LWRK, MAXWRK, MINWRK
+ DOUBLE PRECISION ANRM, ANRMTO, BIGNUM, BNRM, BNRMTO, EPS, PL,
+ $ PR, SAFMAX, SAFMIN, SMLNUM
+* ..
+* .. Local Arrays ..
+ DOUBLE PRECISION DIF( 2 )
+* ..
+* .. External Subroutines ..
+ EXTERNAL DGEQRF, DGGBAK, DGGBAL, DGGHRD, DHGEQZ, DLABAD,
+ $ DLACPY, DLASCL, DLASET, DORGQR, DORMQR, DTGSEN,
+ $ XERBLA
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ILAENV
+ DOUBLE PRECISION DLAMCH, DLANGE
+ EXTERNAL LSAME, ILAENV, DLAMCH, DLANGE
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, SQRT
+* ..
+* .. Executable Statements ..
+*
+* Decode the input arguments
+*
+ IF( LSAME( JOBVSL, 'N' ) ) THEN
+ IJOBVL = 1
+ ILVSL = .FALSE.
+ ELSE IF( LSAME( JOBVSL, 'V' ) ) THEN
+ IJOBVL = 2
+ ILVSL = .TRUE.
+ ELSE
+ IJOBVL = -1
+ ILVSL = .FALSE.
+ END IF
+*
+ IF( LSAME( JOBVSR, 'N' ) ) THEN
+ IJOBVR = 1
+ ILVSR = .FALSE.
+ ELSE IF( LSAME( JOBVSR, 'V' ) ) THEN
+ IJOBVR = 2
+ ILVSR = .TRUE.
+ ELSE
+ IJOBVR = -1
+ ILVSR = .FALSE.
+ END IF
+*
+ WANTST = LSAME( SORT, 'S' )
+ WANTSN = LSAME( SENSE, 'N' )
+ WANTSE = LSAME( SENSE, 'E' )
+ WANTSV = LSAME( SENSE, 'V' )
+ WANTSB = LSAME( SENSE, 'B' )
+ LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 )
+ IF( WANTSN ) THEN
+ IJOB = 0
+ ELSE IF( WANTSE ) THEN
+ IJOB = 1
+ ELSE IF( WANTSV ) THEN
+ IJOB = 2
+ ELSE IF( WANTSB ) THEN
+ IJOB = 4
+ END IF
+*
+* Test the input arguments
+*
+ INFO = 0
+ IF( IJOBVL.LE.0 ) THEN
+ INFO = -1
+ ELSE IF( IJOBVR.LE.0 ) THEN
+ INFO = -2
+ ELSE IF( ( .NOT.WANTST ) .AND. ( .NOT.LSAME( SORT, 'N' ) ) ) THEN
+ INFO = -3
+ ELSE IF( .NOT.( WANTSN .OR. WANTSE .OR. WANTSV .OR. WANTSB ) .OR.
+ $ ( .NOT.WANTST .AND. .NOT.WANTSN ) ) THEN
+ INFO = -5
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -6
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -8
+ ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -10
+ ELSE IF( LDVSL.LT.1 .OR. ( ILVSL .AND. LDVSL.LT.N ) ) THEN
+ INFO = -16
+ ELSE IF( LDVSR.LT.1 .OR. ( ILVSR .AND. LDVSR.LT.N ) ) THEN
+ INFO = -18
+ END IF
+*
+* Compute workspace
+* (Note: Comments in the code beginning "Workspace:" describe the
+* minimal amount of workspace needed at that point in the code,
+* as well as the preferred amount for good performance.
+* NB refers to the optimal block size for the immediately
+* following subroutine, as returned by ILAENV.)
+*
+ IF( INFO.EQ.0 ) THEN
+ IF( N.GT.0) THEN
+ MINWRK = MAX( 8*N, 6*N + 16 )
+ MAXWRK = MINWRK - N +
+ $ N*ILAENV( 1, 'DGEQRF', ' ', N, 1, N, 0 )
+ MAXWRK = MAX( MAXWRK, MINWRK - N +
+ $ N*ILAENV( 1, 'DORMQR', ' ', N, 1, N, -1 ) )
+ IF( ILVSL ) THEN
+ MAXWRK = MAX( MAXWRK, MINWRK - N +
+ $ N*ILAENV( 1, 'DORGQR', ' ', N, 1, N, -1 ) )
+ END IF
+ LWRK = MAXWRK
+ IF( IJOB.GE.1 )
+ $ LWRK = MAX( LWRK, N*N/2 )
+ ELSE
+ MINWRK = 1
+ MAXWRK = 1
+ LWRK = 1
+ END IF
+ WORK( 1 ) = LWRK
+ IF( WANTSN .OR. N.EQ.0 ) THEN
+ LIWMIN = 1
+ ELSE
+ LIWMIN = N + 6
+ END IF
+ IWORK( 1 ) = LIWMIN
+*
+ IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN
+ INFO = -22
+ ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN
+ INFO = -24
+ END IF
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DGGESX', -INFO )
+ RETURN
+ ELSE IF (LQUERY) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 ) THEN
+ SDIM = 0
+ RETURN
+ END IF
+*
+* Get machine constants
+*
+ EPS = DLAMCH( 'P' )
+ SAFMIN = DLAMCH( 'S' )
+ SAFMAX = ONE / SAFMIN
+ CALL DLABAD( SAFMIN, SAFMAX )
+ SMLNUM = SQRT( SAFMIN ) / EPS
+ BIGNUM = ONE / SMLNUM
+*
+* Scale A if max element outside range [SMLNUM,BIGNUM]
+*
+ ANRM = DLANGE( 'M', N, N, A, LDA, WORK )
+ ILASCL = .FALSE.
+ IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
+ ANRMTO = SMLNUM
+ ILASCL = .TRUE.
+ ELSE IF( ANRM.GT.BIGNUM ) THEN
+ ANRMTO = BIGNUM
+ ILASCL = .TRUE.
+ END IF
+ IF( ILASCL )
+ $ CALL DLASCL( 'G', 0, 0, ANRM, ANRMTO, N, N, A, LDA, IERR )
+*
+* Scale B if max element outside range [SMLNUM,BIGNUM]
+*
+ BNRM = DLANGE( 'M', N, N, B, LDB, WORK )
+ ILBSCL = .FALSE.
+ IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN
+ BNRMTO = SMLNUM
+ ILBSCL = .TRUE.
+ ELSE IF( BNRM.GT.BIGNUM ) THEN
+ BNRMTO = BIGNUM
+ ILBSCL = .TRUE.
+ END IF
+ IF( ILBSCL )
+ $ CALL DLASCL( 'G', 0, 0, BNRM, BNRMTO, N, N, B, LDB, IERR )
+*
+* Permute the matrix to make it more nearly triangular
+* (Workspace: need 6*N + 2*N for permutation parameters)
+*
+ ILEFT = 1
+ IRIGHT = N + 1
+ IWRK = IRIGHT + N
+ CALL DGGBAL( 'P', N, A, LDA, B, LDB, ILO, IHI, WORK( ILEFT ),
+ $ WORK( IRIGHT ), WORK( IWRK ), IERR )
+*
+* Reduce B to triangular form (QR decomposition of B)
+* (Workspace: need N, prefer N*NB)
+*
+ IROWS = IHI + 1 - ILO
+ ICOLS = N + 1 - ILO
+ ITAU = IWRK
+ IWRK = ITAU + IROWS
+ CALL DGEQRF( IROWS, ICOLS, B( ILO, ILO ), LDB, WORK( ITAU ),
+ $ WORK( IWRK ), LWORK+1-IWRK, IERR )
+*
+* Apply the orthogonal transformation to matrix A
+* (Workspace: need N, prefer N*NB)
+*
+ CALL DORMQR( 'L', 'T', IROWS, ICOLS, IROWS, B( ILO, ILO ), LDB,
+ $ WORK( ITAU ), A( ILO, ILO ), LDA, WORK( IWRK ),
+ $ LWORK+1-IWRK, IERR )
+*
+* Initialize VSL
+* (Workspace: need N, prefer N*NB)
+*
+ IF( ILVSL ) THEN
+ CALL DLASET( 'Full', N, N, ZERO, ONE, VSL, LDVSL )
+ IF( IROWS.GT.1 ) THEN
+ CALL DLACPY( 'L', IROWS-1, IROWS-1, B( ILO+1, ILO ), LDB,
+ $ VSL( ILO+1, ILO ), LDVSL )
+ END IF
+ CALL DORGQR( IROWS, IROWS, IROWS, VSL( ILO, ILO ), LDVSL,
+ $ WORK( ITAU ), WORK( IWRK ), LWORK+1-IWRK, IERR )
+ END IF
+*
+* Initialize VSR
+*
+ IF( ILVSR )
+ $ CALL DLASET( 'Full', N, N, ZERO, ONE, VSR, LDVSR )
+*
+* Reduce to generalized Hessenberg form
+* (Workspace: none needed)
+*
+ CALL DGGHRD( JOBVSL, JOBVSR, N, ILO, IHI, A, LDA, B, LDB, VSL,
+ $ LDVSL, VSR, LDVSR, IERR )
+*
+ SDIM = 0
+*
+* Perform QZ algorithm, computing Schur vectors if desired
+* (Workspace: need N)
+*
+ IWRK = ITAU
+ CALL DHGEQZ( 'S', JOBVSL, JOBVSR, N, ILO, IHI, A, LDA, B, LDB,
+ $ ALPHAR, ALPHAI, BETA, VSL, LDVSL, VSR, LDVSR,
+ $ WORK( IWRK ), LWORK+1-IWRK, IERR )
+ IF( IERR.NE.0 ) THEN
+ IF( IERR.GT.0 .AND. IERR.LE.N ) THEN
+ INFO = IERR
+ ELSE IF( IERR.GT.N .AND. IERR.LE.2*N ) THEN
+ INFO = IERR - N
+ ELSE
+ INFO = N + 1
+ END IF
+ GO TO 60
+ END IF
+*
+* Sort eigenvalues ALPHA/BETA and compute the reciprocal of
+* condition number(s)
+* (Workspace: If IJOB >= 1, need MAX( 8*(N+1), 2*SDIM*(N-SDIM) )
+* otherwise, need 8*(N+1) )
+*
+ IF( WANTST ) THEN
+*
+* Undo scaling on eigenvalues before SELCTGing
+*
+ IF( ILASCL ) THEN
+ CALL DLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHAR, N,
+ $ IERR )
+ CALL DLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHAI, N,
+ $ IERR )
+ END IF
+ IF( ILBSCL )
+ $ CALL DLASCL( 'G', 0, 0, BNRMTO, BNRM, N, 1, BETA, N, IERR )
+*
+* Select eigenvalues
+*
+ DO 10 I = 1, N
+ BWORK( I ) = SELCTG( ALPHAR( I ), ALPHAI( I ), BETA( I ) )
+ 10 CONTINUE
+*
+* Reorder eigenvalues, transform Generalized Schur vectors, and
+* compute reciprocal condition numbers
+*
+ CALL DTGSEN( IJOB, ILVSL, ILVSR, BWORK, N, A, LDA, B, LDB,
+ $ ALPHAR, ALPHAI, BETA, VSL, LDVSL, VSR, LDVSR,
+ $ SDIM, PL, PR, DIF, WORK( IWRK ), LWORK-IWRK+1,
+ $ IWORK, LIWORK, IERR )
+*
+ IF( IJOB.GE.1 )
+ $ MAXWRK = MAX( MAXWRK, 2*SDIM*( N-SDIM ) )
+ IF( IERR.EQ.-22 ) THEN
+*
+* not enough real workspace
+*
+ INFO = -22
+ ELSE
+ IF( IJOB.EQ.1 .OR. IJOB.EQ.4 ) THEN
+ RCONDE( 1 ) = PL
+ RCONDE( 2 ) = PR
+ END IF
+ IF( IJOB.EQ.2 .OR. IJOB.EQ.4 ) THEN
+ RCONDV( 1 ) = DIF( 1 )
+ RCONDV( 2 ) = DIF( 2 )
+ END IF
+ IF( IERR.EQ.1 )
+ $ INFO = N + 3
+ END IF
+*
+ END IF
+*
+* Apply permutation to VSL and VSR
+* (Workspace: none needed)
+*
+ IF( ILVSL )
+ $ CALL DGGBAK( 'P', 'L', N, ILO, IHI, WORK( ILEFT ),
+ $ WORK( IRIGHT ), N, VSL, LDVSL, IERR )
+*
+ IF( ILVSR )
+ $ CALL DGGBAK( 'P', 'R', N, ILO, IHI, WORK( ILEFT ),
+ $ WORK( IRIGHT ), N, VSR, LDVSR, IERR )
+*
+* Check if unscaling would cause over/underflow, if so, rescale
+* (ALPHAR(I),ALPHAI(I),BETA(I)) so BETA(I) is on the order of
+* B(I,I) and ALPHAR(I) and ALPHAI(I) are on the order of A(I,I)
+*
+ IF( ILASCL ) THEN
+ DO 20 I = 1, N
+ IF( ALPHAI( I ).NE.ZERO ) THEN
+ IF( ( ALPHAR( I ) / SAFMAX ).GT.( ANRMTO / ANRM ) .OR.
+ $ ( SAFMIN / ALPHAR( I ) ).GT.( ANRM / ANRMTO ) ) THEN
+ WORK( 1 ) = ABS( A( I, I ) / ALPHAR( I ) )
+ BETA( I ) = BETA( I )*WORK( 1 )
+ ALPHAR( I ) = ALPHAR( I )*WORK( 1 )
+ ALPHAI( I ) = ALPHAI( I )*WORK( 1 )
+ ELSE IF( ( ALPHAI( I ) / SAFMAX ).GT.
+ $ ( ANRMTO / ANRM ) .OR.
+ $ ( SAFMIN / ALPHAI( I ) ).GT.( ANRM / ANRMTO ) )
+ $ THEN
+ WORK( 1 ) = ABS( A( I, I+1 ) / ALPHAI( I ) )
+ BETA( I ) = BETA( I )*WORK( 1 )
+ ALPHAR( I ) = ALPHAR( I )*WORK( 1 )
+ ALPHAI( I ) = ALPHAI( I )*WORK( 1 )
+ END IF
+ END IF
+ 20 CONTINUE
+ END IF
+*
+ IF( ILBSCL ) THEN
+ DO 30 I = 1, N
+ IF( ALPHAI( I ).NE.ZERO ) THEN
+ IF( ( BETA( I ) / SAFMAX ).GT.( BNRMTO / BNRM ) .OR.
+ $ ( SAFMIN / BETA( I ) ).GT.( BNRM / BNRMTO ) ) THEN
+ WORK( 1 ) = ABS( B( I, I ) / BETA( I ) )
+ BETA( I ) = BETA( I )*WORK( 1 )
+ ALPHAR( I ) = ALPHAR( I )*WORK( 1 )
+ ALPHAI( I ) = ALPHAI( I )*WORK( 1 )
+ END IF
+ END IF
+ 30 CONTINUE
+ END IF
+*
+* Undo scaling
+*
+ IF( ILASCL ) THEN
+ CALL DLASCL( 'H', 0, 0, ANRMTO, ANRM, N, N, A, LDA, IERR )
+ CALL DLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHAR, N, IERR )
+ CALL DLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHAI, N, IERR )
+ END IF
+*
+ IF( ILBSCL ) THEN
+ CALL DLASCL( 'U', 0, 0, BNRMTO, BNRM, N, N, B, LDB, IERR )
+ CALL DLASCL( 'G', 0, 0, BNRMTO, BNRM, N, 1, BETA, N, IERR )
+ END IF
+*
+ IF( WANTST ) THEN
+*
+* Check if reordering is correct
+*
+ LASTSL = .TRUE.
+ LST2SL = .TRUE.
+ SDIM = 0
+ IP = 0
+ DO 50 I = 1, N
+ CURSL = SELCTG( ALPHAR( I ), ALPHAI( I ), BETA( I ) )
+ IF( ALPHAI( I ).EQ.ZERO ) THEN
+ IF( CURSL )
+ $ SDIM = SDIM + 1
+ IP = 0
+ IF( CURSL .AND. .NOT.LASTSL )
+ $ INFO = N + 2
+ ELSE
+ IF( IP.EQ.1 ) THEN
+*
+* Last eigenvalue of conjugate pair
+*
+ CURSL = CURSL .OR. LASTSL
+ LASTSL = CURSL
+ IF( CURSL )
+ $ SDIM = SDIM + 2
+ IP = -1
+ IF( CURSL .AND. .NOT.LST2SL )
+ $ INFO = N + 2
+ ELSE
+*
+* First eigenvalue of conjugate pair
+*
+ IP = 1
+ END IF
+ END IF
+ LST2SL = LASTSL
+ LASTSL = CURSL
+ 50 CONTINUE
+*
+ END IF
+*
+ 60 CONTINUE
+*
+ WORK( 1 ) = MAXWRK
+ IWORK( 1 ) = LIWMIN
+*
+ RETURN
+*
+* End of DGGESX
+*
+ END
+ SUBROUTINE DGGEV( JOBVL, JOBVR, N, A, LDA, B, LDB, ALPHAR, ALPHAI,
+ $ BETA, VL, LDVL, VR, LDVR, WORK, LWORK, INFO )
+*
+* -- LAPACK driver routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER JOBVL, JOBVR
+ INTEGER INFO, LDA, LDB, LDVL, LDVR, LWORK, N
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION A( LDA, * ), ALPHAI( * ), ALPHAR( * ),
+ $ B( LDB, * ), BETA( * ), VL( LDVL, * ),
+ $ VR( LDVR, * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DGGEV computes for a pair of N-by-N real nonsymmetric matrices (A,B)
+* the generalized eigenvalues, and optionally, the left and/or right
+* generalized eigenvectors.
+*
+* A generalized eigenvalue for a pair of matrices (A,B) is a scalar
+* lambda or a ratio alpha/beta = lambda, such that A - lambda*B is
+* singular. It is usually represented as the pair (alpha,beta), as
+* there is a reasonable interpretation for beta=0, and even for both
+* being zero.
+*
+* The right eigenvector v(j) corresponding to the eigenvalue lambda(j)
+* of (A,B) satisfies
+*
+* A * v(j) = lambda(j) * B * v(j).
+*
+* The left eigenvector u(j) corresponding to the eigenvalue lambda(j)
+* of (A,B) satisfies
+*
+* u(j)**H * A = lambda(j) * u(j)**H * B .
+*
+* where u(j)**H is the conjugate-transpose of u(j).
+*
+*
+* Arguments
+* =========
+*
+* JOBVL (input) CHARACTER*1
+* = 'N': do not compute the left generalized eigenvectors;
+* = 'V': compute the left generalized eigenvectors.
+*
+* JOBVR (input) CHARACTER*1
+* = 'N': do not compute the right generalized eigenvectors;
+* = 'V': compute the right generalized eigenvectors.
+*
+* N (input) INTEGER
+* The order of the matrices A, B, VL, and VR. N >= 0.
+*
+* A (input/output) DOUBLE PRECISION array, dimension (LDA, N)
+* On entry, the matrix A in the pair (A,B).
+* On exit, A has been overwritten.
+*
+* LDA (input) INTEGER
+* The leading dimension of A. LDA >= max(1,N).
+*
+* B (input/output) DOUBLE PRECISION array, dimension (LDB, N)
+* On entry, the matrix B in the pair (A,B).
+* On exit, B has been overwritten.
+*
+* LDB (input) INTEGER
+* The leading dimension of B. LDB >= max(1,N).
+*
+* ALPHAR (output) DOUBLE PRECISION array, dimension (N)
+* ALPHAI (output) DOUBLE PRECISION array, dimension (N)
+* BETA (output) DOUBLE PRECISION array, dimension (N)
+* On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, will
+* be the generalized eigenvalues. If ALPHAI(j) is zero, then
+* the j-th eigenvalue is real; if positive, then the j-th and
+* (j+1)-st eigenvalues are a complex conjugate pair, with
+* ALPHAI(j+1) negative.
+*
+* Note: the quotients ALPHAR(j)/BETA(j) and ALPHAI(j)/BETA(j)
+* may easily over- or underflow, and BETA(j) may even be zero.
+* Thus, the user should avoid naively computing the ratio
+* alpha/beta. However, ALPHAR and ALPHAI will be always less
+* than and usually comparable with norm(A) in magnitude, and
+* BETA always less than and usually comparable with norm(B).
+*
+* VL (output) DOUBLE PRECISION array, dimension (LDVL,N)
+* If JOBVL = 'V', the left eigenvectors u(j) are stored one
+* after another in the columns of VL, in the same order as
+* their eigenvalues. If the j-th eigenvalue is real, then
+* u(j) = VL(:,j), the j-th column of VL. If the j-th and
+* (j+1)-th eigenvalues form a complex conjugate pair, then
+* u(j) = VL(:,j)+i*VL(:,j+1) and u(j+1) = VL(:,j)-i*VL(:,j+1).
+* Each eigenvector is scaled so the largest component has
+* abs(real part)+abs(imag. part)=1.
+* Not referenced if JOBVL = 'N'.
+*
+* LDVL (input) INTEGER
+* The leading dimension of the matrix VL. LDVL >= 1, and
+* if JOBVL = 'V', LDVL >= N.
+*
+* VR (output) DOUBLE PRECISION array, dimension (LDVR,N)
+* If JOBVR = 'V', the right eigenvectors v(j) are stored one
+* after another in the columns of VR, in the same order as
+* their eigenvalues. If the j-th eigenvalue is real, then
+* v(j) = VR(:,j), the j-th column of VR. If the j-th and
+* (j+1)-th eigenvalues form a complex conjugate pair, then
+* v(j) = VR(:,j)+i*VR(:,j+1) and v(j+1) = VR(:,j)-i*VR(:,j+1).
+* Each eigenvector is scaled so the largest component has
+* abs(real part)+abs(imag. part)=1.
+* Not referenced if JOBVR = 'N'.
+*
+* LDVR (input) INTEGER
+* The leading dimension of the matrix VR. LDVR >= 1, and
+* if JOBVR = 'V', LDVR >= N.
+*
+* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
+* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+* LWORK (input) INTEGER
+* The dimension of the array WORK. LWORK >= max(1,8*N).
+* For good performance, LWORK must generally be larger.
+*
+* If LWORK = -1, then a workspace query is assumed; the routine
+* only calculates the optimal size of the WORK array, returns
+* this value as the first entry of the WORK array, and no error
+* message related to LWORK is issued by XERBLA.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value.
+* = 1,...,N:
+* The QZ iteration failed. No eigenvectors have been
+* calculated, but ALPHAR(j), ALPHAI(j), and BETA(j)
+* should be correct for j=INFO+1,...,N.
+* > N: =N+1: other than QZ iteration failed in DHGEQZ.
+* =N+2: error return from DTGEVC.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL ILASCL, ILBSCL, ILV, ILVL, ILVR, LQUERY
+ CHARACTER CHTEMP
+ INTEGER ICOLS, IERR, IHI, IJOBVL, IJOBVR, ILEFT, ILO,
+ $ IN, IRIGHT, IROWS, ITAU, IWRK, JC, JR, MAXWRK,
+ $ MINWRK
+ DOUBLE PRECISION ANRM, ANRMTO, BIGNUM, BNRM, BNRMTO, EPS,
+ $ SMLNUM, TEMP
+* ..
+* .. Local Arrays ..
+ LOGICAL LDUMMA( 1 )
+* ..
+* .. External Subroutines ..
+ EXTERNAL DGEQRF, DGGBAK, DGGBAL, DGGHRD, DHGEQZ, DLABAD,
+ $ DLACPY,DLASCL, DLASET, DORGQR, DORMQR, DTGEVC,
+ $ XERBLA
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ILAENV
+ DOUBLE PRECISION DLAMCH, DLANGE
+ EXTERNAL LSAME, ILAENV, DLAMCH, DLANGE
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, SQRT
+* ..
+* .. Executable Statements ..
+*
+* Decode the input arguments
+*
+ IF( LSAME( JOBVL, 'N' ) ) THEN
+ IJOBVL = 1
+ ILVL = .FALSE.
+ ELSE IF( LSAME( JOBVL, 'V' ) ) THEN
+ IJOBVL = 2
+ ILVL = .TRUE.
+ ELSE
+ IJOBVL = -1
+ ILVL = .FALSE.
+ END IF
+*
+ IF( LSAME( JOBVR, 'N' ) ) THEN
+ IJOBVR = 1
+ ILVR = .FALSE.
+ ELSE IF( LSAME( JOBVR, 'V' ) ) THEN
+ IJOBVR = 2
+ ILVR = .TRUE.
+ ELSE
+ IJOBVR = -1
+ ILVR = .FALSE.
+ END IF
+ ILV = ILVL .OR. ILVR
+*
+* Test the input arguments
+*
+ INFO = 0
+ LQUERY = ( LWORK.EQ.-1 )
+ IF( IJOBVL.LE.0 ) THEN
+ INFO = -1
+ ELSE IF( IJOBVR.LE.0 ) THEN
+ INFO = -2
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -5
+ ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -7
+ ELSE IF( LDVL.LT.1 .OR. ( ILVL .AND. LDVL.LT.N ) ) THEN
+ INFO = -12
+ ELSE IF( LDVR.LT.1 .OR. ( ILVR .AND. LDVR.LT.N ) ) THEN
+ INFO = -14
+ END IF
+*
+* Compute workspace
+* (Note: Comments in the code beginning "Workspace:" describe the
+* minimal amount of workspace needed at that point in the code,
+* as well as the preferred amount for good performance.
+* NB refers to the optimal block size for the immediately
+* following subroutine, as returned by ILAENV. The workspace is
+* computed assuming ILO = 1 and IHI = N, the worst case.)
+*
+ IF( INFO.EQ.0 ) THEN
+ MINWRK = MAX( 1, 8*N )
+ MAXWRK = MAX( 1, N*( 7 +
+ $ ILAENV( 1, 'DGEQRF', ' ', N, 1, N, 0 ) ) )
+ MAXWRK = MAX( MAXWRK, N*( 7 +
+ $ ILAENV( 1, 'DORMQR', ' ', N, 1, N, 0 ) ) )
+ IF( ILVL ) THEN
+ MAXWRK = MAX( MAXWRK, N*( 7 +
+ $ ILAENV( 1, 'DORGQR', ' ', N, 1, N, -1 ) ) )
+ END IF
+ WORK( 1 ) = MAXWRK
+*
+ IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY )
+ $ INFO = -16
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DGGEV ', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+* Get machine constants
+*
+ EPS = DLAMCH( 'P' )
+ SMLNUM = DLAMCH( 'S' )
+ BIGNUM = ONE / SMLNUM
+ CALL DLABAD( SMLNUM, BIGNUM )
+ SMLNUM = SQRT( SMLNUM ) / EPS
+ BIGNUM = ONE / SMLNUM
+*
+* Scale A if max element outside range [SMLNUM,BIGNUM]
+*
+ ANRM = DLANGE( 'M', N, N, A, LDA, WORK )
+ ILASCL = .FALSE.
+ IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
+ ANRMTO = SMLNUM
+ ILASCL = .TRUE.
+ ELSE IF( ANRM.GT.BIGNUM ) THEN
+ ANRMTO = BIGNUM
+ ILASCL = .TRUE.
+ END IF
+ IF( ILASCL )
+ $ CALL DLASCL( 'G', 0, 0, ANRM, ANRMTO, N, N, A, LDA, IERR )
+*
+* Scale B if max element outside range [SMLNUM,BIGNUM]
+*
+ BNRM = DLANGE( 'M', N, N, B, LDB, WORK )
+ ILBSCL = .FALSE.
+ IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN
+ BNRMTO = SMLNUM
+ ILBSCL = .TRUE.
+ ELSE IF( BNRM.GT.BIGNUM ) THEN
+ BNRMTO = BIGNUM
+ ILBSCL = .TRUE.
+ END IF
+ IF( ILBSCL )
+ $ CALL DLASCL( 'G', 0, 0, BNRM, BNRMTO, N, N, B, LDB, IERR )
+*
+* Permute the matrices A, B to isolate eigenvalues if possible
+* (Workspace: need 6*N)
+*
+ ILEFT = 1
+ IRIGHT = N + 1
+ IWRK = IRIGHT + N
+ CALL DGGBAL( 'P', N, A, LDA, B, LDB, ILO, IHI, WORK( ILEFT ),
+ $ WORK( IRIGHT ), WORK( IWRK ), IERR )
+*
+* Reduce B to triangular form (QR decomposition of B)
+* (Workspace: need N, prefer N*NB)
+*
+ IROWS = IHI + 1 - ILO
+ IF( ILV ) THEN
+ ICOLS = N + 1 - ILO
+ ELSE
+ ICOLS = IROWS
+ END IF
+ ITAU = IWRK
+ IWRK = ITAU + IROWS
+ CALL DGEQRF( IROWS, ICOLS, B( ILO, ILO ), LDB, WORK( ITAU ),
+ $ WORK( IWRK ), LWORK+1-IWRK, IERR )
+*
+* Apply the orthogonal transformation to matrix A
+* (Workspace: need N, prefer N*NB)
+*
+ CALL DORMQR( 'L', 'T', IROWS, ICOLS, IROWS, B( ILO, ILO ), LDB,
+ $ WORK( ITAU ), A( ILO, ILO ), LDA, WORK( IWRK ),
+ $ LWORK+1-IWRK, IERR )
+*
+* Initialize VL
+* (Workspace: need N, prefer N*NB)
+*
+ IF( ILVL ) THEN
+ CALL DLASET( 'Full', N, N, ZERO, ONE, VL, LDVL )
+ IF( IROWS.GT.1 ) THEN
+ CALL DLACPY( 'L', IROWS-1, IROWS-1, B( ILO+1, ILO ), LDB,
+ $ VL( ILO+1, ILO ), LDVL )
+ END IF
+ CALL DORGQR( IROWS, IROWS, IROWS, VL( ILO, ILO ), LDVL,
+ $ WORK( ITAU ), WORK( IWRK ), LWORK+1-IWRK, IERR )
+ END IF
+*
+* Initialize VR
+*
+ IF( ILVR )
+ $ CALL DLASET( 'Full', N, N, ZERO, ONE, VR, LDVR )
+*
+* Reduce to generalized Hessenberg form
+* (Workspace: none needed)
+*
+ IF( ILV ) THEN
+*
+* Eigenvectors requested -- work on whole matrix.
+*
+ CALL DGGHRD( JOBVL, JOBVR, N, ILO, IHI, A, LDA, B, LDB, VL,
+ $ LDVL, VR, LDVR, IERR )
+ ELSE
+ CALL DGGHRD( 'N', 'N', IROWS, 1, IROWS, A( ILO, ILO ), LDA,
+ $ B( ILO, ILO ), LDB, VL, LDVL, VR, LDVR, IERR )
+ END IF
+*
+* Perform QZ algorithm (Compute eigenvalues, and optionally, the
+* Schur forms and Schur vectors)
+* (Workspace: need N)
+*
+ IWRK = ITAU
+ IF( ILV ) THEN
+ CHTEMP = 'S'
+ ELSE
+ CHTEMP = 'E'
+ END IF
+ CALL DHGEQZ( CHTEMP, JOBVL, JOBVR, N, ILO, IHI, A, LDA, B, LDB,
+ $ ALPHAR, ALPHAI, BETA, VL, LDVL, VR, LDVR,
+ $ WORK( IWRK ), LWORK+1-IWRK, IERR )
+ IF( IERR.NE.0 ) THEN
+ IF( IERR.GT.0 .AND. IERR.LE.N ) THEN
+ INFO = IERR
+ ELSE IF( IERR.GT.N .AND. IERR.LE.2*N ) THEN
+ INFO = IERR - N
+ ELSE
+ INFO = N + 1
+ END IF
+ GO TO 110
+ END IF
+*
+* Compute Eigenvectors
+* (Workspace: need 6*N)
+*
+ IF( ILV ) THEN
+ IF( ILVL ) THEN
+ IF( ILVR ) THEN
+ CHTEMP = 'B'
+ ELSE
+ CHTEMP = 'L'
+ END IF
+ ELSE
+ CHTEMP = 'R'
+ END IF
+ CALL DTGEVC( CHTEMP, 'B', LDUMMA, N, A, LDA, B, LDB, VL, LDVL,
+ $ VR, LDVR, N, IN, WORK( IWRK ), IERR )
+ IF( IERR.NE.0 ) THEN
+ INFO = N + 2
+ GO TO 110
+ END IF
+*
+* Undo balancing on VL and VR and normalization
+* (Workspace: none needed)
+*
+ IF( ILVL ) THEN
+ CALL DGGBAK( 'P', 'L', N, ILO, IHI, WORK( ILEFT ),
+ $ WORK( IRIGHT ), N, VL, LDVL, IERR )
+ DO 50 JC = 1, N
+ IF( ALPHAI( JC ).LT.ZERO )
+ $ GO TO 50
+ TEMP = ZERO
+ IF( ALPHAI( JC ).EQ.ZERO ) THEN
+ DO 10 JR = 1, N
+ TEMP = MAX( TEMP, ABS( VL( JR, JC ) ) )
+ 10 CONTINUE
+ ELSE
+ DO 20 JR = 1, N
+ TEMP = MAX( TEMP, ABS( VL( JR, JC ) )+
+ $ ABS( VL( JR, JC+1 ) ) )
+ 20 CONTINUE
+ END IF
+ IF( TEMP.LT.SMLNUM )
+ $ GO TO 50
+ TEMP = ONE / TEMP
+ IF( ALPHAI( JC ).EQ.ZERO ) THEN
+ DO 30 JR = 1, N
+ VL( JR, JC ) = VL( JR, JC )*TEMP
+ 30 CONTINUE
+ ELSE
+ DO 40 JR = 1, N
+ VL( JR, JC ) = VL( JR, JC )*TEMP
+ VL( JR, JC+1 ) = VL( JR, JC+1 )*TEMP
+ 40 CONTINUE
+ END IF
+ 50 CONTINUE
+ END IF
+ IF( ILVR ) THEN
+ CALL DGGBAK( 'P', 'R', N, ILO, IHI, WORK( ILEFT ),
+ $ WORK( IRIGHT ), N, VR, LDVR, IERR )
+ DO 100 JC = 1, N
+ IF( ALPHAI( JC ).LT.ZERO )
+ $ GO TO 100
+ TEMP = ZERO
+ IF( ALPHAI( JC ).EQ.ZERO ) THEN
+ DO 60 JR = 1, N
+ TEMP = MAX( TEMP, ABS( VR( JR, JC ) ) )
+ 60 CONTINUE
+ ELSE
+ DO 70 JR = 1, N
+ TEMP = MAX( TEMP, ABS( VR( JR, JC ) )+
+ $ ABS( VR( JR, JC+1 ) ) )
+ 70 CONTINUE
+ END IF
+ IF( TEMP.LT.SMLNUM )
+ $ GO TO 100
+ TEMP = ONE / TEMP
+ IF( ALPHAI( JC ).EQ.ZERO ) THEN
+ DO 80 JR = 1, N
+ VR( JR, JC ) = VR( JR, JC )*TEMP
+ 80 CONTINUE
+ ELSE
+ DO 90 JR = 1, N
+ VR( JR, JC ) = VR( JR, JC )*TEMP
+ VR( JR, JC+1 ) = VR( JR, JC+1 )*TEMP
+ 90 CONTINUE
+ END IF
+ 100 CONTINUE
+ END IF
+*
+* End of eigenvector calculation
+*
+ END IF
+*
+* Undo scaling if necessary
+*
+ IF( ILASCL ) THEN
+ CALL DLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHAR, N, IERR )
+ CALL DLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHAI, N, IERR )
+ END IF
+*
+ IF( ILBSCL ) THEN
+ CALL DLASCL( 'G', 0, 0, BNRMTO, BNRM, N, 1, BETA, N, IERR )
+ END IF
+*
+ 110 CONTINUE
+*
+ WORK( 1 ) = MAXWRK
+*
+ RETURN
+*
+* End of DGGEV
+*
+ END
+ 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 )
+*
+* -- LAPACK driver routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER BALANC, JOBVL, JOBVR, SENSE
+ INTEGER IHI, ILO, INFO, LDA, LDB, LDVL, LDVR, LWORK, N
+ DOUBLE PRECISION ABNRM, BBNRM
+* ..
+* .. Array Arguments ..
+ LOGICAL BWORK( * )
+ INTEGER IWORK( * )
+ DOUBLE PRECISION A( LDA, * ), ALPHAI( * ), ALPHAR( * ),
+ $ B( LDB, * ), BETA( * ), LSCALE( * ),
+ $ RCONDE( * ), RCONDV( * ), RSCALE( * ),
+ $ VL( LDVL, * ), VR( LDVR, * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DGGEVX computes for a pair of N-by-N real nonsymmetric matrices (A,B)
+* the generalized eigenvalues, and optionally, the left and/or right
+* generalized eigenvectors.
+*
+* Optionally also, it computes a balancing transformation to improve
+* the conditioning of the eigenvalues and eigenvectors (ILO, IHI,
+* LSCALE, RSCALE, ABNRM, and BBNRM), reciprocal condition numbers for
+* the eigenvalues (RCONDE), and reciprocal condition numbers for the
+* right eigenvectors (RCONDV).
+*
+* A generalized eigenvalue for a pair of matrices (A,B) is a scalar
+* lambda or a ratio alpha/beta = lambda, such that A - lambda*B is
+* singular. It is usually represented as the pair (alpha,beta), as
+* there is a reasonable interpretation for beta=0, and even for both
+* being zero.
+*
+* The right eigenvector v(j) corresponding to the eigenvalue lambda(j)
+* of (A,B) satisfies
+*
+* A * v(j) = lambda(j) * B * v(j) .
+*
+* The left eigenvector u(j) corresponding to the eigenvalue lambda(j)
+* of (A,B) satisfies
+*
+* u(j)**H * A = lambda(j) * u(j)**H * B.
+*
+* where u(j)**H is the conjugate-transpose of u(j).
+*
+*
+* Arguments
+* =========
+*
+* BALANC (input) CHARACTER*1
+* Specifies the balance option to be performed.
+* = 'N': do not diagonally scale or permute;
+* = 'P': permute only;
+* = 'S': scale only;
+* = 'B': both permute and scale.
+* Computed reciprocal condition numbers will be for the
+* matrices after permuting and/or balancing. Permuting does
+* not change condition numbers (in exact arithmetic), but
+* balancing does.
+*
+* JOBVL (input) CHARACTER*1
+* = 'N': do not compute the left generalized eigenvectors;
+* = 'V': compute the left generalized eigenvectors.
+*
+* JOBVR (input) CHARACTER*1
+* = 'N': do not compute the right generalized eigenvectors;
+* = 'V': compute the right generalized eigenvectors.
+*
+* SENSE (input) CHARACTER*1
+* Determines which reciprocal condition numbers are computed.
+* = 'N': none are computed;
+* = 'E': computed for eigenvalues only;
+* = 'V': computed for eigenvectors only;
+* = 'B': computed for eigenvalues and eigenvectors.
+*
+* N (input) INTEGER
+* The order of the matrices A, B, VL, and VR. N >= 0.
+*
+* A (input/output) DOUBLE PRECISION array, dimension (LDA, N)
+* On entry, the matrix A in the pair (A,B).
+* On exit, A has been overwritten. If JOBVL='V' or JOBVR='V'
+* or both, then A contains the first part of the real Schur
+* form of the "balanced" versions of the input A and B.
+*
+* LDA (input) INTEGER
+* The leading dimension of A. LDA >= max(1,N).
+*
+* B (input/output) DOUBLE PRECISION array, dimension (LDB, N)
+* On entry, the matrix B in the pair (A,B).
+* On exit, B has been overwritten. If JOBVL='V' or JOBVR='V'
+* or both, then B contains the second part of the real Schur
+* form of the "balanced" versions of the input A and B.
+*
+* LDB (input) INTEGER
+* The leading dimension of B. LDB >= max(1,N).
+*
+* ALPHAR (output) DOUBLE PRECISION array, dimension (N)
+* ALPHAI (output) DOUBLE PRECISION array, dimension (N)
+* BETA (output) DOUBLE PRECISION array, dimension (N)
+* On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, will
+* be the generalized eigenvalues. If ALPHAI(j) is zero, then
+* the j-th eigenvalue is real; if positive, then the j-th and
+* (j+1)-st eigenvalues are a complex conjugate pair, with
+* ALPHAI(j+1) negative.
+*
+* Note: the quotients ALPHAR(j)/BETA(j) and ALPHAI(j)/BETA(j)
+* may easily over- or underflow, and BETA(j) may even be zero.
+* Thus, the user should avoid naively computing the ratio
+* ALPHA/BETA. However, ALPHAR and ALPHAI will be always less
+* than and usually comparable with norm(A) in magnitude, and
+* BETA always less than and usually comparable with norm(B).
+*
+* VL (output) DOUBLE PRECISION array, dimension (LDVL,N)
+* If JOBVL = 'V', the left eigenvectors u(j) are stored one
+* after another in the columns of VL, in the same order as
+* their eigenvalues. If the j-th eigenvalue is real, then
+* u(j) = VL(:,j), the j-th column of VL. If the j-th and
+* (j+1)-th eigenvalues form a complex conjugate pair, then
+* u(j) = VL(:,j)+i*VL(:,j+1) and u(j+1) = VL(:,j)-i*VL(:,j+1).
+* Each eigenvector will be scaled so the largest component have
+* abs(real part) + abs(imag. part) = 1.
+* Not referenced if JOBVL = 'N'.
+*
+* LDVL (input) INTEGER
+* The leading dimension of the matrix VL. LDVL >= 1, and
+* if JOBVL = 'V', LDVL >= N.
+*
+* VR (output) DOUBLE PRECISION array, dimension (LDVR,N)
+* If JOBVR = 'V', the right eigenvectors v(j) are stored one
+* after another in the columns of VR, in the same order as
+* their eigenvalues. If the j-th eigenvalue is real, then
+* v(j) = VR(:,j), the j-th column of VR. If the j-th and
+* (j+1)-th eigenvalues form a complex conjugate pair, then
+* v(j) = VR(:,j)+i*VR(:,j+1) and v(j+1) = VR(:,j)-i*VR(:,j+1).
+* Each eigenvector will be scaled so the largest component have
+* abs(real part) + abs(imag. part) = 1.
+* Not referenced if JOBVR = 'N'.
+*
+* LDVR (input) INTEGER
+* The leading dimension of the matrix VR. LDVR >= 1, and
+* if JOBVR = 'V', LDVR >= N.
+*
+* ILO (output) INTEGER
+* IHI (output) INTEGER
+* ILO and IHI are integer values such that on exit
+* A(i,j) = 0 and B(i,j) = 0 if i > j and
+* j = 1,...,ILO-1 or i = IHI+1,...,N.
+* If BALANC = 'N' or 'S', ILO = 1 and IHI = N.
+*
+* LSCALE (output) DOUBLE PRECISION array, dimension (N)
+* Details of the permutations and scaling factors applied
+* to the left side of A and B. If PL(j) is the index of the
+* row interchanged with row j, and DL(j) is the scaling
+* factor applied to row j, then
+* LSCALE(j) = PL(j) for j = 1,...,ILO-1
+* = DL(j) for j = ILO,...,IHI
+* = PL(j) for j = IHI+1,...,N.
+* The order in which the interchanges are made is N to IHI+1,
+* then 1 to ILO-1.
+*
+* RSCALE (output) DOUBLE PRECISION array, dimension (N)
+* Details of the permutations and scaling factors applied
+* to the right side of A and B. If PR(j) is the index of the
+* column interchanged with column j, and DR(j) is the scaling
+* factor applied to column j, then
+* RSCALE(j) = PR(j) for j = 1,...,ILO-1
+* = DR(j) for j = ILO,...,IHI
+* = PR(j) for j = IHI+1,...,N
+* The order in which the interchanges are made is N to IHI+1,
+* then 1 to ILO-1.
+*
+* ABNRM (output) DOUBLE PRECISION
+* The one-norm of the balanced matrix A.
+*
+* BBNRM (output) DOUBLE PRECISION
+* The one-norm of the balanced matrix B.
+*
+* RCONDE (output) DOUBLE PRECISION array, dimension (N)
+* If SENSE = 'E' or 'B', the reciprocal condition numbers of
+* the eigenvalues, stored in consecutive elements of the array.
+* For a complex conjugate pair of eigenvalues two consecutive
+* elements of RCONDE are set to the same value. Thus RCONDE(j),
+* RCONDV(j), and the j-th columns of VL and VR all correspond
+* to the j-th eigenpair.
+* If SENSE = 'N or 'V', RCONDE is not referenced.
+*
+* RCONDV (output) DOUBLE PRECISION array, dimension (N)
+* If SENSE = 'V' or 'B', the estimated reciprocal condition
+* numbers of the eigenvectors, stored in consecutive elements
+* of the array. For a complex eigenvector two consecutive
+* elements of RCONDV are set to the same value. If the
+* eigenvalues cannot be reordered to compute RCONDV(j),
+* RCONDV(j) is set to 0; this can only occur when the true
+* value would be very small anyway.
+* If SENSE = 'N' or 'E', RCONDV is not referenced.
+*
+* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
+* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+* LWORK (input) INTEGER
+* The dimension of the array WORK. LWORK >= max(1,2*N).
+* If BALANC = 'S' or 'B', or JOBVL = 'V', or JOBVR = 'V',
+* LWORK >= max(1,6*N).
+* If SENSE = 'E' or 'B', LWORK >= max(1,10*N).
+* If SENSE = 'V' or 'B', LWORK >= 2*N*N+8*N+16.
+*
+* If LWORK = -1, then a workspace query is assumed; the routine
+* only calculates the optimal size of the WORK array, returns
+* this value as the first entry of the WORK array, and no error
+* message related to LWORK is issued by XERBLA.
+*
+* IWORK (workspace) INTEGER array, dimension (N+6)
+* If SENSE = 'E', IWORK is not referenced.
+*
+* BWORK (workspace) LOGICAL array, dimension (N)
+* If SENSE = 'N', BWORK is not referenced.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value.
+* = 1,...,N:
+* The QZ iteration failed. No eigenvectors have been
+* calculated, but ALPHAR(j), ALPHAI(j), and BETA(j)
+* should be correct for j=INFO+1,...,N.
+* > N: =N+1: other than QZ iteration failed in DHGEQZ.
+* =N+2: error return from DTGEVC.
+*
+* Further Details
+* ===============
+*
+* Balancing a matrix pair (A,B) includes, first, permuting rows and
+* columns to isolate eigenvalues, second, applying diagonal similarity
+* transformation to the rows and columns to make the rows and columns
+* as close in norm as possible. The computed reciprocal condition
+* numbers correspond to the balanced matrix. Permuting rows and columns
+* will not change the condition numbers (in exact arithmetic) but
+* diagonal scaling will. For further explanation of balancing, see
+* section 4.11.1.2 of LAPACK Users' Guide.
+*
+* An approximate error bound on the chordal distance between the i-th
+* computed generalized eigenvalue w and the corresponding exact
+* eigenvalue lambda is
+*
+* chord(w, lambda) <= EPS * norm(ABNRM, BBNRM) / RCONDE(I)
+*
+* An approximate error bound for the angle between the i-th computed
+* eigenvector VL(i) or VR(i) is given by
+*
+* EPS * norm(ABNRM, BBNRM) / DIF(i).
+*
+* For further explanation of the reciprocal condition numbers RCONDE
+* and RCONDV, see section 4.11 of LAPACK User's Guide.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL ILASCL, ILBSCL, ILV, ILVL, ILVR, LQUERY, NOSCL,
+ $ PAIR, WANTSB, WANTSE, WANTSN, WANTSV
+ CHARACTER CHTEMP
+ INTEGER I, ICOLS, IERR, IJOBVL, IJOBVR, IN, IROWS,
+ $ ITAU, IWRK, IWRK1, J, JC, JR, M, MAXWRK,
+ $ MINWRK, MM
+ DOUBLE PRECISION ANRM, ANRMTO, BIGNUM, BNRM, BNRMTO, EPS,
+ $ SMLNUM, TEMP
+* ..
+* .. Local Arrays ..
+ LOGICAL LDUMMA( 1 )
+* ..
+* .. External Subroutines ..
+ EXTERNAL DGEQRF, DGGBAK, DGGBAL, DGGHRD, DHGEQZ, DLABAD,
+ $ DLACPY, DLASCL, DLASET, DORGQR, DORMQR, DTGEVC,
+ $ DTGSNA, XERBLA
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ILAENV
+ DOUBLE PRECISION DLAMCH, DLANGE
+ EXTERNAL LSAME, ILAENV, DLAMCH, DLANGE
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, SQRT
+* ..
+* .. Executable Statements ..
+*
+* Decode the input arguments
+*
+ IF( LSAME( JOBVL, 'N' ) ) THEN
+ IJOBVL = 1
+ ILVL = .FALSE.
+ ELSE IF( LSAME( JOBVL, 'V' ) ) THEN
+ IJOBVL = 2
+ ILVL = .TRUE.
+ ELSE
+ IJOBVL = -1
+ ILVL = .FALSE.
+ END IF
+*
+ IF( LSAME( JOBVR, 'N' ) ) THEN
+ IJOBVR = 1
+ ILVR = .FALSE.
+ ELSE IF( LSAME( JOBVR, 'V' ) ) THEN
+ IJOBVR = 2
+ ILVR = .TRUE.
+ ELSE
+ IJOBVR = -1
+ ILVR = .FALSE.
+ END IF
+ ILV = ILVL .OR. ILVR
+*
+ NOSCL = LSAME( BALANC, 'N' ) .OR. LSAME( BALANC, 'P' )
+ WANTSN = LSAME( SENSE, 'N' )
+ WANTSE = LSAME( SENSE, 'E' )
+ WANTSV = LSAME( SENSE, 'V' )
+ WANTSB = LSAME( SENSE, 'B' )
+*
+* Test the input arguments
+*
+ INFO = 0
+ LQUERY = ( LWORK.EQ.-1 )
+ IF( .NOT.( LSAME( BALANC, 'N' ) .OR. LSAME( BALANC,
+ $ 'S' ) .OR. LSAME( BALANC, 'P' ) .OR. LSAME( BALANC, 'B' ) ) )
+ $ THEN
+ INFO = -1
+ ELSE IF( IJOBVL.LE.0 ) THEN
+ INFO = -2
+ ELSE IF( IJOBVR.LE.0 ) THEN
+ INFO = -3
+ ELSE IF( .NOT.( WANTSN .OR. WANTSE .OR. WANTSB .OR. WANTSV ) )
+ $ THEN
+ INFO = -4
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -5
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -7
+ ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -9
+ ELSE IF( LDVL.LT.1 .OR. ( ILVL .AND. LDVL.LT.N ) ) THEN
+ INFO = -14
+ ELSE IF( LDVR.LT.1 .OR. ( ILVR .AND. LDVR.LT.N ) ) THEN
+ INFO = -16
+ END IF
+*
+* Compute workspace
+* (Note: Comments in the code beginning "Workspace:" describe the
+* minimal amount of workspace needed at that point in the code,
+* as well as the preferred amount for good performance.
+* NB refers to the optimal block size for the immediately
+* following subroutine, as returned by ILAENV. The workspace is
+* computed assuming ILO = 1 and IHI = N, the worst case.)
+*
+ IF( INFO.EQ.0 ) THEN
+ IF( N.EQ.0 ) THEN
+ MINWRK = 1
+ MAXWRK = 1
+ ELSE
+ IF( NOSCL .AND. .NOT.ILV ) THEN
+ MINWRK = 2*N
+ ELSE
+ MINWRK = 6*N
+ END IF
+ IF( WANTSE .OR. WANTSB ) THEN
+ MINWRK = 10*N
+ END IF
+ IF( WANTSV .OR. WANTSB ) THEN
+ MINWRK = MAX( MINWRK, 2*N*( N + 4 ) + 16 )
+ END IF
+ MAXWRK = MINWRK
+ MAXWRK = MAX( MAXWRK,
+ $ N + N*ILAENV( 1, 'DGEQRF', ' ', N, 1, N, 0 ) )
+ MAXWRK = MAX( MAXWRK,
+ $ N + N*ILAENV( 1, 'DORMQR', ' ', N, 1, N, 0 ) )
+ IF( ILVL ) THEN
+ MAXWRK = MAX( MAXWRK, N +
+ $ N*ILAENV( 1, 'DORGQR', ' ', N, 1, N, 0 ) )
+ END IF
+ END IF
+ WORK( 1 ) = MAXWRK
+*
+ IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN
+ INFO = -26
+ END IF
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DGGEVX', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+*
+* Get machine constants
+*
+ EPS = DLAMCH( 'P' )
+ SMLNUM = DLAMCH( 'S' )
+ BIGNUM = ONE / SMLNUM
+ CALL DLABAD( SMLNUM, BIGNUM )
+ SMLNUM = SQRT( SMLNUM ) / EPS
+ BIGNUM = ONE / SMLNUM
+*
+* Scale A if max element outside range [SMLNUM,BIGNUM]
+*
+ ANRM = DLANGE( 'M', N, N, A, LDA, WORK )
+ ILASCL = .FALSE.
+ IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
+ ANRMTO = SMLNUM
+ ILASCL = .TRUE.
+ ELSE IF( ANRM.GT.BIGNUM ) THEN
+ ANRMTO = BIGNUM
+ ILASCL = .TRUE.
+ END IF
+ IF( ILASCL )
+ $ CALL DLASCL( 'G', 0, 0, ANRM, ANRMTO, N, N, A, LDA, IERR )
+*
+* Scale B if max element outside range [SMLNUM,BIGNUM]
+*
+ BNRM = DLANGE( 'M', N, N, B, LDB, WORK )
+ ILBSCL = .FALSE.
+ IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN
+ BNRMTO = SMLNUM
+ ILBSCL = .TRUE.
+ ELSE IF( BNRM.GT.BIGNUM ) THEN
+ BNRMTO = BIGNUM
+ ILBSCL = .TRUE.
+ END IF
+ IF( ILBSCL )
+ $ CALL DLASCL( 'G', 0, 0, BNRM, BNRMTO, N, N, B, LDB, IERR )
+*
+* Permute and/or balance the matrix pair (A,B)
+* (Workspace: need 6*N if BALANC = 'S' or 'B', 1 otherwise)
+*
+ CALL DGGBAL( BALANC, N, A, LDA, B, LDB, ILO, IHI, LSCALE, RSCALE,
+ $ WORK, IERR )
+*
+* Compute ABNRM and BBNRM
+*
+ ABNRM = DLANGE( '1', N, N, A, LDA, WORK( 1 ) )
+ IF( ILASCL ) THEN
+ WORK( 1 ) = ABNRM
+ CALL DLASCL( 'G', 0, 0, ANRMTO, ANRM, 1, 1, WORK( 1 ), 1,
+ $ IERR )
+ ABNRM = WORK( 1 )
+ END IF
+*
+ BBNRM = DLANGE( '1', N, N, B, LDB, WORK( 1 ) )
+ IF( ILBSCL ) THEN
+ WORK( 1 ) = BBNRM
+ CALL DLASCL( 'G', 0, 0, BNRMTO, BNRM, 1, 1, WORK( 1 ), 1,
+ $ IERR )
+ BBNRM = WORK( 1 )
+ END IF
+*
+* Reduce B to triangular form (QR decomposition of B)
+* (Workspace: need N, prefer N*NB )
+*
+ IROWS = IHI + 1 - ILO
+ IF( ILV .OR. .NOT.WANTSN ) THEN
+ ICOLS = N + 1 - ILO
+ ELSE
+ ICOLS = IROWS
+ END IF
+ ITAU = 1
+ IWRK = ITAU + IROWS
+ CALL DGEQRF( IROWS, ICOLS, B( ILO, ILO ), LDB, WORK( ITAU ),
+ $ WORK( IWRK ), LWORK+1-IWRK, IERR )
+*
+* Apply the orthogonal transformation to A
+* (Workspace: need N, prefer N*NB)
+*
+ CALL DORMQR( 'L', 'T', IROWS, ICOLS, IROWS, B( ILO, ILO ), LDB,
+ $ WORK( ITAU ), A( ILO, ILO ), LDA, WORK( IWRK ),
+ $ LWORK+1-IWRK, IERR )
+*
+* Initialize VL and/or VR
+* (Workspace: need N, prefer N*NB)
+*
+ IF( ILVL ) THEN
+ CALL DLASET( 'Full', N, N, ZERO, ONE, VL, LDVL )
+ IF( IROWS.GT.1 ) THEN
+ CALL DLACPY( 'L', IROWS-1, IROWS-1, B( ILO+1, ILO ), LDB,
+ $ VL( ILO+1, ILO ), LDVL )
+ END IF
+ CALL DORGQR( IROWS, IROWS, IROWS, VL( ILO, ILO ), LDVL,
+ $ WORK( ITAU ), WORK( IWRK ), LWORK+1-IWRK, IERR )
+ END IF
+*
+ IF( ILVR )
+ $ CALL DLASET( 'Full', N, N, ZERO, ONE, VR, LDVR )
+*
+* Reduce to generalized Hessenberg form
+* (Workspace: none needed)
+*
+ IF( ILV .OR. .NOT.WANTSN ) THEN
+*
+* Eigenvectors requested -- work on whole matrix.
+*
+ CALL DGGHRD( JOBVL, JOBVR, N, ILO, IHI, A, LDA, B, LDB, VL,
+ $ LDVL, VR, LDVR, IERR )
+ ELSE
+ CALL DGGHRD( 'N', 'N', IROWS, 1, IROWS, A( ILO, ILO ), LDA,
+ $ B( ILO, ILO ), LDB, VL, LDVL, VR, LDVR, IERR )
+ END IF
+*
+* Perform QZ algorithm (Compute eigenvalues, and optionally, the
+* Schur forms and Schur vectors)
+* (Workspace: need N)
+*
+ IF( ILV .OR. .NOT.WANTSN ) THEN
+ CHTEMP = 'S'
+ ELSE
+ CHTEMP = 'E'
+ END IF
+*
+ CALL DHGEQZ( CHTEMP, JOBVL, JOBVR, N, ILO, IHI, A, LDA, B, LDB,
+ $ ALPHAR, ALPHAI, BETA, VL, LDVL, VR, LDVR, WORK,
+ $ LWORK, IERR )
+ IF( IERR.NE.0 ) THEN
+ IF( IERR.GT.0 .AND. IERR.LE.N ) THEN
+ INFO = IERR
+ ELSE IF( IERR.GT.N .AND. IERR.LE.2*N ) THEN
+ INFO = IERR - N
+ ELSE
+ INFO = N + 1
+ END IF
+ GO TO 130
+ END IF
+*
+* Compute Eigenvectors and estimate condition numbers if desired
+* (Workspace: DTGEVC: need 6*N
+* DTGSNA: need 2*N*(N+2)+16 if SENSE = 'V' or 'B',
+* need N otherwise )
+*
+ IF( ILV .OR. .NOT.WANTSN ) THEN
+ IF( ILV ) THEN
+ IF( ILVL ) THEN
+ IF( ILVR ) THEN
+ CHTEMP = 'B'
+ ELSE
+ CHTEMP = 'L'
+ END IF
+ ELSE
+ CHTEMP = 'R'
+ END IF
+*
+ CALL DTGEVC( CHTEMP, 'B', LDUMMA, N, A, LDA, B, LDB, VL,
+ $ LDVL, VR, LDVR, N, IN, WORK, IERR )
+ IF( IERR.NE.0 ) THEN
+ INFO = N + 2
+ GO TO 130
+ END IF
+ END IF
+*
+ IF( .NOT.WANTSN ) THEN
+*
+* compute eigenvectors (DTGEVC) and estimate condition
+* numbers (DTGSNA). Note that the definition of the condition
+* number is not invariant under transformation (u,v) to
+* (Q*u, Z*v), where (u,v) are eigenvectors of the generalized
+* Schur form (S,T), Q and Z are orthogonal matrices. In order
+* to avoid using extra 2*N*N workspace, we have to recalculate
+* eigenvectors and estimate one condition numbers at a time.
+*
+ PAIR = .FALSE.
+ DO 20 I = 1, N
+*
+ IF( PAIR ) THEN
+ PAIR = .FALSE.
+ GO TO 20
+ END IF
+ MM = 1
+ IF( I.LT.N ) THEN
+ IF( A( I+1, I ).NE.ZERO ) THEN
+ PAIR = .TRUE.
+ MM = 2
+ END IF
+ END IF
+*
+ DO 10 J = 1, N
+ BWORK( J ) = .FALSE.
+ 10 CONTINUE
+ IF( MM.EQ.1 ) THEN
+ BWORK( I ) = .TRUE.
+ ELSE IF( MM.EQ.2 ) THEN
+ BWORK( I ) = .TRUE.
+ BWORK( I+1 ) = .TRUE.
+ END IF
+*
+ IWRK = MM*N + 1
+ IWRK1 = IWRK + MM*N
+*
+* Compute a pair of left and right eigenvectors.
+* (compute workspace: need up to 4*N + 6*N)
+*
+ IF( WANTSE .OR. WANTSB ) THEN
+ CALL DTGEVC( 'B', 'S', BWORK, N, A, LDA, B, LDB,
+ $ WORK( 1 ), N, WORK( IWRK ), N, MM, M,
+ $ WORK( IWRK1 ), IERR )
+ IF( IERR.NE.0 ) THEN
+ INFO = N + 2
+ GO TO 130
+ END IF
+ END IF
+*
+ CALL DTGSNA( SENSE, 'S', BWORK, N, A, LDA, B, LDB,
+ $ WORK( 1 ), N, WORK( IWRK ), N, RCONDE( I ),
+ $ RCONDV( I ), MM, M, WORK( IWRK1 ),
+ $ LWORK-IWRK1+1, IWORK, IERR )
+*
+ 20 CONTINUE
+ END IF
+ END IF
+*
+* Undo balancing on VL and VR and normalization
+* (Workspace: none needed)
+*
+ IF( ILVL ) THEN
+ CALL DGGBAK( BALANC, 'L', N, ILO, IHI, LSCALE, RSCALE, N, VL,
+ $ LDVL, IERR )
+*
+ DO 70 JC = 1, N
+ IF( ALPHAI( JC ).LT.ZERO )
+ $ GO TO 70
+ TEMP = ZERO
+ IF( ALPHAI( JC ).EQ.ZERO ) THEN
+ DO 30 JR = 1, N
+ TEMP = MAX( TEMP, ABS( VL( JR, JC ) ) )
+ 30 CONTINUE
+ ELSE
+ DO 40 JR = 1, N
+ TEMP = MAX( TEMP, ABS( VL( JR, JC ) )+
+ $ ABS( VL( JR, JC+1 ) ) )
+ 40 CONTINUE
+ END IF
+ IF( TEMP.LT.SMLNUM )
+ $ GO TO 70
+ TEMP = ONE / TEMP
+ IF( ALPHAI( JC ).EQ.ZERO ) THEN
+ DO 50 JR = 1, N
+ VL( JR, JC ) = VL( JR, JC )*TEMP
+ 50 CONTINUE
+ ELSE
+ DO 60 JR = 1, N
+ VL( JR, JC ) = VL( JR, JC )*TEMP
+ VL( JR, JC+1 ) = VL( JR, JC+1 )*TEMP
+ 60 CONTINUE
+ END IF
+ 70 CONTINUE
+ END IF
+ IF( ILVR ) THEN
+ CALL DGGBAK( BALANC, 'R', N, ILO, IHI, LSCALE, RSCALE, N, VR,
+ $ LDVR, IERR )
+ DO 120 JC = 1, N
+ IF( ALPHAI( JC ).LT.ZERO )
+ $ GO TO 120
+ TEMP = ZERO
+ IF( ALPHAI( JC ).EQ.ZERO ) THEN
+ DO 80 JR = 1, N
+ TEMP = MAX( TEMP, ABS( VR( JR, JC ) ) )
+ 80 CONTINUE
+ ELSE
+ DO 90 JR = 1, N
+ TEMP = MAX( TEMP, ABS( VR( JR, JC ) )+
+ $ ABS( VR( JR, JC+1 ) ) )
+ 90 CONTINUE
+ END IF
+ IF( TEMP.LT.SMLNUM )
+ $ GO TO 120
+ TEMP = ONE / TEMP
+ IF( ALPHAI( JC ).EQ.ZERO ) THEN
+ DO 100 JR = 1, N
+ VR( JR, JC ) = VR( JR, JC )*TEMP
+ 100 CONTINUE
+ ELSE
+ DO 110 JR = 1, N
+ VR( JR, JC ) = VR( JR, JC )*TEMP
+ VR( JR, JC+1 ) = VR( JR, JC+1 )*TEMP
+ 110 CONTINUE
+ END IF
+ 120 CONTINUE
+ END IF
+*
+* Undo scaling if necessary
+*
+ IF( ILASCL ) THEN
+ CALL DLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHAR, N, IERR )
+ CALL DLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHAI, N, IERR )
+ END IF
+*
+ IF( ILBSCL ) THEN
+ CALL DLASCL( 'G', 0, 0, BNRMTO, BNRM, N, 1, BETA, N, IERR )
+ END IF
+*
+ 130 CONTINUE
+ WORK( 1 ) = MAXWRK
+*
+ RETURN
+*
+* End of DGGEVX
+*
+ END
+ SUBROUTINE DGGGLM( N, M, P, A, LDA, B, LDB, D, X, Y, WORK, LWORK,
+ $ INFO )
+*
+* -- LAPACK driver routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LDA, LDB, LWORK, M, N, P
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION A( LDA, * ), B( LDB, * ), D( * ), WORK( * ),
+ $ X( * ), Y( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DGGGLM solves a general Gauss-Markov linear model (GLM) problem:
+*
+* minimize || y ||_2 subject to d = A*x + B*y
+* x
+*
+* where A is an N-by-M matrix, B is an N-by-P matrix, and d is a
+* given N-vector. It is assumed that M <= N <= M+P, and
+*
+* rank(A) = M and rank( A B ) = N.
+*
+* Under these assumptions, the constrained equation is always
+* consistent, and there is a unique solution x and a minimal 2-norm
+* solution y, which is obtained using a generalized QR factorization
+* of the matrices (A, B) given by
+*
+* A = Q*(R), B = Q*T*Z.
+* (0)
+*
+* In particular, if matrix B is square nonsingular, then the problem
+* GLM is equivalent to the following weighted linear least squares
+* problem
+*
+* minimize || inv(B)*(d-A*x) ||_2
+* x
+*
+* where inv(B) denotes the inverse of B.
+*
+* Arguments
+* =========
+*
+* N (input) INTEGER
+* The number of rows of the matrices A and B. N >= 0.
+*
+* M (input) INTEGER
+* The number of columns of the matrix A. 0 <= M <= N.
+*
+* P (input) INTEGER
+* The number of columns of the matrix B. P >= N-M.
+*
+* A (input/output) DOUBLE PRECISION array, dimension (LDA,M)
+* On entry, the N-by-M matrix A.
+* On exit, the upper triangular part of the array A contains
+* the M-by-M upper triangular matrix R.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,N).
+*
+* B (input/output) DOUBLE PRECISION array, dimension (LDB,P)
+* On entry, the N-by-P matrix B.
+* On exit, if N <= P, the upper triangle of the subarray
+* B(1:N,P-N+1:P) contains the N-by-N upper triangular matrix T;
+* if N > P, the elements on and above the (N-P)th subdiagonal
+* contain the N-by-P upper trapezoidal matrix T.
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. LDB >= max(1,N).
+*
+* D (input/output) DOUBLE PRECISION array, dimension (N)
+* On entry, D is the left hand side of the GLM equation.
+* On exit, D is destroyed.
+*
+* X (output) DOUBLE PRECISION array, dimension (M)
+* Y (output) DOUBLE PRECISION array, dimension (P)
+* On exit, X and Y are the solutions of the GLM problem.
+*
+* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
+* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+* LWORK (input) INTEGER
+* The dimension of the array WORK. LWORK >= max(1,N+M+P).
+* For optimum performance, LWORK >= M+min(N,P)+max(N,P)*NB,
+* where NB is an upper bound for the optimal blocksizes for
+* DGEQRF, SGERQF, DORMQR and SORMRQ.
+*
+* If LWORK = -1, then a workspace query is assumed; the routine
+* only calculates the optimal size of the WORK array, returns
+* this value as the first entry of the WORK array, and no error
+* message related to LWORK is issued by XERBLA.
+*
+* INFO (output) INTEGER
+* = 0: successful exit.
+* < 0: if INFO = -i, the i-th argument had an illegal value.
+* = 1: the upper triangular factor R associated with A in the
+* generalized QR factorization of the pair (A, B) is
+* singular, so that rank(A) < M; the least squares
+* solution could not be computed.
+* = 2: the bottom (N-M) by (N-M) part of the upper trapezoidal
+* factor T associated with B in the generalized QR
+* factorization of the pair (A, B) is singular, so that
+* rank( A B ) < N; the least squares solution could not
+* be computed.
+*
+* ===================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL LQUERY
+ INTEGER I, LOPT, LWKMIN, LWKOPT, NB, NB1, NB2, NB3,
+ $ NB4, NP
+* ..
+* .. External Subroutines ..
+ EXTERNAL DCOPY, DGEMV, DGGQRF, DORMQR, DORMRQ, DTRTRS,
+ $ XERBLA
+* ..
+* .. External Functions ..
+ INTEGER ILAENV
+ EXTERNAL ILAENV
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC INT, MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters
+*
+ INFO = 0
+ NP = MIN( N, P )
+ LQUERY = ( LWORK.EQ.-1 )
+ IF( N.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( M.LT.0 .OR. M.GT.N ) THEN
+ INFO = -2
+ ELSE IF( P.LT.0 .OR. P.LT.N-M ) THEN
+ INFO = -3
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -5
+ ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -7
+ END IF
+*
+* Calculate workspace
+*
+ IF( INFO.EQ.0) THEN
+ IF( N.EQ.0 ) THEN
+ LWKMIN = 1
+ LWKOPT = 1
+ ELSE
+ NB1 = ILAENV( 1, 'DGEQRF', ' ', N, M, -1, -1 )
+ NB2 = ILAENV( 1, 'DGERQF', ' ', N, M, -1, -1 )
+ NB3 = ILAENV( 1, 'DORMQR', ' ', N, M, P, -1 )
+ NB4 = ILAENV( 1, 'DORMRQ', ' ', N, M, P, -1 )
+ NB = MAX( NB1, NB2, NB3, NB4 )
+ LWKMIN = M + N + P
+ LWKOPT = M + NP + MAX( N, P )*NB
+ END IF
+ WORK( 1 ) = LWKOPT
+*
+ IF( LWORK.LT.LWKMIN .AND. .NOT.LQUERY ) THEN
+ INFO = -12
+ END IF
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DGGGLM', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+* Compute the GQR factorization of matrices A and B:
+*
+* Q'*A = ( R11 ) M, Q'*B*Z' = ( T11 T12 ) M
+* ( 0 ) N-M ( 0 T22 ) N-M
+* M M+P-N N-M
+*
+* where R11 and T22 are upper triangular, and Q and Z are
+* orthogonal.
+*
+ CALL DGGQRF( N, M, P, A, LDA, WORK, B, LDB, WORK( M+1 ),
+ $ WORK( M+NP+1 ), LWORK-M-NP, INFO )
+ LOPT = WORK( M+NP+1 )
+*
+* Update left-hand-side vector d = Q'*d = ( d1 ) M
+* ( d2 ) N-M
+*
+ CALL DORMQR( 'Left', 'Transpose', N, 1, M, A, LDA, WORK, D,
+ $ MAX( 1, N ), WORK( M+NP+1 ), LWORK-M-NP, INFO )
+ LOPT = MAX( LOPT, INT( WORK( M+NP+1 ) ) )
+*
+* Solve T22*y2 = d2 for y2
+*
+ IF( N.GT.M ) THEN
+ CALL DTRTRS( 'Upper', 'No transpose', 'Non unit', N-M, 1,
+ $ B( M+1, M+P-N+1 ), LDB, D( M+1 ), N-M, INFO )
+*
+ IF( INFO.GT.0 ) THEN
+ INFO = 1
+ RETURN
+ END IF
+*
+ CALL DCOPY( N-M, D( M+1 ), 1, Y( M+P-N+1 ), 1 )
+ END IF
+*
+* Set y1 = 0
+*
+ DO 10 I = 1, M + P - N
+ Y( I ) = ZERO
+ 10 CONTINUE
+*
+* Update d1 = d1 - T12*y2
+*
+ CALL DGEMV( 'No transpose', M, N-M, -ONE, B( 1, M+P-N+1 ), LDB,
+ $ Y( M+P-N+1 ), 1, ONE, D, 1 )
+*
+* Solve triangular system: R11*x = d1
+*
+ IF( M.GT.0 ) THEN
+ CALL DTRTRS( 'Upper', 'No Transpose', 'Non unit', M, 1, A, LDA,
+ $ D, M, INFO )
+*
+ IF( INFO.GT.0 ) THEN
+ INFO = 2
+ RETURN
+ END IF
+*
+* Copy D to X
+*
+ CALL DCOPY( M, D, 1, X, 1 )
+ END IF
+*
+* Backward transformation y = Z'*y
+*
+ CALL DORMRQ( 'Left', 'Transpose', P, 1, NP,
+ $ B( MAX( 1, N-P+1 ), 1 ), LDB, WORK( M+1 ), Y,
+ $ MAX( 1, P ), WORK( M+NP+1 ), LWORK-M-NP, INFO )
+ WORK( 1 ) = M + NP + MAX( LOPT, INT( WORK( M+NP+1 ) ) )
+*
+ RETURN
+*
+* End of DGGGLM
+*
+ END
+ SUBROUTINE DGGHRD( COMPQ, COMPZ, N, ILO, IHI, A, LDA, B, LDB, Q,
+ $ LDQ, Z, LDZ, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER COMPQ, COMPZ
+ INTEGER IHI, ILO, INFO, LDA, LDB, LDQ, LDZ, N
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION A( LDA, * ), B( LDB, * ), Q( LDQ, * ),
+ $ Z( LDZ, * )
+* ..
+*
+* Purpose
+* =======
+*
+* DGGHRD reduces a pair of real matrices (A,B) to generalized upper
+* Hessenberg form using orthogonal transformations, where A is a
+* general matrix and B is upper triangular. The form of the
+* generalized eigenvalue problem is
+* A*x = lambda*B*x,
+* and B is typically made upper triangular by computing its QR
+* factorization and moving the orthogonal matrix Q to the left side
+* of the equation.
+*
+* This subroutine simultaneously reduces A to a Hessenberg matrix H:
+* Q**T*A*Z = H
+* and transforms B to another upper triangular matrix T:
+* Q**T*B*Z = T
+* in order to reduce the problem to its standard form
+* H*y = lambda*T*y
+* where y = Z**T*x.
+*
+* The orthogonal matrices Q and Z are determined as products of Givens
+* rotations. They may either be formed explicitly, or they may be
+* postmultiplied into input matrices Q1 and Z1, so that
+*
+* Q1 * A * Z1**T = (Q1*Q) * H * (Z1*Z)**T
+*
+* Q1 * B * Z1**T = (Q1*Q) * T * (Z1*Z)**T
+*
+* If Q1 is the orthogonal matrix from the QR factorization of B in the
+* original equation A*x = lambda*B*x, then DGGHRD reduces the original
+* problem to generalized Hessenberg form.
+*
+* Arguments
+* =========
+*
+* COMPQ (input) CHARACTER*1
+* = 'N': do not compute Q;
+* = 'I': Q is initialized to the unit matrix, and the
+* orthogonal matrix Q is returned;
+* = 'V': Q must contain an orthogonal matrix Q1 on entry,
+* and the product Q1*Q is returned.
+*
+* COMPZ (input) CHARACTER*1
+* = 'N': do not compute Z;
+* = 'I': Z is initialized to the unit matrix, and the
+* orthogonal matrix Z is returned;
+* = 'V': Z must contain an orthogonal matrix Z1 on entry,
+* and the product Z1*Z is returned.
+*
+* N (input) INTEGER
+* The order of the matrices A and B. N >= 0.
+*
+* ILO (input) INTEGER
+* IHI (input) INTEGER
+* ILO and IHI mark the rows and columns of A which are to be
+* reduced. It is assumed that A is already upper triangular
+* in rows and columns 1:ILO-1 and IHI+1:N. ILO and IHI are
+* normally set by a previous call to SGGBAL; otherwise they
+* should be set to 1 and N respectively.
+* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.
+*
+* A (input/output) DOUBLE PRECISION array, dimension (LDA, N)
+* On entry, the N-by-N general matrix to be reduced.
+* On exit, the upper triangle and the first subdiagonal of A
+* are overwritten with the upper Hessenberg matrix H, and the
+* rest is set to zero.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,N).
+*
+* B (input/output) DOUBLE PRECISION array, dimension (LDB, N)
+* On entry, the N-by-N upper triangular matrix B.
+* On exit, the upper triangular matrix T = Q**T B Z. The
+* elements below the diagonal are set to zero.
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. LDB >= max(1,N).
+*
+* Q (input/output) DOUBLE PRECISION array, dimension (LDQ, N)
+* On entry, if COMPQ = 'V', the orthogonal matrix Q1,
+* typically from the QR factorization of B.
+* On exit, if COMPQ='I', the orthogonal matrix Q, and if
+* COMPQ = 'V', the product Q1*Q.
+* Not referenced if COMPQ='N'.
+*
+* LDQ (input) INTEGER
+* The leading dimension of the array Q.
+* LDQ >= N if COMPQ='V' or 'I'; LDQ >= 1 otherwise.
+*
+* Z (input/output) DOUBLE PRECISION array, dimension (LDZ, N)
+* On entry, if COMPZ = 'V', the orthogonal matrix Z1.
+* On exit, if COMPZ='I', the orthogonal matrix Z, and if
+* COMPZ = 'V', the product Z1*Z.
+* Not referenced if COMPZ='N'.
+*
+* LDZ (input) INTEGER
+* The leading dimension of the array Z.
+* LDZ >= N if COMPZ='V' or 'I'; LDZ >= 1 otherwise.
+*
+* INFO (output) INTEGER
+* = 0: successful exit.
+* < 0: if INFO = -i, the i-th argument had an illegal value.
+*
+* Further Details
+* ===============
+*
+* This routine reduces A to Hessenberg and B to triangular form by
+* an unblocked reduction, as described in _Matrix_Computations_,
+* by Golub and Van Loan (Johns Hopkins Press.)
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE, ZERO
+ PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL ILQ, ILZ
+ INTEGER ICOMPQ, ICOMPZ, JCOL, JROW
+ DOUBLE PRECISION C, S, TEMP
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL DLARTG, DLASET, DROT, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+* Decode COMPQ
+*
+ IF( LSAME( COMPQ, 'N' ) ) THEN
+ ILQ = .FALSE.
+ ICOMPQ = 1
+ ELSE IF( LSAME( COMPQ, 'V' ) ) THEN
+ ILQ = .TRUE.
+ ICOMPQ = 2
+ ELSE IF( LSAME( COMPQ, 'I' ) ) THEN
+ ILQ = .TRUE.
+ ICOMPQ = 3
+ ELSE
+ ICOMPQ = 0
+ END IF
+*
+* Decode COMPZ
+*
+ IF( LSAME( COMPZ, 'N' ) ) THEN
+ ILZ = .FALSE.
+ ICOMPZ = 1
+ ELSE IF( LSAME( COMPZ, 'V' ) ) THEN
+ ILZ = .TRUE.
+ ICOMPZ = 2
+ ELSE IF( LSAME( COMPZ, 'I' ) ) THEN
+ ILZ = .TRUE.
+ ICOMPZ = 3
+ ELSE
+ ICOMPZ = 0
+ END IF
+*
+* Test the input parameters.
+*
+ INFO = 0
+ IF( ICOMPQ.LE.0 ) THEN
+ INFO = -1
+ ELSE IF( ICOMPZ.LE.0 ) THEN
+ INFO = -2
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( ILO.LT.1 ) THEN
+ INFO = -4
+ ELSE IF( IHI.GT.N .OR. IHI.LT.ILO-1 ) THEN
+ INFO = -5
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -7
+ ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -9
+ ELSE IF( ( ILQ .AND. LDQ.LT.N ) .OR. LDQ.LT.1 ) THEN
+ INFO = -11
+ ELSE IF( ( ILZ .AND. LDZ.LT.N ) .OR. LDZ.LT.1 ) THEN
+ INFO = -13
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DGGHRD', -INFO )
+ RETURN
+ END IF
+*
+* Initialize Q and Z if desired.
+*
+ IF( ICOMPQ.EQ.3 )
+ $ CALL DLASET( 'Full', N, N, ZERO, ONE, Q, LDQ )
+ IF( ICOMPZ.EQ.3 )
+ $ CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDZ )
+*
+* Quick return if possible
+*
+ IF( N.LE.1 )
+ $ RETURN
+*
+* Zero out lower triangle of B
+*
+ DO 20 JCOL = 1, N - 1
+ DO 10 JROW = JCOL + 1, N
+ B( JROW, JCOL ) = ZERO
+ 10 CONTINUE
+ 20 CONTINUE
+*
+* Reduce A and B
+*
+ DO 40 JCOL = ILO, IHI - 2
+*
+ DO 30 JROW = IHI, JCOL + 2, -1
+*
+* Step 1: rotate rows JROW-1, JROW to kill A(JROW,JCOL)
+*
+ TEMP = A( JROW-1, JCOL )
+ CALL DLARTG( TEMP, A( JROW, JCOL ), C, S,
+ $ A( JROW-1, JCOL ) )
+ A( JROW, JCOL ) = ZERO
+ CALL DROT( N-JCOL, A( JROW-1, JCOL+1 ), LDA,
+ $ A( JROW, JCOL+1 ), LDA, C, S )
+ CALL DROT( N+2-JROW, B( JROW-1, JROW-1 ), LDB,
+ $ B( JROW, JROW-1 ), LDB, C, S )
+ IF( ILQ )
+ $ CALL DROT( N, Q( 1, JROW-1 ), 1, Q( 1, JROW ), 1, C, S )
+*
+* Step 2: rotate columns JROW, JROW-1 to kill B(JROW,JROW-1)
+*
+ TEMP = B( JROW, JROW )
+ CALL DLARTG( TEMP, B( JROW, JROW-1 ), C, S,
+ $ B( JROW, JROW ) )
+ B( JROW, JROW-1 ) = ZERO
+ CALL DROT( IHI, A( 1, JROW ), 1, A( 1, JROW-1 ), 1, C, S )
+ CALL DROT( JROW-1, B( 1, JROW ), 1, B( 1, JROW-1 ), 1, C,
+ $ S )
+ IF( ILZ )
+ $ CALL DROT( N, Z( 1, JROW ), 1, Z( 1, JROW-1 ), 1, C, S )
+ 30 CONTINUE
+ 40 CONTINUE
+*
+ RETURN
+*
+* End of DGGHRD
+*
+ END
+ SUBROUTINE DGGLSE( M, N, P, A, LDA, B, LDB, C, D, X, WORK, LWORK,
+ $ INFO )
+*
+* -- LAPACK driver routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LDA, LDB, LWORK, M, N, P
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( * ), D( * ),
+ $ WORK( * ), X( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DGGLSE solves the linear equality-constrained least squares (LSE)
+* problem:
+*
+* minimize || c - A*x ||_2 subject to B*x = d
+*
+* where A is an M-by-N matrix, B is a P-by-N matrix, c is a given
+* M-vector, and d is a given P-vector. It is assumed that
+* P <= N <= M+P, and
+*
+* rank(B) = P and rank( (A) ) = N.
+* ( (B) )
+*
+* These conditions ensure that the LSE problem has a unique solution,
+* which is obtained using a generalized RQ factorization of the
+* matrices (B, A) given by
+*
+* B = (0 R)*Q, A = Z*T*Q.
+*
+* Arguments
+* =========
+*
+* M (input) INTEGER
+* The number of rows of the matrix A. M >= 0.
+*
+* N (input) INTEGER
+* The number of columns of the matrices A and B. N >= 0.
+*
+* P (input) INTEGER
+* The number of rows of the matrix B. 0 <= P <= N <= M+P.
+*
+* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+* On entry, the M-by-N matrix A.
+* On exit, the elements on and above the diagonal of the array
+* contain the min(M,N)-by-N upper trapezoidal matrix T.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,M).
+*
+* B (input/output) DOUBLE PRECISION array, dimension (LDB,N)
+* On entry, the P-by-N matrix B.
+* On exit, the upper triangle of the subarray B(1:P,N-P+1:N)
+* contains the P-by-P upper triangular matrix R.
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. LDB >= max(1,P).
+*
+* C (input/output) DOUBLE PRECISION array, dimension (M)
+* On entry, C contains the right hand side vector for the
+* least squares part of the LSE problem.
+* On exit, the residual sum of squares for the solution
+* is given by the sum of squares of elements N-P+1 to M of
+* vector C.
+*
+* D (input/output) DOUBLE PRECISION array, dimension (P)
+* On entry, D contains the right hand side vector for the
+* constrained equation.
+* On exit, D is destroyed.
+*
+* X (output) DOUBLE PRECISION array, dimension (N)
+* On exit, X is the solution of the LSE problem.
+*
+* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
+* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+* LWORK (input) INTEGER
+* The dimension of the array WORK. LWORK >= max(1,M+N+P).
+* For optimum performance LWORK >= P+min(M,N)+max(M,N)*NB,
+* where NB is an upper bound for the optimal blocksizes for
+* DGEQRF, SGERQF, DORMQR and SORMRQ.
+*
+* If LWORK = -1, then a workspace query is assumed; the routine
+* only calculates the optimal size of the WORK array, returns
+* this value as the first entry of the WORK array, and no error
+* message related to LWORK is issued by XERBLA.
+*
+* INFO (output) INTEGER
+* = 0: successful exit.
+* < 0: if INFO = -i, the i-th argument had an illegal value.
+* = 1: the upper triangular factor R associated with B in the
+* generalized RQ factorization of the pair (B, A) is
+* singular, so that rank(B) < P; the least squares
+* solution could not be computed.
+* = 2: the (N-P) by (N-P) part of the upper trapezoidal factor
+* T associated with A in the generalized RQ factorization
+* of the pair (B, A) is singular, so that
+* rank( (A) ) < N; the least squares solution could not
+* ( (B) )
+* be computed.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE
+ PARAMETER ( ONE = 1.0D+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL LQUERY
+ INTEGER LOPT, LWKMIN, LWKOPT, MN, NB, NB1, NB2, NB3,
+ $ NB4, NR
+* ..
+* .. External Subroutines ..
+ EXTERNAL DAXPY, DCOPY, DGEMV, DGGRQF, DORMQR, DORMRQ,
+ $ DTRMV, DTRTRS, XERBLA
+* ..
+* .. External Functions ..
+ INTEGER ILAENV
+ EXTERNAL ILAENV
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC INT, MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters
+*
+ INFO = 0
+ MN = MIN( M, N )
+ LQUERY = ( LWORK.EQ.-1 )
+ IF( M.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( P.LT.0 .OR. P.GT.N .OR. P.LT.N-M ) THEN
+ INFO = -3
+ ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+ INFO = -5
+ ELSE IF( LDB.LT.MAX( 1, P ) ) THEN
+ INFO = -7
+ END IF
+*
+* Calculate workspace
+*
+ IF( INFO.EQ.0) THEN
+ IF( N.EQ.0 ) THEN
+ LWKMIN = 1
+ LWKOPT = 1
+ ELSE
+ NB1 = ILAENV( 1, 'DGEQRF', ' ', M, N, -1, -1 )
+ NB2 = ILAENV( 1, 'DGERQF', ' ', M, N, -1, -1 )
+ NB3 = ILAENV( 1, 'DORMQR', ' ', M, N, P, -1 )
+ NB4 = ILAENV( 1, 'DORMRQ', ' ', M, N, P, -1 )
+ NB = MAX( NB1, NB2, NB3, NB4 )
+ LWKMIN = M + N + P
+ LWKOPT = P + MN + MAX( M, N )*NB
+ END IF
+ WORK( 1 ) = LWKOPT
+*
+ IF( LWORK.LT.LWKMIN .AND. .NOT.LQUERY ) THEN
+ INFO = -12
+ END IF
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DGGLSE', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+* Compute the GRQ factorization of matrices B and A:
+*
+* B*Q' = ( 0 T12 ) P Z'*A*Q' = ( R11 R12 ) N-P
+* N-P P ( 0 R22 ) M+P-N
+* N-P P
+*
+* where T12 and R11 are upper triangular, and Q and Z are
+* orthogonal.
+*
+ CALL DGGRQF( P, M, N, B, LDB, WORK, A, LDA, WORK( P+1 ),
+ $ WORK( P+MN+1 ), LWORK-P-MN, INFO )
+ LOPT = WORK( P+MN+1 )
+*
+* Update c = Z'*c = ( c1 ) N-P
+* ( c2 ) M+P-N
+*
+ CALL DORMQR( 'Left', 'Transpose', M, 1, MN, A, LDA, WORK( P+1 ),
+ $ C, MAX( 1, M ), WORK( P+MN+1 ), LWORK-P-MN, INFO )
+ LOPT = MAX( LOPT, INT( WORK( P+MN+1 ) ) )
+*
+* Solve T12*x2 = d for x2
+*
+ IF( P.GT.0 ) THEN
+ CALL DTRTRS( 'Upper', 'No transpose', 'Non-unit', P, 1,
+ $ B( 1, N-P+1 ), LDB, D, P, INFO )
+*
+ IF( INFO.GT.0 ) THEN
+ INFO = 1
+ RETURN
+ END IF
+*
+* Put the solution in X
+*
+ CALL DCOPY( P, D, 1, X( N-P+1 ), 1 )
+*
+* Update c1
+*
+ CALL DGEMV( 'No transpose', N-P, P, -ONE, A( 1, N-P+1 ), LDA,
+ $ D, 1, ONE, C, 1 )
+ END IF
+*
+* Solve R11*x1 = c1 for x1
+*
+ IF( N.GT.P ) THEN
+ CALL DTRTRS( 'Upper', 'No transpose', 'Non-unit', N-P, 1,
+ $ A, LDA, C, N-P, INFO )
+*
+ IF( INFO.GT.0 ) THEN
+ INFO = 2
+ RETURN
+ END IF
+*
+* Put the solutions in X
+*
+ CALL DCOPY( N-P, C, 1, X, 1 )
+ END IF
+*
+* Compute the residual vector:
+*
+ IF( M.LT.N ) THEN
+ NR = M + P - N
+ IF( NR.GT.0 )
+ $ CALL DGEMV( 'No transpose', NR, N-M, -ONE, A( N-P+1, M+1 ),
+ $ LDA, D( NR+1 ), 1, ONE, C( N-P+1 ), 1 )
+ ELSE
+ NR = P
+ END IF
+ IF( NR.GT.0 ) THEN
+ CALL DTRMV( 'Upper', 'No transpose', 'Non unit', NR,
+ $ A( N-P+1, N-P+1 ), LDA, D, 1 )
+ CALL DAXPY( NR, -ONE, D, 1, C( N-P+1 ), 1 )
+ END IF
+*
+* Backward transformation x = Q'*x
+*
+ CALL DORMRQ( 'Left', 'Transpose', N, 1, P, B, LDB, WORK( 1 ), X,
+ $ N, WORK( P+MN+1 ), LWORK-P-MN, INFO )
+ WORK( 1 ) = P + MN + MAX( LOPT, INT( WORK( P+MN+1 ) ) )
+*
+ RETURN
+*
+* End of DGGLSE
+*
+ END
+ SUBROUTINE DGGQRF( N, M, P, A, LDA, TAUA, B, LDB, TAUB, WORK,
+ $ LWORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LDA, LDB, LWORK, M, N, P
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION A( LDA, * ), B( LDB, * ), TAUA( * ), TAUB( * ),
+ $ WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DGGQRF computes a generalized QR factorization of an N-by-M matrix A
+* and an N-by-P matrix B:
+*
+* A = Q*R, B = Q*T*Z,
+*
+* where Q is an N-by-N orthogonal matrix, Z is a P-by-P orthogonal
+* matrix, and R and T assume one of the forms:
+*
+* if N >= M, R = ( R11 ) M , or if N < M, R = ( R11 R12 ) N,
+* ( 0 ) N-M N M-N
+* M
+*
+* where R11 is upper triangular, and
+*
+* if N <= P, T = ( 0 T12 ) N, or if N > P, T = ( T11 ) N-P,
+* P-N N ( T21 ) P
+* P
+*
+* where T12 or T21 is upper triangular.
+*
+* In particular, if B is square and nonsingular, the GQR factorization
+* of A and B implicitly gives the QR factorization of inv(B)*A:
+*
+* inv(B)*A = Z'*(inv(T)*R)
+*
+* where inv(B) denotes the inverse of the matrix B, and Z' denotes the
+* transpose of the matrix Z.
+*
+* Arguments
+* =========
+*
+* N (input) INTEGER
+* The number of rows of the matrices A and B. N >= 0.
+*
+* M (input) INTEGER
+* The number of columns of the matrix A. M >= 0.
+*
+* P (input) INTEGER
+* The number of columns of the matrix B. P >= 0.
+*
+* A (input/output) DOUBLE PRECISION array, dimension (LDA,M)
+* On entry, the N-by-M matrix A.
+* On exit, the elements on and above the diagonal of the array
+* contain the min(N,M)-by-M upper trapezoidal matrix R (R is
+* upper triangular if N >= M); the elements below the diagonal,
+* with the array TAUA, represent the orthogonal matrix Q as a
+* product of min(N,M) elementary reflectors (see Further
+* Details).
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,N).
+*
+* TAUA (output) DOUBLE PRECISION array, dimension (min(N,M))
+* The scalar factors of the elementary reflectors which
+* represent the orthogonal matrix Q (see Further Details).
+*
+* B (input/output) DOUBLE PRECISION array, dimension (LDB,P)
+* On entry, the N-by-P matrix B.
+* On exit, if N <= P, the upper triangle of the subarray
+* B(1:N,P-N+1:P) contains the N-by-N upper triangular matrix T;
+* if N > P, the elements on and above the (N-P)-th subdiagonal
+* contain the N-by-P upper trapezoidal matrix T; the remaining
+* elements, with the array TAUB, represent the orthogonal
+* matrix Z as a product of elementary reflectors (see Further
+* Details).
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. LDB >= max(1,N).
+*
+* TAUB (output) DOUBLE PRECISION array, dimension (min(N,P))
+* The scalar factors of the elementary reflectors which
+* represent the orthogonal matrix Z (see Further Details).
+*
+* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
+* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+* LWORK (input) INTEGER
+* The dimension of the array WORK. LWORK >= max(1,N,M,P).
+* For optimum performance LWORK >= max(N,M,P)*max(NB1,NB2,NB3),
+* where NB1 is the optimal blocksize for the QR factorization
+* of an N-by-M matrix, NB2 is the optimal blocksize for the
+* RQ factorization of an N-by-P matrix, and NB3 is the optimal
+* blocksize for a call of DORMQR.
+*
+* If LWORK = -1, then a workspace query is assumed; the routine
+* only calculates the optimal size of the WORK array, returns
+* this value as the first entry of the WORK array, and no error
+* message related to LWORK is issued by XERBLA.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value.
+*
+* Further Details
+* ===============
+*
+* The matrix Q is represented as a product of elementary reflectors
+*
+* Q = H(1) H(2) . . . H(k), where k = min(n,m).
+*
+* Each H(i) has the form
+*
+* H(i) = I - taua * v * v'
+*
+* where taua is a real scalar, and v is a real vector with
+* v(1:i-1) = 0 and v(i) = 1; v(i+1:n) is stored on exit in A(i+1:n,i),
+* and taua in TAUA(i).
+* To form Q explicitly, use LAPACK subroutine DORGQR.
+* To use Q to update another matrix, use LAPACK subroutine DORMQR.
+*
+* The matrix Z is represented as a product of elementary reflectors
+*
+* Z = H(1) H(2) . . . H(k), where k = min(n,p).
+*
+* Each H(i) has the form
+*
+* H(i) = I - taub * v * v'
+*
+* where taub is a real scalar, and v is a real vector with
+* v(p-k+i+1:p) = 0 and v(p-k+i) = 1; v(1:p-k+i-1) is stored on exit in
+* B(n-k+i,1:p-k+i-1), and taub in TAUB(i).
+* To form Z explicitly, use LAPACK subroutine DORGRQ.
+* To use Z to update another matrix, use LAPACK subroutine DORMRQ.
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ LOGICAL LQUERY
+ INTEGER LOPT, LWKOPT, NB, NB1, NB2, NB3
+* ..
+* .. External Subroutines ..
+ EXTERNAL DGEQRF, DGERQF, DORMQR, XERBLA
+* ..
+* .. External Functions ..
+ INTEGER ILAENV
+ EXTERNAL ILAENV
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC INT, MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters
+*
+ INFO = 0
+ NB1 = ILAENV( 1, 'DGEQRF', ' ', N, M, -1, -1 )
+ NB2 = ILAENV( 1, 'DGERQF', ' ', N, P, -1, -1 )
+ NB3 = ILAENV( 1, 'DORMQR', ' ', N, M, P, -1 )
+ NB = MAX( NB1, NB2, NB3 )
+ LWKOPT = MAX( N, M, P )*NB
+ WORK( 1 ) = LWKOPT
+ LQUERY = ( LWORK.EQ.-1 )
+ IF( N.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( M.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( P.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -5
+ ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -8
+ ELSE IF( LWORK.LT.MAX( 1, N, M, P ) .AND. .NOT.LQUERY ) THEN
+ INFO = -11
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DGGQRF', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* QR factorization of N-by-M matrix A: A = Q*R
+*
+ CALL DGEQRF( N, M, A, LDA, TAUA, WORK, LWORK, INFO )
+ LOPT = WORK( 1 )
+*
+* Update B := Q'*B.
+*
+ CALL DORMQR( 'Left', 'Transpose', N, P, MIN( N, M ), A, LDA, TAUA,
+ $ B, LDB, WORK, LWORK, INFO )
+ LOPT = MAX( LOPT, INT( WORK( 1 ) ) )
+*
+* RQ factorization of N-by-P matrix B: B = T*Z.
+*
+ CALL DGERQF( N, P, B, LDB, TAUB, WORK, LWORK, INFO )
+ WORK( 1 ) = MAX( LOPT, INT( WORK( 1 ) ) )
+*
+ RETURN
+*
+* End of DGGQRF
+*
+ END
+ SUBROUTINE DGGRQF( M, P, N, A, LDA, TAUA, B, LDB, TAUB, WORK,
+ $ LWORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LDA, LDB, LWORK, M, N, P
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION A( LDA, * ), B( LDB, * ), TAUA( * ), TAUB( * ),
+ $ WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DGGRQF computes a generalized RQ factorization of an M-by-N matrix A
+* and a P-by-N matrix B:
+*
+* A = R*Q, B = Z*T*Q,
+*
+* where Q is an N-by-N orthogonal matrix, Z is a P-by-P orthogonal
+* matrix, and R and T assume one of the forms:
+*
+* if M <= N, R = ( 0 R12 ) M, or if M > N, R = ( R11 ) M-N,
+* N-M M ( R21 ) N
+* N
+*
+* where R12 or R21 is upper triangular, and
+*
+* if P >= N, T = ( T11 ) N , or if P < N, T = ( T11 T12 ) P,
+* ( 0 ) P-N P N-P
+* N
+*
+* where T11 is upper triangular.
+*
+* In particular, if B is square and nonsingular, the GRQ factorization
+* of A and B implicitly gives the RQ factorization of A*inv(B):
+*
+* A*inv(B) = (R*inv(T))*Z'
+*
+* where inv(B) denotes the inverse of the matrix B, and Z' denotes the
+* transpose of the matrix Z.
+*
+* Arguments
+* =========
+*
+* M (input) INTEGER
+* The number of rows of the matrix A. M >= 0.
+*
+* P (input) INTEGER
+* The number of rows of the matrix B. P >= 0.
+*
+* N (input) INTEGER
+* The number of columns of the matrices A and B. N >= 0.
+*
+* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+* On entry, the M-by-N matrix A.
+* On exit, if M <= N, the upper triangle of the subarray
+* A(1:M,N-M+1:N) contains the M-by-M upper triangular matrix R;
+* if M > N, the elements on and above the (M-N)-th subdiagonal
+* contain the M-by-N upper trapezoidal matrix R; the remaining
+* elements, with the array TAUA, represent the orthogonal
+* matrix Q as a product of elementary reflectors (see Further
+* Details).
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,M).
+*
+* TAUA (output) DOUBLE PRECISION array, dimension (min(M,N))
+* The scalar factors of the elementary reflectors which
+* represent the orthogonal matrix Q (see Further Details).
+*
+* B (input/output) DOUBLE PRECISION array, dimension (LDB,N)
+* On entry, the P-by-N matrix B.
+* On exit, the elements on and above the diagonal of the array
+* contain the min(P,N)-by-N upper trapezoidal matrix T (T is
+* upper triangular if P >= N); the elements below the diagonal,
+* with the array TAUB, represent the orthogonal matrix Z as a
+* product of elementary reflectors (see Further Details).
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. LDB >= max(1,P).
+*
+* TAUB (output) DOUBLE PRECISION array, dimension (min(P,N))
+* The scalar factors of the elementary reflectors which
+* represent the orthogonal matrix Z (see Further Details).
+*
+* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
+* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+* LWORK (input) INTEGER
+* The dimension of the array WORK. LWORK >= max(1,N,M,P).
+* For optimum performance LWORK >= max(N,M,P)*max(NB1,NB2,NB3),
+* where NB1 is the optimal blocksize for the RQ factorization
+* of an M-by-N matrix, NB2 is the optimal blocksize for the
+* QR factorization of a P-by-N matrix, and NB3 is the optimal
+* blocksize for a call of DORMRQ.
+*
+* If LWORK = -1, then a workspace query is assumed; the routine
+* only calculates the optimal size of the WORK array, returns
+* this value as the first entry of the WORK array, and no error
+* message related to LWORK is issued by XERBLA.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INF0= -i, the i-th argument had an illegal value.
+*
+* Further Details
+* ===============
+*
+* The matrix Q is represented as a product of elementary reflectors
+*
+* Q = H(1) H(2) . . . H(k), where k = min(m,n).
+*
+* Each H(i) has the form
+*
+* H(i) = I - taua * v * v'
+*
+* where taua is a real scalar, and v is a real vector with
+* v(n-k+i+1:n) = 0 and v(n-k+i) = 1; v(1:n-k+i-1) is stored on exit in
+* A(m-k+i,1:n-k+i-1), and taua in TAUA(i).
+* To form Q explicitly, use LAPACK subroutine DORGRQ.
+* To use Q to update another matrix, use LAPACK subroutine DORMRQ.
+*
+* The matrix Z is represented as a product of elementary reflectors
+*
+* Z = H(1) H(2) . . . H(k), where k = min(p,n).
+*
+* Each H(i) has the form
+*
+* H(i) = I - taub * v * v'
+*
+* where taub is a real scalar, and v is a real vector with
+* v(1:i-1) = 0 and v(i) = 1; v(i+1:p) is stored on exit in B(i+1:p,i),
+* and taub in TAUB(i).
+* To form Z explicitly, use LAPACK subroutine DORGQR.
+* To use Z to update another matrix, use LAPACK subroutine DORMQR.
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ LOGICAL LQUERY
+ INTEGER LOPT, LWKOPT, NB, NB1, NB2, NB3
+* ..
+* .. External Subroutines ..
+ EXTERNAL DGEQRF, DGERQF, DORMRQ, XERBLA
+* ..
+* .. External Functions ..
+ INTEGER ILAENV
+ EXTERNAL ILAENV
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC INT, MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters
+*
+ INFO = 0
+ NB1 = ILAENV( 1, 'DGERQF', ' ', M, N, -1, -1 )
+ NB2 = ILAENV( 1, 'DGEQRF', ' ', P, N, -1, -1 )
+ NB3 = ILAENV( 1, 'DORMRQ', ' ', M, N, P, -1 )
+ NB = MAX( NB1, NB2, NB3 )
+ LWKOPT = MAX( N, M, P )*NB
+ WORK( 1 ) = LWKOPT
+ LQUERY = ( LWORK.EQ.-1 )
+ IF( M.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( P.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+ INFO = -5
+ ELSE IF( LDB.LT.MAX( 1, P ) ) THEN
+ INFO = -8
+ ELSE IF( LWORK.LT.MAX( 1, M, P, N ) .AND. .NOT.LQUERY ) THEN
+ INFO = -11
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DGGRQF', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* RQ factorization of M-by-N matrix A: A = R*Q
+*
+ CALL DGERQF( M, N, A, LDA, TAUA, WORK, LWORK, INFO )
+ LOPT = WORK( 1 )
+*
+* Update B := B*Q'
+*
+ CALL DORMRQ( 'Right', 'Transpose', P, N, MIN( M, N ),
+ $ A( MAX( 1, M-N+1 ), 1 ), LDA, TAUA, B, LDB, WORK,
+ $ LWORK, INFO )
+ LOPT = MAX( LOPT, INT( WORK( 1 ) ) )
+*
+* QR factorization of P-by-N matrix B: B = Z*T
+*
+ CALL DGEQRF( P, N, B, LDB, TAUB, WORK, LWORK, INFO )
+ WORK( 1 ) = MAX( LOPT, INT( WORK( 1 ) ) )
+*
+ RETURN
+*
+* End of DGGRQF
+*
+ END
+ 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 )
+*
+* -- LAPACK driver routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER JOBQ, JOBU, JOBV
+ INTEGER INFO, K, L, LDA, LDB, LDQ, LDU, LDV, M, N, P
+* ..
+* .. Array Arguments ..
+ INTEGER IWORK( * )
+ DOUBLE PRECISION A( LDA, * ), ALPHA( * ), B( LDB, * ),
+ $ BETA( * ), Q( LDQ, * ), U( LDU, * ),
+ $ V( LDV, * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DGGSVD computes the generalized singular value decomposition (GSVD)
+* of an M-by-N real matrix A and P-by-N real matrix B:
+*
+* U'*A*Q = D1*( 0 R ), V'*B*Q = D2*( 0 R )
+*
+* where U, V and Q are orthogonal matrices, and Z' is the transpose
+* of Z. Let K+L = the effective numerical rank of the matrix (A',B')',
+* then R is a K+L-by-K+L nonsingular upper triangular matrix, D1 and
+* D2 are M-by-(K+L) and P-by-(K+L) "diagonal" matrices and of the
+* following structures, respectively:
+*
+* If M-K-L >= 0,
+*
+* K L
+* D1 = K ( I 0 )
+* L ( 0 C )
+* M-K-L ( 0 0 )
+*
+* K L
+* D2 = L ( 0 S )
+* P-L ( 0 0 )
+*
+* N-K-L K L
+* ( 0 R ) = K ( 0 R11 R12 )
+* L ( 0 0 R22 )
+*
+* where
+*
+* C = diag( ALPHA(K+1), ... , ALPHA(K+L) ),
+* S = diag( BETA(K+1), ... , BETA(K+L) ),
+* C**2 + S**2 = I.
+*
+* R is stored in A(1:K+L,N-K-L+1:N) on exit.
+*
+* If M-K-L < 0,
+*
+* K M-K K+L-M
+* D1 = K ( I 0 0 )
+* M-K ( 0 C 0 )
+*
+* K M-K K+L-M
+* D2 = M-K ( 0 S 0 )
+* K+L-M ( 0 0 I )
+* P-L ( 0 0 0 )
+*
+* N-K-L K M-K K+L-M
+* ( 0 R ) = K ( 0 R11 R12 R13 )
+* M-K ( 0 0 R22 R23 )
+* K+L-M ( 0 0 0 R33 )
+*
+* where
+*
+* C = diag( ALPHA(K+1), ... , ALPHA(M) ),
+* S = diag( BETA(K+1), ... , BETA(M) ),
+* C**2 + S**2 = I.
+*
+* (R11 R12 R13 ) is stored in A(1:M, N-K-L+1:N), and R33 is stored
+* ( 0 R22 R23 )
+* in B(M-K+1:L,N+M-K-L+1:N) on exit.
+*
+* The routine computes C, S, R, and optionally the orthogonal
+* transformation matrices U, V and Q.
+*
+* In particular, if B is an N-by-N nonsingular matrix, then the GSVD of
+* A and B implicitly gives the SVD of A*inv(B):
+* A*inv(B) = U*(D1*inv(D2))*V'.
+* If ( A',B')' has orthonormal columns, then the GSVD of A and B is
+* also equal to the CS decomposition of A and B. Furthermore, the GSVD
+* can be used to derive the solution of the eigenvalue problem:
+* A'*A x = lambda* B'*B x.
+* In some literature, the GSVD of A and B is presented in the form
+* U'*A*X = ( 0 D1 ), V'*B*X = ( 0 D2 )
+* where U and V are orthogonal and X is nonsingular, D1 and D2 are
+* ``diagonal''. The former GSVD form can be converted to the latter
+* form by taking the nonsingular matrix X as
+*
+* X = Q*( I 0 )
+* ( 0 inv(R) ).
+*
+* Arguments
+* =========
+*
+* JOBU (input) CHARACTER*1
+* = 'U': Orthogonal matrix U is computed;
+* = 'N': U is not computed.
+*
+* JOBV (input) CHARACTER*1
+* = 'V': Orthogonal matrix V is computed;
+* = 'N': V is not computed.
+*
+* JOBQ (input) CHARACTER*1
+* = 'Q': Orthogonal matrix Q is computed;
+* = 'N': Q is not computed.
+*
+* M (input) INTEGER
+* The number of rows of the matrix A. M >= 0.
+*
+* N (input) INTEGER
+* The number of columns of the matrices A and B. N >= 0.
+*
+* P (input) INTEGER
+* The number of rows of the matrix B. P >= 0.
+*
+* K (output) INTEGER
+* L (output) INTEGER
+* On exit, K and L specify the dimension of the subblocks
+* described in the Purpose section.
+* K + L = effective numerical rank of (A',B')'.
+*
+* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+* On entry, the M-by-N matrix A.
+* On exit, A contains the triangular matrix R, or part of R.
+* See Purpose for details.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,M).
+*
+* B (input/output) DOUBLE PRECISION array, dimension (LDB,N)
+* On entry, the P-by-N matrix B.
+* On exit, B contains the triangular matrix R if M-K-L < 0.
+* See Purpose for details.
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. LDB >= max(1,P).
+*
+* ALPHA (output) DOUBLE PRECISION array, dimension (N)
+* BETA (output) DOUBLE PRECISION array, dimension (N)
+* On exit, ALPHA and BETA contain the generalized singular
+* value pairs of A and B;
+* ALPHA(1:K) = 1,
+* BETA(1:K) = 0,
+* and if M-K-L >= 0,
+* ALPHA(K+1:K+L) = C,
+* BETA(K+1:K+L) = S,
+* or if M-K-L < 0,
+* ALPHA(K+1:M)=C, ALPHA(M+1:K+L)=0
+* BETA(K+1:M) =S, BETA(M+1:K+L) =1
+* and
+* ALPHA(K+L+1:N) = 0
+* BETA(K+L+1:N) = 0
+*
+* U (output) DOUBLE PRECISION array, dimension (LDU,M)
+* If JOBU = 'U', U contains the M-by-M orthogonal matrix U.
+* If JOBU = 'N', U is not referenced.
+*
+* LDU (input) INTEGER
+* The leading dimension of the array U. LDU >= max(1,M) if
+* JOBU = 'U'; LDU >= 1 otherwise.
+*
+* V (output) DOUBLE PRECISION array, dimension (LDV,P)
+* If JOBV = 'V', V contains the P-by-P orthogonal matrix V.
+* If JOBV = 'N', V is not referenced.
+*
+* LDV (input) INTEGER
+* The leading dimension of the array V. LDV >= max(1,P) if
+* JOBV = 'V'; LDV >= 1 otherwise.
+*
+* Q (output) DOUBLE PRECISION array, dimension (LDQ,N)
+* If JOBQ = 'Q', Q contains the N-by-N orthogonal matrix Q.
+* If JOBQ = 'N', Q is not referenced.
+*
+* LDQ (input) INTEGER
+* The leading dimension of the array Q. LDQ >= max(1,N) if
+* JOBQ = 'Q'; LDQ >= 1 otherwise.
+*
+* WORK (workspace) DOUBLE PRECISION array,
+* dimension (max(3*N,M,P)+N)
+*
+* IWORK (workspace/output) INTEGER array, dimension (N)
+* On exit, IWORK stores the sorting information. More
+* precisely, the following loop will sort ALPHA
+* for I = K+1, min(M,K+L)
+* swap ALPHA(I) and ALPHA(IWORK(I))
+* endfor
+* such that ALPHA(1) >= ALPHA(2) >= ... >= ALPHA(N).
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value.
+* > 0: if INFO = 1, the Jacobi-type procedure failed to
+* converge. For further details, see subroutine DTGSJA.
+*
+* Internal Parameters
+* ===================
+*
+* TOLA DOUBLE PRECISION
+* TOLB DOUBLE PRECISION
+* TOLA and TOLB are the thresholds to determine the effective
+* rank of (A',B')'. Generally, they are set to
+* TOLA = MAX(M,N)*norm(A)*MAZHEPS,
+* TOLB = MAX(P,N)*norm(B)*MAZHEPS.
+* The size of TOLA and TOLB may affect the size of backward
+* errors of the decomposition.
+*
+* Further Details
+* ===============
+*
+* 2-96 Based on modifications by
+* Ming Gu and Huan Ren, Computer Science Division, University of
+* California at Berkeley, USA
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ LOGICAL WANTQ, WANTU, WANTV
+ INTEGER I, IBND, ISUB, J, NCYCLE
+ DOUBLE PRECISION ANORM, BNORM, SMAX, TEMP, TOLA, TOLB, ULP, UNFL
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ DOUBLE PRECISION DLAMCH, DLANGE
+ EXTERNAL LSAME, DLAMCH, DLANGE
+* ..
+* .. External Subroutines ..
+ EXTERNAL DCOPY, DGGSVP, DTGSJA, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters
+*
+ WANTU = LSAME( JOBU, 'U' )
+ WANTV = LSAME( JOBV, 'V' )
+ WANTQ = LSAME( JOBQ, 'Q' )
+*
+ INFO = 0
+ IF( .NOT.( WANTU .OR. LSAME( JOBU, 'N' ) ) ) THEN
+ INFO = -1
+ ELSE IF( .NOT.( WANTV .OR. LSAME( JOBV, 'N' ) ) ) THEN
+ INFO = -2
+ ELSE IF( .NOT.( WANTQ .OR. LSAME( JOBQ, 'N' ) ) ) THEN
+ INFO = -3
+ ELSE IF( M.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -5
+ ELSE IF( P.LT.0 ) THEN
+ INFO = -6
+ ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+ INFO = -10
+ ELSE IF( LDB.LT.MAX( 1, P ) ) THEN
+ INFO = -12
+ ELSE IF( LDU.LT.1 .OR. ( WANTU .AND. LDU.LT.M ) ) THEN
+ INFO = -16
+ ELSE IF( LDV.LT.1 .OR. ( WANTV .AND. LDV.LT.P ) ) THEN
+ INFO = -18
+ ELSE IF( LDQ.LT.1 .OR. ( WANTQ .AND. LDQ.LT.N ) ) THEN
+ INFO = -20
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DGGSVD', -INFO )
+ RETURN
+ END IF
+*
+* Compute the Frobenius norm of matrices A and B
+*
+ ANORM = DLANGE( '1', M, N, A, LDA, WORK )
+ BNORM = DLANGE( '1', P, N, B, LDB, WORK )
+*
+* Get machine precision and set up threshold for determining
+* the effective numerical rank of the matrices A and B.
+*
+ ULP = DLAMCH( 'Precision' )
+ UNFL = DLAMCH( 'Safe Minimum' )
+ TOLA = MAX( M, N )*MAX( ANORM, UNFL )*ULP
+ TOLB = MAX( P, N )*MAX( BNORM, UNFL )*ULP
+*
+* Preprocessing
+*
+ CALL DGGSVP( JOBU, JOBV, JOBQ, M, P, N, A, LDA, B, LDB, TOLA,
+ $ TOLB, K, L, U, LDU, V, LDV, Q, LDQ, IWORK, WORK,
+ $ WORK( N+1 ), INFO )
+*
+* Compute the GSVD of two upper "triangular" matrices
+*
+ CALL 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 )
+*
+* Sort the singular values and store the pivot indices in IWORK
+* Copy ALPHA to WORK, then sort ALPHA in WORK
+*
+ CALL DCOPY( N, ALPHA, 1, WORK, 1 )
+ IBND = MIN( L, M-K )
+ DO 20 I = 1, IBND
+*
+* Scan for largest ALPHA(K+I)
+*
+ ISUB = I
+ SMAX = WORK( K+I )
+ DO 10 J = I + 1, IBND
+ TEMP = WORK( K+J )
+ IF( TEMP.GT.SMAX ) THEN
+ ISUB = J
+ SMAX = TEMP
+ END IF
+ 10 CONTINUE
+ IF( ISUB.NE.I ) THEN
+ WORK( K+ISUB ) = WORK( K+I )
+ WORK( K+I ) = SMAX
+ IWORK( K+I ) = K + ISUB
+ ELSE
+ IWORK( K+I ) = K + I
+ END IF
+ 20 CONTINUE
+*
+ RETURN
+*
+* End of DGGSVD
+*
+ END
+ 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 )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER JOBQ, JOBU, JOBV
+ INTEGER INFO, K, L, LDA, LDB, LDQ, LDU, LDV, M, N, P
+ DOUBLE PRECISION TOLA, TOLB
+* ..
+* .. Array Arguments ..
+ INTEGER IWORK( * )
+ DOUBLE PRECISION A( LDA, * ), B( LDB, * ), Q( LDQ, * ),
+ $ TAU( * ), U( LDU, * ), V( LDV, * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DGGSVP computes orthogonal matrices U, V and Q such that
+*
+* N-K-L K L
+* U'*A*Q = K ( 0 A12 A13 ) if M-K-L >= 0;
+* L ( 0 0 A23 )
+* M-K-L ( 0 0 0 )
+*
+* N-K-L K L
+* = K ( 0 A12 A13 ) if M-K-L < 0;
+* M-K ( 0 0 A23 )
+*
+* N-K-L K L
+* V'*B*Q = L ( 0 0 B13 )
+* P-L ( 0 0 0 )
+*
+* where the K-by-K matrix A12 and L-by-L matrix B13 are nonsingular
+* upper triangular; A23 is L-by-L upper triangular if M-K-L >= 0,
+* otherwise A23 is (M-K)-by-L upper trapezoidal. K+L = the effective
+* numerical rank of the (M+P)-by-N matrix (A',B')'. Z' denotes the
+* transpose of Z.
+*
+* This decomposition is the preprocessing step for computing the
+* Generalized Singular Value Decomposition (GSVD), see subroutine
+* DGGSVD.
+*
+* Arguments
+* =========
+*
+* JOBU (input) CHARACTER*1
+* = 'U': Orthogonal matrix U is computed;
+* = 'N': U is not computed.
+*
+* JOBV (input) CHARACTER*1
+* = 'V': Orthogonal matrix V is computed;
+* = 'N': V is not computed.
+*
+* JOBQ (input) CHARACTER*1
+* = 'Q': Orthogonal matrix Q is computed;
+* = 'N': Q is not computed.
+*
+* M (input) INTEGER
+* The number of rows of the matrix A. M >= 0.
+*
+* P (input) INTEGER
+* The number of rows of the matrix B. P >= 0.
+*
+* N (input) INTEGER
+* The number of columns of the matrices A and B. N >= 0.
+*
+* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+* On entry, the M-by-N matrix A.
+* On exit, A contains the triangular (or trapezoidal) matrix
+* described in the Purpose section.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,M).
+*
+* B (input/output) DOUBLE PRECISION array, dimension (LDB,N)
+* On entry, the P-by-N matrix B.
+* On exit, B contains the triangular matrix described in
+* the Purpose section.
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. LDB >= max(1,P).
+*
+* TOLA (input) DOUBLE PRECISION
+* TOLB (input) DOUBLE PRECISION
+* TOLA and TOLB are the thresholds to determine the effective
+* numerical rank of matrix B and a subblock of A. Generally,
+* they are set to
+* TOLA = MAX(M,N)*norm(A)*MAZHEPS,
+* TOLB = MAX(P,N)*norm(B)*MAZHEPS.
+* The size of TOLA and TOLB may affect the size of backward
+* errors of the decomposition.
+*
+* K (output) INTEGER
+* L (output) INTEGER
+* On exit, K and L specify the dimension of the subblocks
+* described in Purpose.
+* K + L = effective numerical rank of (A',B')'.
+*
+* U (output) DOUBLE PRECISION array, dimension (LDU,M)
+* If JOBU = 'U', U contains the orthogonal matrix U.
+* If JOBU = 'N', U is not referenced.
+*
+* LDU (input) INTEGER
+* The leading dimension of the array U. LDU >= max(1,M) if
+* JOBU = 'U'; LDU >= 1 otherwise.
+*
+* V (output) DOUBLE PRECISION array, dimension (LDV,M)
+* If JOBV = 'V', V contains the orthogonal matrix V.
+* If JOBV = 'N', V is not referenced.
+*
+* LDV (input) INTEGER
+* The leading dimension of the array V. LDV >= max(1,P) if
+* JOBV = 'V'; LDV >= 1 otherwise.
+*
+* Q (output) DOUBLE PRECISION array, dimension (LDQ,N)
+* If JOBQ = 'Q', Q contains the orthogonal matrix Q.
+* If JOBQ = 'N', Q is not referenced.
+*
+* LDQ (input) INTEGER
+* The leading dimension of the array Q. LDQ >= max(1,N) if
+* JOBQ = 'Q'; LDQ >= 1 otherwise.
+*
+* IWORK (workspace) INTEGER array, dimension (N)
+*
+* TAU (workspace) DOUBLE PRECISION array, dimension (N)
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (max(3*N,M,P))
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value.
+*
+*
+* Further Details
+* ===============
+*
+* The subroutine uses LAPACK subroutine DGEQPF for the QR factorization
+* with column pivoting to detect the effective numerical rank of the
+* a matrix. It may be replaced by a better rank determination strategy.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL FORWRD, WANTQ, WANTU, WANTV
+ INTEGER I, J
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL DGEQPF, DGEQR2, DGERQ2, DLACPY, DLAPMT, DLASET,
+ $ DORG2R, DORM2R, DORMR2, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters
+*
+ WANTU = LSAME( JOBU, 'U' )
+ WANTV = LSAME( JOBV, 'V' )
+ WANTQ = LSAME( JOBQ, 'Q' )
+ FORWRD = .TRUE.
+*
+ INFO = 0
+ IF( .NOT.( WANTU .OR. LSAME( JOBU, 'N' ) ) ) THEN
+ INFO = -1
+ ELSE IF( .NOT.( WANTV .OR. LSAME( JOBV, 'N' ) ) ) THEN
+ INFO = -2
+ ELSE IF( .NOT.( WANTQ .OR. LSAME( JOBQ, 'N' ) ) ) THEN
+ INFO = -3
+ ELSE IF( M.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( P.LT.0 ) THEN
+ INFO = -5
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -6
+ ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+ INFO = -8
+ ELSE IF( LDB.LT.MAX( 1, P ) ) THEN
+ INFO = -10
+ ELSE IF( LDU.LT.1 .OR. ( WANTU .AND. LDU.LT.M ) ) THEN
+ INFO = -16
+ ELSE IF( LDV.LT.1 .OR. ( WANTV .AND. LDV.LT.P ) ) THEN
+ INFO = -18
+ ELSE IF( LDQ.LT.1 .OR. ( WANTQ .AND. LDQ.LT.N ) ) THEN
+ INFO = -20
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DGGSVP', -INFO )
+ RETURN
+ END IF
+*
+* QR with column pivoting of B: B*P = V*( S11 S12 )
+* ( 0 0 )
+*
+ DO 10 I = 1, N
+ IWORK( I ) = 0
+ 10 CONTINUE
+ CALL DGEQPF( P, N, B, LDB, IWORK, TAU, WORK, INFO )
+*
+* Update A := A*P
+*
+ CALL DLAPMT( FORWRD, M, N, A, LDA, IWORK )
+*
+* Determine the effective rank of matrix B.
+*
+ L = 0
+ DO 20 I = 1, MIN( P, N )
+ IF( ABS( B( I, I ) ).GT.TOLB )
+ $ L = L + 1
+ 20 CONTINUE
+*
+ IF( WANTV ) THEN
+*
+* Copy the details of V, and form V.
+*
+ CALL DLASET( 'Full', P, P, ZERO, ZERO, V, LDV )
+ IF( P.GT.1 )
+ $ CALL DLACPY( 'Lower', P-1, N, B( 2, 1 ), LDB, V( 2, 1 ),
+ $ LDV )
+ CALL DORG2R( P, P, MIN( P, N ), V, LDV, TAU, WORK, INFO )
+ END IF
+*
+* Clean up B
+*
+ DO 40 J = 1, L - 1
+ DO 30 I = J + 1, L
+ B( I, J ) = ZERO
+ 30 CONTINUE
+ 40 CONTINUE
+ IF( P.GT.L )
+ $ CALL DLASET( 'Full', P-L, N, ZERO, ZERO, B( L+1, 1 ), LDB )
+*
+ IF( WANTQ ) THEN
+*
+* Set Q = I and Update Q := Q*P
+*
+ CALL DLASET( 'Full', N, N, ZERO, ONE, Q, LDQ )
+ CALL DLAPMT( FORWRD, N, N, Q, LDQ, IWORK )
+ END IF
+*
+ IF( P.GE.L .AND. N.NE.L ) THEN
+*
+* RQ factorization of (S11 S12): ( S11 S12 ) = ( 0 S12 )*Z
+*
+ CALL DGERQ2( L, N, B, LDB, TAU, WORK, INFO )
+*
+* Update A := A*Z'
+*
+ CALL DORMR2( 'Right', 'Transpose', M, N, L, B, LDB, TAU, A,
+ $ LDA, WORK, INFO )
+*
+ IF( WANTQ ) THEN
+*
+* Update Q := Q*Z'
+*
+ CALL DORMR2( 'Right', 'Transpose', N, N, L, B, LDB, TAU, Q,
+ $ LDQ, WORK, INFO )
+ END IF
+*
+* Clean up B
+*
+ CALL DLASET( 'Full', L, N-L, ZERO, ZERO, B, LDB )
+ DO 60 J = N - L + 1, N
+ DO 50 I = J - N + L + 1, L
+ B( I, J ) = ZERO
+ 50 CONTINUE
+ 60 CONTINUE
+*
+ END IF
+*
+* Let N-L L
+* A = ( A11 A12 ) M,
+*
+* then the following does the complete QR decomposition of A11:
+*
+* A11 = U*( 0 T12 )*P1'
+* ( 0 0 )
+*
+ DO 70 I = 1, N - L
+ IWORK( I ) = 0
+ 70 CONTINUE
+ CALL DGEQPF( M, N-L, A, LDA, IWORK, TAU, WORK, INFO )
+*
+* Determine the effective rank of A11
+*
+ K = 0
+ DO 80 I = 1, MIN( M, N-L )
+ IF( ABS( A( I, I ) ).GT.TOLA )
+ $ K = K + 1
+ 80 CONTINUE
+*
+* Update A12 := U'*A12, where A12 = A( 1:M, N-L+1:N )
+*
+ CALL DORM2R( 'Left', 'Transpose', M, L, MIN( M, N-L ), A, LDA,
+ $ TAU, A( 1, N-L+1 ), LDA, WORK, INFO )
+*
+ IF( WANTU ) THEN
+*
+* Copy the details of U, and form U
+*
+ CALL DLASET( 'Full', M, M, ZERO, ZERO, U, LDU )
+ IF( M.GT.1 )
+ $ CALL DLACPY( 'Lower', M-1, N-L, A( 2, 1 ), LDA, U( 2, 1 ),
+ $ LDU )
+ CALL DORG2R( M, M, MIN( M, N-L ), U, LDU, TAU, WORK, INFO )
+ END IF
+*
+ IF( WANTQ ) THEN
+*
+* Update Q( 1:N, 1:N-L ) = Q( 1:N, 1:N-L )*P1
+*
+ CALL DLAPMT( FORWRD, N, N-L, Q, LDQ, IWORK )
+ END IF
+*
+* Clean up A: set the strictly lower triangular part of
+* A(1:K, 1:K) = 0, and A( K+1:M, 1:N-L ) = 0.
+*
+ DO 100 J = 1, K - 1
+ DO 90 I = J + 1, K
+ A( I, J ) = ZERO
+ 90 CONTINUE
+ 100 CONTINUE
+ IF( M.GT.K )
+ $ CALL DLASET( 'Full', M-K, N-L, ZERO, ZERO, A( K+1, 1 ), LDA )
+*
+ IF( N-L.GT.K ) THEN
+*
+* RQ factorization of ( T11 T12 ) = ( 0 T12 )*Z1
+*
+ CALL DGERQ2( K, N-L, A, LDA, TAU, WORK, INFO )
+*
+ IF( WANTQ ) THEN
+*
+* Update Q( 1:N,1:N-L ) = Q( 1:N,1:N-L )*Z1'
+*
+ CALL DORMR2( 'Right', 'Transpose', N, N-L, K, A, LDA, TAU,
+ $ Q, LDQ, WORK, INFO )
+ END IF
+*
+* Clean up A
+*
+ CALL DLASET( 'Full', K, N-L-K, ZERO, ZERO, A, LDA )
+ DO 120 J = N - L - K + 1, N - L
+ DO 110 I = J - N + L + K + 1, K
+ A( I, J ) = ZERO
+ 110 CONTINUE
+ 120 CONTINUE
+*
+ END IF
+*
+ IF( M.GT.K ) THEN
+*
+* QR factorization of A( K+1:M,N-L+1:N )
+*
+ CALL DGEQR2( M-K, L, A( K+1, N-L+1 ), LDA, TAU, WORK, INFO )
+*
+ IF( WANTU ) THEN
+*
+* Update U(:,K+1:M) := U(:,K+1:M)*U1
+*
+ CALL DORM2R( 'Right', 'No transpose', M, M-K, MIN( M-K, L ),
+ $ A( K+1, N-L+1 ), LDA, TAU, U( 1, K+1 ), LDU,
+ $ WORK, INFO )
+ END IF
+*
+* Clean up
+*
+ DO 140 J = N - L + 1, N
+ DO 130 I = J - N + K + L + 1, M
+ A( I, J ) = ZERO
+ 130 CONTINUE
+ 140 CONTINUE
+*
+ END IF
+*
+ RETURN
+*
+* End of DGGSVP
+*
+ END
+ SUBROUTINE DGTCON( NORM, N, DL, D, DU, DU2, IPIV, ANORM, RCOND,
+ $ WORK, IWORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH.
+*
+* .. Scalar Arguments ..
+ CHARACTER NORM
+ INTEGER INFO, N
+ DOUBLE PRECISION ANORM, RCOND
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * ), IWORK( * )
+ DOUBLE PRECISION D( * ), DL( * ), DU( * ), DU2( * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DGTCON estimates the reciprocal of the condition number of a real
+* tridiagonal matrix A using the LU factorization as computed by
+* DGTTRF.
+*
+* An estimate is obtained for norm(inv(A)), and the reciprocal of the
+* condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).
+*
+* Arguments
+* =========
+*
+* NORM (input) CHARACTER*1
+* Specifies whether the 1-norm condition number or the
+* infinity-norm condition number is required:
+* = '1' or 'O': 1-norm;
+* = 'I': Infinity-norm.
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* DL (input) DOUBLE PRECISION array, dimension (N-1)
+* The (n-1) multipliers that define the matrix L from the
+* LU factorization of A as computed by DGTTRF.
+*
+* D (input) DOUBLE PRECISION array, dimension (N)
+* The n diagonal elements of the upper triangular matrix U from
+* the LU factorization of A.
+*
+* DU (input) DOUBLE PRECISION array, dimension (N-1)
+* The (n-1) elements of the first superdiagonal of U.
+*
+* DU2 (input) DOUBLE PRECISION array, dimension (N-2)
+* The (n-2) elements of the second superdiagonal of U.
+*
+* IPIV (input) INTEGER array, dimension (N)
+* The pivot indices; for 1 <= i <= n, row i of the matrix was
+* interchanged with row IPIV(i). IPIV(i) will always be either
+* i or i+1; IPIV(i) = i indicates a row interchange was not
+* required.
+*
+* ANORM (input) DOUBLE PRECISION
+* If NORM = '1' or 'O', the 1-norm of the original matrix A.
+* If NORM = 'I', the infinity-norm of the original matrix A.
+*
+* RCOND (output) DOUBLE PRECISION
+* The reciprocal of the condition number of the matrix A,
+* computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an
+* estimate of the 1-norm of inv(A) computed in this routine.
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (2*N)
+*
+* IWORK (workspace) INTEGER array, dimension (N)
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE, ZERO
+ PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL ONENRM
+ INTEGER I, KASE, KASE1
+ DOUBLE PRECISION AINVNM
+* ..
+* .. Local Arrays ..
+ INTEGER ISAVE( 3 )
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL DGTTRS, DLACN2, XERBLA
+* ..
+* .. Executable Statements ..
+*
+* Test the input arguments.
+*
+ INFO = 0
+ ONENRM = NORM.EQ.'1' .OR. LSAME( NORM, 'O' )
+ IF( .NOT.ONENRM .AND. .NOT.LSAME( NORM, 'I' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( ANORM.LT.ZERO ) THEN
+ INFO = -8
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DGTCON', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ RCOND = ZERO
+ IF( N.EQ.0 ) THEN
+ RCOND = ONE
+ RETURN
+ ELSE IF( ANORM.EQ.ZERO ) THEN
+ RETURN
+ END IF
+*
+* Check that D(1:N) is non-zero.
+*
+ DO 10 I = 1, N
+ IF( D( I ).EQ.ZERO )
+ $ RETURN
+ 10 CONTINUE
+*
+ AINVNM = ZERO
+ IF( ONENRM ) THEN
+ KASE1 = 1
+ ELSE
+ KASE1 = 2
+ END IF
+ KASE = 0
+ 20 CONTINUE
+ CALL DLACN2( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE, ISAVE )
+ IF( KASE.NE.0 ) THEN
+ IF( KASE.EQ.KASE1 ) THEN
+*
+* Multiply by inv(U)*inv(L).
+*
+ CALL DGTTRS( 'No transpose', N, 1, DL, D, DU, DU2, IPIV,
+ $ WORK, N, INFO )
+ ELSE
+*
+* Multiply by inv(L')*inv(U').
+*
+ CALL DGTTRS( 'Transpose', N, 1, DL, D, DU, DU2, IPIV, WORK,
+ $ N, INFO )
+ END IF
+ GO TO 20
+ END IF
+*
+* Compute the estimate of the reciprocal condition number.
+*
+ IF( AINVNM.NE.ZERO )
+ $ RCOND = ( ONE / AINVNM ) / ANORM
+*
+ RETURN
+*
+* End of DGTCON
+*
+ END
+ SUBROUTINE DGTRFS( TRANS, N, NRHS, DL, D, DU, DLF, DF, DUF, DU2,
+ $ IPIV, B, LDB, X, LDX, FERR, BERR, WORK, IWORK,
+ $ INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH.
+*
+* .. Scalar Arguments ..
+ CHARACTER TRANS
+ INTEGER INFO, LDB, LDX, N, NRHS
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * ), IWORK( * )
+ DOUBLE PRECISION B( LDB, * ), BERR( * ), D( * ), DF( * ),
+ $ DL( * ), DLF( * ), DU( * ), DU2( * ), DUF( * ),
+ $ FERR( * ), WORK( * ), X( LDX, * )
+* ..
+*
+* Purpose
+* =======
+*
+* DGTRFS improves the computed solution to a system of linear
+* equations when the coefficient matrix is tridiagonal, and provides
+* error bounds and backward error estimates for the solution.
+*
+* Arguments
+* =========
+*
+* TRANS (input) CHARACTER*1
+* Specifies the form of the system of equations:
+* = 'N': A * X = B (No transpose)
+* = 'T': A**T * X = B (Transpose)
+* = 'C': A**H * X = B (Conjugate transpose = Transpose)
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* NRHS (input) INTEGER
+* The number of right hand sides, i.e., the number of columns
+* of the matrix B. NRHS >= 0.
+*
+* DL (input) DOUBLE PRECISION array, dimension (N-1)
+* The (n-1) subdiagonal elements of A.
+*
+* D (input) DOUBLE PRECISION array, dimension (N)
+* The diagonal elements of A.
+*
+* DU (input) DOUBLE PRECISION array, dimension (N-1)
+* The (n-1) superdiagonal elements of A.
+*
+* DLF (input) DOUBLE PRECISION array, dimension (N-1)
+* The (n-1) multipliers that define the matrix L from the
+* LU factorization of A as computed by DGTTRF.
+*
+* DF (input) DOUBLE PRECISION array, dimension (N)
+* The n diagonal elements of the upper triangular matrix U from
+* the LU factorization of A.
+*
+* DUF (input) DOUBLE PRECISION array, dimension (N-1)
+* The (n-1) elements of the first superdiagonal of U.
+*
+* DU2 (input) DOUBLE PRECISION array, dimension (N-2)
+* The (n-2) elements of the second superdiagonal of U.
+*
+* IPIV (input) INTEGER array, dimension (N)
+* The pivot indices; for 1 <= i <= n, row i of the matrix was
+* interchanged with row IPIV(i). IPIV(i) will always be either
+* i or i+1; IPIV(i) = i indicates a row interchange was not
+* required.
+*
+* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS)
+* The right hand side matrix B.
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. LDB >= max(1,N).
+*
+* X (input/output) DOUBLE PRECISION array, dimension (LDX,NRHS)
+* On entry, the solution matrix X, as computed by DGTTRS.
+* On exit, the improved solution matrix X.
+*
+* LDX (input) INTEGER
+* The leading dimension of the array X. LDX >= max(1,N).
+*
+* FERR (output) DOUBLE PRECISION array, dimension (NRHS)
+* The estimated forward error bound for each solution vector
+* X(j) (the j-th column of the solution matrix X).
+* If XTRUE is the true solution corresponding to X(j), FERR(j)
+* is an estimated upper bound for the magnitude of the largest
+* element in (X(j) - XTRUE) divided by the magnitude of the
+* largest element in X(j). The estimate is as reliable as
+* the estimate for RCOND, and is almost always a slight
+* overestimate of the true error.
+*
+* BERR (output) DOUBLE PRECISION array, dimension (NRHS)
+* The componentwise relative backward error of each solution
+* vector X(j) (i.e., the smallest relative change in
+* any element of A or B that makes X(j) an exact solution).
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (3*N)
+*
+* IWORK (workspace) INTEGER array, dimension (N)
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+*
+* Internal Parameters
+* ===================
+*
+* ITMAX is the maximum number of steps of iterative refinement.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ INTEGER ITMAX
+ PARAMETER ( ITMAX = 5 )
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+ DOUBLE PRECISION TWO
+ PARAMETER ( TWO = 2.0D+0 )
+ DOUBLE PRECISION THREE
+ PARAMETER ( THREE = 3.0D+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL NOTRAN
+ CHARACTER TRANSN, TRANST
+ INTEGER COUNT, I, J, KASE, NZ
+ DOUBLE PRECISION EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN
+* ..
+* .. Local Arrays ..
+ INTEGER ISAVE( 3 )
+* ..
+* .. External Subroutines ..
+ EXTERNAL DAXPY, DCOPY, DGTTRS, DLACN2, DLAGTM, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ DOUBLE PRECISION DLAMCH
+ EXTERNAL LSAME, DLAMCH
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ NOTRAN = LSAME( TRANS, 'N' )
+ IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT.
+ $ LSAME( TRANS, 'C' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( NRHS.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -13
+ ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
+ INFO = -15
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DGTRFS', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN
+ DO 10 J = 1, NRHS
+ FERR( J ) = ZERO
+ BERR( J ) = ZERO
+ 10 CONTINUE
+ RETURN
+ END IF
+*
+ IF( NOTRAN ) THEN
+ TRANSN = 'N'
+ TRANST = 'T'
+ ELSE
+ TRANSN = 'T'
+ TRANST = 'N'
+ END IF
+*
+* NZ = maximum number of nonzero elements in each row of A, plus 1
+*
+ NZ = 4
+ EPS = DLAMCH( 'Epsilon' )
+ SAFMIN = DLAMCH( 'Safe minimum' )
+ SAFE1 = NZ*SAFMIN
+ SAFE2 = SAFE1 / EPS
+*
+* Do for each right hand side
+*
+ DO 110 J = 1, NRHS
+*
+ COUNT = 1
+ LSTRES = THREE
+ 20 CONTINUE
+*
+* Loop until stopping criterion is satisfied.
+*
+* Compute residual R = B - op(A) * X,
+* where op(A) = A, A**T, or A**H, depending on TRANS.
+*
+ CALL DCOPY( N, B( 1, J ), 1, WORK( N+1 ), 1 )
+ CALL DLAGTM( TRANS, N, 1, -ONE, DL, D, DU, X( 1, J ), LDX, ONE,
+ $ WORK( N+1 ), N )
+*
+* Compute abs(op(A))*abs(x) + abs(b) for use in the backward
+* error bound.
+*
+ IF( NOTRAN ) THEN
+ IF( N.EQ.1 ) THEN
+ WORK( 1 ) = ABS( B( 1, J ) ) + ABS( D( 1 )*X( 1, J ) )
+ ELSE
+ WORK( 1 ) = ABS( B( 1, J ) ) + ABS( D( 1 )*X( 1, J ) ) +
+ $ ABS( DU( 1 )*X( 2, J ) )
+ DO 30 I = 2, N - 1
+ WORK( I ) = ABS( B( I, J ) ) +
+ $ ABS( DL( I-1 )*X( I-1, J ) ) +
+ $ ABS( D( I )*X( I, J ) ) +
+ $ ABS( DU( I )*X( I+1, J ) )
+ 30 CONTINUE
+ WORK( N ) = ABS( B( N, J ) ) +
+ $ ABS( DL( N-1 )*X( N-1, J ) ) +
+ $ ABS( D( N )*X( N, J ) )
+ END IF
+ ELSE
+ IF( N.EQ.1 ) THEN
+ WORK( 1 ) = ABS( B( 1, J ) ) + ABS( D( 1 )*X( 1, J ) )
+ ELSE
+ WORK( 1 ) = ABS( B( 1, J ) ) + ABS( D( 1 )*X( 1, J ) ) +
+ $ ABS( DL( 1 )*X( 2, J ) )
+ DO 40 I = 2, N - 1
+ WORK( I ) = ABS( B( I, J ) ) +
+ $ ABS( DU( I-1 )*X( I-1, J ) ) +
+ $ ABS( D( I )*X( I, J ) ) +
+ $ ABS( DL( I )*X( I+1, J ) )
+ 40 CONTINUE
+ WORK( N ) = ABS( B( N, J ) ) +
+ $ ABS( DU( N-1 )*X( N-1, J ) ) +
+ $ ABS( D( N )*X( N, J ) )
+ END IF
+ END IF
+*
+* Compute componentwise relative backward error from formula
+*
+* max(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) )
+*
+* where abs(Z) is the componentwise absolute value of the matrix
+* or vector Z. If the i-th component of the denominator is less
+* than SAFE2, then SAFE1 is added to the i-th components of the
+* numerator and denominator before dividing.
+*
+ S = ZERO
+ DO 50 I = 1, N
+ IF( WORK( I ).GT.SAFE2 ) THEN
+ S = MAX( S, ABS( WORK( N+I ) ) / WORK( I ) )
+ ELSE
+ S = MAX( S, ( ABS( WORK( N+I ) )+SAFE1 ) /
+ $ ( WORK( I )+SAFE1 ) )
+ END IF
+ 50 CONTINUE
+ BERR( J ) = S
+*
+* Test stopping criterion. Continue iterating if
+* 1) The residual BERR(J) is larger than machine epsilon, and
+* 2) BERR(J) decreased by at least a factor of 2 during the
+* last iteration, and
+* 3) At most ITMAX iterations tried.
+*
+ IF( BERR( J ).GT.EPS .AND. TWO*BERR( J ).LE.LSTRES .AND.
+ $ COUNT.LE.ITMAX ) THEN
+*
+* Update solution and try again.
+*
+ CALL DGTTRS( TRANS, N, 1, DLF, DF, DUF, DU2, IPIV,
+ $ WORK( N+1 ), N, INFO )
+ CALL DAXPY( N, ONE, WORK( N+1 ), 1, X( 1, J ), 1 )
+ LSTRES = BERR( J )
+ COUNT = COUNT + 1
+ GO TO 20
+ END IF
+*
+* Bound error from formula
+*
+* norm(X - XTRUE) / norm(X) .le. FERR =
+* norm( abs(inv(op(A)))*
+* ( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X)
+*
+* where
+* norm(Z) is the magnitude of the largest component of Z
+* inv(op(A)) is the inverse of op(A)
+* abs(Z) is the componentwise absolute value of the matrix or
+* vector Z
+* NZ is the maximum number of nonzeros in any row of A, plus 1
+* EPS is machine epsilon
+*
+* The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B))
+* is incremented by SAFE1 if the i-th component of
+* abs(op(A))*abs(X) + abs(B) is less than SAFE2.
+*
+* Use DLACN2 to estimate the infinity-norm of the matrix
+* inv(op(A)) * diag(W),
+* where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) )))
+*
+ DO 60 I = 1, N
+ IF( WORK( I ).GT.SAFE2 ) THEN
+ WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I )
+ ELSE
+ WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I ) + SAFE1
+ END IF
+ 60 CONTINUE
+*
+ KASE = 0
+ 70 CONTINUE
+ CALL DLACN2( N, WORK( 2*N+1 ), WORK( N+1 ), IWORK, FERR( J ),
+ $ KASE, ISAVE )
+ IF( KASE.NE.0 ) THEN
+ IF( KASE.EQ.1 ) THEN
+*
+* Multiply by diag(W)*inv(op(A)**T).
+*
+ CALL DGTTRS( TRANST, N, 1, DLF, DF, DUF, DU2, IPIV,
+ $ WORK( N+1 ), N, INFO )
+ DO 80 I = 1, N
+ WORK( N+I ) = WORK( I )*WORK( N+I )
+ 80 CONTINUE
+ ELSE
+*
+* Multiply by inv(op(A))*diag(W).
+*
+ DO 90 I = 1, N
+ WORK( N+I ) = WORK( I )*WORK( N+I )
+ 90 CONTINUE
+ CALL DGTTRS( TRANSN, N, 1, DLF, DF, DUF, DU2, IPIV,
+ $ WORK( N+1 ), N, INFO )
+ END IF
+ GO TO 70
+ END IF
+*
+* Normalize error.
+*
+ LSTRES = ZERO
+ DO 100 I = 1, N
+ LSTRES = MAX( LSTRES, ABS( X( I, J ) ) )
+ 100 CONTINUE
+ IF( LSTRES.NE.ZERO )
+ $ FERR( J ) = FERR( J ) / LSTRES
+*
+ 110 CONTINUE
+*
+ RETURN
+*
+* End of DGTRFS
+*
+ END
+ SUBROUTINE DGTSV( N, NRHS, DL, D, DU, B, LDB, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LDB, N, NRHS
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION B( LDB, * ), D( * ), DL( * ), DU( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DGTSV solves the equation
+*
+* A*X = B,
+*
+* where A is an n by n tridiagonal matrix, by Gaussian elimination with
+* partial pivoting.
+*
+* Note that the equation A'*X = B may be solved by interchanging the
+* order of the arguments DU and DL.
+*
+* Arguments
+* =========
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* NRHS (input) INTEGER
+* The number of right hand sides, i.e., the number of columns
+* of the matrix B. NRHS >= 0.
+*
+* DL (input/output) DOUBLE PRECISION array, dimension (N-1)
+* On entry, DL must contain the (n-1) sub-diagonal elements of
+* A.
+*
+* On exit, DL is overwritten by the (n-2) elements of the
+* second super-diagonal of the upper triangular matrix U from
+* the LU factorization of A, in DL(1), ..., DL(n-2).
+*
+* D (input/output) DOUBLE PRECISION array, dimension (N)
+* On entry, D must contain the diagonal elements of A.
+*
+* On exit, D is overwritten by the n diagonal elements of U.
+*
+* DU (input/output) DOUBLE PRECISION array, dimension (N-1)
+* On entry, DU must contain the (n-1) super-diagonal elements
+* of A.
+*
+* On exit, DU is overwritten by the (n-1) elements of the first
+* super-diagonal of U.
+*
+* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
+* On entry, the N by NRHS matrix of right hand side matrix B.
+* On exit, if INFO = 0, the N by NRHS solution matrix X.
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. LDB >= max(1,N).
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* > 0: if INFO = i, U(i,i) is exactly zero, and the solution
+* has not been computed. The factorization has not been
+* completed unless i = N.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO
+ PARAMETER ( ZERO = 0.0D+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, J
+ DOUBLE PRECISION FACT, TEMP
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX
+* ..
+* .. External Subroutines ..
+ EXTERNAL XERBLA
+* ..
+* .. Executable Statements ..
+*
+ INFO = 0
+ IF( N.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( NRHS.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -7
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DGTSV ', -INFO )
+ RETURN
+ END IF
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+ IF( NRHS.EQ.1 ) THEN
+ DO 10 I = 1, N - 2
+ IF( ABS( D( I ) ).GE.ABS( DL( I ) ) ) THEN
+*
+* No row interchange required
+*
+ IF( D( I ).NE.ZERO ) THEN
+ FACT = DL( I ) / D( I )
+ D( I+1 ) = D( I+1 ) - FACT*DU( I )
+ B( I+1, 1 ) = B( I+1, 1 ) - FACT*B( I, 1 )
+ ELSE
+ INFO = I
+ RETURN
+ END IF
+ DL( I ) = ZERO
+ ELSE
+*
+* Interchange rows I and I+1
+*
+ FACT = D( I ) / DL( I )
+ D( I ) = DL( I )
+ TEMP = D( I+1 )
+ D( I+1 ) = DU( I ) - FACT*TEMP
+ DL( I ) = DU( I+1 )
+ DU( I+1 ) = -FACT*DL( I )
+ DU( I ) = TEMP
+ TEMP = B( I, 1 )
+ B( I, 1 ) = B( I+1, 1 )
+ B( I+1, 1 ) = TEMP - FACT*B( I+1, 1 )
+ END IF
+ 10 CONTINUE
+ IF( N.GT.1 ) THEN
+ I = N - 1
+ IF( ABS( D( I ) ).GE.ABS( DL( I ) ) ) THEN
+ IF( D( I ).NE.ZERO ) THEN
+ FACT = DL( I ) / D( I )
+ D( I+1 ) = D( I+1 ) - FACT*DU( I )
+ B( I+1, 1 ) = B( I+1, 1 ) - FACT*B( I, 1 )
+ ELSE
+ INFO = I
+ RETURN
+ END IF
+ ELSE
+ FACT = D( I ) / DL( I )
+ D( I ) = DL( I )
+ TEMP = D( I+1 )
+ D( I+1 ) = DU( I ) - FACT*TEMP
+ DU( I ) = TEMP
+ TEMP = B( I, 1 )
+ B( I, 1 ) = B( I+1, 1 )
+ B( I+1, 1 ) = TEMP - FACT*B( I+1, 1 )
+ END IF
+ END IF
+ IF( D( N ).EQ.ZERO ) THEN
+ INFO = N
+ RETURN
+ END IF
+ ELSE
+ DO 40 I = 1, N - 2
+ IF( ABS( D( I ) ).GE.ABS( DL( I ) ) ) THEN
+*
+* No row interchange required
+*
+ IF( D( I ).NE.ZERO ) THEN
+ FACT = DL( I ) / D( I )
+ D( I+1 ) = D( I+1 ) - FACT*DU( I )
+ DO 20 J = 1, NRHS
+ B( I+1, J ) = B( I+1, J ) - FACT*B( I, J )
+ 20 CONTINUE
+ ELSE
+ INFO = I
+ RETURN
+ END IF
+ DL( I ) = ZERO
+ ELSE
+*
+* Interchange rows I and I+1
+*
+ FACT = D( I ) / DL( I )
+ D( I ) = DL( I )
+ TEMP = D( I+1 )
+ D( I+1 ) = DU( I ) - FACT*TEMP
+ DL( I ) = DU( I+1 )
+ DU( I+1 ) = -FACT*DL( I )
+ DU( I ) = TEMP
+ DO 30 J = 1, NRHS
+ TEMP = B( I, J )
+ B( I, J ) = B( I+1, J )
+ B( I+1, J ) = TEMP - FACT*B( I+1, J )
+ 30 CONTINUE
+ END IF
+ 40 CONTINUE
+ IF( N.GT.1 ) THEN
+ I = N - 1
+ IF( ABS( D( I ) ).GE.ABS( DL( I ) ) ) THEN
+ IF( D( I ).NE.ZERO ) THEN
+ FACT = DL( I ) / D( I )
+ D( I+1 ) = D( I+1 ) - FACT*DU( I )
+ DO 50 J = 1, NRHS
+ B( I+1, J ) = B( I+1, J ) - FACT*B( I, J )
+ 50 CONTINUE
+ ELSE
+ INFO = I
+ RETURN
+ END IF
+ ELSE
+ FACT = D( I ) / DL( I )
+ D( I ) = DL( I )
+ TEMP = D( I+1 )
+ D( I+1 ) = DU( I ) - FACT*TEMP
+ DU( I ) = TEMP
+ DO 60 J = 1, NRHS
+ TEMP = B( I, J )
+ B( I, J ) = B( I+1, J )
+ B( I+1, J ) = TEMP - FACT*B( I+1, J )
+ 60 CONTINUE
+ END IF
+ END IF
+ IF( D( N ).EQ.ZERO ) THEN
+ INFO = N
+ RETURN
+ END IF
+ END IF
+*
+* Back solve with the matrix U from the factorization.
+*
+ IF( NRHS.LE.2 ) THEN
+ J = 1
+ 70 CONTINUE
+ B( N, J ) = B( N, J ) / D( N )
+ IF( N.GT.1 )
+ $ B( N-1, J ) = ( B( N-1, J )-DU( N-1 )*B( N, J ) ) / D( N-1 )
+ DO 80 I = N - 2, 1, -1
+ B( I, J ) = ( B( I, J )-DU( I )*B( I+1, J )-DL( I )*
+ $ B( I+2, J ) ) / D( I )
+ 80 CONTINUE
+ IF( J.LT.NRHS ) THEN
+ J = J + 1
+ GO TO 70
+ END IF
+ ELSE
+ DO 100 J = 1, NRHS
+ B( N, J ) = B( N, J ) / D( N )
+ IF( N.GT.1 )
+ $ B( N-1, J ) = ( B( N-1, J )-DU( N-1 )*B( N, J ) ) /
+ $ D( N-1 )
+ DO 90 I = N - 2, 1, -1
+ B( I, J ) = ( B( I, J )-DU( I )*B( I+1, J )-DL( I )*
+ $ B( I+2, J ) ) / D( I )
+ 90 CONTINUE
+ 100 CONTINUE
+ END IF
+*
+ RETURN
+*
+* End of DGTSV
+*
+ END
+ SUBROUTINE DGTSVX( FACT, TRANS, N, NRHS, DL, D, DU, DLF, DF, DUF,
+ $ DU2, IPIV, B, LDB, X, LDX, RCOND, FERR, BERR,
+ $ WORK, IWORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER FACT, TRANS
+ INTEGER INFO, LDB, LDX, N, NRHS
+ DOUBLE PRECISION RCOND
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * ), IWORK( * )
+ DOUBLE PRECISION B( LDB, * ), BERR( * ), D( * ), DF( * ),
+ $ DL( * ), DLF( * ), DU( * ), DU2( * ), DUF( * ),
+ $ FERR( * ), WORK( * ), X( LDX, * )
+* ..
+*
+* Purpose
+* =======
+*
+* DGTSVX uses the LU factorization to compute the solution to a real
+* system of linear equations A * X = B or A**T * X = B,
+* where A is a tridiagonal matrix of order N and X and B are N-by-NRHS
+* matrices.
+*
+* Error bounds on the solution and a condition estimate are also
+* provided.
+*
+* Description
+* ===========
+*
+* The following steps are performed:
+*
+* 1. If FACT = 'N', the LU decomposition is used to factor the matrix A
+* as A = L * U, where L is a product of permutation and unit lower
+* bidiagonal matrices and U is upper triangular with nonzeros in
+* only the main diagonal and first two superdiagonals.
+*
+* 2. If some U(i,i)=0, so that U is exactly singular, then the routine
+* returns with INFO = i. Otherwise, the factored form of A is used
+* to estimate the condition number of the matrix A. If the
+* reciprocal of the condition number is less than machine precision,
+* INFO = N+1 is returned as a warning, but the routine still goes on
+* to solve for X and compute error bounds as described below.
+*
+* 3. The system of equations is solved for X using the factored form
+* of A.
+*
+* 4. Iterative refinement is applied to improve the computed solution
+* matrix and calculate error bounds and backward error estimates
+* for it.
+*
+* Arguments
+* =========
+*
+* FACT (input) CHARACTER*1
+* Specifies whether or not the factored form of A has been
+* supplied on entry.
+* = 'F': DLF, DF, DUF, DU2, and IPIV contain the factored
+* form of A; DL, D, DU, DLF, DF, DUF, DU2 and IPIV
+* will not be modified.
+* = 'N': The matrix will be copied to DLF, DF, and DUF
+* and factored.
+*
+* TRANS (input) CHARACTER*1
+* Specifies the form of the system of equations:
+* = 'N': A * X = B (No transpose)
+* = 'T': A**T * X = B (Transpose)
+* = 'C': A**H * X = B (Conjugate transpose = Transpose)
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* NRHS (input) INTEGER
+* The number of right hand sides, i.e., the number of columns
+* of the matrix B. NRHS >= 0.
+*
+* DL (input) DOUBLE PRECISION array, dimension (N-1)
+* The (n-1) subdiagonal elements of A.
+*
+* D (input) DOUBLE PRECISION array, dimension (N)
+* The n diagonal elements of A.
+*
+* DU (input) DOUBLE PRECISION array, dimension (N-1)
+* The (n-1) superdiagonal elements of A.
+*
+* DLF (input or output) DOUBLE PRECISION array, dimension (N-1)
+* If FACT = 'F', then DLF is an input argument and on entry
+* contains the (n-1) multipliers that define the matrix L from
+* the LU factorization of A as computed by DGTTRF.
+*
+* If FACT = 'N', then DLF is an output argument and on exit
+* contains the (n-1) multipliers that define the matrix L from
+* the LU factorization of A.
+*
+* DF (input or output) DOUBLE PRECISION array, dimension (N)
+* If FACT = 'F', then DF is an input argument and on entry
+* contains the n diagonal elements of the upper triangular
+* matrix U from the LU factorization of A.
+*
+* If FACT = 'N', then DF is an output argument and on exit
+* contains the n diagonal elements of the upper triangular
+* matrix U from the LU factorization of A.
+*
+* DUF (input or output) DOUBLE PRECISION array, dimension (N-1)
+* If FACT = 'F', then DUF is an input argument and on entry
+* contains the (n-1) elements of the first superdiagonal of U.
+*
+* If FACT = 'N', then DUF is an output argument and on exit
+* contains the (n-1) elements of the first superdiagonal of U.
+*
+* DU2 (input or output) DOUBLE PRECISION array, dimension (N-2)
+* If FACT = 'F', then DU2 is an input argument and on entry
+* contains the (n-2) elements of the second superdiagonal of
+* U.
+*
+* If FACT = 'N', then DU2 is an output argument and on exit
+* contains the (n-2) elements of the second superdiagonal of
+* U.
+*
+* IPIV (input or output) INTEGER array, dimension (N)
+* If FACT = 'F', then IPIV is an input argument and on entry
+* contains the pivot indices from the LU factorization of A as
+* computed by DGTTRF.
+*
+* If FACT = 'N', then IPIV is an output argument and on exit
+* contains the pivot indices from the LU factorization of A;
+* row i of the matrix was interchanged with row IPIV(i).
+* IPIV(i) will always be either i or i+1; IPIV(i) = i indicates
+* a row interchange was not required.
+*
+* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS)
+* The N-by-NRHS right hand side matrix B.
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. LDB >= max(1,N).
+*
+* X (output) DOUBLE PRECISION array, dimension (LDX,NRHS)
+* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X.
+*
+* LDX (input) INTEGER
+* The leading dimension of the array X. LDX >= max(1,N).
+*
+* RCOND (output) DOUBLE PRECISION
+* The estimate of the reciprocal condition number of the matrix
+* A. If RCOND is less than the machine precision (in
+* particular, if RCOND = 0), the matrix is singular to working
+* precision. This condition is indicated by a return code of
+* INFO > 0.
+*
+* FERR (output) DOUBLE PRECISION array, dimension (NRHS)
+* The estimated forward error bound for each solution vector
+* X(j) (the j-th column of the solution matrix X).
+* If XTRUE is the true solution corresponding to X(j), FERR(j)
+* is an estimated upper bound for the magnitude of the largest
+* element in (X(j) - XTRUE) divided by the magnitude of the
+* largest element in X(j). The estimate is as reliable as
+* the estimate for RCOND, and is almost always a slight
+* overestimate of the true error.
+*
+* BERR (output) DOUBLE PRECISION array, dimension (NRHS)
+* The componentwise relative backward error of each solution
+* vector X(j) (i.e., the smallest relative change in
+* any element of A or B that makes X(j) an exact solution).
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (3*N)
+*
+* IWORK (workspace) INTEGER array, dimension (N)
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* > 0: if INFO = i, and i is
+* <= N: U(i,i) is exactly zero. The factorization
+* has not been completed unless i = N, but the
+* factor U is exactly singular, so the solution
+* and error bounds could not be computed.
+* RCOND = 0 is returned.
+* = N+1: U is nonsingular, but RCOND is less than machine
+* precision, meaning that the matrix is singular
+* to working precision. Nevertheless, the
+* solution and error bounds are computed because
+* there are a number of situations where the
+* computed solution can be more accurate than the
+* value of RCOND would suggest.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO
+ PARAMETER ( ZERO = 0.0D+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL NOFACT, NOTRAN
+ CHARACTER NORM
+ DOUBLE PRECISION ANORM
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ DOUBLE PRECISION DLAMCH, DLANGT
+ EXTERNAL LSAME, DLAMCH, DLANGT
+* ..
+* .. External Subroutines ..
+ EXTERNAL DCOPY, DGTCON, DGTRFS, DGTTRF, DGTTRS, DLACPY,
+ $ XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+ INFO = 0
+ NOFACT = LSAME( FACT, 'N' )
+ NOTRAN = LSAME( TRANS, 'N' )
+ IF( .NOT.NOFACT .AND. .NOT.LSAME( FACT, 'F' ) ) THEN
+ INFO = -1
+ ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT.
+ $ LSAME( TRANS, 'C' ) ) THEN
+ INFO = -2
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( NRHS.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -14
+ ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
+ INFO = -16
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DGTSVX', -INFO )
+ RETURN
+ END IF
+*
+ IF( NOFACT ) THEN
+*
+* Compute the LU factorization of A.
+*
+ CALL DCOPY( N, D, 1, DF, 1 )
+ IF( N.GT.1 ) THEN
+ CALL DCOPY( N-1, DL, 1, DLF, 1 )
+ CALL DCOPY( N-1, DU, 1, DUF, 1 )
+ END IF
+ CALL DGTTRF( N, DLF, DF, DUF, DU2, IPIV, INFO )
+*
+* Return if INFO is non-zero.
+*
+ IF( INFO.GT.0 )THEN
+ RCOND = ZERO
+ RETURN
+ END IF
+ END IF
+*
+* Compute the norm of the matrix A.
+*
+ IF( NOTRAN ) THEN
+ NORM = '1'
+ ELSE
+ NORM = 'I'
+ END IF
+ ANORM = DLANGT( NORM, N, DL, D, DU )
+*
+* Compute the reciprocal of the condition number of A.
+*
+ CALL DGTCON( NORM, N, DLF, DF, DUF, DU2, IPIV, ANORM, RCOND, WORK,
+ $ IWORK, INFO )
+*
+* Compute the solution vectors X.
+*
+ CALL DLACPY( 'Full', N, NRHS, B, LDB, X, LDX )
+ CALL DGTTRS( TRANS, N, NRHS, DLF, DF, DUF, DU2, IPIV, X, LDX,
+ $ INFO )
+*
+* Use iterative refinement to improve the computed solutions and
+* compute error bounds and backward error estimates for them.
+*
+ CALL DGTRFS( TRANS, N, NRHS, DL, D, DU, DLF, DF, DUF, DU2, IPIV,
+ $ B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO )
+*
+* Set INFO = N+1 if the matrix is singular to working precision.
+*
+ IF( RCOND.LT.DLAMCH( 'Epsilon' ) )
+ $ INFO = N + 1
+*
+ RETURN
+*
+* End of DGTSVX
+*
+ END
+ SUBROUTINE DGTTRF( N, DL, D, DU, DU2, IPIV, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, N
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ DOUBLE PRECISION D( * ), DL( * ), DU( * ), DU2( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DGTTRF computes an LU factorization of a real tridiagonal matrix A
+* using elimination with partial pivoting and row interchanges.
+*
+* The factorization has the form
+* A = L * U
+* where L is a product of permutation and unit lower bidiagonal
+* matrices and U is upper triangular with nonzeros in only the main
+* diagonal and first two superdiagonals.
+*
+* Arguments
+* =========
+*
+* N (input) INTEGER
+* The order of the matrix A.
+*
+* DL (input/output) DOUBLE PRECISION array, dimension (N-1)
+* On entry, DL must contain the (n-1) sub-diagonal elements of
+* A.
+*
+* On exit, DL is overwritten by the (n-1) multipliers that
+* define the matrix L from the LU factorization of A.
+*
+* D (input/output) DOUBLE PRECISION array, dimension (N)
+* On entry, D must contain the diagonal elements of A.
+*
+* On exit, D is overwritten by the n diagonal elements of the
+* upper triangular matrix U from the LU factorization of A.
+*
+* DU (input/output) DOUBLE PRECISION array, dimension (N-1)
+* On entry, DU must contain the (n-1) super-diagonal elements
+* of A.
+*
+* On exit, DU is overwritten by the (n-1) elements of the first
+* super-diagonal of U.
+*
+* DU2 (output) DOUBLE PRECISION array, dimension (N-2)
+* On exit, DU2 is overwritten by the (n-2) elements of the
+* second super-diagonal of U.
+*
+* IPIV (output) INTEGER array, dimension (N)
+* The pivot indices; for 1 <= i <= n, row i of the matrix was
+* interchanged with row IPIV(i). IPIV(i) will always be either
+* i or i+1; IPIV(i) = i indicates a row interchange was not
+* required.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -k, the k-th argument had an illegal value
+* > 0: if INFO = k, U(k,k) is exactly zero. The factorization
+* has been completed, but the factor U is exactly
+* singular, and division by zero will occur if it is used
+* to solve a system of equations.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO
+ PARAMETER ( ZERO = 0.0D+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I
+ DOUBLE PRECISION FACT, TEMP
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS
+* ..
+* .. External Subroutines ..
+ EXTERNAL XERBLA
+* ..
+* .. Executable Statements ..
+*
+ INFO = 0
+ IF( N.LT.0 ) THEN
+ INFO = -1
+ CALL XERBLA( 'DGTTRF', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+* Initialize IPIV(i) = i and DU2(I) = 0
+*
+ DO 10 I = 1, N
+ IPIV( I ) = I
+ 10 CONTINUE
+ DO 20 I = 1, N - 2
+ DU2( I ) = ZERO
+ 20 CONTINUE
+*
+ DO 30 I = 1, N - 2
+ IF( ABS( D( I ) ).GE.ABS( DL( I ) ) ) THEN
+*
+* No row interchange required, eliminate DL(I)
+*
+ IF( D( I ).NE.ZERO ) THEN
+ FACT = DL( I ) / D( I )
+ DL( I ) = FACT
+ D( I+1 ) = D( I+1 ) - FACT*DU( I )
+ END IF
+ ELSE
+*
+* Interchange rows I and I+1, eliminate DL(I)
+*
+ FACT = D( I ) / DL( I )
+ D( I ) = DL( I )
+ DL( I ) = FACT
+ TEMP = DU( I )
+ DU( I ) = D( I+1 )
+ D( I+1 ) = TEMP - FACT*D( I+1 )
+ DU2( I ) = DU( I+1 )
+ DU( I+1 ) = -FACT*DU( I+1 )
+ IPIV( I ) = I + 1
+ END IF
+ 30 CONTINUE
+ IF( N.GT.1 ) THEN
+ I = N - 1
+ IF( ABS( D( I ) ).GE.ABS( DL( I ) ) ) THEN
+ IF( D( I ).NE.ZERO ) THEN
+ FACT = DL( I ) / D( I )
+ DL( I ) = FACT
+ D( I+1 ) = D( I+1 ) - FACT*DU( I )
+ END IF
+ ELSE
+ FACT = D( I ) / DL( I )
+ D( I ) = DL( I )
+ DL( I ) = FACT
+ TEMP = DU( I )
+ DU( I ) = D( I+1 )
+ D( I+1 ) = TEMP - FACT*D( I+1 )
+ IPIV( I ) = I + 1
+ END IF
+ END IF
+*
+* Check for a zero on the diagonal of U.
+*
+ DO 40 I = 1, N
+ IF( D( I ).EQ.ZERO ) THEN
+ INFO = I
+ GO TO 50
+ END IF
+ 40 CONTINUE
+ 50 CONTINUE
+*
+ RETURN
+*
+* End of DGTTRF
+*
+ END
+ SUBROUTINE DGTTRS( TRANS, N, NRHS, DL, D, DU, DU2, IPIV, B, LDB,
+ $ INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER TRANS
+ INTEGER INFO, LDB, N, NRHS
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ DOUBLE PRECISION B( LDB, * ), D( * ), DL( * ), DU( * ), DU2( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DGTTRS solves one of the systems of equations
+* A*X = B or A'*X = B,
+* with a tridiagonal matrix A using the LU factorization computed
+* by DGTTRF.
+*
+* Arguments
+* =========
+*
+* TRANS (input) CHARACTER*1
+* Specifies the form of the system of equations.
+* = 'N': A * X = B (No transpose)
+* = 'T': A'* X = B (Transpose)
+* = 'C': A'* X = B (Conjugate transpose = Transpose)
+*
+* N (input) INTEGER
+* The order of the matrix A.
+*
+* NRHS (input) INTEGER
+* The number of right hand sides, i.e., the number of columns
+* of the matrix B. NRHS >= 0.
+*
+* DL (input) DOUBLE PRECISION array, dimension (N-1)
+* The (n-1) multipliers that define the matrix L from the
+* LU factorization of A.
+*
+* D (input) DOUBLE PRECISION array, dimension (N)
+* The n diagonal elements of the upper triangular matrix U from
+* the LU factorization of A.
+*
+* DU (input) DOUBLE PRECISION array, dimension (N-1)
+* The (n-1) elements of the first super-diagonal of U.
+*
+* DU2 (input) DOUBLE PRECISION array, dimension (N-2)
+* The (n-2) elements of the second super-diagonal of U.
+*
+* IPIV (input) INTEGER array, dimension (N)
+* The pivot indices; for 1 <= i <= n, row i of the matrix was
+* interchanged with row IPIV(i). IPIV(i) will always be either
+* i or i+1; IPIV(i) = i indicates a row interchange was not
+* required.
+*
+* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
+* On entry, the matrix of right hand side vectors B.
+* On exit, B is overwritten by the solution vectors X.
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. LDB >= max(1,N).
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ LOGICAL NOTRAN
+ INTEGER ITRANS, J, JB, NB
+* ..
+* .. External Functions ..
+ INTEGER ILAENV
+ EXTERNAL ILAENV
+* ..
+* .. External Subroutines ..
+ EXTERNAL DGTTS2, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+ INFO = 0
+ NOTRAN = ( TRANS.EQ.'N' .OR. TRANS.EQ.'n' )
+ IF( .NOT.NOTRAN .AND. .NOT.( TRANS.EQ.'T' .OR. TRANS.EQ.
+ $ 't' ) .AND. .NOT.( TRANS.EQ.'C' .OR. TRANS.EQ.'c' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( NRHS.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( LDB.LT.MAX( N, 1 ) ) THEN
+ INFO = -10
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DGTTRS', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 .OR. NRHS.EQ.0 )
+ $ RETURN
+*
+* Decode TRANS
+*
+ IF( NOTRAN ) THEN
+ ITRANS = 0
+ ELSE
+ ITRANS = 1
+ END IF
+*
+* Determine the number of right-hand sides to solve at a time.
+*
+ IF( NRHS.EQ.1 ) THEN
+ NB = 1
+ ELSE
+ NB = MAX( 1, ILAENV( 1, 'DGTTRS', TRANS, N, NRHS, -1, -1 ) )
+ END IF
+*
+ IF( NB.GE.NRHS ) THEN
+ CALL DGTTS2( ITRANS, N, NRHS, DL, D, DU, DU2, IPIV, B, LDB )
+ ELSE
+ DO 10 J = 1, NRHS, NB
+ JB = MIN( NRHS-J+1, NB )
+ CALL DGTTS2( ITRANS, N, JB, DL, D, DU, DU2, IPIV, B( 1, J ),
+ $ LDB )
+ 10 CONTINUE
+ END IF
+*
+* End of DGTTRS
+*
+ END
+ SUBROUTINE DGTTS2( ITRANS, N, NRHS, DL, D, DU, DU2, IPIV, B, LDB )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER ITRANS, LDB, N, NRHS
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ DOUBLE PRECISION B( LDB, * ), D( * ), DL( * ), DU( * ), DU2( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DGTTS2 solves one of the systems of equations
+* A*X = B or A'*X = B,
+* with a tridiagonal matrix A using the LU factorization computed
+* by DGTTRF.
+*
+* Arguments
+* =========
+*
+* ITRANS (input) INTEGER
+* Specifies the form of the system of equations.
+* = 0: A * X = B (No transpose)
+* = 1: A'* X = B (Transpose)
+* = 2: A'* X = B (Conjugate transpose = Transpose)
+*
+* N (input) INTEGER
+* The order of the matrix A.
+*
+* NRHS (input) INTEGER
+* The number of right hand sides, i.e., the number of columns
+* of the matrix B. NRHS >= 0.
+*
+* DL (input) DOUBLE PRECISION array, dimension (N-1)
+* The (n-1) multipliers that define the matrix L from the
+* LU factorization of A.
+*
+* D (input) DOUBLE PRECISION array, dimension (N)
+* The n diagonal elements of the upper triangular matrix U from
+* the LU factorization of A.
+*
+* DU (input) DOUBLE PRECISION array, dimension (N-1)
+* The (n-1) elements of the first super-diagonal of U.
+*
+* DU2 (input) DOUBLE PRECISION array, dimension (N-2)
+* The (n-2) elements of the second super-diagonal of U.
+*
+* IPIV (input) INTEGER array, dimension (N)
+* The pivot indices; for 1 <= i <= n, row i of the matrix was
+* interchanged with row IPIV(i). IPIV(i) will always be either
+* i or i+1; IPIV(i) = i indicates a row interchange was not
+* required.
+*
+* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
+* On entry, the matrix of right hand side vectors B.
+* On exit, B is overwritten by the solution vectors X.
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. LDB >= max(1,N).
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ INTEGER I, IP, J
+ DOUBLE PRECISION TEMP
+* ..
+* .. Executable Statements ..
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 .OR. NRHS.EQ.0 )
+ $ RETURN
+*
+ IF( ITRANS.EQ.0 ) THEN
+*
+* Solve A*X = B using the LU factorization of A,
+* overwriting each right hand side vector with its solution.
+*
+ IF( NRHS.LE.1 ) THEN
+ J = 1
+ 10 CONTINUE
+*
+* Solve L*x = b.
+*
+ DO 20 I = 1, N - 1
+ IP = IPIV( I )
+ TEMP = B( I+1-IP+I, J ) - DL( I )*B( IP, J )
+ B( I, J ) = B( IP, J )
+ B( I+1, J ) = TEMP
+ 20 CONTINUE
+*
+* Solve U*x = b.
+*
+ B( N, J ) = B( N, J ) / D( N )
+ IF( N.GT.1 )
+ $ B( N-1, J ) = ( B( N-1, J )-DU( N-1 )*B( N, J ) ) /
+ $ D( N-1 )
+ DO 30 I = N - 2, 1, -1
+ B( I, J ) = ( B( I, J )-DU( I )*B( I+1, J )-DU2( I )*
+ $ B( I+2, J ) ) / D( I )
+ 30 CONTINUE
+ IF( J.LT.NRHS ) THEN
+ J = J + 1
+ GO TO 10
+ END IF
+ ELSE
+ DO 60 J = 1, NRHS
+*
+* Solve L*x = b.
+*
+ DO 40 I = 1, N - 1
+ IF( IPIV( I ).EQ.I ) THEN
+ B( I+1, J ) = B( I+1, J ) - DL( I )*B( I, J )
+ ELSE
+ TEMP = B( I, J )
+ B( I, J ) = B( I+1, J )
+ B( I+1, J ) = TEMP - DL( I )*B( I, J )
+ END IF
+ 40 CONTINUE
+*
+* Solve U*x = b.
+*
+ B( N, J ) = B( N, J ) / D( N )
+ IF( N.GT.1 )
+ $ B( N-1, J ) = ( B( N-1, J )-DU( N-1 )*B( N, J ) ) /
+ $ D( N-1 )
+ DO 50 I = N - 2, 1, -1
+ B( I, J ) = ( B( I, J )-DU( I )*B( I+1, J )-DU2( I )*
+ $ B( I+2, J ) ) / D( I )
+ 50 CONTINUE
+ 60 CONTINUE
+ END IF
+ ELSE
+*
+* Solve A' * X = B.
+*
+ IF( NRHS.LE.1 ) THEN
+*
+* Solve U'*x = b.
+*
+ J = 1
+ 70 CONTINUE
+ B( 1, J ) = B( 1, J ) / D( 1 )
+ IF( N.GT.1 )
+ $ B( 2, J ) = ( B( 2, J )-DU( 1 )*B( 1, J ) ) / D( 2 )
+ DO 80 I = 3, N
+ B( I, J ) = ( B( I, J )-DU( I-1 )*B( I-1, J )-DU2( I-2 )*
+ $ B( I-2, J ) ) / D( I )
+ 80 CONTINUE
+*
+* Solve L'*x = b.
+*
+ DO 90 I = N - 1, 1, -1
+ IP = IPIV( I )
+ TEMP = B( I, J ) - DL( I )*B( I+1, J )
+ B( I, J ) = B( IP, J )
+ B( IP, J ) = TEMP
+ 90 CONTINUE
+ IF( J.LT.NRHS ) THEN
+ J = J + 1
+ GO TO 70
+ END IF
+*
+ ELSE
+ DO 120 J = 1, NRHS
+*
+* Solve U'*x = b.
+*
+ B( 1, J ) = B( 1, J ) / D( 1 )
+ IF( N.GT.1 )
+ $ B( 2, J ) = ( B( 2, J )-DU( 1 )*B( 1, J ) ) / D( 2 )
+ DO 100 I = 3, N
+ B( I, J ) = ( B( I, J )-DU( I-1 )*B( I-1, J )-
+ $ DU2( I-2 )*B( I-2, J ) ) / D( I )
+ 100 CONTINUE
+ DO 110 I = N - 1, 1, -1
+ IF( IPIV( I ).EQ.I ) THEN
+ B( I, J ) = B( I, J ) - DL( I )*B( I+1, J )
+ ELSE
+ TEMP = B( I+1, J )
+ B( I+1, J ) = B( I, J ) - DL( I )*TEMP
+ B( I, J ) = TEMP
+ END IF
+ 110 CONTINUE
+ 120 CONTINUE
+ END IF
+ END IF
+*
+* End of DGTTS2
+*
+ END
+ SUBROUTINE DHGEQZ( JOB, COMPQ, COMPZ, N, ILO, IHI, H, LDH, T, LDT,
+ $ ALPHAR, ALPHAI, BETA, Q, LDQ, Z, LDZ, WORK,
+ $ LWORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER COMPQ, COMPZ, JOB
+ INTEGER IHI, ILO, INFO, LDH, LDQ, LDT, LDZ, LWORK, N
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION ALPHAI( * ), ALPHAR( * ), BETA( * ),
+ $ H( LDH, * ), Q( LDQ, * ), T( LDT, * ),
+ $ WORK( * ), Z( LDZ, * )
+* ..
+*
+* Purpose
+* =======
+*
+* DHGEQZ computes the eigenvalues of a real matrix pair (H,T),
+* where H is an upper Hessenberg matrix and T is upper triangular,
+* using the double-shift QZ method.
+* Matrix pairs of this type are produced by the reduction to
+* generalized upper Hessenberg form of a real matrix pair (A,B):
+*
+* A = Q1*H*Z1**T, B = Q1*T*Z1**T,
+*
+* as computed by DGGHRD.
+*
+* If JOB='S', then the Hessenberg-triangular pair (H,T) is
+* also reduced to generalized Schur form,
+*
+* H = Q*S*Z**T, T = Q*P*Z**T,
+*
+* where Q and Z are orthogonal matrices, P is an upper triangular
+* matrix, and S is a quasi-triangular matrix with 1-by-1 and 2-by-2
+* diagonal blocks.
+*
+* The 1-by-1 blocks correspond to real eigenvalues of the matrix pair
+* (H,T) and the 2-by-2 blocks correspond to complex conjugate pairs of
+* eigenvalues.
+*
+* Additionally, the 2-by-2 upper triangular diagonal blocks of P
+* corresponding to 2-by-2 blocks of S are reduced to positive diagonal
+* form, i.e., if S(j+1,j) is non-zero, then P(j+1,j) = P(j,j+1) = 0,
+* P(j,j) > 0, and P(j+1,j+1) > 0.
+*
+* Optionally, the orthogonal matrix Q from the generalized Schur
+* factorization may be postmultiplied into an input matrix Q1, and the
+* orthogonal matrix Z may be postmultiplied into an input matrix Z1.
+* If Q1 and Z1 are the orthogonal matrices from DGGHRD that reduced
+* the matrix pair (A,B) to generalized upper Hessenberg form, then the
+* output matrices Q1*Q and Z1*Z are the orthogonal factors from the
+* generalized Schur factorization of (A,B):
+*
+* A = (Q1*Q)*S*(Z1*Z)**T, B = (Q1*Q)*P*(Z1*Z)**T.
+*
+* To avoid overflow, eigenvalues of the matrix pair (H,T) (equivalently,
+* of (A,B)) are computed as a pair of values (alpha,beta), where alpha is
+* complex and beta real.
+* If beta is nonzero, lambda = alpha / beta is an eigenvalue of the
+* generalized nonsymmetric eigenvalue problem (GNEP)
+* A*x = lambda*B*x
+* and if alpha is nonzero, mu = beta / alpha is an eigenvalue of the
+* alternate form of the GNEP
+* mu*A*y = B*y.
+* Real eigenvalues can be read directly from the generalized Schur
+* form:
+* alpha = S(i,i), beta = P(i,i).
+*
+* Ref: C.B. Moler & G.W. Stewart, "An Algorithm for Generalized Matrix
+* Eigenvalue Problems", SIAM J. Numer. Anal., 10(1973),
+* pp. 241--256.
+*
+* Arguments
+* =========
+*
+* JOB (input) CHARACTER*1
+* = 'E': Compute eigenvalues only;
+* = 'S': Compute eigenvalues and the Schur form.
+*
+* COMPQ (input) CHARACTER*1
+* = 'N': Left Schur vectors (Q) are not computed;
+* = 'I': Q is initialized to the unit matrix and the matrix Q
+* of left Schur vectors of (H,T) is returned;
+* = 'V': Q must contain an orthogonal matrix Q1 on entry and
+* the product Q1*Q is returned.
+*
+* COMPZ (input) CHARACTER*1
+* = 'N': Right Schur vectors (Z) are not computed;
+* = 'I': Z is initialized to the unit matrix and the matrix Z
+* of right Schur vectors of (H,T) is returned;
+* = 'V': Z must contain an orthogonal matrix Z1 on entry and
+* the product Z1*Z is returned.
+*
+* N (input) INTEGER
+* The order of the matrices H, T, Q, and Z. N >= 0.
+*
+* ILO (input) INTEGER
+* IHI (input) INTEGER
+* ILO and IHI mark the rows and columns of H which are in
+* Hessenberg form. It is assumed that A is already upper
+* triangular in rows and columns 1:ILO-1 and IHI+1:N.
+* If N > 0, 1 <= ILO <= IHI <= N; if N = 0, ILO=1 and IHI=0.
+*
+* H (input/output) DOUBLE PRECISION array, dimension (LDH, N)
+* On entry, the N-by-N upper Hessenberg matrix H.
+* On exit, if JOB = 'S', H contains the upper quasi-triangular
+* matrix S from the generalized Schur factorization;
+* 2-by-2 diagonal blocks (corresponding to complex conjugate
+* pairs of eigenvalues) are returned in standard form, with
+* H(i,i) = H(i+1,i+1) and H(i+1,i)*H(i,i+1) < 0.
+* If JOB = 'E', the diagonal blocks of H match those of S, but
+* the rest of H is unspecified.
+*
+* LDH (input) INTEGER
+* The leading dimension of the array H. LDH >= max( 1, N ).
+*
+* T (input/output) DOUBLE PRECISION array, dimension (LDT, N)
+* On entry, the N-by-N upper triangular matrix T.
+* On exit, if JOB = 'S', T contains the upper triangular
+* matrix P from the generalized Schur factorization;
+* 2-by-2 diagonal blocks of P corresponding to 2-by-2 blocks of S
+* are reduced to positive diagonal form, i.e., if H(j+1,j) is
+* non-zero, then T(j+1,j) = T(j,j+1) = 0, T(j,j) > 0, and
+* T(j+1,j+1) > 0.
+* If JOB = 'E', the diagonal blocks of T match those of P, but
+* the rest of T is unspecified.
+*
+* LDT (input) INTEGER
+* The leading dimension of the array T. LDT >= max( 1, N ).
+*
+* ALPHAR (output) DOUBLE PRECISION array, dimension (N)
+* The real parts of each scalar alpha defining an eigenvalue
+* of GNEP.
+*
+* ALPHAI (output) DOUBLE PRECISION array, dimension (N)
+* The imaginary parts of each scalar alpha defining an
+* eigenvalue of GNEP.
+* If ALPHAI(j) is zero, then the j-th eigenvalue is real; if
+* positive, then the j-th and (j+1)-st eigenvalues are a
+* complex conjugate pair, with ALPHAI(j+1) = -ALPHAI(j).
+*
+* BETA (output) DOUBLE PRECISION array, dimension (N)
+* The scalars beta that define the eigenvalues of GNEP.
+* Together, the quantities alpha = (ALPHAR(j),ALPHAI(j)) and
+* beta = BETA(j) represent the j-th eigenvalue of the matrix
+* pair (A,B), in one of the forms lambda = alpha/beta or
+* mu = beta/alpha. Since either lambda or mu may overflow,
+* they should not, in general, be computed.
+*
+* Q (input/output) DOUBLE PRECISION array, dimension (LDQ, N)
+* On entry, if COMPZ = 'V', the orthogonal matrix Q1 used in
+* the reduction of (A,B) to generalized Hessenberg form.
+* On exit, if COMPZ = 'I', the orthogonal matrix of left Schur
+* vectors of (H,T), and if COMPZ = 'V', the orthogonal matrix
+* of left Schur vectors of (A,B).
+* Not referenced if COMPZ = 'N'.
+*
+* LDQ (input) INTEGER
+* The leading dimension of the array Q. LDQ >= 1.
+* If COMPQ='V' or 'I', then LDQ >= N.
+*
+* Z (input/output) DOUBLE PRECISION array, dimension (LDZ, N)
+* On entry, if COMPZ = 'V', the orthogonal matrix Z1 used in
+* the reduction of (A,B) to generalized Hessenberg form.
+* On exit, if COMPZ = 'I', the orthogonal matrix of
+* right Schur vectors of (H,T), and if COMPZ = 'V', the
+* orthogonal matrix of right Schur vectors of (A,B).
+* Not referenced if COMPZ = 'N'.
+*
+* LDZ (input) INTEGER
+* The leading dimension of the array Z. LDZ >= 1.
+* If COMPZ='V' or 'I', then LDZ >= N.
+*
+* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
+* On exit, if INFO >= 0, WORK(1) returns the optimal LWORK.
+*
+* LWORK (input) INTEGER
+* The dimension of the array WORK. LWORK >= max(1,N).
+*
+* If LWORK = -1, then a workspace query is assumed; the routine
+* only calculates the optimal size of the WORK array, returns
+* this value as the first entry of the WORK array, and no error
+* message related to LWORK is issued by XERBLA.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* = 1,...,N: the QZ iteration did not converge. (H,T) is not
+* in Schur form, but ALPHAR(i), ALPHAI(i), and
+* BETA(i), i=INFO+1,...,N should be correct.
+* = N+1,...,2*N: the shift calculation failed. (H,T) is not
+* in Schur form, but ALPHAR(i), ALPHAI(i), and
+* BETA(i), i=INFO-N+1,...,N should be correct.
+*
+* Further Details
+* ===============
+*
+* Iteration counters:
+*
+* JITER -- counts iterations.
+* IITER -- counts iterations run since ILAST was last
+* changed. This is therefore reset only when a 1-by-1 or
+* 2-by-2 block deflates off the bottom.
+*
+* =====================================================================
+*
+* .. Parameters ..
+* $ SAFETY = 1.0E+0 )
+ DOUBLE PRECISION HALF, ZERO, ONE, SAFETY
+ PARAMETER ( HALF = 0.5D+0, ZERO = 0.0D+0, ONE = 1.0D+0,
+ $ SAFETY = 1.0D+2 )
+* ..
+* .. Local Scalars ..
+ LOGICAL ILAZR2, ILAZRO, ILPIVT, ILQ, ILSCHR, ILZ,
+ $ LQUERY
+ INTEGER ICOMPQ, ICOMPZ, IFIRST, IFRSTM, IITER, ILAST,
+ $ ILASTM, IN, ISCHUR, ISTART, J, JC, JCH, JITER,
+ $ JR, MAXIT
+ DOUBLE PRECISION A11, A12, A1I, A1R, A21, A22, A2I, A2R, AD11,
+ $ AD11L, AD12, AD12L, AD21, AD21L, AD22, AD22L,
+ $ AD32L, AN, ANORM, ASCALE, ATOL, B11, B1A, B1I,
+ $ B1R, B22, B2A, B2I, B2R, BN, BNORM, BSCALE,
+ $ BTOL, C, C11I, C11R, C12, C21, C22I, C22R, CL,
+ $ CQ, CR, CZ, ESHIFT, S, S1, S1INV, S2, SAFMAX,
+ $ SAFMIN, SCALE, SL, SQI, SQR, SR, SZI, SZR, T1,
+ $ TAU, TEMP, TEMP2, TEMPI, TEMPR, U1, U12, U12L,
+ $ U2, ULP, VS, W11, W12, W21, W22, WABS, WI, WR,
+ $ WR2
+* ..
+* .. Local Arrays ..
+ DOUBLE PRECISION V( 3 )
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ DOUBLE PRECISION DLAMCH, DLANHS, DLAPY2, DLAPY3
+ EXTERNAL LSAME, DLAMCH, DLANHS, DLAPY2, DLAPY3
+* ..
+* .. External Subroutines ..
+ EXTERNAL DLAG2, DLARFG, DLARTG, DLASET, DLASV2, DROT,
+ $ XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, DBLE, MAX, MIN, SQRT
+* ..
+* .. Executable Statements ..
+*
+* Decode JOB, COMPQ, COMPZ
+*
+ IF( LSAME( JOB, 'E' ) ) THEN
+ ILSCHR = .FALSE.
+ ISCHUR = 1
+ ELSE IF( LSAME( JOB, 'S' ) ) THEN
+ ILSCHR = .TRUE.
+ ISCHUR = 2
+ ELSE
+ ISCHUR = 0
+ END IF
+*
+ IF( LSAME( COMPQ, 'N' ) ) THEN
+ ILQ = .FALSE.
+ ICOMPQ = 1
+ ELSE IF( LSAME( COMPQ, 'V' ) ) THEN
+ ILQ = .TRUE.
+ ICOMPQ = 2
+ ELSE IF( LSAME( COMPQ, 'I' ) ) THEN
+ ILQ = .TRUE.
+ ICOMPQ = 3
+ ELSE
+ ICOMPQ = 0
+ END IF
+*
+ IF( LSAME( COMPZ, 'N' ) ) THEN
+ ILZ = .FALSE.
+ ICOMPZ = 1
+ ELSE IF( LSAME( COMPZ, 'V' ) ) THEN
+ ILZ = .TRUE.
+ ICOMPZ = 2
+ ELSE IF( LSAME( COMPZ, 'I' ) ) THEN
+ ILZ = .TRUE.
+ ICOMPZ = 3
+ ELSE
+ ICOMPZ = 0
+ END IF
+*
+* Check Argument Values
+*
+ INFO = 0
+ WORK( 1 ) = MAX( 1, N )
+ LQUERY = ( LWORK.EQ.-1 )
+ IF( ISCHUR.EQ.0 ) THEN
+ INFO = -1
+ ELSE IF( ICOMPQ.EQ.0 ) THEN
+ INFO = -2
+ ELSE IF( ICOMPZ.EQ.0 ) THEN
+ INFO = -3
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( ILO.LT.1 ) THEN
+ INFO = -5
+ ELSE IF( IHI.GT.N .OR. IHI.LT.ILO-1 ) THEN
+ INFO = -6
+ ELSE IF( LDH.LT.N ) THEN
+ INFO = -8
+ ELSE IF( LDT.LT.N ) THEN
+ INFO = -10
+ ELSE IF( LDQ.LT.1 .OR. ( ILQ .AND. LDQ.LT.N ) ) THEN
+ INFO = -15
+ ELSE IF( LDZ.LT.1 .OR. ( ILZ .AND. LDZ.LT.N ) ) THEN
+ INFO = -17
+ ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN
+ INFO = -19
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DHGEQZ', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.LE.0 ) THEN
+ WORK( 1 ) = DBLE( 1 )
+ RETURN
+ END IF
+*
+* Initialize Q and Z
+*
+ IF( ICOMPQ.EQ.3 )
+ $ CALL DLASET( 'Full', N, N, ZERO, ONE, Q, LDQ )
+ IF( ICOMPZ.EQ.3 )
+ $ CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDZ )
+*
+* Machine Constants
+*
+ IN = IHI + 1 - ILO
+ SAFMIN = DLAMCH( 'S' )
+ SAFMAX = ONE / SAFMIN
+ ULP = DLAMCH( 'E' )*DLAMCH( 'B' )
+ ANORM = DLANHS( 'F', IN, H( ILO, ILO ), LDH, WORK )
+ BNORM = DLANHS( 'F', IN, T( ILO, ILO ), LDT, WORK )
+ ATOL = MAX( SAFMIN, ULP*ANORM )
+ BTOL = MAX( SAFMIN, ULP*BNORM )
+ ASCALE = ONE / MAX( SAFMIN, ANORM )
+ BSCALE = ONE / MAX( SAFMIN, BNORM )
+*
+* Set Eigenvalues IHI+1:N
+*
+ DO 30 J = IHI + 1, N
+ IF( T( J, J ).LT.ZERO ) THEN
+ IF( ILSCHR ) THEN
+ DO 10 JR = 1, J
+ H( JR, J ) = -H( JR, J )
+ T( JR, J ) = -T( JR, J )
+ 10 CONTINUE
+ ELSE
+ H( J, J ) = -H( J, J )
+ T( J, J ) = -T( J, J )
+ END IF
+ IF( ILZ ) THEN
+ DO 20 JR = 1, N
+ Z( JR, J ) = -Z( JR, J )
+ 20 CONTINUE
+ END IF
+ END IF
+ ALPHAR( J ) = H( J, J )
+ ALPHAI( J ) = ZERO
+ BETA( J ) = T( J, J )
+ 30 CONTINUE
+*
+* If IHI < ILO, skip QZ steps
+*
+ IF( IHI.LT.ILO )
+ $ GO TO 380
+*
+* MAIN QZ ITERATION LOOP
+*
+* Initialize dynamic indices
+*
+* Eigenvalues ILAST+1:N have been found.
+* Column operations modify rows IFRSTM:whatever.
+* Row operations modify columns whatever:ILASTM.
+*
+* If only eigenvalues are being computed, then
+* IFRSTM is the row of the last splitting row above row ILAST;
+* this is always at least ILO.
+* IITER counts iterations since the last eigenvalue was found,
+* to tell when to use an extraordinary shift.
+* MAXIT is the maximum number of QZ sweeps allowed.
+*
+ ILAST = IHI
+ IF( ILSCHR ) THEN
+ IFRSTM = 1
+ ILASTM = N
+ ELSE
+ IFRSTM = ILO
+ ILASTM = IHI
+ END IF
+ IITER = 0
+ ESHIFT = ZERO
+ MAXIT = 30*( IHI-ILO+1 )
+*
+ DO 360 JITER = 1, MAXIT
+*
+* Split the matrix if possible.
+*
+* Two tests:
+* 1: H(j,j-1)=0 or j=ILO
+* 2: T(j,j)=0
+*
+ IF( ILAST.EQ.ILO ) THEN
+*
+* Special case: j=ILAST
+*
+ GO TO 80
+ ELSE
+ IF( ABS( H( ILAST, ILAST-1 ) ).LE.ATOL ) THEN
+ H( ILAST, ILAST-1 ) = ZERO
+ GO TO 80
+ END IF
+ END IF
+*
+ IF( ABS( T( ILAST, ILAST ) ).LE.BTOL ) THEN
+ T( ILAST, ILAST ) = ZERO
+ GO TO 70
+ END IF
+*
+* General case: j<ILAST
+*
+ DO 60 J = ILAST - 1, ILO, -1
+*
+* Test 1: for H(j,j-1)=0 or j=ILO
+*
+ IF( J.EQ.ILO ) THEN
+ ILAZRO = .TRUE.
+ ELSE
+ IF( ABS( H( J, J-1 ) ).LE.ATOL ) THEN
+ H( J, J-1 ) = ZERO
+ ILAZRO = .TRUE.
+ ELSE
+ ILAZRO = .FALSE.
+ END IF
+ END IF
+*
+* Test 2: for T(j,j)=0
+*
+ IF( ABS( T( J, J ) ).LT.BTOL ) THEN
+ T( J, J ) = ZERO
+*
+* Test 1a: Check for 2 consecutive small subdiagonals in A
+*
+ ILAZR2 = .FALSE.
+ IF( .NOT.ILAZRO ) THEN
+ TEMP = ABS( H( J, J-1 ) )
+ TEMP2 = ABS( H( J, J ) )
+ TEMPR = MAX( TEMP, TEMP2 )
+ IF( TEMPR.LT.ONE .AND. TEMPR.NE.ZERO ) THEN
+ TEMP = TEMP / TEMPR
+ TEMP2 = TEMP2 / TEMPR
+ END IF
+ IF( TEMP*( ASCALE*ABS( H( J+1, J ) ) ).LE.TEMP2*
+ $ ( ASCALE*ATOL ) )ILAZR2 = .TRUE.
+ END IF
+*
+* If both tests pass (1 & 2), i.e., the leading diagonal
+* element of B in the block is zero, split a 1x1 block off
+* at the top. (I.e., at the J-th row/column) The leading
+* diagonal element of the remainder can also be zero, so
+* this may have to be done repeatedly.
+*
+ IF( ILAZRO .OR. ILAZR2 ) THEN
+ DO 40 JCH = J, ILAST - 1
+ TEMP = H( JCH, JCH )
+ CALL DLARTG( TEMP, H( JCH+1, JCH ), C, S,
+ $ H( JCH, JCH ) )
+ H( JCH+1, JCH ) = ZERO
+ CALL DROT( ILASTM-JCH, H( JCH, JCH+1 ), LDH,
+ $ H( JCH+1, JCH+1 ), LDH, C, S )
+ CALL DROT( ILASTM-JCH, T( JCH, JCH+1 ), LDT,
+ $ T( JCH+1, JCH+1 ), LDT, C, S )
+ IF( ILQ )
+ $ CALL DROT( N, Q( 1, JCH ), 1, Q( 1, JCH+1 ), 1,
+ $ C, S )
+ IF( ILAZR2 )
+ $ H( JCH, JCH-1 ) = H( JCH, JCH-1 )*C
+ ILAZR2 = .FALSE.
+ IF( ABS( T( JCH+1, JCH+1 ) ).GE.BTOL ) THEN
+ IF( JCH+1.GE.ILAST ) THEN
+ GO TO 80
+ ELSE
+ IFIRST = JCH + 1
+ GO TO 110
+ END IF
+ END IF
+ T( JCH+1, JCH+1 ) = ZERO
+ 40 CONTINUE
+ GO TO 70
+ ELSE
+*
+* Only test 2 passed -- chase the zero to T(ILAST,ILAST)
+* Then process as in the case T(ILAST,ILAST)=0
+*
+ DO 50 JCH = J, ILAST - 1
+ TEMP = T( JCH, JCH+1 )
+ CALL DLARTG( TEMP, T( JCH+1, JCH+1 ), C, S,
+ $ T( JCH, JCH+1 ) )
+ T( JCH+1, JCH+1 ) = ZERO
+ IF( JCH.LT.ILASTM-1 )
+ $ CALL DROT( ILASTM-JCH-1, T( JCH, JCH+2 ), LDT,
+ $ T( JCH+1, JCH+2 ), LDT, C, S )
+ CALL DROT( ILASTM-JCH+2, H( JCH, JCH-1 ), LDH,
+ $ H( JCH+1, JCH-1 ), LDH, C, S )
+ IF( ILQ )
+ $ CALL DROT( N, Q( 1, JCH ), 1, Q( 1, JCH+1 ), 1,
+ $ C, S )
+ TEMP = H( JCH+1, JCH )
+ CALL DLARTG( TEMP, H( JCH+1, JCH-1 ), C, S,
+ $ H( JCH+1, JCH ) )
+ H( JCH+1, JCH-1 ) = ZERO
+ CALL DROT( JCH+1-IFRSTM, H( IFRSTM, JCH ), 1,
+ $ H( IFRSTM, JCH-1 ), 1, C, S )
+ CALL DROT( JCH-IFRSTM, T( IFRSTM, JCH ), 1,
+ $ T( IFRSTM, JCH-1 ), 1, C, S )
+ IF( ILZ )
+ $ CALL DROT( N, Z( 1, JCH ), 1, Z( 1, JCH-1 ), 1,
+ $ C, S )
+ 50 CONTINUE
+ GO TO 70
+ END IF
+ ELSE IF( ILAZRO ) THEN
+*
+* Only test 1 passed -- work on J:ILAST
+*
+ IFIRST = J
+ GO TO 110
+ END IF
+*
+* Neither test passed -- try next J
+*
+ 60 CONTINUE
+*
+* (Drop-through is "impossible")
+*
+ INFO = N + 1
+ GO TO 420
+*
+* T(ILAST,ILAST)=0 -- clear H(ILAST,ILAST-1) to split off a
+* 1x1 block.
+*
+ 70 CONTINUE
+ TEMP = H( ILAST, ILAST )
+ CALL DLARTG( TEMP, H( ILAST, ILAST-1 ), C, S,
+ $ H( ILAST, ILAST ) )
+ H( ILAST, ILAST-1 ) = ZERO
+ CALL DROT( ILAST-IFRSTM, H( IFRSTM, ILAST ), 1,
+ $ H( IFRSTM, ILAST-1 ), 1, C, S )
+ CALL DROT( ILAST-IFRSTM, T( IFRSTM, ILAST ), 1,
+ $ T( IFRSTM, ILAST-1 ), 1, C, S )
+ IF( ILZ )
+ $ CALL DROT( N, Z( 1, ILAST ), 1, Z( 1, ILAST-1 ), 1, C, S )
+*
+* H(ILAST,ILAST-1)=0 -- Standardize B, set ALPHAR, ALPHAI,
+* and BETA
+*
+ 80 CONTINUE
+ IF( T( ILAST, ILAST ).LT.ZERO ) THEN
+ IF( ILSCHR ) THEN
+ DO 90 J = IFRSTM, ILAST
+ H( J, ILAST ) = -H( J, ILAST )
+ T( J, ILAST ) = -T( J, ILAST )
+ 90 CONTINUE
+ ELSE
+ H( ILAST, ILAST ) = -H( ILAST, ILAST )
+ T( ILAST, ILAST ) = -T( ILAST, ILAST )
+ END IF
+ IF( ILZ ) THEN
+ DO 100 J = 1, N
+ Z( J, ILAST ) = -Z( J, ILAST )
+ 100 CONTINUE
+ END IF
+ END IF
+ ALPHAR( ILAST ) = H( ILAST, ILAST )
+ ALPHAI( ILAST ) = ZERO
+ BETA( ILAST ) = T( ILAST, ILAST )
+*
+* Go to next block -- exit if finished.
+*
+ ILAST = ILAST - 1
+ IF( ILAST.LT.ILO )
+ $ GO TO 380
+*
+* Reset counters
+*
+ IITER = 0
+ ESHIFT = ZERO
+ IF( .NOT.ILSCHR ) THEN
+ ILASTM = ILAST
+ IF( IFRSTM.GT.ILAST )
+ $ IFRSTM = ILO
+ END IF
+ GO TO 350
+*
+* QZ step
+*
+* This iteration only involves rows/columns IFIRST:ILAST. We
+* assume IFIRST < ILAST, and that the diagonal of B is non-zero.
+*
+ 110 CONTINUE
+ IITER = IITER + 1
+ IF( .NOT.ILSCHR ) THEN
+ IFRSTM = IFIRST
+ END IF
+*
+* Compute single shifts.
+*
+* At this point, IFIRST < ILAST, and the diagonal elements of
+* T(IFIRST:ILAST,IFIRST,ILAST) are larger than BTOL (in
+* magnitude)
+*
+ IF( ( IITER / 10 )*10.EQ.IITER ) THEN
+*
+* Exceptional shift. Chosen for no particularly good reason.
+* (Single shift only.)
+*
+ IF( ( DBLE( MAXIT )*SAFMIN )*ABS( H( ILAST-1, ILAST ) ).LT.
+ $ ABS( T( ILAST-1, ILAST-1 ) ) ) THEN
+ ESHIFT = ESHIFT + H( ILAST-1, ILAST ) /
+ $ T( ILAST-1, ILAST-1 )
+ ELSE
+ ESHIFT = ESHIFT + ONE / ( SAFMIN*DBLE( MAXIT ) )
+ END IF
+ S1 = ONE
+ WR = ESHIFT
+*
+ ELSE
+*
+* Shifts based on the generalized eigenvalues of the
+* bottom-right 2x2 block of A and B. The first eigenvalue
+* returned by DLAG2 is the Wilkinson shift (AEP p.512),
+*
+ CALL DLAG2( H( ILAST-1, ILAST-1 ), LDH,
+ $ T( ILAST-1, ILAST-1 ), LDT, SAFMIN*SAFETY, S1,
+ $ S2, WR, WR2, WI )
+*
+ TEMP = MAX( S1, SAFMIN*MAX( ONE, ABS( WR ), ABS( WI ) ) )
+ IF( WI.NE.ZERO )
+ $ GO TO 200
+ END IF
+*
+* Fiddle with shift to avoid overflow
+*
+ TEMP = MIN( ASCALE, ONE )*( HALF*SAFMAX )
+ IF( S1.GT.TEMP ) THEN
+ SCALE = TEMP / S1
+ ELSE
+ SCALE = ONE
+ END IF
+*
+ TEMP = MIN( BSCALE, ONE )*( HALF*SAFMAX )
+ IF( ABS( WR ).GT.TEMP )
+ $ SCALE = MIN( SCALE, TEMP / ABS( WR ) )
+ S1 = SCALE*S1
+ WR = SCALE*WR
+*
+* Now check for two consecutive small subdiagonals.
+*
+ DO 120 J = ILAST - 1, IFIRST + 1, -1
+ ISTART = J
+ TEMP = ABS( S1*H( J, J-1 ) )
+ TEMP2 = ABS( S1*H( J, J )-WR*T( J, J ) )
+ TEMPR = MAX( TEMP, TEMP2 )
+ IF( TEMPR.LT.ONE .AND. TEMPR.NE.ZERO ) THEN
+ TEMP = TEMP / TEMPR
+ TEMP2 = TEMP2 / TEMPR
+ END IF
+ IF( ABS( ( ASCALE*H( J+1, J ) )*TEMP ).LE.( ASCALE*ATOL )*
+ $ TEMP2 )GO TO 130
+ 120 CONTINUE
+*
+ ISTART = IFIRST
+ 130 CONTINUE
+*
+* Do an implicit single-shift QZ sweep.
+*
+* Initial Q
+*
+ TEMP = S1*H( ISTART, ISTART ) - WR*T( ISTART, ISTART )
+ TEMP2 = S1*H( ISTART+1, ISTART )
+ CALL DLARTG( TEMP, TEMP2, C, S, TEMPR )
+*
+* Sweep
+*
+ DO 190 J = ISTART, ILAST - 1
+ IF( J.GT.ISTART ) THEN
+ TEMP = H( J, J-1 )
+ CALL DLARTG( TEMP, H( J+1, J-1 ), C, S, H( J, J-1 ) )
+ H( J+1, J-1 ) = ZERO
+ END IF
+*
+ DO 140 JC = J, ILASTM
+ TEMP = C*H( J, JC ) + S*H( J+1, JC )
+ H( J+1, JC ) = -S*H( J, JC ) + C*H( J+1, JC )
+ H( J, JC ) = TEMP
+ TEMP2 = C*T( J, JC ) + S*T( J+1, JC )
+ T( J+1, JC ) = -S*T( J, JC ) + C*T( J+1, JC )
+ T( J, JC ) = TEMP2
+ 140 CONTINUE
+ IF( ILQ ) THEN
+ DO 150 JR = 1, N
+ TEMP = C*Q( JR, J ) + S*Q( JR, J+1 )
+ Q( JR, J+1 ) = -S*Q( JR, J ) + C*Q( JR, J+1 )
+ Q( JR, J ) = TEMP
+ 150 CONTINUE
+ END IF
+*
+ TEMP = T( J+1, J+1 )
+ CALL DLARTG( TEMP, T( J+1, J ), C, S, T( J+1, J+1 ) )
+ T( J+1, J ) = ZERO
+*
+ DO 160 JR = IFRSTM, MIN( J+2, ILAST )
+ TEMP = C*H( JR, J+1 ) + S*H( JR, J )
+ H( JR, J ) = -S*H( JR, J+1 ) + C*H( JR, J )
+ H( JR, J+1 ) = TEMP
+ 160 CONTINUE
+ DO 170 JR = IFRSTM, J
+ TEMP = C*T( JR, J+1 ) + S*T( JR, J )
+ T( JR, J ) = -S*T( JR, J+1 ) + C*T( JR, J )
+ T( JR, J+1 ) = TEMP
+ 170 CONTINUE
+ IF( ILZ ) THEN
+ DO 180 JR = 1, N
+ TEMP = C*Z( JR, J+1 ) + S*Z( JR, J )
+ Z( JR, J ) = -S*Z( JR, J+1 ) + C*Z( JR, J )
+ Z( JR, J+1 ) = TEMP
+ 180 CONTINUE
+ END IF
+ 190 CONTINUE
+*
+ GO TO 350
+*
+* Use Francis double-shift
+*
+* Note: the Francis double-shift should work with real shifts,
+* but only if the block is at least 3x3.
+* This code may break if this point is reached with
+* a 2x2 block with real eigenvalues.
+*
+ 200 CONTINUE
+ IF( IFIRST+1.EQ.ILAST ) THEN
+*
+* Special case -- 2x2 block with complex eigenvectors
+*
+* Step 1: Standardize, that is, rotate so that
+*
+* ( B11 0 )
+* B = ( ) with B11 non-negative.
+* ( 0 B22 )
+*
+ CALL DLASV2( T( ILAST-1, ILAST-1 ), T( ILAST-1, ILAST ),
+ $ T( ILAST, ILAST ), B22, B11, SR, CR, SL, CL )
+*
+ IF( B11.LT.ZERO ) THEN
+ CR = -CR
+ SR = -SR
+ B11 = -B11
+ B22 = -B22
+ END IF
+*
+ CALL DROT( ILASTM+1-IFIRST, H( ILAST-1, ILAST-1 ), LDH,
+ $ H( ILAST, ILAST-1 ), LDH, CL, SL )
+ CALL DROT( ILAST+1-IFRSTM, H( IFRSTM, ILAST-1 ), 1,
+ $ H( IFRSTM, ILAST ), 1, CR, SR )
+*
+ IF( ILAST.LT.ILASTM )
+ $ CALL DROT( ILASTM-ILAST, T( ILAST-1, ILAST+1 ), LDT,
+ $ T( ILAST, ILAST+1 ), LDH, CL, SL )
+ IF( IFRSTM.LT.ILAST-1 )
+ $ CALL DROT( IFIRST-IFRSTM, T( IFRSTM, ILAST-1 ), 1,
+ $ T( IFRSTM, ILAST ), 1, CR, SR )
+*
+ IF( ILQ )
+ $ CALL DROT( N, Q( 1, ILAST-1 ), 1, Q( 1, ILAST ), 1, CL,
+ $ SL )
+ IF( ILZ )
+ $ CALL DROT( N, Z( 1, ILAST-1 ), 1, Z( 1, ILAST ), 1, CR,
+ $ SR )
+*
+ T( ILAST-1, ILAST-1 ) = B11
+ T( ILAST-1, ILAST ) = ZERO
+ T( ILAST, ILAST-1 ) = ZERO
+ T( ILAST, ILAST ) = B22
+*
+* If B22 is negative, negate column ILAST
+*
+ IF( B22.LT.ZERO ) THEN
+ DO 210 J = IFRSTM, ILAST
+ H( J, ILAST ) = -H( J, ILAST )
+ T( J, ILAST ) = -T( J, ILAST )
+ 210 CONTINUE
+*
+ IF( ILZ ) THEN
+ DO 220 J = 1, N
+ Z( J, ILAST ) = -Z( J, ILAST )
+ 220 CONTINUE
+ END IF
+ END IF
+*
+* Step 2: Compute ALPHAR, ALPHAI, and BETA (see refs.)
+*
+* Recompute shift
+*
+ CALL DLAG2( H( ILAST-1, ILAST-1 ), LDH,
+ $ T( ILAST-1, ILAST-1 ), LDT, SAFMIN*SAFETY, S1,
+ $ TEMP, WR, TEMP2, WI )
+*
+* If standardization has perturbed the shift onto real line,
+* do another (real single-shift) QR step.
+*
+ IF( WI.EQ.ZERO )
+ $ GO TO 350
+ S1INV = ONE / S1
+*
+* Do EISPACK (QZVAL) computation of alpha and beta
+*
+ A11 = H( ILAST-1, ILAST-1 )
+ A21 = H( ILAST, ILAST-1 )
+ A12 = H( ILAST-1, ILAST )
+ A22 = H( ILAST, ILAST )
+*
+* Compute complex Givens rotation on right
+* (Assume some element of C = (sA - wB) > unfl )
+* __
+* (sA - wB) ( CZ -SZ )
+* ( SZ CZ )
+*
+ C11R = S1*A11 - WR*B11
+ C11I = -WI*B11
+ C12 = S1*A12
+ C21 = S1*A21
+ C22R = S1*A22 - WR*B22
+ C22I = -WI*B22
+*
+ IF( ABS( C11R )+ABS( C11I )+ABS( C12 ).GT.ABS( C21 )+
+ $ ABS( C22R )+ABS( C22I ) ) THEN
+ T1 = DLAPY3( C12, C11R, C11I )
+ CZ = C12 / T1
+ SZR = -C11R / T1
+ SZI = -C11I / T1
+ ELSE
+ CZ = DLAPY2( C22R, C22I )
+ IF( CZ.LE.SAFMIN ) THEN
+ CZ = ZERO
+ SZR = ONE
+ SZI = ZERO
+ ELSE
+ TEMPR = C22R / CZ
+ TEMPI = C22I / CZ
+ T1 = DLAPY2( CZ, C21 )
+ CZ = CZ / T1
+ SZR = -C21*TEMPR / T1
+ SZI = C21*TEMPI / T1
+ END IF
+ END IF
+*
+* Compute Givens rotation on left
+*
+* ( CQ SQ )
+* ( __ ) A or B
+* ( -SQ CQ )
+*
+ AN = ABS( A11 ) + ABS( A12 ) + ABS( A21 ) + ABS( A22 )
+ BN = ABS( B11 ) + ABS( B22 )
+ WABS = ABS( WR ) + ABS( WI )
+ IF( S1*AN.GT.WABS*BN ) THEN
+ CQ = CZ*B11
+ SQR = SZR*B22
+ SQI = -SZI*B22
+ ELSE
+ A1R = CZ*A11 + SZR*A12
+ A1I = SZI*A12
+ A2R = CZ*A21 + SZR*A22
+ A2I = SZI*A22
+ CQ = DLAPY2( A1R, A1I )
+ IF( CQ.LE.SAFMIN ) THEN
+ CQ = ZERO
+ SQR = ONE
+ SQI = ZERO
+ ELSE
+ TEMPR = A1R / CQ
+ TEMPI = A1I / CQ
+ SQR = TEMPR*A2R + TEMPI*A2I
+ SQI = TEMPI*A2R - TEMPR*A2I
+ END IF
+ END IF
+ T1 = DLAPY3( CQ, SQR, SQI )
+ CQ = CQ / T1
+ SQR = SQR / T1
+ SQI = SQI / T1
+*
+* Compute diagonal elements of QBZ
+*
+ TEMPR = SQR*SZR - SQI*SZI
+ TEMPI = SQR*SZI + SQI*SZR
+ B1R = CQ*CZ*B11 + TEMPR*B22
+ B1I = TEMPI*B22
+ B1A = DLAPY2( B1R, B1I )
+ B2R = CQ*CZ*B22 + TEMPR*B11
+ B2I = -TEMPI*B11
+ B2A = DLAPY2( B2R, B2I )
+*
+* Normalize so beta > 0, and Im( alpha1 ) > 0
+*
+ BETA( ILAST-1 ) = B1A
+ BETA( ILAST ) = B2A
+ ALPHAR( ILAST-1 ) = ( WR*B1A )*S1INV
+ ALPHAI( ILAST-1 ) = ( WI*B1A )*S1INV
+ ALPHAR( ILAST ) = ( WR*B2A )*S1INV
+ ALPHAI( ILAST ) = -( WI*B2A )*S1INV
+*
+* Step 3: Go to next block -- exit if finished.
+*
+ ILAST = IFIRST - 1
+ IF( ILAST.LT.ILO )
+ $ GO TO 380
+*
+* Reset counters
+*
+ IITER = 0
+ ESHIFT = ZERO
+ IF( .NOT.ILSCHR ) THEN
+ ILASTM = ILAST
+ IF( IFRSTM.GT.ILAST )
+ $ IFRSTM = ILO
+ END IF
+ GO TO 350
+ ELSE
+*
+* Usual case: 3x3 or larger block, using Francis implicit
+* double-shift
+*
+* 2
+* Eigenvalue equation is w - c w + d = 0,
+*
+* -1 2 -1
+* so compute 1st column of (A B ) - c A B + d
+* using the formula in QZIT (from EISPACK)
+*
+* We assume that the block is at least 3x3
+*
+ AD11 = ( ASCALE*H( ILAST-1, ILAST-1 ) ) /
+ $ ( BSCALE*T( ILAST-1, ILAST-1 ) )
+ AD21 = ( ASCALE*H( ILAST, ILAST-1 ) ) /
+ $ ( BSCALE*T( ILAST-1, ILAST-1 ) )
+ AD12 = ( ASCALE*H( ILAST-1, ILAST ) ) /
+ $ ( BSCALE*T( ILAST, ILAST ) )
+ AD22 = ( ASCALE*H( ILAST, ILAST ) ) /
+ $ ( BSCALE*T( ILAST, ILAST ) )
+ U12 = T( ILAST-1, ILAST ) / T( ILAST, ILAST )
+ AD11L = ( ASCALE*H( IFIRST, IFIRST ) ) /
+ $ ( BSCALE*T( IFIRST, IFIRST ) )
+ AD21L = ( ASCALE*H( IFIRST+1, IFIRST ) ) /
+ $ ( BSCALE*T( IFIRST, IFIRST ) )
+ AD12L = ( ASCALE*H( IFIRST, IFIRST+1 ) ) /
+ $ ( BSCALE*T( IFIRST+1, IFIRST+1 ) )
+ AD22L = ( ASCALE*H( IFIRST+1, IFIRST+1 ) ) /
+ $ ( BSCALE*T( IFIRST+1, IFIRST+1 ) )
+ AD32L = ( ASCALE*H( IFIRST+2, IFIRST+1 ) ) /
+ $ ( BSCALE*T( IFIRST+1, IFIRST+1 ) )
+ U12L = T( IFIRST, IFIRST+1 ) / T( IFIRST+1, IFIRST+1 )
+*
+ V( 1 ) = ( AD11-AD11L )*( AD22-AD11L ) - AD12*AD21 +
+ $ AD21*U12*AD11L + ( AD12L-AD11L*U12L )*AD21L
+ V( 2 ) = ( ( AD22L-AD11L )-AD21L*U12L-( AD11-AD11L )-
+ $ ( AD22-AD11L )+AD21*U12 )*AD21L
+ V( 3 ) = AD32L*AD21L
+*
+ ISTART = IFIRST
+*
+ CALL DLARFG( 3, V( 1 ), V( 2 ), 1, TAU )
+ V( 1 ) = ONE
+*
+* Sweep
+*
+ DO 290 J = ISTART, ILAST - 2
+*
+* All but last elements: use 3x3 Householder transforms.
+*
+* Zero (j-1)st column of A
+*
+ IF( J.GT.ISTART ) THEN
+ V( 1 ) = H( J, J-1 )
+ V( 2 ) = H( J+1, J-1 )
+ V( 3 ) = H( J+2, J-1 )
+*
+ CALL DLARFG( 3, H( J, J-1 ), V( 2 ), 1, TAU )
+ V( 1 ) = ONE
+ H( J+1, J-1 ) = ZERO
+ H( J+2, J-1 ) = ZERO
+ END IF
+*
+ DO 230 JC = J, ILASTM
+ TEMP = TAU*( H( J, JC )+V( 2 )*H( J+1, JC )+V( 3 )*
+ $ H( J+2, JC ) )
+ H( J, JC ) = H( J, JC ) - TEMP
+ H( J+1, JC ) = H( J+1, JC ) - TEMP*V( 2 )
+ H( J+2, JC ) = H( J+2, JC ) - TEMP*V( 3 )
+ TEMP2 = TAU*( T( J, JC )+V( 2 )*T( J+1, JC )+V( 3 )*
+ $ T( J+2, JC ) )
+ T( J, JC ) = T( J, JC ) - TEMP2
+ T( J+1, JC ) = T( J+1, JC ) - TEMP2*V( 2 )
+ T( J+2, JC ) = T( J+2, JC ) - TEMP2*V( 3 )
+ 230 CONTINUE
+ IF( ILQ ) THEN
+ DO 240 JR = 1, N
+ TEMP = TAU*( Q( JR, J )+V( 2 )*Q( JR, J+1 )+V( 3 )*
+ $ Q( JR, J+2 ) )
+ Q( JR, J ) = Q( JR, J ) - TEMP
+ Q( JR, J+1 ) = Q( JR, J+1 ) - TEMP*V( 2 )
+ Q( JR, J+2 ) = Q( JR, J+2 ) - TEMP*V( 3 )
+ 240 CONTINUE
+ END IF
+*
+* Zero j-th column of B (see DLAGBC for details)
+*
+* Swap rows to pivot
+*
+ ILPIVT = .FALSE.
+ TEMP = MAX( ABS( T( J+1, J+1 ) ), ABS( T( J+1, J+2 ) ) )
+ TEMP2 = MAX( ABS( T( J+2, J+1 ) ), ABS( T( J+2, J+2 ) ) )
+ IF( MAX( TEMP, TEMP2 ).LT.SAFMIN ) THEN
+ SCALE = ZERO
+ U1 = ONE
+ U2 = ZERO
+ GO TO 250
+ ELSE IF( TEMP.GE.TEMP2 ) THEN
+ W11 = T( J+1, J+1 )
+ W21 = T( J+2, J+1 )
+ W12 = T( J+1, J+2 )
+ W22 = T( J+2, J+2 )
+ U1 = T( J+1, J )
+ U2 = T( J+2, J )
+ ELSE
+ W21 = T( J+1, J+1 )
+ W11 = T( J+2, J+1 )
+ W22 = T( J+1, J+2 )
+ W12 = T( J+2, J+2 )
+ U2 = T( J+1, J )
+ U1 = T( J+2, J )
+ END IF
+*
+* Swap columns if nec.
+*
+ IF( ABS( W12 ).GT.ABS( W11 ) ) THEN
+ ILPIVT = .TRUE.
+ TEMP = W12
+ TEMP2 = W22
+ W12 = W11
+ W22 = W21
+ W11 = TEMP
+ W21 = TEMP2
+ END IF
+*
+* LU-factor
+*
+ TEMP = W21 / W11
+ U2 = U2 - TEMP*U1
+ W22 = W22 - TEMP*W12
+ W21 = ZERO
+*
+* Compute SCALE
+*
+ SCALE = ONE
+ IF( ABS( W22 ).LT.SAFMIN ) THEN
+ SCALE = ZERO
+ U2 = ONE
+ U1 = -W12 / W11
+ GO TO 250
+ END IF
+ IF( ABS( W22 ).LT.ABS( U2 ) )
+ $ SCALE = ABS( W22 / U2 )
+ IF( ABS( W11 ).LT.ABS( U1 ) )
+ $ SCALE = MIN( SCALE, ABS( W11 / U1 ) )
+*
+* Solve
+*
+ U2 = ( SCALE*U2 ) / W22
+ U1 = ( SCALE*U1-W12*U2 ) / W11
+*
+ 250 CONTINUE
+ IF( ILPIVT ) THEN
+ TEMP = U2
+ U2 = U1
+ U1 = TEMP
+ END IF
+*
+* Compute Householder Vector
+*
+ T1 = SQRT( SCALE**2+U1**2+U2**2 )
+ TAU = ONE + SCALE / T1
+ VS = -ONE / ( SCALE+T1 )
+ V( 1 ) = ONE
+ V( 2 ) = VS*U1
+ V( 3 ) = VS*U2
+*
+* Apply transformations from the right.
+*
+ DO 260 JR = IFRSTM, MIN( J+3, ILAST )
+ TEMP = TAU*( H( JR, J )+V( 2 )*H( JR, J+1 )+V( 3 )*
+ $ H( JR, J+2 ) )
+ H( JR, J ) = H( JR, J ) - TEMP
+ H( JR, J+1 ) = H( JR, J+1 ) - TEMP*V( 2 )
+ H( JR, J+2 ) = H( JR, J+2 ) - TEMP*V( 3 )
+ 260 CONTINUE
+ DO 270 JR = IFRSTM, J + 2
+ TEMP = TAU*( T( JR, J )+V( 2 )*T( JR, J+1 )+V( 3 )*
+ $ T( JR, J+2 ) )
+ T( JR, J ) = T( JR, J ) - TEMP
+ T( JR, J+1 ) = T( JR, J+1 ) - TEMP*V( 2 )
+ T( JR, J+2 ) = T( JR, J+2 ) - TEMP*V( 3 )
+ 270 CONTINUE
+ IF( ILZ ) THEN
+ DO 280 JR = 1, N
+ TEMP = TAU*( Z( JR, J )+V( 2 )*Z( JR, J+1 )+V( 3 )*
+ $ Z( JR, J+2 ) )
+ Z( JR, J ) = Z( JR, J ) - TEMP
+ Z( JR, J+1 ) = Z( JR, J+1 ) - TEMP*V( 2 )
+ Z( JR, J+2 ) = Z( JR, J+2 ) - TEMP*V( 3 )
+ 280 CONTINUE
+ END IF
+ T( J+1, J ) = ZERO
+ T( J+2, J ) = ZERO
+ 290 CONTINUE
+*
+* Last elements: Use Givens rotations
+*
+* Rotations from the left
+*
+ J = ILAST - 1
+ TEMP = H( J, J-1 )
+ CALL DLARTG( TEMP, H( J+1, J-1 ), C, S, H( J, J-1 ) )
+ H( J+1, J-1 ) = ZERO
+*
+ DO 300 JC = J, ILASTM
+ TEMP = C*H( J, JC ) + S*H( J+1, JC )
+ H( J+1, JC ) = -S*H( J, JC ) + C*H( J+1, JC )
+ H( J, JC ) = TEMP
+ TEMP2 = C*T( J, JC ) + S*T( J+1, JC )
+ T( J+1, JC ) = -S*T( J, JC ) + C*T( J+1, JC )
+ T( J, JC ) = TEMP2
+ 300 CONTINUE
+ IF( ILQ ) THEN
+ DO 310 JR = 1, N
+ TEMP = C*Q( JR, J ) + S*Q( JR, J+1 )
+ Q( JR, J+1 ) = -S*Q( JR, J ) + C*Q( JR, J+1 )
+ Q( JR, J ) = TEMP
+ 310 CONTINUE
+ END IF
+*
+* Rotations from the right.
+*
+ TEMP = T( J+1, J+1 )
+ CALL DLARTG( TEMP, T( J+1, J ), C, S, T( J+1, J+1 ) )
+ T( J+1, J ) = ZERO
+*
+ DO 320 JR = IFRSTM, ILAST
+ TEMP = C*H( JR, J+1 ) + S*H( JR, J )
+ H( JR, J ) = -S*H( JR, J+1 ) + C*H( JR, J )
+ H( JR, J+1 ) = TEMP
+ 320 CONTINUE
+ DO 330 JR = IFRSTM, ILAST - 1
+ TEMP = C*T( JR, J+1 ) + S*T( JR, J )
+ T( JR, J ) = -S*T( JR, J+1 ) + C*T( JR, J )
+ T( JR, J+1 ) = TEMP
+ 330 CONTINUE
+ IF( ILZ ) THEN
+ DO 340 JR = 1, N
+ TEMP = C*Z( JR, J+1 ) + S*Z( JR, J )
+ Z( JR, J ) = -S*Z( JR, J+1 ) + C*Z( JR, J )
+ Z( JR, J+1 ) = TEMP
+ 340 CONTINUE
+ END IF
+*
+* End of Double-Shift code
+*
+ END IF
+*
+ GO TO 350
+*
+* End of iteration loop
+*
+ 350 CONTINUE
+ 360 CONTINUE
+*
+* Drop-through = non-convergence
+*
+ INFO = ILAST
+ GO TO 420
+*
+* Successful completion of all QZ steps
+*
+ 380 CONTINUE
+*
+* Set Eigenvalues 1:ILO-1
+*
+ DO 410 J = 1, ILO - 1
+ IF( T( J, J ).LT.ZERO ) THEN
+ IF( ILSCHR ) THEN
+ DO 390 JR = 1, J
+ H( JR, J ) = -H( JR, J )
+ T( JR, J ) = -T( JR, J )
+ 390 CONTINUE
+ ELSE
+ H( J, J ) = -H( J, J )
+ T( J, J ) = -T( J, J )
+ END IF
+ IF( ILZ ) THEN
+ DO 400 JR = 1, N
+ Z( JR, J ) = -Z( JR, J )
+ 400 CONTINUE
+ END IF
+ END IF
+ ALPHAR( J ) = H( J, J )
+ ALPHAI( J ) = ZERO
+ BETA( J ) = T( J, J )
+ 410 CONTINUE
+*
+* Normal Termination
+*
+ INFO = 0
+*
+* Exit (other than argument error) -- return optimal workspace size
+*
+ 420 CONTINUE
+ WORK( 1 ) = DBLE( N )
+ RETURN
+*
+* End of DHGEQZ
+*
+ END
+ SUBROUTINE DHSEIN( SIDE, EIGSRC, INITV, SELECT, N, H, LDH, WR, WI,
+ $ VL, LDVL, VR, LDVR, MM, M, WORK, IFAILL,
+ $ IFAILR, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER EIGSRC, INITV, SIDE
+ INTEGER INFO, LDH, LDVL, LDVR, M, MM, N
+* ..
+* .. Array Arguments ..
+ LOGICAL SELECT( * )
+ INTEGER IFAILL( * ), IFAILR( * )
+ DOUBLE PRECISION H( LDH, * ), VL( LDVL, * ), VR( LDVR, * ),
+ $ WI( * ), WORK( * ), WR( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DHSEIN uses inverse iteration to find specified right and/or left
+* eigenvectors of a real upper Hessenberg matrix H.
+*
+* The right eigenvector x and the left eigenvector y of the matrix H
+* corresponding to an eigenvalue w are defined by:
+*
+* H * x = w * x, y**h * H = w * y**h
+*
+* where y**h denotes the conjugate transpose of the vector y.
+*
+* Arguments
+* =========
+*
+* SIDE (input) CHARACTER*1
+* = 'R': compute right eigenvectors only;
+* = 'L': compute left eigenvectors only;
+* = 'B': compute both right and left eigenvectors.
+*
+* EIGSRC (input) CHARACTER*1
+* Specifies the source of eigenvalues supplied in (WR,WI):
+* = 'Q': the eigenvalues were found using DHSEQR; thus, if
+* H has zero subdiagonal elements, and so is
+* block-triangular, then the j-th eigenvalue can be
+* assumed to be an eigenvalue of the block containing
+* the j-th row/column. This property allows DHSEIN to
+* perform inverse iteration on just one diagonal block.
+* = 'N': no assumptions are made on the correspondence
+* between eigenvalues and diagonal blocks. In this
+* case, DHSEIN must always perform inverse iteration
+* using the whole matrix H.
+*
+* INITV (input) CHARACTER*1
+* = 'N': no initial vectors are supplied;
+* = 'U': user-supplied initial vectors are stored in the arrays
+* VL and/or VR.
+*
+* SELECT (input/output) LOGICAL array, dimension (N)
+* Specifies the eigenvectors to be computed. To select the
+* real eigenvector corresponding to a real eigenvalue WR(j),
+* SELECT(j) must be set to .TRUE.. To select the complex
+* eigenvector corresponding to a complex eigenvalue
+* (WR(j),WI(j)), with complex conjugate (WR(j+1),WI(j+1)),
+* either SELECT(j) or SELECT(j+1) or both must be set to
+* .TRUE.; then on exit SELECT(j) is .TRUE. and SELECT(j+1) is
+* .FALSE..
+*
+* N (input) INTEGER
+* The order of the matrix H. N >= 0.
+*
+* H (input) DOUBLE PRECISION array, dimension (LDH,N)
+* The upper Hessenberg matrix H.
+*
+* LDH (input) INTEGER
+* The leading dimension of the array H. LDH >= max(1,N).
+*
+* WR (input/output) DOUBLE PRECISION array, dimension (N)
+* WI (input) DOUBLE PRECISION array, dimension (N)
+* On entry, the real and imaginary parts of the eigenvalues of
+* H; a complex conjugate pair of eigenvalues must be stored in
+* consecutive elements of WR and WI.
+* On exit, WR may have been altered since close eigenvalues
+* are perturbed slightly in searching for independent
+* eigenvectors.
+*
+* VL (input/output) DOUBLE PRECISION array, dimension (LDVL,MM)
+* On entry, if INITV = 'U' and SIDE = 'L' or 'B', VL must
+* contain starting vectors for the inverse iteration for the
+* left eigenvectors; the starting vector for each eigenvector
+* must be in the same column(s) in which the eigenvector will
+* be stored.
+* On exit, if SIDE = 'L' or 'B', the left eigenvectors
+* specified by SELECT will be stored consecutively in the
+* columns of VL, in the same order as their eigenvalues. A
+* complex eigenvector corresponding to a complex eigenvalue is
+* stored in two consecutive columns, the first holding the real
+* part and the second the imaginary part.
+* If SIDE = 'R', VL is not referenced.
+*
+* LDVL (input) INTEGER
+* The leading dimension of the array VL.
+* LDVL >= max(1,N) if SIDE = 'L' or 'B'; LDVL >= 1 otherwise.
+*
+* VR (input/output) DOUBLE PRECISION array, dimension (LDVR,MM)
+* On entry, if INITV = 'U' and SIDE = 'R' or 'B', VR must
+* contain starting vectors for the inverse iteration for the
+* right eigenvectors; the starting vector for each eigenvector
+* must be in the same column(s) in which the eigenvector will
+* be stored.
+* On exit, if SIDE = 'R' or 'B', the right eigenvectors
+* specified by SELECT will be stored consecutively in the
+* columns of VR, in the same order as their eigenvalues. A
+* complex eigenvector corresponding to a complex eigenvalue is
+* stored in two consecutive columns, the first holding the real
+* part and the second the imaginary part.
+* If SIDE = 'L', VR is not referenced.
+*
+* LDVR (input) INTEGER
+* The leading dimension of the array VR.
+* LDVR >= max(1,N) if SIDE = 'R' or 'B'; LDVR >= 1 otherwise.
+*
+* MM (input) INTEGER
+* The number of columns in the arrays VL and/or VR. MM >= M.
+*
+* M (output) INTEGER
+* The number of columns in the arrays VL and/or VR required to
+* store the eigenvectors; each selected real eigenvector
+* occupies one column and each selected complex eigenvector
+* occupies two columns.
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension ((N+2)*N)
+*
+* IFAILL (output) INTEGER array, dimension (MM)
+* If SIDE = 'L' or 'B', IFAILL(i) = j > 0 if the left
+* eigenvector in the i-th column of VL (corresponding to the
+* eigenvalue w(j)) failed to converge; IFAILL(i) = 0 if the
+* eigenvector converged satisfactorily. If the i-th and (i+1)th
+* columns of VL hold a complex eigenvector, then IFAILL(i) and
+* IFAILL(i+1) are set to the same value.
+* If SIDE = 'R', IFAILL is not referenced.
+*
+* IFAILR (output) INTEGER array, dimension (MM)
+* If SIDE = 'R' or 'B', IFAILR(i) = j > 0 if the right
+* eigenvector in the i-th column of VR (corresponding to the
+* eigenvalue w(j)) failed to converge; IFAILR(i) = 0 if the
+* eigenvector converged satisfactorily. If the i-th and (i+1)th
+* columns of VR hold a complex eigenvector, then IFAILR(i) and
+* IFAILR(i+1) are set to the same value.
+* If SIDE = 'L', IFAILR is not referenced.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* > 0: if INFO = i, i is the number of eigenvectors which
+* failed to converge; see IFAILL and IFAILR for further
+* details.
+*
+* Further Details
+* ===============
+*
+* Each eigenvector is normalized so that the element of largest
+* magnitude has magnitude 1; here the magnitude of a complex number
+* (x,y) is taken to be |x|+|y|.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL BOTHV, FROMQR, LEFTV, NOINIT, PAIR, RIGHTV
+ INTEGER I, IINFO, K, KL, KLN, KR, KSI, KSR, LDWORK
+ DOUBLE PRECISION BIGNUM, EPS3, HNORM, SMLNUM, ULP, UNFL, WKI,
+ $ WKR
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ DOUBLE PRECISION DLAMCH, DLANHS
+ EXTERNAL LSAME, DLAMCH, DLANHS
+* ..
+* .. External Subroutines ..
+ EXTERNAL DLAEIN, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX
+* ..
+* .. Executable Statements ..
+*
+* Decode and test the input parameters.
+*
+ BOTHV = LSAME( SIDE, 'B' )
+ RIGHTV = LSAME( SIDE, 'R' ) .OR. BOTHV
+ LEFTV = LSAME( SIDE, 'L' ) .OR. BOTHV
+*
+ FROMQR = LSAME( EIGSRC, 'Q' )
+*
+ NOINIT = LSAME( INITV, 'N' )
+*
+* Set M to the number of columns required to store the selected
+* eigenvectors, and standardize the array SELECT.
+*
+ M = 0
+ PAIR = .FALSE.
+ DO 10 K = 1, N
+ IF( PAIR ) THEN
+ PAIR = .FALSE.
+ SELECT( K ) = .FALSE.
+ ELSE
+ IF( WI( K ).EQ.ZERO ) THEN
+ IF( SELECT( K ) )
+ $ M = M + 1
+ ELSE
+ PAIR = .TRUE.
+ IF( SELECT( K ) .OR. SELECT( K+1 ) ) THEN
+ SELECT( K ) = .TRUE.
+ M = M + 2
+ END IF
+ END IF
+ END IF
+ 10 CONTINUE
+*
+ INFO = 0
+ IF( .NOT.RIGHTV .AND. .NOT.LEFTV ) THEN
+ INFO = -1
+ ELSE IF( .NOT.FROMQR .AND. .NOT.LSAME( EIGSRC, 'N' ) ) THEN
+ INFO = -2
+ ELSE IF( .NOT.NOINIT .AND. .NOT.LSAME( INITV, 'U' ) ) THEN
+ INFO = -3
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -5
+ ELSE IF( LDH.LT.MAX( 1, N ) ) THEN
+ INFO = -7
+ ELSE IF( LDVL.LT.1 .OR. ( LEFTV .AND. LDVL.LT.N ) ) THEN
+ INFO = -11
+ ELSE IF( LDVR.LT.1 .OR. ( RIGHTV .AND. LDVR.LT.N ) ) THEN
+ INFO = -13
+ ELSE IF( MM.LT.M ) THEN
+ INFO = -14
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DHSEIN', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible.
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+* Set machine-dependent constants.
+*
+ UNFL = DLAMCH( 'Safe minimum' )
+ ULP = DLAMCH( 'Precision' )
+ SMLNUM = UNFL*( N / ULP )
+ BIGNUM = ( ONE-ULP ) / SMLNUM
+*
+ LDWORK = N + 1
+*
+ KL = 1
+ KLN = 0
+ IF( FROMQR ) THEN
+ KR = 0
+ ELSE
+ KR = N
+ END IF
+ KSR = 1
+*
+ DO 120 K = 1, N
+ IF( SELECT( K ) ) THEN
+*
+* Compute eigenvector(s) corresponding to W(K).
+*
+ IF( FROMQR ) THEN
+*
+* If affiliation of eigenvalues is known, check whether
+* the matrix splits.
+*
+* Determine KL and KR such that 1 <= KL <= K <= KR <= N
+* and H(KL,KL-1) and H(KR+1,KR) are zero (or KL = 1 or
+* KR = N).
+*
+* Then inverse iteration can be performed with the
+* submatrix H(KL:N,KL:N) for a left eigenvector, and with
+* the submatrix H(1:KR,1:KR) for a right eigenvector.
+*
+ DO 20 I = K, KL + 1, -1
+ IF( H( I, I-1 ).EQ.ZERO )
+ $ GO TO 30
+ 20 CONTINUE
+ 30 CONTINUE
+ KL = I
+ IF( K.GT.KR ) THEN
+ DO 40 I = K, N - 1
+ IF( H( I+1, I ).EQ.ZERO )
+ $ GO TO 50
+ 40 CONTINUE
+ 50 CONTINUE
+ KR = I
+ END IF
+ END IF
+*
+ IF( KL.NE.KLN ) THEN
+ KLN = KL
+*
+* Compute infinity-norm of submatrix H(KL:KR,KL:KR) if it
+* has not ben computed before.
+*
+ HNORM = DLANHS( 'I', KR-KL+1, H( KL, KL ), LDH, WORK )
+ IF( HNORM.GT.ZERO ) THEN
+ EPS3 = HNORM*ULP
+ ELSE
+ EPS3 = SMLNUM
+ END IF
+ END IF
+*
+* Perturb eigenvalue if it is close to any previous
+* selected eigenvalues affiliated to the submatrix
+* H(KL:KR,KL:KR). Close roots are modified by EPS3.
+*
+ WKR = WR( K )
+ WKI = WI( K )
+ 60 CONTINUE
+ DO 70 I = K - 1, KL, -1
+ IF( SELECT( I ) .AND. ABS( WR( I )-WKR )+
+ $ ABS( WI( I )-WKI ).LT.EPS3 ) THEN
+ WKR = WKR + EPS3
+ GO TO 60
+ END IF
+ 70 CONTINUE
+ WR( K ) = WKR
+*
+ PAIR = WKI.NE.ZERO
+ IF( PAIR ) THEN
+ KSI = KSR + 1
+ ELSE
+ KSI = KSR
+ END IF
+ IF( LEFTV ) THEN
+*
+* Compute left eigenvector.
+*
+ CALL DLAEIN( .FALSE., NOINIT, N-KL+1, H( KL, KL ), LDH,
+ $ WKR, WKI, VL( KL, KSR ), VL( KL, KSI ),
+ $ WORK, LDWORK, WORK( N*N+N+1 ), EPS3, SMLNUM,
+ $ BIGNUM, IINFO )
+ IF( IINFO.GT.0 ) THEN
+ IF( PAIR ) THEN
+ INFO = INFO + 2
+ ELSE
+ INFO = INFO + 1
+ END IF
+ IFAILL( KSR ) = K
+ IFAILL( KSI ) = K
+ ELSE
+ IFAILL( KSR ) = 0
+ IFAILL( KSI ) = 0
+ END IF
+ DO 80 I = 1, KL - 1
+ VL( I, KSR ) = ZERO
+ 80 CONTINUE
+ IF( PAIR ) THEN
+ DO 90 I = 1, KL - 1
+ VL( I, KSI ) = ZERO
+ 90 CONTINUE
+ END IF
+ END IF
+ IF( RIGHTV ) THEN
+*
+* Compute right eigenvector.
+*
+ CALL DLAEIN( .TRUE., NOINIT, KR, H, LDH, WKR, WKI,
+ $ VR( 1, KSR ), VR( 1, KSI ), WORK, LDWORK,
+ $ WORK( N*N+N+1 ), EPS3, SMLNUM, BIGNUM,
+ $ IINFO )
+ IF( IINFO.GT.0 ) THEN
+ IF( PAIR ) THEN
+ INFO = INFO + 2
+ ELSE
+ INFO = INFO + 1
+ END IF
+ IFAILR( KSR ) = K
+ IFAILR( KSI ) = K
+ ELSE
+ IFAILR( KSR ) = 0
+ IFAILR( KSI ) = 0
+ END IF
+ DO 100 I = KR + 1, N
+ VR( I, KSR ) = ZERO
+ 100 CONTINUE
+ IF( PAIR ) THEN
+ DO 110 I = KR + 1, N
+ VR( I, KSI ) = ZERO
+ 110 CONTINUE
+ END IF
+ END IF
+*
+ IF( PAIR ) THEN
+ KSR = KSR + 2
+ ELSE
+ KSR = KSR + 1
+ END IF
+ END IF
+ 120 CONTINUE
+*
+ RETURN
+*
+* End of DHSEIN
+*
+ END
+ SUBROUTINE DHSEQR( JOB, COMPZ, N, ILO, IHI, H, LDH, WR, WI, Z,
+ $ LDZ, WORK, LWORK, INFO )
+*
+* -- LAPACK driver routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER IHI, ILO, INFO, LDH, LDZ, LWORK, N
+ CHARACTER COMPZ, JOB
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION H( LDH, * ), WI( * ), WORK( * ), WR( * ),
+ $ Z( LDZ, * )
+* ..
+* Purpose
+* =======
+*
+* DHSEQR computes the eigenvalues of a Hessenberg matrix H
+* and, optionally, the matrices T and Z from the Schur decomposition
+* H = Z T Z**T, where T is an upper quasi-triangular matrix (the
+* Schur form), and Z is the orthogonal matrix of Schur vectors.
+*
+* Optionally Z may be postmultiplied into an input orthogonal
+* matrix Q so that this routine can give the Schur factorization
+* of a matrix A which has been reduced to the Hessenberg form H
+* by the orthogonal matrix Q: A = Q*H*Q**T = (QZ)*T*(QZ)**T.
+*
+* Arguments
+* =========
+*
+* JOB (input) CHARACTER*1
+* = 'E': compute eigenvalues only;
+* = 'S': compute eigenvalues and the Schur form T.
+*
+* COMPZ (input) CHARACTER*1
+* = 'N': no Schur vectors are computed;
+* = 'I': Z is initialized to the unit matrix and the matrix Z
+* of Schur vectors of H is returned;
+* = 'V': Z must contain an orthogonal matrix Q on entry, and
+* the product Q*Z is returned.
+*
+* N (input) INTEGER
+* The order of the matrix H. N .GE. 0.
+*
+* ILO (input) INTEGER
+* IHI (input) INTEGER
+* It is assumed that H is already upper triangular in rows
+* and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally
+* set by a previous call to DGEBAL, and then passed to DGEHRD
+* when the matrix output by DGEBAL is reduced to Hessenberg
+* form. Otherwise ILO and IHI should be set to 1 and N
+* respectively. If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N.
+* If N = 0, then ILO = 1 and IHI = 0.
+*
+* H (input/output) DOUBLE PRECISION array, dimension (LDH,N)
+* On entry, the upper Hessenberg matrix H.
+* On exit, if INFO = 0 and JOB = 'S', then H contains the
+* upper quasi-triangular matrix T from the Schur decomposition
+* (the Schur form); 2-by-2 diagonal blocks (corresponding to
+* complex conjugate pairs of eigenvalues) are returned in
+* standard form, with H(i,i) = H(i+1,i+1) and
+* H(i+1,i)*H(i,i+1).LT.0. If INFO = 0 and JOB = 'E', the
+* contents of H are unspecified on exit. (The output value of
+* H when INFO.GT.0 is given under the description of INFO
+* below.)
+*
+* Unlike earlier versions of DHSEQR, this subroutine may
+* explicitly H(i,j) = 0 for i.GT.j and j = 1, 2, ... ILO-1
+* or j = IHI+1, IHI+2, ... N.
+*
+* LDH (input) INTEGER
+* The leading dimension of the array H. LDH .GE. max(1,N).
+*
+* WR (output) DOUBLE PRECISION array, dimension (N)
+* WI (output) DOUBLE PRECISION array, dimension (N)
+* The real and imaginary parts, respectively, of the computed
+* eigenvalues. If two eigenvalues are computed as a complex
+* conjugate pair, they are stored in consecutive elements of
+* WR and WI, say the i-th and (i+1)th, with WI(i) .GT. 0 and
+* WI(i+1) .LT. 0. If JOB = 'S', the eigenvalues are stored in
+* the same order as on the diagonal of the Schur form returned
+* in H, with WR(i) = H(i,i) and, if H(i:i+1,i:i+1) is a 2-by-2
+* diagonal block, WI(i) = sqrt(-H(i+1,i)*H(i,i+1)) and
+* WI(i+1) = -WI(i).
+*
+* Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N)
+* If COMPZ = 'N', Z is not referenced.
+* If COMPZ = 'I', on entry Z need not be set and on exit,
+* if INFO = 0, Z contains the orthogonal matrix Z of the Schur
+* vectors of H. If COMPZ = 'V', on entry Z must contain an
+* N-by-N matrix Q, which is assumed to be equal to the unit
+* matrix except for the submatrix Z(ILO:IHI,ILO:IHI). On exit,
+* if INFO = 0, Z contains Q*Z.
+* Normally Q is the orthogonal matrix generated by DORGHR
+* after the call to DGEHRD which formed the Hessenberg matrix
+* H. (The output value of Z when INFO.GT.0 is given under
+* the description of INFO below.)
+*
+* LDZ (input) INTEGER
+* The leading dimension of the array Z. if COMPZ = 'I' or
+* COMPZ = 'V', then LDZ.GE.MAX(1,N). Otherwize, LDZ.GE.1.
+*
+* WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK)
+* On exit, if INFO = 0, WORK(1) returns an estimate of
+* the optimal value for LWORK.
+*
+* LWORK (input) INTEGER
+* The dimension of the array WORK. LWORK .GE. max(1,N)
+* is sufficient, but LWORK typically as large as 6*N may
+* be required for optimal performance. A workspace query
+* to determine the optimal workspace size is recommended.
+*
+* If LWORK = -1, then DHSEQR does a workspace query.
+* In this case, DHSEQR checks the input parameters and
+* estimates the optimal workspace size for the given
+* values of N, ILO and IHI. The estimate is returned
+* in WORK(1). No error message related to LWORK is
+* issued by XERBLA. Neither H nor Z are accessed.
+*
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* .LT. 0: if INFO = -i, the i-th argument had an illegal
+* value
+* .GT. 0: if INFO = i, DHSEQR failed to compute all of
+* the eigenvalues. Elements 1:ilo-1 and i+1:n of WR
+* and WI contain those eigenvalues which have been
+* successfully computed. (Failures are rare.)
+*
+* If INFO .GT. 0 and JOB = 'E', then on exit, the
+* remaining unconverged eigenvalues are the eigen-
+* values of the upper Hessenberg matrix rows and
+* columns ILO through INFO of the final, output
+* value of H.
+*
+* If INFO .GT. 0 and JOB = 'S', then on exit
+*
+* (*) (initial value of H)*U = U*(final value of H)
+*
+* where U is an orthogonal matrix. The final
+* value of H is upper Hessenberg and quasi-triangular
+* in rows and columns INFO+1 through IHI.
+*
+* If INFO .GT. 0 and COMPZ = 'V', then on exit
+*
+* (final value of Z) = (initial value of Z)*U
+*
+* where U is the orthogonal matrix in (*) (regard-
+* less of the value of JOB.)
+*
+* If INFO .GT. 0 and COMPZ = 'I', then on exit
+* (final value of Z) = U
+* where U is the orthogonal matrix in (*) (regard-
+* less of the value of JOB.)
+*
+* If INFO .GT. 0 and COMPZ = 'N', then Z is not
+* accessed.
+*
+* ================================================================
+* Default values supplied by
+* ILAENV(ISPEC,'DHSEQR',JOB(:1)//COMPZ(:1),N,ILO,IHI,LWORK).
+* It is suggested that these defaults be adjusted in order
+* to attain best performance in each particular
+* computational environment.
+*
+* ISPEC=1: The DLAHQR vs DLAQR0 crossover point.
+* Default: 75. (Must be at least 11.)
+*
+* ISPEC=2: Recommended deflation window size.
+* This depends on ILO, IHI and NS. NS is the
+* number of simultaneous shifts returned
+* by ILAENV(ISPEC=4). (See ISPEC=4 below.)
+* The default for (IHI-ILO+1).LE.500 is NS.
+* The default for (IHI-ILO+1).GT.500 is 3*NS/2.
+*
+* ISPEC=3: Nibble crossover point. (See ILAENV for
+* details.) Default: 14% of deflation window
+* size.
+*
+* ISPEC=4: Number of simultaneous shifts, NS, in
+* a multi-shift QR iteration.
+*
+* If IHI-ILO+1 is ...
+*
+* greater than ...but less ... the
+* or equal to ... than default is
+*
+* 1 30 NS - 2(+)
+* 30 60 NS - 4(+)
+* 60 150 NS = 10(+)
+* 150 590 NS = **
+* 590 3000 NS = 64
+* 3000 6000 NS = 128
+* 6000 infinity NS = 256
+*
+* (+) By default some or all matrices of this order
+* are passed to the implicit double shift routine
+* DLAHQR and NS is ignored. See ISPEC=1 above
+* and comments in IPARM for details.
+*
+* The asterisks (**) indicate an ad-hoc
+* function of N increasing from 10 to 64.
+*
+* ISPEC=5: Select structured matrix multiply.
+* (See ILAENV for details.) Default: 3.
+*
+* ================================================================
+* Based on contributions by
+* Karen Braman and Ralph Byers, Department of Mathematics,
+* University of Kansas, USA
+*
+* ================================================================
+* References:
+* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR
+* Algorithm Part I: Maintaining Well Focused Shifts, and Level 3
+* Performance, SIAM Journal of Matrix Analysis, volume 23, pages
+* 929--947, 2002.
+*
+* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR
+* Algorithm Part II: Aggressive Early Deflation, SIAM Journal
+* of Matrix Analysis, volume 23, pages 948--973, 2002.
+*
+* ================================================================
+* .. Parameters ..
+*
+* ==== Matrices of order NTINY or smaller must be processed by
+* . DLAHQR because of insufficient subdiagonal scratch space.
+* . (This is a hard limit.) ====
+*
+* ==== NL allocates some local workspace to help small matrices
+* . through a rare DLAHQR failure. NL .GT. NTINY = 11 is
+* . required and NL .LE. NMIN = ILAENV(ISPEC=1,...) is recom-
+* . mended. (The default value of NMIN is 75.) Using NL = 49
+* . allows up to six simultaneous shifts and a 16-by-16
+* . deflation window. ====
+*
+ INTEGER NTINY
+ PARAMETER ( NTINY = 11 )
+ INTEGER NL
+ PARAMETER ( NL = 49 )
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0d0, ONE = 1.0d0 )
+* ..
+* .. Local Arrays ..
+ DOUBLE PRECISION HL( NL, NL ), WORKL( NL )
+* ..
+* .. Local Scalars ..
+ INTEGER I, KBOT, NMIN
+ LOGICAL INITZ, LQUERY, WANTT, WANTZ
+* ..
+* .. External Functions ..
+ INTEGER ILAENV
+ LOGICAL LSAME
+ EXTERNAL ILAENV, LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL DLACPY, DLAHQR, DLAQR0, DLASET, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC DBLE, MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+* ==== Decode and check the input parameters. ====
+*
+ WANTT = LSAME( JOB, 'S' )
+ INITZ = LSAME( COMPZ, 'I' )
+ WANTZ = INITZ .OR. LSAME( COMPZ, 'V' )
+ WORK( 1 ) = DBLE( MAX( 1, N ) )
+ LQUERY = LWORK.EQ.-1
+*
+ INFO = 0
+ IF( .NOT.LSAME( JOB, 'E' ) .AND. .NOT.WANTT ) THEN
+ INFO = -1
+ ELSE IF( .NOT.LSAME( COMPZ, 'N' ) .AND. .NOT.WANTZ ) THEN
+ INFO = -2
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN
+ INFO = -4
+ ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN
+ INFO = -5
+ ELSE IF( LDH.LT.MAX( 1, N ) ) THEN
+ INFO = -7
+ ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.MAX( 1, N ) ) ) THEN
+ INFO = -11
+ ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN
+ INFO = -13
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+*
+* ==== Quick return in case of invalid argument. ====
+*
+ CALL XERBLA( 'DHSEQR', -INFO )
+ RETURN
+*
+ ELSE IF( N.EQ.0 ) THEN
+*
+* ==== Quick return in case N = 0; nothing to do. ====
+*
+ RETURN
+*
+ ELSE IF( LQUERY ) THEN
+*
+* ==== Quick return in case of a workspace query ====
+*
+ CALL DLAQR0( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, ILO,
+ $ IHI, Z, LDZ, WORK, LWORK, INFO )
+* ==== Ensure reported workspace size is backward-compatible with
+* . previous LAPACK versions. ====
+ WORK( 1 ) = MAX( DBLE( MAX( 1, N ) ), WORK( 1 ) )
+ RETURN
+*
+ ELSE
+*
+* ==== copy eigenvalues isolated by DGEBAL ====
+*
+ DO 10 I = 1, ILO - 1
+ WR( I ) = H( I, I )
+ WI( I ) = ZERO
+ 10 CONTINUE
+ DO 20 I = IHI + 1, N
+ WR( I ) = H( I, I )
+ WI( I ) = ZERO
+ 20 CONTINUE
+*
+* ==== Initialize Z, if requested ====
+*
+ IF( INITZ )
+ $ CALL DLASET( 'A', N, N, ZERO, ONE, Z, LDZ )
+*
+* ==== Quick return if possible ====
+*
+ IF( ILO.EQ.IHI ) THEN
+ WR( ILO ) = H( ILO, ILO )
+ WI( ILO ) = ZERO
+ RETURN
+ END IF
+*
+* ==== DLAHQR/DLAQR0 crossover point ====
+*
+ NMIN = ILAENV( 12, 'DHSEQR', JOB( : 1 ) // COMPZ( : 1 ), N,
+ $ ILO, IHI, LWORK )
+ NMIN = MAX( NTINY, NMIN )
+*
+* ==== DLAQR0 for big matrices; DLAHQR for small ones ====
+*
+ IF( N.GT.NMIN ) THEN
+ CALL DLAQR0( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, ILO,
+ $ IHI, Z, LDZ, WORK, LWORK, INFO )
+ ELSE
+*
+* ==== Small matrix ====
+*
+ CALL DLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, ILO,
+ $ IHI, Z, LDZ, INFO )
+*
+ IF( INFO.GT.0 ) THEN
+*
+* ==== A rare DLAHQR failure! DLAQR0 sometimes succeeds
+* . when DLAHQR fails. ====
+*
+ KBOT = INFO
+*
+ IF( N.GE.NL ) THEN
+*
+* ==== Larger matrices have enough subdiagonal scratch
+* . space to call DLAQR0 directly. ====
+*
+ CALL DLAQR0( WANTT, WANTZ, N, ILO, KBOT, H, LDH, WR,
+ $ WI, ILO, IHI, Z, LDZ, WORK, LWORK, INFO )
+*
+ ELSE
+*
+* ==== Tiny matrices don't have enough subdiagonal
+* . scratch space to benefit from DLAQR0. Hence,
+* . tiny matrices must be copied into a larger
+* . array before calling DLAQR0. ====
+*
+ CALL DLACPY( 'A', N, N, H, LDH, HL, NL )
+ HL( N+1, N ) = ZERO
+ CALL DLASET( 'A', NL, NL-N, ZERO, ZERO, HL( 1, N+1 ),
+ $ NL )
+ CALL DLAQR0( WANTT, WANTZ, NL, ILO, KBOT, HL, NL, WR,
+ $ WI, ILO, IHI, Z, LDZ, WORKL, NL, INFO )
+ IF( WANTT .OR. INFO.NE.0 )
+ $ CALL DLACPY( 'A', N, N, HL, NL, H, LDH )
+ END IF
+ END IF
+ END IF
+*
+* ==== Clear out the trash, if necessary. ====
+*
+ IF( ( WANTT .OR. INFO.NE.0 ) .AND. N.GT.2 )
+ $ CALL DLASET( 'L', N-2, N-2, ZERO, ZERO, H( 3, 1 ), LDH )
+*
+* ==== Ensure reported workspace size is backward-compatible with
+* . previous LAPACK versions. ====
+*
+ WORK( 1 ) = MAX( DBLE( MAX( 1, N ) ), WORK( 1 ) )
+ END IF
+*
+* ==== End of DHSEQR ====
+*
+ END
+ LOGICAL FUNCTION DISNAN(DIN)
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ DOUBLE PRECISION DIN
+* ..
+*
+* Purpose
+* =======
+*
+* DISNAN returns .TRUE. if its argument is NaN, and .FALSE.
+* otherwise. To be replaced by the Fortran 2003 intrinsic in the
+* future.
+*
+* Arguments
+* =========
+*
+* DIN (input) DOUBLE PRECISION
+* Input to test for NaN.
+*
+* =====================================================================
+*
+* .. External Functions ..
+ LOGICAL DLAISNAN
+ EXTERNAL DLAISNAN
+* ..
+* .. Executable Statements ..
+ DISNAN = DLAISNAN(DIN,DIN)
+ RETURN
+ END
+ SUBROUTINE DLABAD( SMALL, LARGE )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ DOUBLE PRECISION LARGE, SMALL
+* ..
+*
+* Purpose
+* =======
+*
+* DLABAD takes as input the values computed by DLAMCH for underflow and
+* overflow, and returns the square root of each of these values if the
+* log of LARGE is sufficiently large. This subroutine is intended to
+* identify machines with a large exponent range, such as the Crays, and
+* redefine the underflow and overflow limits to be the square roots of
+* the values computed by DLAMCH. This subroutine is needed because
+* DLAMCH does not compensate for poor arithmetic in the upper half of
+* the exponent range, as is found on a Cray.
+*
+* Arguments
+* =========
+*
+* SMALL (input/output) DOUBLE PRECISION
+* On entry, the underflow threshold as computed by DLAMCH.
+* On exit, if LOG10(LARGE) is sufficiently large, the square
+* root of SMALL, otherwise unchanged.
+*
+* LARGE (input/output) DOUBLE PRECISION
+* On entry, the overflow threshold as computed by DLAMCH.
+* On exit, if LOG10(LARGE) is sufficiently large, the square
+* root of LARGE, otherwise unchanged.
+*
+* =====================================================================
+*
+* .. Intrinsic Functions ..
+ INTRINSIC LOG10, SQRT
+* ..
+* .. Executable Statements ..
+*
+* If it looks like we're on a Cray, take the square root of
+* SMALL and LARGE to avoid overflow and underflow problems.
+*
+ IF( LOG10( LARGE ).GT.2000.D0 ) THEN
+ SMALL = SQRT( SMALL )
+ LARGE = SQRT( LARGE )
+ END IF
+*
+ RETURN
+*
+* End of DLABAD
+*
+ END
+ SUBROUTINE DLABRD( M, N, NB, A, LDA, D, E, TAUQ, TAUP, X, LDX, Y,
+ $ LDY )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER LDA, LDX, LDY, M, N, NB
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION A( LDA, * ), D( * ), E( * ), TAUP( * ),
+ $ TAUQ( * ), X( LDX, * ), Y( LDY, * )
+* ..
+*
+* Purpose
+* =======
+*
+* DLABRD reduces the first NB rows and columns of a real general
+* m by n matrix A to upper or lower bidiagonal form by an orthogonal
+* transformation Q' * A * P, and returns the matrices X and Y which
+* are needed to apply the transformation to the unreduced part of A.
+*
+* If m >= n, A is reduced to upper bidiagonal form; if m < n, to lower
+* bidiagonal form.
+*
+* This is an auxiliary routine called by DGEBRD
+*
+* Arguments
+* =========
+*
+* M (input) INTEGER
+* The number of rows in the matrix A.
+*
+* N (input) INTEGER
+* The number of columns in the matrix A.
+*
+* NB (input) INTEGER
+* The number of leading rows and columns of A to be reduced.
+*
+* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+* On entry, the m by n general matrix to be reduced.
+* On exit, the first NB rows and columns of the matrix are
+* overwritten; the rest of the array is unchanged.
+* If m >= n, elements on and below the diagonal in the first NB
+* columns, with the array TAUQ, represent the orthogonal
+* matrix Q as a product of elementary reflectors; and
+* elements above the diagonal in the first NB rows, with the
+* array TAUP, represent the orthogonal matrix P as a product
+* of elementary reflectors.
+* If m < n, elements below the diagonal in the first NB
+* columns, with the array TAUQ, represent the orthogonal
+* matrix Q as a product of elementary reflectors, and
+* elements on and above the diagonal in the first NB rows,
+* with the array TAUP, represent the orthogonal matrix P as
+* a product of elementary reflectors.
+* See Further Details.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,M).
+*
+* D (output) DOUBLE PRECISION array, dimension (NB)
+* The diagonal elements of the first NB rows and columns of
+* the reduced matrix. D(i) = A(i,i).
+*
+* E (output) DOUBLE PRECISION array, dimension (NB)
+* The off-diagonal elements of the first NB rows and columns of
+* the reduced matrix.
+*
+* TAUQ (output) DOUBLE PRECISION array dimension (NB)
+* The scalar factors of the elementary reflectors which
+* represent the orthogonal matrix Q. See Further Details.
+*
+* TAUP (output) DOUBLE PRECISION array, dimension (NB)
+* The scalar factors of the elementary reflectors which
+* represent the orthogonal matrix P. See Further Details.
+*
+* X (output) DOUBLE PRECISION array, dimension (LDX,NB)
+* The m-by-nb matrix X required to update the unreduced part
+* of A.
+*
+* LDX (input) INTEGER
+* The leading dimension of the array X. LDX >= M.
+*
+* Y (output) DOUBLE PRECISION array, dimension (LDY,NB)
+* The n-by-nb matrix Y required to update the unreduced part
+* of A.
+*
+* LDY (input) INTEGER
+* The leading dimension of the array Y. LDY >= N.
+*
+* Further Details
+* ===============
+*
+* The matrices Q and P are represented as products of elementary
+* reflectors:
+*
+* Q = H(1) H(2) . . . H(nb) and P = G(1) G(2) . . . G(nb)
+*
+* Each H(i) and G(i) has the form:
+*
+* H(i) = I - tauq * v * v' and G(i) = I - taup * u * u'
+*
+* where tauq and taup are real scalars, and v and u are real vectors.
+*
+* If m >= n, v(1:i-1) = 0, v(i) = 1, and v(i:m) is stored on exit in
+* A(i:m,i); u(1:i) = 0, u(i+1) = 1, and u(i+1:n) is stored on exit in
+* A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i).
+*
+* If m < n, v(1:i) = 0, v(i+1) = 1, and v(i+1:m) is stored on exit in
+* A(i+2:m,i); u(1:i-1) = 0, u(i) = 1, and u(i:n) is stored on exit in
+* A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i).
+*
+* The elements of the vectors v and u together form the m-by-nb matrix
+* V and the nb-by-n matrix U' which are needed, with X and Y, to apply
+* the transformation to the unreduced part of the matrix, using a block
+* update of the form: A := A - V*Y' - X*U'.
+*
+* The contents of A on exit are illustrated by the following examples
+* with nb = 2:
+*
+* m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n):
+*
+* ( 1 1 u1 u1 u1 ) ( 1 u1 u1 u1 u1 u1 )
+* ( v1 1 1 u2 u2 ) ( 1 1 u2 u2 u2 u2 )
+* ( v1 v2 a a a ) ( v1 1 a a a a )
+* ( v1 v2 a a a ) ( v1 v2 a a a a )
+* ( v1 v2 a a a ) ( v1 v2 a a a a )
+* ( v1 v2 a a a )
+*
+* where a denotes an element of the original matrix which is unchanged,
+* vi denotes an element of the vector defining H(i), and ui an element
+* of the vector defining G(i).
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I
+* ..
+* .. External Subroutines ..
+ EXTERNAL DGEMV, DLARFG, DSCAL
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MIN
+* ..
+* .. Executable Statements ..
+*
+* Quick return if possible
+*
+ IF( M.LE.0 .OR. N.LE.0 )
+ $ RETURN
+*
+ IF( M.GE.N ) THEN
+*
+* Reduce to upper bidiagonal form
+*
+ DO 10 I = 1, NB
+*
+* Update A(i:m,i)
+*
+ CALL DGEMV( 'No transpose', M-I+1, I-1, -ONE, A( I, 1 ),
+ $ LDA, Y( I, 1 ), LDY, ONE, A( I, I ), 1 )
+ CALL DGEMV( 'No transpose', M-I+1, I-1, -ONE, X( I, 1 ),
+ $ LDX, A( 1, I ), 1, ONE, A( I, I ), 1 )
+*
+* Generate reflection Q(i) to annihilate A(i+1:m,i)
+*
+ CALL DLARFG( M-I+1, A( I, I ), A( MIN( I+1, M ), I ), 1,
+ $ TAUQ( I ) )
+ D( I ) = A( I, I )
+ IF( I.LT.N ) THEN
+ A( I, I ) = ONE
+*
+* Compute Y(i+1:n,i)
+*
+ CALL DGEMV( 'Transpose', M-I+1, N-I, ONE, A( I, I+1 ),
+ $ LDA, A( I, I ), 1, ZERO, Y( I+1, I ), 1 )
+ CALL DGEMV( 'Transpose', M-I+1, I-1, ONE, A( I, 1 ), LDA,
+ $ A( I, I ), 1, ZERO, Y( 1, I ), 1 )
+ CALL DGEMV( 'No transpose', N-I, I-1, -ONE, Y( I+1, 1 ),
+ $ LDY, Y( 1, I ), 1, ONE, Y( I+1, I ), 1 )
+ CALL DGEMV( 'Transpose', M-I+1, I-1, ONE, X( I, 1 ), LDX,
+ $ A( I, I ), 1, ZERO, Y( 1, I ), 1 )
+ CALL DGEMV( 'Transpose', I-1, N-I, -ONE, A( 1, I+1 ),
+ $ LDA, Y( 1, I ), 1, ONE, Y( I+1, I ), 1 )
+ CALL DSCAL( N-I, TAUQ( I ), Y( I+1, I ), 1 )
+*
+* Update A(i,i+1:n)
+*
+ CALL DGEMV( 'No transpose', N-I, I, -ONE, Y( I+1, 1 ),
+ $ LDY, A( I, 1 ), LDA, ONE, A( I, I+1 ), LDA )
+ CALL DGEMV( 'Transpose', I-1, N-I, -ONE, A( 1, I+1 ),
+ $ LDA, X( I, 1 ), LDX, ONE, A( I, I+1 ), LDA )
+*
+* Generate reflection P(i) to annihilate A(i,i+2:n)
+*
+ CALL DLARFG( N-I, A( I, I+1 ), A( I, MIN( I+2, N ) ),
+ $ LDA, TAUP( I ) )
+ E( I ) = A( I, I+1 )
+ A( I, I+1 ) = ONE
+*
+* Compute X(i+1:m,i)
+*
+ CALL DGEMV( 'No transpose', M-I, N-I, ONE, A( I+1, I+1 ),
+ $ LDA, A( I, I+1 ), LDA, ZERO, X( I+1, I ), 1 )
+ CALL DGEMV( 'Transpose', N-I, I, ONE, Y( I+1, 1 ), LDY,
+ $ A( I, I+1 ), LDA, ZERO, X( 1, I ), 1 )
+ CALL DGEMV( 'No transpose', M-I, I, -ONE, A( I+1, 1 ),
+ $ LDA, X( 1, I ), 1, ONE, X( I+1, I ), 1 )
+ CALL DGEMV( 'No transpose', I-1, N-I, ONE, A( 1, I+1 ),
+ $ LDA, A( I, I+1 ), LDA, ZERO, X( 1, I ), 1 )
+ CALL DGEMV( 'No transpose', M-I, I-1, -ONE, X( I+1, 1 ),
+ $ LDX, X( 1, I ), 1, ONE, X( I+1, I ), 1 )
+ CALL DSCAL( M-I, TAUP( I ), X( I+1, I ), 1 )
+ END IF
+ 10 CONTINUE
+ ELSE
+*
+* Reduce to lower bidiagonal form
+*
+ DO 20 I = 1, NB
+*
+* Update A(i,i:n)
+*
+ CALL DGEMV( 'No transpose', N-I+1, I-1, -ONE, Y( I, 1 ),
+ $ LDY, A( I, 1 ), LDA, ONE, A( I, I ), LDA )
+ CALL DGEMV( 'Transpose', I-1, N-I+1, -ONE, A( 1, I ), LDA,
+ $ X( I, 1 ), LDX, ONE, A( I, I ), LDA )
+*
+* Generate reflection P(i) to annihilate A(i,i+1:n)
+*
+ CALL DLARFG( N-I+1, A( I, I ), A( I, MIN( I+1, N ) ), LDA,
+ $ TAUP( I ) )
+ D( I ) = A( I, I )
+ IF( I.LT.M ) THEN
+ A( I, I ) = ONE
+*
+* Compute X(i+1:m,i)
+*
+ CALL DGEMV( 'No transpose', M-I, N-I+1, ONE, A( I+1, I ),
+ $ LDA, A( I, I ), LDA, ZERO, X( I+1, I ), 1 )
+ CALL DGEMV( 'Transpose', N-I+1, I-1, ONE, Y( I, 1 ), LDY,
+ $ A( I, I ), LDA, ZERO, X( 1, I ), 1 )
+ CALL DGEMV( 'No transpose', M-I, I-1, -ONE, A( I+1, 1 ),
+ $ LDA, X( 1, I ), 1, ONE, X( I+1, I ), 1 )
+ CALL DGEMV( 'No transpose', I-1, N-I+1, ONE, A( 1, I ),
+ $ LDA, A( I, I ), LDA, ZERO, X( 1, I ), 1 )
+ CALL DGEMV( 'No transpose', M-I, I-1, -ONE, X( I+1, 1 ),
+ $ LDX, X( 1, I ), 1, ONE, X( I+1, I ), 1 )
+ CALL DSCAL( M-I, TAUP( I ), X( I+1, I ), 1 )
+*
+* Update A(i+1:m,i)
+*
+ CALL DGEMV( 'No transpose', M-I, I-1, -ONE, A( I+1, 1 ),
+ $ LDA, Y( I, 1 ), LDY, ONE, A( I+1, I ), 1 )
+ CALL DGEMV( 'No transpose', M-I, I, -ONE, X( I+1, 1 ),
+ $ LDX, A( 1, I ), 1, ONE, A( I+1, I ), 1 )
+*
+* Generate reflection Q(i) to annihilate A(i+2:m,i)
+*
+ CALL DLARFG( M-I, A( I+1, I ), A( MIN( I+2, M ), I ), 1,
+ $ TAUQ( I ) )
+ E( I ) = A( I+1, I )
+ A( I+1, I ) = ONE
+*
+* Compute Y(i+1:n,i)
+*
+ CALL DGEMV( 'Transpose', M-I, N-I, ONE, A( I+1, I+1 ),
+ $ LDA, A( I+1, I ), 1, ZERO, Y( I+1, I ), 1 )
+ CALL DGEMV( 'Transpose', M-I, I-1, ONE, A( I+1, 1 ), LDA,
+ $ A( I+1, I ), 1, ZERO, Y( 1, I ), 1 )
+ CALL DGEMV( 'No transpose', N-I, I-1, -ONE, Y( I+1, 1 ),
+ $ LDY, Y( 1, I ), 1, ONE, Y( I+1, I ), 1 )
+ CALL DGEMV( 'Transpose', M-I, I, ONE, X( I+1, 1 ), LDX,
+ $ A( I+1, I ), 1, ZERO, Y( 1, I ), 1 )
+ CALL DGEMV( 'Transpose', I, N-I, -ONE, A( 1, I+1 ), LDA,
+ $ Y( 1, I ), 1, ONE, Y( I+1, I ), 1 )
+ CALL DSCAL( N-I, TAUQ( I ), Y( I+1, I ), 1 )
+ END IF
+ 20 CONTINUE
+ END IF
+ RETURN
+*
+* End of DLABRD
+*
+ END
+ SUBROUTINE DLACN2( N, V, X, ISGN, EST, KASE, ISAVE )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER KASE, N
+ DOUBLE PRECISION EST
+* ..
+* .. Array Arguments ..
+ INTEGER ISGN( * ), ISAVE( 3 )
+ DOUBLE PRECISION V( * ), X( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DLACN2 estimates the 1-norm of a square, real matrix A.
+* Reverse communication is used for evaluating matrix-vector products.
+*
+* Arguments
+* =========
+*
+* N (input) INTEGER
+* The order of the matrix. N >= 1.
+*
+* V (workspace) DOUBLE PRECISION array, dimension (N)
+* On the final return, V = A*W, where EST = norm(V)/norm(W)
+* (W is not returned).
+*
+* X (input/output) DOUBLE PRECISION array, dimension (N)
+* On an intermediate return, X should be overwritten by
+* A * X, if KASE=1,
+* A' * X, if KASE=2,
+* and DLACN2 must be re-called with all the other parameters
+* unchanged.
+*
+* ISGN (workspace) INTEGER array, dimension (N)
+*
+* EST (input/output) DOUBLE PRECISION
+* On entry with KASE = 1 or 2 and ISAVE(1) = 3, EST should be
+* unchanged from the previous call to DLACN2.
+* On exit, EST is an estimate (a lower bound) for norm(A).
+*
+* KASE (input/output) INTEGER
+* On the initial call to DLACN2, KASE should be 0.
+* On an intermediate return, KASE will be 1 or 2, indicating
+* whether X should be overwritten by A * X or A' * X.
+* On the final return from DLACN2, KASE will again be 0.
+*
+* ISAVE (input/output) INTEGER array, dimension (3)
+* ISAVE is used to save variables between calls to DLACN2
+*
+* Further Details
+* ======= =======
+*
+* Contributed by Nick Higham, University of Manchester.
+* Originally named SONEST, dated March 16, 1988.
+*
+* Reference: N.J. Higham, "FORTRAN codes for estimating the one-norm of
+* a real or complex matrix, with applications to condition estimation",
+* ACM Trans. Math. Soft., vol. 14, no. 4, pp. 381-396, December 1988.
+*
+* This is a thread safe version of DLACON, which uses the array ISAVE
+* in place of a SAVE statement, as follows:
+*
+* DLACON DLACN2
+* JUMP ISAVE(1)
+* J ISAVE(2)
+* ITER ISAVE(3)
+*
+* =====================================================================
+*
+* .. Parameters ..
+ INTEGER ITMAX
+ PARAMETER ( ITMAX = 5 )
+ DOUBLE PRECISION ZERO, ONE, TWO
+ PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, JLAST
+ DOUBLE PRECISION ALTSGN, ESTOLD, TEMP
+* ..
+* .. External Functions ..
+ INTEGER IDAMAX
+ DOUBLE PRECISION DASUM
+ EXTERNAL IDAMAX, DASUM
+* ..
+* .. External Subroutines ..
+ EXTERNAL DCOPY
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, DBLE, NINT, SIGN
+* ..
+* .. Executable Statements ..
+*
+ IF( KASE.EQ.0 ) THEN
+ DO 10 I = 1, N
+ X( I ) = ONE / DBLE( N )
+ 10 CONTINUE
+ KASE = 1
+ ISAVE( 1 ) = 1
+ RETURN
+ END IF
+*
+ GO TO ( 20, 40, 70, 110, 140 )ISAVE( 1 )
+*
+* ................ ENTRY (ISAVE( 1 ) = 1)
+* FIRST ITERATION. X HAS BEEN OVERWRITTEN BY A*X.
+*
+ 20 CONTINUE
+ IF( N.EQ.1 ) THEN
+ V( 1 ) = X( 1 )
+ EST = ABS( V( 1 ) )
+* ... QUIT
+ GO TO 150
+ END IF
+ EST = DASUM( N, X, 1 )
+*
+ DO 30 I = 1, N
+ X( I ) = SIGN( ONE, X( I ) )
+ ISGN( I ) = NINT( X( I ) )
+ 30 CONTINUE
+ KASE = 2
+ ISAVE( 1 ) = 2
+ RETURN
+*
+* ................ ENTRY (ISAVE( 1 ) = 2)
+* FIRST ITERATION. X HAS BEEN OVERWRITTEN BY TRANSPOSE(A)*X.
+*
+ 40 CONTINUE
+ ISAVE( 2 ) = IDAMAX( N, X, 1 )
+ ISAVE( 3 ) = 2
+*
+* MAIN LOOP - ITERATIONS 2,3,...,ITMAX.
+*
+ 50 CONTINUE
+ DO 60 I = 1, N
+ X( I ) = ZERO
+ 60 CONTINUE
+ X( ISAVE( 2 ) ) = ONE
+ KASE = 1
+ ISAVE( 1 ) = 3
+ RETURN
+*
+* ................ ENTRY (ISAVE( 1 ) = 3)
+* X HAS BEEN OVERWRITTEN BY A*X.
+*
+ 70 CONTINUE
+ CALL DCOPY( N, X, 1, V, 1 )
+ ESTOLD = EST
+ EST = DASUM( N, V, 1 )
+ DO 80 I = 1, N
+ IF( NINT( SIGN( ONE, X( I ) ) ).NE.ISGN( I ) )
+ $ GO TO 90
+ 80 CONTINUE
+* REPEATED SIGN VECTOR DETECTED, HENCE ALGORITHM HAS CONVERGED.
+ GO TO 120
+*
+ 90 CONTINUE
+* TEST FOR CYCLING.
+ IF( EST.LE.ESTOLD )
+ $ GO TO 120
+*
+ DO 100 I = 1, N
+ X( I ) = SIGN( ONE, X( I ) )
+ ISGN( I ) = NINT( X( I ) )
+ 100 CONTINUE
+ KASE = 2
+ ISAVE( 1 ) = 4
+ RETURN
+*
+* ................ ENTRY (ISAVE( 1 ) = 4)
+* X HAS BEEN OVERWRITTEN BY TRANSPOSE(A)*X.
+*
+ 110 CONTINUE
+ JLAST = ISAVE( 2 )
+ ISAVE( 2 ) = IDAMAX( N, X, 1 )
+ IF( ( X( JLAST ).NE.ABS( X( ISAVE( 2 ) ) ) ) .AND.
+ $ ( ISAVE( 3 ).LT.ITMAX ) ) THEN
+ ISAVE( 3 ) = ISAVE( 3 ) + 1
+ GO TO 50
+ END IF
+*
+* ITERATION COMPLETE. FINAL STAGE.
+*
+ 120 CONTINUE
+ ALTSGN = ONE
+ DO 130 I = 1, N
+ X( I ) = ALTSGN*( ONE+DBLE( I-1 ) / DBLE( N-1 ) )
+ ALTSGN = -ALTSGN
+ 130 CONTINUE
+ KASE = 1
+ ISAVE( 1 ) = 5
+ RETURN
+*
+* ................ ENTRY (ISAVE( 1 ) = 5)
+* X HAS BEEN OVERWRITTEN BY A*X.
+*
+ 140 CONTINUE
+ TEMP = TWO*( DASUM( N, X, 1 ) / DBLE( 3*N ) )
+ IF( TEMP.GT.EST ) THEN
+ CALL DCOPY( N, X, 1, V, 1 )
+ EST = TEMP
+ END IF
+*
+ 150 CONTINUE
+ KASE = 0
+ RETURN
+*
+* End of DLACN2
+*
+ END
+ SUBROUTINE DLACON( N, V, X, ISGN, EST, KASE )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER KASE, N
+ DOUBLE PRECISION EST
+* ..
+* .. Array Arguments ..
+ INTEGER ISGN( * )
+ DOUBLE PRECISION V( * ), X( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DLACON estimates the 1-norm of a square, real matrix A.
+* Reverse communication is used for evaluating matrix-vector products.
+*
+* Arguments
+* =========
+*
+* N (input) INTEGER
+* The order of the matrix. N >= 1.
+*
+* V (workspace) DOUBLE PRECISION array, dimension (N)
+* On the final return, V = A*W, where EST = norm(V)/norm(W)
+* (W is not returned).
+*
+* X (input/output) DOUBLE PRECISION array, dimension (N)
+* On an intermediate return, X should be overwritten by
+* A * X, if KASE=1,
+* A' * X, if KASE=2,
+* and DLACON must be re-called with all the other parameters
+* unchanged.
+*
+* ISGN (workspace) INTEGER array, dimension (N)
+*
+* EST (input/output) DOUBLE PRECISION
+* On entry with KASE = 1 or 2 and JUMP = 3, EST should be
+* unchanged from the previous call to DLACON.
+* On exit, EST is an estimate (a lower bound) for norm(A).
+*
+* KASE (input/output) INTEGER
+* On the initial call to DLACON, KASE should be 0.
+* On an intermediate return, KASE will be 1 or 2, indicating
+* whether X should be overwritten by A * X or A' * X.
+* On the final return from DLACON, KASE will again be 0.
+*
+* Further Details
+* ======= =======
+*
+* Contributed by Nick Higham, University of Manchester.
+* Originally named SONEST, dated March 16, 1988.
+*
+* Reference: N.J. Higham, "FORTRAN codes for estimating the one-norm of
+* a real or complex matrix, with applications to condition estimation",
+* ACM Trans. Math. Soft., vol. 14, no. 4, pp. 381-396, December 1988.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ INTEGER ITMAX
+ PARAMETER ( ITMAX = 5 )
+ DOUBLE PRECISION ZERO, ONE, TWO
+ PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, ITER, J, JLAST, JUMP
+ DOUBLE PRECISION ALTSGN, ESTOLD, TEMP
+* ..
+* .. External Functions ..
+ INTEGER IDAMAX
+ DOUBLE PRECISION DASUM
+ EXTERNAL IDAMAX, DASUM
+* ..
+* .. External Subroutines ..
+ EXTERNAL DCOPY
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, DBLE, NINT, SIGN
+* ..
+* .. Save statement ..
+ SAVE
+* ..
+* .. Executable Statements ..
+*
+ IF( KASE.EQ.0 ) THEN
+ DO 10 I = 1, N
+ X( I ) = ONE / DBLE( N )
+ 10 CONTINUE
+ KASE = 1
+ JUMP = 1
+ RETURN
+ END IF
+*
+ GO TO ( 20, 40, 70, 110, 140 )JUMP
+*
+* ................ ENTRY (JUMP = 1)
+* FIRST ITERATION. X HAS BEEN OVERWRITTEN BY A*X.
+*
+ 20 CONTINUE
+ IF( N.EQ.1 ) THEN
+ V( 1 ) = X( 1 )
+ EST = ABS( V( 1 ) )
+* ... QUIT
+ GO TO 150
+ END IF
+ EST = DASUM( N, X, 1 )
+*
+ DO 30 I = 1, N
+ X( I ) = SIGN( ONE, X( I ) )
+ ISGN( I ) = NINT( X( I ) )
+ 30 CONTINUE
+ KASE = 2
+ JUMP = 2
+ RETURN
+*
+* ................ ENTRY (JUMP = 2)
+* FIRST ITERATION. X HAS BEEN OVERWRITTEN BY TRANSPOSE(A)*X.
+*
+ 40 CONTINUE
+ J = IDAMAX( N, X, 1 )
+ ITER = 2
+*
+* MAIN LOOP - ITERATIONS 2,3,...,ITMAX.
+*
+ 50 CONTINUE
+ DO 60 I = 1, N
+ X( I ) = ZERO
+ 60 CONTINUE
+ X( J ) = ONE
+ KASE = 1
+ JUMP = 3
+ RETURN
+*
+* ................ ENTRY (JUMP = 3)
+* X HAS BEEN OVERWRITTEN BY A*X.
+*
+ 70 CONTINUE
+ CALL DCOPY( N, X, 1, V, 1 )
+ ESTOLD = EST
+ EST = DASUM( N, V, 1 )
+ DO 80 I = 1, N
+ IF( NINT( SIGN( ONE, X( I ) ) ).NE.ISGN( I ) )
+ $ GO TO 90
+ 80 CONTINUE
+* REPEATED SIGN VECTOR DETECTED, HENCE ALGORITHM HAS CONVERGED.
+ GO TO 120
+*
+ 90 CONTINUE
+* TEST FOR CYCLING.
+ IF( EST.LE.ESTOLD )
+ $ GO TO 120
+*
+ DO 100 I = 1, N
+ X( I ) = SIGN( ONE, X( I ) )
+ ISGN( I ) = NINT( X( I ) )
+ 100 CONTINUE
+ KASE = 2
+ JUMP = 4
+ RETURN
+*
+* ................ ENTRY (JUMP = 4)
+* X HAS BEEN OVERWRITTEN BY TRANSPOSE(A)*X.
+*
+ 110 CONTINUE
+ JLAST = J
+ J = IDAMAX( N, X, 1 )
+ IF( ( X( JLAST ).NE.ABS( X( J ) ) ) .AND. ( ITER.LT.ITMAX ) ) THEN
+ ITER = ITER + 1
+ GO TO 50
+ END IF
+*
+* ITERATION COMPLETE. FINAL STAGE.
+*
+ 120 CONTINUE
+ ALTSGN = ONE
+ DO 130 I = 1, N
+ X( I ) = ALTSGN*( ONE+DBLE( I-1 ) / DBLE( N-1 ) )
+ ALTSGN = -ALTSGN
+ 130 CONTINUE
+ KASE = 1
+ JUMP = 5
+ RETURN
+*
+* ................ ENTRY (JUMP = 5)
+* X HAS BEEN OVERWRITTEN BY A*X.
+*
+ 140 CONTINUE
+ TEMP = TWO*( DASUM( N, X, 1 ) / DBLE( 3*N ) )
+ IF( TEMP.GT.EST ) THEN
+ CALL DCOPY( N, X, 1, V, 1 )
+ EST = TEMP
+ END IF
+*
+ 150 CONTINUE
+ KASE = 0
+ RETURN
+*
+* End of DLACON
+*
+ END
+ SUBROUTINE DLACPY( UPLO, M, N, A, LDA, B, LDB )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER LDA, LDB, M, N
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION A( LDA, * ), B( LDB, * )
+* ..
+*
+* Purpose
+* =======
+*
+* DLACPY copies all or part of a two-dimensional matrix A to another
+* matrix B.
+*
+* Arguments
+* =========
+*
+* UPLO (input) CHARACTER*1
+* Specifies the part of the matrix A to be copied to B.
+* = 'U': Upper triangular part
+* = 'L': Lower triangular part
+* Otherwise: All of the matrix A
+*
+* M (input) INTEGER
+* The number of rows of the matrix A. M >= 0.
+*
+* N (input) INTEGER
+* The number of columns of the matrix A. N >= 0.
+*
+* A (input) DOUBLE PRECISION array, dimension (LDA,N)
+* The m by n matrix A. If UPLO = 'U', only the upper triangle
+* or trapezoid is accessed; if UPLO = 'L', only the lower
+* triangle or trapezoid is accessed.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,M).
+*
+* B (output) DOUBLE PRECISION array, dimension (LDB,N)
+* On exit, B = A in the locations specified by UPLO.
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. LDB >= max(1,M).
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ INTEGER I, J
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MIN
+* ..
+* .. Executable Statements ..
+*
+ IF( LSAME( UPLO, 'U' ) ) THEN
+ DO 20 J = 1, N
+ DO 10 I = 1, MIN( J, M )
+ B( I, J ) = A( I, J )
+ 10 CONTINUE
+ 20 CONTINUE
+ ELSE IF( LSAME( UPLO, 'L' ) ) THEN
+ DO 40 J = 1, N
+ DO 30 I = J, M
+ B( I, J ) = A( I, J )
+ 30 CONTINUE
+ 40 CONTINUE
+ ELSE
+ DO 60 J = 1, N
+ DO 50 I = 1, M
+ B( I, J ) = A( I, J )
+ 50 CONTINUE
+ 60 CONTINUE
+ END IF
+ RETURN
+*
+* End of DLACPY
+*
+ END
+ SUBROUTINE DLADIV( A, B, C, D, P, Q )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ DOUBLE PRECISION A, B, C, D, P, Q
+* ..
+*
+* Purpose
+* =======
+*
+* DLADIV performs complex division in real arithmetic
+*
+* a + i*b
+* p + i*q = ---------
+* c + i*d
+*
+* The algorithm is due to Robert L. Smith and can be found
+* in D. Knuth, The art of Computer Programming, Vol.2, p.195
+*
+* Arguments
+* =========
+*
+* A (input) DOUBLE PRECISION
+* B (input) DOUBLE PRECISION
+* C (input) DOUBLE PRECISION
+* D (input) DOUBLE PRECISION
+* The scalars a, b, c, and d in the above expression.
+*
+* P (output) DOUBLE PRECISION
+* Q (output) DOUBLE PRECISION
+* The scalars p and q in the above expression.
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ DOUBLE PRECISION E, F
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS
+* ..
+* .. Executable Statements ..
+*
+ IF( ABS( D ).LT.ABS( C ) ) THEN
+ E = D / C
+ F = C + D*E
+ P = ( A+B*E ) / F
+ Q = ( B-A*E ) / F
+ ELSE
+ E = C / D
+ F = D + C*E
+ P = ( B+A*E ) / F
+ Q = ( -A+B*E ) / F
+ END IF
+*
+ RETURN
+*
+* End of DLADIV
+*
+ END
+ SUBROUTINE DLAE2( A, B, C, RT1, RT2 )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ DOUBLE PRECISION A, B, C, RT1, RT2
+* ..
+*
+* Purpose
+* =======
+*
+* DLAE2 computes the eigenvalues of a 2-by-2 symmetric matrix
+* [ A B ]
+* [ B C ].
+* On return, RT1 is the eigenvalue of larger absolute value, and RT2
+* is the eigenvalue of smaller absolute value.
+*
+* Arguments
+* =========
+*
+* A (input) DOUBLE PRECISION
+* The (1,1) element of the 2-by-2 matrix.
+*
+* B (input) DOUBLE PRECISION
+* The (1,2) and (2,1) elements of the 2-by-2 matrix.
+*
+* C (input) DOUBLE PRECISION
+* The (2,2) element of the 2-by-2 matrix.
+*
+* RT1 (output) DOUBLE PRECISION
+* The eigenvalue of larger absolute value.
+*
+* RT2 (output) DOUBLE PRECISION
+* The eigenvalue of smaller absolute value.
+*
+* Further Details
+* ===============
+*
+* RT1 is accurate to a few ulps barring over/underflow.
+*
+* RT2 may be inaccurate if there is massive cancellation in the
+* determinant A*C-B*B; higher precision or correctly rounded or
+* correctly truncated arithmetic would be needed to compute RT2
+* accurately in all cases.
+*
+* Overflow is possible only if RT1 is within a factor of 5 of overflow.
+* Underflow is harmless if the input data is 0 or exceeds
+* underflow_threshold / macheps.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE
+ PARAMETER ( ONE = 1.0D0 )
+ DOUBLE PRECISION TWO
+ PARAMETER ( TWO = 2.0D0 )
+ DOUBLE PRECISION ZERO
+ PARAMETER ( ZERO = 0.0D0 )
+ DOUBLE PRECISION HALF
+ PARAMETER ( HALF = 0.5D0 )
+* ..
+* .. Local Scalars ..
+ DOUBLE PRECISION AB, ACMN, ACMX, ADF, DF, RT, SM, TB
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, SQRT
+* ..
+* .. Executable Statements ..
+*
+* Compute the eigenvalues
+*
+ SM = A + C
+ DF = A - C
+ ADF = ABS( DF )
+ TB = B + B
+ AB = ABS( TB )
+ IF( ABS( A ).GT.ABS( C ) ) THEN
+ ACMX = A
+ ACMN = C
+ ELSE
+ ACMX = C
+ ACMN = A
+ END IF
+ IF( ADF.GT.AB ) THEN
+ RT = ADF*SQRT( ONE+( AB / ADF )**2 )
+ ELSE IF( ADF.LT.AB ) THEN
+ RT = AB*SQRT( ONE+( ADF / AB )**2 )
+ ELSE
+*
+* Includes case AB=ADF=0
+*
+ RT = AB*SQRT( TWO )
+ END IF
+ IF( SM.LT.ZERO ) THEN
+ RT1 = HALF*( SM-RT )
+*
+* Order of execution important.
+* To get fully accurate smaller eigenvalue,
+* next line needs to be executed in higher precision.
+*
+ RT2 = ( ACMX / RT1 )*ACMN - ( B / RT1 )*B
+ ELSE IF( SM.GT.ZERO ) THEN
+ RT1 = HALF*( SM+RT )
+*
+* Order of execution important.
+* To get fully accurate smaller eigenvalue,
+* next line needs to be executed in higher precision.
+*
+ RT2 = ( ACMX / RT1 )*ACMN - ( B / RT1 )*B
+ ELSE
+*
+* Includes case RT1 = RT2 = 0
+*
+ RT1 = HALF*RT
+ RT2 = -HALF*RT
+ END IF
+ RETURN
+*
+* End of DLAE2
+*
+ END
+ SUBROUTINE DLAEBZ( IJOB, NITMAX, N, MMAX, MINP, NBMIN, ABSTOL,
+ $ RELTOL, PIVMIN, D, E, E2, NVAL, AB, C, MOUT,
+ $ NAB, WORK, IWORK, INFO )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER IJOB, INFO, MINP, MMAX, MOUT, N, NBMIN, NITMAX
+ DOUBLE PRECISION ABSTOL, PIVMIN, RELTOL
+* ..
+* .. Array Arguments ..
+ INTEGER IWORK( * ), NAB( MMAX, * ), NVAL( * )
+ DOUBLE PRECISION AB( MMAX, * ), C( * ), D( * ), E( * ), E2( * ),
+ $ WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DLAEBZ contains the iteration loops which compute and use the
+* function N(w), which is the count of eigenvalues of a symmetric
+* tridiagonal matrix T less than or equal to its argument w. It
+* performs a choice of two types of loops:
+*
+* IJOB=1, followed by
+* IJOB=2: It takes as input a list of intervals and returns a list of
+* sufficiently small intervals whose union contains the same
+* eigenvalues as the union of the original intervals.
+* The input intervals are (AB(j,1),AB(j,2)], j=1,...,MINP.
+* The output interval (AB(j,1),AB(j,2)] will contain
+* eigenvalues NAB(j,1)+1,...,NAB(j,2), where 1 <= j <= MOUT.
+*
+* IJOB=3: It performs a binary search in each input interval
+* (AB(j,1),AB(j,2)] for a point w(j) such that
+* N(w(j))=NVAL(j), and uses C(j) as the starting point of
+* the search. If such a w(j) is found, then on output
+* AB(j,1)=AB(j,2)=w. If no such w(j) is found, then on output
+* (AB(j,1),AB(j,2)] will be a small interval containing the
+* point where N(w) jumps through NVAL(j), unless that point
+* lies outside the initial interval.
+*
+* Note that the intervals are in all cases half-open intervals,
+* i.e., of the form (a,b] , which includes b but not a .
+*
+* To avoid underflow, the matrix should be scaled so that its largest
+* element is no greater than overflow**(1/2) * underflow**(1/4)
+* in absolute value. To assure the most accurate computation
+* of small eigenvalues, the matrix should be scaled to be
+* not much smaller than that, either.
+*
+* See W. Kahan "Accurate Eigenvalues of a Symmetric Tridiagonal
+* Matrix", Report CS41, Computer Science Dept., Stanford
+* University, July 21, 1966
+*
+* Note: the arguments are, in general, *not* checked for unreasonable
+* values.
+*
+* Arguments
+* =========
+*
+* IJOB (input) INTEGER
+* Specifies what is to be done:
+* = 1: Compute NAB for the initial intervals.
+* = 2: Perform bisection iteration to find eigenvalues of T.
+* = 3: Perform bisection iteration to invert N(w), i.e.,
+* to find a point which has a specified number of
+* eigenvalues of T to its left.
+* Other values will cause DLAEBZ to return with INFO=-1.
+*
+* NITMAX (input) INTEGER
+* The maximum number of "levels" of bisection to be
+* performed, i.e., an interval of width W will not be made
+* smaller than 2^(-NITMAX) * W. If not all intervals
+* have converged after NITMAX iterations, then INFO is set
+* to the number of non-converged intervals.
+*
+* N (input) INTEGER
+* The dimension n of the tridiagonal matrix T. It must be at
+* least 1.
+*
+* MMAX (input) INTEGER
+* The maximum number of intervals. If more than MMAX intervals
+* are generated, then DLAEBZ will quit with INFO=MMAX+1.
+*
+* MINP (input) INTEGER
+* The initial number of intervals. It may not be greater than
+* MMAX.
+*
+* NBMIN (input) INTEGER
+* The smallest number of intervals that should be processed
+* using a vector loop. If zero, then only the scalar loop
+* will be used.
+*
+* ABSTOL (input) DOUBLE PRECISION
+* The minimum (absolute) width of an interval. When an
+* interval is narrower than ABSTOL, or than RELTOL times the
+* larger (in magnitude) endpoint, then it is considered to be
+* sufficiently small, i.e., converged. This must be at least
+* zero.
+*
+* RELTOL (input) DOUBLE PRECISION
+* The minimum relative width of an interval. When an interval
+* is narrower than ABSTOL, or than RELTOL times the larger (in
+* magnitude) endpoint, then it is considered to be
+* sufficiently small, i.e., converged. Note: this should
+* always be at least radix*machine epsilon.
+*
+* PIVMIN (input) DOUBLE PRECISION
+* The minimum absolute value of a "pivot" in the Sturm
+* sequence loop. This *must* be at least max |e(j)**2| *
+* safe_min and at least safe_min, where safe_min is at least
+* the smallest number that can divide one without overflow.
+*
+* D (input) DOUBLE PRECISION array, dimension (N)
+* The diagonal elements of the tridiagonal matrix T.
+*
+* E (input) DOUBLE PRECISION array, dimension (N)
+* The offdiagonal elements of the tridiagonal matrix T in
+* positions 1 through N-1. E(N) is arbitrary.
+*
+* E2 (input) DOUBLE PRECISION array, dimension (N)
+* The squares of the offdiagonal elements of the tridiagonal
+* matrix T. E2(N) is ignored.
+*
+* NVAL (input/output) INTEGER array, dimension (MINP)
+* If IJOB=1 or 2, not referenced.
+* If IJOB=3, the desired values of N(w). The elements of NVAL
+* will be reordered to correspond with the intervals in AB.
+* Thus, NVAL(j) on output will not, in general be the same as
+* NVAL(j) on input, but it will correspond with the interval
+* (AB(j,1),AB(j,2)] on output.
+*
+* AB (input/output) DOUBLE PRECISION array, dimension (MMAX,2)
+* The endpoints of the intervals. AB(j,1) is a(j), the left
+* endpoint of the j-th interval, and AB(j,2) is b(j), the
+* right endpoint of the j-th interval. The input intervals
+* will, in general, be modified, split, and reordered by the
+* calculation.
+*
+* C (input/output) DOUBLE PRECISION array, dimension (MMAX)
+* If IJOB=1, ignored.
+* If IJOB=2, workspace.
+* If IJOB=3, then on input C(j) should be initialized to the
+* first search point in the binary search.
+*
+* MOUT (output) INTEGER
+* If IJOB=1, the number of eigenvalues in the intervals.
+* If IJOB=2 or 3, the number of intervals output.
+* If IJOB=3, MOUT will equal MINP.
+*
+* NAB (input/output) INTEGER array, dimension (MMAX,2)
+* If IJOB=1, then on output NAB(i,j) will be set to N(AB(i,j)).
+* If IJOB=2, then on input, NAB(i,j) should be set. It must
+* satisfy the condition:
+* N(AB(i,1)) <= NAB(i,1) <= NAB(i,2) <= N(AB(i,2)),
+* which means that in interval i only eigenvalues
+* NAB(i,1)+1,...,NAB(i,2) will be considered. Usually,
+* NAB(i,j)=N(AB(i,j)), from a previous call to DLAEBZ with
+* IJOB=1.
+* On output, NAB(i,j) will contain
+* max(na(k),min(nb(k),N(AB(i,j)))), where k is the index of
+* the input interval that the output interval
+* (AB(j,1),AB(j,2)] came from, and na(k) and nb(k) are the
+* the input values of NAB(k,1) and NAB(k,2).
+* If IJOB=3, then on output, NAB(i,j) contains N(AB(i,j)),
+* unless N(w) > NVAL(i) for all search points w , in which
+* case NAB(i,1) will not be modified, i.e., the output
+* value will be the same as the input value (modulo
+* reorderings -- see NVAL and AB), or unless N(w) < NVAL(i)
+* for all search points w , in which case NAB(i,2) will
+* not be modified. Normally, NAB should be set to some
+* distinctive value(s) before DLAEBZ is called.
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (MMAX)
+* Workspace.
+*
+* IWORK (workspace) INTEGER array, dimension (MMAX)
+* Workspace.
+*
+* INFO (output) INTEGER
+* = 0: All intervals converged.
+* = 1--MMAX: The last INFO intervals did not converge.
+* = MMAX+1: More than MMAX intervals were generated.
+*
+* Further Details
+* ===============
+*
+* This routine is intended to be called only by other LAPACK
+* routines, thus the interface is less user-friendly. It is intended
+* for two purposes:
+*
+* (a) finding eigenvalues. In this case, DLAEBZ should have one or
+* more initial intervals set up in AB, and DLAEBZ should be called
+* with IJOB=1. This sets up NAB, and also counts the eigenvalues.
+* Intervals with no eigenvalues would usually be thrown out at
+* this point. Also, if not all the eigenvalues in an interval i
+* are desired, NAB(i,1) can be increased or NAB(i,2) decreased.
+* For example, set NAB(i,1)=NAB(i,2)-1 to get the largest
+* eigenvalue. DLAEBZ is then called with IJOB=2 and MMAX
+* no smaller than the value of MOUT returned by the call with
+* IJOB=1. After this (IJOB=2) call, eigenvalues NAB(i,1)+1
+* through NAB(i,2) are approximately AB(i,1) (or AB(i,2)) to the
+* tolerance specified by ABSTOL and RELTOL.
+*
+* (b) finding an interval (a',b'] containing eigenvalues w(f),...,w(l).
+* In this case, start with a Gershgorin interval (a,b). Set up
+* AB to contain 2 search intervals, both initially (a,b). One
+* NVAL element should contain f-1 and the other should contain l
+* , while C should contain a and b, resp. NAB(i,1) should be -1
+* and NAB(i,2) should be N+1, to flag an error if the desired
+* interval does not lie in (a,b). DLAEBZ is then called with
+* IJOB=3. On exit, if w(f-1) < w(f), then one of the intervals --
+* j -- will have AB(j,1)=AB(j,2) and NAB(j,1)=NAB(j,2)=f-1, while
+* if, to the specified tolerance, w(f-k)=...=w(f+r), k > 0 and r
+* >= 0, then the interval will have N(AB(j,1))=NAB(j,1)=f-k and
+* N(AB(j,2))=NAB(j,2)=f+r. The cases w(l) < w(l+1) and
+* w(l-r)=...=w(l+k) are handled similarly.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, TWO, HALF
+ PARAMETER ( ZERO = 0.0D0, TWO = 2.0D0,
+ $ HALF = 1.0D0 / TWO )
+* ..
+* .. Local Scalars ..
+ INTEGER ITMP1, ITMP2, J, JI, JIT, JP, KF, KFNEW, KL,
+ $ KLNEW
+ DOUBLE PRECISION TMP1, TMP2
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+* Check for Errors
+*
+ INFO = 0
+ IF( IJOB.LT.1 .OR. IJOB.GT.3 ) THEN
+ INFO = -1
+ RETURN
+ END IF
+*
+* Initialize NAB
+*
+ IF( IJOB.EQ.1 ) THEN
+*
+* Compute the number of eigenvalues in the initial intervals.
+*
+ MOUT = 0
+*DIR$ NOVECTOR
+ DO 30 JI = 1, MINP
+ DO 20 JP = 1, 2
+ TMP1 = D( 1 ) - AB( JI, JP )
+ IF( ABS( TMP1 ).LT.PIVMIN )
+ $ TMP1 = -PIVMIN
+ NAB( JI, JP ) = 0
+ IF( TMP1.LE.ZERO )
+ $ NAB( JI, JP ) = 1
+*
+ DO 10 J = 2, N
+ TMP1 = D( J ) - E2( J-1 ) / TMP1 - AB( JI, JP )
+ IF( ABS( TMP1 ).LT.PIVMIN )
+ $ TMP1 = -PIVMIN
+ IF( TMP1.LE.ZERO )
+ $ NAB( JI, JP ) = NAB( JI, JP ) + 1
+ 10 CONTINUE
+ 20 CONTINUE
+ MOUT = MOUT + NAB( JI, 2 ) - NAB( JI, 1 )
+ 30 CONTINUE
+ RETURN
+ END IF
+*
+* Initialize for loop
+*
+* KF and KL have the following meaning:
+* Intervals 1,...,KF-1 have converged.
+* Intervals KF,...,KL still need to be refined.
+*
+ KF = 1
+ KL = MINP
+*
+* If IJOB=2, initialize C.
+* If IJOB=3, use the user-supplied starting point.
+*
+ IF( IJOB.EQ.2 ) THEN
+ DO 40 JI = 1, MINP
+ C( JI ) = HALF*( AB( JI, 1 )+AB( JI, 2 ) )
+ 40 CONTINUE
+ END IF
+*
+* Iteration loop
+*
+ DO 130 JIT = 1, NITMAX
+*
+* Loop over intervals
+*
+ IF( KL-KF+1.GE.NBMIN .AND. NBMIN.GT.0 ) THEN
+*
+* Begin of Parallel Version of the loop
+*
+ DO 60 JI = KF, KL
+*
+* Compute N(c), the number of eigenvalues less than c
+*
+ WORK( JI ) = D( 1 ) - C( JI )
+ IWORK( JI ) = 0
+ IF( WORK( JI ).LE.PIVMIN ) THEN
+ IWORK( JI ) = 1
+ WORK( JI ) = MIN( WORK( JI ), -PIVMIN )
+ END IF
+*
+ DO 50 J = 2, N
+ WORK( JI ) = D( J ) - E2( J-1 ) / WORK( JI ) - C( JI )
+ IF( WORK( JI ).LE.PIVMIN ) THEN
+ IWORK( JI ) = IWORK( JI ) + 1
+ WORK( JI ) = MIN( WORK( JI ), -PIVMIN )
+ END IF
+ 50 CONTINUE
+ 60 CONTINUE
+*
+ IF( IJOB.LE.2 ) THEN
+*
+* IJOB=2: Choose all intervals containing eigenvalues.
+*
+ KLNEW = KL
+ DO 70 JI = KF, KL
+*
+* Insure that N(w) is monotone
+*
+ IWORK( JI ) = MIN( NAB( JI, 2 ),
+ $ MAX( NAB( JI, 1 ), IWORK( JI ) ) )
+*
+* Update the Queue -- add intervals if both halves
+* contain eigenvalues.
+*
+ IF( IWORK( JI ).EQ.NAB( JI, 2 ) ) THEN
+*
+* No eigenvalue in the upper interval:
+* just use the lower interval.
+*
+ AB( JI, 2 ) = C( JI )
+*
+ ELSE IF( IWORK( JI ).EQ.NAB( JI, 1 ) ) THEN
+*
+* No eigenvalue in the lower interval:
+* just use the upper interval.
+*
+ AB( JI, 1 ) = C( JI )
+ ELSE
+ KLNEW = KLNEW + 1
+ IF( KLNEW.LE.MMAX ) THEN
+*
+* Eigenvalue in both intervals -- add upper to
+* queue.
+*
+ AB( KLNEW, 2 ) = AB( JI, 2 )
+ NAB( KLNEW, 2 ) = NAB( JI, 2 )
+ AB( KLNEW, 1 ) = C( JI )
+ NAB( KLNEW, 1 ) = IWORK( JI )
+ AB( JI, 2 ) = C( JI )
+ NAB( JI, 2 ) = IWORK( JI )
+ ELSE
+ INFO = MMAX + 1
+ END IF
+ END IF
+ 70 CONTINUE
+ IF( INFO.NE.0 )
+ $ RETURN
+ KL = KLNEW
+ ELSE
+*
+* IJOB=3: Binary search. Keep only the interval containing
+* w s.t. N(w) = NVAL
+*
+ DO 80 JI = KF, KL
+ IF( IWORK( JI ).LE.NVAL( JI ) ) THEN
+ AB( JI, 1 ) = C( JI )
+ NAB( JI, 1 ) = IWORK( JI )
+ END IF
+ IF( IWORK( JI ).GE.NVAL( JI ) ) THEN
+ AB( JI, 2 ) = C( JI )
+ NAB( JI, 2 ) = IWORK( JI )
+ END IF
+ 80 CONTINUE
+ END IF
+*
+ ELSE
+*
+* End of Parallel Version of the loop
+*
+* Begin of Serial Version of the loop
+*
+ KLNEW = KL
+ DO 100 JI = KF, KL
+*
+* Compute N(w), the number of eigenvalues less than w
+*
+ TMP1 = C( JI )
+ TMP2 = D( 1 ) - TMP1
+ ITMP1 = 0
+ IF( TMP2.LE.PIVMIN ) THEN
+ ITMP1 = 1
+ TMP2 = MIN( TMP2, -PIVMIN )
+ END IF
+*
+* A series of compiler directives to defeat vectorization
+* for the next loop
+*
+*$PL$ CMCHAR=' '
+CDIR$ NEXTSCALAR
+C$DIR SCALAR
+CDIR$ NEXT SCALAR
+CVD$L NOVECTOR
+CDEC$ NOVECTOR
+CVD$ NOVECTOR
+*VDIR NOVECTOR
+*VOCL LOOP,SCALAR
+CIBM PREFER SCALAR
+*$PL$ CMCHAR='*'
+*
+ DO 90 J = 2, N
+ TMP2 = D( J ) - E2( J-1 ) / TMP2 - TMP1
+ IF( TMP2.LE.PIVMIN ) THEN
+ ITMP1 = ITMP1 + 1
+ TMP2 = MIN( TMP2, -PIVMIN )
+ END IF
+ 90 CONTINUE
+*
+ IF( IJOB.LE.2 ) THEN
+*
+* IJOB=2: Choose all intervals containing eigenvalues.
+*
+* Insure that N(w) is monotone
+*
+ ITMP1 = MIN( NAB( JI, 2 ),
+ $ MAX( NAB( JI, 1 ), ITMP1 ) )
+*
+* Update the Queue -- add intervals if both halves
+* contain eigenvalues.
+*
+ IF( ITMP1.EQ.NAB( JI, 2 ) ) THEN
+*
+* No eigenvalue in the upper interval:
+* just use the lower interval.
+*
+ AB( JI, 2 ) = TMP1
+*
+ ELSE IF( ITMP1.EQ.NAB( JI, 1 ) ) THEN
+*
+* No eigenvalue in the lower interval:
+* just use the upper interval.
+*
+ AB( JI, 1 ) = TMP1
+ ELSE IF( KLNEW.LT.MMAX ) THEN
+*
+* Eigenvalue in both intervals -- add upper to queue.
+*
+ KLNEW = KLNEW + 1
+ AB( KLNEW, 2 ) = AB( JI, 2 )
+ NAB( KLNEW, 2 ) = NAB( JI, 2 )
+ AB( KLNEW, 1 ) = TMP1
+ NAB( KLNEW, 1 ) = ITMP1
+ AB( JI, 2 ) = TMP1
+ NAB( JI, 2 ) = ITMP1
+ ELSE
+ INFO = MMAX + 1
+ RETURN
+ END IF
+ ELSE
+*
+* IJOB=3: Binary search. Keep only the interval
+* containing w s.t. N(w) = NVAL
+*
+ IF( ITMP1.LE.NVAL( JI ) ) THEN
+ AB( JI, 1 ) = TMP1
+ NAB( JI, 1 ) = ITMP1
+ END IF
+ IF( ITMP1.GE.NVAL( JI ) ) THEN
+ AB( JI, 2 ) = TMP1
+ NAB( JI, 2 ) = ITMP1
+ END IF
+ END IF
+ 100 CONTINUE
+ KL = KLNEW
+*
+* End of Serial Version of the loop
+*
+ END IF
+*
+* Check for convergence
+*
+ KFNEW = KF
+ DO 110 JI = KF, KL
+ TMP1 = ABS( AB( JI, 2 )-AB( JI, 1 ) )
+ TMP2 = MAX( ABS( AB( JI, 2 ) ), ABS( AB( JI, 1 ) ) )
+ IF( TMP1.LT.MAX( ABSTOL, PIVMIN, RELTOL*TMP2 ) .OR.
+ $ NAB( JI, 1 ).GE.NAB( JI, 2 ) ) THEN
+*
+* Converged -- Swap with position KFNEW,
+* then increment KFNEW
+*
+ IF( JI.GT.KFNEW ) THEN
+ TMP1 = AB( JI, 1 )
+ TMP2 = AB( JI, 2 )
+ ITMP1 = NAB( JI, 1 )
+ ITMP2 = NAB( JI, 2 )
+ AB( JI, 1 ) = AB( KFNEW, 1 )
+ AB( JI, 2 ) = AB( KFNEW, 2 )
+ NAB( JI, 1 ) = NAB( KFNEW, 1 )
+ NAB( JI, 2 ) = NAB( KFNEW, 2 )
+ AB( KFNEW, 1 ) = TMP1
+ AB( KFNEW, 2 ) = TMP2
+ NAB( KFNEW, 1 ) = ITMP1
+ NAB( KFNEW, 2 ) = ITMP2
+ IF( IJOB.EQ.3 ) THEN
+ ITMP1 = NVAL( JI )
+ NVAL( JI ) = NVAL( KFNEW )
+ NVAL( KFNEW ) = ITMP1
+ END IF
+ END IF
+ KFNEW = KFNEW + 1
+ END IF
+ 110 CONTINUE
+ KF = KFNEW
+*
+* Choose Midpoints
+*
+ DO 120 JI = KF, KL
+ C( JI ) = HALF*( AB( JI, 1 )+AB( JI, 2 ) )
+ 120 CONTINUE
+*
+* If no more intervals to refine, quit.
+*
+ IF( KF.GT.KL )
+ $ GO TO 140
+ 130 CONTINUE
+*
+* Converged
+*
+ 140 CONTINUE
+ INFO = MAX( KL+1-KF, 0 )
+ MOUT = KL
+*
+ RETURN
+*
+* End of DLAEBZ
+*
+ END
+ SUBROUTINE DLAED0( ICOMPQ, QSIZ, N, D, E, Q, LDQ, QSTORE, LDQS,
+ $ WORK, IWORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER ICOMPQ, INFO, LDQ, LDQS, N, QSIZ
+* ..
+* .. Array Arguments ..
+ INTEGER IWORK( * )
+ DOUBLE PRECISION D( * ), E( * ), Q( LDQ, * ), QSTORE( LDQS, * ),
+ $ WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DLAED0 computes all eigenvalues and corresponding eigenvectors of a
+* symmetric tridiagonal matrix using the divide and conquer method.
+*
+* Arguments
+* =========
+*
+* ICOMPQ (input) INTEGER
+* = 0: Compute eigenvalues only.
+* = 1: Compute eigenvectors of original dense symmetric matrix
+* also. On entry, Q contains the orthogonal matrix used
+* to reduce the original matrix to tridiagonal form.
+* = 2: Compute eigenvalues and eigenvectors of tridiagonal
+* matrix.
+*
+* QSIZ (input) INTEGER
+* The dimension of the orthogonal matrix used to reduce
+* the full matrix to tridiagonal form. QSIZ >= N if ICOMPQ = 1.
+*
+* N (input) INTEGER
+* The dimension of the symmetric tridiagonal matrix. N >= 0.
+*
+* D (input/output) DOUBLE PRECISION array, dimension (N)
+* On entry, the main diagonal of the tridiagonal matrix.
+* On exit, its eigenvalues.
+*
+* E (input) DOUBLE PRECISION array, dimension (N-1)
+* The off-diagonal elements of the tridiagonal matrix.
+* On exit, E has been destroyed.
+*
+* Q (input/output) DOUBLE PRECISION array, dimension (LDQ, N)
+* On entry, Q must contain an N-by-N orthogonal matrix.
+* If ICOMPQ = 0 Q is not referenced.
+* If ICOMPQ = 1 On entry, Q is a subset of the columns of the
+* orthogonal matrix used to reduce the full
+* matrix to tridiagonal form corresponding to
+* the subset of the full matrix which is being
+* decomposed at this time.
+* If ICOMPQ = 2 On entry, Q will be the identity matrix.
+* On exit, Q contains the eigenvectors of the
+* tridiagonal matrix.
+*
+* LDQ (input) INTEGER
+* The leading dimension of the array Q. If eigenvectors are
+* desired, then LDQ >= max(1,N). In any case, LDQ >= 1.
+*
+* QSTORE (workspace) DOUBLE PRECISION array, dimension (LDQS, N)
+* Referenced only when ICOMPQ = 1. Used to store parts of
+* the eigenvector matrix when the updating matrix multiplies
+* take place.
+*
+* LDQS (input) INTEGER
+* The leading dimension of the array QSTORE. If ICOMPQ = 1,
+* then LDQS >= max(1,N). In any case, LDQS >= 1.
+*
+* WORK (workspace) DOUBLE PRECISION array,
+* If ICOMPQ = 0 or 1, the dimension of WORK must be at least
+* 1 + 3*N + 2*N*lg N + 2*N**2
+* ( lg( N ) = smallest integer k
+* such that 2^k >= N )
+* If ICOMPQ = 2, the dimension of WORK must be at least
+* 4*N + N**2.
+*
+* IWORK (workspace) INTEGER array,
+* If ICOMPQ = 0 or 1, the dimension of IWORK must be at least
+* 6 + 6*N + 5*N*lg N.
+* ( lg( N ) = smallest integer k
+* such that 2^k >= N )
+* If ICOMPQ = 2, the dimension of IWORK must be at least
+* 3 + 5*N.
+*
+* INFO (output) INTEGER
+* = 0: successful exit.
+* < 0: if INFO = -i, the i-th argument had an illegal value.
+* > 0: The algorithm failed to compute an eigenvalue while
+* working on the submatrix lying in rows and columns
+* INFO/(N+1) through mod(INFO,N+1).
+*
+* Further Details
+* ===============
+*
+* Based on contributions by
+* Jeff Rutter, Computer Science Division, University of California
+* at Berkeley, USA
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE, TWO
+ PARAMETER ( ZERO = 0.D0, ONE = 1.D0, TWO = 2.D0 )
+* ..
+* .. Local Scalars ..
+ INTEGER CURLVL, CURPRB, CURR, I, IGIVCL, IGIVNM,
+ $ IGIVPT, INDXQ, IPERM, IPRMPT, IQ, IQPTR, IWREM,
+ $ J, K, LGN, MATSIZ, MSD2, SMLSIZ, SMM1, SPM1,
+ $ SPM2, SUBMAT, SUBPBS, TLVLS
+ DOUBLE PRECISION TEMP
+* ..
+* .. External Subroutines ..
+ EXTERNAL DCOPY, DGEMM, DLACPY, DLAED1, DLAED7, DSTEQR,
+ $ XERBLA
+* ..
+* .. External Functions ..
+ INTEGER ILAENV
+ EXTERNAL ILAENV
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, DBLE, INT, LOG, MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+*
+ IF( ICOMPQ.LT.0 .OR. ICOMPQ.GT.2 ) THEN
+ INFO = -1
+ ELSE IF( ( ICOMPQ.EQ.1 ) .AND. ( QSIZ.LT.MAX( 0, N ) ) ) THEN
+ INFO = -2
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN
+ INFO = -7
+ ELSE IF( LDQS.LT.MAX( 1, N ) ) THEN
+ INFO = -9
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DLAED0', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+ SMLSIZ = ILAENV( 9, 'DLAED0', ' ', 0, 0, 0, 0 )
+*
+* Determine the size and placement of the submatrices, and save in
+* the leading elements of IWORK.
+*
+ IWORK( 1 ) = N
+ SUBPBS = 1
+ TLVLS = 0
+ 10 CONTINUE
+ IF( IWORK( SUBPBS ).GT.SMLSIZ ) THEN
+ DO 20 J = SUBPBS, 1, -1
+ IWORK( 2*J ) = ( IWORK( J )+1 ) / 2
+ IWORK( 2*J-1 ) = IWORK( J ) / 2
+ 20 CONTINUE
+ TLVLS = TLVLS + 1
+ SUBPBS = 2*SUBPBS
+ GO TO 10
+ END IF
+ DO 30 J = 2, SUBPBS
+ IWORK( J ) = IWORK( J ) + IWORK( J-1 )
+ 30 CONTINUE
+*
+* Divide the matrix into SUBPBS submatrices of size at most SMLSIZ+1
+* using rank-1 modifications (cuts).
+*
+ SPM1 = SUBPBS - 1
+ DO 40 I = 1, SPM1
+ SUBMAT = IWORK( I ) + 1
+ SMM1 = SUBMAT - 1
+ D( SMM1 ) = D( SMM1 ) - ABS( E( SMM1 ) )
+ D( SUBMAT ) = D( SUBMAT ) - ABS( E( SMM1 ) )
+ 40 CONTINUE
+*
+ INDXQ = 4*N + 3
+ IF( ICOMPQ.NE.2 ) THEN
+*
+* Set up workspaces for eigenvalues only/accumulate new vectors
+* routine
+*
+ TEMP = LOG( DBLE( N ) ) / LOG( TWO )
+ LGN = INT( TEMP )
+ IF( 2**LGN.LT.N )
+ $ LGN = LGN + 1
+ IF( 2**LGN.LT.N )
+ $ LGN = LGN + 1
+ IPRMPT = INDXQ + N + 1
+ IPERM = IPRMPT + N*LGN
+ IQPTR = IPERM + N*LGN
+ IGIVPT = IQPTR + N + 2
+ IGIVCL = IGIVPT + N*LGN
+*
+ IGIVNM = 1
+ IQ = IGIVNM + 2*N*LGN
+ IWREM = IQ + N**2 + 1
+*
+* Initialize pointers
+*
+ DO 50 I = 0, SUBPBS
+ IWORK( IPRMPT+I ) = 1
+ IWORK( IGIVPT+I ) = 1
+ 50 CONTINUE
+ IWORK( IQPTR ) = 1
+ END IF
+*
+* Solve each submatrix eigenproblem at the bottom of the divide and
+* conquer tree.
+*
+ CURR = 0
+ DO 70 I = 0, SPM1
+ IF( I.EQ.0 ) THEN
+ SUBMAT = 1
+ MATSIZ = IWORK( 1 )
+ ELSE
+ SUBMAT = IWORK( I ) + 1
+ MATSIZ = IWORK( I+1 ) - IWORK( I )
+ END IF
+ IF( ICOMPQ.EQ.2 ) THEN
+ CALL DSTEQR( 'I', MATSIZ, D( SUBMAT ), E( SUBMAT ),
+ $ Q( SUBMAT, SUBMAT ), LDQ, WORK, INFO )
+ IF( INFO.NE.0 )
+ $ GO TO 130
+ ELSE
+ CALL DSTEQR( 'I', MATSIZ, D( SUBMAT ), E( SUBMAT ),
+ $ WORK( IQ-1+IWORK( IQPTR+CURR ) ), MATSIZ, WORK,
+ $ INFO )
+ IF( INFO.NE.0 )
+ $ GO TO 130
+ IF( ICOMPQ.EQ.1 ) THEN
+ CALL DGEMM( 'N', 'N', QSIZ, MATSIZ, MATSIZ, ONE,
+ $ Q( 1, SUBMAT ), LDQ, WORK( IQ-1+IWORK( IQPTR+
+ $ CURR ) ), MATSIZ, ZERO, QSTORE( 1, SUBMAT ),
+ $ LDQS )
+ END IF
+ IWORK( IQPTR+CURR+1 ) = IWORK( IQPTR+CURR ) + MATSIZ**2
+ CURR = CURR + 1
+ END IF
+ K = 1
+ DO 60 J = SUBMAT, IWORK( I+1 )
+ IWORK( INDXQ+J ) = K
+ K = K + 1
+ 60 CONTINUE
+ 70 CONTINUE
+*
+* Successively merge eigensystems of adjacent submatrices
+* into eigensystem for the corresponding larger matrix.
+*
+* while ( SUBPBS > 1 )
+*
+ CURLVL = 1
+ 80 CONTINUE
+ IF( SUBPBS.GT.1 ) THEN
+ SPM2 = SUBPBS - 2
+ DO 90 I = 0, SPM2, 2
+ IF( I.EQ.0 ) THEN
+ SUBMAT = 1
+ MATSIZ = IWORK( 2 )
+ MSD2 = IWORK( 1 )
+ CURPRB = 0
+ ELSE
+ SUBMAT = IWORK( I ) + 1
+ MATSIZ = IWORK( I+2 ) - IWORK( I )
+ MSD2 = MATSIZ / 2
+ CURPRB = CURPRB + 1
+ END IF
+*
+* Merge lower order eigensystems (of size MSD2 and MATSIZ - MSD2)
+* into an eigensystem of size MATSIZ.
+* DLAED1 is used only for the full eigensystem of a tridiagonal
+* matrix.
+* DLAED7 handles the cases in which eigenvalues only or eigenvalues
+* and eigenvectors of a full symmetric matrix (which was reduced to
+* tridiagonal form) are desired.
+*
+ IF( ICOMPQ.EQ.2 ) THEN
+ CALL DLAED1( MATSIZ, D( SUBMAT ), Q( SUBMAT, SUBMAT ),
+ $ LDQ, IWORK( INDXQ+SUBMAT ),
+ $ E( SUBMAT+MSD2-1 ), MSD2, WORK,
+ $ IWORK( SUBPBS+1 ), INFO )
+ ELSE
+ CALL DLAED7( ICOMPQ, MATSIZ, QSIZ, TLVLS, CURLVL, CURPRB,
+ $ D( SUBMAT ), QSTORE( 1, SUBMAT ), LDQS,
+ $ IWORK( INDXQ+SUBMAT ), E( SUBMAT+MSD2-1 ),
+ $ MSD2, WORK( IQ ), IWORK( IQPTR ),
+ $ IWORK( IPRMPT ), IWORK( IPERM ),
+ $ IWORK( IGIVPT ), IWORK( IGIVCL ),
+ $ WORK( IGIVNM ), WORK( IWREM ),
+ $ IWORK( SUBPBS+1 ), INFO )
+ END IF
+ IF( INFO.NE.0 )
+ $ GO TO 130
+ IWORK( I / 2+1 ) = IWORK( I+2 )
+ 90 CONTINUE
+ SUBPBS = SUBPBS / 2
+ CURLVL = CURLVL + 1
+ GO TO 80
+ END IF
+*
+* end while
+*
+* Re-merge the eigenvalues/vectors which were deflated at the final
+* merge step.
+*
+ IF( ICOMPQ.EQ.1 ) THEN
+ DO 100 I = 1, N
+ J = IWORK( INDXQ+I )
+ WORK( I ) = D( J )
+ CALL DCOPY( QSIZ, QSTORE( 1, J ), 1, Q( 1, I ), 1 )
+ 100 CONTINUE
+ CALL DCOPY( N, WORK, 1, D, 1 )
+ ELSE IF( ICOMPQ.EQ.2 ) THEN
+ DO 110 I = 1, N
+ J = IWORK( INDXQ+I )
+ WORK( I ) = D( J )
+ CALL DCOPY( N, Q( 1, J ), 1, WORK( N*I+1 ), 1 )
+ 110 CONTINUE
+ CALL DCOPY( N, WORK, 1, D, 1 )
+ CALL DLACPY( 'A', N, N, WORK( N+1 ), N, Q, LDQ )
+ ELSE
+ DO 120 I = 1, N
+ J = IWORK( INDXQ+I )
+ WORK( I ) = D( J )
+ 120 CONTINUE
+ CALL DCOPY( N, WORK, 1, D, 1 )
+ END IF
+ GO TO 140
+*
+ 130 CONTINUE
+ INFO = SUBMAT*( N+1 ) + SUBMAT + MATSIZ - 1
+*
+ 140 CONTINUE
+ RETURN
+*
+* End of DLAED0
+*
+ END
+ SUBROUTINE DLAED1( N, D, Q, LDQ, INDXQ, RHO, CUTPNT, WORK, IWORK,
+ $ INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER CUTPNT, INFO, LDQ, N
+ DOUBLE PRECISION RHO
+* ..
+* .. Array Arguments ..
+ INTEGER INDXQ( * ), IWORK( * )
+ DOUBLE PRECISION D( * ), Q( LDQ, * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DLAED1 computes the updated eigensystem of a diagonal
+* matrix after modification by a rank-one symmetric matrix. This
+* routine is used only for the eigenproblem which requires all
+* eigenvalues and eigenvectors of a tridiagonal matrix. DLAED7 handles
+* the case in which eigenvalues only or eigenvalues and eigenvectors
+* of a full symmetric matrix (which was reduced to tridiagonal form)
+* are desired.
+*
+* T = Q(in) ( D(in) + RHO * Z*Z' ) Q'(in) = Q(out) * D(out) * Q'(out)
+*
+* where Z = Q'u, u is a vector of length N with ones in the
+* CUTPNT and CUTPNT + 1 th elements and zeros elsewhere.
+*
+* The eigenvectors of the original matrix are stored in Q, and the
+* eigenvalues are in D. The algorithm consists of three stages:
+*
+* The first stage consists of deflating the size of the problem
+* when there are multiple eigenvalues or if there is a zero in
+* the Z vector. For each such occurence the dimension of the
+* secular equation problem is reduced by one. This stage is
+* performed by the routine DLAED2.
+*
+* The second stage consists of calculating the updated
+* eigenvalues. This is done by finding the roots of the secular
+* equation via the routine DLAED4 (as called by DLAED3).
+* This routine also calculates the eigenvectors of the current
+* problem.
+*
+* The final stage consists of computing the updated eigenvectors
+* directly using the updated eigenvalues. The eigenvectors for
+* the current problem are multiplied with the eigenvectors from
+* the overall problem.
+*
+* Arguments
+* =========
+*
+* N (input) INTEGER
+* The dimension of the symmetric tridiagonal matrix. N >= 0.
+*
+* D (input/output) DOUBLE PRECISION array, dimension (N)
+* On entry, the eigenvalues of the rank-1-perturbed matrix.
+* On exit, the eigenvalues of the repaired matrix.
+*
+* Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N)
+* On entry, the eigenvectors of the rank-1-perturbed matrix.
+* On exit, the eigenvectors of the repaired tridiagonal matrix.
+*
+* LDQ (input) INTEGER
+* The leading dimension of the array Q. LDQ >= max(1,N).
+*
+* INDXQ (input/output) INTEGER array, dimension (N)
+* On entry, the permutation which separately sorts the two
+* subproblems in D into ascending order.
+* On exit, the permutation which will reintegrate the
+* subproblems back into sorted order,
+* i.e. D( INDXQ( I = 1, N ) ) will be in ascending order.
+*
+* RHO (input) DOUBLE PRECISION
+* The subdiagonal entry used to create the rank-1 modification.
+*
+* CUTPNT (input) INTEGER
+* The location of the last eigenvalue in the leading sub-matrix.
+* min(1,N) <= CUTPNT <= N/2.
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (4*N + N**2)
+*
+* IWORK (workspace) INTEGER array, dimension (4*N)
+*
+* INFO (output) INTEGER
+* = 0: successful exit.
+* < 0: if INFO = -i, the i-th argument had an illegal value.
+* > 0: if INFO = 1, an eigenvalue did not converge
+*
+* Further Details
+* ===============
+*
+* Based on contributions by
+* Jeff Rutter, Computer Science Division, University of California
+* at Berkeley, USA
+* Modified by Francoise Tisseur, University of Tennessee.
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ INTEGER COLTYP, I, IDLMDA, INDX, INDXC, INDXP, IQ2, IS,
+ $ IW, IZ, K, N1, N2, ZPP1
+* ..
+* .. External Subroutines ..
+ EXTERNAL DCOPY, DLAED2, DLAED3, DLAMRG, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+*
+ IF( N.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN
+ INFO = -4
+ ELSE IF( MIN( 1, N / 2 ).GT.CUTPNT .OR. ( N / 2 ).LT.CUTPNT ) THEN
+ INFO = -7
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DLAED1', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+* The following values are integer pointers which indicate
+* the portion of the workspace
+* used by a particular array in DLAED2 and DLAED3.
+*
+ IZ = 1
+ IDLMDA = IZ + N
+ IW = IDLMDA + N
+ IQ2 = IW + N
+*
+ INDX = 1
+ INDXC = INDX + N
+ COLTYP = INDXC + N
+ INDXP = COLTYP + N
+*
+*
+* Form the z-vector which consists of the last row of Q_1 and the
+* first row of Q_2.
+*
+ CALL DCOPY( CUTPNT, Q( CUTPNT, 1 ), LDQ, WORK( IZ ), 1 )
+ ZPP1 = CUTPNT + 1
+ CALL DCOPY( N-CUTPNT, Q( ZPP1, ZPP1 ), LDQ, WORK( IZ+CUTPNT ), 1 )
+*
+* Deflate eigenvalues.
+*
+ CALL DLAED2( K, N, CUTPNT, D, Q, LDQ, INDXQ, RHO, WORK( IZ ),
+ $ WORK( IDLMDA ), WORK( IW ), WORK( IQ2 ),
+ $ IWORK( INDX ), IWORK( INDXC ), IWORK( INDXP ),
+ $ IWORK( COLTYP ), INFO )
+*
+ IF( INFO.NE.0 )
+ $ GO TO 20
+*
+* Solve Secular Equation.
+*
+ IF( K.NE.0 ) THEN
+ IS = ( IWORK( COLTYP )+IWORK( COLTYP+1 ) )*CUTPNT +
+ $ ( IWORK( COLTYP+1 )+IWORK( COLTYP+2 ) )*( N-CUTPNT ) + IQ2
+ CALL DLAED3( K, N, CUTPNT, D, Q, LDQ, RHO, WORK( IDLMDA ),
+ $ WORK( IQ2 ), IWORK( INDXC ), IWORK( COLTYP ),
+ $ WORK( IW ), WORK( IS ), INFO )
+ IF( INFO.NE.0 )
+ $ GO TO 20
+*
+* Prepare the INDXQ sorting permutation.
+*
+ N1 = K
+ N2 = N - K
+ CALL DLAMRG( N1, N2, D, 1, -1, INDXQ )
+ ELSE
+ DO 10 I = 1, N
+ INDXQ( I ) = I
+ 10 CONTINUE
+ END IF
+*
+ 20 CONTINUE
+ RETURN
+*
+* End of DLAED1
+*
+ END
+ SUBROUTINE DLAED2( K, N, N1, D, Q, LDQ, INDXQ, RHO, Z, DLAMDA, W,
+ $ Q2, INDX, INDXC, INDXP, COLTYP, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, K, LDQ, N, N1
+ DOUBLE PRECISION RHO
+* ..
+* .. Array Arguments ..
+ INTEGER COLTYP( * ), INDX( * ), INDXC( * ), INDXP( * ),
+ $ INDXQ( * )
+ DOUBLE PRECISION D( * ), DLAMDA( * ), Q( LDQ, * ), Q2( * ),
+ $ W( * ), Z( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DLAED2 merges the two sets of eigenvalues together into a single
+* sorted set. Then it tries to deflate the size of the problem.
+* There are two ways in which deflation can occur: when two or more
+* eigenvalues are close together or if there is a tiny entry in the
+* Z vector. For each such occurrence the order of the related secular
+* equation problem is reduced by one.
+*
+* Arguments
+* =========
+*
+* K (output) INTEGER
+* The number of non-deflated eigenvalues, and the order of the
+* related secular equation. 0 <= K <=N.
+*
+* N (input) INTEGER
+* The dimension of the symmetric tridiagonal matrix. N >= 0.
+*
+* N1 (input) INTEGER
+* The location of the last eigenvalue in the leading sub-matrix.
+* min(1,N) <= N1 <= N/2.
+*
+* D (input/output) DOUBLE PRECISION array, dimension (N)
+* On entry, D contains the eigenvalues of the two submatrices to
+* be combined.
+* On exit, D contains the trailing (N-K) updated eigenvalues
+* (those which were deflated) sorted into increasing order.
+*
+* Q (input/output) DOUBLE PRECISION array, dimension (LDQ, N)
+* On entry, Q contains the eigenvectors of two submatrices in
+* the two square blocks with corners at (1,1), (N1,N1)
+* and (N1+1, N1+1), (N,N).
+* On exit, Q contains the trailing (N-K) updated eigenvectors
+* (those which were deflated) in its last N-K columns.
+*
+* LDQ (input) INTEGER
+* The leading dimension of the array Q. LDQ >= max(1,N).
+*
+* INDXQ (input/output) INTEGER array, dimension (N)
+* The permutation which separately sorts the two sub-problems
+* in D into ascending order. Note that elements in the second
+* half of this permutation must first have N1 added to their
+* values. Destroyed on exit.
+*
+* RHO (input/output) DOUBLE PRECISION
+* On entry, the off-diagonal element associated with the rank-1
+* cut which originally split the two submatrices which are now
+* being recombined.
+* On exit, RHO has been modified to the value required by
+* DLAED3.
+*
+* Z (input) DOUBLE PRECISION array, dimension (N)
+* On entry, Z contains the updating vector (the last
+* row of the first sub-eigenvector matrix and the first row of
+* the second sub-eigenvector matrix).
+* On exit, the contents of Z have been destroyed by the updating
+* process.
+*
+* DLAMDA (output) DOUBLE PRECISION array, dimension (N)
+* A copy of the first K eigenvalues which will be used by
+* DLAED3 to form the secular equation.
+*
+* W (output) DOUBLE PRECISION array, dimension (N)
+* The first k values of the final deflation-altered z-vector
+* which will be passed to DLAED3.
+*
+* Q2 (output) DOUBLE PRECISION array, dimension (N1**2+(N-N1)**2)
+* A copy of the first K eigenvectors which will be used by
+* DLAED3 in a matrix multiply (DGEMM) to solve for the new
+* eigenvectors.
+*
+* INDX (workspace) INTEGER array, dimension (N)
+* The permutation used to sort the contents of DLAMDA into
+* ascending order.
+*
+* INDXC (output) INTEGER array, dimension (N)
+* The permutation used to arrange the columns of the deflated
+* Q matrix into three groups: the first group contains non-zero
+* elements only at and above N1, the second contains
+* non-zero elements only below N1, and the third is dense.
+*
+* INDXP (workspace) INTEGER array, dimension (N)
+* The permutation used to place deflated values of D at the end
+* of the array. INDXP(1:K) points to the nondeflated D-values
+* and INDXP(K+1:N) points to the deflated eigenvalues.
+*
+* COLTYP (workspace/output) INTEGER array, dimension (N)
+* During execution, a label which will indicate which of the
+* following types a column in the Q2 matrix is:
+* 1 : non-zero in the upper half only;
+* 2 : dense;
+* 3 : non-zero in the lower half only;
+* 4 : deflated.
+* On exit, COLTYP(i) is the number of columns of type i,
+* for i=1 to 4 only.
+*
+* INFO (output) INTEGER
+* = 0: successful exit.
+* < 0: if INFO = -i, the i-th argument had an illegal value.
+*
+* Further Details
+* ===============
+*
+* Based on contributions by
+* Jeff Rutter, Computer Science Division, University of California
+* at Berkeley, USA
+* Modified by Francoise Tisseur, University of Tennessee.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION MONE, ZERO, ONE, TWO, EIGHT
+ PARAMETER ( MONE = -1.0D0, ZERO = 0.0D0, ONE = 1.0D0,
+ $ TWO = 2.0D0, EIGHT = 8.0D0 )
+* ..
+* .. Local Arrays ..
+ INTEGER CTOT( 4 ), PSM( 4 )
+* ..
+* .. Local Scalars ..
+ INTEGER CT, I, IMAX, IQ1, IQ2, J, JMAX, JS, K2, N1P1,
+ $ N2, NJ, PJ
+ DOUBLE PRECISION C, EPS, S, T, TAU, TOL
+* ..
+* .. External Functions ..
+ INTEGER IDAMAX
+ DOUBLE PRECISION DLAMCH, DLAPY2
+ EXTERNAL IDAMAX, DLAMCH, DLAPY2
+* ..
+* .. External Subroutines ..
+ EXTERNAL DCOPY, DLACPY, DLAMRG, DROT, DSCAL, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, MIN, SQRT
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+*
+ IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN
+ INFO = -6
+ ELSE IF( MIN( 1, ( N / 2 ) ).GT.N1 .OR. ( N / 2 ).LT.N1 ) THEN
+ INFO = -3
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DLAED2', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+ N2 = N - N1
+ N1P1 = N1 + 1
+*
+ IF( RHO.LT.ZERO ) THEN
+ CALL DSCAL( N2, MONE, Z( N1P1 ), 1 )
+ END IF
+*
+* Normalize z so that norm(z) = 1. Since z is the concatenation of
+* two normalized vectors, norm2(z) = sqrt(2).
+*
+ T = ONE / SQRT( TWO )
+ CALL DSCAL( N, T, Z, 1 )
+*
+* RHO = ABS( norm(z)**2 * RHO )
+*
+ RHO = ABS( TWO*RHO )
+*
+* Sort the eigenvalues into increasing order
+*
+ DO 10 I = N1P1, N
+ INDXQ( I ) = INDXQ( I ) + N1
+ 10 CONTINUE
+*
+* re-integrate the deflated parts from the last pass
+*
+ DO 20 I = 1, N
+ DLAMDA( I ) = D( INDXQ( I ) )
+ 20 CONTINUE
+ CALL DLAMRG( N1, N2, DLAMDA, 1, 1, INDXC )
+ DO 30 I = 1, N
+ INDX( I ) = INDXQ( INDXC( I ) )
+ 30 CONTINUE
+*
+* Calculate the allowable deflation tolerance
+*
+ IMAX = IDAMAX( N, Z, 1 )
+ JMAX = IDAMAX( N, D, 1 )
+ EPS = DLAMCH( 'Epsilon' )
+ TOL = EIGHT*EPS*MAX( ABS( D( JMAX ) ), ABS( Z( IMAX ) ) )
+*
+* If the rank-1 modifier is small enough, no more needs to be done
+* except to reorganize Q so that its columns correspond with the
+* elements in D.
+*
+ IF( RHO*ABS( Z( IMAX ) ).LE.TOL ) THEN
+ K = 0
+ IQ2 = 1
+ DO 40 J = 1, N
+ I = INDX( J )
+ CALL DCOPY( N, Q( 1, I ), 1, Q2( IQ2 ), 1 )
+ DLAMDA( J ) = D( I )
+ IQ2 = IQ2 + N
+ 40 CONTINUE
+ CALL DLACPY( 'A', N, N, Q2, N, Q, LDQ )
+ CALL DCOPY( N, DLAMDA, 1, D, 1 )
+ GO TO 190
+ END IF
+*
+* If there are multiple eigenvalues then the problem deflates. Here
+* the number of equal eigenvalues are found. As each equal
+* eigenvalue is found, an elementary reflector is computed to rotate
+* the corresponding eigensubspace so that the corresponding
+* components of Z are zero in this new basis.
+*
+ DO 50 I = 1, N1
+ COLTYP( I ) = 1
+ 50 CONTINUE
+ DO 60 I = N1P1, N
+ COLTYP( I ) = 3
+ 60 CONTINUE
+*
+*
+ K = 0
+ K2 = N + 1
+ DO 70 J = 1, N
+ NJ = INDX( J )
+ IF( RHO*ABS( Z( NJ ) ).LE.TOL ) THEN
+*
+* Deflate due to small z component.
+*
+ K2 = K2 - 1
+ COLTYP( NJ ) = 4
+ INDXP( K2 ) = NJ
+ IF( J.EQ.N )
+ $ GO TO 100
+ ELSE
+ PJ = NJ
+ GO TO 80
+ END IF
+ 70 CONTINUE
+ 80 CONTINUE
+ J = J + 1
+ NJ = INDX( J )
+ IF( J.GT.N )
+ $ GO TO 100
+ IF( RHO*ABS( Z( NJ ) ).LE.TOL ) THEN
+*
+* Deflate due to small z component.
+*
+ K2 = K2 - 1
+ COLTYP( NJ ) = 4
+ INDXP( K2 ) = NJ
+ ELSE
+*
+* Check if eigenvalues are close enough to allow deflation.
+*
+ S = Z( PJ )
+ C = Z( NJ )
+*
+* Find sqrt(a**2+b**2) without overflow or
+* destructive underflow.
+*
+ TAU = DLAPY2( C, S )
+ T = D( NJ ) - D( PJ )
+ C = C / TAU
+ S = -S / TAU
+ IF( ABS( T*C*S ).LE.TOL ) THEN
+*
+* Deflation is possible.
+*
+ Z( NJ ) = TAU
+ Z( PJ ) = ZERO
+ IF( COLTYP( NJ ).NE.COLTYP( PJ ) )
+ $ COLTYP( NJ ) = 2
+ COLTYP( PJ ) = 4
+ CALL DROT( N, Q( 1, PJ ), 1, Q( 1, NJ ), 1, C, S )
+ T = D( PJ )*C**2 + D( NJ )*S**2
+ D( NJ ) = D( PJ )*S**2 + D( NJ )*C**2
+ D( PJ ) = T
+ K2 = K2 - 1
+ I = 1
+ 90 CONTINUE
+ IF( K2+I.LE.N ) THEN
+ IF( D( PJ ).LT.D( INDXP( K2+I ) ) ) THEN
+ INDXP( K2+I-1 ) = INDXP( K2+I )
+ INDXP( K2+I ) = PJ
+ I = I + 1
+ GO TO 90
+ ELSE
+ INDXP( K2+I-1 ) = PJ
+ END IF
+ ELSE
+ INDXP( K2+I-1 ) = PJ
+ END IF
+ PJ = NJ
+ ELSE
+ K = K + 1
+ DLAMDA( K ) = D( PJ )
+ W( K ) = Z( PJ )
+ INDXP( K ) = PJ
+ PJ = NJ
+ END IF
+ END IF
+ GO TO 80
+ 100 CONTINUE
+*
+* Record the last eigenvalue.
+*
+ K = K + 1
+ DLAMDA( K ) = D( PJ )
+ W( K ) = Z( PJ )
+ INDXP( K ) = PJ
+*
+* Count up the total number of the various types of columns, then
+* form a permutation which positions the four column types into
+* four uniform groups (although one or more of these groups may be
+* empty).
+*
+ DO 110 J = 1, 4
+ CTOT( J ) = 0
+ 110 CONTINUE
+ DO 120 J = 1, N
+ CT = COLTYP( J )
+ CTOT( CT ) = CTOT( CT ) + 1
+ 120 CONTINUE
+*
+* PSM(*) = Position in SubMatrix (of types 1 through 4)
+*
+ PSM( 1 ) = 1
+ PSM( 2 ) = 1 + CTOT( 1 )
+ PSM( 3 ) = PSM( 2 ) + CTOT( 2 )
+ PSM( 4 ) = PSM( 3 ) + CTOT( 3 )
+ K = N - CTOT( 4 )
+*
+* Fill out the INDXC array so that the permutation which it induces
+* will place all type-1 columns first, all type-2 columns next,
+* then all type-3's, and finally all type-4's.
+*
+ DO 130 J = 1, N
+ JS = INDXP( J )
+ CT = COLTYP( JS )
+ INDX( PSM( CT ) ) = JS
+ INDXC( PSM( CT ) ) = J
+ PSM( CT ) = PSM( CT ) + 1
+ 130 CONTINUE
+*
+* Sort the eigenvalues and corresponding eigenvectors into DLAMDA
+* and Q2 respectively. The eigenvalues/vectors which were not
+* deflated go into the first K slots of DLAMDA and Q2 respectively,
+* while those which were deflated go into the last N - K slots.
+*
+ I = 1
+ IQ1 = 1
+ IQ2 = 1 + ( CTOT( 1 )+CTOT( 2 ) )*N1
+ DO 140 J = 1, CTOT( 1 )
+ JS = INDX( I )
+ CALL DCOPY( N1, Q( 1, JS ), 1, Q2( IQ1 ), 1 )
+ Z( I ) = D( JS )
+ I = I + 1
+ IQ1 = IQ1 + N1
+ 140 CONTINUE
+*
+ DO 150 J = 1, CTOT( 2 )
+ JS = INDX( I )
+ CALL DCOPY( N1, Q( 1, JS ), 1, Q2( IQ1 ), 1 )
+ CALL DCOPY( N2, Q( N1+1, JS ), 1, Q2( IQ2 ), 1 )
+ Z( I ) = D( JS )
+ I = I + 1
+ IQ1 = IQ1 + N1
+ IQ2 = IQ2 + N2
+ 150 CONTINUE
+*
+ DO 160 J = 1, CTOT( 3 )
+ JS = INDX( I )
+ CALL DCOPY( N2, Q( N1+1, JS ), 1, Q2( IQ2 ), 1 )
+ Z( I ) = D( JS )
+ I = I + 1
+ IQ2 = IQ2 + N2
+ 160 CONTINUE
+*
+ IQ1 = IQ2
+ DO 170 J = 1, CTOT( 4 )
+ JS = INDX( I )
+ CALL DCOPY( N, Q( 1, JS ), 1, Q2( IQ2 ), 1 )
+ IQ2 = IQ2 + N
+ Z( I ) = D( JS )
+ I = I + 1
+ 170 CONTINUE
+*
+* The deflated eigenvalues and their corresponding vectors go back
+* into the last N - K slots of D and Q respectively.
+*
+ CALL DLACPY( 'A', N, CTOT( 4 ), Q2( IQ1 ), N, Q( 1, K+1 ), LDQ )
+ CALL DCOPY( N-K, Z( K+1 ), 1, D( K+1 ), 1 )
+*
+* Copy CTOT into COLTYP for referencing in DLAED3.
+*
+ DO 180 J = 1, 4
+ COLTYP( J ) = CTOT( J )
+ 180 CONTINUE
+*
+ 190 CONTINUE
+ RETURN
+*
+* End of DLAED2
+*
+ END
+ SUBROUTINE DLAED3( K, N, N1, D, Q, LDQ, RHO, DLAMDA, Q2, INDX,
+ $ CTOT, W, S, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, K, LDQ, N, N1
+ DOUBLE PRECISION RHO
+* ..
+* .. Array Arguments ..
+ INTEGER CTOT( * ), INDX( * )
+ DOUBLE PRECISION D( * ), DLAMDA( * ), Q( LDQ, * ), Q2( * ),
+ $ S( * ), W( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DLAED3 finds the roots of the secular equation, as defined by the
+* values in D, W, and RHO, between 1 and K. It makes the
+* appropriate calls to DLAED4 and then updates the eigenvectors by
+* multiplying the matrix of eigenvectors of the pair of eigensystems
+* being combined by the matrix of eigenvectors of the K-by-K system
+* which is solved here.
+*
+* This code makes very mild assumptions about floating point
+* arithmetic. It will work on machines with a guard digit in
+* add/subtract, or on those binary machines without guard digits
+* which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2.
+* It could conceivably fail on hexadecimal or decimal machines
+* without guard digits, but we know of none.
+*
+* Arguments
+* =========
+*
+* K (input) INTEGER
+* The number of terms in the rational function to be solved by
+* DLAED4. K >= 0.
+*
+* N (input) INTEGER
+* The number of rows and columns in the Q matrix.
+* N >= K (deflation may result in N>K).
+*
+* N1 (input) INTEGER
+* The location of the last eigenvalue in the leading submatrix.
+* min(1,N) <= N1 <= N/2.
+*
+* D (output) DOUBLE PRECISION array, dimension (N)
+* D(I) contains the updated eigenvalues for
+* 1 <= I <= K.
+*
+* Q (output) DOUBLE PRECISION array, dimension (LDQ,N)
+* Initially the first K columns are used as workspace.
+* On output the columns 1 to K contain
+* the updated eigenvectors.
+*
+* LDQ (input) INTEGER
+* The leading dimension of the array Q. LDQ >= max(1,N).
+*
+* RHO (input) DOUBLE PRECISION
+* The value of the parameter in the rank one update equation.
+* RHO >= 0 required.
+*
+* DLAMDA (input/output) DOUBLE PRECISION array, dimension (K)
+* The first K elements of this array contain the old roots
+* of the deflated updating problem. These are the poles
+* of the secular equation. May be changed on output by
+* having lowest order bit set to zero on Cray X-MP, Cray Y-MP,
+* Cray-2, or Cray C-90, as described above.
+*
+* Q2 (input) DOUBLE PRECISION array, dimension (LDQ2, N)
+* The first K columns of this matrix contain the non-deflated
+* eigenvectors for the split problem.
+*
+* INDX (input) INTEGER array, dimension (N)
+* The permutation used to arrange the columns of the deflated
+* Q matrix into three groups (see DLAED2).
+* The rows of the eigenvectors found by DLAED4 must be likewise
+* permuted before the matrix multiply can take place.
+*
+* CTOT (input) INTEGER array, dimension (4)
+* A count of the total number of the various types of columns
+* in Q, as described in INDX. The fourth column type is any
+* column which has been deflated.
+*
+* W (input/output) DOUBLE PRECISION array, dimension (K)
+* The first K elements of this array contain the components
+* of the deflation-adjusted updating vector. Destroyed on
+* output.
+*
+* S (workspace) DOUBLE PRECISION array, dimension (N1 + 1)*K
+* Will contain the eigenvectors of the repaired matrix which
+* will be multiplied by the previously accumulated eigenvectors
+* to update the system.
+*
+* LDS (input) INTEGER
+* The leading dimension of S. LDS >= max(1,K).
+*
+* INFO (output) INTEGER
+* = 0: successful exit.
+* < 0: if INFO = -i, the i-th argument had an illegal value.
+* > 0: if INFO = 1, an eigenvalue did not converge
+*
+* Further Details
+* ===============
+*
+* Based on contributions by
+* Jeff Rutter, Computer Science Division, University of California
+* at Berkeley, USA
+* Modified by Francoise Tisseur, University of Tennessee.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE, ZERO
+ PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, II, IQ2, J, N12, N2, N23
+ DOUBLE PRECISION TEMP
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DLAMC3, DNRM2
+ EXTERNAL DLAMC3, DNRM2
+* ..
+* .. External Subroutines ..
+ EXTERNAL DCOPY, DGEMM, DLACPY, DLAED4, DLASET, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, SIGN, SQRT
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+*
+ IF( K.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( N.LT.K ) THEN
+ INFO = -2
+ ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN
+ INFO = -6
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DLAED3', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( K.EQ.0 )
+ $ RETURN
+*
+* Modify values DLAMDA(i) to make sure all DLAMDA(i)-DLAMDA(j) can
+* be computed with high relative accuracy (barring over/underflow).
+* This is a problem on machines without a guard digit in
+* add/subtract (Cray XMP, Cray YMP, Cray C 90 and Cray 2).
+* The following code replaces DLAMDA(I) by 2*DLAMDA(I)-DLAMDA(I),
+* which on any of these machines zeros out the bottommost
+* bit of DLAMDA(I) if it is 1; this makes the subsequent
+* subtractions DLAMDA(I)-DLAMDA(J) unproblematic when cancellation
+* occurs. On binary machines with a guard digit (almost all
+* machines) it does not change DLAMDA(I) at all. On hexadecimal
+* and decimal machines with a guard digit, it slightly
+* changes the bottommost bits of DLAMDA(I). It does not account
+* for hexadecimal or decimal machines without guard digits
+* (we know of none). We use a subroutine call to compute
+* 2*DLAMBDA(I) to prevent optimizing compilers from eliminating
+* this code.
+*
+ DO 10 I = 1, K
+ DLAMDA( I ) = DLAMC3( DLAMDA( I ), DLAMDA( I ) ) - DLAMDA( I )
+ 10 CONTINUE
+*
+ DO 20 J = 1, K
+ CALL DLAED4( K, J, DLAMDA, W, Q( 1, J ), RHO, D( J ), INFO )
+*
+* If the zero finder fails, the computation is terminated.
+*
+ IF( INFO.NE.0 )
+ $ GO TO 120
+ 20 CONTINUE
+*
+ IF( K.EQ.1 )
+ $ GO TO 110
+ IF( K.EQ.2 ) THEN
+ DO 30 J = 1, K
+ W( 1 ) = Q( 1, J )
+ W( 2 ) = Q( 2, J )
+ II = INDX( 1 )
+ Q( 1, J ) = W( II )
+ II = INDX( 2 )
+ Q( 2, J ) = W( II )
+ 30 CONTINUE
+ GO TO 110
+ END IF
+*
+* Compute updated W.
+*
+ CALL DCOPY( K, W, 1, S, 1 )
+*
+* Initialize W(I) = Q(I,I)
+*
+ CALL DCOPY( K, Q, LDQ+1, W, 1 )
+ DO 60 J = 1, K
+ DO 40 I = 1, J - 1
+ W( I ) = W( I )*( Q( I, J ) / ( DLAMDA( I )-DLAMDA( J ) ) )
+ 40 CONTINUE
+ DO 50 I = J + 1, K
+ W( I ) = W( I )*( Q( I, J ) / ( DLAMDA( I )-DLAMDA( J ) ) )
+ 50 CONTINUE
+ 60 CONTINUE
+ DO 70 I = 1, K
+ W( I ) = SIGN( SQRT( -W( I ) ), S( I ) )
+ 70 CONTINUE
+*
+* Compute eigenvectors of the modified rank-1 modification.
+*
+ DO 100 J = 1, K
+ DO 80 I = 1, K
+ S( I ) = W( I ) / Q( I, J )
+ 80 CONTINUE
+ TEMP = DNRM2( K, S, 1 )
+ DO 90 I = 1, K
+ II = INDX( I )
+ Q( I, J ) = S( II ) / TEMP
+ 90 CONTINUE
+ 100 CONTINUE
+*
+* Compute the updated eigenvectors.
+*
+ 110 CONTINUE
+*
+ N2 = N - N1
+ N12 = CTOT( 1 ) + CTOT( 2 )
+ N23 = CTOT( 2 ) + CTOT( 3 )
+*
+ CALL DLACPY( 'A', N23, K, Q( CTOT( 1 )+1, 1 ), LDQ, S, N23 )
+ IQ2 = N1*N12 + 1
+ IF( N23.NE.0 ) THEN
+ CALL DGEMM( 'N', 'N', N2, K, N23, ONE, Q2( IQ2 ), N2, S, N23,
+ $ ZERO, Q( N1+1, 1 ), LDQ )
+ ELSE
+ CALL DLASET( 'A', N2, K, ZERO, ZERO, Q( N1+1, 1 ), LDQ )
+ END IF
+*
+ CALL DLACPY( 'A', N12, K, Q, LDQ, S, N12 )
+ IF( N12.NE.0 ) THEN
+ CALL DGEMM( 'N', 'N', N1, K, N12, ONE, Q2, N1, S, N12, ZERO, Q,
+ $ LDQ )
+ ELSE
+ CALL DLASET( 'A', N1, K, ZERO, ZERO, Q( 1, 1 ), LDQ )
+ END IF
+*
+*
+ 120 CONTINUE
+ RETURN
+*
+* End of DLAED3
+*
+ END
+ SUBROUTINE DLAED4( N, I, D, Z, DELTA, RHO, DLAM, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER I, INFO, N
+ DOUBLE PRECISION DLAM, RHO
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION D( * ), DELTA( * ), Z( * )
+* ..
+*
+* Purpose
+* =======
+*
+* This subroutine computes the I-th updated eigenvalue of a symmetric
+* rank-one modification to a diagonal matrix whose elements are
+* given in the array d, and that
+*
+* D(i) < D(j) for i < j
+*
+* and that RHO > 0. This is arranged by the calling routine, and is
+* no loss in generality. The rank-one modified system is thus
+*
+* diag( D ) + RHO * Z * Z_transpose.
+*
+* where we assume the Euclidean norm of Z is 1.
+*
+* The method consists of approximating the rational functions in the
+* secular equation by simpler interpolating rational functions.
+*
+* Arguments
+* =========
+*
+* N (input) INTEGER
+* The length of all arrays.
+*
+* I (input) INTEGER
+* The index of the eigenvalue to be computed. 1 <= I <= N.
+*
+* D (input) DOUBLE PRECISION array, dimension (N)
+* The original eigenvalues. It is assumed that they are in
+* order, D(I) < D(J) for I < J.
+*
+* Z (input) DOUBLE PRECISION array, dimension (N)
+* The components of the updating vector.
+*
+* DELTA (output) DOUBLE PRECISION array, dimension (N)
+* If N .GT. 2, DELTA contains (D(j) - lambda_I) in its j-th
+* component. If N = 1, then DELTA(1) = 1. If N = 2, see DLAED5
+* for detail. The vector DELTA contains the information necessary
+* to construct the eigenvectors by DLAED3 and DLAED9.
+*
+* RHO (input) DOUBLE PRECISION
+* The scalar in the symmetric updating formula.
+*
+* DLAM (output) DOUBLE PRECISION
+* The computed lambda_I, the I-th updated eigenvalue.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* > 0: if INFO = 1, the updating process failed.
+*
+* Internal Parameters
+* ===================
+*
+* Logical variable ORGATI (origin-at-i?) is used for distinguishing
+* whether D(i) or D(i+1) is treated as the origin.
+*
+* ORGATI = .true. origin at i
+* ORGATI = .false. origin at i+1
+*
+* Logical variable SWTCH3 (switch-for-3-poles?) is for noting
+* if we are working with THREE poles!
+*
+* MAXIT is the maximum number of iterations allowed for each
+* eigenvalue.
+*
+* Further Details
+* ===============
+*
+* Based on contributions by
+* Ren-Cang Li, Computer Science Division, University of California
+* at Berkeley, USA
+*
+* =====================================================================
+*
+* .. Parameters ..
+ INTEGER MAXIT
+ PARAMETER ( MAXIT = 30 )
+ DOUBLE PRECISION ZERO, ONE, TWO, THREE, FOUR, EIGHT, TEN
+ PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0,
+ $ THREE = 3.0D0, FOUR = 4.0D0, EIGHT = 8.0D0,
+ $ TEN = 10.0D0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL ORGATI, SWTCH, SWTCH3
+ INTEGER II, IIM1, IIP1, IP1, ITER, J, NITER
+ DOUBLE PRECISION A, B, C, DEL, DLTLB, DLTUB, DPHI, DPSI, DW,
+ $ EPS, ERRETM, ETA, MIDPT, PHI, PREW, PSI,
+ $ RHOINV, TAU, TEMP, TEMP1, W
+* ..
+* .. Local Arrays ..
+ DOUBLE PRECISION ZZ( 3 )
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DLAMCH
+ EXTERNAL DLAMCH
+* ..
+* .. External Subroutines ..
+ EXTERNAL DLAED5, DLAED6
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, MIN, SQRT
+* ..
+* .. Executable Statements ..
+*
+* Since this routine is called in an inner loop, we do no argument
+* checking.
+*
+* Quick return for N=1 and 2.
+*
+ INFO = 0
+ IF( N.EQ.1 ) THEN
+*
+* Presumably, I=1 upon entry
+*
+ DLAM = D( 1 ) + RHO*Z( 1 )*Z( 1 )
+ DELTA( 1 ) = ONE
+ RETURN
+ END IF
+ IF( N.EQ.2 ) THEN
+ CALL DLAED5( I, D, Z, DELTA, RHO, DLAM )
+ RETURN
+ END IF
+*
+* Compute machine epsilon
+*
+ EPS = DLAMCH( 'Epsilon' )
+ RHOINV = ONE / RHO
+*
+* The case I = N
+*
+ IF( I.EQ.N ) THEN
+*
+* Initialize some basic variables
+*
+ II = N - 1
+ NITER = 1
+*
+* Calculate initial guess
+*
+ MIDPT = RHO / TWO
+*
+* If ||Z||_2 is not one, then TEMP should be set to
+* RHO * ||Z||_2^2 / TWO
+*
+ DO 10 J = 1, N
+ DELTA( J ) = ( D( J )-D( I ) ) - MIDPT
+ 10 CONTINUE
+*
+ PSI = ZERO
+ DO 20 J = 1, N - 2
+ PSI = PSI + Z( J )*Z( J ) / DELTA( J )
+ 20 CONTINUE
+*
+ C = RHOINV + PSI
+ W = C + Z( II )*Z( II ) / DELTA( II ) +
+ $ Z( N )*Z( N ) / DELTA( N )
+*
+ IF( W.LE.ZERO ) THEN
+ TEMP = Z( N-1 )*Z( N-1 ) / ( D( N )-D( N-1 )+RHO ) +
+ $ Z( N )*Z( N ) / RHO
+ IF( C.LE.TEMP ) THEN
+ TAU = RHO
+ ELSE
+ DEL = D( N ) - D( N-1 )
+ A = -C*DEL + Z( N-1 )*Z( N-1 ) + Z( N )*Z( N )
+ B = Z( N )*Z( N )*DEL
+ IF( A.LT.ZERO ) THEN
+ TAU = TWO*B / ( SQRT( A*A+FOUR*B*C )-A )
+ ELSE
+ TAU = ( A+SQRT( A*A+FOUR*B*C ) ) / ( TWO*C )
+ END IF
+ END IF
+*
+* It can be proved that
+* D(N)+RHO/2 <= LAMBDA(N) < D(N)+TAU <= D(N)+RHO
+*
+ DLTLB = MIDPT
+ DLTUB = RHO
+ ELSE
+ DEL = D( N ) - D( N-1 )
+ A = -C*DEL + Z( N-1 )*Z( N-1 ) + Z( N )*Z( N )
+ B = Z( N )*Z( N )*DEL
+ IF( A.LT.ZERO ) THEN
+ TAU = TWO*B / ( SQRT( A*A+FOUR*B*C )-A )
+ ELSE
+ TAU = ( A+SQRT( A*A+FOUR*B*C ) ) / ( TWO*C )
+ END IF
+*
+* It can be proved that
+* D(N) < D(N)+TAU < LAMBDA(N) < D(N)+RHO/2
+*
+ DLTLB = ZERO
+ DLTUB = MIDPT
+ END IF
+*
+ DO 30 J = 1, N
+ DELTA( J ) = ( D( J )-D( I ) ) - TAU
+ 30 CONTINUE
+*
+* Evaluate PSI and the derivative DPSI
+*
+ DPSI = ZERO
+ PSI = ZERO
+ ERRETM = ZERO
+ DO 40 J = 1, II
+ TEMP = Z( J ) / DELTA( J )
+ PSI = PSI + Z( J )*TEMP
+ DPSI = DPSI + TEMP*TEMP
+ ERRETM = ERRETM + PSI
+ 40 CONTINUE
+ ERRETM = ABS( ERRETM )
+*
+* Evaluate PHI and the derivative DPHI
+*
+ TEMP = Z( N ) / DELTA( N )
+ PHI = Z( N )*TEMP
+ DPHI = TEMP*TEMP
+ ERRETM = EIGHT*( -PHI-PSI ) + ERRETM - PHI + RHOINV +
+ $ ABS( TAU )*( DPSI+DPHI )
+*
+ W = RHOINV + PHI + PSI
+*
+* Test for convergence
+*
+ IF( ABS( W ).LE.EPS*ERRETM ) THEN
+ DLAM = D( I ) + TAU
+ GO TO 250
+ END IF
+*
+ IF( W.LE.ZERO ) THEN
+ DLTLB = MAX( DLTLB, TAU )
+ ELSE
+ DLTUB = MIN( DLTUB, TAU )
+ END IF
+*
+* Calculate the new step
+*
+ NITER = NITER + 1
+ C = W - DELTA( N-1 )*DPSI - DELTA( N )*DPHI
+ A = ( DELTA( N-1 )+DELTA( N ) )*W -
+ $ DELTA( N-1 )*DELTA( N )*( DPSI+DPHI )
+ B = DELTA( N-1 )*DELTA( N )*W
+ IF( C.LT.ZERO )
+ $ C = ABS( C )
+ IF( C.EQ.ZERO ) THEN
+* ETA = B/A
+* ETA = RHO - TAU
+ ETA = DLTUB - TAU
+ ELSE IF( A.GE.ZERO ) THEN
+ ETA = ( A+SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C )
+ ELSE
+ ETA = TWO*B / ( A-SQRT( ABS( A*A-FOUR*B*C ) ) )
+ END IF
+*
+* Note, eta should be positive if w is negative, and
+* eta should be negative otherwise. However,
+* if for some reason caused by roundoff, eta*w > 0,
+* we simply use one Newton step instead. This way
+* will guarantee eta*w < 0.
+*
+ IF( W*ETA.GT.ZERO )
+ $ ETA = -W / ( DPSI+DPHI )
+ TEMP = TAU + ETA
+ IF( TEMP.GT.DLTUB .OR. TEMP.LT.DLTLB ) THEN
+ IF( W.LT.ZERO ) THEN
+ ETA = ( DLTUB-TAU ) / TWO
+ ELSE
+ ETA = ( DLTLB-TAU ) / TWO
+ END IF
+ END IF
+ DO 50 J = 1, N
+ DELTA( J ) = DELTA( J ) - ETA
+ 50 CONTINUE
+*
+ TAU = TAU + ETA
+*
+* Evaluate PSI and the derivative DPSI
+*
+ DPSI = ZERO
+ PSI = ZERO
+ ERRETM = ZERO
+ DO 60 J = 1, II
+ TEMP = Z( J ) / DELTA( J )
+ PSI = PSI + Z( J )*TEMP
+ DPSI = DPSI + TEMP*TEMP
+ ERRETM = ERRETM + PSI
+ 60 CONTINUE
+ ERRETM = ABS( ERRETM )
+*
+* Evaluate PHI and the derivative DPHI
+*
+ TEMP = Z( N ) / DELTA( N )
+ PHI = Z( N )*TEMP
+ DPHI = TEMP*TEMP
+ ERRETM = EIGHT*( -PHI-PSI ) + ERRETM - PHI + RHOINV +
+ $ ABS( TAU )*( DPSI+DPHI )
+*
+ W = RHOINV + PHI + PSI
+*
+* Main loop to update the values of the array DELTA
+*
+ ITER = NITER + 1
+*
+ DO 90 NITER = ITER, MAXIT
+*
+* Test for convergence
+*
+ IF( ABS( W ).LE.EPS*ERRETM ) THEN
+ DLAM = D( I ) + TAU
+ GO TO 250
+ END IF
+*
+ IF( W.LE.ZERO ) THEN
+ DLTLB = MAX( DLTLB, TAU )
+ ELSE
+ DLTUB = MIN( DLTUB, TAU )
+ END IF
+*
+* Calculate the new step
+*
+ C = W - DELTA( N-1 )*DPSI - DELTA( N )*DPHI
+ A = ( DELTA( N-1 )+DELTA( N ) )*W -
+ $ DELTA( N-1 )*DELTA( N )*( DPSI+DPHI )
+ B = DELTA( N-1 )*DELTA( N )*W
+ IF( A.GE.ZERO ) THEN
+ ETA = ( A+SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C )
+ ELSE
+ ETA = TWO*B / ( A-SQRT( ABS( A*A-FOUR*B*C ) ) )
+ END IF
+*
+* Note, eta should be positive if w is negative, and
+* eta should be negative otherwise. However,
+* if for some reason caused by roundoff, eta*w > 0,
+* we simply use one Newton step instead. This way
+* will guarantee eta*w < 0.
+*
+ IF( W*ETA.GT.ZERO )
+ $ ETA = -W / ( DPSI+DPHI )
+ TEMP = TAU + ETA
+ IF( TEMP.GT.DLTUB .OR. TEMP.LT.DLTLB ) THEN
+ IF( W.LT.ZERO ) THEN
+ ETA = ( DLTUB-TAU ) / TWO
+ ELSE
+ ETA = ( DLTLB-TAU ) / TWO
+ END IF
+ END IF
+ DO 70 J = 1, N
+ DELTA( J ) = DELTA( J ) - ETA
+ 70 CONTINUE
+*
+ TAU = TAU + ETA
+*
+* Evaluate PSI and the derivative DPSI
+*
+ DPSI = ZERO
+ PSI = ZERO
+ ERRETM = ZERO
+ DO 80 J = 1, II
+ TEMP = Z( J ) / DELTA( J )
+ PSI = PSI + Z( J )*TEMP
+ DPSI = DPSI + TEMP*TEMP
+ ERRETM = ERRETM + PSI
+ 80 CONTINUE
+ ERRETM = ABS( ERRETM )
+*
+* Evaluate PHI and the derivative DPHI
+*
+ TEMP = Z( N ) / DELTA( N )
+ PHI = Z( N )*TEMP
+ DPHI = TEMP*TEMP
+ ERRETM = EIGHT*( -PHI-PSI ) + ERRETM - PHI + RHOINV +
+ $ ABS( TAU )*( DPSI+DPHI )
+*
+ W = RHOINV + PHI + PSI
+ 90 CONTINUE
+*
+* Return with INFO = 1, NITER = MAXIT and not converged
+*
+ INFO = 1
+ DLAM = D( I ) + TAU
+ GO TO 250
+*
+* End for the case I = N
+*
+ ELSE
+*
+* The case for I < N
+*
+ NITER = 1
+ IP1 = I + 1
+*
+* Calculate initial guess
+*
+ DEL = D( IP1 ) - D( I )
+ MIDPT = DEL / TWO
+ DO 100 J = 1, N
+ DELTA( J ) = ( D( J )-D( I ) ) - MIDPT
+ 100 CONTINUE
+*
+ PSI = ZERO
+ DO 110 J = 1, I - 1
+ PSI = PSI + Z( J )*Z( J ) / DELTA( J )
+ 110 CONTINUE
+*
+ PHI = ZERO
+ DO 120 J = N, I + 2, -1
+ PHI = PHI + Z( J )*Z( J ) / DELTA( J )
+ 120 CONTINUE
+ C = RHOINV + PSI + PHI
+ W = C + Z( I )*Z( I ) / DELTA( I ) +
+ $ Z( IP1 )*Z( IP1 ) / DELTA( IP1 )
+*
+ IF( W.GT.ZERO ) THEN
+*
+* d(i)< the ith eigenvalue < (d(i)+d(i+1))/2
+*
+* We choose d(i) as origin.
+*
+ ORGATI = .TRUE.
+ A = C*DEL + Z( I )*Z( I ) + Z( IP1 )*Z( IP1 )
+ B = Z( I )*Z( I )*DEL
+ IF( A.GT.ZERO ) THEN
+ TAU = TWO*B / ( A+SQRT( ABS( A*A-FOUR*B*C ) ) )
+ ELSE
+ TAU = ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C )
+ END IF
+ DLTLB = ZERO
+ DLTUB = MIDPT
+ ELSE
+*
+* (d(i)+d(i+1))/2 <= the ith eigenvalue < d(i+1)
+*
+* We choose d(i+1) as origin.
+*
+ ORGATI = .FALSE.
+ A = C*DEL - Z( I )*Z( I ) - Z( IP1 )*Z( IP1 )
+ B = Z( IP1 )*Z( IP1 )*DEL
+ IF( A.LT.ZERO ) THEN
+ TAU = TWO*B / ( A-SQRT( ABS( A*A+FOUR*B*C ) ) )
+ ELSE
+ TAU = -( A+SQRT( ABS( A*A+FOUR*B*C ) ) ) / ( TWO*C )
+ END IF
+ DLTLB = -MIDPT
+ DLTUB = ZERO
+ END IF
+*
+ IF( ORGATI ) THEN
+ DO 130 J = 1, N
+ DELTA( J ) = ( D( J )-D( I ) ) - TAU
+ 130 CONTINUE
+ ELSE
+ DO 140 J = 1, N
+ DELTA( J ) = ( D( J )-D( IP1 ) ) - TAU
+ 140 CONTINUE
+ END IF
+ IF( ORGATI ) THEN
+ II = I
+ ELSE
+ II = I + 1
+ END IF
+ IIM1 = II - 1
+ IIP1 = II + 1
+*
+* Evaluate PSI and the derivative DPSI
+*
+ DPSI = ZERO
+ PSI = ZERO
+ ERRETM = ZERO
+ DO 150 J = 1, IIM1
+ TEMP = Z( J ) / DELTA( J )
+ PSI = PSI + Z( J )*TEMP
+ DPSI = DPSI + TEMP*TEMP
+ ERRETM = ERRETM + PSI
+ 150 CONTINUE
+ ERRETM = ABS( ERRETM )
+*
+* Evaluate PHI and the derivative DPHI
+*
+ DPHI = ZERO
+ PHI = ZERO
+ DO 160 J = N, IIP1, -1
+ TEMP = Z( J ) / DELTA( J )
+ PHI = PHI + Z( J )*TEMP
+ DPHI = DPHI + TEMP*TEMP
+ ERRETM = ERRETM + PHI
+ 160 CONTINUE
+*
+ W = RHOINV + PHI + PSI
+*
+* W is the value of the secular function with
+* its ii-th element removed.
+*
+ SWTCH3 = .FALSE.
+ IF( ORGATI ) THEN
+ IF( W.LT.ZERO )
+ $ SWTCH3 = .TRUE.
+ ELSE
+ IF( W.GT.ZERO )
+ $ SWTCH3 = .TRUE.
+ END IF
+ IF( II.EQ.1 .OR. II.EQ.N )
+ $ SWTCH3 = .FALSE.
+*
+ TEMP = Z( II ) / DELTA( II )
+ DW = DPSI + DPHI + TEMP*TEMP
+ TEMP = Z( II )*TEMP
+ W = W + TEMP
+ ERRETM = EIGHT*( PHI-PSI ) + ERRETM + TWO*RHOINV +
+ $ THREE*ABS( TEMP ) + ABS( TAU )*DW
+*
+* Test for convergence
+*
+ IF( ABS( W ).LE.EPS*ERRETM ) THEN
+ IF( ORGATI ) THEN
+ DLAM = D( I ) + TAU
+ ELSE
+ DLAM = D( IP1 ) + TAU
+ END IF
+ GO TO 250
+ END IF
+*
+ IF( W.LE.ZERO ) THEN
+ DLTLB = MAX( DLTLB, TAU )
+ ELSE
+ DLTUB = MIN( DLTUB, TAU )
+ END IF
+*
+* Calculate the new step
+*
+ NITER = NITER + 1
+ IF( .NOT.SWTCH3 ) THEN
+ IF( ORGATI ) THEN
+ C = W - DELTA( IP1 )*DW - ( D( I )-D( IP1 ) )*
+ $ ( Z( I ) / DELTA( I ) )**2
+ ELSE
+ C = W - DELTA( I )*DW - ( D( IP1 )-D( I ) )*
+ $ ( Z( IP1 ) / DELTA( IP1 ) )**2
+ END IF
+ A = ( DELTA( I )+DELTA( IP1 ) )*W -
+ $ DELTA( I )*DELTA( IP1 )*DW
+ B = DELTA( I )*DELTA( IP1 )*W
+ IF( C.EQ.ZERO ) THEN
+ IF( A.EQ.ZERO ) THEN
+ IF( ORGATI ) THEN
+ A = Z( I )*Z( I ) + DELTA( IP1 )*DELTA( IP1 )*
+ $ ( DPSI+DPHI )
+ ELSE
+ A = Z( IP1 )*Z( IP1 ) + DELTA( I )*DELTA( I )*
+ $ ( DPSI+DPHI )
+ END IF
+ END IF
+ ETA = B / A
+ ELSE IF( A.LE.ZERO ) THEN
+ ETA = ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C )
+ ELSE
+ ETA = TWO*B / ( A+SQRT( ABS( A*A-FOUR*B*C ) ) )
+ END IF
+ ELSE
+*
+* Interpolation using THREE most relevant poles
+*
+ TEMP = RHOINV + PSI + PHI
+ IF( ORGATI ) THEN
+ TEMP1 = Z( IIM1 ) / DELTA( IIM1 )
+ TEMP1 = TEMP1*TEMP1
+ C = TEMP - DELTA( IIP1 )*( DPSI+DPHI ) -
+ $ ( D( IIM1 )-D( IIP1 ) )*TEMP1
+ ZZ( 1 ) = Z( IIM1 )*Z( IIM1 )
+ ZZ( 3 ) = DELTA( IIP1 )*DELTA( IIP1 )*
+ $ ( ( DPSI-TEMP1 )+DPHI )
+ ELSE
+ TEMP1 = Z( IIP1 ) / DELTA( IIP1 )
+ TEMP1 = TEMP1*TEMP1
+ C = TEMP - DELTA( IIM1 )*( DPSI+DPHI ) -
+ $ ( D( IIP1 )-D( IIM1 ) )*TEMP1
+ ZZ( 1 ) = DELTA( IIM1 )*DELTA( IIM1 )*
+ $ ( DPSI+( DPHI-TEMP1 ) )
+ ZZ( 3 ) = Z( IIP1 )*Z( IIP1 )
+ END IF
+ ZZ( 2 ) = Z( II )*Z( II )
+ CALL DLAED6( NITER, ORGATI, C, DELTA( IIM1 ), ZZ, W, ETA,
+ $ INFO )
+ IF( INFO.NE.0 )
+ $ GO TO 250
+ END IF
+*
+* Note, eta should be positive if w is negative, and
+* eta should be negative otherwise. However,
+* if for some reason caused by roundoff, eta*w > 0,
+* we simply use one Newton step instead. This way
+* will guarantee eta*w < 0.
+*
+ IF( W*ETA.GE.ZERO )
+ $ ETA = -W / DW
+ TEMP = TAU + ETA
+ IF( TEMP.GT.DLTUB .OR. TEMP.LT.DLTLB ) THEN
+ IF( W.LT.ZERO ) THEN
+ ETA = ( DLTUB-TAU ) / TWO
+ ELSE
+ ETA = ( DLTLB-TAU ) / TWO
+ END IF
+ END IF
+*
+ PREW = W
+*
+ DO 180 J = 1, N
+ DELTA( J ) = DELTA( J ) - ETA
+ 180 CONTINUE
+*
+* Evaluate PSI and the derivative DPSI
+*
+ DPSI = ZERO
+ PSI = ZERO
+ ERRETM = ZERO
+ DO 190 J = 1, IIM1
+ TEMP = Z( J ) / DELTA( J )
+ PSI = PSI + Z( J )*TEMP
+ DPSI = DPSI + TEMP*TEMP
+ ERRETM = ERRETM + PSI
+ 190 CONTINUE
+ ERRETM = ABS( ERRETM )
+*
+* Evaluate PHI and the derivative DPHI
+*
+ DPHI = ZERO
+ PHI = ZERO
+ DO 200 J = N, IIP1, -1
+ TEMP = Z( J ) / DELTA( J )
+ PHI = PHI + Z( J )*TEMP
+ DPHI = DPHI + TEMP*TEMP
+ ERRETM = ERRETM + PHI
+ 200 CONTINUE
+*
+ TEMP = Z( II ) / DELTA( II )
+ DW = DPSI + DPHI + TEMP*TEMP
+ TEMP = Z( II )*TEMP
+ W = RHOINV + PHI + PSI + TEMP
+ ERRETM = EIGHT*( PHI-PSI ) + ERRETM + TWO*RHOINV +
+ $ THREE*ABS( TEMP ) + ABS( TAU+ETA )*DW
+*
+ SWTCH = .FALSE.
+ IF( ORGATI ) THEN
+ IF( -W.GT.ABS( PREW ) / TEN )
+ $ SWTCH = .TRUE.
+ ELSE
+ IF( W.GT.ABS( PREW ) / TEN )
+ $ SWTCH = .TRUE.
+ END IF
+*
+ TAU = TAU + ETA
+*
+* Main loop to update the values of the array DELTA
+*
+ ITER = NITER + 1
+*
+ DO 240 NITER = ITER, MAXIT
+*
+* Test for convergence
+*
+ IF( ABS( W ).LE.EPS*ERRETM ) THEN
+ IF( ORGATI ) THEN
+ DLAM = D( I ) + TAU
+ ELSE
+ DLAM = D( IP1 ) + TAU
+ END IF
+ GO TO 250
+ END IF
+*
+ IF( W.LE.ZERO ) THEN
+ DLTLB = MAX( DLTLB, TAU )
+ ELSE
+ DLTUB = MIN( DLTUB, TAU )
+ END IF
+*
+* Calculate the new step
+*
+ IF( .NOT.SWTCH3 ) THEN
+ IF( .NOT.SWTCH ) THEN
+ IF( ORGATI ) THEN
+ C = W - DELTA( IP1 )*DW -
+ $ ( D( I )-D( IP1 ) )*( Z( I ) / DELTA( I ) )**2
+ ELSE
+ C = W - DELTA( I )*DW - ( D( IP1 )-D( I ) )*
+ $ ( Z( IP1 ) / DELTA( IP1 ) )**2
+ END IF
+ ELSE
+ TEMP = Z( II ) / DELTA( II )
+ IF( ORGATI ) THEN
+ DPSI = DPSI + TEMP*TEMP
+ ELSE
+ DPHI = DPHI + TEMP*TEMP
+ END IF
+ C = W - DELTA( I )*DPSI - DELTA( IP1 )*DPHI
+ END IF
+ A = ( DELTA( I )+DELTA( IP1 ) )*W -
+ $ DELTA( I )*DELTA( IP1 )*DW
+ B = DELTA( I )*DELTA( IP1 )*W
+ IF( C.EQ.ZERO ) THEN
+ IF( A.EQ.ZERO ) THEN
+ IF( .NOT.SWTCH ) THEN
+ IF( ORGATI ) THEN
+ A = Z( I )*Z( I ) + DELTA( IP1 )*
+ $ DELTA( IP1 )*( DPSI+DPHI )
+ ELSE
+ A = Z( IP1 )*Z( IP1 ) +
+ $ DELTA( I )*DELTA( I )*( DPSI+DPHI )
+ END IF
+ ELSE
+ A = DELTA( I )*DELTA( I )*DPSI +
+ $ DELTA( IP1 )*DELTA( IP1 )*DPHI
+ END IF
+ END IF
+ ETA = B / A
+ ELSE IF( A.LE.ZERO ) THEN
+ ETA = ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C )
+ ELSE
+ ETA = TWO*B / ( A+SQRT( ABS( A*A-FOUR*B*C ) ) )
+ END IF
+ ELSE
+*
+* Interpolation using THREE most relevant poles
+*
+ TEMP = RHOINV + PSI + PHI
+ IF( SWTCH ) THEN
+ C = TEMP - DELTA( IIM1 )*DPSI - DELTA( IIP1 )*DPHI
+ ZZ( 1 ) = DELTA( IIM1 )*DELTA( IIM1 )*DPSI
+ ZZ( 3 ) = DELTA( IIP1 )*DELTA( IIP1 )*DPHI
+ ELSE
+ IF( ORGATI ) THEN
+ TEMP1 = Z( IIM1 ) / DELTA( IIM1 )
+ TEMP1 = TEMP1*TEMP1
+ C = TEMP - DELTA( IIP1 )*( DPSI+DPHI ) -
+ $ ( D( IIM1 )-D( IIP1 ) )*TEMP1
+ ZZ( 1 ) = Z( IIM1 )*Z( IIM1 )
+ ZZ( 3 ) = DELTA( IIP1 )*DELTA( IIP1 )*
+ $ ( ( DPSI-TEMP1 )+DPHI )
+ ELSE
+ TEMP1 = Z( IIP1 ) / DELTA( IIP1 )
+ TEMP1 = TEMP1*TEMP1
+ C = TEMP - DELTA( IIM1 )*( DPSI+DPHI ) -
+ $ ( D( IIP1 )-D( IIM1 ) )*TEMP1
+ ZZ( 1 ) = DELTA( IIM1 )*DELTA( IIM1 )*
+ $ ( DPSI+( DPHI-TEMP1 ) )
+ ZZ( 3 ) = Z( IIP1 )*Z( IIP1 )
+ END IF
+ END IF
+ CALL DLAED6( NITER, ORGATI, C, DELTA( IIM1 ), ZZ, W, ETA,
+ $ INFO )
+ IF( INFO.NE.0 )
+ $ GO TO 250
+ END IF
+*
+* Note, eta should be positive if w is negative, and
+* eta should be negative otherwise. However,
+* if for some reason caused by roundoff, eta*w > 0,
+* we simply use one Newton step instead. This way
+* will guarantee eta*w < 0.
+*
+ IF( W*ETA.GE.ZERO )
+ $ ETA = -W / DW
+ TEMP = TAU + ETA
+ IF( TEMP.GT.DLTUB .OR. TEMP.LT.DLTLB ) THEN
+ IF( W.LT.ZERO ) THEN
+ ETA = ( DLTUB-TAU ) / TWO
+ ELSE
+ ETA = ( DLTLB-TAU ) / TWO
+ END IF
+ END IF
+*
+ DO 210 J = 1, N
+ DELTA( J ) = DELTA( J ) - ETA
+ 210 CONTINUE
+*
+ TAU = TAU + ETA
+ PREW = W
+*
+* Evaluate PSI and the derivative DPSI
+*
+ DPSI = ZERO
+ PSI = ZERO
+ ERRETM = ZERO
+ DO 220 J = 1, IIM1
+ TEMP = Z( J ) / DELTA( J )
+ PSI = PSI + Z( J )*TEMP
+ DPSI = DPSI + TEMP*TEMP
+ ERRETM = ERRETM + PSI
+ 220 CONTINUE
+ ERRETM = ABS( ERRETM )
+*
+* Evaluate PHI and the derivative DPHI
+*
+ DPHI = ZERO
+ PHI = ZERO
+ DO 230 J = N, IIP1, -1
+ TEMP = Z( J ) / DELTA( J )
+ PHI = PHI + Z( J )*TEMP
+ DPHI = DPHI + TEMP*TEMP
+ ERRETM = ERRETM + PHI
+ 230 CONTINUE
+*
+ TEMP = Z( II ) / DELTA( II )
+ DW = DPSI + DPHI + TEMP*TEMP
+ TEMP = Z( II )*TEMP
+ W = RHOINV + PHI + PSI + TEMP
+ ERRETM = EIGHT*( PHI-PSI ) + ERRETM + TWO*RHOINV +
+ $ THREE*ABS( TEMP ) + ABS( TAU )*DW
+ IF( W*PREW.GT.ZERO .AND. ABS( W ).GT.ABS( PREW ) / TEN )
+ $ SWTCH = .NOT.SWTCH
+*
+ 240 CONTINUE
+*
+* Return with INFO = 1, NITER = MAXIT and not converged
+*
+ INFO = 1
+ IF( ORGATI ) THEN
+ DLAM = D( I ) + TAU
+ ELSE
+ DLAM = D( IP1 ) + TAU
+ END IF
+*
+ END IF
+*
+ 250 CONTINUE
+*
+ RETURN
+*
+* End of DLAED4
+*
+ END
+ SUBROUTINE DLAED5( I, D, Z, DELTA, RHO, DLAM )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER I
+ DOUBLE PRECISION DLAM, RHO
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION D( 2 ), DELTA( 2 ), Z( 2 )
+* ..
+*
+* Purpose
+* =======
+*
+* This subroutine computes the I-th eigenvalue of a symmetric rank-one
+* modification of a 2-by-2 diagonal matrix
+*
+* diag( D ) + RHO * Z * transpose(Z) .
+*
+* The diagonal elements in the array D are assumed to satisfy
+*
+* D(i) < D(j) for i < j .
+*
+* We also assume RHO > 0 and that the Euclidean norm of the vector
+* Z is one.
+*
+* Arguments
+* =========
+*
+* I (input) INTEGER
+* The index of the eigenvalue to be computed. I = 1 or I = 2.
+*
+* D (input) DOUBLE PRECISION array, dimension (2)
+* The original eigenvalues. We assume D(1) < D(2).
+*
+* Z (input) DOUBLE PRECISION array, dimension (2)
+* The components of the updating vector.
+*
+* DELTA (output) DOUBLE PRECISION array, dimension (2)
+* The vector DELTA contains the information necessary
+* to construct the eigenvectors.
+*
+* RHO (input) DOUBLE PRECISION
+* The scalar in the symmetric updating formula.
+*
+* DLAM (output) DOUBLE PRECISION
+* The computed lambda_I, the I-th updated eigenvalue.
+*
+* Further Details
+* ===============
+*
+* Based on contributions by
+* Ren-Cang Li, Computer Science Division, University of California
+* at Berkeley, USA
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE, TWO, FOUR
+ PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0,
+ $ FOUR = 4.0D0 )
+* ..
+* .. Local Scalars ..
+ DOUBLE PRECISION B, C, DEL, TAU, TEMP, W
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, SQRT
+* ..
+* .. Executable Statements ..
+*
+ DEL = D( 2 ) - D( 1 )
+ IF( I.EQ.1 ) THEN
+ W = ONE + TWO*RHO*( Z( 2 )*Z( 2 )-Z( 1 )*Z( 1 ) ) / DEL
+ IF( W.GT.ZERO ) THEN
+ B = DEL + RHO*( Z( 1 )*Z( 1 )+Z( 2 )*Z( 2 ) )
+ C = RHO*Z( 1 )*Z( 1 )*DEL
+*
+* B > ZERO, always
+*
+ TAU = TWO*C / ( B+SQRT( ABS( B*B-FOUR*C ) ) )
+ DLAM = D( 1 ) + TAU
+ DELTA( 1 ) = -Z( 1 ) / TAU
+ DELTA( 2 ) = Z( 2 ) / ( DEL-TAU )
+ ELSE
+ B = -DEL + RHO*( Z( 1 )*Z( 1 )+Z( 2 )*Z( 2 ) )
+ C = RHO*Z( 2 )*Z( 2 )*DEL
+ IF( B.GT.ZERO ) THEN
+ TAU = -TWO*C / ( B+SQRT( B*B+FOUR*C ) )
+ ELSE
+ TAU = ( B-SQRT( B*B+FOUR*C ) ) / TWO
+ END IF
+ DLAM = D( 2 ) + TAU
+ DELTA( 1 ) = -Z( 1 ) / ( DEL+TAU )
+ DELTA( 2 ) = -Z( 2 ) / TAU
+ END IF
+ TEMP = SQRT( DELTA( 1 )*DELTA( 1 )+DELTA( 2 )*DELTA( 2 ) )
+ DELTA( 1 ) = DELTA( 1 ) / TEMP
+ DELTA( 2 ) = DELTA( 2 ) / TEMP
+ ELSE
+*
+* Now I=2
+*
+ B = -DEL + RHO*( Z( 1 )*Z( 1 )+Z( 2 )*Z( 2 ) )
+ C = RHO*Z( 2 )*Z( 2 )*DEL
+ IF( B.GT.ZERO ) THEN
+ TAU = ( B+SQRT( B*B+FOUR*C ) ) / TWO
+ ELSE
+ TAU = TWO*C / ( -B+SQRT( B*B+FOUR*C ) )
+ END IF
+ DLAM = D( 2 ) + TAU
+ DELTA( 1 ) = -Z( 1 ) / ( DEL+TAU )
+ DELTA( 2 ) = -Z( 2 ) / TAU
+ TEMP = SQRT( DELTA( 1 )*DELTA( 1 )+DELTA( 2 )*DELTA( 2 ) )
+ DELTA( 1 ) = DELTA( 1 ) / TEMP
+ DELTA( 2 ) = DELTA( 2 ) / TEMP
+ END IF
+ RETURN
+*
+* End OF DLAED5
+*
+ END
+ SUBROUTINE DLAED6( KNITER, ORGATI, RHO, D, Z, FINIT, TAU, INFO )
+*
+* -- LAPACK routine (version 3.1.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* February 2007
+*
+* .. Scalar Arguments ..
+ LOGICAL ORGATI
+ INTEGER INFO, KNITER
+ DOUBLE PRECISION FINIT, RHO, TAU
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION D( 3 ), Z( 3 )
+* ..
+*
+* Purpose
+* =======
+*
+* DLAED6 computes the positive or negative root (closest to the origin)
+* of
+* z(1) z(2) z(3)
+* f(x) = rho + --------- + ---------- + ---------
+* d(1)-x d(2)-x d(3)-x
+*
+* It is assumed that
+*
+* if ORGATI = .true. the root is between d(2) and d(3);
+* otherwise it is between d(1) and d(2)
+*
+* This routine will be called by DLAED4 when necessary. In most cases,
+* the root sought is the smallest in magnitude, though it might not be
+* in some extremely rare situations.
+*
+* Arguments
+* =========
+*
+* KNITER (input) INTEGER
+* Refer to DLAED4 for its significance.
+*
+* ORGATI (input) LOGICAL
+* If ORGATI is true, the needed root is between d(2) and
+* d(3); otherwise it is between d(1) and d(2). See
+* DLAED4 for further details.
+*
+* RHO (input) DOUBLE PRECISION
+* Refer to the equation f(x) above.
+*
+* D (input) DOUBLE PRECISION array, dimension (3)
+* D satisfies d(1) < d(2) < d(3).
+*
+* Z (input) DOUBLE PRECISION array, dimension (3)
+* Each of the elements in z must be positive.
+*
+* FINIT (input) DOUBLE PRECISION
+* The value of f at 0. It is more accurate than the one
+* evaluated inside this routine (if someone wants to do
+* so).
+*
+* TAU (output) DOUBLE PRECISION
+* The root of the equation f(x).
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* > 0: if INFO = 1, failure to converge
+*
+* Further Details
+* ===============
+*
+* 30/06/99: Based on contributions by
+* Ren-Cang Li, Computer Science Division, University of California
+* at Berkeley, USA
+*
+* 10/02/03: This version has a few statements commented out for thread
+* safety (machine parameters are computed on each entry). SJH.
+*
+* 05/10/06: Modified from a new version of Ren-Cang Li, use
+* Gragg-Thornton-Warner cubic convergent scheme for better stability.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ INTEGER MAXIT
+ PARAMETER ( MAXIT = 40 )
+ DOUBLE PRECISION ZERO, ONE, TWO, THREE, FOUR, EIGHT
+ PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0,
+ $ THREE = 3.0D0, FOUR = 4.0D0, EIGHT = 8.0D0 )
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DLAMCH
+ EXTERNAL DLAMCH
+* ..
+* .. Local Arrays ..
+ DOUBLE PRECISION DSCALE( 3 ), ZSCALE( 3 )
+* ..
+* .. Local Scalars ..
+ LOGICAL SCALE
+ INTEGER I, ITER, NITER
+ DOUBLE PRECISION A, B, BASE, C, DDF, DF, EPS, ERRETM, ETA, F,
+ $ FC, SCLFAC, SCLINV, SMALL1, SMALL2, SMINV1,
+ $ SMINV2, TEMP, TEMP1, TEMP2, TEMP3, TEMP4,
+ $ LBD, UBD
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, INT, LOG, MAX, MIN, SQRT
+* ..
+* .. Executable Statements ..
+*
+ INFO = 0
+*
+ IF( ORGATI ) THEN
+ LBD = D(2)
+ UBD = D(3)
+ ELSE
+ LBD = D(1)
+ UBD = D(2)
+ END IF
+ IF( FINIT .LT. ZERO )THEN
+ LBD = ZERO
+ ELSE
+ UBD = ZERO
+ END IF
+*
+ NITER = 1
+ TAU = ZERO
+ IF( KNITER.EQ.2 ) THEN
+ IF( ORGATI ) THEN
+ TEMP = ( D( 3 )-D( 2 ) ) / TWO
+ C = RHO + Z( 1 ) / ( ( D( 1 )-D( 2 ) )-TEMP )
+ A = C*( D( 2 )+D( 3 ) ) + Z( 2 ) + Z( 3 )
+ B = C*D( 2 )*D( 3 ) + Z( 2 )*D( 3 ) + Z( 3 )*D( 2 )
+ ELSE
+ TEMP = ( D( 1 )-D( 2 ) ) / TWO
+ C = RHO + Z( 3 ) / ( ( D( 3 )-D( 2 ) )-TEMP )
+ A = C*( D( 1 )+D( 2 ) ) + Z( 1 ) + Z( 2 )
+ B = C*D( 1 )*D( 2 ) + Z( 1 )*D( 2 ) + Z( 2 )*D( 1 )
+ END IF
+ TEMP = MAX( ABS( A ), ABS( B ), ABS( C ) )
+ A = A / TEMP
+ B = B / TEMP
+ C = C / TEMP
+ IF( C.EQ.ZERO ) THEN
+ TAU = B / A
+ ELSE IF( A.LE.ZERO ) THEN
+ TAU = ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C )
+ ELSE
+ TAU = TWO*B / ( A+SQRT( ABS( A*A-FOUR*B*C ) ) )
+ END IF
+ IF( TAU .LT. LBD .OR. TAU .GT. UBD )
+ $ TAU = ( LBD+UBD )/TWO
+ IF( D(1).EQ.TAU .OR. D(2).EQ.TAU .OR. D(3).EQ.TAU ) THEN
+ TAU = ZERO
+ ELSE
+ TEMP = FINIT + TAU*Z(1)/( D(1)*( D( 1 )-TAU ) ) +
+ $ TAU*Z(2)/( D(2)*( D( 2 )-TAU ) ) +
+ $ TAU*Z(3)/( D(3)*( D( 3 )-TAU ) )
+ IF( TEMP .LE. ZERO )THEN
+ LBD = TAU
+ ELSE
+ UBD = TAU
+ END IF
+ IF( ABS( FINIT ).LE.ABS( TEMP ) )
+ $ TAU = ZERO
+ END IF
+ END IF
+*
+* get machine parameters for possible scaling to avoid overflow
+*
+* modified by Sven: parameters SMALL1, SMINV1, SMALL2,
+* SMINV2, EPS are not SAVEd anymore between one call to the
+* others but recomputed at each call
+*
+ EPS = DLAMCH( 'Epsilon' )
+ BASE = DLAMCH( 'Base' )
+ SMALL1 = BASE**( INT( LOG( DLAMCH( 'SafMin' ) ) / LOG( BASE ) /
+ $ THREE ) )
+ SMINV1 = ONE / SMALL1
+ SMALL2 = SMALL1*SMALL1
+ SMINV2 = SMINV1*SMINV1
+*
+* Determine if scaling of inputs necessary to avoid overflow
+* when computing 1/TEMP**3
+*
+ IF( ORGATI ) THEN
+ TEMP = MIN( ABS( D( 2 )-TAU ), ABS( D( 3 )-TAU ) )
+ ELSE
+ TEMP = MIN( ABS( D( 1 )-TAU ), ABS( D( 2 )-TAU ) )
+ END IF
+ SCALE = .FALSE.
+ IF( TEMP.LE.SMALL1 ) THEN
+ SCALE = .TRUE.
+ IF( TEMP.LE.SMALL2 ) THEN
+*
+* Scale up by power of radix nearest 1/SAFMIN**(2/3)
+*
+ SCLFAC = SMINV2
+ SCLINV = SMALL2
+ ELSE
+*
+* Scale up by power of radix nearest 1/SAFMIN**(1/3)
+*
+ SCLFAC = SMINV1
+ SCLINV = SMALL1
+ END IF
+*
+* Scaling up safe because D, Z, TAU scaled elsewhere to be O(1)
+*
+ DO 10 I = 1, 3
+ DSCALE( I ) = D( I )*SCLFAC
+ ZSCALE( I ) = Z( I )*SCLFAC
+ 10 CONTINUE
+ TAU = TAU*SCLFAC
+ LBD = LBD*SCLFAC
+ UBD = UBD*SCLFAC
+ ELSE
+*
+* Copy D and Z to DSCALE and ZSCALE
+*
+ DO 20 I = 1, 3
+ DSCALE( I ) = D( I )
+ ZSCALE( I ) = Z( I )
+ 20 CONTINUE
+ END IF
+*
+ FC = ZERO
+ DF = ZERO
+ DDF = ZERO
+ DO 30 I = 1, 3
+ TEMP = ONE / ( DSCALE( I )-TAU )
+ TEMP1 = ZSCALE( I )*TEMP
+ TEMP2 = TEMP1*TEMP
+ TEMP3 = TEMP2*TEMP
+ FC = FC + TEMP1 / DSCALE( I )
+ DF = DF + TEMP2
+ DDF = DDF + TEMP3
+ 30 CONTINUE
+ F = FINIT + TAU*FC
+*
+ IF( ABS( F ).LE.ZERO )
+ $ GO TO 60
+ IF( F .LE. ZERO )THEN
+ LBD = TAU
+ ELSE
+ UBD = TAU
+ END IF
+*
+* Iteration begins -- Use Gragg-Thornton-Warner cubic convergent
+* scheme
+*
+* It is not hard to see that
+*
+* 1) Iterations will go up monotonically
+* if FINIT < 0;
+*
+* 2) Iterations will go down monotonically
+* if FINIT > 0.
+*
+ ITER = NITER + 1
+*
+ DO 50 NITER = ITER, MAXIT
+*
+ IF( ORGATI ) THEN
+ TEMP1 = DSCALE( 2 ) - TAU
+ TEMP2 = DSCALE( 3 ) - TAU
+ ELSE
+ TEMP1 = DSCALE( 1 ) - TAU
+ TEMP2 = DSCALE( 2 ) - TAU
+ END IF
+ A = ( TEMP1+TEMP2 )*F - TEMP1*TEMP2*DF
+ B = TEMP1*TEMP2*F
+ C = F - ( TEMP1+TEMP2 )*DF + TEMP1*TEMP2*DDF
+ TEMP = MAX( ABS( A ), ABS( B ), ABS( C ) )
+ A = A / TEMP
+ B = B / TEMP
+ C = C / TEMP
+ IF( C.EQ.ZERO ) THEN
+ ETA = B / A
+ ELSE IF( A.LE.ZERO ) THEN
+ ETA = ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C )
+ ELSE
+ ETA = TWO*B / ( A+SQRT( ABS( A*A-FOUR*B*C ) ) )
+ END IF
+ IF( F*ETA.GE.ZERO ) THEN
+ ETA = -F / DF
+ END IF
+*
+ TAU = TAU + ETA
+ IF( TAU .LT. LBD .OR. TAU .GT. UBD )
+ $ TAU = ( LBD + UBD )/TWO
+*
+ FC = ZERO
+ ERRETM = ZERO
+ DF = ZERO
+ DDF = ZERO
+ DO 40 I = 1, 3
+ TEMP = ONE / ( DSCALE( I )-TAU )
+ TEMP1 = ZSCALE( I )*TEMP
+ TEMP2 = TEMP1*TEMP
+ TEMP3 = TEMP2*TEMP
+ TEMP4 = TEMP1 / DSCALE( I )
+ FC = FC + TEMP4
+ ERRETM = ERRETM + ABS( TEMP4 )
+ DF = DF + TEMP2
+ DDF = DDF + TEMP3
+ 40 CONTINUE
+ F = FINIT + TAU*FC
+ ERRETM = EIGHT*( ABS( FINIT )+ABS( TAU )*ERRETM ) +
+ $ ABS( TAU )*DF
+ IF( ABS( F ).LE.EPS*ERRETM )
+ $ GO TO 60
+ IF( F .LE. ZERO )THEN
+ LBD = TAU
+ ELSE
+ UBD = TAU
+ END IF
+ 50 CONTINUE
+ INFO = 1
+ 60 CONTINUE
+*
+* Undo scaling
+*
+ IF( SCALE )
+ $ TAU = TAU*SCLINV
+ RETURN
+*
+* End of DLAED6
+*
+ END
+ SUBROUTINE DLAED7( ICOMPQ, N, QSIZ, TLVLS, CURLVL, CURPBM, D, Q,
+ $ LDQ, INDXQ, RHO, CUTPNT, QSTORE, QPTR, PRMPTR,
+ $ PERM, GIVPTR, GIVCOL, GIVNUM, WORK, IWORK,
+ $ INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER CURLVL, CURPBM, CUTPNT, ICOMPQ, INFO, LDQ, N,
+ $ QSIZ, TLVLS
+ DOUBLE PRECISION RHO
+* ..
+* .. Array Arguments ..
+ INTEGER GIVCOL( 2, * ), GIVPTR( * ), INDXQ( * ),
+ $ IWORK( * ), PERM( * ), PRMPTR( * ), QPTR( * )
+ DOUBLE PRECISION D( * ), GIVNUM( 2, * ), Q( LDQ, * ),
+ $ QSTORE( * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DLAED7 computes the updated eigensystem of a diagonal
+* matrix after modification by a rank-one symmetric matrix. This
+* routine is used only for the eigenproblem which requires all
+* eigenvalues and optionally eigenvectors of a dense symmetric matrix
+* that has been reduced to tridiagonal form. DLAED1 handles
+* the case in which all eigenvalues and eigenvectors of a symmetric
+* tridiagonal matrix are desired.
+*
+* T = Q(in) ( D(in) + RHO * Z*Z' ) Q'(in) = Q(out) * D(out) * Q'(out)
+*
+* where Z = Q'u, u is a vector of length N with ones in the
+* CUTPNT and CUTPNT + 1 th elements and zeros elsewhere.
+*
+* The eigenvectors of the original matrix are stored in Q, and the
+* eigenvalues are in D. The algorithm consists of three stages:
+*
+* The first stage consists of deflating the size of the problem
+* when there are multiple eigenvalues or if there is a zero in
+* the Z vector. For each such occurence the dimension of the
+* secular equation problem is reduced by one. This stage is
+* performed by the routine DLAED8.
+*
+* The second stage consists of calculating the updated
+* eigenvalues. This is done by finding the roots of the secular
+* equation via the routine DLAED4 (as called by DLAED9).
+* This routine also calculates the eigenvectors of the current
+* problem.
+*
+* The final stage consists of computing the updated eigenvectors
+* directly using the updated eigenvalues. The eigenvectors for
+* the current problem are multiplied with the eigenvectors from
+* the overall problem.
+*
+* Arguments
+* =========
+*
+* ICOMPQ (input) INTEGER
+* = 0: Compute eigenvalues only.
+* = 1: Compute eigenvectors of original dense symmetric matrix
+* also. On entry, Q contains the orthogonal matrix used
+* to reduce the original matrix to tridiagonal form.
+*
+* N (input) INTEGER
+* The dimension of the symmetric tridiagonal matrix. N >= 0.
+*
+* QSIZ (input) INTEGER
+* The dimension of the orthogonal matrix used to reduce
+* the full matrix to tridiagonal form. QSIZ >= N if ICOMPQ = 1.
+*
+* TLVLS (input) INTEGER
+* The total number of merging levels in the overall divide and
+* conquer tree.
+*
+* CURLVL (input) INTEGER
+* The current level in the overall merge routine,
+* 0 <= CURLVL <= TLVLS.
+*
+* CURPBM (input) INTEGER
+* The current problem in the current level in the overall
+* merge routine (counting from upper left to lower right).
+*
+* D (input/output) DOUBLE PRECISION array, dimension (N)
+* On entry, the eigenvalues of the rank-1-perturbed matrix.
+* On exit, the eigenvalues of the repaired matrix.
+*
+* Q (input/output) DOUBLE PRECISION array, dimension (LDQ, N)
+* On entry, the eigenvectors of the rank-1-perturbed matrix.
+* On exit, the eigenvectors of the repaired tridiagonal matrix.
+*
+* LDQ (input) INTEGER
+* The leading dimension of the array Q. LDQ >= max(1,N).
+*
+* INDXQ (output) INTEGER array, dimension (N)
+* The permutation which will reintegrate the subproblem just
+* solved back into sorted order, i.e., D( INDXQ( I = 1, N ) )
+* will be in ascending order.
+*
+* RHO (input) DOUBLE PRECISION
+* The subdiagonal element used to create the rank-1
+* modification.
+*
+* CUTPNT (input) INTEGER
+* Contains the location of the last eigenvalue in the leading
+* sub-matrix. min(1,N) <= CUTPNT <= N.
+*
+* QSTORE (input/output) DOUBLE PRECISION array, dimension (N**2+1)
+* Stores eigenvectors of submatrices encountered during
+* divide and conquer, packed together. QPTR points to
+* beginning of the submatrices.
+*
+* QPTR (input/output) INTEGER array, dimension (N+2)
+* List of indices pointing to beginning of submatrices stored
+* in QSTORE. The submatrices are numbered starting at the
+* bottom left of the divide and conquer tree, from left to
+* right and bottom to top.
+*
+* PRMPTR (input) INTEGER array, dimension (N lg N)
+* Contains a list of pointers which indicate where in PERM a
+* level's permutation is stored. PRMPTR(i+1) - PRMPTR(i)
+* indicates the size of the permutation and also the size of
+* the full, non-deflated problem.
+*
+* PERM (input) INTEGER array, dimension (N lg N)
+* Contains the permutations (from deflation and sorting) to be
+* applied to each eigenblock.
+*
+* GIVPTR (input) INTEGER array, dimension (N lg N)
+* Contains a list of pointers which indicate where in GIVCOL a
+* level's Givens rotations are stored. GIVPTR(i+1) - GIVPTR(i)
+* indicates the number of Givens rotations.
+*
+* GIVCOL (input) INTEGER array, dimension (2, N lg N)
+* Each pair of numbers indicates a pair of columns to take place
+* in a Givens rotation.
+*
+* GIVNUM (input) DOUBLE PRECISION array, dimension (2, N lg N)
+* Each number indicates the S value to be used in the
+* corresponding Givens rotation.
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (3*N+QSIZ*N)
+*
+* IWORK (workspace) INTEGER array, dimension (4*N)
+*
+* INFO (output) INTEGER
+* = 0: successful exit.
+* < 0: if INFO = -i, the i-th argument had an illegal value.
+* > 0: if INFO = 1, an eigenvalue did not converge
+*
+* Further Details
+* ===============
+*
+* Based on contributions by
+* Jeff Rutter, Computer Science Division, University of California
+* at Berkeley, USA
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE, ZERO
+ PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0 )
+* ..
+* .. Local Scalars ..
+ INTEGER COLTYP, CURR, I, IDLMDA, INDX, INDXC, INDXP,
+ $ IQ2, IS, IW, IZ, K, LDQ2, N1, N2, PTR
+* ..
+* .. External Subroutines ..
+ EXTERNAL DGEMM, DLAED8, DLAED9, DLAEDA, DLAMRG, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+*
+ IF( ICOMPQ.LT.0 .OR. ICOMPQ.GT.1 ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( ICOMPQ.EQ.1 .AND. QSIZ.LT.N ) THEN
+ INFO = -4
+ ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN
+ INFO = -9
+ ELSE IF( MIN( 1, N ).GT.CUTPNT .OR. N.LT.CUTPNT ) THEN
+ INFO = -12
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DLAED7', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+* The following values are for bookkeeping purposes only. They are
+* integer pointers which indicate the portion of the workspace
+* used by a particular array in DLAED8 and DLAED9.
+*
+ IF( ICOMPQ.EQ.1 ) THEN
+ LDQ2 = QSIZ
+ ELSE
+ LDQ2 = N
+ END IF
+*
+ IZ = 1
+ IDLMDA = IZ + N
+ IW = IDLMDA + N
+ IQ2 = IW + N
+ IS = IQ2 + N*LDQ2
+*
+ INDX = 1
+ INDXC = INDX + N
+ COLTYP = INDXC + N
+ INDXP = COLTYP + N
+*
+* Form the z-vector which consists of the last row of Q_1 and the
+* first row of Q_2.
+*
+ PTR = 1 + 2**TLVLS
+ DO 10 I = 1, CURLVL - 1
+ PTR = PTR + 2**( TLVLS-I )
+ 10 CONTINUE
+ CURR = PTR + CURPBM
+ CALL DLAEDA( N, TLVLS, CURLVL, CURPBM, PRMPTR, PERM, GIVPTR,
+ $ GIVCOL, GIVNUM, QSTORE, QPTR, WORK( IZ ),
+ $ WORK( IZ+N ), INFO )
+*
+* When solving the final problem, we no longer need the stored data,
+* so we will overwrite the data from this level onto the previously
+* used storage space.
+*
+ IF( CURLVL.EQ.TLVLS ) THEN
+ QPTR( CURR ) = 1
+ PRMPTR( CURR ) = 1
+ GIVPTR( CURR ) = 1
+ END IF
+*
+* Sort and Deflate eigenvalues.
+*
+ CALL DLAED8( ICOMPQ, K, N, QSIZ, D, Q, LDQ, INDXQ, RHO, CUTPNT,
+ $ WORK( IZ ), WORK( IDLMDA ), WORK( IQ2 ), LDQ2,
+ $ WORK( IW ), PERM( PRMPTR( CURR ) ), GIVPTR( CURR+1 ),
+ $ GIVCOL( 1, GIVPTR( CURR ) ),
+ $ GIVNUM( 1, GIVPTR( CURR ) ), IWORK( INDXP ),
+ $ IWORK( INDX ), INFO )
+ PRMPTR( CURR+1 ) = PRMPTR( CURR ) + N
+ GIVPTR( CURR+1 ) = GIVPTR( CURR+1 ) + GIVPTR( CURR )
+*
+* Solve Secular Equation.
+*
+ IF( K.NE.0 ) THEN
+ CALL DLAED9( K, 1, K, N, D, WORK( IS ), K, RHO, WORK( IDLMDA ),
+ $ WORK( IW ), QSTORE( QPTR( CURR ) ), K, INFO )
+ IF( INFO.NE.0 )
+ $ GO TO 30
+ IF( ICOMPQ.EQ.1 ) THEN
+ CALL DGEMM( 'N', 'N', QSIZ, K, K, ONE, WORK( IQ2 ), LDQ2,
+ $ QSTORE( QPTR( CURR ) ), K, ZERO, Q, LDQ )
+ END IF
+ QPTR( CURR+1 ) = QPTR( CURR ) + K**2
+*
+* Prepare the INDXQ sorting permutation.
+*
+ N1 = K
+ N2 = N - K
+ CALL DLAMRG( N1, N2, D, 1, -1, INDXQ )
+ ELSE
+ QPTR( CURR+1 ) = QPTR( CURR )
+ DO 20 I = 1, N
+ INDXQ( I ) = I
+ 20 CONTINUE
+ END IF
+*
+ 30 CONTINUE
+ RETURN
+*
+* End of DLAED7
+*
+ END
+ SUBROUTINE DLAED8( ICOMPQ, K, N, QSIZ, D, Q, LDQ, INDXQ, RHO,
+ $ CUTPNT, Z, DLAMDA, Q2, LDQ2, W, PERM, GIVPTR,
+ $ GIVCOL, GIVNUM, INDXP, INDX, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER CUTPNT, GIVPTR, ICOMPQ, INFO, K, LDQ, LDQ2, N,
+ $ QSIZ
+ DOUBLE PRECISION RHO
+* ..
+* .. Array Arguments ..
+ INTEGER GIVCOL( 2, * ), INDX( * ), INDXP( * ),
+ $ INDXQ( * ), PERM( * )
+ DOUBLE PRECISION D( * ), DLAMDA( * ), GIVNUM( 2, * ),
+ $ Q( LDQ, * ), Q2( LDQ2, * ), W( * ), Z( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DLAED8 merges the two sets of eigenvalues together into a single
+* sorted set. Then it tries to deflate the size of the problem.
+* There are two ways in which deflation can occur: when two or more
+* eigenvalues are close together or if there is a tiny element in the
+* Z vector. For each such occurrence the order of the related secular
+* equation problem is reduced by one.
+*
+* Arguments
+* =========
+*
+* ICOMPQ (input) INTEGER
+* = 0: Compute eigenvalues only.
+* = 1: Compute eigenvectors of original dense symmetric matrix
+* also. On entry, Q contains the orthogonal matrix used
+* to reduce the original matrix to tridiagonal form.
+*
+* K (output) INTEGER
+* The number of non-deflated eigenvalues, and the order of the
+* related secular equation.
+*
+* N (input) INTEGER
+* The dimension of the symmetric tridiagonal matrix. N >= 0.
+*
+* QSIZ (input) INTEGER
+* The dimension of the orthogonal matrix used to reduce
+* the full matrix to tridiagonal form. QSIZ >= N if ICOMPQ = 1.
+*
+* D (input/output) DOUBLE PRECISION array, dimension (N)
+* On entry, the eigenvalues of the two submatrices to be
+* combined. On exit, the trailing (N-K) updated eigenvalues
+* (those which were deflated) sorted into increasing order.
+*
+* Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N)
+* If ICOMPQ = 0, Q is not referenced. Otherwise,
+* on entry, Q contains the eigenvectors of the partially solved
+* system which has been previously updated in matrix
+* multiplies with other partially solved eigensystems.
+* On exit, Q contains the trailing (N-K) updated eigenvectors
+* (those which were deflated) in its last N-K columns.
+*
+* LDQ (input) INTEGER
+* The leading dimension of the array Q. LDQ >= max(1,N).
+*
+* INDXQ (input) INTEGER array, dimension (N)
+* The permutation which separately sorts the two sub-problems
+* in D into ascending order. Note that elements in the second
+* half of this permutation must first have CUTPNT added to
+* their values in order to be accurate.
+*
+* RHO (input/output) DOUBLE PRECISION
+* On entry, the off-diagonal element associated with the rank-1
+* cut which originally split the two submatrices which are now
+* being recombined.
+* On exit, RHO has been modified to the value required by
+* DLAED3.
+*
+* CUTPNT (input) INTEGER
+* The location of the last eigenvalue in the leading
+* sub-matrix. min(1,N) <= CUTPNT <= N.
+*
+* Z (input) DOUBLE PRECISION array, dimension (N)
+* On entry, Z contains the updating vector (the last row of
+* the first sub-eigenvector matrix and the first row of the
+* second sub-eigenvector matrix).
+* On exit, the contents of Z are destroyed by the updating
+* process.
+*
+* DLAMDA (output) DOUBLE PRECISION array, dimension (N)
+* A copy of the first K eigenvalues which will be used by
+* DLAED3 to form the secular equation.
+*
+* Q2 (output) DOUBLE PRECISION array, dimension (LDQ2,N)
+* If ICOMPQ = 0, Q2 is not referenced. Otherwise,
+* a copy of the first K eigenvectors which will be used by
+* DLAED7 in a matrix multiply (DGEMM) to update the new
+* eigenvectors.
+*
+* LDQ2 (input) INTEGER
+* The leading dimension of the array Q2. LDQ2 >= max(1,N).
+*
+* W (output) DOUBLE PRECISION array, dimension (N)
+* The first k values of the final deflation-altered z-vector and
+* will be passed to DLAED3.
+*
+* PERM (output) INTEGER array, dimension (N)
+* The permutations (from deflation and sorting) to be applied
+* to each eigenblock.
+*
+* GIVPTR (output) INTEGER
+* The number of Givens rotations which took place in this
+* subproblem.
+*
+* GIVCOL (output) INTEGER array, dimension (2, N)
+* Each pair of numbers indicates a pair of columns to take place
+* in a Givens rotation.
+*
+* GIVNUM (output) DOUBLE PRECISION array, dimension (2, N)
+* Each number indicates the S value to be used in the
+* corresponding Givens rotation.
+*
+* INDXP (workspace) INTEGER array, dimension (N)
+* The permutation used to place deflated values of D at the end
+* of the array. INDXP(1:K) points to the nondeflated D-values
+* and INDXP(K+1:N) points to the deflated eigenvalues.
+*
+* INDX (workspace) INTEGER array, dimension (N)
+* The permutation used to sort the contents of D into ascending
+* order.
+*
+* INFO (output) INTEGER
+* = 0: successful exit.
+* < 0: if INFO = -i, the i-th argument had an illegal value.
+*
+* Further Details
+* ===============
+*
+* Based on contributions by
+* Jeff Rutter, Computer Science Division, University of California
+* at Berkeley, USA
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION MONE, ZERO, ONE, TWO, EIGHT
+ PARAMETER ( MONE = -1.0D0, ZERO = 0.0D0, ONE = 1.0D0,
+ $ TWO = 2.0D0, EIGHT = 8.0D0 )
+* ..
+* .. Local Scalars ..
+*
+ INTEGER I, IMAX, J, JLAM, JMAX, JP, K2, N1, N1P1, N2
+ DOUBLE PRECISION C, EPS, S, T, TAU, TOL
+* ..
+* .. External Functions ..
+ INTEGER IDAMAX
+ DOUBLE PRECISION DLAMCH, DLAPY2
+ EXTERNAL IDAMAX, DLAMCH, DLAPY2
+* ..
+* .. External Subroutines ..
+ EXTERNAL DCOPY, DLACPY, DLAMRG, DROT, DSCAL, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, MIN, SQRT
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+*
+ IF( ICOMPQ.LT.0 .OR. ICOMPQ.GT.1 ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( ICOMPQ.EQ.1 .AND. QSIZ.LT.N ) THEN
+ INFO = -4
+ ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN
+ INFO = -7
+ ELSE IF( CUTPNT.LT.MIN( 1, N ) .OR. CUTPNT.GT.N ) THEN
+ INFO = -10
+ ELSE IF( LDQ2.LT.MAX( 1, N ) ) THEN
+ INFO = -14
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DLAED8', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+ N1 = CUTPNT
+ N2 = N - N1
+ N1P1 = N1 + 1
+*
+ IF( RHO.LT.ZERO ) THEN
+ CALL DSCAL( N2, MONE, Z( N1P1 ), 1 )
+ END IF
+*
+* Normalize z so that norm(z) = 1
+*
+ T = ONE / SQRT( TWO )
+ DO 10 J = 1, N
+ INDX( J ) = J
+ 10 CONTINUE
+ CALL DSCAL( N, T, Z, 1 )
+ RHO = ABS( TWO*RHO )
+*
+* Sort the eigenvalues into increasing order
+*
+ DO 20 I = CUTPNT + 1, N
+ INDXQ( I ) = INDXQ( I ) + CUTPNT
+ 20 CONTINUE
+ DO 30 I = 1, N
+ DLAMDA( I ) = D( INDXQ( I ) )
+ W( I ) = Z( INDXQ( I ) )
+ 30 CONTINUE
+ I = 1
+ J = CUTPNT + 1
+ CALL DLAMRG( N1, N2, DLAMDA, 1, 1, INDX )
+ DO 40 I = 1, N
+ D( I ) = DLAMDA( INDX( I ) )
+ Z( I ) = W( INDX( I ) )
+ 40 CONTINUE
+*
+* Calculate the allowable deflation tolerence
+*
+ IMAX = IDAMAX( N, Z, 1 )
+ JMAX = IDAMAX( N, D, 1 )
+ EPS = DLAMCH( 'Epsilon' )
+ TOL = EIGHT*EPS*ABS( D( JMAX ) )
+*
+* If the rank-1 modifier is small enough, no more needs to be done
+* except to reorganize Q so that its columns correspond with the
+* elements in D.
+*
+ IF( RHO*ABS( Z( IMAX ) ).LE.TOL ) THEN
+ K = 0
+ IF( ICOMPQ.EQ.0 ) THEN
+ DO 50 J = 1, N
+ PERM( J ) = INDXQ( INDX( J ) )
+ 50 CONTINUE
+ ELSE
+ DO 60 J = 1, N
+ PERM( J ) = INDXQ( INDX( J ) )
+ CALL DCOPY( QSIZ, Q( 1, PERM( J ) ), 1, Q2( 1, J ), 1 )
+ 60 CONTINUE
+ CALL DLACPY( 'A', QSIZ, N, Q2( 1, 1 ), LDQ2, Q( 1, 1 ),
+ $ LDQ )
+ END IF
+ RETURN
+ END IF
+*
+* If there are multiple eigenvalues then the problem deflates. Here
+* the number of equal eigenvalues are found. As each equal
+* eigenvalue is found, an elementary reflector is computed to rotate
+* the corresponding eigensubspace so that the corresponding
+* components of Z are zero in this new basis.
+*
+ K = 0
+ GIVPTR = 0
+ K2 = N + 1
+ DO 70 J = 1, N
+ IF( RHO*ABS( Z( J ) ).LE.TOL ) THEN
+*
+* Deflate due to small z component.
+*
+ K2 = K2 - 1
+ INDXP( K2 ) = J
+ IF( J.EQ.N )
+ $ GO TO 110
+ ELSE
+ JLAM = J
+ GO TO 80
+ END IF
+ 70 CONTINUE
+ 80 CONTINUE
+ J = J + 1
+ IF( J.GT.N )
+ $ GO TO 100
+ IF( RHO*ABS( Z( J ) ).LE.TOL ) THEN
+*
+* Deflate due to small z component.
+*
+ K2 = K2 - 1
+ INDXP( K2 ) = J
+ ELSE
+*
+* Check if eigenvalues are close enough to allow deflation.
+*
+ S = Z( JLAM )
+ C = Z( J )
+*
+* Find sqrt(a**2+b**2) without overflow or
+* destructive underflow.
+*
+ TAU = DLAPY2( C, S )
+ T = D( J ) - D( JLAM )
+ C = C / TAU
+ S = -S / TAU
+ IF( ABS( T*C*S ).LE.TOL ) THEN
+*
+* Deflation is possible.
+*
+ Z( J ) = TAU
+ Z( JLAM ) = ZERO
+*
+* Record the appropriate Givens rotation
+*
+ GIVPTR = GIVPTR + 1
+ GIVCOL( 1, GIVPTR ) = INDXQ( INDX( JLAM ) )
+ GIVCOL( 2, GIVPTR ) = INDXQ( INDX( J ) )
+ GIVNUM( 1, GIVPTR ) = C
+ GIVNUM( 2, GIVPTR ) = S
+ IF( ICOMPQ.EQ.1 ) THEN
+ CALL DROT( QSIZ, Q( 1, INDXQ( INDX( JLAM ) ) ), 1,
+ $ Q( 1, INDXQ( INDX( J ) ) ), 1, C, S )
+ END IF
+ T = D( JLAM )*C*C + D( J )*S*S
+ D( J ) = D( JLAM )*S*S + D( J )*C*C
+ D( JLAM ) = T
+ K2 = K2 - 1
+ I = 1
+ 90 CONTINUE
+ IF( K2+I.LE.N ) THEN
+ IF( D( JLAM ).LT.D( INDXP( K2+I ) ) ) THEN
+ INDXP( K2+I-1 ) = INDXP( K2+I )
+ INDXP( K2+I ) = JLAM
+ I = I + 1
+ GO TO 90
+ ELSE
+ INDXP( K2+I-1 ) = JLAM
+ END IF
+ ELSE
+ INDXP( K2+I-1 ) = JLAM
+ END IF
+ JLAM = J
+ ELSE
+ K = K + 1
+ W( K ) = Z( JLAM )
+ DLAMDA( K ) = D( JLAM )
+ INDXP( K ) = JLAM
+ JLAM = J
+ END IF
+ END IF
+ GO TO 80
+ 100 CONTINUE
+*
+* Record the last eigenvalue.
+*
+ K = K + 1
+ W( K ) = Z( JLAM )
+ DLAMDA( K ) = D( JLAM )
+ INDXP( K ) = JLAM
+*
+ 110 CONTINUE
+*
+* Sort the eigenvalues and corresponding eigenvectors into DLAMDA
+* and Q2 respectively. The eigenvalues/vectors which were not
+* deflated go into the first K slots of DLAMDA and Q2 respectively,
+* while those which were deflated go into the last N - K slots.
+*
+ IF( ICOMPQ.EQ.0 ) THEN
+ DO 120 J = 1, N
+ JP = INDXP( J )
+ DLAMDA( J ) = D( JP )
+ PERM( J ) = INDXQ( INDX( JP ) )
+ 120 CONTINUE
+ ELSE
+ DO 130 J = 1, N
+ JP = INDXP( J )
+ DLAMDA( J ) = D( JP )
+ PERM( J ) = INDXQ( INDX( JP ) )
+ CALL DCOPY( QSIZ, Q( 1, PERM( J ) ), 1, Q2( 1, J ), 1 )
+ 130 CONTINUE
+ END IF
+*
+* The deflated eigenvalues and their corresponding vectors go back
+* into the last N - K slots of D and Q respectively.
+*
+ IF( K.LT.N ) THEN
+ IF( ICOMPQ.EQ.0 ) THEN
+ CALL DCOPY( N-K, DLAMDA( K+1 ), 1, D( K+1 ), 1 )
+ ELSE
+ CALL DCOPY( N-K, DLAMDA( K+1 ), 1, D( K+1 ), 1 )
+ CALL DLACPY( 'A', QSIZ, N-K, Q2( 1, K+1 ), LDQ2,
+ $ Q( 1, K+1 ), LDQ )
+ END IF
+ END IF
+*
+ RETURN
+*
+* End of DLAED8
+*
+ END
+ SUBROUTINE DLAED9( K, KSTART, KSTOP, N, D, Q, LDQ, RHO, DLAMDA, W,
+ $ S, LDS, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, K, KSTART, KSTOP, LDQ, LDS, N
+ DOUBLE PRECISION RHO
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION D( * ), DLAMDA( * ), Q( LDQ, * ), S( LDS, * ),
+ $ W( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DLAED9 finds the roots of the secular equation, as defined by the
+* values in D, Z, and RHO, between KSTART and KSTOP. It makes the
+* appropriate calls to DLAED4 and then stores the new matrix of
+* eigenvectors for use in calculating the next level of Z vectors.
+*
+* Arguments
+* =========
+*
+* K (input) INTEGER
+* The number of terms in the rational function to be solved by
+* DLAED4. K >= 0.
+*
+* KSTART (input) INTEGER
+* KSTOP (input) INTEGER
+* The updated eigenvalues Lambda(I), KSTART <= I <= KSTOP
+* are to be computed. 1 <= KSTART <= KSTOP <= K.
+*
+* N (input) INTEGER
+* The number of rows and columns in the Q matrix.
+* N >= K (delation may result in N > K).
+*
+* D (output) DOUBLE PRECISION array, dimension (N)
+* D(I) contains the updated eigenvalues
+* for KSTART <= I <= KSTOP.
+*
+* Q (workspace) DOUBLE PRECISION array, dimension (LDQ,N)
+*
+* LDQ (input) INTEGER
+* The leading dimension of the array Q. LDQ >= max( 1, N ).
+*
+* RHO (input) DOUBLE PRECISION
+* The value of the parameter in the rank one update equation.
+* RHO >= 0 required.
+*
+* DLAMDA (input) DOUBLE PRECISION array, dimension (K)
+* The first K elements of this array contain the old roots
+* of the deflated updating problem. These are the poles
+* of the secular equation.
+*
+* W (input) DOUBLE PRECISION array, dimension (K)
+* The first K elements of this array contain the components
+* of the deflation-adjusted updating vector.
+*
+* S (output) DOUBLE PRECISION array, dimension (LDS, K)
+* Will contain the eigenvectors of the repaired matrix which
+* will be stored for subsequent Z vector calculation and
+* multiplied by the previously accumulated eigenvectors
+* to update the system.
+*
+* LDS (input) INTEGER
+* The leading dimension of S. LDS >= max( 1, K ).
+*
+* INFO (output) INTEGER
+* = 0: successful exit.
+* < 0: if INFO = -i, the i-th argument had an illegal value.
+* > 0: if INFO = 1, an eigenvalue did not converge
+*
+* Further Details
+* ===============
+*
+* Based on contributions by
+* Jeff Rutter, Computer Science Division, University of California
+* at Berkeley, USA
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ INTEGER I, J
+ DOUBLE PRECISION TEMP
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DLAMC3, DNRM2
+ EXTERNAL DLAMC3, DNRM2
+* ..
+* .. External Subroutines ..
+ EXTERNAL DCOPY, DLAED4, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, SIGN, SQRT
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+*
+ IF( K.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( KSTART.LT.1 .OR. KSTART.GT.MAX( 1, K ) ) THEN
+ INFO = -2
+ ELSE IF( MAX( 1, KSTOP ).LT.KSTART .OR. KSTOP.GT.MAX( 1, K ) )
+ $ THEN
+ INFO = -3
+ ELSE IF( N.LT.K ) THEN
+ INFO = -4
+ ELSE IF( LDQ.LT.MAX( 1, K ) ) THEN
+ INFO = -7
+ ELSE IF( LDS.LT.MAX( 1, K ) ) THEN
+ INFO = -12
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DLAED9', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( K.EQ.0 )
+ $ RETURN
+*
+* Modify values DLAMDA(i) to make sure all DLAMDA(i)-DLAMDA(j) can
+* be computed with high relative accuracy (barring over/underflow).
+* This is a problem on machines without a guard digit in
+* add/subtract (Cray XMP, Cray YMP, Cray C 90 and Cray 2).
+* The following code replaces DLAMDA(I) by 2*DLAMDA(I)-DLAMDA(I),
+* which on any of these machines zeros out the bottommost
+* bit of DLAMDA(I) if it is 1; this makes the subsequent
+* subtractions DLAMDA(I)-DLAMDA(J) unproblematic when cancellation
+* occurs. On binary machines with a guard digit (almost all
+* machines) it does not change DLAMDA(I) at all. On hexadecimal
+* and decimal machines with a guard digit, it slightly
+* changes the bottommost bits of DLAMDA(I). It does not account
+* for hexadecimal or decimal machines without guard digits
+* (we know of none). We use a subroutine call to compute
+* 2*DLAMBDA(I) to prevent optimizing compilers from eliminating
+* this code.
+*
+ DO 10 I = 1, N
+ DLAMDA( I ) = DLAMC3( DLAMDA( I ), DLAMDA( I ) ) - DLAMDA( I )
+ 10 CONTINUE
+*
+ DO 20 J = KSTART, KSTOP
+ CALL DLAED4( K, J, DLAMDA, W, Q( 1, J ), RHO, D( J ), INFO )
+*
+* If the zero finder fails, the computation is terminated.
+*
+ IF( INFO.NE.0 )
+ $ GO TO 120
+ 20 CONTINUE
+*
+ IF( K.EQ.1 .OR. K.EQ.2 ) THEN
+ DO 40 I = 1, K
+ DO 30 J = 1, K
+ S( J, I ) = Q( J, I )
+ 30 CONTINUE
+ 40 CONTINUE
+ GO TO 120
+ END IF
+*
+* Compute updated W.
+*
+ CALL DCOPY( K, W, 1, S, 1 )
+*
+* Initialize W(I) = Q(I,I)
+*
+ CALL DCOPY( K, Q, LDQ+1, W, 1 )
+ DO 70 J = 1, K
+ DO 50 I = 1, J - 1
+ W( I ) = W( I )*( Q( I, J ) / ( DLAMDA( I )-DLAMDA( J ) ) )
+ 50 CONTINUE
+ DO 60 I = J + 1, K
+ W( I ) = W( I )*( Q( I, J ) / ( DLAMDA( I )-DLAMDA( J ) ) )
+ 60 CONTINUE
+ 70 CONTINUE
+ DO 80 I = 1, K
+ W( I ) = SIGN( SQRT( -W( I ) ), S( I, 1 ) )
+ 80 CONTINUE
+*
+* Compute eigenvectors of the modified rank-1 modification.
+*
+ DO 110 J = 1, K
+ DO 90 I = 1, K
+ Q( I, J ) = W( I ) / Q( I, J )
+ 90 CONTINUE
+ TEMP = DNRM2( K, Q( 1, J ), 1 )
+ DO 100 I = 1, K
+ S( I, J ) = Q( I, J ) / TEMP
+ 100 CONTINUE
+ 110 CONTINUE
+*
+ 120 CONTINUE
+ RETURN
+*
+* End of DLAED9
+*
+ END
+ SUBROUTINE DLAEDA( N, TLVLS, CURLVL, CURPBM, PRMPTR, PERM, GIVPTR,
+ $ GIVCOL, GIVNUM, Q, QPTR, Z, ZTEMP, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER CURLVL, CURPBM, INFO, N, TLVLS
+* ..
+* .. Array Arguments ..
+ INTEGER GIVCOL( 2, * ), GIVPTR( * ), PERM( * ),
+ $ PRMPTR( * ), QPTR( * )
+ DOUBLE PRECISION GIVNUM( 2, * ), Q( * ), Z( * ), ZTEMP( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DLAEDA computes the Z vector corresponding to the merge step in the
+* CURLVLth step of the merge process with TLVLS steps for the CURPBMth
+* problem.
+*
+* Arguments
+* =========
+*
+* N (input) INTEGER
+* The dimension of the symmetric tridiagonal matrix. N >= 0.
+*
+* TLVLS (input) INTEGER
+* The total number of merging levels in the overall divide and
+* conquer tree.
+*
+* CURLVL (input) INTEGER
+* The current level in the overall merge routine,
+* 0 <= curlvl <= tlvls.
+*
+* CURPBM (input) INTEGER
+* The current problem in the current level in the overall
+* merge routine (counting from upper left to lower right).
+*
+* PRMPTR (input) INTEGER array, dimension (N lg N)
+* Contains a list of pointers which indicate where in PERM a
+* level's permutation is stored. PRMPTR(i+1) - PRMPTR(i)
+* indicates the size of the permutation and incidentally the
+* size of the full, non-deflated problem.
+*
+* PERM (input) INTEGER array, dimension (N lg N)
+* Contains the permutations (from deflation and sorting) to be
+* applied to each eigenblock.
+*
+* GIVPTR (input) INTEGER array, dimension (N lg N)
+* Contains a list of pointers which indicate where in GIVCOL a
+* level's Givens rotations are stored. GIVPTR(i+1) - GIVPTR(i)
+* indicates the number of Givens rotations.
+*
+* GIVCOL (input) INTEGER array, dimension (2, N lg N)
+* Each pair of numbers indicates a pair of columns to take place
+* in a Givens rotation.
+*
+* GIVNUM (input) DOUBLE PRECISION array, dimension (2, N lg N)
+* Each number indicates the S value to be used in the
+* corresponding Givens rotation.
+*
+* Q (input) DOUBLE PRECISION array, dimension (N**2)
+* Contains the square eigenblocks from previous levels, the
+* starting positions for blocks are given by QPTR.
+*
+* QPTR (input) INTEGER array, dimension (N+2)
+* Contains a list of pointers which indicate where in Q an
+* eigenblock is stored. SQRT( QPTR(i+1) - QPTR(i) ) indicates
+* the size of the block.
+*
+* Z (output) DOUBLE PRECISION array, dimension (N)
+* On output this vector contains the updating vector (the last
+* row of the first sub-eigenvector matrix and the first row of
+* the second sub-eigenvector matrix).
+*
+* ZTEMP (workspace) DOUBLE PRECISION array, dimension (N)
+*
+* INFO (output) INTEGER
+* = 0: successful exit.
+* < 0: if INFO = -i, the i-th argument had an illegal value.
+*
+* Further Details
+* ===============
+*
+* Based on contributions by
+* Jeff Rutter, Computer Science Division, University of California
+* at Berkeley, USA
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, HALF, ONE
+ PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0 )
+* ..
+* .. Local Scalars ..
+ INTEGER BSIZ1, BSIZ2, CURR, I, K, MID, PSIZ1, PSIZ2,
+ $ PTR, ZPTR1
+* ..
+* .. External Subroutines ..
+ EXTERNAL DCOPY, DGEMV, DROT, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC DBLE, INT, SQRT
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+*
+ IF( N.LT.0 ) THEN
+ INFO = -1
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DLAEDA', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+* Determine location of first number in second half.
+*
+ MID = N / 2 + 1
+*
+* Gather last/first rows of appropriate eigenblocks into center of Z
+*
+ PTR = 1
+*
+* Determine location of lowest level subproblem in the full storage
+* scheme
+*
+ CURR = PTR + CURPBM*2**CURLVL + 2**( CURLVL-1 ) - 1
+*
+* Determine size of these matrices. We add HALF to the value of
+* the SQRT in case the machine underestimates one of these square
+* roots.
+*
+ BSIZ1 = INT( HALF+SQRT( DBLE( QPTR( CURR+1 )-QPTR( CURR ) ) ) )
+ BSIZ2 = INT( HALF+SQRT( DBLE( QPTR( CURR+2 )-QPTR( CURR+1 ) ) ) )
+ DO 10 K = 1, MID - BSIZ1 - 1
+ Z( K ) = ZERO
+ 10 CONTINUE
+ CALL DCOPY( BSIZ1, Q( QPTR( CURR )+BSIZ1-1 ), BSIZ1,
+ $ Z( MID-BSIZ1 ), 1 )
+ CALL DCOPY( BSIZ2, Q( QPTR( CURR+1 ) ), BSIZ2, Z( MID ), 1 )
+ DO 20 K = MID + BSIZ2, N
+ Z( K ) = ZERO
+ 20 CONTINUE
+*
+* Loop thru remaining levels 1 -> CURLVL applying the Givens
+* rotations and permutation and then multiplying the center matrices
+* against the current Z.
+*
+ PTR = 2**TLVLS + 1
+ DO 70 K = 1, CURLVL - 1
+ CURR = PTR + CURPBM*2**( CURLVL-K ) + 2**( CURLVL-K-1 ) - 1
+ PSIZ1 = PRMPTR( CURR+1 ) - PRMPTR( CURR )
+ PSIZ2 = PRMPTR( CURR+2 ) - PRMPTR( CURR+1 )
+ ZPTR1 = MID - PSIZ1
+*
+* Apply Givens at CURR and CURR+1
+*
+ DO 30 I = GIVPTR( CURR ), GIVPTR( CURR+1 ) - 1
+ CALL DROT( 1, Z( ZPTR1+GIVCOL( 1, I )-1 ), 1,
+ $ Z( ZPTR1+GIVCOL( 2, I )-1 ), 1, GIVNUM( 1, I ),
+ $ GIVNUM( 2, I ) )
+ 30 CONTINUE
+ DO 40 I = GIVPTR( CURR+1 ), GIVPTR( CURR+2 ) - 1
+ CALL DROT( 1, Z( MID-1+GIVCOL( 1, I ) ), 1,
+ $ Z( MID-1+GIVCOL( 2, I ) ), 1, GIVNUM( 1, I ),
+ $ GIVNUM( 2, I ) )
+ 40 CONTINUE
+ PSIZ1 = PRMPTR( CURR+1 ) - PRMPTR( CURR )
+ PSIZ2 = PRMPTR( CURR+2 ) - PRMPTR( CURR+1 )
+ DO 50 I = 0, PSIZ1 - 1
+ ZTEMP( I+1 ) = Z( ZPTR1+PERM( PRMPTR( CURR )+I )-1 )
+ 50 CONTINUE
+ DO 60 I = 0, PSIZ2 - 1
+ ZTEMP( PSIZ1+I+1 ) = Z( MID+PERM( PRMPTR( CURR+1 )+I )-1 )
+ 60 CONTINUE
+*
+* Multiply Blocks at CURR and CURR+1
+*
+* Determine size of these matrices. We add HALF to the value of
+* the SQRT in case the machine underestimates one of these
+* square roots.
+*
+ BSIZ1 = INT( HALF+SQRT( DBLE( QPTR( CURR+1 )-QPTR( CURR ) ) ) )
+ BSIZ2 = INT( HALF+SQRT( DBLE( QPTR( CURR+2 )-QPTR( CURR+
+ $ 1 ) ) ) )
+ IF( BSIZ1.GT.0 ) THEN
+ CALL DGEMV( 'T', BSIZ1, BSIZ1, ONE, Q( QPTR( CURR ) ),
+ $ BSIZ1, ZTEMP( 1 ), 1, ZERO, Z( ZPTR1 ), 1 )
+ END IF
+ CALL DCOPY( PSIZ1-BSIZ1, ZTEMP( BSIZ1+1 ), 1, Z( ZPTR1+BSIZ1 ),
+ $ 1 )
+ IF( BSIZ2.GT.0 ) THEN
+ CALL DGEMV( 'T', BSIZ2, BSIZ2, ONE, Q( QPTR( CURR+1 ) ),
+ $ BSIZ2, ZTEMP( PSIZ1+1 ), 1, ZERO, Z( MID ), 1 )
+ END IF
+ CALL DCOPY( PSIZ2-BSIZ2, ZTEMP( PSIZ1+BSIZ2+1 ), 1,
+ $ Z( MID+BSIZ2 ), 1 )
+*
+ PTR = PTR + 2**( TLVLS-K )
+ 70 CONTINUE
+*
+ RETURN
+*
+* End of DLAEDA
+*
+ END
+ SUBROUTINE DLAEIN( RIGHTV, NOINIT, N, H, LDH, WR, WI, VR, VI, B,
+ $ LDB, WORK, EPS3, SMLNUM, BIGNUM, INFO )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ LOGICAL NOINIT, RIGHTV
+ INTEGER INFO, LDB, LDH, N
+ DOUBLE PRECISION BIGNUM, EPS3, SMLNUM, WI, WR
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION B( LDB, * ), H( LDH, * ), VI( * ), VR( * ),
+ $ WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DLAEIN uses inverse iteration to find a right or left eigenvector
+* corresponding to the eigenvalue (WR,WI) of a real upper Hessenberg
+* matrix H.
+*
+* Arguments
+* =========
+*
+* RIGHTV (input) LOGICAL
+* = .TRUE. : compute right eigenvector;
+* = .FALSE.: compute left eigenvector.
+*
+* NOINIT (input) LOGICAL
+* = .TRUE. : no initial vector supplied in (VR,VI).
+* = .FALSE.: initial vector supplied in (VR,VI).
+*
+* N (input) INTEGER
+* The order of the matrix H. N >= 0.
+*
+* H (input) DOUBLE PRECISION array, dimension (LDH,N)
+* The upper Hessenberg matrix H.
+*
+* LDH (input) INTEGER
+* The leading dimension of the array H. LDH >= max(1,N).
+*
+* WR (input) DOUBLE PRECISION
+* WI (input) DOUBLE PRECISION
+* The real and imaginary parts of the eigenvalue of H whose
+* corresponding right or left eigenvector is to be computed.
+*
+* VR (input/output) DOUBLE PRECISION array, dimension (N)
+* VI (input/output) DOUBLE PRECISION array, dimension (N)
+* On entry, if NOINIT = .FALSE. and WI = 0.0, VR must contain
+* a real starting vector for inverse iteration using the real
+* eigenvalue WR; if NOINIT = .FALSE. and WI.ne.0.0, VR and VI
+* must contain the real and imaginary parts of a complex
+* starting vector for inverse iteration using the complex
+* eigenvalue (WR,WI); otherwise VR and VI need not be set.
+* On exit, if WI = 0.0 (real eigenvalue), VR contains the
+* computed real eigenvector; if WI.ne.0.0 (complex eigenvalue),
+* VR and VI contain the real and imaginary parts of the
+* computed complex eigenvector. The eigenvector is normalized
+* so that the component of largest magnitude has magnitude 1;
+* here the magnitude of a complex number (x,y) is taken to be
+* |x| + |y|.
+* VI is not referenced if WI = 0.0.
+*
+* B (workspace) DOUBLE PRECISION array, dimension (LDB,N)
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. LDB >= N+1.
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (N)
+*
+* EPS3 (input) DOUBLE PRECISION
+* A small machine-dependent value which is used to perturb
+* close eigenvalues, and to replace zero pivots.
+*
+* SMLNUM (input) DOUBLE PRECISION
+* A machine-dependent value close to the underflow threshold.
+*
+* BIGNUM (input) DOUBLE PRECISION
+* A machine-dependent value close to the overflow threshold.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* = 1: inverse iteration did not converge; VR is set to the
+* last iterate, and so is VI if WI.ne.0.0.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE, TENTH
+ PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TENTH = 1.0D-1 )
+* ..
+* .. Local Scalars ..
+ CHARACTER NORMIN, TRANS
+ INTEGER I, I1, I2, I3, IERR, ITS, J
+ DOUBLE PRECISION ABSBII, ABSBJJ, EI, EJ, GROWTO, NORM, NRMSML,
+ $ REC, ROOTN, SCALE, TEMP, VCRIT, VMAX, VNORM, W,
+ $ W1, X, XI, XR, Y
+* ..
+* .. External Functions ..
+ INTEGER IDAMAX
+ DOUBLE PRECISION DASUM, DLAPY2, DNRM2
+ EXTERNAL IDAMAX, DASUM, DLAPY2, DNRM2
+* ..
+* .. External Subroutines ..
+ EXTERNAL DLADIV, DLATRS, DSCAL
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, DBLE, MAX, SQRT
+* ..
+* .. Executable Statements ..
+*
+ INFO = 0
+*
+* GROWTO is the threshold used in the acceptance test for an
+* eigenvector.
+*
+ ROOTN = SQRT( DBLE( N ) )
+ GROWTO = TENTH / ROOTN
+ NRMSML = MAX( ONE, EPS3*ROOTN )*SMLNUM
+*
+* Form B = H - (WR,WI)*I (except that the subdiagonal elements and
+* the imaginary parts of the diagonal elements are not stored).
+*
+ DO 20 J = 1, N
+ DO 10 I = 1, J - 1
+ B( I, J ) = H( I, J )
+ 10 CONTINUE
+ B( J, J ) = H( J, J ) - WR
+ 20 CONTINUE
+*
+ IF( WI.EQ.ZERO ) THEN
+*
+* Real eigenvalue.
+*
+ IF( NOINIT ) THEN
+*
+* Set initial vector.
+*
+ DO 30 I = 1, N
+ VR( I ) = EPS3
+ 30 CONTINUE
+ ELSE
+*
+* Scale supplied initial vector.
+*
+ VNORM = DNRM2( N, VR, 1 )
+ CALL DSCAL( N, ( EPS3*ROOTN ) / MAX( VNORM, NRMSML ), VR,
+ $ 1 )
+ END IF
+*
+ IF( RIGHTV ) THEN
+*
+* LU decomposition with partial pivoting of B, replacing zero
+* pivots by EPS3.
+*
+ DO 60 I = 1, N - 1
+ EI = H( I+1, I )
+ IF( ABS( B( I, I ) ).LT.ABS( EI ) ) THEN
+*
+* Interchange rows and eliminate.
+*
+ X = B( I, I ) / EI
+ B( I, I ) = EI
+ DO 40 J = I + 1, N
+ TEMP = B( I+1, J )
+ B( I+1, J ) = B( I, J ) - X*TEMP
+ B( I, J ) = TEMP
+ 40 CONTINUE
+ ELSE
+*
+* Eliminate without interchange.
+*
+ IF( B( I, I ).EQ.ZERO )
+ $ B( I, I ) = EPS3
+ X = EI / B( I, I )
+ IF( X.NE.ZERO ) THEN
+ DO 50 J = I + 1, N
+ B( I+1, J ) = B( I+1, J ) - X*B( I, J )
+ 50 CONTINUE
+ END IF
+ END IF
+ 60 CONTINUE
+ IF( B( N, N ).EQ.ZERO )
+ $ B( N, N ) = EPS3
+*
+ TRANS = 'N'
+*
+ ELSE
+*
+* UL decomposition with partial pivoting of B, replacing zero
+* pivots by EPS3.
+*
+ DO 90 J = N, 2, -1
+ EJ = H( J, J-1 )
+ IF( ABS( B( J, J ) ).LT.ABS( EJ ) ) THEN
+*
+* Interchange columns and eliminate.
+*
+ X = B( J, J ) / EJ
+ B( J, J ) = EJ
+ DO 70 I = 1, J - 1
+ TEMP = B( I, J-1 )
+ B( I, J-1 ) = B( I, J ) - X*TEMP
+ B( I, J ) = TEMP
+ 70 CONTINUE
+ ELSE
+*
+* Eliminate without interchange.
+*
+ IF( B( J, J ).EQ.ZERO )
+ $ B( J, J ) = EPS3
+ X = EJ / B( J, J )
+ IF( X.NE.ZERO ) THEN
+ DO 80 I = 1, J - 1
+ B( I, J-1 ) = B( I, J-1 ) - X*B( I, J )
+ 80 CONTINUE
+ END IF
+ END IF
+ 90 CONTINUE
+ IF( B( 1, 1 ).EQ.ZERO )
+ $ B( 1, 1 ) = EPS3
+*
+ TRANS = 'T'
+*
+ END IF
+*
+ NORMIN = 'N'
+ DO 110 ITS = 1, N
+*
+* Solve U*x = scale*v for a right eigenvector
+* or U'*x = scale*v for a left eigenvector,
+* overwriting x on v.
+*
+ CALL DLATRS( 'Upper', TRANS, 'Nonunit', NORMIN, N, B, LDB,
+ $ VR, SCALE, WORK, IERR )
+ NORMIN = 'Y'
+*
+* Test for sufficient growth in the norm of v.
+*
+ VNORM = DASUM( N, VR, 1 )
+ IF( VNORM.GE.GROWTO*SCALE )
+ $ GO TO 120
+*
+* Choose new orthogonal starting vector and try again.
+*
+ TEMP = EPS3 / ( ROOTN+ONE )
+ VR( 1 ) = EPS3
+ DO 100 I = 2, N
+ VR( I ) = TEMP
+ 100 CONTINUE
+ VR( N-ITS+1 ) = VR( N-ITS+1 ) - EPS3*ROOTN
+ 110 CONTINUE
+*
+* Failure to find eigenvector in N iterations.
+*
+ INFO = 1
+*
+ 120 CONTINUE
+*
+* Normalize eigenvector.
+*
+ I = IDAMAX( N, VR, 1 )
+ CALL DSCAL( N, ONE / ABS( VR( I ) ), VR, 1 )
+ ELSE
+*
+* Complex eigenvalue.
+*
+ IF( NOINIT ) THEN
+*
+* Set initial vector.
+*
+ DO 130 I = 1, N
+ VR( I ) = EPS3
+ VI( I ) = ZERO
+ 130 CONTINUE
+ ELSE
+*
+* Scale supplied initial vector.
+*
+ NORM = DLAPY2( DNRM2( N, VR, 1 ), DNRM2( N, VI, 1 ) )
+ REC = ( EPS3*ROOTN ) / MAX( NORM, NRMSML )
+ CALL DSCAL( N, REC, VR, 1 )
+ CALL DSCAL( N, REC, VI, 1 )
+ END IF
+*
+ IF( RIGHTV ) THEN
+*
+* LU decomposition with partial pivoting of B, replacing zero
+* pivots by EPS3.
+*
+* The imaginary part of the (i,j)-th element of U is stored in
+* B(j+1,i).
+*
+ B( 2, 1 ) = -WI
+ DO 140 I = 2, N
+ B( I+1, 1 ) = ZERO
+ 140 CONTINUE
+*
+ DO 170 I = 1, N - 1
+ ABSBII = DLAPY2( B( I, I ), B( I+1, I ) )
+ EI = H( I+1, I )
+ IF( ABSBII.LT.ABS( EI ) ) THEN
+*
+* Interchange rows and eliminate.
+*
+ XR = B( I, I ) / EI
+ XI = B( I+1, I ) / EI
+ B( I, I ) = EI
+ B( I+1, I ) = ZERO
+ DO 150 J = I + 1, N
+ TEMP = B( I+1, J )
+ B( I+1, J ) = B( I, J ) - XR*TEMP
+ B( J+1, I+1 ) = B( J+1, I ) - XI*TEMP
+ B( I, J ) = TEMP
+ B( J+1, I ) = ZERO
+ 150 CONTINUE
+ B( I+2, I ) = -WI
+ B( I+1, I+1 ) = B( I+1, I+1 ) - XI*WI
+ B( I+2, I+1 ) = B( I+2, I+1 ) + XR*WI
+ ELSE
+*
+* Eliminate without interchanging rows.
+*
+ IF( ABSBII.EQ.ZERO ) THEN
+ B( I, I ) = EPS3
+ B( I+1, I ) = ZERO
+ ABSBII = EPS3
+ END IF
+ EI = ( EI / ABSBII ) / ABSBII
+ XR = B( I, I )*EI
+ XI = -B( I+1, I )*EI
+ DO 160 J = I + 1, N
+ B( I+1, J ) = B( I+1, J ) - XR*B( I, J ) +
+ $ XI*B( J+1, I )
+ B( J+1, I+1 ) = -XR*B( J+1, I ) - XI*B( I, J )
+ 160 CONTINUE
+ B( I+2, I+1 ) = B( I+2, I+1 ) - WI
+ END IF
+*
+* Compute 1-norm of offdiagonal elements of i-th row.
+*
+ WORK( I ) = DASUM( N-I, B( I, I+1 ), LDB ) +
+ $ DASUM( N-I, B( I+2, I ), 1 )
+ 170 CONTINUE
+ IF( B( N, N ).EQ.ZERO .AND. B( N+1, N ).EQ.ZERO )
+ $ B( N, N ) = EPS3
+ WORK( N ) = ZERO
+*
+ I1 = N
+ I2 = 1
+ I3 = -1
+ ELSE
+*
+* UL decomposition with partial pivoting of conjg(B),
+* replacing zero pivots by EPS3.
+*
+* The imaginary part of the (i,j)-th element of U is stored in
+* B(j+1,i).
+*
+ B( N+1, N ) = WI
+ DO 180 J = 1, N - 1
+ B( N+1, J ) = ZERO
+ 180 CONTINUE
+*
+ DO 210 J = N, 2, -1
+ EJ = H( J, J-1 )
+ ABSBJJ = DLAPY2( B( J, J ), B( J+1, J ) )
+ IF( ABSBJJ.LT.ABS( EJ ) ) THEN
+*
+* Interchange columns and eliminate
+*
+ XR = B( J, J ) / EJ
+ XI = B( J+1, J ) / EJ
+ B( J, J ) = EJ
+ B( J+1, J ) = ZERO
+ DO 190 I = 1, J - 1
+ TEMP = B( I, J-1 )
+ B( I, J-1 ) = B( I, J ) - XR*TEMP
+ B( J, I ) = B( J+1, I ) - XI*TEMP
+ B( I, J ) = TEMP
+ B( J+1, I ) = ZERO
+ 190 CONTINUE
+ B( J+1, J-1 ) = WI
+ B( J-1, J-1 ) = B( J-1, J-1 ) + XI*WI
+ B( J, J-1 ) = B( J, J-1 ) - XR*WI
+ ELSE
+*
+* Eliminate without interchange.
+*
+ IF( ABSBJJ.EQ.ZERO ) THEN
+ B( J, J ) = EPS3
+ B( J+1, J ) = ZERO
+ ABSBJJ = EPS3
+ END IF
+ EJ = ( EJ / ABSBJJ ) / ABSBJJ
+ XR = B( J, J )*EJ
+ XI = -B( J+1, J )*EJ
+ DO 200 I = 1, J - 1
+ B( I, J-1 ) = B( I, J-1 ) - XR*B( I, J ) +
+ $ XI*B( J+1, I )
+ B( J, I ) = -XR*B( J+1, I ) - XI*B( I, J )
+ 200 CONTINUE
+ B( J, J-1 ) = B( J, J-1 ) + WI
+ END IF
+*
+* Compute 1-norm of offdiagonal elements of j-th column.
+*
+ WORK( J ) = DASUM( J-1, B( 1, J ), 1 ) +
+ $ DASUM( J-1, B( J+1, 1 ), LDB )
+ 210 CONTINUE
+ IF( B( 1, 1 ).EQ.ZERO .AND. B( 2, 1 ).EQ.ZERO )
+ $ B( 1, 1 ) = EPS3
+ WORK( 1 ) = ZERO
+*
+ I1 = 1
+ I2 = N
+ I3 = 1
+ END IF
+*
+ DO 270 ITS = 1, N
+ SCALE = ONE
+ VMAX = ONE
+ VCRIT = BIGNUM
+*
+* Solve U*(xr,xi) = scale*(vr,vi) for a right eigenvector,
+* or U'*(xr,xi) = scale*(vr,vi) for a left eigenvector,
+* overwriting (xr,xi) on (vr,vi).
+*
+ DO 250 I = I1, I2, I3
+*
+ IF( WORK( I ).GT.VCRIT ) THEN
+ REC = ONE / VMAX
+ CALL DSCAL( N, REC, VR, 1 )
+ CALL DSCAL( N, REC, VI, 1 )
+ SCALE = SCALE*REC
+ VMAX = ONE
+ VCRIT = BIGNUM
+ END IF
+*
+ XR = VR( I )
+ XI = VI( I )
+ IF( RIGHTV ) THEN
+ DO 220 J = I + 1, N
+ XR = XR - B( I, J )*VR( J ) + B( J+1, I )*VI( J )
+ XI = XI - B( I, J )*VI( J ) - B( J+1, I )*VR( J )
+ 220 CONTINUE
+ ELSE
+ DO 230 J = 1, I - 1
+ XR = XR - B( J, I )*VR( J ) + B( I+1, J )*VI( J )
+ XI = XI - B( J, I )*VI( J ) - B( I+1, J )*VR( J )
+ 230 CONTINUE
+ END IF
+*
+ W = ABS( B( I, I ) ) + ABS( B( I+1, I ) )
+ IF( W.GT.SMLNUM ) THEN
+ IF( W.LT.ONE ) THEN
+ W1 = ABS( XR ) + ABS( XI )
+ IF( W1.GT.W*BIGNUM ) THEN
+ REC = ONE / W1
+ CALL DSCAL( N, REC, VR, 1 )
+ CALL DSCAL( N, REC, VI, 1 )
+ XR = VR( I )
+ XI = VI( I )
+ SCALE = SCALE*REC
+ VMAX = VMAX*REC
+ END IF
+ END IF
+*
+* Divide by diagonal element of B.
+*
+ CALL DLADIV( XR, XI, B( I, I ), B( I+1, I ), VR( I ),
+ $ VI( I ) )
+ VMAX = MAX( ABS( VR( I ) )+ABS( VI( I ) ), VMAX )
+ VCRIT = BIGNUM / VMAX
+ ELSE
+ DO 240 J = 1, N
+ VR( J ) = ZERO
+ VI( J ) = ZERO
+ 240 CONTINUE
+ VR( I ) = ONE
+ VI( I ) = ONE
+ SCALE = ZERO
+ VMAX = ONE
+ VCRIT = BIGNUM
+ END IF
+ 250 CONTINUE
+*
+* Test for sufficient growth in the norm of (VR,VI).
+*
+ VNORM = DASUM( N, VR, 1 ) + DASUM( N, VI, 1 )
+ IF( VNORM.GE.GROWTO*SCALE )
+ $ GO TO 280
+*
+* Choose a new orthogonal starting vector and try again.
+*
+ Y = EPS3 / ( ROOTN+ONE )
+ VR( 1 ) = EPS3
+ VI( 1 ) = ZERO
+*
+ DO 260 I = 2, N
+ VR( I ) = Y
+ VI( I ) = ZERO
+ 260 CONTINUE
+ VR( N-ITS+1 ) = VR( N-ITS+1 ) - EPS3*ROOTN
+ 270 CONTINUE
+*
+* Failure to find eigenvector in N iterations
+*
+ INFO = 1
+*
+ 280 CONTINUE
+*
+* Normalize eigenvector.
+*
+ VNORM = ZERO
+ DO 290 I = 1, N
+ VNORM = MAX( VNORM, ABS( VR( I ) )+ABS( VI( I ) ) )
+ 290 CONTINUE
+ CALL DSCAL( N, ONE / VNORM, VR, 1 )
+ CALL DSCAL( N, ONE / VNORM, VI, 1 )
+*
+ END IF
+*
+ RETURN
+*
+* End of DLAEIN
+*
+ END
+ SUBROUTINE DLAEV2( A, B, C, RT1, RT2, CS1, SN1 )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ DOUBLE PRECISION A, B, C, CS1, RT1, RT2, SN1
+* ..
+*
+* Purpose
+* =======
+*
+* DLAEV2 computes the eigendecomposition of a 2-by-2 symmetric matrix
+* [ A B ]
+* [ B C ].
+* On return, RT1 is the eigenvalue of larger absolute value, RT2 is the
+* eigenvalue of smaller absolute value, and (CS1,SN1) is the unit right
+* eigenvector for RT1, giving the decomposition
+*
+* [ CS1 SN1 ] [ A B ] [ CS1 -SN1 ] = [ RT1 0 ]
+* [-SN1 CS1 ] [ B C ] [ SN1 CS1 ] [ 0 RT2 ].
+*
+* Arguments
+* =========
+*
+* A (input) DOUBLE PRECISION
+* The (1,1) element of the 2-by-2 matrix.
+*
+* B (input) DOUBLE PRECISION
+* The (1,2) element and the conjugate of the (2,1) element of
+* the 2-by-2 matrix.
+*
+* C (input) DOUBLE PRECISION
+* The (2,2) element of the 2-by-2 matrix.
+*
+* RT1 (output) DOUBLE PRECISION
+* The eigenvalue of larger absolute value.
+*
+* RT2 (output) DOUBLE PRECISION
+* The eigenvalue of smaller absolute value.
+*
+* CS1 (output) DOUBLE PRECISION
+* SN1 (output) DOUBLE PRECISION
+* The vector (CS1, SN1) is a unit right eigenvector for RT1.
+*
+* Further Details
+* ===============
+*
+* RT1 is accurate to a few ulps barring over/underflow.
+*
+* RT2 may be inaccurate if there is massive cancellation in the
+* determinant A*C-B*B; higher precision or correctly rounded or
+* correctly truncated arithmetic would be needed to compute RT2
+* accurately in all cases.
+*
+* CS1 and SN1 are accurate to a few ulps barring over/underflow.
+*
+* Overflow is possible only if RT1 is within a factor of 5 of overflow.
+* Underflow is harmless if the input data is 0 or exceeds
+* underflow_threshold / macheps.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE
+ PARAMETER ( ONE = 1.0D0 )
+ DOUBLE PRECISION TWO
+ PARAMETER ( TWO = 2.0D0 )
+ DOUBLE PRECISION ZERO
+ PARAMETER ( ZERO = 0.0D0 )
+ DOUBLE PRECISION HALF
+ PARAMETER ( HALF = 0.5D0 )
+* ..
+* .. Local Scalars ..
+ INTEGER SGN1, SGN2
+ DOUBLE PRECISION AB, ACMN, ACMX, ACS, ADF, CS, CT, DF, RT, SM,
+ $ TB, TN
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, SQRT
+* ..
+* .. Executable Statements ..
+*
+* Compute the eigenvalues
+*
+ SM = A + C
+ DF = A - C
+ ADF = ABS( DF )
+ TB = B + B
+ AB = ABS( TB )
+ IF( ABS( A ).GT.ABS( C ) ) THEN
+ ACMX = A
+ ACMN = C
+ ELSE
+ ACMX = C
+ ACMN = A
+ END IF
+ IF( ADF.GT.AB ) THEN
+ RT = ADF*SQRT( ONE+( AB / ADF )**2 )
+ ELSE IF( ADF.LT.AB ) THEN
+ RT = AB*SQRT( ONE+( ADF / AB )**2 )
+ ELSE
+*
+* Includes case AB=ADF=0
+*
+ RT = AB*SQRT( TWO )
+ END IF
+ IF( SM.LT.ZERO ) THEN
+ RT1 = HALF*( SM-RT )
+ SGN1 = -1
+*
+* Order of execution important.
+* To get fully accurate smaller eigenvalue,
+* next line needs to be executed in higher precision.
+*
+ RT2 = ( ACMX / RT1 )*ACMN - ( B / RT1 )*B
+ ELSE IF( SM.GT.ZERO ) THEN
+ RT1 = HALF*( SM+RT )
+ SGN1 = 1
+*
+* Order of execution important.
+* To get fully accurate smaller eigenvalue,
+* next line needs to be executed in higher precision.
+*
+ RT2 = ( ACMX / RT1 )*ACMN - ( B / RT1 )*B
+ ELSE
+*
+* Includes case RT1 = RT2 = 0
+*
+ RT1 = HALF*RT
+ RT2 = -HALF*RT
+ SGN1 = 1
+ END IF
+*
+* Compute the eigenvector
+*
+ IF( DF.GE.ZERO ) THEN
+ CS = DF + RT
+ SGN2 = 1
+ ELSE
+ CS = DF - RT
+ SGN2 = -1
+ END IF
+ ACS = ABS( CS )
+ IF( ACS.GT.AB ) THEN
+ CT = -TB / CS
+ SN1 = ONE / SQRT( ONE+CT*CT )
+ CS1 = CT*SN1
+ ELSE
+ IF( AB.EQ.ZERO ) THEN
+ CS1 = ONE
+ SN1 = ZERO
+ ELSE
+ TN = -CS / TB
+ CS1 = ONE / SQRT( ONE+TN*TN )
+ SN1 = TN*CS1
+ END IF
+ END IF
+ IF( SGN1.EQ.SGN2 ) THEN
+ TN = CS1
+ CS1 = -SN1
+ SN1 = TN
+ END IF
+ RETURN
+*
+* End of DLAEV2
+*
+ END
+ SUBROUTINE DLAEXC( WANTQ, N, T, LDT, Q, LDQ, J1, N1, N2, WORK,
+ $ INFO )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ LOGICAL WANTQ
+ INTEGER INFO, J1, LDQ, LDT, N, N1, N2
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION Q( LDQ, * ), T( LDT, * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DLAEXC swaps adjacent diagonal blocks T11 and T22 of order 1 or 2 in
+* an upper quasi-triangular matrix T by an orthogonal similarity
+* transformation.
+*
+* T must be in Schur canonical form, that is, block upper triangular
+* with 1-by-1 and 2-by-2 diagonal blocks; each 2-by-2 diagonal block
+* has its diagonal elemnts equal and its off-diagonal elements of
+* opposite sign.
+*
+* Arguments
+* =========
+*
+* WANTQ (input) LOGICAL
+* = .TRUE. : accumulate the transformation in the matrix Q;
+* = .FALSE.: do not accumulate the transformation.
+*
+* N (input) INTEGER
+* The order of the matrix T. N >= 0.
+*
+* T (input/output) DOUBLE PRECISION array, dimension (LDT,N)
+* On entry, the upper quasi-triangular matrix T, in Schur
+* canonical form.
+* On exit, the updated matrix T, again in Schur canonical form.
+*
+* LDT (input) INTEGER
+* The leading dimension of the array T. LDT >= max(1,N).
+*
+* Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N)
+* On entry, if WANTQ is .TRUE., the orthogonal matrix Q.
+* On exit, if WANTQ is .TRUE., the updated matrix Q.
+* If WANTQ is .FALSE., Q is not referenced.
+*
+* LDQ (input) INTEGER
+* The leading dimension of the array Q.
+* LDQ >= 1; and if WANTQ is .TRUE., LDQ >= N.
+*
+* J1 (input) INTEGER
+* The index of the first row of the first block T11.
+*
+* N1 (input) INTEGER
+* The order of the first block T11. N1 = 0, 1 or 2.
+*
+* N2 (input) INTEGER
+* The order of the second block T22. N2 = 0, 1 or 2.
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (N)
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* = 1: the transformed matrix T would be too far from Schur
+* form; the blocks are not swapped and T and Q are
+* unchanged.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+ DOUBLE PRECISION TEN
+ PARAMETER ( TEN = 1.0D+1 )
+ INTEGER LDD, LDX
+ PARAMETER ( LDD = 4, LDX = 2 )
+* ..
+* .. Local Scalars ..
+ INTEGER IERR, J2, J3, J4, K, ND
+ DOUBLE PRECISION CS, DNORM, EPS, SCALE, SMLNUM, SN, T11, T22,
+ $ T33, TAU, TAU1, TAU2, TEMP, THRESH, WI1, WI2,
+ $ WR1, WR2, XNORM
+* ..
+* .. Local Arrays ..
+ DOUBLE PRECISION D( LDD, 4 ), U( 3 ), U1( 3 ), U2( 3 ),
+ $ X( LDX, 2 )
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DLAMCH, DLANGE
+ EXTERNAL DLAMCH, DLANGE
+* ..
+* .. External Subroutines ..
+ EXTERNAL DLACPY, DLANV2, DLARFG, DLARFX, DLARTG, DLASY2,
+ $ DROT
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX
+* ..
+* .. Executable Statements ..
+*
+ INFO = 0
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 .OR. N1.EQ.0 .OR. N2.EQ.0 )
+ $ RETURN
+ IF( J1+N1.GT.N )
+ $ RETURN
+*
+ J2 = J1 + 1
+ J3 = J1 + 2
+ J4 = J1 + 3
+*
+ IF( N1.EQ.1 .AND. N2.EQ.1 ) THEN
+*
+* Swap two 1-by-1 blocks.
+*
+ T11 = T( J1, J1 )
+ T22 = T( J2, J2 )
+*
+* Determine the transformation to perform the interchange.
+*
+ CALL DLARTG( T( J1, J2 ), T22-T11, CS, SN, TEMP )
+*
+* Apply transformation to the matrix T.
+*
+ IF( J3.LE.N )
+ $ CALL DROT( N-J1-1, T( J1, J3 ), LDT, T( J2, J3 ), LDT, CS,
+ $ SN )
+ CALL DROT( J1-1, T( 1, J1 ), 1, T( 1, J2 ), 1, CS, SN )
+*
+ T( J1, J1 ) = T22
+ T( J2, J2 ) = T11
+*
+ IF( WANTQ ) THEN
+*
+* Accumulate transformation in the matrix Q.
+*
+ CALL DROT( N, Q( 1, J1 ), 1, Q( 1, J2 ), 1, CS, SN )
+ END IF
+*
+ ELSE
+*
+* Swapping involves at least one 2-by-2 block.
+*
+* Copy the diagonal block of order N1+N2 to the local array D
+* and compute its norm.
+*
+ ND = N1 + N2
+ CALL DLACPY( 'Full', ND, ND, T( J1, J1 ), LDT, D, LDD )
+ DNORM = DLANGE( 'Max', ND, ND, D, LDD, WORK )
+*
+* Compute machine-dependent threshold for test for accepting
+* swap.
+*
+ EPS = DLAMCH( 'P' )
+ SMLNUM = DLAMCH( 'S' ) / EPS
+ THRESH = MAX( TEN*EPS*DNORM, SMLNUM )
+*
+* Solve T11*X - X*T22 = scale*T12 for X.
+*
+ CALL DLASY2( .FALSE., .FALSE., -1, N1, N2, D, LDD,
+ $ D( N1+1, N1+1 ), LDD, D( 1, N1+1 ), LDD, SCALE, X,
+ $ LDX, XNORM, IERR )
+*
+* Swap the adjacent diagonal blocks.
+*
+ K = N1 + N1 + N2 - 3
+ GO TO ( 10, 20, 30 )K
+*
+ 10 CONTINUE
+*
+* N1 = 1, N2 = 2: generate elementary reflector H so that:
+*
+* ( scale, X11, X12 ) H = ( 0, 0, * )
+*
+ U( 1 ) = SCALE
+ U( 2 ) = X( 1, 1 )
+ U( 3 ) = X( 1, 2 )
+ CALL DLARFG( 3, U( 3 ), U, 1, TAU )
+ U( 3 ) = ONE
+ T11 = T( J1, J1 )
+*
+* Perform swap provisionally on diagonal block in D.
+*
+ CALL DLARFX( 'L', 3, 3, U, TAU, D, LDD, WORK )
+ CALL DLARFX( 'R', 3, 3, U, TAU, D, LDD, WORK )
+*
+* Test whether to reject swap.
+*
+ IF( MAX( ABS( D( 3, 1 ) ), ABS( D( 3, 2 ) ), ABS( D( 3,
+ $ 3 )-T11 ) ).GT.THRESH )GO TO 50
+*
+* Accept swap: apply transformation to the entire matrix T.
+*
+ CALL DLARFX( 'L', 3, N-J1+1, U, TAU, T( J1, J1 ), LDT, WORK )
+ CALL DLARFX( 'R', J2, 3, U, TAU, T( 1, J1 ), LDT, WORK )
+*
+ T( J3, J1 ) = ZERO
+ T( J3, J2 ) = ZERO
+ T( J3, J3 ) = T11
+*
+ IF( WANTQ ) THEN
+*
+* Accumulate transformation in the matrix Q.
+*
+ CALL DLARFX( 'R', N, 3, U, TAU, Q( 1, J1 ), LDQ, WORK )
+ END IF
+ GO TO 40
+*
+ 20 CONTINUE
+*
+* N1 = 2, N2 = 1: generate elementary reflector H so that:
+*
+* H ( -X11 ) = ( * )
+* ( -X21 ) = ( 0 )
+* ( scale ) = ( 0 )
+*
+ U( 1 ) = -X( 1, 1 )
+ U( 2 ) = -X( 2, 1 )
+ U( 3 ) = SCALE
+ CALL DLARFG( 3, U( 1 ), U( 2 ), 1, TAU )
+ U( 1 ) = ONE
+ T33 = T( J3, J3 )
+*
+* Perform swap provisionally on diagonal block in D.
+*
+ CALL DLARFX( 'L', 3, 3, U, TAU, D, LDD, WORK )
+ CALL DLARFX( 'R', 3, 3, U, TAU, D, LDD, WORK )
+*
+* Test whether to reject swap.
+*
+ IF( MAX( ABS( D( 2, 1 ) ), ABS( D( 3, 1 ) ), ABS( D( 1,
+ $ 1 )-T33 ) ).GT.THRESH )GO TO 50
+*
+* Accept swap: apply transformation to the entire matrix T.
+*
+ CALL DLARFX( 'R', J3, 3, U, TAU, T( 1, J1 ), LDT, WORK )
+ CALL DLARFX( 'L', 3, N-J1, U, TAU, T( J1, J2 ), LDT, WORK )
+*
+ T( J1, J1 ) = T33
+ T( J2, J1 ) = ZERO
+ T( J3, J1 ) = ZERO
+*
+ IF( WANTQ ) THEN
+*
+* Accumulate transformation in the matrix Q.
+*
+ CALL DLARFX( 'R', N, 3, U, TAU, Q( 1, J1 ), LDQ, WORK )
+ END IF
+ GO TO 40
+*
+ 30 CONTINUE
+*
+* N1 = 2, N2 = 2: generate elementary reflectors H(1) and H(2) so
+* that:
+*
+* H(2) H(1) ( -X11 -X12 ) = ( * * )
+* ( -X21 -X22 ) ( 0 * )
+* ( scale 0 ) ( 0 0 )
+* ( 0 scale ) ( 0 0 )
+*
+ U1( 1 ) = -X( 1, 1 )
+ U1( 2 ) = -X( 2, 1 )
+ U1( 3 ) = SCALE
+ CALL DLARFG( 3, U1( 1 ), U1( 2 ), 1, TAU1 )
+ U1( 1 ) = ONE
+*
+ TEMP = -TAU1*( X( 1, 2 )+U1( 2 )*X( 2, 2 ) )
+ U2( 1 ) = -TEMP*U1( 2 ) - X( 2, 2 )
+ U2( 2 ) = -TEMP*U1( 3 )
+ U2( 3 ) = SCALE
+ CALL DLARFG( 3, U2( 1 ), U2( 2 ), 1, TAU2 )
+ U2( 1 ) = ONE
+*
+* Perform swap provisionally on diagonal block in D.
+*
+ CALL DLARFX( 'L', 3, 4, U1, TAU1, D, LDD, WORK )
+ CALL DLARFX( 'R', 4, 3, U1, TAU1, D, LDD, WORK )
+ CALL DLARFX( 'L', 3, 4, U2, TAU2, D( 2, 1 ), LDD, WORK )
+ CALL DLARFX( 'R', 4, 3, U2, TAU2, D( 1, 2 ), LDD, WORK )
+*
+* Test whether to reject swap.
+*
+ IF( MAX( ABS( D( 3, 1 ) ), ABS( D( 3, 2 ) ), ABS( D( 4, 1 ) ),
+ $ ABS( D( 4, 2 ) ) ).GT.THRESH )GO TO 50
+*
+* Accept swap: apply transformation to the entire matrix T.
+*
+ CALL DLARFX( 'L', 3, N-J1+1, U1, TAU1, T( J1, J1 ), LDT, WORK )
+ CALL DLARFX( 'R', J4, 3, U1, TAU1, T( 1, J1 ), LDT, WORK )
+ CALL DLARFX( 'L', 3, N-J1+1, U2, TAU2, T( J2, J1 ), LDT, WORK )
+ CALL DLARFX( 'R', J4, 3, U2, TAU2, T( 1, J2 ), LDT, WORK )
+*
+ T( J3, J1 ) = ZERO
+ T( J3, J2 ) = ZERO
+ T( J4, J1 ) = ZERO
+ T( J4, J2 ) = ZERO
+*
+ IF( WANTQ ) THEN
+*
+* Accumulate transformation in the matrix Q.
+*
+ CALL DLARFX( 'R', N, 3, U1, TAU1, Q( 1, J1 ), LDQ, WORK )
+ CALL DLARFX( 'R', N, 3, U2, TAU2, Q( 1, J2 ), LDQ, WORK )
+ END IF
+*
+ 40 CONTINUE
+*
+ IF( N2.EQ.2 ) THEN
+*
+* Standardize new 2-by-2 block T11
+*
+ CALL DLANV2( T( J1, J1 ), T( J1, J2 ), T( J2, J1 ),
+ $ T( J2, J2 ), WR1, WI1, WR2, WI2, CS, SN )
+ CALL DROT( N-J1-1, T( J1, J1+2 ), LDT, T( J2, J1+2 ), LDT,
+ $ CS, SN )
+ CALL DROT( J1-1, T( 1, J1 ), 1, T( 1, J2 ), 1, CS, SN )
+ IF( WANTQ )
+ $ CALL DROT( N, Q( 1, J1 ), 1, Q( 1, J2 ), 1, CS, SN )
+ END IF
+*
+ IF( N1.EQ.2 ) THEN
+*
+* Standardize new 2-by-2 block T22
+*
+ J3 = J1 + N2
+ J4 = J3 + 1
+ CALL DLANV2( T( J3, J3 ), T( J3, J4 ), T( J4, J3 ),
+ $ T( J4, J4 ), WR1, WI1, WR2, WI2, CS, SN )
+ IF( J3+2.LE.N )
+ $ CALL DROT( N-J3-1, T( J3, J3+2 ), LDT, T( J4, J3+2 ),
+ $ LDT, CS, SN )
+ CALL DROT( J3-1, T( 1, J3 ), 1, T( 1, J4 ), 1, CS, SN )
+ IF( WANTQ )
+ $ CALL DROT( N, Q( 1, J3 ), 1, Q( 1, J4 ), 1, CS, SN )
+ END IF
+*
+ END IF
+ RETURN
+*
+* Exit with INFO = 1 if swap was rejected.
+*
+ 50 CONTINUE
+ INFO = 1
+ RETURN
+*
+* End of DLAEXC
+*
+ END
+ SUBROUTINE DLAG2( A, LDA, B, LDB, SAFMIN, SCALE1, SCALE2, WR1,
+ $ WR2, WI )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER LDA, LDB
+ DOUBLE PRECISION SAFMIN, SCALE1, SCALE2, WI, WR1, WR2
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION A( LDA, * ), B( LDB, * )
+* ..
+*
+* Purpose
+* =======
+*
+* DLAG2 computes the eigenvalues of a 2 x 2 generalized eigenvalue
+* problem A - w B, with scaling as necessary to avoid over-/underflow.
+*
+* The scaling factor "s" results in a modified eigenvalue equation
+*
+* s A - w B
+*
+* where s is a non-negative scaling factor chosen so that w, w B,
+* and s A do not overflow and, if possible, do not underflow, either.
+*
+* Arguments
+* =========
+*
+* A (input) DOUBLE PRECISION array, dimension (LDA, 2)
+* On entry, the 2 x 2 matrix A. It is assumed that its 1-norm
+* is less than 1/SAFMIN. Entries less than
+* sqrt(SAFMIN)*norm(A) are subject to being treated as zero.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= 2.
+*
+* B (input) DOUBLE PRECISION array, dimension (LDB, 2)
+* On entry, the 2 x 2 upper triangular matrix B. It is
+* assumed that the one-norm of B is less than 1/SAFMIN. The
+* diagonals should be at least sqrt(SAFMIN) times the largest
+* element of B (in absolute value); if a diagonal is smaller
+* than that, then +/- sqrt(SAFMIN) will be used instead of
+* that diagonal.
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. LDB >= 2.
+*
+* SAFMIN (input) DOUBLE PRECISION
+* The smallest positive number s.t. 1/SAFMIN does not
+* overflow. (This should always be DLAMCH('S') -- it is an
+* argument in order to avoid having to call DLAMCH frequently.)
+*
+* SCALE1 (output) DOUBLE PRECISION
+* A scaling factor used to avoid over-/underflow in the
+* eigenvalue equation which defines the first eigenvalue. If
+* the eigenvalues are complex, then the eigenvalues are
+* ( WR1 +/- WI i ) / SCALE1 (which may lie outside the
+* exponent range of the machine), SCALE1=SCALE2, and SCALE1
+* will always be positive. If the eigenvalues are real, then
+* the first (real) eigenvalue is WR1 / SCALE1 , but this may
+* overflow or underflow, and in fact, SCALE1 may be zero or
+* less than the underflow threshhold if the exact eigenvalue
+* is sufficiently large.
+*
+* SCALE2 (output) DOUBLE PRECISION
+* A scaling factor used to avoid over-/underflow in the
+* eigenvalue equation which defines the second eigenvalue. If
+* the eigenvalues are complex, then SCALE2=SCALE1. If the
+* eigenvalues are real, then the second (real) eigenvalue is
+* WR2 / SCALE2 , but this may overflow or underflow, and in
+* fact, SCALE2 may be zero or less than the underflow
+* threshhold if the exact eigenvalue is sufficiently large.
+*
+* WR1 (output) DOUBLE PRECISION
+* If the eigenvalue is real, then WR1 is SCALE1 times the
+* eigenvalue closest to the (2,2) element of A B**(-1). If the
+* eigenvalue is complex, then WR1=WR2 is SCALE1 times the real
+* part of the eigenvalues.
+*
+* WR2 (output) DOUBLE PRECISION
+* If the eigenvalue is real, then WR2 is SCALE2 times the
+* other eigenvalue. If the eigenvalue is complex, then
+* WR1=WR2 is SCALE1 times the real part of the eigenvalues.
+*
+* WI (output) DOUBLE PRECISION
+* If the eigenvalue is real, then WI is zero. If the
+* eigenvalue is complex, then WI is SCALE1 times the imaginary
+* part of the eigenvalues. WI will always be non-negative.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE, TWO
+ PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0 )
+ DOUBLE PRECISION HALF
+ PARAMETER ( HALF = ONE / TWO )
+ DOUBLE PRECISION FUZZY1
+ PARAMETER ( FUZZY1 = ONE+1.0D-5 )
+* ..
+* .. Local Scalars ..
+ DOUBLE PRECISION A11, A12, A21, A22, ABI22, ANORM, AS11, AS12,
+ $ AS22, ASCALE, B11, B12, B22, BINV11, BINV22,
+ $ BMIN, BNORM, BSCALE, BSIZE, C1, C2, C3, C4, C5,
+ $ DIFF, DISCR, PP, QQ, R, RTMAX, RTMIN, S1, S2,
+ $ SAFMAX, SHIFT, SS, SUM, WABS, WBIG, WDET,
+ $ WSCALE, WSIZE, WSMALL
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, MIN, SIGN, SQRT
+* ..
+* .. Executable Statements ..
+*
+ RTMIN = SQRT( SAFMIN )
+ RTMAX = ONE / RTMIN
+ SAFMAX = ONE / SAFMIN
+*
+* Scale A
+*
+ ANORM = MAX( ABS( A( 1, 1 ) )+ABS( A( 2, 1 ) ),
+ $ ABS( A( 1, 2 ) )+ABS( A( 2, 2 ) ), SAFMIN )
+ ASCALE = ONE / ANORM
+ A11 = ASCALE*A( 1, 1 )
+ A21 = ASCALE*A( 2, 1 )
+ A12 = ASCALE*A( 1, 2 )
+ A22 = ASCALE*A( 2, 2 )
+*
+* Perturb B if necessary to insure non-singularity
+*
+ B11 = B( 1, 1 )
+ B12 = B( 1, 2 )
+ B22 = B( 2, 2 )
+ BMIN = RTMIN*MAX( ABS( B11 ), ABS( B12 ), ABS( B22 ), RTMIN )
+ IF( ABS( B11 ).LT.BMIN )
+ $ B11 = SIGN( BMIN, B11 )
+ IF( ABS( B22 ).LT.BMIN )
+ $ B22 = SIGN( BMIN, B22 )
+*
+* Scale B
+*
+ BNORM = MAX( ABS( B11 ), ABS( B12 )+ABS( B22 ), SAFMIN )
+ BSIZE = MAX( ABS( B11 ), ABS( B22 ) )
+ BSCALE = ONE / BSIZE
+ B11 = B11*BSCALE
+ B12 = B12*BSCALE
+ B22 = B22*BSCALE
+*
+* Compute larger eigenvalue by method described by C. van Loan
+*
+* ( AS is A shifted by -SHIFT*B )
+*
+ BINV11 = ONE / B11
+ BINV22 = ONE / B22
+ S1 = A11*BINV11
+ S2 = A22*BINV22
+ IF( ABS( S1 ).LE.ABS( S2 ) ) THEN
+ AS12 = A12 - S1*B12
+ AS22 = A22 - S1*B22
+ SS = A21*( BINV11*BINV22 )
+ ABI22 = AS22*BINV22 - SS*B12
+ PP = HALF*ABI22
+ SHIFT = S1
+ ELSE
+ AS12 = A12 - S2*B12
+ AS11 = A11 - S2*B11
+ SS = A21*( BINV11*BINV22 )
+ ABI22 = -SS*B12
+ PP = HALF*( AS11*BINV11+ABI22 )
+ SHIFT = S2
+ END IF
+ QQ = SS*AS12
+ IF( ABS( PP*RTMIN ).GE.ONE ) THEN
+ DISCR = ( RTMIN*PP )**2 + QQ*SAFMIN
+ R = SQRT( ABS( DISCR ) )*RTMAX
+ ELSE
+ IF( PP**2+ABS( QQ ).LE.SAFMIN ) THEN
+ DISCR = ( RTMAX*PP )**2 + QQ*SAFMAX
+ R = SQRT( ABS( DISCR ) )*RTMIN
+ ELSE
+ DISCR = PP**2 + QQ
+ R = SQRT( ABS( DISCR ) )
+ END IF
+ END IF
+*
+* Note: the test of R in the following IF is to cover the case when
+* DISCR is small and negative and is flushed to zero during
+* the calculation of R. On machines which have a consistent
+* flush-to-zero threshhold and handle numbers above that
+* threshhold correctly, it would not be necessary.
+*
+ IF( DISCR.GE.ZERO .OR. R.EQ.ZERO ) THEN
+ SUM = PP + SIGN( R, PP )
+ DIFF = PP - SIGN( R, PP )
+ WBIG = SHIFT + SUM
+*
+* Compute smaller eigenvalue
+*
+ WSMALL = SHIFT + DIFF
+ IF( HALF*ABS( WBIG ).GT.MAX( ABS( WSMALL ), SAFMIN ) ) THEN
+ WDET = ( A11*A22-A12*A21 )*( BINV11*BINV22 )
+ WSMALL = WDET / WBIG
+ END IF
+*
+* Choose (real) eigenvalue closest to 2,2 element of A*B**(-1)
+* for WR1.
+*
+ IF( PP.GT.ABI22 ) THEN
+ WR1 = MIN( WBIG, WSMALL )
+ WR2 = MAX( WBIG, WSMALL )
+ ELSE
+ WR1 = MAX( WBIG, WSMALL )
+ WR2 = MIN( WBIG, WSMALL )
+ END IF
+ WI = ZERO
+ ELSE
+*
+* Complex eigenvalues
+*
+ WR1 = SHIFT + PP
+ WR2 = WR1
+ WI = R
+ END IF
+*
+* Further scaling to avoid underflow and overflow in computing
+* SCALE1 and overflow in computing w*B.
+*
+* This scale factor (WSCALE) is bounded from above using C1 and C2,
+* and from below using C3 and C4.
+* C1 implements the condition s A must never overflow.
+* C2 implements the condition w B must never overflow.
+* C3, with C2,
+* implement the condition that s A - w B must never overflow.
+* C4 implements the condition s should not underflow.
+* C5 implements the condition max(s,|w|) should be at least 2.
+*
+ C1 = BSIZE*( SAFMIN*MAX( ONE, ASCALE ) )
+ C2 = SAFMIN*MAX( ONE, BNORM )
+ C3 = BSIZE*SAFMIN
+ IF( ASCALE.LE.ONE .AND. BSIZE.LE.ONE ) THEN
+ C4 = MIN( ONE, ( ASCALE / SAFMIN )*BSIZE )
+ ELSE
+ C4 = ONE
+ END IF
+ IF( ASCALE.LE.ONE .OR. BSIZE.LE.ONE ) THEN
+ C5 = MIN( ONE, ASCALE*BSIZE )
+ ELSE
+ C5 = ONE
+ END IF
+*
+* Scale first eigenvalue
+*
+ WABS = ABS( WR1 ) + ABS( WI )
+ WSIZE = MAX( SAFMIN, C1, FUZZY1*( WABS*C2+C3 ),
+ $ MIN( C4, HALF*MAX( WABS, C5 ) ) )
+ IF( WSIZE.NE.ONE ) THEN
+ WSCALE = ONE / WSIZE
+ IF( WSIZE.GT.ONE ) THEN
+ SCALE1 = ( MAX( ASCALE, BSIZE )*WSCALE )*
+ $ MIN( ASCALE, BSIZE )
+ ELSE
+ SCALE1 = ( MIN( ASCALE, BSIZE )*WSCALE )*
+ $ MAX( ASCALE, BSIZE )
+ END IF
+ WR1 = WR1*WSCALE
+ IF( WI.NE.ZERO ) THEN
+ WI = WI*WSCALE
+ WR2 = WR1
+ SCALE2 = SCALE1
+ END IF
+ ELSE
+ SCALE1 = ASCALE*BSIZE
+ SCALE2 = SCALE1
+ END IF
+*
+* Scale second eigenvalue (if real)
+*
+ IF( WI.EQ.ZERO ) THEN
+ WSIZE = MAX( SAFMIN, C1, FUZZY1*( ABS( WR2 )*C2+C3 ),
+ $ MIN( C4, HALF*MAX( ABS( WR2 ), C5 ) ) )
+ IF( WSIZE.NE.ONE ) THEN
+ WSCALE = ONE / WSIZE
+ IF( WSIZE.GT.ONE ) THEN
+ SCALE2 = ( MAX( ASCALE, BSIZE )*WSCALE )*
+ $ MIN( ASCALE, BSIZE )
+ ELSE
+ SCALE2 = ( MIN( ASCALE, BSIZE )*WSCALE )*
+ $ MAX( ASCALE, BSIZE )
+ END IF
+ WR2 = WR2*WSCALE
+ ELSE
+ SCALE2 = ASCALE*BSIZE
+ END IF
+ END IF
+*
+* End of DLAG2
+*
+ RETURN
+ END
+ SUBROUTINE DLAG2S( M, N, A, LDA, SA, LDSA, INFO)
+*
+* -- LAPACK PROTOTYPE auxiliary routine (version 3.1.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* January 2007
+*
+* ..
+* .. WARNING: PROTOTYPE ..
+* This is an LAPACK PROTOTYPE routine which means that the
+* interface of this routine is likely to be changed in the future
+* based on community feedback.
+*
+* .. Scalar Arguments ..
+ INTEGER INFO,LDA,LDSA,M,N
+* ..
+* .. Array Arguments ..
+ REAL SA(LDSA,*)
+ DOUBLE PRECISION A(LDA,*)
+* ..
+*
+* Purpose
+* =======
+*
+* DLAG2S converts a DOUBLE PRECISION matrix, SA, to a SINGLE
+* PRECISION matrix, A.
+*
+* RMAX is the overflow for the SINGLE PRECISION arithmetic
+* DLAG2S checks that all the entries of A are between -RMAX and
+* RMAX. If not the convertion is aborted and a flag is raised.
+*
+* This is a helper routine so there is no argument checking.
+*
+* Arguments
+* =========
+*
+* M (input) INTEGER
+* The number of lines of the matrix A. M >= 0.
+*
+* N (input) INTEGER
+* The number of columns of the matrix A. N >= 0.
+*
+* A (input) DOUBLE PRECISION array, dimension (LDA,N)
+* On entry, the M-by-N coefficient matrix A.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,M).
+*
+* SA (output) REAL array, dimension (LDSA,N)
+* On exit, if INFO=0, the M-by-N coefficient matrix SA.
+*
+* LDSA (input) INTEGER
+* The leading dimension of the array SA. LDSA >= max(1,M).
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* > 0: if INFO = k, the (i,j) entry of the matrix A has
+* overflowed when moving from DOUBLE PRECISION to SINGLE
+* k is given by k = (i-1)*LDA+j
+*
+* =========
+*
+* .. Local Scalars ..
+ INTEGER I,J
+ DOUBLE PRECISION RMAX
+* ..
+* .. External Functions ..
+ REAL SLAMCH
+ EXTERNAL SLAMCH
+* ..
+* .. Executable Statements ..
+*
+ RMAX = SLAMCH('O')
+ DO 20 J = 1,N
+ DO 30 I = 1,M
+ IF ((A(I,J).LT.-RMAX) .OR. (A(I,J).GT.RMAX)) THEN
+ INFO = (I-1)*LDA + J
+ GO TO 10
+ END IF
+ SA(I,J) = A(I,J)
+ 30 CONTINUE
+ 20 CONTINUE
+ 10 CONTINUE
+ RETURN
+*
+* End of DLAG2S
+*
+ END
+ SUBROUTINE DLAGS2( UPPER, A1, A2, A3, B1, B2, B3, CSU, SNU, CSV,
+ $ SNV, CSQ, SNQ )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ LOGICAL UPPER
+ DOUBLE PRECISION A1, A2, A3, B1, B2, B3, CSQ, CSU, CSV, SNQ,
+ $ SNU, SNV
+* ..
+*
+* Purpose
+* =======
+*
+* DLAGS2 computes 2-by-2 orthogonal matrices U, V and Q, such
+* that if ( UPPER ) then
+*
+* U'*A*Q = U'*( A1 A2 )*Q = ( x 0 )
+* ( 0 A3 ) ( x x )
+* and
+* V'*B*Q = V'*( B1 B2 )*Q = ( x 0 )
+* ( 0 B3 ) ( x x )
+*
+* or if ( .NOT.UPPER ) then
+*
+* U'*A*Q = U'*( A1 0 )*Q = ( x x )
+* ( A2 A3 ) ( 0 x )
+* and
+* V'*B*Q = V'*( B1 0 )*Q = ( x x )
+* ( B2 B3 ) ( 0 x )
+*
+* The rows of the transformed A and B are parallel, where
+*
+* U = ( CSU SNU ), V = ( CSV SNV ), Q = ( CSQ SNQ )
+* ( -SNU CSU ) ( -SNV CSV ) ( -SNQ CSQ )
+*
+* Z' denotes the transpose of Z.
+*
+*
+* Arguments
+* =========
+*
+* UPPER (input) LOGICAL
+* = .TRUE.: the input matrices A and B are upper triangular.
+* = .FALSE.: the input matrices A and B are lower triangular.
+*
+* A1 (input) DOUBLE PRECISION
+* A2 (input) DOUBLE PRECISION
+* A3 (input) DOUBLE PRECISION
+* On entry, A1, A2 and A3 are elements of the input 2-by-2
+* upper (lower) triangular matrix A.
+*
+* B1 (input) DOUBLE PRECISION
+* B2 (input) DOUBLE PRECISION
+* B3 (input) DOUBLE PRECISION
+* On entry, B1, B2 and B3 are elements of the input 2-by-2
+* upper (lower) triangular matrix B.
+*
+* CSU (output) DOUBLE PRECISION
+* SNU (output) DOUBLE PRECISION
+* The desired orthogonal matrix U.
+*
+* CSV (output) DOUBLE PRECISION
+* SNV (output) DOUBLE PRECISION
+* The desired orthogonal matrix V.
+*
+* CSQ (output) DOUBLE PRECISION
+* SNQ (output) DOUBLE PRECISION
+* The desired orthogonal matrix Q.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO
+ PARAMETER ( ZERO = 0.0D+0 )
+* ..
+* .. Local Scalars ..
+ DOUBLE PRECISION A, AUA11, AUA12, AUA21, AUA22, AVB11, AVB12,
+ $ AVB21, AVB22, B, C, CSL, CSR, D, R, S1, S2,
+ $ SNL, SNR, UA11, UA11R, UA12, UA21, UA22, UA22R,
+ $ VB11, VB11R, VB12, VB21, VB22, VB22R
+* ..
+* .. External Subroutines ..
+ EXTERNAL DLARTG, DLASV2
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS
+* ..
+* .. Executable Statements ..
+*
+ IF( UPPER ) THEN
+*
+* Input matrices A and B are upper triangular matrices
+*
+* Form matrix C = A*adj(B) = ( a b )
+* ( 0 d )
+*
+ A = A1*B3
+ D = A3*B1
+ B = A2*B1 - A1*B2
+*
+* The SVD of real 2-by-2 triangular C
+*
+* ( CSL -SNL )*( A B )*( CSR SNR ) = ( R 0 )
+* ( SNL CSL ) ( 0 D ) ( -SNR CSR ) ( 0 T )
+*
+ CALL DLASV2( A, B, D, S1, S2, SNR, CSR, SNL, CSL )
+*
+ IF( ABS( CSL ).GE.ABS( SNL ) .OR. ABS( CSR ).GE.ABS( SNR ) )
+ $ THEN
+*
+* Compute the (1,1) and (1,2) elements of U'*A and V'*B,
+* and (1,2) element of |U|'*|A| and |V|'*|B|.
+*
+ UA11R = CSL*A1
+ UA12 = CSL*A2 + SNL*A3
+*
+ VB11R = CSR*B1
+ VB12 = CSR*B2 + SNR*B3
+*
+ AUA12 = ABS( CSL )*ABS( A2 ) + ABS( SNL )*ABS( A3 )
+ AVB12 = ABS( CSR )*ABS( B2 ) + ABS( SNR )*ABS( B3 )
+*
+* zero (1,2) elements of U'*A and V'*B
+*
+ IF( ( ABS( UA11R )+ABS( UA12 ) ).NE.ZERO ) THEN
+ IF( AUA12 / ( ABS( UA11R )+ABS( UA12 ) ).LE.AVB12 /
+ $ ( ABS( VB11R )+ABS( VB12 ) ) ) THEN
+ CALL DLARTG( -UA11R, UA12, CSQ, SNQ, R )
+ ELSE
+ CALL DLARTG( -VB11R, VB12, CSQ, SNQ, R )
+ END IF
+ ELSE
+ CALL DLARTG( -VB11R, VB12, CSQ, SNQ, R )
+ END IF
+*
+ CSU = CSL
+ SNU = -SNL
+ CSV = CSR
+ SNV = -SNR
+*
+ ELSE
+*
+* Compute the (2,1) and (2,2) elements of U'*A and V'*B,
+* and (2,2) element of |U|'*|A| and |V|'*|B|.
+*
+ UA21 = -SNL*A1
+ UA22 = -SNL*A2 + CSL*A3
+*
+ VB21 = -SNR*B1
+ VB22 = -SNR*B2 + CSR*B3
+*
+ AUA22 = ABS( SNL )*ABS( A2 ) + ABS( CSL )*ABS( A3 )
+ AVB22 = ABS( SNR )*ABS( B2 ) + ABS( CSR )*ABS( B3 )
+*
+* zero (2,2) elements of U'*A and V'*B, and then swap.
+*
+ IF( ( ABS( UA21 )+ABS( UA22 ) ).NE.ZERO ) THEN
+ IF( AUA22 / ( ABS( UA21 )+ABS( UA22 ) ).LE.AVB22 /
+ $ ( ABS( VB21 )+ABS( VB22 ) ) ) THEN
+ CALL DLARTG( -UA21, UA22, CSQ, SNQ, R )
+ ELSE
+ CALL DLARTG( -VB21, VB22, CSQ, SNQ, R )
+ END IF
+ ELSE
+ CALL DLARTG( -VB21, VB22, CSQ, SNQ, R )
+ END IF
+*
+ CSU = SNL
+ SNU = CSL
+ CSV = SNR
+ SNV = CSR
+*
+ END IF
+*
+ ELSE
+*
+* Input matrices A and B are lower triangular matrices
+*
+* Form matrix C = A*adj(B) = ( a 0 )
+* ( c d )
+*
+ A = A1*B3
+ D = A3*B1
+ C = A2*B3 - A3*B2
+*
+* The SVD of real 2-by-2 triangular C
+*
+* ( CSL -SNL )*( A 0 )*( CSR SNR ) = ( R 0 )
+* ( SNL CSL ) ( C D ) ( -SNR CSR ) ( 0 T )
+*
+ CALL DLASV2( A, C, D, S1, S2, SNR, CSR, SNL, CSL )
+*
+ IF( ABS( CSR ).GE.ABS( SNR ) .OR. ABS( CSL ).GE.ABS( SNL ) )
+ $ THEN
+*
+* Compute the (2,1) and (2,2) elements of U'*A and V'*B,
+* and (2,1) element of |U|'*|A| and |V|'*|B|.
+*
+ UA21 = -SNR*A1 + CSR*A2
+ UA22R = CSR*A3
+*
+ VB21 = -SNL*B1 + CSL*B2
+ VB22R = CSL*B3
+*
+ AUA21 = ABS( SNR )*ABS( A1 ) + ABS( CSR )*ABS( A2 )
+ AVB21 = ABS( SNL )*ABS( B1 ) + ABS( CSL )*ABS( B2 )
+*
+* zero (2,1) elements of U'*A and V'*B.
+*
+ IF( ( ABS( UA21 )+ABS( UA22R ) ).NE.ZERO ) THEN
+ IF( AUA21 / ( ABS( UA21 )+ABS( UA22R ) ).LE.AVB21 /
+ $ ( ABS( VB21 )+ABS( VB22R ) ) ) THEN
+ CALL DLARTG( UA22R, UA21, CSQ, SNQ, R )
+ ELSE
+ CALL DLARTG( VB22R, VB21, CSQ, SNQ, R )
+ END IF
+ ELSE
+ CALL DLARTG( VB22R, VB21, CSQ, SNQ, R )
+ END IF
+*
+ CSU = CSR
+ SNU = -SNR
+ CSV = CSL
+ SNV = -SNL
+*
+ ELSE
+*
+* Compute the (1,1) and (1,2) elements of U'*A and V'*B,
+* and (1,1) element of |U|'*|A| and |V|'*|B|.
+*
+ UA11 = CSR*A1 + SNR*A2
+ UA12 = SNR*A3
+*
+ VB11 = CSL*B1 + SNL*B2
+ VB12 = SNL*B3
+*
+ AUA11 = ABS( CSR )*ABS( A1 ) + ABS( SNR )*ABS( A2 )
+ AVB11 = ABS( CSL )*ABS( B1 ) + ABS( SNL )*ABS( B2 )
+*
+* zero (1,1) elements of U'*A and V'*B, and then swap.
+*
+ IF( ( ABS( UA11 )+ABS( UA12 ) ).NE.ZERO ) THEN
+ IF( AUA11 / ( ABS( UA11 )+ABS( UA12 ) ).LE.AVB11 /
+ $ ( ABS( VB11 )+ABS( VB12 ) ) ) THEN
+ CALL DLARTG( UA12, UA11, CSQ, SNQ, R )
+ ELSE
+ CALL DLARTG( VB12, VB11, CSQ, SNQ, R )
+ END IF
+ ELSE
+ CALL DLARTG( VB12, VB11, CSQ, SNQ, R )
+ END IF
+*
+ CSU = SNR
+ SNU = CSR
+ CSV = SNL
+ SNV = CSL
+*
+ END IF
+*
+ END IF
+*
+ RETURN
+*
+* End of DLAGS2
+*
+ END
+ SUBROUTINE DLAGTF( N, A, LAMBDA, B, C, TOL, D, IN, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, N
+ DOUBLE PRECISION LAMBDA, TOL
+* ..
+* .. Array Arguments ..
+ INTEGER IN( * )
+ DOUBLE PRECISION A( * ), B( * ), C( * ), D( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DLAGTF factorizes the matrix (T - lambda*I), where T is an n by n
+* tridiagonal matrix and lambda is a scalar, as
+*
+* T - lambda*I = PLU,
+*
+* where P is a permutation matrix, L is a unit lower tridiagonal matrix
+* with at most one non-zero sub-diagonal elements per column and U is
+* an upper triangular matrix with at most two non-zero super-diagonal
+* elements per column.
+*
+* The factorization is obtained by Gaussian elimination with partial
+* pivoting and implicit row scaling.
+*
+* The parameter LAMBDA is included in the routine so that DLAGTF may
+* be used, in conjunction with DLAGTS, to obtain eigenvectors of T by
+* inverse iteration.
+*
+* Arguments
+* =========
+*
+* N (input) INTEGER
+* The order of the matrix T.
+*
+* A (input/output) DOUBLE PRECISION array, dimension (N)
+* On entry, A must contain the diagonal elements of T.
+*
+* On exit, A is overwritten by the n diagonal elements of the
+* upper triangular matrix U of the factorization of T.
+*
+* LAMBDA (input) DOUBLE PRECISION
+* On entry, the scalar lambda.
+*
+* B (input/output) DOUBLE PRECISION array, dimension (N-1)
+* On entry, B must contain the (n-1) super-diagonal elements of
+* T.
+*
+* On exit, B is overwritten by the (n-1) super-diagonal
+* elements of the matrix U of the factorization of T.
+*
+* C (input/output) DOUBLE PRECISION array, dimension (N-1)
+* On entry, C must contain the (n-1) sub-diagonal elements of
+* T.
+*
+* On exit, C is overwritten by the (n-1) sub-diagonal elements
+* of the matrix L of the factorization of T.
+*
+* TOL (input) DOUBLE PRECISION
+* On entry, a relative tolerance used to indicate whether or
+* not the matrix (T - lambda*I) is nearly singular. TOL should
+* normally be chose as approximately the largest relative error
+* in the elements of T. For example, if the elements of T are
+* correct to about 4 significant figures, then TOL should be
+* set to about 5*10**(-4). If TOL is supplied as less than eps,
+* where eps is the relative machine precision, then the value
+* eps is used in place of TOL.
+*
+* D (output) DOUBLE PRECISION array, dimension (N-2)
+* On exit, D is overwritten by the (n-2) second super-diagonal
+* elements of the matrix U of the factorization of T.
+*
+* IN (output) INTEGER array, dimension (N)
+* On exit, IN contains details of the permutation matrix P. If
+* an interchange occurred at the kth step of the elimination,
+* then IN(k) = 1, otherwise IN(k) = 0. The element IN(n)
+* returns the smallest positive integer j such that
+*
+* abs( u(j,j) ).le. norm( (T - lambda*I)(j) )*TOL,
+*
+* where norm( A(j) ) denotes the sum of the absolute values of
+* the jth row of the matrix A. If no such j exists then IN(n)
+* is returned as zero. If IN(n) is returned as positive, then a
+* diagonal element of U is small, indicating that
+* (T - lambda*I) is singular or nearly singular,
+*
+* INFO (output) INTEGER
+* = 0 : successful exit
+* .lt. 0: if INFO = -k, the kth argument had an illegal value
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO
+ PARAMETER ( ZERO = 0.0D+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER K
+ DOUBLE PRECISION EPS, MULT, PIV1, PIV2, SCALE1, SCALE2, TEMP, TL
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DLAMCH
+ EXTERNAL DLAMCH
+* ..
+* .. External Subroutines ..
+ EXTERNAL XERBLA
+* ..
+* .. Executable Statements ..
+*
+ INFO = 0
+ IF( N.LT.0 ) THEN
+ INFO = -1
+ CALL XERBLA( 'DLAGTF', -INFO )
+ RETURN
+ END IF
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+ A( 1 ) = A( 1 ) - LAMBDA
+ IN( N ) = 0
+ IF( N.EQ.1 ) THEN
+ IF( A( 1 ).EQ.ZERO )
+ $ IN( 1 ) = 1
+ RETURN
+ END IF
+*
+ EPS = DLAMCH( 'Epsilon' )
+*
+ TL = MAX( TOL, EPS )
+ SCALE1 = ABS( A( 1 ) ) + ABS( B( 1 ) )
+ DO 10 K = 1, N - 1
+ A( K+1 ) = A( K+1 ) - LAMBDA
+ SCALE2 = ABS( C( K ) ) + ABS( A( K+1 ) )
+ IF( K.LT.( N-1 ) )
+ $ SCALE2 = SCALE2 + ABS( B( K+1 ) )
+ IF( A( K ).EQ.ZERO ) THEN
+ PIV1 = ZERO
+ ELSE
+ PIV1 = ABS( A( K ) ) / SCALE1
+ END IF
+ IF( C( K ).EQ.ZERO ) THEN
+ IN( K ) = 0
+ PIV2 = ZERO
+ SCALE1 = SCALE2
+ IF( K.LT.( N-1 ) )
+ $ D( K ) = ZERO
+ ELSE
+ PIV2 = ABS( C( K ) ) / SCALE2
+ IF( PIV2.LE.PIV1 ) THEN
+ IN( K ) = 0
+ SCALE1 = SCALE2
+ C( K ) = C( K ) / A( K )
+ A( K+1 ) = A( K+1 ) - C( K )*B( K )
+ IF( K.LT.( N-1 ) )
+ $ D( K ) = ZERO
+ ELSE
+ IN( K ) = 1
+ MULT = A( K ) / C( K )
+ A( K ) = C( K )
+ TEMP = A( K+1 )
+ A( K+1 ) = B( K ) - MULT*TEMP
+ IF( K.LT.( N-1 ) ) THEN
+ D( K ) = B( K+1 )
+ B( K+1 ) = -MULT*D( K )
+ END IF
+ B( K ) = TEMP
+ C( K ) = MULT
+ END IF
+ END IF
+ IF( ( MAX( PIV1, PIV2 ).LE.TL ) .AND. ( IN( N ).EQ.0 ) )
+ $ IN( N ) = K
+ 10 CONTINUE
+ IF( ( ABS( A( N ) ).LE.SCALE1*TL ) .AND. ( IN( N ).EQ.0 ) )
+ $ IN( N ) = N
+*
+ RETURN
+*
+* End of DLAGTF
+*
+ END
+ SUBROUTINE DLAGTM( TRANS, N, NRHS, ALPHA, DL, D, DU, X, LDX, BETA,
+ $ B, LDB )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER TRANS
+ INTEGER LDB, LDX, N, NRHS
+ DOUBLE PRECISION ALPHA, BETA
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION B( LDB, * ), D( * ), DL( * ), DU( * ),
+ $ X( LDX, * )
+* ..
+*
+* Purpose
+* =======
+*
+* DLAGTM performs a matrix-vector product of the form
+*
+* B := alpha * A * X + beta * B
+*
+* where A is a tridiagonal matrix of order N, B and X are N by NRHS
+* matrices, and alpha and beta are real scalars, each of which may be
+* 0., 1., or -1.
+*
+* Arguments
+* =========
+*
+* TRANS (input) CHARACTER*1
+* Specifies the operation applied to A.
+* = 'N': No transpose, B := alpha * A * X + beta * B
+* = 'T': Transpose, B := alpha * A'* X + beta * B
+* = 'C': Conjugate transpose = Transpose
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* NRHS (input) INTEGER
+* The number of right hand sides, i.e., the number of columns
+* of the matrices X and B.
+*
+* ALPHA (input) DOUBLE PRECISION
+* The scalar alpha. ALPHA must be 0., 1., or -1.; otherwise,
+* it is assumed to be 0.
+*
+* DL (input) DOUBLE PRECISION array, dimension (N-1)
+* The (n-1) sub-diagonal elements of T.
+*
+* D (input) DOUBLE PRECISION array, dimension (N)
+* The diagonal elements of T.
+*
+* DU (input) DOUBLE PRECISION array, dimension (N-1)
+* The (n-1) super-diagonal elements of T.
+*
+* X (input) DOUBLE PRECISION array, dimension (LDX,NRHS)
+* The N by NRHS matrix X.
+* LDX (input) INTEGER
+* The leading dimension of the array X. LDX >= max(N,1).
+*
+* BETA (input) DOUBLE PRECISION
+* The scalar beta. BETA must be 0., 1., or -1.; otherwise,
+* it is assumed to be 1.
+*
+* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
+* On entry, the N by NRHS matrix B.
+* On exit, B is overwritten by the matrix expression
+* B := alpha * A * X + beta * B.
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. LDB >= max(N,1).
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE, ZERO
+ PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, J
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. Executable Statements ..
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+* Multiply B by BETA if BETA.NE.1.
+*
+ IF( BETA.EQ.ZERO ) THEN
+ DO 20 J = 1, NRHS
+ DO 10 I = 1, N
+ B( I, J ) = ZERO
+ 10 CONTINUE
+ 20 CONTINUE
+ ELSE IF( BETA.EQ.-ONE ) THEN
+ DO 40 J = 1, NRHS
+ DO 30 I = 1, N
+ B( I, J ) = -B( I, J )
+ 30 CONTINUE
+ 40 CONTINUE
+ END IF
+*
+ IF( ALPHA.EQ.ONE ) THEN
+ IF( LSAME( TRANS, 'N' ) ) THEN
+*
+* Compute B := B + A*X
+*
+ DO 60 J = 1, NRHS
+ IF( N.EQ.1 ) THEN
+ B( 1, J ) = B( 1, J ) + D( 1 )*X( 1, J )
+ ELSE
+ B( 1, J ) = B( 1, J ) + D( 1 )*X( 1, J ) +
+ $ DU( 1 )*X( 2, J )
+ B( N, J ) = B( N, J ) + DL( N-1 )*X( N-1, J ) +
+ $ D( N )*X( N, J )
+ DO 50 I = 2, N - 1
+ B( I, J ) = B( I, J ) + DL( I-1 )*X( I-1, J ) +
+ $ D( I )*X( I, J ) + DU( I )*X( I+1, J )
+ 50 CONTINUE
+ END IF
+ 60 CONTINUE
+ ELSE
+*
+* Compute B := B + A'*X
+*
+ DO 80 J = 1, NRHS
+ IF( N.EQ.1 ) THEN
+ B( 1, J ) = B( 1, J ) + D( 1 )*X( 1, J )
+ ELSE
+ B( 1, J ) = B( 1, J ) + D( 1 )*X( 1, J ) +
+ $ DL( 1 )*X( 2, J )
+ B( N, J ) = B( N, J ) + DU( N-1 )*X( N-1, J ) +
+ $ D( N )*X( N, J )
+ DO 70 I = 2, N - 1
+ B( I, J ) = B( I, J ) + DU( I-1 )*X( I-1, J ) +
+ $ D( I )*X( I, J ) + DL( I )*X( I+1, J )
+ 70 CONTINUE
+ END IF
+ 80 CONTINUE
+ END IF
+ ELSE IF( ALPHA.EQ.-ONE ) THEN
+ IF( LSAME( TRANS, 'N' ) ) THEN
+*
+* Compute B := B - A*X
+*
+ DO 100 J = 1, NRHS
+ IF( N.EQ.1 ) THEN
+ B( 1, J ) = B( 1, J ) - D( 1 )*X( 1, J )
+ ELSE
+ B( 1, J ) = B( 1, J ) - D( 1 )*X( 1, J ) -
+ $ DU( 1 )*X( 2, J )
+ B( N, J ) = B( N, J ) - DL( N-1 )*X( N-1, J ) -
+ $ D( N )*X( N, J )
+ DO 90 I = 2, N - 1
+ B( I, J ) = B( I, J ) - DL( I-1 )*X( I-1, J ) -
+ $ D( I )*X( I, J ) - DU( I )*X( I+1, J )
+ 90 CONTINUE
+ END IF
+ 100 CONTINUE
+ ELSE
+*
+* Compute B := B - A'*X
+*
+ DO 120 J = 1, NRHS
+ IF( N.EQ.1 ) THEN
+ B( 1, J ) = B( 1, J ) - D( 1 )*X( 1, J )
+ ELSE
+ B( 1, J ) = B( 1, J ) - D( 1 )*X( 1, J ) -
+ $ DL( 1 )*X( 2, J )
+ B( N, J ) = B( N, J ) - DU( N-1 )*X( N-1, J ) -
+ $ D( N )*X( N, J )
+ DO 110 I = 2, N - 1
+ B( I, J ) = B( I, J ) - DU( I-1 )*X( I-1, J ) -
+ $ D( I )*X( I, J ) - DL( I )*X( I+1, J )
+ 110 CONTINUE
+ END IF
+ 120 CONTINUE
+ END IF
+ END IF
+ RETURN
+*
+* End of DLAGTM
+*
+ END
+ SUBROUTINE DLAGTS( JOB, N, A, B, C, D, IN, Y, TOL, INFO )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, JOB, N
+ DOUBLE PRECISION TOL
+* ..
+* .. Array Arguments ..
+ INTEGER IN( * )
+ DOUBLE PRECISION A( * ), B( * ), C( * ), D( * ), Y( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DLAGTS may be used to solve one of the systems of equations
+*
+* (T - lambda*I)*x = y or (T - lambda*I)'*x = y,
+*
+* where T is an n by n tridiagonal matrix, for x, following the
+* factorization of (T - lambda*I) as
+*
+* (T - lambda*I) = P*L*U ,
+*
+* by routine DLAGTF. The choice of equation to be solved is
+* controlled by the argument JOB, and in each case there is an option
+* to perturb zero or very small diagonal elements of U, this option
+* being intended for use in applications such as inverse iteration.
+*
+* Arguments
+* =========
+*
+* JOB (input) INTEGER
+* Specifies the job to be performed by DLAGTS as follows:
+* = 1: The equations (T - lambda*I)x = y are to be solved,
+* but diagonal elements of U are not to be perturbed.
+* = -1: The equations (T - lambda*I)x = y are to be solved
+* and, if overflow would otherwise occur, the diagonal
+* elements of U are to be perturbed. See argument TOL
+* below.
+* = 2: The equations (T - lambda*I)'x = y are to be solved,
+* but diagonal elements of U are not to be perturbed.
+* = -2: The equations (T - lambda*I)'x = y are to be solved
+* and, if overflow would otherwise occur, the diagonal
+* elements of U are to be perturbed. See argument TOL
+* below.
+*
+* N (input) INTEGER
+* The order of the matrix T.
+*
+* A (input) DOUBLE PRECISION array, dimension (N)
+* On entry, A must contain the diagonal elements of U as
+* returned from DLAGTF.
+*
+* B (input) DOUBLE PRECISION array, dimension (N-1)
+* On entry, B must contain the first super-diagonal elements of
+* U as returned from DLAGTF.
+*
+* C (input) DOUBLE PRECISION array, dimension (N-1)
+* On entry, C must contain the sub-diagonal elements of L as
+* returned from DLAGTF.
+*
+* D (input) DOUBLE PRECISION array, dimension (N-2)
+* On entry, D must contain the second super-diagonal elements
+* of U as returned from DLAGTF.
+*
+* IN (input) INTEGER array, dimension (N)
+* On entry, IN must contain details of the matrix P as returned
+* from DLAGTF.
+*
+* Y (input/output) DOUBLE PRECISION array, dimension (N)
+* On entry, the right hand side vector y.
+* On exit, Y is overwritten by the solution vector x.
+*
+* TOL (input/output) DOUBLE PRECISION
+* On entry, with JOB .lt. 0, TOL should be the minimum
+* perturbation to be made to very small diagonal elements of U.
+* TOL should normally be chosen as about eps*norm(U), where eps
+* is the relative machine precision, but if TOL is supplied as
+* non-positive, then it is reset to eps*max( abs( u(i,j) ) ).
+* If JOB .gt. 0 then TOL is not referenced.
+*
+* On exit, TOL is changed as described above, only if TOL is
+* non-positive on entry. Otherwise TOL is unchanged.
+*
+* INFO (output) INTEGER
+* = 0 : successful exit
+* .lt. 0: if INFO = -i, the i-th argument had an illegal value
+* .gt. 0: overflow would occur when computing the INFO(th)
+* element of the solution vector x. This can only occur
+* when JOB is supplied as positive and either means
+* that a diagonal element of U is very small, or that
+* the elements of the right-hand side vector y are very
+* large.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE, ZERO
+ PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER K
+ DOUBLE PRECISION ABSAK, AK, BIGNUM, EPS, PERT, SFMIN, TEMP
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, SIGN
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DLAMCH
+ EXTERNAL DLAMCH
+* ..
+* .. External Subroutines ..
+ EXTERNAL XERBLA
+* ..
+* .. Executable Statements ..
+*
+ INFO = 0
+ IF( ( ABS( JOB ).GT.2 ) .OR. ( JOB.EQ.0 ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DLAGTS', -INFO )
+ RETURN
+ END IF
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+ EPS = DLAMCH( 'Epsilon' )
+ SFMIN = DLAMCH( 'Safe minimum' )
+ BIGNUM = ONE / SFMIN
+*
+ IF( JOB.LT.0 ) THEN
+ IF( TOL.LE.ZERO ) THEN
+ TOL = ABS( A( 1 ) )
+ IF( N.GT.1 )
+ $ TOL = MAX( TOL, ABS( A( 2 ) ), ABS( B( 1 ) ) )
+ DO 10 K = 3, N
+ TOL = MAX( TOL, ABS( A( K ) ), ABS( B( K-1 ) ),
+ $ ABS( D( K-2 ) ) )
+ 10 CONTINUE
+ TOL = TOL*EPS
+ IF( TOL.EQ.ZERO )
+ $ TOL = EPS
+ END IF
+ END IF
+*
+ IF( ABS( JOB ).EQ.1 ) THEN
+ DO 20 K = 2, N
+ IF( IN( K-1 ).EQ.0 ) THEN
+ Y( K ) = Y( K ) - C( K-1 )*Y( K-1 )
+ ELSE
+ TEMP = Y( K-1 )
+ Y( K-1 ) = Y( K )
+ Y( K ) = TEMP - C( K-1 )*Y( K )
+ END IF
+ 20 CONTINUE
+ IF( JOB.EQ.1 ) THEN
+ DO 30 K = N, 1, -1
+ IF( K.LE.N-2 ) THEN
+ TEMP = Y( K ) - B( K )*Y( K+1 ) - D( K )*Y( K+2 )
+ ELSE IF( K.EQ.N-1 ) THEN
+ TEMP = Y( K ) - B( K )*Y( K+1 )
+ ELSE
+ TEMP = Y( K )
+ END IF
+ AK = A( K )
+ ABSAK = ABS( AK )
+ IF( ABSAK.LT.ONE ) THEN
+ IF( ABSAK.LT.SFMIN ) THEN
+ IF( ABSAK.EQ.ZERO .OR. ABS( TEMP )*SFMIN.GT.ABSAK )
+ $ THEN
+ INFO = K
+ RETURN
+ ELSE
+ TEMP = TEMP*BIGNUM
+ AK = AK*BIGNUM
+ END IF
+ ELSE IF( ABS( TEMP ).GT.ABSAK*BIGNUM ) THEN
+ INFO = K
+ RETURN
+ END IF
+ END IF
+ Y( K ) = TEMP / AK
+ 30 CONTINUE
+ ELSE
+ DO 50 K = N, 1, -1
+ IF( K.LE.N-2 ) THEN
+ TEMP = Y( K ) - B( K )*Y( K+1 ) - D( K )*Y( K+2 )
+ ELSE IF( K.EQ.N-1 ) THEN
+ TEMP = Y( K ) - B( K )*Y( K+1 )
+ ELSE
+ TEMP = Y( K )
+ END IF
+ AK = A( K )
+ PERT = SIGN( TOL, AK )
+ 40 CONTINUE
+ ABSAK = ABS( AK )
+ IF( ABSAK.LT.ONE ) THEN
+ IF( ABSAK.LT.SFMIN ) THEN
+ IF( ABSAK.EQ.ZERO .OR. ABS( TEMP )*SFMIN.GT.ABSAK )
+ $ THEN
+ AK = AK + PERT
+ PERT = 2*PERT
+ GO TO 40
+ ELSE
+ TEMP = TEMP*BIGNUM
+ AK = AK*BIGNUM
+ END IF
+ ELSE IF( ABS( TEMP ).GT.ABSAK*BIGNUM ) THEN
+ AK = AK + PERT
+ PERT = 2*PERT
+ GO TO 40
+ END IF
+ END IF
+ Y( K ) = TEMP / AK
+ 50 CONTINUE
+ END IF
+ ELSE
+*
+* Come to here if JOB = 2 or -2
+*
+ IF( JOB.EQ.2 ) THEN
+ DO 60 K = 1, N
+ IF( K.GE.3 ) THEN
+ TEMP = Y( K ) - B( K-1 )*Y( K-1 ) - D( K-2 )*Y( K-2 )
+ ELSE IF( K.EQ.2 ) THEN
+ TEMP = Y( K ) - B( K-1 )*Y( K-1 )
+ ELSE
+ TEMP = Y( K )
+ END IF
+ AK = A( K )
+ ABSAK = ABS( AK )
+ IF( ABSAK.LT.ONE ) THEN
+ IF( ABSAK.LT.SFMIN ) THEN
+ IF( ABSAK.EQ.ZERO .OR. ABS( TEMP )*SFMIN.GT.ABSAK )
+ $ THEN
+ INFO = K
+ RETURN
+ ELSE
+ TEMP = TEMP*BIGNUM
+ AK = AK*BIGNUM
+ END IF
+ ELSE IF( ABS( TEMP ).GT.ABSAK*BIGNUM ) THEN
+ INFO = K
+ RETURN
+ END IF
+ END IF
+ Y( K ) = TEMP / AK
+ 60 CONTINUE
+ ELSE
+ DO 80 K = 1, N
+ IF( K.GE.3 ) THEN
+ TEMP = Y( K ) - B( K-1 )*Y( K-1 ) - D( K-2 )*Y( K-2 )
+ ELSE IF( K.EQ.2 ) THEN
+ TEMP = Y( K ) - B( K-1 )*Y( K-1 )
+ ELSE
+ TEMP = Y( K )
+ END IF
+ AK = A( K )
+ PERT = SIGN( TOL, AK )
+ 70 CONTINUE
+ ABSAK = ABS( AK )
+ IF( ABSAK.LT.ONE ) THEN
+ IF( ABSAK.LT.SFMIN ) THEN
+ IF( ABSAK.EQ.ZERO .OR. ABS( TEMP )*SFMIN.GT.ABSAK )
+ $ THEN
+ AK = AK + PERT
+ PERT = 2*PERT
+ GO TO 70
+ ELSE
+ TEMP = TEMP*BIGNUM
+ AK = AK*BIGNUM
+ END IF
+ ELSE IF( ABS( TEMP ).GT.ABSAK*BIGNUM ) THEN
+ AK = AK + PERT
+ PERT = 2*PERT
+ GO TO 70
+ END IF
+ END IF
+ Y( K ) = TEMP / AK
+ 80 CONTINUE
+ END IF
+*
+ DO 90 K = N, 2, -1
+ IF( IN( K-1 ).EQ.0 ) THEN
+ Y( K-1 ) = Y( K-1 ) - C( K-1 )*Y( K )
+ ELSE
+ TEMP = Y( K-1 )
+ Y( K-1 ) = Y( K )
+ Y( K ) = TEMP - C( K-1 )*Y( K )
+ END IF
+ 90 CONTINUE
+ END IF
+*
+* End of DLAGTS
+*
+ END
+ SUBROUTINE DLAGV2( A, LDA, B, LDB, ALPHAR, ALPHAI, BETA, CSL, SNL,
+ $ CSR, SNR )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER LDA, LDB
+ DOUBLE PRECISION CSL, CSR, SNL, SNR
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION A( LDA, * ), ALPHAI( 2 ), ALPHAR( 2 ),
+ $ B( LDB, * ), BETA( 2 )
+* ..
+*
+* Purpose
+* =======
+*
+* DLAGV2 computes the Generalized Schur factorization of a real 2-by-2
+* matrix pencil (A,B) where B is upper triangular. This routine
+* computes orthogonal (rotation) matrices given by CSL, SNL and CSR,
+* SNR such that
+*
+* 1) if the pencil (A,B) has two real eigenvalues (include 0/0 or 1/0
+* types), then
+*
+* [ a11 a12 ] := [ CSL SNL ] [ a11 a12 ] [ CSR -SNR ]
+* [ 0 a22 ] [ -SNL CSL ] [ a21 a22 ] [ SNR CSR ]
+*
+* [ b11 b12 ] := [ CSL SNL ] [ b11 b12 ] [ CSR -SNR ]
+* [ 0 b22 ] [ -SNL CSL ] [ 0 b22 ] [ SNR CSR ],
+*
+* 2) if the pencil (A,B) has a pair of complex conjugate eigenvalues,
+* then
+*
+* [ a11 a12 ] := [ CSL SNL ] [ a11 a12 ] [ CSR -SNR ]
+* [ a21 a22 ] [ -SNL CSL ] [ a21 a22 ] [ SNR CSR ]
+*
+* [ b11 0 ] := [ CSL SNL ] [ b11 b12 ] [ CSR -SNR ]
+* [ 0 b22 ] [ -SNL CSL ] [ 0 b22 ] [ SNR CSR ]
+*
+* where b11 >= b22 > 0.
+*
+*
+* Arguments
+* =========
+*
+* A (input/output) DOUBLE PRECISION array, dimension (LDA, 2)
+* On entry, the 2 x 2 matrix A.
+* On exit, A is overwritten by the ``A-part'' of the
+* generalized Schur form.
+*
+* LDA (input) INTEGER
+* THe leading dimension of the array A. LDA >= 2.
+*
+* B (input/output) DOUBLE PRECISION array, dimension (LDB, 2)
+* On entry, the upper triangular 2 x 2 matrix B.
+* On exit, B is overwritten by the ``B-part'' of the
+* generalized Schur form.
+*
+* LDB (input) INTEGER
+* THe leading dimension of the array B. LDB >= 2.
+*
+* ALPHAR (output) DOUBLE PRECISION array, dimension (2)
+* ALPHAI (output) DOUBLE PRECISION array, dimension (2)
+* BETA (output) DOUBLE PRECISION array, dimension (2)
+* (ALPHAR(k)+i*ALPHAI(k))/BETA(k) are the eigenvalues of the
+* pencil (A,B), k=1,2, i = sqrt(-1). Note that BETA(k) may
+* be zero.
+*
+* CSL (output) DOUBLE PRECISION
+* The cosine of the left rotation matrix.
+*
+* SNL (output) DOUBLE PRECISION
+* The sine of the left rotation matrix.
+*
+* CSR (output) DOUBLE PRECISION
+* The cosine of the right rotation matrix.
+*
+* SNR (output) DOUBLE PRECISION
+* The sine of the right rotation matrix.
+*
+* Further Details
+* ===============
+*
+* Based on contributions by
+* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+* ..
+* .. Local Scalars ..
+ DOUBLE PRECISION ANORM, ASCALE, BNORM, BSCALE, H1, H2, H3, QQ,
+ $ R, RR, SAFMIN, SCALE1, SCALE2, T, ULP, WI, WR1,
+ $ WR2
+* ..
+* .. External Subroutines ..
+ EXTERNAL DLAG2, DLARTG, DLASV2, DROT
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DLAMCH, DLAPY2
+ EXTERNAL DLAMCH, DLAPY2
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX
+* ..
+* .. Executable Statements ..
+*
+ SAFMIN = DLAMCH( 'S' )
+ ULP = DLAMCH( 'P' )
+*
+* Scale A
+*
+ ANORM = MAX( ABS( A( 1, 1 ) )+ABS( A( 2, 1 ) ),
+ $ ABS( A( 1, 2 ) )+ABS( A( 2, 2 ) ), SAFMIN )
+ ASCALE = ONE / ANORM
+ A( 1, 1 ) = ASCALE*A( 1, 1 )
+ A( 1, 2 ) = ASCALE*A( 1, 2 )
+ A( 2, 1 ) = ASCALE*A( 2, 1 )
+ A( 2, 2 ) = ASCALE*A( 2, 2 )
+*
+* Scale B
+*
+ BNORM = MAX( ABS( B( 1, 1 ) ), ABS( B( 1, 2 ) )+ABS( B( 2, 2 ) ),
+ $ SAFMIN )
+ BSCALE = ONE / BNORM
+ B( 1, 1 ) = BSCALE*B( 1, 1 )
+ B( 1, 2 ) = BSCALE*B( 1, 2 )
+ B( 2, 2 ) = BSCALE*B( 2, 2 )
+*
+* Check if A can be deflated
+*
+ IF( ABS( A( 2, 1 ) ).LE.ULP ) THEN
+ CSL = ONE
+ SNL = ZERO
+ CSR = ONE
+ SNR = ZERO
+ A( 2, 1 ) = ZERO
+ B( 2, 1 ) = ZERO
+*
+* Check if B is singular
+*
+ ELSE IF( ABS( B( 1, 1 ) ).LE.ULP ) THEN
+ CALL DLARTG( A( 1, 1 ), A( 2, 1 ), CSL, SNL, R )
+ CSR = ONE
+ SNR = ZERO
+ CALL DROT( 2, A( 1, 1 ), LDA, A( 2, 1 ), LDA, CSL, SNL )
+ CALL DROT( 2, B( 1, 1 ), LDB, B( 2, 1 ), LDB, CSL, SNL )
+ A( 2, 1 ) = ZERO
+ B( 1, 1 ) = ZERO
+ B( 2, 1 ) = ZERO
+*
+ ELSE IF( ABS( B( 2, 2 ) ).LE.ULP ) THEN
+ CALL DLARTG( A( 2, 2 ), A( 2, 1 ), CSR, SNR, T )
+ SNR = -SNR
+ CALL DROT( 2, A( 1, 1 ), 1, A( 1, 2 ), 1, CSR, SNR )
+ CALL DROT( 2, B( 1, 1 ), 1, B( 1, 2 ), 1, CSR, SNR )
+ CSL = ONE
+ SNL = ZERO
+ A( 2, 1 ) = ZERO
+ B( 2, 1 ) = ZERO
+ B( 2, 2 ) = ZERO
+*
+ ELSE
+*
+* B is nonsingular, first compute the eigenvalues of (A,B)
+*
+ CALL DLAG2( A, LDA, B, LDB, SAFMIN, SCALE1, SCALE2, WR1, WR2,
+ $ WI )
+*
+ IF( WI.EQ.ZERO ) THEN
+*
+* two real eigenvalues, compute s*A-w*B
+*
+ H1 = SCALE1*A( 1, 1 ) - WR1*B( 1, 1 )
+ H2 = SCALE1*A( 1, 2 ) - WR1*B( 1, 2 )
+ H3 = SCALE1*A( 2, 2 ) - WR1*B( 2, 2 )
+*
+ RR = DLAPY2( H1, H2 )
+ QQ = DLAPY2( SCALE1*A( 2, 1 ), H3 )
+*
+ IF( RR.GT.QQ ) THEN
+*
+* find right rotation matrix to zero 1,1 element of
+* (sA - wB)
+*
+ CALL DLARTG( H2, H1, CSR, SNR, T )
+*
+ ELSE
+*
+* find right rotation matrix to zero 2,1 element of
+* (sA - wB)
+*
+ CALL DLARTG( H3, SCALE1*A( 2, 1 ), CSR, SNR, T )
+*
+ END IF
+*
+ SNR = -SNR
+ CALL DROT( 2, A( 1, 1 ), 1, A( 1, 2 ), 1, CSR, SNR )
+ CALL DROT( 2, B( 1, 1 ), 1, B( 1, 2 ), 1, CSR, SNR )
+*
+* compute inf norms of A and B
+*
+ H1 = MAX( ABS( A( 1, 1 ) )+ABS( A( 1, 2 ) ),
+ $ ABS( A( 2, 1 ) )+ABS( A( 2, 2 ) ) )
+ H2 = MAX( ABS( B( 1, 1 ) )+ABS( B( 1, 2 ) ),
+ $ ABS( B( 2, 1 ) )+ABS( B( 2, 2 ) ) )
+*
+ IF( ( SCALE1*H1 ).GE.ABS( WR1 )*H2 ) THEN
+*
+* find left rotation matrix Q to zero out B(2,1)
+*
+ CALL DLARTG( B( 1, 1 ), B( 2, 1 ), CSL, SNL, R )
+*
+ ELSE
+*
+* find left rotation matrix Q to zero out A(2,1)
+*
+ CALL DLARTG( A( 1, 1 ), A( 2, 1 ), CSL, SNL, R )
+*
+ END IF
+*
+ CALL DROT( 2, A( 1, 1 ), LDA, A( 2, 1 ), LDA, CSL, SNL )
+ CALL DROT( 2, B( 1, 1 ), LDB, B( 2, 1 ), LDB, CSL, SNL )
+*
+ A( 2, 1 ) = ZERO
+ B( 2, 1 ) = ZERO
+*
+ ELSE
+*
+* a pair of complex conjugate eigenvalues
+* first compute the SVD of the matrix B
+*
+ CALL DLASV2( B( 1, 1 ), B( 1, 2 ), B( 2, 2 ), R, T, SNR,
+ $ CSR, SNL, CSL )
+*
+* Form (A,B) := Q(A,B)Z' where Q is left rotation matrix and
+* Z is right rotation matrix computed from DLASV2
+*
+ CALL DROT( 2, A( 1, 1 ), LDA, A( 2, 1 ), LDA, CSL, SNL )
+ CALL DROT( 2, B( 1, 1 ), LDB, B( 2, 1 ), LDB, CSL, SNL )
+ CALL DROT( 2, A( 1, 1 ), 1, A( 1, 2 ), 1, CSR, SNR )
+ CALL DROT( 2, B( 1, 1 ), 1, B( 1, 2 ), 1, CSR, SNR )
+*
+ B( 2, 1 ) = ZERO
+ B( 1, 2 ) = ZERO
+*
+ END IF
+*
+ END IF
+*
+* Unscaling
+*
+ A( 1, 1 ) = ANORM*A( 1, 1 )
+ A( 2, 1 ) = ANORM*A( 2, 1 )
+ A( 1, 2 ) = ANORM*A( 1, 2 )
+ A( 2, 2 ) = ANORM*A( 2, 2 )
+ B( 1, 1 ) = BNORM*B( 1, 1 )
+ B( 2, 1 ) = BNORM*B( 2, 1 )
+ B( 1, 2 ) = BNORM*B( 1, 2 )
+ B( 2, 2 ) = BNORM*B( 2, 2 )
+*
+ IF( WI.EQ.ZERO ) THEN
+ ALPHAR( 1 ) = A( 1, 1 )
+ ALPHAR( 2 ) = A( 2, 2 )
+ ALPHAI( 1 ) = ZERO
+ ALPHAI( 2 ) = ZERO
+ BETA( 1 ) = B( 1, 1 )
+ BETA( 2 ) = B( 2, 2 )
+ ELSE
+ ALPHAR( 1 ) = ANORM*WR1 / SCALE1 / BNORM
+ ALPHAI( 1 ) = ANORM*WI / SCALE1 / BNORM
+ ALPHAR( 2 ) = ALPHAR( 1 )
+ ALPHAI( 2 ) = -ALPHAI( 1 )
+ BETA( 1 ) = ONE
+ BETA( 2 ) = ONE
+ END IF
+*
+ RETURN
+*
+* End of DLAGV2
+*
+ END
+ SUBROUTINE DLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI,
+ $ ILOZ, IHIZ, Z, LDZ, INFO )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, N
+ LOGICAL WANTT, WANTZ
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION H( LDH, * ), WI( * ), WR( * ), Z( LDZ, * )
+* ..
+*
+* Purpose
+* =======
+*
+* DLAHQR is an auxiliary routine called by DHSEQR to update the
+* eigenvalues and Schur decomposition already computed by DHSEQR, by
+* dealing with the Hessenberg submatrix in rows and columns ILO to
+* IHI.
+*
+* Arguments
+* =========
+*
+* WANTT (input) LOGICAL
+* = .TRUE. : the full Schur form T is required;
+* = .FALSE.: only eigenvalues are required.
+*
+* WANTZ (input) LOGICAL
+* = .TRUE. : the matrix of Schur vectors Z is required;
+* = .FALSE.: Schur vectors are not required.
+*
+* N (input) INTEGER
+* The order of the matrix H. N >= 0.
+*
+* ILO (input) INTEGER
+* IHI (input) INTEGER
+* It is assumed that H is already upper quasi-triangular in
+* rows and columns IHI+1:N, and that H(ILO,ILO-1) = 0 (unless
+* ILO = 1). DLAHQR works primarily with the Hessenberg
+* submatrix in rows and columns ILO to IHI, but applies
+* transformations to all of H if WANTT is .TRUE..
+* 1 <= ILO <= max(1,IHI); IHI <= N.
+*
+* H (input/output) DOUBLE PRECISION array, dimension (LDH,N)
+* On entry, the upper Hessenberg matrix H.
+* On exit, if INFO is zero and if WANTT is .TRUE., H is upper
+* quasi-triangular in rows and columns ILO:IHI, with any
+* 2-by-2 diagonal blocks in standard form. If INFO is zero
+* and WANTT is .FALSE., the contents of H are unspecified on
+* exit. The output state of H if INFO is nonzero is given
+* below under the description of INFO.
+*
+* LDH (input) INTEGER
+* The leading dimension of the array H. LDH >= max(1,N).
+*
+* WR (output) DOUBLE PRECISION array, dimension (N)
+* WI (output) DOUBLE PRECISION array, dimension (N)
+* The real and imaginary parts, respectively, of the computed
+* eigenvalues ILO to IHI are stored in the corresponding
+* elements of WR and WI. If two eigenvalues are computed as a
+* complex conjugate pair, they are stored in consecutive
+* elements of WR and WI, say the i-th and (i+1)th, with
+* WI(i) > 0 and WI(i+1) < 0. If WANTT is .TRUE., the
+* eigenvalues are stored in the same order as on the diagonal
+* of the Schur form returned in H, with WR(i) = H(i,i), and, if
+* H(i:i+1,i:i+1) is a 2-by-2 diagonal block,
+* WI(i) = sqrt(H(i+1,i)*H(i,i+1)) and WI(i+1) = -WI(i).
+*
+* ILOZ (input) INTEGER
+* IHIZ (input) INTEGER
+* Specify the rows of Z to which transformations must be
+* applied if WANTZ is .TRUE..
+* 1 <= ILOZ <= ILO; IHI <= IHIZ <= N.
+*
+* Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N)
+* If WANTZ is .TRUE., on entry Z must contain the current
+* matrix Z of transformations accumulated by DHSEQR, and on
+* exit Z has been updated; transformations are applied only to
+* the submatrix Z(ILOZ:IHIZ,ILO:IHI).
+* If WANTZ is .FALSE., Z is not referenced.
+*
+* LDZ (input) INTEGER
+* The leading dimension of the array Z. LDZ >= max(1,N).
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* .GT. 0: If INFO = i, DLAHQR failed to compute all the
+* eigenvalues ILO to IHI in a total of 30 iterations
+* per eigenvalue; elements i+1:ihi of WR and WI
+* contain those eigenvalues which have been
+* successfully computed.
+*
+* If INFO .GT. 0 and WANTT is .FALSE., then on exit,
+* the remaining unconverged eigenvalues are the
+* eigenvalues of the upper Hessenberg matrix rows
+* and columns ILO thorugh INFO of the final, output
+* value of H.
+*
+* If INFO .GT. 0 and WANTT is .TRUE., then on exit
+* (*) (initial value of H)*U = U*(final value of H)
+* where U is an orthognal matrix. The final
+* value of H is upper Hessenberg and triangular in
+* rows and columns INFO+1 through IHI.
+*
+* If INFO .GT. 0 and WANTZ is .TRUE., then on exit
+* (final value of Z) = (initial value of Z)*U
+* where U is the orthogonal matrix in (*)
+* (regardless of the value of WANTT.)
+*
+* Further Details
+* ===============
+*
+* 02-96 Based on modifications by
+* David Day, Sandia National Laboratory, USA
+*
+* 12-04 Further modifications by
+* Ralph Byers, University of Kansas, USA
+*
+* This is a modified version of DLAHQR from LAPACK version 3.0.
+* It is (1) more robust against overflow and underflow and
+* (2) adopts the more conservative Ahues & Tisseur stopping
+* criterion (LAWN 122, 1997).
+*
+* =========================================================
+*
+* .. Parameters ..
+ INTEGER ITMAX
+ PARAMETER ( ITMAX = 30 )
+ DOUBLE PRECISION ZERO, ONE, TWO
+ PARAMETER ( ZERO = 0.0d0, ONE = 1.0d0, TWO = 2.0d0 )
+ DOUBLE PRECISION DAT1, DAT2
+ PARAMETER ( DAT1 = 3.0d0 / 4.0d0, DAT2 = -0.4375d0 )
+* ..
+* .. Local Scalars ..
+ DOUBLE PRECISION AA, AB, BA, BB, CS, DET, H11, H12, H21, H21S,
+ $ H22, RT1I, RT1R, RT2I, RT2R, RTDISC, S, SAFMAX,
+ $ SAFMIN, SMLNUM, SN, SUM, T1, T2, T3, TR, TST,
+ $ ULP, V2, V3
+ INTEGER I, I1, I2, ITS, J, K, L, M, NH, NR, NZ
+* ..
+* .. Local Arrays ..
+ DOUBLE PRECISION V( 3 )
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DLAMCH
+ EXTERNAL DLAMCH
+* ..
+* .. External Subroutines ..
+ EXTERNAL DCOPY, DLABAD, DLANV2, DLARFG, DROT
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, DBLE, MAX, MIN, SQRT
+* ..
+* .. Executable Statements ..
+*
+ INFO = 0
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 )
+ $ RETURN
+ IF( ILO.EQ.IHI ) THEN
+ WR( ILO ) = H( ILO, ILO )
+ WI( ILO ) = ZERO
+ RETURN
+ END IF
+*
+* ==== clear out the trash ====
+ DO 10 J = ILO, IHI - 3
+ H( J+2, J ) = ZERO
+ H( J+3, J ) = ZERO
+ 10 CONTINUE
+ IF( ILO.LE.IHI-2 )
+ $ H( IHI, IHI-2 ) = ZERO
+*
+ NH = IHI - ILO + 1
+ NZ = IHIZ - ILOZ + 1
+*
+* Set machine-dependent constants for the stopping criterion.
+*
+ SAFMIN = DLAMCH( 'SAFE MINIMUM' )
+ SAFMAX = ONE / SAFMIN
+ CALL DLABAD( SAFMIN, SAFMAX )
+ ULP = DLAMCH( 'PRECISION' )
+ SMLNUM = SAFMIN*( DBLE( NH ) / ULP )
+*
+* I1 and I2 are the indices of the first row and last column of H
+* to which transformations must be applied. If eigenvalues only are
+* being computed, I1 and I2 are set inside the main loop.
+*
+ IF( WANTT ) THEN
+ I1 = 1
+ I2 = N
+ END IF
+*
+* The main loop begins here. I is the loop index and decreases from
+* IHI to ILO in steps of 1 or 2. Each iteration of the loop works
+* with the active submatrix in rows and columns L to I.
+* Eigenvalues I+1 to IHI have already converged. Either L = ILO or
+* H(L,L-1) is negligible so that the matrix splits.
+*
+ I = IHI
+ 20 CONTINUE
+ L = ILO
+ IF( I.LT.ILO )
+ $ GO TO 160
+*
+* Perform QR iterations on rows and columns ILO to I until a
+* submatrix of order 1 or 2 splits off at the bottom because a
+* subdiagonal element has become negligible.
+*
+ DO 140 ITS = 0, ITMAX
+*
+* Look for a single small subdiagonal element.
+*
+ DO 30 K = I, L + 1, -1
+ IF( ABS( H( K, K-1 ) ).LE.SMLNUM )
+ $ GO TO 40
+ TST = ABS( H( K-1, K-1 ) ) + ABS( H( K, K ) )
+ IF( TST.EQ.ZERO ) THEN
+ IF( K-2.GE.ILO )
+ $ TST = TST + ABS( H( K-1, K-2 ) )
+ IF( K+1.LE.IHI )
+ $ TST = TST + ABS( H( K+1, K ) )
+ END IF
+* ==== The following is a conservative small subdiagonal
+* . deflation criterion due to Ahues & Tisseur (LAWN 122,
+* . 1997). It has better mathematical foundation and
+* . improves accuracy in some cases. ====
+ IF( ABS( H( K, K-1 ) ).LE.ULP*TST ) THEN
+ AB = MAX( ABS( H( K, K-1 ) ), ABS( H( K-1, K ) ) )
+ BA = MIN( ABS( H( K, K-1 ) ), ABS( H( K-1, K ) ) )
+ AA = MAX( ABS( H( K, K ) ),
+ $ ABS( H( K-1, K-1 )-H( K, K ) ) )
+ BB = MIN( ABS( H( K, K ) ),
+ $ ABS( H( K-1, K-1 )-H( K, K ) ) )
+ S = AA + AB
+ IF( BA*( AB / S ).LE.MAX( SMLNUM,
+ $ ULP*( BB*( AA / S ) ) ) )GO TO 40
+ END IF
+ 30 CONTINUE
+ 40 CONTINUE
+ L = K
+ IF( L.GT.ILO ) THEN
+*
+* H(L,L-1) is negligible
+*
+ H( L, L-1 ) = ZERO
+ END IF
+*
+* Exit from loop if a submatrix of order 1 or 2 has split off.
+*
+ IF( L.GE.I-1 )
+ $ GO TO 150
+*
+* Now the active submatrix is in rows and columns L to I. If
+* eigenvalues only are being computed, only the active submatrix
+* need be transformed.
+*
+ IF( .NOT.WANTT ) THEN
+ I1 = L
+ I2 = I
+ END IF
+*
+ IF( ITS.EQ.10 .OR. ITS.EQ.20 ) THEN
+*
+* Exceptional shift.
+*
+ H11 = DAT1*S + H( I, I )
+ H12 = DAT2*S
+ H21 = S
+ H22 = H11
+ ELSE
+*
+* Prepare to use Francis' double shift
+* (i.e. 2nd degree generalized Rayleigh quotient)
+*
+ H11 = H( I-1, I-1 )
+ H21 = H( I, I-1 )
+ H12 = H( I-1, I )
+ H22 = H( I, I )
+ END IF
+ S = ABS( H11 ) + ABS( H12 ) + ABS( H21 ) + ABS( H22 )
+ IF( S.EQ.ZERO ) THEN
+ RT1R = ZERO
+ RT1I = ZERO
+ RT2R = ZERO
+ RT2I = ZERO
+ ELSE
+ H11 = H11 / S
+ H21 = H21 / S
+ H12 = H12 / S
+ H22 = H22 / S
+ TR = ( H11+H22 ) / TWO
+ DET = ( H11-TR )*( H22-TR ) - H12*H21
+ RTDISC = SQRT( ABS( DET ) )
+ IF( DET.GE.ZERO ) THEN
+*
+* ==== complex conjugate shifts ====
+*
+ RT1R = TR*S
+ RT2R = RT1R
+ RT1I = RTDISC*S
+ RT2I = -RT1I
+ ELSE
+*
+* ==== real shifts (use only one of them) ====
+*
+ RT1R = TR + RTDISC
+ RT2R = TR - RTDISC
+ IF( ABS( RT1R-H22 ).LE.ABS( RT2R-H22 ) ) THEN
+ RT1R = RT1R*S
+ RT2R = RT1R
+ ELSE
+ RT2R = RT2R*S
+ RT1R = RT2R
+ END IF
+ RT1I = ZERO
+ RT2I = ZERO
+ END IF
+ END IF
+*
+* Look for two consecutive small subdiagonal elements.
+*
+ DO 50 M = I - 2, L, -1
+* Determine the effect of starting the double-shift QR
+* iteration at row M, and see if this would make H(M,M-1)
+* negligible. (The following uses scaling to avoid
+* overflows and most underflows.)
+*
+ H21S = H( M+1, M )
+ S = ABS( H( M, M )-RT2R ) + ABS( RT2I ) + ABS( H21S )
+ H21S = H( M+1, M ) / S
+ V( 1 ) = H21S*H( M, M+1 ) + ( H( M, M )-RT1R )*
+ $ ( ( H( M, M )-RT2R ) / S ) - RT1I*( RT2I / S )
+ V( 2 ) = H21S*( H( M, M )+H( M+1, M+1 )-RT1R-RT2R )
+ V( 3 ) = H21S*H( M+2, M+1 )
+ S = ABS( V( 1 ) ) + ABS( V( 2 ) ) + ABS( V( 3 ) )
+ V( 1 ) = V( 1 ) / S
+ V( 2 ) = V( 2 ) / S
+ V( 3 ) = V( 3 ) / S
+ IF( M.EQ.L )
+ $ GO TO 60
+ IF( ABS( H( M, M-1 ) )*( ABS( V( 2 ) )+ABS( V( 3 ) ) ).LE.
+ $ ULP*ABS( V( 1 ) )*( ABS( H( M-1, M-1 ) )+ABS( H( M,
+ $ M ) )+ABS( H( M+1, M+1 ) ) ) )GO TO 60
+ 50 CONTINUE
+ 60 CONTINUE
+*
+* Double-shift QR step
+*
+ DO 130 K = M, I - 1
+*
+* The first iteration of this loop determines a reflection G
+* from the vector V and applies it from left and right to H,
+* thus creating a nonzero bulge below the subdiagonal.
+*
+* Each subsequent iteration determines a reflection G to
+* restore the Hessenberg form in the (K-1)th column, and thus
+* chases the bulge one step toward the bottom of the active
+* submatrix. NR is the order of G.
+*
+ NR = MIN( 3, I-K+1 )
+ IF( K.GT.M )
+ $ CALL DCOPY( NR, H( K, K-1 ), 1, V, 1 )
+ CALL DLARFG( NR, V( 1 ), V( 2 ), 1, T1 )
+ IF( K.GT.M ) THEN
+ H( K, K-1 ) = V( 1 )
+ H( K+1, K-1 ) = ZERO
+ IF( K.LT.I-1 )
+ $ H( K+2, K-1 ) = ZERO
+ ELSE IF( M.GT.L ) THEN
+ H( K, K-1 ) = -H( K, K-1 )
+ END IF
+ V2 = V( 2 )
+ T2 = T1*V2
+ IF( NR.EQ.3 ) THEN
+ V3 = V( 3 )
+ T3 = T1*V3
+*
+* Apply G from the left to transform the rows of the matrix
+* in columns K to I2.
+*
+ DO 70 J = K, I2
+ SUM = H( K, J ) + V2*H( K+1, J ) + V3*H( K+2, J )
+ H( K, J ) = H( K, J ) - SUM*T1
+ H( K+1, J ) = H( K+1, J ) - SUM*T2
+ H( K+2, J ) = H( K+2, J ) - SUM*T3
+ 70 CONTINUE
+*
+* Apply G from the right to transform the columns of the
+* matrix in rows I1 to min(K+3,I).
+*
+ DO 80 J = I1, MIN( K+3, I )
+ SUM = H( J, K ) + V2*H( J, K+1 ) + V3*H( J, K+2 )
+ H( J, K ) = H( J, K ) - SUM*T1
+ H( J, K+1 ) = H( J, K+1 ) - SUM*T2
+ H( J, K+2 ) = H( J, K+2 ) - SUM*T3
+ 80 CONTINUE
+*
+ IF( WANTZ ) THEN
+*
+* Accumulate transformations in the matrix Z
+*
+ DO 90 J = ILOZ, IHIZ
+ SUM = Z( J, K ) + V2*Z( J, K+1 ) + V3*Z( J, K+2 )
+ Z( J, K ) = Z( J, K ) - SUM*T1
+ Z( J, K+1 ) = Z( J, K+1 ) - SUM*T2
+ Z( J, K+2 ) = Z( J, K+2 ) - SUM*T3
+ 90 CONTINUE
+ END IF
+ ELSE IF( NR.EQ.2 ) THEN
+*
+* Apply G from the left to transform the rows of the matrix
+* in columns K to I2.
+*
+ DO 100 J = K, I2
+ SUM = H( K, J ) + V2*H( K+1, J )
+ H( K, J ) = H( K, J ) - SUM*T1
+ H( K+1, J ) = H( K+1, J ) - SUM*T2
+ 100 CONTINUE
+*
+* Apply G from the right to transform the columns of the
+* matrix in rows I1 to min(K+3,I).
+*
+ DO 110 J = I1, I
+ SUM = H( J, K ) + V2*H( J, K+1 )
+ H( J, K ) = H( J, K ) - SUM*T1
+ H( J, K+1 ) = H( J, K+1 ) - SUM*T2
+ 110 CONTINUE
+*
+ IF( WANTZ ) THEN
+*
+* Accumulate transformations in the matrix Z
+*
+ DO 120 J = ILOZ, IHIZ
+ SUM = Z( J, K ) + V2*Z( J, K+1 )
+ Z( J, K ) = Z( J, K ) - SUM*T1
+ Z( J, K+1 ) = Z( J, K+1 ) - SUM*T2
+ 120 CONTINUE
+ END IF
+ END IF
+ 130 CONTINUE
+*
+ 140 CONTINUE
+*
+* Failure to converge in remaining number of iterations
+*
+ INFO = I
+ RETURN
+*
+ 150 CONTINUE
+*
+ IF( L.EQ.I ) THEN
+*
+* H(I,I-1) is negligible: one eigenvalue has converged.
+*
+ WR( I ) = H( I, I )
+ WI( I ) = ZERO
+ ELSE IF( L.EQ.I-1 ) THEN
+*
+* H(I-1,I-2) is negligible: a pair of eigenvalues have converged.
+*
+* Transform the 2-by-2 submatrix to standard Schur form,
+* and compute and store the eigenvalues.
+*
+ CALL DLANV2( H( I-1, I-1 ), H( I-1, I ), H( I, I-1 ),
+ $ H( I, I ), WR( I-1 ), WI( I-1 ), WR( I ), WI( I ),
+ $ CS, SN )
+*
+ IF( WANTT ) THEN
+*
+* Apply the transformation to the rest of H.
+*
+ IF( I2.GT.I )
+ $ CALL DROT( I2-I, H( I-1, I+1 ), LDH, H( I, I+1 ), LDH,
+ $ CS, SN )
+ CALL DROT( I-I1-1, H( I1, I-1 ), 1, H( I1, I ), 1, CS, SN )
+ END IF
+ IF( WANTZ ) THEN
+*
+* Apply the transformation to Z.
+*
+ CALL DROT( NZ, Z( ILOZ, I-1 ), 1, Z( ILOZ, I ), 1, CS, SN )
+ END IF
+ END IF
+*
+* return to start of the main loop with new value of I.
+*
+ I = L - 1
+ GO TO 20
+*
+ 160 CONTINUE
+ RETURN
+*
+* End of DLAHQR
+*
+ END
+ SUBROUTINE DLAHR2( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER K, LDA, LDT, LDY, N, NB
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION A( LDA, * ), T( LDT, NB ), TAU( NB ),
+ $ Y( LDY, NB )
+* ..
+*
+* Purpose
+* =======
+*
+* DLAHR2 reduces the first NB columns of A real general n-BY-(n-k+1)
+* matrix A so that elements below the k-th subdiagonal are zero. The
+* reduction is performed by an orthogonal similarity transformation
+* Q' * A * Q. The routine returns the matrices V and T which determine
+* Q as a block reflector I - V*T*V', and also the matrix Y = A * V * T.
+*
+* This is an auxiliary routine called by DGEHRD.
+*
+* Arguments
+* =========
+*
+* N (input) INTEGER
+* The order of the matrix A.
+*
+* K (input) INTEGER
+* The offset for the reduction. Elements below the k-th
+* subdiagonal in the first NB columns are reduced to zero.
+* K < N.
+*
+* NB (input) INTEGER
+* The number of columns to be reduced.
+*
+* A (input/output) DOUBLE PRECISION array, dimension (LDA,N-K+1)
+* On entry, the n-by-(n-k+1) general matrix A.
+* On exit, the elements on and above the k-th subdiagonal in
+* the first NB columns are overwritten with the corresponding
+* elements of the reduced matrix; the elements below the k-th
+* subdiagonal, with the array TAU, represent the matrix Q as a
+* product of elementary reflectors. The other columns of A are
+* unchanged. See Further Details.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,N).
+*
+* TAU (output) DOUBLE PRECISION array, dimension (NB)
+* The scalar factors of the elementary reflectors. See Further
+* Details.
+*
+* T (output) DOUBLE PRECISION array, dimension (LDT,NB)
+* The upper triangular matrix T.
+*
+* LDT (input) INTEGER
+* The leading dimension of the array T. LDT >= NB.
+*
+* Y (output) DOUBLE PRECISION array, dimension (LDY,NB)
+* The n-by-nb matrix Y.
+*
+* LDY (input) INTEGER
+* The leading dimension of the array Y. LDY >= N.
+*
+* Further Details
+* ===============
+*
+* The matrix Q is represented as a product of nb elementary reflectors
+*
+* Q = H(1) H(2) . . . H(nb).
+*
+* Each H(i) has the form
+*
+* H(i) = I - tau * v * v'
+*
+* where tau is a real scalar, and v is a real vector with
+* v(1:i+k-1) = 0, v(i+k) = 1; v(i+k+1:n) is stored on exit in
+* A(i+k+1:n,i), and tau in TAU(i).
+*
+* The elements of the vectors v together form the (n-k+1)-by-nb matrix
+* V which is needed, with T and Y, to apply the transformation to the
+* unreduced part of the matrix, using an update of the form:
+* A := (I - V*T*V') * (A - Y*V').
+*
+* The contents of A on exit are illustrated by the following example
+* with n = 7, k = 3 and nb = 2:
+*
+* ( a a a a a )
+* ( a a a a a )
+* ( a a a a a )
+* ( h h a a a )
+* ( v1 h a a a )
+* ( v1 v2 a a a )
+* ( v1 v2 a a a )
+*
+* where a denotes an element of the original matrix A, h denotes a
+* modified element of the upper Hessenberg matrix H, and vi denotes an
+* element of the vector defining H(i).
+*
+* This file is a slight modification of LAPACK-3.0's DLAHRD
+* incorporating improvements proposed by Quintana-Orti and Van de
+* Gejin. Note that the entries of A(1:K,2:NB) differ from those
+* returned by the original LAPACK routine. This function is
+* not backward compatible with LAPACK3.0.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D+0,
+ $ ONE = 1.0D+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I
+ DOUBLE PRECISION EI
+* ..
+* .. External Subroutines ..
+ EXTERNAL DAXPY, DCOPY, DGEMM, DGEMV, DLACPY,
+ $ DLARFG, DSCAL, DTRMM, DTRMV
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MIN
+* ..
+* .. Executable Statements ..
+*
+* Quick return if possible
+*
+ IF( N.LE.1 )
+ $ RETURN
+*
+ DO 10 I = 1, NB
+ IF( I.GT.1 ) THEN
+*
+* Update A(K+1:N,I)
+*
+* Update I-th column of A - Y * V'
+*
+ CALL DGEMV( 'NO TRANSPOSE', N-K, I-1, -ONE, Y(K+1,1), LDY,
+ $ A( K+I-1, 1 ), LDA, ONE, A( K+1, I ), 1 )
+*
+* Apply I - V * T' * V' to this column (call it b) from the
+* left, using the last column of T as workspace
+*
+* Let V = ( V1 ) and b = ( b1 ) (first I-1 rows)
+* ( V2 ) ( b2 )
+*
+* where V1 is unit lower triangular
+*
+* w := V1' * b1
+*
+ CALL DCOPY( I-1, A( K+1, I ), 1, T( 1, NB ), 1 )
+ CALL DTRMV( 'Lower', 'Transpose', 'UNIT',
+ $ I-1, A( K+1, 1 ),
+ $ LDA, T( 1, NB ), 1 )
+*
+* w := w + V2'*b2
+*
+ CALL DGEMV( 'Transpose', N-K-I+1, I-1,
+ $ ONE, A( K+I, 1 ),
+ $ LDA, A( K+I, I ), 1, ONE, T( 1, NB ), 1 )
+*
+* w := T'*w
+*
+ CALL DTRMV( 'Upper', 'Transpose', 'NON-UNIT',
+ $ I-1, T, LDT,
+ $ T( 1, NB ), 1 )
+*
+* b2 := b2 - V2*w
+*
+ CALL DGEMV( 'NO TRANSPOSE', N-K-I+1, I-1, -ONE,
+ $ A( K+I, 1 ),
+ $ LDA, T( 1, NB ), 1, ONE, A( K+I, I ), 1 )
+*
+* b1 := b1 - V1*w
+*
+ CALL DTRMV( 'Lower', 'NO TRANSPOSE',
+ $ 'UNIT', I-1,
+ $ A( K+1, 1 ), LDA, T( 1, NB ), 1 )
+ CALL DAXPY( I-1, -ONE, T( 1, NB ), 1, A( K+1, I ), 1 )
+*
+ A( K+I-1, I-1 ) = EI
+ END IF
+*
+* Generate the elementary reflector H(I) to annihilate
+* A(K+I+1:N,I)
+*
+ CALL DLARFG( N-K-I+1, A( K+I, I ), A( MIN( K+I+1, N ), I ), 1,
+ $ TAU( I ) )
+ EI = A( K+I, I )
+ A( K+I, I ) = ONE
+*
+* Compute Y(K+1:N,I)
+*
+ CALL DGEMV( 'NO TRANSPOSE', N-K, N-K-I+1,
+ $ ONE, A( K+1, I+1 ),
+ $ LDA, A( K+I, I ), 1, ZERO, Y( K+1, I ), 1 )
+ CALL DGEMV( 'Transpose', N-K-I+1, I-1,
+ $ ONE, A( K+I, 1 ), LDA,
+ $ A( K+I, I ), 1, ZERO, T( 1, I ), 1 )
+ CALL DGEMV( 'NO TRANSPOSE', N-K, I-1, -ONE,
+ $ Y( K+1, 1 ), LDY,
+ $ T( 1, I ), 1, ONE, Y( K+1, I ), 1 )
+ CALL DSCAL( N-K, TAU( I ), Y( K+1, I ), 1 )
+*
+* Compute T(1:I,I)
+*
+ CALL DSCAL( I-1, -TAU( I ), T( 1, I ), 1 )
+ CALL DTRMV( 'Upper', 'No Transpose', 'NON-UNIT',
+ $ I-1, T, LDT,
+ $ T( 1, I ), 1 )
+ T( I, I ) = TAU( I )
+*
+ 10 CONTINUE
+ A( K+NB, NB ) = EI
+*
+* Compute Y(1:K,1:NB)
+*
+ CALL DLACPY( 'ALL', K, NB, A( 1, 2 ), LDA, Y, LDY )
+ CALL DTRMM( 'RIGHT', 'Lower', 'NO TRANSPOSE',
+ $ 'UNIT', K, NB,
+ $ ONE, A( K+1, 1 ), LDA, Y, LDY )
+ IF( N.GT.K+NB )
+ $ CALL DGEMM( 'NO TRANSPOSE', 'NO TRANSPOSE', K,
+ $ NB, N-K-NB, ONE,
+ $ A( 1, 2+NB ), LDA, A( K+1+NB, 1 ), LDA, ONE, Y,
+ $ LDY )
+ CALL DTRMM( 'RIGHT', 'Upper', 'NO TRANSPOSE',
+ $ 'NON-UNIT', K, NB,
+ $ ONE, T, LDT, Y, LDY )
+*
+ RETURN
+*
+* End of DLAHR2
+*
+ END
+ SUBROUTINE DLAHRD( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER K, LDA, LDT, LDY, N, NB
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION A( LDA, * ), T( LDT, NB ), TAU( NB ),
+ $ Y( LDY, NB )
+* ..
+*
+* Purpose
+* =======
+*
+* DLAHRD reduces the first NB columns of a real general n-by-(n-k+1)
+* matrix A so that elements below the k-th subdiagonal are zero. The
+* reduction is performed by an orthogonal similarity transformation
+* Q' * A * Q. The routine returns the matrices V and T which determine
+* Q as a block reflector I - V*T*V', and also the matrix Y = A * V * T.
+*
+* This is an OBSOLETE auxiliary routine.
+* This routine will be 'deprecated' in a future release.
+* Please use the new routine DLAHR2 instead.
+*
+* Arguments
+* =========
+*
+* N (input) INTEGER
+* The order of the matrix A.
+*
+* K (input) INTEGER
+* The offset for the reduction. Elements below the k-th
+* subdiagonal in the first NB columns are reduced to zero.
+*
+* NB (input) INTEGER
+* The number of columns to be reduced.
+*
+* A (input/output) DOUBLE PRECISION array, dimension (LDA,N-K+1)
+* On entry, the n-by-(n-k+1) general matrix A.
+* On exit, the elements on and above the k-th subdiagonal in
+* the first NB columns are overwritten with the corresponding
+* elements of the reduced matrix; the elements below the k-th
+* subdiagonal, with the array TAU, represent the matrix Q as a
+* product of elementary reflectors. The other columns of A are
+* unchanged. See Further Details.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,N).
+*
+* TAU (output) DOUBLE PRECISION array, dimension (NB)
+* The scalar factors of the elementary reflectors. See Further
+* Details.
+*
+* T (output) DOUBLE PRECISION array, dimension (LDT,NB)
+* The upper triangular matrix T.
+*
+* LDT (input) INTEGER
+* The leading dimension of the array T. LDT >= NB.
+*
+* Y (output) DOUBLE PRECISION array, dimension (LDY,NB)
+* The n-by-nb matrix Y.
+*
+* LDY (input) INTEGER
+* The leading dimension of the array Y. LDY >= N.
+*
+* Further Details
+* ===============
+*
+* The matrix Q is represented as a product of nb elementary reflectors
+*
+* Q = H(1) H(2) . . . H(nb).
+*
+* Each H(i) has the form
+*
+* H(i) = I - tau * v * v'
+*
+* where tau is a real scalar, and v is a real vector with
+* v(1:i+k-1) = 0, v(i+k) = 1; v(i+k+1:n) is stored on exit in
+* A(i+k+1:n,i), and tau in TAU(i).
+*
+* The elements of the vectors v together form the (n-k+1)-by-nb matrix
+* V which is needed, with T and Y, to apply the transformation to the
+* unreduced part of the matrix, using an update of the form:
+* A := (I - V*T*V') * (A - Y*V').
+*
+* The contents of A on exit are illustrated by the following example
+* with n = 7, k = 3 and nb = 2:
+*
+* ( a h a a a )
+* ( a h a a a )
+* ( a h a a a )
+* ( h h a a a )
+* ( v1 h a a a )
+* ( v1 v2 a a a )
+* ( v1 v2 a a a )
+*
+* where a denotes an element of the original matrix A, h denotes a
+* modified element of the upper Hessenberg matrix H, and vi denotes an
+* element of the vector defining H(i).
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I
+ DOUBLE PRECISION EI
+* ..
+* .. External Subroutines ..
+ EXTERNAL DAXPY, DCOPY, DGEMV, DLARFG, DSCAL, DTRMV
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MIN
+* ..
+* .. Executable Statements ..
+*
+* Quick return if possible
+*
+ IF( N.LE.1 )
+ $ RETURN
+*
+ DO 10 I = 1, NB
+ IF( I.GT.1 ) THEN
+*
+* Update A(1:n,i)
+*
+* Compute i-th column of A - Y * V'
+*
+ CALL DGEMV( 'No transpose', N, I-1, -ONE, Y, LDY,
+ $ A( K+I-1, 1 ), LDA, ONE, A( 1, I ), 1 )
+*
+* Apply I - V * T' * V' to this column (call it b) from the
+* left, using the last column of T as workspace
+*
+* Let V = ( V1 ) and b = ( b1 ) (first I-1 rows)
+* ( V2 ) ( b2 )
+*
+* where V1 is unit lower triangular
+*
+* w := V1' * b1
+*
+ CALL DCOPY( I-1, A( K+1, I ), 1, T( 1, NB ), 1 )
+ CALL DTRMV( 'Lower', 'Transpose', 'Unit', I-1, A( K+1, 1 ),
+ $ LDA, T( 1, NB ), 1 )
+*
+* w := w + V2'*b2
+*
+ CALL DGEMV( 'Transpose', N-K-I+1, I-1, ONE, A( K+I, 1 ),
+ $ LDA, A( K+I, I ), 1, ONE, T( 1, NB ), 1 )
+*
+* w := T'*w
+*
+ CALL DTRMV( 'Upper', 'Transpose', 'Non-unit', I-1, T, LDT,
+ $ T( 1, NB ), 1 )
+*
+* b2 := b2 - V2*w
+*
+ CALL DGEMV( 'No transpose', N-K-I+1, I-1, -ONE, A( K+I, 1 ),
+ $ LDA, T( 1, NB ), 1, ONE, A( K+I, I ), 1 )
+*
+* b1 := b1 - V1*w
+*
+ CALL DTRMV( 'Lower', 'No transpose', 'Unit', I-1,
+ $ A( K+1, 1 ), LDA, T( 1, NB ), 1 )
+ CALL DAXPY( I-1, -ONE, T( 1, NB ), 1, A( K+1, I ), 1 )
+*
+ A( K+I-1, I-1 ) = EI
+ END IF
+*
+* Generate the elementary reflector H(i) to annihilate
+* A(k+i+1:n,i)
+*
+ CALL DLARFG( N-K-I+1, A( K+I, I ), A( MIN( K+I+1, N ), I ), 1,
+ $ TAU( I ) )
+ EI = A( K+I, I )
+ A( K+I, I ) = ONE
+*
+* Compute Y(1:n,i)
+*
+ CALL DGEMV( 'No transpose', N, N-K-I+1, ONE, A( 1, I+1 ), LDA,
+ $ A( K+I, I ), 1, ZERO, Y( 1, I ), 1 )
+ CALL DGEMV( 'Transpose', N-K-I+1, I-1, ONE, A( K+I, 1 ), LDA,
+ $ A( K+I, I ), 1, ZERO, T( 1, I ), 1 )
+ CALL DGEMV( 'No transpose', N, I-1, -ONE, Y, LDY, T( 1, I ), 1,
+ $ ONE, Y( 1, I ), 1 )
+ CALL DSCAL( N, TAU( I ), Y( 1, I ), 1 )
+*
+* Compute T(1:i,i)
+*
+ CALL DSCAL( I-1, -TAU( I ), T( 1, I ), 1 )
+ CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, T, LDT,
+ $ T( 1, I ), 1 )
+ T( I, I ) = TAU( I )
+*
+ 10 CONTINUE
+ A( K+NB, NB ) = EI
+*
+ RETURN
+*
+* End of DLAHRD
+*
+ END
+ SUBROUTINE DLAIC1( JOB, J, X, SEST, W, GAMMA, SESTPR, S, C )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER J, JOB
+ DOUBLE PRECISION C, GAMMA, S, SEST, SESTPR
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION W( J ), X( J )
+* ..
+*
+* Purpose
+* =======
+*
+* DLAIC1 applies one step of incremental condition estimation in
+* its simplest version:
+*
+* Let x, twonorm(x) = 1, be an approximate singular vector of an j-by-j
+* lower triangular matrix L, such that
+* twonorm(L*x) = sest
+* Then DLAIC1 computes sestpr, s, c such that
+* the vector
+* [ s*x ]
+* xhat = [ c ]
+* is an approximate singular vector of
+* [ L 0 ]
+* Lhat = [ w' gamma ]
+* in the sense that
+* twonorm(Lhat*xhat) = sestpr.
+*
+* Depending on JOB, an estimate for the largest or smallest singular
+* value is computed.
+*
+* Note that [s c]' and sestpr**2 is an eigenpair of the system
+*
+* diag(sest*sest, 0) + [alpha gamma] * [ alpha ]
+* [ gamma ]
+*
+* where alpha = x'*w.
+*
+* Arguments
+* =========
+*
+* JOB (input) INTEGER
+* = 1: an estimate for the largest singular value is computed.
+* = 2: an estimate for the smallest singular value is computed.
+*
+* J (input) INTEGER
+* Length of X and W
+*
+* X (input) DOUBLE PRECISION array, dimension (J)
+* The j-vector x.
+*
+* SEST (input) DOUBLE PRECISION
+* Estimated singular value of j by j matrix L
+*
+* W (input) DOUBLE PRECISION array, dimension (J)
+* The j-vector w.
+*
+* GAMMA (input) DOUBLE PRECISION
+* The diagonal element gamma.
+*
+* SESTPR (output) DOUBLE PRECISION
+* Estimated singular value of (j+1) by (j+1) matrix Lhat.
+*
+* S (output) DOUBLE PRECISION
+* Sine needed in forming xhat.
+*
+* C (output) DOUBLE PRECISION
+* Cosine needed in forming xhat.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE, TWO
+ PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 )
+ DOUBLE PRECISION HALF, FOUR
+ PARAMETER ( HALF = 0.5D0, FOUR = 4.0D0 )
+* ..
+* .. Local Scalars ..
+ DOUBLE PRECISION ABSALP, ABSEST, ABSGAM, ALPHA, B, COSINE, EPS,
+ $ NORMA, S1, S2, SINE, T, TEST, TMP, ZETA1, ZETA2
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, SIGN, SQRT
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DDOT, DLAMCH
+ EXTERNAL DDOT, DLAMCH
+* ..
+* .. Executable Statements ..
+*
+ EPS = DLAMCH( 'Epsilon' )
+ ALPHA = DDOT( J, X, 1, W, 1 )
+*
+ ABSALP = ABS( ALPHA )
+ ABSGAM = ABS( GAMMA )
+ ABSEST = ABS( SEST )
+*
+ IF( JOB.EQ.1 ) THEN
+*
+* Estimating largest singular value
+*
+* special cases
+*
+ IF( SEST.EQ.ZERO ) THEN
+ S1 = MAX( ABSGAM, ABSALP )
+ IF( S1.EQ.ZERO ) THEN
+ S = ZERO
+ C = ONE
+ SESTPR = ZERO
+ ELSE
+ S = ALPHA / S1
+ C = GAMMA / S1
+ TMP = SQRT( S*S+C*C )
+ S = S / TMP
+ C = C / TMP
+ SESTPR = S1*TMP
+ END IF
+ RETURN
+ ELSE IF( ABSGAM.LE.EPS*ABSEST ) THEN
+ S = ONE
+ C = ZERO
+ TMP = MAX( ABSEST, ABSALP )
+ S1 = ABSEST / TMP
+ S2 = ABSALP / TMP
+ SESTPR = TMP*SQRT( S1*S1+S2*S2 )
+ RETURN
+ ELSE IF( ABSALP.LE.EPS*ABSEST ) THEN
+ S1 = ABSGAM
+ S2 = ABSEST
+ IF( S1.LE.S2 ) THEN
+ S = ONE
+ C = ZERO
+ SESTPR = S2
+ ELSE
+ S = ZERO
+ C = ONE
+ SESTPR = S1
+ END IF
+ RETURN
+ ELSE IF( ABSEST.LE.EPS*ABSALP .OR. ABSEST.LE.EPS*ABSGAM ) THEN
+ S1 = ABSGAM
+ S2 = ABSALP
+ IF( S1.LE.S2 ) THEN
+ TMP = S1 / S2
+ S = SQRT( ONE+TMP*TMP )
+ SESTPR = S2*S
+ C = ( GAMMA / S2 ) / S
+ S = SIGN( ONE, ALPHA ) / S
+ ELSE
+ TMP = S2 / S1
+ C = SQRT( ONE+TMP*TMP )
+ SESTPR = S1*C
+ S = ( ALPHA / S1 ) / C
+ C = SIGN( ONE, GAMMA ) / C
+ END IF
+ RETURN
+ ELSE
+*
+* normal case
+*
+ ZETA1 = ALPHA / ABSEST
+ ZETA2 = GAMMA / ABSEST
+*
+ B = ( ONE-ZETA1*ZETA1-ZETA2*ZETA2 )*HALF
+ C = ZETA1*ZETA1
+ IF( B.GT.ZERO ) THEN
+ T = C / ( B+SQRT( B*B+C ) )
+ ELSE
+ T = SQRT( B*B+C ) - B
+ END IF
+*
+ SINE = -ZETA1 / T
+ COSINE = -ZETA2 / ( ONE+T )
+ TMP = SQRT( SINE*SINE+COSINE*COSINE )
+ S = SINE / TMP
+ C = COSINE / TMP
+ SESTPR = SQRT( T+ONE )*ABSEST
+ RETURN
+ END IF
+*
+ ELSE IF( JOB.EQ.2 ) THEN
+*
+* Estimating smallest singular value
+*
+* special cases
+*
+ IF( SEST.EQ.ZERO ) THEN
+ SESTPR = ZERO
+ IF( MAX( ABSGAM, ABSALP ).EQ.ZERO ) THEN
+ SINE = ONE
+ COSINE = ZERO
+ ELSE
+ SINE = -GAMMA
+ COSINE = ALPHA
+ END IF
+ S1 = MAX( ABS( SINE ), ABS( COSINE ) )
+ S = SINE / S1
+ C = COSINE / S1
+ TMP = SQRT( S*S+C*C )
+ S = S / TMP
+ C = C / TMP
+ RETURN
+ ELSE IF( ABSGAM.LE.EPS*ABSEST ) THEN
+ S = ZERO
+ C = ONE
+ SESTPR = ABSGAM
+ RETURN
+ ELSE IF( ABSALP.LE.EPS*ABSEST ) THEN
+ S1 = ABSGAM
+ S2 = ABSEST
+ IF( S1.LE.S2 ) THEN
+ S = ZERO
+ C = ONE
+ SESTPR = S1
+ ELSE
+ S = ONE
+ C = ZERO
+ SESTPR = S2
+ END IF
+ RETURN
+ ELSE IF( ABSEST.LE.EPS*ABSALP .OR. ABSEST.LE.EPS*ABSGAM ) THEN
+ S1 = ABSGAM
+ S2 = ABSALP
+ IF( S1.LE.S2 ) THEN
+ TMP = S1 / S2
+ C = SQRT( ONE+TMP*TMP )
+ SESTPR = ABSEST*( TMP / C )
+ S = -( GAMMA / S2 ) / C
+ C = SIGN( ONE, ALPHA ) / C
+ ELSE
+ TMP = S2 / S1
+ S = SQRT( ONE+TMP*TMP )
+ SESTPR = ABSEST / S
+ C = ( ALPHA / S1 ) / S
+ S = -SIGN( ONE, GAMMA ) / S
+ END IF
+ RETURN
+ ELSE
+*
+* normal case
+*
+ ZETA1 = ALPHA / ABSEST
+ ZETA2 = GAMMA / ABSEST
+*
+ NORMA = MAX( ONE+ZETA1*ZETA1+ABS( ZETA1*ZETA2 ),
+ $ ABS( ZETA1*ZETA2 )+ZETA2*ZETA2 )
+*
+* See if root is closer to zero or to ONE
+*
+ TEST = ONE + TWO*( ZETA1-ZETA2 )*( ZETA1+ZETA2 )
+ IF( TEST.GE.ZERO ) THEN
+*
+* root is close to zero, compute directly
+*
+ B = ( ZETA1*ZETA1+ZETA2*ZETA2+ONE )*HALF
+ C = ZETA2*ZETA2
+ T = C / ( B+SQRT( ABS( B*B-C ) ) )
+ SINE = ZETA1 / ( ONE-T )
+ COSINE = -ZETA2 / T
+ SESTPR = SQRT( T+FOUR*EPS*EPS*NORMA )*ABSEST
+ ELSE
+*
+* root is closer to ONE, shift by that amount
+*
+ B = ( ZETA2*ZETA2+ZETA1*ZETA1-ONE )*HALF
+ C = ZETA1*ZETA1
+ IF( B.GE.ZERO ) THEN
+ T = -C / ( B+SQRT( B*B+C ) )
+ ELSE
+ T = B - SQRT( B*B+C )
+ END IF
+ SINE = -ZETA1 / T
+ COSINE = -ZETA2 / ( ONE+T )
+ SESTPR = SQRT( ONE+T+FOUR*EPS*EPS*NORMA )*ABSEST
+ END IF
+ TMP = SQRT( SINE*SINE+COSINE*COSINE )
+ S = SINE / TMP
+ C = COSINE / TMP
+ RETURN
+*
+ END IF
+ END IF
+ RETURN
+*
+* End of DLAIC1
+*
+ END
+ LOGICAL FUNCTION DLAISNAN(DIN1,DIN2)
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ DOUBLE PRECISION DIN1,DIN2
+* ..
+*
+* Purpose
+* =======
+*
+* This routine is not for general use. It exists solely to avoid
+* over-optimization in DISNAN.
+*
+* DLAISNAN checks for NaNs by comparing its two arguments for
+* inequality. NaN is the only floating-point value where NaN != NaN
+* returns .TRUE. To check for NaNs, pass the same variable as both
+* arguments.
+*
+* Strictly speaking, Fortran does not allow aliasing of function
+* arguments. So a compiler must assume that the two arguments are
+* not the same variable, and the test will not be optimized away.
+* Interprocedural or whole-program optimization may delete this
+* test. The ISNAN functions will be replaced by the correct
+* Fortran 03 intrinsic once the intrinsic is widely available.
+*
+* Arguments
+* =========
+*
+* DIN1 (input) DOUBLE PRECISION
+* DIN2 (input) DOUBLE PRECISION
+* Two numbers to compare for inequality.
+*
+* =====================================================================
+*
+* .. Executable Statements ..
+ DLAISNAN = (DIN1.NE.DIN2)
+ RETURN
+ END
+ SUBROUTINE DLALN2( LTRANS, NA, NW, SMIN, CA, A, LDA, D1, D2, B,
+ $ LDB, WR, WI, X, LDX, SCALE, XNORM, INFO )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ LOGICAL LTRANS
+ INTEGER INFO, LDA, LDB, LDX, NA, NW
+ DOUBLE PRECISION CA, D1, D2, SCALE, SMIN, WI, WR, XNORM
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION A( LDA, * ), B( LDB, * ), X( LDX, * )
+* ..
+*
+* Purpose
+* =======
+*
+* DLALN2 solves a system of the form (ca A - w D ) X = s B
+* or (ca A' - w D) X = s B with possible scaling ("s") and
+* perturbation of A. (A' means A-transpose.)
+*
+* A is an NA x NA real matrix, ca is a real scalar, D is an NA x NA
+* real diagonal matrix, w is a real or complex value, and X and B are
+* NA x 1 matrices -- real if w is real, complex if w is complex. NA
+* may be 1 or 2.
+*
+* If w is complex, X and B are represented as NA x 2 matrices,
+* the first column of each being the real part and the second
+* being the imaginary part.
+*
+* "s" is a scaling factor (.LE. 1), computed by DLALN2, which is
+* so chosen that X can be computed without overflow. X is further
+* scaled if necessary to assure that norm(ca A - w D)*norm(X) is less
+* than overflow.
+*
+* If both singular values of (ca A - w D) are less than SMIN,
+* SMIN*identity will be used instead of (ca A - w D). If only one
+* singular value is less than SMIN, one element of (ca A - w D) will be
+* perturbed enough to make the smallest singular value roughly SMIN.
+* If both singular values are at least SMIN, (ca A - w D) will not be
+* perturbed. In any case, the perturbation will be at most some small
+* multiple of max( SMIN, ulp*norm(ca A - w D) ). The singular values
+* are computed by infinity-norm approximations, and thus will only be
+* correct to a factor of 2 or so.
+*
+* Note: all input quantities are assumed to be smaller than overflow
+* by a reasonable factor. (See BIGNUM.)
+*
+* Arguments
+* ==========
+*
+* LTRANS (input) LOGICAL
+* =.TRUE.: A-transpose will be used.
+* =.FALSE.: A will be used (not transposed.)
+*
+* NA (input) INTEGER
+* The size of the matrix A. It may (only) be 1 or 2.
+*
+* NW (input) INTEGER
+* 1 if "w" is real, 2 if "w" is complex. It may only be 1
+* or 2.
+*
+* SMIN (input) DOUBLE PRECISION
+* The desired lower bound on the singular values of A. This
+* should be a safe distance away from underflow or overflow,
+* say, between (underflow/machine precision) and (machine
+* precision * overflow ). (See BIGNUM and ULP.)
+*
+* CA (input) DOUBLE PRECISION
+* The coefficient c, which A is multiplied by.
+*
+* A (input) DOUBLE PRECISION array, dimension (LDA,NA)
+* The NA x NA matrix A.
+*
+* LDA (input) INTEGER
+* The leading dimension of A. It must be at least NA.
+*
+* D1 (input) DOUBLE PRECISION
+* The 1,1 element in the diagonal matrix D.
+*
+* D2 (input) DOUBLE PRECISION
+* The 2,2 element in the diagonal matrix D. Not used if NW=1.
+*
+* B (input) DOUBLE PRECISION array, dimension (LDB,NW)
+* The NA x NW matrix B (right-hand side). If NW=2 ("w" is
+* complex), column 1 contains the real part of B and column 2
+* contains the imaginary part.
+*
+* LDB (input) INTEGER
+* The leading dimension of B. It must be at least NA.
+*
+* WR (input) DOUBLE PRECISION
+* The real part of the scalar "w".
+*
+* WI (input) DOUBLE PRECISION
+* The imaginary part of the scalar "w". Not used if NW=1.
+*
+* X (output) DOUBLE PRECISION array, dimension (LDX,NW)
+* The NA x NW matrix X (unknowns), as computed by DLALN2.
+* If NW=2 ("w" is complex), on exit, column 1 will contain
+* the real part of X and column 2 will contain the imaginary
+* part.
+*
+* LDX (input) INTEGER
+* The leading dimension of X. It must be at least NA.
+*
+* SCALE (output) DOUBLE PRECISION
+* The scale factor that B must be multiplied by to insure
+* that overflow does not occur when computing X. Thus,
+* (ca A - w D) X will be SCALE*B, not B (ignoring
+* perturbations of A.) It will be at most 1.
+*
+* XNORM (output) DOUBLE PRECISION
+* The infinity-norm of X, when X is regarded as an NA x NW
+* real matrix.
+*
+* INFO (output) INTEGER
+* An error flag. It will be set to zero if no error occurs,
+* a negative number if an argument is in error, or a positive
+* number if ca A - w D had to be perturbed.
+* The possible values are:
+* = 0: No error occurred, and (ca A - w D) did not have to be
+* perturbed.
+* = 1: (ca A - w D) had to be perturbed to make its smallest
+* (or only) singular value greater than SMIN.
+* NOTE: In the interests of speed, this routine does not
+* check the inputs for errors.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
+ DOUBLE PRECISION TWO
+ PARAMETER ( TWO = 2.0D0 )
+* ..
+* .. Local Scalars ..
+ INTEGER ICMAX, J
+ DOUBLE PRECISION BBND, BI1, BI2, BIGNUM, BNORM, BR1, BR2, CI21,
+ $ CI22, CMAX, CNORM, CR21, CR22, CSI, CSR, LI21,
+ $ LR21, SMINI, SMLNUM, TEMP, U22ABS, UI11, UI11R,
+ $ UI12, UI12S, UI22, UR11, UR11R, UR12, UR12S,
+ $ UR22, XI1, XI2, XR1, XR2
+* ..
+* .. Local Arrays ..
+ LOGICAL RSWAP( 4 ), ZSWAP( 4 )
+ INTEGER IPIVOT( 4, 4 )
+ DOUBLE PRECISION CI( 2, 2 ), CIV( 4 ), CR( 2, 2 ), CRV( 4 )
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DLAMCH
+ EXTERNAL DLAMCH
+* ..
+* .. External Subroutines ..
+ EXTERNAL DLADIV
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX
+* ..
+* .. Equivalences ..
+ EQUIVALENCE ( CI( 1, 1 ), CIV( 1 ) ),
+ $ ( CR( 1, 1 ), CRV( 1 ) )
+* ..
+* .. Data statements ..
+ DATA ZSWAP / .FALSE., .FALSE., .TRUE., .TRUE. /
+ DATA RSWAP / .FALSE., .TRUE., .FALSE., .TRUE. /
+ DATA IPIVOT / 1, 2, 3, 4, 2, 1, 4, 3, 3, 4, 1, 2, 4,
+ $ 3, 2, 1 /
+* ..
+* .. Executable Statements ..
+*
+* Compute BIGNUM
+*
+ SMLNUM = TWO*DLAMCH( 'Safe minimum' )
+ BIGNUM = ONE / SMLNUM
+ SMINI = MAX( SMIN, SMLNUM )
+*
+* Don't check for input errors
+*
+ INFO = 0
+*
+* Standard Initializations
+*
+ SCALE = ONE
+*
+ IF( NA.EQ.1 ) THEN
+*
+* 1 x 1 (i.e., scalar) system C X = B
+*
+ IF( NW.EQ.1 ) THEN
+*
+* Real 1x1 system.
+*
+* C = ca A - w D
+*
+ CSR = CA*A( 1, 1 ) - WR*D1
+ CNORM = ABS( CSR )
+*
+* If | C | < SMINI, use C = SMINI
+*
+ IF( CNORM.LT.SMINI ) THEN
+ CSR = SMINI
+ CNORM = SMINI
+ INFO = 1
+ END IF
+*
+* Check scaling for X = B / C
+*
+ BNORM = ABS( B( 1, 1 ) )
+ IF( CNORM.LT.ONE .AND. BNORM.GT.ONE ) THEN
+ IF( BNORM.GT.BIGNUM*CNORM )
+ $ SCALE = ONE / BNORM
+ END IF
+*
+* Compute X
+*
+ X( 1, 1 ) = ( B( 1, 1 )*SCALE ) / CSR
+ XNORM = ABS( X( 1, 1 ) )
+ ELSE
+*
+* Complex 1x1 system (w is complex)
+*
+* C = ca A - w D
+*
+ CSR = CA*A( 1, 1 ) - WR*D1
+ CSI = -WI*D1
+ CNORM = ABS( CSR ) + ABS( CSI )
+*
+* If | C | < SMINI, use C = SMINI
+*
+ IF( CNORM.LT.SMINI ) THEN
+ CSR = SMINI
+ CSI = ZERO
+ CNORM = SMINI
+ INFO = 1
+ END IF
+*
+* Check scaling for X = B / C
+*
+ BNORM = ABS( B( 1, 1 ) ) + ABS( B( 1, 2 ) )
+ IF( CNORM.LT.ONE .AND. BNORM.GT.ONE ) THEN
+ IF( BNORM.GT.BIGNUM*CNORM )
+ $ SCALE = ONE / BNORM
+ END IF
+*
+* Compute X
+*
+ CALL DLADIV( SCALE*B( 1, 1 ), SCALE*B( 1, 2 ), CSR, CSI,
+ $ X( 1, 1 ), X( 1, 2 ) )
+ XNORM = ABS( X( 1, 1 ) ) + ABS( X( 1, 2 ) )
+ END IF
+*
+ ELSE
+*
+* 2x2 System
+*
+* Compute the real part of C = ca A - w D (or ca A' - w D )
+*
+ CR( 1, 1 ) = CA*A( 1, 1 ) - WR*D1
+ CR( 2, 2 ) = CA*A( 2, 2 ) - WR*D2
+ IF( LTRANS ) THEN
+ CR( 1, 2 ) = CA*A( 2, 1 )
+ CR( 2, 1 ) = CA*A( 1, 2 )
+ ELSE
+ CR( 2, 1 ) = CA*A( 2, 1 )
+ CR( 1, 2 ) = CA*A( 1, 2 )
+ END IF
+*
+ IF( NW.EQ.1 ) THEN
+*
+* Real 2x2 system (w is real)
+*
+* Find the largest element in C
+*
+ CMAX = ZERO
+ ICMAX = 0
+*
+ DO 10 J = 1, 4
+ IF( ABS( CRV( J ) ).GT.CMAX ) THEN
+ CMAX = ABS( CRV( J ) )
+ ICMAX = J
+ END IF
+ 10 CONTINUE
+*
+* If norm(C) < SMINI, use SMINI*identity.
+*
+ IF( CMAX.LT.SMINI ) THEN
+ BNORM = MAX( ABS( B( 1, 1 ) ), ABS( B( 2, 1 ) ) )
+ IF( SMINI.LT.ONE .AND. BNORM.GT.ONE ) THEN
+ IF( BNORM.GT.BIGNUM*SMINI )
+ $ SCALE = ONE / BNORM
+ END IF
+ TEMP = SCALE / SMINI
+ X( 1, 1 ) = TEMP*B( 1, 1 )
+ X( 2, 1 ) = TEMP*B( 2, 1 )
+ XNORM = TEMP*BNORM
+ INFO = 1
+ RETURN
+ END IF
+*
+* Gaussian elimination with complete pivoting.
+*
+ UR11 = CRV( ICMAX )
+ CR21 = CRV( IPIVOT( 2, ICMAX ) )
+ UR12 = CRV( IPIVOT( 3, ICMAX ) )
+ CR22 = CRV( IPIVOT( 4, ICMAX ) )
+ UR11R = ONE / UR11
+ LR21 = UR11R*CR21
+ UR22 = CR22 - UR12*LR21
+*
+* If smaller pivot < SMINI, use SMINI
+*
+ IF( ABS( UR22 ).LT.SMINI ) THEN
+ UR22 = SMINI
+ INFO = 1
+ END IF
+ IF( RSWAP( ICMAX ) ) THEN
+ BR1 = B( 2, 1 )
+ BR2 = B( 1, 1 )
+ ELSE
+ BR1 = B( 1, 1 )
+ BR2 = B( 2, 1 )
+ END IF
+ BR2 = BR2 - LR21*BR1
+ BBND = MAX( ABS( BR1*( UR22*UR11R ) ), ABS( BR2 ) )
+ IF( BBND.GT.ONE .AND. ABS( UR22 ).LT.ONE ) THEN
+ IF( BBND.GE.BIGNUM*ABS( UR22 ) )
+ $ SCALE = ONE / BBND
+ END IF
+*
+ XR2 = ( BR2*SCALE ) / UR22
+ XR1 = ( SCALE*BR1 )*UR11R - XR2*( UR11R*UR12 )
+ IF( ZSWAP( ICMAX ) ) THEN
+ X( 1, 1 ) = XR2
+ X( 2, 1 ) = XR1
+ ELSE
+ X( 1, 1 ) = XR1
+ X( 2, 1 ) = XR2
+ END IF
+ XNORM = MAX( ABS( XR1 ), ABS( XR2 ) )
+*
+* Further scaling if norm(A) norm(X) > overflow
+*
+ IF( XNORM.GT.ONE .AND. CMAX.GT.ONE ) THEN
+ IF( XNORM.GT.BIGNUM / CMAX ) THEN
+ TEMP = CMAX / BIGNUM
+ X( 1, 1 ) = TEMP*X( 1, 1 )
+ X( 2, 1 ) = TEMP*X( 2, 1 )
+ XNORM = TEMP*XNORM
+ SCALE = TEMP*SCALE
+ END IF
+ END IF
+ ELSE
+*
+* Complex 2x2 system (w is complex)
+*
+* Find the largest element in C
+*
+ CI( 1, 1 ) = -WI*D1
+ CI( 2, 1 ) = ZERO
+ CI( 1, 2 ) = ZERO
+ CI( 2, 2 ) = -WI*D2
+ CMAX = ZERO
+ ICMAX = 0
+*
+ DO 20 J = 1, 4
+ IF( ABS( CRV( J ) )+ABS( CIV( J ) ).GT.CMAX ) THEN
+ CMAX = ABS( CRV( J ) ) + ABS( CIV( J ) )
+ ICMAX = J
+ END IF
+ 20 CONTINUE
+*
+* If norm(C) < SMINI, use SMINI*identity.
+*
+ IF( CMAX.LT.SMINI ) THEN
+ BNORM = MAX( ABS( B( 1, 1 ) )+ABS( B( 1, 2 ) ),
+ $ ABS( B( 2, 1 ) )+ABS( B( 2, 2 ) ) )
+ IF( SMINI.LT.ONE .AND. BNORM.GT.ONE ) THEN
+ IF( BNORM.GT.BIGNUM*SMINI )
+ $ SCALE = ONE / BNORM
+ END IF
+ TEMP = SCALE / SMINI
+ X( 1, 1 ) = TEMP*B( 1, 1 )
+ X( 2, 1 ) = TEMP*B( 2, 1 )
+ X( 1, 2 ) = TEMP*B( 1, 2 )
+ X( 2, 2 ) = TEMP*B( 2, 2 )
+ XNORM = TEMP*BNORM
+ INFO = 1
+ RETURN
+ END IF
+*
+* Gaussian elimination with complete pivoting.
+*
+ UR11 = CRV( ICMAX )
+ UI11 = CIV( ICMAX )
+ CR21 = CRV( IPIVOT( 2, ICMAX ) )
+ CI21 = CIV( IPIVOT( 2, ICMAX ) )
+ UR12 = CRV( IPIVOT( 3, ICMAX ) )
+ UI12 = CIV( IPIVOT( 3, ICMAX ) )
+ CR22 = CRV( IPIVOT( 4, ICMAX ) )
+ CI22 = CIV( IPIVOT( 4, ICMAX ) )
+ IF( ICMAX.EQ.1 .OR. ICMAX.EQ.4 ) THEN
+*
+* Code when off-diagonals of pivoted C are real
+*
+ IF( ABS( UR11 ).GT.ABS( UI11 ) ) THEN
+ TEMP = UI11 / UR11
+ UR11R = ONE / ( UR11*( ONE+TEMP**2 ) )
+ UI11R = -TEMP*UR11R
+ ELSE
+ TEMP = UR11 / UI11
+ UI11R = -ONE / ( UI11*( ONE+TEMP**2 ) )
+ UR11R = -TEMP*UI11R
+ END IF
+ LR21 = CR21*UR11R
+ LI21 = CR21*UI11R
+ UR12S = UR12*UR11R
+ UI12S = UR12*UI11R
+ UR22 = CR22 - UR12*LR21
+ UI22 = CI22 - UR12*LI21
+ ELSE
+*
+* Code when diagonals of pivoted C are real
+*
+ UR11R = ONE / UR11
+ UI11R = ZERO
+ LR21 = CR21*UR11R
+ LI21 = CI21*UR11R
+ UR12S = UR12*UR11R
+ UI12S = UI12*UR11R
+ UR22 = CR22 - UR12*LR21 + UI12*LI21
+ UI22 = -UR12*LI21 - UI12*LR21
+ END IF
+ U22ABS = ABS( UR22 ) + ABS( UI22 )
+*
+* If smaller pivot < SMINI, use SMINI
+*
+ IF( U22ABS.LT.SMINI ) THEN
+ UR22 = SMINI
+ UI22 = ZERO
+ INFO = 1
+ END IF
+ IF( RSWAP( ICMAX ) ) THEN
+ BR2 = B( 1, 1 )
+ BR1 = B( 2, 1 )
+ BI2 = B( 1, 2 )
+ BI1 = B( 2, 2 )
+ ELSE
+ BR1 = B( 1, 1 )
+ BR2 = B( 2, 1 )
+ BI1 = B( 1, 2 )
+ BI2 = B( 2, 2 )
+ END IF
+ BR2 = BR2 - LR21*BR1 + LI21*BI1
+ BI2 = BI2 - LI21*BR1 - LR21*BI1
+ BBND = MAX( ( ABS( BR1 )+ABS( BI1 ) )*
+ $ ( U22ABS*( ABS( UR11R )+ABS( UI11R ) ) ),
+ $ ABS( BR2 )+ABS( BI2 ) )
+ IF( BBND.GT.ONE .AND. U22ABS.LT.ONE ) THEN
+ IF( BBND.GE.BIGNUM*U22ABS ) THEN
+ SCALE = ONE / BBND
+ BR1 = SCALE*BR1
+ BI1 = SCALE*BI1
+ BR2 = SCALE*BR2
+ BI2 = SCALE*BI2
+ END IF
+ END IF
+*
+ CALL DLADIV( BR2, BI2, UR22, UI22, XR2, XI2 )
+ XR1 = UR11R*BR1 - UI11R*BI1 - UR12S*XR2 + UI12S*XI2
+ XI1 = UI11R*BR1 + UR11R*BI1 - UI12S*XR2 - UR12S*XI2
+ IF( ZSWAP( ICMAX ) ) THEN
+ X( 1, 1 ) = XR2
+ X( 2, 1 ) = XR1
+ X( 1, 2 ) = XI2
+ X( 2, 2 ) = XI1
+ ELSE
+ X( 1, 1 ) = XR1
+ X( 2, 1 ) = XR2
+ X( 1, 2 ) = XI1
+ X( 2, 2 ) = XI2
+ END IF
+ XNORM = MAX( ABS( XR1 )+ABS( XI1 ), ABS( XR2 )+ABS( XI2 ) )
+*
+* Further scaling if norm(A) norm(X) > overflow
+*
+ IF( XNORM.GT.ONE .AND. CMAX.GT.ONE ) THEN
+ IF( XNORM.GT.BIGNUM / CMAX ) THEN
+ TEMP = CMAX / BIGNUM
+ X( 1, 1 ) = TEMP*X( 1, 1 )
+ X( 2, 1 ) = TEMP*X( 2, 1 )
+ X( 1, 2 ) = TEMP*X( 1, 2 )
+ X( 2, 2 ) = TEMP*X( 2, 2 )
+ XNORM = TEMP*XNORM
+ SCALE = TEMP*SCALE
+ END IF
+ END IF
+ END IF
+ END IF
+*
+ RETURN
+*
+* End of DLALN2
+*
+ END
+ 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 )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER GIVPTR, ICOMPQ, INFO, K, LDB, LDBX, LDGCOL,
+ $ LDGNUM, NL, NR, NRHS, SQRE
+ DOUBLE PRECISION C, S
+* ..
+* .. Array Arguments ..
+ INTEGER GIVCOL( LDGCOL, * ), PERM( * )
+ DOUBLE PRECISION B( LDB, * ), BX( LDBX, * ), DIFL( * ),
+ $ DIFR( LDGNUM, * ), GIVNUM( LDGNUM, * ),
+ $ POLES( LDGNUM, * ), WORK( * ), Z( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DLALS0 applies back the multiplying factors of either the left or the
+* right singular vector matrix of a diagonal matrix appended by a row
+* to the right hand side matrix B in solving the least squares problem
+* using the divide-and-conquer SVD approach.
+*
+* For the left singular vector matrix, three types of orthogonal
+* matrices are involved:
+*
+* (1L) Givens rotations: the number of such rotations is GIVPTR; the
+* pairs of columns/rows they were applied to are stored in GIVCOL;
+* and the C- and S-values of these rotations are stored in GIVNUM.
+*
+* (2L) Permutation. The (NL+1)-st row of B is to be moved to the first
+* row, and for J=2:N, PERM(J)-th row of B is to be moved to the
+* J-th row.
+*
+* (3L) The left singular vector matrix of the remaining matrix.
+*
+* For the right singular vector matrix, four types of orthogonal
+* matrices are involved:
+*
+* (1R) The right singular vector matrix of the remaining matrix.
+*
+* (2R) If SQRE = 1, one extra Givens rotation to generate the right
+* null space.
+*
+* (3R) The inverse transformation of (2L).
+*
+* (4R) The inverse transformation of (1L).
+*
+* Arguments
+* =========
+*
+* ICOMPQ (input) INTEGER
+* Specifies whether singular vectors are to be computed in
+* factored form:
+* = 0: Left singular vector matrix.
+* = 1: Right singular vector matrix.
+*
+* NL (input) INTEGER
+* The row dimension of the upper block. NL >= 1.
+*
+* NR (input) INTEGER
+* The row dimension of the lower block. NR >= 1.
+*
+* SQRE (input) INTEGER
+* = 0: the lower block is an NR-by-NR square matrix.
+* = 1: the lower block is an NR-by-(NR+1) rectangular matrix.
+*
+* The bidiagonal matrix has row dimension N = NL + NR + 1,
+* and column dimension M = N + SQRE.
+*
+* NRHS (input) INTEGER
+* The number of columns of B and BX. NRHS must be at least 1.
+*
+* B (input/output) DOUBLE PRECISION array, dimension ( LDB, NRHS )
+* On input, B contains the right hand sides of the least
+* squares problem in rows 1 through M. On output, B contains
+* the solution X in rows 1 through N.
+*
+* LDB (input) INTEGER
+* The leading dimension of B. LDB must be at least
+* max(1,MAX( M, N ) ).
+*
+* BX (workspace) DOUBLE PRECISION array, dimension ( LDBX, NRHS )
+*
+* LDBX (input) INTEGER
+* The leading dimension of BX.
+*
+* PERM (input) INTEGER array, dimension ( N )
+* The permutations (from deflation and sorting) applied
+* to the two blocks.
+*
+* GIVPTR (input) INTEGER
+* The number of Givens rotations which took place in this
+* subproblem.
+*
+* GIVCOL (input) INTEGER array, dimension ( LDGCOL, 2 )
+* Each pair of numbers indicates a pair of rows/columns
+* involved in a Givens rotation.
+*
+* LDGCOL (input) INTEGER
+* The leading dimension of GIVCOL, must be at least N.
+*
+* GIVNUM (input) DOUBLE PRECISION array, dimension ( LDGNUM, 2 )
+* Each number indicates the C or S value used in the
+* corresponding Givens rotation.
+*
+* LDGNUM (input) INTEGER
+* The leading dimension of arrays DIFR, POLES and
+* GIVNUM, must be at least K.
+*
+* POLES (input) DOUBLE PRECISION array, dimension ( LDGNUM, 2 )
+* On entry, POLES(1:K, 1) contains the new singular
+* values obtained from solving the secular equation, and
+* POLES(1:K, 2) is an array containing the poles in the secular
+* equation.
+*
+* DIFL (input) DOUBLE PRECISION array, dimension ( K ).
+* On entry, DIFL(I) is the distance between I-th updated
+* (undeflated) singular value and the I-th (undeflated) old
+* singular value.
+*
+* DIFR (input) DOUBLE PRECISION array, dimension ( LDGNUM, 2 ).
+* On entry, DIFR(I, 1) contains the distances between I-th
+* updated (undeflated) singular value and the I+1-th
+* (undeflated) old singular value. And DIFR(I, 2) is the
+* normalizing factor for the I-th right singular vector.
+*
+* Z (input) DOUBLE PRECISION array, dimension ( K )
+* Contain the components of the deflation-adjusted updating row
+* vector.
+*
+* K (input) INTEGER
+* Contains the dimension of the non-deflated matrix,
+* This is the order of the related secular equation. 1 <= K <=N.
+*
+* C (input) DOUBLE PRECISION
+* C contains garbage if SQRE =0 and the C-value of a Givens
+* rotation related to the right null space if SQRE = 1.
+*
+* S (input) DOUBLE PRECISION
+* S contains garbage if SQRE =0 and the S-value of a Givens
+* rotation related to the right null space if SQRE = 1.
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension ( K )
+*
+* INFO (output) INTEGER
+* = 0: successful exit.
+* < 0: if INFO = -i, the i-th argument had an illegal value.
+*
+* Further Details
+* ===============
+*
+* Based on contributions by
+* Ming Gu and Ren-Cang Li, Computer Science Division, University of
+* California at Berkeley, USA
+* Osni Marques, LBNL/NERSC, USA
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE, ZERO, NEGONE
+ PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0, NEGONE = -1.0D0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, J, M, N, NLP1
+ DOUBLE PRECISION DIFLJ, DIFRJ, DJ, DSIGJ, DSIGJP, TEMP
+* ..
+* .. External Subroutines ..
+ EXTERNAL DCOPY, DGEMV, DLACPY, DLASCL, DROT, DSCAL,
+ $ XERBLA
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DLAMC3, DNRM2
+ EXTERNAL DLAMC3, DNRM2
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+*
+ IF( ( ICOMPQ.LT.0 ) .OR. ( ICOMPQ.GT.1 ) ) THEN
+ INFO = -1
+ ELSE IF( NL.LT.1 ) THEN
+ INFO = -2
+ ELSE IF( NR.LT.1 ) THEN
+ INFO = -3
+ ELSE IF( ( SQRE.LT.0 ) .OR. ( SQRE.GT.1 ) ) THEN
+ INFO = -4
+ END IF
+*
+ N = NL + NR + 1
+*
+ IF( NRHS.LT.1 ) THEN
+ INFO = -5
+ ELSE IF( LDB.LT.N ) THEN
+ INFO = -7
+ ELSE IF( LDBX.LT.N ) THEN
+ INFO = -9
+ ELSE IF( GIVPTR.LT.0 ) THEN
+ INFO = -11
+ ELSE IF( LDGCOL.LT.N ) THEN
+ INFO = -13
+ ELSE IF( LDGNUM.LT.N ) THEN
+ INFO = -15
+ ELSE IF( K.LT.1 ) THEN
+ INFO = -20
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DLALS0', -INFO )
+ RETURN
+ END IF
+*
+ M = N + SQRE
+ NLP1 = NL + 1
+*
+ IF( ICOMPQ.EQ.0 ) THEN
+*
+* Apply back orthogonal transformations from the left.
+*
+* Step (1L): apply back the Givens rotations performed.
+*
+ DO 10 I = 1, GIVPTR
+ CALL DROT( NRHS, B( GIVCOL( I, 2 ), 1 ), LDB,
+ $ B( GIVCOL( I, 1 ), 1 ), LDB, GIVNUM( I, 2 ),
+ $ GIVNUM( I, 1 ) )
+ 10 CONTINUE
+*
+* Step (2L): permute rows of B.
+*
+ CALL DCOPY( NRHS, B( NLP1, 1 ), LDB, BX( 1, 1 ), LDBX )
+ DO 20 I = 2, N
+ CALL DCOPY( NRHS, B( PERM( I ), 1 ), LDB, BX( I, 1 ), LDBX )
+ 20 CONTINUE
+*
+* Step (3L): apply the inverse of the left singular vector
+* matrix to BX.
+*
+ IF( K.EQ.1 ) THEN
+ CALL DCOPY( NRHS, BX, LDBX, B, LDB )
+ IF( Z( 1 ).LT.ZERO ) THEN
+ CALL DSCAL( NRHS, NEGONE, B, LDB )
+ END IF
+ ELSE
+ DO 50 J = 1, K
+ DIFLJ = DIFL( J )
+ DJ = POLES( J, 1 )
+ DSIGJ = -POLES( J, 2 )
+ IF( J.LT.K ) THEN
+ DIFRJ = -DIFR( J, 1 )
+ DSIGJP = -POLES( J+1, 2 )
+ END IF
+ IF( ( Z( J ).EQ.ZERO ) .OR. ( POLES( J, 2 ).EQ.ZERO ) )
+ $ THEN
+ WORK( J ) = ZERO
+ ELSE
+ WORK( J ) = -POLES( J, 2 )*Z( J ) / DIFLJ /
+ $ ( POLES( J, 2 )+DJ )
+ END IF
+ DO 30 I = 1, J - 1
+ IF( ( Z( I ).EQ.ZERO ) .OR.
+ $ ( POLES( I, 2 ).EQ.ZERO ) ) THEN
+ WORK( I ) = ZERO
+ ELSE
+ WORK( I ) = POLES( I, 2 )*Z( I ) /
+ $ ( DLAMC3( POLES( I, 2 ), DSIGJ )-
+ $ DIFLJ ) / ( POLES( I, 2 )+DJ )
+ END IF
+ 30 CONTINUE
+ DO 40 I = J + 1, K
+ IF( ( Z( I ).EQ.ZERO ) .OR.
+ $ ( POLES( I, 2 ).EQ.ZERO ) ) THEN
+ WORK( I ) = ZERO
+ ELSE
+ WORK( I ) = POLES( I, 2 )*Z( I ) /
+ $ ( DLAMC3( POLES( I, 2 ), DSIGJP )+
+ $ DIFRJ ) / ( POLES( I, 2 )+DJ )
+ END IF
+ 40 CONTINUE
+ WORK( 1 ) = NEGONE
+ TEMP = DNRM2( K, WORK, 1 )
+ CALL DGEMV( 'T', K, NRHS, ONE, BX, LDBX, WORK, 1, ZERO,
+ $ B( J, 1 ), LDB )
+ CALL DLASCL( 'G', 0, 0, TEMP, ONE, 1, NRHS, B( J, 1 ),
+ $ LDB, INFO )
+ 50 CONTINUE
+ END IF
+*
+* Move the deflated rows of BX to B also.
+*
+ IF( K.LT.MAX( M, N ) )
+ $ CALL DLACPY( 'A', N-K, NRHS, BX( K+1, 1 ), LDBX,
+ $ B( K+1, 1 ), LDB )
+ ELSE
+*
+* Apply back the right orthogonal transformations.
+*
+* Step (1R): apply back the new right singular vector matrix
+* to B.
+*
+ IF( K.EQ.1 ) THEN
+ CALL DCOPY( NRHS, B, LDB, BX, LDBX )
+ ELSE
+ DO 80 J = 1, K
+ DSIGJ = POLES( J, 2 )
+ IF( Z( J ).EQ.ZERO ) THEN
+ WORK( J ) = ZERO
+ ELSE
+ WORK( J ) = -Z( J ) / DIFL( J ) /
+ $ ( DSIGJ+POLES( J, 1 ) ) / DIFR( J, 2 )
+ END IF
+ DO 60 I = 1, J - 1
+ IF( Z( J ).EQ.ZERO ) THEN
+ WORK( I ) = ZERO
+ ELSE
+ WORK( I ) = Z( J ) / ( DLAMC3( DSIGJ, -POLES( I+1,
+ $ 2 ) )-DIFR( I, 1 ) ) /
+ $ ( DSIGJ+POLES( I, 1 ) ) / DIFR( I, 2 )
+ END IF
+ 60 CONTINUE
+ DO 70 I = J + 1, K
+ IF( Z( J ).EQ.ZERO ) THEN
+ WORK( I ) = ZERO
+ ELSE
+ WORK( I ) = Z( J ) / ( DLAMC3( DSIGJ, -POLES( I,
+ $ 2 ) )-DIFL( I ) ) /
+ $ ( DSIGJ+POLES( I, 1 ) ) / DIFR( I, 2 )
+ END IF
+ 70 CONTINUE
+ CALL DGEMV( 'T', K, NRHS, ONE, B, LDB, WORK, 1, ZERO,
+ $ BX( J, 1 ), LDBX )
+ 80 CONTINUE
+ END IF
+*
+* Step (2R): if SQRE = 1, apply back the rotation that is
+* related to the right null space of the subproblem.
+*
+ IF( SQRE.EQ.1 ) THEN
+ CALL DCOPY( NRHS, B( M, 1 ), LDB, BX( M, 1 ), LDBX )
+ CALL DROT( NRHS, BX( 1, 1 ), LDBX, BX( M, 1 ), LDBX, C, S )
+ END IF
+ IF( K.LT.MAX( M, N ) )
+ $ CALL DLACPY( 'A', N-K, NRHS, B( K+1, 1 ), LDB, BX( K+1, 1 ),
+ $ LDBX )
+*
+* Step (3R): permute rows of B.
+*
+ CALL DCOPY( NRHS, BX( 1, 1 ), LDBX, B( NLP1, 1 ), LDB )
+ IF( SQRE.EQ.1 ) THEN
+ CALL DCOPY( NRHS, BX( M, 1 ), LDBX, B( M, 1 ), LDB )
+ END IF
+ DO 90 I = 2, N
+ CALL DCOPY( NRHS, BX( I, 1 ), LDBX, B( PERM( I ), 1 ), LDB )
+ 90 CONTINUE
+*
+* Step (4R): apply back the Givens rotations performed.
+*
+ DO 100 I = GIVPTR, 1, -1
+ CALL DROT( NRHS, B( GIVCOL( I, 2 ), 1 ), LDB,
+ $ B( GIVCOL( I, 1 ), 1 ), LDB, GIVNUM( I, 2 ),
+ $ -GIVNUM( I, 1 ) )
+ 100 CONTINUE
+ END IF
+*
+ RETURN
+*
+* End of DLALS0
+*
+ END
+ 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 )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER ICOMPQ, INFO, LDB, LDBX, LDGCOL, LDU, N, NRHS,
+ $ SMLSIZ
+* ..
+* .. Array Arguments ..
+ INTEGER GIVCOL( LDGCOL, * ), GIVPTR( * ), IWORK( * ),
+ $ K( * ), PERM( LDGCOL, * )
+ DOUBLE PRECISION B( LDB, * ), BX( LDBX, * ), C( * ),
+ $ DIFL( LDU, * ), DIFR( LDU, * ),
+ $ GIVNUM( LDU, * ), POLES( LDU, * ), S( * ),
+ $ U( LDU, * ), VT( LDU, * ), WORK( * ),
+ $ Z( LDU, * )
+* ..
+*
+* Purpose
+* =======
+*
+* DLALSA is an itermediate step in solving the least squares problem
+* by computing the SVD of the coefficient matrix in compact form (The
+* singular vectors are computed as products of simple orthorgonal
+* matrices.).
+*
+* If ICOMPQ = 0, DLALSA applies the inverse of the left singular vector
+* matrix of an upper bidiagonal matrix to the right hand side; and if
+* ICOMPQ = 1, DLALSA applies the right singular vector matrix to the
+* right hand side. The singular vector matrices were generated in
+* compact form by DLALSA.
+*
+* Arguments
+* =========
+*
+*
+* ICOMPQ (input) INTEGER
+* Specifies whether the left or the right singular vector
+* matrix is involved.
+* = 0: Left singular vector matrix
+* = 1: Right singular vector matrix
+*
+* SMLSIZ (input) INTEGER
+* The maximum size of the subproblems at the bottom of the
+* computation tree.
+*
+* N (input) INTEGER
+* The row and column dimensions of the upper bidiagonal matrix.
+*
+* NRHS (input) INTEGER
+* The number of columns of B and BX. NRHS must be at least 1.
+*
+* B (input/output) DOUBLE PRECISION array, dimension ( LDB, NRHS )
+* On input, B contains the right hand sides of the least
+* squares problem in rows 1 through M.
+* On output, B contains the solution X in rows 1 through N.
+*
+* LDB (input) INTEGER
+* The leading dimension of B in the calling subprogram.
+* LDB must be at least max(1,MAX( M, N ) ).
+*
+* BX (output) DOUBLE PRECISION array, dimension ( LDBX, NRHS )
+* On exit, the result of applying the left or right singular
+* vector matrix to B.
+*
+* LDBX (input) INTEGER
+* The leading dimension of BX.
+*
+* U (input) DOUBLE PRECISION array, dimension ( LDU, SMLSIZ ).
+* On entry, U contains the left singular vector matrices of all
+* subproblems at the bottom level.
+*
+* LDU (input) INTEGER, LDU = > N.
+* The leading dimension of arrays U, VT, DIFL, DIFR,
+* POLES, GIVNUM, and Z.
+*
+* VT (input) DOUBLE PRECISION array, dimension ( LDU, SMLSIZ+1 ).
+* On entry, VT' contains the right singular vector matrices of
+* all subproblems at the bottom level.
+*
+* K (input) INTEGER array, dimension ( N ).
+*
+* DIFL (input) DOUBLE PRECISION array, dimension ( LDU, NLVL ).
+* where NLVL = INT(log_2 (N/(SMLSIZ+1))) + 1.
+*
+* DIFR (input) DOUBLE PRECISION array, dimension ( LDU, 2 * NLVL ).
+* On entry, DIFL(*, I) and DIFR(*, 2 * I -1) record
+* distances between singular values on the I-th level and
+* singular values on the (I -1)-th level, and DIFR(*, 2 * I)
+* record the normalizing factors of the right singular vectors
+* matrices of subproblems on I-th level.
+*
+* Z (input) DOUBLE PRECISION array, dimension ( LDU, NLVL ).
+* On entry, Z(1, I) contains the components of the deflation-
+* adjusted updating row vector for subproblems on the I-th
+* level.
+*
+* POLES (input) DOUBLE PRECISION array, dimension ( LDU, 2 * NLVL ).
+* On entry, POLES(*, 2 * I -1: 2 * I) contains the new and old
+* singular values involved in the secular equations on the I-th
+* level.
+*
+* GIVPTR (input) INTEGER array, dimension ( N ).
+* On entry, GIVPTR( I ) records the number of Givens
+* rotations performed on the I-th problem on the computation
+* tree.
+*
+* GIVCOL (input) INTEGER array, dimension ( LDGCOL, 2 * NLVL ).
+* On entry, for each I, GIVCOL(*, 2 * I - 1: 2 * I) records the
+* locations of Givens rotations performed on the I-th level on
+* the computation tree.
+*
+* LDGCOL (input) INTEGER, LDGCOL = > N.
+* The leading dimension of arrays GIVCOL and PERM.
+*
+* PERM (input) INTEGER array, dimension ( LDGCOL, NLVL ).
+* On entry, PERM(*, I) records permutations done on the I-th
+* level of the computation tree.
+*
+* GIVNUM (input) DOUBLE PRECISION array, dimension ( LDU, 2 * NLVL ).
+* On entry, GIVNUM(*, 2 *I -1 : 2 * I) records the C- and S-
+* values of Givens rotations performed on the I-th level on the
+* computation tree.
+*
+* C (input) DOUBLE PRECISION array, dimension ( N ).
+* On entry, if the I-th subproblem is not square,
+* C( I ) contains the C-value of a Givens rotation related to
+* the right null space of the I-th subproblem.
+*
+* S (input) DOUBLE PRECISION array, dimension ( N ).
+* On entry, if the I-th subproblem is not square,
+* S( I ) contains the S-value of a Givens rotation related to
+* the right null space of the I-th subproblem.
+*
+* WORK (workspace) DOUBLE PRECISION array.
+* The dimension must be at least N.
+*
+* IWORK (workspace) INTEGER array.
+* The dimension must be at least 3 * N
+*
+* INFO (output) INTEGER
+* = 0: successful exit.
+* < 0: if INFO = -i, the i-th argument had an illegal value.
+*
+* Further Details
+* ===============
+*
+* Based on contributions by
+* Ming Gu and Ren-Cang Li, Computer Science Division, University of
+* California at Berkeley, USA
+* Osni Marques, LBNL/NERSC, USA
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, I1, IC, IM1, INODE, J, LF, LL, LVL, LVL2,
+ $ ND, NDB1, NDIML, NDIMR, NL, NLF, NLP1, NLVL,
+ $ NR, NRF, NRP1, SQRE
+* ..
+* .. External Subroutines ..
+ EXTERNAL DCOPY, DGEMM, DLALS0, DLASDT, XERBLA
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+*
+ IF( ( ICOMPQ.LT.0 ) .OR. ( ICOMPQ.GT.1 ) ) THEN
+ INFO = -1
+ ELSE IF( SMLSIZ.LT.3 ) THEN
+ INFO = -2
+ ELSE IF( N.LT.SMLSIZ ) THEN
+ INFO = -3
+ ELSE IF( NRHS.LT.1 ) THEN
+ INFO = -4
+ ELSE IF( LDB.LT.N ) THEN
+ INFO = -6
+ ELSE IF( LDBX.LT.N ) THEN
+ INFO = -8
+ ELSE IF( LDU.LT.N ) THEN
+ INFO = -10
+ ELSE IF( LDGCOL.LT.N ) THEN
+ INFO = -19
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DLALSA', -INFO )
+ RETURN
+ END IF
+*
+* Book-keeping and setting up the computation tree.
+*
+ INODE = 1
+ NDIML = INODE + N
+ NDIMR = NDIML + N
+*
+ CALL DLASDT( N, NLVL, ND, IWORK( INODE ), IWORK( NDIML ),
+ $ IWORK( NDIMR ), SMLSIZ )
+*
+* The following code applies back the left singular vector factors.
+* For applying back the right singular vector factors, go to 50.
+*
+ IF( ICOMPQ.EQ.1 ) THEN
+ GO TO 50
+ END IF
+*
+* The nodes on the bottom level of the tree were solved
+* by DLASDQ. The corresponding left and right singular vector
+* matrices are in explicit form. First apply back the left
+* singular vector matrices.
+*
+ NDB1 = ( ND+1 ) / 2
+ DO 10 I = NDB1, ND
+*
+* IC : center row of each node
+* NL : number of rows of left subproblem
+* NR : number of rows of right subproblem
+* NLF: starting row of the left subproblem
+* NRF: starting row of the right subproblem
+*
+ I1 = I - 1
+ IC = IWORK( INODE+I1 )
+ NL = IWORK( NDIML+I1 )
+ NR = IWORK( NDIMR+I1 )
+ NLF = IC - NL
+ NRF = IC + 1
+ CALL DGEMM( 'T', 'N', NL, NRHS, NL, ONE, U( NLF, 1 ), LDU,
+ $ B( NLF, 1 ), LDB, ZERO, BX( NLF, 1 ), LDBX )
+ CALL DGEMM( 'T', 'N', NR, NRHS, NR, ONE, U( NRF, 1 ), LDU,
+ $ B( NRF, 1 ), LDB, ZERO, BX( NRF, 1 ), LDBX )
+ 10 CONTINUE
+*
+* Next copy the rows of B that correspond to unchanged rows
+* in the bidiagonal matrix to BX.
+*
+ DO 20 I = 1, ND
+ IC = IWORK( INODE+I-1 )
+ CALL DCOPY( NRHS, B( IC, 1 ), LDB, BX( IC, 1 ), LDBX )
+ 20 CONTINUE
+*
+* Finally go through the left singular vector matrices of all
+* the other subproblems bottom-up on the tree.
+*
+ J = 2**NLVL
+ SQRE = 0
+*
+ DO 40 LVL = NLVL, 1, -1
+ LVL2 = 2*LVL - 1
+*
+* find the first node LF and last node LL on
+* the current level LVL
+*
+ IF( LVL.EQ.1 ) THEN
+ LF = 1
+ LL = 1
+ ELSE
+ LF = 2**( LVL-1 )
+ LL = 2*LF - 1
+ END IF
+ DO 30 I = LF, LL
+ IM1 = I - 1
+ IC = IWORK( INODE+IM1 )
+ NL = IWORK( NDIML+IM1 )
+ NR = IWORK( NDIMR+IM1 )
+ NLF = IC - NL
+ NRF = IC + 1
+ J = J - 1
+ CALL DLALS0( ICOMPQ, NL, NR, SQRE, NRHS, BX( NLF, 1 ), LDBX,
+ $ B( NLF, 1 ), LDB, PERM( NLF, LVL ),
+ $ GIVPTR( J ), GIVCOL( NLF, LVL2 ), LDGCOL,
+ $ GIVNUM( NLF, LVL2 ), LDU, POLES( NLF, LVL2 ),
+ $ DIFL( NLF, LVL ), DIFR( NLF, LVL2 ),
+ $ Z( NLF, LVL ), K( J ), C( J ), S( J ), WORK,
+ $ INFO )
+ 30 CONTINUE
+ 40 CONTINUE
+ GO TO 90
+*
+* ICOMPQ = 1: applying back the right singular vector factors.
+*
+ 50 CONTINUE
+*
+* First now go through the right singular vector matrices of all
+* the tree nodes top-down.
+*
+ J = 0
+ DO 70 LVL = 1, NLVL
+ LVL2 = 2*LVL - 1
+*
+* Find the first node LF and last node LL on
+* the current level LVL.
+*
+ IF( LVL.EQ.1 ) THEN
+ LF = 1
+ LL = 1
+ ELSE
+ LF = 2**( LVL-1 )
+ LL = 2*LF - 1
+ END IF
+ DO 60 I = LL, LF, -1
+ IM1 = I - 1
+ IC = IWORK( INODE+IM1 )
+ NL = IWORK( NDIML+IM1 )
+ NR = IWORK( NDIMR+IM1 )
+ NLF = IC - NL
+ NRF = IC + 1
+ IF( I.EQ.LL ) THEN
+ SQRE = 0
+ ELSE
+ SQRE = 1
+ END IF
+ J = J + 1
+ CALL DLALS0( ICOMPQ, NL, NR, SQRE, NRHS, B( NLF, 1 ), LDB,
+ $ BX( NLF, 1 ), LDBX, PERM( NLF, LVL ),
+ $ GIVPTR( J ), GIVCOL( NLF, LVL2 ), LDGCOL,
+ $ GIVNUM( NLF, LVL2 ), LDU, POLES( NLF, LVL2 ),
+ $ DIFL( NLF, LVL ), DIFR( NLF, LVL2 ),
+ $ Z( NLF, LVL ), K( J ), C( J ), S( J ), WORK,
+ $ INFO )
+ 60 CONTINUE
+ 70 CONTINUE
+*
+* The nodes on the bottom level of the tree were solved
+* by DLASDQ. The corresponding right singular vector
+* matrices are in explicit form. Apply them back.
+*
+ NDB1 = ( ND+1 ) / 2
+ DO 80 I = NDB1, ND
+ I1 = I - 1
+ IC = IWORK( INODE+I1 )
+ NL = IWORK( NDIML+I1 )
+ NR = IWORK( NDIMR+I1 )
+ NLP1 = NL + 1
+ IF( I.EQ.ND ) THEN
+ NRP1 = NR
+ ELSE
+ NRP1 = NR + 1
+ END IF
+ NLF = IC - NL
+ NRF = IC + 1
+ CALL DGEMM( 'T', 'N', NLP1, NRHS, NLP1, ONE, VT( NLF, 1 ), LDU,
+ $ B( NLF, 1 ), LDB, ZERO, BX( NLF, 1 ), LDBX )
+ CALL DGEMM( 'T', 'N', NRP1, NRHS, NRP1, ONE, VT( NRF, 1 ), LDU,
+ $ B( NRF, 1 ), LDB, ZERO, BX( NRF, 1 ), LDBX )
+ 80 CONTINUE
+*
+ 90 CONTINUE
+*
+ RETURN
+*
+* End of DLALSA
+*
+ END
+ SUBROUTINE DLALSD( UPLO, SMLSIZ, N, NRHS, D, E, B, LDB, RCOND,
+ $ RANK, WORK, IWORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, LDB, N, NRHS, RANK, SMLSIZ
+ DOUBLE PRECISION RCOND
+* ..
+* .. Array Arguments ..
+ INTEGER IWORK( * )
+ DOUBLE PRECISION B( LDB, * ), D( * ), E( * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DLALSD uses the singular value decomposition of A to solve the least
+* squares problem of finding X to minimize the Euclidean norm of each
+* column of A*X-B, where A is N-by-N upper bidiagonal, and X and B
+* are N-by-NRHS. The solution X overwrites B.
+*
+* The singular values of A smaller than RCOND times the largest
+* singular value are treated as zero in solving the least squares
+* problem; in this case a minimum norm solution is returned.
+* The actual singular values are returned in D in ascending order.
+*
+* This code makes very mild assumptions about floating point
+* arithmetic. It will work on machines with a guard digit in
+* add/subtract, or on those binary machines without guard digits
+* which subtract like the Cray XMP, Cray YMP, Cray C 90, or Cray 2.
+* It could conceivably fail on hexadecimal or decimal machines
+* without guard digits, but we know of none.
+*
+* Arguments
+* =========
+*
+* UPLO (input) CHARACTER*1
+* = 'U': D and E define an upper bidiagonal matrix.
+* = 'L': D and E define a lower bidiagonal matrix.
+*
+* SMLSIZ (input) INTEGER
+* The maximum size of the subproblems at the bottom of the
+* computation tree.
+*
+* N (input) INTEGER
+* The dimension of the bidiagonal matrix. N >= 0.
+*
+* NRHS (input) INTEGER
+* The number of columns of B. NRHS must be at least 1.
+*
+* D (input/output) DOUBLE PRECISION array, dimension (N)
+* On entry D contains the main diagonal of the bidiagonal
+* matrix. On exit, if INFO = 0, D contains its singular values.
+*
+* E (input/output) DOUBLE PRECISION array, dimension (N-1)
+* Contains the super-diagonal entries of the bidiagonal matrix.
+* On exit, E has been destroyed.
+*
+* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
+* On input, B contains the right hand sides of the least
+* squares problem. On output, B contains the solution X.
+*
+* LDB (input) INTEGER
+* The leading dimension of B in the calling subprogram.
+* LDB must be at least max(1,N).
+*
+* RCOND (input) DOUBLE PRECISION
+* The singular values of A less than or equal to RCOND times
+* the largest singular value are treated as zero in solving
+* the least squares problem. If RCOND is negative,
+* machine precision is used instead.
+* For example, if diag(S)*X=B were the least squares problem,
+* where diag(S) is a diagonal matrix of singular values, the
+* solution would be X(i) = B(i) / S(i) if S(i) is greater than
+* RCOND*max(S), and X(i) = 0 if S(i) is less than or equal to
+* RCOND*max(S).
+*
+* RANK (output) INTEGER
+* The number of singular values of A greater than RCOND times
+* the largest singular value.
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension at least
+* (9*N + 2*N*SMLSIZ + 8*N*NLVL + N*NRHS + (SMLSIZ+1)**2),
+* where NLVL = max(0, INT(log_2 (N/(SMLSIZ+1))) + 1).
+*
+* IWORK (workspace) INTEGER array, dimension at least
+* (3*N*NLVL + 11*N)
+*
+* INFO (output) INTEGER
+* = 0: successful exit.
+* < 0: if INFO = -i, the i-th argument had an illegal value.
+* > 0: The algorithm failed to compute an singular value while
+* working on the submatrix lying in rows and columns
+* INFO/(N+1) through MOD(INFO,N+1).
+*
+* Further Details
+* ===============
+*
+* Based on contributions by
+* Ming Gu and Ren-Cang Li, Computer Science Division, University of
+* California at Berkeley, USA
+* Osni Marques, LBNL/NERSC, USA
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE, TWO
+ PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 )
+* ..
+* .. Local Scalars ..
+ INTEGER BX, BXST, C, DIFL, DIFR, GIVCOL, GIVNUM,
+ $ GIVPTR, I, ICMPQ1, ICMPQ2, IWK, J, K, NLVL,
+ $ NM1, NSIZE, NSUB, NWORK, PERM, POLES, S, SIZEI,
+ $ SMLSZP, SQRE, ST, ST1, U, VT, Z
+ DOUBLE PRECISION CS, EPS, ORGNRM, R, RCND, SN, TOL
+* ..
+* .. External Functions ..
+ INTEGER IDAMAX
+ DOUBLE PRECISION DLAMCH, DLANST
+ EXTERNAL IDAMAX, DLAMCH, DLANST
+* ..
+* .. External Subroutines ..
+ EXTERNAL DCOPY, DGEMM, DLACPY, DLALSA, DLARTG, DLASCL,
+ $ DLASDA, DLASDQ, DLASET, DLASRT, DROT, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, DBLE, INT, LOG, SIGN
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+*
+ IF( N.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( NRHS.LT.1 ) THEN
+ INFO = -4
+ ELSE IF( ( LDB.LT.1 ) .OR. ( LDB.LT.N ) ) THEN
+ INFO = -8
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DLALSD', -INFO )
+ RETURN
+ END IF
+*
+ EPS = DLAMCH( 'Epsilon' )
+*
+* Set up the tolerance.
+*
+ IF( ( RCOND.LE.ZERO ) .OR. ( RCOND.GE.ONE ) ) THEN
+ RCND = EPS
+ ELSE
+ RCND = RCOND
+ END IF
+*
+ RANK = 0
+*
+* Quick return if possible.
+*
+ IF( N.EQ.0 ) THEN
+ RETURN
+ ELSE IF( N.EQ.1 ) THEN
+ IF( D( 1 ).EQ.ZERO ) THEN
+ CALL DLASET( 'A', 1, NRHS, ZERO, ZERO, B, LDB )
+ ELSE
+ RANK = 1
+ CALL DLASCL( 'G', 0, 0, D( 1 ), ONE, 1, NRHS, B, LDB, INFO )
+ D( 1 ) = ABS( D( 1 ) )
+ END IF
+ RETURN
+ END IF
+*
+* Rotate the matrix if it is lower bidiagonal.
+*
+ IF( UPLO.EQ.'L' ) THEN
+ DO 10 I = 1, N - 1
+ CALL DLARTG( D( I ), E( I ), CS, SN, R )
+ D( I ) = R
+ E( I ) = SN*D( I+1 )
+ D( I+1 ) = CS*D( I+1 )
+ IF( NRHS.EQ.1 ) THEN
+ CALL DROT( 1, B( I, 1 ), 1, B( I+1, 1 ), 1, CS, SN )
+ ELSE
+ WORK( I*2-1 ) = CS
+ WORK( I*2 ) = SN
+ END IF
+ 10 CONTINUE
+ IF( NRHS.GT.1 ) THEN
+ DO 30 I = 1, NRHS
+ DO 20 J = 1, N - 1
+ CS = WORK( J*2-1 )
+ SN = WORK( J*2 )
+ CALL DROT( 1, B( J, I ), 1, B( J+1, I ), 1, CS, SN )
+ 20 CONTINUE
+ 30 CONTINUE
+ END IF
+ END IF
+*
+* Scale.
+*
+ NM1 = N - 1
+ ORGNRM = DLANST( 'M', N, D, E )
+ IF( ORGNRM.EQ.ZERO ) THEN
+ CALL DLASET( 'A', N, NRHS, ZERO, ZERO, B, LDB )
+ RETURN
+ END IF
+*
+ CALL DLASCL( 'G', 0, 0, ORGNRM, ONE, N, 1, D, N, INFO )
+ CALL DLASCL( 'G', 0, 0, ORGNRM, ONE, NM1, 1, E, NM1, INFO )
+*
+* If N is smaller than the minimum divide size SMLSIZ, then solve
+* the problem with another solver.
+*
+ IF( N.LE.SMLSIZ ) THEN
+ NWORK = 1 + N*N
+ CALL DLASET( 'A', N, N, ZERO, ONE, WORK, N )
+ CALL DLASDQ( 'U', 0, N, N, 0, NRHS, D, E, WORK, N, WORK, N, B,
+ $ LDB, WORK( NWORK ), INFO )
+ IF( INFO.NE.0 ) THEN
+ RETURN
+ END IF
+ TOL = RCND*ABS( D( IDAMAX( N, D, 1 ) ) )
+ DO 40 I = 1, N
+ IF( D( I ).LE.TOL ) THEN
+ CALL DLASET( 'A', 1, NRHS, ZERO, ZERO, B( I, 1 ), LDB )
+ ELSE
+ CALL DLASCL( 'G', 0, 0, D( I ), ONE, 1, NRHS, B( I, 1 ),
+ $ LDB, INFO )
+ RANK = RANK + 1
+ END IF
+ 40 CONTINUE
+ CALL DGEMM( 'T', 'N', N, NRHS, N, ONE, WORK, N, B, LDB, ZERO,
+ $ WORK( NWORK ), N )
+ CALL DLACPY( 'A', N, NRHS, WORK( NWORK ), N, B, LDB )
+*
+* Unscale.
+*
+ CALL DLASCL( 'G', 0, 0, ONE, ORGNRM, N, 1, D, N, INFO )
+ CALL DLASRT( 'D', N, D, INFO )
+ CALL DLASCL( 'G', 0, 0, ORGNRM, ONE, N, NRHS, B, LDB, INFO )
+*
+ RETURN
+ END IF
+*
+* Book-keeping and setting up some constants.
+*
+ NLVL = INT( LOG( DBLE( N ) / DBLE( SMLSIZ+1 ) ) / LOG( TWO ) ) + 1
+*
+ SMLSZP = SMLSIZ + 1
+*
+ U = 1
+ VT = 1 + SMLSIZ*N
+ DIFL = VT + SMLSZP*N
+ DIFR = DIFL + NLVL*N
+ Z = DIFR + NLVL*N*2
+ C = Z + NLVL*N
+ S = C + N
+ POLES = S + N
+ GIVNUM = POLES + 2*NLVL*N
+ BX = GIVNUM + 2*NLVL*N
+ NWORK = BX + N*NRHS
+*
+ SIZEI = 1 + N
+ K = SIZEI + N
+ GIVPTR = K + N
+ PERM = GIVPTR + N
+ GIVCOL = PERM + NLVL*N
+ IWK = GIVCOL + NLVL*N*2
+*
+ ST = 1
+ SQRE = 0
+ ICMPQ1 = 1
+ ICMPQ2 = 0
+ NSUB = 0
+*
+ DO 50 I = 1, N
+ IF( ABS( D( I ) ).LT.EPS ) THEN
+ D( I ) = SIGN( EPS, D( I ) )
+ END IF
+ 50 CONTINUE
+*
+ DO 60 I = 1, NM1
+ IF( ( ABS( E( I ) ).LT.EPS ) .OR. ( I.EQ.NM1 ) ) THEN
+ NSUB = NSUB + 1
+ IWORK( NSUB ) = ST
+*
+* Subproblem found. First determine its size and then
+* apply divide and conquer on it.
+*
+ IF( I.LT.NM1 ) THEN
+*
+* A subproblem with E(I) small for I < NM1.
+*
+ NSIZE = I - ST + 1
+ IWORK( SIZEI+NSUB-1 ) = NSIZE
+ ELSE IF( ABS( E( I ) ).GE.EPS ) THEN
+*
+* A subproblem with E(NM1) not too small but I = NM1.
+*
+ NSIZE = N - ST + 1
+ IWORK( SIZEI+NSUB-1 ) = NSIZE
+ ELSE
+*
+* A subproblem with E(NM1) small. This implies an
+* 1-by-1 subproblem at D(N), which is not solved
+* explicitly.
+*
+ NSIZE = I - ST + 1
+ IWORK( SIZEI+NSUB-1 ) = NSIZE
+ NSUB = NSUB + 1
+ IWORK( NSUB ) = N
+ IWORK( SIZEI+NSUB-1 ) = 1
+ CALL DCOPY( NRHS, B( N, 1 ), LDB, WORK( BX+NM1 ), N )
+ END IF
+ ST1 = ST - 1
+ IF( NSIZE.EQ.1 ) THEN
+*
+* This is a 1-by-1 subproblem and is not solved
+* explicitly.
+*
+ CALL DCOPY( NRHS, B( ST, 1 ), LDB, WORK( BX+ST1 ), N )
+ ELSE IF( NSIZE.LE.SMLSIZ ) THEN
+*
+* This is a small subproblem and is solved by DLASDQ.
+*
+ CALL DLASET( 'A', NSIZE, NSIZE, ZERO, ONE,
+ $ WORK( VT+ST1 ), N )
+ CALL DLASDQ( 'U', 0, NSIZE, NSIZE, 0, NRHS, D( ST ),
+ $ E( ST ), WORK( VT+ST1 ), N, WORK( NWORK ),
+ $ N, B( ST, 1 ), LDB, WORK( NWORK ), INFO )
+ IF( INFO.NE.0 ) THEN
+ RETURN
+ END IF
+ CALL DLACPY( 'A', NSIZE, NRHS, B( ST, 1 ), LDB,
+ $ WORK( BX+ST1 ), N )
+ ELSE
+*
+* A large problem. Solve it using divide and conquer.
+*
+ CALL DLASDA( ICMPQ1, SMLSIZ, NSIZE, SQRE, D( ST ),
+ $ E( ST ), WORK( U+ST1 ), N, WORK( VT+ST1 ),
+ $ IWORK( K+ST1 ), WORK( DIFL+ST1 ),
+ $ WORK( DIFR+ST1 ), WORK( Z+ST1 ),
+ $ WORK( POLES+ST1 ), IWORK( GIVPTR+ST1 ),
+ $ IWORK( GIVCOL+ST1 ), N, IWORK( PERM+ST1 ),
+ $ WORK( GIVNUM+ST1 ), WORK( C+ST1 ),
+ $ WORK( S+ST1 ), WORK( NWORK ), IWORK( IWK ),
+ $ INFO )
+ IF( INFO.NE.0 ) THEN
+ RETURN
+ END IF
+ BXST = BX + ST1
+ CALL DLALSA( ICMPQ2, SMLSIZ, NSIZE, NRHS, B( ST, 1 ),
+ $ LDB, WORK( BXST ), N, WORK( U+ST1 ), N,
+ $ WORK( VT+ST1 ), IWORK( K+ST1 ),
+ $ WORK( DIFL+ST1 ), WORK( DIFR+ST1 ),
+ $ WORK( Z+ST1 ), WORK( POLES+ST1 ),
+ $ IWORK( GIVPTR+ST1 ), IWORK( GIVCOL+ST1 ), N,
+ $ IWORK( PERM+ST1 ), WORK( GIVNUM+ST1 ),
+ $ WORK( C+ST1 ), WORK( S+ST1 ), WORK( NWORK ),
+ $ IWORK( IWK ), INFO )
+ IF( INFO.NE.0 ) THEN
+ RETURN
+ END IF
+ END IF
+ ST = I + 1
+ END IF
+ 60 CONTINUE
+*
+* Apply the singular values and treat the tiny ones as zero.
+*
+ TOL = RCND*ABS( D( IDAMAX( N, D, 1 ) ) )
+*
+ DO 70 I = 1, N
+*
+* Some of the elements in D can be negative because 1-by-1
+* subproblems were not solved explicitly.
+*
+ IF( ABS( D( I ) ).LE.TOL ) THEN
+ CALL DLASET( 'A', 1, NRHS, ZERO, ZERO, WORK( BX+I-1 ), N )
+ ELSE
+ RANK = RANK + 1
+ CALL DLASCL( 'G', 0, 0, D( I ), ONE, 1, NRHS,
+ $ WORK( BX+I-1 ), N, INFO )
+ END IF
+ D( I ) = ABS( D( I ) )
+ 70 CONTINUE
+*
+* Now apply back the right singular vectors.
+*
+ ICMPQ2 = 1
+ DO 80 I = 1, NSUB
+ ST = IWORK( I )
+ ST1 = ST - 1
+ NSIZE = IWORK( SIZEI+I-1 )
+ BXST = BX + ST1
+ IF( NSIZE.EQ.1 ) THEN
+ CALL DCOPY( NRHS, WORK( BXST ), N, B( ST, 1 ), LDB )
+ ELSE IF( NSIZE.LE.SMLSIZ ) THEN
+ CALL DGEMM( 'T', 'N', NSIZE, NRHS, NSIZE, ONE,
+ $ WORK( VT+ST1 ), N, WORK( BXST ), N, ZERO,
+ $ B( ST, 1 ), LDB )
+ ELSE
+ CALL DLALSA( ICMPQ2, SMLSIZ, NSIZE, NRHS, WORK( BXST ), N,
+ $ B( ST, 1 ), LDB, WORK( U+ST1 ), N,
+ $ WORK( VT+ST1 ), IWORK( K+ST1 ),
+ $ WORK( DIFL+ST1 ), WORK( DIFR+ST1 ),
+ $ WORK( Z+ST1 ), WORK( POLES+ST1 ),
+ $ IWORK( GIVPTR+ST1 ), IWORK( GIVCOL+ST1 ), N,
+ $ IWORK( PERM+ST1 ), WORK( GIVNUM+ST1 ),
+ $ WORK( C+ST1 ), WORK( S+ST1 ), WORK( NWORK ),
+ $ IWORK( IWK ), INFO )
+ IF( INFO.NE.0 ) THEN
+ RETURN
+ END IF
+ END IF
+ 80 CONTINUE
+*
+* Unscale and sort the singular values.
+*
+ CALL DLASCL( 'G', 0, 0, ONE, ORGNRM, N, 1, D, N, INFO )
+ CALL DLASRT( 'D', N, D, INFO )
+ CALL DLASCL( 'G', 0, 0, ORGNRM, ONE, N, NRHS, B, LDB, INFO )
+*
+ RETURN
+*
+* End of DLALSD
+*
+ END
+ SUBROUTINE DLAMRG( N1, N2, A, DTRD1, DTRD2, INDEX )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER DTRD1, DTRD2, N1, N2
+* ..
+* .. Array Arguments ..
+ INTEGER INDEX( * )
+ DOUBLE PRECISION A( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DLAMRG will create a permutation list which will merge the elements
+* of A (which is composed of two independently sorted sets) into a
+* single set which is sorted in ascending order.
+*
+* Arguments
+* =========
+*
+* N1 (input) INTEGER
+* N2 (input) INTEGER
+* These arguements contain the respective lengths of the two
+* sorted lists to be merged.
+*
+* A (input) DOUBLE PRECISION array, dimension (N1+N2)
+* The first N1 elements of A contain a list of numbers which
+* are sorted in either ascending or descending order. Likewise
+* for the final N2 elements.
+*
+* DTRD1 (input) INTEGER
+* DTRD2 (input) INTEGER
+* These are the strides to be taken through the array A.
+* Allowable strides are 1 and -1. They indicate whether a
+* subset of A is sorted in ascending (DTRDx = 1) or descending
+* (DTRDx = -1) order.
+*
+* INDEX (output) INTEGER array, dimension (N1+N2)
+* On exit this array will contain a permutation such that
+* if B( I ) = A( INDEX( I ) ) for I=1,N1+N2, then B will be
+* sorted in ascending order.
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ INTEGER I, IND1, IND2, N1SV, N2SV
+* ..
+* .. Executable Statements ..
+*
+ N1SV = N1
+ N2SV = N2
+ IF( DTRD1.GT.0 ) THEN
+ IND1 = 1
+ ELSE
+ IND1 = N1
+ END IF
+ IF( DTRD2.GT.0 ) THEN
+ IND2 = 1 + N1
+ ELSE
+ IND2 = N1 + N2
+ END IF
+ I = 1
+* while ( (N1SV > 0) & (N2SV > 0) )
+ 10 CONTINUE
+ IF( N1SV.GT.0 .AND. N2SV.GT.0 ) THEN
+ IF( A( IND1 ).LE.A( IND2 ) ) THEN
+ INDEX( I ) = IND1
+ I = I + 1
+ IND1 = IND1 + DTRD1
+ N1SV = N1SV - 1
+ ELSE
+ INDEX( I ) = IND2
+ I = I + 1
+ IND2 = IND2 + DTRD2
+ N2SV = N2SV - 1
+ END IF
+ GO TO 10
+ END IF
+* end while
+ IF( N1SV.EQ.0 ) THEN
+ DO 20 N1SV = 1, N2SV
+ INDEX( I ) = IND2
+ I = I + 1
+ IND2 = IND2 + DTRD2
+ 20 CONTINUE
+ ELSE
+* N2SV .EQ. 0
+ DO 30 N2SV = 1, N1SV
+ INDEX( I ) = IND1
+ I = I + 1
+ IND1 = IND1 + DTRD1
+ 30 CONTINUE
+ END IF
+*
+ RETURN
+*
+* End of DLAMRG
+*
+ END
+ FUNCTION DLANEG( N, D, LLD, SIGMA, PIVMIN, R )
+ IMPLICIT NONE
+ INTEGER DLANEG
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER N, R
+ DOUBLE PRECISION PIVMIN, SIGMA
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION D( * ), LLD( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DLANEG computes the Sturm count, the number of negative pivots
+* encountered while factoring tridiagonal T - sigma I = L D L^T.
+* This implementation works directly on the factors without forming
+* the tridiagonal matrix T. The Sturm count is also the number of
+* eigenvalues of T less than sigma.
+*
+* This routine is called from DLARRB.
+*
+* The current routine does not use the PIVMIN parameter but rather
+* requires IEEE-754 propagation of Infinities and NaNs. This
+* routine also has no input range restrictions but does require
+* default exception handling such that x/0 produces Inf when x is
+* non-zero, and Inf/Inf produces NaN. For more information, see:
+*
+* Marques, Riedy, and Voemel, "Benefits of IEEE-754 Features in
+* Modern Symmetric Tridiagonal Eigensolvers," SIAM Journal on
+* Scientific Computing, v28, n5, 2006. DOI 10.1137/050641624
+* (Tech report version in LAWN 172 with the same title.)
+*
+* Arguments
+* =========
+*
+* N (input) INTEGER
+* The order of the matrix.
+*
+* D (input) DOUBLE PRECISION array, dimension (N)
+* The N diagonal elements of the diagonal matrix D.
+*
+* LLD (input) DOUBLE PRECISION array, dimension (N-1)
+* The (N-1) elements L(i)*L(i)*D(i).
+*
+* SIGMA (input) DOUBLE PRECISION
+* Shift amount in T - sigma I = L D L^T.
+*
+* PIVMIN (input) DOUBLE PRECISION
+* The minimum pivot in the Sturm sequence. May be used
+* when zero pivots are encountered on non-IEEE-754
+* architectures.
+*
+* R (input) INTEGER
+* The twist index for the twisted factorization that is used
+* for the negcount.
+*
+* Further Details
+* ===============
+*
+* Based on contributions by
+* Osni Marques, LBNL/NERSC, USA
+* Christof Voemel, University of California, Berkeley, USA
+* Jason Riedy, University of California, Berkeley, USA
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
+* Some architectures propagate Infinities and NaNs very slowly, so
+* the code computes counts in BLKLEN chunks. Then a NaN can
+* propagate at most BLKLEN columns before being detected. This is
+* not a general tuning parameter; it needs only to be just large
+* enough that the overhead is tiny in common cases.
+ INTEGER BLKLEN
+ PARAMETER ( BLKLEN = 128 )
+* ..
+* .. Local Scalars ..
+ INTEGER BJ, J, NEG1, NEG2, NEGCNT
+ DOUBLE PRECISION BSAV, DMINUS, DPLUS, GAMMA, P, T, TMP
+ LOGICAL SAWNAN
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MIN, MAX
+* ..
+* .. External Functions ..
+ LOGICAL DISNAN
+ EXTERNAL DISNAN
+* ..
+* .. Executable Statements ..
+
+ NEGCNT = 0
+
+* I) upper part: L D L^T - SIGMA I = L+ D+ L+^T
+ T = -SIGMA
+ DO 210 BJ = 1, R-1, BLKLEN
+ NEG1 = 0
+ BSAV = T
+ DO 21 J = BJ, MIN(BJ+BLKLEN-1, R-1)
+ DPLUS = D( J ) + T
+ IF( DPLUS.LT.ZERO ) NEG1 = NEG1 + 1
+ TMP = T / DPLUS
+ T = TMP * LLD( J ) - SIGMA
+ 21 CONTINUE
+ SAWNAN = DISNAN( T )
+* Run a slower version of the above loop if a NaN is detected.
+* A NaN should occur only with a zero pivot after an infinite
+* pivot. In that case, substituting 1 for T/DPLUS is the
+* correct limit.
+ IF( SAWNAN ) THEN
+ NEG1 = 0
+ T = BSAV
+ DO 22 J = BJ, MIN(BJ+BLKLEN-1, R-1)
+ DPLUS = D( J ) + T
+ IF( DPLUS.LT.ZERO ) NEG1 = NEG1 + 1
+ TMP = T / DPLUS
+ IF (DISNAN(TMP)) TMP = ONE
+ T = TMP * LLD(J) - SIGMA
+ 22 CONTINUE
+ END IF
+ NEGCNT = NEGCNT + NEG1
+ 210 CONTINUE
+*
+* II) lower part: L D L^T - SIGMA I = U- D- U-^T
+ P = D( N ) - SIGMA
+ DO 230 BJ = N-1, R, -BLKLEN
+ NEG2 = 0
+ BSAV = P
+ DO 23 J = BJ, MAX(BJ-BLKLEN+1, R), -1
+ DMINUS = LLD( J ) + P
+ IF( DMINUS.LT.ZERO ) NEG2 = NEG2 + 1
+ TMP = P / DMINUS
+ P = TMP * D( J ) - SIGMA
+ 23 CONTINUE
+ SAWNAN = DISNAN( P )
+* As above, run a slower version that substitutes 1 for Inf/Inf.
+*
+ IF( SAWNAN ) THEN
+ NEG2 = 0
+ P = BSAV
+ DO 24 J = BJ, MAX(BJ-BLKLEN+1, R), -1
+ DMINUS = LLD( J ) + P
+ IF( DMINUS.LT.ZERO ) NEG2 = NEG2 + 1
+ TMP = P / DMINUS
+ IF (DISNAN(TMP)) TMP = ONE
+ P = TMP * D(J) - SIGMA
+ 24 CONTINUE
+ END IF
+ NEGCNT = NEGCNT + NEG2
+ 230 CONTINUE
+*
+* III) Twist index
+* T was shifted by SIGMA initially.
+ GAMMA = (T + SIGMA) + P
+ IF( GAMMA.LT.ZERO ) NEGCNT = NEGCNT+1
+
+ DLANEG = NEGCNT
+ END
+ DOUBLE PRECISION FUNCTION DLANGB( NORM, N, KL, KU, AB, LDAB,
+ $ WORK )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER NORM
+ INTEGER KL, KU, LDAB, N
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION AB( LDAB, * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DLANGB returns the value of the one norm, or the Frobenius norm, or
+* the infinity norm, or the element of largest absolute value of an
+* n by n band matrix A, with kl sub-diagonals and ku super-diagonals.
+*
+* Description
+* ===========
+*
+* DLANGB returns the value
+*
+* DLANGB = ( max(abs(A(i,j))), NORM = 'M' or 'm'
+* (
+* ( norm1(A), NORM = '1', 'O' or 'o'
+* (
+* ( normI(A), NORM = 'I' or 'i'
+* (
+* ( normF(A), NORM = 'F', 'f', 'E' or 'e'
+*
+* where norm1 denotes the one norm of a matrix (maximum column sum),
+* normI denotes the infinity norm of a matrix (maximum row sum) and
+* normF denotes the Frobenius norm of a matrix (square root of sum of
+* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.
+*
+* Arguments
+* =========
+*
+* NORM (input) CHARACTER*1
+* Specifies the value to be returned in DLANGB as described
+* above.
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0. When N = 0, DLANGB is
+* set to zero.
+*
+* KL (input) INTEGER
+* The number of sub-diagonals of the matrix A. KL >= 0.
+*
+* KU (input) INTEGER
+* The number of super-diagonals of the matrix A. KU >= 0.
+*
+* AB (input) DOUBLE PRECISION array, dimension (LDAB,N)
+* The band matrix A, stored in rows 1 to KL+KU+1. The j-th
+* column of A is stored in the j-th column of the array AB as
+* follows:
+* AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(n,j+kl).
+*
+* LDAB (input) INTEGER
+* The leading dimension of the array AB. LDAB >= KL+KU+1.
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)),
+* where LWORK >= N when NORM = 'I'; otherwise, WORK is not
+* referenced.
+*
+* =====================================================================
+*
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE, ZERO
+ PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, J, K, L
+ DOUBLE PRECISION SCALE, SUM, VALUE
+* ..
+* .. External Subroutines ..
+ EXTERNAL DLASSQ
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, MIN, SQRT
+* ..
+* .. Executable Statements ..
+*
+ IF( N.EQ.0 ) THEN
+ VALUE = ZERO
+ ELSE IF( LSAME( NORM, 'M' ) ) THEN
+*
+* Find max(abs(A(i,j))).
+*
+ VALUE = ZERO
+ DO 20 J = 1, N
+ DO 10 I = MAX( KU+2-J, 1 ), MIN( N+KU+1-J, KL+KU+1 )
+ VALUE = MAX( VALUE, ABS( AB( I, J ) ) )
+ 10 CONTINUE
+ 20 CONTINUE
+ ELSE IF( ( LSAME( NORM, 'O' ) ) .OR. ( NORM.EQ.'1' ) ) THEN
+*
+* Find norm1(A).
+*
+ VALUE = ZERO
+ DO 40 J = 1, N
+ SUM = ZERO
+ DO 30 I = MAX( KU+2-J, 1 ), MIN( N+KU+1-J, KL+KU+1 )
+ SUM = SUM + ABS( AB( I, J ) )
+ 30 CONTINUE
+ VALUE = MAX( VALUE, SUM )
+ 40 CONTINUE
+ ELSE IF( LSAME( NORM, 'I' ) ) THEN
+*
+* Find normI(A).
+*
+ DO 50 I = 1, N
+ WORK( I ) = ZERO
+ 50 CONTINUE
+ DO 70 J = 1, N
+ K = KU + 1 - J
+ DO 60 I = MAX( 1, J-KU ), MIN( N, J+KL )
+ WORK( I ) = WORK( I ) + ABS( AB( K+I, J ) )
+ 60 CONTINUE
+ 70 CONTINUE
+ VALUE = ZERO
+ DO 80 I = 1, N
+ VALUE = MAX( VALUE, WORK( I ) )
+ 80 CONTINUE
+ ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN
+*
+* Find normF(A).
+*
+ SCALE = ZERO
+ SUM = ONE
+ DO 90 J = 1, N
+ L = MAX( 1, J-KU )
+ K = KU + 1 - J + L
+ CALL DLASSQ( MIN( N, J+KL )-L+1, AB( K, J ), 1, SCALE, SUM )
+ 90 CONTINUE
+ VALUE = SCALE*SQRT( SUM )
+ END IF
+*
+ DLANGB = VALUE
+ RETURN
+*
+* End of DLANGB
+*
+ END
+ DOUBLE PRECISION FUNCTION DLANGE( NORM, M, N, A, LDA, WORK )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER NORM
+ INTEGER LDA, M, N
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION A( LDA, * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DLANGE returns the value of the one norm, or the Frobenius norm, or
+* the infinity norm, or the element of largest absolute value of a
+* real matrix A.
+*
+* Description
+* ===========
+*
+* DLANGE returns the value
+*
+* DLANGE = ( max(abs(A(i,j))), NORM = 'M' or 'm'
+* (
+* ( norm1(A), NORM = '1', 'O' or 'o'
+* (
+* ( normI(A), NORM = 'I' or 'i'
+* (
+* ( normF(A), NORM = 'F', 'f', 'E' or 'e'
+*
+* where norm1 denotes the one norm of a matrix (maximum column sum),
+* normI denotes the infinity norm of a matrix (maximum row sum) and
+* normF denotes the Frobenius norm of a matrix (square root of sum of
+* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.
+*
+* Arguments
+* =========
+*
+* NORM (input) CHARACTER*1
+* Specifies the value to be returned in DLANGE as described
+* above.
+*
+* M (input) INTEGER
+* The number of rows of the matrix A. M >= 0. When M = 0,
+* DLANGE is set to zero.
+*
+* N (input) INTEGER
+* The number of columns of the matrix A. N >= 0. When N = 0,
+* DLANGE is set to zero.
+*
+* A (input) DOUBLE PRECISION array, dimension (LDA,N)
+* The m by n matrix A.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(M,1).
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)),
+* where LWORK >= M when NORM = 'I'; otherwise, WORK is not
+* referenced.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE, ZERO
+ PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, J
+ DOUBLE PRECISION SCALE, SUM, VALUE
+* ..
+* .. External Subroutines ..
+ EXTERNAL DLASSQ
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, MIN, SQRT
+* ..
+* .. Executable Statements ..
+*
+ IF( MIN( M, N ).EQ.0 ) THEN
+ VALUE = ZERO
+ ELSE IF( LSAME( NORM, 'M' ) ) THEN
+*
+* Find max(abs(A(i,j))).
+*
+ VALUE = ZERO
+ DO 20 J = 1, N
+ DO 10 I = 1, M
+ VALUE = MAX( VALUE, ABS( A( I, J ) ) )
+ 10 CONTINUE
+ 20 CONTINUE
+ ELSE IF( ( LSAME( NORM, 'O' ) ) .OR. ( NORM.EQ.'1' ) ) THEN
+*
+* Find norm1(A).
+*
+ VALUE = ZERO
+ DO 40 J = 1, N
+ SUM = ZERO
+ DO 30 I = 1, M
+ SUM = SUM + ABS( A( I, J ) )
+ 30 CONTINUE
+ VALUE = MAX( VALUE, SUM )
+ 40 CONTINUE
+ ELSE IF( LSAME( NORM, 'I' ) ) THEN
+*
+* Find normI(A).
+*
+ DO 50 I = 1, M
+ WORK( I ) = ZERO
+ 50 CONTINUE
+ DO 70 J = 1, N
+ DO 60 I = 1, M
+ WORK( I ) = WORK( I ) + ABS( A( I, J ) )
+ 60 CONTINUE
+ 70 CONTINUE
+ VALUE = ZERO
+ DO 80 I = 1, M
+ VALUE = MAX( VALUE, WORK( I ) )
+ 80 CONTINUE
+ ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN
+*
+* Find normF(A).
+*
+ SCALE = ZERO
+ SUM = ONE
+ DO 90 J = 1, N
+ CALL DLASSQ( M, A( 1, J ), 1, SCALE, SUM )
+ 90 CONTINUE
+ VALUE = SCALE*SQRT( SUM )
+ END IF
+*
+ DLANGE = VALUE
+ RETURN
+*
+* End of DLANGE
+*
+ END
+ DOUBLE PRECISION FUNCTION DLANGT( NORM, N, DL, D, DU )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER NORM
+ INTEGER N
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION D( * ), DL( * ), DU( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DLANGT returns the value of the one norm, or the Frobenius norm, or
+* the infinity norm, or the element of largest absolute value of a
+* real tridiagonal matrix A.
+*
+* Description
+* ===========
+*
+* DLANGT returns the value
+*
+* DLANGT = ( max(abs(A(i,j))), NORM = 'M' or 'm'
+* (
+* ( norm1(A), NORM = '1', 'O' or 'o'
+* (
+* ( normI(A), NORM = 'I' or 'i'
+* (
+* ( normF(A), NORM = 'F', 'f', 'E' or 'e'
+*
+* where norm1 denotes the one norm of a matrix (maximum column sum),
+* normI denotes the infinity norm of a matrix (maximum row sum) and
+* normF denotes the Frobenius norm of a matrix (square root of sum of
+* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.
+*
+* Arguments
+* =========
+*
+* NORM (input) CHARACTER*1
+* Specifies the value to be returned in DLANGT as described
+* above.
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0. When N = 0, DLANGT is
+* set to zero.
+*
+* DL (input) DOUBLE PRECISION array, dimension (N-1)
+* The (n-1) sub-diagonal elements of A.
+*
+* D (input) DOUBLE PRECISION array, dimension (N)
+* The diagonal elements of A.
+*
+* DU (input) DOUBLE PRECISION array, dimension (N-1)
+* The (n-1) super-diagonal elements of A.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE, ZERO
+ PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I
+ DOUBLE PRECISION ANORM, SCALE, SUM
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL DLASSQ
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, SQRT
+* ..
+* .. Executable Statements ..
+*
+ IF( N.LE.0 ) THEN
+ ANORM = ZERO
+ ELSE IF( LSAME( NORM, 'M' ) ) THEN
+*
+* Find max(abs(A(i,j))).
+*
+ ANORM = ABS( D( N ) )
+ DO 10 I = 1, N - 1
+ ANORM = MAX( ANORM, ABS( DL( I ) ) )
+ ANORM = MAX( ANORM, ABS( D( I ) ) )
+ ANORM = MAX( ANORM, ABS( DU( I ) ) )
+ 10 CONTINUE
+ ELSE IF( LSAME( NORM, 'O' ) .OR. NORM.EQ.'1' ) THEN
+*
+* Find norm1(A).
+*
+ IF( N.EQ.1 ) THEN
+ ANORM = ABS( D( 1 ) )
+ ELSE
+ ANORM = MAX( ABS( D( 1 ) )+ABS( DL( 1 ) ),
+ $ ABS( D( N ) )+ABS( DU( N-1 ) ) )
+ DO 20 I = 2, N - 1
+ ANORM = MAX( ANORM, ABS( D( I ) )+ABS( DL( I ) )+
+ $ ABS( DU( I-1 ) ) )
+ 20 CONTINUE
+ END IF
+ ELSE IF( LSAME( NORM, 'I' ) ) THEN
+*
+* Find normI(A).
+*
+ IF( N.EQ.1 ) THEN
+ ANORM = ABS( D( 1 ) )
+ ELSE
+ ANORM = MAX( ABS( D( 1 ) )+ABS( DU( 1 ) ),
+ $ ABS( D( N ) )+ABS( DL( N-1 ) ) )
+ DO 30 I = 2, N - 1
+ ANORM = MAX( ANORM, ABS( D( I ) )+ABS( DU( I ) )+
+ $ ABS( DL( I-1 ) ) )
+ 30 CONTINUE
+ END IF
+ ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN
+*
+* Find normF(A).
+*
+ SCALE = ZERO
+ SUM = ONE
+ CALL DLASSQ( N, D, 1, SCALE, SUM )
+ IF( N.GT.1 ) THEN
+ CALL DLASSQ( N-1, DL, 1, SCALE, SUM )
+ CALL DLASSQ( N-1, DU, 1, SCALE, SUM )
+ END IF
+ ANORM = SCALE*SQRT( SUM )
+ END IF
+*
+ DLANGT = ANORM
+ RETURN
+*
+* End of DLANGT
+*
+ END
+ DOUBLE PRECISION FUNCTION DLANHS( NORM, N, A, LDA, WORK )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER NORM
+ INTEGER LDA, N
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION A( LDA, * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DLANHS returns the value of the one norm, or the Frobenius norm, or
+* the infinity norm, or the element of largest absolute value of a
+* Hessenberg matrix A.
+*
+* Description
+* ===========
+*
+* DLANHS returns the value
+*
+* DLANHS = ( max(abs(A(i,j))), NORM = 'M' or 'm'
+* (
+* ( norm1(A), NORM = '1', 'O' or 'o'
+* (
+* ( normI(A), NORM = 'I' or 'i'
+* (
+* ( normF(A), NORM = 'F', 'f', 'E' or 'e'
+*
+* where norm1 denotes the one norm of a matrix (maximum column sum),
+* normI denotes the infinity norm of a matrix (maximum row sum) and
+* normF denotes the Frobenius norm of a matrix (square root of sum of
+* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.
+*
+* Arguments
+* =========
+*
+* NORM (input) CHARACTER*1
+* Specifies the value to be returned in DLANHS as described
+* above.
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0. When N = 0, DLANHS is
+* set to zero.
+*
+* A (input) DOUBLE PRECISION array, dimension (LDA,N)
+* The n by n upper Hessenberg matrix A; the part of A below the
+* first sub-diagonal is not referenced.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(N,1).
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)),
+* where LWORK >= N when NORM = 'I'; otherwise, WORK is not
+* referenced.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE, ZERO
+ PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, J
+ DOUBLE PRECISION SCALE, SUM, VALUE
+* ..
+* .. External Subroutines ..
+ EXTERNAL DLASSQ
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, MIN, SQRT
+* ..
+* .. Executable Statements ..
+*
+ IF( N.EQ.0 ) THEN
+ VALUE = ZERO
+ ELSE IF( LSAME( NORM, 'M' ) ) THEN
+*
+* Find max(abs(A(i,j))).
+*
+ VALUE = ZERO
+ DO 20 J = 1, N
+ DO 10 I = 1, MIN( N, J+1 )
+ VALUE = MAX( VALUE, ABS( A( I, J ) ) )
+ 10 CONTINUE
+ 20 CONTINUE
+ ELSE IF( ( LSAME( NORM, 'O' ) ) .OR. ( NORM.EQ.'1' ) ) THEN
+*
+* Find norm1(A).
+*
+ VALUE = ZERO
+ DO 40 J = 1, N
+ SUM = ZERO
+ DO 30 I = 1, MIN( N, J+1 )
+ SUM = SUM + ABS( A( I, J ) )
+ 30 CONTINUE
+ VALUE = MAX( VALUE, SUM )
+ 40 CONTINUE
+ ELSE IF( LSAME( NORM, 'I' ) ) THEN
+*
+* Find normI(A).
+*
+ DO 50 I = 1, N
+ WORK( I ) = ZERO
+ 50 CONTINUE
+ DO 70 J = 1, N
+ DO 60 I = 1, MIN( N, J+1 )
+ WORK( I ) = WORK( I ) + ABS( A( I, J ) )
+ 60 CONTINUE
+ 70 CONTINUE
+ VALUE = ZERO
+ DO 80 I = 1, N
+ VALUE = MAX( VALUE, WORK( I ) )
+ 80 CONTINUE
+ ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN
+*
+* Find normF(A).
+*
+ SCALE = ZERO
+ SUM = ONE
+ DO 90 J = 1, N
+ CALL DLASSQ( MIN( N, J+1 ), A( 1, J ), 1, SCALE, SUM )
+ 90 CONTINUE
+ VALUE = SCALE*SQRT( SUM )
+ END IF
+*
+ DLANHS = VALUE
+ RETURN
+*
+* End of DLANHS
+*
+ END
+ DOUBLE PRECISION FUNCTION DLANSB( NORM, UPLO, N, K, AB, LDAB,
+ $ WORK )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER NORM, UPLO
+ INTEGER K, LDAB, N
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION AB( LDAB, * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DLANSB returns the value of the one norm, or the Frobenius norm, or
+* the infinity norm, or the element of largest absolute value of an
+* n by n symmetric band matrix A, with k super-diagonals.
+*
+* Description
+* ===========
+*
+* DLANSB returns the value
+*
+* DLANSB = ( max(abs(A(i,j))), NORM = 'M' or 'm'
+* (
+* ( norm1(A), NORM = '1', 'O' or 'o'
+* (
+* ( normI(A), NORM = 'I' or 'i'
+* (
+* ( normF(A), NORM = 'F', 'f', 'E' or 'e'
+*
+* where norm1 denotes the one norm of a matrix (maximum column sum),
+* normI denotes the infinity norm of a matrix (maximum row sum) and
+* normF denotes the Frobenius norm of a matrix (square root of sum of
+* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.
+*
+* Arguments
+* =========
+*
+* NORM (input) CHARACTER*1
+* Specifies the value to be returned in DLANSB as described
+* above.
+*
+* UPLO (input) CHARACTER*1
+* Specifies whether the upper or lower triangular part of the
+* band matrix A is supplied.
+* = 'U': Upper triangular part is supplied
+* = 'L': Lower triangular part is supplied
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0. When N = 0, DLANSB is
+* set to zero.
+*
+* K (input) INTEGER
+* The number of super-diagonals or sub-diagonals of the
+* band matrix A. K >= 0.
+*
+* AB (input) DOUBLE PRECISION array, dimension (LDAB,N)
+* The upper or lower triangle of the symmetric band matrix A,
+* stored in the first K+1 rows of AB. The j-th column of A is
+* stored in the j-th column of the array AB as follows:
+* if UPLO = 'U', AB(k+1+i-j,j) = A(i,j) for max(1,j-k)<=i<=j;
+* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+k).
+*
+* LDAB (input) INTEGER
+* The leading dimension of the array AB. LDAB >= K+1.
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)),
+* where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,
+* WORK is not referenced.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE, ZERO
+ PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, J, L
+ DOUBLE PRECISION ABSA, SCALE, SUM, VALUE
+* ..
+* .. External Subroutines ..
+ EXTERNAL DLASSQ
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, MIN, SQRT
+* ..
+* .. Executable Statements ..
+*
+ IF( N.EQ.0 ) THEN
+ VALUE = ZERO
+ ELSE IF( LSAME( NORM, 'M' ) ) THEN
+*
+* Find max(abs(A(i,j))).
+*
+ VALUE = ZERO
+ IF( LSAME( UPLO, 'U' ) ) THEN
+ DO 20 J = 1, N
+ DO 10 I = MAX( K+2-J, 1 ), K + 1
+ VALUE = MAX( VALUE, ABS( AB( I, J ) ) )
+ 10 CONTINUE
+ 20 CONTINUE
+ ELSE
+ DO 40 J = 1, N
+ DO 30 I = 1, MIN( N+1-J, K+1 )
+ VALUE = MAX( VALUE, ABS( AB( I, J ) ) )
+ 30 CONTINUE
+ 40 CONTINUE
+ END IF
+ ELSE IF( ( LSAME( NORM, 'I' ) ) .OR. ( LSAME( NORM, 'O' ) ) .OR.
+ $ ( NORM.EQ.'1' ) ) THEN
+*
+* Find normI(A) ( = norm1(A), since A is symmetric).
+*
+ VALUE = ZERO
+ IF( LSAME( UPLO, 'U' ) ) THEN
+ DO 60 J = 1, N
+ SUM = ZERO
+ L = K + 1 - J
+ DO 50 I = MAX( 1, J-K ), J - 1
+ ABSA = ABS( AB( L+I, J ) )
+ SUM = SUM + ABSA
+ WORK( I ) = WORK( I ) + ABSA
+ 50 CONTINUE
+ WORK( J ) = SUM + ABS( AB( K+1, J ) )
+ 60 CONTINUE
+ DO 70 I = 1, N
+ VALUE = MAX( VALUE, WORK( I ) )
+ 70 CONTINUE
+ ELSE
+ DO 80 I = 1, N
+ WORK( I ) = ZERO
+ 80 CONTINUE
+ DO 100 J = 1, N
+ SUM = WORK( J ) + ABS( AB( 1, J ) )
+ L = 1 - J
+ DO 90 I = J + 1, MIN( N, J+K )
+ ABSA = ABS( AB( L+I, J ) )
+ SUM = SUM + ABSA
+ WORK( I ) = WORK( I ) + ABSA
+ 90 CONTINUE
+ VALUE = MAX( VALUE, SUM )
+ 100 CONTINUE
+ END IF
+ ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN
+*
+* Find normF(A).
+*
+ SCALE = ZERO
+ SUM = ONE
+ IF( K.GT.0 ) THEN
+ IF( LSAME( UPLO, 'U' ) ) THEN
+ DO 110 J = 2, N
+ CALL DLASSQ( MIN( J-1, K ), AB( MAX( K+2-J, 1 ), J ),
+ $ 1, SCALE, SUM )
+ 110 CONTINUE
+ L = K + 1
+ ELSE
+ DO 120 J = 1, N - 1
+ CALL DLASSQ( MIN( N-J, K ), AB( 2, J ), 1, SCALE,
+ $ SUM )
+ 120 CONTINUE
+ L = 1
+ END IF
+ SUM = 2*SUM
+ ELSE
+ L = 1
+ END IF
+ CALL DLASSQ( N, AB( L, 1 ), LDAB, SCALE, SUM )
+ VALUE = SCALE*SQRT( SUM )
+ END IF
+*
+ DLANSB = VALUE
+ RETURN
+*
+* End of DLANSB
+*
+ END
+ DOUBLE PRECISION FUNCTION DLANSP( NORM, UPLO, N, AP, WORK )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER NORM, UPLO
+ INTEGER N
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION AP( * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DLANSP returns the value of the one norm, or the Frobenius norm, or
+* the infinity norm, or the element of largest absolute value of a
+* real symmetric matrix A, supplied in packed form.
+*
+* Description
+* ===========
+*
+* DLANSP returns the value
+*
+* DLANSP = ( max(abs(A(i,j))), NORM = 'M' or 'm'
+* (
+* ( norm1(A), NORM = '1', 'O' or 'o'
+* (
+* ( normI(A), NORM = 'I' or 'i'
+* (
+* ( normF(A), NORM = 'F', 'f', 'E' or 'e'
+*
+* where norm1 denotes the one norm of a matrix (maximum column sum),
+* normI denotes the infinity norm of a matrix (maximum row sum) and
+* normF denotes the Frobenius norm of a matrix (square root of sum of
+* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.
+*
+* Arguments
+* =========
+*
+* NORM (input) CHARACTER*1
+* Specifies the value to be returned in DLANSP as described
+* above.
+*
+* UPLO (input) CHARACTER*1
+* Specifies whether the upper or lower triangular part of the
+* symmetric matrix A is supplied.
+* = 'U': Upper triangular part of A is supplied
+* = 'L': Lower triangular part of A is supplied
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0. When N = 0, DLANSP is
+* set to zero.
+*
+* AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)
+* The upper or lower triangle of the symmetric matrix A, packed
+* columnwise in a linear array. The j-th column of A is stored
+* in the array AP as follows:
+* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
+* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)),
+* where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,
+* WORK is not referenced.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE, ZERO
+ PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, J, K
+ DOUBLE PRECISION ABSA, SCALE, SUM, VALUE
+* ..
+* .. External Subroutines ..
+ EXTERNAL DLASSQ
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, SQRT
+* ..
+* .. Executable Statements ..
+*
+ IF( N.EQ.0 ) THEN
+ VALUE = ZERO
+ ELSE IF( LSAME( NORM, 'M' ) ) THEN
+*
+* Find max(abs(A(i,j))).
+*
+ VALUE = ZERO
+ IF( LSAME( UPLO, 'U' ) ) THEN
+ K = 1
+ DO 20 J = 1, N
+ DO 10 I = K, K + J - 1
+ VALUE = MAX( VALUE, ABS( AP( I ) ) )
+ 10 CONTINUE
+ K = K + J
+ 20 CONTINUE
+ ELSE
+ K = 1
+ DO 40 J = 1, N
+ DO 30 I = K, K + N - J
+ VALUE = MAX( VALUE, ABS( AP( I ) ) )
+ 30 CONTINUE
+ K = K + N - J + 1
+ 40 CONTINUE
+ END IF
+ ELSE IF( ( LSAME( NORM, 'I' ) ) .OR. ( LSAME( NORM, 'O' ) ) .OR.
+ $ ( NORM.EQ.'1' ) ) THEN
+*
+* Find normI(A) ( = norm1(A), since A is symmetric).
+*
+ VALUE = ZERO
+ K = 1
+ IF( LSAME( UPLO, 'U' ) ) THEN
+ DO 60 J = 1, N
+ SUM = ZERO
+ DO 50 I = 1, J - 1
+ ABSA = ABS( AP( K ) )
+ SUM = SUM + ABSA
+ WORK( I ) = WORK( I ) + ABSA
+ K = K + 1
+ 50 CONTINUE
+ WORK( J ) = SUM + ABS( AP( K ) )
+ K = K + 1
+ 60 CONTINUE
+ DO 70 I = 1, N
+ VALUE = MAX( VALUE, WORK( I ) )
+ 70 CONTINUE
+ ELSE
+ DO 80 I = 1, N
+ WORK( I ) = ZERO
+ 80 CONTINUE
+ DO 100 J = 1, N
+ SUM = WORK( J ) + ABS( AP( K ) )
+ K = K + 1
+ DO 90 I = J + 1, N
+ ABSA = ABS( AP( K ) )
+ SUM = SUM + ABSA
+ WORK( I ) = WORK( I ) + ABSA
+ K = K + 1
+ 90 CONTINUE
+ VALUE = MAX( VALUE, SUM )
+ 100 CONTINUE
+ END IF
+ ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN
+*
+* Find normF(A).
+*
+ SCALE = ZERO
+ SUM = ONE
+ K = 2
+ IF( LSAME( UPLO, 'U' ) ) THEN
+ DO 110 J = 2, N
+ CALL DLASSQ( J-1, AP( K ), 1, SCALE, SUM )
+ K = K + J
+ 110 CONTINUE
+ ELSE
+ DO 120 J = 1, N - 1
+ CALL DLASSQ( N-J, AP( K ), 1, SCALE, SUM )
+ K = K + N - J + 1
+ 120 CONTINUE
+ END IF
+ SUM = 2*SUM
+ K = 1
+ DO 130 I = 1, N
+ IF( AP( K ).NE.ZERO ) THEN
+ ABSA = ABS( AP( K ) )
+ IF( SCALE.LT.ABSA ) THEN
+ SUM = ONE + SUM*( SCALE / ABSA )**2
+ SCALE = ABSA
+ ELSE
+ SUM = SUM + ( ABSA / SCALE )**2
+ END IF
+ END IF
+ IF( LSAME( UPLO, 'U' ) ) THEN
+ K = K + I + 1
+ ELSE
+ K = K + N - I + 1
+ END IF
+ 130 CONTINUE
+ VALUE = SCALE*SQRT( SUM )
+ END IF
+*
+ DLANSP = VALUE
+ RETURN
+*
+* End of DLANSP
+*
+ END
+ DOUBLE PRECISION FUNCTION DLANST( NORM, N, D, E )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER NORM
+ INTEGER N
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION D( * ), E( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DLANST returns the value of the one norm, or the Frobenius norm, or
+* the infinity norm, or the element of largest absolute value of a
+* real symmetric tridiagonal matrix A.
+*
+* Description
+* ===========
+*
+* DLANST returns the value
+*
+* DLANST = ( max(abs(A(i,j))), NORM = 'M' or 'm'
+* (
+* ( norm1(A), NORM = '1', 'O' or 'o'
+* (
+* ( normI(A), NORM = 'I' or 'i'
+* (
+* ( normF(A), NORM = 'F', 'f', 'E' or 'e'
+*
+* where norm1 denotes the one norm of a matrix (maximum column sum),
+* normI denotes the infinity norm of a matrix (maximum row sum) and
+* normF denotes the Frobenius norm of a matrix (square root of sum of
+* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.
+*
+* Arguments
+* =========
+*
+* NORM (input) CHARACTER*1
+* Specifies the value to be returned in DLANST as described
+* above.
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0. When N = 0, DLANST is
+* set to zero.
+*
+* D (input) DOUBLE PRECISION array, dimension (N)
+* The diagonal elements of A.
+*
+* E (input) DOUBLE PRECISION array, dimension (N-1)
+* The (n-1) sub-diagonal or super-diagonal elements of A.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE, ZERO
+ PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I
+ DOUBLE PRECISION ANORM, SCALE, SUM
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL DLASSQ
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, SQRT
+* ..
+* .. Executable Statements ..
+*
+ IF( N.LE.0 ) THEN
+ ANORM = ZERO
+ ELSE IF( LSAME( NORM, 'M' ) ) THEN
+*
+* Find max(abs(A(i,j))).
+*
+ ANORM = ABS( D( N ) )
+ DO 10 I = 1, N - 1
+ ANORM = MAX( ANORM, ABS( D( I ) ) )
+ ANORM = MAX( ANORM, ABS( E( I ) ) )
+ 10 CONTINUE
+ ELSE IF( LSAME( NORM, 'O' ) .OR. NORM.EQ.'1' .OR.
+ $ LSAME( NORM, 'I' ) ) THEN
+*
+* Find norm1(A).
+*
+ IF( N.EQ.1 ) THEN
+ ANORM = ABS( D( 1 ) )
+ ELSE
+ ANORM = MAX( ABS( D( 1 ) )+ABS( E( 1 ) ),
+ $ ABS( E( N-1 ) )+ABS( D( N ) ) )
+ DO 20 I = 2, N - 1
+ ANORM = MAX( ANORM, ABS( D( I ) )+ABS( E( I ) )+
+ $ ABS( E( I-1 ) ) )
+ 20 CONTINUE
+ END IF
+ ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN
+*
+* Find normF(A).
+*
+ SCALE = ZERO
+ SUM = ONE
+ IF( N.GT.1 ) THEN
+ CALL DLASSQ( N-1, E, 1, SCALE, SUM )
+ SUM = 2*SUM
+ END IF
+ CALL DLASSQ( N, D, 1, SCALE, SUM )
+ ANORM = SCALE*SQRT( SUM )
+ END IF
+*
+ DLANST = ANORM
+ RETURN
+*
+* End of DLANST
+*
+ END
+ DOUBLE PRECISION FUNCTION DLANSY( NORM, UPLO, N, A, LDA, WORK )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER NORM, UPLO
+ INTEGER LDA, N
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION A( LDA, * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DLANSY returns the value of the one norm, or the Frobenius norm, or
+* the infinity norm, or the element of largest absolute value of a
+* real symmetric matrix A.
+*
+* Description
+* ===========
+*
+* DLANSY returns the value
+*
+* DLANSY = ( max(abs(A(i,j))), NORM = 'M' or 'm'
+* (
+* ( norm1(A), NORM = '1', 'O' or 'o'
+* (
+* ( normI(A), NORM = 'I' or 'i'
+* (
+* ( normF(A), NORM = 'F', 'f', 'E' or 'e'
+*
+* where norm1 denotes the one norm of a matrix (maximum column sum),
+* normI denotes the infinity norm of a matrix (maximum row sum) and
+* normF denotes the Frobenius norm of a matrix (square root of sum of
+* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.
+*
+* Arguments
+* =========
+*
+* NORM (input) CHARACTER*1
+* Specifies the value to be returned in DLANSY as described
+* above.
+*
+* UPLO (input) CHARACTER*1
+* Specifies whether the upper or lower triangular part of the
+* symmetric matrix A is to be referenced.
+* = 'U': Upper triangular part of A is referenced
+* = 'L': Lower triangular part of A is referenced
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0. When N = 0, DLANSY is
+* set to zero.
+*
+* A (input) DOUBLE PRECISION array, dimension (LDA,N)
+* The symmetric matrix A. If UPLO = 'U', the leading n by n
+* upper triangular part of A contains the upper triangular part
+* of the matrix A, and the strictly lower triangular part of A
+* is not referenced. If UPLO = 'L', the leading n by n lower
+* triangular part of A contains the lower triangular part of
+* the matrix A, and the strictly upper triangular part of A is
+* not referenced.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(N,1).
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)),
+* where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,
+* WORK is not referenced.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE, ZERO
+ PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, J
+ DOUBLE PRECISION ABSA, SCALE, SUM, VALUE
+* ..
+* .. External Subroutines ..
+ EXTERNAL DLASSQ
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, SQRT
+* ..
+* .. Executable Statements ..
+*
+ IF( N.EQ.0 ) THEN
+ VALUE = ZERO
+ ELSE IF( LSAME( NORM, 'M' ) ) THEN
+*
+* Find max(abs(A(i,j))).
+*
+ VALUE = ZERO
+ IF( LSAME( UPLO, 'U' ) ) THEN
+ DO 20 J = 1, N
+ DO 10 I = 1, J
+ VALUE = MAX( VALUE, ABS( A( I, J ) ) )
+ 10 CONTINUE
+ 20 CONTINUE
+ ELSE
+ DO 40 J = 1, N
+ DO 30 I = J, N
+ VALUE = MAX( VALUE, ABS( A( I, J ) ) )
+ 30 CONTINUE
+ 40 CONTINUE
+ END IF
+ ELSE IF( ( LSAME( NORM, 'I' ) ) .OR. ( LSAME( NORM, 'O' ) ) .OR.
+ $ ( NORM.EQ.'1' ) ) THEN
+*
+* Find normI(A) ( = norm1(A), since A is symmetric).
+*
+ VALUE = ZERO
+ IF( LSAME( UPLO, 'U' ) ) THEN
+ DO 60 J = 1, N
+ SUM = ZERO
+ DO 50 I = 1, J - 1
+ ABSA = ABS( A( I, J ) )
+ SUM = SUM + ABSA
+ WORK( I ) = WORK( I ) + ABSA
+ 50 CONTINUE
+ WORK( J ) = SUM + ABS( A( J, J ) )
+ 60 CONTINUE
+ DO 70 I = 1, N
+ VALUE = MAX( VALUE, WORK( I ) )
+ 70 CONTINUE
+ ELSE
+ DO 80 I = 1, N
+ WORK( I ) = ZERO
+ 80 CONTINUE
+ DO 100 J = 1, N
+ SUM = WORK( J ) + ABS( A( J, J ) )
+ DO 90 I = J + 1, N
+ ABSA = ABS( A( I, J ) )
+ SUM = SUM + ABSA
+ WORK( I ) = WORK( I ) + ABSA
+ 90 CONTINUE
+ VALUE = MAX( VALUE, SUM )
+ 100 CONTINUE
+ END IF
+ ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN
+*
+* Find normF(A).
+*
+ SCALE = ZERO
+ SUM = ONE
+ IF( LSAME( UPLO, 'U' ) ) THEN
+ DO 110 J = 2, N
+ CALL DLASSQ( J-1, A( 1, J ), 1, SCALE, SUM )
+ 110 CONTINUE
+ ELSE
+ DO 120 J = 1, N - 1
+ CALL DLASSQ( N-J, A( J+1, J ), 1, SCALE, SUM )
+ 120 CONTINUE
+ END IF
+ SUM = 2*SUM
+ CALL DLASSQ( N, A, LDA+1, SCALE, SUM )
+ VALUE = SCALE*SQRT( SUM )
+ END IF
+*
+ DLANSY = VALUE
+ RETURN
+*
+* End of DLANSY
+*
+ END
+ DOUBLE PRECISION FUNCTION DLANTB( NORM, UPLO, DIAG, N, K, AB,
+ $ LDAB, WORK )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER DIAG, NORM, UPLO
+ INTEGER K, LDAB, N
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION AB( LDAB, * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DLANTB returns the value of the one norm, or the Frobenius norm, or
+* the infinity norm, or the element of largest absolute value of an
+* n by n triangular band matrix A, with ( k + 1 ) diagonals.
+*
+* Description
+* ===========
+*
+* DLANTB returns the value
+*
+* DLANTB = ( max(abs(A(i,j))), NORM = 'M' or 'm'
+* (
+* ( norm1(A), NORM = '1', 'O' or 'o'
+* (
+* ( normI(A), NORM = 'I' or 'i'
+* (
+* ( normF(A), NORM = 'F', 'f', 'E' or 'e'
+*
+* where norm1 denotes the one norm of a matrix (maximum column sum),
+* normI denotes the infinity norm of a matrix (maximum row sum) and
+* normF denotes the Frobenius norm of a matrix (square root of sum of
+* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.
+*
+* Arguments
+* =========
+*
+* NORM (input) CHARACTER*1
+* Specifies the value to be returned in DLANTB as described
+* above.
+*
+* UPLO (input) CHARACTER*1
+* Specifies whether the matrix A is upper or lower triangular.
+* = 'U': Upper triangular
+* = 'L': Lower triangular
+*
+* DIAG (input) CHARACTER*1
+* Specifies whether or not the matrix A is unit triangular.
+* = 'N': Non-unit triangular
+* = 'U': Unit triangular
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0. When N = 0, DLANTB is
+* set to zero.
+*
+* K (input) INTEGER
+* The number of super-diagonals of the matrix A if UPLO = 'U',
+* or the number of sub-diagonals of the matrix A if UPLO = 'L'.
+* K >= 0.
+*
+* AB (input) DOUBLE PRECISION array, dimension (LDAB,N)
+* The upper or lower triangular band matrix A, stored in the
+* first k+1 rows of AB. The j-th column of A is stored
+* in the j-th column of the array AB as follows:
+* if UPLO = 'U', AB(k+1+i-j,j) = A(i,j) for max(1,j-k)<=i<=j;
+* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+k).
+* Note that when DIAG = 'U', the elements of the array AB
+* corresponding to the diagonal elements of the matrix A are
+* not referenced, but are assumed to be one.
+*
+* LDAB (input) INTEGER
+* The leading dimension of the array AB. LDAB >= K+1.
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)),
+* where LWORK >= N when NORM = 'I'; otherwise, WORK is not
+* referenced.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE, ZERO
+ PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL UDIAG
+ INTEGER I, J, L
+ DOUBLE PRECISION SCALE, SUM, VALUE
+* ..
+* .. External Subroutines ..
+ EXTERNAL DLASSQ
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, MIN, SQRT
+* ..
+* .. Executable Statements ..
+*
+ IF( N.EQ.0 ) THEN
+ VALUE = ZERO
+ ELSE IF( LSAME( NORM, 'M' ) ) THEN
+*
+* Find max(abs(A(i,j))).
+*
+ IF( LSAME( DIAG, 'U' ) ) THEN
+ VALUE = ONE
+ IF( LSAME( UPLO, 'U' ) ) THEN
+ DO 20 J = 1, N
+ DO 10 I = MAX( K+2-J, 1 ), K
+ VALUE = MAX( VALUE, ABS( AB( I, J ) ) )
+ 10 CONTINUE
+ 20 CONTINUE
+ ELSE
+ DO 40 J = 1, N
+ DO 30 I = 2, MIN( N+1-J, K+1 )
+ VALUE = MAX( VALUE, ABS( AB( I, J ) ) )
+ 30 CONTINUE
+ 40 CONTINUE
+ END IF
+ ELSE
+ VALUE = ZERO
+ IF( LSAME( UPLO, 'U' ) ) THEN
+ DO 60 J = 1, N
+ DO 50 I = MAX( K+2-J, 1 ), K + 1
+ VALUE = MAX( VALUE, ABS( AB( I, J ) ) )
+ 50 CONTINUE
+ 60 CONTINUE
+ ELSE
+ DO 80 J = 1, N
+ DO 70 I = 1, MIN( N+1-J, K+1 )
+ VALUE = MAX( VALUE, ABS( AB( I, J ) ) )
+ 70 CONTINUE
+ 80 CONTINUE
+ END IF
+ END IF
+ ELSE IF( ( LSAME( NORM, 'O' ) ) .OR. ( NORM.EQ.'1' ) ) THEN
+*
+* Find norm1(A).
+*
+ VALUE = ZERO
+ UDIAG = LSAME( DIAG, 'U' )
+ IF( LSAME( UPLO, 'U' ) ) THEN
+ DO 110 J = 1, N
+ IF( UDIAG ) THEN
+ SUM = ONE
+ DO 90 I = MAX( K+2-J, 1 ), K
+ SUM = SUM + ABS( AB( I, J ) )
+ 90 CONTINUE
+ ELSE
+ SUM = ZERO
+ DO 100 I = MAX( K+2-J, 1 ), K + 1
+ SUM = SUM + ABS( AB( I, J ) )
+ 100 CONTINUE
+ END IF
+ VALUE = MAX( VALUE, SUM )
+ 110 CONTINUE
+ ELSE
+ DO 140 J = 1, N
+ IF( UDIAG ) THEN
+ SUM = ONE
+ DO 120 I = 2, MIN( N+1-J, K+1 )
+ SUM = SUM + ABS( AB( I, J ) )
+ 120 CONTINUE
+ ELSE
+ SUM = ZERO
+ DO 130 I = 1, MIN( N+1-J, K+1 )
+ SUM = SUM + ABS( AB( I, J ) )
+ 130 CONTINUE
+ END IF
+ VALUE = MAX( VALUE, SUM )
+ 140 CONTINUE
+ END IF
+ ELSE IF( LSAME( NORM, 'I' ) ) THEN
+*
+* Find normI(A).
+*
+ VALUE = ZERO
+ IF( LSAME( UPLO, 'U' ) ) THEN
+ IF( LSAME( DIAG, 'U' ) ) THEN
+ DO 150 I = 1, N
+ WORK( I ) = ONE
+ 150 CONTINUE
+ DO 170 J = 1, N
+ L = K + 1 - J
+ DO 160 I = MAX( 1, J-K ), J - 1
+ WORK( I ) = WORK( I ) + ABS( AB( L+I, J ) )
+ 160 CONTINUE
+ 170 CONTINUE
+ ELSE
+ DO 180 I = 1, N
+ WORK( I ) = ZERO
+ 180 CONTINUE
+ DO 200 J = 1, N
+ L = K + 1 - J
+ DO 190 I = MAX( 1, J-K ), J
+ WORK( I ) = WORK( I ) + ABS( AB( L+I, J ) )
+ 190 CONTINUE
+ 200 CONTINUE
+ END IF
+ ELSE
+ IF( LSAME( DIAG, 'U' ) ) THEN
+ DO 210 I = 1, N
+ WORK( I ) = ONE
+ 210 CONTINUE
+ DO 230 J = 1, N
+ L = 1 - J
+ DO 220 I = J + 1, MIN( N, J+K )
+ WORK( I ) = WORK( I ) + ABS( AB( L+I, J ) )
+ 220 CONTINUE
+ 230 CONTINUE
+ ELSE
+ DO 240 I = 1, N
+ WORK( I ) = ZERO
+ 240 CONTINUE
+ DO 260 J = 1, N
+ L = 1 - J
+ DO 250 I = J, MIN( N, J+K )
+ WORK( I ) = WORK( I ) + ABS( AB( L+I, J ) )
+ 250 CONTINUE
+ 260 CONTINUE
+ END IF
+ END IF
+ DO 270 I = 1, N
+ VALUE = MAX( VALUE, WORK( I ) )
+ 270 CONTINUE
+ ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN
+*
+* Find normF(A).
+*
+ IF( LSAME( UPLO, 'U' ) ) THEN
+ IF( LSAME( DIAG, 'U' ) ) THEN
+ SCALE = ONE
+ SUM = N
+ IF( K.GT.0 ) THEN
+ DO 280 J = 2, N
+ CALL DLASSQ( MIN( J-1, K ),
+ $ AB( MAX( K+2-J, 1 ), J ), 1, SCALE,
+ $ SUM )
+ 280 CONTINUE
+ END IF
+ ELSE
+ SCALE = ZERO
+ SUM = ONE
+ DO 290 J = 1, N
+ CALL DLASSQ( MIN( J, K+1 ), AB( MAX( K+2-J, 1 ), J ),
+ $ 1, SCALE, SUM )
+ 290 CONTINUE
+ END IF
+ ELSE
+ IF( LSAME( DIAG, 'U' ) ) THEN
+ SCALE = ONE
+ SUM = N
+ IF( K.GT.0 ) THEN
+ DO 300 J = 1, N - 1
+ CALL DLASSQ( MIN( N-J, K ), AB( 2, J ), 1, SCALE,
+ $ SUM )
+ 300 CONTINUE
+ END IF
+ ELSE
+ SCALE = ZERO
+ SUM = ONE
+ DO 310 J = 1, N
+ CALL DLASSQ( MIN( N-J+1, K+1 ), AB( 1, J ), 1, SCALE,
+ $ SUM )
+ 310 CONTINUE
+ END IF
+ END IF
+ VALUE = SCALE*SQRT( SUM )
+ END IF
+*
+ DLANTB = VALUE
+ RETURN
+*
+* End of DLANTB
+*
+ END
+ DOUBLE PRECISION FUNCTION DLANTP( NORM, UPLO, DIAG, N, AP, WORK )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER DIAG, NORM, UPLO
+ INTEGER N
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION AP( * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DLANTP returns the value of the one norm, or the Frobenius norm, or
+* the infinity norm, or the element of largest absolute value of a
+* triangular matrix A, supplied in packed form.
+*
+* Description
+* ===========
+*
+* DLANTP returns the value
+*
+* DLANTP = ( max(abs(A(i,j))), NORM = 'M' or 'm'
+* (
+* ( norm1(A), NORM = '1', 'O' or 'o'
+* (
+* ( normI(A), NORM = 'I' or 'i'
+* (
+* ( normF(A), NORM = 'F', 'f', 'E' or 'e'
+*
+* where norm1 denotes the one norm of a matrix (maximum column sum),
+* normI denotes the infinity norm of a matrix (maximum row sum) and
+* normF denotes the Frobenius norm of a matrix (square root of sum of
+* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.
+*
+* Arguments
+* =========
+*
+* NORM (input) CHARACTER*1
+* Specifies the value to be returned in DLANTP as described
+* above.
+*
+* UPLO (input) CHARACTER*1
+* Specifies whether the matrix A is upper or lower triangular.
+* = 'U': Upper triangular
+* = 'L': Lower triangular
+*
+* DIAG (input) CHARACTER*1
+* Specifies whether or not the matrix A is unit triangular.
+* = 'N': Non-unit triangular
+* = 'U': Unit triangular
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0. When N = 0, DLANTP is
+* set to zero.
+*
+* AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)
+* The upper or lower triangular matrix A, packed columnwise in
+* a linear array. The j-th column of A is stored in the array
+* AP as follows:
+* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
+* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
+* Note that when DIAG = 'U', the elements of the array AP
+* corresponding to the diagonal elements of the matrix A are
+* not referenced, but are assumed to be one.
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)),
+* where LWORK >= N when NORM = 'I'; otherwise, WORK is not
+* referenced.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE, ZERO
+ PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL UDIAG
+ INTEGER I, J, K
+ DOUBLE PRECISION SCALE, SUM, VALUE
+* ..
+* .. External Subroutines ..
+ EXTERNAL DLASSQ
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, SQRT
+* ..
+* .. Executable Statements ..
+*
+ IF( N.EQ.0 ) THEN
+ VALUE = ZERO
+ ELSE IF( LSAME( NORM, 'M' ) ) THEN
+*
+* Find max(abs(A(i,j))).
+*
+ K = 1
+ IF( LSAME( DIAG, 'U' ) ) THEN
+ VALUE = ONE
+ IF( LSAME( UPLO, 'U' ) ) THEN
+ DO 20 J = 1, N
+ DO 10 I = K, K + J - 2
+ VALUE = MAX( VALUE, ABS( AP( I ) ) )
+ 10 CONTINUE
+ K = K + J
+ 20 CONTINUE
+ ELSE
+ DO 40 J = 1, N
+ DO 30 I = K + 1, K + N - J
+ VALUE = MAX( VALUE, ABS( AP( I ) ) )
+ 30 CONTINUE
+ K = K + N - J + 1
+ 40 CONTINUE
+ END IF
+ ELSE
+ VALUE = ZERO
+ IF( LSAME( UPLO, 'U' ) ) THEN
+ DO 60 J = 1, N
+ DO 50 I = K, K + J - 1
+ VALUE = MAX( VALUE, ABS( AP( I ) ) )
+ 50 CONTINUE
+ K = K + J
+ 60 CONTINUE
+ ELSE
+ DO 80 J = 1, N
+ DO 70 I = K, K + N - J
+ VALUE = MAX( VALUE, ABS( AP( I ) ) )
+ 70 CONTINUE
+ K = K + N - J + 1
+ 80 CONTINUE
+ END IF
+ END IF
+ ELSE IF( ( LSAME( NORM, 'O' ) ) .OR. ( NORM.EQ.'1' ) ) THEN
+*
+* Find norm1(A).
+*
+ VALUE = ZERO
+ K = 1
+ UDIAG = LSAME( DIAG, 'U' )
+ IF( LSAME( UPLO, 'U' ) ) THEN
+ DO 110 J = 1, N
+ IF( UDIAG ) THEN
+ SUM = ONE
+ DO 90 I = K, K + J - 2
+ SUM = SUM + ABS( AP( I ) )
+ 90 CONTINUE
+ ELSE
+ SUM = ZERO
+ DO 100 I = K, K + J - 1
+ SUM = SUM + ABS( AP( I ) )
+ 100 CONTINUE
+ END IF
+ K = K + J
+ VALUE = MAX( VALUE, SUM )
+ 110 CONTINUE
+ ELSE
+ DO 140 J = 1, N
+ IF( UDIAG ) THEN
+ SUM = ONE
+ DO 120 I = K + 1, K + N - J
+ SUM = SUM + ABS( AP( I ) )
+ 120 CONTINUE
+ ELSE
+ SUM = ZERO
+ DO 130 I = K, K + N - J
+ SUM = SUM + ABS( AP( I ) )
+ 130 CONTINUE
+ END IF
+ K = K + N - J + 1
+ VALUE = MAX( VALUE, SUM )
+ 140 CONTINUE
+ END IF
+ ELSE IF( LSAME( NORM, 'I' ) ) THEN
+*
+* Find normI(A).
+*
+ K = 1
+ IF( LSAME( UPLO, 'U' ) ) THEN
+ IF( LSAME( DIAG, 'U' ) ) THEN
+ DO 150 I = 1, N
+ WORK( I ) = ONE
+ 150 CONTINUE
+ DO 170 J = 1, N
+ DO 160 I = 1, J - 1
+ WORK( I ) = WORK( I ) + ABS( AP( K ) )
+ K = K + 1
+ 160 CONTINUE
+ K = K + 1
+ 170 CONTINUE
+ ELSE
+ DO 180 I = 1, N
+ WORK( I ) = ZERO
+ 180 CONTINUE
+ DO 200 J = 1, N
+ DO 190 I = 1, J
+ WORK( I ) = WORK( I ) + ABS( AP( K ) )
+ K = K + 1
+ 190 CONTINUE
+ 200 CONTINUE
+ END IF
+ ELSE
+ IF( LSAME( DIAG, 'U' ) ) THEN
+ DO 210 I = 1, N
+ WORK( I ) = ONE
+ 210 CONTINUE
+ DO 230 J = 1, N
+ K = K + 1
+ DO 220 I = J + 1, N
+ WORK( I ) = WORK( I ) + ABS( AP( K ) )
+ K = K + 1
+ 220 CONTINUE
+ 230 CONTINUE
+ ELSE
+ DO 240 I = 1, N
+ WORK( I ) = ZERO
+ 240 CONTINUE
+ DO 260 J = 1, N
+ DO 250 I = J, N
+ WORK( I ) = WORK( I ) + ABS( AP( K ) )
+ K = K + 1
+ 250 CONTINUE
+ 260 CONTINUE
+ END IF
+ END IF
+ VALUE = ZERO
+ DO 270 I = 1, N
+ VALUE = MAX( VALUE, WORK( I ) )
+ 270 CONTINUE
+ ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN
+*
+* Find normF(A).
+*
+ IF( LSAME( UPLO, 'U' ) ) THEN
+ IF( LSAME( DIAG, 'U' ) ) THEN
+ SCALE = ONE
+ SUM = N
+ K = 2
+ DO 280 J = 2, N
+ CALL DLASSQ( J-1, AP( K ), 1, SCALE, SUM )
+ K = K + J
+ 280 CONTINUE
+ ELSE
+ SCALE = ZERO
+ SUM = ONE
+ K = 1
+ DO 290 J = 1, N
+ CALL DLASSQ( J, AP( K ), 1, SCALE, SUM )
+ K = K + J
+ 290 CONTINUE
+ END IF
+ ELSE
+ IF( LSAME( DIAG, 'U' ) ) THEN
+ SCALE = ONE
+ SUM = N
+ K = 2
+ DO 300 J = 1, N - 1
+ CALL DLASSQ( N-J, AP( K ), 1, SCALE, SUM )
+ K = K + N - J + 1
+ 300 CONTINUE
+ ELSE
+ SCALE = ZERO
+ SUM = ONE
+ K = 1
+ DO 310 J = 1, N
+ CALL DLASSQ( N-J+1, AP( K ), 1, SCALE, SUM )
+ K = K + N - J + 1
+ 310 CONTINUE
+ END IF
+ END IF
+ VALUE = SCALE*SQRT( SUM )
+ END IF
+*
+ DLANTP = VALUE
+ RETURN
+*
+* End of DLANTP
+*
+ END
+ DOUBLE PRECISION FUNCTION DLANTR( NORM, UPLO, DIAG, M, N, A, LDA,
+ $ WORK )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER DIAG, NORM, UPLO
+ INTEGER LDA, M, N
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION A( LDA, * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DLANTR returns the value of the one norm, or the Frobenius norm, or
+* the infinity norm, or the element of largest absolute value of a
+* trapezoidal or triangular matrix A.
+*
+* Description
+* ===========
+*
+* DLANTR returns the value
+*
+* DLANTR = ( max(abs(A(i,j))), NORM = 'M' or 'm'
+* (
+* ( norm1(A), NORM = '1', 'O' or 'o'
+* (
+* ( normI(A), NORM = 'I' or 'i'
+* (
+* ( normF(A), NORM = 'F', 'f', 'E' or 'e'
+*
+* where norm1 denotes the one norm of a matrix (maximum column sum),
+* normI denotes the infinity norm of a matrix (maximum row sum) and
+* normF denotes the Frobenius norm of a matrix (square root of sum of
+* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.
+*
+* Arguments
+* =========
+*
+* NORM (input) CHARACTER*1
+* Specifies the value to be returned in DLANTR as described
+* above.
+*
+* UPLO (input) CHARACTER*1
+* Specifies whether the matrix A is upper or lower trapezoidal.
+* = 'U': Upper trapezoidal
+* = 'L': Lower trapezoidal
+* Note that A is triangular instead of trapezoidal if M = N.
+*
+* DIAG (input) CHARACTER*1
+* Specifies whether or not the matrix A has unit diagonal.
+* = 'N': Non-unit diagonal
+* = 'U': Unit diagonal
+*
+* M (input) INTEGER
+* The number of rows of the matrix A. M >= 0, and if
+* UPLO = 'U', M <= N. When M = 0, DLANTR is set to zero.
+*
+* N (input) INTEGER
+* The number of columns of the matrix A. N >= 0, and if
+* UPLO = 'L', N <= M. When N = 0, DLANTR is set to zero.
+*
+* A (input) DOUBLE PRECISION array, dimension (LDA,N)
+* The trapezoidal matrix A (A is triangular if M = N).
+* If UPLO = 'U', the leading m by n upper trapezoidal part of
+* the array A contains the upper trapezoidal matrix, and the
+* strictly lower triangular part of A is not referenced.
+* If UPLO = 'L', the leading m by n lower trapezoidal part of
+* the array A contains the lower trapezoidal matrix, and the
+* strictly upper triangular part of A is not referenced. Note
+* that when DIAG = 'U', the diagonal elements of A are not
+* referenced and are assumed to be one.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(M,1).
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)),
+* where LWORK >= M when NORM = 'I'; otherwise, WORK is not
+* referenced.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE, ZERO
+ PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL UDIAG
+ INTEGER I, J
+ DOUBLE PRECISION SCALE, SUM, VALUE
+* ..
+* .. External Subroutines ..
+ EXTERNAL DLASSQ
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, MIN, SQRT
+* ..
+* .. Executable Statements ..
+*
+ IF( MIN( M, N ).EQ.0 ) THEN
+ VALUE = ZERO
+ ELSE IF( LSAME( NORM, 'M' ) ) THEN
+*
+* Find max(abs(A(i,j))).
+*
+ IF( LSAME( DIAG, 'U' ) ) THEN
+ VALUE = ONE
+ IF( LSAME( UPLO, 'U' ) ) THEN
+ DO 20 J = 1, N
+ DO 10 I = 1, MIN( M, J-1 )
+ VALUE = MAX( VALUE, ABS( A( I, J ) ) )
+ 10 CONTINUE
+ 20 CONTINUE
+ ELSE
+ DO 40 J = 1, N
+ DO 30 I = J + 1, M
+ VALUE = MAX( VALUE, ABS( A( I, J ) ) )
+ 30 CONTINUE
+ 40 CONTINUE
+ END IF
+ ELSE
+ VALUE = ZERO
+ IF( LSAME( UPLO, 'U' ) ) THEN
+ DO 60 J = 1, N
+ DO 50 I = 1, MIN( M, J )
+ VALUE = MAX( VALUE, ABS( A( I, J ) ) )
+ 50 CONTINUE
+ 60 CONTINUE
+ ELSE
+ DO 80 J = 1, N
+ DO 70 I = J, M
+ VALUE = MAX( VALUE, ABS( A( I, J ) ) )
+ 70 CONTINUE
+ 80 CONTINUE
+ END IF
+ END IF
+ ELSE IF( ( LSAME( NORM, 'O' ) ) .OR. ( NORM.EQ.'1' ) ) THEN
+*
+* Find norm1(A).
+*
+ VALUE = ZERO
+ UDIAG = LSAME( DIAG, 'U' )
+ IF( LSAME( UPLO, 'U' ) ) THEN
+ DO 110 J = 1, N
+ IF( ( UDIAG ) .AND. ( J.LE.M ) ) THEN
+ SUM = ONE
+ DO 90 I = 1, J - 1
+ SUM = SUM + ABS( A( I, J ) )
+ 90 CONTINUE
+ ELSE
+ SUM = ZERO
+ DO 100 I = 1, MIN( M, J )
+ SUM = SUM + ABS( A( I, J ) )
+ 100 CONTINUE
+ END IF
+ VALUE = MAX( VALUE, SUM )
+ 110 CONTINUE
+ ELSE
+ DO 140 J = 1, N
+ IF( UDIAG ) THEN
+ SUM = ONE
+ DO 120 I = J + 1, M
+ SUM = SUM + ABS( A( I, J ) )
+ 120 CONTINUE
+ ELSE
+ SUM = ZERO
+ DO 130 I = J, M
+ SUM = SUM + ABS( A( I, J ) )
+ 130 CONTINUE
+ END IF
+ VALUE = MAX( VALUE, SUM )
+ 140 CONTINUE
+ END IF
+ ELSE IF( LSAME( NORM, 'I' ) ) THEN
+*
+* Find normI(A).
+*
+ IF( LSAME( UPLO, 'U' ) ) THEN
+ IF( LSAME( DIAG, 'U' ) ) THEN
+ DO 150 I = 1, M
+ WORK( I ) = ONE
+ 150 CONTINUE
+ DO 170 J = 1, N
+ DO 160 I = 1, MIN( M, J-1 )
+ WORK( I ) = WORK( I ) + ABS( A( I, J ) )
+ 160 CONTINUE
+ 170 CONTINUE
+ ELSE
+ DO 180 I = 1, M
+ WORK( I ) = ZERO
+ 180 CONTINUE
+ DO 200 J = 1, N
+ DO 190 I = 1, MIN( M, J )
+ WORK( I ) = WORK( I ) + ABS( A( I, J ) )
+ 190 CONTINUE
+ 200 CONTINUE
+ END IF
+ ELSE
+ IF( LSAME( DIAG, 'U' ) ) THEN
+ DO 210 I = 1, N
+ WORK( I ) = ONE
+ 210 CONTINUE
+ DO 220 I = N + 1, M
+ WORK( I ) = ZERO
+ 220 CONTINUE
+ DO 240 J = 1, N
+ DO 230 I = J + 1, M
+ WORK( I ) = WORK( I ) + ABS( A( I, J ) )
+ 230 CONTINUE
+ 240 CONTINUE
+ ELSE
+ DO 250 I = 1, M
+ WORK( I ) = ZERO
+ 250 CONTINUE
+ DO 270 J = 1, N
+ DO 260 I = J, M
+ WORK( I ) = WORK( I ) + ABS( A( I, J ) )
+ 260 CONTINUE
+ 270 CONTINUE
+ END IF
+ END IF
+ VALUE = ZERO
+ DO 280 I = 1, M
+ VALUE = MAX( VALUE, WORK( I ) )
+ 280 CONTINUE
+ ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN
+*
+* Find normF(A).
+*
+ IF( LSAME( UPLO, 'U' ) ) THEN
+ IF( LSAME( DIAG, 'U' ) ) THEN
+ SCALE = ONE
+ SUM = MIN( M, N )
+ DO 290 J = 2, N
+ CALL DLASSQ( MIN( M, J-1 ), A( 1, J ), 1, SCALE, SUM )
+ 290 CONTINUE
+ ELSE
+ SCALE = ZERO
+ SUM = ONE
+ DO 300 J = 1, N
+ CALL DLASSQ( MIN( M, J ), A( 1, J ), 1, SCALE, SUM )
+ 300 CONTINUE
+ END IF
+ ELSE
+ IF( LSAME( DIAG, 'U' ) ) THEN
+ SCALE = ONE
+ SUM = MIN( M, N )
+ DO 310 J = 1, N
+ CALL DLASSQ( M-J, A( MIN( M, J+1 ), J ), 1, SCALE,
+ $ SUM )
+ 310 CONTINUE
+ ELSE
+ SCALE = ZERO
+ SUM = ONE
+ DO 320 J = 1, N
+ CALL DLASSQ( M-J+1, A( J, J ), 1, SCALE, SUM )
+ 320 CONTINUE
+ END IF
+ END IF
+ VALUE = SCALE*SQRT( SUM )
+ END IF
+*
+ DLANTR = VALUE
+ RETURN
+*
+* End of DLANTR
+*
+ END
+ SUBROUTINE DLANV2( A, B, C, D, RT1R, RT1I, RT2R, RT2I, CS, SN )
+*
+* -- LAPACK driver routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ DOUBLE PRECISION A, B, C, CS, D, RT1I, RT1R, RT2I, RT2R, SN
+* ..
+*
+* Purpose
+* =======
+*
+* DLANV2 computes the Schur factorization of a real 2-by-2 nonsymmetric
+* matrix in standard form:
+*
+* [ A B ] = [ CS -SN ] [ AA BB ] [ CS SN ]
+* [ C D ] [ SN CS ] [ CC DD ] [-SN CS ]
+*
+* where either
+* 1) CC = 0 so that AA and DD are real eigenvalues of the matrix, or
+* 2) AA = DD and BB*CC < 0, so that AA + or - sqrt(BB*CC) are complex
+* conjugate eigenvalues.
+*
+* Arguments
+* =========
+*
+* A (input/output) DOUBLE PRECISION
+* B (input/output) DOUBLE PRECISION
+* C (input/output) DOUBLE PRECISION
+* D (input/output) DOUBLE PRECISION
+* On entry, the elements of the input matrix.
+* On exit, they are overwritten by the elements of the
+* standardised Schur form.
+*
+* RT1R (output) DOUBLE PRECISION
+* RT1I (output) DOUBLE PRECISION
+* RT2R (output) DOUBLE PRECISION
+* RT2I (output) DOUBLE PRECISION
+* The real and imaginary parts of the eigenvalues. If the
+* eigenvalues are a complex conjugate pair, RT1I > 0.
+*
+* CS (output) DOUBLE PRECISION
+* SN (output) DOUBLE PRECISION
+* Parameters of the rotation matrix.
+*
+* Further Details
+* ===============
+*
+* Modified by V. Sima, Research Institute for Informatics, Bucharest,
+* Romania, to reduce the risk of cancellation errors,
+* when computing real eigenvalues, and to ensure, if possible, that
+* abs(RT1R) >= abs(RT2R).
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, HALF, ONE
+ PARAMETER ( ZERO = 0.0D+0, HALF = 0.5D+0, ONE = 1.0D+0 )
+ DOUBLE PRECISION MULTPL
+ PARAMETER ( MULTPL = 4.0D+0 )
+* ..
+* .. Local Scalars ..
+ DOUBLE PRECISION AA, BB, BCMAX, BCMIS, CC, CS1, DD, EPS, P, SAB,
+ $ SAC, SCALE, SIGMA, SN1, TAU, TEMP, Z
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DLAMCH, DLAPY2
+ EXTERNAL DLAMCH, DLAPY2
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, MIN, SIGN, SQRT
+* ..
+* .. Executable Statements ..
+*
+ EPS = DLAMCH( 'P' )
+ IF( C.EQ.ZERO ) THEN
+ CS = ONE
+ SN = ZERO
+ GO TO 10
+*
+ ELSE IF( B.EQ.ZERO ) THEN
+*
+* Swap rows and columns
+*
+ CS = ZERO
+ SN = ONE
+ TEMP = D
+ D = A
+ A = TEMP
+ B = -C
+ C = ZERO
+ GO TO 10
+ ELSE IF( ( A-D ).EQ.ZERO .AND. SIGN( ONE, B ).NE.SIGN( ONE, C ) )
+ $ THEN
+ CS = ONE
+ SN = ZERO
+ GO TO 10
+ ELSE
+*
+ TEMP = A - D
+ P = HALF*TEMP
+ BCMAX = MAX( ABS( B ), ABS( C ) )
+ BCMIS = MIN( ABS( B ), ABS( C ) )*SIGN( ONE, B )*SIGN( ONE, C )
+ SCALE = MAX( ABS( P ), BCMAX )
+ Z = ( P / SCALE )*P + ( BCMAX / SCALE )*BCMIS
+*
+* If Z is of the order of the machine accuracy, postpone the
+* decision on the nature of eigenvalues
+*
+ IF( Z.GE.MULTPL*EPS ) THEN
+*
+* Real eigenvalues. Compute A and D.
+*
+ Z = P + SIGN( SQRT( SCALE )*SQRT( Z ), P )
+ A = D + Z
+ D = D - ( BCMAX / Z )*BCMIS
+*
+* Compute B and the rotation matrix
+*
+ TAU = DLAPY2( C, Z )
+ CS = Z / TAU
+ SN = C / TAU
+ B = B - C
+ C = ZERO
+ ELSE
+*
+* Complex eigenvalues, or real (almost) equal eigenvalues.
+* Make diagonal elements equal.
+*
+ SIGMA = B + C
+ TAU = DLAPY2( SIGMA, TEMP )
+ CS = SQRT( HALF*( ONE+ABS( SIGMA ) / TAU ) )
+ SN = -( P / ( TAU*CS ) )*SIGN( ONE, SIGMA )
+*
+* Compute [ AA BB ] = [ A B ] [ CS -SN ]
+* [ CC DD ] [ C D ] [ SN CS ]
+*
+ AA = A*CS + B*SN
+ BB = -A*SN + B*CS
+ CC = C*CS + D*SN
+ DD = -C*SN + D*CS
+*
+* Compute [ A B ] = [ CS SN ] [ AA BB ]
+* [ C D ] [-SN CS ] [ CC DD ]
+*
+ A = AA*CS + CC*SN
+ B = BB*CS + DD*SN
+ C = -AA*SN + CC*CS
+ D = -BB*SN + DD*CS
+*
+ TEMP = HALF*( A+D )
+ A = TEMP
+ D = TEMP
+*
+ IF( C.NE.ZERO ) THEN
+ IF( B.NE.ZERO ) THEN
+ IF( SIGN( ONE, B ).EQ.SIGN( ONE, C ) ) THEN
+*
+* Real eigenvalues: reduce to upper triangular form
+*
+ SAB = SQRT( ABS( B ) )
+ SAC = SQRT( ABS( C ) )
+ P = SIGN( SAB*SAC, C )
+ TAU = ONE / SQRT( ABS( B+C ) )
+ A = TEMP + P
+ D = TEMP - P
+ B = B - C
+ C = ZERO
+ CS1 = SAB*TAU
+ SN1 = SAC*TAU
+ TEMP = CS*CS1 - SN*SN1
+ SN = CS*SN1 + SN*CS1
+ CS = TEMP
+ END IF
+ ELSE
+ B = -C
+ C = ZERO
+ TEMP = CS
+ CS = -SN
+ SN = TEMP
+ END IF
+ END IF
+ END IF
+*
+ END IF
+*
+ 10 CONTINUE
+*
+* Store eigenvalues in (RT1R,RT1I) and (RT2R,RT2I).
+*
+ RT1R = A
+ RT2R = D
+ IF( C.EQ.ZERO ) THEN
+ RT1I = ZERO
+ RT2I = ZERO
+ ELSE
+ RT1I = SQRT( ABS( B ) )*SQRT( ABS( C ) )
+ RT2I = -RT1I
+ END IF
+ RETURN
+*
+* End of DLANV2
+*
+ END
+ SUBROUTINE DLAPLL( N, X, INCX, Y, INCY, SSMIN )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INCX, INCY, N
+ DOUBLE PRECISION SSMIN
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION X( * ), Y( * )
+* ..
+*
+* Purpose
+* =======
+*
+* Given two column vectors X and Y, let
+*
+* A = ( X Y ).
+*
+* The subroutine first computes the QR factorization of A = Q*R,
+* and then computes the SVD of the 2-by-2 upper triangular matrix R.
+* The smaller singular value of R is returned in SSMIN, which is used
+* as the measurement of the linear dependency of the vectors X and Y.
+*
+* Arguments
+* =========
+*
+* N (input) INTEGER
+* The length of the vectors X and Y.
+*
+* X (input/output) DOUBLE PRECISION array,
+* dimension (1+(N-1)*INCX)
+* On entry, X contains the N-vector X.
+* On exit, X is overwritten.
+*
+* INCX (input) INTEGER
+* The increment between successive elements of X. INCX > 0.
+*
+* Y (input/output) DOUBLE PRECISION array,
+* dimension (1+(N-1)*INCY)
+* On entry, Y contains the N-vector Y.
+* On exit, Y is overwritten.
+*
+* INCY (input) INTEGER
+* The increment between successive elements of Y. INCY > 0.
+*
+* SSMIN (output) DOUBLE PRECISION
+* The smallest singular value of the N-by-2 matrix A = ( X Y ).
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+* ..
+* .. Local Scalars ..
+ DOUBLE PRECISION A11, A12, A22, C, SSMAX, TAU
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DDOT
+ EXTERNAL DDOT
+* ..
+* .. External Subroutines ..
+ EXTERNAL DAXPY, DLARFG, DLAS2
+* ..
+* .. Executable Statements ..
+*
+* Quick return if possible
+*
+ IF( N.LE.1 ) THEN
+ SSMIN = ZERO
+ RETURN
+ END IF
+*
+* Compute the QR factorization of the N-by-2 matrix ( X Y )
+*
+ CALL DLARFG( N, X( 1 ), X( 1+INCX ), INCX, TAU )
+ A11 = X( 1 )
+ X( 1 ) = ONE
+*
+ C = -TAU*DDOT( N, X, INCX, Y, INCY )
+ CALL DAXPY( N, C, X, INCX, Y, INCY )
+*
+ CALL DLARFG( N-1, Y( 1+INCY ), Y( 1+2*INCY ), INCY, TAU )
+*
+ A12 = Y( 1 )
+ A22 = Y( 1+INCY )
+*
+* Compute the SVD of 2-by-2 Upper triangular matrix.
+*
+ CALL DLAS2( A11, A12, A22, SSMIN, SSMAX )
+*
+ RETURN
+*
+* End of DLAPLL
+*
+ END
+ SUBROUTINE DLAPMT( FORWRD, M, N, X, LDX, K )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ LOGICAL FORWRD
+ INTEGER LDX, M, N
+* ..
+* .. Array Arguments ..
+ INTEGER K( * )
+ DOUBLE PRECISION X( LDX, * )
+* ..
+*
+* Purpose
+* =======
+*
+* DLAPMT rearranges the columns of the M by N matrix X as specified
+* by the permutation K(1),K(2),...,K(N) of the integers 1,...,N.
+* If FORWRD = .TRUE., forward permutation:
+*
+* X(*,K(J)) is moved X(*,J) for J = 1,2,...,N.
+*
+* If FORWRD = .FALSE., backward permutation:
+*
+* X(*,J) is moved to X(*,K(J)) for J = 1,2,...,N.
+*
+* Arguments
+* =========
+*
+* FORWRD (input) LOGICAL
+* = .TRUE., forward permutation
+* = .FALSE., backward permutation
+*
+* M (input) INTEGER
+* The number of rows of the matrix X. M >= 0.
+*
+* N (input) INTEGER
+* The number of columns of the matrix X. N >= 0.
+*
+* X (input/output) DOUBLE PRECISION array, dimension (LDX,N)
+* On entry, the M by N matrix X.
+* On exit, X contains the permuted matrix X.
+*
+* LDX (input) INTEGER
+* The leading dimension of the array X, LDX >= MAX(1,M).
+*
+* K (input/output) INTEGER array, dimension (N)
+* On entry, K contains the permutation vector. K is used as
+* internal workspace, but reset to its original value on
+* output.
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ INTEGER I, II, IN, J
+ DOUBLE PRECISION TEMP
+* ..
+* .. Executable Statements ..
+*
+ IF( N.LE.1 )
+ $ RETURN
+*
+ DO 10 I = 1, N
+ K( I ) = -K( I )
+ 10 CONTINUE
+*
+ IF( FORWRD ) THEN
+*
+* Forward permutation
+*
+ DO 50 I = 1, N
+*
+ IF( K( I ).GT.0 )
+ $ GO TO 40
+*
+ J = I
+ K( J ) = -K( J )
+ IN = K( J )
+*
+ 20 CONTINUE
+ IF( K( IN ).GT.0 )
+ $ GO TO 40
+*
+ DO 30 II = 1, M
+ TEMP = X( II, J )
+ X( II, J ) = X( II, IN )
+ X( II, IN ) = TEMP
+ 30 CONTINUE
+*
+ K( IN ) = -K( IN )
+ J = IN
+ IN = K( IN )
+ GO TO 20
+*
+ 40 CONTINUE
+*
+ 50 CONTINUE
+*
+ ELSE
+*
+* Backward permutation
+*
+ DO 90 I = 1, N
+*
+ IF( K( I ).GT.0 )
+ $ GO TO 80
+*
+ K( I ) = -K( I )
+ J = K( I )
+ 60 CONTINUE
+ IF( J.EQ.I )
+ $ GO TO 80
+*
+ DO 70 II = 1, M
+ TEMP = X( II, I )
+ X( II, I ) = X( II, J )
+ X( II, J ) = TEMP
+ 70 CONTINUE
+*
+ K( J ) = -K( J )
+ J = K( J )
+ GO TO 60
+*
+ 80 CONTINUE
+*
+ 90 CONTINUE
+*
+ END IF
+*
+ RETURN
+*
+* End of DLAPMT
+*
+ END
+ DOUBLE PRECISION FUNCTION DLAPY2( X, Y )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ DOUBLE PRECISION X, Y
+* ..
+*
+* Purpose
+* =======
+*
+* DLAPY2 returns sqrt(x**2+y**2), taking care not to cause unnecessary
+* overflow.
+*
+* Arguments
+* =========
+*
+* X (input) DOUBLE PRECISION
+* Y (input) DOUBLE PRECISION
+* X and Y specify the values x and y.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO
+ PARAMETER ( ZERO = 0.0D0 )
+ DOUBLE PRECISION ONE
+ PARAMETER ( ONE = 1.0D0 )
+* ..
+* .. Local Scalars ..
+ DOUBLE PRECISION W, XABS, YABS, Z
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, MIN, SQRT
+* ..
+* .. Executable Statements ..
+*
+ XABS = ABS( X )
+ YABS = ABS( Y )
+ W = MAX( XABS, YABS )
+ Z = MIN( XABS, YABS )
+ IF( Z.EQ.ZERO ) THEN
+ DLAPY2 = W
+ ELSE
+ DLAPY2 = W*SQRT( ONE+( Z / W )**2 )
+ END IF
+ RETURN
+*
+* End of DLAPY2
+*
+ END
+ DOUBLE PRECISION FUNCTION DLAPY3( X, Y, Z )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ DOUBLE PRECISION X, Y, Z
+* ..
+*
+* Purpose
+* =======
+*
+* DLAPY3 returns sqrt(x**2+y**2+z**2), taking care not to cause
+* unnecessary overflow.
+*
+* Arguments
+* =========
+*
+* X (input) DOUBLE PRECISION
+* Y (input) DOUBLE PRECISION
+* Z (input) DOUBLE PRECISION
+* X, Y and Z specify the values x, y and z.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO
+ PARAMETER ( ZERO = 0.0D0 )
+* ..
+* .. Local Scalars ..
+ DOUBLE PRECISION W, XABS, YABS, ZABS
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, SQRT
+* ..
+* .. Executable Statements ..
+*
+ XABS = ABS( X )
+ YABS = ABS( Y )
+ ZABS = ABS( Z )
+ W = MAX( XABS, YABS, ZABS )
+ IF( W.EQ.ZERO ) THEN
+* W can be zero for max(0,nan,0)
+* adding all three entries together will make sure
+* NaN will not disappear.
+ DLAPY3 = XABS + YABS + ZABS
+ ELSE
+ DLAPY3 = W*SQRT( ( XABS / W )**2+( YABS / W )**2+
+ $ ( ZABS / W )**2 )
+ END IF
+ RETURN
+*
+* End of DLAPY3
+*
+ END
+ SUBROUTINE DLAQGB( M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND,
+ $ AMAX, EQUED )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER EQUED
+ INTEGER KL, KU, LDAB, M, N
+ DOUBLE PRECISION AMAX, COLCND, ROWCND
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION AB( LDAB, * ), C( * ), R( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DLAQGB equilibrates a general M by N band matrix A with KL
+* subdiagonals and KU superdiagonals using the row and scaling factors
+* in the vectors R and C.
+*
+* Arguments
+* =========
+*
+* M (input) INTEGER
+* The number of rows of the matrix A. M >= 0.
+*
+* N (input) INTEGER
+* The number of columns of the matrix A. N >= 0.
+*
+* KL (input) INTEGER
+* The number of subdiagonals within the band of A. KL >= 0.
+*
+* KU (input) INTEGER
+* The number of superdiagonals within the band of A. KU >= 0.
+*
+* AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N)
+* On entry, the matrix A in band storage, in rows 1 to KL+KU+1.
+* The j-th column of A is stored in the j-th column of the
+* array AB as follows:
+* AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl)
+*
+* On exit, the equilibrated matrix, in the same storage format
+* as A. See EQUED for the form of the equilibrated matrix.
+*
+* LDAB (input) INTEGER
+* The leading dimension of the array AB. LDA >= KL+KU+1.
+*
+* R (input) DOUBLE PRECISION array, dimension (M)
+* The row scale factors for A.
+*
+* C (input) DOUBLE PRECISION array, dimension (N)
+* The column scale factors for A.
+*
+* ROWCND (input) DOUBLE PRECISION
+* Ratio of the smallest R(i) to the largest R(i).
+*
+* COLCND (input) DOUBLE PRECISION
+* Ratio of the smallest C(i) to the largest C(i).
+*
+* AMAX (input) DOUBLE PRECISION
+* Absolute value of largest matrix entry.
+*
+* EQUED (output) CHARACTER*1
+* Specifies the form of equilibration that was done.
+* = 'N': No equilibration
+* = 'R': Row equilibration, i.e., A has been premultiplied by
+* diag(R).
+* = 'C': Column equilibration, i.e., A has been postmultiplied
+* by diag(C).
+* = 'B': Both row and column equilibration, i.e., A has been
+* replaced by diag(R) * A * diag(C).
+*
+* Internal Parameters
+* ===================
+*
+* THRESH is a threshold value used to decide if row or column scaling
+* should be done based on the ratio of the row or column scaling
+* factors. If ROWCND < THRESH, row scaling is done, and if
+* COLCND < THRESH, column scaling is done.
+*
+* LARGE and SMALL are threshold values used to decide if row scaling
+* should be done based on the absolute size of the largest matrix
+* element. If AMAX > LARGE or AMAX < SMALL, row scaling is done.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE, THRESH
+ PARAMETER ( ONE = 1.0D+0, THRESH = 0.1D+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, J
+ DOUBLE PRECISION CJ, LARGE, SMALL
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DLAMCH
+ EXTERNAL DLAMCH
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+* Quick return if possible
+*
+ IF( M.LE.0 .OR. N.LE.0 ) THEN
+ EQUED = 'N'
+ RETURN
+ END IF
+*
+* Initialize LARGE and SMALL.
+*
+ SMALL = DLAMCH( 'Safe minimum' ) / DLAMCH( 'Precision' )
+ LARGE = ONE / SMALL
+*
+ IF( ROWCND.GE.THRESH .AND. AMAX.GE.SMALL .AND. AMAX.LE.LARGE )
+ $ THEN
+*
+* No row scaling
+*
+ IF( COLCND.GE.THRESH ) THEN
+*
+* No column scaling
+*
+ EQUED = 'N'
+ ELSE
+*
+* Column scaling
+*
+ DO 20 J = 1, N
+ CJ = C( J )
+ DO 10 I = MAX( 1, J-KU ), MIN( M, J+KL )
+ AB( KU+1+I-J, J ) = CJ*AB( KU+1+I-J, J )
+ 10 CONTINUE
+ 20 CONTINUE
+ EQUED = 'C'
+ END IF
+ ELSE IF( COLCND.GE.THRESH ) THEN
+*
+* Row scaling, no column scaling
+*
+ DO 40 J = 1, N
+ DO 30 I = MAX( 1, J-KU ), MIN( M, J+KL )
+ AB( KU+1+I-J, J ) = R( I )*AB( KU+1+I-J, J )
+ 30 CONTINUE
+ 40 CONTINUE
+ EQUED = 'R'
+ ELSE
+*
+* Row and column scaling
+*
+ DO 60 J = 1, N
+ CJ = C( J )
+ DO 50 I = MAX( 1, J-KU ), MIN( M, J+KL )
+ AB( KU+1+I-J, J ) = CJ*R( I )*AB( KU+1+I-J, J )
+ 50 CONTINUE
+ 60 CONTINUE
+ EQUED = 'B'
+ END IF
+*
+ RETURN
+*
+* End of DLAQGB
+*
+ END
+ SUBROUTINE DLAQGE( M, N, A, LDA, R, C, ROWCND, COLCND, AMAX,
+ $ EQUED )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER EQUED
+ INTEGER LDA, M, N
+ DOUBLE PRECISION AMAX, COLCND, ROWCND
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION A( LDA, * ), C( * ), R( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DLAQGE equilibrates a general M by N matrix A using the row and
+* column scaling factors in the vectors R and C.
+*
+* Arguments
+* =========
+*
+* M (input) INTEGER
+* The number of rows of the matrix A. M >= 0.
+*
+* N (input) INTEGER
+* The number of columns of the matrix A. N >= 0.
+*
+* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+* On entry, the M by N matrix A.
+* On exit, the equilibrated matrix. See EQUED for the form of
+* the equilibrated matrix.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(M,1).
+*
+* R (input) DOUBLE PRECISION array, dimension (M)
+* The row scale factors for A.
+*
+* C (input) DOUBLE PRECISION array, dimension (N)
+* The column scale factors for A.
+*
+* ROWCND (input) DOUBLE PRECISION
+* Ratio of the smallest R(i) to the largest R(i).
+*
+* COLCND (input) DOUBLE PRECISION
+* Ratio of the smallest C(i) to the largest C(i).
+*
+* AMAX (input) DOUBLE PRECISION
+* Absolute value of largest matrix entry.
+*
+* EQUED (output) CHARACTER*1
+* Specifies the form of equilibration that was done.
+* = 'N': No equilibration
+* = 'R': Row equilibration, i.e., A has been premultiplied by
+* diag(R).
+* = 'C': Column equilibration, i.e., A has been postmultiplied
+* by diag(C).
+* = 'B': Both row and column equilibration, i.e., A has been
+* replaced by diag(R) * A * diag(C).
+*
+* Internal Parameters
+* ===================
+*
+* THRESH is a threshold value used to decide if row or column scaling
+* should be done based on the ratio of the row or column scaling
+* factors. If ROWCND < THRESH, row scaling is done, and if
+* COLCND < THRESH, column scaling is done.
+*
+* LARGE and SMALL are threshold values used to decide if row scaling
+* should be done based on the absolute size of the largest matrix
+* element. If AMAX > LARGE or AMAX < SMALL, row scaling is done.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE, THRESH
+ PARAMETER ( ONE = 1.0D+0, THRESH = 0.1D+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, J
+ DOUBLE PRECISION CJ, LARGE, SMALL
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DLAMCH
+ EXTERNAL DLAMCH
+* ..
+* .. Executable Statements ..
+*
+* Quick return if possible
+*
+ IF( M.LE.0 .OR. N.LE.0 ) THEN
+ EQUED = 'N'
+ RETURN
+ END IF
+*
+* Initialize LARGE and SMALL.
+*
+ SMALL = DLAMCH( 'Safe minimum' ) / DLAMCH( 'Precision' )
+ LARGE = ONE / SMALL
+*
+ IF( ROWCND.GE.THRESH .AND. AMAX.GE.SMALL .AND. AMAX.LE.LARGE )
+ $ THEN
+*
+* No row scaling
+*
+ IF( COLCND.GE.THRESH ) THEN
+*
+* No column scaling
+*
+ EQUED = 'N'
+ ELSE
+*
+* Column scaling
+*
+ DO 20 J = 1, N
+ CJ = C( J )
+ DO 10 I = 1, M
+ A( I, J ) = CJ*A( I, J )
+ 10 CONTINUE
+ 20 CONTINUE
+ EQUED = 'C'
+ END IF
+ ELSE IF( COLCND.GE.THRESH ) THEN
+*
+* Row scaling, no column scaling
+*
+ DO 40 J = 1, N
+ DO 30 I = 1, M
+ A( I, J ) = R( I )*A( I, J )
+ 30 CONTINUE
+ 40 CONTINUE
+ EQUED = 'R'
+ ELSE
+*
+* Row and column scaling
+*
+ DO 60 J = 1, N
+ CJ = C( J )
+ DO 50 I = 1, M
+ A( I, J ) = CJ*R( I )*A( I, J )
+ 50 CONTINUE
+ 60 CONTINUE
+ EQUED = 'B'
+ END IF
+*
+ RETURN
+*
+* End of DLAQGE
+*
+ END
+ SUBROUTINE DLAQP2( M, N, OFFSET, A, LDA, JPVT, TAU, VN1, VN2,
+ $ WORK )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER LDA, M, N, OFFSET
+* ..
+* .. Array Arguments ..
+ INTEGER JPVT( * )
+ DOUBLE PRECISION A( LDA, * ), TAU( * ), VN1( * ), VN2( * ),
+ $ WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DLAQP2 computes a QR factorization with column pivoting of
+* the block A(OFFSET+1:M,1:N).
+* The block A(1:OFFSET,1:N) is accordingly pivoted, but not factorized.
+*
+* Arguments
+* =========
+*
+* M (input) INTEGER
+* The number of rows of the matrix A. M >= 0.
+*
+* N (input) INTEGER
+* The number of columns of the matrix A. N >= 0.
+*
+* OFFSET (input) INTEGER
+* The number of rows of the matrix A that must be pivoted
+* but no factorized. OFFSET >= 0.
+*
+* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+* On entry, the M-by-N matrix A.
+* On exit, the upper triangle of block A(OFFSET+1:M,1:N) is
+* the triangular factor obtained; the elements in block
+* A(OFFSET+1:M,1:N) below the diagonal, together with the
+* array TAU, represent the orthogonal matrix Q as a product of
+* elementary reflectors. Block A(1:OFFSET,1:N) has been
+* accordingly pivoted, but no factorized.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,M).
+*
+* JPVT (input/output) INTEGER array, dimension (N)
+* On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted
+* to the front of A*P (a leading column); if JPVT(i) = 0,
+* the i-th column of A is a free column.
+* On exit, if JPVT(i) = k, then the i-th column of A*P
+* was the k-th column of A.
+*
+* TAU (output) DOUBLE PRECISION array, dimension (min(M,N))
+* The scalar factors of the elementary reflectors.
+*
+* VN1 (input/output) DOUBLE PRECISION array, dimension (N)
+* The vector with the partial column norms.
+*
+* VN2 (input/output) DOUBLE PRECISION array, dimension (N)
+* The vector with the exact column norms.
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (N)
+*
+* Further Details
+* ===============
+*
+* Based on contributions by
+* G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain
+* X. Sun, Computer Science Dept., Duke University, USA
+*
+* Partial column norm updating strategy modified by
+* Z. Drmac and Z. Bujanovic, Dept. of Mathematics,
+* University of Zagreb, Croatia.
+* June 2006.
+* For more details see LAPACK Working Note 176.
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, ITEMP, J, MN, OFFPI, PVT
+ DOUBLE PRECISION AII, TEMP, TEMP2, TOL3Z
+* ..
+* .. External Subroutines ..
+ EXTERNAL DLARF, DLARFG, DSWAP
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, MIN, SQRT
+* ..
+* .. External Functions ..
+ INTEGER IDAMAX
+ DOUBLE PRECISION DLAMCH, DNRM2
+ EXTERNAL IDAMAX, DLAMCH, DNRM2
+* ..
+* .. Executable Statements ..
+*
+ MN = MIN( M-OFFSET, N )
+ TOL3Z = SQRT(DLAMCH('Epsilon'))
+*
+* Compute factorization.
+*
+ DO 20 I = 1, MN
+*
+ OFFPI = OFFSET + I
+*
+* Determine ith pivot column and swap if necessary.
+*
+ PVT = ( I-1 ) + IDAMAX( N-I+1, VN1( I ), 1 )
+*
+ IF( PVT.NE.I ) THEN
+ CALL DSWAP( M, A( 1, PVT ), 1, A( 1, I ), 1 )
+ ITEMP = JPVT( PVT )
+ JPVT( PVT ) = JPVT( I )
+ JPVT( I ) = ITEMP
+ VN1( PVT ) = VN1( I )
+ VN2( PVT ) = VN2( I )
+ END IF
+*
+* Generate elementary reflector H(i).
+*
+ IF( OFFPI.LT.M ) THEN
+ CALL DLARFG( M-OFFPI+1, A( OFFPI, I ), A( OFFPI+1, I ), 1,
+ $ TAU( I ) )
+ ELSE
+ CALL DLARFG( 1, A( M, I ), A( M, I ), 1, TAU( I ) )
+ END IF
+*
+ IF( I.LT.N ) THEN
+*
+* Apply H(i)' to A(offset+i:m,i+1:n) from the left.
+*
+ AII = A( OFFPI, I )
+ A( OFFPI, I ) = ONE
+ CALL DLARF( 'Left', M-OFFPI+1, N-I, A( OFFPI, I ), 1,
+ $ TAU( I ), A( OFFPI, I+1 ), LDA, WORK( 1 ) )
+ A( OFFPI, I ) = AII
+ END IF
+*
+* Update partial column norms.
+*
+ DO 10 J = I + 1, N
+ IF( VN1( J ).NE.ZERO ) THEN
+*
+* NOTE: The following 4 lines follow from the analysis in
+* Lapack Working Note 176.
+*
+ TEMP = ONE - ( ABS( A( OFFPI, J ) ) / VN1( J ) )**2
+ TEMP = MAX( TEMP, ZERO )
+ TEMP2 = TEMP*( VN1( J ) / VN2( J ) )**2
+ IF( TEMP2 .LE. TOL3Z ) THEN
+ IF( OFFPI.LT.M ) THEN
+ VN1( J ) = DNRM2( M-OFFPI, A( OFFPI+1, J ), 1 )
+ VN2( J ) = VN1( J )
+ ELSE
+ VN1( J ) = ZERO
+ VN2( J ) = ZERO
+ END IF
+ ELSE
+ VN1( J ) = VN1( J )*SQRT( TEMP )
+ END IF
+ END IF
+ 10 CONTINUE
+*
+ 20 CONTINUE
+*
+ RETURN
+*
+* End of DLAQP2
+*
+ END
+ SUBROUTINE DLAQPS( M, N, OFFSET, NB, KB, A, LDA, JPVT, TAU, VN1,
+ $ VN2, AUXV, F, LDF )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER KB, LDA, LDF, M, N, NB, OFFSET
+* ..
+* .. Array Arguments ..
+ INTEGER JPVT( * )
+ DOUBLE PRECISION A( LDA, * ), AUXV( * ), F( LDF, * ), TAU( * ),
+ $ VN1( * ), VN2( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DLAQPS computes a step of QR factorization with column pivoting
+* of a real M-by-N matrix A by using Blas-3. It tries to factorize
+* NB columns from A starting from the row OFFSET+1, and updates all
+* of the matrix with Blas-3 xGEMM.
+*
+* In some cases, due to catastrophic cancellations, it cannot
+* factorize NB columns. Hence, the actual number of factorized
+* columns is returned in KB.
+*
+* Block A(1:OFFSET,1:N) is accordingly pivoted, but not factorized.
+*
+* Arguments
+* =========
+*
+* M (input) INTEGER
+* The number of rows of the matrix A. M >= 0.
+*
+* N (input) INTEGER
+* The number of columns of the matrix A. N >= 0
+*
+* OFFSET (input) INTEGER
+* The number of rows of A that have been factorized in
+* previous steps.
+*
+* NB (input) INTEGER
+* The number of columns to factorize.
+*
+* KB (output) INTEGER
+* The number of columns actually factorized.
+*
+* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+* On entry, the M-by-N matrix A.
+* On exit, block A(OFFSET+1:M,1:KB) is the triangular
+* factor obtained and block A(1:OFFSET,1:N) has been
+* accordingly pivoted, but no factorized.
+* The rest of the matrix, block A(OFFSET+1:M,KB+1:N) has
+* been updated.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,M).
+*
+* JPVT (input/output) INTEGER array, dimension (N)
+* JPVT(I) = K <==> Column K of the full matrix A has been
+* permuted into position I in AP.
+*
+* TAU (output) DOUBLE PRECISION array, dimension (KB)
+* The scalar factors of the elementary reflectors.
+*
+* VN1 (input/output) DOUBLE PRECISION array, dimension (N)
+* The vector with the partial column norms.
+*
+* VN2 (input/output) DOUBLE PRECISION array, dimension (N)
+* The vector with the exact column norms.
+*
+* AUXV (input/output) DOUBLE PRECISION array, dimension (NB)
+* Auxiliar vector.
+*
+* F (input/output) DOUBLE PRECISION array, dimension (LDF,NB)
+* Matrix F' = L*Y'*A.
+*
+* LDF (input) INTEGER
+* The leading dimension of the array F. LDF >= max(1,N).
+*
+* Further Details
+* ===============
+*
+* Based on contributions by
+* G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain
+* X. Sun, Computer Science Dept., Duke University, USA
+*
+* Partial column norm updating strategy modified by
+* Z. Drmac and Z. Bujanovic, Dept. of Mathematics,
+* University of Zagreb, Croatia.
+* June 2006.
+* For more details see LAPACK Working Note 176.
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER ITEMP, J, K, LASTRK, LSTICC, PVT, RK
+ DOUBLE PRECISION AKK, TEMP, TEMP2, TOL3Z
+* ..
+* .. External Subroutines ..
+ EXTERNAL DGEMM, DGEMV, DLARFG, DSWAP
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, DBLE, MAX, MIN, NINT, SQRT
+* ..
+* .. External Functions ..
+ INTEGER IDAMAX
+ DOUBLE PRECISION DLAMCH, DNRM2
+ EXTERNAL IDAMAX, DLAMCH, DNRM2
+* ..
+* .. Executable Statements ..
+*
+ LASTRK = MIN( M, N+OFFSET )
+ LSTICC = 0
+ K = 0
+ TOL3Z = SQRT(DLAMCH('Epsilon'))
+*
+* Beginning of while loop.
+*
+ 10 CONTINUE
+ IF( ( K.LT.NB ) .AND. ( LSTICC.EQ.0 ) ) THEN
+ K = K + 1
+ RK = OFFSET + K
+*
+* Determine ith pivot column and swap if necessary
+*
+ PVT = ( K-1 ) + IDAMAX( N-K+1, VN1( K ), 1 )
+ IF( PVT.NE.K ) THEN
+ CALL DSWAP( M, A( 1, PVT ), 1, A( 1, K ), 1 )
+ CALL DSWAP( K-1, F( PVT, 1 ), LDF, F( K, 1 ), LDF )
+ ITEMP = JPVT( PVT )
+ JPVT( PVT ) = JPVT( K )
+ JPVT( K ) = ITEMP
+ VN1( PVT ) = VN1( K )
+ VN2( PVT ) = VN2( K )
+ END IF
+*
+* Apply previous Householder reflectors to column K:
+* A(RK:M,K) := A(RK:M,K) - A(RK:M,1:K-1)*F(K,1:K-1)'.
+*
+ IF( K.GT.1 ) THEN
+ CALL DGEMV( 'No transpose', M-RK+1, K-1, -ONE, A( RK, 1 ),
+ $ LDA, F( K, 1 ), LDF, ONE, A( RK, K ), 1 )
+ END IF
+*
+* Generate elementary reflector H(k).
+*
+ IF( RK.LT.M ) THEN
+ CALL DLARFG( M-RK+1, A( RK, K ), A( RK+1, K ), 1, TAU( K ) )
+ ELSE
+ CALL DLARFG( 1, A( RK, K ), A( RK, K ), 1, TAU( K ) )
+ END IF
+*
+ AKK = A( RK, K )
+ A( RK, K ) = ONE
+*
+* Compute Kth column of F:
+*
+* Compute F(K+1:N,K) := tau(K)*A(RK:M,K+1:N)'*A(RK:M,K).
+*
+ IF( K.LT.N ) THEN
+ CALL DGEMV( 'Transpose', M-RK+1, N-K, TAU( K ),
+ $ A( RK, K+1 ), LDA, A( RK, K ), 1, ZERO,
+ $ F( K+1, K ), 1 )
+ END IF
+*
+* Padding F(1:K,K) with zeros.
+*
+ DO 20 J = 1, K
+ F( J, K ) = ZERO
+ 20 CONTINUE
+*
+* Incremental updating of F:
+* F(1:N,K) := F(1:N,K) - tau(K)*F(1:N,1:K-1)*A(RK:M,1:K-1)'
+* *A(RK:M,K).
+*
+ IF( K.GT.1 ) THEN
+ CALL DGEMV( 'Transpose', M-RK+1, K-1, -TAU( K ), A( RK, 1 ),
+ $ LDA, A( RK, K ), 1, ZERO, AUXV( 1 ), 1 )
+*
+ CALL DGEMV( 'No transpose', N, K-1, ONE, F( 1, 1 ), LDF,
+ $ AUXV( 1 ), 1, ONE, F( 1, K ), 1 )
+ END IF
+*
+* Update the current row of A:
+* A(RK,K+1:N) := A(RK,K+1:N) - A(RK,1:K)*F(K+1:N,1:K)'.
+*
+ IF( K.LT.N ) THEN
+ CALL DGEMV( 'No transpose', N-K, K, -ONE, F( K+1, 1 ), LDF,
+ $ A( RK, 1 ), LDA, ONE, A( RK, K+1 ), LDA )
+ END IF
+*
+* Update partial column norms.
+*
+ IF( RK.LT.LASTRK ) THEN
+ DO 30 J = K + 1, N
+ IF( VN1( J ).NE.ZERO ) THEN
+*
+* NOTE: The following 4 lines follow from the analysis in
+* Lapack Working Note 176.
+*
+ TEMP = ABS( A( RK, J ) ) / VN1( J )
+ TEMP = MAX( ZERO, ( ONE+TEMP )*( ONE-TEMP ) )
+ TEMP2 = TEMP*( VN1( J ) / VN2( J ) )**2
+ IF( TEMP2 .LE. TOL3Z ) THEN
+ VN2( J ) = DBLE( LSTICC )
+ LSTICC = J
+ ELSE
+ VN1( J ) = VN1( J )*SQRT( TEMP )
+ END IF
+ END IF
+ 30 CONTINUE
+ END IF
+*
+ A( RK, K ) = AKK
+*
+* End of while loop.
+*
+ GO TO 10
+ END IF
+ KB = K
+ RK = OFFSET + KB
+*
+* Apply the block reflector to the rest of the matrix:
+* A(OFFSET+KB+1:M,KB+1:N) := A(OFFSET+KB+1:M,KB+1:N) -
+* A(OFFSET+KB+1:M,1:KB)*F(KB+1:N,1:KB)'.
+*
+ IF( KB.LT.MIN( N, M-OFFSET ) ) THEN
+ CALL DGEMM( 'No transpose', 'Transpose', M-RK, N-KB, KB, -ONE,
+ $ A( RK+1, 1 ), LDA, F( KB+1, 1 ), LDF, ONE,
+ $ A( RK+1, KB+1 ), LDA )
+ END IF
+*
+* Recomputation of difficult columns.
+*
+ 40 CONTINUE
+ IF( LSTICC.GT.0 ) THEN
+ ITEMP = NINT( VN2( LSTICC ) )
+ VN1( LSTICC ) = DNRM2( M-RK, A( RK+1, LSTICC ), 1 )
+*
+* NOTE: The computation of VN1( LSTICC ) relies on the fact that
+* SNRM2 does not fail on vectors with norm below the value of
+* SQRT(DLAMCH('S'))
+*
+ VN2( LSTICC ) = VN1( LSTICC )
+ LSTICC = ITEMP
+ GO TO 40
+ END IF
+*
+ RETURN
+*
+* End of DLAQPS
+*
+ END
+ SUBROUTINE DLAQR0( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI,
+ $ ILOZ, IHIZ, Z, LDZ, WORK, LWORK, INFO )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, LWORK, N
+ LOGICAL WANTT, WANTZ
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION H( LDH, * ), WI( * ), WORK( * ), WR( * ),
+ $ Z( LDZ, * )
+* ..
+*
+* Purpose
+* =======
+*
+* DLAQR0 computes the eigenvalues of a Hessenberg matrix H
+* and, optionally, the matrices T and Z from the Schur decomposition
+* H = Z T Z**T, where T is an upper quasi-triangular matrix (the
+* Schur form), and Z is the orthogonal matrix of Schur vectors.
+*
+* Optionally Z may be postmultiplied into an input orthogonal
+* matrix Q so that this routine can give the Schur factorization
+* of a matrix A which has been reduced to the Hessenberg form H
+* by the orthogonal matrix Q: A = Q*H*Q**T = (QZ)*T*(QZ)**T.
+*
+* Arguments
+* =========
+*
+* WANTT (input) LOGICAL
+* = .TRUE. : the full Schur form T is required;
+* = .FALSE.: only eigenvalues are required.
+*
+* WANTZ (input) LOGICAL
+* = .TRUE. : the matrix of Schur vectors Z is required;
+* = .FALSE.: Schur vectors are not required.
+*
+* N (input) INTEGER
+* The order of the matrix H. N .GE. 0.
+*
+* ILO (input) INTEGER
+* IHI (input) INTEGER
+* It is assumed that H is already upper triangular in rows
+* and columns 1:ILO-1 and IHI+1:N and, if ILO.GT.1,
+* H(ILO,ILO-1) is zero. ILO and IHI are normally set by a
+* previous call to DGEBAL, and then passed to DGEHRD when the
+* matrix output by DGEBAL is reduced to Hessenberg form.
+* Otherwise, ILO and IHI should be set to 1 and N,
+* respectively. If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N.
+* If N = 0, then ILO = 1 and IHI = 0.
+*
+* H (input/output) DOUBLE PRECISION array, dimension (LDH,N)
+* On entry, the upper Hessenberg matrix H.
+* On exit, if INFO = 0 and WANTT is .TRUE., then H contains
+* the upper quasi-triangular matrix T from the Schur
+* decomposition (the Schur form); 2-by-2 diagonal blocks
+* (corresponding to complex conjugate pairs of eigenvalues)
+* are returned in standard form, with H(i,i) = H(i+1,i+1)
+* and H(i+1,i)*H(i,i+1).LT.0. If INFO = 0 and WANTT is
+* .FALSE., then the contents of H are unspecified on exit.
+* (The output value of H when INFO.GT.0 is given under the
+* description of INFO below.)
+*
+* This subroutine may explicitly set H(i,j) = 0 for i.GT.j and
+* j = 1, 2, ... ILO-1 or j = IHI+1, IHI+2, ... N.
+*
+* LDH (input) INTEGER
+* The leading dimension of the array H. LDH .GE. max(1,N).
+*
+* WR (output) DOUBLE PRECISION array, dimension (IHI)
+* WI (output) DOUBLE PRECISION array, dimension (IHI)
+* The real and imaginary parts, respectively, of the computed
+* eigenvalues of H(ILO:IHI,ILO:IHI) are stored WR(ILO:IHI)
+* and WI(ILO:IHI). If two eigenvalues are computed as a
+* complex conjugate pair, they are stored in consecutive
+* elements of WR and WI, say the i-th and (i+1)th, with
+* WI(i) .GT. 0 and WI(i+1) .LT. 0. If WANTT is .TRUE., then
+* the eigenvalues are stored in the same order as on the
+* diagonal of the Schur form returned in H, with
+* WR(i) = H(i,i) and, if H(i:i+1,i:i+1) is a 2-by-2 diagonal
+* block, WI(i) = sqrt(-H(i+1,i)*H(i,i+1)) and
+* WI(i+1) = -WI(i).
+*
+* ILOZ (input) INTEGER
+* IHIZ (input) INTEGER
+* Specify the rows of Z to which transformations must be
+* applied if WANTZ is .TRUE..
+* 1 .LE. ILOZ .LE. ILO; IHI .LE. IHIZ .LE. N.
+*
+* Z (input/output) DOUBLE PRECISION array, dimension (LDZ,IHI)
+* If WANTZ is .FALSE., then Z is not referenced.
+* If WANTZ is .TRUE., then Z(ILO:IHI,ILOZ:IHIZ) is
+* replaced by Z(ILO:IHI,ILOZ:IHIZ)*U where U is the
+* orthogonal Schur factor of H(ILO:IHI,ILO:IHI).
+* (The output value of Z when INFO.GT.0 is given under
+* the description of INFO below.)
+*
+* LDZ (input) INTEGER
+* The leading dimension of the array Z. if WANTZ is .TRUE.
+* then LDZ.GE.MAX(1,IHIZ). Otherwize, LDZ.GE.1.
+*
+* WORK (workspace/output) DOUBLE PRECISION array, dimension LWORK
+* On exit, if LWORK = -1, WORK(1) returns an estimate of
+* the optimal value for LWORK.
+*
+* LWORK (input) INTEGER
+* The dimension of the array WORK. LWORK .GE. max(1,N)
+* is sufficient, but LWORK typically as large as 6*N may
+* be required for optimal performance. A workspace query
+* to determine the optimal workspace size is recommended.
+*
+* If LWORK = -1, then DLAQR0 does a workspace query.
+* In this case, DLAQR0 checks the input parameters and
+* estimates the optimal workspace size for the given
+* values of N, ILO and IHI. The estimate is returned
+* in WORK(1). No error message related to LWORK is
+* issued by XERBLA. Neither H nor Z are accessed.
+*
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* .GT. 0: if INFO = i, DLAQR0 failed to compute all of
+* the eigenvalues. Elements 1:ilo-1 and i+1:n of WR
+* and WI contain those eigenvalues which have been
+* successfully computed. (Failures are rare.)
+*
+* If INFO .GT. 0 and WANT is .FALSE., then on exit,
+* the remaining unconverged eigenvalues are the eigen-
+* values of the upper Hessenberg matrix rows and
+* columns ILO through INFO of the final, output
+* value of H.
+*
+* If INFO .GT. 0 and WANTT is .TRUE., then on exit
+*
+* (*) (initial value of H)*U = U*(final value of H)
+*
+* where U is an orthogonal matrix. The final
+* value of H is upper Hessenberg and quasi-triangular
+* in rows and columns INFO+1 through IHI.
+*
+* If INFO .GT. 0 and WANTZ is .TRUE., then on exit
+*
+* (final value of Z(ILO:IHI,ILOZ:IHIZ)
+* = (initial value of Z(ILO:IHI,ILOZ:IHIZ)*U
+*
+* where U is the orthogonal matrix in (*) (regard-
+* less of the value of WANTT.)
+*
+* If INFO .GT. 0 and WANTZ is .FALSE., then Z is not
+* accessed.
+*
+*
+* ================================================================
+* Based on contributions by
+* Karen Braman and Ralph Byers, Department of Mathematics,
+* University of Kansas, USA
+*
+* ================================================================
+*
+* References:
+* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR
+* Algorithm Part I: Maintaining Well Focused Shifts, and Level 3
+* Performance, SIAM Journal of Matrix Analysis, volume 23, pages
+* 929--947, 2002.
+*
+* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR
+* Algorithm Part II: Aggressive Early Deflation, SIAM Journal
+* of Matrix Analysis, volume 23, pages 948--973, 2002.
+*
+* ================================================================
+* .. Parameters ..
+*
+* ==== Matrices of order NTINY or smaller must be processed by
+* . DLAHQR because of insufficient subdiagonal scratch space.
+* . (This is a hard limit.) ====
+*
+* ==== Exceptional deflation windows: try to cure rare
+* . slow convergence by increasing the size of the
+* . deflation window after KEXNW iterations. =====
+*
+* ==== Exceptional shifts: try to cure rare slow convergence
+* . with ad-hoc exceptional shifts every KEXSH iterations.
+* . The constants WILK1 and WILK2 are used to form the
+* . exceptional shifts. ====
+*
+ INTEGER NTINY
+ PARAMETER ( NTINY = 11 )
+ INTEGER KEXNW, KEXSH
+ PARAMETER ( KEXNW = 5, KEXSH = 6 )
+ DOUBLE PRECISION WILK1, WILK2
+ PARAMETER ( WILK1 = 0.75d0, WILK2 = -0.4375d0 )
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0d0, ONE = 1.0d0 )
+* ..
+* .. Local Scalars ..
+ DOUBLE PRECISION AA, BB, CC, CS, DD, SN, SS, SWAP
+ INTEGER I, INF, IT, ITMAX, K, KACC22, KBOT, KDU, KS,
+ $ KT, KTOP, KU, KV, KWH, KWTOP, KWV, LD, LS,
+ $ LWKOPT, NDFL, NH, NHO, NIBBLE, NMIN, NS, NSMAX,
+ $ NSR, NVE, NW, NWMAX, NWR
+ LOGICAL NWINC, SORTED
+ CHARACTER JBCMPZ*2
+* ..
+* .. External Functions ..
+ INTEGER ILAENV
+ EXTERNAL ILAENV
+* ..
+* .. Local Arrays ..
+ DOUBLE PRECISION ZDUM( 1, 1 )
+* ..
+* .. External Subroutines ..
+ EXTERNAL DLACPY, DLAHQR, DLANV2, DLAQR3, DLAQR4, DLAQR5
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, DBLE, INT, MAX, MIN, MOD
+* ..
+* .. Executable Statements ..
+ INFO = 0
+*
+* ==== Quick return for N = 0: nothing to do. ====
+*
+ IF( N.EQ.0 ) THEN
+ WORK( 1 ) = ONE
+ RETURN
+ END IF
+*
+* ==== Set up job flags for ILAENV. ====
+*
+ IF( WANTT ) THEN
+ JBCMPZ( 1: 1 ) = 'S'
+ ELSE
+ JBCMPZ( 1: 1 ) = 'E'
+ END IF
+ IF( WANTZ ) THEN
+ JBCMPZ( 2: 2 ) = 'V'
+ ELSE
+ JBCMPZ( 2: 2 ) = 'N'
+ END IF
+*
+* ==== Tiny matrices must use DLAHQR. ====
+*
+ IF( N.LE.NTINY ) THEN
+*
+* ==== Estimate optimal workspace. ====
+*
+ LWKOPT = 1
+ IF( LWORK.NE.-1 )
+ $ CALL DLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI,
+ $ ILOZ, IHIZ, Z, LDZ, INFO )
+ ELSE
+*
+* ==== Use small bulge multi-shift QR with aggressive early
+* . deflation on larger-than-tiny matrices. ====
+*
+* ==== Hope for the best. ====
+*
+ INFO = 0
+*
+* ==== NWR = recommended deflation window size. At this
+* . point, N .GT. NTINY = 11, so there is enough
+* . subdiagonal workspace for NWR.GE.2 as required.
+* . (In fact, there is enough subdiagonal space for
+* . NWR.GE.3.) ====
+*
+ NWR = ILAENV( 13, 'DLAQR0', JBCMPZ, N, ILO, IHI, LWORK )
+ NWR = MAX( 2, NWR )
+ NWR = MIN( IHI-ILO+1, ( N-1 ) / 3, NWR )
+ NW = NWR
+*
+* ==== NSR = recommended number of simultaneous shifts.
+* . At this point N .GT. NTINY = 11, so there is at
+* . enough subdiagonal workspace for NSR to be even
+* . and greater than or equal to two as required. ====
+*
+ NSR = ILAENV( 15, 'DLAQR0', JBCMPZ, N, ILO, IHI, LWORK )
+ NSR = MIN( NSR, ( N+6 ) / 9, IHI-ILO )
+ NSR = MAX( 2, NSR-MOD( NSR, 2 ) )
+*
+* ==== Estimate optimal workspace ====
+*
+* ==== Workspace query call to DLAQR3 ====
+*
+ CALL DLAQR3( WANTT, WANTZ, N, ILO, IHI, NWR+1, H, LDH, ILOZ,
+ $ IHIZ, Z, LDZ, LS, LD, WR, WI, H, LDH, N, H, LDH,
+ $ N, H, LDH, WORK, -1 )
+*
+* ==== Optimal workspace = MAX(DLAQR5, DLAQR3) ====
+*
+ LWKOPT = MAX( 3*NSR / 2, INT( WORK( 1 ) ) )
+*
+* ==== Quick return in case of workspace query. ====
+*
+ IF( LWORK.EQ.-1 ) THEN
+ WORK( 1 ) = DBLE( LWKOPT )
+ RETURN
+ END IF
+*
+* ==== DLAHQR/DLAQR0 crossover point ====
+*
+ NMIN = ILAENV( 12, 'DLAQR0', JBCMPZ, N, ILO, IHI, LWORK )
+ NMIN = MAX( NTINY, NMIN )
+*
+* ==== Nibble crossover point ====
+*
+ NIBBLE = ILAENV( 14, 'DLAQR0', JBCMPZ, N, ILO, IHI, LWORK )
+ NIBBLE = MAX( 0, NIBBLE )
+*
+* ==== Accumulate reflections during ttswp? Use block
+* . 2-by-2 structure during matrix-matrix multiply? ====
+*
+ KACC22 = ILAENV( 16, 'DLAQR0', JBCMPZ, N, ILO, IHI, LWORK )
+ KACC22 = MAX( 0, KACC22 )
+ KACC22 = MIN( 2, KACC22 )
+*
+* ==== NWMAX = the largest possible deflation window for
+* . which there is sufficient workspace. ====
+*
+ NWMAX = MIN( ( N-1 ) / 3, LWORK / 2 )
+*
+* ==== NSMAX = the Largest number of simultaneous shifts
+* . for which there is sufficient workspace. ====
+*
+ NSMAX = MIN( ( N+6 ) / 9, 2*LWORK / 3 )
+ NSMAX = NSMAX - MOD( NSMAX, 2 )
+*
+* ==== NDFL: an iteration count restarted at deflation. ====
+*
+ NDFL = 1
+*
+* ==== ITMAX = iteration limit ====
+*
+ ITMAX = MAX( 30, 2*KEXSH )*MAX( 10, ( IHI-ILO+1 ) )
+*
+* ==== Last row and column in the active block ====
+*
+ KBOT = IHI
+*
+* ==== Main Loop ====
+*
+ DO 80 IT = 1, ITMAX
+*
+* ==== Done when KBOT falls below ILO ====
+*
+ IF( KBOT.LT.ILO )
+ $ GO TO 90
+*
+* ==== Locate active block ====
+*
+ DO 10 K = KBOT, ILO + 1, -1
+ IF( H( K, K-1 ).EQ.ZERO )
+ $ GO TO 20
+ 10 CONTINUE
+ K = ILO
+ 20 CONTINUE
+ KTOP = K
+*
+* ==== Select deflation window size ====
+*
+ NH = KBOT - KTOP + 1
+ IF( NDFL.LT.KEXNW .OR. NH.LT.NW ) THEN
+*
+* ==== Typical deflation window. If possible and
+* . advisable, nibble the entire active block.
+* . If not, use size NWR or NWR+1 depending upon
+* . which has the smaller corresponding subdiagonal
+* . entry (a heuristic). ====
+*
+ NWINC = .TRUE.
+ IF( NH.LE.MIN( NMIN, NWMAX ) ) THEN
+ NW = NH
+ ELSE
+ NW = MIN( NWR, NH, NWMAX )
+ IF( NW.LT.NWMAX ) THEN
+ IF( NW.GE.NH-1 ) THEN
+ NW = NH
+ ELSE
+ KWTOP = KBOT - NW + 1
+ IF( ABS( H( KWTOP, KWTOP-1 ) ).GT.
+ $ ABS( H( KWTOP-1, KWTOP-2 ) ) )NW = NW + 1
+ END IF
+ END IF
+ END IF
+ ELSE
+*
+* ==== Exceptional deflation window. If there have
+* . been no deflations in KEXNW or more iterations,
+* . then vary the deflation window size. At first,
+* . because, larger windows are, in general, more
+* . powerful than smaller ones, rapidly increase the
+* . window up to the maximum reasonable and possible.
+* . Then maybe try a slightly smaller window. ====
+*
+ IF( NWINC .AND. NW.LT.MIN( NWMAX, NH ) ) THEN
+ NW = MIN( NWMAX, NH, 2*NW )
+ ELSE
+ NWINC = .FALSE.
+ IF( NW.EQ.NH .AND. NH.GT.2 )
+ $ NW = NH - 1
+ END IF
+ END IF
+*
+* ==== Aggressive early deflation:
+* . split workspace under the subdiagonal into
+* . - an nw-by-nw work array V in the lower
+* . left-hand-corner,
+* . - an NW-by-at-least-NW-but-more-is-better
+* . (NW-by-NHO) horizontal work array along
+* . the bottom edge,
+* . - an at-least-NW-but-more-is-better (NHV-by-NW)
+* . vertical work array along the left-hand-edge.
+* . ====
+*
+ KV = N - NW + 1
+ KT = NW + 1
+ NHO = ( N-NW-1 ) - KT + 1
+ KWV = NW + 2
+ NVE = ( N-NW ) - KWV + 1
+*
+* ==== Aggressive early deflation ====
+*
+ CALL DLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ,
+ $ IHIZ, Z, LDZ, LS, LD, WR, WI, H( KV, 1 ), LDH,
+ $ NHO, H( KV, KT ), LDH, NVE, H( KWV, 1 ), LDH,
+ $ WORK, LWORK )
+*
+* ==== Adjust KBOT accounting for new deflations. ====
+*
+ KBOT = KBOT - LD
+*
+* ==== KS points to the shifts. ====
+*
+ KS = KBOT - LS + 1
+*
+* ==== Skip an expensive QR sweep if there is a (partly
+* . heuristic) reason to expect that many eigenvalues
+* . will deflate without it. Here, the QR sweep is
+* . skipped if many eigenvalues have just been deflated
+* . or if the remaining active block is small.
+*
+ IF( ( LD.EQ.0 ) .OR. ( ( 100*LD.LE.NW*NIBBLE ) .AND. ( KBOT-
+ $ KTOP+1.GT.MIN( NMIN, NWMAX ) ) ) ) THEN
+*
+* ==== NS = nominal number of simultaneous shifts.
+* . This may be lowered (slightly) if DLAQR3
+* . did not provide that many shifts. ====
+*
+ NS = MIN( NSMAX, NSR, MAX( 2, KBOT-KTOP ) )
+ NS = NS - MOD( NS, 2 )
+*
+* ==== If there have been no deflations
+* . in a multiple of KEXSH iterations,
+* . then try exceptional shifts.
+* . Otherwise use shifts provided by
+* . DLAQR3 above or from the eigenvalues
+* . of a trailing principal submatrix. ====
+*
+ IF( MOD( NDFL, KEXSH ).EQ.0 ) THEN
+ KS = KBOT - NS + 1
+ DO 30 I = KBOT, MAX( KS+1, KTOP+2 ), -2
+ SS = ABS( H( I, I-1 ) ) + ABS( H( I-1, I-2 ) )
+ AA = WILK1*SS + H( I, I )
+ BB = SS
+ CC = WILK2*SS
+ DD = AA
+ CALL DLANV2( AA, BB, CC, DD, WR( I-1 ), WI( I-1 ),
+ $ WR( I ), WI( I ), CS, SN )
+ 30 CONTINUE
+ IF( KS.EQ.KTOP ) THEN
+ WR( KS+1 ) = H( KS+1, KS+1 )
+ WI( KS+1 ) = ZERO
+ WR( KS ) = WR( KS+1 )
+ WI( KS ) = WI( KS+1 )
+ END IF
+ ELSE
+*
+* ==== Got NS/2 or fewer shifts? Use DLAQR4 or
+* . DLAHQR on a trailing principal submatrix to
+* . get more. (Since NS.LE.NSMAX.LE.(N+6)/9,
+* . there is enough space below the subdiagonal
+* . to fit an NS-by-NS scratch array.) ====
+*
+ IF( KBOT-KS+1.LE.NS / 2 ) THEN
+ KS = KBOT - NS + 1
+ KT = N - NS + 1
+ CALL DLACPY( 'A', NS, NS, H( KS, KS ), LDH,
+ $ H( KT, 1 ), LDH )
+ IF( NS.GT.NMIN ) THEN
+ CALL DLAQR4( .false., .false., NS, 1, NS,
+ $ H( KT, 1 ), LDH, WR( KS ),
+ $ WI( KS ), 1, 1, ZDUM, 1, WORK,
+ $ LWORK, INF )
+ ELSE
+ CALL DLAHQR( .false., .false., NS, 1, NS,
+ $ H( KT, 1 ), LDH, WR( KS ),
+ $ WI( KS ), 1, 1, ZDUM, 1, INF )
+ END IF
+ KS = KS + INF
+*
+* ==== In case of a rare QR failure use
+* . eigenvalues of the trailing 2-by-2
+* . principal submatrix. ====
+*
+ IF( KS.GE.KBOT ) THEN
+ AA = H( KBOT-1, KBOT-1 )
+ CC = H( KBOT, KBOT-1 )
+ BB = H( KBOT-1, KBOT )
+ DD = H( KBOT, KBOT )
+ CALL DLANV2( AA, BB, CC, DD, WR( KBOT-1 ),
+ $ WI( KBOT-1 ), WR( KBOT ),
+ $ WI( KBOT ), CS, SN )
+ KS = KBOT - 1
+ END IF
+ END IF
+*
+ IF( KBOT-KS+1.GT.NS ) THEN
+*
+* ==== Sort the shifts (Helps a little)
+* . Bubble sort keeps complex conjugate
+* . pairs together. ====
+*
+ SORTED = .false.
+ DO 50 K = KBOT, KS + 1, -1
+ IF( SORTED )
+ $ GO TO 60
+ SORTED = .true.
+ DO 40 I = KS, K - 1
+ IF( ABS( WR( I ) )+ABS( WI( I ) ).LT.
+ $ ABS( WR( I+1 ) )+ABS( WI( I+1 ) ) ) THEN
+ SORTED = .false.
+*
+ SWAP = WR( I )
+ WR( I ) = WR( I+1 )
+ WR( I+1 ) = SWAP
+*
+ SWAP = WI( I )
+ WI( I ) = WI( I+1 )
+ WI( I+1 ) = SWAP
+ END IF
+ 40 CONTINUE
+ 50 CONTINUE
+ 60 CONTINUE
+ END IF
+*
+* ==== Shuffle shifts into pairs of real shifts
+* . and pairs of complex conjugate shifts
+* . assuming complex conjugate shifts are
+* . already adjacent to one another. (Yes,
+* . they are.) ====
+*
+ DO 70 I = KBOT, KS + 2, -2
+ IF( WI( I ).NE.-WI( I-1 ) ) THEN
+*
+ SWAP = WR( I )
+ WR( I ) = WR( I-1 )
+ WR( I-1 ) = WR( I-2 )
+ WR( I-2 ) = SWAP
+*
+ SWAP = WI( I )
+ WI( I ) = WI( I-1 )
+ WI( I-1 ) = WI( I-2 )
+ WI( I-2 ) = SWAP
+ END IF
+ 70 CONTINUE
+ END IF
+*
+* ==== If there are only two shifts and both are
+* . real, then use only one. ====
+*
+ IF( KBOT-KS+1.EQ.2 ) THEN
+ IF( WI( KBOT ).EQ.ZERO ) THEN
+ IF( ABS( WR( KBOT )-H( KBOT, KBOT ) ).LT.
+ $ ABS( WR( KBOT-1 )-H( KBOT, KBOT ) ) ) THEN
+ WR( KBOT-1 ) = WR( KBOT )
+ ELSE
+ WR( KBOT ) = WR( KBOT-1 )
+ END IF
+ END IF
+ END IF
+*
+* ==== Use up to NS of the the smallest magnatiude
+* . shifts. If there aren't NS shifts available,
+* . then use them all, possibly dropping one to
+* . make the number of shifts even. ====
+*
+ NS = MIN( NS, KBOT-KS+1 )
+ NS = NS - MOD( NS, 2 )
+ KS = KBOT - NS + 1
+*
+* ==== Small-bulge multi-shift QR sweep:
+* . split workspace under the subdiagonal into
+* . - a KDU-by-KDU work array U in the lower
+* . left-hand-corner,
+* . - a KDU-by-at-least-KDU-but-more-is-better
+* . (KDU-by-NHo) horizontal work array WH along
+* . the bottom edge,
+* . - and an at-least-KDU-but-more-is-better-by-KDU
+* . (NVE-by-KDU) vertical work WV arrow along
+* . the left-hand-edge. ====
+*
+ KDU = 3*NS - 3
+ KU = N - KDU + 1
+ KWH = KDU + 1
+ NHO = ( N-KDU+1-4 ) - ( KDU+1 ) + 1
+ KWV = KDU + 4
+ NVE = N - KDU - KWV + 1
+*
+* ==== Small-bulge multi-shift QR sweep ====
+*
+ CALL DLAQR5( WANTT, WANTZ, KACC22, N, KTOP, KBOT, NS,
+ $ WR( KS ), WI( KS ), H, LDH, ILOZ, IHIZ, Z,
+ $ LDZ, WORK, 3, H( KU, 1 ), LDH, NVE,
+ $ H( KWV, 1 ), LDH, NHO, H( KU, KWH ), LDH )
+ END IF
+*
+* ==== Note progress (or the lack of it). ====
+*
+ IF( LD.GT.0 ) THEN
+ NDFL = 1
+ ELSE
+ NDFL = NDFL + 1
+ END IF
+*
+* ==== End of main loop ====
+ 80 CONTINUE
+*
+* ==== Iteration limit exceeded. Set INFO to show where
+* . the problem occurred and exit. ====
+*
+ INFO = KBOT
+ 90 CONTINUE
+ END IF
+*
+* ==== Return the optimal value of LWORK. ====
+*
+ WORK( 1 ) = DBLE( LWKOPT )
+*
+* ==== End of DLAQR0 ====
+*
+ END
+ SUBROUTINE DLAQR1( N, H, LDH, SR1, SI1, SR2, SI2, V )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ DOUBLE PRECISION SI1, SI2, SR1, SR2
+ INTEGER LDH, N
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION H( LDH, * ), V( * )
+* ..
+*
+* Given a 2-by-2 or 3-by-3 matrix H, DLAQR1 sets v to a
+* scalar multiple of the first column of the product
+*
+* (*) K = (H - (sr1 + i*si1)*I)*(H - (sr2 + i*si2)*I)
+*
+* scaling to avoid overflows and most underflows. It
+* is assumed that either
+*
+* 1) sr1 = sr2 and si1 = -si2
+* or
+* 2) si1 = si2 = 0.
+*
+* This is useful for starting double implicit shift bulges
+* in the QR algorithm.
+*
+*
+* N (input) integer
+* Order of the matrix H. N must be either 2 or 3.
+*
+* H (input) DOUBLE PRECISION array of dimension (LDH,N)
+* The 2-by-2 or 3-by-3 matrix H in (*).
+*
+* LDH (input) integer
+* The leading dimension of H as declared in
+* the calling procedure. LDH.GE.N
+*
+* SR1 (input) DOUBLE PRECISION
+* SI1 The shifts in (*).
+* SR2
+* SI2
+*
+* V (output) DOUBLE PRECISION array of dimension N
+* A scalar multiple of the first column of the
+* matrix K in (*).
+*
+* ================================================================
+* Based on contributions by
+* Karen Braman and Ralph Byers, Department of Mathematics,
+* University of Kansas, USA
+*
+* ================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO
+ PARAMETER ( ZERO = 0.0d0 )
+* ..
+* .. Local Scalars ..
+ DOUBLE PRECISION H21S, H31S, S
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS
+* ..
+* .. Executable Statements ..
+ IF( N.EQ.2 ) THEN
+ S = ABS( H( 1, 1 )-SR2 ) + ABS( SI2 ) + ABS( H( 2, 1 ) )
+ IF( S.EQ.ZERO ) THEN
+ V( 1 ) = ZERO
+ V( 2 ) = ZERO
+ ELSE
+ H21S = H( 2, 1 ) / S
+ V( 1 ) = H21S*H( 1, 2 ) + ( H( 1, 1 )-SR1 )*
+ $ ( ( H( 1, 1 )-SR2 ) / S ) - SI1*( SI2 / S )
+ V( 2 ) = H21S*( H( 1, 1 )+H( 2, 2 )-SR1-SR2 )
+ END IF
+ ELSE
+ S = ABS( H( 1, 1 )-SR2 ) + ABS( SI2 ) + ABS( H( 2, 1 ) ) +
+ $ ABS( H( 3, 1 ) )
+ IF( S.EQ.ZERO ) THEN
+ V( 1 ) = ZERO
+ V( 2 ) = ZERO
+ V( 3 ) = ZERO
+ ELSE
+ H21S = H( 2, 1 ) / S
+ H31S = H( 3, 1 ) / S
+ V( 1 ) = ( H( 1, 1 )-SR1 )*( ( H( 1, 1 )-SR2 ) / S ) -
+ $ SI1*( SI2 / S ) + H( 1, 2 )*H21S + H( 1, 3 )*H31S
+ V( 2 ) = H21S*( H( 1, 1 )+H( 2, 2 )-SR1-SR2 ) +
+ $ H( 2, 3 )*H31S
+ V( 3 ) = H31S*( H( 1, 1 )+H( 3, 3 )-SR1-SR2 ) +
+ $ H21S*H( 3, 2 )
+ END IF
+ END IF
+ END
+ 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 )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER IHIZ, ILOZ, KBOT, KTOP, LDH, LDT, LDV, LDWV,
+ $ LDZ, LWORK, N, ND, NH, NS, NV, NW
+ LOGICAL WANTT, WANTZ
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION H( LDH, * ), SI( * ), SR( * ), T( LDT, * ),
+ $ V( LDV, * ), WORK( * ), WV( LDWV, * ),
+ $ Z( LDZ, * )
+* ..
+*
+* This subroutine is identical to DLAQR3 except that it avoids
+* recursion by calling DLAHQR instead of DLAQR4.
+*
+*
+* ******************************************************************
+* Aggressive early deflation:
+*
+* This subroutine accepts as input an upper Hessenberg matrix
+* H and performs an orthogonal similarity transformation
+* designed to detect and deflate fully converged eigenvalues from
+* a trailing principal submatrix. On output H has been over-
+* written by a new Hessenberg matrix that is a perturbation of
+* an orthogonal similarity transformation of H. It is to be
+* hoped that the final version of H has many zero subdiagonal
+* entries.
+*
+* ******************************************************************
+* WANTT (input) LOGICAL
+* If .TRUE., then the Hessenberg matrix H is fully updated
+* so that the quasi-triangular Schur factor may be
+* computed (in cooperation with the calling subroutine).
+* If .FALSE., then only enough of H is updated to preserve
+* the eigenvalues.
+*
+* WANTZ (input) LOGICAL
+* If .TRUE., then the orthogonal matrix Z is updated so
+* so that the orthogonal Schur factor may be computed
+* (in cooperation with the calling subroutine).
+* If .FALSE., then Z is not referenced.
+*
+* N (input) INTEGER
+* The order of the matrix H and (if WANTZ is .TRUE.) the
+* order of the orthogonal matrix Z.
+*
+* KTOP (input) INTEGER
+* It is assumed that either KTOP = 1 or H(KTOP,KTOP-1)=0.
+* KBOT and KTOP together determine an isolated block
+* along the diagonal of the Hessenberg matrix.
+*
+* KBOT (input) INTEGER
+* It is assumed without a check that either
+* KBOT = N or H(KBOT+1,KBOT)=0. KBOT and KTOP together
+* determine an isolated block along the diagonal of the
+* Hessenberg matrix.
+*
+* NW (input) INTEGER
+* Deflation window size. 1 .LE. NW .LE. (KBOT-KTOP+1).
+*
+* H (input/output) DOUBLE PRECISION array, dimension (LDH,N)
+* On input the initial N-by-N section of H stores the
+* Hessenberg matrix undergoing aggressive early deflation.
+* On output H has been transformed by an orthogonal
+* similarity transformation, perturbed, and the returned
+* to Hessenberg form that (it is to be hoped) has some
+* zero subdiagonal entries.
+*
+* LDH (input) integer
+* Leading dimension of H just as declared in the calling
+* subroutine. N .LE. LDH
+*
+* ILOZ (input) INTEGER
+* IHIZ (input) INTEGER
+* Specify the rows of Z to which transformations must be
+* applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N.
+*
+* Z (input/output) DOUBLE PRECISION array, dimension (LDZ,IHI)
+* IF WANTZ is .TRUE., then on output, the orthogonal
+* similarity transformation mentioned above has been
+* accumulated into Z(ILOZ:IHIZ,ILO:IHI) from the right.
+* If WANTZ is .FALSE., then Z is unreferenced.
+*
+* LDZ (input) integer
+* The leading dimension of Z just as declared in the
+* calling subroutine. 1 .LE. LDZ.
+*
+* NS (output) integer
+* The number of unconverged (ie approximate) eigenvalues
+* returned in SR and SI that may be used as shifts by the
+* calling subroutine.
+*
+* ND (output) integer
+* The number of converged eigenvalues uncovered by this
+* subroutine.
+*
+* SR (output) DOUBLE PRECISION array, dimension KBOT
+* SI (output) DOUBLE PRECISION array, dimension KBOT
+* On output, the real and imaginary parts of approximate
+* eigenvalues that may be used for shifts are stored in
+* SR(KBOT-ND-NS+1) through SR(KBOT-ND) and
+* SI(KBOT-ND-NS+1) through SI(KBOT-ND), respectively.
+* The real and imaginary parts of converged eigenvalues
+* are stored in SR(KBOT-ND+1) through SR(KBOT) and
+* SI(KBOT-ND+1) through SI(KBOT), respectively.
+*
+* V (workspace) DOUBLE PRECISION array, dimension (LDV,NW)
+* An NW-by-NW work array.
+*
+* LDV (input) integer scalar
+* The leading dimension of V just as declared in the
+* calling subroutine. NW .LE. LDV
+*
+* NH (input) integer scalar
+* The number of columns of T. NH.GE.NW.
+*
+* T (workspace) DOUBLE PRECISION array, dimension (LDT,NW)
+*
+* LDT (input) integer
+* The leading dimension of T just as declared in the
+* calling subroutine. NW .LE. LDT
+*
+* NV (input) integer
+* The number of rows of work array WV available for
+* workspace. NV.GE.NW.
+*
+* WV (workspace) DOUBLE PRECISION array, dimension (LDWV,NW)
+*
+* LDWV (input) integer
+* The leading dimension of W just as declared in the
+* calling subroutine. NW .LE. LDV
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension LWORK.
+* On exit, WORK(1) is set to an estimate of the optimal value
+* of LWORK for the given values of N, NW, KTOP and KBOT.
+*
+* LWORK (input) integer
+* The dimension of the work array WORK. LWORK = 2*NW
+* suffices, but greater efficiency may result from larger
+* values of LWORK.
+*
+* If LWORK = -1, then a workspace query is assumed; DLAQR2
+* only estimates the optimal workspace size for the given
+* values of N, NW, KTOP and KBOT. The estimate is returned
+* in WORK(1). No error message related to LWORK is issued
+* by XERBLA. Neither H nor Z are accessed.
+*
+* ================================================================
+* Based on contributions by
+* Karen Braman and Ralph Byers, Department of Mathematics,
+* University of Kansas, USA
+*
+* ================================================================
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0d0, ONE = 1.0d0 )
+* ..
+* .. Local Scalars ..
+ DOUBLE PRECISION AA, BB, BETA, CC, CS, DD, EVI, EVK, FOO, S,
+ $ SAFMAX, SAFMIN, SMLNUM, SN, TAU, ULP
+ INTEGER I, IFST, ILST, INFO, INFQR, J, JW, K, KCOL,
+ $ KEND, KLN, KROW, KWTOP, LTOP, LWK1, LWK2,
+ $ LWKOPT
+ LOGICAL BULGE, SORTED
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DLAMCH
+ EXTERNAL DLAMCH
+* ..
+* .. External Subroutines ..
+ EXTERNAL DCOPY, DGEHRD, DGEMM, DLABAD, DLACPY, DLAHQR,
+ $ DLANV2, DLARF, DLARFG, DLASET, DORGHR, DTREXC
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, DBLE, INT, MAX, MIN, SQRT
+* ..
+* .. Executable Statements ..
+*
+* ==== Estimate optimal workspace. ====
+*
+ JW = MIN( NW, KBOT-KTOP+1 )
+ IF( JW.LE.2 ) THEN
+ LWKOPT = 1
+ ELSE
+*
+* ==== Workspace query call to DGEHRD ====
+*
+ CALL DGEHRD( JW, 1, JW-1, T, LDT, WORK, WORK, -1, INFO )
+ LWK1 = INT( WORK( 1 ) )
+*
+* ==== Workspace query call to DORGHR ====
+*
+ CALL DORGHR( JW, 1, JW-1, T, LDT, WORK, WORK, -1, INFO )
+ LWK2 = INT( WORK( 1 ) )
+*
+* ==== Optimal workspace ====
+*
+ LWKOPT = JW + MAX( LWK1, LWK2 )
+ END IF
+*
+* ==== Quick return in case of workspace query. ====
+*
+ IF( LWORK.EQ.-1 ) THEN
+ WORK( 1 ) = DBLE( LWKOPT )
+ RETURN
+ END IF
+*
+* ==== Nothing to do ...
+* ... for an empty active block ... ====
+ NS = 0
+ ND = 0
+ IF( KTOP.GT.KBOT )
+ $ RETURN
+* ... nor for an empty deflation window. ====
+ IF( NW.LT.1 )
+ $ RETURN
+*
+* ==== Machine constants ====
+*
+ SAFMIN = DLAMCH( 'SAFE MINIMUM' )
+ SAFMAX = ONE / SAFMIN
+ CALL DLABAD( SAFMIN, SAFMAX )
+ ULP = DLAMCH( 'PRECISION' )
+ SMLNUM = SAFMIN*( DBLE( N ) / ULP )
+*
+* ==== Setup deflation window ====
+*
+ JW = MIN( NW, KBOT-KTOP+1 )
+ KWTOP = KBOT - JW + 1
+ IF( KWTOP.EQ.KTOP ) THEN
+ S = ZERO
+ ELSE
+ S = H( KWTOP, KWTOP-1 )
+ END IF
+*
+ IF( KBOT.EQ.KWTOP ) THEN
+*
+* ==== 1-by-1 deflation window: not much to do ====
+*
+ SR( KWTOP ) = H( KWTOP, KWTOP )
+ SI( KWTOP ) = ZERO
+ NS = 1
+ ND = 0
+ IF( ABS( S ).LE.MAX( SMLNUM, ULP*ABS( H( KWTOP, KWTOP ) ) ) )
+ $ THEN
+ NS = 0
+ ND = 1
+ IF( KWTOP.GT.KTOP )
+ $ H( KWTOP, KWTOP-1 ) = ZERO
+ END IF
+ RETURN
+ END IF
+*
+* ==== Convert to spike-triangular form. (In case of a
+* . rare QR failure, this routine continues to do
+* . aggressive early deflation using that part of
+* . the deflation window that converged using INFQR
+* . here and there to keep track.) ====
+*
+ CALL DLACPY( 'U', JW, JW, H( KWTOP, KWTOP ), LDH, T, LDT )
+ CALL DCOPY( JW-1, H( KWTOP+1, KWTOP ), LDH+1, T( 2, 1 ), LDT+1 )
+*
+ CALL DLASET( 'A', JW, JW, ZERO, ONE, V, LDV )
+ CALL DLAHQR( .true., .true., JW, 1, JW, T, LDT, SR( KWTOP ),
+ $ SI( KWTOP ), 1, JW, V, LDV, INFQR )
+*
+* ==== DTREXC needs a clean margin near the diagonal ====
+*
+ DO 10 J = 1, JW - 3
+ T( J+2, J ) = ZERO
+ T( J+3, J ) = ZERO
+ 10 CONTINUE
+ IF( JW.GT.2 )
+ $ T( JW, JW-2 ) = ZERO
+*
+* ==== Deflation detection loop ====
+*
+ NS = JW
+ ILST = INFQR + 1
+ 20 CONTINUE
+ IF( ILST.LE.NS ) THEN
+ IF( NS.EQ.1 ) THEN
+ BULGE = .FALSE.
+ ELSE
+ BULGE = T( NS, NS-1 ).NE.ZERO
+ END IF
+*
+* ==== Small spike tip test for deflation ====
+*
+ IF( .NOT.BULGE ) THEN
+*
+* ==== Real eigenvalue ====
+*
+ FOO = ABS( T( NS, NS ) )
+ IF( FOO.EQ.ZERO )
+ $ FOO = ABS( S )
+ IF( ABS( S*V( 1, NS ) ).LE.MAX( SMLNUM, ULP*FOO ) ) THEN
+*
+* ==== Deflatable ====
+*
+ NS = NS - 1
+ ELSE
+*
+* ==== Undeflatable. Move it up out of the way.
+* . (DTREXC can not fail in this case.) ====
+*
+ IFST = NS
+ CALL DTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, WORK,
+ $ INFO )
+ ILST = ILST + 1
+ END IF
+ ELSE
+*
+* ==== Complex conjugate pair ====
+*
+ FOO = ABS( T( NS, NS ) ) + SQRT( ABS( T( NS, NS-1 ) ) )*
+ $ SQRT( ABS( T( NS-1, NS ) ) )
+ IF( FOO.EQ.ZERO )
+ $ FOO = ABS( S )
+ IF( MAX( ABS( S*V( 1, NS ) ), ABS( S*V( 1, NS-1 ) ) ).LE.
+ $ MAX( SMLNUM, ULP*FOO ) ) THEN
+*
+* ==== Deflatable ====
+*
+ NS = NS - 2
+ ELSE
+*
+* ==== Undflatable. Move them up out of the way.
+* . Fortunately, DTREXC does the right thing with
+* . ILST in case of a rare exchange failure. ====
+*
+ IFST = NS
+ CALL DTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, WORK,
+ $ INFO )
+ ILST = ILST + 2
+ END IF
+ END IF
+*
+* ==== End deflation detection loop ====
+*
+ GO TO 20
+ END IF
+*
+* ==== Return to Hessenberg form ====
+*
+ IF( NS.EQ.0 )
+ $ S = ZERO
+*
+ IF( NS.LT.JW ) THEN
+*
+* ==== sorting diagonal blocks of T improves accuracy for
+* . graded matrices. Bubble sort deals well with
+* . exchange failures. ====
+*
+ SORTED = .false.
+ I = NS + 1
+ 30 CONTINUE
+ IF( SORTED )
+ $ GO TO 50
+ SORTED = .true.
+*
+ KEND = I - 1
+ I = INFQR + 1
+ IF( I.EQ.NS ) THEN
+ K = I + 1
+ ELSE IF( T( I+1, I ).EQ.ZERO ) THEN
+ K = I + 1
+ ELSE
+ K = I + 2
+ END IF
+ 40 CONTINUE
+ IF( K.LE.KEND ) THEN
+ IF( K.EQ.I+1 ) THEN
+ EVI = ABS( T( I, I ) )
+ ELSE
+ EVI = ABS( T( I, I ) ) + SQRT( ABS( T( I+1, I ) ) )*
+ $ SQRT( ABS( T( I, I+1 ) ) )
+ END IF
+*
+ IF( K.EQ.KEND ) THEN
+ EVK = ABS( T( K, K ) )
+ ELSE IF( T( K+1, K ).EQ.ZERO ) THEN
+ EVK = ABS( T( K, K ) )
+ ELSE
+ EVK = ABS( T( K, K ) ) + SQRT( ABS( T( K+1, K ) ) )*
+ $ SQRT( ABS( T( K, K+1 ) ) )
+ END IF
+*
+ IF( EVI.GE.EVK ) THEN
+ I = K
+ ELSE
+ SORTED = .false.
+ IFST = I
+ ILST = K
+ CALL DTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, WORK,
+ $ INFO )
+ IF( INFO.EQ.0 ) THEN
+ I = ILST
+ ELSE
+ I = K
+ END IF
+ END IF
+ IF( I.EQ.KEND ) THEN
+ K = I + 1
+ ELSE IF( T( I+1, I ).EQ.ZERO ) THEN
+ K = I + 1
+ ELSE
+ K = I + 2
+ END IF
+ GO TO 40
+ END IF
+ GO TO 30
+ 50 CONTINUE
+ END IF
+*
+* ==== Restore shift/eigenvalue array from T ====
+*
+ I = JW
+ 60 CONTINUE
+ IF( I.GE.INFQR+1 ) THEN
+ IF( I.EQ.INFQR+1 ) THEN
+ SR( KWTOP+I-1 ) = T( I, I )
+ SI( KWTOP+I-1 ) = ZERO
+ I = I - 1
+ ELSE IF( T( I, I-1 ).EQ.ZERO ) THEN
+ SR( KWTOP+I-1 ) = T( I, I )
+ SI( KWTOP+I-1 ) = ZERO
+ I = I - 1
+ ELSE
+ AA = T( I-1, I-1 )
+ CC = T( I, I-1 )
+ BB = T( I-1, I )
+ DD = T( I, I )
+ CALL DLANV2( AA, BB, CC, DD, SR( KWTOP+I-2 ),
+ $ SI( KWTOP+I-2 ), SR( KWTOP+I-1 ),
+ $ SI( KWTOP+I-1 ), CS, SN )
+ I = I - 2
+ END IF
+ GO TO 60
+ END IF
+*
+ IF( NS.LT.JW .OR. S.EQ.ZERO ) THEN
+ IF( NS.GT.1 .AND. S.NE.ZERO ) THEN
+*
+* ==== Reflect spike back into lower triangle ====
+*
+ CALL DCOPY( NS, V, LDV, WORK, 1 )
+ BETA = WORK( 1 )
+ CALL DLARFG( NS, BETA, WORK( 2 ), 1, TAU )
+ WORK( 1 ) = ONE
+*
+ CALL DLASET( 'L', JW-2, JW-2, ZERO, ZERO, T( 3, 1 ), LDT )
+*
+ CALL DLARF( 'L', NS, JW, WORK, 1, TAU, T, LDT,
+ $ WORK( JW+1 ) )
+ CALL DLARF( 'R', NS, NS, WORK, 1, TAU, T, LDT,
+ $ WORK( JW+1 ) )
+ CALL DLARF( 'R', JW, NS, WORK, 1, TAU, V, LDV,
+ $ WORK( JW+1 ) )
+*
+ CALL DGEHRD( JW, 1, NS, T, LDT, WORK, WORK( JW+1 ),
+ $ LWORK-JW, INFO )
+ END IF
+*
+* ==== Copy updated reduced window into place ====
+*
+ IF( KWTOP.GT.1 )
+ $ H( KWTOP, KWTOP-1 ) = S*V( 1, 1 )
+ CALL DLACPY( 'U', JW, JW, T, LDT, H( KWTOP, KWTOP ), LDH )
+ CALL DCOPY( JW-1, T( 2, 1 ), LDT+1, H( KWTOP+1, KWTOP ),
+ $ LDH+1 )
+*
+* ==== Accumulate orthogonal matrix in order update
+* . H and Z, if requested. (A modified version
+* . of DORGHR that accumulates block Householder
+* . transformations into V directly might be
+* . marginally more efficient than the following.) ====
+*
+ IF( NS.GT.1 .AND. S.NE.ZERO ) THEN
+ CALL DORGHR( JW, 1, NS, T, LDT, WORK, WORK( JW+1 ),
+ $ LWORK-JW, INFO )
+ CALL DGEMM( 'N', 'N', JW, NS, NS, ONE, V, LDV, T, LDT, ZERO,
+ $ WV, LDWV )
+ CALL DLACPY( 'A', JW, NS, WV, LDWV, V, LDV )
+ END IF
+*
+* ==== Update vertical slab in H ====
+*
+ IF( WANTT ) THEN
+ LTOP = 1
+ ELSE
+ LTOP = KTOP
+ END IF
+ DO 70 KROW = LTOP, KWTOP - 1, NV
+ KLN = MIN( NV, KWTOP-KROW )
+ CALL DGEMM( 'N', 'N', KLN, JW, JW, ONE, H( KROW, KWTOP ),
+ $ LDH, V, LDV, ZERO, WV, LDWV )
+ CALL DLACPY( 'A', KLN, JW, WV, LDWV, H( KROW, KWTOP ), LDH )
+ 70 CONTINUE
+*
+* ==== Update horizontal slab in H ====
+*
+ IF( WANTT ) THEN
+ DO 80 KCOL = KBOT + 1, N, NH
+ KLN = MIN( NH, N-KCOL+1 )
+ CALL DGEMM( 'C', 'N', JW, KLN, JW, ONE, V, LDV,
+ $ H( KWTOP, KCOL ), LDH, ZERO, T, LDT )
+ CALL DLACPY( 'A', JW, KLN, T, LDT, H( KWTOP, KCOL ),
+ $ LDH )
+ 80 CONTINUE
+ END IF
+*
+* ==== Update vertical slab in Z ====
+*
+ IF( WANTZ ) THEN
+ DO 90 KROW = ILOZ, IHIZ, NV
+ KLN = MIN( NV, IHIZ-KROW+1 )
+ CALL DGEMM( 'N', 'N', KLN, JW, JW, ONE, Z( KROW, KWTOP ),
+ $ LDZ, V, LDV, ZERO, WV, LDWV )
+ CALL DLACPY( 'A', KLN, JW, WV, LDWV, Z( KROW, KWTOP ),
+ $ LDZ )
+ 90 CONTINUE
+ END IF
+ END IF
+*
+* ==== Return the number of deflations ... ====
+*
+ ND = JW - NS
+*
+* ==== ... and the number of shifts. (Subtracting
+* . INFQR from the spike length takes care
+* . of the case of a rare QR failure while
+* . calculating eigenvalues of the deflation
+* . window.) ====
+*
+ NS = NS - INFQR
+*
+* ==== Return optimal workspace. ====
+*
+ WORK( 1 ) = DBLE( LWKOPT )
+*
+* ==== End of DLAQR2 ====
+*
+ END
+ 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 )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER IHIZ, ILOZ, KBOT, KTOP, LDH, LDT, LDV, LDWV,
+ $ LDZ, LWORK, N, ND, NH, NS, NV, NW
+ LOGICAL WANTT, WANTZ
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION H( LDH, * ), SI( * ), SR( * ), T( LDT, * ),
+ $ V( LDV, * ), WORK( * ), WV( LDWV, * ),
+ $ Z( LDZ, * )
+* ..
+*
+* ******************************************************************
+* Aggressive early deflation:
+*
+* This subroutine accepts as input an upper Hessenberg matrix
+* H and performs an orthogonal similarity transformation
+* designed to detect and deflate fully converged eigenvalues from
+* a trailing principal submatrix. On output H has been over-
+* written by a new Hessenberg matrix that is a perturbation of
+* an orthogonal similarity transformation of H. It is to be
+* hoped that the final version of H has many zero subdiagonal
+* entries.
+*
+* ******************************************************************
+* WANTT (input) LOGICAL
+* If .TRUE., then the Hessenberg matrix H is fully updated
+* so that the quasi-triangular Schur factor may be
+* computed (in cooperation with the calling subroutine).
+* If .FALSE., then only enough of H is updated to preserve
+* the eigenvalues.
+*
+* WANTZ (input) LOGICAL
+* If .TRUE., then the orthogonal matrix Z is updated so
+* so that the orthogonal Schur factor may be computed
+* (in cooperation with the calling subroutine).
+* If .FALSE., then Z is not referenced.
+*
+* N (input) INTEGER
+* The order of the matrix H and (if WANTZ is .TRUE.) the
+* order of the orthogonal matrix Z.
+*
+* KTOP (input) INTEGER
+* It is assumed that either KTOP = 1 or H(KTOP,KTOP-1)=0.
+* KBOT and KTOP together determine an isolated block
+* along the diagonal of the Hessenberg matrix.
+*
+* KBOT (input) INTEGER
+* It is assumed without a check that either
+* KBOT = N or H(KBOT+1,KBOT)=0. KBOT and KTOP together
+* determine an isolated block along the diagonal of the
+* Hessenberg matrix.
+*
+* NW (input) INTEGER
+* Deflation window size. 1 .LE. NW .LE. (KBOT-KTOP+1).
+*
+* H (input/output) DOUBLE PRECISION array, dimension (LDH,N)
+* On input the initial N-by-N section of H stores the
+* Hessenberg matrix undergoing aggressive early deflation.
+* On output H has been transformed by an orthogonal
+* similarity transformation, perturbed, and the returned
+* to Hessenberg form that (it is to be hoped) has some
+* zero subdiagonal entries.
+*
+* LDH (input) integer
+* Leading dimension of H just as declared in the calling
+* subroutine. N .LE. LDH
+*
+* ILOZ (input) INTEGER
+* IHIZ (input) INTEGER
+* Specify the rows of Z to which transformations must be
+* applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N.
+*
+* Z (input/output) DOUBLE PRECISION array, dimension (LDZ,IHI)
+* IF WANTZ is .TRUE., then on output, the orthogonal
+* similarity transformation mentioned above has been
+* accumulated into Z(ILOZ:IHIZ,ILO:IHI) from the right.
+* If WANTZ is .FALSE., then Z is unreferenced.
+*
+* LDZ (input) integer
+* The leading dimension of Z just as declared in the
+* calling subroutine. 1 .LE. LDZ.
+*
+* NS (output) integer
+* The number of unconverged (ie approximate) eigenvalues
+* returned in SR and SI that may be used as shifts by the
+* calling subroutine.
+*
+* ND (output) integer
+* The number of converged eigenvalues uncovered by this
+* subroutine.
+*
+* SR (output) DOUBLE PRECISION array, dimension KBOT
+* SI (output) DOUBLE PRECISION array, dimension KBOT
+* On output, the real and imaginary parts of approximate
+* eigenvalues that may be used for shifts are stored in
+* SR(KBOT-ND-NS+1) through SR(KBOT-ND) and
+* SI(KBOT-ND-NS+1) through SI(KBOT-ND), respectively.
+* The real and imaginary parts of converged eigenvalues
+* are stored in SR(KBOT-ND+1) through SR(KBOT) and
+* SI(KBOT-ND+1) through SI(KBOT), respectively.
+*
+* V (workspace) DOUBLE PRECISION array, dimension (LDV,NW)
+* An NW-by-NW work array.
+*
+* LDV (input) integer scalar
+* The leading dimension of V just as declared in the
+* calling subroutine. NW .LE. LDV
+*
+* NH (input) integer scalar
+* The number of columns of T. NH.GE.NW.
+*
+* T (workspace) DOUBLE PRECISION array, dimension (LDT,NW)
+*
+* LDT (input) integer
+* The leading dimension of T just as declared in the
+* calling subroutine. NW .LE. LDT
+*
+* NV (input) integer
+* The number of rows of work array WV available for
+* workspace. NV.GE.NW.
+*
+* WV (workspace) DOUBLE PRECISION array, dimension (LDWV,NW)
+*
+* LDWV (input) integer
+* The leading dimension of W just as declared in the
+* calling subroutine. NW .LE. LDV
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension LWORK.
+* On exit, WORK(1) is set to an estimate of the optimal value
+* of LWORK for the given values of N, NW, KTOP and KBOT.
+*
+* LWORK (input) integer
+* The dimension of the work array WORK. LWORK = 2*NW
+* suffices, but greater efficiency may result from larger
+* values of LWORK.
+*
+* If LWORK = -1, then a workspace query is assumed; DLAQR3
+* only estimates the optimal workspace size for the given
+* values of N, NW, KTOP and KBOT. The estimate is returned
+* in WORK(1). No error message related to LWORK is issued
+* by XERBLA. Neither H nor Z are accessed.
+*
+* ================================================================
+* Based on contributions by
+* Karen Braman and Ralph Byers, Department of Mathematics,
+* University of Kansas, USA
+*
+* ==================================================================
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0d0, ONE = 1.0d0 )
+* ..
+* .. Local Scalars ..
+ DOUBLE PRECISION AA, BB, BETA, CC, CS, DD, EVI, EVK, FOO, S,
+ $ SAFMAX, SAFMIN, SMLNUM, SN, TAU, ULP
+ INTEGER I, IFST, ILST, INFO, INFQR, J, JW, K, KCOL,
+ $ KEND, KLN, KROW, KWTOP, LTOP, LWK1, LWK2, LWK3,
+ $ LWKOPT, NMIN
+ LOGICAL BULGE, SORTED
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DLAMCH
+ INTEGER ILAENV
+ EXTERNAL DLAMCH, ILAENV
+* ..
+* .. External Subroutines ..
+ EXTERNAL DCOPY, DGEHRD, DGEMM, DLABAD, DLACPY, DLAHQR,
+ $ DLANV2, DLAQR4, DLARF, DLARFG, DLASET, DORGHR,
+ $ DTREXC
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, DBLE, INT, MAX, MIN, SQRT
+* ..
+* .. Executable Statements ..
+*
+* ==== Estimate optimal workspace. ====
+*
+ JW = MIN( NW, KBOT-KTOP+1 )
+ IF( JW.LE.2 ) THEN
+ LWKOPT = 1
+ ELSE
+*
+* ==== Workspace query call to DGEHRD ====
+*
+ CALL DGEHRD( JW, 1, JW-1, T, LDT, WORK, WORK, -1, INFO )
+ LWK1 = INT( WORK( 1 ) )
+*
+* ==== Workspace query call to DORGHR ====
+*
+ CALL DORGHR( JW, 1, JW-1, T, LDT, WORK, WORK, -1, INFO )
+ LWK2 = INT( WORK( 1 ) )
+*
+* ==== Workspace query call to DLAQR4 ====
+*
+ CALL DLAQR4( .true., .true., JW, 1, JW, T, LDT, SR, SI, 1, JW,
+ $ V, LDV, WORK, -1, INFQR )
+ LWK3 = INT( WORK( 1 ) )
+*
+* ==== Optimal workspace ====
+*
+ LWKOPT = MAX( JW+MAX( LWK1, LWK2 ), LWK3 )
+ END IF
+*
+* ==== Quick return in case of workspace query. ====
+*
+ IF( LWORK.EQ.-1 ) THEN
+ WORK( 1 ) = DBLE( LWKOPT )
+ RETURN
+ END IF
+*
+* ==== Nothing to do ...
+* ... for an empty active block ... ====
+ NS = 0
+ ND = 0
+ IF( KTOP.GT.KBOT )
+ $ RETURN
+* ... nor for an empty deflation window. ====
+ IF( NW.LT.1 )
+ $ RETURN
+*
+* ==== Machine constants ====
+*
+ SAFMIN = DLAMCH( 'SAFE MINIMUM' )
+ SAFMAX = ONE / SAFMIN
+ CALL DLABAD( SAFMIN, SAFMAX )
+ ULP = DLAMCH( 'PRECISION' )
+ SMLNUM = SAFMIN*( DBLE( N ) / ULP )
+*
+* ==== Setup deflation window ====
+*
+ JW = MIN( NW, KBOT-KTOP+1 )
+ KWTOP = KBOT - JW + 1
+ IF( KWTOP.EQ.KTOP ) THEN
+ S = ZERO
+ ELSE
+ S = H( KWTOP, KWTOP-1 )
+ END IF
+*
+ IF( KBOT.EQ.KWTOP ) THEN
+*
+* ==== 1-by-1 deflation window: not much to do ====
+*
+ SR( KWTOP ) = H( KWTOP, KWTOP )
+ SI( KWTOP ) = ZERO
+ NS = 1
+ ND = 0
+ IF( ABS( S ).LE.MAX( SMLNUM, ULP*ABS( H( KWTOP, KWTOP ) ) ) )
+ $ THEN
+ NS = 0
+ ND = 1
+ IF( KWTOP.GT.KTOP )
+ $ H( KWTOP, KWTOP-1 ) = ZERO
+ END IF
+ RETURN
+ END IF
+*
+* ==== Convert to spike-triangular form. (In case of a
+* . rare QR failure, this routine continues to do
+* . aggressive early deflation using that part of
+* . the deflation window that converged using INFQR
+* . here and there to keep track.) ====
+*
+ CALL DLACPY( 'U', JW, JW, H( KWTOP, KWTOP ), LDH, T, LDT )
+ CALL DCOPY( JW-1, H( KWTOP+1, KWTOP ), LDH+1, T( 2, 1 ), LDT+1 )
+*
+ CALL DLASET( 'A', JW, JW, ZERO, ONE, V, LDV )
+ NMIN = ILAENV( 12, 'DLAQR3', 'SV', JW, 1, JW, LWORK )
+ IF( JW.GT.NMIN ) THEN
+ CALL DLAQR4( .true., .true., JW, 1, JW, T, LDT, SR( KWTOP ),
+ $ SI( KWTOP ), 1, JW, V, LDV, WORK, LWORK, INFQR )
+ ELSE
+ CALL DLAHQR( .true., .true., JW, 1, JW, T, LDT, SR( KWTOP ),
+ $ SI( KWTOP ), 1, JW, V, LDV, INFQR )
+ END IF
+*
+* ==== DTREXC needs a clean margin near the diagonal ====
+*
+ DO 10 J = 1, JW - 3
+ T( J+2, J ) = ZERO
+ T( J+3, J ) = ZERO
+ 10 CONTINUE
+ IF( JW.GT.2 )
+ $ T( JW, JW-2 ) = ZERO
+*
+* ==== Deflation detection loop ====
+*
+ NS = JW
+ ILST = INFQR + 1
+ 20 CONTINUE
+ IF( ILST.LE.NS ) THEN
+ IF( NS.EQ.1 ) THEN
+ BULGE = .FALSE.
+ ELSE
+ BULGE = T( NS, NS-1 ).NE.ZERO
+ END IF
+*
+* ==== Small spike tip test for deflation ====
+*
+ IF( .NOT.BULGE ) THEN
+*
+* ==== Real eigenvalue ====
+*
+ FOO = ABS( T( NS, NS ) )
+ IF( FOO.EQ.ZERO )
+ $ FOO = ABS( S )
+ IF( ABS( S*V( 1, NS ) ).LE.MAX( SMLNUM, ULP*FOO ) ) THEN
+*
+* ==== Deflatable ====
+*
+ NS = NS - 1
+ ELSE
+*
+* ==== Undeflatable. Move it up out of the way.
+* . (DTREXC can not fail in this case.) ====
+*
+ IFST = NS
+ CALL DTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, WORK,
+ $ INFO )
+ ILST = ILST + 1
+ END IF
+ ELSE
+*
+* ==== Complex conjugate pair ====
+*
+ FOO = ABS( T( NS, NS ) ) + SQRT( ABS( T( NS, NS-1 ) ) )*
+ $ SQRT( ABS( T( NS-1, NS ) ) )
+ IF( FOO.EQ.ZERO )
+ $ FOO = ABS( S )
+ IF( MAX( ABS( S*V( 1, NS ) ), ABS( S*V( 1, NS-1 ) ) ).LE.
+ $ MAX( SMLNUM, ULP*FOO ) ) THEN
+*
+* ==== Deflatable ====
+*
+ NS = NS - 2
+ ELSE
+*
+* ==== Undflatable. Move them up out of the way.
+* . Fortunately, DTREXC does the right thing with
+* . ILST in case of a rare exchange failure. ====
+*
+ IFST = NS
+ CALL DTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, WORK,
+ $ INFO )
+ ILST = ILST + 2
+ END IF
+ END IF
+*
+* ==== End deflation detection loop ====
+*
+ GO TO 20
+ END IF
+*
+* ==== Return to Hessenberg form ====
+*
+ IF( NS.EQ.0 )
+ $ S = ZERO
+*
+ IF( NS.LT.JW ) THEN
+*
+* ==== sorting diagonal blocks of T improves accuracy for
+* . graded matrices. Bubble sort deals well with
+* . exchange failures. ====
+*
+ SORTED = .false.
+ I = NS + 1
+ 30 CONTINUE
+ IF( SORTED )
+ $ GO TO 50
+ SORTED = .true.
+*
+ KEND = I - 1
+ I = INFQR + 1
+ IF( I.EQ.NS ) THEN
+ K = I + 1
+ ELSE IF( T( I+1, I ).EQ.ZERO ) THEN
+ K = I + 1
+ ELSE
+ K = I + 2
+ END IF
+ 40 CONTINUE
+ IF( K.LE.KEND ) THEN
+ IF( K.EQ.I+1 ) THEN
+ EVI = ABS( T( I, I ) )
+ ELSE
+ EVI = ABS( T( I, I ) ) + SQRT( ABS( T( I+1, I ) ) )*
+ $ SQRT( ABS( T( I, I+1 ) ) )
+ END IF
+*
+ IF( K.EQ.KEND ) THEN
+ EVK = ABS( T( K, K ) )
+ ELSE IF( T( K+1, K ).EQ.ZERO ) THEN
+ EVK = ABS( T( K, K ) )
+ ELSE
+ EVK = ABS( T( K, K ) ) + SQRT( ABS( T( K+1, K ) ) )*
+ $ SQRT( ABS( T( K, K+1 ) ) )
+ END IF
+*
+ IF( EVI.GE.EVK ) THEN
+ I = K
+ ELSE
+ SORTED = .false.
+ IFST = I
+ ILST = K
+ CALL DTREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, WORK,
+ $ INFO )
+ IF( INFO.EQ.0 ) THEN
+ I = ILST
+ ELSE
+ I = K
+ END IF
+ END IF
+ IF( I.EQ.KEND ) THEN
+ K = I + 1
+ ELSE IF( T( I+1, I ).EQ.ZERO ) THEN
+ K = I + 1
+ ELSE
+ K = I + 2
+ END IF
+ GO TO 40
+ END IF
+ GO TO 30
+ 50 CONTINUE
+ END IF
+*
+* ==== Restore shift/eigenvalue array from T ====
+*
+ I = JW
+ 60 CONTINUE
+ IF( I.GE.INFQR+1 ) THEN
+ IF( I.EQ.INFQR+1 ) THEN
+ SR( KWTOP+I-1 ) = T( I, I )
+ SI( KWTOP+I-1 ) = ZERO
+ I = I - 1
+ ELSE IF( T( I, I-1 ).EQ.ZERO ) THEN
+ SR( KWTOP+I-1 ) = T( I, I )
+ SI( KWTOP+I-1 ) = ZERO
+ I = I - 1
+ ELSE
+ AA = T( I-1, I-1 )
+ CC = T( I, I-1 )
+ BB = T( I-1, I )
+ DD = T( I, I )
+ CALL DLANV2( AA, BB, CC, DD, SR( KWTOP+I-2 ),
+ $ SI( KWTOP+I-2 ), SR( KWTOP+I-1 ),
+ $ SI( KWTOP+I-1 ), CS, SN )
+ I = I - 2
+ END IF
+ GO TO 60
+ END IF
+*
+ IF( NS.LT.JW .OR. S.EQ.ZERO ) THEN
+ IF( NS.GT.1 .AND. S.NE.ZERO ) THEN
+*
+* ==== Reflect spike back into lower triangle ====
+*
+ CALL DCOPY( NS, V, LDV, WORK, 1 )
+ BETA = WORK( 1 )
+ CALL DLARFG( NS, BETA, WORK( 2 ), 1, TAU )
+ WORK( 1 ) = ONE
+*
+ CALL DLASET( 'L', JW-2, JW-2, ZERO, ZERO, T( 3, 1 ), LDT )
+*
+ CALL DLARF( 'L', NS, JW, WORK, 1, TAU, T, LDT,
+ $ WORK( JW+1 ) )
+ CALL DLARF( 'R', NS, NS, WORK, 1, TAU, T, LDT,
+ $ WORK( JW+1 ) )
+ CALL DLARF( 'R', JW, NS, WORK, 1, TAU, V, LDV,
+ $ WORK( JW+1 ) )
+*
+ CALL DGEHRD( JW, 1, NS, T, LDT, WORK, WORK( JW+1 ),
+ $ LWORK-JW, INFO )
+ END IF
+*
+* ==== Copy updated reduced window into place ====
+*
+ IF( KWTOP.GT.1 )
+ $ H( KWTOP, KWTOP-1 ) = S*V( 1, 1 )
+ CALL DLACPY( 'U', JW, JW, T, LDT, H( KWTOP, KWTOP ), LDH )
+ CALL DCOPY( JW-1, T( 2, 1 ), LDT+1, H( KWTOP+1, KWTOP ),
+ $ LDH+1 )
+*
+* ==== Accumulate orthogonal matrix in order update
+* . H and Z, if requested. (A modified version
+* . of DORGHR that accumulates block Householder
+* . transformations into V directly might be
+* . marginally more efficient than the following.) ====
+*
+ IF( NS.GT.1 .AND. S.NE.ZERO ) THEN
+ CALL DORGHR( JW, 1, NS, T, LDT, WORK, WORK( JW+1 ),
+ $ LWORK-JW, INFO )
+ CALL DGEMM( 'N', 'N', JW, NS, NS, ONE, V, LDV, T, LDT, ZERO,
+ $ WV, LDWV )
+ CALL DLACPY( 'A', JW, NS, WV, LDWV, V, LDV )
+ END IF
+*
+* ==== Update vertical slab in H ====
+*
+ IF( WANTT ) THEN
+ LTOP = 1
+ ELSE
+ LTOP = KTOP
+ END IF
+ DO 70 KROW = LTOP, KWTOP - 1, NV
+ KLN = MIN( NV, KWTOP-KROW )
+ CALL DGEMM( 'N', 'N', KLN, JW, JW, ONE, H( KROW, KWTOP ),
+ $ LDH, V, LDV, ZERO, WV, LDWV )
+ CALL DLACPY( 'A', KLN, JW, WV, LDWV, H( KROW, KWTOP ), LDH )
+ 70 CONTINUE
+*
+* ==== Update horizontal slab in H ====
+*
+ IF( WANTT ) THEN
+ DO 80 KCOL = KBOT + 1, N, NH
+ KLN = MIN( NH, N-KCOL+1 )
+ CALL DGEMM( 'C', 'N', JW, KLN, JW, ONE, V, LDV,
+ $ H( KWTOP, KCOL ), LDH, ZERO, T, LDT )
+ CALL DLACPY( 'A', JW, KLN, T, LDT, H( KWTOP, KCOL ),
+ $ LDH )
+ 80 CONTINUE
+ END IF
+*
+* ==== Update vertical slab in Z ====
+*
+ IF( WANTZ ) THEN
+ DO 90 KROW = ILOZ, IHIZ, NV
+ KLN = MIN( NV, IHIZ-KROW+1 )
+ CALL DGEMM( 'N', 'N', KLN, JW, JW, ONE, Z( KROW, KWTOP ),
+ $ LDZ, V, LDV, ZERO, WV, LDWV )
+ CALL DLACPY( 'A', KLN, JW, WV, LDWV, Z( KROW, KWTOP ),
+ $ LDZ )
+ 90 CONTINUE
+ END IF
+ END IF
+*
+* ==== Return the number of deflations ... ====
+*
+ ND = JW - NS
+*
+* ==== ... and the number of shifts. (Subtracting
+* . INFQR from the spike length takes care
+* . of the case of a rare QR failure while
+* . calculating eigenvalues of the deflation
+* . window.) ====
+*
+ NS = NS - INFQR
+*
+* ==== Return optimal workspace. ====
+*
+ WORK( 1 ) = DBLE( LWKOPT )
+*
+* ==== End of DLAQR3 ====
+*
+ END
+ SUBROUTINE DLAQR4( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI,
+ $ ILOZ, IHIZ, Z, LDZ, WORK, LWORK, INFO )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, LWORK, N
+ LOGICAL WANTT, WANTZ
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION H( LDH, * ), WI( * ), WORK( * ), WR( * ),
+ $ Z( LDZ, * )
+* ..
+*
+* This subroutine implements one level of recursion for DLAQR0.
+* It is a complete implementation of the small bulge multi-shift
+* QR algorithm. It may be called by DLAQR0 and, for large enough
+* deflation window size, it may be called by DLAQR3. This
+* subroutine is identical to DLAQR0 except that it calls DLAQR2
+* instead of DLAQR3.
+*
+* Purpose
+* =======
+*
+* DLAQR4 computes the eigenvalues of a Hessenberg matrix H
+* and, optionally, the matrices T and Z from the Schur decomposition
+* H = Z T Z**T, where T is an upper quasi-triangular matrix (the
+* Schur form), and Z is the orthogonal matrix of Schur vectors.
+*
+* Optionally Z may be postmultiplied into an input orthogonal
+* matrix Q so that this routine can give the Schur factorization
+* of a matrix A which has been reduced to the Hessenberg form H
+* by the orthogonal matrix Q: A = Q*H*Q**T = (QZ)*T*(QZ)**T.
+*
+* Arguments
+* =========
+*
+* WANTT (input) LOGICAL
+* = .TRUE. : the full Schur form T is required;
+* = .FALSE.: only eigenvalues are required.
+*
+* WANTZ (input) LOGICAL
+* = .TRUE. : the matrix of Schur vectors Z is required;
+* = .FALSE.: Schur vectors are not required.
+*
+* N (input) INTEGER
+* The order of the matrix H. N .GE. 0.
+*
+* ILO (input) INTEGER
+* IHI (input) INTEGER
+* It is assumed that H is already upper triangular in rows
+* and columns 1:ILO-1 and IHI+1:N and, if ILO.GT.1,
+* H(ILO,ILO-1) is zero. ILO and IHI are normally set by a
+* previous call to DGEBAL, and then passed to DGEHRD when the
+* matrix output by DGEBAL is reduced to Hessenberg form.
+* Otherwise, ILO and IHI should be set to 1 and N,
+* respectively. If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N.
+* If N = 0, then ILO = 1 and IHI = 0.
+*
+* H (input/output) DOUBLE PRECISION array, dimension (LDH,N)
+* On entry, the upper Hessenberg matrix H.
+* On exit, if INFO = 0 and WANTT is .TRUE., then H contains
+* the upper quasi-triangular matrix T from the Schur
+* decomposition (the Schur form); 2-by-2 diagonal blocks
+* (corresponding to complex conjugate pairs of eigenvalues)
+* are returned in standard form, with H(i,i) = H(i+1,i+1)
+* and H(i+1,i)*H(i,i+1).LT.0. If INFO = 0 and WANTT is
+* .FALSE., then the contents of H are unspecified on exit.
+* (The output value of H when INFO.GT.0 is given under the
+* description of INFO below.)
+*
+* This subroutine may explicitly set H(i,j) = 0 for i.GT.j and
+* j = 1, 2, ... ILO-1 or j = IHI+1, IHI+2, ... N.
+*
+* LDH (input) INTEGER
+* The leading dimension of the array H. LDH .GE. max(1,N).
+*
+* WR (output) DOUBLE PRECISION array, dimension (IHI)
+* WI (output) DOUBLE PRECISION array, dimension (IHI)
+* The real and imaginary parts, respectively, of the computed
+* eigenvalues of H(ILO:IHI,ILO:IHI) are stored WR(ILO:IHI)
+* and WI(ILO:IHI). If two eigenvalues are computed as a
+* complex conjugate pair, they are stored in consecutive
+* elements of WR and WI, say the i-th and (i+1)th, with
+* WI(i) .GT. 0 and WI(i+1) .LT. 0. If WANTT is .TRUE., then
+* the eigenvalues are stored in the same order as on the
+* diagonal of the Schur form returned in H, with
+* WR(i) = H(i,i) and, if H(i:i+1,i:i+1) is a 2-by-2 diagonal
+* block, WI(i) = sqrt(-H(i+1,i)*H(i,i+1)) and
+* WI(i+1) = -WI(i).
+*
+* ILOZ (input) INTEGER
+* IHIZ (input) INTEGER
+* Specify the rows of Z to which transformations must be
+* applied if WANTZ is .TRUE..
+* 1 .LE. ILOZ .LE. ILO; IHI .LE. IHIZ .LE. N.
+*
+* Z (input/output) DOUBLE PRECISION array, dimension (LDZ,IHI)
+* If WANTZ is .FALSE., then Z is not referenced.
+* If WANTZ is .TRUE., then Z(ILO:IHI,ILOZ:IHIZ) is
+* replaced by Z(ILO:IHI,ILOZ:IHIZ)*U where U is the
+* orthogonal Schur factor of H(ILO:IHI,ILO:IHI).
+* (The output value of Z when INFO.GT.0 is given under
+* the description of INFO below.)
+*
+* LDZ (input) INTEGER
+* The leading dimension of the array Z. if WANTZ is .TRUE.
+* then LDZ.GE.MAX(1,IHIZ). Otherwize, LDZ.GE.1.
+*
+* WORK (workspace/output) DOUBLE PRECISION array, dimension LWORK
+* On exit, if LWORK = -1, WORK(1) returns an estimate of
+* the optimal value for LWORK.
+*
+* LWORK (input) INTEGER
+* The dimension of the array WORK. LWORK .GE. max(1,N)
+* is sufficient, but LWORK typically as large as 6*N may
+* be required for optimal performance. A workspace query
+* to determine the optimal workspace size is recommended.
+*
+* If LWORK = -1, then DLAQR4 does a workspace query.
+* In this case, DLAQR4 checks the input parameters and
+* estimates the optimal workspace size for the given
+* values of N, ILO and IHI. The estimate is returned
+* in WORK(1). No error message related to LWORK is
+* issued by XERBLA. Neither H nor Z are accessed.
+*
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* .GT. 0: if INFO = i, DLAQR4 failed to compute all of
+* the eigenvalues. Elements 1:ilo-1 and i+1:n of WR
+* and WI contain those eigenvalues which have been
+* successfully computed. (Failures are rare.)
+*
+* If INFO .GT. 0 and WANT is .FALSE., then on exit,
+* the remaining unconverged eigenvalues are the eigen-
+* values of the upper Hessenberg matrix rows and
+* columns ILO through INFO of the final, output
+* value of H.
+*
+* If INFO .GT. 0 and WANTT is .TRUE., then on exit
+*
+* (*) (initial value of H)*U = U*(final value of H)
+*
+* where U is an orthogonal matrix. The final
+* value of H is upper Hessenberg and quasi-triangular
+* in rows and columns INFO+1 through IHI.
+*
+* If INFO .GT. 0 and WANTZ is .TRUE., then on exit
+*
+* (final value of Z(ILO:IHI,ILOZ:IHIZ)
+* = (initial value of Z(ILO:IHI,ILOZ:IHIZ)*U
+*
+* where U is the orthogonal matrix in (*) (regard-
+* less of the value of WANTT.)
+*
+* If INFO .GT. 0 and WANTZ is .FALSE., then Z is not
+* accessed.
+*
+* ================================================================
+* Based on contributions by
+* Karen Braman and Ralph Byers, Department of Mathematics,
+* University of Kansas, USA
+*
+* ================================================================
+* References:
+* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR
+* Algorithm Part I: Maintaining Well Focused Shifts, and Level 3
+* Performance, SIAM Journal of Matrix Analysis, volume 23, pages
+* 929--947, 2002.
+*
+* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR
+* Algorithm Part II: Aggressive Early Deflation, SIAM Journal
+* of Matrix Analysis, volume 23, pages 948--973, 2002.
+*
+* ================================================================
+* .. Parameters ..
+*
+* ==== Matrices of order NTINY or smaller must be processed by
+* . DLAHQR because of insufficient subdiagonal scratch space.
+* . (This is a hard limit.) ====
+*
+* ==== Exceptional deflation windows: try to cure rare
+* . slow convergence by increasing the size of the
+* . deflation window after KEXNW iterations. =====
+*
+* ==== Exceptional shifts: try to cure rare slow convergence
+* . with ad-hoc exceptional shifts every KEXSH iterations.
+* . The constants WILK1 and WILK2 are used to form the
+* . exceptional shifts. ====
+*
+ INTEGER NTINY
+ PARAMETER ( NTINY = 11 )
+ INTEGER KEXNW, KEXSH
+ PARAMETER ( KEXNW = 5, KEXSH = 6 )
+ DOUBLE PRECISION WILK1, WILK2
+ PARAMETER ( WILK1 = 0.75d0, WILK2 = -0.4375d0 )
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0d0, ONE = 1.0d0 )
+* ..
+* .. Local Scalars ..
+ DOUBLE PRECISION AA, BB, CC, CS, DD, SN, SS, SWAP
+ INTEGER I, INF, IT, ITMAX, K, KACC22, KBOT, KDU, KS,
+ $ KT, KTOP, KU, KV, KWH, KWTOP, KWV, LD, LS,
+ $ LWKOPT, NDFL, NH, NHO, NIBBLE, NMIN, NS, NSMAX,
+ $ NSR, NVE, NW, NWMAX, NWR
+ LOGICAL NWINC, SORTED
+ CHARACTER JBCMPZ*2
+* ..
+* .. External Functions ..
+ INTEGER ILAENV
+ EXTERNAL ILAENV
+* ..
+* .. Local Arrays ..
+ DOUBLE PRECISION ZDUM( 1, 1 )
+* ..
+* .. External Subroutines ..
+ EXTERNAL DLACPY, DLAHQR, DLANV2, DLAQR2, DLAQR5
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, DBLE, INT, MAX, MIN, MOD
+* ..
+* .. Executable Statements ..
+ INFO = 0
+*
+* ==== Quick return for N = 0: nothing to do. ====
+*
+ IF( N.EQ.0 ) THEN
+ WORK( 1 ) = ONE
+ RETURN
+ END IF
+*
+* ==== Set up job flags for ILAENV. ====
+*
+ IF( WANTT ) THEN
+ JBCMPZ( 1: 1 ) = 'S'
+ ELSE
+ JBCMPZ( 1: 1 ) = 'E'
+ END IF
+ IF( WANTZ ) THEN
+ JBCMPZ( 2: 2 ) = 'V'
+ ELSE
+ JBCMPZ( 2: 2 ) = 'N'
+ END IF
+*
+* ==== Tiny matrices must use DLAHQR. ====
+*
+ IF( N.LE.NTINY ) THEN
+*
+* ==== Estimate optimal workspace. ====
+*
+ LWKOPT = 1
+ IF( LWORK.NE.-1 )
+ $ CALL DLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI,
+ $ ILOZ, IHIZ, Z, LDZ, INFO )
+ ELSE
+*
+* ==== Use small bulge multi-shift QR with aggressive early
+* . deflation on larger-than-tiny matrices. ====
+*
+* ==== Hope for the best. ====
+*
+ INFO = 0
+*
+* ==== NWR = recommended deflation window size. At this
+* . point, N .GT. NTINY = 11, so there is enough
+* . subdiagonal workspace for NWR.GE.2 as required.
+* . (In fact, there is enough subdiagonal space for
+* . NWR.GE.3.) ====
+*
+ NWR = ILAENV( 13, 'DLAQR4', JBCMPZ, N, ILO, IHI, LWORK )
+ NWR = MAX( 2, NWR )
+ NWR = MIN( IHI-ILO+1, ( N-1 ) / 3, NWR )
+ NW = NWR
+*
+* ==== NSR = recommended number of simultaneous shifts.
+* . At this point N .GT. NTINY = 11, so there is at
+* . enough subdiagonal workspace for NSR to be even
+* . and greater than or equal to two as required. ====
+*
+ NSR = ILAENV( 15, 'DLAQR4', JBCMPZ, N, ILO, IHI, LWORK )
+ NSR = MIN( NSR, ( N+6 ) / 9, IHI-ILO )
+ NSR = MAX( 2, NSR-MOD( NSR, 2 ) )
+*
+* ==== Estimate optimal workspace ====
+*
+* ==== Workspace query call to DLAQR2 ====
+*
+ CALL DLAQR2( WANTT, WANTZ, N, ILO, IHI, NWR+1, H, LDH, ILOZ,
+ $ IHIZ, Z, LDZ, LS, LD, WR, WI, H, LDH, N, H, LDH,
+ $ N, H, LDH, WORK, -1 )
+*
+* ==== Optimal workspace = MAX(DLAQR5, DLAQR2) ====
+*
+ LWKOPT = MAX( 3*NSR / 2, INT( WORK( 1 ) ) )
+*
+* ==== Quick return in case of workspace query. ====
+*
+ IF( LWORK.EQ.-1 ) THEN
+ WORK( 1 ) = DBLE( LWKOPT )
+ RETURN
+ END IF
+*
+* ==== DLAHQR/DLAQR0 crossover point ====
+*
+ NMIN = ILAENV( 12, 'DLAQR4', JBCMPZ, N, ILO, IHI, LWORK )
+ NMIN = MAX( NTINY, NMIN )
+*
+* ==== Nibble crossover point ====
+*
+ NIBBLE = ILAENV( 14, 'DLAQR4', JBCMPZ, N, ILO, IHI, LWORK )
+ NIBBLE = MAX( 0, NIBBLE )
+*
+* ==== Accumulate reflections during ttswp? Use block
+* . 2-by-2 structure during matrix-matrix multiply? ====
+*
+ KACC22 = ILAENV( 16, 'DLAQR4', JBCMPZ, N, ILO, IHI, LWORK )
+ KACC22 = MAX( 0, KACC22 )
+ KACC22 = MIN( 2, KACC22 )
+*
+* ==== NWMAX = the largest possible deflation window for
+* . which there is sufficient workspace. ====
+*
+ NWMAX = MIN( ( N-1 ) / 3, LWORK / 2 )
+*
+* ==== NSMAX = the Largest number of simultaneous shifts
+* . for which there is sufficient workspace. ====
+*
+ NSMAX = MIN( ( N+6 ) / 9, 2*LWORK / 3 )
+ NSMAX = NSMAX - MOD( NSMAX, 2 )
+*
+* ==== NDFL: an iteration count restarted at deflation. ====
+*
+ NDFL = 1
+*
+* ==== ITMAX = iteration limit ====
+*
+ ITMAX = MAX( 30, 2*KEXSH )*MAX( 10, ( IHI-ILO+1 ) )
+*
+* ==== Last row and column in the active block ====
+*
+ KBOT = IHI
+*
+* ==== Main Loop ====
+*
+ DO 80 IT = 1, ITMAX
+*
+* ==== Done when KBOT falls below ILO ====
+*
+ IF( KBOT.LT.ILO )
+ $ GO TO 90
+*
+* ==== Locate active block ====
+*
+ DO 10 K = KBOT, ILO + 1, -1
+ IF( H( K, K-1 ).EQ.ZERO )
+ $ GO TO 20
+ 10 CONTINUE
+ K = ILO
+ 20 CONTINUE
+ KTOP = K
+*
+* ==== Select deflation window size ====
+*
+ NH = KBOT - KTOP + 1
+ IF( NDFL.LT.KEXNW .OR. NH.LT.NW ) THEN
+*
+* ==== Typical deflation window. If possible and
+* . advisable, nibble the entire active block.
+* . If not, use size NWR or NWR+1 depending upon
+* . which has the smaller corresponding subdiagonal
+* . entry (a heuristic). ====
+*
+ NWINC = .TRUE.
+ IF( NH.LE.MIN( NMIN, NWMAX ) ) THEN
+ NW = NH
+ ELSE
+ NW = MIN( NWR, NH, NWMAX )
+ IF( NW.LT.NWMAX ) THEN
+ IF( NW.GE.NH-1 ) THEN
+ NW = NH
+ ELSE
+ KWTOP = KBOT - NW + 1
+ IF( ABS( H( KWTOP, KWTOP-1 ) ).GT.
+ $ ABS( H( KWTOP-1, KWTOP-2 ) ) )NW = NW + 1
+ END IF
+ END IF
+ END IF
+ ELSE
+*
+* ==== Exceptional deflation window. If there have
+* . been no deflations in KEXNW or more iterations,
+* . then vary the deflation window size. At first,
+* . because, larger windows are, in general, more
+* . powerful than smaller ones, rapidly increase the
+* . window up to the maximum reasonable and possible.
+* . Then maybe try a slightly smaller window. ====
+*
+ IF( NWINC .AND. NW.LT.MIN( NWMAX, NH ) ) THEN
+ NW = MIN( NWMAX, NH, 2*NW )
+ ELSE
+ NWINC = .FALSE.
+ IF( NW.EQ.NH .AND. NH.GT.2 )
+ $ NW = NH - 1
+ END IF
+ END IF
+*
+* ==== Aggressive early deflation:
+* . split workspace under the subdiagonal into
+* . - an nw-by-nw work array V in the lower
+* . left-hand-corner,
+* . - an NW-by-at-least-NW-but-more-is-better
+* . (NW-by-NHO) horizontal work array along
+* . the bottom edge,
+* . - an at-least-NW-but-more-is-better (NHV-by-NW)
+* . vertical work array along the left-hand-edge.
+* . ====
+*
+ KV = N - NW + 1
+ KT = NW + 1
+ NHO = ( N-NW-1 ) - KT + 1
+ KWV = NW + 2
+ NVE = ( N-NW ) - KWV + 1
+*
+* ==== Aggressive early deflation ====
+*
+ CALL DLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ,
+ $ IHIZ, Z, LDZ, LS, LD, WR, WI, H( KV, 1 ), LDH,
+ $ NHO, H( KV, KT ), LDH, NVE, H( KWV, 1 ), LDH,
+ $ WORK, LWORK )
+*
+* ==== Adjust KBOT accounting for new deflations. ====
+*
+ KBOT = KBOT - LD
+*
+* ==== KS points to the shifts. ====
+*
+ KS = KBOT - LS + 1
+*
+* ==== Skip an expensive QR sweep if there is a (partly
+* . heuristic) reason to expect that many eigenvalues
+* . will deflate without it. Here, the QR sweep is
+* . skipped if many eigenvalues have just been deflated
+* . or if the remaining active block is small.
+*
+ IF( ( LD.EQ.0 ) .OR. ( ( 100*LD.LE.NW*NIBBLE ) .AND. ( KBOT-
+ $ KTOP+1.GT.MIN( NMIN, NWMAX ) ) ) ) THEN
+*
+* ==== NS = nominal number of simultaneous shifts.
+* . This may be lowered (slightly) if DLAQR2
+* . did not provide that many shifts. ====
+*
+ NS = MIN( NSMAX, NSR, MAX( 2, KBOT-KTOP ) )
+ NS = NS - MOD( NS, 2 )
+*
+* ==== If there have been no deflations
+* . in a multiple of KEXSH iterations,
+* . then try exceptional shifts.
+* . Otherwise use shifts provided by
+* . DLAQR2 above or from the eigenvalues
+* . of a trailing principal submatrix. ====
+*
+ IF( MOD( NDFL, KEXSH ).EQ.0 ) THEN
+ KS = KBOT - NS + 1
+ DO 30 I = KBOT, MAX( KS+1, KTOP+2 ), -2
+ SS = ABS( H( I, I-1 ) ) + ABS( H( I-1, I-2 ) )
+ AA = WILK1*SS + H( I, I )
+ BB = SS
+ CC = WILK2*SS
+ DD = AA
+ CALL DLANV2( AA, BB, CC, DD, WR( I-1 ), WI( I-1 ),
+ $ WR( I ), WI( I ), CS, SN )
+ 30 CONTINUE
+ IF( KS.EQ.KTOP ) THEN
+ WR( KS+1 ) = H( KS+1, KS+1 )
+ WI( KS+1 ) = ZERO
+ WR( KS ) = WR( KS+1 )
+ WI( KS ) = WI( KS+1 )
+ END IF
+ ELSE
+*
+* ==== Got NS/2 or fewer shifts? Use DLAHQR
+* . on a trailing principal submatrix to
+* . get more. (Since NS.LE.NSMAX.LE.(N+6)/9,
+* . there is enough space below the subdiagonal
+* . to fit an NS-by-NS scratch array.) ====
+*
+ IF( KBOT-KS+1.LE.NS / 2 ) THEN
+ KS = KBOT - NS + 1
+ KT = N - NS + 1
+ CALL DLACPY( 'A', NS, NS, H( KS, KS ), LDH,
+ $ H( KT, 1 ), LDH )
+ CALL DLAHQR( .false., .false., NS, 1, NS,
+ $ H( KT, 1 ), LDH, WR( KS ), WI( KS ),
+ $ 1, 1, ZDUM, 1, INF )
+ KS = KS + INF
+*
+* ==== In case of a rare QR failure use
+* . eigenvalues of the trailing 2-by-2
+* . principal submatrix. ====
+*
+ IF( KS.GE.KBOT ) THEN
+ AA = H( KBOT-1, KBOT-1 )
+ CC = H( KBOT, KBOT-1 )
+ BB = H( KBOT-1, KBOT )
+ DD = H( KBOT, KBOT )
+ CALL DLANV2( AA, BB, CC, DD, WR( KBOT-1 ),
+ $ WI( KBOT-1 ), WR( KBOT ),
+ $ WI( KBOT ), CS, SN )
+ KS = KBOT - 1
+ END IF
+ END IF
+*
+ IF( KBOT-KS+1.GT.NS ) THEN
+*
+* ==== Sort the shifts (Helps a little)
+* . Bubble sort keeps complex conjugate
+* . pairs together. ====
+*
+ SORTED = .false.
+ DO 50 K = KBOT, KS + 1, -1
+ IF( SORTED )
+ $ GO TO 60
+ SORTED = .true.
+ DO 40 I = KS, K - 1
+ IF( ABS( WR( I ) )+ABS( WI( I ) ).LT.
+ $ ABS( WR( I+1 ) )+ABS( WI( I+1 ) ) ) THEN
+ SORTED = .false.
+*
+ SWAP = WR( I )
+ WR( I ) = WR( I+1 )
+ WR( I+1 ) = SWAP
+*
+ SWAP = WI( I )
+ WI( I ) = WI( I+1 )
+ WI( I+1 ) = SWAP
+ END IF
+ 40 CONTINUE
+ 50 CONTINUE
+ 60 CONTINUE
+ END IF
+*
+* ==== Shuffle shifts into pairs of real shifts
+* . and pairs of complex conjugate shifts
+* . assuming complex conjugate shifts are
+* . already adjacent to one another. (Yes,
+* . they are.) ====
+*
+ DO 70 I = KBOT, KS + 2, -2
+ IF( WI( I ).NE.-WI( I-1 ) ) THEN
+*
+ SWAP = WR( I )
+ WR( I ) = WR( I-1 )
+ WR( I-1 ) = WR( I-2 )
+ WR( I-2 ) = SWAP
+*
+ SWAP = WI( I )
+ WI( I ) = WI( I-1 )
+ WI( I-1 ) = WI( I-2 )
+ WI( I-2 ) = SWAP
+ END IF
+ 70 CONTINUE
+ END IF
+*
+* ==== If there are only two shifts and both are
+* . real, then use only one. ====
+*
+ IF( KBOT-KS+1.EQ.2 ) THEN
+ IF( WI( KBOT ).EQ.ZERO ) THEN
+ IF( ABS( WR( KBOT )-H( KBOT, KBOT ) ).LT.
+ $ ABS( WR( KBOT-1 )-H( KBOT, KBOT ) ) ) THEN
+ WR( KBOT-1 ) = WR( KBOT )
+ ELSE
+ WR( KBOT ) = WR( KBOT-1 )
+ END IF
+ END IF
+ END IF
+*
+* ==== Use up to NS of the the smallest magnatiude
+* . shifts. If there aren't NS shifts available,
+* . then use them all, possibly dropping one to
+* . make the number of shifts even. ====
+*
+ NS = MIN( NS, KBOT-KS+1 )
+ NS = NS - MOD( NS, 2 )
+ KS = KBOT - NS + 1
+*
+* ==== Small-bulge multi-shift QR sweep:
+* . split workspace under the subdiagonal into
+* . - a KDU-by-KDU work array U in the lower
+* . left-hand-corner,
+* . - a KDU-by-at-least-KDU-but-more-is-better
+* . (KDU-by-NHo) horizontal work array WH along
+* . the bottom edge,
+* . - and an at-least-KDU-but-more-is-better-by-KDU
+* . (NVE-by-KDU) vertical work WV arrow along
+* . the left-hand-edge. ====
+*
+ KDU = 3*NS - 3
+ KU = N - KDU + 1
+ KWH = KDU + 1
+ NHO = ( N-KDU+1-4 ) - ( KDU+1 ) + 1
+ KWV = KDU + 4
+ NVE = N - KDU - KWV + 1
+*
+* ==== Small-bulge multi-shift QR sweep ====
+*
+ CALL DLAQR5( WANTT, WANTZ, KACC22, N, KTOP, KBOT, NS,
+ $ WR( KS ), WI( KS ), H, LDH, ILOZ, IHIZ, Z,
+ $ LDZ, WORK, 3, H( KU, 1 ), LDH, NVE,
+ $ H( KWV, 1 ), LDH, NHO, H( KU, KWH ), LDH )
+ END IF
+*
+* ==== Note progress (or the lack of it). ====
+*
+ IF( LD.GT.0 ) THEN
+ NDFL = 1
+ ELSE
+ NDFL = NDFL + 1
+ END IF
+*
+* ==== End of main loop ====
+ 80 CONTINUE
+*
+* ==== Iteration limit exceeded. Set INFO to show where
+* . the problem occurred and exit. ====
+*
+ INFO = KBOT
+ 90 CONTINUE
+ END IF
+*
+* ==== Return the optimal value of LWORK. ====
+*
+ WORK( 1 ) = DBLE( LWKOPT )
+*
+* ==== End of DLAQR4 ====
+*
+ END
+ 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 )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER IHIZ, ILOZ, KACC22, KBOT, KTOP, LDH, LDU, LDV,
+ $ LDWH, LDWV, LDZ, N, NH, NSHFTS, NV
+ LOGICAL WANTT, WANTZ
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION H( LDH, * ), SI( * ), SR( * ), U( LDU, * ),
+ $ V( LDV, * ), WH( LDWH, * ), WV( LDWV, * ),
+ $ Z( LDZ, * )
+* ..
+*
+* This auxiliary subroutine called by DLAQR0 performs a
+* single small-bulge multi-shift QR sweep.
+*
+* WANTT (input) logical scalar
+* WANTT = .true. if the quasi-triangular Schur factor
+* is being computed. WANTT is set to .false. otherwise.
+*
+* WANTZ (input) logical scalar
+* WANTZ = .true. if the orthogonal Schur factor is being
+* computed. WANTZ is set to .false. otherwise.
+*
+* KACC22 (input) integer with value 0, 1, or 2.
+* Specifies the computation mode of far-from-diagonal
+* orthogonal updates.
+* = 0: DLAQR5 does not accumulate reflections and does not
+* use matrix-matrix multiply to update far-from-diagonal
+* matrix entries.
+* = 1: DLAQR5 accumulates reflections and uses matrix-matrix
+* multiply to update the far-from-diagonal matrix entries.
+* = 2: DLAQR5 accumulates reflections, uses matrix-matrix
+* multiply to update the far-from-diagonal matrix entries,
+* and takes advantage of 2-by-2 block structure during
+* matrix multiplies.
+*
+* N (input) integer scalar
+* N is the order of the Hessenberg matrix H upon which this
+* subroutine operates.
+*
+* KTOP (input) integer scalar
+* KBOT (input) integer scalar
+* These are the first and last rows and columns of an
+* isolated diagonal block upon which the QR sweep is to be
+* applied. It is assumed without a check that
+* either KTOP = 1 or H(KTOP,KTOP-1) = 0
+* and
+* either KBOT = N or H(KBOT+1,KBOT) = 0.
+*
+* NSHFTS (input) integer scalar
+* NSHFTS gives the number of simultaneous shifts. NSHFTS
+* must be positive and even.
+*
+* SR (input) DOUBLE PRECISION array of size (NSHFTS)
+* SI (input) DOUBLE PRECISION array of size (NSHFTS)
+* SR contains the real parts and SI contains the imaginary
+* parts of the NSHFTS shifts of origin that define the
+* multi-shift QR sweep.
+*
+* H (input/output) DOUBLE PRECISION array of size (LDH,N)
+* On input H contains a Hessenberg matrix. On output a
+* multi-shift QR sweep with shifts SR(J)+i*SI(J) is applied
+* to the isolated diagonal block in rows and columns KTOP
+* through KBOT.
+*
+* LDH (input) integer scalar
+* LDH is the leading dimension of H just as declared in the
+* calling procedure. LDH.GE.MAX(1,N).
+*
+* ILOZ (input) INTEGER
+* IHIZ (input) INTEGER
+* Specify the rows of Z to which transformations must be
+* applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N
+*
+* Z (input/output) DOUBLE PRECISION array of size (LDZ,IHI)
+* If WANTZ = .TRUE., then the QR Sweep orthogonal
+* similarity transformation is accumulated into
+* Z(ILOZ:IHIZ,ILO:IHI) from the right.
+* If WANTZ = .FALSE., then Z is unreferenced.
+*
+* LDZ (input) integer scalar
+* LDA is the leading dimension of Z just as declared in
+* the calling procedure. LDZ.GE.N.
+*
+* V (workspace) DOUBLE PRECISION array of size (LDV,NSHFTS/2)
+*
+* LDV (input) integer scalar
+* LDV is the leading dimension of V as declared in the
+* calling procedure. LDV.GE.3.
+*
+* U (workspace) DOUBLE PRECISION array of size
+* (LDU,3*NSHFTS-3)
+*
+* LDU (input) integer scalar
+* LDU is the leading dimension of U just as declared in the
+* in the calling subroutine. LDU.GE.3*NSHFTS-3.
+*
+* NH (input) integer scalar
+* NH is the number of columns in array WH available for
+* workspace. NH.GE.1.
+*
+* WH (workspace) DOUBLE PRECISION array of size (LDWH,NH)
+*
+* LDWH (input) integer scalar
+* Leading dimension of WH just as declared in the
+* calling procedure. LDWH.GE.3*NSHFTS-3.
+*
+* NV (input) integer scalar
+* NV is the number of rows in WV agailable for workspace.
+* NV.GE.1.
+*
+* WV (workspace) DOUBLE PRECISION array of size
+* (LDWV,3*NSHFTS-3)
+*
+* LDWV (input) integer scalar
+* LDWV is the leading dimension of WV as declared in the
+* in the calling subroutine. LDWV.GE.NV.
+*
+*
+* ================================================================
+* Based on contributions by
+* Karen Braman and Ralph Byers, Department of Mathematics,
+* University of Kansas, USA
+*
+* ============================================================
+* Reference:
+*
+* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR
+* Algorithm Part I: Maintaining Well Focused Shifts, and
+* Level 3 Performance, SIAM Journal of Matrix Analysis,
+* volume 23, pages 929--947, 2002.
+*
+* ============================================================
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0d0, ONE = 1.0d0 )
+* ..
+* .. Local Scalars ..
+ DOUBLE PRECISION ALPHA, BETA, H11, H12, H21, H22, REFSUM,
+ $ SAFMAX, SAFMIN, SCL, SMLNUM, SWAP, TST1, TST2,
+ $ ULP
+ INTEGER I, I2, I4, INCOL, J, J2, J4, JBOT, JCOL, JLEN,
+ $ JROW, JTOP, K, K1, KDU, KMS, KNZ, KRCOL, KZS,
+ $ M, M22, MBOT, MEND, MSTART, MTOP, NBMPS, NDCOL,
+ $ NS, NU
+ LOGICAL ACCUM, BLK22, BMP22
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DLAMCH
+ EXTERNAL DLAMCH
+* ..
+* .. Intrinsic Functions ..
+*
+ INTRINSIC ABS, DBLE, MAX, MIN, MOD
+* ..
+* .. Local Arrays ..
+ DOUBLE PRECISION VT( 3 )
+* ..
+* .. External Subroutines ..
+ EXTERNAL DGEMM, DLABAD, DLACPY, DLAQR1, DLARFG, DLASET,
+ $ DTRMM
+* ..
+* .. Executable Statements ..
+*
+* ==== If there are no shifts, then there is nothing to do. ====
+*
+ IF( NSHFTS.LT.2 )
+ $ RETURN
+*
+* ==== If the active block is empty or 1-by-1, then there
+* . is nothing to do. ====
+*
+ IF( KTOP.GE.KBOT )
+ $ RETURN
+*
+* ==== Shuffle shifts into pairs of real shifts and pairs
+* . of complex conjugate shifts assuming complex
+* . conjugate shifts are already adjacent to one
+* . another. ====
+*
+ DO 10 I = 1, NSHFTS - 2, 2
+ IF( SI( I ).NE.-SI( I+1 ) ) THEN
+*
+ SWAP = SR( I )
+ SR( I ) = SR( I+1 )
+ SR( I+1 ) = SR( I+2 )
+ SR( I+2 ) = SWAP
+*
+ SWAP = SI( I )
+ SI( I ) = SI( I+1 )
+ SI( I+1 ) = SI( I+2 )
+ SI( I+2 ) = SWAP
+ END IF
+ 10 CONTINUE
+*
+* ==== NSHFTS is supposed to be even, but if is odd,
+* . then simply reduce it by one. The shuffle above
+* . ensures that the dropped shift is real and that
+* . the remaining shifts are paired. ====
+*
+ NS = NSHFTS - MOD( NSHFTS, 2 )
+*
+* ==== Machine constants for deflation ====
+*
+ SAFMIN = DLAMCH( 'SAFE MINIMUM' )
+ SAFMAX = ONE / SAFMIN
+ CALL DLABAD( SAFMIN, SAFMAX )
+ ULP = DLAMCH( 'PRECISION' )
+ SMLNUM = SAFMIN*( DBLE( N ) / ULP )
+*
+* ==== Use accumulated reflections to update far-from-diagonal
+* . entries ? ====
+*
+ ACCUM = ( KACC22.EQ.1 ) .OR. ( KACC22.EQ.2 )
+*
+* ==== If so, exploit the 2-by-2 block structure? ====
+*
+ BLK22 = ( NS.GT.2 ) .AND. ( KACC22.EQ.2 )
+*
+* ==== clear trash ====
+*
+ IF( KTOP+2.LE.KBOT )
+ $ H( KTOP+2, KTOP ) = ZERO
+*
+* ==== NBMPS = number of 2-shift bulges in the chain ====
+*
+ NBMPS = NS / 2
+*
+* ==== KDU = width of slab ====
+*
+ KDU = 6*NBMPS - 3
+*
+* ==== Create and chase chains of NBMPS bulges ====
+*
+ DO 220 INCOL = 3*( 1-NBMPS ) + KTOP - 1, KBOT - 2, 3*NBMPS - 2
+ NDCOL = INCOL + KDU
+ IF( ACCUM )
+ $ CALL DLASET( 'ALL', KDU, KDU, ZERO, ONE, U, LDU )
+*
+* ==== Near-the-diagonal bulge chase. The following loop
+* . performs the near-the-diagonal part of a small bulge
+* . multi-shift QR sweep. Each 6*NBMPS-2 column diagonal
+* . chunk extends from column INCOL to column NDCOL
+* . (including both column INCOL and column NDCOL). The
+* . following loop chases a 3*NBMPS column long chain of
+* . NBMPS bulges 3*NBMPS-2 columns to the right. (INCOL
+* . may be less than KTOP and and NDCOL may be greater than
+* . KBOT indicating phantom columns from which to chase
+* . bulges before they are actually introduced or to which
+* . to chase bulges beyond column KBOT.) ====
+*
+ DO 150 KRCOL = INCOL, MIN( INCOL+3*NBMPS-3, KBOT-2 )
+*
+* ==== Bulges number MTOP to MBOT are active double implicit
+* . shift bulges. There may or may not also be small
+* . 2-by-2 bulge, if there is room. The inactive bulges
+* . (if any) must wait until the active bulges have moved
+* . down the diagonal to make room. The phantom matrix
+* . paradigm described above helps keep track. ====
+*
+ MTOP = MAX( 1, ( ( KTOP-1 )-KRCOL+2 ) / 3+1 )
+ MBOT = MIN( NBMPS, ( KBOT-KRCOL ) / 3 )
+ M22 = MBOT + 1
+ BMP22 = ( MBOT.LT.NBMPS ) .AND. ( KRCOL+3*( M22-1 ) ).EQ.
+ $ ( KBOT-2 )
+*
+* ==== Generate reflections to chase the chain right
+* . one column. (The minimum value of K is KTOP-1.) ====
+*
+ DO 20 M = MTOP, MBOT
+ K = KRCOL + 3*( M-1 )
+ IF( K.EQ.KTOP-1 ) THEN
+ CALL DLAQR1( 3, H( KTOP, KTOP ), LDH, SR( 2*M-1 ),
+ $ SI( 2*M-1 ), SR( 2*M ), SI( 2*M ),
+ $ V( 1, M ) )
+ ALPHA = V( 1, M )
+ CALL DLARFG( 3, ALPHA, V( 2, M ), 1, V( 1, M ) )
+ ELSE
+ BETA = H( K+1, K )
+ V( 2, M ) = H( K+2, K )
+ V( 3, M ) = H( K+3, K )
+ CALL DLARFG( 3, BETA, V( 2, M ), 1, V( 1, M ) )
+*
+* ==== A Bulge may collapse because of vigilant
+* . deflation or destructive underflow. (The
+* . initial bulge is always collapsed.) Use
+* . the two-small-subdiagonals trick to try
+* . to get it started again. If V(2,M).NE.0 and
+* . V(3,M) = H(K+3,K+1) = H(K+3,K+2) = 0, then
+* . this bulge is collapsing into a zero
+* . subdiagonal. It will be restarted next
+* . trip through the loop.)
+*
+ IF( V( 1, M ).NE.ZERO .AND.
+ $ ( V( 3, M ).NE.ZERO .OR. ( H( K+3,
+ $ K+1 ).EQ.ZERO .AND. H( K+3, K+2 ).EQ.ZERO ) ) )
+ $ THEN
+*
+* ==== Typical case: not collapsed (yet). ====
+*
+ H( K+1, K ) = BETA
+ H( K+2, K ) = ZERO
+ H( K+3, K ) = ZERO
+ ELSE
+*
+* ==== Atypical case: collapsed. Attempt to
+* . reintroduce ignoring H(K+1,K). If the
+* . fill resulting from the new reflector
+* . is too large, then abandon it.
+* . Otherwise, use the new one. ====
+*
+ CALL DLAQR1( 3, H( K+1, K+1 ), LDH, SR( 2*M-1 ),
+ $ SI( 2*M-1 ), SR( 2*M ), SI( 2*M ),
+ $ VT )
+ SCL = ABS( VT( 1 ) ) + ABS( VT( 2 ) ) +
+ $ ABS( VT( 3 ) )
+ IF( SCL.NE.ZERO ) THEN
+ VT( 1 ) = VT( 1 ) / SCL
+ VT( 2 ) = VT( 2 ) / SCL
+ VT( 3 ) = VT( 3 ) / SCL
+ END IF
+*
+* ==== The following is the traditional and
+* . conservative two-small-subdiagonals
+* . test. ====
+* .
+ IF( ABS( H( K+1, K ) )*( ABS( VT( 2 ) )+
+ $ ABS( VT( 3 ) ) ).GT.ULP*ABS( VT( 1 ) )*
+ $ ( ABS( H( K, K ) )+ABS( H( K+1,
+ $ K+1 ) )+ABS( H( K+2, K+2 ) ) ) ) THEN
+*
+* ==== Starting a new bulge here would
+* . create non-negligible fill. If
+* . the old reflector is diagonal (only
+* . possible with underflows), then
+* . change it to I. Otherwise, use
+* . it with trepidation. ====
+*
+ IF( V( 2, M ).EQ.ZERO .AND. V( 3, M ).EQ.ZERO )
+ $ THEN
+ V( 1, M ) = ZERO
+ ELSE
+ H( K+1, K ) = BETA
+ H( K+2, K ) = ZERO
+ H( K+3, K ) = ZERO
+ END IF
+ ELSE
+*
+* ==== Stating a new bulge here would
+* . create only negligible fill.
+* . Replace the old reflector with
+* . the new one. ====
+*
+ ALPHA = VT( 1 )
+ CALL DLARFG( 3, ALPHA, VT( 2 ), 1, VT( 1 ) )
+ REFSUM = H( K+1, K ) + H( K+2, K )*VT( 2 ) +
+ $ H( K+3, K )*VT( 3 )
+ H( K+1, K ) = H( K+1, K ) - VT( 1 )*REFSUM
+ H( K+2, K ) = ZERO
+ H( K+3, K ) = ZERO
+ V( 1, M ) = VT( 1 )
+ V( 2, M ) = VT( 2 )
+ V( 3, M ) = VT( 3 )
+ END IF
+ END IF
+ END IF
+ 20 CONTINUE
+*
+* ==== Generate a 2-by-2 reflection, if needed. ====
+*
+ K = KRCOL + 3*( M22-1 )
+ IF( BMP22 ) THEN
+ IF( K.EQ.KTOP-1 ) THEN
+ CALL DLAQR1( 2, H( K+1, K+1 ), LDH, SR( 2*M22-1 ),
+ $ SI( 2*M22-1 ), SR( 2*M22 ), SI( 2*M22 ),
+ $ V( 1, M22 ) )
+ BETA = V( 1, M22 )
+ CALL DLARFG( 2, BETA, V( 2, M22 ), 1, V( 1, M22 ) )
+ ELSE
+ BETA = H( K+1, K )
+ V( 2, M22 ) = H( K+2, K )
+ CALL DLARFG( 2, BETA, V( 2, M22 ), 1, V( 1, M22 ) )
+ H( K+1, K ) = BETA
+ H( K+2, K ) = ZERO
+ END IF
+ ELSE
+*
+* ==== Initialize V(1,M22) here to avoid possible undefined
+* . variable problems later. ====
+*
+ V( 1, M22 ) = ZERO
+ END IF
+*
+* ==== Multiply H by reflections from the left ====
+*
+ IF( ACCUM ) THEN
+ JBOT = MIN( NDCOL, KBOT )
+ ELSE IF( WANTT ) THEN
+ JBOT = N
+ ELSE
+ JBOT = KBOT
+ END IF
+ DO 40 J = MAX( KTOP, KRCOL ), JBOT
+ MEND = MIN( MBOT, ( J-KRCOL+2 ) / 3 )
+ DO 30 M = MTOP, MEND
+ K = KRCOL + 3*( M-1 )
+ REFSUM = V( 1, M )*( H( K+1, J )+V( 2, M )*
+ $ H( K+2, J )+V( 3, M )*H( K+3, J ) )
+ H( K+1, J ) = H( K+1, J ) - REFSUM
+ H( K+2, J ) = H( K+2, J ) - REFSUM*V( 2, M )
+ H( K+3, J ) = H( K+3, J ) - REFSUM*V( 3, M )
+ 30 CONTINUE
+ 40 CONTINUE
+ IF( BMP22 ) THEN
+ K = KRCOL + 3*( M22-1 )
+ DO 50 J = MAX( K+1, KTOP ), JBOT
+ REFSUM = V( 1, M22 )*( H( K+1, J )+V( 2, M22 )*
+ $ H( K+2, J ) )
+ H( K+1, J ) = H( K+1, J ) - REFSUM
+ H( K+2, J ) = H( K+2, J ) - REFSUM*V( 2, M22 )
+ 50 CONTINUE
+ END IF
+*
+* ==== Multiply H by reflections from the right.
+* . Delay filling in the last row until the
+* . vigilant deflation check is complete. ====
+*
+ IF( ACCUM ) THEN
+ JTOP = MAX( KTOP, INCOL )
+ ELSE IF( WANTT ) THEN
+ JTOP = 1
+ ELSE
+ JTOP = KTOP
+ END IF
+ DO 90 M = MTOP, MBOT
+ IF( V( 1, M ).NE.ZERO ) THEN
+ K = KRCOL + 3*( M-1 )
+ DO 60 J = JTOP, MIN( KBOT, K+3 )
+ REFSUM = V( 1, M )*( H( J, K+1 )+V( 2, M )*
+ $ H( J, K+2 )+V( 3, M )*H( J, K+3 ) )
+ H( J, K+1 ) = H( J, K+1 ) - REFSUM
+ H( J, K+2 ) = H( J, K+2 ) - REFSUM*V( 2, M )
+ H( J, K+3 ) = H( J, K+3 ) - REFSUM*V( 3, M )
+ 60 CONTINUE
+*
+ IF( ACCUM ) THEN
+*
+* ==== Accumulate U. (If necessary, update Z later
+* . with with an efficient matrix-matrix
+* . multiply.) ====
+*
+ KMS = K - INCOL
+ DO 70 J = MAX( 1, KTOP-INCOL ), KDU
+ REFSUM = V( 1, M )*( U( J, KMS+1 )+V( 2, M )*
+ $ U( J, KMS+2 )+V( 3, M )*U( J, KMS+3 ) )
+ U( J, KMS+1 ) = U( J, KMS+1 ) - REFSUM
+ U( J, KMS+2 ) = U( J, KMS+2 ) - REFSUM*V( 2, M )
+ U( J, KMS+3 ) = U( J, KMS+3 ) - REFSUM*V( 3, M )
+ 70 CONTINUE
+ ELSE IF( WANTZ ) THEN
+*
+* ==== U is not accumulated, so update Z
+* . now by multiplying by reflections
+* . from the right. ====
+*
+ DO 80 J = ILOZ, IHIZ
+ REFSUM = V( 1, M )*( Z( J, K+1 )+V( 2, M )*
+ $ Z( J, K+2 )+V( 3, M )*Z( J, K+3 ) )
+ Z( J, K+1 ) = Z( J, K+1 ) - REFSUM
+ Z( J, K+2 ) = Z( J, K+2 ) - REFSUM*V( 2, M )
+ Z( J, K+3 ) = Z( J, K+3 ) - REFSUM*V( 3, M )
+ 80 CONTINUE
+ END IF
+ END IF
+ 90 CONTINUE
+*
+* ==== Special case: 2-by-2 reflection (if needed) ====
+*
+ K = KRCOL + 3*( M22-1 )
+ IF( BMP22 .AND. ( V( 1, M22 ).NE.ZERO ) ) THEN
+ DO 100 J = JTOP, MIN( KBOT, K+3 )
+ REFSUM = V( 1, M22 )*( H( J, K+1 )+V( 2, M22 )*
+ $ H( J, K+2 ) )
+ H( J, K+1 ) = H( J, K+1 ) - REFSUM
+ H( J, K+2 ) = H( J, K+2 ) - REFSUM*V( 2, M22 )
+ 100 CONTINUE
+*
+ IF( ACCUM ) THEN
+ KMS = K - INCOL
+ DO 110 J = MAX( 1, KTOP-INCOL ), KDU
+ REFSUM = V( 1, M22 )*( U( J, KMS+1 )+V( 2, M22 )*
+ $ U( J, KMS+2 ) )
+ U( J, KMS+1 ) = U( J, KMS+1 ) - REFSUM
+ U( J, KMS+2 ) = U( J, KMS+2 ) - REFSUM*V( 2, M22 )
+ 110 CONTINUE
+ ELSE IF( WANTZ ) THEN
+ DO 120 J = ILOZ, IHIZ
+ REFSUM = V( 1, M22 )*( Z( J, K+1 )+V( 2, M22 )*
+ $ Z( J, K+2 ) )
+ Z( J, K+1 ) = Z( J, K+1 ) - REFSUM
+ Z( J, K+2 ) = Z( J, K+2 ) - REFSUM*V( 2, M22 )
+ 120 CONTINUE
+ END IF
+ END IF
+*
+* ==== Vigilant deflation check ====
+*
+ MSTART = MTOP
+ IF( KRCOL+3*( MSTART-1 ).LT.KTOP )
+ $ MSTART = MSTART + 1
+ MEND = MBOT
+ IF( BMP22 )
+ $ MEND = MEND + 1
+ IF( KRCOL.EQ.KBOT-2 )
+ $ MEND = MEND + 1
+ DO 130 M = MSTART, MEND
+ K = MIN( KBOT-1, KRCOL+3*( M-1 ) )
+*
+* ==== The following convergence test requires that
+* . the tradition small-compared-to-nearby-diagonals
+* . criterion and the Ahues & Tisseur (LAWN 122, 1997)
+* . criteria both be satisfied. The latter improves
+* . accuracy in some examples. Falling back on an
+* . alternate convergence criterion when TST1 or TST2
+* . is zero (as done here) is traditional but probably
+* . unnecessary. ====
+*
+ IF( H( K+1, K ).NE.ZERO ) THEN
+ TST1 = ABS( H( K, K ) ) + ABS( H( K+1, K+1 ) )
+ IF( TST1.EQ.ZERO ) THEN
+ IF( K.GE.KTOP+1 )
+ $ TST1 = TST1 + ABS( H( K, K-1 ) )
+ IF( K.GE.KTOP+2 )
+ $ TST1 = TST1 + ABS( H( K, K-2 ) )
+ IF( K.GE.KTOP+3 )
+ $ TST1 = TST1 + ABS( H( K, K-3 ) )
+ IF( K.LE.KBOT-2 )
+ $ TST1 = TST1 + ABS( H( K+2, K+1 ) )
+ IF( K.LE.KBOT-3 )
+ $ TST1 = TST1 + ABS( H( K+3, K+1 ) )
+ IF( K.LE.KBOT-4 )
+ $ TST1 = TST1 + ABS( H( K+4, K+1 ) )
+ END IF
+ IF( ABS( H( K+1, K ) ).LE.MAX( SMLNUM, ULP*TST1 ) )
+ $ THEN
+ H12 = MAX( ABS( H( K+1, K ) ), ABS( H( K, K+1 ) ) )
+ H21 = MIN( ABS( H( K+1, K ) ), ABS( H( K, K+1 ) ) )
+ H11 = MAX( ABS( H( K+1, K+1 ) ),
+ $ ABS( H( K, K )-H( K+1, K+1 ) ) )
+ H22 = MIN( ABS( H( K+1, K+1 ) ),
+ $ ABS( H( K, K )-H( K+1, K+1 ) ) )
+ SCL = H11 + H12
+ TST2 = H22*( H11 / SCL )
+*
+ IF( TST2.EQ.ZERO .OR. H21*( H12 / SCL ).LE.
+ $ MAX( SMLNUM, ULP*TST2 ) )H( K+1, K ) = ZERO
+ END IF
+ END IF
+ 130 CONTINUE
+*
+* ==== Fill in the last row of each bulge. ====
+*
+ MEND = MIN( NBMPS, ( KBOT-KRCOL-1 ) / 3 )
+ DO 140 M = MTOP, MEND
+ K = KRCOL + 3*( M-1 )
+ REFSUM = V( 1, M )*V( 3, M )*H( K+4, K+3 )
+ H( K+4, K+1 ) = -REFSUM
+ H( K+4, K+2 ) = -REFSUM*V( 2, M )
+ H( K+4, K+3 ) = H( K+4, K+3 ) - REFSUM*V( 3, M )
+ 140 CONTINUE
+*
+* ==== End of near-the-diagonal bulge chase. ====
+*
+ 150 CONTINUE
+*
+* ==== Use U (if accumulated) to update far-from-diagonal
+* . entries in H. If required, use U to update Z as
+* . well. ====
+*
+ IF( ACCUM ) THEN
+ IF( WANTT ) THEN
+ JTOP = 1
+ JBOT = N
+ ELSE
+ JTOP = KTOP
+ JBOT = KBOT
+ END IF
+ IF( ( .NOT.BLK22 ) .OR. ( INCOL.LT.KTOP ) .OR.
+ $ ( NDCOL.GT.KBOT ) .OR. ( NS.LE.2 ) ) THEN
+*
+* ==== Updates not exploiting the 2-by-2 block
+* . structure of U. K1 and NU keep track of
+* . the location and size of U in the special
+* . cases of introducing bulges and chasing
+* . bulges off the bottom. In these special
+* . cases and in case the number of shifts
+* . is NS = 2, there is no 2-by-2 block
+* . structure to exploit. ====
+*
+ K1 = MAX( 1, KTOP-INCOL )
+ NU = ( KDU-MAX( 0, NDCOL-KBOT ) ) - K1 + 1
+*
+* ==== Horizontal Multiply ====
+*
+ DO 160 JCOL = MIN( NDCOL, KBOT ) + 1, JBOT, NH
+ JLEN = MIN( NH, JBOT-JCOL+1 )
+ CALL DGEMM( 'C', 'N', NU, JLEN, NU, ONE, U( K1, K1 ),
+ $ LDU, H( INCOL+K1, JCOL ), LDH, ZERO, WH,
+ $ LDWH )
+ CALL DLACPY( 'ALL', NU, JLEN, WH, LDWH,
+ $ H( INCOL+K1, JCOL ), LDH )
+ 160 CONTINUE
+*
+* ==== Vertical multiply ====
+*
+ DO 170 JROW = JTOP, MAX( KTOP, INCOL ) - 1, NV
+ JLEN = MIN( NV, MAX( KTOP, INCOL )-JROW )
+ CALL DGEMM( 'N', 'N', JLEN, NU, NU, ONE,
+ $ H( JROW, INCOL+K1 ), LDH, U( K1, K1 ),
+ $ LDU, ZERO, WV, LDWV )
+ CALL DLACPY( 'ALL', JLEN, NU, WV, LDWV,
+ $ H( JROW, INCOL+K1 ), LDH )
+ 170 CONTINUE
+*
+* ==== Z multiply (also vertical) ====
+*
+ IF( WANTZ ) THEN
+ DO 180 JROW = ILOZ, IHIZ, NV
+ JLEN = MIN( NV, IHIZ-JROW+1 )
+ CALL DGEMM( 'N', 'N', JLEN, NU, NU, ONE,
+ $ Z( JROW, INCOL+K1 ), LDZ, U( K1, K1 ),
+ $ LDU, ZERO, WV, LDWV )
+ CALL DLACPY( 'ALL', JLEN, NU, WV, LDWV,
+ $ Z( JROW, INCOL+K1 ), LDZ )
+ 180 CONTINUE
+ END IF
+ ELSE
+*
+* ==== Updates exploiting U's 2-by-2 block structure.
+* . (I2, I4, J2, J4 are the last rows and columns
+* . of the blocks.) ====
+*
+ I2 = ( KDU+1 ) / 2
+ I4 = KDU
+ J2 = I4 - I2
+ J4 = KDU
+*
+* ==== KZS and KNZ deal with the band of zeros
+* . along the diagonal of one of the triangular
+* . blocks. ====
+*
+ KZS = ( J4-J2 ) - ( NS+1 )
+ KNZ = NS + 1
+*
+* ==== Horizontal multiply ====
+*
+ DO 190 JCOL = MIN( NDCOL, KBOT ) + 1, JBOT, NH
+ JLEN = MIN( NH, JBOT-JCOL+1 )
+*
+* ==== Copy bottom of H to top+KZS of scratch ====
+* (The first KZS rows get multiplied by zero.) ====
+*
+ CALL DLACPY( 'ALL', KNZ, JLEN, H( INCOL+1+J2, JCOL ),
+ $ LDH, WH( KZS+1, 1 ), LDWH )
+*
+* ==== Multiply by U21' ====
+*
+ CALL DLASET( 'ALL', KZS, JLEN, ZERO, ZERO, WH, LDWH )
+ CALL DTRMM( 'L', 'U', 'C', 'N', KNZ, JLEN, ONE,
+ $ U( J2+1, 1+KZS ), LDU, WH( KZS+1, 1 ),
+ $ LDWH )
+*
+* ==== Multiply top of H by U11' ====
+*
+ CALL DGEMM( 'C', 'N', I2, JLEN, J2, ONE, U, LDU,
+ $ H( INCOL+1, JCOL ), LDH, ONE, WH, LDWH )
+*
+* ==== Copy top of H bottom of WH ====
+*
+ CALL DLACPY( 'ALL', J2, JLEN, H( INCOL+1, JCOL ), LDH,
+ $ WH( I2+1, 1 ), LDWH )
+*
+* ==== Multiply by U21' ====
+*
+ CALL DTRMM( 'L', 'L', 'C', 'N', J2, JLEN, ONE,
+ $ U( 1, I2+1 ), LDU, WH( I2+1, 1 ), LDWH )
+*
+* ==== Multiply by U22 ====
+*
+ CALL DGEMM( 'C', 'N', I4-I2, JLEN, J4-J2, ONE,
+ $ U( J2+1, I2+1 ), LDU,
+ $ H( INCOL+1+J2, JCOL ), LDH, ONE,
+ $ WH( I2+1, 1 ), LDWH )
+*
+* ==== Copy it back ====
+*
+ CALL DLACPY( 'ALL', KDU, JLEN, WH, LDWH,
+ $ H( INCOL+1, JCOL ), LDH )
+ 190 CONTINUE
+*
+* ==== Vertical multiply ====
+*
+ DO 200 JROW = JTOP, MAX( INCOL, KTOP ) - 1, NV
+ JLEN = MIN( NV, MAX( INCOL, KTOP )-JROW )
+*
+* ==== Copy right of H to scratch (the first KZS
+* . columns get multiplied by zero) ====
+*
+ CALL DLACPY( 'ALL', JLEN, KNZ, H( JROW, INCOL+1+J2 ),
+ $ LDH, WV( 1, 1+KZS ), LDWV )
+*
+* ==== Multiply by U21 ====
+*
+ CALL DLASET( 'ALL', JLEN, KZS, ZERO, ZERO, WV, LDWV )
+ CALL DTRMM( 'R', 'U', 'N', 'N', JLEN, KNZ, ONE,
+ $ U( J2+1, 1+KZS ), LDU, WV( 1, 1+KZS ),
+ $ LDWV )
+*
+* ==== Multiply by U11 ====
+*
+ CALL DGEMM( 'N', 'N', JLEN, I2, J2, ONE,
+ $ H( JROW, INCOL+1 ), LDH, U, LDU, ONE, WV,
+ $ LDWV )
+*
+* ==== Copy left of H to right of scratch ====
+*
+ CALL DLACPY( 'ALL', JLEN, J2, H( JROW, INCOL+1 ), LDH,
+ $ WV( 1, 1+I2 ), LDWV )
+*
+* ==== Multiply by U21 ====
+*
+ CALL DTRMM( 'R', 'L', 'N', 'N', JLEN, I4-I2, ONE,
+ $ U( 1, I2+1 ), LDU, WV( 1, 1+I2 ), LDWV )
+*
+* ==== Multiply by U22 ====
+*
+ CALL DGEMM( 'N', 'N', JLEN, I4-I2, J4-J2, ONE,
+ $ H( JROW, INCOL+1+J2 ), LDH,
+ $ U( J2+1, I2+1 ), LDU, ONE, WV( 1, 1+I2 ),
+ $ LDWV )
+*
+* ==== Copy it back ====
+*
+ CALL DLACPY( 'ALL', JLEN, KDU, WV, LDWV,
+ $ H( JROW, INCOL+1 ), LDH )
+ 200 CONTINUE
+*
+* ==== Multiply Z (also vertical) ====
+*
+ IF( WANTZ ) THEN
+ DO 210 JROW = ILOZ, IHIZ, NV
+ JLEN = MIN( NV, IHIZ-JROW+1 )
+*
+* ==== Copy right of Z to left of scratch (first
+* . KZS columns get multiplied by zero) ====
+*
+ CALL DLACPY( 'ALL', JLEN, KNZ,
+ $ Z( JROW, INCOL+1+J2 ), LDZ,
+ $ WV( 1, 1+KZS ), LDWV )
+*
+* ==== Multiply by U12 ====
+*
+ CALL DLASET( 'ALL', JLEN, KZS, ZERO, ZERO, WV,
+ $ LDWV )
+ CALL DTRMM( 'R', 'U', 'N', 'N', JLEN, KNZ, ONE,
+ $ U( J2+1, 1+KZS ), LDU, WV( 1, 1+KZS ),
+ $ LDWV )
+*
+* ==== Multiply by U11 ====
+*
+ CALL DGEMM( 'N', 'N', JLEN, I2, J2, ONE,
+ $ Z( JROW, INCOL+1 ), LDZ, U, LDU, ONE,
+ $ WV, LDWV )
+*
+* ==== Copy left of Z to right of scratch ====
+*
+ CALL DLACPY( 'ALL', JLEN, J2, Z( JROW, INCOL+1 ),
+ $ LDZ, WV( 1, 1+I2 ), LDWV )
+*
+* ==== Multiply by U21 ====
+*
+ CALL DTRMM( 'R', 'L', 'N', 'N', JLEN, I4-I2, ONE,
+ $ U( 1, I2+1 ), LDU, WV( 1, 1+I2 ),
+ $ LDWV )
+*
+* ==== Multiply by U22 ====
+*
+ CALL DGEMM( 'N', 'N', JLEN, I4-I2, J4-J2, ONE,
+ $ Z( JROW, INCOL+1+J2 ), LDZ,
+ $ U( J2+1, I2+1 ), LDU, ONE,
+ $ WV( 1, 1+I2 ), LDWV )
+*
+* ==== Copy the result back to Z ====
+*
+ CALL DLACPY( 'ALL', JLEN, KDU, WV, LDWV,
+ $ Z( JROW, INCOL+1 ), LDZ )
+ 210 CONTINUE
+ END IF
+ END IF
+ END IF
+ 220 CONTINUE
+*
+* ==== End of DLAQR5 ====
+*
+ END
+ SUBROUTINE DLAQSB( UPLO, N, KD, AB, LDAB, S, SCOND, AMAX, EQUED )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER EQUED, UPLO
+ INTEGER KD, LDAB, N
+ DOUBLE PRECISION AMAX, SCOND
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION AB( LDAB, * ), S( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DLAQSB equilibrates a symmetric band matrix A using the scaling
+* factors in the vector S.
+*
+* Arguments
+* =========
+*
+* UPLO (input) CHARACTER*1
+* Specifies whether the upper or lower triangular part of the
+* symmetric matrix A is stored.
+* = 'U': Upper triangular
+* = 'L': Lower triangular
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* KD (input) INTEGER
+* The number of super-diagonals of the matrix A if UPLO = 'U',
+* or the number of sub-diagonals if UPLO = 'L'. KD >= 0.
+*
+* AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N)
+* On entry, the upper or lower triangle of the symmetric band
+* matrix A, stored in the first KD+1 rows of the array. The
+* j-th column of A is stored in the j-th column of the array AB
+* as follows:
+* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
+* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).
+*
+* On exit, if INFO = 0, the triangular factor U or L from the
+* Cholesky factorization A = U'*U or A = L*L' of the band
+* matrix A, in the same storage format as A.
+*
+* LDAB (input) INTEGER
+* The leading dimension of the array AB. LDAB >= KD+1.
+*
+* S (input) DOUBLE PRECISION array, dimension (N)
+* The scale factors for A.
+*
+* SCOND (input) DOUBLE PRECISION
+* Ratio of the smallest S(i) to the largest S(i).
+*
+* AMAX (input) DOUBLE PRECISION
+* Absolute value of largest matrix entry.
+*
+* EQUED (output) CHARACTER*1
+* Specifies whether or not equilibration was done.
+* = 'N': No equilibration.
+* = 'Y': Equilibration was done, i.e., A has been replaced by
+* diag(S) * A * diag(S).
+*
+* Internal Parameters
+* ===================
+*
+* THRESH is a threshold value used to decide if scaling should be done
+* based on the ratio of the scaling factors. If SCOND < THRESH,
+* scaling is done.
+*
+* LARGE and SMALL are threshold values used to decide if scaling should
+* be done based on the absolute size of the largest matrix element.
+* If AMAX > LARGE or AMAX < SMALL, scaling is done.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE, THRESH
+ PARAMETER ( ONE = 1.0D+0, THRESH = 0.1D+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, J
+ DOUBLE PRECISION CJ, LARGE, SMALL
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ DOUBLE PRECISION DLAMCH
+ EXTERNAL LSAME, DLAMCH
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+* Quick return if possible
+*
+ IF( N.LE.0 ) THEN
+ EQUED = 'N'
+ RETURN
+ END IF
+*
+* Initialize LARGE and SMALL.
+*
+ SMALL = DLAMCH( 'Safe minimum' ) / DLAMCH( 'Precision' )
+ LARGE = ONE / SMALL
+*
+ IF( SCOND.GE.THRESH .AND. AMAX.GE.SMALL .AND. AMAX.LE.LARGE ) THEN
+*
+* No equilibration
+*
+ EQUED = 'N'
+ ELSE
+*
+* Replace A by diag(S) * A * diag(S).
+*
+ IF( LSAME( UPLO, 'U' ) ) THEN
+*
+* Upper triangle of A is stored in band format.
+*
+ DO 20 J = 1, N
+ CJ = S( J )
+ DO 10 I = MAX( 1, J-KD ), J
+ AB( KD+1+I-J, J ) = CJ*S( I )*AB( KD+1+I-J, J )
+ 10 CONTINUE
+ 20 CONTINUE
+ ELSE
+*
+* Lower triangle of A is stored.
+*
+ DO 40 J = 1, N
+ CJ = S( J )
+ DO 30 I = J, MIN( N, J+KD )
+ AB( 1+I-J, J ) = CJ*S( I )*AB( 1+I-J, J )
+ 30 CONTINUE
+ 40 CONTINUE
+ END IF
+ EQUED = 'Y'
+ END IF
+*
+ RETURN
+*
+* End of DLAQSB
+*
+ END
+ SUBROUTINE DLAQSP( UPLO, N, AP, S, SCOND, AMAX, EQUED )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER EQUED, UPLO
+ INTEGER N
+ DOUBLE PRECISION AMAX, SCOND
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION AP( * ), S( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DLAQSP equilibrates a symmetric matrix A using the scaling factors
+* in the vector S.
+*
+* Arguments
+* =========
+*
+* UPLO (input) CHARACTER*1
+* Specifies whether the upper or lower triangular part of the
+* symmetric matrix A is stored.
+* = 'U': Upper triangular
+* = 'L': Lower triangular
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)
+* On entry, the upper or lower triangle of the symmetric matrix
+* A, packed columnwise in a linear array. The j-th column of A
+* is stored in the array AP as follows:
+* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
+* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
+*
+* On exit, the equilibrated matrix: diag(S) * A * diag(S), in
+* the same storage format as A.
+*
+* S (input) DOUBLE PRECISION array, dimension (N)
+* The scale factors for A.
+*
+* SCOND (input) DOUBLE PRECISION
+* Ratio of the smallest S(i) to the largest S(i).
+*
+* AMAX (input) DOUBLE PRECISION
+* Absolute value of largest matrix entry.
+*
+* EQUED (output) CHARACTER*1
+* Specifies whether or not equilibration was done.
+* = 'N': No equilibration.
+* = 'Y': Equilibration was done, i.e., A has been replaced by
+* diag(S) * A * diag(S).
+*
+* Internal Parameters
+* ===================
+*
+* THRESH is a threshold value used to decide if scaling should be done
+* based on the ratio of the scaling factors. If SCOND < THRESH,
+* scaling is done.
+*
+* LARGE and SMALL are threshold values used to decide if scaling should
+* be done based on the absolute size of the largest matrix element.
+* If AMAX > LARGE or AMAX < SMALL, scaling is done.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE, THRESH
+ PARAMETER ( ONE = 1.0D+0, THRESH = 0.1D+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, J, JC
+ DOUBLE PRECISION CJ, LARGE, SMALL
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ DOUBLE PRECISION DLAMCH
+ EXTERNAL LSAME, DLAMCH
+* ..
+* .. Executable Statements ..
+*
+* Quick return if possible
+*
+ IF( N.LE.0 ) THEN
+ EQUED = 'N'
+ RETURN
+ END IF
+*
+* Initialize LARGE and SMALL.
+*
+ SMALL = DLAMCH( 'Safe minimum' ) / DLAMCH( 'Precision' )
+ LARGE = ONE / SMALL
+*
+ IF( SCOND.GE.THRESH .AND. AMAX.GE.SMALL .AND. AMAX.LE.LARGE ) THEN
+*
+* No equilibration
+*
+ EQUED = 'N'
+ ELSE
+*
+* Replace A by diag(S) * A * diag(S).
+*
+ IF( LSAME( UPLO, 'U' ) ) THEN
+*
+* Upper triangle of A is stored.
+*
+ JC = 1
+ DO 20 J = 1, N
+ CJ = S( J )
+ DO 10 I = 1, J
+ AP( JC+I-1 ) = CJ*S( I )*AP( JC+I-1 )
+ 10 CONTINUE
+ JC = JC + J
+ 20 CONTINUE
+ ELSE
+*
+* Lower triangle of A is stored.
+*
+ JC = 1
+ DO 40 J = 1, N
+ CJ = S( J )
+ DO 30 I = J, N
+ AP( JC+I-J ) = CJ*S( I )*AP( JC+I-J )
+ 30 CONTINUE
+ JC = JC + N - J + 1
+ 40 CONTINUE
+ END IF
+ EQUED = 'Y'
+ END IF
+*
+ RETURN
+*
+* End of DLAQSP
+*
+ END
+ SUBROUTINE DLAQSY( UPLO, N, A, LDA, S, SCOND, AMAX, EQUED )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER EQUED, UPLO
+ INTEGER LDA, N
+ DOUBLE PRECISION AMAX, SCOND
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION A( LDA, * ), S( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DLAQSY equilibrates a symmetric matrix A using the scaling factors
+* in the vector S.
+*
+* Arguments
+* =========
+*
+* UPLO (input) CHARACTER*1
+* Specifies whether the upper or lower triangular part of the
+* symmetric matrix A is stored.
+* = 'U': Upper triangular
+* = 'L': Lower triangular
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+* On entry, the symmetric matrix A. If UPLO = 'U', the leading
+* n by n upper triangular part of A contains the upper
+* triangular part of the matrix A, and the strictly lower
+* triangular part of A is not referenced. If UPLO = 'L', the
+* leading n by n lower triangular part of A contains the lower
+* triangular part of the matrix A, and the strictly upper
+* triangular part of A is not referenced.
+*
+* On exit, if EQUED = 'Y', the equilibrated matrix:
+* diag(S) * A * diag(S).
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(N,1).
+*
+* S (input) DOUBLE PRECISION array, dimension (N)
+* The scale factors for A.
+*
+* SCOND (input) DOUBLE PRECISION
+* Ratio of the smallest S(i) to the largest S(i).
+*
+* AMAX (input) DOUBLE PRECISION
+* Absolute value of largest matrix entry.
+*
+* EQUED (output) CHARACTER*1
+* Specifies whether or not equilibration was done.
+* = 'N': No equilibration.
+* = 'Y': Equilibration was done, i.e., A has been replaced by
+* diag(S) * A * diag(S).
+*
+* Internal Parameters
+* ===================
+*
+* THRESH is a threshold value used to decide if scaling should be done
+* based on the ratio of the scaling factors. If SCOND < THRESH,
+* scaling is done.
+*
+* LARGE and SMALL are threshold values used to decide if scaling should
+* be done based on the absolute size of the largest matrix element.
+* If AMAX > LARGE or AMAX < SMALL, scaling is done.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE, THRESH
+ PARAMETER ( ONE = 1.0D+0, THRESH = 0.1D+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, J
+ DOUBLE PRECISION CJ, LARGE, SMALL
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ DOUBLE PRECISION DLAMCH
+ EXTERNAL LSAME, DLAMCH
+* ..
+* .. Executable Statements ..
+*
+* Quick return if possible
+*
+ IF( N.LE.0 ) THEN
+ EQUED = 'N'
+ RETURN
+ END IF
+*
+* Initialize LARGE and SMALL.
+*
+ SMALL = DLAMCH( 'Safe minimum' ) / DLAMCH( 'Precision' )
+ LARGE = ONE / SMALL
+*
+ IF( SCOND.GE.THRESH .AND. AMAX.GE.SMALL .AND. AMAX.LE.LARGE ) THEN
+*
+* No equilibration
+*
+ EQUED = 'N'
+ ELSE
+*
+* Replace A by diag(S) * A * diag(S).
+*
+ IF( LSAME( UPLO, 'U' ) ) THEN
+*
+* Upper triangle of A is stored.
+*
+ DO 20 J = 1, N
+ CJ = S( J )
+ DO 10 I = 1, J
+ A( I, J ) = CJ*S( I )*A( I, J )
+ 10 CONTINUE
+ 20 CONTINUE
+ ELSE
+*
+* Lower triangle of A is stored.
+*
+ DO 40 J = 1, N
+ CJ = S( J )
+ DO 30 I = J, N
+ A( I, J ) = CJ*S( I )*A( I, J )
+ 30 CONTINUE
+ 40 CONTINUE
+ END IF
+ EQUED = 'Y'
+ END IF
+*
+ RETURN
+*
+* End of DLAQSY
+*
+ END
+ SUBROUTINE DLAQTR( LTRAN, LREAL, N, T, LDT, B, W, SCALE, X, WORK,
+ $ INFO )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ LOGICAL LREAL, LTRAN
+ INTEGER INFO, LDT, N
+ DOUBLE PRECISION SCALE, W
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION B( * ), T( LDT, * ), WORK( * ), X( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DLAQTR solves the real quasi-triangular system
+*
+* op(T)*p = scale*c, if LREAL = .TRUE.
+*
+* or the complex quasi-triangular systems
+*
+* op(T + iB)*(p+iq) = scale*(c+id), if LREAL = .FALSE.
+*
+* in real arithmetic, where T is upper quasi-triangular.
+* If LREAL = .FALSE., then the first diagonal block of T must be
+* 1 by 1, B is the specially structured matrix
+*
+* B = [ b(1) b(2) ... b(n) ]
+* [ w ]
+* [ w ]
+* [ . ]
+* [ w ]
+*
+* op(A) = A or A', A' denotes the conjugate transpose of
+* matrix A.
+*
+* On input, X = [ c ]. On output, X = [ p ].
+* [ d ] [ q ]
+*
+* This subroutine is designed for the condition number estimation
+* in routine DTRSNA.
+*
+* Arguments
+* =========
+*
+* LTRAN (input) LOGICAL
+* On entry, LTRAN specifies the option of conjugate transpose:
+* = .FALSE., op(T+i*B) = T+i*B,
+* = .TRUE., op(T+i*B) = (T+i*B)'.
+*
+* LREAL (input) LOGICAL
+* On entry, LREAL specifies the input matrix structure:
+* = .FALSE., the input is complex
+* = .TRUE., the input is real
+*
+* N (input) INTEGER
+* On entry, N specifies the order of T+i*B. N >= 0.
+*
+* T (input) DOUBLE PRECISION array, dimension (LDT,N)
+* On entry, T contains a matrix in Schur canonical form.
+* If LREAL = .FALSE., then the first diagonal block of T mu
+* be 1 by 1.
+*
+* LDT (input) INTEGER
+* The leading dimension of the matrix T. LDT >= max(1,N).
+*
+* B (input) DOUBLE PRECISION array, dimension (N)
+* On entry, B contains the elements to form the matrix
+* B as described above.
+* If LREAL = .TRUE., B is not referenced.
+*
+* W (input) DOUBLE PRECISION
+* On entry, W is the diagonal element of the matrix B.
+* If LREAL = .TRUE., W is not referenced.
+*
+* SCALE (output) DOUBLE PRECISION
+* On exit, SCALE is the scale factor.
+*
+* X (input/output) DOUBLE PRECISION array, dimension (2*N)
+* On entry, X contains the right hand side of the system.
+* On exit, X is overwritten by the solution.
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (N)
+*
+* INFO (output) INTEGER
+* On exit, INFO is set to
+* 0: successful exit.
+* 1: the some diagonal 1 by 1 block has been perturbed by
+* a small number SMIN to keep nonsingularity.
+* 2: the some diagonal 2 by 2 block has been perturbed by
+* a small number in DLALN2 to keep nonsingularity.
+* NOTE: In the interests of speed, this routine does not
+* check the inputs for errors.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL NOTRAN
+ INTEGER I, IERR, J, J1, J2, JNEXT, K, N1, N2
+ DOUBLE PRECISION BIGNUM, EPS, REC, SCALOC, SI, SMIN, SMINW,
+ $ SMLNUM, SR, TJJ, TMP, XJ, XMAX, XNORM, Z
+* ..
+* .. Local Arrays ..
+ DOUBLE PRECISION D( 2, 2 ), V( 2, 2 )
+* ..
+* .. External Functions ..
+ INTEGER IDAMAX
+ DOUBLE PRECISION DASUM, DDOT, DLAMCH, DLANGE
+ EXTERNAL IDAMAX, DASUM, DDOT, DLAMCH, DLANGE
+* ..
+* .. External Subroutines ..
+ EXTERNAL DAXPY, DLADIV, DLALN2, DSCAL
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX
+* ..
+* .. Executable Statements ..
+*
+* Do not test the input parameters for errors
+*
+ NOTRAN = .NOT.LTRAN
+ INFO = 0
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+* Set constants to control overflow
+*
+ EPS = DLAMCH( 'P' )
+ SMLNUM = DLAMCH( 'S' ) / EPS
+ BIGNUM = ONE / SMLNUM
+*
+ XNORM = DLANGE( 'M', N, N, T, LDT, D )
+ IF( .NOT.LREAL )
+ $ XNORM = MAX( XNORM, ABS( W ), DLANGE( 'M', N, 1, B, N, D ) )
+ SMIN = MAX( SMLNUM, EPS*XNORM )
+*
+* Compute 1-norm of each column of strictly upper triangular
+* part of T to control overflow in triangular solver.
+*
+ WORK( 1 ) = ZERO
+ DO 10 J = 2, N
+ WORK( J ) = DASUM( J-1, T( 1, J ), 1 )
+ 10 CONTINUE
+*
+ IF( .NOT.LREAL ) THEN
+ DO 20 I = 2, N
+ WORK( I ) = WORK( I ) + ABS( B( I ) )
+ 20 CONTINUE
+ END IF
+*
+ N2 = 2*N
+ N1 = N
+ IF( .NOT.LREAL )
+ $ N1 = N2
+ K = IDAMAX( N1, X, 1 )
+ XMAX = ABS( X( K ) )
+ SCALE = ONE
+*
+ IF( XMAX.GT.BIGNUM ) THEN
+ SCALE = BIGNUM / XMAX
+ CALL DSCAL( N1, SCALE, X, 1 )
+ XMAX = BIGNUM
+ END IF
+*
+ IF( LREAL ) THEN
+*
+ IF( NOTRAN ) THEN
+*
+* Solve T*p = scale*c
+*
+ JNEXT = N
+ DO 30 J = N, 1, -1
+ IF( J.GT.JNEXT )
+ $ GO TO 30
+ J1 = J
+ J2 = J
+ JNEXT = J - 1
+ IF( J.GT.1 ) THEN
+ IF( T( J, J-1 ).NE.ZERO ) THEN
+ J1 = J - 1
+ JNEXT = J - 2
+ END IF
+ END IF
+*
+ IF( J1.EQ.J2 ) THEN
+*
+* Meet 1 by 1 diagonal block
+*
+* Scale to avoid overflow when computing
+* x(j) = b(j)/T(j,j)
+*
+ XJ = ABS( X( J1 ) )
+ TJJ = ABS( T( J1, J1 ) )
+ TMP = T( J1, J1 )
+ IF( TJJ.LT.SMIN ) THEN
+ TMP = SMIN
+ TJJ = SMIN
+ INFO = 1
+ END IF
+*
+ IF( XJ.EQ.ZERO )
+ $ GO TO 30
+*
+ IF( TJJ.LT.ONE ) THEN
+ IF( XJ.GT.BIGNUM*TJJ ) THEN
+ REC = ONE / XJ
+ CALL DSCAL( N, REC, X, 1 )
+ SCALE = SCALE*REC
+ XMAX = XMAX*REC
+ END IF
+ END IF
+ X( J1 ) = X( J1 ) / TMP
+ XJ = ABS( X( J1 ) )
+*
+* Scale x if necessary to avoid overflow when adding a
+* multiple of column j1 of T.
+*
+ IF( XJ.GT.ONE ) THEN
+ REC = ONE / XJ
+ IF( WORK( J1 ).GT.( BIGNUM-XMAX )*REC ) THEN
+ CALL DSCAL( N, REC, X, 1 )
+ SCALE = SCALE*REC
+ END IF
+ END IF
+ IF( J1.GT.1 ) THEN
+ CALL DAXPY( J1-1, -X( J1 ), T( 1, J1 ), 1, X, 1 )
+ K = IDAMAX( J1-1, X, 1 )
+ XMAX = ABS( X( K ) )
+ END IF
+*
+ ELSE
+*
+* Meet 2 by 2 diagonal block
+*
+* Call 2 by 2 linear system solve, to take
+* care of possible overflow by scaling factor.
+*
+ D( 1, 1 ) = X( J1 )
+ D( 2, 1 ) = X( J2 )
+ CALL DLALN2( .FALSE., 2, 1, SMIN, ONE, T( J1, J1 ),
+ $ LDT, ONE, ONE, D, 2, ZERO, ZERO, V, 2,
+ $ SCALOC, XNORM, IERR )
+ IF( IERR.NE.0 )
+ $ INFO = 2
+*
+ IF( SCALOC.NE.ONE ) THEN
+ CALL DSCAL( N, SCALOC, X, 1 )
+ SCALE = SCALE*SCALOC
+ END IF
+ X( J1 ) = V( 1, 1 )
+ X( J2 ) = V( 2, 1 )
+*
+* Scale V(1,1) (= X(J1)) and/or V(2,1) (=X(J2))
+* to avoid overflow in updating right-hand side.
+*
+ XJ = MAX( ABS( V( 1, 1 ) ), ABS( V( 2, 1 ) ) )
+ IF( XJ.GT.ONE ) THEN
+ REC = ONE / XJ
+ IF( MAX( WORK( J1 ), WORK( J2 ) ).GT.
+ $ ( BIGNUM-XMAX )*REC ) THEN
+ CALL DSCAL( N, REC, X, 1 )
+ SCALE = SCALE*REC
+ END IF
+ END IF
+*
+* Update right-hand side
+*
+ IF( J1.GT.1 ) THEN
+ CALL DAXPY( J1-1, -X( J1 ), T( 1, J1 ), 1, X, 1 )
+ CALL DAXPY( J1-1, -X( J2 ), T( 1, J2 ), 1, X, 1 )
+ K = IDAMAX( J1-1, X, 1 )
+ XMAX = ABS( X( K ) )
+ END IF
+*
+ END IF
+*
+ 30 CONTINUE
+*
+ ELSE
+*
+* Solve T'*p = scale*c
+*
+ JNEXT = 1
+ DO 40 J = 1, N
+ IF( J.LT.JNEXT )
+ $ GO TO 40
+ J1 = J
+ J2 = J
+ JNEXT = J + 1
+ IF( J.LT.N ) THEN
+ IF( T( J+1, J ).NE.ZERO ) THEN
+ J2 = J + 1
+ JNEXT = J + 2
+ END IF
+ END IF
+*
+ IF( J1.EQ.J2 ) THEN
+*
+* 1 by 1 diagonal block
+*
+* Scale if necessary to avoid overflow in forming the
+* right-hand side element by inner product.
+*
+ XJ = ABS( X( J1 ) )
+ IF( XMAX.GT.ONE ) THEN
+ REC = ONE / XMAX
+ IF( WORK( J1 ).GT.( BIGNUM-XJ )*REC ) THEN
+ CALL DSCAL( N, REC, X, 1 )
+ SCALE = SCALE*REC
+ XMAX = XMAX*REC
+ END IF
+ END IF
+*
+ X( J1 ) = X( J1 ) - DDOT( J1-1, T( 1, J1 ), 1, X, 1 )
+*
+ XJ = ABS( X( J1 ) )
+ TJJ = ABS( T( J1, J1 ) )
+ TMP = T( J1, J1 )
+ IF( TJJ.LT.SMIN ) THEN
+ TMP = SMIN
+ TJJ = SMIN
+ INFO = 1
+ END IF
+*
+ IF( TJJ.LT.ONE ) THEN
+ IF( XJ.GT.BIGNUM*TJJ ) THEN
+ REC = ONE / XJ
+ CALL DSCAL( N, REC, X, 1 )
+ SCALE = SCALE*REC
+ XMAX = XMAX*REC
+ END IF
+ END IF
+ X( J1 ) = X( J1 ) / TMP
+ XMAX = MAX( XMAX, ABS( X( J1 ) ) )
+*
+ ELSE
+*
+* 2 by 2 diagonal block
+*
+* Scale if necessary to avoid overflow in forming the
+* right-hand side elements by inner product.
+*
+ XJ = MAX( ABS( X( J1 ) ), ABS( X( J2 ) ) )
+ IF( XMAX.GT.ONE ) THEN
+ REC = ONE / XMAX
+ IF( MAX( WORK( J2 ), WORK( J1 ) ).GT.( BIGNUM-XJ )*
+ $ REC ) THEN
+ CALL DSCAL( N, REC, X, 1 )
+ SCALE = SCALE*REC
+ XMAX = XMAX*REC
+ END IF
+ END IF
+*
+ D( 1, 1 ) = X( J1 ) - DDOT( J1-1, T( 1, J1 ), 1, X,
+ $ 1 )
+ D( 2, 1 ) = X( J2 ) - DDOT( J1-1, T( 1, J2 ), 1, X,
+ $ 1 )
+*
+ CALL DLALN2( .TRUE., 2, 1, SMIN, ONE, T( J1, J1 ),
+ $ LDT, ONE, ONE, D, 2, ZERO, ZERO, V, 2,
+ $ SCALOC, XNORM, IERR )
+ IF( IERR.NE.0 )
+ $ INFO = 2
+*
+ IF( SCALOC.NE.ONE ) THEN
+ CALL DSCAL( N, SCALOC, X, 1 )
+ SCALE = SCALE*SCALOC
+ END IF
+ X( J1 ) = V( 1, 1 )
+ X( J2 ) = V( 2, 1 )
+ XMAX = MAX( ABS( X( J1 ) ), ABS( X( J2 ) ), XMAX )
+*
+ END IF
+ 40 CONTINUE
+ END IF
+*
+ ELSE
+*
+ SMINW = MAX( EPS*ABS( W ), SMIN )
+ IF( NOTRAN ) THEN
+*
+* Solve (T + iB)*(p+iq) = c+id
+*
+ JNEXT = N
+ DO 70 J = N, 1, -1
+ IF( J.GT.JNEXT )
+ $ GO TO 70
+ J1 = J
+ J2 = J
+ JNEXT = J - 1
+ IF( J.GT.1 ) THEN
+ IF( T( J, J-1 ).NE.ZERO ) THEN
+ J1 = J - 1
+ JNEXT = J - 2
+ END IF
+ END IF
+*
+ IF( J1.EQ.J2 ) THEN
+*
+* 1 by 1 diagonal block
+*
+* Scale if necessary to avoid overflow in division
+*
+ Z = W
+ IF( J1.EQ.1 )
+ $ Z = B( 1 )
+ XJ = ABS( X( J1 ) ) + ABS( X( N+J1 ) )
+ TJJ = ABS( T( J1, J1 ) ) + ABS( Z )
+ TMP = T( J1, J1 )
+ IF( TJJ.LT.SMINW ) THEN
+ TMP = SMINW
+ TJJ = SMINW
+ INFO = 1
+ END IF
+*
+ IF( XJ.EQ.ZERO )
+ $ GO TO 70
+*
+ IF( TJJ.LT.ONE ) THEN
+ IF( XJ.GT.BIGNUM*TJJ ) THEN
+ REC = ONE / XJ
+ CALL DSCAL( N2, REC, X, 1 )
+ SCALE = SCALE*REC
+ XMAX = XMAX*REC
+ END IF
+ END IF
+ CALL DLADIV( X( J1 ), X( N+J1 ), TMP, Z, SR, SI )
+ X( J1 ) = SR
+ X( N+J1 ) = SI
+ XJ = ABS( X( J1 ) ) + ABS( X( N+J1 ) )
+*
+* Scale x if necessary to avoid overflow when adding a
+* multiple of column j1 of T.
+*
+ IF( XJ.GT.ONE ) THEN
+ REC = ONE / XJ
+ IF( WORK( J1 ).GT.( BIGNUM-XMAX )*REC ) THEN
+ CALL DSCAL( N2, REC, X, 1 )
+ SCALE = SCALE*REC
+ END IF
+ END IF
+*
+ IF( J1.GT.1 ) THEN
+ CALL DAXPY( J1-1, -X( J1 ), T( 1, J1 ), 1, X, 1 )
+ CALL DAXPY( J1-1, -X( N+J1 ), T( 1, J1 ), 1,
+ $ X( N+1 ), 1 )
+*
+ X( 1 ) = X( 1 ) + B( J1 )*X( N+J1 )
+ X( N+1 ) = X( N+1 ) - B( J1 )*X( J1 )
+*
+ XMAX = ZERO
+ DO 50 K = 1, J1 - 1
+ XMAX = MAX( XMAX, ABS( X( K ) )+
+ $ ABS( X( K+N ) ) )
+ 50 CONTINUE
+ END IF
+*
+ ELSE
+*
+* Meet 2 by 2 diagonal block
+*
+ D( 1, 1 ) = X( J1 )
+ D( 2, 1 ) = X( J2 )
+ D( 1, 2 ) = X( N+J1 )
+ D( 2, 2 ) = X( N+J2 )
+ CALL DLALN2( .FALSE., 2, 2, SMINW, ONE, T( J1, J1 ),
+ $ LDT, ONE, ONE, D, 2, ZERO, -W, V, 2,
+ $ SCALOC, XNORM, IERR )
+ IF( IERR.NE.0 )
+ $ INFO = 2
+*
+ IF( SCALOC.NE.ONE ) THEN
+ CALL DSCAL( 2*N, SCALOC, X, 1 )
+ SCALE = SCALOC*SCALE
+ END IF
+ X( J1 ) = V( 1, 1 )
+ X( J2 ) = V( 2, 1 )
+ X( N+J1 ) = V( 1, 2 )
+ X( N+J2 ) = V( 2, 2 )
+*
+* Scale X(J1), .... to avoid overflow in
+* updating right hand side.
+*
+ XJ = MAX( ABS( V( 1, 1 ) )+ABS( V( 1, 2 ) ),
+ $ ABS( V( 2, 1 ) )+ABS( V( 2, 2 ) ) )
+ IF( XJ.GT.ONE ) THEN
+ REC = ONE / XJ
+ IF( MAX( WORK( J1 ), WORK( J2 ) ).GT.
+ $ ( BIGNUM-XMAX )*REC ) THEN
+ CALL DSCAL( N2, REC, X, 1 )
+ SCALE = SCALE*REC
+ END IF
+ END IF
+*
+* Update the right-hand side.
+*
+ IF( J1.GT.1 ) THEN
+ CALL DAXPY( J1-1, -X( J1 ), T( 1, J1 ), 1, X, 1 )
+ CALL DAXPY( J1-1, -X( J2 ), T( 1, J2 ), 1, X, 1 )
+*
+ CALL DAXPY( J1-1, -X( N+J1 ), T( 1, J1 ), 1,
+ $ X( N+1 ), 1 )
+ CALL DAXPY( J1-1, -X( N+J2 ), T( 1, J2 ), 1,
+ $ X( N+1 ), 1 )
+*
+ X( 1 ) = X( 1 ) + B( J1 )*X( N+J1 ) +
+ $ B( J2 )*X( N+J2 )
+ X( N+1 ) = X( N+1 ) - B( J1 )*X( J1 ) -
+ $ B( J2 )*X( J2 )
+*
+ XMAX = ZERO
+ DO 60 K = 1, J1 - 1
+ XMAX = MAX( ABS( X( K ) )+ABS( X( K+N ) ),
+ $ XMAX )
+ 60 CONTINUE
+ END IF
+*
+ END IF
+ 70 CONTINUE
+*
+ ELSE
+*
+* Solve (T + iB)'*(p+iq) = c+id
+*
+ JNEXT = 1
+ DO 80 J = 1, N
+ IF( J.LT.JNEXT )
+ $ GO TO 80
+ J1 = J
+ J2 = J
+ JNEXT = J + 1
+ IF( J.LT.N ) THEN
+ IF( T( J+1, J ).NE.ZERO ) THEN
+ J2 = J + 1
+ JNEXT = J + 2
+ END IF
+ END IF
+*
+ IF( J1.EQ.J2 ) THEN
+*
+* 1 by 1 diagonal block
+*
+* Scale if necessary to avoid overflow in forming the
+* right-hand side element by inner product.
+*
+ XJ = ABS( X( J1 ) ) + ABS( X( J1+N ) )
+ IF( XMAX.GT.ONE ) THEN
+ REC = ONE / XMAX
+ IF( WORK( J1 ).GT.( BIGNUM-XJ )*REC ) THEN
+ CALL DSCAL( N2, REC, X, 1 )
+ SCALE = SCALE*REC
+ XMAX = XMAX*REC
+ END IF
+ END IF
+*
+ X( J1 ) = X( J1 ) - DDOT( J1-1, T( 1, J1 ), 1, X, 1 )
+ X( N+J1 ) = X( N+J1 ) - DDOT( J1-1, T( 1, J1 ), 1,
+ $ X( N+1 ), 1 )
+ IF( J1.GT.1 ) THEN
+ X( J1 ) = X( J1 ) - B( J1 )*X( N+1 )
+ X( N+J1 ) = X( N+J1 ) + B( J1 )*X( 1 )
+ END IF
+ XJ = ABS( X( J1 ) ) + ABS( X( J1+N ) )
+*
+ Z = W
+ IF( J1.EQ.1 )
+ $ Z = B( 1 )
+*
+* Scale if necessary to avoid overflow in
+* complex division
+*
+ TJJ = ABS( T( J1, J1 ) ) + ABS( Z )
+ TMP = T( J1, J1 )
+ IF( TJJ.LT.SMINW ) THEN
+ TMP = SMINW
+ TJJ = SMINW
+ INFO = 1
+ END IF
+*
+ IF( TJJ.LT.ONE ) THEN
+ IF( XJ.GT.BIGNUM*TJJ ) THEN
+ REC = ONE / XJ
+ CALL DSCAL( N2, REC, X, 1 )
+ SCALE = SCALE*REC
+ XMAX = XMAX*REC
+ END IF
+ END IF
+ CALL DLADIV( X( J1 ), X( N+J1 ), TMP, -Z, SR, SI )
+ X( J1 ) = SR
+ X( J1+N ) = SI
+ XMAX = MAX( ABS( X( J1 ) )+ABS( X( J1+N ) ), XMAX )
+*
+ ELSE
+*
+* 2 by 2 diagonal block
+*
+* Scale if necessary to avoid overflow in forming the
+* right-hand side element by inner product.
+*
+ XJ = MAX( ABS( X( J1 ) )+ABS( X( N+J1 ) ),
+ $ ABS( X( J2 ) )+ABS( X( N+J2 ) ) )
+ IF( XMAX.GT.ONE ) THEN
+ REC = ONE / XMAX
+ IF( MAX( WORK( J1 ), WORK( J2 ) ).GT.
+ $ ( BIGNUM-XJ ) / XMAX ) THEN
+ CALL DSCAL( N2, REC, X, 1 )
+ SCALE = SCALE*REC
+ XMAX = XMAX*REC
+ END IF
+ END IF
+*
+ D( 1, 1 ) = X( J1 ) - DDOT( J1-1, T( 1, J1 ), 1, X,
+ $ 1 )
+ D( 2, 1 ) = X( J2 ) - DDOT( J1-1, T( 1, J2 ), 1, X,
+ $ 1 )
+ D( 1, 2 ) = X( N+J1 ) - DDOT( J1-1, T( 1, J1 ), 1,
+ $ X( N+1 ), 1 )
+ D( 2, 2 ) = X( N+J2 ) - DDOT( J1-1, T( 1, J2 ), 1,
+ $ X( N+1 ), 1 )
+ D( 1, 1 ) = D( 1, 1 ) - B( J1 )*X( N+1 )
+ D( 2, 1 ) = D( 2, 1 ) - B( J2 )*X( N+1 )
+ D( 1, 2 ) = D( 1, 2 ) + B( J1 )*X( 1 )
+ D( 2, 2 ) = D( 2, 2 ) + B( J2 )*X( 1 )
+*
+ CALL DLALN2( .TRUE., 2, 2, SMINW, ONE, T( J1, J1 ),
+ $ LDT, ONE, ONE, D, 2, ZERO, W, V, 2,
+ $ SCALOC, XNORM, IERR )
+ IF( IERR.NE.0 )
+ $ INFO = 2
+*
+ IF( SCALOC.NE.ONE ) THEN
+ CALL DSCAL( N2, SCALOC, X, 1 )
+ SCALE = SCALOC*SCALE
+ END IF
+ X( J1 ) = V( 1, 1 )
+ X( J2 ) = V( 2, 1 )
+ X( N+J1 ) = V( 1, 2 )
+ X( N+J2 ) = V( 2, 2 )
+ XMAX = MAX( ABS( X( J1 ) )+ABS( X( N+J1 ) ),
+ $ ABS( X( J2 ) )+ABS( X( N+J2 ) ), XMAX )
+*
+ END IF
+*
+ 80 CONTINUE
+*
+ END IF
+*
+ END IF
+*
+ RETURN
+*
+* End of DLAQTR
+*
+ END
+ SUBROUTINE DLAR1V( N, B1, BN, LAMBDA, D, L, LD, LLD,
+ $ PIVMIN, GAPTOL, Z, WANTNC, NEGCNT, ZTZ, MINGMA,
+ $ R, ISUPPZ, NRMINV, RESID, RQCORR, WORK )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ LOGICAL WANTNC
+ INTEGER B1, BN, N, NEGCNT, R
+ DOUBLE PRECISION GAPTOL, LAMBDA, MINGMA, NRMINV, PIVMIN, RESID,
+ $ RQCORR, ZTZ
+* ..
+* .. Array Arguments ..
+ INTEGER ISUPPZ( * )
+ DOUBLE PRECISION D( * ), L( * ), LD( * ), LLD( * ),
+ $ WORK( * )
+ DOUBLE PRECISION Z( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DLAR1V computes the (scaled) r-th column of the inverse of
+* the sumbmatrix in rows B1 through BN of the tridiagonal matrix
+* L D L^T - sigma I. When sigma is close to an eigenvalue, the
+* computed vector is an accurate eigenvector. Usually, r corresponds
+* to the index where the eigenvector is largest in magnitude.
+* The following steps accomplish this computation :
+* (a) Stationary qd transform, L D L^T - sigma I = L(+) D(+) L(+)^T,
+* (b) Progressive qd transform, L D L^T - sigma I = U(-) D(-) U(-)^T,
+* (c) Computation of the diagonal elements of the inverse of
+* L D L^T - sigma I by combining the above transforms, and choosing
+* r as the index where the diagonal of the inverse is (one of the)
+* largest in magnitude.
+* (d) Computation of the (scaled) r-th column of the inverse using the
+* twisted factorization obtained by combining the top part of the
+* the stationary and the bottom part of the progressive transform.
+*
+* Arguments
+* =========
+*
+* N (input) INTEGER
+* The order of the matrix L D L^T.
+*
+* B1 (input) INTEGER
+* First index of the submatrix of L D L^T.
+*
+* BN (input) INTEGER
+* Last index of the submatrix of L D L^T.
+*
+* LAMBDA (input) DOUBLE PRECISION
+* The shift. In order to compute an accurate eigenvector,
+* LAMBDA should be a good approximation to an eigenvalue
+* of L D L^T.
+*
+* L (input) DOUBLE PRECISION array, dimension (N-1)
+* The (n-1) subdiagonal elements of the unit bidiagonal matrix
+* L, in elements 1 to N-1.
+*
+* D (input) DOUBLE PRECISION array, dimension (N)
+* The n diagonal elements of the diagonal matrix D.
+*
+* LD (input) DOUBLE PRECISION array, dimension (N-1)
+* The n-1 elements L(i)*D(i).
+*
+* LLD (input) DOUBLE PRECISION array, dimension (N-1)
+* The n-1 elements L(i)*L(i)*D(i).
+*
+* PIVMIN (input) DOUBLE PRECISION
+* The minimum pivot in the Sturm sequence.
+*
+* GAPTOL (input) DOUBLE PRECISION
+* Tolerance that indicates when eigenvector entries are negligible
+* w.r.t. their contribution to the residual.
+*
+* Z (input/output) DOUBLE PRECISION array, dimension (N)
+* On input, all entries of Z must be set to 0.
+* On output, Z contains the (scaled) r-th column of the
+* inverse. The scaling is such that Z(R) equals 1.
+*
+* WANTNC (input) LOGICAL
+* Specifies whether NEGCNT has to be computed.
+*
+* NEGCNT (output) INTEGER
+* If WANTNC is .TRUE. then NEGCNT = the number of pivots < pivmin
+* in the matrix factorization L D L^T, and NEGCNT = -1 otherwise.
+*
+* ZTZ (output) DOUBLE PRECISION
+* The square of the 2-norm of Z.
+*
+* MINGMA (output) DOUBLE PRECISION
+* The reciprocal of the largest (in magnitude) diagonal
+* element of the inverse of L D L^T - sigma I.
+*
+* R (input/output) INTEGER
+* The twist index for the twisted factorization used to
+* compute Z.
+* On input, 0 <= R <= N. If R is input as 0, R is set to
+* the index where (L D L^T - sigma I)^{-1} is largest
+* in magnitude. If 1 <= R <= N, R is unchanged.
+* On output, R contains the twist index used to compute Z.
+* Ideally, R designates the position of the maximum entry in the
+* eigenvector.
+*
+* ISUPPZ (output) INTEGER array, dimension (2)
+* The support of the vector in Z, i.e., the vector Z is
+* nonzero only in elements ISUPPZ(1) through ISUPPZ( 2 ).
+*
+* NRMINV (output) DOUBLE PRECISION
+* NRMINV = 1/SQRT( ZTZ )
+*
+* RESID (output) DOUBLE PRECISION
+* The residual of the FP vector.
+* RESID = ABS( MINGMA )/SQRT( ZTZ )
+*
+* RQCORR (output) DOUBLE PRECISION
+* The Rayleigh Quotient correction to LAMBDA.
+* RQCORR = MINGMA*TMP
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (4*N)
+*
+* Further Details
+* ===============
+*
+* Based on contributions by
+* Beresford Parlett, University of California, Berkeley, USA
+* Jim Demmel, University of California, Berkeley, USA
+* Inderjit Dhillon, University of Texas, Austin, USA
+* Osni Marques, LBNL/NERSC, USA
+* Christof Voemel, University of California, Berkeley, USA
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
+
+* ..
+* .. Local Scalars ..
+ LOGICAL SAWNAN1, SAWNAN2
+ INTEGER I, INDLPL, INDP, INDS, INDUMN, NEG1, NEG2, R1,
+ $ R2
+ DOUBLE PRECISION DMINUS, DPLUS, EPS, S, TMP
+* ..
+* .. External Functions ..
+ LOGICAL DISNAN
+ DOUBLE PRECISION DLAMCH
+ EXTERNAL DISNAN, DLAMCH
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS
+* ..
+* .. Executable Statements ..
+*
+ EPS = DLAMCH( 'Precision' )
+
+
+ IF( R.EQ.0 ) THEN
+ R1 = B1
+ R2 = BN
+ ELSE
+ R1 = R
+ R2 = R
+ END IF
+
+* Storage for LPLUS
+ INDLPL = 0
+* Storage for UMINUS
+ INDUMN = N
+ INDS = 2*N + 1
+ INDP = 3*N + 1
+
+ IF( B1.EQ.1 ) THEN
+ WORK( INDS ) = ZERO
+ ELSE
+ WORK( INDS+B1-1 ) = LLD( B1-1 )
+ END IF
+
+*
+* Compute the stationary transform (using the differential form)
+* until the index R2.
+*
+ SAWNAN1 = .FALSE.
+ NEG1 = 0
+ S = WORK( INDS+B1-1 ) - LAMBDA
+ DO 50 I = B1, R1 - 1
+ DPLUS = D( I ) + S
+ WORK( INDLPL+I ) = LD( I ) / DPLUS
+ IF(DPLUS.LT.ZERO) NEG1 = NEG1 + 1
+ WORK( INDS+I ) = S*WORK( INDLPL+I )*L( I )
+ S = WORK( INDS+I ) - LAMBDA
+ 50 CONTINUE
+ SAWNAN1 = DISNAN( S )
+ IF( SAWNAN1 ) GOTO 60
+ DO 51 I = R1, R2 - 1
+ DPLUS = D( I ) + S
+ WORK( INDLPL+I ) = LD( I ) / DPLUS
+ WORK( INDS+I ) = S*WORK( INDLPL+I )*L( I )
+ S = WORK( INDS+I ) - LAMBDA
+ 51 CONTINUE
+ SAWNAN1 = DISNAN( S )
+*
+ 60 CONTINUE
+ IF( SAWNAN1 ) THEN
+* Runs a slower version of the above loop if a NaN is detected
+ NEG1 = 0
+ S = WORK( INDS+B1-1 ) - LAMBDA
+ DO 70 I = B1, R1 - 1
+ DPLUS = D( I ) + S
+ IF(ABS(DPLUS).LT.PIVMIN) DPLUS = -PIVMIN
+ WORK( INDLPL+I ) = LD( I ) / DPLUS
+ IF(DPLUS.LT.ZERO) NEG1 = NEG1 + 1
+ WORK( INDS+I ) = S*WORK( INDLPL+I )*L( I )
+ IF( WORK( INDLPL+I ).EQ.ZERO )
+ $ WORK( INDS+I ) = LLD( I )
+ S = WORK( INDS+I ) - LAMBDA
+ 70 CONTINUE
+ DO 71 I = R1, R2 - 1
+ DPLUS = D( I ) + S
+ IF(ABS(DPLUS).LT.PIVMIN) DPLUS = -PIVMIN
+ WORK( INDLPL+I ) = LD( I ) / DPLUS
+ WORK( INDS+I ) = S*WORK( INDLPL+I )*L( I )
+ IF( WORK( INDLPL+I ).EQ.ZERO )
+ $ WORK( INDS+I ) = LLD( I )
+ S = WORK( INDS+I ) - LAMBDA
+ 71 CONTINUE
+ END IF
+*
+* Compute the progressive transform (using the differential form)
+* until the index R1
+*
+ SAWNAN2 = .FALSE.
+ NEG2 = 0
+ WORK( INDP+BN-1 ) = D( BN ) - LAMBDA
+ DO 80 I = BN - 1, R1, -1
+ DMINUS = LLD( I ) + WORK( INDP+I )
+ TMP = D( I ) / DMINUS
+ IF(DMINUS.LT.ZERO) NEG2 = NEG2 + 1
+ WORK( INDUMN+I ) = L( I )*TMP
+ WORK( INDP+I-1 ) = WORK( INDP+I )*TMP - LAMBDA
+ 80 CONTINUE
+ TMP = WORK( INDP+R1-1 )
+ SAWNAN2 = DISNAN( TMP )
+
+ IF( SAWNAN2 ) THEN
+* Runs a slower version of the above loop if a NaN is detected
+ NEG2 = 0
+ DO 100 I = BN-1, R1, -1
+ DMINUS = LLD( I ) + WORK( INDP+I )
+ IF(ABS(DMINUS).LT.PIVMIN) DMINUS = -PIVMIN
+ TMP = D( I ) / DMINUS
+ IF(DMINUS.LT.ZERO) NEG2 = NEG2 + 1
+ WORK( INDUMN+I ) = L( I )*TMP
+ WORK( INDP+I-1 ) = WORK( INDP+I )*TMP - LAMBDA
+ IF( TMP.EQ.ZERO )
+ $ WORK( INDP+I-1 ) = D( I ) - LAMBDA
+ 100 CONTINUE
+ END IF
+*
+* Find the index (from R1 to R2) of the largest (in magnitude)
+* diagonal element of the inverse
+*
+ MINGMA = WORK( INDS+R1-1 ) + WORK( INDP+R1-1 )
+ IF( MINGMA.LT.ZERO ) NEG1 = NEG1 + 1
+ IF( WANTNC ) THEN
+ NEGCNT = NEG1 + NEG2
+ ELSE
+ NEGCNT = -1
+ ENDIF
+ IF( ABS(MINGMA).EQ.ZERO )
+ $ MINGMA = EPS*WORK( INDS+R1-1 )
+ R = R1
+ DO 110 I = R1, R2 - 1
+ TMP = WORK( INDS+I ) + WORK( INDP+I )
+ IF( TMP.EQ.ZERO )
+ $ TMP = EPS*WORK( INDS+I )
+ IF( ABS( TMP ).LE.ABS( MINGMA ) ) THEN
+ MINGMA = TMP
+ R = I + 1
+ END IF
+ 110 CONTINUE
+*
+* Compute the FP vector: solve N^T v = e_r
+*
+ ISUPPZ( 1 ) = B1
+ ISUPPZ( 2 ) = BN
+ Z( R ) = ONE
+ ZTZ = ONE
+*
+* Compute the FP vector upwards from R
+*
+ IF( .NOT.SAWNAN1 .AND. .NOT.SAWNAN2 ) THEN
+ DO 210 I = R-1, B1, -1
+ Z( I ) = -( WORK( INDLPL+I )*Z( I+1 ) )
+ IF( (ABS(Z(I))+ABS(Z(I+1)))* ABS(LD(I)).LT.GAPTOL )
+ $ THEN
+ Z( I ) = ZERO
+ ISUPPZ( 1 ) = I + 1
+ GOTO 220
+ ENDIF
+ ZTZ = ZTZ + Z( I )*Z( I )
+ 210 CONTINUE
+ 220 CONTINUE
+ ELSE
+* Run slower loop if NaN occurred.
+ DO 230 I = R - 1, B1, -1
+ IF( Z( I+1 ).EQ.ZERO ) THEN
+ Z( I ) = -( LD( I+1 ) / LD( I ) )*Z( I+2 )
+ ELSE
+ Z( I ) = -( WORK( INDLPL+I )*Z( I+1 ) )
+ END IF
+ IF( (ABS(Z(I))+ABS(Z(I+1)))* ABS(LD(I)).LT.GAPTOL )
+ $ THEN
+ Z( I ) = ZERO
+ ISUPPZ( 1 ) = I + 1
+ GO TO 240
+ END IF
+ ZTZ = ZTZ + Z( I )*Z( I )
+ 230 CONTINUE
+ 240 CONTINUE
+ ENDIF
+
+* Compute the FP vector downwards from R in blocks of size BLKSIZ
+ IF( .NOT.SAWNAN1 .AND. .NOT.SAWNAN2 ) THEN
+ DO 250 I = R, BN-1
+ Z( I+1 ) = -( WORK( INDUMN+I )*Z( I ) )
+ IF( (ABS(Z(I))+ABS(Z(I+1)))* ABS(LD(I)).LT.GAPTOL )
+ $ THEN
+ Z( I+1 ) = ZERO
+ ISUPPZ( 2 ) = I
+ GO TO 260
+ END IF
+ ZTZ = ZTZ + Z( I+1 )*Z( I+1 )
+ 250 CONTINUE
+ 260 CONTINUE
+ ELSE
+* Run slower loop if NaN occurred.
+ DO 270 I = R, BN - 1
+ IF( Z( I ).EQ.ZERO ) THEN
+ Z( I+1 ) = -( LD( I-1 ) / LD( I ) )*Z( I-1 )
+ ELSE
+ Z( I+1 ) = -( WORK( INDUMN+I )*Z( I ) )
+ END IF
+ IF( (ABS(Z(I))+ABS(Z(I+1)))* ABS(LD(I)).LT.GAPTOL )
+ $ THEN
+ Z( I+1 ) = ZERO
+ ISUPPZ( 2 ) = I
+ GO TO 280
+ END IF
+ ZTZ = ZTZ + Z( I+1 )*Z( I+1 )
+ 270 CONTINUE
+ 280 CONTINUE
+ END IF
+*
+* Compute quantities for convergence test
+*
+ TMP = ONE / ZTZ
+ NRMINV = SQRT( TMP )
+ RESID = ABS( MINGMA )*NRMINV
+ RQCORR = MINGMA*TMP
+*
+*
+ RETURN
+*
+* End of DLAR1V
+*
+ END
+ SUBROUTINE DLAR2V( N, X, Y, Z, INCX, C, S, INCC )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INCC, INCX, N
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION C( * ), S( * ), X( * ), Y( * ), Z( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DLAR2V applies a vector of real plane rotations from both sides to
+* a sequence of 2-by-2 real symmetric matrices, defined by the elements
+* of the vectors x, y and z. For i = 1,2,...,n
+*
+* ( x(i) z(i) ) := ( c(i) s(i) ) ( x(i) z(i) ) ( c(i) -s(i) )
+* ( z(i) y(i) ) ( -s(i) c(i) ) ( z(i) y(i) ) ( s(i) c(i) )
+*
+* Arguments
+* =========
+*
+* N (input) INTEGER
+* The number of plane rotations to be applied.
+*
+* X (input/output) DOUBLE PRECISION array,
+* dimension (1+(N-1)*INCX)
+* The vector x.
+*
+* Y (input/output) DOUBLE PRECISION array,
+* dimension (1+(N-1)*INCX)
+* The vector y.
+*
+* Z (input/output) DOUBLE PRECISION array,
+* dimension (1+(N-1)*INCX)
+* The vector z.
+*
+* INCX (input) INTEGER
+* The increment between elements of X, Y and Z. INCX > 0.
+*
+* C (input) DOUBLE PRECISION array, dimension (1+(N-1)*INCC)
+* The cosines of the plane rotations.
+*
+* S (input) DOUBLE PRECISION array, dimension (1+(N-1)*INCC)
+* The sines of the plane rotations.
+*
+* INCC (input) INTEGER
+* The increment between elements of C and S. INCC > 0.
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ INTEGER I, IC, IX
+ DOUBLE PRECISION CI, SI, T1, T2, T3, T4, T5, T6, XI, YI, ZI
+* ..
+* .. Executable Statements ..
+*
+ IX = 1
+ IC = 1
+ DO 10 I = 1, N
+ XI = X( IX )
+ YI = Y( IX )
+ ZI = Z( IX )
+ CI = C( IC )
+ SI = S( IC )
+ T1 = SI*ZI
+ T2 = CI*ZI
+ T3 = T2 - SI*XI
+ T4 = T2 + SI*YI
+ T5 = CI*XI + T1
+ T6 = CI*YI - T1
+ X( IX ) = CI*T5 + SI*T4
+ Y( IX ) = CI*T6 - SI*T3
+ Z( IX ) = CI*T4 - SI*T5
+ IX = IX + INCX
+ IC = IC + INCC
+ 10 CONTINUE
+*
+* End of DLAR2V
+*
+ RETURN
+ END
+ SUBROUTINE DLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER SIDE
+ INTEGER INCV, LDC, M, N
+ DOUBLE PRECISION TAU
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION C( LDC, * ), V( * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DLARF applies a real elementary reflector H to a real m by n matrix
+* C, from either the left or the right. H is represented in the form
+*
+* H = I - tau * v * v'
+*
+* where tau is a real scalar and v is a real vector.
+*
+* If tau = 0, then H is taken to be the unit matrix.
+*
+* Arguments
+* =========
+*
+* SIDE (input) CHARACTER*1
+* = 'L': form H * C
+* = 'R': form C * H
+*
+* M (input) INTEGER
+* The number of rows of the matrix C.
+*
+* N (input) INTEGER
+* The number of columns of the matrix C.
+*
+* V (input) DOUBLE PRECISION array, dimension
+* (1 + (M-1)*abs(INCV)) if SIDE = 'L'
+* or (1 + (N-1)*abs(INCV)) if SIDE = 'R'
+* The vector v in the representation of H. V is not used if
+* TAU = 0.
+*
+* INCV (input) INTEGER
+* The increment between elements of v. INCV <> 0.
+*
+* TAU (input) DOUBLE PRECISION
+* The value tau in the representation of H.
+*
+* C (input/output) DOUBLE PRECISION array, dimension (LDC,N)
+* On entry, the m by n matrix C.
+* On exit, C is overwritten by the matrix H * C if SIDE = 'L',
+* or C * H if SIDE = 'R'.
+*
+* LDC (input) INTEGER
+* The leading dimension of the array C. LDC >= max(1,M).
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension
+* (N) if SIDE = 'L'
+* or (M) if SIDE = 'R'
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE, ZERO
+ PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
+* ..
+* .. External Subroutines ..
+ EXTERNAL DGEMV, DGER
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. Executable Statements ..
+*
+ IF( LSAME( SIDE, 'L' ) ) THEN
+*
+* Form H * C
+*
+ IF( TAU.NE.ZERO ) THEN
+*
+* w := C' * v
+*
+ CALL DGEMV( 'Transpose', M, N, ONE, C, LDC, V, INCV, ZERO,
+ $ WORK, 1 )
+*
+* C := C - v * w'
+*
+ CALL DGER( M, N, -TAU, V, INCV, WORK, 1, C, LDC )
+ END IF
+ ELSE
+*
+* Form C * H
+*
+ IF( TAU.NE.ZERO ) THEN
+*
+* w := C * v
+*
+ CALL DGEMV( 'No transpose', M, N, ONE, C, LDC, V, INCV,
+ $ ZERO, WORK, 1 )
+*
+* C := C - w * v'
+*
+ CALL DGER( M, N, -TAU, WORK, 1, V, INCV, C, LDC )
+ END IF
+ END IF
+ RETURN
+*
+* End of DLARF
+*
+ END
+ SUBROUTINE DLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV,
+ $ T, LDT, C, LDC, WORK, LDWORK )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER DIRECT, SIDE, STOREV, TRANS
+ INTEGER K, LDC, LDT, LDV, LDWORK, M, N
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION C( LDC, * ), T( LDT, * ), V( LDV, * ),
+ $ WORK( LDWORK, * )
+* ..
+*
+* Purpose
+* =======
+*
+* DLARFB applies a real block reflector H or its transpose H' to a
+* real m by n matrix C, from either the left or the right.
+*
+* Arguments
+* =========
+*
+* SIDE (input) CHARACTER*1
+* = 'L': apply H or H' from the Left
+* = 'R': apply H or H' from the Right
+*
+* TRANS (input) CHARACTER*1
+* = 'N': apply H (No transpose)
+* = 'T': apply H' (Transpose)
+*
+* DIRECT (input) CHARACTER*1
+* Indicates how H is formed from a product of elementary
+* reflectors
+* = 'F': H = H(1) H(2) . . . H(k) (Forward)
+* = 'B': H = H(k) . . . H(2) H(1) (Backward)
+*
+* STOREV (input) CHARACTER*1
+* Indicates how the vectors which define the elementary
+* reflectors are stored:
+* = 'C': Columnwise
+* = 'R': Rowwise
+*
+* M (input) INTEGER
+* The number of rows of the matrix C.
+*
+* N (input) INTEGER
+* The number of columns of the matrix C.
+*
+* K (input) INTEGER
+* The order of the matrix T (= the number of elementary
+* reflectors whose product defines the block reflector).
+*
+* V (input) DOUBLE PRECISION array, dimension
+* (LDV,K) if STOREV = 'C'
+* (LDV,M) if STOREV = 'R' and SIDE = 'L'
+* (LDV,N) if STOREV = 'R' and SIDE = 'R'
+* The matrix V. See further details.
+*
+* LDV (input) INTEGER
+* The leading dimension of the array V.
+* If STOREV = 'C' and SIDE = 'L', LDV >= max(1,M);
+* if STOREV = 'C' and SIDE = 'R', LDV >= max(1,N);
+* if STOREV = 'R', LDV >= K.
+*
+* T (input) DOUBLE PRECISION array, dimension (LDT,K)
+* The triangular k by k matrix T in the representation of the
+* block reflector.
+*
+* LDT (input) INTEGER
+* The leading dimension of the array T. LDT >= K.
+*
+* C (input/output) DOUBLE PRECISION array, dimension (LDC,N)
+* On entry, the m by n matrix C.
+* On exit, C is overwritten by H*C or H'*C or C*H or C*H'.
+*
+* LDC (input) INTEGER
+* The leading dimension of the array C. LDA >= max(1,M).
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (LDWORK,K)
+*
+* LDWORK (input) INTEGER
+* The leading dimension of the array WORK.
+* If SIDE = 'L', LDWORK >= max(1,N);
+* if SIDE = 'R', LDWORK >= max(1,M).
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE
+ PARAMETER ( ONE = 1.0D+0 )
+* ..
+* .. Local Scalars ..
+ CHARACTER TRANST
+ INTEGER I, J
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL DCOPY, DGEMM, DTRMM
+* ..
+* .. Executable Statements ..
+*
+* Quick return if possible
+*
+ IF( M.LE.0 .OR. N.LE.0 )
+ $ RETURN
+*
+ IF( LSAME( TRANS, 'N' ) ) THEN
+ TRANST = 'T'
+ ELSE
+ TRANST = 'N'
+ END IF
+*
+ IF( LSAME( STOREV, 'C' ) ) THEN
+*
+ IF( LSAME( DIRECT, 'F' ) ) THEN
+*
+* Let V = ( V1 ) (first K rows)
+* ( V2 )
+* where V1 is unit lower triangular.
+*
+ IF( LSAME( SIDE, 'L' ) ) THEN
+*
+* Form H * C or H' * C where C = ( C1 )
+* ( C2 )
+*
+* W := C' * V = (C1'*V1 + C2'*V2) (stored in WORK)
+*
+* W := C1'
+*
+ DO 10 J = 1, K
+ CALL DCOPY( N, C( J, 1 ), LDC, WORK( 1, J ), 1 )
+ 10 CONTINUE
+*
+* W := W * V1
+*
+ CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', N,
+ $ K, ONE, V, LDV, WORK, LDWORK )
+ IF( M.GT.K ) THEN
+*
+* W := W + C2'*V2
+*
+ CALL DGEMM( 'Transpose', 'No transpose', N, K, M-K,
+ $ ONE, C( K+1, 1 ), LDC, V( K+1, 1 ), LDV,
+ $ ONE, WORK, LDWORK )
+ END IF
+*
+* W := W * T' or W * T
+*
+ CALL DTRMM( 'Right', 'Upper', TRANST, 'Non-unit', N, K,
+ $ ONE, T, LDT, WORK, LDWORK )
+*
+* C := C - V * W'
+*
+ IF( M.GT.K ) THEN
+*
+* C2 := C2 - V2 * W'
+*
+ CALL DGEMM( 'No transpose', 'Transpose', M-K, N, K,
+ $ -ONE, V( K+1, 1 ), LDV, WORK, LDWORK, ONE,
+ $ C( K+1, 1 ), LDC )
+ END IF
+*
+* W := W * V1'
+*
+ CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', N, K,
+ $ ONE, V, LDV, WORK, LDWORK )
+*
+* C1 := C1 - W'
+*
+ DO 30 J = 1, K
+ DO 20 I = 1, N
+ C( J, I ) = C( J, I ) - WORK( I, J )
+ 20 CONTINUE
+ 30 CONTINUE
+*
+ ELSE IF( LSAME( SIDE, 'R' ) ) THEN
+*
+* Form C * H or C * H' where C = ( C1 C2 )
+*
+* W := C * V = (C1*V1 + C2*V2) (stored in WORK)
+*
+* W := C1
+*
+ DO 40 J = 1, K
+ CALL DCOPY( M, C( 1, J ), 1, WORK( 1, J ), 1 )
+ 40 CONTINUE
+*
+* W := W * V1
+*
+ CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', M,
+ $ K, ONE, V, LDV, WORK, LDWORK )
+ IF( N.GT.K ) THEN
+*
+* W := W + C2 * V2
+*
+ CALL DGEMM( 'No transpose', 'No transpose', M, K, N-K,
+ $ ONE, C( 1, K+1 ), LDC, V( K+1, 1 ), LDV,
+ $ ONE, WORK, LDWORK )
+ END IF
+*
+* W := W * T or W * T'
+*
+ CALL DTRMM( 'Right', 'Upper', TRANS, 'Non-unit', M, K,
+ $ ONE, T, LDT, WORK, LDWORK )
+*
+* C := C - W * V'
+*
+ IF( N.GT.K ) THEN
+*
+* C2 := C2 - W * V2'
+*
+ CALL DGEMM( 'No transpose', 'Transpose', M, N-K, K,
+ $ -ONE, WORK, LDWORK, V( K+1, 1 ), LDV, ONE,
+ $ C( 1, K+1 ), LDC )
+ END IF
+*
+* W := W * V1'
+*
+ CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', M, K,
+ $ ONE, V, LDV, WORK, LDWORK )
+*
+* C1 := C1 - W
+*
+ DO 60 J = 1, K
+ DO 50 I = 1, M
+ C( I, J ) = C( I, J ) - WORK( I, J )
+ 50 CONTINUE
+ 60 CONTINUE
+ END IF
+*
+ ELSE
+*
+* Let V = ( V1 )
+* ( V2 ) (last K rows)
+* where V2 is unit upper triangular.
+*
+ IF( LSAME( SIDE, 'L' ) ) THEN
+*
+* Form H * C or H' * C where C = ( C1 )
+* ( C2 )
+*
+* W := C' * V = (C1'*V1 + C2'*V2) (stored in WORK)
+*
+* W := C2'
+*
+ DO 70 J = 1, K
+ CALL DCOPY( N, C( M-K+J, 1 ), LDC, WORK( 1, J ), 1 )
+ 70 CONTINUE
+*
+* W := W * V2
+*
+ CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', N,
+ $ K, ONE, V( M-K+1, 1 ), LDV, WORK, LDWORK )
+ IF( M.GT.K ) THEN
+*
+* W := W + C1'*V1
+*
+ CALL DGEMM( 'Transpose', 'No transpose', N, K, M-K,
+ $ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK )
+ END IF
+*
+* W := W * T' or W * T
+*
+ CALL DTRMM( 'Right', 'Lower', TRANST, 'Non-unit', N, K,
+ $ ONE, T, LDT, WORK, LDWORK )
+*
+* C := C - V * W'
+*
+ IF( M.GT.K ) THEN
+*
+* C1 := C1 - V1 * W'
+*
+ CALL DGEMM( 'No transpose', 'Transpose', M-K, N, K,
+ $ -ONE, V, LDV, WORK, LDWORK, ONE, C, LDC )
+ END IF
+*
+* W := W * V2'
+*
+ CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', N, K,
+ $ ONE, V( M-K+1, 1 ), LDV, WORK, LDWORK )
+*
+* C2 := C2 - W'
+*
+ DO 90 J = 1, K
+ DO 80 I = 1, N
+ C( M-K+J, I ) = C( M-K+J, I ) - WORK( I, J )
+ 80 CONTINUE
+ 90 CONTINUE
+*
+ ELSE IF( LSAME( SIDE, 'R' ) ) THEN
+*
+* Form C * H or C * H' where C = ( C1 C2 )
+*
+* W := C * V = (C1*V1 + C2*V2) (stored in WORK)
+*
+* W := C2
+*
+ DO 100 J = 1, K
+ CALL DCOPY( M, C( 1, N-K+J ), 1, WORK( 1, J ), 1 )
+ 100 CONTINUE
+*
+* W := W * V2
+*
+ CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', M,
+ $ K, ONE, V( N-K+1, 1 ), LDV, WORK, LDWORK )
+ IF( N.GT.K ) THEN
+*
+* W := W + C1 * V1
+*
+ CALL DGEMM( 'No transpose', 'No transpose', M, K, N-K,
+ $ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK )
+ END IF
+*
+* W := W * T or W * T'
+*
+ CALL DTRMM( 'Right', 'Lower', TRANS, 'Non-unit', M, K,
+ $ ONE, T, LDT, WORK, LDWORK )
+*
+* C := C - W * V'
+*
+ IF( N.GT.K ) THEN
+*
+* C1 := C1 - W * V1'
+*
+ CALL DGEMM( 'No transpose', 'Transpose', M, N-K, K,
+ $ -ONE, WORK, LDWORK, V, LDV, ONE, C, LDC )
+ END IF
+*
+* W := W * V2'
+*
+ CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', M, K,
+ $ ONE, V( N-K+1, 1 ), LDV, WORK, LDWORK )
+*
+* C2 := C2 - W
+*
+ DO 120 J = 1, K
+ DO 110 I = 1, M
+ C( I, N-K+J ) = C( I, N-K+J ) - WORK( I, J )
+ 110 CONTINUE
+ 120 CONTINUE
+ END IF
+ END IF
+*
+ ELSE IF( LSAME( STOREV, 'R' ) ) THEN
+*
+ IF( LSAME( DIRECT, 'F' ) ) THEN
+*
+* Let V = ( V1 V2 ) (V1: first K columns)
+* where V1 is unit upper triangular.
+*
+ IF( LSAME( SIDE, 'L' ) ) THEN
+*
+* Form H * C or H' * C where C = ( C1 )
+* ( C2 )
+*
+* W := C' * V' = (C1'*V1' + C2'*V2') (stored in WORK)
+*
+* W := C1'
+*
+ DO 130 J = 1, K
+ CALL DCOPY( N, C( J, 1 ), LDC, WORK( 1, J ), 1 )
+ 130 CONTINUE
+*
+* W := W * V1'
+*
+ CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', N, K,
+ $ ONE, V, LDV, WORK, LDWORK )
+ IF( M.GT.K ) THEN
+*
+* W := W + C2'*V2'
+*
+ CALL DGEMM( 'Transpose', 'Transpose', N, K, M-K, ONE,
+ $ C( K+1, 1 ), LDC, V( 1, K+1 ), LDV, ONE,
+ $ WORK, LDWORK )
+ END IF
+*
+* W := W * T' or W * T
+*
+ CALL DTRMM( 'Right', 'Upper', TRANST, 'Non-unit', N, K,
+ $ ONE, T, LDT, WORK, LDWORK )
+*
+* C := C - V' * W'
+*
+ IF( M.GT.K ) THEN
+*
+* C2 := C2 - V2' * W'
+*
+ CALL DGEMM( 'Transpose', 'Transpose', M-K, N, K, -ONE,
+ $ V( 1, K+1 ), LDV, WORK, LDWORK, ONE,
+ $ C( K+1, 1 ), LDC )
+ END IF
+*
+* W := W * V1
+*
+ CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', N,
+ $ K, ONE, V, LDV, WORK, LDWORK )
+*
+* C1 := C1 - W'
+*
+ DO 150 J = 1, K
+ DO 140 I = 1, N
+ C( J, I ) = C( J, I ) - WORK( I, J )
+ 140 CONTINUE
+ 150 CONTINUE
+*
+ ELSE IF( LSAME( SIDE, 'R' ) ) THEN
+*
+* Form C * H or C * H' where C = ( C1 C2 )
+*
+* W := C * V' = (C1*V1' + C2*V2') (stored in WORK)
+*
+* W := C1
+*
+ DO 160 J = 1, K
+ CALL DCOPY( M, C( 1, J ), 1, WORK( 1, J ), 1 )
+ 160 CONTINUE
+*
+* W := W * V1'
+*
+ CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Unit', M, K,
+ $ ONE, V, LDV, WORK, LDWORK )
+ IF( N.GT.K ) THEN
+*
+* W := W + C2 * V2'
+*
+ CALL DGEMM( 'No transpose', 'Transpose', M, K, N-K,
+ $ ONE, C( 1, K+1 ), LDC, V( 1, K+1 ), LDV,
+ $ ONE, WORK, LDWORK )
+ END IF
+*
+* W := W * T or W * T'
+*
+ CALL DTRMM( 'Right', 'Upper', TRANS, 'Non-unit', M, K,
+ $ ONE, T, LDT, WORK, LDWORK )
+*
+* C := C - W * V
+*
+ IF( N.GT.K ) THEN
+*
+* C2 := C2 - W * V2
+*
+ CALL DGEMM( 'No transpose', 'No transpose', M, N-K, K,
+ $ -ONE, WORK, LDWORK, V( 1, K+1 ), LDV, ONE,
+ $ C( 1, K+1 ), LDC )
+ END IF
+*
+* W := W * V1
+*
+ CALL DTRMM( 'Right', 'Upper', 'No transpose', 'Unit', M,
+ $ K, ONE, V, LDV, WORK, LDWORK )
+*
+* C1 := C1 - W
+*
+ DO 180 J = 1, K
+ DO 170 I = 1, M
+ C( I, J ) = C( I, J ) - WORK( I, J )
+ 170 CONTINUE
+ 180 CONTINUE
+*
+ END IF
+*
+ ELSE
+*
+* Let V = ( V1 V2 ) (V2: last K columns)
+* where V2 is unit lower triangular.
+*
+ IF( LSAME( SIDE, 'L' ) ) THEN
+*
+* Form H * C or H' * C where C = ( C1 )
+* ( C2 )
+*
+* W := C' * V' = (C1'*V1' + C2'*V2') (stored in WORK)
+*
+* W := C2'
+*
+ DO 190 J = 1, K
+ CALL DCOPY( N, C( M-K+J, 1 ), LDC, WORK( 1, J ), 1 )
+ 190 CONTINUE
+*
+* W := W * V2'
+*
+ CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', N, K,
+ $ ONE, V( 1, M-K+1 ), LDV, WORK, LDWORK )
+ IF( M.GT.K ) THEN
+*
+* W := W + C1'*V1'
+*
+ CALL DGEMM( 'Transpose', 'Transpose', N, K, M-K, ONE,
+ $ C, LDC, V, LDV, ONE, WORK, LDWORK )
+ END IF
+*
+* W := W * T' or W * T
+*
+ CALL DTRMM( 'Right', 'Lower', TRANST, 'Non-unit', N, K,
+ $ ONE, T, LDT, WORK, LDWORK )
+*
+* C := C - V' * W'
+*
+ IF( M.GT.K ) THEN
+*
+* C1 := C1 - V1' * W'
+*
+ CALL DGEMM( 'Transpose', 'Transpose', M-K, N, K, -ONE,
+ $ V, LDV, WORK, LDWORK, ONE, C, LDC )
+ END IF
+*
+* W := W * V2
+*
+ CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', N,
+ $ K, ONE, V( 1, M-K+1 ), LDV, WORK, LDWORK )
+*
+* C2 := C2 - W'
+*
+ DO 210 J = 1, K
+ DO 200 I = 1, N
+ C( M-K+J, I ) = C( M-K+J, I ) - WORK( I, J )
+ 200 CONTINUE
+ 210 CONTINUE
+*
+ ELSE IF( LSAME( SIDE, 'R' ) ) THEN
+*
+* Form C * H or C * H' where C = ( C1 C2 )
+*
+* W := C * V' = (C1*V1' + C2*V2') (stored in WORK)
+*
+* W := C2
+*
+ DO 220 J = 1, K
+ CALL DCOPY( M, C( 1, N-K+J ), 1, WORK( 1, J ), 1 )
+ 220 CONTINUE
+*
+* W := W * V2'
+*
+ CALL DTRMM( 'Right', 'Lower', 'Transpose', 'Unit', M, K,
+ $ ONE, V( 1, N-K+1 ), LDV, WORK, LDWORK )
+ IF( N.GT.K ) THEN
+*
+* W := W + C1 * V1'
+*
+ CALL DGEMM( 'No transpose', 'Transpose', M, K, N-K,
+ $ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK )
+ END IF
+*
+* W := W * T or W * T'
+*
+ CALL DTRMM( 'Right', 'Lower', TRANS, 'Non-unit', M, K,
+ $ ONE, T, LDT, WORK, LDWORK )
+*
+* C := C - W * V
+*
+ IF( N.GT.K ) THEN
+*
+* C1 := C1 - W * V1
+*
+ CALL DGEMM( 'No transpose', 'No transpose', M, N-K, K,
+ $ -ONE, WORK, LDWORK, V, LDV, ONE, C, LDC )
+ END IF
+*
+* W := W * V2
+*
+ CALL DTRMM( 'Right', 'Lower', 'No transpose', 'Unit', M,
+ $ K, ONE, V( 1, N-K+1 ), LDV, WORK, LDWORK )
+*
+* C1 := C1 - W
+*
+ DO 240 J = 1, K
+ DO 230 I = 1, M
+ C( I, N-K+J ) = C( I, N-K+J ) - WORK( I, J )
+ 230 CONTINUE
+ 240 CONTINUE
+*
+ END IF
+*
+ END IF
+ END IF
+*
+ RETURN
+*
+* End of DLARFB
+*
+ END
+ SUBROUTINE DLARFG( N, ALPHA, X, INCX, TAU )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INCX, N
+ DOUBLE PRECISION ALPHA, TAU
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION X( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DLARFG generates a real elementary reflector H of order n, such
+* that
+*
+* H * ( alpha ) = ( beta ), H' * H = I.
+* ( x ) ( 0 )
+*
+* where alpha and beta are scalars, and x is an (n-1)-element real
+* vector. H is represented in the form
+*
+* H = I - tau * ( 1 ) * ( 1 v' ) ,
+* ( v )
+*
+* where tau is a real scalar and v is a real (n-1)-element
+* vector.
+*
+* If the elements of x are all zero, then tau = 0 and H is taken to be
+* the unit matrix.
+*
+* Otherwise 1 <= tau <= 2.
+*
+* Arguments
+* =========
+*
+* N (input) INTEGER
+* The order of the elementary reflector.
+*
+* ALPHA (input/output) DOUBLE PRECISION
+* On entry, the value alpha.
+* On exit, it is overwritten with the value beta.
+*
+* X (input/output) DOUBLE PRECISION array, dimension
+* (1+(N-2)*abs(INCX))
+* On entry, the vector x.
+* On exit, it is overwritten with the vector v.
+*
+* INCX (input) INTEGER
+* The increment between elements of X. INCX > 0.
+*
+* TAU (output) DOUBLE PRECISION
+* The value tau.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE, ZERO
+ PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER J, KNT
+ DOUBLE PRECISION BETA, RSAFMN, SAFMIN, XNORM
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DLAMCH, DLAPY2, DNRM2
+ EXTERNAL DLAMCH, DLAPY2, DNRM2
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, SIGN
+* ..
+* .. External Subroutines ..
+ EXTERNAL DSCAL
+* ..
+* .. Executable Statements ..
+*
+ IF( N.LE.1 ) THEN
+ TAU = ZERO
+ RETURN
+ END IF
+*
+ XNORM = DNRM2( N-1, X, INCX )
+*
+ IF( XNORM.EQ.ZERO ) THEN
+*
+* H = I
+*
+ TAU = ZERO
+ ELSE
+*
+* general case
+*
+ BETA = -SIGN( DLAPY2( ALPHA, XNORM ), ALPHA )
+ SAFMIN = DLAMCH( 'S' ) / DLAMCH( 'E' )
+ IF( ABS( BETA ).LT.SAFMIN ) THEN
+*
+* XNORM, BETA may be inaccurate; scale X and recompute them
+*
+ RSAFMN = ONE / SAFMIN
+ KNT = 0
+ 10 CONTINUE
+ KNT = KNT + 1
+ CALL DSCAL( N-1, RSAFMN, X, INCX )
+ BETA = BETA*RSAFMN
+ ALPHA = ALPHA*RSAFMN
+ IF( ABS( BETA ).LT.SAFMIN )
+ $ GO TO 10
+*
+* New BETA is at most 1, at least SAFMIN
+*
+ XNORM = DNRM2( N-1, X, INCX )
+ BETA = -SIGN( DLAPY2( ALPHA, XNORM ), ALPHA )
+ TAU = ( BETA-ALPHA ) / BETA
+ CALL DSCAL( N-1, ONE / ( ALPHA-BETA ), X, INCX )
+*
+* If ALPHA is subnormal, it may lose relative accuracy
+*
+ ALPHA = BETA
+ DO 20 J = 1, KNT
+ ALPHA = ALPHA*SAFMIN
+ 20 CONTINUE
+ ELSE
+ TAU = ( BETA-ALPHA ) / BETA
+ CALL DSCAL( N-1, ONE / ( ALPHA-BETA ), X, INCX )
+ ALPHA = BETA
+ END IF
+ END IF
+*
+ RETURN
+*
+* End of DLARFG
+*
+ END
+ SUBROUTINE DLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER DIRECT, STOREV
+ INTEGER K, LDT, LDV, N
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION T( LDT, * ), TAU( * ), V( LDV, * )
+* ..
+*
+* Purpose
+* =======
+*
+* DLARFT forms the triangular factor T of a real block reflector H
+* of order n, which is defined as a product of k elementary reflectors.
+*
+* If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular;
+*
+* If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular.
+*
+* If STOREV = 'C', the vector which defines the elementary reflector
+* H(i) is stored in the i-th column of the array V, and
+*
+* H = I - V * T * V'
+*
+* If STOREV = 'R', the vector which defines the elementary reflector
+* H(i) is stored in the i-th row of the array V, and
+*
+* H = I - V' * T * V
+*
+* Arguments
+* =========
+*
+* DIRECT (input) CHARACTER*1
+* Specifies the order in which the elementary reflectors are
+* multiplied to form the block reflector:
+* = 'F': H = H(1) H(2) . . . H(k) (Forward)
+* = 'B': H = H(k) . . . H(2) H(1) (Backward)
+*
+* STOREV (input) CHARACTER*1
+* Specifies how the vectors which define the elementary
+* reflectors are stored (see also Further Details):
+* = 'C': columnwise
+* = 'R': rowwise
+*
+* N (input) INTEGER
+* The order of the block reflector H. N >= 0.
+*
+* K (input) INTEGER
+* The order of the triangular factor T (= the number of
+* elementary reflectors). K >= 1.
+*
+* V (input/output) DOUBLE PRECISION array, dimension
+* (LDV,K) if STOREV = 'C'
+* (LDV,N) if STOREV = 'R'
+* The matrix V. See further details.
+*
+* LDV (input) INTEGER
+* The leading dimension of the array V.
+* If STOREV = 'C', LDV >= max(1,N); if STOREV = 'R', LDV >= K.
+*
+* TAU (input) DOUBLE PRECISION array, dimension (K)
+* TAU(i) must contain the scalar factor of the elementary
+* reflector H(i).
+*
+* T (output) DOUBLE PRECISION array, dimension (LDT,K)
+* The k by k triangular factor T of the block reflector.
+* If DIRECT = 'F', T is upper triangular; if DIRECT = 'B', T is
+* lower triangular. The rest of the array is not used.
+*
+* LDT (input) INTEGER
+* The leading dimension of the array T. LDT >= K.
+*
+* Further Details
+* ===============
+*
+* The shape of the matrix V and the storage of the vectors which define
+* the H(i) is best illustrated by the following example with n = 5 and
+* k = 3. The elements equal to 1 are not stored; the corresponding
+* array elements are modified but restored on exit. The rest of the
+* array is not used.
+*
+* DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R':
+*
+* V = ( 1 ) V = ( 1 v1 v1 v1 v1 )
+* ( v1 1 ) ( 1 v2 v2 v2 )
+* ( v1 v2 1 ) ( 1 v3 v3 )
+* ( v1 v2 v3 )
+* ( v1 v2 v3 )
+*
+* DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R':
+*
+* V = ( v1 v2 v3 ) V = ( v1 v1 1 )
+* ( v1 v2 v3 ) ( v2 v2 v2 1 )
+* ( 1 v2 v3 ) ( v3 v3 v3 v3 1 )
+* ( 1 v3 )
+* ( 1 )
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE, ZERO
+ PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, J
+ DOUBLE PRECISION VII
+* ..
+* .. External Subroutines ..
+ EXTERNAL DGEMV, DTRMV
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. Executable Statements ..
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+ IF( LSAME( DIRECT, 'F' ) ) THEN
+ DO 20 I = 1, K
+ IF( TAU( I ).EQ.ZERO ) THEN
+*
+* H(i) = I
+*
+ DO 10 J = 1, I
+ T( J, I ) = ZERO
+ 10 CONTINUE
+ ELSE
+*
+* general case
+*
+ VII = V( I, I )
+ V( I, I ) = ONE
+ IF( LSAME( STOREV, 'C' ) ) THEN
+*
+* T(1:i-1,i) := - tau(i) * V(i:n,1:i-1)' * V(i:n,i)
+*
+ CALL DGEMV( 'Transpose', N-I+1, I-1, -TAU( I ),
+ $ V( I, 1 ), LDV, V( I, I ), 1, ZERO,
+ $ T( 1, I ), 1 )
+ ELSE
+*
+* T(1:i-1,i) := - tau(i) * V(1:i-1,i:n) * V(i,i:n)'
+*
+ CALL DGEMV( 'No transpose', I-1, N-I+1, -TAU( I ),
+ $ V( 1, I ), LDV, V( I, I ), LDV, ZERO,
+ $ T( 1, I ), 1 )
+ END IF
+ V( I, I ) = VII
+*
+* T(1:i-1,i) := T(1:i-1,1:i-1) * T(1:i-1,i)
+*
+ CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', I-1, T,
+ $ LDT, T( 1, I ), 1 )
+ T( I, I ) = TAU( I )
+ END IF
+ 20 CONTINUE
+ ELSE
+ DO 40 I = K, 1, -1
+ IF( TAU( I ).EQ.ZERO ) THEN
+*
+* H(i) = I
+*
+ DO 30 J = I, K
+ T( J, I ) = ZERO
+ 30 CONTINUE
+ ELSE
+*
+* general case
+*
+ IF( I.LT.K ) THEN
+ IF( LSAME( STOREV, 'C' ) ) THEN
+ VII = V( N-K+I, I )
+ V( N-K+I, I ) = ONE
+*
+* T(i+1:k,i) :=
+* - tau(i) * V(1:n-k+i,i+1:k)' * V(1:n-k+i,i)
+*
+ CALL DGEMV( 'Transpose', N-K+I, K-I, -TAU( I ),
+ $ V( 1, I+1 ), LDV, V( 1, I ), 1, ZERO,
+ $ T( I+1, I ), 1 )
+ V( N-K+I, I ) = VII
+ ELSE
+ VII = V( I, N-K+I )
+ V( I, N-K+I ) = ONE
+*
+* T(i+1:k,i) :=
+* - tau(i) * V(i+1:k,1:n-k+i) * V(i,1:n-k+i)'
+*
+ CALL DGEMV( 'No transpose', K-I, N-K+I, -TAU( I ),
+ $ V( I+1, 1 ), LDV, V( I, 1 ), LDV, ZERO,
+ $ T( I+1, I ), 1 )
+ V( I, N-K+I ) = VII
+ END IF
+*
+* T(i+1:k,i) := T(i+1:k,i+1:k) * T(i+1:k,i)
+*
+ CALL DTRMV( 'Lower', 'No transpose', 'Non-unit', K-I,
+ $ T( I+1, I+1 ), LDT, T( I+1, I ), 1 )
+ END IF
+ T( I, I ) = TAU( I )
+ END IF
+ 40 CONTINUE
+ END IF
+ RETURN
+*
+* End of DLARFT
+*
+ END
+ SUBROUTINE DLARFX( SIDE, M, N, V, TAU, C, LDC, WORK )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER SIDE
+ INTEGER LDC, M, N
+ DOUBLE PRECISION TAU
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION C( LDC, * ), V( * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DLARFX applies a real elementary reflector H to a real m by n
+* matrix C, from either the left or the right. H is represented in the
+* form
+*
+* H = I - tau * v * v'
+*
+* where tau is a real scalar and v is a real vector.
+*
+* If tau = 0, then H is taken to be the unit matrix
+*
+* This version uses inline code if H has order < 11.
+*
+* Arguments
+* =========
+*
+* SIDE (input) CHARACTER*1
+* = 'L': form H * C
+* = 'R': form C * H
+*
+* M (input) INTEGER
+* The number of rows of the matrix C.
+*
+* N (input) INTEGER
+* The number of columns of the matrix C.
+*
+* V (input) DOUBLE PRECISION array, dimension (M) if SIDE = 'L'
+* or (N) if SIDE = 'R'
+* The vector v in the representation of H.
+*
+* TAU (input) DOUBLE PRECISION
+* The value tau in the representation of H.
+*
+* C (input/output) DOUBLE PRECISION array, dimension (LDC,N)
+* On entry, the m by n matrix C.
+* On exit, C is overwritten by the matrix H * C if SIDE = 'L',
+* or C * H if SIDE = 'R'.
+*
+* LDC (input) INTEGER
+* The leading dimension of the array C. LDA >= (1,M).
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension
+* (N) if SIDE = 'L'
+* or (M) if SIDE = 'R'
+* WORK is not referenced if H has order < 11.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER J
+ DOUBLE PRECISION SUM, T1, T10, T2, T3, T4, T5, T6, T7, T8, T9,
+ $ V1, V10, V2, V3, V4, V5, V6, V7, V8, V9
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL DGEMV, DGER
+* ..
+* .. Executable Statements ..
+*
+ IF( TAU.EQ.ZERO )
+ $ RETURN
+ IF( LSAME( SIDE, 'L' ) ) THEN
+*
+* Form H * C, where H has order m.
+*
+ GO TO ( 10, 30, 50, 70, 90, 110, 130, 150,
+ $ 170, 190 )M
+*
+* Code for general M
+*
+* w := C'*v
+*
+ CALL DGEMV( 'Transpose', M, N, ONE, C, LDC, V, 1, ZERO, WORK,
+ $ 1 )
+*
+* C := C - tau * v * w'
+*
+ CALL DGER( M, N, -TAU, V, 1, WORK, 1, C, LDC )
+ GO TO 410
+ 10 CONTINUE
+*
+* Special code for 1 x 1 Householder
+*
+ T1 = ONE - TAU*V( 1 )*V( 1 )
+ DO 20 J = 1, N
+ C( 1, J ) = T1*C( 1, J )
+ 20 CONTINUE
+ GO TO 410
+ 30 CONTINUE
+*
+* Special code for 2 x 2 Householder
+*
+ V1 = V( 1 )
+ T1 = TAU*V1
+ V2 = V( 2 )
+ T2 = TAU*V2
+ DO 40 J = 1, N
+ SUM = V1*C( 1, J ) + V2*C( 2, J )
+ C( 1, J ) = C( 1, J ) - SUM*T1
+ C( 2, J ) = C( 2, J ) - SUM*T2
+ 40 CONTINUE
+ GO TO 410
+ 50 CONTINUE
+*
+* Special code for 3 x 3 Householder
+*
+ V1 = V( 1 )
+ T1 = TAU*V1
+ V2 = V( 2 )
+ T2 = TAU*V2
+ V3 = V( 3 )
+ T3 = TAU*V3
+ DO 60 J = 1, N
+ SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J )
+ C( 1, J ) = C( 1, J ) - SUM*T1
+ C( 2, J ) = C( 2, J ) - SUM*T2
+ C( 3, J ) = C( 3, J ) - SUM*T3
+ 60 CONTINUE
+ GO TO 410
+ 70 CONTINUE
+*
+* Special code for 4 x 4 Householder
+*
+ V1 = V( 1 )
+ T1 = TAU*V1
+ V2 = V( 2 )
+ T2 = TAU*V2
+ V3 = V( 3 )
+ T3 = TAU*V3
+ V4 = V( 4 )
+ T4 = TAU*V4
+ DO 80 J = 1, N
+ SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) +
+ $ V4*C( 4, J )
+ C( 1, J ) = C( 1, J ) - SUM*T1
+ C( 2, J ) = C( 2, J ) - SUM*T2
+ C( 3, J ) = C( 3, J ) - SUM*T3
+ C( 4, J ) = C( 4, J ) - SUM*T4
+ 80 CONTINUE
+ GO TO 410
+ 90 CONTINUE
+*
+* Special code for 5 x 5 Householder
+*
+ V1 = V( 1 )
+ T1 = TAU*V1
+ V2 = V( 2 )
+ T2 = TAU*V2
+ V3 = V( 3 )
+ T3 = TAU*V3
+ V4 = V( 4 )
+ T4 = TAU*V4
+ V5 = V( 5 )
+ T5 = TAU*V5
+ DO 100 J = 1, N
+ SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) +
+ $ V4*C( 4, J ) + V5*C( 5, J )
+ C( 1, J ) = C( 1, J ) - SUM*T1
+ C( 2, J ) = C( 2, J ) - SUM*T2
+ C( 3, J ) = C( 3, J ) - SUM*T3
+ C( 4, J ) = C( 4, J ) - SUM*T4
+ C( 5, J ) = C( 5, J ) - SUM*T5
+ 100 CONTINUE
+ GO TO 410
+ 110 CONTINUE
+*
+* Special code for 6 x 6 Householder
+*
+ V1 = V( 1 )
+ T1 = TAU*V1
+ V2 = V( 2 )
+ T2 = TAU*V2
+ V3 = V( 3 )
+ T3 = TAU*V3
+ V4 = V( 4 )
+ T4 = TAU*V4
+ V5 = V( 5 )
+ T5 = TAU*V5
+ V6 = V( 6 )
+ T6 = TAU*V6
+ DO 120 J = 1, N
+ SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) +
+ $ V4*C( 4, J ) + V5*C( 5, J ) + V6*C( 6, J )
+ C( 1, J ) = C( 1, J ) - SUM*T1
+ C( 2, J ) = C( 2, J ) - SUM*T2
+ C( 3, J ) = C( 3, J ) - SUM*T3
+ C( 4, J ) = C( 4, J ) - SUM*T4
+ C( 5, J ) = C( 5, J ) - SUM*T5
+ C( 6, J ) = C( 6, J ) - SUM*T6
+ 120 CONTINUE
+ GO TO 410
+ 130 CONTINUE
+*
+* Special code for 7 x 7 Householder
+*
+ V1 = V( 1 )
+ T1 = TAU*V1
+ V2 = V( 2 )
+ T2 = TAU*V2
+ V3 = V( 3 )
+ T3 = TAU*V3
+ V4 = V( 4 )
+ T4 = TAU*V4
+ V5 = V( 5 )
+ T5 = TAU*V5
+ V6 = V( 6 )
+ T6 = TAU*V6
+ V7 = V( 7 )
+ T7 = TAU*V7
+ DO 140 J = 1, N
+ SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) +
+ $ V4*C( 4, J ) + V5*C( 5, J ) + V6*C( 6, J ) +
+ $ V7*C( 7, J )
+ C( 1, J ) = C( 1, J ) - SUM*T1
+ C( 2, J ) = C( 2, J ) - SUM*T2
+ C( 3, J ) = C( 3, J ) - SUM*T3
+ C( 4, J ) = C( 4, J ) - SUM*T4
+ C( 5, J ) = C( 5, J ) - SUM*T5
+ C( 6, J ) = C( 6, J ) - SUM*T6
+ C( 7, J ) = C( 7, J ) - SUM*T7
+ 140 CONTINUE
+ GO TO 410
+ 150 CONTINUE
+*
+* Special code for 8 x 8 Householder
+*
+ V1 = V( 1 )
+ T1 = TAU*V1
+ V2 = V( 2 )
+ T2 = TAU*V2
+ V3 = V( 3 )
+ T3 = TAU*V3
+ V4 = V( 4 )
+ T4 = TAU*V4
+ V5 = V( 5 )
+ T5 = TAU*V5
+ V6 = V( 6 )
+ T6 = TAU*V6
+ V7 = V( 7 )
+ T7 = TAU*V7
+ V8 = V( 8 )
+ T8 = TAU*V8
+ DO 160 J = 1, N
+ SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) +
+ $ V4*C( 4, J ) + V5*C( 5, J ) + V6*C( 6, J ) +
+ $ V7*C( 7, J ) + V8*C( 8, J )
+ C( 1, J ) = C( 1, J ) - SUM*T1
+ C( 2, J ) = C( 2, J ) - SUM*T2
+ C( 3, J ) = C( 3, J ) - SUM*T3
+ C( 4, J ) = C( 4, J ) - SUM*T4
+ C( 5, J ) = C( 5, J ) - SUM*T5
+ C( 6, J ) = C( 6, J ) - SUM*T6
+ C( 7, J ) = C( 7, J ) - SUM*T7
+ C( 8, J ) = C( 8, J ) - SUM*T8
+ 160 CONTINUE
+ GO TO 410
+ 170 CONTINUE
+*
+* Special code for 9 x 9 Householder
+*
+ V1 = V( 1 )
+ T1 = TAU*V1
+ V2 = V( 2 )
+ T2 = TAU*V2
+ V3 = V( 3 )
+ T3 = TAU*V3
+ V4 = V( 4 )
+ T4 = TAU*V4
+ V5 = V( 5 )
+ T5 = TAU*V5
+ V6 = V( 6 )
+ T6 = TAU*V6
+ V7 = V( 7 )
+ T7 = TAU*V7
+ V8 = V( 8 )
+ T8 = TAU*V8
+ V9 = V( 9 )
+ T9 = TAU*V9
+ DO 180 J = 1, N
+ SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) +
+ $ V4*C( 4, J ) + V5*C( 5, J ) + V6*C( 6, J ) +
+ $ V7*C( 7, J ) + V8*C( 8, J ) + V9*C( 9, J )
+ C( 1, J ) = C( 1, J ) - SUM*T1
+ C( 2, J ) = C( 2, J ) - SUM*T2
+ C( 3, J ) = C( 3, J ) - SUM*T3
+ C( 4, J ) = C( 4, J ) - SUM*T4
+ C( 5, J ) = C( 5, J ) - SUM*T5
+ C( 6, J ) = C( 6, J ) - SUM*T6
+ C( 7, J ) = C( 7, J ) - SUM*T7
+ C( 8, J ) = C( 8, J ) - SUM*T8
+ C( 9, J ) = C( 9, J ) - SUM*T9
+ 180 CONTINUE
+ GO TO 410
+ 190 CONTINUE
+*
+* Special code for 10 x 10 Householder
+*
+ V1 = V( 1 )
+ T1 = TAU*V1
+ V2 = V( 2 )
+ T2 = TAU*V2
+ V3 = V( 3 )
+ T3 = TAU*V3
+ V4 = V( 4 )
+ T4 = TAU*V4
+ V5 = V( 5 )
+ T5 = TAU*V5
+ V6 = V( 6 )
+ T6 = TAU*V6
+ V7 = V( 7 )
+ T7 = TAU*V7
+ V8 = V( 8 )
+ T8 = TAU*V8
+ V9 = V( 9 )
+ T9 = TAU*V9
+ V10 = V( 10 )
+ T10 = TAU*V10
+ DO 200 J = 1, N
+ SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) +
+ $ V4*C( 4, J ) + V5*C( 5, J ) + V6*C( 6, J ) +
+ $ V7*C( 7, J ) + V8*C( 8, J ) + V9*C( 9, J ) +
+ $ V10*C( 10, J )
+ C( 1, J ) = C( 1, J ) - SUM*T1
+ C( 2, J ) = C( 2, J ) - SUM*T2
+ C( 3, J ) = C( 3, J ) - SUM*T3
+ C( 4, J ) = C( 4, J ) - SUM*T4
+ C( 5, J ) = C( 5, J ) - SUM*T5
+ C( 6, J ) = C( 6, J ) - SUM*T6
+ C( 7, J ) = C( 7, J ) - SUM*T7
+ C( 8, J ) = C( 8, J ) - SUM*T8
+ C( 9, J ) = C( 9, J ) - SUM*T9
+ C( 10, J ) = C( 10, J ) - SUM*T10
+ 200 CONTINUE
+ GO TO 410
+ ELSE
+*
+* Form C * H, where H has order n.
+*
+ GO TO ( 210, 230, 250, 270, 290, 310, 330, 350,
+ $ 370, 390 )N
+*
+* Code for general N
+*
+* w := C * v
+*
+ CALL DGEMV( 'No transpose', M, N, ONE, C, LDC, V, 1, ZERO,
+ $ WORK, 1 )
+*
+* C := C - tau * w * v'
+*
+ CALL DGER( M, N, -TAU, WORK, 1, V, 1, C, LDC )
+ GO TO 410
+ 210 CONTINUE
+*
+* Special code for 1 x 1 Householder
+*
+ T1 = ONE - TAU*V( 1 )*V( 1 )
+ DO 220 J = 1, M
+ C( J, 1 ) = T1*C( J, 1 )
+ 220 CONTINUE
+ GO TO 410
+ 230 CONTINUE
+*
+* Special code for 2 x 2 Householder
+*
+ V1 = V( 1 )
+ T1 = TAU*V1
+ V2 = V( 2 )
+ T2 = TAU*V2
+ DO 240 J = 1, M
+ SUM = V1*C( J, 1 ) + V2*C( J, 2 )
+ C( J, 1 ) = C( J, 1 ) - SUM*T1
+ C( J, 2 ) = C( J, 2 ) - SUM*T2
+ 240 CONTINUE
+ GO TO 410
+ 250 CONTINUE
+*
+* Special code for 3 x 3 Householder
+*
+ V1 = V( 1 )
+ T1 = TAU*V1
+ V2 = V( 2 )
+ T2 = TAU*V2
+ V3 = V( 3 )
+ T3 = TAU*V3
+ DO 260 J = 1, M
+ SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 )
+ C( J, 1 ) = C( J, 1 ) - SUM*T1
+ C( J, 2 ) = C( J, 2 ) - SUM*T2
+ C( J, 3 ) = C( J, 3 ) - SUM*T3
+ 260 CONTINUE
+ GO TO 410
+ 270 CONTINUE
+*
+* Special code for 4 x 4 Householder
+*
+ V1 = V( 1 )
+ T1 = TAU*V1
+ V2 = V( 2 )
+ T2 = TAU*V2
+ V3 = V( 3 )
+ T3 = TAU*V3
+ V4 = V( 4 )
+ T4 = TAU*V4
+ DO 280 J = 1, M
+ SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) +
+ $ V4*C( J, 4 )
+ C( J, 1 ) = C( J, 1 ) - SUM*T1
+ C( J, 2 ) = C( J, 2 ) - SUM*T2
+ C( J, 3 ) = C( J, 3 ) - SUM*T3
+ C( J, 4 ) = C( J, 4 ) - SUM*T4
+ 280 CONTINUE
+ GO TO 410
+ 290 CONTINUE
+*
+* Special code for 5 x 5 Householder
+*
+ V1 = V( 1 )
+ T1 = TAU*V1
+ V2 = V( 2 )
+ T2 = TAU*V2
+ V3 = V( 3 )
+ T3 = TAU*V3
+ V4 = V( 4 )
+ T4 = TAU*V4
+ V5 = V( 5 )
+ T5 = TAU*V5
+ DO 300 J = 1, M
+ SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) +
+ $ V4*C( J, 4 ) + V5*C( J, 5 )
+ C( J, 1 ) = C( J, 1 ) - SUM*T1
+ C( J, 2 ) = C( J, 2 ) - SUM*T2
+ C( J, 3 ) = C( J, 3 ) - SUM*T3
+ C( J, 4 ) = C( J, 4 ) - SUM*T4
+ C( J, 5 ) = C( J, 5 ) - SUM*T5
+ 300 CONTINUE
+ GO TO 410
+ 310 CONTINUE
+*
+* Special code for 6 x 6 Householder
+*
+ V1 = V( 1 )
+ T1 = TAU*V1
+ V2 = V( 2 )
+ T2 = TAU*V2
+ V3 = V( 3 )
+ T3 = TAU*V3
+ V4 = V( 4 )
+ T4 = TAU*V4
+ V5 = V( 5 )
+ T5 = TAU*V5
+ V6 = V( 6 )
+ T6 = TAU*V6
+ DO 320 J = 1, M
+ SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) +
+ $ V4*C( J, 4 ) + V5*C( J, 5 ) + V6*C( J, 6 )
+ C( J, 1 ) = C( J, 1 ) - SUM*T1
+ C( J, 2 ) = C( J, 2 ) - SUM*T2
+ C( J, 3 ) = C( J, 3 ) - SUM*T3
+ C( J, 4 ) = C( J, 4 ) - SUM*T4
+ C( J, 5 ) = C( J, 5 ) - SUM*T5
+ C( J, 6 ) = C( J, 6 ) - SUM*T6
+ 320 CONTINUE
+ GO TO 410
+ 330 CONTINUE
+*
+* Special code for 7 x 7 Householder
+*
+ V1 = V( 1 )
+ T1 = TAU*V1
+ V2 = V( 2 )
+ T2 = TAU*V2
+ V3 = V( 3 )
+ T3 = TAU*V3
+ V4 = V( 4 )
+ T4 = TAU*V4
+ V5 = V( 5 )
+ T5 = TAU*V5
+ V6 = V( 6 )
+ T6 = TAU*V6
+ V7 = V( 7 )
+ T7 = TAU*V7
+ DO 340 J = 1, M
+ SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) +
+ $ V4*C( J, 4 ) + V5*C( J, 5 ) + V6*C( J, 6 ) +
+ $ V7*C( J, 7 )
+ C( J, 1 ) = C( J, 1 ) - SUM*T1
+ C( J, 2 ) = C( J, 2 ) - SUM*T2
+ C( J, 3 ) = C( J, 3 ) - SUM*T3
+ C( J, 4 ) = C( J, 4 ) - SUM*T4
+ C( J, 5 ) = C( J, 5 ) - SUM*T5
+ C( J, 6 ) = C( J, 6 ) - SUM*T6
+ C( J, 7 ) = C( J, 7 ) - SUM*T7
+ 340 CONTINUE
+ GO TO 410
+ 350 CONTINUE
+*
+* Special code for 8 x 8 Householder
+*
+ V1 = V( 1 )
+ T1 = TAU*V1
+ V2 = V( 2 )
+ T2 = TAU*V2
+ V3 = V( 3 )
+ T3 = TAU*V3
+ V4 = V( 4 )
+ T4 = TAU*V4
+ V5 = V( 5 )
+ T5 = TAU*V5
+ V6 = V( 6 )
+ T6 = TAU*V6
+ V7 = V( 7 )
+ T7 = TAU*V7
+ V8 = V( 8 )
+ T8 = TAU*V8
+ DO 360 J = 1, M
+ SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) +
+ $ V4*C( J, 4 ) + V5*C( J, 5 ) + V6*C( J, 6 ) +
+ $ V7*C( J, 7 ) + V8*C( J, 8 )
+ C( J, 1 ) = C( J, 1 ) - SUM*T1
+ C( J, 2 ) = C( J, 2 ) - SUM*T2
+ C( J, 3 ) = C( J, 3 ) - SUM*T3
+ C( J, 4 ) = C( J, 4 ) - SUM*T4
+ C( J, 5 ) = C( J, 5 ) - SUM*T5
+ C( J, 6 ) = C( J, 6 ) - SUM*T6
+ C( J, 7 ) = C( J, 7 ) - SUM*T7
+ C( J, 8 ) = C( J, 8 ) - SUM*T8
+ 360 CONTINUE
+ GO TO 410
+ 370 CONTINUE
+*
+* Special code for 9 x 9 Householder
+*
+ V1 = V( 1 )
+ T1 = TAU*V1
+ V2 = V( 2 )
+ T2 = TAU*V2
+ V3 = V( 3 )
+ T3 = TAU*V3
+ V4 = V( 4 )
+ T4 = TAU*V4
+ V5 = V( 5 )
+ T5 = TAU*V5
+ V6 = V( 6 )
+ T6 = TAU*V6
+ V7 = V( 7 )
+ T7 = TAU*V7
+ V8 = V( 8 )
+ T8 = TAU*V8
+ V9 = V( 9 )
+ T9 = TAU*V9
+ DO 380 J = 1, M
+ SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) +
+ $ V4*C( J, 4 ) + V5*C( J, 5 ) + V6*C( J, 6 ) +
+ $ V7*C( J, 7 ) + V8*C( J, 8 ) + V9*C( J, 9 )
+ C( J, 1 ) = C( J, 1 ) - SUM*T1
+ C( J, 2 ) = C( J, 2 ) - SUM*T2
+ C( J, 3 ) = C( J, 3 ) - SUM*T3
+ C( J, 4 ) = C( J, 4 ) - SUM*T4
+ C( J, 5 ) = C( J, 5 ) - SUM*T5
+ C( J, 6 ) = C( J, 6 ) - SUM*T6
+ C( J, 7 ) = C( J, 7 ) - SUM*T7
+ C( J, 8 ) = C( J, 8 ) - SUM*T8
+ C( J, 9 ) = C( J, 9 ) - SUM*T9
+ 380 CONTINUE
+ GO TO 410
+ 390 CONTINUE
+*
+* Special code for 10 x 10 Householder
+*
+ V1 = V( 1 )
+ T1 = TAU*V1
+ V2 = V( 2 )
+ T2 = TAU*V2
+ V3 = V( 3 )
+ T3 = TAU*V3
+ V4 = V( 4 )
+ T4 = TAU*V4
+ V5 = V( 5 )
+ T5 = TAU*V5
+ V6 = V( 6 )
+ T6 = TAU*V6
+ V7 = V( 7 )
+ T7 = TAU*V7
+ V8 = V( 8 )
+ T8 = TAU*V8
+ V9 = V( 9 )
+ T9 = TAU*V9
+ V10 = V( 10 )
+ T10 = TAU*V10
+ DO 400 J = 1, M
+ SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) +
+ $ V4*C( J, 4 ) + V5*C( J, 5 ) + V6*C( J, 6 ) +
+ $ V7*C( J, 7 ) + V8*C( J, 8 ) + V9*C( J, 9 ) +
+ $ V10*C( J, 10 )
+ C( J, 1 ) = C( J, 1 ) - SUM*T1
+ C( J, 2 ) = C( J, 2 ) - SUM*T2
+ C( J, 3 ) = C( J, 3 ) - SUM*T3
+ C( J, 4 ) = C( J, 4 ) - SUM*T4
+ C( J, 5 ) = C( J, 5 ) - SUM*T5
+ C( J, 6 ) = C( J, 6 ) - SUM*T6
+ C( J, 7 ) = C( J, 7 ) - SUM*T7
+ C( J, 8 ) = C( J, 8 ) - SUM*T8
+ C( J, 9 ) = C( J, 9 ) - SUM*T9
+ C( J, 10 ) = C( J, 10 ) - SUM*T10
+ 400 CONTINUE
+ GO TO 410
+ END IF
+ 410 CONTINUE
+ RETURN
+*
+* End of DLARFX
+*
+ END
+ SUBROUTINE DLARGV( N, X, INCX, Y, INCY, C, INCC )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INCC, INCX, INCY, N
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION C( * ), X( * ), Y( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DLARGV generates a vector of real plane rotations, determined by
+* elements of the real vectors x and y. For i = 1,2,...,n
+*
+* ( c(i) s(i) ) ( x(i) ) = ( a(i) )
+* ( -s(i) c(i) ) ( y(i) ) = ( 0 )
+*
+* Arguments
+* =========
+*
+* N (input) INTEGER
+* The number of plane rotations to be generated.
+*
+* X (input/output) DOUBLE PRECISION array,
+* dimension (1+(N-1)*INCX)
+* On entry, the vector x.
+* On exit, x(i) is overwritten by a(i), for i = 1,...,n.
+*
+* INCX (input) INTEGER
+* The increment between elements of X. INCX > 0.
+*
+* Y (input/output) DOUBLE PRECISION array,
+* dimension (1+(N-1)*INCY)
+* On entry, the vector y.
+* On exit, the sines of the plane rotations.
+*
+* INCY (input) INTEGER
+* The increment between elements of Y. INCY > 0.
+*
+* C (output) DOUBLE PRECISION array, dimension (1+(N-1)*INCC)
+* The cosines of the plane rotations.
+*
+* INCC (input) INTEGER
+* The increment between elements of C. INCC > 0.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, IC, IX, IY
+ DOUBLE PRECISION F, G, T, TT
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, SQRT
+* ..
+* .. Executable Statements ..
+*
+ IX = 1
+ IY = 1
+ IC = 1
+ DO 10 I = 1, N
+ F = X( IX )
+ G = Y( IY )
+ IF( G.EQ.ZERO ) THEN
+ C( IC ) = ONE
+ ELSE IF( F.EQ.ZERO ) THEN
+ C( IC ) = ZERO
+ Y( IY ) = ONE
+ X( IX ) = G
+ ELSE IF( ABS( F ).GT.ABS( G ) ) THEN
+ T = G / F
+ TT = SQRT( ONE+T*T )
+ C( IC ) = ONE / TT
+ Y( IY ) = T*C( IC )
+ X( IX ) = F*TT
+ ELSE
+ T = F / G
+ TT = SQRT( ONE+T*T )
+ Y( IY ) = ONE / TT
+ C( IC ) = T*Y( IY )
+ X( IX ) = G*TT
+ END IF
+ IC = IC + INCC
+ IY = IY + INCY
+ IX = IX + INCX
+ 10 CONTINUE
+ RETURN
+*
+* End of DLARGV
+*
+ END
+ SUBROUTINE DLARNV( IDIST, ISEED, N, X )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER IDIST, N
+* ..
+* .. Array Arguments ..
+ INTEGER ISEED( 4 )
+ DOUBLE PRECISION X( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DLARNV returns a vector of n random real numbers from a uniform or
+* normal distribution.
+*
+* Arguments
+* =========
+*
+* IDIST (input) INTEGER
+* Specifies the distribution of the random numbers:
+* = 1: uniform (0,1)
+* = 2: uniform (-1,1)
+* = 3: normal (0,1)
+*
+* ISEED (input/output) INTEGER array, dimension (4)
+* On entry, the seed of the random number generator; the array
+* elements must be between 0 and 4095, and ISEED(4) must be
+* odd.
+* On exit, the seed is updated.
+*
+* N (input) INTEGER
+* The number of random numbers to be generated.
+*
+* X (output) DOUBLE PRECISION array, dimension (N)
+* The generated random numbers.
+*
+* Further Details
+* ===============
+*
+* This routine calls the auxiliary routine DLARUV to generate random
+* real numbers from a uniform (0,1) distribution, in batches of up to
+* 128 using vectorisable code. The Box-Muller method is used to
+* transform numbers from a uniform to a normal distribution.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE, TWO
+ PARAMETER ( ONE = 1.0D+0, TWO = 2.0D+0 )
+ INTEGER LV
+ PARAMETER ( LV = 128 )
+ DOUBLE PRECISION TWOPI
+ PARAMETER ( TWOPI = 6.2831853071795864769252867663D+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, IL, IL2, IV
+* ..
+* .. Local Arrays ..
+ DOUBLE PRECISION U( LV )
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC COS, LOG, MIN, SQRT
+* ..
+* .. External Subroutines ..
+ EXTERNAL DLARUV
+* ..
+* .. Executable Statements ..
+*
+ DO 40 IV = 1, N, LV / 2
+ IL = MIN( LV / 2, N-IV+1 )
+ IF( IDIST.EQ.3 ) THEN
+ IL2 = 2*IL
+ ELSE
+ IL2 = IL
+ END IF
+*
+* Call DLARUV to generate IL2 numbers from a uniform (0,1)
+* distribution (IL2 <= LV)
+*
+ CALL DLARUV( ISEED, IL2, U )
+*
+ IF( IDIST.EQ.1 ) THEN
+*
+* Copy generated numbers
+*
+ DO 10 I = 1, IL
+ X( IV+I-1 ) = U( I )
+ 10 CONTINUE
+ ELSE IF( IDIST.EQ.2 ) THEN
+*
+* Convert generated numbers to uniform (-1,1) distribution
+*
+ DO 20 I = 1, IL
+ X( IV+I-1 ) = TWO*U( I ) - ONE
+ 20 CONTINUE
+ ELSE IF( IDIST.EQ.3 ) THEN
+*
+* Convert generated numbers to normal (0,1) distribution
+*
+ DO 30 I = 1, IL
+ X( IV+I-1 ) = SQRT( -TWO*LOG( U( 2*I-1 ) ) )*
+ $ COS( TWOPI*U( 2*I ) )
+ 30 CONTINUE
+ END IF
+ 40 CONTINUE
+ RETURN
+*
+* End of DLARNV
+*
+ END
+ SUBROUTINE DLARRA( N, D, E, E2, SPLTOL, TNRM,
+ $ NSPLIT, ISPLIT, INFO )
+ IMPLICIT NONE
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, N, NSPLIT
+ DOUBLE PRECISION SPLTOL, TNRM
+* ..
+* .. Array Arguments ..
+ INTEGER ISPLIT( * )
+ DOUBLE PRECISION D( * ), E( * ), E2( * )
+* ..
+*
+* Purpose
+* =======
+*
+* Compute the splitting points with threshold SPLTOL.
+* DLARRA sets any "small" off-diagonal elements to zero.
+*
+* Arguments
+* =========
+*
+* N (input) INTEGER
+* The order of the matrix. N > 0.
+*
+* D (input) DOUBLE PRECISION array, dimension (N)
+* On entry, the N diagonal elements of the tridiagonal
+* matrix T.
+*
+* E (input/output) DOUBLE PRECISION array, dimension (N)
+* On entry, the first (N-1) entries contain the subdiagonal
+* elements of the tridiagonal matrix T; E(N) need not be set.
+* On exit, the entries E( ISPLIT( I ) ), 1 <= I <= NSPLIT,
+* are set to zero, the other entries of E are untouched.
+*
+* E2 (input/output) DOUBLE PRECISION array, dimension (N)
+* On entry, the first (N-1) entries contain the SQUARES of the
+* subdiagonal elements of the tridiagonal matrix T;
+* E2(N) need not be set.
+* On exit, the entries E2( ISPLIT( I ) ),
+* 1 <= I <= NSPLIT, have been set to zero
+*
+* SPLTOL (input) DOUBLE PRECISION
+* The threshold for splitting. Two criteria can be used:
+* SPLTOL<0 : criterion based on absolute off-diagonal value
+* SPLTOL>0 : criterion that preserves relative accuracy
+*
+* TNRM (input) DOUBLE PRECISION
+* The norm of the matrix.
+*
+* NSPLIT (output) INTEGER
+* The number of blocks T splits into. 1 <= NSPLIT <= N.
+*
+* ISPLIT (output) INTEGER array, dimension (N)
+* The splitting points, at which T breaks up into blocks.
+* The first block consists of rows/columns 1 to ISPLIT(1),
+* the second of rows/columns ISPLIT(1)+1 through ISPLIT(2),
+* etc., and the NSPLIT-th consists of rows/columns
+* ISPLIT(NSPLIT-1)+1 through ISPLIT(NSPLIT)=N.
+*
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+*
+* Further Details
+* ===============
+*
+* Based on contributions by
+* Beresford Parlett, University of California, Berkeley, USA
+* Jim Demmel, University of California, Berkeley, USA
+* Inderjit Dhillon, University of Texas, Austin, USA
+* Osni Marques, LBNL/NERSC, USA
+* Christof Voemel, University of California, Berkeley, USA
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO
+ PARAMETER ( ZERO = 0.0D0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I
+ DOUBLE PRECISION EABS, TMP1
+
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS
+* ..
+* .. Executable Statements ..
+*
+ INFO = 0
+
+* Compute splitting points
+ NSPLIT = 1
+ IF(SPLTOL.LT.ZERO) THEN
+* Criterion based on absolute off-diagonal value
+ TMP1 = ABS(SPLTOL)* TNRM
+ DO 9 I = 1, N-1
+ EABS = ABS( E(I) )
+ IF( EABS .LE. TMP1) THEN
+ E(I) = ZERO
+ E2(I) = ZERO
+ ISPLIT( NSPLIT ) = I
+ NSPLIT = NSPLIT + 1
+ END IF
+ 9 CONTINUE
+ ELSE
+* Criterion that guarantees relative accuracy
+ DO 10 I = 1, N-1
+ EABS = ABS( E(I) )
+ IF( EABS .LE. SPLTOL * SQRT(ABS(D(I)))*SQRT(ABS(D(I+1))) )
+ $ THEN
+ E(I) = ZERO
+ E2(I) = ZERO
+ ISPLIT( NSPLIT ) = I
+ NSPLIT = NSPLIT + 1
+ END IF
+ 10 CONTINUE
+ ENDIF
+ ISPLIT( NSPLIT ) = N
+
+ RETURN
+*
+* End of DLARRA
+*
+ END
+ SUBROUTINE DLARRB( N, D, LLD, IFIRST, ILAST, RTOL1,
+ $ RTOL2, OFFSET, W, WGAP, WERR, WORK, IWORK,
+ $ PIVMIN, SPDIAM, TWIST, INFO )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER IFIRST, ILAST, INFO, N, OFFSET, TWIST
+ DOUBLE PRECISION PIVMIN, RTOL1, RTOL2, SPDIAM
+* ..
+* .. Array Arguments ..
+ INTEGER IWORK( * )
+ DOUBLE PRECISION D( * ), LLD( * ), W( * ),
+ $ WERR( * ), WGAP( * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* Given the relatively robust representation(RRR) L D L^T, DLARRB
+* does "limited" bisection to refine the eigenvalues of L D L^T,
+* W( IFIRST-OFFSET ) through W( ILAST-OFFSET ), to more accuracy. Initial
+* guesses for these eigenvalues are input in W, the corresponding estimate
+* of the error in these guesses and their gaps are input in WERR
+* and WGAP, respectively. During bisection, intervals
+* [left, right] are maintained by storing their mid-points and
+* semi-widths in the arrays W and WERR respectively.
+*
+* Arguments
+* =========
+*
+* N (input) INTEGER
+* The order of the matrix.
+*
+* D (input) DOUBLE PRECISION array, dimension (N)
+* The N diagonal elements of the diagonal matrix D.
+*
+* LLD (input) DOUBLE PRECISION array, dimension (N-1)
+* The (N-1) elements L(i)*L(i)*D(i).
+*
+* IFIRST (input) INTEGER
+* The index of the first eigenvalue to be computed.
+*
+* ILAST (input) INTEGER
+* The index of the last eigenvalue to be computed.
+*
+* RTOL1 (input) DOUBLE PRECISION
+* RTOL2 (input) DOUBLE PRECISION
+* Tolerance for the convergence of the bisection intervals.
+* An interval [LEFT,RIGHT] has converged if
+* RIGHT-LEFT.LT.MAX( RTOL1*GAP, RTOL2*MAX(|LEFT|,|RIGHT|) )
+* where GAP is the (estimated) distance to the nearest
+* eigenvalue.
+*
+* OFFSET (input) INTEGER
+* Offset for the arrays W, WGAP and WERR, i.e., the IFIRST-OFFSET
+* through ILAST-OFFSET elements of these arrays are to be used.
+*
+* W (input/output) DOUBLE PRECISION array, dimension (N)
+* On input, W( IFIRST-OFFSET ) through W( ILAST-OFFSET ) are
+* estimates of the eigenvalues of L D L^T indexed IFIRST throug
+* ILAST.
+* On output, these estimates are refined.
+*
+* WGAP (input/output) DOUBLE PRECISION array, dimension (N-1)
+* On input, the (estimated) gaps between consecutive
+* eigenvalues of L D L^T, i.e., WGAP(I-OFFSET) is the gap between
+* eigenvalues I and I+1. Note that if IFIRST.EQ.ILAST
+* then WGAP(IFIRST-OFFSET) must be set to ZERO.
+* On output, these gaps are refined.
+*
+* WERR (input/output) DOUBLE PRECISION array, dimension (N)
+* On input, WERR( IFIRST-OFFSET ) through WERR( ILAST-OFFSET ) are
+* the errors in the estimates of the corresponding elements in W.
+* On output, these errors are refined.
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (2*N)
+* Workspace.
+*
+* IWORK (workspace) INTEGER array, dimension (2*N)
+* Workspace.
+*
+* PIVMIN (input) DOUBLE PRECISION
+* The minimum pivot in the Sturm sequence.
+*
+* SPDIAM (input) DOUBLE PRECISION
+* The spectral diameter of the matrix.
+*
+* TWIST (input) INTEGER
+* The twist index for the twisted factorization that is used
+* for the negcount.
+* TWIST = N: Compute negcount from L D L^T - LAMBDA I = L+ D+ L+^T
+* TWIST = 1: Compute negcount from L D L^T - LAMBDA I = U- D- U-^T
+* TWIST = R: Compute negcount from L D L^T - LAMBDA I = N(r) D(r) N(r)
+*
+* INFO (output) INTEGER
+* Error flag.
+*
+* Further Details
+* ===============
+*
+* Based on contributions by
+* Beresford Parlett, University of California, Berkeley, USA
+* Jim Demmel, University of California, Berkeley, USA
+* Inderjit Dhillon, University of Texas, Austin, USA
+* Osni Marques, LBNL/NERSC, USA
+* Christof Voemel, University of California, Berkeley, USA
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, TWO, HALF
+ PARAMETER ( ZERO = 0.0D0, TWO = 2.0D0,
+ $ HALF = 0.5D0 )
+ INTEGER MAXITR
+* ..
+* .. Local Scalars ..
+ INTEGER I, I1, II, IP, ITER, K, NEGCNT, NEXT, NINT,
+ $ OLNINT, PREV, R
+ DOUBLE PRECISION BACK, CVRGD, GAP, LEFT, LGAP, MID, MNWDTH,
+ $ RGAP, RIGHT, TMP, WIDTH
+* ..
+* .. External Functions ..
+ INTEGER DLANEG
+ EXTERNAL DLANEG
+*
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+ INFO = 0
+*
+ MAXITR = INT( ( LOG( SPDIAM+PIVMIN )-LOG( PIVMIN ) ) /
+ $ LOG( TWO ) ) + 2
+ MNWDTH = TWO * PIVMIN
+*
+ R = TWIST
+ IF((R.LT.1).OR.(R.GT.N)) R = N
+*
+* Initialize unconverged intervals in [ WORK(2*I-1), WORK(2*I) ].
+* The Sturm Count, Count( WORK(2*I-1) ) is arranged to be I-1, while
+* Count( WORK(2*I) ) is stored in IWORK( 2*I ). The integer IWORK( 2*I-1 )
+* for an unconverged interval is set to the index of the next unconverged
+* interval, and is -1 or 0 for a converged interval. Thus a linked
+* list of unconverged intervals is set up.
+*
+ I1 = IFIRST
+* The number of unconverged intervals
+ NINT = 0
+* The last unconverged interval found
+ PREV = 0
+
+ RGAP = WGAP( I1-OFFSET )
+ DO 75 I = I1, ILAST
+ K = 2*I
+ II = I - OFFSET
+ LEFT = W( II ) - WERR( II )
+ RIGHT = W( II ) + WERR( II )
+ LGAP = RGAP
+ RGAP = WGAP( II )
+ GAP = MIN( LGAP, RGAP )
+
+* Make sure that [LEFT,RIGHT] contains the desired eigenvalue
+* Compute negcount from dstqds facto L+D+L+^T = L D L^T - LEFT
+*
+* Do while( NEGCNT(LEFT).GT.I-1 )
+*
+ BACK = WERR( II )
+ 20 CONTINUE
+ NEGCNT = DLANEG( N, D, LLD, LEFT, PIVMIN, R )
+ IF( NEGCNT.GT.I-1 ) THEN
+ LEFT = LEFT - BACK
+ BACK = TWO*BACK
+ GO TO 20
+ END IF
+*
+* Do while( NEGCNT(RIGHT).LT.I )
+* Compute negcount from dstqds facto L+D+L+^T = L D L^T - RIGHT
+*
+ BACK = WERR( II )
+ 50 CONTINUE
+
+ NEGCNT = DLANEG( N, D, LLD, RIGHT, PIVMIN, R )
+ IF( NEGCNT.LT.I ) THEN
+ RIGHT = RIGHT + BACK
+ BACK = TWO*BACK
+ GO TO 50
+ END IF
+ WIDTH = HALF*ABS( LEFT - RIGHT )
+ TMP = MAX( ABS( LEFT ), ABS( RIGHT ) )
+ CVRGD = MAX(RTOL1*GAP,RTOL2*TMP)
+ IF( WIDTH.LE.CVRGD .OR. WIDTH.LE.MNWDTH ) THEN
+* This interval has already converged and does not need refinement.
+* (Note that the gaps might change through refining the
+* eigenvalues, however, they can only get bigger.)
+* Remove it from the list.
+ IWORK( K-1 ) = -1
+* Make sure that I1 always points to the first unconverged interval
+ IF((I.EQ.I1).AND.(I.LT.ILAST)) I1 = I + 1
+ IF((PREV.GE.I1).AND.(I.LE.ILAST)) IWORK( 2*PREV-1 ) = I + 1
+ ELSE
+* unconverged interval found
+ PREV = I
+ NINT = NINT + 1
+ IWORK( K-1 ) = I + 1
+ IWORK( K ) = NEGCNT
+ END IF
+ WORK( K-1 ) = LEFT
+ WORK( K ) = RIGHT
+ 75 CONTINUE
+
+*
+* Do while( NINT.GT.0 ), i.e. there are still unconverged intervals
+* and while (ITER.LT.MAXITR)
+*
+ ITER = 0
+ 80 CONTINUE
+ PREV = I1 - 1
+ I = I1
+ OLNINT = NINT
+
+ DO 100 IP = 1, OLNINT
+ K = 2*I
+ II = I - OFFSET
+ RGAP = WGAP( II )
+ LGAP = RGAP
+ IF(II.GT.1) LGAP = WGAP( II-1 )
+ GAP = MIN( LGAP, RGAP )
+ NEXT = IWORK( K-1 )
+ LEFT = WORK( K-1 )
+ RIGHT = WORK( K )
+ MID = HALF*( LEFT + RIGHT )
+
+* semiwidth of interval
+ WIDTH = RIGHT - MID
+ TMP = MAX( ABS( LEFT ), ABS( RIGHT ) )
+ CVRGD = MAX(RTOL1*GAP,RTOL2*TMP)
+ IF( ( WIDTH.LE.CVRGD ) .OR. ( WIDTH.LE.MNWDTH ).OR.
+ $ ( ITER.EQ.MAXITR ) )THEN
+* reduce number of unconverged intervals
+ NINT = NINT - 1
+* Mark interval as converged.
+ IWORK( K-1 ) = 0
+ IF( I1.EQ.I ) THEN
+ I1 = NEXT
+ ELSE
+* Prev holds the last unconverged interval previously examined
+ IF(PREV.GE.I1) IWORK( 2*PREV-1 ) = NEXT
+ END IF
+ I = NEXT
+ GO TO 100
+ END IF
+ PREV = I
+*
+* Perform one bisection step
+*
+ NEGCNT = DLANEG( N, D, LLD, MID, PIVMIN, R )
+ IF( NEGCNT.LE.I-1 ) THEN
+ WORK( K-1 ) = MID
+ ELSE
+ WORK( K ) = MID
+ END IF
+ I = NEXT
+ 100 CONTINUE
+ ITER = ITER + 1
+* do another loop if there are still unconverged intervals
+* However, in the last iteration, all intervals are accepted
+* since this is the best we can do.
+ IF( ( NINT.GT.0 ).AND.(ITER.LE.MAXITR) ) GO TO 80
+*
+*
+* At this point, all the intervals have converged
+ DO 110 I = IFIRST, ILAST
+ K = 2*I
+ II = I - OFFSET
+* All intervals marked by '0' have been refined.
+ IF( IWORK( K-1 ).EQ.0 ) THEN
+ W( II ) = HALF*( WORK( K-1 )+WORK( K ) )
+ WERR( II ) = WORK( K ) - W( II )
+ END IF
+ 110 CONTINUE
+*
+ DO 111 I = IFIRST+1, ILAST
+ K = 2*I
+ II = I - OFFSET
+ WGAP( II-1 ) = MAX( ZERO,
+ $ W(II) - WERR (II) - W( II-1 ) - WERR( II-1 ))
+ 111 CONTINUE
+
+ RETURN
+*
+* End of DLARRB
+*
+ END
+ SUBROUTINE DLARRC( JOBT, N, VL, VU, D, E, PIVMIN,
+ $ EIGCNT, LCNT, RCNT, INFO )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER JOBT
+ INTEGER EIGCNT, INFO, LCNT, N, RCNT
+ DOUBLE PRECISION PIVMIN, VL, VU
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION D( * ), E( * )
+* ..
+*
+* Purpose
+* =======
+*
+* Find the number of eigenvalues of the symmetric tridiagonal matrix T
+* that are in the interval (VL,VU] if JOBT = 'T', and of L D L^T
+* if JOBT = 'L'.
+*
+* Arguments
+* =========
+*
+* JOBT (input) CHARACTER*1
+* = 'T': Compute Sturm count for matrix T.
+* = 'L': Compute Sturm count for matrix L D L^T.
+*
+* N (input) INTEGER
+* The order of the matrix. N > 0.
+*
+* VL (input) DOUBLE PRECISION
+* VU (input) DOUBLE PRECISION
+* The lower and upper bounds for the eigenvalues.
+*
+* D (input) DOUBLE PRECISION array, dimension (N)
+* JOBT = 'T': The N diagonal elements of the tridiagonal matrix T.
+* JOBT = 'L': The N diagonal elements of the diagonal matrix D.
+*
+* E (input) DOUBLE PRECISION array, dimension (N)
+* JOBT = 'T': The N-1 offdiagonal elements of the matrix T.
+* JOBT = 'L': The N-1 offdiagonal elements of the matrix L.
+*
+* PIVMIN (input) DOUBLE PRECISION
+* The minimum pivot in the Sturm sequence for T.
+*
+* EIGCNT (output) INTEGER
+* The number of eigenvalues of the symmetric tridiagonal matrix T
+* that are in the interval (VL,VU]
+*
+* LCNT (output) INTEGER
+* RCNT (output) INTEGER
+* The left and right negcounts of the interval.
+*
+* INFO (output) INTEGER
+*
+* Further Details
+* ===============
+*
+* Based on contributions by
+* Beresford Parlett, University of California, Berkeley, USA
+* Jim Demmel, University of California, Berkeley, USA
+* Inderjit Dhillon, University of Texas, Austin, USA
+* Osni Marques, LBNL/NERSC, USA
+* Christof Voemel, University of California, Berkeley, USA
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO
+ PARAMETER ( ZERO = 0.0D0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I
+ LOGICAL MATT
+ DOUBLE PRECISION LPIVOT, RPIVOT, SL, SU, TMP, TMP2
+
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. Executable Statements ..
+*
+ INFO = 0
+ LCNT = 0
+ RCNT = 0
+ EIGCNT = 0
+ MATT = LSAME( JOBT, 'T' )
+
+
+ IF (MATT) THEN
+* Sturm sequence count on T
+ LPIVOT = D( 1 ) - VL
+ RPIVOT = D( 1 ) - VU
+ IF( LPIVOT.LE.ZERO ) THEN
+ LCNT = LCNT + 1
+ ENDIF
+ IF( RPIVOT.LE.ZERO ) THEN
+ RCNT = RCNT + 1
+ ENDIF
+ DO 10 I = 1, N-1
+ TMP = E(I)**2
+ LPIVOT = ( D( I+1 )-VL ) - TMP/LPIVOT
+ RPIVOT = ( D( I+1 )-VU ) - TMP/RPIVOT
+ IF( LPIVOT.LE.ZERO ) THEN
+ LCNT = LCNT + 1
+ ENDIF
+ IF( RPIVOT.LE.ZERO ) THEN
+ RCNT = RCNT + 1
+ ENDIF
+ 10 CONTINUE
+ ELSE
+* Sturm sequence count on L D L^T
+ SL = -VL
+ SU = -VU
+ DO 20 I = 1, N - 1
+ LPIVOT = D( I ) + SL
+ RPIVOT = D( I ) + SU
+ IF( LPIVOT.LE.ZERO ) THEN
+ LCNT = LCNT + 1
+ ENDIF
+ IF( RPIVOT.LE.ZERO ) THEN
+ RCNT = RCNT + 1
+ ENDIF
+ TMP = E(I) * D(I) * E(I)
+*
+ TMP2 = TMP / LPIVOT
+ IF( TMP2.EQ.ZERO ) THEN
+ SL = TMP - VL
+ ELSE
+ SL = SL*TMP2 - VL
+ END IF
+*
+ TMP2 = TMP / RPIVOT
+ IF( TMP2.EQ.ZERO ) THEN
+ SU = TMP - VU
+ ELSE
+ SU = SU*TMP2 - VU
+ END IF
+ 20 CONTINUE
+ LPIVOT = D( N ) + SL
+ RPIVOT = D( N ) + SU
+ IF( LPIVOT.LE.ZERO ) THEN
+ LCNT = LCNT + 1
+ ENDIF
+ IF( RPIVOT.LE.ZERO ) THEN
+ RCNT = RCNT + 1
+ ENDIF
+ ENDIF
+ EIGCNT = RCNT - LCNT
+
+ RETURN
+*
+* end of DLARRC
+*
+ END
+ 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 )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER ORDER, RANGE
+ INTEGER IL, INFO, IU, M, N, NSPLIT
+ DOUBLE PRECISION PIVMIN, RELTOL, VL, VU, WL, WU
+* ..
+* .. Array Arguments ..
+ INTEGER IBLOCK( * ), INDEXW( * ),
+ $ ISPLIT( * ), IWORK( * )
+ DOUBLE PRECISION D( * ), E( * ), E2( * ),
+ $ GERS( * ), W( * ), WERR( * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DLARRD computes the eigenvalues of a symmetric tridiagonal
+* matrix T to suitable accuracy. This is an auxiliary code to be
+* called from DSTEMR.
+* The user may ask for all eigenvalues, all eigenvalues
+* in the half-open interval (VL, VU], or the IL-th through IU-th
+* eigenvalues.
+*
+* To avoid overflow, the matrix must be scaled so that its
+* largest element is no greater than overflow**(1/2) *
+* underflow**(1/4) in absolute value, and for greatest
+* accuracy, it should not be much smaller than that.
+*
+* See W. Kahan "Accurate Eigenvalues of a Symmetric Tridiagonal
+* Matrix", Report CS41, Computer Science Dept., Stanford
+* University, July 21, 1966.
+*
+* Arguments
+* =========
+*
+* RANGE (input) CHARACTER
+* = 'A': ("All") all eigenvalues will be found.
+* = 'V': ("Value") all eigenvalues in the half-open interval
+* (VL, VU] will be found.
+* = 'I': ("Index") the IL-th through IU-th eigenvalues (of the
+* entire matrix) will be found.
+*
+* ORDER (input) CHARACTER
+* = 'B': ("By Block") the eigenvalues will be grouped by
+* split-off block (see IBLOCK, ISPLIT) and
+* ordered from smallest to largest within
+* the block.
+* = 'E': ("Entire matrix")
+* the eigenvalues for the entire matrix
+* will be ordered from smallest to
+* largest.
+*
+* N (input) INTEGER
+* The order of the tridiagonal matrix T. N >= 0.
+*
+* VL (input) DOUBLE PRECISION
+* VU (input) DOUBLE PRECISION
+* If RANGE='V', the lower and upper bounds of the interval to
+* be searched for eigenvalues. Eigenvalues less than or equal
+* to VL, or greater than VU, will not be returned. VL < VU.
+* Not referenced if RANGE = 'A' or 'I'.
+*
+* IL (input) INTEGER
+* IU (input) INTEGER
+* If RANGE='I', the indices (in ascending order) of the
+* smallest and largest eigenvalues to be returned.
+* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
+* Not referenced if RANGE = 'A' or 'V'.
+*
+* GERS (input) DOUBLE PRECISION array, dimension (2*N)
+* The N Gerschgorin intervals (the i-th Gerschgorin interval
+* is (GERS(2*i-1), GERS(2*i)).
+*
+* RELTOL (input) DOUBLE PRECISION
+* The minimum relative width of an interval. When an interval
+* is narrower than RELTOL times the larger (in
+* magnitude) endpoint, then it is considered to be
+* sufficiently small, i.e., converged. Note: this should
+* always be at least radix*machine epsilon.
+*
+* D (input) DOUBLE PRECISION array, dimension (N)
+* The n diagonal elements of the tridiagonal matrix T.
+*
+* E (input) DOUBLE PRECISION array, dimension (N-1)
+* The (n-1) off-diagonal elements of the tridiagonal matrix T.
+*
+* E2 (input) DOUBLE PRECISION array, dimension (N-1)
+* The (n-1) squared off-diagonal elements of the tridiagonal matrix T.
+*
+* PIVMIN (input) DOUBLE PRECISION
+* The minimum pivot allowed in the Sturm sequence for T.
+*
+* NSPLIT (input) INTEGER
+* The number of diagonal blocks in the matrix T.
+* 1 <= NSPLIT <= N.
+*
+* ISPLIT (input) INTEGER array, dimension (N)
+* The splitting points, at which T breaks up into submatrices.
+* The first submatrix consists of rows/columns 1 to ISPLIT(1),
+* the second of rows/columns ISPLIT(1)+1 through ISPLIT(2),
+* etc., and the NSPLIT-th consists of rows/columns
+* ISPLIT(NSPLIT-1)+1 through ISPLIT(NSPLIT)=N.
+* (Only the first NSPLIT elements will actually be used, but
+* since the user cannot know a priori what value NSPLIT will
+* have, N words must be reserved for ISPLIT.)
+*
+* M (output) INTEGER
+* The actual number of eigenvalues found. 0 <= M <= N.
+* (See also the description of INFO=2,3.)
+*
+* W (output) DOUBLE PRECISION array, dimension (N)
+* On exit, the first M elements of W will contain the
+* eigenvalue approximations. DLARRD computes an interval
+* I_j = (a_j, b_j] that includes eigenvalue j. The eigenvalue
+* approximation is given as the interval midpoint
+* W(j)= ( a_j + b_j)/2. The corresponding error is bounded by
+* WERR(j) = abs( a_j - b_j)/2
+*
+* WERR (output) DOUBLE PRECISION array, dimension (N)
+* The error bound on the corresponding eigenvalue approximation
+* in W.
+*
+* WL (output) DOUBLE PRECISION
+* WU (output) DOUBLE PRECISION
+* The interval (WL, WU] contains all the wanted eigenvalues.
+* If RANGE='V', then WL=VL and WU=VU.
+* If RANGE='A', then WL and WU are the global Gerschgorin bounds
+* on the spectrum.
+* If RANGE='I', then WL and WU are computed by DLAEBZ from the
+* index range specified.
+*
+* IBLOCK (output) INTEGER array, dimension (N)
+* At each row/column j where E(j) is zero or small, the
+* matrix T is considered to split into a block diagonal
+* matrix. On exit, if INFO = 0, IBLOCK(i) specifies to which
+* block (from 1 to the number of blocks) the eigenvalue W(i)
+* belongs. (DLARRD may use the remaining N-M elements as
+* workspace.)
+*
+* INDEXW (output) INTEGER array, dimension (N)
+* The indices of the eigenvalues within each block (submatrix);
+* for example, INDEXW(i)= j and IBLOCK(i)=k imply that the
+* i-th eigenvalue W(i) is the j-th eigenvalue in block k.
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (4*N)
+*
+* IWORK (workspace) INTEGER array, dimension (3*N)
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* > 0: some or all of the eigenvalues failed to converge or
+* were not computed:
+* =1 or 3: Bisection failed to converge for some
+* eigenvalues; these eigenvalues are flagged by a
+* negative block number. The effect is that the
+* eigenvalues may not be as accurate as the
+* absolute and relative tolerances. This is
+* generally caused by unexpectedly inaccurate
+* arithmetic.
+* =2 or 3: RANGE='I' only: Not all of the eigenvalues
+* IL:IU were found.
+* Effect: M < IU+1-IL
+* Cause: non-monotonic arithmetic, causing the
+* Sturm sequence to be non-monotonic.
+* Cure: recalculate, using RANGE='A', and pick
+* out eigenvalues IL:IU. In some cases,
+* increasing the PARAMETER "FUDGE" may
+* make things work.
+* = 4: RANGE='I', and the Gershgorin interval
+* initially used was too small. No eigenvalues
+* were computed.
+* Probable cause: your machine has sloppy
+* floating-point arithmetic.
+* Cure: Increase the PARAMETER "FUDGE",
+* recompile, and try again.
+*
+* Internal Parameters
+* ===================
+*
+* FUDGE DOUBLE PRECISION, default = 2
+* A "fudge factor" to widen the Gershgorin intervals. Ideally,
+* a value of 1 should work, but on machines with sloppy
+* arithmetic, this needs to be larger. The default for
+* publicly released versions should be large enough to handle
+* the worst machine around. Note that this has no effect
+* on accuracy of the solution.
+*
+* Based on contributions by
+* W. Kahan, University of California, Berkeley, USA
+* Beresford Parlett, University of California, Berkeley, USA
+* Jim Demmel, University of California, Berkeley, USA
+* Inderjit Dhillon, University of Texas, Austin, USA
+* Osni Marques, LBNL/NERSC, USA
+* Christof Voemel, University of California, Berkeley, USA
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE, TWO, HALF, FUDGE
+ PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0,
+ $ TWO = 2.0D0, HALF = ONE/TWO,
+ $ FUDGE = TWO )
+ INTEGER ALLRNG, VALRNG, INDRNG
+ PARAMETER ( ALLRNG = 1, VALRNG = 2, INDRNG = 3 )
+* ..
+* .. Local Scalars ..
+ LOGICAL NCNVRG, TOOFEW
+ INTEGER I, IB, IBEGIN, IDISCL, IDISCU, IE, IEND, IINFO,
+ $ IM, IN, IOFF, IOUT, IRANGE, ITMAX, ITMP1,
+ $ ITMP2, IW, IWOFF, J, JBLK, JDISC, JE, JEE, NB,
+ $ NWL, NWU
+ DOUBLE PRECISION ATOLI, EPS, GL, GU, RTOLI, SPDIAM, TMP1, TMP2,
+ $ TNORM, UFLOW, WKILL, WLU, WUL
+
+* ..
+* .. Local Arrays ..
+ INTEGER IDUMMA( 1 )
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ILAENV
+ DOUBLE PRECISION DLAMCH
+ EXTERNAL LSAME, ILAENV, DLAMCH
+* ..
+* .. External Subroutines ..
+ EXTERNAL DLAEBZ
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, INT, LOG, MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+ INFO = 0
+*
+* Decode RANGE
+*
+ IF( LSAME( RANGE, 'A' ) ) THEN
+ IRANGE = ALLRNG
+ ELSE IF( LSAME( RANGE, 'V' ) ) THEN
+ IRANGE = VALRNG
+ ELSE IF( LSAME( RANGE, 'I' ) ) THEN
+ IRANGE = INDRNG
+ ELSE
+ IRANGE = 0
+ END IF
+*
+* Check for Errors
+*
+ IF( IRANGE.LE.0 ) THEN
+ INFO = -1
+ ELSE IF( .NOT.(LSAME(ORDER,'B').OR.LSAME(ORDER,'E')) ) THEN
+ INFO = -2
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( IRANGE.EQ.VALRNG ) THEN
+ IF( VL.GE.VU )
+ $ INFO = -5
+ ELSE IF( IRANGE.EQ.INDRNG .AND.
+ $ ( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) ) THEN
+ INFO = -6
+ ELSE IF( IRANGE.EQ.INDRNG .AND.
+ $ ( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) ) THEN
+ INFO = -7
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ RETURN
+ END IF
+
+* Initialize error flags
+ INFO = 0
+ NCNVRG = .FALSE.
+ TOOFEW = .FALSE.
+
+* Quick return if possible
+ M = 0
+ IF( N.EQ.0 ) RETURN
+
+* Simplification:
+ IF( IRANGE.EQ.INDRNG .AND. IL.EQ.1 .AND. IU.EQ.N ) IRANGE = 1
+
+* Get machine constants
+ EPS = DLAMCH( 'P' )
+ UFLOW = DLAMCH( 'U' )
+
+
+* Special Case when N=1
+* Treat case of 1x1 matrix for quick return
+ IF( N.EQ.1 ) THEN
+ IF( (IRANGE.EQ.ALLRNG).OR.
+ $ ((IRANGE.EQ.VALRNG).AND.(D(1).GT.VL).AND.(D(1).LE.VU)).OR.
+ $ ((IRANGE.EQ.INDRNG).AND.(IL.EQ.1).AND.(IU.EQ.1)) ) THEN
+ M = 1
+ W(1) = D(1)
+* The computation error of the eigenvalue is zero
+ WERR(1) = ZERO
+ IBLOCK( 1 ) = 1
+ INDEXW( 1 ) = 1
+ ENDIF
+ RETURN
+ END IF
+
+* NB is the minimum vector length for vector bisection, or 0
+* if only scalar is to be done.
+ NB = ILAENV( 1, 'DSTEBZ', ' ', N, -1, -1, -1 )
+ IF( NB.LE.1 ) NB = 0
+
+* Find global spectral radius
+ GL = D(1)
+ GU = D(1)
+ DO 5 I = 1,N
+ GL = MIN( GL, GERS( 2*I - 1))
+ GU = MAX( GU, GERS(2*I) )
+ 5 CONTINUE
+* Compute global Gerschgorin bounds and spectral diameter
+ TNORM = MAX( ABS( GL ), ABS( GU ) )
+ GL = GL - FUDGE*TNORM*EPS*N - FUDGE*TWO*PIVMIN
+ GU = GU + FUDGE*TNORM*EPS*N + FUDGE*TWO*PIVMIN
+ SPDIAM = GU - GL
+* Input arguments for DLAEBZ:
+* The relative tolerance. An interval (a,b] lies within
+* "relative tolerance" if b-a < RELTOL*max(|a|,|b|),
+ RTOLI = RELTOL
+* Set the absolute tolerance for interval convergence to zero to force
+* interval convergence based on relative size of the interval.
+* This is dangerous because intervals might not converge when RELTOL is
+* small. But at least a very small number should be selected so that for
+* strongly graded matrices, the code can get relatively accurate
+* eigenvalues.
+ ATOLI = FUDGE*TWO*UFLOW + FUDGE*TWO*PIVMIN
+
+ IF( IRANGE.EQ.INDRNG ) THEN
+
+* RANGE='I': Compute an interval containing eigenvalues
+* IL through IU. The initial interval [GL,GU] from the global
+* Gerschgorin bounds GL and GU is refined by DLAEBZ.
+ ITMAX = INT( ( LOG( TNORM+PIVMIN )-LOG( PIVMIN ) ) /
+ $ LOG( TWO ) ) + 2
+ WORK( N+1 ) = GL
+ WORK( N+2 ) = GL
+ WORK( N+3 ) = GU
+ WORK( N+4 ) = GU
+ WORK( N+5 ) = GL
+ WORK( N+6 ) = GU
+ IWORK( 1 ) = -1
+ IWORK( 2 ) = -1
+ IWORK( 3 ) = N + 1
+ IWORK( 4 ) = N + 1
+ IWORK( 5 ) = IL - 1
+ IWORK( 6 ) = IU
+*
+ CALL DLAEBZ( 3, ITMAX, N, 2, 2, NB, ATOLI, RTOLI, PIVMIN,
+ $ D, E, E2, IWORK( 5 ), WORK( N+1 ), WORK( N+5 ), IOUT,
+ $ IWORK, W, IBLOCK, IINFO )
+ IF( IINFO .NE. 0 ) THEN
+ INFO = IINFO
+ RETURN
+ END IF
+* On exit, output intervals may not be ordered by ascending negcount
+ IF( IWORK( 6 ).EQ.IU ) THEN
+ WL = WORK( N+1 )
+ WLU = WORK( N+3 )
+ NWL = IWORK( 1 )
+ WU = WORK( N+4 )
+ WUL = WORK( N+2 )
+ NWU = IWORK( 4 )
+ ELSE
+ WL = WORK( N+2 )
+ WLU = WORK( N+4 )
+ NWL = IWORK( 2 )
+ WU = WORK( N+3 )
+ WUL = WORK( N+1 )
+ NWU = IWORK( 3 )
+ END IF
+* On exit, the interval [WL, WLU] contains a value with negcount NWL,
+* and [WUL, WU] contains a value with negcount NWU.
+ IF( NWL.LT.0 .OR. NWL.GE.N .OR. NWU.LT.1 .OR. NWU.GT.N ) THEN
+ INFO = 4
+ RETURN
+ END IF
+
+ ELSEIF( IRANGE.EQ.VALRNG ) THEN
+ WL = VL
+ WU = VU
+
+ ELSEIF( IRANGE.EQ.ALLRNG ) THEN
+ WL = GL
+ WU = GU
+ ENDIF
+
+
+
+* Find Eigenvalues -- Loop Over blocks and recompute NWL and NWU.
+* NWL accumulates the number of eigenvalues .le. WL,
+* NWU accumulates the number of eigenvalues .le. WU
+ M = 0
+ IEND = 0
+ INFO = 0
+ NWL = 0
+ NWU = 0
+*
+ DO 70 JBLK = 1, NSPLIT
+ IOFF = IEND
+ IBEGIN = IOFF + 1
+ IEND = ISPLIT( JBLK )
+ IN = IEND - IOFF
+*
+ IF( IN.EQ.1 ) THEN
+* 1x1 block
+ IF( WL.GE.D( IBEGIN )-PIVMIN )
+ $ NWL = NWL + 1
+ IF( WU.GE.D( IBEGIN )-PIVMIN )
+ $ NWU = NWU + 1
+ IF( IRANGE.EQ.ALLRNG .OR.
+ $ ( WL.LT.D( IBEGIN )-PIVMIN
+ $ .AND. WU.GE. D( IBEGIN )-PIVMIN ) ) THEN
+ M = M + 1
+ W( M ) = D( IBEGIN )
+ WERR(M) = ZERO
+* The gap for a single block doesn't matter for the later
+* algorithm and is assigned an arbitrary large value
+ IBLOCK( M ) = JBLK
+ INDEXW( M ) = 1
+ END IF
+
+* Disabled 2x2 case because of a failure on the following matrix
+* RANGE = 'I', IL = IU = 4
+* Original Tridiagonal, d = [
+* -0.150102010615740E+00
+* -0.849897989384260E+00
+* -0.128208148052635E-15
+* 0.128257718286320E-15
+* ];
+* e = [
+* -0.357171383266986E+00
+* -0.180411241501588E-15
+* -0.175152352710251E-15
+* ];
+*
+* ELSE IF( IN.EQ.2 ) THEN
+** 2x2 block
+* DISC = SQRT( (HALF*(D(IBEGIN)-D(IEND)))**2 + E(IBEGIN)**2 )
+* TMP1 = HALF*(D(IBEGIN)+D(IEND))
+* L1 = TMP1 - DISC
+* IF( WL.GE. L1-PIVMIN )
+* $ NWL = NWL + 1
+* IF( WU.GE. L1-PIVMIN )
+* $ NWU = NWU + 1
+* IF( IRANGE.EQ.ALLRNG .OR. ( WL.LT.L1-PIVMIN .AND. WU.GE.
+* $ L1-PIVMIN ) ) THEN
+* M = M + 1
+* W( M ) = L1
+** The uncertainty of eigenvalues of a 2x2 matrix is very small
+* WERR( M ) = EPS * ABS( W( M ) ) * TWO
+* IBLOCK( M ) = JBLK
+* INDEXW( M ) = 1
+* ENDIF
+* L2 = TMP1 + DISC
+* IF( WL.GE. L2-PIVMIN )
+* $ NWL = NWL + 1
+* IF( WU.GE. L2-PIVMIN )
+* $ NWU = NWU + 1
+* IF( IRANGE.EQ.ALLRNG .OR. ( WL.LT.L2-PIVMIN .AND. WU.GE.
+* $ L2-PIVMIN ) ) THEN
+* M = M + 1
+* W( M ) = L2
+** The uncertainty of eigenvalues of a 2x2 matrix is very small
+* WERR( M ) = EPS * ABS( W( M ) ) * TWO
+* IBLOCK( M ) = JBLK
+* INDEXW( M ) = 2
+* ENDIF
+ ELSE
+* General Case - block of size IN >= 2
+* Compute local Gerschgorin interval and use it as the initial
+* interval for DLAEBZ
+ GU = D( IBEGIN )
+ GL = D( IBEGIN )
+ TMP1 = ZERO
+
+ DO 40 J = IBEGIN, IEND
+ GL = MIN( GL, GERS( 2*J - 1))
+ GU = MAX( GU, GERS(2*J) )
+ 40 CONTINUE
+ SPDIAM = GU - GL
+ GL = GL - FUDGE*SPDIAM*EPS*IN - FUDGE*PIVMIN
+ GU = GU + FUDGE*SPDIAM*EPS*IN + FUDGE*PIVMIN
+*
+ IF( IRANGE.GT.1 ) THEN
+ IF( GU.LT.WL ) THEN
+* the local block contains none of the wanted eigenvalues
+ NWL = NWL + IN
+ NWU = NWU + IN
+ GO TO 70
+ END IF
+* refine search interval if possible, only range (WL,WU] matters
+ GL = MAX( GL, WL )
+ GU = MIN( GU, WU )
+ IF( GL.GE.GU )
+ $ GO TO 70
+ END IF
+
+* Find negcount of initial interval boundaries GL and GU
+ WORK( N+1 ) = GL
+ WORK( N+IN+1 ) = GU
+ CALL DLAEBZ( 1, 0, IN, IN, 1, NB, ATOLI, RTOLI, PIVMIN,
+ $ D( IBEGIN ), E( IBEGIN ), E2( IBEGIN ),
+ $ IDUMMA, WORK( N+1 ), WORK( N+2*IN+1 ), IM,
+ $ IWORK, W( M+1 ), IBLOCK( M+1 ), IINFO )
+ IF( IINFO .NE. 0 ) THEN
+ INFO = IINFO
+ RETURN
+ END IF
+*
+ NWL = NWL + IWORK( 1 )
+ NWU = NWU + IWORK( IN+1 )
+ IWOFF = M - IWORK( 1 )
+
+* Compute Eigenvalues
+ ITMAX = INT( ( LOG( GU-GL+PIVMIN )-LOG( PIVMIN ) ) /
+ $ LOG( TWO ) ) + 2
+ CALL DLAEBZ( 2, ITMAX, IN, IN, 1, NB, ATOLI, RTOLI, PIVMIN,
+ $ D( IBEGIN ), E( IBEGIN ), E2( IBEGIN ),
+ $ IDUMMA, WORK( N+1 ), WORK( N+2*IN+1 ), IOUT,
+ $ IWORK, W( M+1 ), IBLOCK( M+1 ), IINFO )
+ IF( IINFO .NE. 0 ) THEN
+ INFO = IINFO
+ RETURN
+ END IF
+*
+* Copy eigenvalues into W and IBLOCK
+* Use -JBLK for block number for unconverged eigenvalues.
+* Loop over the number of output intervals from DLAEBZ
+ DO 60 J = 1, IOUT
+* eigenvalue approximation is middle point of interval
+ TMP1 = HALF*( WORK( J+N )+WORK( J+IN+N ) )
+* semi length of error interval
+ TMP2 = HALF*ABS( WORK( J+N )-WORK( J+IN+N ) )
+ IF( J.GT.IOUT-IINFO ) THEN
+* Flag non-convergence.
+ NCNVRG = .TRUE.
+ IB = -JBLK
+ ELSE
+ IB = JBLK
+ END IF
+ DO 50 JE = IWORK( J ) + 1 + IWOFF,
+ $ IWORK( J+IN ) + IWOFF
+ W( JE ) = TMP1
+ WERR( JE ) = TMP2
+ INDEXW( JE ) = JE - IWOFF
+ IBLOCK( JE ) = IB
+ 50 CONTINUE
+ 60 CONTINUE
+*
+ M = M + IM
+ END IF
+ 70 CONTINUE
+
+* If RANGE='I', then (WL,WU) contains eigenvalues NWL+1,...,NWU
+* If NWL+1 < IL or NWU > IU, discard extra eigenvalues.
+ IF( IRANGE.EQ.INDRNG ) THEN
+ IDISCL = IL - 1 - NWL
+ IDISCU = NWU - IU
+*
+ IF( IDISCL.GT.0 ) THEN
+ IM = 0
+ DO 80 JE = 1, M
+* Remove some of the smallest eigenvalues from the left so that
+* at the end IDISCL =0. Move all eigenvalues up to the left.
+ IF( W( JE ).LE.WLU .AND. IDISCL.GT.0 ) THEN
+ IDISCL = IDISCL - 1
+ ELSE
+ IM = IM + 1
+ W( IM ) = W( JE )
+ WERR( IM ) = WERR( JE )
+ INDEXW( IM ) = INDEXW( JE )
+ IBLOCK( IM ) = IBLOCK( JE )
+ END IF
+ 80 CONTINUE
+ M = IM
+ END IF
+ IF( IDISCU.GT.0 ) THEN
+* Remove some of the largest eigenvalues from the right so that
+* at the end IDISCU =0. Move all eigenvalues up to the left.
+ IM=M+1
+ DO 81 JE = M, 1, -1
+ IF( W( JE ).GE.WUL .AND. IDISCU.GT.0 ) THEN
+ IDISCU = IDISCU - 1
+ ELSE
+ IM = IM - 1
+ W( IM ) = W( JE )
+ WERR( IM ) = WERR( JE )
+ INDEXW( IM ) = INDEXW( JE )
+ IBLOCK( IM ) = IBLOCK( JE )
+ END IF
+ 81 CONTINUE
+ JEE = 0
+ DO 82 JE = IM, M
+ JEE = JEE + 1
+ W( JEE ) = W( JE )
+ WERR( JEE ) = WERR( JE )
+ INDEXW( JEE ) = INDEXW( JE )
+ IBLOCK( JEE ) = IBLOCK( JE )
+ 82 CONTINUE
+ M = M-IM+1
+ END IF
+
+ IF( IDISCL.GT.0 .OR. IDISCU.GT.0 ) THEN
+* Code to deal with effects of bad arithmetic. (If N(w) is
+* monotone non-decreasing, this should never happen.)
+* Some low eigenvalues to be discarded are not in (WL,WLU],
+* or high eigenvalues to be discarded are not in (WUL,WU]
+* so just kill off the smallest IDISCL/largest IDISCU
+* eigenvalues, by marking the corresponding IBLOCK = 0
+ IF( IDISCL.GT.0 ) THEN
+ WKILL = WU
+ DO 100 JDISC = 1, IDISCL
+ IW = 0
+ DO 90 JE = 1, M
+ IF( IBLOCK( JE ).NE.0 .AND.
+ $ ( W( JE ).LT.WKILL .OR. IW.EQ.0 ) ) THEN
+ IW = JE
+ WKILL = W( JE )
+ END IF
+ 90 CONTINUE
+ IBLOCK( IW ) = 0
+ 100 CONTINUE
+ END IF
+ IF( IDISCU.GT.0 ) THEN
+ WKILL = WL
+ DO 120 JDISC = 1, IDISCU
+ IW = 0
+ DO 110 JE = 1, M
+ IF( IBLOCK( JE ).NE.0 .AND.
+ $ ( W( JE ).GE.WKILL .OR. IW.EQ.0 ) ) THEN
+ IW = JE
+ WKILL = W( JE )
+ END IF
+ 110 CONTINUE
+ IBLOCK( IW ) = 0
+ 120 CONTINUE
+ END IF
+* Now erase all eigenvalues with IBLOCK set to zero
+ IM = 0
+ DO 130 JE = 1, M
+ IF( IBLOCK( JE ).NE.0 ) THEN
+ IM = IM + 1
+ W( IM ) = W( JE )
+ WERR( IM ) = WERR( JE )
+ INDEXW( IM ) = INDEXW( JE )
+ IBLOCK( IM ) = IBLOCK( JE )
+ END IF
+ 130 CONTINUE
+ M = IM
+ END IF
+ IF( IDISCL.LT.0 .OR. IDISCU.LT.0 ) THEN
+ TOOFEW = .TRUE.
+ END IF
+ END IF
+*
+ IF(( IRANGE.EQ.ALLRNG .AND. M.NE.N ).OR.
+ $ ( IRANGE.EQ.INDRNG .AND. M.NE.IU-IL+1 ) ) THEN
+ TOOFEW = .TRUE.
+ END IF
+
+* If ORDER='B', do nothing the eigenvalues are already sorted by
+* block.
+* If ORDER='E', sort the eigenvalues from smallest to largest
+
+ IF( LSAME(ORDER,'E') .AND. NSPLIT.GT.1 ) THEN
+ DO 150 JE = 1, M - 1
+ IE = 0
+ TMP1 = W( JE )
+ DO 140 J = JE + 1, M
+ IF( W( J ).LT.TMP1 ) THEN
+ IE = J
+ TMP1 = W( J )
+ END IF
+ 140 CONTINUE
+ IF( IE.NE.0 ) THEN
+ TMP2 = WERR( IE )
+ ITMP1 = IBLOCK( IE )
+ ITMP2 = INDEXW( IE )
+ W( IE ) = W( JE )
+ WERR( IE ) = WERR( JE )
+ IBLOCK( IE ) = IBLOCK( JE )
+ INDEXW( IE ) = INDEXW( JE )
+ W( JE ) = TMP1
+ WERR( JE ) = TMP2
+ IBLOCK( JE ) = ITMP1
+ INDEXW( JE ) = ITMP2
+ END IF
+ 150 CONTINUE
+ END IF
+*
+ INFO = 0
+ IF( NCNVRG )
+ $ INFO = INFO + 1
+ IF( TOOFEW )
+ $ INFO = INFO + 2
+ RETURN
+*
+* End of DLARRD
+*
+ END
+ 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 )
+ IMPLICIT NONE
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER RANGE
+ INTEGER IL, INFO, IU, M, N, NSPLIT
+ DOUBLE PRECISION PIVMIN, RTOL1, RTOL2, SPLTOL, VL, VU
+* ..
+* .. Array Arguments ..
+ INTEGER IBLOCK( * ), ISPLIT( * ), IWORK( * ),
+ $ INDEXW( * )
+ DOUBLE PRECISION D( * ), E( * ), E2( * ), GERS( * ),
+ $ W( * ),WERR( * ), WGAP( * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* To find the desired eigenvalues of a given real symmetric
+* tridiagonal matrix T, DLARRE sets any "small" off-diagonal
+* elements to zero, and for each unreduced block T_i, it finds
+* (a) a suitable shift at one end of the block's spectrum,
+* (b) the base representation, T_i - sigma_i I = L_i D_i L_i^T, and
+* (c) eigenvalues of each L_i D_i L_i^T.
+* The representations and eigenvalues found are then used by
+* DSTEMR to compute the eigenvectors of T.
+* The accuracy varies depending on whether bisection is used to
+* find a few eigenvalues or the dqds algorithm (subroutine DLASQ2) to
+* conpute all and then discard any unwanted one.
+* As an added benefit, DLARRE also outputs the n
+* Gerschgorin intervals for the matrices L_i D_i L_i^T.
+*
+* Arguments
+* =========
+*
+* RANGE (input) CHARACTER
+* = 'A': ("All") all eigenvalues will be found.
+* = 'V': ("Value") all eigenvalues in the half-open interval
+* (VL, VU] will be found.
+* = 'I': ("Index") the IL-th through IU-th eigenvalues (of the
+* entire matrix) will be found.
+*
+* N (input) INTEGER
+* The order of the matrix. N > 0.
+*
+* VL (input/output) DOUBLE PRECISION
+* VU (input/output) DOUBLE PRECISION
+* If RANGE='V', the lower and upper bounds for the eigenvalues.
+* Eigenvalues less than or equal to VL, or greater than VU,
+* will not be returned. VL < VU.
+* If RANGE='I' or ='A', DLARRE computes bounds on the desired
+* part of the spectrum.
+*
+* IL (input) INTEGER
+* IU (input) INTEGER
+* If RANGE='I', the indices (in ascending order) of the
+* smallest and largest eigenvalues to be returned.
+* 1 <= IL <= IU <= N.
+*
+* D (input/output) DOUBLE PRECISION array, dimension (N)
+* On entry, the N diagonal elements of the tridiagonal
+* matrix T.
+* On exit, the N diagonal elements of the diagonal
+* matrices D_i.
+*
+* E (input/output) DOUBLE PRECISION array, dimension (N)
+* On entry, the first (N-1) entries contain the subdiagonal
+* elements of the tridiagonal matrix T; E(N) need not be set.
+* On exit, E contains the subdiagonal elements of the unit
+* bidiagonal matrices L_i. The entries E( ISPLIT( I ) ),
+* 1 <= I <= NSPLIT, contain the base points sigma_i on output.
+*
+* E2 (input/output) DOUBLE PRECISION array, dimension (N)
+* On entry, the first (N-1) entries contain the SQUARES of the
+* subdiagonal elements of the tridiagonal matrix T;
+* E2(N) need not be set.
+* On exit, the entries E2( ISPLIT( I ) ),
+* 1 <= I <= NSPLIT, have been set to zero
+*
+* RTOL1 (input) DOUBLE PRECISION
+* RTOL2 (input) DOUBLE PRECISION
+* Parameters for bisection.
+* An interval [LEFT,RIGHT] has converged if
+* RIGHT-LEFT.LT.MAX( RTOL1*GAP, RTOL2*MAX(|LEFT|,|RIGHT|) )
+*
+* SPLTOL (input) DOUBLE PRECISION
+* The threshold for splitting.
+*
+* NSPLIT (output) INTEGER
+* The number of blocks T splits into. 1 <= NSPLIT <= N.
+*
+* ISPLIT (output) INTEGER array, dimension (N)
+* The splitting points, at which T breaks up into blocks.
+* The first block consists of rows/columns 1 to ISPLIT(1),
+* the second of rows/columns ISPLIT(1)+1 through ISPLIT(2),
+* etc., and the NSPLIT-th consists of rows/columns
+* ISPLIT(NSPLIT-1)+1 through ISPLIT(NSPLIT)=N.
+*
+* M (output) INTEGER
+* The total number of eigenvalues (of all L_i D_i L_i^T)
+* found.
+*
+* W (output) DOUBLE PRECISION array, dimension (N)
+* The first M elements contain the eigenvalues. The
+* eigenvalues of each of the blocks, L_i D_i L_i^T, are
+* sorted in ascending order ( DLARRE may use the
+* remaining N-M elements as workspace).
+*
+* WERR (output) DOUBLE PRECISION array, dimension (N)
+* The error bound on the corresponding eigenvalue in W.
+*
+* WGAP (output) DOUBLE PRECISION array, dimension (N)
+* The separation from the right neighbor eigenvalue in W.
+* The gap is only with respect to the eigenvalues of the same block
+* as each block has its own representation tree.
+* Exception: at the right end of a block we store the left gap
+*
+* IBLOCK (output) INTEGER array, dimension (N)
+* The indices of the blocks (submatrices) associated with the
+* corresponding eigenvalues in W; IBLOCK(i)=1 if eigenvalue
+* W(i) belongs to the first block from the top, =2 if W(i)
+* belongs to the second block, etc.
+*
+* INDEXW (output) INTEGER array, dimension (N)
+* The indices of the eigenvalues within each block (submatrix);
+* for example, INDEXW(i)= 10 and IBLOCK(i)=2 imply that the
+* i-th eigenvalue W(i) is the 10-th eigenvalue in block 2
+*
+* GERS (output) DOUBLE PRECISION array, dimension (2*N)
+* The N Gerschgorin intervals (the i-th Gerschgorin interval
+* is (GERS(2*i-1), GERS(2*i)).
+*
+* PIVMIN (output) DOUBLE PRECISION
+* The minimum pivot in the Sturm sequence for T.
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (6*N)
+* Workspace.
+*
+* IWORK (workspace) INTEGER array, dimension (5*N)
+* Workspace.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* > 0: A problem occured in DLARRE.
+* < 0: One of the called subroutines signaled an internal problem.
+* Needs inspection of the corresponding parameter IINFO
+* for further information.
+*
+* =-1: Problem in DLARRD.
+* = 2: No base representation could be found in MAXTRY iterations.
+* Increasing MAXTRY and recompilation might be a remedy.
+* =-3: Problem in DLARRB when computing the refined root
+* representation for DLASQ2.
+* =-4: Problem in DLARRB when preforming bisection on the
+* desired part of the spectrum.
+* =-5: Problem in DLASQ2.
+* =-6: Problem in DLASQ2.
+*
+* Further Details
+* The base representations are required to suffer very little
+* element growth and consequently define all their eigenvalues to
+* high relative accuracy.
+* ===============
+*
+* Based on contributions by
+* Beresford Parlett, University of California, Berkeley, USA
+* Jim Demmel, University of California, Berkeley, USA
+* Inderjit Dhillon, University of Texas, Austin, USA
+* Osni Marques, LBNL/NERSC, USA
+* Christof Voemel, University of California, Berkeley, USA
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION FAC, FOUR, FOURTH, FUDGE, HALF, HNDRD,
+ $ MAXGROWTH, ONE, PERT, TWO, ZERO
+ PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0,
+ $ TWO = 2.0D0, FOUR=4.0D0,
+ $ HNDRD = 100.0D0,
+ $ PERT = 8.0D0,
+ $ HALF = ONE/TWO, FOURTH = ONE/FOUR, FAC= HALF,
+ $ MAXGROWTH = 64.0D0, FUDGE = 2.0D0 )
+ INTEGER MAXTRY, ALLRNG, INDRNG, VALRNG
+ PARAMETER ( MAXTRY = 6, ALLRNG = 1, INDRNG = 2,
+ $ VALRNG = 3 )
+* ..
+* .. Local Scalars ..
+ LOGICAL FORCEB, NOREP, USEDQD
+ INTEGER CNT, CNT1, CNT2, I, IBEGIN, IDUM, IEND, IINFO,
+ $ IN, INDL, INDU, IRANGE, J, JBLK, MB, MM,
+ $ WBEGIN, WEND
+ DOUBLE PRECISION AVGAP, BSRTOL, CLWDTH, DMAX, DPIVOT, EABS,
+ $ EMAX, EOLD, EPS, GL, GU, ISLEFT, ISRGHT, RTL,
+ $ RTOL, S1, S2, SAFMIN, SGNDEF, SIGMA, SPDIAM,
+ $ TAU, TMP, TMP1
+
+
+* ..
+* .. Local Arrays ..
+ INTEGER ISEED( 4 )
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ DOUBLE PRECISION DLAMCH
+ EXTERNAL DLAMCH, LSAME
+
+* ..
+* .. External Subroutines ..
+ EXTERNAL DCOPY, DLARNV, DLARRA, DLARRB, DLARRC, DLARRD,
+ $ DLASQ2
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, MIN
+
+* ..
+* .. Executable Statements ..
+*
+
+ INFO = 0
+
+*
+* Decode RANGE
+*
+ IF( LSAME( RANGE, 'A' ) ) THEN
+ IRANGE = ALLRNG
+ ELSE IF( LSAME( RANGE, 'V' ) ) THEN
+ IRANGE = VALRNG
+ ELSE IF( LSAME( RANGE, 'I' ) ) THEN
+ IRANGE = INDRNG
+ END IF
+
+ M = 0
+
+* Get machine constants
+ SAFMIN = DLAMCH( 'S' )
+ EPS = DLAMCH( 'P' )
+
+* Set parameters
+ RTL = SQRT(EPS)
+ BSRTOL = SQRT(EPS)
+
+* Treat case of 1x1 matrix for quick return
+ IF( N.EQ.1 ) THEN
+ IF( (IRANGE.EQ.ALLRNG).OR.
+ $ ((IRANGE.EQ.VALRNG).AND.(D(1).GT.VL).AND.(D(1).LE.VU)).OR.
+ $ ((IRANGE.EQ.INDRNG).AND.(IL.EQ.1).AND.(IU.EQ.1)) ) THEN
+ M = 1
+ W(1) = D(1)
+* The computation error of the eigenvalue is zero
+ WERR(1) = ZERO
+ WGAP(1) = ZERO
+ IBLOCK( 1 ) = 1
+ INDEXW( 1 ) = 1
+ GERS(1) = D( 1 )
+ GERS(2) = D( 1 )
+ ENDIF
+* store the shift for the initial RRR, which is zero in this case
+ E(1) = ZERO
+ RETURN
+ END IF
+
+* General case: tridiagonal matrix of order > 1
+*
+* Init WERR, WGAP. Compute Gerschgorin intervals and spectral diameter.
+* Compute maximum off-diagonal entry and pivmin.
+ GL = D(1)
+ GU = D(1)
+ EOLD = ZERO
+ EMAX = ZERO
+ E(N) = ZERO
+ DO 5 I = 1,N
+ WERR(I) = ZERO
+ WGAP(I) = ZERO
+ EABS = ABS( E(I) )
+ IF( EABS .GE. EMAX ) THEN
+ EMAX = EABS
+ END IF
+ TMP1 = EABS + EOLD
+ GERS( 2*I-1) = D(I) - TMP1
+ GL = MIN( GL, GERS( 2*I - 1))
+ GERS( 2*I ) = D(I) + TMP1
+ GU = MAX( GU, GERS(2*I) )
+ EOLD = EABS
+ 5 CONTINUE
+* The minimum pivot allowed in the Sturm sequence for T
+ PIVMIN = SAFMIN * MAX( ONE, EMAX**2 )
+* Compute spectral diameter. The Gerschgorin bounds give an
+* estimate that is wrong by at most a factor of SQRT(2)
+ SPDIAM = GU - GL
+
+* Compute splitting points
+ CALL DLARRA( N, D, E, E2, SPLTOL, SPDIAM,
+ $ NSPLIT, ISPLIT, IINFO )
+
+* Can force use of bisection instead of faster DQDS.
+* Option left in the code for future multisection work.
+ FORCEB = .FALSE.
+
+ IF( (IRANGE.EQ.ALLRNG) .AND. (.NOT. FORCEB) ) THEN
+* Set interval [VL,VU] that contains all eigenvalues
+ VL = GL
+ VU = GU
+ ELSE
+* We call DLARRD to find crude approximations to the eigenvalues
+* in the desired range. In case IRANGE = INDRNG, we also obtain the
+* interval (VL,VU] that contains all the wanted eigenvalues.
+* An interval [LEFT,RIGHT] has converged if
+* RIGHT-LEFT.LT.RTOL*MAX(ABS(LEFT),ABS(RIGHT))
+* DLARRD needs a WORK of size 4*N, IWORK of size 3*N
+ CALL DLARRD( RANGE, 'B', N, VL, VU, IL, IU, GERS,
+ $ BSRTOL, D, E, E2, PIVMIN, NSPLIT, ISPLIT,
+ $ MM, W, WERR, VL, VU, IBLOCK, INDEXW,
+ $ WORK, IWORK, IINFO )
+ IF( IINFO.NE.0 ) THEN
+ INFO = -1
+ RETURN
+ ENDIF
+* Make sure that the entries M+1 to N in W, WERR, IBLOCK, INDEXW are 0
+ DO 14 I = MM+1,N
+ W( I ) = ZERO
+ WERR( I ) = ZERO
+ IBLOCK( I ) = 0
+ INDEXW( I ) = 0
+ 14 CONTINUE
+ END IF
+
+
+***
+* Loop over unreduced blocks
+ IBEGIN = 1
+ WBEGIN = 1
+ DO 170 JBLK = 1, NSPLIT
+ IEND = ISPLIT( JBLK )
+ IN = IEND - IBEGIN + 1
+
+* 1 X 1 block
+ IF( IN.EQ.1 ) THEN
+ IF( (IRANGE.EQ.ALLRNG).OR.( (IRANGE.EQ.VALRNG).AND.
+ $ ( D( IBEGIN ).GT.VL ).AND.( D( IBEGIN ).LE.VU ) )
+ $ .OR. ( (IRANGE.EQ.INDRNG).AND.(IBLOCK(WBEGIN).EQ.JBLK))
+ $ ) THEN
+ M = M + 1
+ W( M ) = D( IBEGIN )
+ WERR(M) = ZERO
+* The gap for a single block doesn't matter for the later
+* algorithm and is assigned an arbitrary large value
+ WGAP(M) = ZERO
+ IBLOCK( M ) = JBLK
+ INDEXW( M ) = 1
+ WBEGIN = WBEGIN + 1
+ ENDIF
+* E( IEND ) holds the shift for the initial RRR
+ E( IEND ) = ZERO
+ IBEGIN = IEND + 1
+ GO TO 170
+ END IF
+*
+* Blocks of size larger than 1x1
+*
+* E( IEND ) will hold the shift for the initial RRR, for now set it =0
+ E( IEND ) = ZERO
+*
+* Find local outer bounds GL,GU for the block
+ GL = D(IBEGIN)
+ GU = D(IBEGIN)
+ DO 15 I = IBEGIN , IEND
+ GL = MIN( GERS( 2*I-1 ), GL )
+ GU = MAX( GERS( 2*I ), GU )
+ 15 CONTINUE
+ SPDIAM = GU - GL
+
+ IF(.NOT. ((IRANGE.EQ.ALLRNG).AND.(.NOT.FORCEB)) ) THEN
+* Count the number of eigenvalues in the current block.
+ MB = 0
+ DO 20 I = WBEGIN,MM
+ IF( IBLOCK(I).EQ.JBLK ) THEN
+ MB = MB+1
+ ELSE
+ GOTO 21
+ ENDIF
+ 20 CONTINUE
+ 21 CONTINUE
+
+ IF( MB.EQ.0) THEN
+* No eigenvalue in the current block lies in the desired range
+* E( IEND ) holds the shift for the initial RRR
+ E( IEND ) = ZERO
+ IBEGIN = IEND + 1
+ GO TO 170
+ ELSE
+
+* Decide whether dqds or bisection is more efficient
+ USEDQD = ( (MB .GT. FAC*IN) .AND. (.NOT.FORCEB) )
+ WEND = WBEGIN + MB - 1
+* Calculate gaps for the current block
+* In later stages, when representations for individual
+* eigenvalues are different, we use SIGMA = E( IEND ).
+ SIGMA = ZERO
+ DO 30 I = WBEGIN, WEND - 1
+ WGAP( I ) = MAX( ZERO,
+ $ W(I+1)-WERR(I+1) - (W(I)+WERR(I)) )
+ 30 CONTINUE
+ WGAP( WEND ) = MAX( ZERO,
+ $ VU - SIGMA - (W( WEND )+WERR( WEND )))
+* Find local index of the first and last desired evalue.
+ INDL = INDEXW(WBEGIN)
+ INDU = INDEXW( WEND )
+ ENDIF
+ ENDIF
+ IF(( (IRANGE.EQ.ALLRNG) .AND. (.NOT. FORCEB) ).OR.USEDQD) THEN
+* Case of DQDS
+* Find approximations to the extremal eigenvalues of the block
+ CALL DLARRK( IN, 1, GL, GU, D(IBEGIN),
+ $ E2(IBEGIN), PIVMIN, RTL, TMP, TMP1, IINFO )
+ IF( IINFO.NE.0 ) THEN
+ INFO = -1
+ RETURN
+ ENDIF
+ ISLEFT = MAX(GL, TMP - TMP1
+ $ - HNDRD * EPS* ABS(TMP - TMP1))
+
+ CALL DLARRK( IN, IN, GL, GU, D(IBEGIN),
+ $ E2(IBEGIN), PIVMIN, RTL, TMP, TMP1, IINFO )
+ IF( IINFO.NE.0 ) THEN
+ INFO = -1
+ RETURN
+ ENDIF
+ ISRGHT = MIN(GU, TMP + TMP1
+ $ + HNDRD * EPS * ABS(TMP + TMP1))
+* Improve the estimate of the spectral diameter
+ SPDIAM = ISRGHT - ISLEFT
+ ELSE
+* Case of bisection
+* Find approximations to the wanted extremal eigenvalues
+ ISLEFT = MAX(GL, W(WBEGIN) - WERR(WBEGIN)
+ $ - HNDRD * EPS*ABS(W(WBEGIN)- WERR(WBEGIN) ))
+ ISRGHT = MIN(GU,W(WEND) + WERR(WEND)
+ $ + HNDRD * EPS * ABS(W(WEND)+ WERR(WEND)))
+ ENDIF
+
+
+* Decide whether the base representation for the current block
+* L_JBLK D_JBLK L_JBLK^T = T_JBLK - sigma_JBLK I
+* should be on the left or the right end of the current block.
+* The strategy is to shift to the end which is "more populated"
+* Furthermore, decide whether to use DQDS for the computation of
+* the eigenvalue approximations at the end of DLARRE or bisection.
+* dqds is chosen if all eigenvalues are desired or the number of
+* eigenvalues to be computed is large compared to the blocksize.
+ IF( ( IRANGE.EQ.ALLRNG ) .AND. (.NOT.FORCEB) ) THEN
+* If all the eigenvalues have to be computed, we use dqd
+ USEDQD = .TRUE.
+* INDL is the local index of the first eigenvalue to compute
+ INDL = 1
+ INDU = IN
+* MB = number of eigenvalues to compute
+ MB = IN
+ WEND = WBEGIN + MB - 1
+* Define 1/4 and 3/4 points of the spectrum
+ S1 = ISLEFT + FOURTH * SPDIAM
+ S2 = ISRGHT - FOURTH * SPDIAM
+ ELSE
+* DLARRD has computed IBLOCK and INDEXW for each eigenvalue
+* approximation.
+* choose sigma
+ IF( USEDQD ) THEN
+ S1 = ISLEFT + FOURTH * SPDIAM
+ S2 = ISRGHT - FOURTH * SPDIAM
+ ELSE
+ TMP = MIN(ISRGHT,VU) - MAX(ISLEFT,VL)
+ S1 = MAX(ISLEFT,VL) + FOURTH * TMP
+ S2 = MIN(ISRGHT,VU) - FOURTH * TMP
+ ENDIF
+ ENDIF
+
+* Compute the negcount at the 1/4 and 3/4 points
+ IF(MB.GT.1) THEN
+ CALL DLARRC( 'T', IN, S1, S2, D(IBEGIN),
+ $ E(IBEGIN), PIVMIN, CNT, CNT1, CNT2, IINFO)
+ ENDIF
+
+ IF(MB.EQ.1) THEN
+ SIGMA = GL
+ SGNDEF = ONE
+ ELSEIF( CNT1 - INDL .GE. INDU - CNT2 ) THEN
+ IF( ( IRANGE.EQ.ALLRNG ) .AND. (.NOT.FORCEB) ) THEN
+ SIGMA = MAX(ISLEFT,GL)
+ ELSEIF( USEDQD ) THEN
+* use Gerschgorin bound as shift to get pos def matrix
+* for dqds
+ SIGMA = ISLEFT
+ ELSE
+* use approximation of the first desired eigenvalue of the
+* block as shift
+ SIGMA = MAX(ISLEFT,VL)
+ ENDIF
+ SGNDEF = ONE
+ ELSE
+ IF( ( IRANGE.EQ.ALLRNG ) .AND. (.NOT.FORCEB) ) THEN
+ SIGMA = MIN(ISRGHT,GU)
+ ELSEIF( USEDQD ) THEN
+* use Gerschgorin bound as shift to get neg def matrix
+* for dqds
+ SIGMA = ISRGHT
+ ELSE
+* use approximation of the first desired eigenvalue of the
+* block as shift
+ SIGMA = MIN(ISRGHT,VU)
+ ENDIF
+ SGNDEF = -ONE
+ ENDIF
+
+
+* An initial SIGMA has been chosen that will be used for computing
+* T - SIGMA I = L D L^T
+* Define the increment TAU of the shift in case the initial shift
+* needs to be refined to obtain a factorization with not too much
+* element growth.
+ IF( USEDQD ) THEN
+* The initial SIGMA was to the outer end of the spectrum
+* the matrix is definite and we need not retreat.
+ TAU = SPDIAM*EPS*N + TWO*PIVMIN
+ ELSE
+ IF(MB.GT.1) THEN
+ CLWDTH = W(WEND) + WERR(WEND) - W(WBEGIN) - WERR(WBEGIN)
+ AVGAP = ABS(CLWDTH / DBLE(WEND-WBEGIN))
+ IF( SGNDEF.EQ.ONE ) THEN
+ TAU = HALF*MAX(WGAP(WBEGIN),AVGAP)
+ TAU = MAX(TAU,WERR(WBEGIN))
+ ELSE
+ TAU = HALF*MAX(WGAP(WEND-1),AVGAP)
+ TAU = MAX(TAU,WERR(WEND))
+ ENDIF
+ ELSE
+ TAU = WERR(WBEGIN)
+ ENDIF
+ ENDIF
+*
+ DO 80 IDUM = 1, MAXTRY
+* Compute L D L^T factorization of tridiagonal matrix T - sigma I.
+* Store D in WORK(1:IN), L in WORK(IN+1:2*IN), and reciprocals of
+* pivots in WORK(2*IN+1:3*IN)
+ DPIVOT = D( IBEGIN ) - SIGMA
+ WORK( 1 ) = DPIVOT
+ DMAX = ABS( WORK(1) )
+ J = IBEGIN
+ DO 70 I = 1, IN - 1
+ WORK( 2*IN+I ) = ONE / WORK( I )
+ TMP = E( J )*WORK( 2*IN+I )
+ WORK( IN+I ) = TMP
+ DPIVOT = ( D( J+1 )-SIGMA ) - TMP*E( J )
+ WORK( I+1 ) = DPIVOT
+ DMAX = MAX( DMAX, ABS(DPIVOT) )
+ J = J + 1
+ 70 CONTINUE
+* check for element growth
+ IF( DMAX .GT. MAXGROWTH*SPDIAM ) THEN
+ NOREP = .TRUE.
+ ELSE
+ NOREP = .FALSE.
+ ENDIF
+ IF( USEDQD .AND. .NOT.NOREP ) THEN
+* Ensure the definiteness of the representation
+* All entries of D (of L D L^T) must have the same sign
+ DO 71 I = 1, IN
+ TMP = SGNDEF*WORK( I )
+ IF( TMP.LT.ZERO ) NOREP = .TRUE.
+ 71 CONTINUE
+ ENDIF
+ IF(NOREP) THEN
+* Note that in the case of IRANGE=ALLRNG, we use the Gerschgorin
+* shift which makes the matrix definite. So we should end up
+* here really only in the case of IRANGE = VALRNG or INDRNG.
+ IF( IDUM.EQ.MAXTRY-1 ) THEN
+ IF( SGNDEF.EQ.ONE ) THEN
+* The fudged Gerschgorin shift should succeed
+ SIGMA =
+ $ GL - FUDGE*SPDIAM*EPS*N - FUDGE*TWO*PIVMIN
+ ELSE
+ SIGMA =
+ $ GU + FUDGE*SPDIAM*EPS*N + FUDGE*TWO*PIVMIN
+ END IF
+ ELSE
+ SIGMA = SIGMA - SGNDEF * TAU
+ TAU = TWO * TAU
+ END IF
+ ELSE
+* an initial RRR is found
+ GO TO 83
+ END IF
+ 80 CONTINUE
+* if the program reaches this point, no base representation could be
+* found in MAXTRY iterations.
+ INFO = 2
+ RETURN
+
+ 83 CONTINUE
+* At this point, we have found an initial base representation
+* T - SIGMA I = L D L^T with not too much element growth.
+* Store the shift.
+ E( IEND ) = SIGMA
+* Store D and L.
+ CALL DCOPY( IN, WORK, 1, D( IBEGIN ), 1 )
+ CALL DCOPY( IN-1, WORK( IN+1 ), 1, E( IBEGIN ), 1 )
+
+
+ IF(MB.GT.1 ) THEN
+*
+* Perturb each entry of the base representation by a small
+* (but random) relative amount to overcome difficulties with
+* glued matrices.
+*
+ DO 122 I = 1, 4
+ ISEED( I ) = 1
+ 122 CONTINUE
+
+ CALL DLARNV(2, ISEED, 2*IN-1, WORK(1))
+ DO 125 I = 1,IN-1
+ D(IBEGIN+I-1) = D(IBEGIN+I-1)*(ONE+EPS*PERT*WORK(I))
+ E(IBEGIN+I-1) = E(IBEGIN+I-1)*(ONE+EPS*PERT*WORK(IN+I))
+ 125 CONTINUE
+ D(IEND) = D(IEND)*(ONE+EPS*FOUR*WORK(IN))
+*
+ ENDIF
+*
+* Don't update the Gerschgorin intervals because keeping track
+* of the updates would be too much work in DLARRV.
+* We update W instead and use it to locate the proper Gerschgorin
+* intervals.
+
+* Compute the required eigenvalues of L D L' by bisection or dqds
+ IF ( .NOT.USEDQD ) THEN
+* If DLARRD has been used, shift the eigenvalue approximations
+* according to their representation. This is necessary for
+* a uniform DLARRV since dqds computes eigenvalues of the
+* shifted representation. In DLARRV, W will always hold the
+* UNshifted eigenvalue approximation.
+ DO 134 J=WBEGIN,WEND
+ W(J) = W(J) - SIGMA
+ WERR(J) = WERR(J) + ABS(W(J)) * EPS
+ 134 CONTINUE
+* call DLARRB to reduce eigenvalue error of the approximations
+* from DLARRD
+ DO 135 I = IBEGIN, IEND-1
+ WORK( I ) = D( I ) * E( I )**2
+ 135 CONTINUE
+* use bisection to find EV from INDL to INDU
+ CALL DLARRB(IN, D(IBEGIN), WORK(IBEGIN),
+ $ INDL, INDU, RTOL1, RTOL2, INDL-1,
+ $ W(WBEGIN), WGAP(WBEGIN), WERR(WBEGIN),
+ $ WORK( 2*N+1 ), IWORK, PIVMIN, SPDIAM,
+ $ IN, IINFO )
+ IF( IINFO .NE. 0 ) THEN
+ INFO = -4
+ RETURN
+ END IF
+* DLARRB computes all gaps correctly except for the last one
+* Record distance to VU/GU
+ WGAP( WEND ) = MAX( ZERO,
+ $ ( VU-SIGMA ) - ( W( WEND ) + WERR( WEND ) ) )
+ DO 138 I = INDL, INDU
+ M = M + 1
+ IBLOCK(M) = JBLK
+ INDEXW(M) = I
+ 138 CONTINUE
+ ELSE
+* Call dqds to get all eigs (and then possibly delete unwanted
+* eigenvalues).
+* Note that dqds finds the eigenvalues of the L D L^T representation
+* of T to high relative accuracy. High relative accuracy
+* might be lost when the shift of the RRR is subtracted to obtain
+* the eigenvalues of T. However, T is not guaranteed to define its
+* eigenvalues to high relative accuracy anyway.
+* Set RTOL to the order of the tolerance used in DLASQ2
+* This is an ESTIMATED error, the worst case bound is 4*N*EPS
+* which is usually too large and requires unnecessary work to be
+* done by bisection when computing the eigenvectors
+ RTOL = LOG(DBLE(IN)) * FOUR * EPS
+ J = IBEGIN
+ DO 140 I = 1, IN - 1
+ WORK( 2*I-1 ) = ABS( D( J ) )
+ WORK( 2*I ) = E( J )*E( J )*WORK( 2*I-1 )
+ J = J + 1
+ 140 CONTINUE
+ WORK( 2*IN-1 ) = ABS( D( IEND ) )
+ WORK( 2*IN ) = ZERO
+ CALL DLASQ2( IN, WORK, IINFO )
+ IF( IINFO .NE. 0 ) THEN
+* If IINFO = -5 then an index is part of a tight cluster
+* and should be changed. The index is in IWORK(1) and the
+* gap is in WORK(N+1)
+ INFO = -5
+ RETURN
+ ELSE
+* Test that all eigenvalues are positive as expected
+ DO 149 I = 1, IN
+ IF( WORK( I ).LT.ZERO ) THEN
+ INFO = -6
+ RETURN
+ ENDIF
+ 149 CONTINUE
+ END IF
+ IF( SGNDEF.GT.ZERO ) THEN
+ DO 150 I = INDL, INDU
+ M = M + 1
+ W( M ) = WORK( IN-I+1 )
+ IBLOCK( M ) = JBLK
+ INDEXW( M ) = I
+ 150 CONTINUE
+ ELSE
+ DO 160 I = INDL, INDU
+ M = M + 1
+ W( M ) = -WORK( I )
+ IBLOCK( M ) = JBLK
+ INDEXW( M ) = I
+ 160 CONTINUE
+ END IF
+
+ DO 165 I = M - MB + 1, M
+* the value of RTOL below should be the tolerance in DLASQ2
+ WERR( I ) = RTOL * ABS( W(I) )
+ 165 CONTINUE
+ DO 166 I = M - MB + 1, M - 1
+* compute the right gap between the intervals
+ WGAP( I ) = MAX( ZERO,
+ $ W(I+1)-WERR(I+1) - (W(I)+WERR(I)) )
+ 166 CONTINUE
+ WGAP( M ) = MAX( ZERO,
+ $ ( VU-SIGMA ) - ( W( M ) + WERR( M ) ) )
+ END IF
+* proceed with next block
+ IBEGIN = IEND + 1
+ WBEGIN = WEND + 1
+ 170 CONTINUE
+*
+
+ RETURN
+*
+* end of DLARRE
+*
+ END
+ SUBROUTINE DLARRF( N, D, L, LD, CLSTRT, CLEND,
+ $ W, WGAP, WERR,
+ $ SPDIAM, CLGAPL, CLGAPR, PIVMIN, SIGMA,
+ $ DPLUS, LPLUS, WORK, INFO )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+**
+* .. Scalar Arguments ..
+ INTEGER CLSTRT, CLEND, INFO, N
+ DOUBLE PRECISION CLGAPL, CLGAPR, PIVMIN, SIGMA, SPDIAM
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION D( * ), DPLUS( * ), L( * ), LD( * ),
+ $ LPLUS( * ), W( * ), WGAP( * ), WERR( * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* Given the initial representation L D L^T and its cluster of close
+* eigenvalues (in a relative measure), W( CLSTRT ), W( CLSTRT+1 ), ...
+* W( CLEND ), DLARRF finds a new relatively robust representation
+* L D L^T - SIGMA I = L(+) D(+) L(+)^T such that at least one of the
+* eigenvalues of L(+) D(+) L(+)^T is relatively isolated.
+*
+* Arguments
+* =========
+*
+* N (input) INTEGER
+* The order of the matrix (subblock, if the matrix splitted).
+*
+* D (input) DOUBLE PRECISION array, dimension (N)
+* The N diagonal elements of the diagonal matrix D.
+*
+* L (input) DOUBLE PRECISION array, dimension (N-1)
+* The (N-1) subdiagonal elements of the unit bidiagonal
+* matrix L.
+*
+* LD (input) DOUBLE PRECISION array, dimension (N-1)
+* The (N-1) elements L(i)*D(i).
+*
+* CLSTRT (input) INTEGER
+* The index of the first eigenvalue in the cluster.
+*
+* CLEND (input) INTEGER
+* The index of the last eigenvalue in the cluster.
+*
+* W (input) DOUBLE PRECISION array, dimension >= (CLEND-CLSTRT+1)
+* The eigenvalue APPROXIMATIONS of L D L^T in ascending order.
+* W( CLSTRT ) through W( CLEND ) form the cluster of relatively
+* close eigenalues.
+*
+* WGAP (input/output) DOUBLE PRECISION array, dimension >= (CLEND-CLSTRT+1)
+* The separation from the right neighbor eigenvalue in W.
+*
+* WERR (input) DOUBLE PRECISION array, dimension >= (CLEND-CLSTRT+1)
+* WERR contain the semiwidth of the uncertainty
+* interval of the corresponding eigenvalue APPROXIMATION in W
+*
+* SPDIAM (input) estimate of the spectral diameter obtained from the
+* Gerschgorin intervals
+*
+* CLGAPL, CLGAPR (input) absolute gap on each end of the cluster.
+* Set by the calling routine to protect against shifts too close
+* to eigenvalues outside the cluster.
+*
+* PIVMIN (input) DOUBLE PRECISION
+* The minimum pivot allowed in the Sturm sequence.
+*
+* SIGMA (output) DOUBLE PRECISION
+* The shift used to form L(+) D(+) L(+)^T.
+*
+* DPLUS (output) DOUBLE PRECISION array, dimension (N)
+* The N diagonal elements of the diagonal matrix D(+).
+*
+* LPLUS (output) DOUBLE PRECISION array, dimension (N-1)
+* The first (N-1) elements of LPLUS contain the subdiagonal
+* elements of the unit bidiagonal matrix L(+).
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (2*N)
+* Workspace.
+*
+* Further Details
+* ===============
+*
+* Based on contributions by
+* Beresford Parlett, University of California, Berkeley, USA
+* Jim Demmel, University of California, Berkeley, USA
+* Inderjit Dhillon, University of Texas, Austin, USA
+* Osni Marques, LBNL/NERSC, USA
+* Christof Voemel, University of California, Berkeley, USA
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION FOUR, MAXGROWTH1, MAXGROWTH2, ONE, QUART, TWO,
+ $ ZERO
+ PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0,
+ $ FOUR = 4.0D0, QUART = 0.25D0,
+ $ MAXGROWTH1 = 8.D0,
+ $ MAXGROWTH2 = 8.D0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL DORRR1, FORCER, NOFAIL, SAWNAN1, SAWNAN2, TRYRRR1
+ INTEGER I, INDX, KTRY, KTRYMAX, SLEFT, SRIGHT, SHIFT
+ PARAMETER ( KTRYMAX = 1, SLEFT = 1, SRIGHT = 2 )
+ DOUBLE PRECISION AVGAP, BESTSHIFT, CLWDTH, EPS, FACT, FAIL,
+ $ FAIL2, GROWTHBOUND, LDELTA, LDMAX, LSIGMA,
+ $ MAX1, MAX2, MINGAP, OLDP, PROD, RDELTA, RDMAX,
+ $ RRR1, RRR2, RSIGMA, S, SMLGROWTH, TMP, ZNM2
+* ..
+* .. External Functions ..
+ LOGICAL DISNAN
+ DOUBLE PRECISION DLAMCH
+ EXTERNAL DISNAN, DLAMCH
+* ..
+* .. External Subroutines ..
+ EXTERNAL DCOPY
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS
+* ..
+* .. Executable Statements ..
+*
+ INFO = 0
+ FACT = DBLE(2**KTRYMAX)
+ EPS = DLAMCH( 'Precision' )
+ SHIFT = 0
+ FORCER = .FALSE.
+
+
+* Note that we cannot guarantee that for any of the shifts tried,
+* the factorization has a small or even moderate element growth.
+* There could be Ritz values at both ends of the cluster and despite
+* backing off, there are examples where all factorizations tried
+* (in IEEE mode, allowing zero pivots & infinities) have INFINITE
+* element growth.
+* For this reason, we should use PIVMIN in this subroutine so that at
+* least the L D L^T factorization exists. It can be checked afterwards
+* whether the element growth caused bad residuals/orthogonality.
+
+* Decide whether the code should accept the best among all
+* representations despite large element growth or signal INFO=1
+ NOFAIL = .TRUE.
+*
+
+* Compute the average gap length of the cluster
+ CLWDTH = ABS(W(CLEND)-W(CLSTRT)) + WERR(CLEND) + WERR(CLSTRT)
+ AVGAP = CLWDTH / DBLE(CLEND-CLSTRT)
+ MINGAP = MIN(CLGAPL, CLGAPR)
+* Initial values for shifts to both ends of cluster
+ LSIGMA = MIN(W( CLSTRT ),W( CLEND )) - WERR( CLSTRT )
+ RSIGMA = MAX(W( CLSTRT ),W( CLEND )) + WERR( CLEND )
+
+* Use a small fudge to make sure that we really shift to the outside
+ LSIGMA = LSIGMA - ABS(LSIGMA)* FOUR * EPS
+ RSIGMA = RSIGMA + ABS(RSIGMA)* FOUR * EPS
+
+* Compute upper bounds for how much to back off the initial shifts
+ LDMAX = QUART * MINGAP + TWO * PIVMIN
+ RDMAX = QUART * MINGAP + TWO * PIVMIN
+
+ LDELTA = MAX(AVGAP,WGAP( CLSTRT ))/FACT
+ RDELTA = MAX(AVGAP,WGAP( CLEND-1 ))/FACT
+*
+* Initialize the record of the best representation found
+*
+ S = DLAMCH( 'S' )
+ SMLGROWTH = ONE / S
+ FAIL = DBLE(N-1)*MINGAP/(SPDIAM*EPS)
+ FAIL2 = DBLE(N-1)*MINGAP/(SPDIAM*SQRT(EPS))
+ BESTSHIFT = LSIGMA
+*
+* while (KTRY <= KTRYMAX)
+ KTRY = 0
+ GROWTHBOUND = MAXGROWTH1*SPDIAM
+
+ 5 CONTINUE
+ SAWNAN1 = .FALSE.
+ SAWNAN2 = .FALSE.
+* Ensure that we do not back off too much of the initial shifts
+ LDELTA = MIN(LDMAX,LDELTA)
+ RDELTA = MIN(RDMAX,RDELTA)
+
+* Compute the element growth when shifting to both ends of the cluster
+* accept the shift if there is no element growth at one of the two ends
+
+* Left end
+ S = -LSIGMA
+ DPLUS( 1 ) = D( 1 ) + S
+ IF(ABS(DPLUS(1)).LT.PIVMIN) THEN
+ DPLUS(1) = -PIVMIN
+* Need to set SAWNAN1 because refined RRR test should not be used
+* in this case
+ SAWNAN1 = .TRUE.
+ ENDIF
+ MAX1 = ABS( DPLUS( 1 ) )
+ DO 6 I = 1, N - 1
+ LPLUS( I ) = LD( I ) / DPLUS( I )
+ S = S*LPLUS( I )*L( I ) - LSIGMA
+ DPLUS( I+1 ) = D( I+1 ) + S
+ IF(ABS(DPLUS(I+1)).LT.PIVMIN) THEN
+ DPLUS(I+1) = -PIVMIN
+* Need to set SAWNAN1 because refined RRR test should not be used
+* in this case
+ SAWNAN1 = .TRUE.
+ ENDIF
+ MAX1 = MAX( MAX1,ABS(DPLUS(I+1)) )
+ 6 CONTINUE
+ SAWNAN1 = SAWNAN1 .OR. DISNAN( MAX1 )
+
+ IF( FORCER .OR.
+ $ (MAX1.LE.GROWTHBOUND .AND. .NOT.SAWNAN1 ) ) THEN
+ SIGMA = LSIGMA
+ SHIFT = SLEFT
+ GOTO 100
+ ENDIF
+
+* Right end
+ S = -RSIGMA
+ WORK( 1 ) = D( 1 ) + S
+ IF(ABS(WORK(1)).LT.PIVMIN) THEN
+ WORK(1) = -PIVMIN
+* Need to set SAWNAN2 because refined RRR test should not be used
+* in this case
+ SAWNAN2 = .TRUE.
+ ENDIF
+ MAX2 = ABS( WORK( 1 ) )
+ DO 7 I = 1, N - 1
+ WORK( N+I ) = LD( I ) / WORK( I )
+ S = S*WORK( N+I )*L( I ) - RSIGMA
+ WORK( I+1 ) = D( I+1 ) + S
+ IF(ABS(WORK(I+1)).LT.PIVMIN) THEN
+ WORK(I+1) = -PIVMIN
+* Need to set SAWNAN2 because refined RRR test should not be used
+* in this case
+ SAWNAN2 = .TRUE.
+ ENDIF
+ MAX2 = MAX( MAX2,ABS(WORK(I+1)) )
+ 7 CONTINUE
+ SAWNAN2 = SAWNAN2 .OR. DISNAN( MAX2 )
+
+ IF( FORCER .OR.
+ $ (MAX2.LE.GROWTHBOUND .AND. .NOT.SAWNAN2 ) ) THEN
+ SIGMA = RSIGMA
+ SHIFT = SRIGHT
+ GOTO 100
+ ENDIF
+* If we are at this point, both shifts led to too much element growth
+
+* Record the better of the two shifts (provided it didn't lead to NaN)
+ IF(SAWNAN1.AND.SAWNAN2) THEN
+* both MAX1 and MAX2 are NaN
+ GOTO 50
+ ELSE
+ IF( .NOT.SAWNAN1 ) THEN
+ INDX = 1
+ IF(MAX1.LE.SMLGROWTH) THEN
+ SMLGROWTH = MAX1
+ BESTSHIFT = LSIGMA
+ ENDIF
+ ENDIF
+ IF( .NOT.SAWNAN2 ) THEN
+ IF(SAWNAN1 .OR. MAX2.LE.MAX1) INDX = 2
+ IF(MAX2.LE.SMLGROWTH) THEN
+ SMLGROWTH = MAX2
+ BESTSHIFT = RSIGMA
+ ENDIF
+ ENDIF
+ ENDIF
+
+* If we are here, both the left and the right shift led to
+* element growth. If the element growth is moderate, then
+* we may still accept the representation, if it passes a
+* refined test for RRR. This test supposes that no NaN occurred.
+* Moreover, we use the refined RRR test only for isolated clusters.
+ IF((CLWDTH.LT.MINGAP/DBLE(128)) .AND.
+ $ (MIN(MAX1,MAX2).LT.FAIL2)
+ $ .AND.(.NOT.SAWNAN1).AND.(.NOT.SAWNAN2)) THEN
+ DORRR1 = .TRUE.
+ ELSE
+ DORRR1 = .FALSE.
+ ENDIF
+ TRYRRR1 = .TRUE.
+ IF( TRYRRR1 .AND. DORRR1 ) THEN
+ IF(INDX.EQ.1) THEN
+ TMP = ABS( DPLUS( N ) )
+ ZNM2 = ONE
+ PROD = ONE
+ OLDP = ONE
+ DO 15 I = N-1, 1, -1
+ IF( PROD .LE. EPS ) THEN
+ PROD =
+ $ ((DPLUS(I+1)*WORK(N+I+1))/(DPLUS(I)*WORK(N+I)))*OLDP
+ ELSE
+ PROD = PROD*ABS(WORK(N+I))
+ END IF
+ OLDP = PROD
+ ZNM2 = ZNM2 + PROD**2
+ TMP = MAX( TMP, ABS( DPLUS( I ) * PROD ))
+ 15 CONTINUE
+ RRR1 = TMP/( SPDIAM * SQRT( ZNM2 ) )
+ IF (RRR1.LE.MAXGROWTH2) THEN
+ SIGMA = LSIGMA
+ SHIFT = SLEFT
+ GOTO 100
+ ENDIF
+ ELSE IF(INDX.EQ.2) THEN
+ TMP = ABS( WORK( N ) )
+ ZNM2 = ONE
+ PROD = ONE
+ OLDP = ONE
+ DO 16 I = N-1, 1, -1
+ IF( PROD .LE. EPS ) THEN
+ PROD = ((WORK(I+1)*LPLUS(I+1))/(WORK(I)*LPLUS(I)))*OLDP
+ ELSE
+ PROD = PROD*ABS(LPLUS(I))
+ END IF
+ OLDP = PROD
+ ZNM2 = ZNM2 + PROD**2
+ TMP = MAX( TMP, ABS( WORK( I ) * PROD ))
+ 16 CONTINUE
+ RRR2 = TMP/( SPDIAM * SQRT( ZNM2 ) )
+ IF (RRR2.LE.MAXGROWTH2) THEN
+ SIGMA = RSIGMA
+ SHIFT = SRIGHT
+ GOTO 100
+ ENDIF
+ END IF
+ ENDIF
+
+ 50 CONTINUE
+
+ IF (KTRY.LT.KTRYMAX) THEN
+* If we are here, both shifts failed also the RRR test.
+* Back off to the outside
+ LSIGMA = MAX( LSIGMA - LDELTA,
+ $ LSIGMA - LDMAX)
+ RSIGMA = MIN( RSIGMA + RDELTA,
+ $ RSIGMA + RDMAX )
+ LDELTA = TWO * LDELTA
+ RDELTA = TWO * RDELTA
+ KTRY = KTRY + 1
+ GOTO 5
+ ELSE
+* None of the representations investigated satisfied our
+* criteria. Take the best one we found.
+ IF((SMLGROWTH.LT.FAIL).OR.NOFAIL) THEN
+ LSIGMA = BESTSHIFT
+ RSIGMA = BESTSHIFT
+ FORCER = .TRUE.
+ GOTO 5
+ ELSE
+ INFO = 1
+ RETURN
+ ENDIF
+ END IF
+
+ 100 CONTINUE
+ IF (SHIFT.EQ.SLEFT) THEN
+ ELSEIF (SHIFT.EQ.SRIGHT) THEN
+* store new L and D back into DPLUS, LPLUS
+ CALL DCOPY( N, WORK, 1, DPLUS, 1 )
+ CALL DCOPY( N-1, WORK(N+1), 1, LPLUS, 1 )
+ ENDIF
+
+ RETURN
+*
+* End of DLARRF
+*
+ END
+ SUBROUTINE DLARRJ( N, D, E2, IFIRST, ILAST,
+ $ RTOL, OFFSET, W, WERR, WORK, IWORK,
+ $ PIVMIN, SPDIAM, INFO )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER IFIRST, ILAST, INFO, N, OFFSET
+ DOUBLE PRECISION PIVMIN, RTOL, SPDIAM
+* ..
+* .. Array Arguments ..
+ INTEGER IWORK( * )
+ DOUBLE PRECISION D( * ), E2( * ), W( * ),
+ $ WERR( * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* Given the initial eigenvalue approximations of T, DLARRJ
+* does bisection to refine the eigenvalues of T,
+* W( IFIRST-OFFSET ) through W( ILAST-OFFSET ), to more accuracy. Initial
+* guesses for these eigenvalues are input in W, the corresponding estimate
+* of the error in these guesses in WERR. During bisection, intervals
+* [left, right] are maintained by storing their mid-points and
+* semi-widths in the arrays W and WERR respectively.
+*
+* Arguments
+* =========
+*
+* N (input) INTEGER
+* The order of the matrix.
+*
+* D (input) DOUBLE PRECISION array, dimension (N)
+* The N diagonal elements of T.
+*
+* E2 (input) DOUBLE PRECISION array, dimension (N-1)
+* The Squares of the (N-1) subdiagonal elements of T.
+*
+* IFIRST (input) INTEGER
+* The index of the first eigenvalue to be computed.
+*
+* ILAST (input) INTEGER
+* The index of the last eigenvalue to be computed.
+*
+* RTOL (input) DOUBLE PRECISION
+* Tolerance for the convergence of the bisection intervals.
+* An interval [LEFT,RIGHT] has converged if
+* RIGHT-LEFT.LT.RTOL*MAX(|LEFT|,|RIGHT|).
+*
+* OFFSET (input) INTEGER
+* Offset for the arrays W and WERR, i.e., the IFIRST-OFFSET
+* through ILAST-OFFSET elements of these arrays are to be used.
+*
+* W (input/output) DOUBLE PRECISION array, dimension (N)
+* On input, W( IFIRST-OFFSET ) through W( ILAST-OFFSET ) are
+* estimates of the eigenvalues of L D L^T indexed IFIRST through
+* ILAST.
+* On output, these estimates are refined.
+*
+* WERR (input/output) DOUBLE PRECISION array, dimension (N)
+* On input, WERR( IFIRST-OFFSET ) through WERR( ILAST-OFFSET ) are
+* the errors in the estimates of the corresponding elements in W.
+* On output, these errors are refined.
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (2*N)
+* Workspace.
+*
+* IWORK (workspace) INTEGER array, dimension (2*N)
+* Workspace.
+*
+* PIVMIN (input) DOUBLE PRECISION
+* The minimum pivot in the Sturm sequence for T.
+*
+* SPDIAM (input) DOUBLE PRECISION
+* The spectral diameter of T.
+*
+* INFO (output) INTEGER
+* Error flag.
+*
+* Further Details
+* ===============
+*
+* Based on contributions by
+* Beresford Parlett, University of California, Berkeley, USA
+* Jim Demmel, University of California, Berkeley, USA
+* Inderjit Dhillon, University of Texas, Austin, USA
+* Osni Marques, LBNL/NERSC, USA
+* Christof Voemel, University of California, Berkeley, USA
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE, TWO, HALF
+ PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0,
+ $ HALF = 0.5D0 )
+ INTEGER MAXITR
+* ..
+* .. Local Scalars ..
+ INTEGER CNT, I, I1, I2, II, ITER, J, K, NEXT, NINT,
+ $ OLNINT, P, PREV, SAVI1
+ DOUBLE PRECISION DPLUS, FAC, LEFT, MID, RIGHT, S, TMP, WIDTH
+*
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX
+* ..
+* .. Executable Statements ..
+*
+ INFO = 0
+*
+ MAXITR = INT( ( LOG( SPDIAM+PIVMIN )-LOG( PIVMIN ) ) /
+ $ LOG( TWO ) ) + 2
+*
+* Initialize unconverged intervals in [ WORK(2*I-1), WORK(2*I) ].
+* The Sturm Count, Count( WORK(2*I-1) ) is arranged to be I-1, while
+* Count( WORK(2*I) ) is stored in IWORK( 2*I ). The integer IWORK( 2*I-1 )
+* for an unconverged interval is set to the index of the next unconverged
+* interval, and is -1 or 0 for a converged interval. Thus a linked
+* list of unconverged intervals is set up.
+*
+
+ I1 = IFIRST
+ I2 = ILAST
+* The number of unconverged intervals
+ NINT = 0
+* The last unconverged interval found
+ PREV = 0
+ DO 75 I = I1, I2
+ K = 2*I
+ II = I - OFFSET
+ LEFT = W( II ) - WERR( II )
+ MID = W(II)
+ RIGHT = W( II ) + WERR( II )
+ WIDTH = RIGHT - MID
+ TMP = MAX( ABS( LEFT ), ABS( RIGHT ) )
+
+* The following test prevents the test of converged intervals
+ IF( WIDTH.LT.RTOL*TMP ) THEN
+* This interval has already converged and does not need refinement.
+* (Note that the gaps might change through refining the
+* eigenvalues, however, they can only get bigger.)
+* Remove it from the list.
+ IWORK( K-1 ) = -1
+* Make sure that I1 always points to the first unconverged interval
+ IF((I.EQ.I1).AND.(I.LT.I2)) I1 = I + 1
+ IF((PREV.GE.I1).AND.(I.LE.I2)) IWORK( 2*PREV-1 ) = I + 1
+ ELSE
+* unconverged interval found
+ PREV = I
+* Make sure that [LEFT,RIGHT] contains the desired eigenvalue
+*
+* Do while( CNT(LEFT).GT.I-1 )
+*
+ FAC = ONE
+ 20 CONTINUE
+ CNT = 0
+ S = LEFT
+ DPLUS = D( 1 ) - S
+ IF( DPLUS.LT.ZERO ) CNT = CNT + 1
+ DO 30 J = 2, N
+ DPLUS = D( J ) - S - E2( J-1 )/DPLUS
+ IF( DPLUS.LT.ZERO ) CNT = CNT + 1
+ 30 CONTINUE
+ IF( CNT.GT.I-1 ) THEN
+ LEFT = LEFT - WERR( II )*FAC
+ FAC = TWO*FAC
+ GO TO 20
+ END IF
+*
+* Do while( CNT(RIGHT).LT.I )
+*
+ FAC = ONE
+ 50 CONTINUE
+ CNT = 0
+ S = RIGHT
+ DPLUS = D( 1 ) - S
+ IF( DPLUS.LT.ZERO ) CNT = CNT + 1
+ DO 60 J = 2, N
+ DPLUS = D( J ) - S - E2( J-1 )/DPLUS
+ IF( DPLUS.LT.ZERO ) CNT = CNT + 1
+ 60 CONTINUE
+ IF( CNT.LT.I ) THEN
+ RIGHT = RIGHT + WERR( II )*FAC
+ FAC = TWO*FAC
+ GO TO 50
+ END IF
+ NINT = NINT + 1
+ IWORK( K-1 ) = I + 1
+ IWORK( K ) = CNT
+ END IF
+ WORK( K-1 ) = LEFT
+ WORK( K ) = RIGHT
+ 75 CONTINUE
+
+
+ SAVI1 = I1
+*
+* Do while( NINT.GT.0 ), i.e. there are still unconverged intervals
+* and while (ITER.LT.MAXITR)
+*
+ ITER = 0
+ 80 CONTINUE
+ PREV = I1 - 1
+ I = I1
+ OLNINT = NINT
+
+ DO 100 P = 1, OLNINT
+ K = 2*I
+ II = I - OFFSET
+ NEXT = IWORK( K-1 )
+ LEFT = WORK( K-1 )
+ RIGHT = WORK( K )
+ MID = HALF*( LEFT + RIGHT )
+
+* semiwidth of interval
+ WIDTH = RIGHT - MID
+ TMP = MAX( ABS( LEFT ), ABS( RIGHT ) )
+
+ IF( ( WIDTH.LT.RTOL*TMP ) .OR.
+ $ (ITER.EQ.MAXITR) )THEN
+* reduce number of unconverged intervals
+ NINT = NINT - 1
+* Mark interval as converged.
+ IWORK( K-1 ) = 0
+ IF( I1.EQ.I ) THEN
+ I1 = NEXT
+ ELSE
+* Prev holds the last unconverged interval previously examined
+ IF(PREV.GE.I1) IWORK( 2*PREV-1 ) = NEXT
+ END IF
+ I = NEXT
+ GO TO 100
+ END IF
+ PREV = I
+*
+* Perform one bisection step
+*
+ CNT = 0
+ S = MID
+ DPLUS = D( 1 ) - S
+ IF( DPLUS.LT.ZERO ) CNT = CNT + 1
+ DO 90 J = 2, N
+ DPLUS = D( J ) - S - E2( J-1 )/DPLUS
+ IF( DPLUS.LT.ZERO ) CNT = CNT + 1
+ 90 CONTINUE
+ IF( CNT.LE.I-1 ) THEN
+ WORK( K-1 ) = MID
+ ELSE
+ WORK( K ) = MID
+ END IF
+ I = NEXT
+
+ 100 CONTINUE
+ ITER = ITER + 1
+* do another loop if there are still unconverged intervals
+* However, in the last iteration, all intervals are accepted
+* since this is the best we can do.
+ IF( ( NINT.GT.0 ).AND.(ITER.LE.MAXITR) ) GO TO 80
+*
+*
+* At this point, all the intervals have converged
+ DO 110 I = SAVI1, ILAST
+ K = 2*I
+ II = I - OFFSET
+* All intervals marked by '0' have been refined.
+ IF( IWORK( K-1 ).EQ.0 ) THEN
+ W( II ) = HALF*( WORK( K-1 )+WORK( K ) )
+ WERR( II ) = WORK( K ) - W( II )
+ END IF
+ 110 CONTINUE
+*
+
+ RETURN
+*
+* End of DLARRJ
+*
+ END
+ SUBROUTINE DLARRK( N, IW, GL, GU,
+ $ D, E2, PIVMIN, RELTOL, W, WERR, INFO)
+ IMPLICIT NONE
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, IW, N
+ DOUBLE PRECISION PIVMIN, RELTOL, GL, GU, W, WERR
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION D( * ), E2( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DLARRK computes one eigenvalue of a symmetric tridiagonal
+* matrix T to suitable accuracy. This is an auxiliary code to be
+* called from DSTEMR.
+*
+* To avoid overflow, the matrix must be scaled so that its
+* largest element is no greater than overflow**(1/2) *
+* underflow**(1/4) in absolute value, and for greatest
+* accuracy, it should not be much smaller than that.
+*
+* See W. Kahan "Accurate Eigenvalues of a Symmetric Tridiagonal
+* Matrix", Report CS41, Computer Science Dept., Stanford
+* University, July 21, 1966.
+*
+* Arguments
+* =========
+*
+* N (input) INTEGER
+* The order of the tridiagonal matrix T. N >= 0.
+*
+* IW (input) INTEGER
+* The index of the eigenvalues to be returned.
+*
+* GL (input) DOUBLE PRECISION
+* GU (input) DOUBLE PRECISION
+* An upper and a lower bound on the eigenvalue.
+*
+* D (input) DOUBLE PRECISION array, dimension (N)
+* The n diagonal elements of the tridiagonal matrix T.
+*
+* E2 (input) DOUBLE PRECISION array, dimension (N-1)
+* The (n-1) squared off-diagonal elements of the tridiagonal matrix T.
+*
+* PIVMIN (input) DOUBLE PRECISION
+* The minimum pivot allowed in the Sturm sequence for T.
+*
+* RELTOL (input) DOUBLE PRECISION
+* The minimum relative width of an interval. When an interval
+* is narrower than RELTOL times the larger (in
+* magnitude) endpoint, then it is considered to be
+* sufficiently small, i.e., converged. Note: this should
+* always be at least radix*machine epsilon.
+*
+* W (output) DOUBLE PRECISION
+*
+* WERR (output) DOUBLE PRECISION
+* The error bound on the corresponding eigenvalue approximation
+* in W.
+*
+* INFO (output) INTEGER
+* = 0: Eigenvalue converged
+* = -1: Eigenvalue did NOT converge
+*
+* Internal Parameters
+* ===================
+*
+* FUDGE DOUBLE PRECISION, default = 2
+* A "fudge factor" to widen the Gershgorin intervals.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION FUDGE, HALF, TWO, ZERO
+ PARAMETER ( HALF = 0.5D0, TWO = 2.0D0,
+ $ FUDGE = TWO, ZERO = 0.0D0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, IT, ITMAX, NEGCNT
+ DOUBLE PRECISION ATOLI, EPS, LEFT, MID, RIGHT, RTOLI, TMP1,
+ $ TMP2, TNORM
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DLAMCH
+ EXTERNAL DLAMCH
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, INT, LOG, MAX
+* ..
+* .. Executable Statements ..
+*
+* Get machine constants
+ EPS = DLAMCH( 'P' )
+
+ TNORM = MAX( ABS( GL ), ABS( GU ) )
+ RTOLI = RELTOL
+ ATOLI = FUDGE*TWO*PIVMIN
+
+ ITMAX = INT( ( LOG( TNORM+PIVMIN )-LOG( PIVMIN ) ) /
+ $ LOG( TWO ) ) + 2
+
+ INFO = -1
+
+ LEFT = GL - FUDGE*TNORM*EPS*N - FUDGE*TWO*PIVMIN
+ RIGHT = GU + FUDGE*TNORM*EPS*N + FUDGE*TWO*PIVMIN
+ IT = 0
+
+ 10 CONTINUE
+*
+* Check if interval converged or maximum number of iterations reached
+*
+ TMP1 = ABS( RIGHT - LEFT )
+ TMP2 = MAX( ABS(RIGHT), ABS(LEFT) )
+ IF( TMP1.LT.MAX( ATOLI, PIVMIN, RTOLI*TMP2 ) ) THEN
+ INFO = 0
+ GOTO 30
+ ENDIF
+ IF(IT.GT.ITMAX)
+ $ GOTO 30
+
+*
+* Count number of negative pivots for mid-point
+*
+ IT = IT + 1
+ MID = HALF * (LEFT + RIGHT)
+ NEGCNT = 0
+ TMP1 = D( 1 ) - MID
+ IF( ABS( TMP1 ).LT.PIVMIN )
+ $ TMP1 = -PIVMIN
+ IF( TMP1.LE.ZERO )
+ $ NEGCNT = NEGCNT + 1
+*
+ DO 20 I = 2, N
+ TMP1 = D( I ) - E2( I-1 ) / TMP1 - MID
+ IF( ABS( TMP1 ).LT.PIVMIN )
+ $ TMP1 = -PIVMIN
+ IF( TMP1.LE.ZERO )
+ $ NEGCNT = NEGCNT + 1
+ 20 CONTINUE
+
+ IF(NEGCNT.GE.IW) THEN
+ RIGHT = MID
+ ELSE
+ LEFT = MID
+ ENDIF
+ GOTO 10
+
+ 30 CONTINUE
+*
+* Converged or maximum number of iterations reached
+*
+ W = HALF * (LEFT + RIGHT)
+ WERR = HALF * ABS( RIGHT - LEFT )
+
+ RETURN
+*
+* End of DLARRK
+*
+ END
+ SUBROUTINE DLARRR( N, D, E, INFO )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER N, INFO
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION D( * ), E( * )
+* ..
+*
+*
+* Purpose
+* =======
+*
+* Perform tests to decide whether the symmetric tridiagonal matrix T
+* warrants expensive computations which guarantee high relative accuracy
+* in the eigenvalues.
+*
+* Arguments
+* =========
+*
+* N (input) INTEGER
+* The order of the matrix. N > 0.
+*
+* D (input) DOUBLE PRECISION array, dimension (N)
+* The N diagonal elements of the tridiagonal matrix T.
+*
+* E (input/output) DOUBLE PRECISION array, dimension (N)
+* On entry, the first (N-1) entries contain the subdiagonal
+* elements of the tridiagonal matrix T; E(N) is set to ZERO.
+*
+* INFO (output) INTEGER
+* INFO = 0(default) : the matrix warrants computations preserving
+* relative accuracy.
+* INFO = 1 : the matrix warrants computations guaranteeing
+* only absolute accuracy.
+*
+* Further Details
+* ===============
+*
+* Based on contributions by
+* Beresford Parlett, University of California, Berkeley, USA
+* Jim Demmel, University of California, Berkeley, USA
+* Inderjit Dhillon, University of Texas, Austin, USA
+* Osni Marques, LBNL/NERSC, USA
+* Christof Voemel, University of California, Berkeley, USA
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, RELCOND
+ PARAMETER ( ZERO = 0.0D0,
+ $ RELCOND = 0.999D0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I
+ LOGICAL YESREL
+ DOUBLE PRECISION EPS, SAFMIN, SMLNUM, RMIN, TMP, TMP2,
+ $ OFFDIG, OFFDIG2
+
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DLAMCH
+ EXTERNAL DLAMCH
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS
+* ..
+* .. Executable Statements ..
+*
+* As a default, do NOT go for relative-accuracy preserving computations.
+ INFO = 1
+
+ SAFMIN = DLAMCH( 'Safe minimum' )
+ EPS = DLAMCH( 'Precision' )
+ SMLNUM = SAFMIN / EPS
+ RMIN = SQRT( SMLNUM )
+
+* Tests for relative accuracy
+*
+* Test for scaled diagonal dominance
+* Scale the diagonal entries to one and check whether the sum of the
+* off-diagonals is less than one
+*
+* The sdd relative error bounds have a 1/(1- 2*x) factor in them,
+* x = max(OFFDIG + OFFDIG2), so when x is close to 1/2, no relative
+* accuracy is promised. In the notation of the code fragment below,
+* 1/(1 - (OFFDIG + OFFDIG2)) is the condition number.
+* We don't think it is worth going into "sdd mode" unless the relative
+* condition number is reasonable, not 1/macheps.
+* The threshold should be compatible with other thresholds used in the
+* code. We set OFFDIG + OFFDIG2 <= .999 =: RELCOND, it corresponds
+* to losing at most 3 decimal digits: 1 / (1 - (OFFDIG + OFFDIG2)) <= 1000
+* instead of the current OFFDIG + OFFDIG2 < 1
+*
+ YESREL = .TRUE.
+ OFFDIG = ZERO
+ TMP = SQRT(ABS(D(1)))
+ IF (TMP.LT.RMIN) YESREL = .FALSE.
+ IF(.NOT.YESREL) GOTO 11
+ DO 10 I = 2, N
+ TMP2 = SQRT(ABS(D(I)))
+ IF (TMP2.LT.RMIN) YESREL = .FALSE.
+ IF(.NOT.YESREL) GOTO 11
+ OFFDIG2 = ABS(E(I-1))/(TMP*TMP2)
+ IF(OFFDIG+OFFDIG2.GE.RELCOND) YESREL = .FALSE.
+ IF(.NOT.YESREL) GOTO 11
+ TMP = TMP2
+ OFFDIG = OFFDIG2
+ 10 CONTINUE
+ 11 CONTINUE
+
+ IF( YESREL ) THEN
+ INFO = 0
+ RETURN
+ ELSE
+ ENDIF
+*
+
+*
+* *** MORE TO BE IMPLEMENTED ***
+*
+
+*
+* Test if the lower bidiagonal matrix L from T = L D L^T
+* (zero shift facto) is well conditioned
+*
+
+*
+* Test if the upper bidiagonal matrix U from T = U D U^T
+* (zero shift facto) is well conditioned.
+* In this case, the matrix needs to be flipped and, at the end
+* of the eigenvector computation, the flip needs to be applied
+* to the computed eigenvectors (and the support)
+*
+
+*
+ RETURN
+*
+* END OF DLARRR
+*
+ END
+ 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 )
+*
+* -- LAPACK auxiliary routine (version 3.1.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER DOL, DOU, INFO, LDZ, M, N
+ DOUBLE PRECISION MINRGP, PIVMIN, RTOL1, RTOL2, VL, VU
+* ..
+* .. Array Arguments ..
+ INTEGER IBLOCK( * ), INDEXW( * ), ISPLIT( * ),
+ $ ISUPPZ( * ), IWORK( * )
+ DOUBLE PRECISION D( * ), GERS( * ), L( * ), W( * ), WERR( * ),
+ $ WGAP( * ), WORK( * )
+ DOUBLE PRECISION Z( LDZ, * )
+* ..
+*
+* Purpose
+* =======
+*
+* DLARRV computes the eigenvectors of the tridiagonal matrix
+* T = L D L^T given L, D and APPROXIMATIONS to the eigenvalues of L D L^T.
+* The input eigenvalues should have been computed by DLARRE.
+*
+* Arguments
+* =========
+*
+* N (input) INTEGER
+* The order of the matrix. N >= 0.
+*
+* VL (input) DOUBLE PRECISION
+* VU (input) DOUBLE PRECISION
+* Lower and upper bounds of the interval that contains the desired
+* eigenvalues. VL < VU. Needed to compute gaps on the left or right
+* end of the extremal eigenvalues in the desired RANGE.
+*
+* D (input/output) DOUBLE PRECISION array, dimension (N)
+* On entry, the N diagonal elements of the diagonal matrix D.
+* On exit, D may be overwritten.
+*
+* L (input/output) DOUBLE PRECISION array, dimension (N)
+* On entry, the (N-1) subdiagonal elements of the unit
+* bidiagonal matrix L are in elements 1 to N-1 of L
+* (if the matrix is not splitted.) At the end of each block
+* is stored the corresponding shift as given by DLARRE.
+* On exit, L is overwritten.
+*
+* PIVMIN (in) DOUBLE PRECISION
+* The minimum pivot allowed in the Sturm sequence.
+*
+* ISPLIT (input) INTEGER array, dimension (N)
+* The splitting points, at which T breaks up into blocks.
+* The first block consists of rows/columns 1 to
+* ISPLIT( 1 ), the second of rows/columns ISPLIT( 1 )+1
+* through ISPLIT( 2 ), etc.
+*
+* M (input) INTEGER
+* The total number of input eigenvalues. 0 <= M <= N.
+*
+* DOL (input) INTEGER
+* DOU (input) INTEGER
+* If the user wants to compute only selected eigenvectors from all
+* the eigenvalues supplied, he can specify an index range DOL:DOU.
+* Or else the setting DOL=1, DOU=M should be applied.
+* Note that DOL and DOU refer to the order in which the eigenvalues
+* are stored in W.
+* If the user wants to compute only selected eigenpairs, then
+* the columns DOL-1 to DOU+1 of the eigenvector space Z contain the
+* computed eigenvectors. All other columns of Z are set to zero.
+*
+* MINRGP (input) DOUBLE PRECISION
+*
+* RTOL1 (input) DOUBLE PRECISION
+* RTOL2 (input) DOUBLE PRECISION
+* Parameters for bisection.
+* An interval [LEFT,RIGHT] has converged if
+* RIGHT-LEFT.LT.MAX( RTOL1*GAP, RTOL2*MAX(|LEFT|,|RIGHT|) )
+*
+* W (input/output) DOUBLE PRECISION array, dimension (N)
+* The first M elements of W contain the APPROXIMATE eigenvalues for
+* which eigenvectors are to be computed. The eigenvalues
+* should be grouped by split-off block and ordered from
+* smallest to largest within the block ( The output array
+* W from DLARRE is expected here ). Furthermore, they are with
+* respect to the shift of the corresponding root representation
+* for their block. On exit, W holds the eigenvalues of the
+* UNshifted matrix.
+*
+* WERR (input/output) DOUBLE PRECISION array, dimension (N)
+* The first M elements contain the semiwidth of the uncertainty
+* interval of the corresponding eigenvalue in W
+*
+* WGAP (input/output) DOUBLE PRECISION array, dimension (N)
+* The separation from the right neighbor eigenvalue in W.
+*
+* IBLOCK (input) INTEGER array, dimension (N)
+* The indices of the blocks (submatrices) associated with the
+* corresponding eigenvalues in W; IBLOCK(i)=1 if eigenvalue
+* W(i) belongs to the first block from the top, =2 if W(i)
+* belongs to the second block, etc.
+*
+* INDEXW (input) INTEGER array, dimension (N)
+* The indices of the eigenvalues within each block (submatrix);
+* for example, INDEXW(i)= 10 and IBLOCK(i)=2 imply that the
+* i-th eigenvalue W(i) is the 10-th eigenvalue in the second block.
+*
+* GERS (input) DOUBLE PRECISION array, dimension (2*N)
+* The N Gerschgorin intervals (the i-th Gerschgorin interval
+* is (GERS(2*i-1), GERS(2*i)). The Gerschgorin intervals should
+* be computed from the original UNshifted matrix.
+*
+* Z (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M) )
+* If INFO = 0, the first M columns of Z contain the
+* orthonormal eigenvectors of the matrix T
+* corresponding to the input eigenvalues, with the i-th
+* column of Z holding the eigenvector associated with W(i).
+* Note: the user must ensure that at least max(1,M) columns are
+* supplied in the array Z.
+*
+* LDZ (input) INTEGER
+* The leading dimension of the array Z. LDZ >= 1, and if
+* JOBZ = 'V', LDZ >= max(1,N).
+*
+* ISUPPZ (output) INTEGER array, dimension ( 2*max(1,M) )
+* The support of the eigenvectors in Z, i.e., the indices
+* indicating the nonzero elements in Z. The I-th eigenvector
+* is nonzero only in elements ISUPPZ( 2*I-1 ) through
+* ISUPPZ( 2*I ).
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (12*N)
+*
+* IWORK (workspace) INTEGER array, dimension (7*N)
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+*
+* > 0: A problem occured in DLARRV.
+* < 0: One of the called subroutines signaled an internal problem.
+* Needs inspection of the corresponding parameter IINFO
+* for further information.
+*
+* =-1: Problem in DLARRB when refining a child's eigenvalues.
+* =-2: Problem in DLARRF when computing the RRR of a child.
+* When a child is inside a tight cluster, it can be difficult
+* to find an RRR. A partial remedy from the user's point of
+* view is to make the parameter MINRGP smaller and recompile.
+* However, as the orthogonality of the computed vectors is
+* proportional to 1/MINRGP, the user should be aware that
+* he might be trading in precision when he decreases MINRGP.
+* =-3: Problem in DLARRB when refining a single eigenvalue
+* after the Rayleigh correction was rejected.
+* = 5: The Rayleigh Quotient Iteration failed to converge to
+* full accuracy in MAXITR steps.
+*
+* Further Details
+* ===============
+*
+* Based on contributions by
+* Beresford Parlett, University of California, Berkeley, USA
+* Jim Demmel, University of California, Berkeley, USA
+* Inderjit Dhillon, University of Texas, Austin, USA
+* Osni Marques, LBNL/NERSC, USA
+* Christof Voemel, University of California, Berkeley, USA
+*
+* =====================================================================
+*
+* .. Parameters ..
+ INTEGER MAXITR
+ PARAMETER ( MAXITR = 10 )
+ DOUBLE PRECISION ZERO, ONE, TWO, THREE, FOUR, HALF
+ PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0,
+ $ TWO = 2.0D0, THREE = 3.0D0,
+ $ FOUR = 4.0D0, HALF = 0.5D0)
+* ..
+* .. Local Scalars ..
+ LOGICAL ESKIP, NEEDBS, STP2II, TRYRQC, USEDBS, USEDRQ
+ INTEGER DONE, I, IBEGIN, IDONE, IEND, II, IINDC1,
+ $ IINDC2, IINDR, IINDWK, IINFO, IM, IN, INDEIG,
+ $ INDLD, INDLLD, INDWRK, ISUPMN, ISUPMX, ITER,
+ $ ITMP1, J, JBLK, K, MINIWSIZE, MINWSIZE, NCLUS,
+ $ NDEPTH, NEGCNT, NEWCLS, NEWFST, NEWFTT, NEWLST,
+ $ NEWSIZ, OFFSET, OLDCLS, OLDFST, OLDIEN, OLDLST,
+ $ OLDNCL, P, PARITY, Q, WBEGIN, WEND, WINDEX,
+ $ WINDMN, WINDPL, ZFROM, ZTO, ZUSEDL, ZUSEDU,
+ $ ZUSEDW
+ DOUBLE PRECISION BSTRES, BSTW, EPS, FUDGE, GAP, GAPTOL, GL, GU,
+ $ LAMBDA, LEFT, LGAP, MINGMA, NRMINV, RESID,
+ $ RGAP, RIGHT, RQCORR, RQTOL, SAVGAP, SGNDEF,
+ $ SIGMA, SPDIAM, SSIGMA, TAU, TMP, TOL, ZTZ
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DLAMCH
+ EXTERNAL DLAMCH
+* ..
+* .. External Subroutines ..
+ EXTERNAL DCOPY, DLAR1V, DLARRB, DLARRF, DLASET,
+ $ DSCAL
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, DBLE, MAX, MIN
+* ..
+* .. Executable Statements ..
+* ..
+
+* The first N entries of WORK are reserved for the eigenvalues
+ INDLD = N+1
+ INDLLD= 2*N+1
+ INDWRK= 3*N+1
+ MINWSIZE = 12 * N
+
+ DO 5 I= 1,MINWSIZE
+ WORK( I ) = ZERO
+ 5 CONTINUE
+
+* IWORK(IINDR+1:IINDR+N) hold the twist indices R for the
+* factorization used to compute the FP vector
+ IINDR = 0
+* IWORK(IINDC1+1:IINC2+N) are used to store the clusters of the current
+* layer and the one above.
+ IINDC1 = N
+ IINDC2 = 2*N
+ IINDWK = 3*N + 1
+
+ MINIWSIZE = 7 * N
+ DO 10 I= 1,MINIWSIZE
+ IWORK( I ) = 0
+ 10 CONTINUE
+
+ ZUSEDL = 1
+ IF(DOL.GT.1) THEN
+* Set lower bound for use of Z
+ ZUSEDL = DOL-1
+ ENDIF
+ ZUSEDU = M
+ IF(DOU.LT.M) THEN
+* Set lower bound for use of Z
+ ZUSEDU = DOU+1
+ ENDIF
+* The width of the part of Z that is used
+ ZUSEDW = ZUSEDU - ZUSEDL + 1
+
+
+ CALL DLASET( 'Full', N, ZUSEDW, ZERO, ZERO,
+ $ Z(1,ZUSEDL), LDZ )
+
+ EPS = DLAMCH( 'Precision' )
+ RQTOL = TWO * EPS
+*
+* Set expert flags for standard code.
+ TRYRQC = .TRUE.
+
+ IF((DOL.EQ.1).AND.(DOU.EQ.M)) THEN
+ ELSE
+* Only selected eigenpairs are computed. Since the other evalues
+* are not refined by RQ iteration, bisection has to compute to full
+* accuracy.
+ RTOL1 = FOUR * EPS
+ RTOL2 = FOUR * EPS
+ ENDIF
+
+* The entries WBEGIN:WEND in W, WERR, WGAP correspond to the
+* desired eigenvalues. The support of the nonzero eigenvector
+* entries is contained in the interval IBEGIN:IEND.
+* Remark that if k eigenpairs are desired, then the eigenvectors
+* are stored in k contiguous columns of Z.
+
+* DONE is the number of eigenvectors already computed
+ DONE = 0
+ IBEGIN = 1
+ WBEGIN = 1
+ DO 170 JBLK = 1, IBLOCK( M )
+ IEND = ISPLIT( JBLK )
+ SIGMA = L( IEND )
+* Find the eigenvectors of the submatrix indexed IBEGIN
+* through IEND.
+ WEND = WBEGIN - 1
+ 15 CONTINUE
+ IF( WEND.LT.M ) THEN
+ IF( IBLOCK( WEND+1 ).EQ.JBLK ) THEN
+ WEND = WEND + 1
+ GO TO 15
+ END IF
+ END IF
+ IF( WEND.LT.WBEGIN ) THEN
+ IBEGIN = IEND + 1
+ GO TO 170
+ ELSEIF( (WEND.LT.DOL).OR.(WBEGIN.GT.DOU) ) THEN
+ IBEGIN = IEND + 1
+ WBEGIN = WEND + 1
+ GO TO 170
+ END IF
+
+* Find local spectral diameter of the block
+ GL = GERS( 2*IBEGIN-1 )
+ GU = GERS( 2*IBEGIN )
+ DO 20 I = IBEGIN+1 , IEND
+ GL = MIN( GERS( 2*I-1 ), GL )
+ GU = MAX( GERS( 2*I ), GU )
+ 20 CONTINUE
+ SPDIAM = GU - GL
+
+* OLDIEN is the last index of the previous block
+ OLDIEN = IBEGIN - 1
+* Calculate the size of the current block
+ IN = IEND - IBEGIN + 1
+* The number of eigenvalues in the current block
+ IM = WEND - WBEGIN + 1
+
+* This is for a 1x1 block
+ IF( IBEGIN.EQ.IEND ) THEN
+ DONE = DONE+1
+ Z( IBEGIN, WBEGIN ) = ONE
+ ISUPPZ( 2*WBEGIN-1 ) = IBEGIN
+ ISUPPZ( 2*WBEGIN ) = IBEGIN
+ W( WBEGIN ) = W( WBEGIN ) + SIGMA
+ WORK( WBEGIN ) = W( WBEGIN )
+ IBEGIN = IEND + 1
+ WBEGIN = WBEGIN + 1
+ GO TO 170
+ END IF
+
+* The desired (shifted) eigenvalues are stored in W(WBEGIN:WEND)
+* Note that these can be approximations, in this case, the corresp.
+* entries of WERR give the size of the uncertainty interval.
+* The eigenvalue approximations will be refined when necessary as
+* high relative accuracy is required for the computation of the
+* corresponding eigenvectors.
+ CALL DCOPY( IM, W( WBEGIN ), 1,
+ & WORK( WBEGIN ), 1 )
+
+* We store in W the eigenvalue approximations w.r.t. the original
+* matrix T.
+ DO 30 I=1,IM
+ W(WBEGIN+I-1) = W(WBEGIN+I-1)+SIGMA
+ 30 CONTINUE
+
+
+* NDEPTH is the current depth of the representation tree
+ NDEPTH = 0
+* PARITY is either 1 or 0
+ PARITY = 1
+* NCLUS is the number of clusters for the next level of the
+* representation tree, we start with NCLUS = 1 for the root
+ NCLUS = 1
+ IWORK( IINDC1+1 ) = 1
+ IWORK( IINDC1+2 ) = IM
+
+* IDONE is the number of eigenvectors already computed in the current
+* block
+ IDONE = 0
+* loop while( IDONE.LT.IM )
+* generate the representation tree for the current block and
+* compute the eigenvectors
+ 40 CONTINUE
+ IF( IDONE.LT.IM ) THEN
+* This is a crude protection against infinitely deep trees
+ IF( NDEPTH.GT.M ) THEN
+ INFO = -2
+ RETURN
+ ENDIF
+* breadth first processing of the current level of the representation
+* tree: OLDNCL = number of clusters on current level
+ OLDNCL = NCLUS
+* reset NCLUS to count the number of child clusters
+ NCLUS = 0
+*
+ PARITY = 1 - PARITY
+ IF( PARITY.EQ.0 ) THEN
+ OLDCLS = IINDC1
+ NEWCLS = IINDC2
+ ELSE
+ OLDCLS = IINDC2
+ NEWCLS = IINDC1
+ END IF
+* Process the clusters on the current level
+ DO 150 I = 1, OLDNCL
+ J = OLDCLS + 2*I
+* OLDFST, OLDLST = first, last index of current cluster.
+* cluster indices start with 1 and are relative
+* to WBEGIN when accessing W, WGAP, WERR, Z
+ OLDFST = IWORK( J-1 )
+ OLDLST = IWORK( J )
+ IF( NDEPTH.GT.0 ) THEN
+* Retrieve relatively robust representation (RRR) of cluster
+* that has been computed at the previous level
+* The RRR is stored in Z and overwritten once the eigenvectors
+* have been computed or when the cluster is refined
+
+ IF((DOL.EQ.1).AND.(DOU.EQ.M)) THEN
+* Get representation from location of the leftmost evalue
+* of the cluster
+ J = WBEGIN + OLDFST - 1
+ ELSE
+ IF(WBEGIN+OLDFST-1.LT.DOL) THEN
+* Get representation from the left end of Z array
+ J = DOL - 1
+ ELSEIF(WBEGIN+OLDFST-1.GT.DOU) THEN
+* Get representation from the right end of Z array
+ J = DOU
+ ELSE
+ J = WBEGIN + OLDFST - 1
+ ENDIF
+ ENDIF
+ CALL DCOPY( IN, Z( IBEGIN, J ), 1, D( IBEGIN ), 1 )
+ CALL DCOPY( IN-1, Z( IBEGIN, J+1 ), 1, L( IBEGIN ),
+ $ 1 )
+ SIGMA = Z( IEND, J+1 )
+
+* Set the corresponding entries in Z to zero
+ CALL DLASET( 'Full', IN, 2, ZERO, ZERO,
+ $ Z( IBEGIN, J), LDZ )
+ END IF
+
+* Compute DL and DLL of current RRR
+ DO 50 J = IBEGIN, IEND-1
+ TMP = D( J )*L( J )
+ WORK( INDLD-1+J ) = TMP
+ WORK( INDLLD-1+J ) = TMP*L( J )
+ 50 CONTINUE
+
+ IF( NDEPTH.GT.0 ) THEN
+* P and Q are index of the first and last eigenvalue to compute
+* within the current block
+ P = INDEXW( WBEGIN-1+OLDFST )
+ Q = INDEXW( WBEGIN-1+OLDLST )
+* Offset for the arrays WORK, WGAP and WERR, i.e., th P-OFFSET
+* thru' Q-OFFSET elements of these arrays are to be used.
+C OFFSET = P-OLDFST
+ OFFSET = INDEXW( WBEGIN ) - 1
+* perform limited bisection (if necessary) to get approximate
+* eigenvalues to the precision needed.
+ CALL DLARRB( IN, D( IBEGIN ),
+ $ WORK(INDLLD+IBEGIN-1),
+ $ P, Q, RTOL1, RTOL2, OFFSET,
+ $ WORK(WBEGIN),WGAP(WBEGIN),WERR(WBEGIN),
+ $ WORK( INDWRK ), IWORK( IINDWK ),
+ $ PIVMIN, SPDIAM, IN, IINFO )
+ IF( IINFO.NE.0 ) THEN
+ INFO = -1
+ RETURN
+ ENDIF
+* We also recompute the extremal gaps. W holds all eigenvalues
+* of the unshifted matrix and must be used for computation
+* of WGAP, the entries of WORK might stem from RRRs with
+* different shifts. The gaps from WBEGIN-1+OLDFST to
+* WBEGIN-1+OLDLST are correctly computed in DLARRB.
+* However, we only allow the gaps to become greater since
+* this is what should happen when we decrease WERR
+ IF( OLDFST.GT.1) THEN
+ WGAP( WBEGIN+OLDFST-2 ) =
+ $ MAX(WGAP(WBEGIN+OLDFST-2),
+ $ W(WBEGIN+OLDFST-1)-WERR(WBEGIN+OLDFST-1)
+ $ - W(WBEGIN+OLDFST-2)-WERR(WBEGIN+OLDFST-2) )
+ ENDIF
+ IF( WBEGIN + OLDLST -1 .LT. WEND ) THEN
+ WGAP( WBEGIN+OLDLST-1 ) =
+ $ MAX(WGAP(WBEGIN+OLDLST-1),
+ $ W(WBEGIN+OLDLST)-WERR(WBEGIN+OLDLST)
+ $ - W(WBEGIN+OLDLST-1)-WERR(WBEGIN+OLDLST-1) )
+ ENDIF
+* Each time the eigenvalues in WORK get refined, we store
+* the newly found approximation with all shifts applied in W
+ DO 53 J=OLDFST,OLDLST
+ W(WBEGIN+J-1) = WORK(WBEGIN+J-1)+SIGMA
+ 53 CONTINUE
+ END IF
+
+* Process the current node.
+ NEWFST = OLDFST
+ DO 140 J = OLDFST, OLDLST
+ IF( J.EQ.OLDLST ) THEN
+* we are at the right end of the cluster, this is also the
+* boundary of the child cluster
+ NEWLST = J
+ ELSE IF ( WGAP( WBEGIN + J -1).GE.
+ $ MINRGP* ABS( WORK(WBEGIN + J -1) ) ) THEN
+* the right relative gap is big enough, the child cluster
+* (NEWFST,..,NEWLST) is well separated from the following
+ NEWLST = J
+ ELSE
+* inside a child cluster, the relative gap is not
+* big enough.
+ GOTO 140
+ END IF
+
+* Compute size of child cluster found
+ NEWSIZ = NEWLST - NEWFST + 1
+
+* NEWFTT is the place in Z where the new RRR or the computed
+* eigenvector is to be stored
+ IF((DOL.EQ.1).AND.(DOU.EQ.M)) THEN
+* Store representation at location of the leftmost evalue
+* of the cluster
+ NEWFTT = WBEGIN + NEWFST - 1
+ ELSE
+ IF(WBEGIN+NEWFST-1.LT.DOL) THEN
+* Store representation at the left end of Z array
+ NEWFTT = DOL - 1
+ ELSEIF(WBEGIN+NEWFST-1.GT.DOU) THEN
+* Store representation at the right end of Z array
+ NEWFTT = DOU
+ ELSE
+ NEWFTT = WBEGIN + NEWFST - 1
+ ENDIF
+ ENDIF
+
+ IF( NEWSIZ.GT.1) THEN
+*
+* Current child is not a singleton but a cluster.
+* Compute and store new representation of child.
+*
+*
+* Compute left and right cluster gap.
+*
+* LGAP and RGAP are not computed from WORK because
+* the eigenvalue approximations may stem from RRRs
+* different shifts. However, W hold all eigenvalues
+* of the unshifted matrix. Still, the entries in WGAP
+* have to be computed from WORK since the entries
+* in W might be of the same order so that gaps are not
+* exhibited correctly for very close eigenvalues.
+ IF( NEWFST.EQ.1 ) THEN
+ LGAP = MAX( ZERO,
+ $ W(WBEGIN)-WERR(WBEGIN) - VL )
+ ELSE
+ LGAP = WGAP( WBEGIN+NEWFST-2 )
+ ENDIF
+ RGAP = WGAP( WBEGIN+NEWLST-1 )
+*
+* Compute left- and rightmost eigenvalue of child
+* to high precision in order to shift as close
+* as possible and obtain as large relative gaps
+* as possible
+*
+ DO 55 K =1,2
+ IF(K.EQ.1) THEN
+ P = INDEXW( WBEGIN-1+NEWFST )
+ ELSE
+ P = INDEXW( WBEGIN-1+NEWLST )
+ ENDIF
+ OFFSET = INDEXW( WBEGIN ) - 1
+ CALL DLARRB( IN, D(IBEGIN),
+ $ WORK( INDLLD+IBEGIN-1 ),P,P,
+ $ RQTOL, RQTOL, OFFSET,
+ $ WORK(WBEGIN),WGAP(WBEGIN),
+ $ WERR(WBEGIN),WORK( INDWRK ),
+ $ IWORK( IINDWK ), PIVMIN, SPDIAM,
+ $ IN, IINFO )
+ 55 CONTINUE
+*
+ IF((WBEGIN+NEWLST-1.LT.DOL).OR.
+ $ (WBEGIN+NEWFST-1.GT.DOU)) THEN
+* if the cluster contains no desired eigenvalues
+* skip the computation of that branch of the rep. tree
+*
+* We could skip before the refinement of the extremal
+* eigenvalues of the child, but then the representation
+* tree could be different from the one when nothing is
+* skipped. For this reason we skip at this place.
+ IDONE = IDONE + NEWLST - NEWFST + 1
+ GOTO 139
+ ENDIF
+*
+* Compute RRR of child cluster.
+* Note that the new RRR is stored in Z
+*
+C DLARRF needs LWORK = 2*N
+ CALL DLARRF( IN, D( IBEGIN ), L( IBEGIN ),
+ $ WORK(INDLD+IBEGIN-1),
+ $ NEWFST, NEWLST, WORK(WBEGIN),
+ $ WGAP(WBEGIN), WERR(WBEGIN),
+ $ SPDIAM, LGAP, RGAP, PIVMIN, TAU,
+ $ Z(IBEGIN, NEWFTT),Z(IBEGIN, NEWFTT+1),
+ $ WORK( INDWRK ), IINFO )
+ IF( IINFO.EQ.0 ) THEN
+* a new RRR for the cluster was found by DLARRF
+* update shift and store it
+ SSIGMA = SIGMA + TAU
+ Z( IEND, NEWFTT+1 ) = SSIGMA
+* WORK() are the midpoints and WERR() the semi-width
+* Note that the entries in W are unchanged.
+ DO 116 K = NEWFST, NEWLST
+ FUDGE =
+ $ THREE*EPS*ABS(WORK(WBEGIN+K-1))
+ WORK( WBEGIN + K - 1 ) =
+ $ WORK( WBEGIN + K - 1) - TAU
+ FUDGE = FUDGE +
+ $ FOUR*EPS*ABS(WORK(WBEGIN+K-1))
+* Fudge errors
+ WERR( WBEGIN + K - 1 ) =
+ $ WERR( WBEGIN + K - 1 ) + FUDGE
+* Gaps are not fudged. Provided that WERR is small
+* when eigenvalues are close, a zero gap indicates
+* that a new representation is needed for resolving
+* the cluster. A fudge could lead to a wrong decision
+* of judging eigenvalues 'separated' which in
+* reality are not. This could have a negative impact
+* on the orthogonality of the computed eigenvectors.
+ 116 CONTINUE
+
+ NCLUS = NCLUS + 1
+ K = NEWCLS + 2*NCLUS
+ IWORK( K-1 ) = NEWFST
+ IWORK( K ) = NEWLST
+ ELSE
+ INFO = -2
+ RETURN
+ ENDIF
+ ELSE
+*
+* Compute eigenvector of singleton
+*
+ ITER = 0
+*
+ TOL = FOUR * LOG(DBLE(IN)) * EPS
+*
+ K = NEWFST
+ WINDEX = WBEGIN + K - 1
+ WINDMN = MAX(WINDEX - 1,1)
+ WINDPL = MIN(WINDEX + 1,M)
+ LAMBDA = WORK( WINDEX )
+ DONE = DONE + 1
+* Check if eigenvector computation is to be skipped
+ IF((WINDEX.LT.DOL).OR.
+ $ (WINDEX.GT.DOU)) THEN
+ ESKIP = .TRUE.
+ GOTO 125
+ ELSE
+ ESKIP = .FALSE.
+ ENDIF
+ LEFT = WORK( WINDEX ) - WERR( WINDEX )
+ RIGHT = WORK( WINDEX ) + WERR( WINDEX )
+ INDEIG = INDEXW( WINDEX )
+* Note that since we compute the eigenpairs for a child,
+* all eigenvalue approximations are w.r.t the same shift.
+* In this case, the entries in WORK should be used for
+* computing the gaps since they exhibit even very small
+* differences in the eigenvalues, as opposed to the
+* entries in W which might "look" the same.
+
+ IF( K .EQ. 1) THEN
+* In the case RANGE='I' and with not much initial
+* accuracy in LAMBDA and VL, the formula
+* LGAP = MAX( ZERO, (SIGMA - VL) + LAMBDA )
+* can lead to an overestimation of the left gap and
+* thus to inadequately early RQI 'convergence'.
+* Prevent this by forcing a small left gap.
+ LGAP = EPS*MAX(ABS(LEFT),ABS(RIGHT))
+ ELSE
+ LGAP = WGAP(WINDMN)
+ ENDIF
+ IF( K .EQ. IM) THEN
+* In the case RANGE='I' and with not much initial
+* accuracy in LAMBDA and VU, the formula
+* can lead to an overestimation of the right gap and
+* thus to inadequately early RQI 'convergence'.
+* Prevent this by forcing a small right gap.
+ RGAP = EPS*MAX(ABS(LEFT),ABS(RIGHT))
+ ELSE
+ RGAP = WGAP(WINDEX)
+ ENDIF
+ GAP = MIN( LGAP, RGAP )
+ IF(( K .EQ. 1).OR.(K .EQ. IM)) THEN
+* The eigenvector support can become wrong
+* because significant entries could be cut off due to a
+* large GAPTOL parameter in LAR1V. Prevent this.
+ GAPTOL = ZERO
+ ELSE
+ GAPTOL = GAP * EPS
+ ENDIF
+ ISUPMN = IN
+ ISUPMX = 1
+* Update WGAP so that it holds the minimum gap
+* to the left or the right. This is crucial in the
+* case where bisection is used to ensure that the
+* eigenvalue is refined up to the required precision.
+* The correct value is restored afterwards.
+ SAVGAP = WGAP(WINDEX)
+ WGAP(WINDEX) = GAP
+* We want to use the Rayleigh Quotient Correction
+* as often as possible since it converges quadratically
+* when we are close enough to the desired eigenvalue.
+* However, the Rayleigh Quotient can have the wrong sign
+* and lead us away from the desired eigenvalue. In this
+* case, the best we can do is to use bisection.
+ USEDBS = .FALSE.
+ USEDRQ = .FALSE.
+* Bisection is initially turned off unless it is forced
+ NEEDBS = .NOT.TRYRQC
+ 120 CONTINUE
+* Check if bisection should be used to refine eigenvalue
+ IF(NEEDBS) THEN
+* Take the bisection as new iterate
+ USEDBS = .TRUE.
+ ITMP1 = IWORK( IINDR+WINDEX )
+ OFFSET = INDEXW( WBEGIN ) - 1
+ CALL DLARRB( IN, D(IBEGIN),
+ $ WORK(INDLLD+IBEGIN-1),INDEIG,INDEIG,
+ $ ZERO, TWO*EPS, OFFSET,
+ $ WORK(WBEGIN),WGAP(WBEGIN),
+ $ WERR(WBEGIN),WORK( INDWRK ),
+ $ IWORK( IINDWK ), PIVMIN, SPDIAM,
+ $ ITMP1, IINFO )
+ IF( IINFO.NE.0 ) THEN
+ INFO = -3
+ RETURN
+ ENDIF
+ LAMBDA = WORK( WINDEX )
+* Reset twist index from inaccurate LAMBDA to
+* force computation of true MINGMA
+ IWORK( IINDR+WINDEX ) = 0
+ ENDIF
+* Given LAMBDA, compute the eigenvector.
+ CALL DLAR1V( IN, 1, IN, LAMBDA, D( IBEGIN ),
+ $ L( IBEGIN ), WORK(INDLD+IBEGIN-1),
+ $ WORK(INDLLD+IBEGIN-1),
+ $ PIVMIN, GAPTOL, Z( IBEGIN, WINDEX ),
+ $ .NOT.USEDBS, NEGCNT, ZTZ, MINGMA,
+ $ IWORK( IINDR+WINDEX ), ISUPPZ( 2*WINDEX-1 ),
+ $ NRMINV, RESID, RQCORR, WORK( INDWRK ) )
+ IF(ITER .EQ. 0) THEN
+ BSTRES = RESID
+ BSTW = LAMBDA
+ ELSEIF(RESID.LT.BSTRES) THEN
+ BSTRES = RESID
+ BSTW = LAMBDA
+ ENDIF
+ ISUPMN = MIN(ISUPMN,ISUPPZ( 2*WINDEX-1 ))
+ ISUPMX = MAX(ISUPMX,ISUPPZ( 2*WINDEX ))
+ ITER = ITER + 1
+
+* sin alpha <= |resid|/gap
+* Note that both the residual and the gap are
+* proportional to the matrix, so ||T|| doesn't play
+* a role in the quotient
+
+*
+* Convergence test for Rayleigh-Quotient iteration
+* (omitted when Bisection has been used)
+*
+ IF( RESID.GT.TOL*GAP .AND. ABS( RQCORR ).GT.
+ $ RQTOL*ABS( LAMBDA ) .AND. .NOT. USEDBS)
+ $ THEN
+* We need to check that the RQCORR update doesn't
+* move the eigenvalue away from the desired one and
+* towards a neighbor. -> protection with bisection
+ IF(INDEIG.LE.NEGCNT) THEN
+* The wanted eigenvalue lies to the left
+ SGNDEF = -ONE
+ ELSE
+* The wanted eigenvalue lies to the right
+ SGNDEF = ONE
+ ENDIF
+* We only use the RQCORR if it improves the
+* the iterate reasonably.
+ IF( ( RQCORR*SGNDEF.GE.ZERO )
+ $ .AND.( LAMBDA + RQCORR.LE. RIGHT)
+ $ .AND.( LAMBDA + RQCORR.GE. LEFT)
+ $ ) THEN
+ USEDRQ = .TRUE.
+* Store new midpoint of bisection interval in WORK
+ IF(SGNDEF.EQ.ONE) THEN
+* The current LAMBDA is on the left of the true
+* eigenvalue
+ LEFT = LAMBDA
+* We prefer to assume that the error estimate
+* is correct. We could make the interval not
+* as a bracket but to be modified if the RQCORR
+* chooses to. In this case, the RIGHT side should
+* be modified as follows:
+* RIGHT = MAX(RIGHT, LAMBDA + RQCORR)
+ ELSE
+* The current LAMBDA is on the right of the true
+* eigenvalue
+ RIGHT = LAMBDA
+* See comment about assuming the error estimate is
+* correct above.
+* LEFT = MIN(LEFT, LAMBDA + RQCORR)
+ ENDIF
+ WORK( WINDEX ) =
+ $ HALF * (RIGHT + LEFT)
+* Take RQCORR since it has the correct sign and
+* improves the iterate reasonably
+ LAMBDA = LAMBDA + RQCORR
+* Update width of error interval
+ WERR( WINDEX ) =
+ $ HALF * (RIGHT-LEFT)
+ ELSE
+ NEEDBS = .TRUE.
+ ENDIF
+ IF(RIGHT-LEFT.LT.RQTOL*ABS(LAMBDA)) THEN
+* The eigenvalue is computed to bisection accuracy
+* compute eigenvector and stop
+ USEDBS = .TRUE.
+ GOTO 120
+ ELSEIF( ITER.LT.MAXITR ) THEN
+ GOTO 120
+ ELSEIF( ITER.EQ.MAXITR ) THEN
+ NEEDBS = .TRUE.
+ GOTO 120
+ ELSE
+ INFO = 5
+ RETURN
+ END IF
+ ELSE
+ STP2II = .FALSE.
+ IF(USEDRQ .AND. USEDBS .AND.
+ $ BSTRES.LE.RESID) THEN
+ LAMBDA = BSTW
+ STP2II = .TRUE.
+ ENDIF
+ IF (STP2II) THEN
+* improve error angle by second step
+ CALL DLAR1V( IN, 1, IN, LAMBDA,
+ $ D( IBEGIN ), L( IBEGIN ),
+ $ WORK(INDLD+IBEGIN-1),
+ $ WORK(INDLLD+IBEGIN-1),
+ $ PIVMIN, GAPTOL, Z( IBEGIN, WINDEX ),
+ $ .NOT.USEDBS, NEGCNT, ZTZ, MINGMA,
+ $ IWORK( IINDR+WINDEX ),
+ $ ISUPPZ( 2*WINDEX-1 ),
+ $ NRMINV, RESID, RQCORR, WORK( INDWRK ) )
+ ENDIF
+ WORK( WINDEX ) = LAMBDA
+ END IF
+*
+* Compute FP-vector support w.r.t. whole matrix
+*
+ ISUPPZ( 2*WINDEX-1 ) = ISUPPZ( 2*WINDEX-1 )+OLDIEN
+ ISUPPZ( 2*WINDEX ) = ISUPPZ( 2*WINDEX )+OLDIEN
+ ZFROM = ISUPPZ( 2*WINDEX-1 )
+ ZTO = ISUPPZ( 2*WINDEX )
+ ISUPMN = ISUPMN + OLDIEN
+ ISUPMX = ISUPMX + OLDIEN
+* Ensure vector is ok if support in the RQI has changed
+ IF(ISUPMN.LT.ZFROM) THEN
+ DO 122 II = ISUPMN,ZFROM-1
+ Z( II, WINDEX ) = ZERO
+ 122 CONTINUE
+ ENDIF
+ IF(ISUPMX.GT.ZTO) THEN
+ DO 123 II = ZTO+1,ISUPMX
+ Z( II, WINDEX ) = ZERO
+ 123 CONTINUE
+ ENDIF
+ CALL DSCAL( ZTO-ZFROM+1, NRMINV,
+ $ Z( ZFROM, WINDEX ), 1 )
+ 125 CONTINUE
+* Update W
+ W( WINDEX ) = LAMBDA+SIGMA
+* Recompute the gaps on the left and right
+* But only allow them to become larger and not
+* smaller (which can only happen through "bad"
+* cancellation and doesn't reflect the theory
+* where the initial gaps are underestimated due
+* to WERR being too crude.)
+ IF(.NOT.ESKIP) THEN
+ IF( K.GT.1) THEN
+ WGAP( WINDMN ) = MAX( WGAP(WINDMN),
+ $ W(WINDEX)-WERR(WINDEX)
+ $ - W(WINDMN)-WERR(WINDMN) )
+ ENDIF
+ IF( WINDEX.LT.WEND ) THEN
+ WGAP( WINDEX ) = MAX( SAVGAP,
+ $ W( WINDPL )-WERR( WINDPL )
+ $ - W( WINDEX )-WERR( WINDEX) )
+ ENDIF
+ ENDIF
+ IDONE = IDONE + 1
+ ENDIF
+* here ends the code for the current child
+*
+ 139 CONTINUE
+* Proceed to any remaining child nodes
+ NEWFST = J + 1
+ 140 CONTINUE
+ 150 CONTINUE
+ NDEPTH = NDEPTH + 1
+ GO TO 40
+ END IF
+ IBEGIN = IEND + 1
+ WBEGIN = WEND + 1
+ 170 CONTINUE
+*
+
+ RETURN
+*
+* End of DLARRV
+*
+ END
+ SUBROUTINE DLARTG( F, G, CS, SN, R )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ DOUBLE PRECISION CS, F, G, R, SN
+* ..
+*
+* Purpose
+* =======
+*
+* DLARTG generate a plane rotation so that
+*
+* [ CS SN ] . [ F ] = [ R ] where CS**2 + SN**2 = 1.
+* [ -SN CS ] [ G ] [ 0 ]
+*
+* This is a slower, more accurate version of the BLAS1 routine DROTG,
+* with the following other differences:
+* F and G are unchanged on return.
+* If G=0, then CS=1 and SN=0.
+* If F=0 and (G .ne. 0), then CS=0 and SN=1 without doing any
+* floating point operations (saves work in DBDSQR when
+* there are zeros on the diagonal).
+*
+* If F exceeds G in magnitude, CS will be positive.
+*
+* Arguments
+* =========
+*
+* F (input) DOUBLE PRECISION
+* The first component of vector to be rotated.
+*
+* G (input) DOUBLE PRECISION
+* The second component of vector to be rotated.
+*
+* CS (output) DOUBLE PRECISION
+* The cosine of the rotation.
+*
+* SN (output) DOUBLE PRECISION
+* The sine of the rotation.
+*
+* R (output) DOUBLE PRECISION
+* The nonzero component of the rotated vector.
+*
+* This version has a few statements commented out for thread safety
+* (machine parameters are computed on each entry). 10 feb 03, SJH.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO
+ PARAMETER ( ZERO = 0.0D0 )
+ DOUBLE PRECISION ONE
+ PARAMETER ( ONE = 1.0D0 )
+ DOUBLE PRECISION TWO
+ PARAMETER ( TWO = 2.0D0 )
+* ..
+* .. Local Scalars ..
+* LOGICAL FIRST
+ INTEGER COUNT, I
+ DOUBLE PRECISION EPS, F1, G1, SAFMIN, SAFMN2, SAFMX2, SCALE
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DLAMCH
+ EXTERNAL DLAMCH
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, INT, LOG, MAX, SQRT
+* ..
+* .. Save statement ..
+* SAVE FIRST, SAFMX2, SAFMIN, SAFMN2
+* ..
+* .. Data statements ..
+* DATA FIRST / .TRUE. /
+* ..
+* .. Executable Statements ..
+*
+* IF( FIRST ) THEN
+ SAFMIN = DLAMCH( 'S' )
+ EPS = DLAMCH( 'E' )
+ SAFMN2 = DLAMCH( 'B' )**INT( LOG( SAFMIN / EPS ) /
+ $ LOG( DLAMCH( 'B' ) ) / TWO )
+ SAFMX2 = ONE / SAFMN2
+* FIRST = .FALSE.
+* END IF
+ IF( G.EQ.ZERO ) THEN
+ CS = ONE
+ SN = ZERO
+ R = F
+ ELSE IF( F.EQ.ZERO ) THEN
+ CS = ZERO
+ SN = ONE
+ R = G
+ ELSE
+ F1 = F
+ G1 = G
+ SCALE = MAX( ABS( F1 ), ABS( G1 ) )
+ IF( SCALE.GE.SAFMX2 ) THEN
+ COUNT = 0
+ 10 CONTINUE
+ COUNT = COUNT + 1
+ F1 = F1*SAFMN2
+ G1 = G1*SAFMN2
+ SCALE = MAX( ABS( F1 ), ABS( G1 ) )
+ IF( SCALE.GE.SAFMX2 )
+ $ GO TO 10
+ R = SQRT( F1**2+G1**2 )
+ CS = F1 / R
+ SN = G1 / R
+ DO 20 I = 1, COUNT
+ R = R*SAFMX2
+ 20 CONTINUE
+ ELSE IF( SCALE.LE.SAFMN2 ) THEN
+ COUNT = 0
+ 30 CONTINUE
+ COUNT = COUNT + 1
+ F1 = F1*SAFMX2
+ G1 = G1*SAFMX2
+ SCALE = MAX( ABS( F1 ), ABS( G1 ) )
+ IF( SCALE.LE.SAFMN2 )
+ $ GO TO 30
+ R = SQRT( F1**2+G1**2 )
+ CS = F1 / R
+ SN = G1 / R
+ DO 40 I = 1, COUNT
+ R = R*SAFMN2
+ 40 CONTINUE
+ ELSE
+ R = SQRT( F1**2+G1**2 )
+ CS = F1 / R
+ SN = G1 / R
+ END IF
+ IF( ABS( F ).GT.ABS( G ) .AND. CS.LT.ZERO ) THEN
+ CS = -CS
+ SN = -SN
+ R = -R
+ END IF
+ END IF
+ RETURN
+*
+* End of DLARTG
+*
+ END
+ SUBROUTINE DLARTV( N, X, INCX, Y, INCY, C, S, INCC )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INCC, INCX, INCY, N
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION C( * ), S( * ), X( * ), Y( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DLARTV applies a vector of real plane rotations to elements of the
+* real vectors x and y. For i = 1,2,...,n
+*
+* ( x(i) ) := ( c(i) s(i) ) ( x(i) )
+* ( y(i) ) ( -s(i) c(i) ) ( y(i) )
+*
+* Arguments
+* =========
+*
+* N (input) INTEGER
+* The number of plane rotations to be applied.
+*
+* X (input/output) DOUBLE PRECISION array,
+* dimension (1+(N-1)*INCX)
+* The vector x.
+*
+* INCX (input) INTEGER
+* The increment between elements of X. INCX > 0.
+*
+* Y (input/output) DOUBLE PRECISION array,
+* dimension (1+(N-1)*INCY)
+* The vector y.
+*
+* INCY (input) INTEGER
+* The increment between elements of Y. INCY > 0.
+*
+* C (input) DOUBLE PRECISION array, dimension (1+(N-1)*INCC)
+* The cosines of the plane rotations.
+*
+* S (input) DOUBLE PRECISION array, dimension (1+(N-1)*INCC)
+* The sines of the plane rotations.
+*
+* INCC (input) INTEGER
+* The increment between elements of C and S. INCC > 0.
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ INTEGER I, IC, IX, IY
+ DOUBLE PRECISION XI, YI
+* ..
+* .. Executable Statements ..
+*
+ IX = 1
+ IY = 1
+ IC = 1
+ DO 10 I = 1, N
+ XI = X( IX )
+ YI = Y( IY )
+ X( IX ) = C( IC )*XI + S( IC )*YI
+ Y( IY ) = C( IC )*YI - S( IC )*XI
+ IX = IX + INCX
+ IY = IY + INCY
+ IC = IC + INCC
+ 10 CONTINUE
+ RETURN
+*
+* End of DLARTV
+*
+ END
+ SUBROUTINE DLARUV( ISEED, N, X )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER N
+* ..
+* .. Array Arguments ..
+ INTEGER ISEED( 4 )
+ DOUBLE PRECISION X( N )
+* ..
+*
+* Purpose
+* =======
+*
+* DLARUV returns a vector of n random real numbers from a uniform (0,1)
+* distribution (n <= 128).
+*
+* This is an auxiliary routine called by DLARNV and ZLARNV.
+*
+* Arguments
+* =========
+*
+* ISEED (input/output) INTEGER array, dimension (4)
+* On entry, the seed of the random number generator; the array
+* elements must be between 0 and 4095, and ISEED(4) must be
+* odd.
+* On exit, the seed is updated.
+*
+* N (input) INTEGER
+* The number of random numbers to be generated. N <= 128.
+*
+* X (output) DOUBLE PRECISION array, dimension (N)
+* The generated random numbers.
+*
+* Further Details
+* ===============
+*
+* This routine uses a multiplicative congruential method with modulus
+* 2**48 and multiplier 33952834046453 (see G.S.Fishman,
+* 'Multiplicative congruential random number generators with modulus
+* 2**b: an exhaustive analysis for b = 32 and a partial analysis for
+* b = 48', Math. Comp. 189, pp 331-344, 1990).
+*
+* 48-bit integers are stored in 4 integer array elements with 12 bits
+* per element. Hence the routine is portable across machines with
+* integers of 32 bits or more.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE
+ PARAMETER ( ONE = 1.0D0 )
+ INTEGER LV, IPW2
+ DOUBLE PRECISION R
+ PARAMETER ( LV = 128, IPW2 = 4096, R = ONE / IPW2 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, I1, I2, I3, I4, IT1, IT2, IT3, IT4, J
+* ..
+* .. Local Arrays ..
+ INTEGER MM( LV, 4 )
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC DBLE, MIN, MOD
+* ..
+* .. Data statements ..
+ DATA ( MM( 1, J ), J = 1, 4 ) / 494, 322, 2508,
+ $ 2549 /
+ DATA ( MM( 2, J ), J = 1, 4 ) / 2637, 789, 3754,
+ $ 1145 /
+ DATA ( MM( 3, J ), J = 1, 4 ) / 255, 1440, 1766,
+ $ 2253 /
+ DATA ( MM( 4, J ), J = 1, 4 ) / 2008, 752, 3572,
+ $ 305 /
+ DATA ( MM( 5, J ), J = 1, 4 ) / 1253, 2859, 2893,
+ $ 3301 /
+ DATA ( MM( 6, J ), J = 1, 4 ) / 3344, 123, 307,
+ $ 1065 /
+ DATA ( MM( 7, J ), J = 1, 4 ) / 4084, 1848, 1297,
+ $ 3133 /
+ DATA ( MM( 8, J ), J = 1, 4 ) / 1739, 643, 3966,
+ $ 2913 /
+ DATA ( MM( 9, J ), J = 1, 4 ) / 3143, 2405, 758,
+ $ 3285 /
+ DATA ( MM( 10, J ), J = 1, 4 ) / 3468, 2638, 2598,
+ $ 1241 /
+ DATA ( MM( 11, J ), J = 1, 4 ) / 688, 2344, 3406,
+ $ 1197 /
+ DATA ( MM( 12, J ), J = 1, 4 ) / 1657, 46, 2922,
+ $ 3729 /
+ DATA ( MM( 13, J ), J = 1, 4 ) / 1238, 3814, 1038,
+ $ 2501 /
+ DATA ( MM( 14, J ), J = 1, 4 ) / 3166, 913, 2934,
+ $ 1673 /
+ DATA ( MM( 15, J ), J = 1, 4 ) / 1292, 3649, 2091,
+ $ 541 /
+ DATA ( MM( 16, J ), J = 1, 4 ) / 3422, 339, 2451,
+ $ 2753 /
+ DATA ( MM( 17, J ), J = 1, 4 ) / 1270, 3808, 1580,
+ $ 949 /
+ DATA ( MM( 18, J ), J = 1, 4 ) / 2016, 822, 1958,
+ $ 2361 /
+ DATA ( MM( 19, J ), J = 1, 4 ) / 154, 2832, 2055,
+ $ 1165 /
+ DATA ( MM( 20, J ), J = 1, 4 ) / 2862, 3078, 1507,
+ $ 4081 /
+ DATA ( MM( 21, J ), J = 1, 4 ) / 697, 3633, 1078,
+ $ 2725 /
+ DATA ( MM( 22, J ), J = 1, 4 ) / 1706, 2970, 3273,
+ $ 3305 /
+ DATA ( MM( 23, J ), J = 1, 4 ) / 491, 637, 17,
+ $ 3069 /
+ DATA ( MM( 24, J ), J = 1, 4 ) / 931, 2249, 854,
+ $ 3617 /
+ DATA ( MM( 25, J ), J = 1, 4 ) / 1444, 2081, 2916,
+ $ 3733 /
+ DATA ( MM( 26, J ), J = 1, 4 ) / 444, 4019, 3971,
+ $ 409 /
+ DATA ( MM( 27, J ), J = 1, 4 ) / 3577, 1478, 2889,
+ $ 2157 /
+ DATA ( MM( 28, J ), J = 1, 4 ) / 3944, 242, 3831,
+ $ 1361 /
+ DATA ( MM( 29, J ), J = 1, 4 ) / 2184, 481, 2621,
+ $ 3973 /
+ DATA ( MM( 30, J ), J = 1, 4 ) / 1661, 2075, 1541,
+ $ 1865 /
+ DATA ( MM( 31, J ), J = 1, 4 ) / 3482, 4058, 893,
+ $ 2525 /
+ DATA ( MM( 32, J ), J = 1, 4 ) / 657, 622, 736,
+ $ 1409 /
+ DATA ( MM( 33, J ), J = 1, 4 ) / 3023, 3376, 3992,
+ $ 3445 /
+ DATA ( MM( 34, J ), J = 1, 4 ) / 3618, 812, 787,
+ $ 3577 /
+ DATA ( MM( 35, J ), J = 1, 4 ) / 1267, 234, 2125,
+ $ 77 /
+ DATA ( MM( 36, J ), J = 1, 4 ) / 1828, 641, 2364,
+ $ 3761 /
+ DATA ( MM( 37, J ), J = 1, 4 ) / 164, 4005, 2460,
+ $ 2149 /
+ DATA ( MM( 38, J ), J = 1, 4 ) / 3798, 1122, 257,
+ $ 1449 /
+ DATA ( MM( 39, J ), J = 1, 4 ) / 3087, 3135, 1574,
+ $ 3005 /
+ DATA ( MM( 40, J ), J = 1, 4 ) / 2400, 2640, 3912,
+ $ 225 /
+ DATA ( MM( 41, J ), J = 1, 4 ) / 2870, 2302, 1216,
+ $ 85 /
+ DATA ( MM( 42, J ), J = 1, 4 ) / 3876, 40, 3248,
+ $ 3673 /
+ DATA ( MM( 43, J ), J = 1, 4 ) / 1905, 1832, 3401,
+ $ 3117 /
+ DATA ( MM( 44, J ), J = 1, 4 ) / 1593, 2247, 2124,
+ $ 3089 /
+ DATA ( MM( 45, J ), J = 1, 4 ) / 1797, 2034, 2762,
+ $ 1349 /
+ DATA ( MM( 46, J ), J = 1, 4 ) / 1234, 2637, 149,
+ $ 2057 /
+ DATA ( MM( 47, J ), J = 1, 4 ) / 3460, 1287, 2245,
+ $ 413 /
+ DATA ( MM( 48, J ), J = 1, 4 ) / 328, 1691, 166,
+ $ 65 /
+ DATA ( MM( 49, J ), J = 1, 4 ) / 2861, 496, 466,
+ $ 1845 /
+ DATA ( MM( 50, J ), J = 1, 4 ) / 1950, 1597, 4018,
+ $ 697 /
+ DATA ( MM( 51, J ), J = 1, 4 ) / 617, 2394, 1399,
+ $ 3085 /
+ DATA ( MM( 52, J ), J = 1, 4 ) / 2070, 2584, 190,
+ $ 3441 /
+ DATA ( MM( 53, J ), J = 1, 4 ) / 3331, 1843, 2879,
+ $ 1573 /
+ DATA ( MM( 54, J ), J = 1, 4 ) / 769, 336, 153,
+ $ 3689 /
+ DATA ( MM( 55, J ), J = 1, 4 ) / 1558, 1472, 2320,
+ $ 2941 /
+ DATA ( MM( 56, J ), J = 1, 4 ) / 2412, 2407, 18,
+ $ 929 /
+ DATA ( MM( 57, J ), J = 1, 4 ) / 2800, 433, 712,
+ $ 533 /
+ DATA ( MM( 58, J ), J = 1, 4 ) / 189, 2096, 2159,
+ $ 2841 /
+ DATA ( MM( 59, J ), J = 1, 4 ) / 287, 1761, 2318,
+ $ 4077 /
+ DATA ( MM( 60, J ), J = 1, 4 ) / 2045, 2810, 2091,
+ $ 721 /
+ DATA ( MM( 61, J ), J = 1, 4 ) / 1227, 566, 3443,
+ $ 2821 /
+ DATA ( MM( 62, J ), J = 1, 4 ) / 2838, 442, 1510,
+ $ 2249 /
+ DATA ( MM( 63, J ), J = 1, 4 ) / 209, 41, 449,
+ $ 2397 /
+ DATA ( MM( 64, J ), J = 1, 4 ) / 2770, 1238, 1956,
+ $ 2817 /
+ DATA ( MM( 65, J ), J = 1, 4 ) / 3654, 1086, 2201,
+ $ 245 /
+ DATA ( MM( 66, J ), J = 1, 4 ) / 3993, 603, 3137,
+ $ 1913 /
+ DATA ( MM( 67, J ), J = 1, 4 ) / 192, 840, 3399,
+ $ 1997 /
+ DATA ( MM( 68, J ), J = 1, 4 ) / 2253, 3168, 1321,
+ $ 3121 /
+ DATA ( MM( 69, J ), J = 1, 4 ) / 3491, 1499, 2271,
+ $ 997 /
+ DATA ( MM( 70, J ), J = 1, 4 ) / 2889, 1084, 3667,
+ $ 1833 /
+ DATA ( MM( 71, J ), J = 1, 4 ) / 2857, 3438, 2703,
+ $ 2877 /
+ DATA ( MM( 72, J ), J = 1, 4 ) / 2094, 2408, 629,
+ $ 1633 /
+ DATA ( MM( 73, J ), J = 1, 4 ) / 1818, 1589, 2365,
+ $ 981 /
+ DATA ( MM( 74, J ), J = 1, 4 ) / 688, 2391, 2431,
+ $ 2009 /
+ DATA ( MM( 75, J ), J = 1, 4 ) / 1407, 288, 1113,
+ $ 941 /
+ DATA ( MM( 76, J ), J = 1, 4 ) / 634, 26, 3922,
+ $ 2449 /
+ DATA ( MM( 77, J ), J = 1, 4 ) / 3231, 512, 2554,
+ $ 197 /
+ DATA ( MM( 78, J ), J = 1, 4 ) / 815, 1456, 184,
+ $ 2441 /
+ DATA ( MM( 79, J ), J = 1, 4 ) / 3524, 171, 2099,
+ $ 285 /
+ DATA ( MM( 80, J ), J = 1, 4 ) / 1914, 1677, 3228,
+ $ 1473 /
+ DATA ( MM( 81, J ), J = 1, 4 ) / 516, 2657, 4012,
+ $ 2741 /
+ DATA ( MM( 82, J ), J = 1, 4 ) / 164, 2270, 1921,
+ $ 3129 /
+ DATA ( MM( 83, J ), J = 1, 4 ) / 303, 2587, 3452,
+ $ 909 /
+ DATA ( MM( 84, J ), J = 1, 4 ) / 2144, 2961, 3901,
+ $ 2801 /
+ DATA ( MM( 85, J ), J = 1, 4 ) / 3480, 1970, 572,
+ $ 421 /
+ DATA ( MM( 86, J ), J = 1, 4 ) / 119, 1817, 3309,
+ $ 4073 /
+ DATA ( MM( 87, J ), J = 1, 4 ) / 3357, 676, 3171,
+ $ 2813 /
+ DATA ( MM( 88, J ), J = 1, 4 ) / 837, 1410, 817,
+ $ 2337 /
+ DATA ( MM( 89, J ), J = 1, 4 ) / 2826, 3723, 3039,
+ $ 1429 /
+ DATA ( MM( 90, J ), J = 1, 4 ) / 2332, 2803, 1696,
+ $ 1177 /
+ DATA ( MM( 91, J ), J = 1, 4 ) / 2089, 3185, 1256,
+ $ 1901 /
+ DATA ( MM( 92, J ), J = 1, 4 ) / 3780, 184, 3715,
+ $ 81 /
+ DATA ( MM( 93, J ), J = 1, 4 ) / 1700, 663, 2077,
+ $ 1669 /
+ DATA ( MM( 94, J ), J = 1, 4 ) / 3712, 499, 3019,
+ $ 2633 /
+ DATA ( MM( 95, J ), J = 1, 4 ) / 150, 3784, 1497,
+ $ 2269 /
+ DATA ( MM( 96, J ), J = 1, 4 ) / 2000, 1631, 1101,
+ $ 129 /
+ DATA ( MM( 97, J ), J = 1, 4 ) / 3375, 1925, 717,
+ $ 1141 /
+ DATA ( MM( 98, J ), J = 1, 4 ) / 1621, 3912, 51,
+ $ 249 /
+ DATA ( MM( 99, J ), J = 1, 4 ) / 3090, 1398, 981,
+ $ 3917 /
+ DATA ( MM( 100, J ), J = 1, 4 ) / 3765, 1349, 1978,
+ $ 2481 /
+ DATA ( MM( 101, J ), J = 1, 4 ) / 1149, 1441, 1813,
+ $ 3941 /
+ DATA ( MM( 102, J ), J = 1, 4 ) / 3146, 2224, 3881,
+ $ 2217 /
+ DATA ( MM( 103, J ), J = 1, 4 ) / 33, 2411, 76,
+ $ 2749 /
+ DATA ( MM( 104, J ), J = 1, 4 ) / 3082, 1907, 3846,
+ $ 3041 /
+ DATA ( MM( 105, J ), J = 1, 4 ) / 2741, 3192, 3694,
+ $ 1877 /
+ DATA ( MM( 106, J ), J = 1, 4 ) / 359, 2786, 1682,
+ $ 345 /
+ DATA ( MM( 107, J ), J = 1, 4 ) / 3316, 382, 124,
+ $ 2861 /
+ DATA ( MM( 108, J ), J = 1, 4 ) / 1749, 37, 1660,
+ $ 1809 /
+ DATA ( MM( 109, J ), J = 1, 4 ) / 185, 759, 3997,
+ $ 3141 /
+ DATA ( MM( 110, J ), J = 1, 4 ) / 2784, 2948, 479,
+ $ 2825 /
+ DATA ( MM( 111, J ), J = 1, 4 ) / 2202, 1862, 1141,
+ $ 157 /
+ DATA ( MM( 112, J ), J = 1, 4 ) / 2199, 3802, 886,
+ $ 2881 /
+ DATA ( MM( 113, J ), J = 1, 4 ) / 1364, 2423, 3514,
+ $ 3637 /
+ DATA ( MM( 114, J ), J = 1, 4 ) / 1244, 2051, 1301,
+ $ 1465 /
+ DATA ( MM( 115, J ), J = 1, 4 ) / 2020, 2295, 3604,
+ $ 2829 /
+ DATA ( MM( 116, J ), J = 1, 4 ) / 3160, 1332, 1888,
+ $ 2161 /
+ DATA ( MM( 117, J ), J = 1, 4 ) / 2785, 1832, 1836,
+ $ 3365 /
+ DATA ( MM( 118, J ), J = 1, 4 ) / 2772, 2405, 1990,
+ $ 361 /
+ DATA ( MM( 119, J ), J = 1, 4 ) / 1217, 3638, 2058,
+ $ 2685 /
+ DATA ( MM( 120, J ), J = 1, 4 ) / 1822, 3661, 692,
+ $ 3745 /
+ DATA ( MM( 121, J ), J = 1, 4 ) / 1245, 327, 1194,
+ $ 2325 /
+ DATA ( MM( 122, J ), J = 1, 4 ) / 2252, 3660, 20,
+ $ 3609 /
+ DATA ( MM( 123, J ), J = 1, 4 ) / 3904, 716, 3285,
+ $ 3821 /
+ DATA ( MM( 124, J ), J = 1, 4 ) / 2774, 1842, 2046,
+ $ 3537 /
+ DATA ( MM( 125, J ), J = 1, 4 ) / 997, 3987, 2107,
+ $ 517 /
+ DATA ( MM( 126, J ), J = 1, 4 ) / 2573, 1368, 3508,
+ $ 3017 /
+ DATA ( MM( 127, J ), J = 1, 4 ) / 1148, 1848, 3525,
+ $ 2141 /
+ DATA ( MM( 128, J ), J = 1, 4 ) / 545, 2366, 3801,
+ $ 1537 /
+* ..
+* .. Executable Statements ..
+*
+ I1 = ISEED( 1 )
+ I2 = ISEED( 2 )
+ I3 = ISEED( 3 )
+ I4 = ISEED( 4 )
+*
+ DO 10 I = 1, MIN( N, LV )
+*
+ 20 CONTINUE
+*
+* Multiply the seed by i-th power of the multiplier modulo 2**48
+*
+ IT4 = I4*MM( I, 4 )
+ IT3 = IT4 / IPW2
+ IT4 = IT4 - IPW2*IT3
+ IT3 = IT3 + I3*MM( I, 4 ) + I4*MM( I, 3 )
+ IT2 = IT3 / IPW2
+ IT3 = IT3 - IPW2*IT2
+ IT2 = IT2 + I2*MM( I, 4 ) + I3*MM( I, 3 ) + I4*MM( I, 2 )
+ IT1 = IT2 / IPW2
+ IT2 = IT2 - IPW2*IT1
+ IT1 = IT1 + I1*MM( I, 4 ) + I2*MM( I, 3 ) + I3*MM( I, 2 ) +
+ $ I4*MM( I, 1 )
+ IT1 = MOD( IT1, IPW2 )
+*
+* Convert 48-bit integer to a real number in the interval (0,1)
+*
+ X( I ) = R*( DBLE( IT1 )+R*( DBLE( IT2 )+R*( DBLE( IT3 )+R*
+ $ DBLE( IT4 ) ) ) )
+*
+ IF (X( I ).EQ.1.0D0) THEN
+* If a real number has n bits of precision, and the first
+* n bits of the 48-bit integer above happen to be all 1 (which
+* will occur about once every 2**n calls), then X( I ) will
+* be rounded to exactly 1.0.
+* Since X( I ) is not supposed to return exactly 0.0 or 1.0,
+* the statistically correct thing to do in this situation is
+* simply to iterate again.
+* N.B. the case X( I ) = 0.0 should not be possible.
+ I1 = I1 + 2
+ I2 = I2 + 2
+ I3 = I3 + 2
+ I4 = I4 + 2
+ GOTO 20
+ END IF
+*
+ 10 CONTINUE
+*
+* Return final value of seed
+*
+ ISEED( 1 ) = IT1
+ ISEED( 2 ) = IT2
+ ISEED( 3 ) = IT3
+ ISEED( 4 ) = IT4
+ RETURN
+*
+* End of DLARUV
+*
+ END
+ SUBROUTINE DLARZ( SIDE, M, N, L, V, INCV, TAU, C, LDC, WORK )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER SIDE
+ INTEGER INCV, L, LDC, M, N
+ DOUBLE PRECISION TAU
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION C( LDC, * ), V( * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DLARZ applies a real elementary reflector H to a real M-by-N
+* matrix C, from either the left or the right. H is represented in the
+* form
+*
+* H = I - tau * v * v'
+*
+* where tau is a real scalar and v is a real vector.
+*
+* If tau = 0, then H is taken to be the unit matrix.
+*
+*
+* H is a product of k elementary reflectors as returned by DTZRZF.
+*
+* Arguments
+* =========
+*
+* SIDE (input) CHARACTER*1
+* = 'L': form H * C
+* = 'R': form C * H
+*
+* M (input) INTEGER
+* The number of rows of the matrix C.
+*
+* N (input) INTEGER
+* The number of columns of the matrix C.
+*
+* L (input) INTEGER
+* The number of entries of the vector V containing
+* the meaningful part of the Householder vectors.
+* If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0.
+*
+* V (input) DOUBLE PRECISION array, dimension (1+(L-1)*abs(INCV))
+* The vector v in the representation of H as returned by
+* DTZRZF. V is not used if TAU = 0.
+*
+* INCV (input) INTEGER
+* The increment between elements of v. INCV <> 0.
+*
+* TAU (input) DOUBLE PRECISION
+* The value tau in the representation of H.
+*
+* C (input/output) DOUBLE PRECISION array, dimension (LDC,N)
+* On entry, the M-by-N matrix C.
+* On exit, C is overwritten by the matrix H * C if SIDE = 'L',
+* or C * H if SIDE = 'R'.
+*
+* LDC (input) INTEGER
+* The leading dimension of the array C. LDC >= max(1,M).
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension
+* (N) if SIDE = 'L'
+* or (M) if SIDE = 'R'
+*
+* Further Details
+* ===============
+*
+* Based on contributions by
+* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE, ZERO
+ PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
+* ..
+* .. External Subroutines ..
+ EXTERNAL DAXPY, DCOPY, DGEMV, DGER
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. Executable Statements ..
+*
+ IF( LSAME( SIDE, 'L' ) ) THEN
+*
+* Form H * C
+*
+ IF( TAU.NE.ZERO ) THEN
+*
+* w( 1:n ) = C( 1, 1:n )
+*
+ CALL DCOPY( N, C, LDC, WORK, 1 )
+*
+* w( 1:n ) = w( 1:n ) + C( m-l+1:m, 1:n )' * v( 1:l )
+*
+ CALL DGEMV( 'Transpose', L, N, ONE, C( M-L+1, 1 ), LDC, V,
+ $ INCV, ONE, WORK, 1 )
+*
+* C( 1, 1:n ) = C( 1, 1:n ) - tau * w( 1:n )
+*
+ CALL DAXPY( N, -TAU, WORK, 1, C, LDC )
+*
+* C( m-l+1:m, 1:n ) = C( m-l+1:m, 1:n ) - ...
+* tau * v( 1:l ) * w( 1:n )'
+*
+ CALL DGER( L, N, -TAU, V, INCV, WORK, 1, C( M-L+1, 1 ),
+ $ LDC )
+ END IF
+*
+ ELSE
+*
+* Form C * H
+*
+ IF( TAU.NE.ZERO ) THEN
+*
+* w( 1:m ) = C( 1:m, 1 )
+*
+ CALL DCOPY( M, C, 1, WORK, 1 )
+*
+* w( 1:m ) = w( 1:m ) + C( 1:m, n-l+1:n, 1:n ) * v( 1:l )
+*
+ CALL DGEMV( 'No transpose', M, L, ONE, C( 1, N-L+1 ), LDC,
+ $ V, INCV, ONE, WORK, 1 )
+*
+* C( 1:m, 1 ) = C( 1:m, 1 ) - tau * w( 1:m )
+*
+ CALL DAXPY( M, -TAU, WORK, 1, C, 1 )
+*
+* C( 1:m, n-l+1:n ) = C( 1:m, n-l+1:n ) - ...
+* tau * w( 1:m ) * v( 1:l )'
+*
+ CALL DGER( M, L, -TAU, WORK, 1, V, INCV, C( 1, N-L+1 ),
+ $ LDC )
+*
+ END IF
+*
+ END IF
+*
+ RETURN
+*
+* End of DLARZ
+*
+ END
+ SUBROUTINE DLARZB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, V,
+ $ LDV, T, LDT, C, LDC, WORK, LDWORK )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER DIRECT, SIDE, STOREV, TRANS
+ INTEGER K, L, LDC, LDT, LDV, LDWORK, M, N
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION C( LDC, * ), T( LDT, * ), V( LDV, * ),
+ $ WORK( LDWORK, * )
+* ..
+*
+* Purpose
+* =======
+*
+* DLARZB applies a real block reflector H or its transpose H**T to
+* a real distributed M-by-N C from the left or the right.
+*
+* Currently, only STOREV = 'R' and DIRECT = 'B' are supported.
+*
+* Arguments
+* =========
+*
+* SIDE (input) CHARACTER*1
+* = 'L': apply H or H' from the Left
+* = 'R': apply H or H' from the Right
+*
+* TRANS (input) CHARACTER*1
+* = 'N': apply H (No transpose)
+* = 'C': apply H' (Transpose)
+*
+* DIRECT (input) CHARACTER*1
+* Indicates how H is formed from a product of elementary
+* reflectors
+* = 'F': H = H(1) H(2) . . . H(k) (Forward, not supported yet)
+* = 'B': H = H(k) . . . H(2) H(1) (Backward)
+*
+* STOREV (input) CHARACTER*1
+* Indicates how the vectors which define the elementary
+* reflectors are stored:
+* = 'C': Columnwise (not supported yet)
+* = 'R': Rowwise
+*
+* M (input) INTEGER
+* The number of rows of the matrix C.
+*
+* N (input) INTEGER
+* The number of columns of the matrix C.
+*
+* K (input) INTEGER
+* The order of the matrix T (= the number of elementary
+* reflectors whose product defines the block reflector).
+*
+* L (input) INTEGER
+* The number of columns of the matrix V containing the
+* meaningful part of the Householder reflectors.
+* If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0.
+*
+* V (input) DOUBLE PRECISION array, dimension (LDV,NV).
+* If STOREV = 'C', NV = K; if STOREV = 'R', NV = L.
+*
+* LDV (input) INTEGER
+* The leading dimension of the array V.
+* If STOREV = 'C', LDV >= L; if STOREV = 'R', LDV >= K.
+*
+* T (input) DOUBLE PRECISION array, dimension (LDT,K)
+* The triangular K-by-K matrix T in the representation of the
+* block reflector.
+*
+* LDT (input) INTEGER
+* The leading dimension of the array T. LDT >= K.
+*
+* C (input/output) DOUBLE PRECISION array, dimension (LDC,N)
+* On entry, the M-by-N matrix C.
+* On exit, C is overwritten by H*C or H'*C or C*H or C*H'.
+*
+* LDC (input) INTEGER
+* The leading dimension of the array C. LDC >= max(1,M).
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (LDWORK,K)
+*
+* LDWORK (input) INTEGER
+* The leading dimension of the array WORK.
+* If SIDE = 'L', LDWORK >= max(1,N);
+* if SIDE = 'R', LDWORK >= max(1,M).
+*
+* Further Details
+* ===============
+*
+* Based on contributions by
+* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE
+ PARAMETER ( ONE = 1.0D+0 )
+* ..
+* .. Local Scalars ..
+ CHARACTER TRANST
+ INTEGER I, INFO, J
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL DCOPY, DGEMM, DTRMM, XERBLA
+* ..
+* .. Executable Statements ..
+*
+* Quick return if possible
+*
+ IF( M.LE.0 .OR. N.LE.0 )
+ $ RETURN
+*
+* Check for currently supported options
+*
+ INFO = 0
+ IF( .NOT.LSAME( DIRECT, 'B' ) ) THEN
+ INFO = -3
+ ELSE IF( .NOT.LSAME( STOREV, 'R' ) ) THEN
+ INFO = -4
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DLARZB', -INFO )
+ RETURN
+ END IF
+*
+ IF( LSAME( TRANS, 'N' ) ) THEN
+ TRANST = 'T'
+ ELSE
+ TRANST = 'N'
+ END IF
+*
+ IF( LSAME( SIDE, 'L' ) ) THEN
+*
+* Form H * C or H' * C
+*
+* W( 1:n, 1:k ) = C( 1:k, 1:n )'
+*
+ DO 10 J = 1, K
+ CALL DCOPY( N, C( J, 1 ), LDC, WORK( 1, J ), 1 )
+ 10 CONTINUE
+*
+* W( 1:n, 1:k ) = W( 1:n, 1:k ) + ...
+* C( m-l+1:m, 1:n )' * V( 1:k, 1:l )'
+*
+ IF( L.GT.0 )
+ $ CALL DGEMM( 'Transpose', 'Transpose', N, K, L, ONE,
+ $ C( M-L+1, 1 ), LDC, V, LDV, ONE, WORK, LDWORK )
+*
+* W( 1:n, 1:k ) = W( 1:n, 1:k ) * T' or W( 1:m, 1:k ) * T
+*
+ CALL DTRMM( 'Right', 'Lower', TRANST, 'Non-unit', N, K, ONE, T,
+ $ LDT, WORK, LDWORK )
+*
+* C( 1:k, 1:n ) = C( 1:k, 1:n ) - W( 1:n, 1:k )'
+*
+ DO 30 J = 1, N
+ DO 20 I = 1, K
+ C( I, J ) = C( I, J ) - WORK( J, I )
+ 20 CONTINUE
+ 30 CONTINUE
+*
+* C( m-l+1:m, 1:n ) = C( m-l+1:m, 1:n ) - ...
+* V( 1:k, 1:l )' * W( 1:n, 1:k )'
+*
+ IF( L.GT.0 )
+ $ CALL DGEMM( 'Transpose', 'Transpose', L, N, K, -ONE, V, LDV,
+ $ WORK, LDWORK, ONE, C( M-L+1, 1 ), LDC )
+*
+ ELSE IF( LSAME( SIDE, 'R' ) ) THEN
+*
+* Form C * H or C * H'
+*
+* W( 1:m, 1:k ) = C( 1:m, 1:k )
+*
+ DO 40 J = 1, K
+ CALL DCOPY( M, C( 1, J ), 1, WORK( 1, J ), 1 )
+ 40 CONTINUE
+*
+* W( 1:m, 1:k ) = W( 1:m, 1:k ) + ...
+* C( 1:m, n-l+1:n ) * V( 1:k, 1:l )'
+*
+ IF( L.GT.0 )
+ $ CALL DGEMM( 'No transpose', 'Transpose', M, K, L, ONE,
+ $ C( 1, N-L+1 ), LDC, V, LDV, ONE, WORK, LDWORK )
+*
+* W( 1:m, 1:k ) = W( 1:m, 1:k ) * T or W( 1:m, 1:k ) * T'
+*
+ CALL DTRMM( 'Right', 'Lower', TRANS, 'Non-unit', M, K, ONE, T,
+ $ LDT, WORK, LDWORK )
+*
+* C( 1:m, 1:k ) = C( 1:m, 1:k ) - W( 1:m, 1:k )
+*
+ DO 60 J = 1, K
+ DO 50 I = 1, M
+ C( I, J ) = C( I, J ) - WORK( I, J )
+ 50 CONTINUE
+ 60 CONTINUE
+*
+* C( 1:m, n-l+1:n ) = C( 1:m, n-l+1:n ) - ...
+* W( 1:m, 1:k ) * V( 1:k, 1:l )
+*
+ IF( L.GT.0 )
+ $ CALL DGEMM( 'No transpose', 'No transpose', M, L, K, -ONE,
+ $ WORK, LDWORK, V, LDV, ONE, C( 1, N-L+1 ), LDC )
+*
+ END IF
+*
+ RETURN
+*
+* End of DLARZB
+*
+ END
+ SUBROUTINE DLARZT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER DIRECT, STOREV
+ INTEGER K, LDT, LDV, N
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION T( LDT, * ), TAU( * ), V( LDV, * )
+* ..
+*
+* Purpose
+* =======
+*
+* DLARZT forms the triangular factor T of a real block reflector
+* H of order > n, which is defined as a product of k elementary
+* reflectors.
+*
+* If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular;
+*
+* If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular.
+*
+* If STOREV = 'C', the vector which defines the elementary reflector
+* H(i) is stored in the i-th column of the array V, and
+*
+* H = I - V * T * V'
+*
+* If STOREV = 'R', the vector which defines the elementary reflector
+* H(i) is stored in the i-th row of the array V, and
+*
+* H = I - V' * T * V
+*
+* Currently, only STOREV = 'R' and DIRECT = 'B' are supported.
+*
+* Arguments
+* =========
+*
+* DIRECT (input) CHARACTER*1
+* Specifies the order in which the elementary reflectors are
+* multiplied to form the block reflector:
+* = 'F': H = H(1) H(2) . . . H(k) (Forward, not supported yet)
+* = 'B': H = H(k) . . . H(2) H(1) (Backward)
+*
+* STOREV (input) CHARACTER*1
+* Specifies how the vectors which define the elementary
+* reflectors are stored (see also Further Details):
+* = 'C': columnwise (not supported yet)
+* = 'R': rowwise
+*
+* N (input) INTEGER
+* The order of the block reflector H. N >= 0.
+*
+* K (input) INTEGER
+* The order of the triangular factor T (= the number of
+* elementary reflectors). K >= 1.
+*
+* V (input/output) DOUBLE PRECISION array, dimension
+* (LDV,K) if STOREV = 'C'
+* (LDV,N) if STOREV = 'R'
+* The matrix V. See further details.
+*
+* LDV (input) INTEGER
+* The leading dimension of the array V.
+* If STOREV = 'C', LDV >= max(1,N); if STOREV = 'R', LDV >= K.
+*
+* TAU (input) DOUBLE PRECISION array, dimension (K)
+* TAU(i) must contain the scalar factor of the elementary
+* reflector H(i).
+*
+* T (output) DOUBLE PRECISION array, dimension (LDT,K)
+* The k by k triangular factor T of the block reflector.
+* If DIRECT = 'F', T is upper triangular; if DIRECT = 'B', T is
+* lower triangular. The rest of the array is not used.
+*
+* LDT (input) INTEGER
+* The leading dimension of the array T. LDT >= K.
+*
+* Further Details
+* ===============
+*
+* Based on contributions by
+* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA
+*
+* The shape of the matrix V and the storage of the vectors which define
+* the H(i) is best illustrated by the following example with n = 5 and
+* k = 3. The elements equal to 1 are not stored; the corresponding
+* array elements are modified but restored on exit. The rest of the
+* array is not used.
+*
+* DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R':
+*
+* ______V_____
+* ( v1 v2 v3 ) / \
+* ( v1 v2 v3 ) ( v1 v1 v1 v1 v1 . . . . 1 )
+* V = ( v1 v2 v3 ) ( v2 v2 v2 v2 v2 . . . 1 )
+* ( v1 v2 v3 ) ( v3 v3 v3 v3 v3 . . 1 )
+* ( v1 v2 v3 )
+* . . .
+* . . .
+* 1 . .
+* 1 .
+* 1
+*
+* DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R':
+*
+* ______V_____
+* 1 / \
+* . 1 ( 1 . . . . v1 v1 v1 v1 v1 )
+* . . 1 ( . 1 . . . v2 v2 v2 v2 v2 )
+* . . . ( . . 1 . . v3 v3 v3 v3 v3 )
+* . . .
+* ( v1 v2 v3 )
+* ( v1 v2 v3 )
+* V = ( v1 v2 v3 )
+* ( v1 v2 v3 )
+* ( v1 v2 v3 )
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO
+ PARAMETER ( ZERO = 0.0D+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, INFO, J
+* ..
+* .. External Subroutines ..
+ EXTERNAL DGEMV, DTRMV, XERBLA
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. Executable Statements ..
+*
+* Check for currently supported options
+*
+ INFO = 0
+ IF( .NOT.LSAME( DIRECT, 'B' ) ) THEN
+ INFO = -1
+ ELSE IF( .NOT.LSAME( STOREV, 'R' ) ) THEN
+ INFO = -2
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DLARZT', -INFO )
+ RETURN
+ END IF
+*
+ DO 20 I = K, 1, -1
+ IF( TAU( I ).EQ.ZERO ) THEN
+*
+* H(i) = I
+*
+ DO 10 J = I, K
+ T( J, I ) = ZERO
+ 10 CONTINUE
+ ELSE
+*
+* general case
+*
+ IF( I.LT.K ) THEN
+*
+* T(i+1:k,i) = - tau(i) * V(i+1:k,1:n) * V(i,1:n)'
+*
+ CALL DGEMV( 'No transpose', K-I, N, -TAU( I ),
+ $ V( I+1, 1 ), LDV, V( I, 1 ), LDV, ZERO,
+ $ T( I+1, I ), 1 )
+*
+* T(i+1:k,i) = T(i+1:k,i+1:k) * T(i+1:k,i)
+*
+ CALL DTRMV( 'Lower', 'No transpose', 'Non-unit', K-I,
+ $ T( I+1, I+1 ), LDT, T( I+1, I ), 1 )
+ END IF
+ T( I, I ) = TAU( I )
+ END IF
+ 20 CONTINUE
+ RETURN
+*
+* End of DLARZT
+*
+ END
+ SUBROUTINE DLAS2( F, G, H, SSMIN, SSMAX )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ DOUBLE PRECISION F, G, H, SSMAX, SSMIN
+* ..
+*
+* Purpose
+* =======
+*
+* DLAS2 computes the singular values of the 2-by-2 matrix
+* [ F G ]
+* [ 0 H ].
+* On return, SSMIN is the smaller singular value and SSMAX is the
+* larger singular value.
+*
+* Arguments
+* =========
+*
+* F (input) DOUBLE PRECISION
+* The (1,1) element of the 2-by-2 matrix.
+*
+* G (input) DOUBLE PRECISION
+* The (1,2) element of the 2-by-2 matrix.
+*
+* H (input) DOUBLE PRECISION
+* The (2,2) element of the 2-by-2 matrix.
+*
+* SSMIN (output) DOUBLE PRECISION
+* The smaller singular value.
+*
+* SSMAX (output) DOUBLE PRECISION
+* The larger singular value.
+*
+* Further Details
+* ===============
+*
+* Barring over/underflow, all output quantities are correct to within
+* a few units in the last place (ulps), even in the absence of a guard
+* digit in addition/subtraction.
+*
+* In IEEE arithmetic, the code works correctly if one matrix element is
+* infinite.
+*
+* Overflow will not occur unless the largest singular value itself
+* overflows, or is within a few ulps of overflow. (On machines with
+* partial overflow, like the Cray, overflow may occur if the largest
+* singular value is within a factor of 2 of overflow.)
+*
+* Underflow is harmless if underflow is gradual. Otherwise, results
+* may correspond to a matrix modified by perturbations of size near
+* the underflow threshold.
+*
+* ====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO
+ PARAMETER ( ZERO = 0.0D0 )
+ DOUBLE PRECISION ONE
+ PARAMETER ( ONE = 1.0D0 )
+ DOUBLE PRECISION TWO
+ PARAMETER ( TWO = 2.0D0 )
+* ..
+* .. Local Scalars ..
+ DOUBLE PRECISION AS, AT, AU, C, FA, FHMN, FHMX, GA, HA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, MIN, SQRT
+* ..
+* .. Executable Statements ..
+*
+ FA = ABS( F )
+ GA = ABS( G )
+ HA = ABS( H )
+ FHMN = MIN( FA, HA )
+ FHMX = MAX( FA, HA )
+ IF( FHMN.EQ.ZERO ) THEN
+ SSMIN = ZERO
+ IF( FHMX.EQ.ZERO ) THEN
+ SSMAX = GA
+ ELSE
+ SSMAX = MAX( FHMX, GA )*SQRT( ONE+
+ $ ( MIN( FHMX, GA ) / MAX( FHMX, GA ) )**2 )
+ END IF
+ ELSE
+ IF( GA.LT.FHMX ) THEN
+ AS = ONE + FHMN / FHMX
+ AT = ( FHMX-FHMN ) / FHMX
+ AU = ( GA / FHMX )**2
+ C = TWO / ( SQRT( AS*AS+AU )+SQRT( AT*AT+AU ) )
+ SSMIN = FHMN*C
+ SSMAX = FHMX / C
+ ELSE
+ AU = FHMX / GA
+ IF( AU.EQ.ZERO ) THEN
+*
+* Avoid possible harmful underflow if exponent range
+* asymmetric (true SSMIN may not underflow even if
+* AU underflows)
+*
+ SSMIN = ( FHMN*FHMX ) / GA
+ SSMAX = GA
+ ELSE
+ AS = ONE + FHMN / FHMX
+ AT = ( FHMX-FHMN ) / FHMX
+ C = ONE / ( SQRT( ONE+( AS*AU )**2 )+
+ $ SQRT( ONE+( AT*AU )**2 ) )
+ SSMIN = ( FHMN*C )*AU
+ SSMIN = SSMIN + SSMIN
+ SSMAX = GA / ( C+C )
+ END IF
+ END IF
+ END IF
+ RETURN
+*
+* End of DLAS2
+*
+ END
+ SUBROUTINE DLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER TYPE
+ INTEGER INFO, KL, KU, LDA, M, N
+ DOUBLE PRECISION CFROM, CTO
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION A( LDA, * )
+* ..
+*
+* Purpose
+* =======
+*
+* DLASCL multiplies the M by N real matrix A by the real scalar
+* CTO/CFROM. This is done without over/underflow as long as the final
+* result CTO*A(I,J)/CFROM does not over/underflow. TYPE specifies that
+* A may be full, upper triangular, lower triangular, upper Hessenberg,
+* or banded.
+*
+* Arguments
+* =========
+*
+* TYPE (input) CHARACTER*1
+* TYPE indices the storage type of the input matrix.
+* = 'G': A is a full matrix.
+* = 'L': A is a lower triangular matrix.
+* = 'U': A is an upper triangular matrix.
+* = 'H': A is an upper Hessenberg matrix.
+* = 'B': A is a symmetric band matrix with lower bandwidth KL
+* and upper bandwidth KU and with the only the lower
+* half stored.
+* = 'Q': A is a symmetric band matrix with lower bandwidth KL
+* and upper bandwidth KU and with the only the upper
+* half stored.
+* = 'Z': A is a band matrix with lower bandwidth KL and upper
+* bandwidth KU.
+*
+* KL (input) INTEGER
+* The lower bandwidth of A. Referenced only if TYPE = 'B',
+* 'Q' or 'Z'.
+*
+* KU (input) INTEGER
+* The upper bandwidth of A. Referenced only if TYPE = 'B',
+* 'Q' or 'Z'.
+*
+* CFROM (input) DOUBLE PRECISION
+* CTO (input) DOUBLE PRECISION
+* The matrix A is multiplied by CTO/CFROM. A(I,J) is computed
+* without over/underflow if the final result CTO*A(I,J)/CFROM
+* can be represented without over/underflow. CFROM must be
+* nonzero.
+*
+* M (input) INTEGER
+* The number of rows of the matrix A. M >= 0.
+*
+* N (input) INTEGER
+* The number of columns of the matrix A. N >= 0.
+*
+* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+* The matrix to be multiplied by CTO/CFROM. See TYPE for the
+* storage type.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,M).
+*
+* INFO (output) INTEGER
+* 0 - successful exit
+* <0 - if INFO = -i, the i-th argument had an illegal value.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL DONE
+ INTEGER I, ITYPE, J, K1, K2, K3, K4
+ DOUBLE PRECISION BIGNUM, CFROM1, CFROMC, CTO1, CTOC, MUL, SMLNUM
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ DOUBLE PRECISION DLAMCH
+ EXTERNAL LSAME, DLAMCH
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, MIN
+* ..
+* .. External Subroutines ..
+ EXTERNAL XERBLA
+* ..
+* .. Executable Statements ..
+*
+* Test the input arguments
+*
+ INFO = 0
+*
+ IF( LSAME( TYPE, 'G' ) ) THEN
+ ITYPE = 0
+ ELSE IF( LSAME( TYPE, 'L' ) ) THEN
+ ITYPE = 1
+ ELSE IF( LSAME( TYPE, 'U' ) ) THEN
+ ITYPE = 2
+ ELSE IF( LSAME( TYPE, 'H' ) ) THEN
+ ITYPE = 3
+ ELSE IF( LSAME( TYPE, 'B' ) ) THEN
+ ITYPE = 4
+ ELSE IF( LSAME( TYPE, 'Q' ) ) THEN
+ ITYPE = 5
+ ELSE IF( LSAME( TYPE, 'Z' ) ) THEN
+ ITYPE = 6
+ ELSE
+ ITYPE = -1
+ END IF
+*
+ IF( ITYPE.EQ.-1 ) THEN
+ INFO = -1
+ ELSE IF( CFROM.EQ.ZERO ) THEN
+ INFO = -4
+ ELSE IF( M.LT.0 ) THEN
+ INFO = -6
+ ELSE IF( N.LT.0 .OR. ( ITYPE.EQ.4 .AND. N.NE.M ) .OR.
+ $ ( ITYPE.EQ.5 .AND. N.NE.M ) ) THEN
+ INFO = -7
+ ELSE IF( ITYPE.LE.3 .AND. LDA.LT.MAX( 1, M ) ) THEN
+ INFO = -9
+ ELSE IF( ITYPE.GE.4 ) THEN
+ IF( KL.LT.0 .OR. KL.GT.MAX( M-1, 0 ) ) THEN
+ INFO = -2
+ ELSE IF( KU.LT.0 .OR. KU.GT.MAX( N-1, 0 ) .OR.
+ $ ( ( ITYPE.EQ.4 .OR. ITYPE.EQ.5 ) .AND. KL.NE.KU ) )
+ $ THEN
+ INFO = -3
+ ELSE IF( ( ITYPE.EQ.4 .AND. LDA.LT.KL+1 ) .OR.
+ $ ( ITYPE.EQ.5 .AND. LDA.LT.KU+1 ) .OR.
+ $ ( ITYPE.EQ.6 .AND. LDA.LT.2*KL+KU+1 ) ) THEN
+ INFO = -9
+ END IF
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DLASCL', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 .OR. M.EQ.0 )
+ $ RETURN
+*
+* Get machine parameters
+*
+ SMLNUM = DLAMCH( 'S' )
+ BIGNUM = ONE / SMLNUM
+*
+ CFROMC = CFROM
+ CTOC = CTO
+*
+ 10 CONTINUE
+ CFROM1 = CFROMC*SMLNUM
+ CTO1 = CTOC / BIGNUM
+ IF( ABS( CFROM1 ).GT.ABS( CTOC ) .AND. CTOC.NE.ZERO ) THEN
+ MUL = SMLNUM
+ DONE = .FALSE.
+ CFROMC = CFROM1
+ ELSE IF( ABS( CTO1 ).GT.ABS( CFROMC ) ) THEN
+ MUL = BIGNUM
+ DONE = .FALSE.
+ CTOC = CTO1
+ ELSE
+ MUL = CTOC / CFROMC
+ DONE = .TRUE.
+ END IF
+*
+ IF( ITYPE.EQ.0 ) THEN
+*
+* Full matrix
+*
+ DO 30 J = 1, N
+ DO 20 I = 1, M
+ A( I, J ) = A( I, J )*MUL
+ 20 CONTINUE
+ 30 CONTINUE
+*
+ ELSE IF( ITYPE.EQ.1 ) THEN
+*
+* Lower triangular matrix
+*
+ DO 50 J = 1, N
+ DO 40 I = J, M
+ A( I, J ) = A( I, J )*MUL
+ 40 CONTINUE
+ 50 CONTINUE
+*
+ ELSE IF( ITYPE.EQ.2 ) THEN
+*
+* Upper triangular matrix
+*
+ DO 70 J = 1, N
+ DO 60 I = 1, MIN( J, M )
+ A( I, J ) = A( I, J )*MUL
+ 60 CONTINUE
+ 70 CONTINUE
+*
+ ELSE IF( ITYPE.EQ.3 ) THEN
+*
+* Upper Hessenberg matrix
+*
+ DO 90 J = 1, N
+ DO 80 I = 1, MIN( J+1, M )
+ A( I, J ) = A( I, J )*MUL
+ 80 CONTINUE
+ 90 CONTINUE
+*
+ ELSE IF( ITYPE.EQ.4 ) THEN
+*
+* Lower half of a symmetric band matrix
+*
+ K3 = KL + 1
+ K4 = N + 1
+ DO 110 J = 1, N
+ DO 100 I = 1, MIN( K3, K4-J )
+ A( I, J ) = A( I, J )*MUL
+ 100 CONTINUE
+ 110 CONTINUE
+*
+ ELSE IF( ITYPE.EQ.5 ) THEN
+*
+* Upper half of a symmetric band matrix
+*
+ K1 = KU + 2
+ K3 = KU + 1
+ DO 130 J = 1, N
+ DO 120 I = MAX( K1-J, 1 ), K3
+ A( I, J ) = A( I, J )*MUL
+ 120 CONTINUE
+ 130 CONTINUE
+*
+ ELSE IF( ITYPE.EQ.6 ) THEN
+*
+* Band matrix
+*
+ K1 = KL + KU + 2
+ K2 = KL + 1
+ K3 = 2*KL + KU + 1
+ K4 = KL + KU + 1 + M
+ DO 150 J = 1, N
+ DO 140 I = MAX( K1-J, K2 ), MIN( K3, K4-J )
+ A( I, J ) = A( I, J )*MUL
+ 140 CONTINUE
+ 150 CONTINUE
+*
+ END IF
+*
+ IF( .NOT.DONE )
+ $ GO TO 10
+*
+ RETURN
+*
+* End of DLASCL
+*
+ END
+ SUBROUTINE DLASD0( N, SQRE, D, E, U, LDU, VT, LDVT, SMLSIZ, IWORK,
+ $ WORK, INFO )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LDU, LDVT, N, SMLSIZ, SQRE
+* ..
+* .. Array Arguments ..
+ INTEGER IWORK( * )
+ DOUBLE PRECISION D( * ), E( * ), U( LDU, * ), VT( LDVT, * ),
+ $ WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* Using a divide and conquer approach, DLASD0 computes the singular
+* value decomposition (SVD) of a real upper bidiagonal N-by-M
+* matrix B with diagonal D and offdiagonal E, where M = N + SQRE.
+* The algorithm computes orthogonal matrices U and VT such that
+* B = U * S * VT. The singular values S are overwritten on D.
+*
+* A related subroutine, DLASDA, computes only the singular values,
+* and optionally, the singular vectors in compact form.
+*
+* Arguments
+* =========
+*
+* N (input) INTEGER
+* On entry, the row dimension of the upper bidiagonal matrix.
+* This is also the dimension of the main diagonal array D.
+*
+* SQRE (input) INTEGER
+* Specifies the column dimension of the bidiagonal matrix.
+* = 0: The bidiagonal matrix has column dimension M = N;
+* = 1: The bidiagonal matrix has column dimension M = N+1;
+*
+* D (input/output) DOUBLE PRECISION array, dimension (N)
+* On entry D contains the main diagonal of the bidiagonal
+* matrix.
+* On exit D, if INFO = 0, contains its singular values.
+*
+* E (input) DOUBLE PRECISION array, dimension (M-1)
+* Contains the subdiagonal entries of the bidiagonal matrix.
+* On exit, E has been destroyed.
+*
+* U (output) DOUBLE PRECISION array, dimension at least (LDQ, N)
+* On exit, U contains the left singular vectors.
+*
+* LDU (input) INTEGER
+* On entry, leading dimension of U.
+*
+* VT (output) DOUBLE PRECISION array, dimension at least (LDVT, M)
+* On exit, VT' contains the right singular vectors.
+*
+* LDVT (input) INTEGER
+* On entry, leading dimension of VT.
+*
+* SMLSIZ (input) INTEGER
+* On entry, maximum size of the subproblems at the
+* bottom of the computation tree.
+*
+* IWORK (workspace) INTEGER work array.
+* Dimension must be at least (8 * N)
+*
+* WORK (workspace) DOUBLE PRECISION work array.
+* Dimension must be at least (3 * M**2 + 2 * M)
+*
+* INFO (output) INTEGER
+* = 0: successful exit.
+* < 0: if INFO = -i, the i-th argument had an illegal value.
+* > 0: if INFO = 1, an singular value did not converge
+*
+* Further Details
+* ===============
+*
+* Based on contributions by
+* Ming Gu and Huan Ren, Computer Science Division, University of
+* California at Berkeley, USA
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ INTEGER I, I1, IC, IDXQ, IDXQC, IM1, INODE, ITEMP, IWK,
+ $ J, LF, LL, LVL, M, NCC, ND, NDB1, NDIML, NDIMR,
+ $ NL, NLF, NLP1, NLVL, NR, NRF, NRP1, SQREI
+ DOUBLE PRECISION ALPHA, BETA
+* ..
+* .. External Subroutines ..
+ EXTERNAL DLASD1, DLASDQ, DLASDT, XERBLA
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+*
+ IF( N.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( ( SQRE.LT.0 ) .OR. ( SQRE.GT.1 ) ) THEN
+ INFO = -2
+ END IF
+*
+ M = N + SQRE
+*
+ IF( LDU.LT.N ) THEN
+ INFO = -6
+ ELSE IF( LDVT.LT.M ) THEN
+ INFO = -8
+ ELSE IF( SMLSIZ.LT.3 ) THEN
+ INFO = -9
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DLASD0', -INFO )
+ RETURN
+ END IF
+*
+* If the input matrix is too small, call DLASDQ to find the SVD.
+*
+ IF( N.LE.SMLSIZ ) THEN
+ CALL DLASDQ( 'U', SQRE, N, M, N, 0, D, E, VT, LDVT, U, LDU, U,
+ $ LDU, WORK, INFO )
+ RETURN
+ END IF
+*
+* Set up the computation tree.
+*
+ INODE = 1
+ NDIML = INODE + N
+ NDIMR = NDIML + N
+ IDXQ = NDIMR + N
+ IWK = IDXQ + N
+ CALL DLASDT( N, NLVL, ND, IWORK( INODE ), IWORK( NDIML ),
+ $ IWORK( NDIMR ), SMLSIZ )
+*
+* For the nodes on bottom level of the tree, solve
+* their subproblems by DLASDQ.
+*
+ NDB1 = ( ND+1 ) / 2
+ NCC = 0
+ DO 30 I = NDB1, ND
+*
+* IC : center row of each node
+* NL : number of rows of left subproblem
+* NR : number of rows of right subproblem
+* NLF: starting row of the left subproblem
+* NRF: starting row of the right subproblem
+*
+ I1 = I - 1
+ IC = IWORK( INODE+I1 )
+ NL = IWORK( NDIML+I1 )
+ NLP1 = NL + 1
+ NR = IWORK( NDIMR+I1 )
+ NRP1 = NR + 1
+ NLF = IC - NL
+ NRF = IC + 1
+ SQREI = 1
+ CALL DLASDQ( 'U', SQREI, NL, NLP1, NL, NCC, D( NLF ), E( NLF ),
+ $ VT( NLF, NLF ), LDVT, U( NLF, NLF ), LDU,
+ $ U( NLF, NLF ), LDU, WORK, INFO )
+ IF( INFO.NE.0 ) THEN
+ RETURN
+ END IF
+ ITEMP = IDXQ + NLF - 2
+ DO 10 J = 1, NL
+ IWORK( ITEMP+J ) = J
+ 10 CONTINUE
+ IF( I.EQ.ND ) THEN
+ SQREI = SQRE
+ ELSE
+ SQREI = 1
+ END IF
+ NRP1 = NR + SQREI
+ CALL DLASDQ( 'U', SQREI, NR, NRP1, NR, NCC, D( NRF ), E( NRF ),
+ $ VT( NRF, NRF ), LDVT, U( NRF, NRF ), LDU,
+ $ U( NRF, NRF ), LDU, WORK, INFO )
+ IF( INFO.NE.0 ) THEN
+ RETURN
+ END IF
+ ITEMP = IDXQ + IC
+ DO 20 J = 1, NR
+ IWORK( ITEMP+J-1 ) = J
+ 20 CONTINUE
+ 30 CONTINUE
+*
+* Now conquer each subproblem bottom-up.
+*
+ DO 50 LVL = NLVL, 1, -1
+*
+* Find the first node LF and last node LL on the
+* current level LVL.
+*
+ IF( LVL.EQ.1 ) THEN
+ LF = 1
+ LL = 1
+ ELSE
+ LF = 2**( LVL-1 )
+ LL = 2*LF - 1
+ END IF
+ DO 40 I = LF, LL
+ IM1 = I - 1
+ IC = IWORK( INODE+IM1 )
+ NL = IWORK( NDIML+IM1 )
+ NR = IWORK( NDIMR+IM1 )
+ NLF = IC - NL
+ IF( ( SQRE.EQ.0 ) .AND. ( I.EQ.LL ) ) THEN
+ SQREI = SQRE
+ ELSE
+ SQREI = 1
+ END IF
+ IDXQC = IDXQ + NLF - 1
+ ALPHA = D( IC )
+ BETA = E( IC )
+ CALL DLASD1( NL, NR, SQREI, D( NLF ), ALPHA, BETA,
+ $ U( NLF, NLF ), LDU, VT( NLF, NLF ), LDVT,
+ $ IWORK( IDXQC ), IWORK( IWK ), WORK, INFO )
+ IF( INFO.NE.0 ) THEN
+ RETURN
+ END IF
+ 40 CONTINUE
+ 50 CONTINUE
+*
+ RETURN
+*
+* End of DLASD0
+*
+ END
+ SUBROUTINE DLASD1( NL, NR, SQRE, D, ALPHA, BETA, U, LDU, VT, LDVT,
+ $ IDXQ, IWORK, WORK, INFO )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LDU, LDVT, NL, NR, SQRE
+ DOUBLE PRECISION ALPHA, BETA
+* ..
+* .. Array Arguments ..
+ INTEGER IDXQ( * ), IWORK( * )
+ DOUBLE PRECISION D( * ), U( LDU, * ), VT( LDVT, * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DLASD1 computes the SVD of an upper bidiagonal N-by-M matrix B,
+* where N = NL + NR + 1 and M = N + SQRE. DLASD1 is called from DLASD0.
+*
+* A related subroutine DLASD7 handles the case in which the singular
+* values (and the singular vectors in factored form) are desired.
+*
+* DLASD1 computes the SVD as follows:
+*
+* ( D1(in) 0 0 0 )
+* B = U(in) * ( Z1' a Z2' b ) * VT(in)
+* ( 0 0 D2(in) 0 )
+*
+* = U(out) * ( D(out) 0) * VT(out)
+*
+* where Z' = (Z1' a Z2' b) = u' VT', and u is a vector of dimension M
+* with ALPHA and BETA in the NL+1 and NL+2 th entries and zeros
+* elsewhere; and the entry b is empty if SQRE = 0.
+*
+* The left singular vectors of the original matrix are stored in U, and
+* the transpose of the right singular vectors are stored in VT, and the
+* singular values are in D. The algorithm consists of three stages:
+*
+* The first stage consists of deflating the size of the problem
+* when there are multiple singular values or when there are zeros in
+* the Z vector. For each such occurence the dimension of the
+* secular equation problem is reduced by one. This stage is
+* performed by the routine DLASD2.
+*
+* The second stage consists of calculating the updated
+* singular values. This is done by finding the square roots of the
+* roots of the secular equation via the routine DLASD4 (as called
+* by DLASD3). This routine also calculates the singular vectors of
+* the current problem.
+*
+* The final stage consists of computing the updated singular vectors
+* directly using the updated singular values. The singular vectors
+* for the current problem are multiplied with the singular vectors
+* from the overall problem.
+*
+* Arguments
+* =========
+*
+* NL (input) INTEGER
+* The row dimension of the upper block. NL >= 1.
+*
+* NR (input) INTEGER
+* The row dimension of the lower block. NR >= 1.
+*
+* SQRE (input) INTEGER
+* = 0: the lower block is an NR-by-NR square matrix.
+* = 1: the lower block is an NR-by-(NR+1) rectangular matrix.
+*
+* The bidiagonal matrix has row dimension N = NL + NR + 1,
+* and column dimension M = N + SQRE.
+*
+* D (input/output) DOUBLE PRECISION array,
+* dimension (N = NL+NR+1).
+* On entry D(1:NL,1:NL) contains the singular values of the
+* upper block; and D(NL+2:N) contains the singular values of
+* the lower block. On exit D(1:N) contains the singular values
+* of the modified matrix.
+*
+* ALPHA (input/output) DOUBLE PRECISION
+* Contains the diagonal element associated with the added row.
+*
+* BETA (input/output) DOUBLE PRECISION
+* Contains the off-diagonal element associated with the added
+* row.
+*
+* U (input/output) DOUBLE PRECISION array, dimension(LDU,N)
+* On entry U(1:NL, 1:NL) contains the left singular vectors of
+* the upper block; U(NL+2:N, NL+2:N) contains the left singular
+* vectors of the lower block. On exit U contains the left
+* singular vectors of the bidiagonal matrix.
+*
+* LDU (input) INTEGER
+* The leading dimension of the array U. LDU >= max( 1, N ).
+*
+* VT (input/output) DOUBLE PRECISION array, dimension(LDVT,M)
+* where M = N + SQRE.
+* On entry VT(1:NL+1, 1:NL+1)' contains the right singular
+* vectors of the upper block; VT(NL+2:M, NL+2:M)' contains
+* the right singular vectors of the lower block. On exit
+* VT' contains the right singular vectors of the
+* bidiagonal matrix.
+*
+* LDVT (input) INTEGER
+* The leading dimension of the array VT. LDVT >= max( 1, M ).
+*
+* IDXQ (output) INTEGER array, dimension(N)
+* This contains the permutation which will reintegrate the
+* subproblem just solved back into sorted order, i.e.
+* D( IDXQ( I = 1, N ) ) will be in ascending order.
+*
+* IWORK (workspace) INTEGER array, dimension( 4 * N )
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension( 3*M**2 + 2*M )
+*
+* INFO (output) INTEGER
+* = 0: successful exit.
+* < 0: if INFO = -i, the i-th argument had an illegal value.
+* > 0: if INFO = 1, an singular value did not converge
+*
+* Further Details
+* ===============
+*
+* Based on contributions by
+* Ming Gu and Huan Ren, Computer Science Division, University of
+* California at Berkeley, USA
+*
+* =====================================================================
+*
+* .. Parameters ..
+*
+ DOUBLE PRECISION ONE, ZERO
+ PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER COLTYP, I, IDX, IDXC, IDXP, IQ, ISIGMA, IU2,
+ $ IVT2, IZ, K, LDQ, LDU2, LDVT2, M, N, N1, N2
+ DOUBLE PRECISION ORGNRM
+* ..
+* .. External Subroutines ..
+ EXTERNAL DLAMRG, DLASCL, DLASD2, DLASD3, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+*
+ IF( NL.LT.1 ) THEN
+ INFO = -1
+ ELSE IF( NR.LT.1 ) THEN
+ INFO = -2
+ ELSE IF( ( SQRE.LT.0 ) .OR. ( SQRE.GT.1 ) ) THEN
+ INFO = -3
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DLASD1', -INFO )
+ RETURN
+ END IF
+*
+ N = NL + NR + 1
+ M = N + SQRE
+*
+* The following values are for bookkeeping purposes only. They are
+* integer pointers which indicate the portion of the workspace
+* used by a particular array in DLASD2 and DLASD3.
+*
+ LDU2 = N
+ LDVT2 = M
+*
+ IZ = 1
+ ISIGMA = IZ + M
+ IU2 = ISIGMA + N
+ IVT2 = IU2 + LDU2*N
+ IQ = IVT2 + LDVT2*M
+*
+ IDX = 1
+ IDXC = IDX + N
+ COLTYP = IDXC + N
+ IDXP = COLTYP + N
+*
+* Scale.
+*
+ ORGNRM = MAX( ABS( ALPHA ), ABS( BETA ) )
+ D( NL+1 ) = ZERO
+ DO 10 I = 1, N
+ IF( ABS( D( I ) ).GT.ORGNRM ) THEN
+ ORGNRM = ABS( D( I ) )
+ END IF
+ 10 CONTINUE
+ CALL DLASCL( 'G', 0, 0, ORGNRM, ONE, N, 1, D, N, INFO )
+ ALPHA = ALPHA / ORGNRM
+ BETA = BETA / ORGNRM
+*
+* Deflate singular values.
+*
+ CALL DLASD2( NL, NR, SQRE, K, D, WORK( IZ ), ALPHA, BETA, U, LDU,
+ $ VT, LDVT, WORK( ISIGMA ), WORK( IU2 ), LDU2,
+ $ WORK( IVT2 ), LDVT2, IWORK( IDXP ), IWORK( IDX ),
+ $ IWORK( IDXC ), IDXQ, IWORK( COLTYP ), INFO )
+*
+* Solve Secular Equation and update singular vectors.
+*
+ LDQ = K
+ CALL DLASD3( NL, NR, SQRE, K, D, WORK( IQ ), LDQ, WORK( ISIGMA ),
+ $ U, LDU, WORK( IU2 ), LDU2, VT, LDVT, WORK( IVT2 ),
+ $ LDVT2, IWORK( IDXC ), IWORK( COLTYP ), WORK( IZ ),
+ $ INFO )
+ IF( INFO.NE.0 ) THEN
+ RETURN
+ END IF
+*
+* Unscale.
+*
+ CALL DLASCL( 'G', 0, 0, ONE, ORGNRM, N, 1, D, N, INFO )
+*
+* Prepare the IDXQ sorting permutation.
+*
+ N1 = K
+ N2 = N - K
+ CALL DLAMRG( N1, N2, D, 1, -1, IDXQ )
+*
+ RETURN
+*
+* End of DLASD1
+*
+ END
+ 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 )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, K, LDU, LDU2, LDVT, LDVT2, NL, NR, SQRE
+ DOUBLE PRECISION ALPHA, BETA
+* ..
+* .. Array Arguments ..
+ INTEGER COLTYP( * ), IDX( * ), IDXC( * ), IDXP( * ),
+ $ IDXQ( * )
+ DOUBLE PRECISION D( * ), DSIGMA( * ), U( LDU, * ),
+ $ U2( LDU2, * ), VT( LDVT, * ), VT2( LDVT2, * ),
+ $ Z( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DLASD2 merges the two sets of singular values together into a single
+* sorted set. Then it tries to deflate the size of the problem.
+* There are two ways in which deflation can occur: when two or more
+* singular values are close together or if there is a tiny entry in the
+* Z vector. For each such occurrence the order of the related secular
+* equation problem is reduced by one.
+*
+* DLASD2 is called from DLASD1.
+*
+* Arguments
+* =========
+*
+* NL (input) INTEGER
+* The row dimension of the upper block. NL >= 1.
+*
+* NR (input) INTEGER
+* The row dimension of the lower block. NR >= 1.
+*
+* SQRE (input) INTEGER
+* = 0: the lower block is an NR-by-NR square matrix.
+* = 1: the lower block is an NR-by-(NR+1) rectangular matrix.
+*
+* The bidiagonal matrix has N = NL + NR + 1 rows and
+* M = N + SQRE >= N columns.
+*
+* K (output) INTEGER
+* Contains the dimension of the non-deflated matrix,
+* This is the order of the related secular equation. 1 <= K <=N.
+*
+* D (input/output) DOUBLE PRECISION array, dimension(N)
+* On entry D contains the singular values of the two submatrices
+* to be combined. On exit D contains the trailing (N-K) updated
+* singular values (those which were deflated) sorted into
+* increasing order.
+*
+* Z (output) DOUBLE PRECISION array, dimension(N)
+* On exit Z contains the updating row vector in the secular
+* equation.
+*
+* ALPHA (input) DOUBLE PRECISION
+* Contains the diagonal element associated with the added row.
+*
+* BETA (input) DOUBLE PRECISION
+* Contains the off-diagonal element associated with the added
+* row.
+*
+* U (input/output) DOUBLE PRECISION array, dimension(LDU,N)
+* On entry U contains the left singular vectors of two
+* submatrices in the two square blocks with corners at (1,1),
+* (NL, NL), and (NL+2, NL+2), (N,N).
+* On exit U contains the trailing (N-K) updated left singular
+* vectors (those which were deflated) in its last N-K columns.
+*
+* LDU (input) INTEGER
+* The leading dimension of the array U. LDU >= N.
+*
+* VT (input/output) DOUBLE PRECISION array, dimension(LDVT,M)
+* On entry VT' contains the right singular vectors of two
+* submatrices in the two square blocks with corners at (1,1),
+* (NL+1, NL+1), and (NL+2, NL+2), (M,M).
+* On exit VT' contains the trailing (N-K) updated right singular
+* vectors (those which were deflated) in its last N-K columns.
+* In case SQRE =1, the last row of VT spans the right null
+* space.
+*
+* LDVT (input) INTEGER
+* The leading dimension of the array VT. LDVT >= M.
+*
+* DSIGMA (output) DOUBLE PRECISION array, dimension (N)
+* Contains a copy of the diagonal elements (K-1 singular values
+* and one zero) in the secular equation.
+*
+* U2 (output) DOUBLE PRECISION array, dimension(LDU2,N)
+* Contains a copy of the first K-1 left singular vectors which
+* will be used by DLASD3 in a matrix multiply (DGEMM) to solve
+* for the new left singular vectors. U2 is arranged into four
+* blocks. The first block contains a column with 1 at NL+1 and
+* zero everywhere else; the second block contains non-zero
+* entries only at and above NL; the third contains non-zero
+* entries only below NL+1; and the fourth is dense.
+*
+* LDU2 (input) INTEGER
+* The leading dimension of the array U2. LDU2 >= N.
+*
+* VT2 (output) DOUBLE PRECISION array, dimension(LDVT2,N)
+* VT2' contains a copy of the first K right singular vectors
+* which will be used by DLASD3 in a matrix multiply (DGEMM) to
+* solve for the new right singular vectors. VT2 is arranged into
+* three blocks. The first block contains a row that corresponds
+* to the special 0 diagonal element in SIGMA; the second block
+* contains non-zeros only at and before NL +1; the third block
+* contains non-zeros only at and after NL +2.
+*
+* LDVT2 (input) INTEGER
+* The leading dimension of the array VT2. LDVT2 >= M.
+*
+* IDXP (workspace) INTEGER array dimension(N)
+* This will contain the permutation used to place deflated
+* values of D at the end of the array. On output IDXP(2:K)
+* points to the nondeflated D-values and IDXP(K+1:N)
+* points to the deflated singular values.
+*
+* IDX (workspace) INTEGER array dimension(N)
+* This will contain the permutation used to sort the contents of
+* D into ascending order.
+*
+* IDXC (output) INTEGER array dimension(N)
+* This will contain the permutation used to arrange the columns
+* of the deflated U matrix into three groups: the first group
+* contains non-zero entries only at and above NL, the second
+* contains non-zero entries only below NL+2, and the third is
+* dense.
+*
+* IDXQ (input/output) INTEGER array dimension(N)
+* This contains the permutation which separately sorts the two
+* sub-problems in D into ascending order. Note that entries in
+* the first hlaf of this permutation must first be moved one
+* position backward; and entries in the second half
+* must first have NL+1 added to their values.
+*
+* COLTYP (workspace/output) INTEGER array dimension(N)
+* As workspace, this will contain a label which will indicate
+* which of the following types a column in the U2 matrix or a
+* row in the VT2 matrix is:
+* 1 : non-zero in the upper half only
+* 2 : non-zero in the lower half only
+* 3 : dense
+* 4 : deflated
+*
+* On exit, it is an array of dimension 4, with COLTYP(I) being
+* the dimension of the I-th type columns.
+*
+* INFO (output) INTEGER
+* = 0: successful exit.
+* < 0: if INFO = -i, the i-th argument had an illegal value.
+*
+* Further Details
+* ===============
+*
+* Based on contributions by
+* Ming Gu and Huan Ren, Computer Science Division, University of
+* California at Berkeley, USA
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE, TWO, EIGHT
+ PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0,
+ $ EIGHT = 8.0D+0 )
+* ..
+* .. Local Arrays ..
+ INTEGER CTOT( 4 ), PSM( 4 )
+* ..
+* .. Local Scalars ..
+ INTEGER CT, I, IDXI, IDXJ, IDXJP, J, JP, JPREV, K2, M,
+ $ N, NLP1, NLP2
+ DOUBLE PRECISION C, EPS, HLFTOL, S, TAU, TOL, Z1
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DLAMCH, DLAPY2
+ EXTERNAL DLAMCH, DLAPY2
+* ..
+* .. External Subroutines ..
+ EXTERNAL DCOPY, DLACPY, DLAMRG, DLASET, DROT, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+*
+ IF( NL.LT.1 ) THEN
+ INFO = -1
+ ELSE IF( NR.LT.1 ) THEN
+ INFO = -2
+ ELSE IF( ( SQRE.NE.1 ) .AND. ( SQRE.NE.0 ) ) THEN
+ INFO = -3
+ END IF
+*
+ N = NL + NR + 1
+ M = N + SQRE
+*
+ IF( LDU.LT.N ) THEN
+ INFO = -10
+ ELSE IF( LDVT.LT.M ) THEN
+ INFO = -12
+ ELSE IF( LDU2.LT.N ) THEN
+ INFO = -15
+ ELSE IF( LDVT2.LT.M ) THEN
+ INFO = -17
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DLASD2', -INFO )
+ RETURN
+ END IF
+*
+ NLP1 = NL + 1
+ NLP2 = NL + 2
+*
+* Generate the first part of the vector Z; and move the singular
+* values in the first part of D one position backward.
+*
+ Z1 = ALPHA*VT( NLP1, NLP1 )
+ Z( 1 ) = Z1
+ DO 10 I = NL, 1, -1
+ Z( I+1 ) = ALPHA*VT( I, NLP1 )
+ D( I+1 ) = D( I )
+ IDXQ( I+1 ) = IDXQ( I ) + 1
+ 10 CONTINUE
+*
+* Generate the second part of the vector Z.
+*
+ DO 20 I = NLP2, M
+ Z( I ) = BETA*VT( I, NLP2 )
+ 20 CONTINUE
+*
+* Initialize some reference arrays.
+*
+ DO 30 I = 2, NLP1
+ COLTYP( I ) = 1
+ 30 CONTINUE
+ DO 40 I = NLP2, N
+ COLTYP( I ) = 2
+ 40 CONTINUE
+*
+* Sort the singular values into increasing order
+*
+ DO 50 I = NLP2, N
+ IDXQ( I ) = IDXQ( I ) + NLP1
+ 50 CONTINUE
+*
+* DSIGMA, IDXC, IDXC, and the first column of U2
+* are used as storage space.
+*
+ DO 60 I = 2, N
+ DSIGMA( I ) = D( IDXQ( I ) )
+ U2( I, 1 ) = Z( IDXQ( I ) )
+ IDXC( I ) = COLTYP( IDXQ( I ) )
+ 60 CONTINUE
+*
+ CALL DLAMRG( NL, NR, DSIGMA( 2 ), 1, 1, IDX( 2 ) )
+*
+ DO 70 I = 2, N
+ IDXI = 1 + IDX( I )
+ D( I ) = DSIGMA( IDXI )
+ Z( I ) = U2( IDXI, 1 )
+ COLTYP( I ) = IDXC( IDXI )
+ 70 CONTINUE
+*
+* Calculate the allowable deflation tolerance
+*
+ EPS = DLAMCH( 'Epsilon' )
+ TOL = MAX( ABS( ALPHA ), ABS( BETA ) )
+ TOL = EIGHT*EPS*MAX( ABS( D( N ) ), TOL )
+*
+* There are 2 kinds of deflation -- first a value in the z-vector
+* is small, second two (or more) singular values are very close
+* together (their difference is small).
+*
+* If the value in the z-vector is small, we simply permute the
+* array so that the corresponding singular value is moved to the
+* end.
+*
+* If two values in the D-vector are close, we perform a two-sided
+* rotation designed to make one of the corresponding z-vector
+* entries zero, and then permute the array so that the deflated
+* singular value is moved to the end.
+*
+* If there are multiple singular values then the problem deflates.
+* Here the number of equal singular values are found. As each equal
+* singular value is found, an elementary reflector is computed to
+* rotate the corresponding singular subspace so that the
+* corresponding components of Z are zero in this new basis.
+*
+ K = 1
+ K2 = N + 1
+ DO 80 J = 2, N
+ IF( ABS( Z( J ) ).LE.TOL ) THEN
+*
+* Deflate due to small z component.
+*
+ K2 = K2 - 1
+ IDXP( K2 ) = J
+ COLTYP( J ) = 4
+ IF( J.EQ.N )
+ $ GO TO 120
+ ELSE
+ JPREV = J
+ GO TO 90
+ END IF
+ 80 CONTINUE
+ 90 CONTINUE
+ J = JPREV
+ 100 CONTINUE
+ J = J + 1
+ IF( J.GT.N )
+ $ GO TO 110
+ IF( ABS( Z( J ) ).LE.TOL ) THEN
+*
+* Deflate due to small z component.
+*
+ K2 = K2 - 1
+ IDXP( K2 ) = J
+ COLTYP( J ) = 4
+ ELSE
+*
+* Check if singular values are close enough to allow deflation.
+*
+ IF( ABS( D( J )-D( JPREV ) ).LE.TOL ) THEN
+*
+* Deflation is possible.
+*
+ S = Z( JPREV )
+ C = Z( J )
+*
+* Find sqrt(a**2+b**2) without overflow or
+* destructive underflow.
+*
+ TAU = DLAPY2( C, S )
+ C = C / TAU
+ S = -S / TAU
+ Z( J ) = TAU
+ Z( JPREV ) = ZERO
+*
+* Apply back the Givens rotation to the left and right
+* singular vector matrices.
+*
+ IDXJP = IDXQ( IDX( JPREV )+1 )
+ IDXJ = IDXQ( IDX( J )+1 )
+ IF( IDXJP.LE.NLP1 ) THEN
+ IDXJP = IDXJP - 1
+ END IF
+ IF( IDXJ.LE.NLP1 ) THEN
+ IDXJ = IDXJ - 1
+ END IF
+ CALL DROT( N, U( 1, IDXJP ), 1, U( 1, IDXJ ), 1, C, S )
+ CALL DROT( M, VT( IDXJP, 1 ), LDVT, VT( IDXJ, 1 ), LDVT, C,
+ $ S )
+ IF( COLTYP( J ).NE.COLTYP( JPREV ) ) THEN
+ COLTYP( J ) = 3
+ END IF
+ COLTYP( JPREV ) = 4
+ K2 = K2 - 1
+ IDXP( K2 ) = JPREV
+ JPREV = J
+ ELSE
+ K = K + 1
+ U2( K, 1 ) = Z( JPREV )
+ DSIGMA( K ) = D( JPREV )
+ IDXP( K ) = JPREV
+ JPREV = J
+ END IF
+ END IF
+ GO TO 100
+ 110 CONTINUE
+*
+* Record the last singular value.
+*
+ K = K + 1
+ U2( K, 1 ) = Z( JPREV )
+ DSIGMA( K ) = D( JPREV )
+ IDXP( K ) = JPREV
+*
+ 120 CONTINUE
+*
+* Count up the total number of the various types of columns, then
+* form a permutation which positions the four column types into
+* four groups of uniform structure (although one or more of these
+* groups may be empty).
+*
+ DO 130 J = 1, 4
+ CTOT( J ) = 0
+ 130 CONTINUE
+ DO 140 J = 2, N
+ CT = COLTYP( J )
+ CTOT( CT ) = CTOT( CT ) + 1
+ 140 CONTINUE
+*
+* PSM(*) = Position in SubMatrix (of types 1 through 4)
+*
+ PSM( 1 ) = 2
+ PSM( 2 ) = 2 + CTOT( 1 )
+ PSM( 3 ) = PSM( 2 ) + CTOT( 2 )
+ PSM( 4 ) = PSM( 3 ) + CTOT( 3 )
+*
+* Fill out the IDXC array so that the permutation which it induces
+* will place all type-1 columns first, all type-2 columns next,
+* then all type-3's, and finally all type-4's, starting from the
+* second column. This applies similarly to the rows of VT.
+*
+ DO 150 J = 2, N
+ JP = IDXP( J )
+ CT = COLTYP( JP )
+ IDXC( PSM( CT ) ) = J
+ PSM( CT ) = PSM( CT ) + 1
+ 150 CONTINUE
+*
+* Sort the singular values and corresponding singular vectors into
+* DSIGMA, U2, and VT2 respectively. The singular values/vectors
+* which were not deflated go into the first K slots of DSIGMA, U2,
+* and VT2 respectively, while those which were deflated go into the
+* last N - K slots, except that the first column/row will be treated
+* separately.
+*
+ DO 160 J = 2, N
+ JP = IDXP( J )
+ DSIGMA( J ) = D( JP )
+ IDXJ = IDXQ( IDX( IDXP( IDXC( J ) ) )+1 )
+ IF( IDXJ.LE.NLP1 ) THEN
+ IDXJ = IDXJ - 1
+ END IF
+ CALL DCOPY( N, U( 1, IDXJ ), 1, U2( 1, J ), 1 )
+ CALL DCOPY( M, VT( IDXJ, 1 ), LDVT, VT2( J, 1 ), LDVT2 )
+ 160 CONTINUE
+*
+* Determine DSIGMA(1), DSIGMA(2) and Z(1)
+*
+ DSIGMA( 1 ) = ZERO
+ HLFTOL = TOL / TWO
+ IF( ABS( DSIGMA( 2 ) ).LE.HLFTOL )
+ $ DSIGMA( 2 ) = HLFTOL
+ IF( M.GT.N ) THEN
+ Z( 1 ) = DLAPY2( Z1, Z( M ) )
+ IF( Z( 1 ).LE.TOL ) THEN
+ C = ONE
+ S = ZERO
+ Z( 1 ) = TOL
+ ELSE
+ C = Z1 / Z( 1 )
+ S = Z( M ) / Z( 1 )
+ END IF
+ ELSE
+ IF( ABS( Z1 ).LE.TOL ) THEN
+ Z( 1 ) = TOL
+ ELSE
+ Z( 1 ) = Z1
+ END IF
+ END IF
+*
+* Move the rest of the updating row to Z.
+*
+ CALL DCOPY( K-1, U2( 2, 1 ), 1, Z( 2 ), 1 )
+*
+* Determine the first column of U2, the first row of VT2 and the
+* last row of VT.
+*
+ CALL DLASET( 'A', N, 1, ZERO, ZERO, U2, LDU2 )
+ U2( NLP1, 1 ) = ONE
+ IF( M.GT.N ) THEN
+ DO 170 I = 1, NLP1
+ VT( M, I ) = -S*VT( NLP1, I )
+ VT2( 1, I ) = C*VT( NLP1, I )
+ 170 CONTINUE
+ DO 180 I = NLP2, M
+ VT2( 1, I ) = S*VT( M, I )
+ VT( M, I ) = C*VT( M, I )
+ 180 CONTINUE
+ ELSE
+ CALL DCOPY( M, VT( NLP1, 1 ), LDVT, VT2( 1, 1 ), LDVT2 )
+ END IF
+ IF( M.GT.N ) THEN
+ CALL DCOPY( M, VT( M, 1 ), LDVT, VT2( M, 1 ), LDVT2 )
+ END IF
+*
+* The deflated singular values and their corresponding vectors go
+* into the back of D, U, and V respectively.
+*
+ IF( N.GT.K ) THEN
+ CALL DCOPY( N-K, DSIGMA( K+1 ), 1, D( K+1 ), 1 )
+ CALL DLACPY( 'A', N, N-K, U2( 1, K+1 ), LDU2, U( 1, K+1 ),
+ $ LDU )
+ CALL DLACPY( 'A', N-K, M, VT2( K+1, 1 ), LDVT2, VT( K+1, 1 ),
+ $ LDVT )
+ END IF
+*
+* Copy CTOT into COLTYP for referencing in DLASD3.
+*
+ DO 190 J = 1, 4
+ COLTYP( J ) = CTOT( J )
+ 190 CONTINUE
+*
+ RETURN
+*
+* End of DLASD2
+*
+ END
+ SUBROUTINE DLASD3( NL, NR, SQRE, K, D, Q, LDQ, DSIGMA, U, LDU, U2,
+ $ LDU2, VT, LDVT, VT2, LDVT2, IDXC, CTOT, Z,
+ $ INFO )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, K, LDQ, LDU, LDU2, LDVT, LDVT2, NL, NR,
+ $ SQRE
+* ..
+* .. Array Arguments ..
+ INTEGER CTOT( * ), IDXC( * )
+ DOUBLE PRECISION D( * ), DSIGMA( * ), Q( LDQ, * ), U( LDU, * ),
+ $ U2( LDU2, * ), VT( LDVT, * ), VT2( LDVT2, * ),
+ $ Z( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DLASD3 finds all the square roots of the roots of the secular
+* equation, as defined by the values in D and Z. It makes the
+* appropriate calls to DLASD4 and then updates the singular
+* vectors by matrix multiplication.
+*
+* This code makes very mild assumptions about floating point
+* arithmetic. It will work on machines with a guard digit in
+* add/subtract, or on those binary machines without guard digits
+* which subtract like the Cray XMP, Cray YMP, Cray C 90, or Cray 2.
+* It could conceivably fail on hexadecimal or decimal machines
+* without guard digits, but we know of none.
+*
+* DLASD3 is called from DLASD1.
+*
+* Arguments
+* =========
+*
+* NL (input) INTEGER
+* The row dimension of the upper block. NL >= 1.
+*
+* NR (input) INTEGER
+* The row dimension of the lower block. NR >= 1.
+*
+* SQRE (input) INTEGER
+* = 0: the lower block is an NR-by-NR square matrix.
+* = 1: the lower block is an NR-by-(NR+1) rectangular matrix.
+*
+* The bidiagonal matrix has N = NL + NR + 1 rows and
+* M = N + SQRE >= N columns.
+*
+* K (input) INTEGER
+* The size of the secular equation, 1 =< K = < N.
+*
+* D (output) DOUBLE PRECISION array, dimension(K)
+* On exit the square roots of the roots of the secular equation,
+* in ascending order.
+*
+* Q (workspace) DOUBLE PRECISION array,
+* dimension at least (LDQ,K).
+*
+* LDQ (input) INTEGER
+* The leading dimension of the array Q. LDQ >= K.
+*
+* DSIGMA (input) DOUBLE PRECISION array, dimension(K)
+* The first K elements of this array contain the old roots
+* of the deflated updating problem. These are the poles
+* of the secular equation.
+*
+* U (output) DOUBLE PRECISION array, dimension (LDU, N)
+* The last N - K columns of this matrix contain the deflated
+* left singular vectors.
+*
+* LDU (input) INTEGER
+* The leading dimension of the array U. LDU >= N.
+*
+* U2 (input/output) DOUBLE PRECISION array, dimension (LDU2, N)
+* The first K columns of this matrix contain the non-deflated
+* left singular vectors for the split problem.
+*
+* LDU2 (input) INTEGER
+* The leading dimension of the array U2. LDU2 >= N.
+*
+* VT (output) DOUBLE PRECISION array, dimension (LDVT, M)
+* The last M - K columns of VT' contain the deflated
+* right singular vectors.
+*
+* LDVT (input) INTEGER
+* The leading dimension of the array VT. LDVT >= N.
+*
+* VT2 (input/output) DOUBLE PRECISION array, dimension (LDVT2, N)
+* The first K columns of VT2' contain the non-deflated
+* right singular vectors for the split problem.
+*
+* LDVT2 (input) INTEGER
+* The leading dimension of the array VT2. LDVT2 >= N.
+*
+* IDXC (input) INTEGER array, dimension ( N )
+* The permutation used to arrange the columns of U (and rows of
+* VT) into three groups: the first group contains non-zero
+* entries only at and above (or before) NL +1; the second
+* contains non-zero entries only at and below (or after) NL+2;
+* and the third is dense. The first column of U and the row of
+* VT are treated separately, however.
+*
+* The rows of the singular vectors found by DLASD4
+* must be likewise permuted before the matrix multiplies can
+* take place.
+*
+* CTOT (input) INTEGER array, dimension ( 4 )
+* A count of the total number of the various types of columns
+* in U (or rows in VT), as described in IDXC. The fourth column
+* type is any column which has been deflated.
+*
+* Z (input) DOUBLE PRECISION array, dimension (K)
+* The first K elements of this array contain the components
+* of the deflation-adjusted updating row vector.
+*
+* INFO (output) INTEGER
+* = 0: successful exit.
+* < 0: if INFO = -i, the i-th argument had an illegal value.
+* > 0: if INFO = 1, an singular value did not converge
+*
+* Further Details
+* ===============
+*
+* Based on contributions by
+* Ming Gu and Huan Ren, Computer Science Division, University of
+* California at Berkeley, USA
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE, ZERO, NEGONE
+ PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0,
+ $ NEGONE = -1.0D+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER CTEMP, I, J, JC, KTEMP, M, N, NLP1, NLP2, NRP1
+ DOUBLE PRECISION RHO, TEMP
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DLAMC3, DNRM2
+ EXTERNAL DLAMC3, DNRM2
+* ..
+* .. External Subroutines ..
+ EXTERNAL DCOPY, DGEMM, DLACPY, DLASCL, DLASD4, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, SIGN, SQRT
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+*
+ IF( NL.LT.1 ) THEN
+ INFO = -1
+ ELSE IF( NR.LT.1 ) THEN
+ INFO = -2
+ ELSE IF( ( SQRE.NE.1 ) .AND. ( SQRE.NE.0 ) ) THEN
+ INFO = -3
+ END IF
+*
+ N = NL + NR + 1
+ M = N + SQRE
+ NLP1 = NL + 1
+ NLP2 = NL + 2
+*
+ IF( ( K.LT.1 ) .OR. ( K.GT.N ) ) THEN
+ INFO = -4
+ ELSE IF( LDQ.LT.K ) THEN
+ INFO = -7
+ ELSE IF( LDU.LT.N ) THEN
+ INFO = -10
+ ELSE IF( LDU2.LT.N ) THEN
+ INFO = -12
+ ELSE IF( LDVT.LT.M ) THEN
+ INFO = -14
+ ELSE IF( LDVT2.LT.M ) THEN
+ INFO = -16
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DLASD3', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( K.EQ.1 ) THEN
+ D( 1 ) = ABS( Z( 1 ) )
+ CALL DCOPY( M, VT2( 1, 1 ), LDVT2, VT( 1, 1 ), LDVT )
+ IF( Z( 1 ).GT.ZERO ) THEN
+ CALL DCOPY( N, U2( 1, 1 ), 1, U( 1, 1 ), 1 )
+ ELSE
+ DO 10 I = 1, N
+ U( I, 1 ) = -U2( I, 1 )
+ 10 CONTINUE
+ END IF
+ RETURN
+ END IF
+*
+* Modify values DSIGMA(i) to make sure all DSIGMA(i)-DSIGMA(j) can
+* be computed with high relative accuracy (barring over/underflow).
+* This is a problem on machines without a guard digit in
+* add/subtract (Cray XMP, Cray YMP, Cray C 90 and Cray 2).
+* The following code replaces DSIGMA(I) by 2*DSIGMA(I)-DSIGMA(I),
+* which on any of these machines zeros out the bottommost
+* bit of DSIGMA(I) if it is 1; this makes the subsequent
+* subtractions DSIGMA(I)-DSIGMA(J) unproblematic when cancellation
+* occurs. On binary machines with a guard digit (almost all
+* machines) it does not change DSIGMA(I) at all. On hexadecimal
+* and decimal machines with a guard digit, it slightly
+* changes the bottommost bits of DSIGMA(I). It does not account
+* for hexadecimal or decimal machines without guard digits
+* (we know of none). We use a subroutine call to compute
+* 2*DSIGMA(I) to prevent optimizing compilers from eliminating
+* this code.
+*
+ DO 20 I = 1, K
+ DSIGMA( I ) = DLAMC3( DSIGMA( I ), DSIGMA( I ) ) - DSIGMA( I )
+ 20 CONTINUE
+*
+* Keep a copy of Z.
+*
+ CALL DCOPY( K, Z, 1, Q, 1 )
+*
+* Normalize Z.
+*
+ RHO = DNRM2( K, Z, 1 )
+ CALL DLASCL( 'G', 0, 0, RHO, ONE, K, 1, Z, K, INFO )
+ RHO = RHO*RHO
+*
+* Find the new singular values.
+*
+ DO 30 J = 1, K
+ CALL DLASD4( K, J, DSIGMA, Z, U( 1, J ), RHO, D( J ),
+ $ VT( 1, J ), INFO )
+*
+* If the zero finder fails, the computation is terminated.
+*
+ IF( INFO.NE.0 ) THEN
+ RETURN
+ END IF
+ 30 CONTINUE
+*
+* Compute updated Z.
+*
+ DO 60 I = 1, K
+ Z( I ) = U( I, K )*VT( I, K )
+ DO 40 J = 1, I - 1
+ Z( I ) = Z( I )*( U( I, J )*VT( I, J ) /
+ $ ( DSIGMA( I )-DSIGMA( J ) ) /
+ $ ( DSIGMA( I )+DSIGMA( J ) ) )
+ 40 CONTINUE
+ DO 50 J = I, K - 1
+ Z( I ) = Z( I )*( U( I, J )*VT( I, J ) /
+ $ ( DSIGMA( I )-DSIGMA( J+1 ) ) /
+ $ ( DSIGMA( I )+DSIGMA( J+1 ) ) )
+ 50 CONTINUE
+ Z( I ) = SIGN( SQRT( ABS( Z( I ) ) ), Q( I, 1 ) )
+ 60 CONTINUE
+*
+* Compute left singular vectors of the modified diagonal matrix,
+* and store related information for the right singular vectors.
+*
+ DO 90 I = 1, K
+ VT( 1, I ) = Z( 1 ) / U( 1, I ) / VT( 1, I )
+ U( 1, I ) = NEGONE
+ DO 70 J = 2, K
+ VT( J, I ) = Z( J ) / U( J, I ) / VT( J, I )
+ U( J, I ) = DSIGMA( J )*VT( J, I )
+ 70 CONTINUE
+ TEMP = DNRM2( K, U( 1, I ), 1 )
+ Q( 1, I ) = U( 1, I ) / TEMP
+ DO 80 J = 2, K
+ JC = IDXC( J )
+ Q( J, I ) = U( JC, I ) / TEMP
+ 80 CONTINUE
+ 90 CONTINUE
+*
+* Update the left singular vector matrix.
+*
+ IF( K.EQ.2 ) THEN
+ CALL DGEMM( 'N', 'N', N, K, K, ONE, U2, LDU2, Q, LDQ, ZERO, U,
+ $ LDU )
+ GO TO 100
+ END IF
+ IF( CTOT( 1 ).GT.0 ) THEN
+ CALL DGEMM( 'N', 'N', NL, K, CTOT( 1 ), ONE, U2( 1, 2 ), LDU2,
+ $ Q( 2, 1 ), LDQ, ZERO, U( 1, 1 ), LDU )
+ IF( CTOT( 3 ).GT.0 ) THEN
+ KTEMP = 2 + CTOT( 1 ) + CTOT( 2 )
+ CALL DGEMM( 'N', 'N', NL, K, CTOT( 3 ), ONE, U2( 1, KTEMP ),
+ $ LDU2, Q( KTEMP, 1 ), LDQ, ONE, U( 1, 1 ), LDU )
+ END IF
+ ELSE IF( CTOT( 3 ).GT.0 ) THEN
+ KTEMP = 2 + CTOT( 1 ) + CTOT( 2 )
+ CALL DGEMM( 'N', 'N', NL, K, CTOT( 3 ), ONE, U2( 1, KTEMP ),
+ $ LDU2, Q( KTEMP, 1 ), LDQ, ZERO, U( 1, 1 ), LDU )
+ ELSE
+ CALL DLACPY( 'F', NL, K, U2, LDU2, U, LDU )
+ END IF
+ CALL DCOPY( K, Q( 1, 1 ), LDQ, U( NLP1, 1 ), LDU )
+ KTEMP = 2 + CTOT( 1 )
+ CTEMP = CTOT( 2 ) + CTOT( 3 )
+ CALL DGEMM( 'N', 'N', NR, K, CTEMP, ONE, U2( NLP2, KTEMP ), LDU2,
+ $ Q( KTEMP, 1 ), LDQ, ZERO, U( NLP2, 1 ), LDU )
+*
+* Generate the right singular vectors.
+*
+ 100 CONTINUE
+ DO 120 I = 1, K
+ TEMP = DNRM2( K, VT( 1, I ), 1 )
+ Q( I, 1 ) = VT( 1, I ) / TEMP
+ DO 110 J = 2, K
+ JC = IDXC( J )
+ Q( I, J ) = VT( JC, I ) / TEMP
+ 110 CONTINUE
+ 120 CONTINUE
+*
+* Update the right singular vector matrix.
+*
+ IF( K.EQ.2 ) THEN
+ CALL DGEMM( 'N', 'N', K, M, K, ONE, Q, LDQ, VT2, LDVT2, ZERO,
+ $ VT, LDVT )
+ RETURN
+ END IF
+ KTEMP = 1 + CTOT( 1 )
+ CALL DGEMM( 'N', 'N', K, NLP1, KTEMP, ONE, Q( 1, 1 ), LDQ,
+ $ VT2( 1, 1 ), LDVT2, ZERO, VT( 1, 1 ), LDVT )
+ KTEMP = 2 + CTOT( 1 ) + CTOT( 2 )
+ IF( KTEMP.LE.LDVT2 )
+ $ CALL DGEMM( 'N', 'N', K, NLP1, CTOT( 3 ), ONE, Q( 1, KTEMP ),
+ $ LDQ, VT2( KTEMP, 1 ), LDVT2, ONE, VT( 1, 1 ),
+ $ LDVT )
+*
+ KTEMP = CTOT( 1 ) + 1
+ NRP1 = NR + SQRE
+ IF( KTEMP.GT.1 ) THEN
+ DO 130 I = 1, K
+ Q( I, KTEMP ) = Q( I, 1 )
+ 130 CONTINUE
+ DO 140 I = NLP2, M
+ VT2( KTEMP, I ) = VT2( 1, I )
+ 140 CONTINUE
+ END IF
+ CTEMP = 1 + CTOT( 2 ) + CTOT( 3 )
+ CALL DGEMM( 'N', 'N', K, NRP1, CTEMP, ONE, Q( 1, KTEMP ), LDQ,
+ $ VT2( KTEMP, NLP2 ), LDVT2, ZERO, VT( 1, NLP2 ), LDVT )
+*
+ RETURN
+*
+* End of DLASD3
+*
+ END
+ SUBROUTINE DLASD4( N, I, D, Z, DELTA, RHO, SIGMA, WORK, INFO )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER I, INFO, N
+ DOUBLE PRECISION RHO, SIGMA
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION D( * ), DELTA( * ), WORK( * ), Z( * )
+* ..
+*
+* Purpose
+* =======
+*
+* This subroutine computes the square root of the I-th updated
+* eigenvalue of a positive symmetric rank-one modification to
+* a positive diagonal matrix whose entries are given as the squares
+* of the corresponding entries in the array d, and that
+*
+* 0 <= D(i) < D(j) for i < j
+*
+* and that RHO > 0. This is arranged by the calling routine, and is
+* no loss in generality. The rank-one modified system is thus
+*
+* diag( D ) * diag( D ) + RHO * Z * Z_transpose.
+*
+* where we assume the Euclidean norm of Z is 1.
+*
+* The method consists of approximating the rational functions in the
+* secular equation by simpler interpolating rational functions.
+*
+* Arguments
+* =========
+*
+* N (input) INTEGER
+* The length of all arrays.
+*
+* I (input) INTEGER
+* The index of the eigenvalue to be computed. 1 <= I <= N.
+*
+* D (input) DOUBLE PRECISION array, dimension ( N )
+* The original eigenvalues. It is assumed that they are in
+* order, 0 <= D(I) < D(J) for I < J.
+*
+* Z (input) DOUBLE PRECISION array, dimension ( N )
+* The components of the updating vector.
+*
+* DELTA (output) DOUBLE PRECISION array, dimension ( N )
+* If N .ne. 1, DELTA contains (D(j) - sigma_I) in its j-th
+* component. If N = 1, then DELTA(1) = 1. The vector DELTA
+* contains the information necessary to construct the
+* (singular) eigenvectors.
+*
+* RHO (input) DOUBLE PRECISION
+* The scalar in the symmetric updating formula.
+*
+* SIGMA (output) DOUBLE PRECISION
+* The computed sigma_I, the I-th updated eigenvalue.
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension ( N )
+* If N .ne. 1, WORK contains (D(j) + sigma_I) in its j-th
+* component. If N = 1, then WORK( 1 ) = 1.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* > 0: if INFO = 1, the updating process failed.
+*
+* Internal Parameters
+* ===================
+*
+* Logical variable ORGATI (origin-at-i?) is used for distinguishing
+* whether D(i) or D(i+1) is treated as the origin.
+*
+* ORGATI = .true. origin at i
+* ORGATI = .false. origin at i+1
+*
+* Logical variable SWTCH3 (switch-for-3-poles?) is for noting
+* if we are working with THREE poles!
+*
+* MAXIT is the maximum number of iterations allowed for each
+* eigenvalue.
+*
+* Further Details
+* ===============
+*
+* Based on contributions by
+* Ren-Cang Li, Computer Science Division, University of California
+* at Berkeley, USA
+*
+* =====================================================================
+*
+* .. Parameters ..
+ INTEGER MAXIT
+ PARAMETER ( MAXIT = 20 )
+ DOUBLE PRECISION ZERO, ONE, TWO, THREE, FOUR, EIGHT, TEN
+ PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0,
+ $ THREE = 3.0D+0, FOUR = 4.0D+0, EIGHT = 8.0D+0,
+ $ TEN = 10.0D+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL ORGATI, SWTCH, SWTCH3
+ INTEGER II, IIM1, IIP1, IP1, ITER, J, NITER
+ DOUBLE PRECISION A, B, C, DELSQ, DELSQ2, DPHI, DPSI, DTIIM,
+ $ DTIIP, DTIPSQ, DTISQ, DTNSQ, DTNSQ1, DW, EPS,
+ $ ERRETM, ETA, PHI, PREW, PSI, RHOINV, SG2LB,
+ $ SG2UB, TAU, TEMP, TEMP1, TEMP2, W
+* ..
+* .. Local Arrays ..
+ DOUBLE PRECISION DD( 3 ), ZZ( 3 )
+* ..
+* .. External Subroutines ..
+ EXTERNAL DLAED6, DLASD5
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DLAMCH
+ EXTERNAL DLAMCH
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, MIN, SQRT
+* ..
+* .. Executable Statements ..
+*
+* Since this routine is called in an inner loop, we do no argument
+* checking.
+*
+* Quick return for N=1 and 2.
+*
+ INFO = 0
+ IF( N.EQ.1 ) THEN
+*
+* Presumably, I=1 upon entry
+*
+ SIGMA = SQRT( D( 1 )*D( 1 )+RHO*Z( 1 )*Z( 1 ) )
+ DELTA( 1 ) = ONE
+ WORK( 1 ) = ONE
+ RETURN
+ END IF
+ IF( N.EQ.2 ) THEN
+ CALL DLASD5( I, D, Z, DELTA, RHO, SIGMA, WORK )
+ RETURN
+ END IF
+*
+* Compute machine epsilon
+*
+ EPS = DLAMCH( 'Epsilon' )
+ RHOINV = ONE / RHO
+*
+* The case I = N
+*
+ IF( I.EQ.N ) THEN
+*
+* Initialize some basic variables
+*
+ II = N - 1
+ NITER = 1
+*
+* Calculate initial guess
+*
+ TEMP = RHO / TWO
+*
+* If ||Z||_2 is not one, then TEMP should be set to
+* RHO * ||Z||_2^2 / TWO
+*
+ TEMP1 = TEMP / ( D( N )+SQRT( D( N )*D( N )+TEMP ) )
+ DO 10 J = 1, N
+ WORK( J ) = D( J ) + D( N ) + TEMP1
+ DELTA( J ) = ( D( J )-D( N ) ) - TEMP1
+ 10 CONTINUE
+*
+ PSI = ZERO
+ DO 20 J = 1, N - 2
+ PSI = PSI + Z( J )*Z( J ) / ( DELTA( J )*WORK( J ) )
+ 20 CONTINUE
+*
+ C = RHOINV + PSI
+ W = C + Z( II )*Z( II ) / ( DELTA( II )*WORK( II ) ) +
+ $ Z( N )*Z( N ) / ( DELTA( N )*WORK( N ) )
+*
+ IF( W.LE.ZERO ) THEN
+ TEMP1 = SQRT( D( N )*D( N )+RHO )
+ TEMP = Z( N-1 )*Z( N-1 ) / ( ( D( N-1 )+TEMP1 )*
+ $ ( D( N )-D( N-1 )+RHO / ( D( N )+TEMP1 ) ) ) +
+ $ Z( N )*Z( N ) / RHO
+*
+* The following TAU is to approximate
+* SIGMA_n^2 - D( N )*D( N )
+*
+ IF( C.LE.TEMP ) THEN
+ TAU = RHO
+ ELSE
+ DELSQ = ( D( N )-D( N-1 ) )*( D( N )+D( N-1 ) )
+ A = -C*DELSQ + Z( N-1 )*Z( N-1 ) + Z( N )*Z( N )
+ B = Z( N )*Z( N )*DELSQ
+ IF( A.LT.ZERO ) THEN
+ TAU = TWO*B / ( SQRT( A*A+FOUR*B*C )-A )
+ ELSE
+ TAU = ( A+SQRT( A*A+FOUR*B*C ) ) / ( TWO*C )
+ END IF
+ END IF
+*
+* It can be proved that
+* D(N)^2+RHO/2 <= SIGMA_n^2 < D(N)^2+TAU <= D(N)^2+RHO
+*
+ ELSE
+ DELSQ = ( D( N )-D( N-1 ) )*( D( N )+D( N-1 ) )
+ A = -C*DELSQ + Z( N-1 )*Z( N-1 ) + Z( N )*Z( N )
+ B = Z( N )*Z( N )*DELSQ
+*
+* The following TAU is to approximate
+* SIGMA_n^2 - D( N )*D( N )
+*
+ IF( A.LT.ZERO ) THEN
+ TAU = TWO*B / ( SQRT( A*A+FOUR*B*C )-A )
+ ELSE
+ TAU = ( A+SQRT( A*A+FOUR*B*C ) ) / ( TWO*C )
+ END IF
+*
+* It can be proved that
+* D(N)^2 < D(N)^2+TAU < SIGMA(N)^2 < D(N)^2+RHO/2
+*
+ END IF
+*
+* The following ETA is to approximate SIGMA_n - D( N )
+*
+ ETA = TAU / ( D( N )+SQRT( D( N )*D( N )+TAU ) )
+*
+ SIGMA = D( N ) + ETA
+ DO 30 J = 1, N
+ DELTA( J ) = ( D( J )-D( I ) ) - ETA
+ WORK( J ) = D( J ) + D( I ) + ETA
+ 30 CONTINUE
+*
+* Evaluate PSI and the derivative DPSI
+*
+ DPSI = ZERO
+ PSI = ZERO
+ ERRETM = ZERO
+ DO 40 J = 1, II
+ TEMP = Z( J ) / ( DELTA( J )*WORK( J ) )
+ PSI = PSI + Z( J )*TEMP
+ DPSI = DPSI + TEMP*TEMP
+ ERRETM = ERRETM + PSI
+ 40 CONTINUE
+ ERRETM = ABS( ERRETM )
+*
+* Evaluate PHI and the derivative DPHI
+*
+ TEMP = Z( N ) / ( DELTA( N )*WORK( N ) )
+ PHI = Z( N )*TEMP
+ DPHI = TEMP*TEMP
+ ERRETM = EIGHT*( -PHI-PSI ) + ERRETM - PHI + RHOINV +
+ $ ABS( TAU )*( DPSI+DPHI )
+*
+ W = RHOINV + PHI + PSI
+*
+* Test for convergence
+*
+ IF( ABS( W ).LE.EPS*ERRETM ) THEN
+ GO TO 240
+ END IF
+*
+* Calculate the new step
+*
+ NITER = NITER + 1
+ DTNSQ1 = WORK( N-1 )*DELTA( N-1 )
+ DTNSQ = WORK( N )*DELTA( N )
+ C = W - DTNSQ1*DPSI - DTNSQ*DPHI
+ A = ( DTNSQ+DTNSQ1 )*W - DTNSQ*DTNSQ1*( DPSI+DPHI )
+ B = DTNSQ*DTNSQ1*W
+ IF( C.LT.ZERO )
+ $ C = ABS( C )
+ IF( C.EQ.ZERO ) THEN
+ ETA = RHO - SIGMA*SIGMA
+ ELSE IF( A.GE.ZERO ) THEN
+ ETA = ( A+SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C )
+ ELSE
+ ETA = TWO*B / ( A-SQRT( ABS( A*A-FOUR*B*C ) ) )
+ END IF
+*
+* Note, eta should be positive if w is negative, and
+* eta should be negative otherwise. However,
+* if for some reason caused by roundoff, eta*w > 0,
+* we simply use one Newton step instead. This way
+* will guarantee eta*w < 0.
+*
+ IF( W*ETA.GT.ZERO )
+ $ ETA = -W / ( DPSI+DPHI )
+ TEMP = ETA - DTNSQ
+ IF( TEMP.GT.RHO )
+ $ ETA = RHO + DTNSQ
+*
+ TAU = TAU + ETA
+ ETA = ETA / ( SIGMA+SQRT( ETA+SIGMA*SIGMA ) )
+ DO 50 J = 1, N
+ DELTA( J ) = DELTA( J ) - ETA
+ WORK( J ) = WORK( J ) + ETA
+ 50 CONTINUE
+*
+ SIGMA = SIGMA + ETA
+*
+* Evaluate PSI and the derivative DPSI
+*
+ DPSI = ZERO
+ PSI = ZERO
+ ERRETM = ZERO
+ DO 60 J = 1, II
+ TEMP = Z( J ) / ( WORK( J )*DELTA( J ) )
+ PSI = PSI + Z( J )*TEMP
+ DPSI = DPSI + TEMP*TEMP
+ ERRETM = ERRETM + PSI
+ 60 CONTINUE
+ ERRETM = ABS( ERRETM )
+*
+* Evaluate PHI and the derivative DPHI
+*
+ TEMP = Z( N ) / ( WORK( N )*DELTA( N ) )
+ PHI = Z( N )*TEMP
+ DPHI = TEMP*TEMP
+ ERRETM = EIGHT*( -PHI-PSI ) + ERRETM - PHI + RHOINV +
+ $ ABS( TAU )*( DPSI+DPHI )
+*
+ W = RHOINV + PHI + PSI
+*
+* Main loop to update the values of the array DELTA
+*
+ ITER = NITER + 1
+*
+ DO 90 NITER = ITER, MAXIT
+*
+* Test for convergence
+*
+ IF( ABS( W ).LE.EPS*ERRETM ) THEN
+ GO TO 240
+ END IF
+*
+* Calculate the new step
+*
+ DTNSQ1 = WORK( N-1 )*DELTA( N-1 )
+ DTNSQ = WORK( N )*DELTA( N )
+ C = W - DTNSQ1*DPSI - DTNSQ*DPHI
+ A = ( DTNSQ+DTNSQ1 )*W - DTNSQ1*DTNSQ*( DPSI+DPHI )
+ B = DTNSQ1*DTNSQ*W
+ IF( A.GE.ZERO ) THEN
+ ETA = ( A+SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C )
+ ELSE
+ ETA = TWO*B / ( A-SQRT( ABS( A*A-FOUR*B*C ) ) )
+ END IF
+*
+* Note, eta should be positive if w is negative, and
+* eta should be negative otherwise. However,
+* if for some reason caused by roundoff, eta*w > 0,
+* we simply use one Newton step instead. This way
+* will guarantee eta*w < 0.
+*
+ IF( W*ETA.GT.ZERO )
+ $ ETA = -W / ( DPSI+DPHI )
+ TEMP = ETA - DTNSQ
+ IF( TEMP.LE.ZERO )
+ $ ETA = ETA / TWO
+*
+ TAU = TAU + ETA
+ ETA = ETA / ( SIGMA+SQRT( ETA+SIGMA*SIGMA ) )
+ DO 70 J = 1, N
+ DELTA( J ) = DELTA( J ) - ETA
+ WORK( J ) = WORK( J ) + ETA
+ 70 CONTINUE
+*
+ SIGMA = SIGMA + ETA
+*
+* Evaluate PSI and the derivative DPSI
+*
+ DPSI = ZERO
+ PSI = ZERO
+ ERRETM = ZERO
+ DO 80 J = 1, II
+ TEMP = Z( J ) / ( WORK( J )*DELTA( J ) )
+ PSI = PSI + Z( J )*TEMP
+ DPSI = DPSI + TEMP*TEMP
+ ERRETM = ERRETM + PSI
+ 80 CONTINUE
+ ERRETM = ABS( ERRETM )
+*
+* Evaluate PHI and the derivative DPHI
+*
+ TEMP = Z( N ) / ( WORK( N )*DELTA( N ) )
+ PHI = Z( N )*TEMP
+ DPHI = TEMP*TEMP
+ ERRETM = EIGHT*( -PHI-PSI ) + ERRETM - PHI + RHOINV +
+ $ ABS( TAU )*( DPSI+DPHI )
+*
+ W = RHOINV + PHI + PSI
+ 90 CONTINUE
+*
+* Return with INFO = 1, NITER = MAXIT and not converged
+*
+ INFO = 1
+ GO TO 240
+*
+* End for the case I = N
+*
+ ELSE
+*
+* The case for I < N
+*
+ NITER = 1
+ IP1 = I + 1
+*
+* Calculate initial guess
+*
+ DELSQ = ( D( IP1 )-D( I ) )*( D( IP1 )+D( I ) )
+ DELSQ2 = DELSQ / TWO
+ TEMP = DELSQ2 / ( D( I )+SQRT( D( I )*D( I )+DELSQ2 ) )
+ DO 100 J = 1, N
+ WORK( J ) = D( J ) + D( I ) + TEMP
+ DELTA( J ) = ( D( J )-D( I ) ) - TEMP
+ 100 CONTINUE
+*
+ PSI = ZERO
+ DO 110 J = 1, I - 1
+ PSI = PSI + Z( J )*Z( J ) / ( WORK( J )*DELTA( J ) )
+ 110 CONTINUE
+*
+ PHI = ZERO
+ DO 120 J = N, I + 2, -1
+ PHI = PHI + Z( J )*Z( J ) / ( WORK( J )*DELTA( J ) )
+ 120 CONTINUE
+ C = RHOINV + PSI + PHI
+ W = C + Z( I )*Z( I ) / ( WORK( I )*DELTA( I ) ) +
+ $ Z( IP1 )*Z( IP1 ) / ( WORK( IP1 )*DELTA( IP1 ) )
+*
+ IF( W.GT.ZERO ) THEN
+*
+* d(i)^2 < the ith sigma^2 < (d(i)^2+d(i+1)^2)/2
+*
+* We choose d(i) as origin.
+*
+ ORGATI = .TRUE.
+ SG2LB = ZERO
+ SG2UB = DELSQ2
+ A = C*DELSQ + Z( I )*Z( I ) + Z( IP1 )*Z( IP1 )
+ B = Z( I )*Z( I )*DELSQ
+ IF( A.GT.ZERO ) THEN
+ TAU = TWO*B / ( A+SQRT( ABS( A*A-FOUR*B*C ) ) )
+ ELSE
+ TAU = ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C )
+ END IF
+*
+* TAU now is an estimation of SIGMA^2 - D( I )^2. The
+* following, however, is the corresponding estimation of
+* SIGMA - D( I ).
+*
+ ETA = TAU / ( D( I )+SQRT( D( I )*D( I )+TAU ) )
+ ELSE
+*
+* (d(i)^2+d(i+1)^2)/2 <= the ith sigma^2 < d(i+1)^2/2
+*
+* We choose d(i+1) as origin.
+*
+ ORGATI = .FALSE.
+ SG2LB = -DELSQ2
+ SG2UB = ZERO
+ A = C*DELSQ - Z( I )*Z( I ) - Z( IP1 )*Z( IP1 )
+ B = Z( IP1 )*Z( IP1 )*DELSQ
+ IF( A.LT.ZERO ) THEN
+ TAU = TWO*B / ( A-SQRT( ABS( A*A+FOUR*B*C ) ) )
+ ELSE
+ TAU = -( A+SQRT( ABS( A*A+FOUR*B*C ) ) ) / ( TWO*C )
+ END IF
+*
+* TAU now is an estimation of SIGMA^2 - D( IP1 )^2. The
+* following, however, is the corresponding estimation of
+* SIGMA - D( IP1 ).
+*
+ ETA = TAU / ( D( IP1 )+SQRT( ABS( D( IP1 )*D( IP1 )+
+ $ TAU ) ) )
+ END IF
+*
+ IF( ORGATI ) THEN
+ II = I
+ SIGMA = D( I ) + ETA
+ DO 130 J = 1, N
+ WORK( J ) = D( J ) + D( I ) + ETA
+ DELTA( J ) = ( D( J )-D( I ) ) - ETA
+ 130 CONTINUE
+ ELSE
+ II = I + 1
+ SIGMA = D( IP1 ) + ETA
+ DO 140 J = 1, N
+ WORK( J ) = D( J ) + D( IP1 ) + ETA
+ DELTA( J ) = ( D( J )-D( IP1 ) ) - ETA
+ 140 CONTINUE
+ END IF
+ IIM1 = II - 1
+ IIP1 = II + 1
+*
+* Evaluate PSI and the derivative DPSI
+*
+ DPSI = ZERO
+ PSI = ZERO
+ ERRETM = ZERO
+ DO 150 J = 1, IIM1
+ TEMP = Z( J ) / ( WORK( J )*DELTA( J ) )
+ PSI = PSI + Z( J )*TEMP
+ DPSI = DPSI + TEMP*TEMP
+ ERRETM = ERRETM + PSI
+ 150 CONTINUE
+ ERRETM = ABS( ERRETM )
+*
+* Evaluate PHI and the derivative DPHI
+*
+ DPHI = ZERO
+ PHI = ZERO
+ DO 160 J = N, IIP1, -1
+ TEMP = Z( J ) / ( WORK( J )*DELTA( J ) )
+ PHI = PHI + Z( J )*TEMP
+ DPHI = DPHI + TEMP*TEMP
+ ERRETM = ERRETM + PHI
+ 160 CONTINUE
+*
+ W = RHOINV + PHI + PSI
+*
+* W is the value of the secular function with
+* its ii-th element removed.
+*
+ SWTCH3 = .FALSE.
+ IF( ORGATI ) THEN
+ IF( W.LT.ZERO )
+ $ SWTCH3 = .TRUE.
+ ELSE
+ IF( W.GT.ZERO )
+ $ SWTCH3 = .TRUE.
+ END IF
+ IF( II.EQ.1 .OR. II.EQ.N )
+ $ SWTCH3 = .FALSE.
+*
+ TEMP = Z( II ) / ( WORK( II )*DELTA( II ) )
+ DW = DPSI + DPHI + TEMP*TEMP
+ TEMP = Z( II )*TEMP
+ W = W + TEMP
+ ERRETM = EIGHT*( PHI-PSI ) + ERRETM + TWO*RHOINV +
+ $ THREE*ABS( TEMP ) + ABS( TAU )*DW
+*
+* Test for convergence
+*
+ IF( ABS( W ).LE.EPS*ERRETM ) THEN
+ GO TO 240
+ END IF
+*
+ IF( W.LE.ZERO ) THEN
+ SG2LB = MAX( SG2LB, TAU )
+ ELSE
+ SG2UB = MIN( SG2UB, TAU )
+ END IF
+*
+* Calculate the new step
+*
+ NITER = NITER + 1
+ IF( .NOT.SWTCH3 ) THEN
+ DTIPSQ = WORK( IP1 )*DELTA( IP1 )
+ DTISQ = WORK( I )*DELTA( I )
+ IF( ORGATI ) THEN
+ C = W - DTIPSQ*DW + DELSQ*( Z( I ) / DTISQ )**2
+ ELSE
+ C = W - DTISQ*DW - DELSQ*( Z( IP1 ) / DTIPSQ )**2
+ END IF
+ A = ( DTIPSQ+DTISQ )*W - DTIPSQ*DTISQ*DW
+ B = DTIPSQ*DTISQ*W
+ IF( C.EQ.ZERO ) THEN
+ IF( A.EQ.ZERO ) THEN
+ IF( ORGATI ) THEN
+ A = Z( I )*Z( I ) + DTIPSQ*DTIPSQ*( DPSI+DPHI )
+ ELSE
+ A = Z( IP1 )*Z( IP1 ) + DTISQ*DTISQ*( DPSI+DPHI )
+ END IF
+ END IF
+ ETA = B / A
+ ELSE IF( A.LE.ZERO ) THEN
+ ETA = ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C )
+ ELSE
+ ETA = TWO*B / ( A+SQRT( ABS( A*A-FOUR*B*C ) ) )
+ END IF
+ ELSE
+*
+* Interpolation using THREE most relevant poles
+*
+ DTIIM = WORK( IIM1 )*DELTA( IIM1 )
+ DTIIP = WORK( IIP1 )*DELTA( IIP1 )
+ TEMP = RHOINV + PSI + PHI
+ IF( ORGATI ) THEN
+ TEMP1 = Z( IIM1 ) / DTIIM
+ TEMP1 = TEMP1*TEMP1
+ C = ( TEMP - DTIIP*( DPSI+DPHI ) ) -
+ $ ( D( IIM1 )-D( IIP1 ) )*( D( IIM1 )+D( IIP1 ) )*TEMP1
+ ZZ( 1 ) = Z( IIM1 )*Z( IIM1 )
+ IF( DPSI.LT.TEMP1 ) THEN
+ ZZ( 3 ) = DTIIP*DTIIP*DPHI
+ ELSE
+ ZZ( 3 ) = DTIIP*DTIIP*( ( DPSI-TEMP1 )+DPHI )
+ END IF
+ ELSE
+ TEMP1 = Z( IIP1 ) / DTIIP
+ TEMP1 = TEMP1*TEMP1
+ C = ( TEMP - DTIIM*( DPSI+DPHI ) ) -
+ $ ( D( IIP1 )-D( IIM1 ) )*( D( IIM1 )+D( IIP1 ) )*TEMP1
+ IF( DPHI.LT.TEMP1 ) THEN
+ ZZ( 1 ) = DTIIM*DTIIM*DPSI
+ ELSE
+ ZZ( 1 ) = DTIIM*DTIIM*( DPSI+( DPHI-TEMP1 ) )
+ END IF
+ ZZ( 3 ) = Z( IIP1 )*Z( IIP1 )
+ END IF
+ ZZ( 2 ) = Z( II )*Z( II )
+ DD( 1 ) = DTIIM
+ DD( 2 ) = DELTA( II )*WORK( II )
+ DD( 3 ) = DTIIP
+ CALL DLAED6( NITER, ORGATI, C, DD, ZZ, W, ETA, INFO )
+ IF( INFO.NE.0 )
+ $ GO TO 240
+ END IF
+*
+* Note, eta should be positive if w is negative, and
+* eta should be negative otherwise. However,
+* if for some reason caused by roundoff, eta*w > 0,
+* we simply use one Newton step instead. This way
+* will guarantee eta*w < 0.
+*
+ IF( W*ETA.GE.ZERO )
+ $ ETA = -W / DW
+ IF( ORGATI ) THEN
+ TEMP1 = WORK( I )*DELTA( I )
+ TEMP = ETA - TEMP1
+ ELSE
+ TEMP1 = WORK( IP1 )*DELTA( IP1 )
+ TEMP = ETA - TEMP1
+ END IF
+ IF( TEMP.GT.SG2UB .OR. TEMP.LT.SG2LB ) THEN
+ IF( W.LT.ZERO ) THEN
+ ETA = ( SG2UB-TAU ) / TWO
+ ELSE
+ ETA = ( SG2LB-TAU ) / TWO
+ END IF
+ END IF
+*
+ TAU = TAU + ETA
+ ETA = ETA / ( SIGMA+SQRT( SIGMA*SIGMA+ETA ) )
+*
+ PREW = W
+*
+ SIGMA = SIGMA + ETA
+ DO 170 J = 1, N
+ WORK( J ) = WORK( J ) + ETA
+ DELTA( J ) = DELTA( J ) - ETA
+ 170 CONTINUE
+*
+* Evaluate PSI and the derivative DPSI
+*
+ DPSI = ZERO
+ PSI = ZERO
+ ERRETM = ZERO
+ DO 180 J = 1, IIM1
+ TEMP = Z( J ) / ( WORK( J )*DELTA( J ) )
+ PSI = PSI + Z( J )*TEMP
+ DPSI = DPSI + TEMP*TEMP
+ ERRETM = ERRETM + PSI
+ 180 CONTINUE
+ ERRETM = ABS( ERRETM )
+*
+* Evaluate PHI and the derivative DPHI
+*
+ DPHI = ZERO
+ PHI = ZERO
+ DO 190 J = N, IIP1, -1
+ TEMP = Z( J ) / ( WORK( J )*DELTA( J ) )
+ PHI = PHI + Z( J )*TEMP
+ DPHI = DPHI + TEMP*TEMP
+ ERRETM = ERRETM + PHI
+ 190 CONTINUE
+*
+ TEMP = Z( II ) / ( WORK( II )*DELTA( II ) )
+ DW = DPSI + DPHI + TEMP*TEMP
+ TEMP = Z( II )*TEMP
+ W = RHOINV + PHI + PSI + TEMP
+ ERRETM = EIGHT*( PHI-PSI ) + ERRETM + TWO*RHOINV +
+ $ THREE*ABS( TEMP ) + ABS( TAU )*DW
+*
+ IF( W.LE.ZERO ) THEN
+ SG2LB = MAX( SG2LB, TAU )
+ ELSE
+ SG2UB = MIN( SG2UB, TAU )
+ END IF
+*
+ SWTCH = .FALSE.
+ IF( ORGATI ) THEN
+ IF( -W.GT.ABS( PREW ) / TEN )
+ $ SWTCH = .TRUE.
+ ELSE
+ IF( W.GT.ABS( PREW ) / TEN )
+ $ SWTCH = .TRUE.
+ END IF
+*
+* Main loop to update the values of the array DELTA and WORK
+*
+ ITER = NITER + 1
+*
+ DO 230 NITER = ITER, MAXIT
+*
+* Test for convergence
+*
+ IF( ABS( W ).LE.EPS*ERRETM ) THEN
+ GO TO 240
+ END IF
+*
+* Calculate the new step
+*
+ IF( .NOT.SWTCH3 ) THEN
+ DTIPSQ = WORK( IP1 )*DELTA( IP1 )
+ DTISQ = WORK( I )*DELTA( I )
+ IF( .NOT.SWTCH ) THEN
+ IF( ORGATI ) THEN
+ C = W - DTIPSQ*DW + DELSQ*( Z( I ) / DTISQ )**2
+ ELSE
+ C = W - DTISQ*DW - DELSQ*( Z( IP1 ) / DTIPSQ )**2
+ END IF
+ ELSE
+ TEMP = Z( II ) / ( WORK( II )*DELTA( II ) )
+ IF( ORGATI ) THEN
+ DPSI = DPSI + TEMP*TEMP
+ ELSE
+ DPHI = DPHI + TEMP*TEMP
+ END IF
+ C = W - DTISQ*DPSI - DTIPSQ*DPHI
+ END IF
+ A = ( DTIPSQ+DTISQ )*W - DTIPSQ*DTISQ*DW
+ B = DTIPSQ*DTISQ*W
+ IF( C.EQ.ZERO ) THEN
+ IF( A.EQ.ZERO ) THEN
+ IF( .NOT.SWTCH ) THEN
+ IF( ORGATI ) THEN
+ A = Z( I )*Z( I ) + DTIPSQ*DTIPSQ*
+ $ ( DPSI+DPHI )
+ ELSE
+ A = Z( IP1 )*Z( IP1 ) +
+ $ DTISQ*DTISQ*( DPSI+DPHI )
+ END IF
+ ELSE
+ A = DTISQ*DTISQ*DPSI + DTIPSQ*DTIPSQ*DPHI
+ END IF
+ END IF
+ ETA = B / A
+ ELSE IF( A.LE.ZERO ) THEN
+ ETA = ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C )
+ ELSE
+ ETA = TWO*B / ( A+SQRT( ABS( A*A-FOUR*B*C ) ) )
+ END IF
+ ELSE
+*
+* Interpolation using THREE most relevant poles
+*
+ DTIIM = WORK( IIM1 )*DELTA( IIM1 )
+ DTIIP = WORK( IIP1 )*DELTA( IIP1 )
+ TEMP = RHOINV + PSI + PHI
+ IF( SWTCH ) THEN
+ C = TEMP - DTIIM*DPSI - DTIIP*DPHI
+ ZZ( 1 ) = DTIIM*DTIIM*DPSI
+ ZZ( 3 ) = DTIIP*DTIIP*DPHI
+ ELSE
+ IF( ORGATI ) THEN
+ TEMP1 = Z( IIM1 ) / DTIIM
+ TEMP1 = TEMP1*TEMP1
+ TEMP2 = ( D( IIM1 )-D( IIP1 ) )*
+ $ ( D( IIM1 )+D( IIP1 ) )*TEMP1
+ C = TEMP - DTIIP*( DPSI+DPHI ) - TEMP2
+ ZZ( 1 ) = Z( IIM1 )*Z( IIM1 )
+ IF( DPSI.LT.TEMP1 ) THEN
+ ZZ( 3 ) = DTIIP*DTIIP*DPHI
+ ELSE
+ ZZ( 3 ) = DTIIP*DTIIP*( ( DPSI-TEMP1 )+DPHI )
+ END IF
+ ELSE
+ TEMP1 = Z( IIP1 ) / DTIIP
+ TEMP1 = TEMP1*TEMP1
+ TEMP2 = ( D( IIP1 )-D( IIM1 ) )*
+ $ ( D( IIM1 )+D( IIP1 ) )*TEMP1
+ C = TEMP - DTIIM*( DPSI+DPHI ) - TEMP2
+ IF( DPHI.LT.TEMP1 ) THEN
+ ZZ( 1 ) = DTIIM*DTIIM*DPSI
+ ELSE
+ ZZ( 1 ) = DTIIM*DTIIM*( DPSI+( DPHI-TEMP1 ) )
+ END IF
+ ZZ( 3 ) = Z( IIP1 )*Z( IIP1 )
+ END IF
+ END IF
+ DD( 1 ) = DTIIM
+ DD( 2 ) = DELTA( II )*WORK( II )
+ DD( 3 ) = DTIIP
+ CALL DLAED6( NITER, ORGATI, C, DD, ZZ, W, ETA, INFO )
+ IF( INFO.NE.0 )
+ $ GO TO 240
+ END IF
+*
+* Note, eta should be positive if w is negative, and
+* eta should be negative otherwise. However,
+* if for some reason caused by roundoff, eta*w > 0,
+* we simply use one Newton step instead. This way
+* will guarantee eta*w < 0.
+*
+ IF( W*ETA.GE.ZERO )
+ $ ETA = -W / DW
+ IF( ORGATI ) THEN
+ TEMP1 = WORK( I )*DELTA( I )
+ TEMP = ETA - TEMP1
+ ELSE
+ TEMP1 = WORK( IP1 )*DELTA( IP1 )
+ TEMP = ETA - TEMP1
+ END IF
+ IF( TEMP.GT.SG2UB .OR. TEMP.LT.SG2LB ) THEN
+ IF( W.LT.ZERO ) THEN
+ ETA = ( SG2UB-TAU ) / TWO
+ ELSE
+ ETA = ( SG2LB-TAU ) / TWO
+ END IF
+ END IF
+*
+ TAU = TAU + ETA
+ ETA = ETA / ( SIGMA+SQRT( SIGMA*SIGMA+ETA ) )
+*
+ SIGMA = SIGMA + ETA
+ DO 200 J = 1, N
+ WORK( J ) = WORK( J ) + ETA
+ DELTA( J ) = DELTA( J ) - ETA
+ 200 CONTINUE
+*
+ PREW = W
+*
+* Evaluate PSI and the derivative DPSI
+*
+ DPSI = ZERO
+ PSI = ZERO
+ ERRETM = ZERO
+ DO 210 J = 1, IIM1
+ TEMP = Z( J ) / ( WORK( J )*DELTA( J ) )
+ PSI = PSI + Z( J )*TEMP
+ DPSI = DPSI + TEMP*TEMP
+ ERRETM = ERRETM + PSI
+ 210 CONTINUE
+ ERRETM = ABS( ERRETM )
+*
+* Evaluate PHI and the derivative DPHI
+*
+ DPHI = ZERO
+ PHI = ZERO
+ DO 220 J = N, IIP1, -1
+ TEMP = Z( J ) / ( WORK( J )*DELTA( J ) )
+ PHI = PHI + Z( J )*TEMP
+ DPHI = DPHI + TEMP*TEMP
+ ERRETM = ERRETM + PHI
+ 220 CONTINUE
+*
+ TEMP = Z( II ) / ( WORK( II )*DELTA( II ) )
+ DW = DPSI + DPHI + TEMP*TEMP
+ TEMP = Z( II )*TEMP
+ W = RHOINV + PHI + PSI + TEMP
+ ERRETM = EIGHT*( PHI-PSI ) + ERRETM + TWO*RHOINV +
+ $ THREE*ABS( TEMP ) + ABS( TAU )*DW
+ IF( W*PREW.GT.ZERO .AND. ABS( W ).GT.ABS( PREW ) / TEN )
+ $ SWTCH = .NOT.SWTCH
+*
+ IF( W.LE.ZERO ) THEN
+ SG2LB = MAX( SG2LB, TAU )
+ ELSE
+ SG2UB = MIN( SG2UB, TAU )
+ END IF
+*
+ 230 CONTINUE
+*
+* Return with INFO = 1, NITER = MAXIT and not converged
+*
+ INFO = 1
+*
+ END IF
+*
+ 240 CONTINUE
+ RETURN
+*
+* End of DLASD4
+*
+ END
+ SUBROUTINE DLASD5( I, D, Z, DELTA, RHO, DSIGMA, WORK )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER I
+ DOUBLE PRECISION DSIGMA, RHO
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION D( 2 ), DELTA( 2 ), WORK( 2 ), Z( 2 )
+* ..
+*
+* Purpose
+* =======
+*
+* This subroutine computes the square root of the I-th eigenvalue
+* of a positive symmetric rank-one modification of a 2-by-2 diagonal
+* matrix
+*
+* diag( D ) * diag( D ) + RHO * Z * transpose(Z) .
+*
+* The diagonal entries in the array D are assumed to satisfy
+*
+* 0 <= D(i) < D(j) for i < j .
+*
+* We also assume RHO > 0 and that the Euclidean norm of the vector
+* Z is one.
+*
+* Arguments
+* =========
+*
+* I (input) INTEGER
+* The index of the eigenvalue to be computed. I = 1 or I = 2.
+*
+* D (input) DOUBLE PRECISION array, dimension ( 2 )
+* The original eigenvalues. We assume 0 <= D(1) < D(2).
+*
+* Z (input) DOUBLE PRECISION array, dimension ( 2 )
+* The components of the updating vector.
+*
+* DELTA (output) DOUBLE PRECISION array, dimension ( 2 )
+* Contains (D(j) - sigma_I) in its j-th component.
+* The vector DELTA contains the information necessary
+* to construct the eigenvectors.
+*
+* RHO (input) DOUBLE PRECISION
+* The scalar in the symmetric updating formula.
+*
+* DSIGMA (output) DOUBLE PRECISION
+* The computed sigma_I, the I-th updated eigenvalue.
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension ( 2 )
+* WORK contains (D(j) + sigma_I) in its j-th component.
+*
+* Further Details
+* ===============
+*
+* Based on contributions by
+* Ren-Cang Li, Computer Science Division, University of California
+* at Berkeley, USA
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE, TWO, THREE, FOUR
+ PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0,
+ $ THREE = 3.0D+0, FOUR = 4.0D+0 )
+* ..
+* .. Local Scalars ..
+ DOUBLE PRECISION B, C, DEL, DELSQ, TAU, W
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, SQRT
+* ..
+* .. Executable Statements ..
+*
+ DEL = D( 2 ) - D( 1 )
+ DELSQ = DEL*( D( 2 )+D( 1 ) )
+ IF( I.EQ.1 ) THEN
+ W = ONE + FOUR*RHO*( Z( 2 )*Z( 2 ) / ( D( 1 )+THREE*D( 2 ) )-
+ $ Z( 1 )*Z( 1 ) / ( THREE*D( 1 )+D( 2 ) ) ) / DEL
+ IF( W.GT.ZERO ) THEN
+ B = DELSQ + RHO*( Z( 1 )*Z( 1 )+Z( 2 )*Z( 2 ) )
+ C = RHO*Z( 1 )*Z( 1 )*DELSQ
+*
+* B > ZERO, always
+*
+* The following TAU is DSIGMA * DSIGMA - D( 1 ) * D( 1 )
+*
+ TAU = TWO*C / ( B+SQRT( ABS( B*B-FOUR*C ) ) )
+*
+* The following TAU is DSIGMA - D( 1 )
+*
+ TAU = TAU / ( D( 1 )+SQRT( D( 1 )*D( 1 )+TAU ) )
+ DSIGMA = D( 1 ) + TAU
+ DELTA( 1 ) = -TAU
+ DELTA( 2 ) = DEL - TAU
+ WORK( 1 ) = TWO*D( 1 ) + TAU
+ WORK( 2 ) = ( D( 1 )+TAU ) + D( 2 )
+* DELTA( 1 ) = -Z( 1 ) / TAU
+* DELTA( 2 ) = Z( 2 ) / ( DEL-TAU )
+ ELSE
+ B = -DELSQ + RHO*( Z( 1 )*Z( 1 )+Z( 2 )*Z( 2 ) )
+ C = RHO*Z( 2 )*Z( 2 )*DELSQ
+*
+* The following TAU is DSIGMA * DSIGMA - D( 2 ) * D( 2 )
+*
+ IF( B.GT.ZERO ) THEN
+ TAU = -TWO*C / ( B+SQRT( B*B+FOUR*C ) )
+ ELSE
+ TAU = ( B-SQRT( B*B+FOUR*C ) ) / TWO
+ END IF
+*
+* The following TAU is DSIGMA - D( 2 )
+*
+ TAU = TAU / ( D( 2 )+SQRT( ABS( D( 2 )*D( 2 )+TAU ) ) )
+ DSIGMA = D( 2 ) + TAU
+ DELTA( 1 ) = -( DEL+TAU )
+ DELTA( 2 ) = -TAU
+ WORK( 1 ) = D( 1 ) + TAU + D( 2 )
+ WORK( 2 ) = TWO*D( 2 ) + TAU
+* DELTA( 1 ) = -Z( 1 ) / ( DEL+TAU )
+* DELTA( 2 ) = -Z( 2 ) / TAU
+ END IF
+* TEMP = SQRT( DELTA( 1 )*DELTA( 1 )+DELTA( 2 )*DELTA( 2 ) )
+* DELTA( 1 ) = DELTA( 1 ) / TEMP
+* DELTA( 2 ) = DELTA( 2 ) / TEMP
+ ELSE
+*
+* Now I=2
+*
+ B = -DELSQ + RHO*( Z( 1 )*Z( 1 )+Z( 2 )*Z( 2 ) )
+ C = RHO*Z( 2 )*Z( 2 )*DELSQ
+*
+* The following TAU is DSIGMA * DSIGMA - D( 2 ) * D( 2 )
+*
+ IF( B.GT.ZERO ) THEN
+ TAU = ( B+SQRT( B*B+FOUR*C ) ) / TWO
+ ELSE
+ TAU = TWO*C / ( -B+SQRT( B*B+FOUR*C ) )
+ END IF
+*
+* The following TAU is DSIGMA - D( 2 )
+*
+ TAU = TAU / ( D( 2 )+SQRT( D( 2 )*D( 2 )+TAU ) )
+ DSIGMA = D( 2 ) + TAU
+ DELTA( 1 ) = -( DEL+TAU )
+ DELTA( 2 ) = -TAU
+ WORK( 1 ) = D( 1 ) + TAU + D( 2 )
+ WORK( 2 ) = TWO*D( 2 ) + TAU
+* DELTA( 1 ) = -Z( 1 ) / ( DEL+TAU )
+* DELTA( 2 ) = -Z( 2 ) / TAU
+* TEMP = SQRT( DELTA( 1 )*DELTA( 1 )+DELTA( 2 )*DELTA( 2 ) )
+* DELTA( 1 ) = DELTA( 1 ) / TEMP
+* DELTA( 2 ) = DELTA( 2 ) / TEMP
+ END IF
+ RETURN
+*
+* End of DLASD5
+*
+ END
+ 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 )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER GIVPTR, ICOMPQ, INFO, K, LDGCOL, LDGNUM, NL,
+ $ NR, SQRE
+ DOUBLE PRECISION ALPHA, BETA, C, S
+* ..
+* .. Array Arguments ..
+ INTEGER GIVCOL( LDGCOL, * ), IDXQ( * ), IWORK( * ),
+ $ PERM( * )
+ DOUBLE PRECISION D( * ), DIFL( * ), DIFR( * ),
+ $ GIVNUM( LDGNUM, * ), POLES( LDGNUM, * ),
+ $ VF( * ), VL( * ), WORK( * ), Z( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DLASD6 computes the SVD of an updated upper bidiagonal matrix B
+* obtained by merging two smaller ones by appending a row. This
+* routine is used only for the problem which requires all singular
+* values and optionally singular vector matrices in factored form.
+* B is an N-by-M matrix with N = NL + NR + 1 and M = N + SQRE.
+* A related subroutine, DLASD1, handles the case in which all singular
+* values and singular vectors of the bidiagonal matrix are desired.
+*
+* DLASD6 computes the SVD as follows:
+*
+* ( D1(in) 0 0 0 )
+* B = U(in) * ( Z1' a Z2' b ) * VT(in)
+* ( 0 0 D2(in) 0 )
+*
+* = U(out) * ( D(out) 0) * VT(out)
+*
+* where Z' = (Z1' a Z2' b) = u' VT', and u is a vector of dimension M
+* with ALPHA and BETA in the NL+1 and NL+2 th entries and zeros
+* elsewhere; and the entry b is empty if SQRE = 0.
+*
+* The singular values of B can be computed using D1, D2, the first
+* components of all the right singular vectors of the lower block, and
+* the last components of all the right singular vectors of the upper
+* block. These components are stored and updated in VF and VL,
+* respectively, in DLASD6. Hence U and VT are not explicitly
+* referenced.
+*
+* The singular values are stored in D. The algorithm consists of two
+* stages:
+*
+* The first stage consists of deflating the size of the problem
+* when there are multiple singular values or if there is a zero
+* in the Z vector. For each such occurence the dimension of the
+* secular equation problem is reduced by one. This stage is
+* performed by the routine DLASD7.
+*
+* The second stage consists of calculating the updated
+* singular values. This is done by finding the roots of the
+* secular equation via the routine DLASD4 (as called by DLASD8).
+* This routine also updates VF and VL and computes the distances
+* between the updated singular values and the old singular
+* values.
+*
+* DLASD6 is called from DLASDA.
+*
+* Arguments
+* =========
+*
+* ICOMPQ (input) INTEGER
+* Specifies whether singular vectors are to be computed in
+* factored form:
+* = 0: Compute singular values only.
+* = 1: Compute singular vectors in factored form as well.
+*
+* NL (input) INTEGER
+* The row dimension of the upper block. NL >= 1.
+*
+* NR (input) INTEGER
+* The row dimension of the lower block. NR >= 1.
+*
+* SQRE (input) INTEGER
+* = 0: the lower block is an NR-by-NR square matrix.
+* = 1: the lower block is an NR-by-(NR+1) rectangular matrix.
+*
+* The bidiagonal matrix has row dimension N = NL + NR + 1,
+* and column dimension M = N + SQRE.
+*
+* D (input/output) DOUBLE PRECISION array, dimension ( NL+NR+1 ).
+* On entry D(1:NL,1:NL) contains the singular values of the
+* upper block, and D(NL+2:N) contains the singular values
+* of the lower block. On exit D(1:N) contains the singular
+* values of the modified matrix.
+*
+* VF (input/output) DOUBLE PRECISION array, dimension ( M )
+* On entry, VF(1:NL+1) contains the first components of all
+* right singular vectors of the upper block; and VF(NL+2:M)
+* contains the first components of all right singular vectors
+* of the lower block. On exit, VF contains the first components
+* of all right singular vectors of the bidiagonal matrix.
+*
+* VL (input/output) DOUBLE PRECISION array, dimension ( M )
+* On entry, VL(1:NL+1) contains the last components of all
+* right singular vectors of the upper block; and VL(NL+2:M)
+* contains the last components of all right singular vectors of
+* the lower block. On exit, VL contains the last components of
+* all right singular vectors of the bidiagonal matrix.
+*
+* ALPHA (input/output) DOUBLE PRECISION
+* Contains the diagonal element associated with the added row.
+*
+* BETA (input/output) DOUBLE PRECISION
+* Contains the off-diagonal element associated with the added
+* row.
+*
+* IDXQ (output) INTEGER array, dimension ( N )
+* This contains the permutation which will reintegrate the
+* subproblem just solved back into sorted order, i.e.
+* D( IDXQ( I = 1, N ) ) will be in ascending order.
+*
+* PERM (output) INTEGER array, dimension ( N )
+* The permutations (from deflation and sorting) to be applied
+* to each block. Not referenced if ICOMPQ = 0.
+*
+* GIVPTR (output) INTEGER
+* The number of Givens rotations which took place in this
+* subproblem. Not referenced if ICOMPQ = 0.
+*
+* GIVCOL (output) INTEGER array, dimension ( LDGCOL, 2 )
+* Each pair of numbers indicates a pair of columns to take place
+* in a Givens rotation. Not referenced if ICOMPQ = 0.
+*
+* LDGCOL (input) INTEGER
+* leading dimension of GIVCOL, must be at least N.
+*
+* GIVNUM (output) DOUBLE PRECISION array, dimension ( LDGNUM, 2 )
+* Each number indicates the C or S value to be used in the
+* corresponding Givens rotation. Not referenced if ICOMPQ = 0.
+*
+* LDGNUM (input) INTEGER
+* The leading dimension of GIVNUM and POLES, must be at least N.
+*
+* POLES (output) DOUBLE PRECISION array, dimension ( LDGNUM, 2 )
+* On exit, POLES(1,*) is an array containing the new singular
+* values obtained from solving the secular equation, and
+* POLES(2,*) is an array containing the poles in the secular
+* equation. Not referenced if ICOMPQ = 0.
+*
+* DIFL (output) DOUBLE PRECISION array, dimension ( N )
+* On exit, DIFL(I) is the distance between I-th updated
+* (undeflated) singular value and the I-th (undeflated) old
+* singular value.
+*
+* DIFR (output) DOUBLE PRECISION array,
+* dimension ( LDGNUM, 2 ) if ICOMPQ = 1 and
+* dimension ( N ) if ICOMPQ = 0.
+* On exit, DIFR(I, 1) is the distance between I-th updated
+* (undeflated) singular value and the I+1-th (undeflated) old
+* singular value.
+*
+* If ICOMPQ = 1, DIFR(1:K,2) is an array containing the
+* normalizing factors for the right singular vector matrix.
+*
+* See DLASD8 for details on DIFL and DIFR.
+*
+* Z (output) DOUBLE PRECISION array, dimension ( M )
+* The first elements of this array contain the components
+* of the deflation-adjusted updating row vector.
+*
+* K (output) INTEGER
+* Contains the dimension of the non-deflated matrix,
+* This is the order of the related secular equation. 1 <= K <=N.
+*
+* C (output) DOUBLE PRECISION
+* C contains garbage if SQRE =0 and the C-value of a Givens
+* rotation related to the right null space if SQRE = 1.
+*
+* S (output) DOUBLE PRECISION
+* S contains garbage if SQRE =0 and the S-value of a Givens
+* rotation related to the right null space if SQRE = 1.
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension ( 4 * M )
+*
+* IWORK (workspace) INTEGER array, dimension ( 3 * N )
+*
+* INFO (output) INTEGER
+* = 0: successful exit.
+* < 0: if INFO = -i, the i-th argument had an illegal value.
+* > 0: if INFO = 1, an singular value did not converge
+*
+* Further Details
+* ===============
+*
+* Based on contributions by
+* Ming Gu and Huan Ren, Computer Science Division, University of
+* California at Berkeley, USA
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE, ZERO
+ PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, IDX, IDXC, IDXP, ISIGMA, IVFW, IVLW, IW, M,
+ $ N, N1, N2
+ DOUBLE PRECISION ORGNRM
+* ..
+* .. External Subroutines ..
+ EXTERNAL DCOPY, DLAMRG, DLASCL, DLASD7, DLASD8, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ N = NL + NR + 1
+ M = N + SQRE
+*
+ IF( ( ICOMPQ.LT.0 ) .OR. ( ICOMPQ.GT.1 ) ) THEN
+ INFO = -1
+ ELSE IF( NL.LT.1 ) THEN
+ INFO = -2
+ ELSE IF( NR.LT.1 ) THEN
+ INFO = -3
+ ELSE IF( ( SQRE.LT.0 ) .OR. ( SQRE.GT.1 ) ) THEN
+ INFO = -4
+ ELSE IF( LDGCOL.LT.N ) THEN
+ INFO = -14
+ ELSE IF( LDGNUM.LT.N ) THEN
+ INFO = -16
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DLASD6', -INFO )
+ RETURN
+ END IF
+*
+* The following values are for bookkeeping purposes only. They are
+* integer pointers which indicate the portion of the workspace
+* used by a particular array in DLASD7 and DLASD8.
+*
+ ISIGMA = 1
+ IW = ISIGMA + N
+ IVFW = IW + M
+ IVLW = IVFW + M
+*
+ IDX = 1
+ IDXC = IDX + N
+ IDXP = IDXC + N
+*
+* Scale.
+*
+ ORGNRM = MAX( ABS( ALPHA ), ABS( BETA ) )
+ D( NL+1 ) = ZERO
+ DO 10 I = 1, N
+ IF( ABS( D( I ) ).GT.ORGNRM ) THEN
+ ORGNRM = ABS( D( I ) )
+ END IF
+ 10 CONTINUE
+ CALL DLASCL( 'G', 0, 0, ORGNRM, ONE, N, 1, D, N, INFO )
+ ALPHA = ALPHA / ORGNRM
+ BETA = BETA / ORGNRM
+*
+* Sort and Deflate singular values.
+*
+ CALL DLASD7( ICOMPQ, NL, NR, SQRE, K, D, Z, WORK( IW ), VF,
+ $ WORK( IVFW ), VL, WORK( IVLW ), ALPHA, BETA,
+ $ WORK( ISIGMA ), IWORK( IDX ), IWORK( IDXP ), IDXQ,
+ $ PERM, GIVPTR, GIVCOL, LDGCOL, GIVNUM, LDGNUM, C, S,
+ $ INFO )
+*
+* Solve Secular Equation, compute DIFL, DIFR, and update VF, VL.
+*
+ CALL DLASD8( ICOMPQ, K, D, Z, VF, VL, DIFL, DIFR, LDGNUM,
+ $ WORK( ISIGMA ), WORK( IW ), INFO )
+*
+* Save the poles if ICOMPQ = 1.
+*
+ IF( ICOMPQ.EQ.1 ) THEN
+ CALL DCOPY( K, D, 1, POLES( 1, 1 ), 1 )
+ CALL DCOPY( K, WORK( ISIGMA ), 1, POLES( 1, 2 ), 1 )
+ END IF
+*
+* Unscale.
+*
+ CALL DLASCL( 'G', 0, 0, ONE, ORGNRM, N, 1, D, N, INFO )
+*
+* Prepare the IDXQ sorting permutation.
+*
+ N1 = K
+ N2 = N - K
+ CALL DLAMRG( N1, N2, D, 1, -1, IDXQ )
+*
+ RETURN
+*
+* End of DLASD6
+*
+ END
+ 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 )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER GIVPTR, ICOMPQ, INFO, K, LDGCOL, LDGNUM, NL,
+ $ NR, SQRE
+ DOUBLE PRECISION ALPHA, BETA, C, S
+* ..
+* .. Array Arguments ..
+ INTEGER GIVCOL( LDGCOL, * ), IDX( * ), IDXP( * ),
+ $ IDXQ( * ), PERM( * )
+ DOUBLE PRECISION D( * ), DSIGMA( * ), GIVNUM( LDGNUM, * ),
+ $ VF( * ), VFW( * ), VL( * ), VLW( * ), Z( * ),
+ $ ZW( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DLASD7 merges the two sets of singular values together into a single
+* sorted set. Then it tries to deflate the size of the problem. There
+* are two ways in which deflation can occur: when two or more singular
+* values are close together or if there is a tiny entry in the Z
+* vector. For each such occurrence the order of the related
+* secular equation problem is reduced by one.
+*
+* DLASD7 is called from DLASD6.
+*
+* Arguments
+* =========
+*
+* ICOMPQ (input) INTEGER
+* Specifies whether singular vectors are to be computed
+* in compact form, as follows:
+* = 0: Compute singular values only.
+* = 1: Compute singular vectors of upper
+* bidiagonal matrix in compact form.
+*
+* NL (input) INTEGER
+* The row dimension of the upper block. NL >= 1.
+*
+* NR (input) INTEGER
+* The row dimension of the lower block. NR >= 1.
+*
+* SQRE (input) INTEGER
+* = 0: the lower block is an NR-by-NR square matrix.
+* = 1: the lower block is an NR-by-(NR+1) rectangular matrix.
+*
+* The bidiagonal matrix has
+* N = NL + NR + 1 rows and
+* M = N + SQRE >= N columns.
+*
+* K (output) INTEGER
+* Contains the dimension of the non-deflated matrix, this is
+* the order of the related secular equation. 1 <= K <=N.
+*
+* D (input/output) DOUBLE PRECISION array, dimension ( N )
+* On entry D contains the singular values of the two submatrices
+* to be combined. On exit D contains the trailing (N-K) updated
+* singular values (those which were deflated) sorted into
+* increasing order.
+*
+* Z (output) DOUBLE PRECISION array, dimension ( M )
+* On exit Z contains the updating row vector in the secular
+* equation.
+*
+* ZW (workspace) DOUBLE PRECISION array, dimension ( M )
+* Workspace for Z.
+*
+* VF (input/output) DOUBLE PRECISION array, dimension ( M )
+* On entry, VF(1:NL+1) contains the first components of all
+* right singular vectors of the upper block; and VF(NL+2:M)
+* contains the first components of all right singular vectors
+* of the lower block. On exit, VF contains the first components
+* of all right singular vectors of the bidiagonal matrix.
+*
+* VFW (workspace) DOUBLE PRECISION array, dimension ( M )
+* Workspace for VF.
+*
+* VL (input/output) DOUBLE PRECISION array, dimension ( M )
+* On entry, VL(1:NL+1) contains the last components of all
+* right singular vectors of the upper block; and VL(NL+2:M)
+* contains the last components of all right singular vectors
+* of the lower block. On exit, VL contains the last components
+* of all right singular vectors of the bidiagonal matrix.
+*
+* VLW (workspace) DOUBLE PRECISION array, dimension ( M )
+* Workspace for VL.
+*
+* ALPHA (input) DOUBLE PRECISION
+* Contains the diagonal element associated with the added row.
+*
+* BETA (input) DOUBLE PRECISION
+* Contains the off-diagonal element associated with the added
+* row.
+*
+* DSIGMA (output) DOUBLE PRECISION array, dimension ( N )
+* Contains a copy of the diagonal elements (K-1 singular values
+* and one zero) in the secular equation.
+*
+* IDX (workspace) INTEGER array, dimension ( N )
+* This will contain the permutation used to sort the contents of
+* D into ascending order.
+*
+* IDXP (workspace) INTEGER array, dimension ( N )
+* This will contain the permutation used to place deflated
+* values of D at the end of the array. On output IDXP(2:K)
+* points to the nondeflated D-values and IDXP(K+1:N)
+* points to the deflated singular values.
+*
+* IDXQ (input) INTEGER array, dimension ( N )
+* This contains the permutation which separately sorts the two
+* sub-problems in D into ascending order. Note that entries in
+* the first half of this permutation must first be moved one
+* position backward; and entries in the second half
+* must first have NL+1 added to their values.
+*
+* PERM (output) INTEGER array, dimension ( N )
+* The permutations (from deflation and sorting) to be applied
+* to each singular block. Not referenced if ICOMPQ = 0.
+*
+* GIVPTR (output) INTEGER
+* The number of Givens rotations which took place in this
+* subproblem. Not referenced if ICOMPQ = 0.
+*
+* GIVCOL (output) INTEGER array, dimension ( LDGCOL, 2 )
+* Each pair of numbers indicates a pair of columns to take place
+* in a Givens rotation. Not referenced if ICOMPQ = 0.
+*
+* LDGCOL (input) INTEGER
+* The leading dimension of GIVCOL, must be at least N.
+*
+* GIVNUM (output) DOUBLE PRECISION array, dimension ( LDGNUM, 2 )
+* Each number indicates the C or S value to be used in the
+* corresponding Givens rotation. Not referenced if ICOMPQ = 0.
+*
+* LDGNUM (input) INTEGER
+* The leading dimension of GIVNUM, must be at least N.
+*
+* C (output) DOUBLE PRECISION
+* C contains garbage if SQRE =0 and the C-value of a Givens
+* rotation related to the right null space if SQRE = 1.
+*
+* S (output) DOUBLE PRECISION
+* S contains garbage if SQRE =0 and the S-value of a Givens
+* rotation related to the right null space if SQRE = 1.
+*
+* INFO (output) INTEGER
+* = 0: successful exit.
+* < 0: if INFO = -i, the i-th argument had an illegal value.
+*
+* Further Details
+* ===============
+*
+* Based on contributions by
+* Ming Gu and Huan Ren, Computer Science Division, University of
+* California at Berkeley, USA
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE, TWO, EIGHT
+ PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0,
+ $ EIGHT = 8.0D+0 )
+* ..
+* .. Local Scalars ..
+*
+ INTEGER I, IDXI, IDXJ, IDXJP, J, JP, JPREV, K2, M, N,
+ $ NLP1, NLP2
+ DOUBLE PRECISION EPS, HLFTOL, TAU, TOL, Z1
+* ..
+* .. External Subroutines ..
+ EXTERNAL DCOPY, DLAMRG, DROT, XERBLA
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DLAMCH, DLAPY2
+ EXTERNAL DLAMCH, DLAPY2
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ N = NL + NR + 1
+ M = N + SQRE
+*
+ IF( ( ICOMPQ.LT.0 ) .OR. ( ICOMPQ.GT.1 ) ) THEN
+ INFO = -1
+ ELSE IF( NL.LT.1 ) THEN
+ INFO = -2
+ ELSE IF( NR.LT.1 ) THEN
+ INFO = -3
+ ELSE IF( ( SQRE.LT.0 ) .OR. ( SQRE.GT.1 ) ) THEN
+ INFO = -4
+ ELSE IF( LDGCOL.LT.N ) THEN
+ INFO = -22
+ ELSE IF( LDGNUM.LT.N ) THEN
+ INFO = -24
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DLASD7', -INFO )
+ RETURN
+ END IF
+*
+ NLP1 = NL + 1
+ NLP2 = NL + 2
+ IF( ICOMPQ.EQ.1 ) THEN
+ GIVPTR = 0
+ END IF
+*
+* Generate the first part of the vector Z and move the singular
+* values in the first part of D one position backward.
+*
+ Z1 = ALPHA*VL( NLP1 )
+ VL( NLP1 ) = ZERO
+ TAU = VF( NLP1 )
+ DO 10 I = NL, 1, -1
+ Z( I+1 ) = ALPHA*VL( I )
+ VL( I ) = ZERO
+ VF( I+1 ) = VF( I )
+ D( I+1 ) = D( I )
+ IDXQ( I+1 ) = IDXQ( I ) + 1
+ 10 CONTINUE
+ VF( 1 ) = TAU
+*
+* Generate the second part of the vector Z.
+*
+ DO 20 I = NLP2, M
+ Z( I ) = BETA*VF( I )
+ VF( I ) = ZERO
+ 20 CONTINUE
+*
+* Sort the singular values into increasing order
+*
+ DO 30 I = NLP2, N
+ IDXQ( I ) = IDXQ( I ) + NLP1
+ 30 CONTINUE
+*
+* DSIGMA, IDXC, IDXC, and ZW are used as storage space.
+*
+ DO 40 I = 2, N
+ DSIGMA( I ) = D( IDXQ( I ) )
+ ZW( I ) = Z( IDXQ( I ) )
+ VFW( I ) = VF( IDXQ( I ) )
+ VLW( I ) = VL( IDXQ( I ) )
+ 40 CONTINUE
+*
+ CALL DLAMRG( NL, NR, DSIGMA( 2 ), 1, 1, IDX( 2 ) )
+*
+ DO 50 I = 2, N
+ IDXI = 1 + IDX( I )
+ D( I ) = DSIGMA( IDXI )
+ Z( I ) = ZW( IDXI )
+ VF( I ) = VFW( IDXI )
+ VL( I ) = VLW( IDXI )
+ 50 CONTINUE
+*
+* Calculate the allowable deflation tolerence
+*
+ EPS = DLAMCH( 'Epsilon' )
+ TOL = MAX( ABS( ALPHA ), ABS( BETA ) )
+ TOL = EIGHT*EIGHT*EPS*MAX( ABS( D( N ) ), TOL )
+*
+* There are 2 kinds of deflation -- first a value in the z-vector
+* is small, second two (or more) singular values are very close
+* together (their difference is small).
+*
+* If the value in the z-vector is small, we simply permute the
+* array so that the corresponding singular value is moved to the
+* end.
+*
+* If two values in the D-vector are close, we perform a two-sided
+* rotation designed to make one of the corresponding z-vector
+* entries zero, and then permute the array so that the deflated
+* singular value is moved to the end.
+*
+* If there are multiple singular values then the problem deflates.
+* Here the number of equal singular values are found. As each equal
+* singular value is found, an elementary reflector is computed to
+* rotate the corresponding singular subspace so that the
+* corresponding components of Z are zero in this new basis.
+*
+ K = 1
+ K2 = N + 1
+ DO 60 J = 2, N
+ IF( ABS( Z( J ) ).LE.TOL ) THEN
+*
+* Deflate due to small z component.
+*
+ K2 = K2 - 1
+ IDXP( K2 ) = J
+ IF( J.EQ.N )
+ $ GO TO 100
+ ELSE
+ JPREV = J
+ GO TO 70
+ END IF
+ 60 CONTINUE
+ 70 CONTINUE
+ J = JPREV
+ 80 CONTINUE
+ J = J + 1
+ IF( J.GT.N )
+ $ GO TO 90
+ IF( ABS( Z( J ) ).LE.TOL ) THEN
+*
+* Deflate due to small z component.
+*
+ K2 = K2 - 1
+ IDXP( K2 ) = J
+ ELSE
+*
+* Check if singular values are close enough to allow deflation.
+*
+ IF( ABS( D( J )-D( JPREV ) ).LE.TOL ) THEN
+*
+* Deflation is possible.
+*
+ S = Z( JPREV )
+ C = Z( J )
+*
+* Find sqrt(a**2+b**2) without overflow or
+* destructive underflow.
+*
+ TAU = DLAPY2( C, S )
+ Z( J ) = TAU
+ Z( JPREV ) = ZERO
+ C = C / TAU
+ S = -S / TAU
+*
+* Record the appropriate Givens rotation
+*
+ IF( ICOMPQ.EQ.1 ) THEN
+ GIVPTR = GIVPTR + 1
+ IDXJP = IDXQ( IDX( JPREV )+1 )
+ IDXJ = IDXQ( IDX( J )+1 )
+ IF( IDXJP.LE.NLP1 ) THEN
+ IDXJP = IDXJP - 1
+ END IF
+ IF( IDXJ.LE.NLP1 ) THEN
+ IDXJ = IDXJ - 1
+ END IF
+ GIVCOL( GIVPTR, 2 ) = IDXJP
+ GIVCOL( GIVPTR, 1 ) = IDXJ
+ GIVNUM( GIVPTR, 2 ) = C
+ GIVNUM( GIVPTR, 1 ) = S
+ END IF
+ CALL DROT( 1, VF( JPREV ), 1, VF( J ), 1, C, S )
+ CALL DROT( 1, VL( JPREV ), 1, VL( J ), 1, C, S )
+ K2 = K2 - 1
+ IDXP( K2 ) = JPREV
+ JPREV = J
+ ELSE
+ K = K + 1
+ ZW( K ) = Z( JPREV )
+ DSIGMA( K ) = D( JPREV )
+ IDXP( K ) = JPREV
+ JPREV = J
+ END IF
+ END IF
+ GO TO 80
+ 90 CONTINUE
+*
+* Record the last singular value.
+*
+ K = K + 1
+ ZW( K ) = Z( JPREV )
+ DSIGMA( K ) = D( JPREV )
+ IDXP( K ) = JPREV
+*
+ 100 CONTINUE
+*
+* Sort the singular values into DSIGMA. The singular values which
+* were not deflated go into the first K slots of DSIGMA, except
+* that DSIGMA(1) is treated separately.
+*
+ DO 110 J = 2, N
+ JP = IDXP( J )
+ DSIGMA( J ) = D( JP )
+ VFW( J ) = VF( JP )
+ VLW( J ) = VL( JP )
+ 110 CONTINUE
+ IF( ICOMPQ.EQ.1 ) THEN
+ DO 120 J = 2, N
+ JP = IDXP( J )
+ PERM( J ) = IDXQ( IDX( JP )+1 )
+ IF( PERM( J ).LE.NLP1 ) THEN
+ PERM( J ) = PERM( J ) - 1
+ END IF
+ 120 CONTINUE
+ END IF
+*
+* The deflated singular values go back into the last N - K slots of
+* D.
+*
+ CALL DCOPY( N-K, DSIGMA( K+1 ), 1, D( K+1 ), 1 )
+*
+* Determine DSIGMA(1), DSIGMA(2), Z(1), VF(1), VL(1), VF(M), and
+* VL(M).
+*
+ DSIGMA( 1 ) = ZERO
+ HLFTOL = TOL / TWO
+ IF( ABS( DSIGMA( 2 ) ).LE.HLFTOL )
+ $ DSIGMA( 2 ) = HLFTOL
+ IF( M.GT.N ) THEN
+ Z( 1 ) = DLAPY2( Z1, Z( M ) )
+ IF( Z( 1 ).LE.TOL ) THEN
+ C = ONE
+ S = ZERO
+ Z( 1 ) = TOL
+ ELSE
+ C = Z1 / Z( 1 )
+ S = -Z( M ) / Z( 1 )
+ END IF
+ CALL DROT( 1, VF( M ), 1, VF( 1 ), 1, C, S )
+ CALL DROT( 1, VL( M ), 1, VL( 1 ), 1, C, S )
+ ELSE
+ IF( ABS( Z1 ).LE.TOL ) THEN
+ Z( 1 ) = TOL
+ ELSE
+ Z( 1 ) = Z1
+ END IF
+ END IF
+*
+* Restore Z, VF, and VL.
+*
+ CALL DCOPY( K-1, ZW( 2 ), 1, Z( 2 ), 1 )
+ CALL DCOPY( N-1, VFW( 2 ), 1, VF( 2 ), 1 )
+ CALL DCOPY( N-1, VLW( 2 ), 1, VL( 2 ), 1 )
+*
+ RETURN
+*
+* End of DLASD7
+*
+ END
+ SUBROUTINE DLASD8( ICOMPQ, K, D, Z, VF, VL, DIFL, DIFR, LDDIFR,
+ $ DSIGMA, WORK, INFO )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER ICOMPQ, INFO, K, LDDIFR
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION D( * ), DIFL( * ), DIFR( LDDIFR, * ),
+ $ DSIGMA( * ), VF( * ), VL( * ), WORK( * ),
+ $ Z( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DLASD8 finds the square roots of the roots of the secular equation,
+* as defined by the values in DSIGMA and Z. It makes the appropriate
+* calls to DLASD4, and stores, for each element in D, the distance
+* to its two nearest poles (elements in DSIGMA). It also updates
+* the arrays VF and VL, the first and last components of all the
+* right singular vectors of the original bidiagonal matrix.
+*
+* DLASD8 is called from DLASD6.
+*
+* Arguments
+* =========
+*
+* ICOMPQ (input) INTEGER
+* Specifies whether singular vectors are to be computed in
+* factored form in the calling routine:
+* = 0: Compute singular values only.
+* = 1: Compute singular vectors in factored form as well.
+*
+* K (input) INTEGER
+* The number of terms in the rational function to be solved
+* by DLASD4. K >= 1.
+*
+* D (output) DOUBLE PRECISION array, dimension ( K )
+* On output, D contains the updated singular values.
+*
+* Z (input) DOUBLE PRECISION array, dimension ( K )
+* The first K elements of this array contain the components
+* of the deflation-adjusted updating row vector.
+*
+* VF (input/output) DOUBLE PRECISION array, dimension ( K )
+* On entry, VF contains information passed through DBEDE8.
+* On exit, VF contains the first K components of the first
+* components of all right singular vectors of the bidiagonal
+* matrix.
+*
+* VL (input/output) DOUBLE PRECISION array, dimension ( K )
+* On entry, VL contains information passed through DBEDE8.
+* On exit, VL contains the first K components of the last
+* components of all right singular vectors of the bidiagonal
+* matrix.
+*
+* DIFL (output) DOUBLE PRECISION array, dimension ( K )
+* On exit, DIFL(I) = D(I) - DSIGMA(I).
+*
+* DIFR (output) DOUBLE PRECISION array,
+* dimension ( LDDIFR, 2 ) if ICOMPQ = 1 and
+* dimension ( K ) if ICOMPQ = 0.
+* On exit, DIFR(I,1) = D(I) - DSIGMA(I+1), DIFR(K,1) is not
+* defined and will not be referenced.
+*
+* If ICOMPQ = 1, DIFR(1:K,2) is an array containing the
+* normalizing factors for the right singular vector matrix.
+*
+* LDDIFR (input) INTEGER
+* The leading dimension of DIFR, must be at least K.
+*
+* DSIGMA (input) DOUBLE PRECISION array, dimension ( K )
+* The first K elements of this array contain the old roots
+* of the deflated updating problem. These are the poles
+* of the secular equation.
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension at least 3 * K
+*
+* INFO (output) INTEGER
+* = 0: successful exit.
+* < 0: if INFO = -i, the i-th argument had an illegal value.
+* > 0: if INFO = 1, an singular value did not converge
+*
+* Further Details
+* ===============
+*
+* Based on contributions by
+* Ming Gu and Huan Ren, Computer Science Division, University of
+* California at Berkeley, USA
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE
+ PARAMETER ( ONE = 1.0D+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, IWK1, IWK2, IWK2I, IWK3, IWK3I, J
+ DOUBLE PRECISION DIFLJ, DIFRJ, DJ, DSIGJ, DSIGJP, RHO, TEMP
+* ..
+* .. External Subroutines ..
+ EXTERNAL DCOPY, DLASCL, DLASD4, DLASET, XERBLA
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DDOT, DLAMC3, DNRM2
+ EXTERNAL DDOT, DLAMC3, DNRM2
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, SIGN, SQRT
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+*
+ IF( ( ICOMPQ.LT.0 ) .OR. ( ICOMPQ.GT.1 ) ) THEN
+ INFO = -1
+ ELSE IF( K.LT.1 ) THEN
+ INFO = -2
+ ELSE IF( LDDIFR.LT.K ) THEN
+ INFO = -9
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DLASD8', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( K.EQ.1 ) THEN
+ D( 1 ) = ABS( Z( 1 ) )
+ DIFL( 1 ) = D( 1 )
+ IF( ICOMPQ.EQ.1 ) THEN
+ DIFL( 2 ) = ONE
+ DIFR( 1, 2 ) = ONE
+ END IF
+ RETURN
+ END IF
+*
+* Modify values DSIGMA(i) to make sure all DSIGMA(i)-DSIGMA(j) can
+* be computed with high relative accuracy (barring over/underflow).
+* This is a problem on machines without a guard digit in
+* add/subtract (Cray XMP, Cray YMP, Cray C 90 and Cray 2).
+* The following code replaces DSIGMA(I) by 2*DSIGMA(I)-DSIGMA(I),
+* which on any of these machines zeros out the bottommost
+* bit of DSIGMA(I) if it is 1; this makes the subsequent
+* subtractions DSIGMA(I)-DSIGMA(J) unproblematic when cancellation
+* occurs. On binary machines with a guard digit (almost all
+* machines) it does not change DSIGMA(I) at all. On hexadecimal
+* and decimal machines with a guard digit, it slightly
+* changes the bottommost bits of DSIGMA(I). It does not account
+* for hexadecimal or decimal machines without guard digits
+* (we know of none). We use a subroutine call to compute
+* 2*DSIGMA(I) to prevent optimizing compilers from eliminating
+* this code.
+*
+ DO 10 I = 1, K
+ DSIGMA( I ) = DLAMC3( DSIGMA( I ), DSIGMA( I ) ) - DSIGMA( I )
+ 10 CONTINUE
+*
+* Book keeping.
+*
+ IWK1 = 1
+ IWK2 = IWK1 + K
+ IWK3 = IWK2 + K
+ IWK2I = IWK2 - 1
+ IWK3I = IWK3 - 1
+*
+* Normalize Z.
+*
+ RHO = DNRM2( K, Z, 1 )
+ CALL DLASCL( 'G', 0, 0, RHO, ONE, K, 1, Z, K, INFO )
+ RHO = RHO*RHO
+*
+* Initialize WORK(IWK3).
+*
+ CALL DLASET( 'A', K, 1, ONE, ONE, WORK( IWK3 ), K )
+*
+* Compute the updated singular values, the arrays DIFL, DIFR,
+* and the updated Z.
+*
+ DO 40 J = 1, K
+ CALL DLASD4( K, J, DSIGMA, Z, WORK( IWK1 ), RHO, D( J ),
+ $ WORK( IWK2 ), INFO )
+*
+* If the root finder fails, the computation is terminated.
+*
+ IF( INFO.NE.0 ) THEN
+ RETURN
+ END IF
+ WORK( IWK3I+J ) = WORK( IWK3I+J )*WORK( J )*WORK( IWK2I+J )
+ DIFL( J ) = -WORK( J )
+ DIFR( J, 1 ) = -WORK( J+1 )
+ DO 20 I = 1, J - 1
+ WORK( IWK3I+I ) = WORK( IWK3I+I )*WORK( I )*
+ $ WORK( IWK2I+I ) / ( DSIGMA( I )-
+ $ DSIGMA( J ) ) / ( DSIGMA( I )+
+ $ DSIGMA( J ) )
+ 20 CONTINUE
+ DO 30 I = J + 1, K
+ WORK( IWK3I+I ) = WORK( IWK3I+I )*WORK( I )*
+ $ WORK( IWK2I+I ) / ( DSIGMA( I )-
+ $ DSIGMA( J ) ) / ( DSIGMA( I )+
+ $ DSIGMA( J ) )
+ 30 CONTINUE
+ 40 CONTINUE
+*
+* Compute updated Z.
+*
+ DO 50 I = 1, K
+ Z( I ) = SIGN( SQRT( ABS( WORK( IWK3I+I ) ) ), Z( I ) )
+ 50 CONTINUE
+*
+* Update VF and VL.
+*
+ DO 80 J = 1, K
+ DIFLJ = DIFL( J )
+ DJ = D( J )
+ DSIGJ = -DSIGMA( J )
+ IF( J.LT.K ) THEN
+ DIFRJ = -DIFR( J, 1 )
+ DSIGJP = -DSIGMA( J+1 )
+ END IF
+ WORK( J ) = -Z( J ) / DIFLJ / ( DSIGMA( J )+DJ )
+ DO 60 I = 1, J - 1
+ WORK( I ) = Z( I ) / ( DLAMC3( DSIGMA( I ), DSIGJ )-DIFLJ )
+ $ / ( DSIGMA( I )+DJ )
+ 60 CONTINUE
+ DO 70 I = J + 1, K
+ WORK( I ) = Z( I ) / ( DLAMC3( DSIGMA( I ), DSIGJP )+DIFRJ )
+ $ / ( DSIGMA( I )+DJ )
+ 70 CONTINUE
+ TEMP = DNRM2( K, WORK, 1 )
+ WORK( IWK2I+J ) = DDOT( K, WORK, 1, VF, 1 ) / TEMP
+ WORK( IWK3I+J ) = DDOT( K, WORK, 1, VL, 1 ) / TEMP
+ IF( ICOMPQ.EQ.1 ) THEN
+ DIFR( J, 2 ) = TEMP
+ END IF
+ 80 CONTINUE
+*
+ CALL DCOPY( K, WORK( IWK2 ), 1, VF, 1 )
+ CALL DCOPY( K, WORK( IWK3 ), 1, VL, 1 )
+*
+ RETURN
+*
+* End of DLASD8
+*
+ END
+ 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 )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER ICOMPQ, INFO, LDGCOL, LDU, N, SMLSIZ, SQRE
+* ..
+* .. Array Arguments ..
+ INTEGER GIVCOL( LDGCOL, * ), GIVPTR( * ), IWORK( * ),
+ $ K( * ), PERM( LDGCOL, * )
+ DOUBLE PRECISION C( * ), D( * ), DIFL( LDU, * ), DIFR( LDU, * ),
+ $ E( * ), GIVNUM( LDU, * ), POLES( LDU, * ),
+ $ S( * ), U( LDU, * ), VT( LDU, * ), WORK( * ),
+ $ Z( LDU, * )
+* ..
+*
+* Purpose
+* =======
+*
+* Using a divide and conquer approach, DLASDA computes the singular
+* value decomposition (SVD) of a real upper bidiagonal N-by-M matrix
+* B with diagonal D and offdiagonal E, where M = N + SQRE. The
+* algorithm computes the singular values in the SVD B = U * S * VT.
+* The orthogonal matrices U and VT are optionally computed in
+* compact form.
+*
+* A related subroutine, DLASD0, computes the singular values and
+* the singular vectors in explicit form.
+*
+* Arguments
+* =========
+*
+* ICOMPQ (input) INTEGER
+* Specifies whether singular vectors are to be computed
+* in compact form, as follows
+* = 0: Compute singular values only.
+* = 1: Compute singular vectors of upper bidiagonal
+* matrix in compact form.
+*
+* SMLSIZ (input) INTEGER
+* The maximum size of the subproblems at the bottom of the
+* computation tree.
+*
+* N (input) INTEGER
+* The row dimension of the upper bidiagonal matrix. This is
+* also the dimension of the main diagonal array D.
+*
+* SQRE (input) INTEGER
+* Specifies the column dimension of the bidiagonal matrix.
+* = 0: The bidiagonal matrix has column dimension M = N;
+* = 1: The bidiagonal matrix has column dimension M = N + 1.
+*
+* D (input/output) DOUBLE PRECISION array, dimension ( N )
+* On entry D contains the main diagonal of the bidiagonal
+* matrix. On exit D, if INFO = 0, contains its singular values.
+*
+* E (input) DOUBLE PRECISION array, dimension ( M-1 )
+* Contains the subdiagonal entries of the bidiagonal matrix.
+* On exit, E has been destroyed.
+*
+* U (output) DOUBLE PRECISION array,
+* dimension ( LDU, SMLSIZ ) if ICOMPQ = 1, and not referenced
+* if ICOMPQ = 0. If ICOMPQ = 1, on exit, U contains the left
+* singular vector matrices of all subproblems at the bottom
+* level.
+*
+* LDU (input) INTEGER, LDU = > N.
+* The leading dimension of arrays U, VT, DIFL, DIFR, POLES,
+* GIVNUM, and Z.
+*
+* VT (output) DOUBLE PRECISION array,
+* dimension ( LDU, SMLSIZ+1 ) if ICOMPQ = 1, and not referenced
+* if ICOMPQ = 0. If ICOMPQ = 1, on exit, VT' contains the right
+* singular vector matrices of all subproblems at the bottom
+* level.
+*
+* K (output) INTEGER array,
+* dimension ( N ) if ICOMPQ = 1 and dimension 1 if ICOMPQ = 0.
+* If ICOMPQ = 1, on exit, K(I) is the dimension of the I-th
+* secular equation on the computation tree.
+*
+* DIFL (output) DOUBLE PRECISION array, dimension ( LDU, NLVL ),
+* where NLVL = floor(log_2 (N/SMLSIZ))).
+*
+* DIFR (output) DOUBLE PRECISION array,
+* dimension ( LDU, 2 * NLVL ) if ICOMPQ = 1 and
+* dimension ( N ) if ICOMPQ = 0.
+* If ICOMPQ = 1, on exit, DIFL(1:N, I) and DIFR(1:N, 2 * I - 1)
+* record distances between singular values on the I-th
+* level and singular values on the (I -1)-th level, and
+* DIFR(1:N, 2 * I ) contains the normalizing factors for
+* the right singular vector matrix. See DLASD8 for details.
+*
+* Z (output) DOUBLE PRECISION array,
+* dimension ( LDU, NLVL ) if ICOMPQ = 1 and
+* dimension ( N ) if ICOMPQ = 0.
+* The first K elements of Z(1, I) contain the components of
+* the deflation-adjusted updating row vector for subproblems
+* on the I-th level.
+*
+* POLES (output) DOUBLE PRECISION array,
+* dimension ( LDU, 2 * NLVL ) if ICOMPQ = 1, and not referenced
+* if ICOMPQ = 0. If ICOMPQ = 1, on exit, POLES(1, 2*I - 1) and
+* POLES(1, 2*I) contain the new and old singular values
+* involved in the secular equations on the I-th level.
+*
+* GIVPTR (output) INTEGER array,
+* dimension ( N ) if ICOMPQ = 1, and not referenced if
+* ICOMPQ = 0. If ICOMPQ = 1, on exit, GIVPTR( I ) records
+* the number of Givens rotations performed on the I-th
+* problem on the computation tree.
+*
+* GIVCOL (output) INTEGER array,
+* dimension ( LDGCOL, 2 * NLVL ) if ICOMPQ = 1, and not
+* referenced if ICOMPQ = 0. If ICOMPQ = 1, on exit, for each I,
+* GIVCOL(1, 2 *I - 1) and GIVCOL(1, 2 *I) record the locations
+* of Givens rotations performed on the I-th level on the
+* computation tree.
+*
+* LDGCOL (input) INTEGER, LDGCOL = > N.
+* The leading dimension of arrays GIVCOL and PERM.
+*
+* PERM (output) INTEGER array,
+* dimension ( LDGCOL, NLVL ) if ICOMPQ = 1, and not referenced
+* if ICOMPQ = 0. If ICOMPQ = 1, on exit, PERM(1, I) records
+* permutations done on the I-th level of the computation tree.
+*
+* GIVNUM (output) DOUBLE PRECISION array,
+* dimension ( LDU, 2 * NLVL ) if ICOMPQ = 1, and not
+* referenced if ICOMPQ = 0. If ICOMPQ = 1, on exit, for each I,
+* GIVNUM(1, 2 *I - 1) and GIVNUM(1, 2 *I) record the C- and S-
+* values of Givens rotations performed on the I-th level on
+* the computation tree.
+*
+* C (output) DOUBLE PRECISION array,
+* dimension ( N ) if ICOMPQ = 1, and dimension 1 if ICOMPQ = 0.
+* If ICOMPQ = 1 and the I-th subproblem is not square, on exit,
+* C( I ) contains the C-value of a Givens rotation related to
+* the right null space of the I-th subproblem.
+*
+* S (output) DOUBLE PRECISION array, dimension ( N ) if
+* ICOMPQ = 1, and dimension 1 if ICOMPQ = 0. If ICOMPQ = 1
+* and the I-th subproblem is not square, on exit, S( I )
+* contains the S-value of a Givens rotation related to
+* the right null space of the I-th subproblem.
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension
+* (6 * N + (SMLSIZ + 1)*(SMLSIZ + 1)).
+*
+* IWORK (workspace) INTEGER array.
+* Dimension must be at least (7 * N).
+*
+* INFO (output) INTEGER
+* = 0: successful exit.
+* < 0: if INFO = -i, the i-th argument had an illegal value.
+* > 0: if INFO = 1, an singular value did not converge
+*
+* Further Details
+* ===============
+*
+* Based on contributions by
+* Ming Gu and Huan Ren, Computer Science Division, University of
+* California at Berkeley, USA
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, I1, IC, IDXQ, IDXQI, IM1, INODE, ITEMP, IWK,
+ $ J, LF, LL, LVL, LVL2, M, NCC, ND, NDB1, NDIML,
+ $ NDIMR, NL, NLF, NLP1, NLVL, NR, NRF, NRP1, NRU,
+ $ NWORK1, NWORK2, SMLSZP, SQREI, VF, VFI, VL, VLI
+ DOUBLE PRECISION ALPHA, BETA
+* ..
+* .. External Subroutines ..
+ EXTERNAL DCOPY, DLASD6, DLASDQ, DLASDT, DLASET, XERBLA
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+*
+ IF( ( ICOMPQ.LT.0 ) .OR. ( ICOMPQ.GT.1 ) ) THEN
+ INFO = -1
+ ELSE IF( SMLSIZ.LT.3 ) THEN
+ INFO = -2
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( ( SQRE.LT.0 ) .OR. ( SQRE.GT.1 ) ) THEN
+ INFO = -4
+ ELSE IF( LDU.LT.( N+SQRE ) ) THEN
+ INFO = -8
+ ELSE IF( LDGCOL.LT.N ) THEN
+ INFO = -17
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DLASDA', -INFO )
+ RETURN
+ END IF
+*
+ M = N + SQRE
+*
+* If the input matrix is too small, call DLASDQ to find the SVD.
+*
+ IF( N.LE.SMLSIZ ) THEN
+ IF( ICOMPQ.EQ.0 ) THEN
+ CALL DLASDQ( 'U', SQRE, N, 0, 0, 0, D, E, VT, LDU, U, LDU,
+ $ U, LDU, WORK, INFO )
+ ELSE
+ CALL DLASDQ( 'U', SQRE, N, M, N, 0, D, E, VT, LDU, U, LDU,
+ $ U, LDU, WORK, INFO )
+ END IF
+ RETURN
+ END IF
+*
+* Book-keeping and set up the computation tree.
+*
+ INODE = 1
+ NDIML = INODE + N
+ NDIMR = NDIML + N
+ IDXQ = NDIMR + N
+ IWK = IDXQ + N
+*
+ NCC = 0
+ NRU = 0
+*
+ SMLSZP = SMLSIZ + 1
+ VF = 1
+ VL = VF + M
+ NWORK1 = VL + M
+ NWORK2 = NWORK1 + SMLSZP*SMLSZP
+*
+ CALL DLASDT( N, NLVL, ND, IWORK( INODE ), IWORK( NDIML ),
+ $ IWORK( NDIMR ), SMLSIZ )
+*
+* for the nodes on bottom level of the tree, solve
+* their subproblems by DLASDQ.
+*
+ NDB1 = ( ND+1 ) / 2
+ DO 30 I = NDB1, ND
+*
+* IC : center row of each node
+* NL : number of rows of left subproblem
+* NR : number of rows of right subproblem
+* NLF: starting row of the left subproblem
+* NRF: starting row of the right subproblem
+*
+ I1 = I - 1
+ IC = IWORK( INODE+I1 )
+ NL = IWORK( NDIML+I1 )
+ NLP1 = NL + 1
+ NR = IWORK( NDIMR+I1 )
+ NLF = IC - NL
+ NRF = IC + 1
+ IDXQI = IDXQ + NLF - 2
+ VFI = VF + NLF - 1
+ VLI = VL + NLF - 1
+ SQREI = 1
+ IF( ICOMPQ.EQ.0 ) THEN
+ CALL DLASET( 'A', NLP1, NLP1, ZERO, ONE, WORK( NWORK1 ),
+ $ SMLSZP )
+ CALL DLASDQ( 'U', SQREI, NL, NLP1, NRU, NCC, D( NLF ),
+ $ E( NLF ), WORK( NWORK1 ), SMLSZP,
+ $ WORK( NWORK2 ), NL, WORK( NWORK2 ), NL,
+ $ WORK( NWORK2 ), INFO )
+ ITEMP = NWORK1 + NL*SMLSZP
+ CALL DCOPY( NLP1, WORK( NWORK1 ), 1, WORK( VFI ), 1 )
+ CALL DCOPY( NLP1, WORK( ITEMP ), 1, WORK( VLI ), 1 )
+ ELSE
+ CALL DLASET( 'A', NL, NL, ZERO, ONE, U( NLF, 1 ), LDU )
+ CALL DLASET( 'A', NLP1, NLP1, ZERO, ONE, VT( NLF, 1 ), LDU )
+ CALL DLASDQ( 'U', SQREI, NL, NLP1, NL, NCC, D( NLF ),
+ $ E( NLF ), VT( NLF, 1 ), LDU, U( NLF, 1 ), LDU,
+ $ U( NLF, 1 ), LDU, WORK( NWORK1 ), INFO )
+ CALL DCOPY( NLP1, VT( NLF, 1 ), 1, WORK( VFI ), 1 )
+ CALL DCOPY( NLP1, VT( NLF, NLP1 ), 1, WORK( VLI ), 1 )
+ END IF
+ IF( INFO.NE.0 ) THEN
+ RETURN
+ END IF
+ DO 10 J = 1, NL
+ IWORK( IDXQI+J ) = J
+ 10 CONTINUE
+ IF( ( I.EQ.ND ) .AND. ( SQRE.EQ.0 ) ) THEN
+ SQREI = 0
+ ELSE
+ SQREI = 1
+ END IF
+ IDXQI = IDXQI + NLP1
+ VFI = VFI + NLP1
+ VLI = VLI + NLP1
+ NRP1 = NR + SQREI
+ IF( ICOMPQ.EQ.0 ) THEN
+ CALL DLASET( 'A', NRP1, NRP1, ZERO, ONE, WORK( NWORK1 ),
+ $ SMLSZP )
+ CALL DLASDQ( 'U', SQREI, NR, NRP1, NRU, NCC, D( NRF ),
+ $ E( NRF ), WORK( NWORK1 ), SMLSZP,
+ $ WORK( NWORK2 ), NR, WORK( NWORK2 ), NR,
+ $ WORK( NWORK2 ), INFO )
+ ITEMP = NWORK1 + ( NRP1-1 )*SMLSZP
+ CALL DCOPY( NRP1, WORK( NWORK1 ), 1, WORK( VFI ), 1 )
+ CALL DCOPY( NRP1, WORK( ITEMP ), 1, WORK( VLI ), 1 )
+ ELSE
+ CALL DLASET( 'A', NR, NR, ZERO, ONE, U( NRF, 1 ), LDU )
+ CALL DLASET( 'A', NRP1, NRP1, ZERO, ONE, VT( NRF, 1 ), LDU )
+ CALL DLASDQ( 'U', SQREI, NR, NRP1, NR, NCC, D( NRF ),
+ $ E( NRF ), VT( NRF, 1 ), LDU, U( NRF, 1 ), LDU,
+ $ U( NRF, 1 ), LDU, WORK( NWORK1 ), INFO )
+ CALL DCOPY( NRP1, VT( NRF, 1 ), 1, WORK( VFI ), 1 )
+ CALL DCOPY( NRP1, VT( NRF, NRP1 ), 1, WORK( VLI ), 1 )
+ END IF
+ IF( INFO.NE.0 ) THEN
+ RETURN
+ END IF
+ DO 20 J = 1, NR
+ IWORK( IDXQI+J ) = J
+ 20 CONTINUE
+ 30 CONTINUE
+*
+* Now conquer each subproblem bottom-up.
+*
+ J = 2**NLVL
+ DO 50 LVL = NLVL, 1, -1
+ LVL2 = LVL*2 - 1
+*
+* Find the first node LF and last node LL on
+* the current level LVL.
+*
+ IF( LVL.EQ.1 ) THEN
+ LF = 1
+ LL = 1
+ ELSE
+ LF = 2**( LVL-1 )
+ LL = 2*LF - 1
+ END IF
+ DO 40 I = LF, LL
+ IM1 = I - 1
+ IC = IWORK( INODE+IM1 )
+ NL = IWORK( NDIML+IM1 )
+ NR = IWORK( NDIMR+IM1 )
+ NLF = IC - NL
+ NRF = IC + 1
+ IF( I.EQ.LL ) THEN
+ SQREI = SQRE
+ ELSE
+ SQREI = 1
+ END IF
+ VFI = VF + NLF - 1
+ VLI = VL + NLF - 1
+ IDXQI = IDXQ + NLF - 1
+ ALPHA = D( IC )
+ BETA = E( IC )
+ IF( ICOMPQ.EQ.0 ) THEN
+ CALL DLASD6( ICOMPQ, NL, NR, SQREI, D( NLF ),
+ $ WORK( VFI ), WORK( VLI ), ALPHA, BETA,
+ $ IWORK( IDXQI ), PERM, GIVPTR( 1 ), GIVCOL,
+ $ LDGCOL, GIVNUM, LDU, POLES, DIFL, DIFR, Z,
+ $ K( 1 ), C( 1 ), S( 1 ), WORK( NWORK1 ),
+ $ IWORK( IWK ), INFO )
+ ELSE
+ J = J - 1
+ CALL DLASD6( ICOMPQ, NL, NR, SQREI, D( NLF ),
+ $ WORK( VFI ), WORK( VLI ), ALPHA, BETA,
+ $ IWORK( IDXQI ), PERM( NLF, LVL ),
+ $ GIVPTR( J ), GIVCOL( NLF, LVL2 ), LDGCOL,
+ $ GIVNUM( NLF, LVL2 ), LDU,
+ $ POLES( NLF, LVL2 ), DIFL( NLF, LVL ),
+ $ DIFR( NLF, LVL2 ), Z( NLF, LVL ), K( J ),
+ $ C( J ), S( J ), WORK( NWORK1 ),
+ $ IWORK( IWK ), INFO )
+ END IF
+ IF( INFO.NE.0 ) THEN
+ RETURN
+ END IF
+ 40 CONTINUE
+ 50 CONTINUE
+*
+ RETURN
+*
+* End of DLASDA
+*
+ END
+ SUBROUTINE DLASDQ( UPLO, SQRE, N, NCVT, NRU, NCC, D, E, VT, LDVT,
+ $ U, LDU, C, LDC, WORK, INFO )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, LDC, LDU, LDVT, N, NCC, NCVT, NRU, SQRE
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION C( LDC, * ), D( * ), E( * ), U( LDU, * ),
+ $ VT( LDVT, * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DLASDQ computes the singular value decomposition (SVD) of a real
+* (upper or lower) bidiagonal matrix with diagonal D and offdiagonal
+* E, accumulating the transformations if desired. Letting B denote
+* the input bidiagonal matrix, the algorithm computes orthogonal
+* matrices Q and P such that B = Q * S * P' (P' denotes the transpose
+* of P). The singular values S are overwritten on D.
+*
+* The input matrix U is changed to U * Q if desired.
+* The input matrix VT is changed to P' * VT if desired.
+* The input matrix C is changed to Q' * C if desired.
+*
+* See "Computing Small Singular Values of Bidiagonal Matrices With
+* Guaranteed High Relative Accuracy," by J. Demmel and W. Kahan,
+* LAPACK Working Note #3, for a detailed description of the algorithm.
+*
+* Arguments
+* =========
+*
+* UPLO (input) CHARACTER*1
+* On entry, UPLO specifies whether the input bidiagonal matrix
+* is upper or lower bidiagonal, and wether it is square are
+* not.
+* UPLO = 'U' or 'u' B is upper bidiagonal.
+* UPLO = 'L' or 'l' B is lower bidiagonal.
+*
+* SQRE (input) INTEGER
+* = 0: then the input matrix is N-by-N.
+* = 1: then the input matrix is N-by-(N+1) if UPLU = 'U' and
+* (N+1)-by-N if UPLU = 'L'.
+*
+* The bidiagonal matrix has
+* N = NL + NR + 1 rows and
+* M = N + SQRE >= N columns.
+*
+* N (input) INTEGER
+* On entry, N specifies the number of rows and columns
+* in the matrix. N must be at least 0.
+*
+* NCVT (input) INTEGER
+* On entry, NCVT specifies the number of columns of
+* the matrix VT. NCVT must be at least 0.
+*
+* NRU (input) INTEGER
+* On entry, NRU specifies the number of rows of
+* the matrix U. NRU must be at least 0.
+*
+* NCC (input) INTEGER
+* On entry, NCC specifies the number of columns of
+* the matrix C. NCC must be at least 0.
+*
+* D (input/output) DOUBLE PRECISION array, dimension (N)
+* On entry, D contains the diagonal entries of the
+* bidiagonal matrix whose SVD is desired. On normal exit,
+* D contains the singular values in ascending order.
+*
+* E (input/output) DOUBLE PRECISION array.
+* dimension is (N-1) if SQRE = 0 and N if SQRE = 1.
+* On entry, the entries of E contain the offdiagonal entries
+* of the bidiagonal matrix whose SVD is desired. On normal
+* exit, E will contain 0. If the algorithm does not converge,
+* D and E will contain the diagonal and superdiagonal entries
+* of a bidiagonal matrix orthogonally equivalent to the one
+* given as input.
+*
+* VT (input/output) DOUBLE PRECISION array, dimension (LDVT, NCVT)
+* On entry, contains a matrix which on exit has been
+* premultiplied by P', dimension N-by-NCVT if SQRE = 0
+* and (N+1)-by-NCVT if SQRE = 1 (not referenced if NCVT=0).
+*
+* LDVT (input) INTEGER
+* On entry, LDVT specifies the leading dimension of VT as
+* declared in the calling (sub) program. LDVT must be at
+* least 1. If NCVT is nonzero LDVT must also be at least N.
+*
+* U (input/output) DOUBLE PRECISION array, dimension (LDU, N)
+* On entry, contains a matrix which on exit has been
+* postmultiplied by Q, dimension NRU-by-N if SQRE = 0
+* and NRU-by-(N+1) if SQRE = 1 (not referenced if NRU=0).
+*
+* LDU (input) INTEGER
+* On entry, LDU specifies the leading dimension of U as
+* declared in the calling (sub) program. LDU must be at
+* least max( 1, NRU ) .
+*
+* C (input/output) DOUBLE PRECISION array, dimension (LDC, NCC)
+* On entry, contains an N-by-NCC matrix which on exit
+* has been premultiplied by Q' dimension N-by-NCC if SQRE = 0
+* and (N+1)-by-NCC if SQRE = 1 (not referenced if NCC=0).
+*
+* LDC (input) INTEGER
+* On entry, LDC specifies the leading dimension of C as
+* declared in the calling (sub) program. LDC must be at
+* least 1. If NCC is nonzero, LDC must also be at least N.
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (4*N)
+* Workspace. Only referenced if one of NCVT, NRU, or NCC is
+* nonzero, and if N is at least 2.
+*
+* INFO (output) INTEGER
+* On exit, a value of 0 indicates a successful exit.
+* If INFO < 0, argument number -INFO is illegal.
+* If INFO > 0, the algorithm did not converge, and INFO
+* specifies how many superdiagonals did not converge.
+*
+* Further Details
+* ===============
+*
+* Based on contributions by
+* Ming Gu and Huan Ren, Computer Science Division, University of
+* California at Berkeley, USA
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO
+ PARAMETER ( ZERO = 0.0D+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL ROTATE
+ INTEGER I, ISUB, IUPLO, J, NP1, SQRE1
+ DOUBLE PRECISION CS, R, SMIN, SN
+* ..
+* .. External Subroutines ..
+ EXTERNAL DBDSQR, DLARTG, DLASR, DSWAP, XERBLA
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ IUPLO = 0
+ IF( LSAME( UPLO, 'U' ) )
+ $ IUPLO = 1
+ IF( LSAME( UPLO, 'L' ) )
+ $ IUPLO = 2
+ IF( IUPLO.EQ.0 ) THEN
+ INFO = -1
+ ELSE IF( ( SQRE.LT.0 ) .OR. ( SQRE.GT.1 ) ) THEN
+ INFO = -2
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( NCVT.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( NRU.LT.0 ) THEN
+ INFO = -5
+ ELSE IF( NCC.LT.0 ) THEN
+ INFO = -6
+ ELSE IF( ( NCVT.EQ.0 .AND. LDVT.LT.1 ) .OR.
+ $ ( NCVT.GT.0 .AND. LDVT.LT.MAX( 1, N ) ) ) THEN
+ INFO = -10
+ ELSE IF( LDU.LT.MAX( 1, NRU ) ) THEN
+ INFO = -12
+ ELSE IF( ( NCC.EQ.0 .AND. LDC.LT.1 ) .OR.
+ $ ( NCC.GT.0 .AND. LDC.LT.MAX( 1, N ) ) ) THEN
+ INFO = -14
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DLASDQ', -INFO )
+ RETURN
+ END IF
+ IF( N.EQ.0 )
+ $ RETURN
+*
+* ROTATE is true if any singular vectors desired, false otherwise
+*
+ ROTATE = ( NCVT.GT.0 ) .OR. ( NRU.GT.0 ) .OR. ( NCC.GT.0 )
+ NP1 = N + 1
+ SQRE1 = SQRE
+*
+* If matrix non-square upper bidiagonal, rotate to be lower
+* bidiagonal. The rotations are on the right.
+*
+ IF( ( IUPLO.EQ.1 ) .AND. ( SQRE1.EQ.1 ) ) THEN
+ DO 10 I = 1, N - 1
+ CALL DLARTG( D( I ), E( I ), CS, SN, R )
+ D( I ) = R
+ E( I ) = SN*D( I+1 )
+ D( I+1 ) = CS*D( I+1 )
+ IF( ROTATE ) THEN
+ WORK( I ) = CS
+ WORK( N+I ) = SN
+ END IF
+ 10 CONTINUE
+ CALL DLARTG( D( N ), E( N ), CS, SN, R )
+ D( N ) = R
+ E( N ) = ZERO
+ IF( ROTATE ) THEN
+ WORK( N ) = CS
+ WORK( N+N ) = SN
+ END IF
+ IUPLO = 2
+ SQRE1 = 0
+*
+* Update singular vectors if desired.
+*
+ IF( NCVT.GT.0 )
+ $ CALL DLASR( 'L', 'V', 'F', NP1, NCVT, WORK( 1 ),
+ $ WORK( NP1 ), VT, LDVT )
+ END IF
+*
+* If matrix lower bidiagonal, rotate to be upper bidiagonal
+* by applying Givens rotations on the left.
+*
+ IF( IUPLO.EQ.2 ) THEN
+ DO 20 I = 1, N - 1
+ CALL DLARTG( D( I ), E( I ), CS, SN, R )
+ D( I ) = R
+ E( I ) = SN*D( I+1 )
+ D( I+1 ) = CS*D( I+1 )
+ IF( ROTATE ) THEN
+ WORK( I ) = CS
+ WORK( N+I ) = SN
+ END IF
+ 20 CONTINUE
+*
+* If matrix (N+1)-by-N lower bidiagonal, one additional
+* rotation is needed.
+*
+ IF( SQRE1.EQ.1 ) THEN
+ CALL DLARTG( D( N ), E( N ), CS, SN, R )
+ D( N ) = R
+ IF( ROTATE ) THEN
+ WORK( N ) = CS
+ WORK( N+N ) = SN
+ END IF
+ END IF
+*
+* Update singular vectors if desired.
+*
+ IF( NRU.GT.0 ) THEN
+ IF( SQRE1.EQ.0 ) THEN
+ CALL DLASR( 'R', 'V', 'F', NRU, N, WORK( 1 ),
+ $ WORK( NP1 ), U, LDU )
+ ELSE
+ CALL DLASR( 'R', 'V', 'F', NRU, NP1, WORK( 1 ),
+ $ WORK( NP1 ), U, LDU )
+ END IF
+ END IF
+ IF( NCC.GT.0 ) THEN
+ IF( SQRE1.EQ.0 ) THEN
+ CALL DLASR( 'L', 'V', 'F', N, NCC, WORK( 1 ),
+ $ WORK( NP1 ), C, LDC )
+ ELSE
+ CALL DLASR( 'L', 'V', 'F', NP1, NCC, WORK( 1 ),
+ $ WORK( NP1 ), C, LDC )
+ END IF
+ END IF
+ END IF
+*
+* Call DBDSQR to compute the SVD of the reduced real
+* N-by-N upper bidiagonal matrix.
+*
+ CALL DBDSQR( 'U', N, NCVT, NRU, NCC, D, E, VT, LDVT, U, LDU, C,
+ $ LDC, WORK, INFO )
+*
+* Sort the singular values into ascending order (insertion sort on
+* singular values, but only one transposition per singular vector)
+*
+ DO 40 I = 1, N
+*
+* Scan for smallest D(I).
+*
+ ISUB = I
+ SMIN = D( I )
+ DO 30 J = I + 1, N
+ IF( D( J ).LT.SMIN ) THEN
+ ISUB = J
+ SMIN = D( J )
+ END IF
+ 30 CONTINUE
+ IF( ISUB.NE.I ) THEN
+*
+* Swap singular values and vectors.
+*
+ D( ISUB ) = D( I )
+ D( I ) = SMIN
+ IF( NCVT.GT.0 )
+ $ CALL DSWAP( NCVT, VT( ISUB, 1 ), LDVT, VT( I, 1 ), LDVT )
+ IF( NRU.GT.0 )
+ $ CALL DSWAP( NRU, U( 1, ISUB ), 1, U( 1, I ), 1 )
+ IF( NCC.GT.0 )
+ $ CALL DSWAP( NCC, C( ISUB, 1 ), LDC, C( I, 1 ), LDC )
+ END IF
+ 40 CONTINUE
+*
+ RETURN
+*
+* End of DLASDQ
+*
+ END
+ SUBROUTINE DLASDT( N, LVL, ND, INODE, NDIML, NDIMR, MSUB )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER LVL, MSUB, N, ND
+* ..
+* .. Array Arguments ..
+ INTEGER INODE( * ), NDIML( * ), NDIMR( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DLASDT creates a tree of subproblems for bidiagonal divide and
+* conquer.
+*
+* Arguments
+* =========
+*
+* N (input) INTEGER
+* On entry, the number of diagonal elements of the
+* bidiagonal matrix.
+*
+* LVL (output) INTEGER
+* On exit, the number of levels on the computation tree.
+*
+* ND (output) INTEGER
+* On exit, the number of nodes on the tree.
+*
+* INODE (output) INTEGER array, dimension ( N )
+* On exit, centers of subproblems.
+*
+* NDIML (output) INTEGER array, dimension ( N )
+* On exit, row dimensions of left children.
+*
+* NDIMR (output) INTEGER array, dimension ( N )
+* On exit, row dimensions of right children.
+*
+* MSUB (input) INTEGER.
+* On entry, the maximum row dimension each subproblem at the
+* bottom of the tree can be of.
+*
+* Further Details
+* ===============
+*
+* Based on contributions by
+* Ming Gu and Huan Ren, Computer Science Division, University of
+* California at Berkeley, USA
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION TWO
+ PARAMETER ( TWO = 2.0D+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, IL, IR, LLST, MAXN, NCRNT, NLVL
+ DOUBLE PRECISION TEMP
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC DBLE, INT, LOG, MAX
+* ..
+* .. Executable Statements ..
+*
+* Find the number of levels on the tree.
+*
+ MAXN = MAX( 1, N )
+ TEMP = LOG( DBLE( MAXN ) / DBLE( MSUB+1 ) ) / LOG( TWO )
+ LVL = INT( TEMP ) + 1
+*
+ I = N / 2
+ INODE( 1 ) = I + 1
+ NDIML( 1 ) = I
+ NDIMR( 1 ) = N - I - 1
+ IL = 0
+ IR = 1
+ LLST = 1
+ DO 20 NLVL = 1, LVL - 1
+*
+* Constructing the tree at (NLVL+1)-st level. The number of
+* nodes created on this level is LLST * 2.
+*
+ DO 10 I = 0, LLST - 1
+ IL = IL + 2
+ IR = IR + 2
+ NCRNT = LLST + I
+ NDIML( IL ) = NDIML( NCRNT ) / 2
+ NDIMR( IL ) = NDIML( NCRNT ) - NDIML( IL ) - 1
+ INODE( IL ) = INODE( NCRNT ) - NDIMR( IL ) - 1
+ NDIML( IR ) = NDIMR( NCRNT ) / 2
+ NDIMR( IR ) = NDIMR( NCRNT ) - NDIML( IR ) - 1
+ INODE( IR ) = INODE( NCRNT ) + NDIML( IR ) + 1
+ 10 CONTINUE
+ LLST = LLST*2
+ 20 CONTINUE
+ ND = LLST*2 - 1
+*
+ RETURN
+*
+* End of DLASDT
+*
+ END
+ SUBROUTINE DLASET( UPLO, M, N, ALPHA, BETA, A, LDA )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER LDA, M, N
+ DOUBLE PRECISION ALPHA, BETA
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION A( LDA, * )
+* ..
+*
+* Purpose
+* =======
+*
+* DLASET initializes an m-by-n matrix A to BETA on the diagonal and
+* ALPHA on the offdiagonals.
+*
+* Arguments
+* =========
+*
+* UPLO (input) CHARACTER*1
+* Specifies the part of the matrix A to be set.
+* = 'U': Upper triangular part is set; the strictly lower
+* triangular part of A is not changed.
+* = 'L': Lower triangular part is set; the strictly upper
+* triangular part of A is not changed.
+* Otherwise: All of the matrix A is set.
+*
+* M (input) INTEGER
+* The number of rows of the matrix A. M >= 0.
+*
+* N (input) INTEGER
+* The number of columns of the matrix A. N >= 0.
+*
+* ALPHA (input) DOUBLE PRECISION
+* The constant to which the offdiagonal elements are to be set.
+*
+* BETA (input) DOUBLE PRECISION
+* The constant to which the diagonal elements are to be set.
+*
+* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+* On exit, the leading m-by-n submatrix of A is set as follows:
+*
+* if UPLO = 'U', A(i,j) = ALPHA, 1<=i<=j-1, 1<=j<=n,
+* if UPLO = 'L', A(i,j) = ALPHA, j+1<=i<=m, 1<=j<=n,
+* otherwise, A(i,j) = ALPHA, 1<=i<=m, 1<=j<=n, i.ne.j,
+*
+* and, for all UPLO, A(i,i) = BETA, 1<=i<=min(m,n).
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,M).
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ INTEGER I, J
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MIN
+* ..
+* .. Executable Statements ..
+*
+ IF( LSAME( UPLO, 'U' ) ) THEN
+*
+* Set the strictly upper triangular or trapezoidal part of the
+* array to ALPHA.
+*
+ DO 20 J = 2, N
+ DO 10 I = 1, MIN( J-1, M )
+ A( I, J ) = ALPHA
+ 10 CONTINUE
+ 20 CONTINUE
+*
+ ELSE IF( LSAME( UPLO, 'L' ) ) THEN
+*
+* Set the strictly lower triangular or trapezoidal part of the
+* array to ALPHA.
+*
+ DO 40 J = 1, MIN( M, N )
+ DO 30 I = J + 1, M
+ A( I, J ) = ALPHA
+ 30 CONTINUE
+ 40 CONTINUE
+*
+ ELSE
+*
+* Set the leading m-by-n submatrix to ALPHA.
+*
+ DO 60 J = 1, N
+ DO 50 I = 1, M
+ A( I, J ) = ALPHA
+ 50 CONTINUE
+ 60 CONTINUE
+ END IF
+*
+* Set the first min(M,N) diagonal elements to BETA.
+*
+ DO 70 I = 1, MIN( M, N )
+ A( I, I ) = BETA
+ 70 CONTINUE
+*
+ RETURN
+*
+* End of DLASET
+*
+ END
+ SUBROUTINE DLASQ1( N, D, E, WORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, N
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION D( * ), E( * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DLASQ1 computes the singular values of a real N-by-N bidiagonal
+* matrix with diagonal D and off-diagonal E. The singular values
+* are computed to high relative accuracy, in the absence of
+* denormalization, underflow and overflow. The algorithm was first
+* presented in
+*
+* "Accurate singular values and differential qd algorithms" by K. V.
+* Fernando and B. N. Parlett, Numer. Math., Vol-67, No. 2, pp. 191-230,
+* 1994,
+*
+* and the present implementation is described in "An implementation of
+* the dqds Algorithm (Positive Case)", LAPACK Working Note.
+*
+* Arguments
+* =========
+*
+* N (input) INTEGER
+* The number of rows and columns in the matrix. N >= 0.
+*
+* D (input/output) DOUBLE PRECISION array, dimension (N)
+* On entry, D contains the diagonal elements of the
+* bidiagonal matrix whose SVD is desired. On normal exit,
+* D contains the singular values in decreasing order.
+*
+* E (input/output) DOUBLE PRECISION array, dimension (N)
+* On entry, elements E(1:N-1) contain the off-diagonal elements
+* of the bidiagonal matrix whose SVD is desired.
+* On exit, E is overwritten.
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (4*N)
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* > 0: the algorithm failed
+* = 1, a split was marked by a positive value in E
+* = 2, current block of Z not diagonalized after 30*N
+* iterations (in inner while loop)
+* = 3, termination criterion of outer while loop not met
+* (program created more than N unreduced blocks)
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO
+ PARAMETER ( ZERO = 0.0D0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, IINFO
+ DOUBLE PRECISION EPS, SCALE, SAFMIN, SIGMN, SIGMX
+* ..
+* .. External Subroutines ..
+ EXTERNAL DCOPY, DLAS2, DLASCL, DLASQ2, DLASRT, XERBLA
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DLAMCH
+ EXTERNAL DLAMCH
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, SQRT
+* ..
+* .. Executable Statements ..
+*
+ INFO = 0
+ IF( N.LT.0 ) THEN
+ INFO = -2
+ CALL XERBLA( 'DLASQ1', -INFO )
+ RETURN
+ ELSE IF( N.EQ.0 ) THEN
+ RETURN
+ ELSE IF( N.EQ.1 ) THEN
+ D( 1 ) = ABS( D( 1 ) )
+ RETURN
+ ELSE IF( N.EQ.2 ) THEN
+ CALL DLAS2( D( 1 ), E( 1 ), D( 2 ), SIGMN, SIGMX )
+ D( 1 ) = SIGMX
+ D( 2 ) = SIGMN
+ RETURN
+ END IF
+*
+* Estimate the largest singular value.
+*
+ SIGMX = ZERO
+ DO 10 I = 1, N - 1
+ D( I ) = ABS( D( I ) )
+ SIGMX = MAX( SIGMX, ABS( E( I ) ) )
+ 10 CONTINUE
+ D( N ) = ABS( D( N ) )
+*
+* Early return if SIGMX is zero (matrix is already diagonal).
+*
+ IF( SIGMX.EQ.ZERO ) THEN
+ CALL DLASRT( 'D', N, D, IINFO )
+ RETURN
+ END IF
+*
+ DO 20 I = 1, N
+ SIGMX = MAX( SIGMX, D( I ) )
+ 20 CONTINUE
+*
+* Copy D and E into WORK (in the Z format) and scale (squaring the
+* input data makes scaling by a power of the radix pointless).
+*
+ EPS = DLAMCH( 'Precision' )
+ SAFMIN = DLAMCH( 'Safe minimum' )
+ SCALE = SQRT( EPS / SAFMIN )
+ CALL DCOPY( N, D, 1, WORK( 1 ), 2 )
+ CALL DCOPY( N-1, E, 1, WORK( 2 ), 2 )
+ CALL DLASCL( 'G', 0, 0, SIGMX, SCALE, 2*N-1, 1, WORK, 2*N-1,
+ $ IINFO )
+*
+* Compute the q's and e's.
+*
+ DO 30 I = 1, 2*N - 1
+ WORK( I ) = WORK( I )**2
+ 30 CONTINUE
+ WORK( 2*N ) = ZERO
+*
+ CALL DLASQ2( N, WORK, INFO )
+*
+ IF( INFO.EQ.0 ) THEN
+ DO 40 I = 1, N
+ D( I ) = SQRT( WORK( I ) )
+ 40 CONTINUE
+ CALL DLASCL( 'G', 0, 0, SCALE, SIGMX, N, 1, D, N, IINFO )
+ END IF
+*
+ RETURN
+*
+* End of DLASQ1
+*
+ END
+ SUBROUTINE DLASQ2( N, Z, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* Modified to call DLAZQ3 in place of DLASQ3, 13 Feb 03, SJH.
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, N
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION Z( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DLASQ2 computes all the eigenvalues of the symmetric positive
+* definite tridiagonal matrix associated with the qd array Z to high
+* relative accuracy are computed to high relative accuracy, in the
+* absence of denormalization, underflow and overflow.
+*
+* To see the relation of Z to the tridiagonal matrix, let L be a
+* unit lower bidiagonal matrix with subdiagonals Z(2,4,6,,..) and
+* let U be an upper bidiagonal matrix with 1's above and diagonal
+* Z(1,3,5,,..). The tridiagonal is L*U or, if you prefer, the
+* symmetric tridiagonal to which it is similar.
+*
+* Note : DLASQ2 defines a logical variable, IEEE, which is true
+* on machines which follow ieee-754 floating-point standard in their
+* handling of infinities and NaNs, and false otherwise. This variable
+* is passed to DLAZQ3.
+*
+* Arguments
+* =========
+*
+* N (input) INTEGER
+* The number of rows and columns in the matrix. N >= 0.
+*
+* Z (workspace) DOUBLE PRECISION array, dimension ( 4*N )
+* On entry Z holds the qd array. On exit, entries 1 to N hold
+* the eigenvalues in decreasing order, Z( 2*N+1 ) holds the
+* trace, and Z( 2*N+2 ) holds the sum of the eigenvalues. If
+* N > 2, then Z( 2*N+3 ) holds the iteration count, Z( 2*N+4 )
+* holds NDIVS/NIN^2, and Z( 2*N+5 ) holds the percentage of
+* shifts that failed.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if the i-th argument is a scalar and had an illegal
+* value, then INFO = -i, if the i-th argument is an
+* array and the j-entry had an illegal value, then
+* INFO = -(i*100+j)
+* > 0: the algorithm failed
+* = 1, a split was marked by a positive value in E
+* = 2, current block of Z not diagonalized after 30*N
+* iterations (in inner while loop)
+* = 3, termination criterion of outer while loop not met
+* (program created more than N unreduced blocks)
+*
+* Further Details
+* ===============
+* Local Variables: I0:N0 defines a current unreduced segment of Z.
+* The shifts are accumulated in SIGMA. Iteration count is in ITER.
+* Ping-pong is controlled by PP (alternates between 0 and 1).
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION CBIAS
+ PARAMETER ( CBIAS = 1.50D0 )
+ DOUBLE PRECISION ZERO, HALF, ONE, TWO, FOUR, HUNDRD
+ PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0,
+ $ TWO = 2.0D0, FOUR = 4.0D0, HUNDRD = 100.0D0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL IEEE
+ INTEGER I0, I4, IINFO, IPN4, ITER, IWHILA, IWHILB, K,
+ $ N0, NBIG, NDIV, NFAIL, PP, SPLT, TTYPE
+ DOUBLE PRECISION D, DESIG, DMIN, DMIN1, DMIN2, DN, DN1, DN2, E,
+ $ EMAX, EMIN, EPS, OLDEMN, QMAX, QMIN, S, SAFMIN,
+ $ SIGMA, T, TAU, TEMP, TOL, TOL2, TRACE, ZMAX
+* ..
+* .. External Subroutines ..
+ EXTERNAL DLAZQ3, DLASRT, XERBLA
+* ..
+* .. External Functions ..
+ INTEGER ILAENV
+ DOUBLE PRECISION DLAMCH
+ EXTERNAL DLAMCH, ILAENV
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, DBLE, MAX, MIN, SQRT
+* ..
+* .. Executable Statements ..
+*
+* Test the input arguments.
+* (in case DLASQ2 is not called by DLASQ1)
+*
+ INFO = 0
+ EPS = DLAMCH( 'Precision' )
+ SAFMIN = DLAMCH( 'Safe minimum' )
+ TOL = EPS*HUNDRD
+ TOL2 = TOL**2
+*
+ IF( N.LT.0 ) THEN
+ INFO = -1
+ CALL XERBLA( 'DLASQ2', 1 )
+ RETURN
+ ELSE IF( N.EQ.0 ) THEN
+ RETURN
+ ELSE IF( N.EQ.1 ) THEN
+*
+* 1-by-1 case.
+*
+ IF( Z( 1 ).LT.ZERO ) THEN
+ INFO = -201
+ CALL XERBLA( 'DLASQ2', 2 )
+ END IF
+ RETURN
+ ELSE IF( N.EQ.2 ) THEN
+*
+* 2-by-2 case.
+*
+ IF( Z( 2 ).LT.ZERO .OR. Z( 3 ).LT.ZERO ) THEN
+ INFO = -2
+ CALL XERBLA( 'DLASQ2', 2 )
+ RETURN
+ ELSE IF( Z( 3 ).GT.Z( 1 ) ) THEN
+ D = Z( 3 )
+ Z( 3 ) = Z( 1 )
+ Z( 1 ) = D
+ END IF
+ Z( 5 ) = Z( 1 ) + Z( 2 ) + Z( 3 )
+ IF( Z( 2 ).GT.Z( 3 )*TOL2 ) THEN
+ T = HALF*( ( Z( 1 )-Z( 3 ) )+Z( 2 ) )
+ S = Z( 3 )*( Z( 2 ) / T )
+ IF( S.LE.T ) THEN
+ S = Z( 3 )*( Z( 2 ) / ( T*( ONE+SQRT( ONE+S / T ) ) ) )
+ ELSE
+ S = Z( 3 )*( Z( 2 ) / ( T+SQRT( T )*SQRT( T+S ) ) )
+ END IF
+ T = Z( 1 ) + ( S+Z( 2 ) )
+ Z( 3 ) = Z( 3 )*( Z( 1 ) / T )
+ Z( 1 ) = T
+ END IF
+ Z( 2 ) = Z( 3 )
+ Z( 6 ) = Z( 2 ) + Z( 1 )
+ RETURN
+ END IF
+*
+* Check for negative data and compute sums of q's and e's.
+*
+ Z( 2*N ) = ZERO
+ EMIN = Z( 2 )
+ QMAX = ZERO
+ ZMAX = ZERO
+ D = ZERO
+ E = ZERO
+*
+ DO 10 K = 1, 2*( N-1 ), 2
+ IF( Z( K ).LT.ZERO ) THEN
+ INFO = -( 200+K )
+ CALL XERBLA( 'DLASQ2', 2 )
+ RETURN
+ ELSE IF( Z( K+1 ).LT.ZERO ) THEN
+ INFO = -( 200+K+1 )
+ CALL XERBLA( 'DLASQ2', 2 )
+ RETURN
+ END IF
+ D = D + Z( K )
+ E = E + Z( K+1 )
+ QMAX = MAX( QMAX, Z( K ) )
+ EMIN = MIN( EMIN, Z( K+1 ) )
+ ZMAX = MAX( QMAX, ZMAX, Z( K+1 ) )
+ 10 CONTINUE
+ IF( Z( 2*N-1 ).LT.ZERO ) THEN
+ INFO = -( 200+2*N-1 )
+ CALL XERBLA( 'DLASQ2', 2 )
+ RETURN
+ END IF
+ D = D + Z( 2*N-1 )
+ QMAX = MAX( QMAX, Z( 2*N-1 ) )
+ ZMAX = MAX( QMAX, ZMAX )
+*
+* Check for diagonality.
+*
+ IF( E.EQ.ZERO ) THEN
+ DO 20 K = 2, N
+ Z( K ) = Z( 2*K-1 )
+ 20 CONTINUE
+ CALL DLASRT( 'D', N, Z, IINFO )
+ Z( 2*N-1 ) = D
+ RETURN
+ END IF
+*
+ TRACE = D + E
+*
+* Check for zero data.
+*
+ IF( TRACE.EQ.ZERO ) THEN
+ Z( 2*N-1 ) = ZERO
+ RETURN
+ END IF
+*
+* Check whether the machine is IEEE conformable.
+*
+ IEEE = ILAENV( 10, 'DLASQ2', 'N', 1, 2, 3, 4 ).EQ.1 .AND.
+ $ ILAENV( 11, 'DLASQ2', 'N', 1, 2, 3, 4 ).EQ.1
+*
+* Rearrange data for locality: Z=(q1,qq1,e1,ee1,q2,qq2,e2,ee2,...).
+*
+ DO 30 K = 2*N, 2, -2
+ Z( 2*K ) = ZERO
+ Z( 2*K-1 ) = Z( K )
+ Z( 2*K-2 ) = ZERO
+ Z( 2*K-3 ) = Z( K-1 )
+ 30 CONTINUE
+*
+ I0 = 1
+ N0 = N
+*
+* Reverse the qd-array, if warranted.
+*
+ IF( CBIAS*Z( 4*I0-3 ).LT.Z( 4*N0-3 ) ) THEN
+ IPN4 = 4*( I0+N0 )
+ DO 40 I4 = 4*I0, 2*( I0+N0-1 ), 4
+ TEMP = Z( I4-3 )
+ Z( I4-3 ) = Z( IPN4-I4-3 )
+ Z( IPN4-I4-3 ) = TEMP
+ TEMP = Z( I4-1 )
+ Z( I4-1 ) = Z( IPN4-I4-5 )
+ Z( IPN4-I4-5 ) = TEMP
+ 40 CONTINUE
+ END IF
+*
+* Initial split checking via dqd and Li's test.
+*
+ PP = 0
+*
+ DO 80 K = 1, 2
+*
+ D = Z( 4*N0+PP-3 )
+ DO 50 I4 = 4*( N0-1 ) + PP, 4*I0 + PP, -4
+ IF( Z( I4-1 ).LE.TOL2*D ) THEN
+ Z( I4-1 ) = -ZERO
+ D = Z( I4-3 )
+ ELSE
+ D = Z( I4-3 )*( D / ( D+Z( I4-1 ) ) )
+ END IF
+ 50 CONTINUE
+*
+* dqd maps Z to ZZ plus Li's test.
+*
+ EMIN = Z( 4*I0+PP+1 )
+ D = Z( 4*I0+PP-3 )
+ DO 60 I4 = 4*I0 + PP, 4*( N0-1 ) + PP, 4
+ Z( I4-2*PP-2 ) = D + Z( I4-1 )
+ IF( Z( I4-1 ).LE.TOL2*D ) THEN
+ Z( I4-1 ) = -ZERO
+ Z( I4-2*PP-2 ) = D
+ Z( I4-2*PP ) = ZERO
+ D = Z( I4+1 )
+ ELSE IF( SAFMIN*Z( I4+1 ).LT.Z( I4-2*PP-2 ) .AND.
+ $ SAFMIN*Z( I4-2*PP-2 ).LT.Z( I4+1 ) ) THEN
+ TEMP = Z( I4+1 ) / Z( I4-2*PP-2 )
+ Z( I4-2*PP ) = Z( I4-1 )*TEMP
+ D = D*TEMP
+ ELSE
+ Z( I4-2*PP ) = Z( I4+1 )*( Z( I4-1 ) / Z( I4-2*PP-2 ) )
+ D = Z( I4+1 )*( D / Z( I4-2*PP-2 ) )
+ END IF
+ EMIN = MIN( EMIN, Z( I4-2*PP ) )
+ 60 CONTINUE
+ Z( 4*N0-PP-2 ) = D
+*
+* Now find qmax.
+*
+ QMAX = Z( 4*I0-PP-2 )
+ DO 70 I4 = 4*I0 - PP + 2, 4*N0 - PP - 2, 4
+ QMAX = MAX( QMAX, Z( I4 ) )
+ 70 CONTINUE
+*
+* Prepare for the next iteration on K.
+*
+ PP = 1 - PP
+ 80 CONTINUE
+*
+* Initialise variables to pass to DLAZQ3
+*
+ TTYPE = 0
+ DMIN1 = ZERO
+ DMIN2 = ZERO
+ DN = ZERO
+ DN1 = ZERO
+ DN2 = ZERO
+ TAU = ZERO
+*
+ ITER = 2
+ NFAIL = 0
+ NDIV = 2*( N0-I0 )
+*
+ DO 140 IWHILA = 1, N + 1
+ IF( N0.LT.1 )
+ $ GO TO 150
+*
+* While array unfinished do
+*
+* E(N0) holds the value of SIGMA when submatrix in I0:N0
+* splits from the rest of the array, but is negated.
+*
+ DESIG = ZERO
+ IF( N0.EQ.N ) THEN
+ SIGMA = ZERO
+ ELSE
+ SIGMA = -Z( 4*N0-1 )
+ END IF
+ IF( SIGMA.LT.ZERO ) THEN
+ INFO = 1
+ RETURN
+ END IF
+*
+* Find last unreduced submatrix's top index I0, find QMAX and
+* EMIN. Find Gershgorin-type bound if Q's much greater than E's.
+*
+ EMAX = ZERO
+ IF( N0.GT.I0 ) THEN
+ EMIN = ABS( Z( 4*N0-5 ) )
+ ELSE
+ EMIN = ZERO
+ END IF
+ QMIN = Z( 4*N0-3 )
+ QMAX = QMIN
+ DO 90 I4 = 4*N0, 8, -4
+ IF( Z( I4-5 ).LE.ZERO )
+ $ GO TO 100
+ IF( QMIN.GE.FOUR*EMAX ) THEN
+ QMIN = MIN( QMIN, Z( I4-3 ) )
+ EMAX = MAX( EMAX, Z( I4-5 ) )
+ END IF
+ QMAX = MAX( QMAX, Z( I4-7 )+Z( I4-5 ) )
+ EMIN = MIN( EMIN, Z( I4-5 ) )
+ 90 CONTINUE
+ I4 = 4
+*
+ 100 CONTINUE
+ I0 = I4 / 4
+*
+* Store EMIN for passing to DLAZQ3.
+*
+ Z( 4*N0-1 ) = EMIN
+*
+* Put -(initial shift) into DMIN.
+*
+ DMIN = -MAX( ZERO, QMIN-TWO*SQRT( QMIN )*SQRT( EMAX ) )
+*
+* Now I0:N0 is unreduced. PP = 0 for ping, PP = 1 for pong.
+*
+ PP = 0
+*
+ NBIG = 30*( N0-I0+1 )
+ DO 120 IWHILB = 1, NBIG
+ IF( I0.GT.N0 )
+ $ GO TO 130
+*
+* While submatrix unfinished take a good dqds step.
+*
+ CALL DLAZQ3( I0, N0, Z, PP, DMIN, SIGMA, DESIG, QMAX, NFAIL,
+ $ ITER, NDIV, IEEE, TTYPE, DMIN1, DMIN2, DN, DN1,
+ $ DN2, TAU )
+*
+ PP = 1 - PP
+*
+* When EMIN is very small check for splits.
+*
+ IF( PP.EQ.0 .AND. N0-I0.GE.3 ) THEN
+ IF( Z( 4*N0 ).LE.TOL2*QMAX .OR.
+ $ Z( 4*N0-1 ).LE.TOL2*SIGMA ) THEN
+ SPLT = I0 - 1
+ QMAX = Z( 4*I0-3 )
+ EMIN = Z( 4*I0-1 )
+ OLDEMN = Z( 4*I0 )
+ DO 110 I4 = 4*I0, 4*( N0-3 ), 4
+ IF( Z( I4 ).LE.TOL2*Z( I4-3 ) .OR.
+ $ Z( I4-1 ).LE.TOL2*SIGMA ) THEN
+ Z( I4-1 ) = -SIGMA
+ SPLT = I4 / 4
+ QMAX = ZERO
+ EMIN = Z( I4+3 )
+ OLDEMN = Z( I4+4 )
+ ELSE
+ QMAX = MAX( QMAX, Z( I4+1 ) )
+ EMIN = MIN( EMIN, Z( I4-1 ) )
+ OLDEMN = MIN( OLDEMN, Z( I4 ) )
+ END IF
+ 110 CONTINUE
+ Z( 4*N0-1 ) = EMIN
+ Z( 4*N0 ) = OLDEMN
+ I0 = SPLT + 1
+ END IF
+ END IF
+*
+ 120 CONTINUE
+*
+ INFO = 2
+ RETURN
+*
+* end IWHILB
+*
+ 130 CONTINUE
+*
+ 140 CONTINUE
+*
+ INFO = 3
+ RETURN
+*
+* end IWHILA
+*
+ 150 CONTINUE
+*
+* Move q's to the front.
+*
+ DO 160 K = 2, N
+ Z( K ) = Z( 4*K-3 )
+ 160 CONTINUE
+*
+* Sort and compute sum of eigenvalues.
+*
+ CALL DLASRT( 'D', N, Z, IINFO )
+*
+ E = ZERO
+ DO 170 K = N, 1, -1
+ E = E + Z( K )
+ 170 CONTINUE
+*
+* Store trace, sum(eigenvalues) and information on performance.
+*
+ Z( 2*N+1 ) = TRACE
+ Z( 2*N+2 ) = E
+ Z( 2*N+3 ) = DBLE( ITER )
+ Z( 2*N+4 ) = DBLE( NDIV ) / DBLE( N**2 )
+ Z( 2*N+5 ) = HUNDRD*NFAIL / DBLE( ITER )
+ RETURN
+*
+* End of DLASQ2
+*
+ END
+ SUBROUTINE DLASQ3( I0, N0, Z, PP, DMIN, SIGMA, DESIG, QMAX, NFAIL,
+ $ ITER, NDIV, IEEE )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ LOGICAL IEEE
+ INTEGER I0, ITER, N0, NDIV, NFAIL, PP
+ DOUBLE PRECISION DESIG, DMIN, QMAX, SIGMA
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION Z( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DLASQ3 checks for deflation, computes a shift (TAU) and calls dqds.
+* In case of failure it changes shifts, and tries again until output
+* is positive.
+*
+* Arguments
+* =========
+*
+* I0 (input) INTEGER
+* First index.
+*
+* N0 (input) INTEGER
+* Last index.
+*
+* Z (input) DOUBLE PRECISION array, dimension ( 4*N )
+* Z holds the qd array.
+*
+* PP (input) INTEGER
+* PP=0 for ping, PP=1 for pong.
+*
+* DMIN (output) DOUBLE PRECISION
+* Minimum value of d.
+*
+* SIGMA (output) DOUBLE PRECISION
+* Sum of shifts used in current segment.
+*
+* DESIG (input/output) DOUBLE PRECISION
+* Lower order part of SIGMA
+*
+* QMAX (input) DOUBLE PRECISION
+* Maximum value of q.
+*
+* NFAIL (output) INTEGER
+* Number of times shift was too big.
+*
+* ITER (output) INTEGER
+* Number of iterations.
+*
+* NDIV (output) INTEGER
+* Number of divisions.
+*
+* TTYPE (output) INTEGER
+* Shift type.
+*
+* IEEE (input) LOGICAL
+* Flag for IEEE or non IEEE arithmetic (passed to DLASQ5).
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION CBIAS
+ PARAMETER ( CBIAS = 1.50D0 )
+ DOUBLE PRECISION ZERO, QURTR, HALF, ONE, TWO, HUNDRD
+ PARAMETER ( ZERO = 0.0D0, QURTR = 0.250D0, HALF = 0.5D0,
+ $ ONE = 1.0D0, TWO = 2.0D0, HUNDRD = 100.0D0 )
+* ..
+* .. Local Scalars ..
+ INTEGER IPN4, J4, N0IN, NN, TTYPE
+ DOUBLE PRECISION DMIN1, DMIN2, DN, DN1, DN2, EPS, S, SAFMIN, T,
+ $ TAU, TEMP, TOL, TOL2
+* ..
+* .. External Subroutines ..
+ EXTERNAL DLASQ4, DLASQ5, DLASQ6
+* ..
+* .. External Function ..
+ DOUBLE PRECISION DLAMCH
+ EXTERNAL DLAMCH
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, MIN, SQRT
+* ..
+* .. Save statement ..
+ SAVE TTYPE
+ SAVE DMIN1, DMIN2, DN, DN1, DN2, TAU
+* ..
+* .. Data statement ..
+ DATA TTYPE / 0 /
+ DATA DMIN1 / ZERO /, DMIN2 / ZERO /, DN / ZERO /,
+ $ DN1 / ZERO /, DN2 / ZERO /, TAU / ZERO /
+* ..
+* .. Executable Statements ..
+*
+ N0IN = N0
+ EPS = DLAMCH( 'Precision' )
+ SAFMIN = DLAMCH( 'Safe minimum' )
+ TOL = EPS*HUNDRD
+ TOL2 = TOL**2
+*
+* Check for deflation.
+*
+ 10 CONTINUE
+*
+ IF( N0.LT.I0 )
+ $ RETURN
+ IF( N0.EQ.I0 )
+ $ GO TO 20
+ NN = 4*N0 + PP
+ IF( N0.EQ.( I0+1 ) )
+ $ GO TO 40
+*
+* Check whether E(N0-1) is negligible, 1 eigenvalue.
+*
+ IF( Z( NN-5 ).GT.TOL2*( SIGMA+Z( NN-3 ) ) .AND.
+ $ Z( NN-2*PP-4 ).GT.TOL2*Z( NN-7 ) )
+ $ GO TO 30
+*
+ 20 CONTINUE
+*
+ Z( 4*N0-3 ) = Z( 4*N0+PP-3 ) + SIGMA
+ N0 = N0 - 1
+ GO TO 10
+*
+* Check whether E(N0-2) is negligible, 2 eigenvalues.
+*
+ 30 CONTINUE
+*
+ IF( Z( NN-9 ).GT.TOL2*SIGMA .AND.
+ $ Z( NN-2*PP-8 ).GT.TOL2*Z( NN-11 ) )
+ $ GO TO 50
+*
+ 40 CONTINUE
+*
+ IF( Z( NN-3 ).GT.Z( NN-7 ) ) THEN
+ S = Z( NN-3 )
+ Z( NN-3 ) = Z( NN-7 )
+ Z( NN-7 ) = S
+ END IF
+ IF( Z( NN-5 ).GT.Z( NN-3 )*TOL2 ) THEN
+ T = HALF*( ( Z( NN-7 )-Z( NN-3 ) )+Z( NN-5 ) )
+ S = Z( NN-3 )*( Z( NN-5 ) / T )
+ IF( S.LE.T ) THEN
+ S = Z( NN-3 )*( Z( NN-5 ) /
+ $ ( T*( ONE+SQRT( ONE+S / T ) ) ) )
+ ELSE
+ S = Z( NN-3 )*( Z( NN-5 ) / ( T+SQRT( T )*SQRT( T+S ) ) )
+ END IF
+ T = Z( NN-7 ) + ( S+Z( NN-5 ) )
+ Z( NN-3 ) = Z( NN-3 )*( Z( NN-7 ) / T )
+ Z( NN-7 ) = T
+ END IF
+ Z( 4*N0-7 ) = Z( NN-7 ) + SIGMA
+ Z( 4*N0-3 ) = Z( NN-3 ) + SIGMA
+ N0 = N0 - 2
+ GO TO 10
+*
+ 50 CONTINUE
+*
+* Reverse the qd-array, if warranted.
+*
+ IF( DMIN.LE.ZERO .OR. N0.LT.N0IN ) THEN
+ IF( CBIAS*Z( 4*I0+PP-3 ).LT.Z( 4*N0+PP-3 ) ) THEN
+ IPN4 = 4*( I0+N0 )
+ DO 60 J4 = 4*I0, 2*( I0+N0-1 ), 4
+ TEMP = Z( J4-3 )
+ Z( J4-3 ) = Z( IPN4-J4-3 )
+ Z( IPN4-J4-3 ) = TEMP
+ TEMP = Z( J4-2 )
+ Z( J4-2 ) = Z( IPN4-J4-2 )
+ Z( IPN4-J4-2 ) = TEMP
+ TEMP = Z( J4-1 )
+ Z( J4-1 ) = Z( IPN4-J4-5 )
+ Z( IPN4-J4-5 ) = TEMP
+ TEMP = Z( J4 )
+ Z( J4 ) = Z( IPN4-J4-4 )
+ Z( IPN4-J4-4 ) = TEMP
+ 60 CONTINUE
+ IF( N0-I0.LE.4 ) THEN
+ Z( 4*N0+PP-1 ) = Z( 4*I0+PP-1 )
+ Z( 4*N0-PP ) = Z( 4*I0-PP )
+ END IF
+ DMIN2 = MIN( DMIN2, Z( 4*N0+PP-1 ) )
+ Z( 4*N0+PP-1 ) = MIN( Z( 4*N0+PP-1 ), Z( 4*I0+PP-1 ),
+ $ Z( 4*I0+PP+3 ) )
+ Z( 4*N0-PP ) = MIN( Z( 4*N0-PP ), Z( 4*I0-PP ),
+ $ Z( 4*I0-PP+4 ) )
+ QMAX = MAX( QMAX, Z( 4*I0+PP-3 ), Z( 4*I0+PP+1 ) )
+ DMIN = -ZERO
+ END IF
+ END IF
+*
+ IF( DMIN.LT.ZERO .OR. SAFMIN*QMAX.LT.MIN( Z( 4*N0+PP-1 ),
+ $ Z( 4*N0+PP-9 ), DMIN2+Z( 4*N0-PP ) ) ) THEN
+*
+* Choose a shift.
+*
+ CALL DLASQ4( I0, N0, Z, PP, N0IN, DMIN, DMIN1, DMIN2, DN, DN1,
+ $ DN2, TAU, TTYPE )
+*
+* Call dqds until DMIN > 0.
+*
+ 80 CONTINUE
+*
+ CALL DLASQ5( I0, N0, Z, PP, TAU, DMIN, DMIN1, DMIN2, DN,
+ $ DN1, DN2, IEEE )
+*
+ NDIV = NDIV + ( N0-I0+2 )
+ ITER = ITER + 1
+*
+* Check status.
+*
+ IF( DMIN.GE.ZERO .AND. DMIN1.GT.ZERO ) THEN
+*
+* Success.
+*
+ GO TO 100
+*
+ ELSE IF( DMIN.LT.ZERO .AND. DMIN1.GT.ZERO .AND.
+ $ Z( 4*( N0-1 )-PP ).LT.TOL*( SIGMA+DN1 ) .AND.
+ $ ABS( DN ).LT.TOL*SIGMA ) THEN
+*
+* Convergence hidden by negative DN.
+*
+ Z( 4*( N0-1 )-PP+2 ) = ZERO
+ DMIN = ZERO
+ GO TO 100
+ ELSE IF( DMIN.LT.ZERO ) THEN
+*
+* TAU too big. Select new TAU and try again.
+*
+ NFAIL = NFAIL + 1
+ IF( TTYPE.LT.-22 ) THEN
+*
+* Failed twice. Play it safe.
+*
+ TAU = ZERO
+ ELSE IF( DMIN1.GT.ZERO ) THEN
+*
+* Late failure. Gives excellent shift.
+*
+ TAU = ( TAU+DMIN )*( ONE-TWO*EPS )
+ TTYPE = TTYPE - 11
+ ELSE
+*
+* Early failure. Divide by 4.
+*
+ TAU = QURTR*TAU
+ TTYPE = TTYPE - 12
+ END IF
+ GO TO 80
+ ELSE IF( DMIN.NE.DMIN ) THEN
+*
+* NaN.
+*
+ TAU = ZERO
+ GO TO 80
+ ELSE
+*
+* Possible underflow. Play it safe.
+*
+ GO TO 90
+ END IF
+ END IF
+*
+* Risk of underflow.
+*
+ 90 CONTINUE
+ CALL DLASQ6( I0, N0, Z, PP, DMIN, DMIN1, DMIN2, DN, DN1, DN2 )
+ NDIV = NDIV + ( N0-I0+2 )
+ ITER = ITER + 1
+ TAU = ZERO
+*
+ 100 CONTINUE
+ IF( TAU.LT.SIGMA ) THEN
+ DESIG = DESIG + TAU
+ T = SIGMA + DESIG
+ DESIG = DESIG - ( T-SIGMA )
+ ELSE
+ T = SIGMA + TAU
+ DESIG = SIGMA - ( T-TAU ) + DESIG
+ END IF
+ SIGMA = T
+*
+ RETURN
+*
+* End of DLASQ3
+*
+ END
+ SUBROUTINE DLASQ4( I0, N0, Z, PP, N0IN, DMIN, DMIN1, DMIN2, DN,
+ $ DN1, DN2, TAU, TTYPE )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER I0, N0, N0IN, PP, TTYPE
+ DOUBLE PRECISION DMIN, DMIN1, DMIN2, DN, DN1, DN2, TAU
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION Z( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DLASQ4 computes an approximation TAU to the smallest eigenvalue
+* using values of d from the previous transform.
+*
+* I0 (input) INTEGER
+* First index.
+*
+* N0 (input) INTEGER
+* Last index.
+*
+* Z (input) DOUBLE PRECISION array, dimension ( 4*N )
+* Z holds the qd array.
+*
+* PP (input) INTEGER
+* PP=0 for ping, PP=1 for pong.
+*
+* N0IN (input) INTEGER
+* The value of N0 at start of EIGTEST.
+*
+* DMIN (input) DOUBLE PRECISION
+* Minimum value of d.
+*
+* DMIN1 (input) DOUBLE PRECISION
+* Minimum value of d, excluding D( N0 ).
+*
+* DMIN2 (input) DOUBLE PRECISION
+* Minimum value of d, excluding D( N0 ) and D( N0-1 ).
+*
+* DN (input) DOUBLE PRECISION
+* d(N)
+*
+* DN1 (input) DOUBLE PRECISION
+* d(N-1)
+*
+* DN2 (input) DOUBLE PRECISION
+* d(N-2)
+*
+* TAU (output) DOUBLE PRECISION
+* This is the shift.
+*
+* TTYPE (output) INTEGER
+* Shift type.
+*
+* Further Details
+* ===============
+* CNST1 = 9/16
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION CNST1, CNST2, CNST3
+ PARAMETER ( CNST1 = 0.5630D0, CNST2 = 1.010D0,
+ $ CNST3 = 1.050D0 )
+ DOUBLE PRECISION QURTR, THIRD, HALF, ZERO, ONE, TWO, HUNDRD
+ PARAMETER ( QURTR = 0.250D0, THIRD = 0.3330D0,
+ $ HALF = 0.50D0, ZERO = 0.0D0, ONE = 1.0D0,
+ $ TWO = 2.0D0, HUNDRD = 100.0D0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I4, NN, NP
+ DOUBLE PRECISION A2, B1, B2, G, GAM, GAP1, GAP2, S
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN, SQRT
+* ..
+* .. Save statement ..
+ SAVE G
+* ..
+* .. Data statement ..
+ DATA G / ZERO /
+* ..
+* .. Executable Statements ..
+*
+* A negative DMIN forces the shift to take that absolute value
+* TTYPE records the type of shift.
+*
+ IF( DMIN.LE.ZERO ) THEN
+ TAU = -DMIN
+ TTYPE = -1
+ RETURN
+ END IF
+*
+ NN = 4*N0 + PP
+ IF( N0IN.EQ.N0 ) THEN
+*
+* No eigenvalues deflated.
+*
+ IF( DMIN.EQ.DN .OR. DMIN.EQ.DN1 ) THEN
+*
+ B1 = SQRT( Z( NN-3 ) )*SQRT( Z( NN-5 ) )
+ B2 = SQRT( Z( NN-7 ) )*SQRT( Z( NN-9 ) )
+ A2 = Z( NN-7 ) + Z( NN-5 )
+*
+* Cases 2 and 3.
+*
+ IF( DMIN.EQ.DN .AND. DMIN1.EQ.DN1 ) THEN
+ GAP2 = DMIN2 - A2 - DMIN2*QURTR
+ IF( GAP2.GT.ZERO .AND. GAP2.GT.B2 ) THEN
+ GAP1 = A2 - DN - ( B2 / GAP2 )*B2
+ ELSE
+ GAP1 = A2 - DN - ( B1+B2 )
+ END IF
+ IF( GAP1.GT.ZERO .AND. GAP1.GT.B1 ) THEN
+ S = MAX( DN-( B1 / GAP1 )*B1, HALF*DMIN )
+ TTYPE = -2
+ ELSE
+ S = ZERO
+ IF( DN.GT.B1 )
+ $ S = DN - B1
+ IF( A2.GT.( B1+B2 ) )
+ $ S = MIN( S, A2-( B1+B2 ) )
+ S = MAX( S, THIRD*DMIN )
+ TTYPE = -3
+ END IF
+ ELSE
+*
+* Case 4.
+*
+ TTYPE = -4
+ S = QURTR*DMIN
+ IF( DMIN.EQ.DN ) THEN
+ GAM = DN
+ A2 = ZERO
+ IF( Z( NN-5 ) .GT. Z( NN-7 ) )
+ $ RETURN
+ B2 = Z( NN-5 ) / Z( NN-7 )
+ NP = NN - 9
+ ELSE
+ NP = NN - 2*PP
+ B2 = Z( NP-2 )
+ GAM = DN1
+ IF( Z( NP-4 ) .GT. Z( NP-2 ) )
+ $ RETURN
+ A2 = Z( NP-4 ) / Z( NP-2 )
+ IF( Z( NN-9 ) .GT. Z( NN-11 ) )
+ $ RETURN
+ B2 = Z( NN-9 ) / Z( NN-11 )
+ NP = NN - 13
+ END IF
+*
+* Approximate contribution to norm squared from I < NN-1.
+*
+ A2 = A2 + B2
+ DO 10 I4 = NP, 4*I0 - 1 + PP, -4
+ IF( B2.EQ.ZERO )
+ $ GO TO 20
+ B1 = B2
+ IF( Z( I4 ) .GT. Z( I4-2 ) )
+ $ RETURN
+ B2 = B2*( Z( I4 ) / Z( I4-2 ) )
+ A2 = A2 + B2
+ IF( HUNDRD*MAX( B2, B1 ).LT.A2 .OR. CNST1.LT.A2 )
+ $ GO TO 20
+ 10 CONTINUE
+ 20 CONTINUE
+ A2 = CNST3*A2
+*
+* Rayleigh quotient residual bound.
+*
+ IF( A2.LT.CNST1 )
+ $ S = GAM*( ONE-SQRT( A2 ) ) / ( ONE+A2 )
+ END IF
+ ELSE IF( DMIN.EQ.DN2 ) THEN
+*
+* Case 5.
+*
+ TTYPE = -5
+ S = QURTR*DMIN
+*
+* Compute contribution to norm squared from I > NN-2.
+*
+ NP = NN - 2*PP
+ B1 = Z( NP-2 )
+ B2 = Z( NP-6 )
+ GAM = DN2
+ IF( Z( NP-8 ).GT.B2 .OR. Z( NP-4 ).GT.B1 )
+ $ RETURN
+ A2 = ( Z( NP-8 ) / B2 )*( ONE+Z( NP-4 ) / B1 )
+*
+* Approximate contribution to norm squared from I < NN-2.
+*
+ IF( N0-I0.GT.2 ) THEN
+ B2 = Z( NN-13 ) / Z( NN-15 )
+ A2 = A2 + B2
+ DO 30 I4 = NN - 17, 4*I0 - 1 + PP, -4
+ IF( B2.EQ.ZERO )
+ $ GO TO 40
+ B1 = B2
+ IF( Z( I4 ) .GT. Z( I4-2 ) )
+ $ RETURN
+ B2 = B2*( Z( I4 ) / Z( I4-2 ) )
+ A2 = A2 + B2
+ IF( HUNDRD*MAX( B2, B1 ).LT.A2 .OR. CNST1.LT.A2 )
+ $ GO TO 40
+ 30 CONTINUE
+ 40 CONTINUE
+ A2 = CNST3*A2
+ END IF
+*
+ IF( A2.LT.CNST1 )
+ $ S = GAM*( ONE-SQRT( A2 ) ) / ( ONE+A2 )
+ ELSE
+*
+* Case 6, no information to guide us.
+*
+ IF( TTYPE.EQ.-6 ) THEN
+ G = G + THIRD*( ONE-G )
+ ELSE IF( TTYPE.EQ.-18 ) THEN
+ G = QURTR*THIRD
+ ELSE
+ G = QURTR
+ END IF
+ S = G*DMIN
+ TTYPE = -6
+ END IF
+*
+ ELSE IF( N0IN.EQ.( N0+1 ) ) THEN
+*
+* One eigenvalue just deflated. Use DMIN1, DN1 for DMIN and DN.
+*
+ IF( DMIN1.EQ.DN1 .AND. DMIN2.EQ.DN2 ) THEN
+*
+* Cases 7 and 8.
+*
+ TTYPE = -7
+ S = THIRD*DMIN1
+ IF( Z( NN-5 ).GT.Z( NN-7 ) )
+ $ RETURN
+ B1 = Z( NN-5 ) / Z( NN-7 )
+ B2 = B1
+ IF( B2.EQ.ZERO )
+ $ GO TO 60
+ DO 50 I4 = 4*N0 - 9 + PP, 4*I0 - 1 + PP, -4
+ A2 = B1
+ IF( Z( I4 ).GT.Z( I4-2 ) )
+ $ RETURN
+ B1 = B1*( Z( I4 ) / Z( I4-2 ) )
+ B2 = B2 + B1
+ IF( HUNDRD*MAX( B1, A2 ).LT.B2 )
+ $ GO TO 60
+ 50 CONTINUE
+ 60 CONTINUE
+ B2 = SQRT( CNST3*B2 )
+ A2 = DMIN1 / ( ONE+B2**2 )
+ GAP2 = HALF*DMIN2 - A2
+ IF( GAP2.GT.ZERO .AND. GAP2.GT.B2*A2 ) THEN
+ S = MAX( S, A2*( ONE-CNST2*A2*( B2 / GAP2 )*B2 ) )
+ ELSE
+ S = MAX( S, A2*( ONE-CNST2*B2 ) )
+ TTYPE = -8
+ END IF
+ ELSE
+*
+* Case 9.
+*
+ S = QURTR*DMIN1
+ IF( DMIN1.EQ.DN1 )
+ $ S = HALF*DMIN1
+ TTYPE = -9
+ END IF
+*
+ ELSE IF( N0IN.EQ.( N0+2 ) ) THEN
+*
+* Two eigenvalues deflated. Use DMIN2, DN2 for DMIN and DN.
+*
+* Cases 10 and 11.
+*
+ IF( DMIN2.EQ.DN2 .AND. TWO*Z( NN-5 ).LT.Z( NN-7 ) ) THEN
+ TTYPE = -10
+ S = THIRD*DMIN2
+ IF( Z( NN-5 ).GT.Z( NN-7 ) )
+ $ RETURN
+ B1 = Z( NN-5 ) / Z( NN-7 )
+ B2 = B1
+ IF( B2.EQ.ZERO )
+ $ GO TO 80
+ DO 70 I4 = 4*N0 - 9 + PP, 4*I0 - 1 + PP, -4
+ IF( Z( I4 ).GT.Z( I4-2 ) )
+ $ RETURN
+ B1 = B1*( Z( I4 ) / Z( I4-2 ) )
+ B2 = B2 + B1
+ IF( HUNDRD*B1.LT.B2 )
+ $ GO TO 80
+ 70 CONTINUE
+ 80 CONTINUE
+ B2 = SQRT( CNST3*B2 )
+ A2 = DMIN2 / ( ONE+B2**2 )
+ GAP2 = Z( NN-7 ) + Z( NN-9 ) -
+ $ SQRT( Z( NN-11 ) )*SQRT( Z( NN-9 ) ) - A2
+ IF( GAP2.GT.ZERO .AND. GAP2.GT.B2*A2 ) THEN
+ S = MAX( S, A2*( ONE-CNST2*A2*( B2 / GAP2 )*B2 ) )
+ ELSE
+ S = MAX( S, A2*( ONE-CNST2*B2 ) )
+ END IF
+ ELSE
+ S = QURTR*DMIN2
+ TTYPE = -11
+ END IF
+ ELSE IF( N0IN.GT.( N0+2 ) ) THEN
+*
+* Case 12, more than two eigenvalues deflated. No information.
+*
+ S = ZERO
+ TTYPE = -12
+ END IF
+*
+ TAU = S
+ RETURN
+*
+* End of DLASQ4
+*
+ END
+ SUBROUTINE DLASQ5( I0, N0, Z, PP, TAU, DMIN, DMIN1, DMIN2, DN,
+ $ DNM1, DNM2, IEEE )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ LOGICAL IEEE
+ INTEGER I0, N0, PP
+ DOUBLE PRECISION DMIN, DMIN1, DMIN2, DN, DNM1, DNM2, TAU
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION Z( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DLASQ5 computes one dqds transform in ping-pong form, one
+* version for IEEE machines another for non IEEE machines.
+*
+* Arguments
+* =========
+*
+* I0 (input) INTEGER
+* First index.
+*
+* N0 (input) INTEGER
+* Last index.
+*
+* Z (input) DOUBLE PRECISION array, dimension ( 4*N )
+* Z holds the qd array. EMIN is stored in Z(4*N0) to avoid
+* an extra argument.
+*
+* PP (input) INTEGER
+* PP=0 for ping, PP=1 for pong.
+*
+* TAU (input) DOUBLE PRECISION
+* This is the shift.
+*
+* DMIN (output) DOUBLE PRECISION
+* Minimum value of d.
+*
+* DMIN1 (output) DOUBLE PRECISION
+* Minimum value of d, excluding D( N0 ).
+*
+* DMIN2 (output) DOUBLE PRECISION
+* Minimum value of d, excluding D( N0 ) and D( N0-1 ).
+*
+* DN (output) DOUBLE PRECISION
+* d(N0), the last value of d.
+*
+* DNM1 (output) DOUBLE PRECISION
+* d(N0-1).
+*
+* DNM2 (output) DOUBLE PRECISION
+* d(N0-2).
+*
+* IEEE (input) LOGICAL
+* Flag for IEEE or non IEEE arithmetic.
+*
+* =====================================================================
+*
+* .. Parameter ..
+ DOUBLE PRECISION ZERO
+ PARAMETER ( ZERO = 0.0D0 )
+* ..
+* .. Local Scalars ..
+ INTEGER J4, J4P2
+ DOUBLE PRECISION D, EMIN, TEMP
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MIN
+* ..
+* .. Executable Statements ..
+*
+ IF( ( N0-I0-1 ).LE.0 )
+ $ RETURN
+*
+ J4 = 4*I0 + PP - 3
+ EMIN = Z( J4+4 )
+ D = Z( J4 ) - TAU
+ DMIN = D
+ DMIN1 = -Z( J4 )
+*
+ IF( IEEE ) THEN
+*
+* Code for IEEE arithmetic.
+*
+ IF( PP.EQ.0 ) THEN
+ DO 10 J4 = 4*I0, 4*( N0-3 ), 4
+ Z( J4-2 ) = D + Z( J4-1 )
+ TEMP = Z( J4+1 ) / Z( J4-2 )
+ D = D*TEMP - TAU
+ DMIN = MIN( DMIN, D )
+ Z( J4 ) = Z( J4-1 )*TEMP
+ EMIN = MIN( Z( J4 ), EMIN )
+ 10 CONTINUE
+ ELSE
+ DO 20 J4 = 4*I0, 4*( N0-3 ), 4
+ Z( J4-3 ) = D + Z( J4 )
+ TEMP = Z( J4+2 ) / Z( J4-3 )
+ D = D*TEMP - TAU
+ DMIN = MIN( DMIN, D )
+ Z( J4-1 ) = Z( J4 )*TEMP
+ EMIN = MIN( Z( J4-1 ), EMIN )
+ 20 CONTINUE
+ END IF
+*
+* Unroll last two steps.
+*
+ DNM2 = D
+ DMIN2 = DMIN
+ J4 = 4*( N0-2 ) - PP
+ J4P2 = J4 + 2*PP - 1
+ Z( J4-2 ) = DNM2 + Z( J4P2 )
+ Z( J4 ) = Z( J4P2+2 )*( Z( J4P2 ) / Z( J4-2 ) )
+ DNM1 = Z( J4P2+2 )*( DNM2 / Z( J4-2 ) ) - TAU
+ DMIN = MIN( DMIN, DNM1 )
+*
+ DMIN1 = DMIN
+ J4 = J4 + 4
+ J4P2 = J4 + 2*PP - 1
+ Z( J4-2 ) = DNM1 + Z( J4P2 )
+ Z( J4 ) = Z( J4P2+2 )*( Z( J4P2 ) / Z( J4-2 ) )
+ DN = Z( J4P2+2 )*( DNM1 / Z( J4-2 ) ) - TAU
+ DMIN = MIN( DMIN, DN )
+*
+ ELSE
+*
+* Code for non IEEE arithmetic.
+*
+ IF( PP.EQ.0 ) THEN
+ DO 30 J4 = 4*I0, 4*( N0-3 ), 4
+ Z( J4-2 ) = D + Z( J4-1 )
+ IF( D.LT.ZERO ) THEN
+ RETURN
+ ELSE
+ Z( J4 ) = Z( J4+1 )*( Z( J4-1 ) / Z( J4-2 ) )
+ D = Z( J4+1 )*( D / Z( J4-2 ) ) - TAU
+ END IF
+ DMIN = MIN( DMIN, D )
+ EMIN = MIN( EMIN, Z( J4 ) )
+ 30 CONTINUE
+ ELSE
+ DO 40 J4 = 4*I0, 4*( N0-3 ), 4
+ Z( J4-3 ) = D + Z( J4 )
+ IF( D.LT.ZERO ) THEN
+ RETURN
+ ELSE
+ Z( J4-1 ) = Z( J4+2 )*( Z( J4 ) / Z( J4-3 ) )
+ D = Z( J4+2 )*( D / Z( J4-3 ) ) - TAU
+ END IF
+ DMIN = MIN( DMIN, D )
+ EMIN = MIN( EMIN, Z( J4-1 ) )
+ 40 CONTINUE
+ END IF
+*
+* Unroll last two steps.
+*
+ DNM2 = D
+ DMIN2 = DMIN
+ J4 = 4*( N0-2 ) - PP
+ J4P2 = J4 + 2*PP - 1
+ Z( J4-2 ) = DNM2 + Z( J4P2 )
+ IF( DNM2.LT.ZERO ) THEN
+ RETURN
+ ELSE
+ Z( J4 ) = Z( J4P2+2 )*( Z( J4P2 ) / Z( J4-2 ) )
+ DNM1 = Z( J4P2+2 )*( DNM2 / Z( J4-2 ) ) - TAU
+ END IF
+ DMIN = MIN( DMIN, DNM1 )
+*
+ DMIN1 = DMIN
+ J4 = J4 + 4
+ J4P2 = J4 + 2*PP - 1
+ Z( J4-2 ) = DNM1 + Z( J4P2 )
+ IF( DNM1.LT.ZERO ) THEN
+ RETURN
+ ELSE
+ Z( J4 ) = Z( J4P2+2 )*( Z( J4P2 ) / Z( J4-2 ) )
+ DN = Z( J4P2+2 )*( DNM1 / Z( J4-2 ) ) - TAU
+ END IF
+ DMIN = MIN( DMIN, DN )
+*
+ END IF
+*
+ Z( J4+2 ) = DN
+ Z( 4*N0-PP ) = EMIN
+ RETURN
+*
+* End of DLASQ5
+*
+ END
+ SUBROUTINE DLASQ6( I0, N0, Z, PP, DMIN, DMIN1, DMIN2, DN,
+ $ DNM1, DNM2 )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER I0, N0, PP
+ DOUBLE PRECISION DMIN, DMIN1, DMIN2, DN, DNM1, DNM2
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION Z( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DLASQ6 computes one dqd (shift equal to zero) transform in
+* ping-pong form, with protection against underflow and overflow.
+*
+* Arguments
+* =========
+*
+* I0 (input) INTEGER
+* First index.
+*
+* N0 (input) INTEGER
+* Last index.
+*
+* Z (input) DOUBLE PRECISION array, dimension ( 4*N )
+* Z holds the qd array. EMIN is stored in Z(4*N0) to avoid
+* an extra argument.
+*
+* PP (input) INTEGER
+* PP=0 for ping, PP=1 for pong.
+*
+* DMIN (output) DOUBLE PRECISION
+* Minimum value of d.
+*
+* DMIN1 (output) DOUBLE PRECISION
+* Minimum value of d, excluding D( N0 ).
+*
+* DMIN2 (output) DOUBLE PRECISION
+* Minimum value of d, excluding D( N0 ) and D( N0-1 ).
+*
+* DN (output) DOUBLE PRECISION
+* d(N0), the last value of d.
+*
+* DNM1 (output) DOUBLE PRECISION
+* d(N0-1).
+*
+* DNM2 (output) DOUBLE PRECISION
+* d(N0-2).
+*
+* =====================================================================
+*
+* .. Parameter ..
+ DOUBLE PRECISION ZERO
+ PARAMETER ( ZERO = 0.0D0 )
+* ..
+* .. Local Scalars ..
+ INTEGER J4, J4P2
+ DOUBLE PRECISION D, EMIN, SAFMIN, TEMP
+* ..
+* .. External Function ..
+ DOUBLE PRECISION DLAMCH
+ EXTERNAL DLAMCH
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MIN
+* ..
+* .. Executable Statements ..
+*
+ IF( ( N0-I0-1 ).LE.0 )
+ $ RETURN
+*
+ SAFMIN = DLAMCH( 'Safe minimum' )
+ J4 = 4*I0 + PP - 3
+ EMIN = Z( J4+4 )
+ D = Z( J4 )
+ DMIN = D
+*
+ IF( PP.EQ.0 ) THEN
+ DO 10 J4 = 4*I0, 4*( N0-3 ), 4
+ Z( J4-2 ) = D + Z( J4-1 )
+ IF( Z( J4-2 ).EQ.ZERO ) THEN
+ Z( J4 ) = ZERO
+ D = Z( J4+1 )
+ DMIN = D
+ EMIN = ZERO
+ ELSE IF( SAFMIN*Z( J4+1 ).LT.Z( J4-2 ) .AND.
+ $ SAFMIN*Z( J4-2 ).LT.Z( J4+1 ) ) THEN
+ TEMP = Z( J4+1 ) / Z( J4-2 )
+ Z( J4 ) = Z( J4-1 )*TEMP
+ D = D*TEMP
+ ELSE
+ Z( J4 ) = Z( J4+1 )*( Z( J4-1 ) / Z( J4-2 ) )
+ D = Z( J4+1 )*( D / Z( J4-2 ) )
+ END IF
+ DMIN = MIN( DMIN, D )
+ EMIN = MIN( EMIN, Z( J4 ) )
+ 10 CONTINUE
+ ELSE
+ DO 20 J4 = 4*I0, 4*( N0-3 ), 4
+ Z( J4-3 ) = D + Z( J4 )
+ IF( Z( J4-3 ).EQ.ZERO ) THEN
+ Z( J4-1 ) = ZERO
+ D = Z( J4+2 )
+ DMIN = D
+ EMIN = ZERO
+ ELSE IF( SAFMIN*Z( J4+2 ).LT.Z( J4-3 ) .AND.
+ $ SAFMIN*Z( J4-3 ).LT.Z( J4+2 ) ) THEN
+ TEMP = Z( J4+2 ) / Z( J4-3 )
+ Z( J4-1 ) = Z( J4 )*TEMP
+ D = D*TEMP
+ ELSE
+ Z( J4-1 ) = Z( J4+2 )*( Z( J4 ) / Z( J4-3 ) )
+ D = Z( J4+2 )*( D / Z( J4-3 ) )
+ END IF
+ DMIN = MIN( DMIN, D )
+ EMIN = MIN( EMIN, Z( J4-1 ) )
+ 20 CONTINUE
+ END IF
+*
+* Unroll last two steps.
+*
+ DNM2 = D
+ DMIN2 = DMIN
+ J4 = 4*( N0-2 ) - PP
+ J4P2 = J4 + 2*PP - 1
+ Z( J4-2 ) = DNM2 + Z( J4P2 )
+ IF( Z( J4-2 ).EQ.ZERO ) THEN
+ Z( J4 ) = ZERO
+ DNM1 = Z( J4P2+2 )
+ DMIN = DNM1
+ EMIN = ZERO
+ ELSE IF( SAFMIN*Z( J4P2+2 ).LT.Z( J4-2 ) .AND.
+ $ SAFMIN*Z( J4-2 ).LT.Z( J4P2+2 ) ) THEN
+ TEMP = Z( J4P2+2 ) / Z( J4-2 )
+ Z( J4 ) = Z( J4P2 )*TEMP
+ DNM1 = DNM2*TEMP
+ ELSE
+ Z( J4 ) = Z( J4P2+2 )*( Z( J4P2 ) / Z( J4-2 ) )
+ DNM1 = Z( J4P2+2 )*( DNM2 / Z( J4-2 ) )
+ END IF
+ DMIN = MIN( DMIN, DNM1 )
+*
+ DMIN1 = DMIN
+ J4 = J4 + 4
+ J4P2 = J4 + 2*PP - 1
+ Z( J4-2 ) = DNM1 + Z( J4P2 )
+ IF( Z( J4-2 ).EQ.ZERO ) THEN
+ Z( J4 ) = ZERO
+ DN = Z( J4P2+2 )
+ DMIN = DN
+ EMIN = ZERO
+ ELSE IF( SAFMIN*Z( J4P2+2 ).LT.Z( J4-2 ) .AND.
+ $ SAFMIN*Z( J4-2 ).LT.Z( J4P2+2 ) ) THEN
+ TEMP = Z( J4P2+2 ) / Z( J4-2 )
+ Z( J4 ) = Z( J4P2 )*TEMP
+ DN = DNM1*TEMP
+ ELSE
+ Z( J4 ) = Z( J4P2+2 )*( Z( J4P2 ) / Z( J4-2 ) )
+ DN = Z( J4P2+2 )*( DNM1 / Z( J4-2 ) )
+ END IF
+ DMIN = MIN( DMIN, DN )
+*
+ Z( J4+2 ) = DN
+ Z( 4*N0-PP ) = EMIN
+ RETURN
+*
+* End of DLASQ6
+*
+ END
+ SUBROUTINE DLASR( SIDE, PIVOT, DIRECT, M, N, C, S, A, LDA )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER DIRECT, PIVOT, SIDE
+ INTEGER LDA, M, N
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION A( LDA, * ), C( * ), S( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DLASR applies a sequence of plane rotations to a real matrix A,
+* from either the left or the right.
+*
+* When SIDE = 'L', the transformation takes the form
+*
+* A := P*A
+*
+* and when SIDE = 'R', the transformation takes the form
+*
+* A := A*P**T
+*
+* where P is an orthogonal matrix consisting of a sequence of z plane
+* rotations, with z = M when SIDE = 'L' and z = N when SIDE = 'R',
+* and P**T is the transpose of P.
+*
+* When DIRECT = 'F' (Forward sequence), then
+*
+* P = P(z-1) * ... * P(2) * P(1)
+*
+* and when DIRECT = 'B' (Backward sequence), then
+*
+* P = P(1) * P(2) * ... * P(z-1)
+*
+* where P(k) is a plane rotation matrix defined by the 2-by-2 rotation
+*
+* R(k) = ( c(k) s(k) )
+* = ( -s(k) c(k) ).
+*
+* When PIVOT = 'V' (Variable pivot), the rotation is performed
+* for the plane (k,k+1), i.e., P(k) has the form
+*
+* P(k) = ( 1 )
+* ( ... )
+* ( 1 )
+* ( c(k) s(k) )
+* ( -s(k) c(k) )
+* ( 1 )
+* ( ... )
+* ( 1 )
+*
+* where R(k) appears as a rank-2 modification to the identity matrix in
+* rows and columns k and k+1.
+*
+* When PIVOT = 'T' (Top pivot), the rotation is performed for the
+* plane (1,k+1), so P(k) has the form
+*
+* P(k) = ( c(k) s(k) )
+* ( 1 )
+* ( ... )
+* ( 1 )
+* ( -s(k) c(k) )
+* ( 1 )
+* ( ... )
+* ( 1 )
+*
+* where R(k) appears in rows and columns 1 and k+1.
+*
+* Similarly, when PIVOT = 'B' (Bottom pivot), the rotation is
+* performed for the plane (k,z), giving P(k) the form
+*
+* P(k) = ( 1 )
+* ( ... )
+* ( 1 )
+* ( c(k) s(k) )
+* ( 1 )
+* ( ... )
+* ( 1 )
+* ( -s(k) c(k) )
+*
+* where R(k) appears in rows and columns k and z. The rotations are
+* performed without ever forming P(k) explicitly.
+*
+* Arguments
+* =========
+*
+* SIDE (input) CHARACTER*1
+* Specifies whether the plane rotation matrix P is applied to
+* A on the left or the right.
+* = 'L': Left, compute A := P*A
+* = 'R': Right, compute A:= A*P**T
+*
+* PIVOT (input) CHARACTER*1
+* Specifies the plane for which P(k) is a plane rotation
+* matrix.
+* = 'V': Variable pivot, the plane (k,k+1)
+* = 'T': Top pivot, the plane (1,k+1)
+* = 'B': Bottom pivot, the plane (k,z)
+*
+* DIRECT (input) CHARACTER*1
+* Specifies whether P is a forward or backward sequence of
+* plane rotations.
+* = 'F': Forward, P = P(z-1)*...*P(2)*P(1)
+* = 'B': Backward, P = P(1)*P(2)*...*P(z-1)
+*
+* M (input) INTEGER
+* The number of rows of the matrix A. If m <= 1, an immediate
+* return is effected.
+*
+* N (input) INTEGER
+* The number of columns of the matrix A. If n <= 1, an
+* immediate return is effected.
+*
+* C (input) DOUBLE PRECISION array, dimension
+* (M-1) if SIDE = 'L'
+* (N-1) if SIDE = 'R'
+* The cosines c(k) of the plane rotations.
+*
+* S (input) DOUBLE PRECISION array, dimension
+* (M-1) if SIDE = 'L'
+* (N-1) if SIDE = 'R'
+* The sines s(k) of the plane rotations. The 2-by-2 plane
+* rotation part of the matrix P(k), R(k), has the form
+* R(k) = ( c(k) s(k) )
+* ( -s(k) c(k) ).
+*
+* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+* The M-by-N matrix A. On exit, A is overwritten by P*A if
+* SIDE = 'R' or by A*P**T if SIDE = 'L'.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,M).
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE, ZERO
+ PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, INFO, J
+ DOUBLE PRECISION CTEMP, STEMP, TEMP
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters
+*
+ INFO = 0
+ IF( .NOT.( LSAME( SIDE, 'L' ) .OR. LSAME( SIDE, 'R' ) ) ) THEN
+ INFO = 1
+ ELSE IF( .NOT.( LSAME( PIVOT, 'V' ) .OR. LSAME( PIVOT,
+ $ 'T' ) .OR. LSAME( PIVOT, 'B' ) ) ) THEN
+ INFO = 2
+ ELSE IF( .NOT.( LSAME( DIRECT, 'F' ) .OR. LSAME( DIRECT, 'B' ) ) )
+ $ THEN
+ INFO = 3
+ ELSE IF( M.LT.0 ) THEN
+ INFO = 4
+ ELSE IF( N.LT.0 ) THEN
+ INFO = 5
+ ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+ INFO = 9
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DLASR ', INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( ( M.EQ.0 ) .OR. ( N.EQ.0 ) )
+ $ RETURN
+ IF( LSAME( SIDE, 'L' ) ) THEN
+*
+* Form P * A
+*
+ IF( LSAME( PIVOT, 'V' ) ) THEN
+ IF( LSAME( DIRECT, 'F' ) ) THEN
+ DO 20 J = 1, M - 1
+ CTEMP = C( J )
+ STEMP = S( J )
+ IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
+ DO 10 I = 1, N
+ TEMP = A( J+1, I )
+ A( J+1, I ) = CTEMP*TEMP - STEMP*A( J, I )
+ A( J, I ) = STEMP*TEMP + CTEMP*A( J, I )
+ 10 CONTINUE
+ END IF
+ 20 CONTINUE
+ ELSE IF( LSAME( DIRECT, 'B' ) ) THEN
+ DO 40 J = M - 1, 1, -1
+ CTEMP = C( J )
+ STEMP = S( J )
+ IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
+ DO 30 I = 1, N
+ TEMP = A( J+1, I )
+ A( J+1, I ) = CTEMP*TEMP - STEMP*A( J, I )
+ A( J, I ) = STEMP*TEMP + CTEMP*A( J, I )
+ 30 CONTINUE
+ END IF
+ 40 CONTINUE
+ END IF
+ ELSE IF( LSAME( PIVOT, 'T' ) ) THEN
+ IF( LSAME( DIRECT, 'F' ) ) THEN
+ DO 60 J = 2, M
+ CTEMP = C( J-1 )
+ STEMP = S( J-1 )
+ IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
+ DO 50 I = 1, N
+ TEMP = A( J, I )
+ A( J, I ) = CTEMP*TEMP - STEMP*A( 1, I )
+ A( 1, I ) = STEMP*TEMP + CTEMP*A( 1, I )
+ 50 CONTINUE
+ END IF
+ 60 CONTINUE
+ ELSE IF( LSAME( DIRECT, 'B' ) ) THEN
+ DO 80 J = M, 2, -1
+ CTEMP = C( J-1 )
+ STEMP = S( J-1 )
+ IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
+ DO 70 I = 1, N
+ TEMP = A( J, I )
+ A( J, I ) = CTEMP*TEMP - STEMP*A( 1, I )
+ A( 1, I ) = STEMP*TEMP + CTEMP*A( 1, I )
+ 70 CONTINUE
+ END IF
+ 80 CONTINUE
+ END IF
+ ELSE IF( LSAME( PIVOT, 'B' ) ) THEN
+ IF( LSAME( DIRECT, 'F' ) ) THEN
+ DO 100 J = 1, M - 1
+ CTEMP = C( J )
+ STEMP = S( J )
+ IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
+ DO 90 I = 1, N
+ TEMP = A( J, I )
+ A( J, I ) = STEMP*A( M, I ) + CTEMP*TEMP
+ A( M, I ) = CTEMP*A( M, I ) - STEMP*TEMP
+ 90 CONTINUE
+ END IF
+ 100 CONTINUE
+ ELSE IF( LSAME( DIRECT, 'B' ) ) THEN
+ DO 120 J = M - 1, 1, -1
+ CTEMP = C( J )
+ STEMP = S( J )
+ IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
+ DO 110 I = 1, N
+ TEMP = A( J, I )
+ A( J, I ) = STEMP*A( M, I ) + CTEMP*TEMP
+ A( M, I ) = CTEMP*A( M, I ) - STEMP*TEMP
+ 110 CONTINUE
+ END IF
+ 120 CONTINUE
+ END IF
+ END IF
+ ELSE IF( LSAME( SIDE, 'R' ) ) THEN
+*
+* Form A * P'
+*
+ IF( LSAME( PIVOT, 'V' ) ) THEN
+ IF( LSAME( DIRECT, 'F' ) ) THEN
+ DO 140 J = 1, N - 1
+ CTEMP = C( J )
+ STEMP = S( J )
+ IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
+ DO 130 I = 1, M
+ TEMP = A( I, J+1 )
+ A( I, J+1 ) = CTEMP*TEMP - STEMP*A( I, J )
+ A( I, J ) = STEMP*TEMP + CTEMP*A( I, J )
+ 130 CONTINUE
+ END IF
+ 140 CONTINUE
+ ELSE IF( LSAME( DIRECT, 'B' ) ) THEN
+ DO 160 J = N - 1, 1, -1
+ CTEMP = C( J )
+ STEMP = S( J )
+ IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
+ DO 150 I = 1, M
+ TEMP = A( I, J+1 )
+ A( I, J+1 ) = CTEMP*TEMP - STEMP*A( I, J )
+ A( I, J ) = STEMP*TEMP + CTEMP*A( I, J )
+ 150 CONTINUE
+ END IF
+ 160 CONTINUE
+ END IF
+ ELSE IF( LSAME( PIVOT, 'T' ) ) THEN
+ IF( LSAME( DIRECT, 'F' ) ) THEN
+ DO 180 J = 2, N
+ CTEMP = C( J-1 )
+ STEMP = S( J-1 )
+ IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
+ DO 170 I = 1, M
+ TEMP = A( I, J )
+ A( I, J ) = CTEMP*TEMP - STEMP*A( I, 1 )
+ A( I, 1 ) = STEMP*TEMP + CTEMP*A( I, 1 )
+ 170 CONTINUE
+ END IF
+ 180 CONTINUE
+ ELSE IF( LSAME( DIRECT, 'B' ) ) THEN
+ DO 200 J = N, 2, -1
+ CTEMP = C( J-1 )
+ STEMP = S( J-1 )
+ IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
+ DO 190 I = 1, M
+ TEMP = A( I, J )
+ A( I, J ) = CTEMP*TEMP - STEMP*A( I, 1 )
+ A( I, 1 ) = STEMP*TEMP + CTEMP*A( I, 1 )
+ 190 CONTINUE
+ END IF
+ 200 CONTINUE
+ END IF
+ ELSE IF( LSAME( PIVOT, 'B' ) ) THEN
+ IF( LSAME( DIRECT, 'F' ) ) THEN
+ DO 220 J = 1, N - 1
+ CTEMP = C( J )
+ STEMP = S( J )
+ IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
+ DO 210 I = 1, M
+ TEMP = A( I, J )
+ A( I, J ) = STEMP*A( I, N ) + CTEMP*TEMP
+ A( I, N ) = CTEMP*A( I, N ) - STEMP*TEMP
+ 210 CONTINUE
+ END IF
+ 220 CONTINUE
+ ELSE IF( LSAME( DIRECT, 'B' ) ) THEN
+ DO 240 J = N - 1, 1, -1
+ CTEMP = C( J )
+ STEMP = S( J )
+ IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
+ DO 230 I = 1, M
+ TEMP = A( I, J )
+ A( I, J ) = STEMP*A( I, N ) + CTEMP*TEMP
+ A( I, N ) = CTEMP*A( I, N ) - STEMP*TEMP
+ 230 CONTINUE
+ END IF
+ 240 CONTINUE
+ END IF
+ END IF
+ END IF
+*
+ RETURN
+*
+* End of DLASR
+*
+ END
+ SUBROUTINE DLASRT( ID, N, D, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER ID
+ INTEGER INFO, N
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION D( * )
+* ..
+*
+* Purpose
+* =======
+*
+* Sort the numbers in D in increasing order (if ID = 'I') or
+* in decreasing order (if ID = 'D' ).
+*
+* Use Quick Sort, reverting to Insertion sort on arrays of
+* size <= 20. Dimension of STACK limits N to about 2**32.
+*
+* Arguments
+* =========
+*
+* ID (input) CHARACTER*1
+* = 'I': sort D in increasing order;
+* = 'D': sort D in decreasing order.
+*
+* N (input) INTEGER
+* The length of the array D.
+*
+* D (input/output) DOUBLE PRECISION array, dimension (N)
+* On entry, the array to be sorted.
+* On exit, D has been sorted into increasing order
+* (D(1) <= ... <= D(N) ) or into decreasing order
+* (D(1) >= ... >= D(N) ), depending on ID.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+*
+* =====================================================================
+*
+* .. Parameters ..
+ INTEGER SELECT
+ PARAMETER ( SELECT = 20 )
+* ..
+* .. Local Scalars ..
+ INTEGER DIR, ENDD, I, J, START, STKPNT
+ DOUBLE PRECISION D1, D2, D3, DMNMX, TMP
+* ..
+* .. Local Arrays ..
+ INTEGER STACK( 2, 32 )
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL XERBLA
+* ..
+* .. Executable Statements ..
+*
+* Test the input paramters.
+*
+ INFO = 0
+ DIR = -1
+ IF( LSAME( ID, 'D' ) ) THEN
+ DIR = 0
+ ELSE IF( LSAME( ID, 'I' ) ) THEN
+ DIR = 1
+ END IF
+ IF( DIR.EQ.-1 ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DLASRT', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.LE.1 )
+ $ RETURN
+*
+ STKPNT = 1
+ STACK( 1, 1 ) = 1
+ STACK( 2, 1 ) = N
+ 10 CONTINUE
+ START = STACK( 1, STKPNT )
+ ENDD = STACK( 2, STKPNT )
+ STKPNT = STKPNT - 1
+ IF( ENDD-START.LE.SELECT .AND. ENDD-START.GT.0 ) THEN
+*
+* Do Insertion sort on D( START:ENDD )
+*
+ IF( DIR.EQ.0 ) THEN
+*
+* Sort into decreasing order
+*
+ DO 30 I = START + 1, ENDD
+ DO 20 J = I, START + 1, -1
+ IF( D( J ).GT.D( J-1 ) ) THEN
+ DMNMX = D( J )
+ D( J ) = D( J-1 )
+ D( J-1 ) = DMNMX
+ ELSE
+ GO TO 30
+ END IF
+ 20 CONTINUE
+ 30 CONTINUE
+*
+ ELSE
+*
+* Sort into increasing order
+*
+ DO 50 I = START + 1, ENDD
+ DO 40 J = I, START + 1, -1
+ IF( D( J ).LT.D( J-1 ) ) THEN
+ DMNMX = D( J )
+ D( J ) = D( J-1 )
+ D( J-1 ) = DMNMX
+ ELSE
+ GO TO 50
+ END IF
+ 40 CONTINUE
+ 50 CONTINUE
+*
+ END IF
+*
+ ELSE IF( ENDD-START.GT.SELECT ) THEN
+*
+* Partition D( START:ENDD ) and stack parts, largest one first
+*
+* Choose partition entry as median of 3
+*
+ D1 = D( START )
+ D2 = D( ENDD )
+ I = ( START+ENDD ) / 2
+ D3 = D( I )
+ IF( D1.LT.D2 ) THEN
+ IF( D3.LT.D1 ) THEN
+ DMNMX = D1
+ ELSE IF( D3.LT.D2 ) THEN
+ DMNMX = D3
+ ELSE
+ DMNMX = D2
+ END IF
+ ELSE
+ IF( D3.LT.D2 ) THEN
+ DMNMX = D2
+ ELSE IF( D3.LT.D1 ) THEN
+ DMNMX = D3
+ ELSE
+ DMNMX = D1
+ END IF
+ END IF
+*
+ IF( DIR.EQ.0 ) THEN
+*
+* Sort into decreasing order
+*
+ I = START - 1
+ J = ENDD + 1
+ 60 CONTINUE
+ 70 CONTINUE
+ J = J - 1
+ IF( D( J ).LT.DMNMX )
+ $ GO TO 70
+ 80 CONTINUE
+ I = I + 1
+ IF( D( I ).GT.DMNMX )
+ $ GO TO 80
+ IF( I.LT.J ) THEN
+ TMP = D( I )
+ D( I ) = D( J )
+ D( J ) = TMP
+ GO TO 60
+ END IF
+ IF( J-START.GT.ENDD-J-1 ) THEN
+ STKPNT = STKPNT + 1
+ STACK( 1, STKPNT ) = START
+ STACK( 2, STKPNT ) = J
+ STKPNT = STKPNT + 1
+ STACK( 1, STKPNT ) = J + 1
+ STACK( 2, STKPNT ) = ENDD
+ ELSE
+ STKPNT = STKPNT + 1
+ STACK( 1, STKPNT ) = J + 1
+ STACK( 2, STKPNT ) = ENDD
+ STKPNT = STKPNT + 1
+ STACK( 1, STKPNT ) = START
+ STACK( 2, STKPNT ) = J
+ END IF
+ ELSE
+*
+* Sort into increasing order
+*
+ I = START - 1
+ J = ENDD + 1
+ 90 CONTINUE
+ 100 CONTINUE
+ J = J - 1
+ IF( D( J ).GT.DMNMX )
+ $ GO TO 100
+ 110 CONTINUE
+ I = I + 1
+ IF( D( I ).LT.DMNMX )
+ $ GO TO 110
+ IF( I.LT.J ) THEN
+ TMP = D( I )
+ D( I ) = D( J )
+ D( J ) = TMP
+ GO TO 90
+ END IF
+ IF( J-START.GT.ENDD-J-1 ) THEN
+ STKPNT = STKPNT + 1
+ STACK( 1, STKPNT ) = START
+ STACK( 2, STKPNT ) = J
+ STKPNT = STKPNT + 1
+ STACK( 1, STKPNT ) = J + 1
+ STACK( 2, STKPNT ) = ENDD
+ ELSE
+ STKPNT = STKPNT + 1
+ STACK( 1, STKPNT ) = J + 1
+ STACK( 2, STKPNT ) = ENDD
+ STKPNT = STKPNT + 1
+ STACK( 1, STKPNT ) = START
+ STACK( 2, STKPNT ) = J
+ END IF
+ END IF
+ END IF
+ IF( STKPNT.GT.0 )
+ $ GO TO 10
+ RETURN
+*
+* End of DLASRT
+*
+ END
+ SUBROUTINE DLASSQ( N, X, INCX, SCALE, SUMSQ )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INCX, N
+ DOUBLE PRECISION SCALE, SUMSQ
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION X( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DLASSQ returns the values scl and smsq such that
+*
+* ( scl**2 )*smsq = x( 1 )**2 +...+ x( n )**2 + ( scale**2 )*sumsq,
+*
+* where x( i ) = X( 1 + ( i - 1 )*INCX ). The value of sumsq is
+* assumed to be non-negative and scl returns the value
+*
+* scl = max( scale, abs( x( i ) ) ).
+*
+* scale and sumsq must be supplied in SCALE and SUMSQ and
+* scl and smsq are overwritten on SCALE and SUMSQ respectively.
+*
+* The routine makes only one pass through the vector x.
+*
+* Arguments
+* =========
+*
+* N (input) INTEGER
+* The number of elements to be used from the vector X.
+*
+* X (input) DOUBLE PRECISION array, dimension (N)
+* The vector for which a scaled sum of squares is computed.
+* x( i ) = X( 1 + ( i - 1 )*INCX ), 1 <= i <= n.
+*
+* INCX (input) INTEGER
+* The increment between successive values of the vector X.
+* INCX > 0.
+*
+* SCALE (input/output) DOUBLE PRECISION
+* On entry, the value scale in the equation above.
+* On exit, SCALE is overwritten with scl , the scaling factor
+* for the sum of squares.
+*
+* SUMSQ (input/output) DOUBLE PRECISION
+* On entry, the value sumsq in the equation above.
+* On exit, SUMSQ is overwritten with smsq , the basic sum of
+* squares from which scl has been factored out.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO
+ PARAMETER ( ZERO = 0.0D+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER IX
+ DOUBLE PRECISION ABSXI
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS
+* ..
+* .. Executable Statements ..
+*
+ IF( N.GT.0 ) THEN
+ DO 10 IX = 1, 1 + ( N-1 )*INCX, INCX
+ IF( X( IX ).NE.ZERO ) THEN
+ ABSXI = ABS( X( IX ) )
+ IF( SCALE.LT.ABSXI ) THEN
+ SUMSQ = 1 + SUMSQ*( SCALE / ABSXI )**2
+ SCALE = ABSXI
+ ELSE
+ SUMSQ = SUMSQ + ( ABSXI / SCALE )**2
+ END IF
+ END IF
+ 10 CONTINUE
+ END IF
+ RETURN
+*
+* End of DLASSQ
+*
+ END
+ SUBROUTINE DLASV2( F, G, H, SSMIN, SSMAX, SNR, CSR, SNL, CSL )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ DOUBLE PRECISION CSL, CSR, F, G, H, SNL, SNR, SSMAX, SSMIN
+* ..
+*
+* Purpose
+* =======
+*
+* DLASV2 computes the singular value decomposition of a 2-by-2
+* triangular matrix
+* [ F G ]
+* [ 0 H ].
+* On return, abs(SSMAX) is the larger singular value, abs(SSMIN) is the
+* smaller singular value, and (CSL,SNL) and (CSR,SNR) are the left and
+* right singular vectors for abs(SSMAX), giving the decomposition
+*
+* [ CSL SNL ] [ F G ] [ CSR -SNR ] = [ SSMAX 0 ]
+* [-SNL CSL ] [ 0 H ] [ SNR CSR ] [ 0 SSMIN ].
+*
+* Arguments
+* =========
+*
+* F (input) DOUBLE PRECISION
+* The (1,1) element of the 2-by-2 matrix.
+*
+* G (input) DOUBLE PRECISION
+* The (1,2) element of the 2-by-2 matrix.
+*
+* H (input) DOUBLE PRECISION
+* The (2,2) element of the 2-by-2 matrix.
+*
+* SSMIN (output) DOUBLE PRECISION
+* abs(SSMIN) is the smaller singular value.
+*
+* SSMAX (output) DOUBLE PRECISION
+* abs(SSMAX) is the larger singular value.
+*
+* SNL (output) DOUBLE PRECISION
+* CSL (output) DOUBLE PRECISION
+* The vector (CSL, SNL) is a unit left singular vector for the
+* singular value abs(SSMAX).
+*
+* SNR (output) DOUBLE PRECISION
+* CSR (output) DOUBLE PRECISION
+* The vector (CSR, SNR) is a unit right singular vector for the
+* singular value abs(SSMAX).
+*
+* Further Details
+* ===============
+*
+* Any input parameter may be aliased with any output parameter.
+*
+* Barring over/underflow and assuming a guard digit in subtraction, all
+* output quantities are correct to within a few units in the last
+* place (ulps).
+*
+* In IEEE arithmetic, the code works correctly if one matrix element is
+* infinite.
+*
+* Overflow will not occur unless the largest singular value itself
+* overflows or is within a few ulps of overflow. (On machines with
+* partial overflow, like the Cray, overflow may occur if the largest
+* singular value is within a factor of 2 of overflow.)
+*
+* Underflow is harmless if underflow is gradual. Otherwise, results
+* may correspond to a matrix modified by perturbations of size near
+* the underflow threshold.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO
+ PARAMETER ( ZERO = 0.0D0 )
+ DOUBLE PRECISION HALF
+ PARAMETER ( HALF = 0.5D0 )
+ DOUBLE PRECISION ONE
+ PARAMETER ( ONE = 1.0D0 )
+ DOUBLE PRECISION TWO
+ PARAMETER ( TWO = 2.0D0 )
+ DOUBLE PRECISION FOUR
+ PARAMETER ( FOUR = 4.0D0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL GASMAL, SWAP
+ INTEGER PMAX
+ DOUBLE PRECISION A, CLT, CRT, D, FA, FT, GA, GT, HA, HT, L, M,
+ $ MM, R, S, SLT, SRT, T, TEMP, TSIGN, TT
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, SIGN, SQRT
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DLAMCH
+ EXTERNAL DLAMCH
+* ..
+* .. Executable Statements ..
+*
+ FT = F
+ FA = ABS( FT )
+ HT = H
+ HA = ABS( H )
+*
+* PMAX points to the maximum absolute element of matrix
+* PMAX = 1 if F largest in absolute values
+* PMAX = 2 if G largest in absolute values
+* PMAX = 3 if H largest in absolute values
+*
+ PMAX = 1
+ SWAP = ( HA.GT.FA )
+ IF( SWAP ) THEN
+ PMAX = 3
+ TEMP = FT
+ FT = HT
+ HT = TEMP
+ TEMP = FA
+ FA = HA
+ HA = TEMP
+*
+* Now FA .ge. HA
+*
+ END IF
+ GT = G
+ GA = ABS( GT )
+ IF( GA.EQ.ZERO ) THEN
+*
+* Diagonal matrix
+*
+ SSMIN = HA
+ SSMAX = FA
+ CLT = ONE
+ CRT = ONE
+ SLT = ZERO
+ SRT = ZERO
+ ELSE
+ GASMAL = .TRUE.
+ IF( GA.GT.FA ) THEN
+ PMAX = 2
+ IF( ( FA / GA ).LT.DLAMCH( 'EPS' ) ) THEN
+*
+* Case of very large GA
+*
+ GASMAL = .FALSE.
+ SSMAX = GA
+ IF( HA.GT.ONE ) THEN
+ SSMIN = FA / ( GA / HA )
+ ELSE
+ SSMIN = ( FA / GA )*HA
+ END IF
+ CLT = ONE
+ SLT = HT / GT
+ SRT = ONE
+ CRT = FT / GT
+ END IF
+ END IF
+ IF( GASMAL ) THEN
+*
+* Normal case
+*
+ D = FA - HA
+ IF( D.EQ.FA ) THEN
+*
+* Copes with infinite F or H
+*
+ L = ONE
+ ELSE
+ L = D / FA
+ END IF
+*
+* Note that 0 .le. L .le. 1
+*
+ M = GT / FT
+*
+* Note that abs(M) .le. 1/macheps
+*
+ T = TWO - L
+*
+* Note that T .ge. 1
+*
+ MM = M*M
+ TT = T*T
+ S = SQRT( TT+MM )
+*
+* Note that 1 .le. S .le. 1 + 1/macheps
+*
+ IF( L.EQ.ZERO ) THEN
+ R = ABS( M )
+ ELSE
+ R = SQRT( L*L+MM )
+ END IF
+*
+* Note that 0 .le. R .le. 1 + 1/macheps
+*
+ A = HALF*( S+R )
+*
+* Note that 1 .le. A .le. 1 + abs(M)
+*
+ SSMIN = HA / A
+ SSMAX = FA*A
+ IF( MM.EQ.ZERO ) THEN
+*
+* Note that M is very tiny
+*
+ IF( L.EQ.ZERO ) THEN
+ T = SIGN( TWO, FT )*SIGN( ONE, GT )
+ ELSE
+ T = GT / SIGN( D, FT ) + M / T
+ END IF
+ ELSE
+ T = ( M / ( S+T )+M / ( R+L ) )*( ONE+A )
+ END IF
+ L = SQRT( T*T+FOUR )
+ CRT = TWO / L
+ SRT = T / L
+ CLT = ( CRT+SRT*M ) / A
+ SLT = ( HT / FT )*SRT / A
+ END IF
+ END IF
+ IF( SWAP ) THEN
+ CSL = SRT
+ SNL = CRT
+ CSR = SLT
+ SNR = CLT
+ ELSE
+ CSL = CLT
+ SNL = SLT
+ CSR = CRT
+ SNR = SRT
+ END IF
+*
+* Correct signs of SSMAX and SSMIN
+*
+ IF( PMAX.EQ.1 )
+ $ TSIGN = SIGN( ONE, CSR )*SIGN( ONE, CSL )*SIGN( ONE, F )
+ IF( PMAX.EQ.2 )
+ $ TSIGN = SIGN( ONE, SNR )*SIGN( ONE, CSL )*SIGN( ONE, G )
+ IF( PMAX.EQ.3 )
+ $ TSIGN = SIGN( ONE, SNR )*SIGN( ONE, SNL )*SIGN( ONE, H )
+ SSMAX = SIGN( SSMAX, TSIGN )
+ SSMIN = SIGN( SSMIN, TSIGN*SIGN( ONE, F )*SIGN( ONE, H ) )
+ RETURN
+*
+* End of DLASV2
+*
+ END
+ SUBROUTINE DLASWP( N, A, LDA, K1, K2, IPIV, INCX )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INCX, K1, K2, LDA, N
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ DOUBLE PRECISION A( LDA, * )
+* ..
+*
+* Purpose
+* =======
+*
+* DLASWP performs a series of row interchanges on the matrix A.
+* One row interchange is initiated for each of rows K1 through K2 of A.
+*
+* Arguments
+* =========
+*
+* N (input) INTEGER
+* The number of columns of the matrix A.
+*
+* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+* On entry, the matrix of column dimension N to which the row
+* interchanges will be applied.
+* On exit, the permuted matrix.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A.
+*
+* K1 (input) INTEGER
+* The first element of IPIV for which a row interchange will
+* be done.
+*
+* K2 (input) INTEGER
+* The last element of IPIV for which a row interchange will
+* be done.
+*
+* IPIV (input) INTEGER array, dimension (K2*abs(INCX))
+* The vector of pivot indices. Only the elements in positions
+* K1 through K2 of IPIV are accessed.
+* IPIV(K) = L implies rows K and L are to be interchanged.
+*
+* INCX (input) INTEGER
+* The increment between successive values of IPIV. If IPIV
+* is negative, the pivots are applied in reverse order.
+*
+* Further Details
+* ===============
+*
+* Modified by
+* R. C. Whaley, Computer Science Dept., Univ. of Tenn., Knoxville, USA
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ INTEGER I, I1, I2, INC, IP, IX, IX0, J, K, N32
+ DOUBLE PRECISION TEMP
+* ..
+* .. Executable Statements ..
+*
+* Interchange row I with row IPIV(I) for each of rows K1 through K2.
+*
+ IF( INCX.GT.0 ) THEN
+ IX0 = K1
+ I1 = K1
+ I2 = K2
+ INC = 1
+ ELSE IF( INCX.LT.0 ) THEN
+ IX0 = 1 + ( 1-K2 )*INCX
+ I1 = K2
+ I2 = K1
+ INC = -1
+ ELSE
+ RETURN
+ END IF
+*
+ N32 = ( N / 32 )*32
+ IF( N32.NE.0 ) THEN
+ DO 30 J = 1, N32, 32
+ IX = IX0
+ DO 20 I = I1, I2, INC
+ IP = IPIV( IX )
+ IF( IP.NE.I ) THEN
+ DO 10 K = J, J + 31
+ TEMP = A( I, K )
+ A( I, K ) = A( IP, K )
+ A( IP, K ) = TEMP
+ 10 CONTINUE
+ END IF
+ IX = IX + INCX
+ 20 CONTINUE
+ 30 CONTINUE
+ END IF
+ IF( N32.NE.N ) THEN
+ N32 = N32 + 1
+ IX = IX0
+ DO 50 I = I1, I2, INC
+ IP = IPIV( IX )
+ IF( IP.NE.I ) THEN
+ DO 40 K = N32, N
+ TEMP = A( I, K )
+ A( I, K ) = A( IP, K )
+ A( IP, K ) = TEMP
+ 40 CONTINUE
+ END IF
+ IX = IX + INCX
+ 50 CONTINUE
+ END IF
+*
+ RETURN
+*
+* End of DLASWP
+*
+ END
+ SUBROUTINE DLASY2( LTRANL, LTRANR, ISGN, N1, N2, TL, LDTL, TR,
+ $ LDTR, B, LDB, SCALE, X, LDX, XNORM, INFO )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ LOGICAL LTRANL, LTRANR
+ INTEGER INFO, ISGN, LDB, LDTL, LDTR, LDX, N1, N2
+ DOUBLE PRECISION SCALE, XNORM
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION B( LDB, * ), TL( LDTL, * ), TR( LDTR, * ),
+ $ X( LDX, * )
+* ..
+*
+* Purpose
+* =======
+*
+* DLASY2 solves for the N1 by N2 matrix X, 1 <= N1,N2 <= 2, in
+*
+* op(TL)*X + ISGN*X*op(TR) = SCALE*B,
+*
+* where TL is N1 by N1, TR is N2 by N2, B is N1 by N2, and ISGN = 1 or
+* -1. op(T) = T or T', where T' denotes the transpose of T.
+*
+* Arguments
+* =========
+*
+* LTRANL (input) LOGICAL
+* On entry, LTRANL specifies the op(TL):
+* = .FALSE., op(TL) = TL,
+* = .TRUE., op(TL) = TL'.
+*
+* LTRANR (input) LOGICAL
+* On entry, LTRANR specifies the op(TR):
+* = .FALSE., op(TR) = TR,
+* = .TRUE., op(TR) = TR'.
+*
+* ISGN (input) INTEGER
+* On entry, ISGN specifies the sign of the equation
+* as described before. ISGN may only be 1 or -1.
+*
+* N1 (input) INTEGER
+* On entry, N1 specifies the order of matrix TL.
+* N1 may only be 0, 1 or 2.
+*
+* N2 (input) INTEGER
+* On entry, N2 specifies the order of matrix TR.
+* N2 may only be 0, 1 or 2.
+*
+* TL (input) DOUBLE PRECISION array, dimension (LDTL,2)
+* On entry, TL contains an N1 by N1 matrix.
+*
+* LDTL (input) INTEGER
+* The leading dimension of the matrix TL. LDTL >= max(1,N1).
+*
+* TR (input) DOUBLE PRECISION array, dimension (LDTR,2)
+* On entry, TR contains an N2 by N2 matrix.
+*
+* LDTR (input) INTEGER
+* The leading dimension of the matrix TR. LDTR >= max(1,N2).
+*
+* B (input) DOUBLE PRECISION array, dimension (LDB,2)
+* On entry, the N1 by N2 matrix B contains the right-hand
+* side of the equation.
+*
+* LDB (input) INTEGER
+* The leading dimension of the matrix B. LDB >= max(1,N1).
+*
+* SCALE (output) DOUBLE PRECISION
+* On exit, SCALE contains the scale factor. SCALE is chosen
+* less than or equal to 1 to prevent the solution overflowing.
+*
+* X (output) DOUBLE PRECISION array, dimension (LDX,2)
+* On exit, X contains the N1 by N2 solution.
+*
+* LDX (input) INTEGER
+* The leading dimension of the matrix X. LDX >= max(1,N1).
+*
+* XNORM (output) DOUBLE PRECISION
+* On exit, XNORM is the infinity-norm of the solution.
+*
+* INFO (output) INTEGER
+* On exit, INFO is set to
+* 0: successful exit.
+* 1: TL and TR have too close eigenvalues, so TL or
+* TR is perturbed to get a nonsingular equation.
+* NOTE: In the interests of speed, this routine does not
+* check the inputs for errors.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+ DOUBLE PRECISION TWO, HALF, EIGHT
+ PARAMETER ( TWO = 2.0D+0, HALF = 0.5D+0, EIGHT = 8.0D+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL BSWAP, XSWAP
+ INTEGER I, IP, IPIV, IPSV, J, JP, JPSV, K
+ DOUBLE PRECISION BET, EPS, GAM, L21, SGN, SMIN, SMLNUM, TAU1,
+ $ TEMP, U11, U12, U22, XMAX
+* ..
+* .. Local Arrays ..
+ LOGICAL BSWPIV( 4 ), XSWPIV( 4 )
+ INTEGER JPIV( 4 ), LOCL21( 4 ), LOCU12( 4 ),
+ $ LOCU22( 4 )
+ DOUBLE PRECISION BTMP( 4 ), T16( 4, 4 ), TMP( 4 ), X2( 2 )
+* ..
+* .. External Functions ..
+ INTEGER IDAMAX
+ DOUBLE PRECISION DLAMCH
+ EXTERNAL IDAMAX, DLAMCH
+* ..
+* .. External Subroutines ..
+ EXTERNAL DCOPY, DSWAP
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX
+* ..
+* .. Data statements ..
+ DATA LOCU12 / 3, 4, 1, 2 / , LOCL21 / 2, 1, 4, 3 / ,
+ $ LOCU22 / 4, 3, 2, 1 /
+ DATA XSWPIV / .FALSE., .FALSE., .TRUE., .TRUE. /
+ DATA BSWPIV / .FALSE., .TRUE., .FALSE., .TRUE. /
+* ..
+* .. Executable Statements ..
+*
+* Do not check the input parameters for errors
+*
+ INFO = 0
+*
+* Quick return if possible
+*
+ IF( N1.EQ.0 .OR. N2.EQ.0 )
+ $ RETURN
+*
+* Set constants to control overflow
+*
+ EPS = DLAMCH( 'P' )
+ SMLNUM = DLAMCH( 'S' ) / EPS
+ SGN = ISGN
+*
+ K = N1 + N1 + N2 - 2
+ GO TO ( 10, 20, 30, 50 )K
+*
+* 1 by 1: TL11*X + SGN*X*TR11 = B11
+*
+ 10 CONTINUE
+ TAU1 = TL( 1, 1 ) + SGN*TR( 1, 1 )
+ BET = ABS( TAU1 )
+ IF( BET.LE.SMLNUM ) THEN
+ TAU1 = SMLNUM
+ BET = SMLNUM
+ INFO = 1
+ END IF
+*
+ SCALE = ONE
+ GAM = ABS( B( 1, 1 ) )
+ IF( SMLNUM*GAM.GT.BET )
+ $ SCALE = ONE / GAM
+*
+ X( 1, 1 ) = ( B( 1, 1 )*SCALE ) / TAU1
+ XNORM = ABS( X( 1, 1 ) )
+ RETURN
+*
+* 1 by 2:
+* TL11*[X11 X12] + ISGN*[X11 X12]*op[TR11 TR12] = [B11 B12]
+* [TR21 TR22]
+*
+ 20 CONTINUE
+*
+ SMIN = MAX( EPS*MAX( ABS( TL( 1, 1 ) ), ABS( TR( 1, 1 ) ),
+ $ ABS( TR( 1, 2 ) ), ABS( TR( 2, 1 ) ), ABS( TR( 2, 2 ) ) ),
+ $ SMLNUM )
+ TMP( 1 ) = TL( 1, 1 ) + SGN*TR( 1, 1 )
+ TMP( 4 ) = TL( 1, 1 ) + SGN*TR( 2, 2 )
+ IF( LTRANR ) THEN
+ TMP( 2 ) = SGN*TR( 2, 1 )
+ TMP( 3 ) = SGN*TR( 1, 2 )
+ ELSE
+ TMP( 2 ) = SGN*TR( 1, 2 )
+ TMP( 3 ) = SGN*TR( 2, 1 )
+ END IF
+ BTMP( 1 ) = B( 1, 1 )
+ BTMP( 2 ) = B( 1, 2 )
+ GO TO 40
+*
+* 2 by 1:
+* op[TL11 TL12]*[X11] + ISGN* [X11]*TR11 = [B11]
+* [TL21 TL22] [X21] [X21] [B21]
+*
+ 30 CONTINUE
+ SMIN = MAX( EPS*MAX( ABS( TR( 1, 1 ) ), ABS( TL( 1, 1 ) ),
+ $ ABS( TL( 1, 2 ) ), ABS( TL( 2, 1 ) ), ABS( TL( 2, 2 ) ) ),
+ $ SMLNUM )
+ TMP( 1 ) = TL( 1, 1 ) + SGN*TR( 1, 1 )
+ TMP( 4 ) = TL( 2, 2 ) + SGN*TR( 1, 1 )
+ IF( LTRANL ) THEN
+ TMP( 2 ) = TL( 1, 2 )
+ TMP( 3 ) = TL( 2, 1 )
+ ELSE
+ TMP( 2 ) = TL( 2, 1 )
+ TMP( 3 ) = TL( 1, 2 )
+ END IF
+ BTMP( 1 ) = B( 1, 1 )
+ BTMP( 2 ) = B( 2, 1 )
+ 40 CONTINUE
+*
+* Solve 2 by 2 system using complete pivoting.
+* Set pivots less than SMIN to SMIN.
+*
+ IPIV = IDAMAX( 4, TMP, 1 )
+ U11 = TMP( IPIV )
+ IF( ABS( U11 ).LE.SMIN ) THEN
+ INFO = 1
+ U11 = SMIN
+ END IF
+ U12 = TMP( LOCU12( IPIV ) )
+ L21 = TMP( LOCL21( IPIV ) ) / U11
+ U22 = TMP( LOCU22( IPIV ) ) - U12*L21
+ XSWAP = XSWPIV( IPIV )
+ BSWAP = BSWPIV( IPIV )
+ IF( ABS( U22 ).LE.SMIN ) THEN
+ INFO = 1
+ U22 = SMIN
+ END IF
+ IF( BSWAP ) THEN
+ TEMP = BTMP( 2 )
+ BTMP( 2 ) = BTMP( 1 ) - L21*TEMP
+ BTMP( 1 ) = TEMP
+ ELSE
+ BTMP( 2 ) = BTMP( 2 ) - L21*BTMP( 1 )
+ END IF
+ SCALE = ONE
+ IF( ( TWO*SMLNUM )*ABS( BTMP( 2 ) ).GT.ABS( U22 ) .OR.
+ $ ( TWO*SMLNUM )*ABS( BTMP( 1 ) ).GT.ABS( U11 ) ) THEN
+ SCALE = HALF / MAX( ABS( BTMP( 1 ) ), ABS( BTMP( 2 ) ) )
+ BTMP( 1 ) = BTMP( 1 )*SCALE
+ BTMP( 2 ) = BTMP( 2 )*SCALE
+ END IF
+ X2( 2 ) = BTMP( 2 ) / U22
+ X2( 1 ) = BTMP( 1 ) / U11 - ( U12 / U11 )*X2( 2 )
+ IF( XSWAP ) THEN
+ TEMP = X2( 2 )
+ X2( 2 ) = X2( 1 )
+ X2( 1 ) = TEMP
+ END IF
+ X( 1, 1 ) = X2( 1 )
+ IF( N1.EQ.1 ) THEN
+ X( 1, 2 ) = X2( 2 )
+ XNORM = ABS( X( 1, 1 ) ) + ABS( X( 1, 2 ) )
+ ELSE
+ X( 2, 1 ) = X2( 2 )
+ XNORM = MAX( ABS( X( 1, 1 ) ), ABS( X( 2, 1 ) ) )
+ END IF
+ RETURN
+*
+* 2 by 2:
+* op[TL11 TL12]*[X11 X12] +ISGN* [X11 X12]*op[TR11 TR12] = [B11 B12]
+* [TL21 TL22] [X21 X22] [X21 X22] [TR21 TR22] [B21 B22]
+*
+* Solve equivalent 4 by 4 system using complete pivoting.
+* Set pivots less than SMIN to SMIN.
+*
+ 50 CONTINUE
+ SMIN = MAX( ABS( TR( 1, 1 ) ), ABS( TR( 1, 2 ) ),
+ $ ABS( TR( 2, 1 ) ), ABS( TR( 2, 2 ) ) )
+ SMIN = MAX( SMIN, ABS( TL( 1, 1 ) ), ABS( TL( 1, 2 ) ),
+ $ ABS( TL( 2, 1 ) ), ABS( TL( 2, 2 ) ) )
+ SMIN = MAX( EPS*SMIN, SMLNUM )
+ BTMP( 1 ) = ZERO
+ CALL DCOPY( 16, BTMP, 0, T16, 1 )
+ T16( 1, 1 ) = TL( 1, 1 ) + SGN*TR( 1, 1 )
+ T16( 2, 2 ) = TL( 2, 2 ) + SGN*TR( 1, 1 )
+ T16( 3, 3 ) = TL( 1, 1 ) + SGN*TR( 2, 2 )
+ T16( 4, 4 ) = TL( 2, 2 ) + SGN*TR( 2, 2 )
+ IF( LTRANL ) THEN
+ T16( 1, 2 ) = TL( 2, 1 )
+ T16( 2, 1 ) = TL( 1, 2 )
+ T16( 3, 4 ) = TL( 2, 1 )
+ T16( 4, 3 ) = TL( 1, 2 )
+ ELSE
+ T16( 1, 2 ) = TL( 1, 2 )
+ T16( 2, 1 ) = TL( 2, 1 )
+ T16( 3, 4 ) = TL( 1, 2 )
+ T16( 4, 3 ) = TL( 2, 1 )
+ END IF
+ IF( LTRANR ) THEN
+ T16( 1, 3 ) = SGN*TR( 1, 2 )
+ T16( 2, 4 ) = SGN*TR( 1, 2 )
+ T16( 3, 1 ) = SGN*TR( 2, 1 )
+ T16( 4, 2 ) = SGN*TR( 2, 1 )
+ ELSE
+ T16( 1, 3 ) = SGN*TR( 2, 1 )
+ T16( 2, 4 ) = SGN*TR( 2, 1 )
+ T16( 3, 1 ) = SGN*TR( 1, 2 )
+ T16( 4, 2 ) = SGN*TR( 1, 2 )
+ END IF
+ BTMP( 1 ) = B( 1, 1 )
+ BTMP( 2 ) = B( 2, 1 )
+ BTMP( 3 ) = B( 1, 2 )
+ BTMP( 4 ) = B( 2, 2 )
+*
+* Perform elimination
+*
+ DO 100 I = 1, 3
+ XMAX = ZERO
+ DO 70 IP = I, 4
+ DO 60 JP = I, 4
+ IF( ABS( T16( IP, JP ) ).GE.XMAX ) THEN
+ XMAX = ABS( T16( IP, JP ) )
+ IPSV = IP
+ JPSV = JP
+ END IF
+ 60 CONTINUE
+ 70 CONTINUE
+ IF( IPSV.NE.I ) THEN
+ CALL DSWAP( 4, T16( IPSV, 1 ), 4, T16( I, 1 ), 4 )
+ TEMP = BTMP( I )
+ BTMP( I ) = BTMP( IPSV )
+ BTMP( IPSV ) = TEMP
+ END IF
+ IF( JPSV.NE.I )
+ $ CALL DSWAP( 4, T16( 1, JPSV ), 1, T16( 1, I ), 1 )
+ JPIV( I ) = JPSV
+ IF( ABS( T16( I, I ) ).LT.SMIN ) THEN
+ INFO = 1
+ T16( I, I ) = SMIN
+ END IF
+ DO 90 J = I + 1, 4
+ T16( J, I ) = T16( J, I ) / T16( I, I )
+ BTMP( J ) = BTMP( J ) - T16( J, I )*BTMP( I )
+ DO 80 K = I + 1, 4
+ T16( J, K ) = T16( J, K ) - T16( J, I )*T16( I, K )
+ 80 CONTINUE
+ 90 CONTINUE
+ 100 CONTINUE
+ IF( ABS( T16( 4, 4 ) ).LT.SMIN )
+ $ T16( 4, 4 ) = SMIN
+ SCALE = ONE
+ IF( ( EIGHT*SMLNUM )*ABS( BTMP( 1 ) ).GT.ABS( T16( 1, 1 ) ) .OR.
+ $ ( EIGHT*SMLNUM )*ABS( BTMP( 2 ) ).GT.ABS( T16( 2, 2 ) ) .OR.
+ $ ( EIGHT*SMLNUM )*ABS( BTMP( 3 ) ).GT.ABS( T16( 3, 3 ) ) .OR.
+ $ ( EIGHT*SMLNUM )*ABS( BTMP( 4 ) ).GT.ABS( T16( 4, 4 ) ) ) THEN
+ SCALE = ( ONE / EIGHT ) / MAX( ABS( BTMP( 1 ) ),
+ $ ABS( BTMP( 2 ) ), ABS( BTMP( 3 ) ), ABS( BTMP( 4 ) ) )
+ BTMP( 1 ) = BTMP( 1 )*SCALE
+ BTMP( 2 ) = BTMP( 2 )*SCALE
+ BTMP( 3 ) = BTMP( 3 )*SCALE
+ BTMP( 4 ) = BTMP( 4 )*SCALE
+ END IF
+ DO 120 I = 1, 4
+ K = 5 - I
+ TEMP = ONE / T16( K, K )
+ TMP( K ) = BTMP( K )*TEMP
+ DO 110 J = K + 1, 4
+ TMP( K ) = TMP( K ) - ( TEMP*T16( K, J ) )*TMP( J )
+ 110 CONTINUE
+ 120 CONTINUE
+ DO 130 I = 1, 3
+ IF( JPIV( 4-I ).NE.4-I ) THEN
+ TEMP = TMP( 4-I )
+ TMP( 4-I ) = TMP( JPIV( 4-I ) )
+ TMP( JPIV( 4-I ) ) = TEMP
+ END IF
+ 130 CONTINUE
+ X( 1, 1 ) = TMP( 1 )
+ X( 2, 1 ) = TMP( 2 )
+ X( 1, 2 ) = TMP( 3 )
+ X( 2, 2 ) = TMP( 4 )
+ XNORM = MAX( ABS( TMP( 1 ) )+ABS( TMP( 3 ) ),
+ $ ABS( TMP( 2 ) )+ABS( TMP( 4 ) ) )
+ RETURN
+*
+* End of DLASY2
+*
+ END
+ SUBROUTINE DLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, KB, LDA, LDW, N, NB
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ DOUBLE PRECISION A( LDA, * ), W( LDW, * )
+* ..
+*
+* Purpose
+* =======
+*
+* DLASYF computes a partial factorization of a real symmetric matrix A
+* using the Bunch-Kaufman diagonal pivoting method. The partial
+* factorization has the form:
+*
+* A = ( I U12 ) ( A11 0 ) ( I 0 ) if UPLO = 'U', or:
+* ( 0 U22 ) ( 0 D ) ( U12' U22' )
+*
+* A = ( L11 0 ) ( D 0 ) ( L11' L21' ) if UPLO = 'L'
+* ( L21 I ) ( 0 A22 ) ( 0 I )
+*
+* where the order of D is at most NB. The actual order is returned in
+* the argument KB, and is either NB or NB-1, or N if N <= NB.
+*
+* DLASYF is an auxiliary routine called by DSYTRF. It uses blocked code
+* (calling Level 3 BLAS) to update the submatrix A11 (if UPLO = 'U') or
+* A22 (if UPLO = 'L').
+*
+* Arguments
+* =========
+*
+* UPLO (input) CHARACTER*1
+* Specifies whether the upper or lower triangular part of the
+* symmetric matrix A is stored:
+* = 'U': Upper triangular
+* = 'L': Lower triangular
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* NB (input) INTEGER
+* The maximum number of columns of the matrix A that should be
+* factored. NB should be at least 2 to allow for 2-by-2 pivot
+* blocks.
+*
+* KB (output) INTEGER
+* The number of columns of A that were actually factored.
+* KB is either NB-1 or NB, or N if N <= NB.
+*
+* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+* On entry, the symmetric matrix A. If UPLO = 'U', the leading
+* n-by-n upper triangular part of A contains the upper
+* triangular part of the matrix A, and the strictly lower
+* triangular part of A is not referenced. If UPLO = 'L', the
+* leading n-by-n lower triangular part of A contains the lower
+* triangular part of the matrix A, and the strictly upper
+* triangular part of A is not referenced.
+* On exit, A contains details of the partial factorization.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,N).
+*
+* IPIV (output) INTEGER array, dimension (N)
+* Details of the interchanges and the block structure of D.
+* If UPLO = 'U', only the last KB elements of IPIV are set;
+* if UPLO = 'L', only the first KB elements are set.
+*
+* If IPIV(k) > 0, then rows and columns k and IPIV(k) were
+* interchanged and D(k,k) is a 1-by-1 diagonal block.
+* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and
+* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)
+* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =
+* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were
+* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
+*
+* W (workspace) DOUBLE PRECISION array, dimension (LDW,NB)
+*
+* LDW (input) INTEGER
+* The leading dimension of the array W. LDW >= max(1,N).
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* > 0: if INFO = k, D(k,k) is exactly zero. The factorization
+* has been completed, but the block diagonal matrix D is
+* exactly singular.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+ DOUBLE PRECISION EIGHT, SEVTEN
+ PARAMETER ( EIGHT = 8.0D+0, SEVTEN = 17.0D+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER IMAX, J, JB, JJ, JMAX, JP, K, KK, KKW, KP,
+ $ KSTEP, KW
+ DOUBLE PRECISION ABSAKK, ALPHA, COLMAX, D11, D21, D22, R1,
+ $ ROWMAX, T
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER IDAMAX
+ EXTERNAL LSAME, IDAMAX
+* ..
+* .. External Subroutines ..
+ EXTERNAL DCOPY, DGEMM, DGEMV, DSCAL, DSWAP
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, MIN, SQRT
+* ..
+* .. Executable Statements ..
+*
+ INFO = 0
+*
+* Initialize ALPHA for use in choosing pivot block size.
+*
+ ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT
+*
+ IF( LSAME( UPLO, 'U' ) ) THEN
+*
+* Factorize the trailing columns of A using the upper triangle
+* of A and working backwards, and compute the matrix W = U12*D
+* for use in updating A11
+*
+* K is the main loop index, decreasing from N in steps of 1 or 2
+*
+* KW is the column of W which corresponds to column K of A
+*
+ K = N
+ 10 CONTINUE
+ KW = NB + K - N
+*
+* Exit from loop
+*
+ IF( ( K.LE.N-NB+1 .AND. NB.LT.N ) .OR. K.LT.1 )
+ $ GO TO 30
+*
+* Copy column K of A to column KW of W and update it
+*
+ CALL DCOPY( K, A( 1, K ), 1, W( 1, KW ), 1 )
+ IF( K.LT.N )
+ $ CALL DGEMV( 'No transpose', K, N-K, -ONE, A( 1, K+1 ), LDA,
+ $ W( K, KW+1 ), LDW, ONE, W( 1, KW ), 1 )
+*
+ KSTEP = 1
+*
+* Determine rows and columns to be interchanged and whether
+* a 1-by-1 or 2-by-2 pivot block will be used
+*
+ ABSAKK = ABS( W( K, KW ) )
+*
+* IMAX is the row-index of the largest off-diagonal element in
+* column K, and COLMAX is its absolute value
+*
+ IF( K.GT.1 ) THEN
+ IMAX = IDAMAX( K-1, W( 1, KW ), 1 )
+ COLMAX = ABS( W( IMAX, KW ) )
+ ELSE
+ COLMAX = ZERO
+ END IF
+*
+ IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN
+*
+* Column K is zero: set INFO and continue
+*
+ IF( INFO.EQ.0 )
+ $ INFO = K
+ KP = K
+ ELSE
+ IF( ABSAKK.GE.ALPHA*COLMAX ) THEN
+*
+* no interchange, use 1-by-1 pivot block
+*
+ KP = K
+ ELSE
+*
+* Copy column IMAX to column KW-1 of W and update it
+*
+ CALL DCOPY( IMAX, A( 1, IMAX ), 1, W( 1, KW-1 ), 1 )
+ CALL DCOPY( K-IMAX, A( IMAX, IMAX+1 ), LDA,
+ $ W( IMAX+1, KW-1 ), 1 )
+ IF( K.LT.N )
+ $ CALL DGEMV( 'No transpose', K, N-K, -ONE, A( 1, K+1 ),
+ $ LDA, W( IMAX, KW+1 ), LDW, ONE,
+ $ W( 1, KW-1 ), 1 )
+*
+* JMAX is the column-index of the largest off-diagonal
+* element in row IMAX, and ROWMAX is its absolute value
+*
+ JMAX = IMAX + IDAMAX( K-IMAX, W( IMAX+1, KW-1 ), 1 )
+ ROWMAX = ABS( W( JMAX, KW-1 ) )
+ IF( IMAX.GT.1 ) THEN
+ JMAX = IDAMAX( IMAX-1, W( 1, KW-1 ), 1 )
+ ROWMAX = MAX( ROWMAX, ABS( W( JMAX, KW-1 ) ) )
+ END IF
+*
+ IF( ABSAKK.GE.ALPHA*COLMAX*( COLMAX / ROWMAX ) ) THEN
+*
+* no interchange, use 1-by-1 pivot block
+*
+ KP = K
+ ELSE IF( ABS( W( IMAX, KW-1 ) ).GE.ALPHA*ROWMAX ) THEN
+*
+* interchange rows and columns K and IMAX, use 1-by-1
+* pivot block
+*
+ KP = IMAX
+*
+* copy column KW-1 of W to column KW
+*
+ CALL DCOPY( K, W( 1, KW-1 ), 1, W( 1, KW ), 1 )
+ ELSE
+*
+* interchange rows and columns K-1 and IMAX, use 2-by-2
+* pivot block
+*
+ KP = IMAX
+ KSTEP = 2
+ END IF
+ END IF
+*
+ KK = K - KSTEP + 1
+ KKW = NB + KK - N
+*
+* Updated column KP is already stored in column KKW of W
+*
+ IF( KP.NE.KK ) THEN
+*
+* Copy non-updated column KK to column KP
+*
+ A( KP, K ) = A( KK, K )
+ CALL DCOPY( K-1-KP, A( KP+1, KK ), 1, A( KP, KP+1 ),
+ $ LDA )
+ CALL DCOPY( KP, A( 1, KK ), 1, A( 1, KP ), 1 )
+*
+* Interchange rows KK and KP in last KK columns of A and W
+*
+ CALL DSWAP( N-KK+1, A( KK, KK ), LDA, A( KP, KK ), LDA )
+ CALL DSWAP( N-KK+1, W( KK, KKW ), LDW, W( KP, KKW ),
+ $ LDW )
+ END IF
+*
+ IF( KSTEP.EQ.1 ) THEN
+*
+* 1-by-1 pivot block D(k): column KW of W now holds
+*
+* W(k) = U(k)*D(k)
+*
+* where U(k) is the k-th column of U
+*
+* Store U(k) in column k of A
+*
+ CALL DCOPY( K, W( 1, KW ), 1, A( 1, K ), 1 )
+ R1 = ONE / A( K, K )
+ CALL DSCAL( K-1, R1, A( 1, K ), 1 )
+ ELSE
+*
+* 2-by-2 pivot block D(k): columns KW and KW-1 of W now
+* hold
+*
+* ( W(k-1) W(k) ) = ( U(k-1) U(k) )*D(k)
+*
+* where U(k) and U(k-1) are the k-th and (k-1)-th columns
+* of U
+*
+ IF( K.GT.2 ) THEN
+*
+* Store U(k) and U(k-1) in columns k and k-1 of A
+*
+ D21 = W( K-1, KW )
+ D11 = W( K, KW ) / D21
+ D22 = W( K-1, KW-1 ) / D21
+ T = ONE / ( D11*D22-ONE )
+ D21 = T / D21
+ DO 20 J = 1, K - 2
+ A( J, K-1 ) = D21*( D11*W( J, KW-1 )-W( J, KW ) )
+ A( J, K ) = D21*( D22*W( J, KW )-W( J, KW-1 ) )
+ 20 CONTINUE
+ END IF
+*
+* Copy D(k) to A
+*
+ A( K-1, K-1 ) = W( K-1, KW-1 )
+ A( K-1, K ) = W( K-1, KW )
+ A( K, K ) = W( K, KW )
+ END IF
+ END IF
+*
+* Store details of the interchanges in IPIV
+*
+ IF( KSTEP.EQ.1 ) THEN
+ IPIV( K ) = KP
+ ELSE
+ IPIV( K ) = -KP
+ IPIV( K-1 ) = -KP
+ END IF
+*
+* Decrease K and return to the start of the main loop
+*
+ K = K - KSTEP
+ GO TO 10
+*
+ 30 CONTINUE
+*
+* Update the upper triangle of A11 (= A(1:k,1:k)) as
+*
+* A11 := A11 - U12*D*U12' = A11 - U12*W'
+*
+* computing blocks of NB columns at a time
+*
+ DO 50 J = ( ( K-1 ) / NB )*NB + 1, 1, -NB
+ JB = MIN( NB, K-J+1 )
+*
+* Update the upper triangle of the diagonal block
+*
+ DO 40 JJ = J, J + JB - 1
+ CALL DGEMV( 'No transpose', JJ-J+1, N-K, -ONE,
+ $ A( J, K+1 ), LDA, W( JJ, KW+1 ), LDW, ONE,
+ $ A( J, JJ ), 1 )
+ 40 CONTINUE
+*
+* Update the rectangular superdiagonal block
+*
+ CALL DGEMM( 'No transpose', 'Transpose', J-1, JB, N-K, -ONE,
+ $ A( 1, K+1 ), LDA, W( J, KW+1 ), LDW, ONE,
+ $ A( 1, J ), LDA )
+ 50 CONTINUE
+*
+* Put U12 in standard form by partially undoing the interchanges
+* in columns k+1:n
+*
+ J = K + 1
+ 60 CONTINUE
+ JJ = J
+ JP = IPIV( J )
+ IF( JP.LT.0 ) THEN
+ JP = -JP
+ J = J + 1
+ END IF
+ J = J + 1
+ IF( JP.NE.JJ .AND. J.LE.N )
+ $ CALL DSWAP( N-J+1, A( JP, J ), LDA, A( JJ, J ), LDA )
+ IF( J.LE.N )
+ $ GO TO 60
+*
+* Set KB to the number of columns factorized
+*
+ KB = N - K
+*
+ ELSE
+*
+* Factorize the leading columns of A using the lower triangle
+* of A and working forwards, and compute the matrix W = L21*D
+* for use in updating A22
+*
+* K is the main loop index, increasing from 1 in steps of 1 or 2
+*
+ K = 1
+ 70 CONTINUE
+*
+* Exit from loop
+*
+ IF( ( K.GE.NB .AND. NB.LT.N ) .OR. K.GT.N )
+ $ GO TO 90
+*
+* Copy column K of A to column K of W and update it
+*
+ CALL DCOPY( N-K+1, A( K, K ), 1, W( K, K ), 1 )
+ CALL DGEMV( 'No transpose', N-K+1, K-1, -ONE, A( K, 1 ), LDA,
+ $ W( K, 1 ), LDW, ONE, W( K, K ), 1 )
+*
+ KSTEP = 1
+*
+* Determine rows and columns to be interchanged and whether
+* a 1-by-1 or 2-by-2 pivot block will be used
+*
+ ABSAKK = ABS( W( K, K ) )
+*
+* IMAX is the row-index of the largest off-diagonal element in
+* column K, and COLMAX is its absolute value
+*
+ IF( K.LT.N ) THEN
+ IMAX = K + IDAMAX( N-K, W( K+1, K ), 1 )
+ COLMAX = ABS( W( IMAX, K ) )
+ ELSE
+ COLMAX = ZERO
+ END IF
+*
+ IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN
+*
+* Column K is zero: set INFO and continue
+*
+ IF( INFO.EQ.0 )
+ $ INFO = K
+ KP = K
+ ELSE
+ IF( ABSAKK.GE.ALPHA*COLMAX ) THEN
+*
+* no interchange, use 1-by-1 pivot block
+*
+ KP = K
+ ELSE
+*
+* Copy column IMAX to column K+1 of W and update it
+*
+ CALL DCOPY( IMAX-K, A( IMAX, K ), LDA, W( K, K+1 ), 1 )
+ CALL DCOPY( N-IMAX+1, A( IMAX, IMAX ), 1, W( IMAX, K+1 ),
+ $ 1 )
+ CALL DGEMV( 'No transpose', N-K+1, K-1, -ONE, A( K, 1 ),
+ $ LDA, W( IMAX, 1 ), LDW, ONE, W( K, K+1 ), 1 )
+*
+* JMAX is the column-index of the largest off-diagonal
+* element in row IMAX, and ROWMAX is its absolute value
+*
+ JMAX = K - 1 + IDAMAX( IMAX-K, W( K, K+1 ), 1 )
+ ROWMAX = ABS( W( JMAX, K+1 ) )
+ IF( IMAX.LT.N ) THEN
+ JMAX = IMAX + IDAMAX( N-IMAX, W( IMAX+1, K+1 ), 1 )
+ ROWMAX = MAX( ROWMAX, ABS( W( JMAX, K+1 ) ) )
+ END IF
+*
+ IF( ABSAKK.GE.ALPHA*COLMAX*( COLMAX / ROWMAX ) ) THEN
+*
+* no interchange, use 1-by-1 pivot block
+*
+ KP = K
+ ELSE IF( ABS( W( IMAX, K+1 ) ).GE.ALPHA*ROWMAX ) THEN
+*
+* interchange rows and columns K and IMAX, use 1-by-1
+* pivot block
+*
+ KP = IMAX
+*
+* copy column K+1 of W to column K
+*
+ CALL DCOPY( N-K+1, W( K, K+1 ), 1, W( K, K ), 1 )
+ ELSE
+*
+* interchange rows and columns K+1 and IMAX, use 2-by-2
+* pivot block
+*
+ KP = IMAX
+ KSTEP = 2
+ END IF
+ END IF
+*
+ KK = K + KSTEP - 1
+*
+* Updated column KP is already stored in column KK of W
+*
+ IF( KP.NE.KK ) THEN
+*
+* Copy non-updated column KK to column KP
+*
+ A( KP, K ) = A( KK, K )
+ CALL DCOPY( KP-K-1, A( K+1, KK ), 1, A( KP, K+1 ), LDA )
+ CALL DCOPY( N-KP+1, A( KP, KK ), 1, A( KP, KP ), 1 )
+*
+* Interchange rows KK and KP in first KK columns of A and W
+*
+ CALL DSWAP( KK, A( KK, 1 ), LDA, A( KP, 1 ), LDA )
+ CALL DSWAP( KK, W( KK, 1 ), LDW, W( KP, 1 ), LDW )
+ END IF
+*
+ IF( KSTEP.EQ.1 ) THEN
+*
+* 1-by-1 pivot block D(k): column k of W now holds
+*
+* W(k) = L(k)*D(k)
+*
+* where L(k) is the k-th column of L
+*
+* Store L(k) in column k of A
+*
+ CALL DCOPY( N-K+1, W( K, K ), 1, A( K, K ), 1 )
+ IF( K.LT.N ) THEN
+ R1 = ONE / A( K, K )
+ CALL DSCAL( N-K, R1, A( K+1, K ), 1 )
+ END IF
+ ELSE
+*
+* 2-by-2 pivot block D(k): columns k and k+1 of W now hold
+*
+* ( W(k) W(k+1) ) = ( L(k) L(k+1) )*D(k)
+*
+* where L(k) and L(k+1) are the k-th and (k+1)-th columns
+* of L
+*
+ IF( K.LT.N-1 ) THEN
+*
+* Store L(k) and L(k+1) in columns k and k+1 of A
+*
+ D21 = W( K+1, K )
+ D11 = W( K+1, K+1 ) / D21
+ D22 = W( K, K ) / D21
+ T = ONE / ( D11*D22-ONE )
+ D21 = T / D21
+ DO 80 J = K + 2, N
+ A( J, K ) = D21*( D11*W( J, K )-W( J, K+1 ) )
+ A( J, K+1 ) = D21*( D22*W( J, K+1 )-W( J, K ) )
+ 80 CONTINUE
+ END IF
+*
+* Copy D(k) to A
+*
+ A( K, K ) = W( K, K )
+ A( K+1, K ) = W( K+1, K )
+ A( K+1, K+1 ) = W( K+1, K+1 )
+ END IF
+ END IF
+*
+* Store details of the interchanges in IPIV
+*
+ IF( KSTEP.EQ.1 ) THEN
+ IPIV( K ) = KP
+ ELSE
+ IPIV( K ) = -KP
+ IPIV( K+1 ) = -KP
+ END IF
+*
+* Increase K and return to the start of the main loop
+*
+ K = K + KSTEP
+ GO TO 70
+*
+ 90 CONTINUE
+*
+* Update the lower triangle of A22 (= A(k:n,k:n)) as
+*
+* A22 := A22 - L21*D*L21' = A22 - L21*W'
+*
+* computing blocks of NB columns at a time
+*
+ DO 110 J = K, N, NB
+ JB = MIN( NB, N-J+1 )
+*
+* Update the lower triangle of the diagonal block
+*
+ DO 100 JJ = J, J + JB - 1
+ CALL DGEMV( 'No transpose', J+JB-JJ, K-1, -ONE,
+ $ A( JJ, 1 ), LDA, W( JJ, 1 ), LDW, ONE,
+ $ A( JJ, JJ ), 1 )
+ 100 CONTINUE
+*
+* Update the rectangular subdiagonal block
+*
+ IF( J+JB.LE.N )
+ $ CALL DGEMM( 'No transpose', 'Transpose', N-J-JB+1, JB,
+ $ K-1, -ONE, A( J+JB, 1 ), LDA, W( J, 1 ), LDW,
+ $ ONE, A( J+JB, J ), LDA )
+ 110 CONTINUE
+*
+* Put L21 in standard form by partially undoing the interchanges
+* in columns 1:k-1
+*
+ J = K - 1
+ 120 CONTINUE
+ JJ = J
+ JP = IPIV( J )
+ IF( JP.LT.0 ) THEN
+ JP = -JP
+ J = J - 1
+ END IF
+ J = J - 1
+ IF( JP.NE.JJ .AND. J.GE.1 )
+ $ CALL DSWAP( J, A( JP, 1 ), LDA, A( JJ, 1 ), LDA )
+ IF( J.GE.1 )
+ $ GO TO 120
+*
+* Set KB to the number of columns factorized
+*
+ KB = K - 1
+*
+ END IF
+ RETURN
+*
+* End of DLASYF
+*
+ END
+ SUBROUTINE DLATBS( UPLO, TRANS, DIAG, NORMIN, N, KD, AB, LDAB, X,
+ $ SCALE, CNORM, INFO )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER DIAG, NORMIN, TRANS, UPLO
+ INTEGER INFO, KD, LDAB, N
+ DOUBLE PRECISION SCALE
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION AB( LDAB, * ), CNORM( * ), X( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DLATBS solves one of the triangular systems
+*
+* A *x = s*b or A'*x = s*b
+*
+* with scaling to prevent overflow, where A is an upper or lower
+* triangular band matrix. Here A' denotes the transpose of A, x and b
+* are n-element vectors, and s is a scaling factor, usually less than
+* or equal to 1, chosen so that the components of x will be less than
+* the overflow threshold. If the unscaled problem will not cause
+* overflow, the Level 2 BLAS routine DTBSV is called. If the matrix A
+* is singular (A(j,j) = 0 for some j), then s is set to 0 and a
+* non-trivial solution to A*x = 0 is returned.
+*
+* Arguments
+* =========
+*
+* UPLO (input) CHARACTER*1
+* Specifies whether the matrix A is upper or lower triangular.
+* = 'U': Upper triangular
+* = 'L': Lower triangular
+*
+* TRANS (input) CHARACTER*1
+* Specifies the operation applied to A.
+* = 'N': Solve A * x = s*b (No transpose)
+* = 'T': Solve A'* x = s*b (Transpose)
+* = 'C': Solve A'* x = s*b (Conjugate transpose = Transpose)
+*
+* DIAG (input) CHARACTER*1
+* Specifies whether or not the matrix A is unit triangular.
+* = 'N': Non-unit triangular
+* = 'U': Unit triangular
+*
+* NORMIN (input) CHARACTER*1
+* Specifies whether CNORM has been set or not.
+* = 'Y': CNORM contains the column norms on entry
+* = 'N': CNORM is not set on entry. On exit, the norms will
+* be computed and stored in CNORM.
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* KD (input) INTEGER
+* The number of subdiagonals or superdiagonals in the
+* triangular matrix A. KD >= 0.
+*
+* AB (input) DOUBLE PRECISION array, dimension (LDAB,N)
+* The upper or lower triangular band matrix A, stored in the
+* first KD+1 rows of the array. The j-th column of A is stored
+* in the j-th column of the array AB as follows:
+* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
+* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).
+*
+* LDAB (input) INTEGER
+* The leading dimension of the array AB. LDAB >= KD+1.
+*
+* X (input/output) DOUBLE PRECISION array, dimension (N)
+* On entry, the right hand side b of the triangular system.
+* On exit, X is overwritten by the solution vector x.
+*
+* SCALE (output) DOUBLE PRECISION
+* The scaling factor s for the triangular system
+* A * x = s*b or A'* x = s*b.
+* If SCALE = 0, the matrix A is singular or badly scaled, and
+* the vector x is an exact or approximate solution to A*x = 0.
+*
+* CNORM (input or output) DOUBLE PRECISION array, dimension (N)
+*
+* If NORMIN = 'Y', CNORM is an input argument and CNORM(j)
+* contains the norm of the off-diagonal part of the j-th column
+* of A. If TRANS = 'N', CNORM(j) must be greater than or equal
+* to the infinity-norm, and if TRANS = 'T' or 'C', CNORM(j)
+* must be greater than or equal to the 1-norm.
+*
+* If NORMIN = 'N', CNORM is an output argument and CNORM(j)
+* returns the 1-norm of the offdiagonal part of the j-th column
+* of A.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -k, the k-th argument had an illegal value
+*
+* Further Details
+* ======= =======
+*
+* A rough bound on x is computed; if that is less than overflow, DTBSV
+* is called, otherwise, specific code is used which checks for possible
+* overflow or divide-by-zero at every operation.
+*
+* A columnwise scheme is used for solving A*x = b. The basic algorithm
+* if A is lower triangular is
+*
+* x[1:n] := b[1:n]
+* for j = 1, ..., n
+* x(j) := x(j) / A(j,j)
+* x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j]
+* end
+*
+* Define bounds on the components of x after j iterations of the loop:
+* M(j) = bound on x[1:j]
+* G(j) = bound on x[j+1:n]
+* Initially, let M(0) = 0 and G(0) = max{x(i), i=1,...,n}.
+*
+* Then for iteration j+1 we have
+* M(j+1) <= G(j) / | A(j+1,j+1) |
+* G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] |
+* <= G(j) ( 1 + CNORM(j+1) / | A(j+1,j+1) | )
+*
+* where CNORM(j+1) is greater than or equal to the infinity-norm of
+* column j+1 of A, not counting the diagonal. Hence
+*
+* G(j) <= G(0) product ( 1 + CNORM(i) / | A(i,i) | )
+* 1<=i<=j
+* and
+*
+* |x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + CNORM(i) / |A(i,i)| )
+* 1<=i< j
+*
+* Since |x(j)| <= M(j), we use the Level 2 BLAS routine DTBSV if the
+* reciprocal of the largest M(j), j=1,..,n, is larger than
+* max(underflow, 1/overflow).
+*
+* The bound on x(j) is also used to determine when a step in the
+* columnwise method can be performed without fear of overflow. If
+* the computed bound is greater than a large constant, x is scaled to
+* prevent overflow, but if the bound overflows, x is set to 0, x(j) to
+* 1, and scale to 0, and a non-trivial solution to A*x = 0 is found.
+*
+* Similarly, a row-wise scheme is used to solve A'*x = b. The basic
+* algorithm for A upper triangular is
+*
+* for j = 1, ..., n
+* x(j) := ( b(j) - A[1:j-1,j]' * x[1:j-1] ) / A(j,j)
+* end
+*
+* We simultaneously compute two bounds
+* G(j) = bound on ( b(i) - A[1:i-1,i]' * x[1:i-1] ), 1<=i<=j
+* M(j) = bound on x(i), 1<=i<=j
+*
+* The initial values are G(0) = 0, M(0) = max{b(i), i=1,..,n}, and we
+* add the constraint G(j) >= G(j-1) and M(j) >= M(j-1) for j >= 1.
+* Then the bound on x(j) is
+*
+* M(j) <= M(j-1) * ( 1 + CNORM(j) ) / | A(j,j) |
+*
+* <= M(0) * product ( ( 1 + CNORM(i) ) / |A(i,i)| )
+* 1<=i<=j
+*
+* and we can safely call DTBSV if 1/M(n) and 1/G(n) are both greater
+* than max(underflow, 1/overflow).
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, HALF, ONE
+ PARAMETER ( ZERO = 0.0D+0, HALF = 0.5D+0, ONE = 1.0D+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL NOTRAN, NOUNIT, UPPER
+ INTEGER I, IMAX, J, JFIRST, JINC, JLAST, JLEN, MAIND
+ DOUBLE PRECISION BIGNUM, GROW, REC, SMLNUM, SUMJ, TJJ, TJJS,
+ $ TMAX, TSCAL, USCAL, XBND, XJ, XMAX
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER IDAMAX
+ DOUBLE PRECISION DASUM, DDOT, DLAMCH
+ EXTERNAL LSAME, IDAMAX, DASUM, DDOT, DLAMCH
+* ..
+* .. External Subroutines ..
+ EXTERNAL DAXPY, DSCAL, DTBSV, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ NOTRAN = LSAME( TRANS, 'N' )
+ NOUNIT = LSAME( DIAG, 'N' )
+*
+* Test the input parameters.
+*
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT.
+ $ LSAME( TRANS, 'C' ) ) THEN
+ INFO = -2
+ ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
+ INFO = -3
+ ELSE IF( .NOT.LSAME( NORMIN, 'Y' ) .AND. .NOT.
+ $ LSAME( NORMIN, 'N' ) ) THEN
+ INFO = -4
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -5
+ ELSE IF( KD.LT.0 ) THEN
+ INFO = -6
+ ELSE IF( LDAB.LT.KD+1 ) THEN
+ INFO = -8
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DLATBS', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+* Determine machine dependent parameters to control overflow.
+*
+ SMLNUM = DLAMCH( 'Safe minimum' ) / DLAMCH( 'Precision' )
+ BIGNUM = ONE / SMLNUM
+ SCALE = ONE
+*
+ IF( LSAME( NORMIN, 'N' ) ) THEN
+*
+* Compute the 1-norm of each column, not including the diagonal.
+*
+ IF( UPPER ) THEN
+*
+* A is upper triangular.
+*
+ DO 10 J = 1, N
+ JLEN = MIN( KD, J-1 )
+ CNORM( J ) = DASUM( JLEN, AB( KD+1-JLEN, J ), 1 )
+ 10 CONTINUE
+ ELSE
+*
+* A is lower triangular.
+*
+ DO 20 J = 1, N
+ JLEN = MIN( KD, N-J )
+ IF( JLEN.GT.0 ) THEN
+ CNORM( J ) = DASUM( JLEN, AB( 2, J ), 1 )
+ ELSE
+ CNORM( J ) = ZERO
+ END IF
+ 20 CONTINUE
+ END IF
+ END IF
+*
+* Scale the column norms by TSCAL if the maximum element in CNORM is
+* greater than BIGNUM.
+*
+ IMAX = IDAMAX( N, CNORM, 1 )
+ TMAX = CNORM( IMAX )
+ IF( TMAX.LE.BIGNUM ) THEN
+ TSCAL = ONE
+ ELSE
+ TSCAL = ONE / ( SMLNUM*TMAX )
+ CALL DSCAL( N, TSCAL, CNORM, 1 )
+ END IF
+*
+* Compute a bound on the computed solution vector to see if the
+* Level 2 BLAS routine DTBSV can be used.
+*
+ J = IDAMAX( N, X, 1 )
+ XMAX = ABS( X( J ) )
+ XBND = XMAX
+ IF( NOTRAN ) THEN
+*
+* Compute the growth in A * x = b.
+*
+ IF( UPPER ) THEN
+ JFIRST = N
+ JLAST = 1
+ JINC = -1
+ MAIND = KD + 1
+ ELSE
+ JFIRST = 1
+ JLAST = N
+ JINC = 1
+ MAIND = 1
+ END IF
+*
+ IF( TSCAL.NE.ONE ) THEN
+ GROW = ZERO
+ GO TO 50
+ END IF
+*
+ IF( NOUNIT ) THEN
+*
+* A is non-unit triangular.
+*
+* Compute GROW = 1/G(j) and XBND = 1/M(j).
+* Initially, G(0) = max{x(i), i=1,...,n}.
+*
+ GROW = ONE / MAX( XBND, SMLNUM )
+ XBND = GROW
+ DO 30 J = JFIRST, JLAST, JINC
+*
+* Exit the loop if the growth factor is too small.
+*
+ IF( GROW.LE.SMLNUM )
+ $ GO TO 50
+*
+* M(j) = G(j-1) / abs(A(j,j))
+*
+ TJJ = ABS( AB( MAIND, J ) )
+ XBND = MIN( XBND, MIN( ONE, TJJ )*GROW )
+ IF( TJJ+CNORM( J ).GE.SMLNUM ) THEN
+*
+* G(j) = G(j-1)*( 1 + CNORM(j) / abs(A(j,j)) )
+*
+ GROW = GROW*( TJJ / ( TJJ+CNORM( J ) ) )
+ ELSE
+*
+* G(j) could overflow, set GROW to 0.
+*
+ GROW = ZERO
+ END IF
+ 30 CONTINUE
+ GROW = XBND
+ ELSE
+*
+* A is unit triangular.
+*
+* Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}.
+*
+ GROW = MIN( ONE, ONE / MAX( XBND, SMLNUM ) )
+ DO 40 J = JFIRST, JLAST, JINC
+*
+* Exit the loop if the growth factor is too small.
+*
+ IF( GROW.LE.SMLNUM )
+ $ GO TO 50
+*
+* G(j) = G(j-1)*( 1 + CNORM(j) )
+*
+ GROW = GROW*( ONE / ( ONE+CNORM( J ) ) )
+ 40 CONTINUE
+ END IF
+ 50 CONTINUE
+*
+ ELSE
+*
+* Compute the growth in A' * x = b.
+*
+ IF( UPPER ) THEN
+ JFIRST = 1
+ JLAST = N
+ JINC = 1
+ MAIND = KD + 1
+ ELSE
+ JFIRST = N
+ JLAST = 1
+ JINC = -1
+ MAIND = 1
+ END IF
+*
+ IF( TSCAL.NE.ONE ) THEN
+ GROW = ZERO
+ GO TO 80
+ END IF
+*
+ IF( NOUNIT ) THEN
+*
+* A is non-unit triangular.
+*
+* Compute GROW = 1/G(j) and XBND = 1/M(j).
+* Initially, M(0) = max{x(i), i=1,...,n}.
+*
+ GROW = ONE / MAX( XBND, SMLNUM )
+ XBND = GROW
+ DO 60 J = JFIRST, JLAST, JINC
+*
+* Exit the loop if the growth factor is too small.
+*
+ IF( GROW.LE.SMLNUM )
+ $ GO TO 80
+*
+* G(j) = max( G(j-1), M(j-1)*( 1 + CNORM(j) ) )
+*
+ XJ = ONE + CNORM( J )
+ GROW = MIN( GROW, XBND / XJ )
+*
+* M(j) = M(j-1)*( 1 + CNORM(j) ) / abs(A(j,j))
+*
+ TJJ = ABS( AB( MAIND, J ) )
+ IF( XJ.GT.TJJ )
+ $ XBND = XBND*( TJJ / XJ )
+ 60 CONTINUE
+ GROW = MIN( GROW, XBND )
+ ELSE
+*
+* A is unit triangular.
+*
+* Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}.
+*
+ GROW = MIN( ONE, ONE / MAX( XBND, SMLNUM ) )
+ DO 70 J = JFIRST, JLAST, JINC
+*
+* Exit the loop if the growth factor is too small.
+*
+ IF( GROW.LE.SMLNUM )
+ $ GO TO 80
+*
+* G(j) = ( 1 + CNORM(j) )*G(j-1)
+*
+ XJ = ONE + CNORM( J )
+ GROW = GROW / XJ
+ 70 CONTINUE
+ END IF
+ 80 CONTINUE
+ END IF
+*
+ IF( ( GROW*TSCAL ).GT.SMLNUM ) THEN
+*
+* Use the Level 2 BLAS solve if the reciprocal of the bound on
+* elements of X is not too small.
+*
+ CALL DTBSV( UPLO, TRANS, DIAG, N, KD, AB, LDAB, X, 1 )
+ ELSE
+*
+* Use a Level 1 BLAS solve, scaling intermediate results.
+*
+ IF( XMAX.GT.BIGNUM ) THEN
+*
+* Scale X so that its components are less than or equal to
+* BIGNUM in absolute value.
+*
+ SCALE = BIGNUM / XMAX
+ CALL DSCAL( N, SCALE, X, 1 )
+ XMAX = BIGNUM
+ END IF
+*
+ IF( NOTRAN ) THEN
+*
+* Solve A * x = b
+*
+ DO 110 J = JFIRST, JLAST, JINC
+*
+* Compute x(j) = b(j) / A(j,j), scaling x if necessary.
+*
+ XJ = ABS( X( J ) )
+ IF( NOUNIT ) THEN
+ TJJS = AB( MAIND, J )*TSCAL
+ ELSE
+ TJJS = TSCAL
+ IF( TSCAL.EQ.ONE )
+ $ GO TO 100
+ END IF
+ TJJ = ABS( TJJS )
+ IF( TJJ.GT.SMLNUM ) THEN
+*
+* abs(A(j,j)) > SMLNUM:
+*
+ IF( TJJ.LT.ONE ) THEN
+ IF( XJ.GT.TJJ*BIGNUM ) THEN
+*
+* Scale x by 1/b(j).
+*
+ REC = ONE / XJ
+ CALL DSCAL( N, REC, X, 1 )
+ SCALE = SCALE*REC
+ XMAX = XMAX*REC
+ END IF
+ END IF
+ X( J ) = X( J ) / TJJS
+ XJ = ABS( X( J ) )
+ ELSE IF( TJJ.GT.ZERO ) THEN
+*
+* 0 < abs(A(j,j)) <= SMLNUM:
+*
+ IF( XJ.GT.TJJ*BIGNUM ) THEN
+*
+* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM
+* to avoid overflow when dividing by A(j,j).
+*
+ REC = ( TJJ*BIGNUM ) / XJ
+ IF( CNORM( J ).GT.ONE ) THEN
+*
+* Scale by 1/CNORM(j) to avoid overflow when
+* multiplying x(j) times column j.
+*
+ REC = REC / CNORM( J )
+ END IF
+ CALL DSCAL( N, REC, X, 1 )
+ SCALE = SCALE*REC
+ XMAX = XMAX*REC
+ END IF
+ X( J ) = X( J ) / TJJS
+ XJ = ABS( X( J ) )
+ ELSE
+*
+* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and
+* scale = 0, and compute a solution to A*x = 0.
+*
+ DO 90 I = 1, N
+ X( I ) = ZERO
+ 90 CONTINUE
+ X( J ) = ONE
+ XJ = ONE
+ SCALE = ZERO
+ XMAX = ZERO
+ END IF
+ 100 CONTINUE
+*
+* Scale x if necessary to avoid overflow when adding a
+* multiple of column j of A.
+*
+ IF( XJ.GT.ONE ) THEN
+ REC = ONE / XJ
+ IF( CNORM( J ).GT.( BIGNUM-XMAX )*REC ) THEN
+*
+* Scale x by 1/(2*abs(x(j))).
+*
+ REC = REC*HALF
+ CALL DSCAL( N, REC, X, 1 )
+ SCALE = SCALE*REC
+ END IF
+ ELSE IF( XJ*CNORM( J ).GT.( BIGNUM-XMAX ) ) THEN
+*
+* Scale x by 1/2.
+*
+ CALL DSCAL( N, HALF, X, 1 )
+ SCALE = SCALE*HALF
+ END IF
+*
+ IF( UPPER ) THEN
+ IF( J.GT.1 ) THEN
+*
+* Compute the update
+* x(max(1,j-kd):j-1) := x(max(1,j-kd):j-1) -
+* x(j)* A(max(1,j-kd):j-1,j)
+*
+ JLEN = MIN( KD, J-1 )
+ CALL DAXPY( JLEN, -X( J )*TSCAL,
+ $ AB( KD+1-JLEN, J ), 1, X( J-JLEN ), 1 )
+ I = IDAMAX( J-1, X, 1 )
+ XMAX = ABS( X( I ) )
+ END IF
+ ELSE IF( J.LT.N ) THEN
+*
+* Compute the update
+* x(j+1:min(j+kd,n)) := x(j+1:min(j+kd,n)) -
+* x(j) * A(j+1:min(j+kd,n),j)
+*
+ JLEN = MIN( KD, N-J )
+ IF( JLEN.GT.0 )
+ $ CALL DAXPY( JLEN, -X( J )*TSCAL, AB( 2, J ), 1,
+ $ X( J+1 ), 1 )
+ I = J + IDAMAX( N-J, X( J+1 ), 1 )
+ XMAX = ABS( X( I ) )
+ END IF
+ 110 CONTINUE
+*
+ ELSE
+*
+* Solve A' * x = b
+*
+ DO 160 J = JFIRST, JLAST, JINC
+*
+* Compute x(j) = b(j) - sum A(k,j)*x(k).
+* k<>j
+*
+ XJ = ABS( X( J ) )
+ USCAL = TSCAL
+ REC = ONE / MAX( XMAX, ONE )
+ IF( CNORM( J ).GT.( BIGNUM-XJ )*REC ) THEN
+*
+* If x(j) could overflow, scale x by 1/(2*XMAX).
+*
+ REC = REC*HALF
+ IF( NOUNIT ) THEN
+ TJJS = AB( MAIND, J )*TSCAL
+ ELSE
+ TJJS = TSCAL
+ END IF
+ TJJ = ABS( TJJS )
+ IF( TJJ.GT.ONE ) THEN
+*
+* Divide by A(j,j) when scaling x if A(j,j) > 1.
+*
+ REC = MIN( ONE, REC*TJJ )
+ USCAL = USCAL / TJJS
+ END IF
+ IF( REC.LT.ONE ) THEN
+ CALL DSCAL( N, REC, X, 1 )
+ SCALE = SCALE*REC
+ XMAX = XMAX*REC
+ END IF
+ END IF
+*
+ SUMJ = ZERO
+ IF( USCAL.EQ.ONE ) THEN
+*
+* If the scaling needed for A in the dot product is 1,
+* call DDOT to perform the dot product.
+*
+ IF( UPPER ) THEN
+ JLEN = MIN( KD, J-1 )
+ SUMJ = DDOT( JLEN, AB( KD+1-JLEN, J ), 1,
+ $ X( J-JLEN ), 1 )
+ ELSE
+ JLEN = MIN( KD, N-J )
+ IF( JLEN.GT.0 )
+ $ SUMJ = DDOT( JLEN, AB( 2, J ), 1, X( J+1 ), 1 )
+ END IF
+ ELSE
+*
+* Otherwise, use in-line code for the dot product.
+*
+ IF( UPPER ) THEN
+ JLEN = MIN( KD, J-1 )
+ DO 120 I = 1, JLEN
+ SUMJ = SUMJ + ( AB( KD+I-JLEN, J )*USCAL )*
+ $ X( J-JLEN-1+I )
+ 120 CONTINUE
+ ELSE
+ JLEN = MIN( KD, N-J )
+ DO 130 I = 1, JLEN
+ SUMJ = SUMJ + ( AB( I+1, J )*USCAL )*X( J+I )
+ 130 CONTINUE
+ END IF
+ END IF
+*
+ IF( USCAL.EQ.TSCAL ) THEN
+*
+* Compute x(j) := ( x(j) - sumj ) / A(j,j) if 1/A(j,j)
+* was not used to scale the dotproduct.
+*
+ X( J ) = X( J ) - SUMJ
+ XJ = ABS( X( J ) )
+ IF( NOUNIT ) THEN
+*
+* Compute x(j) = x(j) / A(j,j), scaling if necessary.
+*
+ TJJS = AB( MAIND, J )*TSCAL
+ ELSE
+ TJJS = TSCAL
+ IF( TSCAL.EQ.ONE )
+ $ GO TO 150
+ END IF
+ TJJ = ABS( TJJS )
+ IF( TJJ.GT.SMLNUM ) THEN
+*
+* abs(A(j,j)) > SMLNUM:
+*
+ IF( TJJ.LT.ONE ) THEN
+ IF( XJ.GT.TJJ*BIGNUM ) THEN
+*
+* Scale X by 1/abs(x(j)).
+*
+ REC = ONE / XJ
+ CALL DSCAL( N, REC, X, 1 )
+ SCALE = SCALE*REC
+ XMAX = XMAX*REC
+ END IF
+ END IF
+ X( J ) = X( J ) / TJJS
+ ELSE IF( TJJ.GT.ZERO ) THEN
+*
+* 0 < abs(A(j,j)) <= SMLNUM:
+*
+ IF( XJ.GT.TJJ*BIGNUM ) THEN
+*
+* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM.
+*
+ REC = ( TJJ*BIGNUM ) / XJ
+ CALL DSCAL( N, REC, X, 1 )
+ SCALE = SCALE*REC
+ XMAX = XMAX*REC
+ END IF
+ X( J ) = X( J ) / TJJS
+ ELSE
+*
+* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and
+* scale = 0, and compute a solution to A'*x = 0.
+*
+ DO 140 I = 1, N
+ X( I ) = ZERO
+ 140 CONTINUE
+ X( J ) = ONE
+ SCALE = ZERO
+ XMAX = ZERO
+ END IF
+ 150 CONTINUE
+ ELSE
+*
+* Compute x(j) := x(j) / A(j,j) - sumj if the dot
+* product has already been divided by 1/A(j,j).
+*
+ X( J ) = X( J ) / TJJS - SUMJ
+ END IF
+ XMAX = MAX( XMAX, ABS( X( J ) ) )
+ 160 CONTINUE
+ END IF
+ SCALE = SCALE / TSCAL
+ END IF
+*
+* Scale the column norms by 1/TSCAL for return.
+*
+ IF( TSCAL.NE.ONE ) THEN
+ CALL DSCAL( N, ONE / TSCAL, CNORM, 1 )
+ END IF
+*
+ RETURN
+*
+* End of DLATBS
+*
+ END
+ SUBROUTINE DLATDF( IJOB, N, Z, LDZ, RHS, RDSUM, RDSCAL, IPIV,
+ $ JPIV )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER IJOB, LDZ, N
+ DOUBLE PRECISION RDSCAL, RDSUM
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * ), JPIV( * )
+ DOUBLE PRECISION RHS( * ), Z( LDZ, * )
+* ..
+*
+* Purpose
+* =======
+*
+* DLATDF uses the LU factorization of the n-by-n matrix Z computed by
+* DGETC2 and computes a contribution to the reciprocal Dif-estimate
+* by solving Z * x = b for x, and choosing the r.h.s. b such that
+* the norm of x is as large as possible. On entry RHS = b holds the
+* contribution from earlier solved sub-systems, and on return RHS = x.
+*
+* The factorization of Z returned by DGETC2 has the form Z = P*L*U*Q,
+* where P and Q are permutation matrices. L is lower triangular with
+* unit diagonal elements and U is upper triangular.
+*
+* Arguments
+* =========
+*
+* IJOB (input) INTEGER
+* IJOB = 2: First compute an approximative null-vector e
+* of Z using DGECON, e is normalized and solve for
+* Zx = +-e - f with the sign giving the greater value
+* of 2-norm(x). About 5 times as expensive as Default.
+* IJOB .ne. 2: Local look ahead strategy where all entries of
+* the r.h.s. b is choosen as either +1 or -1 (Default).
+*
+* N (input) INTEGER
+* The number of columns of the matrix Z.
+*
+* Z (input) DOUBLE PRECISION array, dimension (LDZ, N)
+* On entry, the LU part of the factorization of the n-by-n
+* matrix Z computed by DGETC2: Z = P * L * U * Q
+*
+* LDZ (input) INTEGER
+* The leading dimension of the array Z. LDA >= max(1, N).
+*
+* RHS (input/output) DOUBLE PRECISION array, dimension N.
+* On entry, RHS contains contributions from other subsystems.
+* On exit, RHS contains the solution of the subsystem with
+* entries acoording to the value of IJOB (see above).
+*
+* RDSUM (input/output) DOUBLE PRECISION
+* On entry, the sum of squares of computed contributions to
+* the Dif-estimate under computation by DTGSYL, where the
+* scaling factor RDSCAL (see below) has been factored out.
+* On exit, the corresponding sum of squares updated with the
+* contributions from the current sub-system.
+* If TRANS = 'T' RDSUM is not touched.
+* NOTE: RDSUM only makes sense when DTGSY2 is called by STGSYL.
+*
+* RDSCAL (input/output) DOUBLE PRECISION
+* On entry, scaling factor used to prevent overflow in RDSUM.
+* On exit, RDSCAL is updated w.r.t. the current contributions
+* in RDSUM.
+* If TRANS = 'T', RDSCAL is not touched.
+* NOTE: RDSCAL only makes sense when DTGSY2 is called by
+* DTGSYL.
+*
+* IPIV (input) INTEGER array, dimension (N).
+* The pivot indices; for 1 <= i <= N, row i of the
+* matrix has been interchanged with row IPIV(i).
+*
+* JPIV (input) INTEGER array, dimension (N).
+* The pivot indices; for 1 <= j <= N, column j of the
+* matrix has been interchanged with column JPIV(j).
+*
+* Further Details
+* ===============
+*
+* Based on contributions by
+* Bo Kagstrom and Peter Poromaa, Department of Computing Science,
+* Umea University, S-901 87 Umea, Sweden.
+*
+* This routine is a further developed implementation of algorithm
+* BSOLVE in [1] using complete pivoting in the LU factorization.
+*
+* [1] Bo Kagstrom and Lars Westin,
+* Generalized Schur Methods with Condition Estimators for
+* Solving the Generalized Sylvester Equation, IEEE Transactions
+* on Automatic Control, Vol. 34, No. 7, July 1989, pp 745-751.
+*
+* [2] Peter Poromaa,
+* On Efficient and Robust Estimators for the Separation
+* between two Regular Matrix Pairs with Applications in
+* Condition Estimation. Report IMINF-95.05, Departement of
+* Computing Science, Umea University, S-901 87 Umea, Sweden, 1995.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ INTEGER MAXDIM
+ PARAMETER ( MAXDIM = 8 )
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, INFO, J, K
+ DOUBLE PRECISION BM, BP, PMONE, SMINU, SPLUS, TEMP
+* ..
+* .. Local Arrays ..
+ INTEGER IWORK( MAXDIM )
+ DOUBLE PRECISION WORK( 4*MAXDIM ), XM( MAXDIM ), XP( MAXDIM )
+* ..
+* .. External Subroutines ..
+ EXTERNAL DAXPY, DCOPY, DGECON, DGESC2, DLASSQ, DLASWP,
+ $ DSCAL
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DASUM, DDOT
+ EXTERNAL DASUM, DDOT
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, SQRT
+* ..
+* .. Executable Statements ..
+*
+ IF( IJOB.NE.2 ) THEN
+*
+* Apply permutations IPIV to RHS
+*
+ CALL DLASWP( 1, RHS, LDZ, 1, N-1, IPIV, 1 )
+*
+* Solve for L-part choosing RHS either to +1 or -1.
+*
+ PMONE = -ONE
+*
+ DO 10 J = 1, N - 1
+ BP = RHS( J ) + ONE
+ BM = RHS( J ) - ONE
+ SPLUS = ONE
+*
+* Look-ahead for L-part RHS(1:N-1) = + or -1, SPLUS and
+* SMIN computed more efficiently than in BSOLVE [1].
+*
+ SPLUS = SPLUS + DDOT( N-J, Z( J+1, J ), 1, Z( J+1, J ), 1 )
+ SMINU = DDOT( N-J, Z( J+1, J ), 1, RHS( J+1 ), 1 )
+ SPLUS = SPLUS*RHS( J )
+ IF( SPLUS.GT.SMINU ) THEN
+ RHS( J ) = BP
+ ELSE IF( SMINU.GT.SPLUS ) THEN
+ RHS( J ) = BM
+ ELSE
+*
+* In this case the updating sums are equal and we can
+* choose RHS(J) +1 or -1. The first time this happens
+* we choose -1, thereafter +1. This is a simple way to
+* get good estimates of matrices like Byers well-known
+* example (see [1]). (Not done in BSOLVE.)
+*
+ RHS( J ) = RHS( J ) + PMONE
+ PMONE = ONE
+ END IF
+*
+* Compute the remaining r.h.s.
+*
+ TEMP = -RHS( J )
+ CALL DAXPY( N-J, TEMP, Z( J+1, J ), 1, RHS( J+1 ), 1 )
+*
+ 10 CONTINUE
+*
+* Solve for U-part, look-ahead for RHS(N) = +-1. This is not done
+* in BSOLVE and will hopefully give us a better estimate because
+* any ill-conditioning of the original matrix is transfered to U
+* and not to L. U(N, N) is an approximation to sigma_min(LU).
+*
+ CALL DCOPY( N-1, RHS, 1, XP, 1 )
+ XP( N ) = RHS( N ) + ONE
+ RHS( N ) = RHS( N ) - ONE
+ SPLUS = ZERO
+ SMINU = ZERO
+ DO 30 I = N, 1, -1
+ TEMP = ONE / Z( I, I )
+ XP( I ) = XP( I )*TEMP
+ RHS( I ) = RHS( I )*TEMP
+ DO 20 K = I + 1, N
+ XP( I ) = XP( I ) - XP( K )*( Z( I, K )*TEMP )
+ RHS( I ) = RHS( I ) - RHS( K )*( Z( I, K )*TEMP )
+ 20 CONTINUE
+ SPLUS = SPLUS + ABS( XP( I ) )
+ SMINU = SMINU + ABS( RHS( I ) )
+ 30 CONTINUE
+ IF( SPLUS.GT.SMINU )
+ $ CALL DCOPY( N, XP, 1, RHS, 1 )
+*
+* Apply the permutations JPIV to the computed solution (RHS)
+*
+ CALL DLASWP( 1, RHS, LDZ, 1, N-1, JPIV, -1 )
+*
+* Compute the sum of squares
+*
+ CALL DLASSQ( N, RHS, 1, RDSCAL, RDSUM )
+*
+ ELSE
+*
+* IJOB = 2, Compute approximate nullvector XM of Z
+*
+ CALL DGECON( 'I', N, Z, LDZ, ONE, TEMP, WORK, IWORK, INFO )
+ CALL DCOPY( N, WORK( N+1 ), 1, XM, 1 )
+*
+* Compute RHS
+*
+ CALL DLASWP( 1, XM, LDZ, 1, N-1, IPIV, -1 )
+ TEMP = ONE / SQRT( DDOT( N, XM, 1, XM, 1 ) )
+ CALL DSCAL( N, TEMP, XM, 1 )
+ CALL DCOPY( N, XM, 1, XP, 1 )
+ CALL DAXPY( N, ONE, RHS, 1, XP, 1 )
+ CALL DAXPY( N, -ONE, XM, 1, RHS, 1 )
+ CALL DGESC2( N, Z, LDZ, RHS, IPIV, JPIV, TEMP )
+ CALL DGESC2( N, Z, LDZ, XP, IPIV, JPIV, TEMP )
+ IF( DASUM( N, XP, 1 ).GT.DASUM( N, RHS, 1 ) )
+ $ CALL DCOPY( N, XP, 1, RHS, 1 )
+*
+* Compute the sum of squares
+*
+ CALL DLASSQ( N, RHS, 1, RDSCAL, RDSUM )
+*
+ END IF
+*
+ RETURN
+*
+* End of DLATDF
+*
+ END
+ SUBROUTINE DLATPS( UPLO, TRANS, DIAG, NORMIN, N, AP, X, SCALE,
+ $ CNORM, INFO )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER DIAG, NORMIN, TRANS, UPLO
+ INTEGER INFO, N
+ DOUBLE PRECISION SCALE
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION AP( * ), CNORM( * ), X( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DLATPS solves one of the triangular systems
+*
+* A *x = s*b or A'*x = s*b
+*
+* with scaling to prevent overflow, where A is an upper or lower
+* triangular matrix stored in packed form. Here A' denotes the
+* transpose of A, x and b are n-element vectors, and s is a scaling
+* factor, usually less than or equal to 1, chosen so that the
+* components of x will be less than the overflow threshold. If the
+* unscaled problem will not cause overflow, the Level 2 BLAS routine
+* DTPSV is called. If the matrix A is singular (A(j,j) = 0 for some j),
+* then s is set to 0 and a non-trivial solution to A*x = 0 is returned.
+*
+* Arguments
+* =========
+*
+* UPLO (input) CHARACTER*1
+* Specifies whether the matrix A is upper or lower triangular.
+* = 'U': Upper triangular
+* = 'L': Lower triangular
+*
+* TRANS (input) CHARACTER*1
+* Specifies the operation applied to A.
+* = 'N': Solve A * x = s*b (No transpose)
+* = 'T': Solve A'* x = s*b (Transpose)
+* = 'C': Solve A'* x = s*b (Conjugate transpose = Transpose)
+*
+* DIAG (input) CHARACTER*1
+* Specifies whether or not the matrix A is unit triangular.
+* = 'N': Non-unit triangular
+* = 'U': Unit triangular
+*
+* NORMIN (input) CHARACTER*1
+* Specifies whether CNORM has been set or not.
+* = 'Y': CNORM contains the column norms on entry
+* = 'N': CNORM is not set on entry. On exit, the norms will
+* be computed and stored in CNORM.
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)
+* The upper or lower triangular matrix A, packed columnwise in
+* a linear array. The j-th column of A is stored in the array
+* AP as follows:
+* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
+* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
+*
+* X (input/output) DOUBLE PRECISION array, dimension (N)
+* On entry, the right hand side b of the triangular system.
+* On exit, X is overwritten by the solution vector x.
+*
+* SCALE (output) DOUBLE PRECISION
+* The scaling factor s for the triangular system
+* A * x = s*b or A'* x = s*b.
+* If SCALE = 0, the matrix A is singular or badly scaled, and
+* the vector x is an exact or approximate solution to A*x = 0.
+*
+* CNORM (input or output) DOUBLE PRECISION array, dimension (N)
+*
+* If NORMIN = 'Y', CNORM is an input argument and CNORM(j)
+* contains the norm of the off-diagonal part of the j-th column
+* of A. If TRANS = 'N', CNORM(j) must be greater than or equal
+* to the infinity-norm, and if TRANS = 'T' or 'C', CNORM(j)
+* must be greater than or equal to the 1-norm.
+*
+* If NORMIN = 'N', CNORM is an output argument and CNORM(j)
+* returns the 1-norm of the offdiagonal part of the j-th column
+* of A.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -k, the k-th argument had an illegal value
+*
+* Further Details
+* ======= =======
+*
+* A rough bound on x is computed; if that is less than overflow, DTPSV
+* is called, otherwise, specific code is used which checks for possible
+* overflow or divide-by-zero at every operation.
+*
+* A columnwise scheme is used for solving A*x = b. The basic algorithm
+* if A is lower triangular is
+*
+* x[1:n] := b[1:n]
+* for j = 1, ..., n
+* x(j) := x(j) / A(j,j)
+* x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j]
+* end
+*
+* Define bounds on the components of x after j iterations of the loop:
+* M(j) = bound on x[1:j]
+* G(j) = bound on x[j+1:n]
+* Initially, let M(0) = 0 and G(0) = max{x(i), i=1,...,n}.
+*
+* Then for iteration j+1 we have
+* M(j+1) <= G(j) / | A(j+1,j+1) |
+* G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] |
+* <= G(j) ( 1 + CNORM(j+1) / | A(j+1,j+1) | )
+*
+* where CNORM(j+1) is greater than or equal to the infinity-norm of
+* column j+1 of A, not counting the diagonal. Hence
+*
+* G(j) <= G(0) product ( 1 + CNORM(i) / | A(i,i) | )
+* 1<=i<=j
+* and
+*
+* |x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + CNORM(i) / |A(i,i)| )
+* 1<=i< j
+*
+* Since |x(j)| <= M(j), we use the Level 2 BLAS routine DTPSV if the
+* reciprocal of the largest M(j), j=1,..,n, is larger than
+* max(underflow, 1/overflow).
+*
+* The bound on x(j) is also used to determine when a step in the
+* columnwise method can be performed without fear of overflow. If
+* the computed bound is greater than a large constant, x is scaled to
+* prevent overflow, but if the bound overflows, x is set to 0, x(j) to
+* 1, and scale to 0, and a non-trivial solution to A*x = 0 is found.
+*
+* Similarly, a row-wise scheme is used to solve A'*x = b. The basic
+* algorithm for A upper triangular is
+*
+* for j = 1, ..., n
+* x(j) := ( b(j) - A[1:j-1,j]' * x[1:j-1] ) / A(j,j)
+* end
+*
+* We simultaneously compute two bounds
+* G(j) = bound on ( b(i) - A[1:i-1,i]' * x[1:i-1] ), 1<=i<=j
+* M(j) = bound on x(i), 1<=i<=j
+*
+* The initial values are G(0) = 0, M(0) = max{b(i), i=1,..,n}, and we
+* add the constraint G(j) >= G(j-1) and M(j) >= M(j-1) for j >= 1.
+* Then the bound on x(j) is
+*
+* M(j) <= M(j-1) * ( 1 + CNORM(j) ) / | A(j,j) |
+*
+* <= M(0) * product ( ( 1 + CNORM(i) ) / |A(i,i)| )
+* 1<=i<=j
+*
+* and we can safely call DTPSV if 1/M(n) and 1/G(n) are both greater
+* than max(underflow, 1/overflow).
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, HALF, ONE
+ PARAMETER ( ZERO = 0.0D+0, HALF = 0.5D+0, ONE = 1.0D+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL NOTRAN, NOUNIT, UPPER
+ INTEGER I, IMAX, IP, J, JFIRST, JINC, JLAST, JLEN
+ DOUBLE PRECISION BIGNUM, GROW, REC, SMLNUM, SUMJ, TJJ, TJJS,
+ $ TMAX, TSCAL, USCAL, XBND, XJ, XMAX
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER IDAMAX
+ DOUBLE PRECISION DASUM, DDOT, DLAMCH
+ EXTERNAL LSAME, IDAMAX, DASUM, DDOT, DLAMCH
+* ..
+* .. External Subroutines ..
+ EXTERNAL DAXPY, DSCAL, DTPSV, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ NOTRAN = LSAME( TRANS, 'N' )
+ NOUNIT = LSAME( DIAG, 'N' )
+*
+* Test the input parameters.
+*
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT.
+ $ LSAME( TRANS, 'C' ) ) THEN
+ INFO = -2
+ ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
+ INFO = -3
+ ELSE IF( .NOT.LSAME( NORMIN, 'Y' ) .AND. .NOT.
+ $ LSAME( NORMIN, 'N' ) ) THEN
+ INFO = -4
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -5
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DLATPS', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+* Determine machine dependent parameters to control overflow.
+*
+ SMLNUM = DLAMCH( 'Safe minimum' ) / DLAMCH( 'Precision' )
+ BIGNUM = ONE / SMLNUM
+ SCALE = ONE
+*
+ IF( LSAME( NORMIN, 'N' ) ) THEN
+*
+* Compute the 1-norm of each column, not including the diagonal.
+*
+ IF( UPPER ) THEN
+*
+* A is upper triangular.
+*
+ IP = 1
+ DO 10 J = 1, N
+ CNORM( J ) = DASUM( J-1, AP( IP ), 1 )
+ IP = IP + J
+ 10 CONTINUE
+ ELSE
+*
+* A is lower triangular.
+*
+ IP = 1
+ DO 20 J = 1, N - 1
+ CNORM( J ) = DASUM( N-J, AP( IP+1 ), 1 )
+ IP = IP + N - J + 1
+ 20 CONTINUE
+ CNORM( N ) = ZERO
+ END IF
+ END IF
+*
+* Scale the column norms by TSCAL if the maximum element in CNORM is
+* greater than BIGNUM.
+*
+ IMAX = IDAMAX( N, CNORM, 1 )
+ TMAX = CNORM( IMAX )
+ IF( TMAX.LE.BIGNUM ) THEN
+ TSCAL = ONE
+ ELSE
+ TSCAL = ONE / ( SMLNUM*TMAX )
+ CALL DSCAL( N, TSCAL, CNORM, 1 )
+ END IF
+*
+* Compute a bound on the computed solution vector to see if the
+* Level 2 BLAS routine DTPSV can be used.
+*
+ J = IDAMAX( N, X, 1 )
+ XMAX = ABS( X( J ) )
+ XBND = XMAX
+ IF( NOTRAN ) THEN
+*
+* Compute the growth in A * x = b.
+*
+ IF( UPPER ) THEN
+ JFIRST = N
+ JLAST = 1
+ JINC = -1
+ ELSE
+ JFIRST = 1
+ JLAST = N
+ JINC = 1
+ END IF
+*
+ IF( TSCAL.NE.ONE ) THEN
+ GROW = ZERO
+ GO TO 50
+ END IF
+*
+ IF( NOUNIT ) THEN
+*
+* A is non-unit triangular.
+*
+* Compute GROW = 1/G(j) and XBND = 1/M(j).
+* Initially, G(0) = max{x(i), i=1,...,n}.
+*
+ GROW = ONE / MAX( XBND, SMLNUM )
+ XBND = GROW
+ IP = JFIRST*( JFIRST+1 ) / 2
+ JLEN = N
+ DO 30 J = JFIRST, JLAST, JINC
+*
+* Exit the loop if the growth factor is too small.
+*
+ IF( GROW.LE.SMLNUM )
+ $ GO TO 50
+*
+* M(j) = G(j-1) / abs(A(j,j))
+*
+ TJJ = ABS( AP( IP ) )
+ XBND = MIN( XBND, MIN( ONE, TJJ )*GROW )
+ IF( TJJ+CNORM( J ).GE.SMLNUM ) THEN
+*
+* G(j) = G(j-1)*( 1 + CNORM(j) / abs(A(j,j)) )
+*
+ GROW = GROW*( TJJ / ( TJJ+CNORM( J ) ) )
+ ELSE
+*
+* G(j) could overflow, set GROW to 0.
+*
+ GROW = ZERO
+ END IF
+ IP = IP + JINC*JLEN
+ JLEN = JLEN - 1
+ 30 CONTINUE
+ GROW = XBND
+ ELSE
+*
+* A is unit triangular.
+*
+* Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}.
+*
+ GROW = MIN( ONE, ONE / MAX( XBND, SMLNUM ) )
+ DO 40 J = JFIRST, JLAST, JINC
+*
+* Exit the loop if the growth factor is too small.
+*
+ IF( GROW.LE.SMLNUM )
+ $ GO TO 50
+*
+* G(j) = G(j-1)*( 1 + CNORM(j) )
+*
+ GROW = GROW*( ONE / ( ONE+CNORM( J ) ) )
+ 40 CONTINUE
+ END IF
+ 50 CONTINUE
+*
+ ELSE
+*
+* Compute the growth in A' * x = b.
+*
+ IF( UPPER ) THEN
+ JFIRST = 1
+ JLAST = N
+ JINC = 1
+ ELSE
+ JFIRST = N
+ JLAST = 1
+ JINC = -1
+ END IF
+*
+ IF( TSCAL.NE.ONE ) THEN
+ GROW = ZERO
+ GO TO 80
+ END IF
+*
+ IF( NOUNIT ) THEN
+*
+* A is non-unit triangular.
+*
+* Compute GROW = 1/G(j) and XBND = 1/M(j).
+* Initially, M(0) = max{x(i), i=1,...,n}.
+*
+ GROW = ONE / MAX( XBND, SMLNUM )
+ XBND = GROW
+ IP = JFIRST*( JFIRST+1 ) / 2
+ JLEN = 1
+ DO 60 J = JFIRST, JLAST, JINC
+*
+* Exit the loop if the growth factor is too small.
+*
+ IF( GROW.LE.SMLNUM )
+ $ GO TO 80
+*
+* G(j) = max( G(j-1), M(j-1)*( 1 + CNORM(j) ) )
+*
+ XJ = ONE + CNORM( J )
+ GROW = MIN( GROW, XBND / XJ )
+*
+* M(j) = M(j-1)*( 1 + CNORM(j) ) / abs(A(j,j))
+*
+ TJJ = ABS( AP( IP ) )
+ IF( XJ.GT.TJJ )
+ $ XBND = XBND*( TJJ / XJ )
+ JLEN = JLEN + 1
+ IP = IP + JINC*JLEN
+ 60 CONTINUE
+ GROW = MIN( GROW, XBND )
+ ELSE
+*
+* A is unit triangular.
+*
+* Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}.
+*
+ GROW = MIN( ONE, ONE / MAX( XBND, SMLNUM ) )
+ DO 70 J = JFIRST, JLAST, JINC
+*
+* Exit the loop if the growth factor is too small.
+*
+ IF( GROW.LE.SMLNUM )
+ $ GO TO 80
+*
+* G(j) = ( 1 + CNORM(j) )*G(j-1)
+*
+ XJ = ONE + CNORM( J )
+ GROW = GROW / XJ
+ 70 CONTINUE
+ END IF
+ 80 CONTINUE
+ END IF
+*
+ IF( ( GROW*TSCAL ).GT.SMLNUM ) THEN
+*
+* Use the Level 2 BLAS solve if the reciprocal of the bound on
+* elements of X is not too small.
+*
+ CALL DTPSV( UPLO, TRANS, DIAG, N, AP, X, 1 )
+ ELSE
+*
+* Use a Level 1 BLAS solve, scaling intermediate results.
+*
+ IF( XMAX.GT.BIGNUM ) THEN
+*
+* Scale X so that its components are less than or equal to
+* BIGNUM in absolute value.
+*
+ SCALE = BIGNUM / XMAX
+ CALL DSCAL( N, SCALE, X, 1 )
+ XMAX = BIGNUM
+ END IF
+*
+ IF( NOTRAN ) THEN
+*
+* Solve A * x = b
+*
+ IP = JFIRST*( JFIRST+1 ) / 2
+ DO 110 J = JFIRST, JLAST, JINC
+*
+* Compute x(j) = b(j) / A(j,j), scaling x if necessary.
+*
+ XJ = ABS( X( J ) )
+ IF( NOUNIT ) THEN
+ TJJS = AP( IP )*TSCAL
+ ELSE
+ TJJS = TSCAL
+ IF( TSCAL.EQ.ONE )
+ $ GO TO 100
+ END IF
+ TJJ = ABS( TJJS )
+ IF( TJJ.GT.SMLNUM ) THEN
+*
+* abs(A(j,j)) > SMLNUM:
+*
+ IF( TJJ.LT.ONE ) THEN
+ IF( XJ.GT.TJJ*BIGNUM ) THEN
+*
+* Scale x by 1/b(j).
+*
+ REC = ONE / XJ
+ CALL DSCAL( N, REC, X, 1 )
+ SCALE = SCALE*REC
+ XMAX = XMAX*REC
+ END IF
+ END IF
+ X( J ) = X( J ) / TJJS
+ XJ = ABS( X( J ) )
+ ELSE IF( TJJ.GT.ZERO ) THEN
+*
+* 0 < abs(A(j,j)) <= SMLNUM:
+*
+ IF( XJ.GT.TJJ*BIGNUM ) THEN
+*
+* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM
+* to avoid overflow when dividing by A(j,j).
+*
+ REC = ( TJJ*BIGNUM ) / XJ
+ IF( CNORM( J ).GT.ONE ) THEN
+*
+* Scale by 1/CNORM(j) to avoid overflow when
+* multiplying x(j) times column j.
+*
+ REC = REC / CNORM( J )
+ END IF
+ CALL DSCAL( N, REC, X, 1 )
+ SCALE = SCALE*REC
+ XMAX = XMAX*REC
+ END IF
+ X( J ) = X( J ) / TJJS
+ XJ = ABS( X( J ) )
+ ELSE
+*
+* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and
+* scale = 0, and compute a solution to A*x = 0.
+*
+ DO 90 I = 1, N
+ X( I ) = ZERO
+ 90 CONTINUE
+ X( J ) = ONE
+ XJ = ONE
+ SCALE = ZERO
+ XMAX = ZERO
+ END IF
+ 100 CONTINUE
+*
+* Scale x if necessary to avoid overflow when adding a
+* multiple of column j of A.
+*
+ IF( XJ.GT.ONE ) THEN
+ REC = ONE / XJ
+ IF( CNORM( J ).GT.( BIGNUM-XMAX )*REC ) THEN
+*
+* Scale x by 1/(2*abs(x(j))).
+*
+ REC = REC*HALF
+ CALL DSCAL( N, REC, X, 1 )
+ SCALE = SCALE*REC
+ END IF
+ ELSE IF( XJ*CNORM( J ).GT.( BIGNUM-XMAX ) ) THEN
+*
+* Scale x by 1/2.
+*
+ CALL DSCAL( N, HALF, X, 1 )
+ SCALE = SCALE*HALF
+ END IF
+*
+ IF( UPPER ) THEN
+ IF( J.GT.1 ) THEN
+*
+* Compute the update
+* x(1:j-1) := x(1:j-1) - x(j) * A(1:j-1,j)
+*
+ CALL DAXPY( J-1, -X( J )*TSCAL, AP( IP-J+1 ), 1, X,
+ $ 1 )
+ I = IDAMAX( J-1, X, 1 )
+ XMAX = ABS( X( I ) )
+ END IF
+ IP = IP - J
+ ELSE
+ IF( J.LT.N ) THEN
+*
+* Compute the update
+* x(j+1:n) := x(j+1:n) - x(j) * A(j+1:n,j)
+*
+ CALL DAXPY( N-J, -X( J )*TSCAL, AP( IP+1 ), 1,
+ $ X( J+1 ), 1 )
+ I = J + IDAMAX( N-J, X( J+1 ), 1 )
+ XMAX = ABS( X( I ) )
+ END IF
+ IP = IP + N - J + 1
+ END IF
+ 110 CONTINUE
+*
+ ELSE
+*
+* Solve A' * x = b
+*
+ IP = JFIRST*( JFIRST+1 ) / 2
+ JLEN = 1
+ DO 160 J = JFIRST, JLAST, JINC
+*
+* Compute x(j) = b(j) - sum A(k,j)*x(k).
+* k<>j
+*
+ XJ = ABS( X( J ) )
+ USCAL = TSCAL
+ REC = ONE / MAX( XMAX, ONE )
+ IF( CNORM( J ).GT.( BIGNUM-XJ )*REC ) THEN
+*
+* If x(j) could overflow, scale x by 1/(2*XMAX).
+*
+ REC = REC*HALF
+ IF( NOUNIT ) THEN
+ TJJS = AP( IP )*TSCAL
+ ELSE
+ TJJS = TSCAL
+ END IF
+ TJJ = ABS( TJJS )
+ IF( TJJ.GT.ONE ) THEN
+*
+* Divide by A(j,j) when scaling x if A(j,j) > 1.
+*
+ REC = MIN( ONE, REC*TJJ )
+ USCAL = USCAL / TJJS
+ END IF
+ IF( REC.LT.ONE ) THEN
+ CALL DSCAL( N, REC, X, 1 )
+ SCALE = SCALE*REC
+ XMAX = XMAX*REC
+ END IF
+ END IF
+*
+ SUMJ = ZERO
+ IF( USCAL.EQ.ONE ) THEN
+*
+* If the scaling needed for A in the dot product is 1,
+* call DDOT to perform the dot product.
+*
+ IF( UPPER ) THEN
+ SUMJ = DDOT( J-1, AP( IP-J+1 ), 1, X, 1 )
+ ELSE IF( J.LT.N ) THEN
+ SUMJ = DDOT( N-J, AP( IP+1 ), 1, X( J+1 ), 1 )
+ END IF
+ ELSE
+*
+* Otherwise, use in-line code for the dot product.
+*
+ IF( UPPER ) THEN
+ DO 120 I = 1, J - 1
+ SUMJ = SUMJ + ( AP( IP-J+I )*USCAL )*X( I )
+ 120 CONTINUE
+ ELSE IF( J.LT.N ) THEN
+ DO 130 I = 1, N - J
+ SUMJ = SUMJ + ( AP( IP+I )*USCAL )*X( J+I )
+ 130 CONTINUE
+ END IF
+ END IF
+*
+ IF( USCAL.EQ.TSCAL ) THEN
+*
+* Compute x(j) := ( x(j) - sumj ) / A(j,j) if 1/A(j,j)
+* was not used to scale the dotproduct.
+*
+ X( J ) = X( J ) - SUMJ
+ XJ = ABS( X( J ) )
+ IF( NOUNIT ) THEN
+*
+* Compute x(j) = x(j) / A(j,j), scaling if necessary.
+*
+ TJJS = AP( IP )*TSCAL
+ ELSE
+ TJJS = TSCAL
+ IF( TSCAL.EQ.ONE )
+ $ GO TO 150
+ END IF
+ TJJ = ABS( TJJS )
+ IF( TJJ.GT.SMLNUM ) THEN
+*
+* abs(A(j,j)) > SMLNUM:
+*
+ IF( TJJ.LT.ONE ) THEN
+ IF( XJ.GT.TJJ*BIGNUM ) THEN
+*
+* Scale X by 1/abs(x(j)).
+*
+ REC = ONE / XJ
+ CALL DSCAL( N, REC, X, 1 )
+ SCALE = SCALE*REC
+ XMAX = XMAX*REC
+ END IF
+ END IF
+ X( J ) = X( J ) / TJJS
+ ELSE IF( TJJ.GT.ZERO ) THEN
+*
+* 0 < abs(A(j,j)) <= SMLNUM:
+*
+ IF( XJ.GT.TJJ*BIGNUM ) THEN
+*
+* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM.
+*
+ REC = ( TJJ*BIGNUM ) / XJ
+ CALL DSCAL( N, REC, X, 1 )
+ SCALE = SCALE*REC
+ XMAX = XMAX*REC
+ END IF
+ X( J ) = X( J ) / TJJS
+ ELSE
+*
+* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and
+* scale = 0, and compute a solution to A'*x = 0.
+*
+ DO 140 I = 1, N
+ X( I ) = ZERO
+ 140 CONTINUE
+ X( J ) = ONE
+ SCALE = ZERO
+ XMAX = ZERO
+ END IF
+ 150 CONTINUE
+ ELSE
+*
+* Compute x(j) := x(j) / A(j,j) - sumj if the dot
+* product has already been divided by 1/A(j,j).
+*
+ X( J ) = X( J ) / TJJS - SUMJ
+ END IF
+ XMAX = MAX( XMAX, ABS( X( J ) ) )
+ JLEN = JLEN + 1
+ IP = IP + JINC*JLEN
+ 160 CONTINUE
+ END IF
+ SCALE = SCALE / TSCAL
+ END IF
+*
+* Scale the column norms by 1/TSCAL for return.
+*
+ IF( TSCAL.NE.ONE ) THEN
+ CALL DSCAL( N, ONE / TSCAL, CNORM, 1 )
+ END IF
+*
+ RETURN
+*
+* End of DLATPS
+*
+ END
+ SUBROUTINE DLATRD( UPLO, N, NB, A, LDA, E, TAU, W, LDW )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER LDA, LDW, N, NB
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION A( LDA, * ), E( * ), TAU( * ), W( LDW, * )
+* ..
+*
+* Purpose
+* =======
+*
+* DLATRD reduces NB rows and columns of a real symmetric matrix A to
+* symmetric tridiagonal form by an orthogonal similarity
+* transformation Q' * A * Q, and returns the matrices V and W which are
+* needed to apply the transformation to the unreduced part of A.
+*
+* If UPLO = 'U', DLATRD reduces the last NB rows and columns of a
+* matrix, of which the upper triangle is supplied;
+* if UPLO = 'L', DLATRD reduces the first NB rows and columns of a
+* matrix, of which the lower triangle is supplied.
+*
+* This is an auxiliary routine called by DSYTRD.
+*
+* Arguments
+* =========
+*
+* UPLO (input) CHARACTER*1
+* Specifies whether the upper or lower triangular part of the
+* symmetric matrix A is stored:
+* = 'U': Upper triangular
+* = 'L': Lower triangular
+*
+* N (input) INTEGER
+* The order of the matrix A.
+*
+* NB (input) INTEGER
+* The number of rows and columns to be reduced.
+*
+* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+* On entry, the symmetric matrix A. If UPLO = 'U', the leading
+* n-by-n upper triangular part of A contains the upper
+* triangular part of the matrix A, and the strictly lower
+* triangular part of A is not referenced. If UPLO = 'L', the
+* leading n-by-n lower triangular part of A contains the lower
+* triangular part of the matrix A, and the strictly upper
+* triangular part of A is not referenced.
+* On exit:
+* if UPLO = 'U', the last NB columns have been reduced to
+* tridiagonal form, with the diagonal elements overwriting
+* the diagonal elements of A; the elements above the diagonal
+* with the array TAU, represent the orthogonal matrix Q as a
+* product of elementary reflectors;
+* if UPLO = 'L', the first NB columns have been reduced to
+* tridiagonal form, with the diagonal elements overwriting
+* the diagonal elements of A; the elements below the diagonal
+* with the array TAU, represent the orthogonal matrix Q as a
+* product of elementary reflectors.
+* See Further Details.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= (1,N).
+*
+* E (output) DOUBLE PRECISION array, dimension (N-1)
+* If UPLO = 'U', E(n-nb:n-1) contains the superdiagonal
+* elements of the last NB columns of the reduced matrix;
+* if UPLO = 'L', E(1:nb) contains the subdiagonal elements of
+* the first NB columns of the reduced matrix.
+*
+* TAU (output) DOUBLE PRECISION array, dimension (N-1)
+* The scalar factors of the elementary reflectors, stored in
+* TAU(n-nb:n-1) if UPLO = 'U', and in TAU(1:nb) if UPLO = 'L'.
+* See Further Details.
+*
+* W (output) DOUBLE PRECISION array, dimension (LDW,NB)
+* The n-by-nb matrix W required to update the unreduced part
+* of A.
+*
+* LDW (input) INTEGER
+* The leading dimension of the array W. LDW >= max(1,N).
+*
+* Further Details
+* ===============
+*
+* If UPLO = 'U', the matrix Q is represented as a product of elementary
+* reflectors
+*
+* Q = H(n) H(n-1) . . . H(n-nb+1).
+*
+* Each H(i) has the form
+*
+* H(i) = I - tau * v * v'
+*
+* where tau is a real scalar, and v is a real vector with
+* v(i:n) = 0 and v(i-1) = 1; v(1:i-1) is stored on exit in A(1:i-1,i),
+* and tau in TAU(i-1).
+*
+* If UPLO = 'L', the matrix Q is represented as a product of elementary
+* reflectors
+*
+* Q = H(1) H(2) . . . H(nb).
+*
+* Each H(i) has the form
+*
+* H(i) = I - tau * v * v'
+*
+* where tau is a real scalar, and v is a real vector with
+* v(1:i) = 0 and v(i+1) = 1; v(i+1:n) is stored on exit in A(i+1:n,i),
+* and tau in TAU(i).
+*
+* The elements of the vectors v together form the n-by-nb matrix V
+* which is needed, with W, to apply the transformation to the unreduced
+* part of the matrix, using a symmetric rank-2k update of the form:
+* A := A - V*W' - W*V'.
+*
+* The contents of A on exit are illustrated by the following examples
+* with n = 5 and nb = 2:
+*
+* if UPLO = 'U': if UPLO = 'L':
+*
+* ( a a a v4 v5 ) ( d )
+* ( a a v4 v5 ) ( 1 d )
+* ( a 1 v5 ) ( v1 1 a )
+* ( d 1 ) ( v1 v2 a a )
+* ( d ) ( v1 v2 a a a )
+*
+* where d denotes a diagonal element of the reduced matrix, a denotes
+* an element of the original matrix that is unchanged, and vi denotes
+* an element of the vector defining H(i).
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE, HALF
+ PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, HALF = 0.5D+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, IW
+ DOUBLE PRECISION ALPHA
+* ..
+* .. External Subroutines ..
+ EXTERNAL DAXPY, DGEMV, DLARFG, DSCAL, DSYMV
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ DOUBLE PRECISION DDOT
+ EXTERNAL LSAME, DDOT
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MIN
+* ..
+* .. Executable Statements ..
+*
+* Quick return if possible
+*
+ IF( N.LE.0 )
+ $ RETURN
+*
+ IF( LSAME( UPLO, 'U' ) ) THEN
+*
+* Reduce last NB columns of upper triangle
+*
+ DO 10 I = N, N - NB + 1, -1
+ IW = I - N + NB
+ IF( I.LT.N ) THEN
+*
+* Update A(1:i,i)
+*
+ CALL DGEMV( 'No transpose', I, N-I, -ONE, A( 1, I+1 ),
+ $ LDA, W( I, IW+1 ), LDW, ONE, A( 1, I ), 1 )
+ CALL DGEMV( 'No transpose', I, N-I, -ONE, W( 1, IW+1 ),
+ $ LDW, A( I, I+1 ), LDA, ONE, A( 1, I ), 1 )
+ END IF
+ IF( I.GT.1 ) THEN
+*
+* Generate elementary reflector H(i) to annihilate
+* A(1:i-2,i)
+*
+ CALL DLARFG( I-1, A( I-1, I ), A( 1, I ), 1, TAU( I-1 ) )
+ E( I-1 ) = A( I-1, I )
+ A( I-1, I ) = ONE
+*
+* Compute W(1:i-1,i)
+*
+ CALL DSYMV( 'Upper', I-1, ONE, A, LDA, A( 1, I ), 1,
+ $ ZERO, W( 1, IW ), 1 )
+ IF( I.LT.N ) THEN
+ CALL DGEMV( 'Transpose', I-1, N-I, ONE, W( 1, IW+1 ),
+ $ LDW, A( 1, I ), 1, ZERO, W( I+1, IW ), 1 )
+ CALL DGEMV( 'No transpose', I-1, N-I, -ONE,
+ $ A( 1, I+1 ), LDA, W( I+1, IW ), 1, ONE,
+ $ W( 1, IW ), 1 )
+ CALL DGEMV( 'Transpose', I-1, N-I, ONE, A( 1, I+1 ),
+ $ LDA, A( 1, I ), 1, ZERO, W( I+1, IW ), 1 )
+ CALL DGEMV( 'No transpose', I-1, N-I, -ONE,
+ $ W( 1, IW+1 ), LDW, W( I+1, IW ), 1, ONE,
+ $ W( 1, IW ), 1 )
+ END IF
+ CALL DSCAL( I-1, TAU( I-1 ), W( 1, IW ), 1 )
+ ALPHA = -HALF*TAU( I-1 )*DDOT( I-1, W( 1, IW ), 1,
+ $ A( 1, I ), 1 )
+ CALL DAXPY( I-1, ALPHA, A( 1, I ), 1, W( 1, IW ), 1 )
+ END IF
+*
+ 10 CONTINUE
+ ELSE
+*
+* Reduce first NB columns of lower triangle
+*
+ DO 20 I = 1, NB
+*
+* Update A(i:n,i)
+*
+ CALL DGEMV( 'No transpose', N-I+1, I-1, -ONE, A( I, 1 ),
+ $ LDA, W( I, 1 ), LDW, ONE, A( I, I ), 1 )
+ CALL DGEMV( 'No transpose', N-I+1, I-1, -ONE, W( I, 1 ),
+ $ LDW, A( I, 1 ), LDA, ONE, A( I, I ), 1 )
+ IF( I.LT.N ) THEN
+*
+* Generate elementary reflector H(i) to annihilate
+* A(i+2:n,i)
+*
+ CALL DLARFG( N-I, A( I+1, I ), A( MIN( I+2, N ), I ), 1,
+ $ TAU( I ) )
+ E( I ) = A( I+1, I )
+ A( I+1, I ) = ONE
+*
+* Compute W(i+1:n,i)
+*
+ CALL DSYMV( 'Lower', N-I, ONE, A( I+1, I+1 ), LDA,
+ $ A( I+1, I ), 1, ZERO, W( I+1, I ), 1 )
+ CALL DGEMV( 'Transpose', N-I, I-1, ONE, W( I+1, 1 ), LDW,
+ $ A( I+1, I ), 1, ZERO, W( 1, I ), 1 )
+ CALL DGEMV( 'No transpose', N-I, I-1, -ONE, A( I+1, 1 ),
+ $ LDA, W( 1, I ), 1, ONE, W( I+1, I ), 1 )
+ CALL DGEMV( 'Transpose', N-I, I-1, ONE, A( I+1, 1 ), LDA,
+ $ A( I+1, I ), 1, ZERO, W( 1, I ), 1 )
+ CALL DGEMV( 'No transpose', N-I, I-1, -ONE, W( I+1, 1 ),
+ $ LDW, W( 1, I ), 1, ONE, W( I+1, I ), 1 )
+ CALL DSCAL( N-I, TAU( I ), W( I+1, I ), 1 )
+ ALPHA = -HALF*TAU( I )*DDOT( N-I, W( I+1, I ), 1,
+ $ A( I+1, I ), 1 )
+ CALL DAXPY( N-I, ALPHA, A( I+1, I ), 1, W( I+1, I ), 1 )
+ END IF
+*
+ 20 CONTINUE
+ END IF
+*
+ RETURN
+*
+* End of DLATRD
+*
+ END
+ SUBROUTINE DLATRS( UPLO, TRANS, DIAG, NORMIN, N, A, LDA, X, SCALE,
+ $ CNORM, INFO )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER DIAG, NORMIN, TRANS, UPLO
+ INTEGER INFO, LDA, N
+ DOUBLE PRECISION SCALE
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION A( LDA, * ), CNORM( * ), X( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DLATRS solves one of the triangular systems
+*
+* A *x = s*b or A'*x = s*b
+*
+* with scaling to prevent overflow. Here A is an upper or lower
+* triangular matrix, A' denotes the transpose of A, x and b are
+* n-element vectors, and s is a scaling factor, usually less than
+* or equal to 1, chosen so that the components of x will be less than
+* the overflow threshold. If the unscaled problem will not cause
+* overflow, the Level 2 BLAS routine DTRSV is called. If the matrix A
+* is singular (A(j,j) = 0 for some j), then s is set to 0 and a
+* non-trivial solution to A*x = 0 is returned.
+*
+* Arguments
+* =========
+*
+* UPLO (input) CHARACTER*1
+* Specifies whether the matrix A is upper or lower triangular.
+* = 'U': Upper triangular
+* = 'L': Lower triangular
+*
+* TRANS (input) CHARACTER*1
+* Specifies the operation applied to A.
+* = 'N': Solve A * x = s*b (No transpose)
+* = 'T': Solve A'* x = s*b (Transpose)
+* = 'C': Solve A'* x = s*b (Conjugate transpose = Transpose)
+*
+* DIAG (input) CHARACTER*1
+* Specifies whether or not the matrix A is unit triangular.
+* = 'N': Non-unit triangular
+* = 'U': Unit triangular
+*
+* NORMIN (input) CHARACTER*1
+* Specifies whether CNORM has been set or not.
+* = 'Y': CNORM contains the column norms on entry
+* = 'N': CNORM is not set on entry. On exit, the norms will
+* be computed and stored in CNORM.
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* A (input) DOUBLE PRECISION array, dimension (LDA,N)
+* The triangular matrix A. If UPLO = 'U', the leading n by n
+* upper triangular part of the array A contains the upper
+* triangular matrix, and the strictly lower triangular part of
+* A is not referenced. If UPLO = 'L', the leading n by n lower
+* triangular part of the array A contains the lower triangular
+* matrix, and the strictly upper triangular part of A is not
+* referenced. If DIAG = 'U', the diagonal elements of A are
+* also not referenced and are assumed to be 1.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max (1,N).
+*
+* X (input/output) DOUBLE PRECISION array, dimension (N)
+* On entry, the right hand side b of the triangular system.
+* On exit, X is overwritten by the solution vector x.
+*
+* SCALE (output) DOUBLE PRECISION
+* The scaling factor s for the triangular system
+* A * x = s*b or A'* x = s*b.
+* If SCALE = 0, the matrix A is singular or badly scaled, and
+* the vector x is an exact or approximate solution to A*x = 0.
+*
+* CNORM (input or output) DOUBLE PRECISION array, dimension (N)
+*
+* If NORMIN = 'Y', CNORM is an input argument and CNORM(j)
+* contains the norm of the off-diagonal part of the j-th column
+* of A. If TRANS = 'N', CNORM(j) must be greater than or equal
+* to the infinity-norm, and if TRANS = 'T' or 'C', CNORM(j)
+* must be greater than or equal to the 1-norm.
+*
+* If NORMIN = 'N', CNORM is an output argument and CNORM(j)
+* returns the 1-norm of the offdiagonal part of the j-th column
+* of A.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -k, the k-th argument had an illegal value
+*
+* Further Details
+* ======= =======
+*
+* A rough bound on x is computed; if that is less than overflow, DTRSV
+* is called, otherwise, specific code is used which checks for possible
+* overflow or divide-by-zero at every operation.
+*
+* A columnwise scheme is used for solving A*x = b. The basic algorithm
+* if A is lower triangular is
+*
+* x[1:n] := b[1:n]
+* for j = 1, ..., n
+* x(j) := x(j) / A(j,j)
+* x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j]
+* end
+*
+* Define bounds on the components of x after j iterations of the loop:
+* M(j) = bound on x[1:j]
+* G(j) = bound on x[j+1:n]
+* Initially, let M(0) = 0 and G(0) = max{x(i), i=1,...,n}.
+*
+* Then for iteration j+1 we have
+* M(j+1) <= G(j) / | A(j+1,j+1) |
+* G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] |
+* <= G(j) ( 1 + CNORM(j+1) / | A(j+1,j+1) | )
+*
+* where CNORM(j+1) is greater than or equal to the infinity-norm of
+* column j+1 of A, not counting the diagonal. Hence
+*
+* G(j) <= G(0) product ( 1 + CNORM(i) / | A(i,i) | )
+* 1<=i<=j
+* and
+*
+* |x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + CNORM(i) / |A(i,i)| )
+* 1<=i< j
+*
+* Since |x(j)| <= M(j), we use the Level 2 BLAS routine DTRSV if the
+* reciprocal of the largest M(j), j=1,..,n, is larger than
+* max(underflow, 1/overflow).
+*
+* The bound on x(j) is also used to determine when a step in the
+* columnwise method can be performed without fear of overflow. If
+* the computed bound is greater than a large constant, x is scaled to
+* prevent overflow, but if the bound overflows, x is set to 0, x(j) to
+* 1, and scale to 0, and a non-trivial solution to A*x = 0 is found.
+*
+* Similarly, a row-wise scheme is used to solve A'*x = b. The basic
+* algorithm for A upper triangular is
+*
+* for j = 1, ..., n
+* x(j) := ( b(j) - A[1:j-1,j]' * x[1:j-1] ) / A(j,j)
+* end
+*
+* We simultaneously compute two bounds
+* G(j) = bound on ( b(i) - A[1:i-1,i]' * x[1:i-1] ), 1<=i<=j
+* M(j) = bound on x(i), 1<=i<=j
+*
+* The initial values are G(0) = 0, M(0) = max{b(i), i=1,..,n}, and we
+* add the constraint G(j) >= G(j-1) and M(j) >= M(j-1) for j >= 1.
+* Then the bound on x(j) is
+*
+* M(j) <= M(j-1) * ( 1 + CNORM(j) ) / | A(j,j) |
+*
+* <= M(0) * product ( ( 1 + CNORM(i) ) / |A(i,i)| )
+* 1<=i<=j
+*
+* and we can safely call DTRSV if 1/M(n) and 1/G(n) are both greater
+* than max(underflow, 1/overflow).
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, HALF, ONE
+ PARAMETER ( ZERO = 0.0D+0, HALF = 0.5D+0, ONE = 1.0D+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL NOTRAN, NOUNIT, UPPER
+ INTEGER I, IMAX, J, JFIRST, JINC, JLAST
+ DOUBLE PRECISION BIGNUM, GROW, REC, SMLNUM, SUMJ, TJJ, TJJS,
+ $ TMAX, TSCAL, USCAL, XBND, XJ, XMAX
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER IDAMAX
+ DOUBLE PRECISION DASUM, DDOT, DLAMCH
+ EXTERNAL LSAME, IDAMAX, DASUM, DDOT, DLAMCH
+* ..
+* .. External Subroutines ..
+ EXTERNAL DAXPY, DSCAL, DTRSV, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ NOTRAN = LSAME( TRANS, 'N' )
+ NOUNIT = LSAME( DIAG, 'N' )
+*
+* Test the input parameters.
+*
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT.
+ $ LSAME( TRANS, 'C' ) ) THEN
+ INFO = -2
+ ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
+ INFO = -3
+ ELSE IF( .NOT.LSAME( NORMIN, 'Y' ) .AND. .NOT.
+ $ LSAME( NORMIN, 'N' ) ) THEN
+ INFO = -4
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -5
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -7
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DLATRS', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+* Determine machine dependent parameters to control overflow.
+*
+ SMLNUM = DLAMCH( 'Safe minimum' ) / DLAMCH( 'Precision' )
+ BIGNUM = ONE / SMLNUM
+ SCALE = ONE
+*
+ IF( LSAME( NORMIN, 'N' ) ) THEN
+*
+* Compute the 1-norm of each column, not including the diagonal.
+*
+ IF( UPPER ) THEN
+*
+* A is upper triangular.
+*
+ DO 10 J = 1, N
+ CNORM( J ) = DASUM( J-1, A( 1, J ), 1 )
+ 10 CONTINUE
+ ELSE
+*
+* A is lower triangular.
+*
+ DO 20 J = 1, N - 1
+ CNORM( J ) = DASUM( N-J, A( J+1, J ), 1 )
+ 20 CONTINUE
+ CNORM( N ) = ZERO
+ END IF
+ END IF
+*
+* Scale the column norms by TSCAL if the maximum element in CNORM is
+* greater than BIGNUM.
+*
+ IMAX = IDAMAX( N, CNORM, 1 )
+ TMAX = CNORM( IMAX )
+ IF( TMAX.LE.BIGNUM ) THEN
+ TSCAL = ONE
+ ELSE
+ TSCAL = ONE / ( SMLNUM*TMAX )
+ CALL DSCAL( N, TSCAL, CNORM, 1 )
+ END IF
+*
+* Compute a bound on the computed solution vector to see if the
+* Level 2 BLAS routine DTRSV can be used.
+*
+ J = IDAMAX( N, X, 1 )
+ XMAX = ABS( X( J ) )
+ XBND = XMAX
+ IF( NOTRAN ) THEN
+*
+* Compute the growth in A * x = b.
+*
+ IF( UPPER ) THEN
+ JFIRST = N
+ JLAST = 1
+ JINC = -1
+ ELSE
+ JFIRST = 1
+ JLAST = N
+ JINC = 1
+ END IF
+*
+ IF( TSCAL.NE.ONE ) THEN
+ GROW = ZERO
+ GO TO 50
+ END IF
+*
+ IF( NOUNIT ) THEN
+*
+* A is non-unit triangular.
+*
+* Compute GROW = 1/G(j) and XBND = 1/M(j).
+* Initially, G(0) = max{x(i), i=1,...,n}.
+*
+ GROW = ONE / MAX( XBND, SMLNUM )
+ XBND = GROW
+ DO 30 J = JFIRST, JLAST, JINC
+*
+* Exit the loop if the growth factor is too small.
+*
+ IF( GROW.LE.SMLNUM )
+ $ GO TO 50
+*
+* M(j) = G(j-1) / abs(A(j,j))
+*
+ TJJ = ABS( A( J, J ) )
+ XBND = MIN( XBND, MIN( ONE, TJJ )*GROW )
+ IF( TJJ+CNORM( J ).GE.SMLNUM ) THEN
+*
+* G(j) = G(j-1)*( 1 + CNORM(j) / abs(A(j,j)) )
+*
+ GROW = GROW*( TJJ / ( TJJ+CNORM( J ) ) )
+ ELSE
+*
+* G(j) could overflow, set GROW to 0.
+*
+ GROW = ZERO
+ END IF
+ 30 CONTINUE
+ GROW = XBND
+ ELSE
+*
+* A is unit triangular.
+*
+* Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}.
+*
+ GROW = MIN( ONE, ONE / MAX( XBND, SMLNUM ) )
+ DO 40 J = JFIRST, JLAST, JINC
+*
+* Exit the loop if the growth factor is too small.
+*
+ IF( GROW.LE.SMLNUM )
+ $ GO TO 50
+*
+* G(j) = G(j-1)*( 1 + CNORM(j) )
+*
+ GROW = GROW*( ONE / ( ONE+CNORM( J ) ) )
+ 40 CONTINUE
+ END IF
+ 50 CONTINUE
+*
+ ELSE
+*
+* Compute the growth in A' * x = b.
+*
+ IF( UPPER ) THEN
+ JFIRST = 1
+ JLAST = N
+ JINC = 1
+ ELSE
+ JFIRST = N
+ JLAST = 1
+ JINC = -1
+ END IF
+*
+ IF( TSCAL.NE.ONE ) THEN
+ GROW = ZERO
+ GO TO 80
+ END IF
+*
+ IF( NOUNIT ) THEN
+*
+* A is non-unit triangular.
+*
+* Compute GROW = 1/G(j) and XBND = 1/M(j).
+* Initially, M(0) = max{x(i), i=1,...,n}.
+*
+ GROW = ONE / MAX( XBND, SMLNUM )
+ XBND = GROW
+ DO 60 J = JFIRST, JLAST, JINC
+*
+* Exit the loop if the growth factor is too small.
+*
+ IF( GROW.LE.SMLNUM )
+ $ GO TO 80
+*
+* G(j) = max( G(j-1), M(j-1)*( 1 + CNORM(j) ) )
+*
+ XJ = ONE + CNORM( J )
+ GROW = MIN( GROW, XBND / XJ )
+*
+* M(j) = M(j-1)*( 1 + CNORM(j) ) / abs(A(j,j))
+*
+ TJJ = ABS( A( J, J ) )
+ IF( XJ.GT.TJJ )
+ $ XBND = XBND*( TJJ / XJ )
+ 60 CONTINUE
+ GROW = MIN( GROW, XBND )
+ ELSE
+*
+* A is unit triangular.
+*
+* Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}.
+*
+ GROW = MIN( ONE, ONE / MAX( XBND, SMLNUM ) )
+ DO 70 J = JFIRST, JLAST, JINC
+*
+* Exit the loop if the growth factor is too small.
+*
+ IF( GROW.LE.SMLNUM )
+ $ GO TO 80
+*
+* G(j) = ( 1 + CNORM(j) )*G(j-1)
+*
+ XJ = ONE + CNORM( J )
+ GROW = GROW / XJ
+ 70 CONTINUE
+ END IF
+ 80 CONTINUE
+ END IF
+*
+ IF( ( GROW*TSCAL ).GT.SMLNUM ) THEN
+*
+* Use the Level 2 BLAS solve if the reciprocal of the bound on
+* elements of X is not too small.
+*
+ CALL DTRSV( UPLO, TRANS, DIAG, N, A, LDA, X, 1 )
+ ELSE
+*
+* Use a Level 1 BLAS solve, scaling intermediate results.
+*
+ IF( XMAX.GT.BIGNUM ) THEN
+*
+* Scale X so that its components are less than or equal to
+* BIGNUM in absolute value.
+*
+ SCALE = BIGNUM / XMAX
+ CALL DSCAL( N, SCALE, X, 1 )
+ XMAX = BIGNUM
+ END IF
+*
+ IF( NOTRAN ) THEN
+*
+* Solve A * x = b
+*
+ DO 110 J = JFIRST, JLAST, JINC
+*
+* Compute x(j) = b(j) / A(j,j), scaling x if necessary.
+*
+ XJ = ABS( X( J ) )
+ IF( NOUNIT ) THEN
+ TJJS = A( J, J )*TSCAL
+ ELSE
+ TJJS = TSCAL
+ IF( TSCAL.EQ.ONE )
+ $ GO TO 100
+ END IF
+ TJJ = ABS( TJJS )
+ IF( TJJ.GT.SMLNUM ) THEN
+*
+* abs(A(j,j)) > SMLNUM:
+*
+ IF( TJJ.LT.ONE ) THEN
+ IF( XJ.GT.TJJ*BIGNUM ) THEN
+*
+* Scale x by 1/b(j).
+*
+ REC = ONE / XJ
+ CALL DSCAL( N, REC, X, 1 )
+ SCALE = SCALE*REC
+ XMAX = XMAX*REC
+ END IF
+ END IF
+ X( J ) = X( J ) / TJJS
+ XJ = ABS( X( J ) )
+ ELSE IF( TJJ.GT.ZERO ) THEN
+*
+* 0 < abs(A(j,j)) <= SMLNUM:
+*
+ IF( XJ.GT.TJJ*BIGNUM ) THEN
+*
+* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM
+* to avoid overflow when dividing by A(j,j).
+*
+ REC = ( TJJ*BIGNUM ) / XJ
+ IF( CNORM( J ).GT.ONE ) THEN
+*
+* Scale by 1/CNORM(j) to avoid overflow when
+* multiplying x(j) times column j.
+*
+ REC = REC / CNORM( J )
+ END IF
+ CALL DSCAL( N, REC, X, 1 )
+ SCALE = SCALE*REC
+ XMAX = XMAX*REC
+ END IF
+ X( J ) = X( J ) / TJJS
+ XJ = ABS( X( J ) )
+ ELSE
+*
+* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and
+* scale = 0, and compute a solution to A*x = 0.
+*
+ DO 90 I = 1, N
+ X( I ) = ZERO
+ 90 CONTINUE
+ X( J ) = ONE
+ XJ = ONE
+ SCALE = ZERO
+ XMAX = ZERO
+ END IF
+ 100 CONTINUE
+*
+* Scale x if necessary to avoid overflow when adding a
+* multiple of column j of A.
+*
+ IF( XJ.GT.ONE ) THEN
+ REC = ONE / XJ
+ IF( CNORM( J ).GT.( BIGNUM-XMAX )*REC ) THEN
+*
+* Scale x by 1/(2*abs(x(j))).
+*
+ REC = REC*HALF
+ CALL DSCAL( N, REC, X, 1 )
+ SCALE = SCALE*REC
+ END IF
+ ELSE IF( XJ*CNORM( J ).GT.( BIGNUM-XMAX ) ) THEN
+*
+* Scale x by 1/2.
+*
+ CALL DSCAL( N, HALF, X, 1 )
+ SCALE = SCALE*HALF
+ END IF
+*
+ IF( UPPER ) THEN
+ IF( J.GT.1 ) THEN
+*
+* Compute the update
+* x(1:j-1) := x(1:j-1) - x(j) * A(1:j-1,j)
+*
+ CALL DAXPY( J-1, -X( J )*TSCAL, A( 1, J ), 1, X,
+ $ 1 )
+ I = IDAMAX( J-1, X, 1 )
+ XMAX = ABS( X( I ) )
+ END IF
+ ELSE
+ IF( J.LT.N ) THEN
+*
+* Compute the update
+* x(j+1:n) := x(j+1:n) - x(j) * A(j+1:n,j)
+*
+ CALL DAXPY( N-J, -X( J )*TSCAL, A( J+1, J ), 1,
+ $ X( J+1 ), 1 )
+ I = J + IDAMAX( N-J, X( J+1 ), 1 )
+ XMAX = ABS( X( I ) )
+ END IF
+ END IF
+ 110 CONTINUE
+*
+ ELSE
+*
+* Solve A' * x = b
+*
+ DO 160 J = JFIRST, JLAST, JINC
+*
+* Compute x(j) = b(j) - sum A(k,j)*x(k).
+* k<>j
+*
+ XJ = ABS( X( J ) )
+ USCAL = TSCAL
+ REC = ONE / MAX( XMAX, ONE )
+ IF( CNORM( J ).GT.( BIGNUM-XJ )*REC ) THEN
+*
+* If x(j) could overflow, scale x by 1/(2*XMAX).
+*
+ REC = REC*HALF
+ IF( NOUNIT ) THEN
+ TJJS = A( J, J )*TSCAL
+ ELSE
+ TJJS = TSCAL
+ END IF
+ TJJ = ABS( TJJS )
+ IF( TJJ.GT.ONE ) THEN
+*
+* Divide by A(j,j) when scaling x if A(j,j) > 1.
+*
+ REC = MIN( ONE, REC*TJJ )
+ USCAL = USCAL / TJJS
+ END IF
+ IF( REC.LT.ONE ) THEN
+ CALL DSCAL( N, REC, X, 1 )
+ SCALE = SCALE*REC
+ XMAX = XMAX*REC
+ END IF
+ END IF
+*
+ SUMJ = ZERO
+ IF( USCAL.EQ.ONE ) THEN
+*
+* If the scaling needed for A in the dot product is 1,
+* call DDOT to perform the dot product.
+*
+ IF( UPPER ) THEN
+ SUMJ = DDOT( J-1, A( 1, J ), 1, X, 1 )
+ ELSE IF( J.LT.N ) THEN
+ SUMJ = DDOT( N-J, A( J+1, J ), 1, X( J+1 ), 1 )
+ END IF
+ ELSE
+*
+* Otherwise, use in-line code for the dot product.
+*
+ IF( UPPER ) THEN
+ DO 120 I = 1, J - 1
+ SUMJ = SUMJ + ( A( I, J )*USCAL )*X( I )
+ 120 CONTINUE
+ ELSE IF( J.LT.N ) THEN
+ DO 130 I = J + 1, N
+ SUMJ = SUMJ + ( A( I, J )*USCAL )*X( I )
+ 130 CONTINUE
+ END IF
+ END IF
+*
+ IF( USCAL.EQ.TSCAL ) THEN
+*
+* Compute x(j) := ( x(j) - sumj ) / A(j,j) if 1/A(j,j)
+* was not used to scale the dotproduct.
+*
+ X( J ) = X( J ) - SUMJ
+ XJ = ABS( X( J ) )
+ IF( NOUNIT ) THEN
+ TJJS = A( J, J )*TSCAL
+ ELSE
+ TJJS = TSCAL
+ IF( TSCAL.EQ.ONE )
+ $ GO TO 150
+ END IF
+*
+* Compute x(j) = x(j) / A(j,j), scaling if necessary.
+*
+ TJJ = ABS( TJJS )
+ IF( TJJ.GT.SMLNUM ) THEN
+*
+* abs(A(j,j)) > SMLNUM:
+*
+ IF( TJJ.LT.ONE ) THEN
+ IF( XJ.GT.TJJ*BIGNUM ) THEN
+*
+* Scale X by 1/abs(x(j)).
+*
+ REC = ONE / XJ
+ CALL DSCAL( N, REC, X, 1 )
+ SCALE = SCALE*REC
+ XMAX = XMAX*REC
+ END IF
+ END IF
+ X( J ) = X( J ) / TJJS
+ ELSE IF( TJJ.GT.ZERO ) THEN
+*
+* 0 < abs(A(j,j)) <= SMLNUM:
+*
+ IF( XJ.GT.TJJ*BIGNUM ) THEN
+*
+* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM.
+*
+ REC = ( TJJ*BIGNUM ) / XJ
+ CALL DSCAL( N, REC, X, 1 )
+ SCALE = SCALE*REC
+ XMAX = XMAX*REC
+ END IF
+ X( J ) = X( J ) / TJJS
+ ELSE
+*
+* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and
+* scale = 0, and compute a solution to A'*x = 0.
+*
+ DO 140 I = 1, N
+ X( I ) = ZERO
+ 140 CONTINUE
+ X( J ) = ONE
+ SCALE = ZERO
+ XMAX = ZERO
+ END IF
+ 150 CONTINUE
+ ELSE
+*
+* Compute x(j) := x(j) / A(j,j) - sumj if the dot
+* product has already been divided by 1/A(j,j).
+*
+ X( J ) = X( J ) / TJJS - SUMJ
+ END IF
+ XMAX = MAX( XMAX, ABS( X( J ) ) )
+ 160 CONTINUE
+ END IF
+ SCALE = SCALE / TSCAL
+ END IF
+*
+* Scale the column norms by 1/TSCAL for return.
+*
+ IF( TSCAL.NE.ONE ) THEN
+ CALL DSCAL( N, ONE / TSCAL, CNORM, 1 )
+ END IF
+*
+ RETURN
+*
+* End of DLATRS
+*
+ END
+ SUBROUTINE DLATRZ( M, N, L, A, LDA, TAU, WORK )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER L, LDA, M, N
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DLATRZ factors the M-by-(M+L) real upper trapezoidal matrix
+* [ A1 A2 ] = [ A(1:M,1:M) A(1:M,N-L+1:N) ] as ( R 0 ) * Z, by means
+* of orthogonal transformations. Z is an (M+L)-by-(M+L) orthogonal
+* matrix and, R and A1 are M-by-M upper triangular matrices.
+*
+* Arguments
+* =========
+*
+* M (input) INTEGER
+* The number of rows of the matrix A. M >= 0.
+*
+* N (input) INTEGER
+* The number of columns of the matrix A. N >= 0.
+*
+* L (input) INTEGER
+* The number of columns of the matrix A containing the
+* meaningful part of the Householder vectors. N-M >= L >= 0.
+*
+* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+* On entry, the leading M-by-N upper trapezoidal part of the
+* array A must contain the matrix to be factorized.
+* On exit, the leading M-by-M upper triangular part of A
+* contains the upper triangular matrix R, and elements N-L+1 to
+* N of the first M rows of A, with the array TAU, represent the
+* orthogonal matrix Z as a product of M elementary reflectors.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,M).
+*
+* TAU (output) DOUBLE PRECISION array, dimension (M)
+* The scalar factors of the elementary reflectors.
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (M)
+*
+* Further Details
+* ===============
+*
+* Based on contributions by
+* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA
+*
+* The factorization is obtained by Householder's method. The kth
+* transformation matrix, Z( k ), which is used to introduce zeros into
+* the ( m - k + 1 )th row of A, is given in the form
+*
+* Z( k ) = ( I 0 ),
+* ( 0 T( k ) )
+*
+* where
+*
+* T( k ) = I - tau*u( k )*u( k )', u( k ) = ( 1 ),
+* ( 0 )
+* ( z( k ) )
+*
+* tau is a scalar and z( k ) is an l element vector. tau and z( k )
+* are chosen to annihilate the elements of the kth row of A2.
+*
+* The scalar tau is returned in the kth element of TAU and the vector
+* u( k ) in the kth row of A2, such that the elements of z( k ) are
+* in a( k, l + 1 ), ..., a( k, n ). The elements of R are returned in
+* the upper triangular part of A1.
+*
+* Z is given by
+*
+* Z = Z( 1 ) * Z( 2 ) * ... * Z( m ).
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO
+ PARAMETER ( ZERO = 0.0D+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I
+* ..
+* .. External Subroutines ..
+ EXTERNAL DLARFG, DLARZ
+* ..
+* .. Executable Statements ..
+*
+* Test the input arguments
+*
+* Quick return if possible
+*
+ IF( M.EQ.0 ) THEN
+ RETURN
+ ELSE IF( M.EQ.N ) THEN
+ DO 10 I = 1, N
+ TAU( I ) = ZERO
+ 10 CONTINUE
+ RETURN
+ END IF
+*
+ DO 20 I = M, 1, -1
+*
+* Generate elementary reflector H(i) to annihilate
+* [ A(i,i) A(i,n-l+1:n) ]
+*
+ CALL DLARFG( L+1, A( I, I ), A( I, N-L+1 ), LDA, TAU( I ) )
+*
+* Apply H(i) to A(1:i-1,i:n) from the right
+*
+ CALL DLARZ( 'Right', I-1, N-I+1, L, A( I, N-L+1 ), LDA,
+ $ TAU( I ), A( 1, I ), LDA, WORK )
+*
+ 20 CONTINUE
+*
+ RETURN
+*
+* End of DLATRZ
+*
+ END
+ SUBROUTINE DLATZM( SIDE, M, N, V, INCV, TAU, C1, C2, LDC, WORK )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER SIDE
+ INTEGER INCV, LDC, M, N
+ DOUBLE PRECISION TAU
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION C1( LDC, * ), C2( LDC, * ), V( * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* This routine is deprecated and has been replaced by routine DORMRZ.
+*
+* DLATZM applies a Householder matrix generated by DTZRQF to a matrix.
+*
+* Let P = I - tau*u*u', u = ( 1 ),
+* ( v )
+* where v is an (m-1) vector if SIDE = 'L', or a (n-1) vector if
+* SIDE = 'R'.
+*
+* If SIDE equals 'L', let
+* C = [ C1 ] 1
+* [ C2 ] m-1
+* n
+* Then C is overwritten by P*C.
+*
+* If SIDE equals 'R', let
+* C = [ C1, C2 ] m
+* 1 n-1
+* Then C is overwritten by C*P.
+*
+* Arguments
+* =========
+*
+* SIDE (input) CHARACTER*1
+* = 'L': form P * C
+* = 'R': form C * P
+*
+* M (input) INTEGER
+* The number of rows of the matrix C.
+*
+* N (input) INTEGER
+* The number of columns of the matrix C.
+*
+* V (input) DOUBLE PRECISION array, dimension
+* (1 + (M-1)*abs(INCV)) if SIDE = 'L'
+* (1 + (N-1)*abs(INCV)) if SIDE = 'R'
+* The vector v in the representation of P. V is not used
+* if TAU = 0.
+*
+* INCV (input) INTEGER
+* The increment between elements of v. INCV <> 0
+*
+* TAU (input) DOUBLE PRECISION
+* The value tau in the representation of P.
+*
+* C1 (input/output) DOUBLE PRECISION array, dimension
+* (LDC,N) if SIDE = 'L'
+* (M,1) if SIDE = 'R'
+* On entry, the n-vector C1 if SIDE = 'L', or the m-vector C1
+* if SIDE = 'R'.
+*
+* On exit, the first row of P*C if SIDE = 'L', or the first
+* column of C*P if SIDE = 'R'.
+*
+* C2 (input/output) DOUBLE PRECISION array, dimension
+* (LDC, N) if SIDE = 'L'
+* (LDC, N-1) if SIDE = 'R'
+* On entry, the (m - 1) x n matrix C2 if SIDE = 'L', or the
+* m x (n - 1) matrix C2 if SIDE = 'R'.
+*
+* On exit, rows 2:m of P*C if SIDE = 'L', or columns 2:m of C*P
+* if SIDE = 'R'.
+*
+* LDC (input) INTEGER
+* The leading dimension of the arrays C1 and C2. LDC >= (1,M).
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension
+* (N) if SIDE = 'L'
+* (M) if SIDE = 'R'
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE, ZERO
+ PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
+* ..
+* .. External Subroutines ..
+ EXTERNAL DAXPY, DCOPY, DGEMV, DGER
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MIN
+* ..
+* .. Executable Statements ..
+*
+ IF( ( MIN( M, N ).EQ.0 ) .OR. ( TAU.EQ.ZERO ) )
+ $ RETURN
+*
+ IF( LSAME( SIDE, 'L' ) ) THEN
+*
+* w := C1 + v' * C2
+*
+ CALL DCOPY( N, C1, LDC, WORK, 1 )
+ CALL DGEMV( 'Transpose', M-1, N, ONE, C2, LDC, V, INCV, ONE,
+ $ WORK, 1 )
+*
+* [ C1 ] := [ C1 ] - tau* [ 1 ] * w'
+* [ C2 ] [ C2 ] [ v ]
+*
+ CALL DAXPY( N, -TAU, WORK, 1, C1, LDC )
+ CALL DGER( M-1, N, -TAU, V, INCV, WORK, 1, C2, LDC )
+*
+ ELSE IF( LSAME( SIDE, 'R' ) ) THEN
+*
+* w := C1 + C2 * v
+*
+ CALL DCOPY( M, C1, 1, WORK, 1 )
+ CALL DGEMV( 'No transpose', M, N-1, ONE, C2, LDC, V, INCV, ONE,
+ $ WORK, 1 )
+*
+* [ C1, C2 ] := [ C1, C2 ] - tau* w * [ 1 , v']
+*
+ CALL DAXPY( M, -TAU, WORK, 1, C1, 1 )
+ CALL DGER( M, N-1, -TAU, WORK, 1, V, INCV, C2, LDC )
+ END IF
+*
+ RETURN
+*
+* End of DLATZM
+*
+ END
+ SUBROUTINE DLAUU2( UPLO, N, A, LDA, INFO )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, LDA, N
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION A( LDA, * )
+* ..
+*
+* Purpose
+* =======
+*
+* DLAUU2 computes the product U * U' or L' * L, where the triangular
+* factor U or L is stored in the upper or lower triangular part of
+* the array A.
+*
+* If UPLO = 'U' or 'u' then the upper triangle of the result is stored,
+* overwriting the factor U in A.
+* If UPLO = 'L' or 'l' then the lower triangle of the result is stored,
+* overwriting the factor L in A.
+*
+* This is the unblocked form of the algorithm, calling Level 2 BLAS.
+*
+* Arguments
+* =========
+*
+* UPLO (input) CHARACTER*1
+* Specifies whether the triangular factor stored in the array A
+* is upper or lower triangular:
+* = 'U': Upper triangular
+* = 'L': Lower triangular
+*
+* N (input) INTEGER
+* The order of the triangular factor U or L. N >= 0.
+*
+* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+* On entry, the triangular factor U or L.
+* On exit, if UPLO = 'U', the upper triangle of A is
+* overwritten with the upper triangle of the product U * U';
+* if UPLO = 'L', the lower triangle of A is overwritten with
+* the lower triangle of the product L' * L.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,N).
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -k, the k-th argument had an illegal value
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE
+ PARAMETER ( ONE = 1.0D+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL UPPER
+ INTEGER I
+ DOUBLE PRECISION AII
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ DOUBLE PRECISION DDOT
+ EXTERNAL LSAME, DDOT
+* ..
+* .. External Subroutines ..
+ EXTERNAL DGEMV, DSCAL, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -4
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DLAUU2', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+ IF( UPPER ) THEN
+*
+* Compute the product U * U'.
+*
+ DO 10 I = 1, N
+ AII = A( I, I )
+ IF( I.LT.N ) THEN
+ A( I, I ) = DDOT( N-I+1, A( I, I ), LDA, A( I, I ), LDA )
+ CALL DGEMV( 'No transpose', I-1, N-I, ONE, A( 1, I+1 ),
+ $ LDA, A( I, I+1 ), LDA, AII, A( 1, I ), 1 )
+ ELSE
+ CALL DSCAL( I, AII, A( 1, I ), 1 )
+ END IF
+ 10 CONTINUE
+*
+ ELSE
+*
+* Compute the product L' * L.
+*
+ DO 20 I = 1, N
+ AII = A( I, I )
+ IF( I.LT.N ) THEN
+ A( I, I ) = DDOT( N-I+1, A( I, I ), 1, A( I, I ), 1 )
+ CALL DGEMV( 'Transpose', N-I, I-1, ONE, A( I+1, 1 ), LDA,
+ $ A( I+1, I ), 1, AII, A( I, 1 ), LDA )
+ ELSE
+ CALL DSCAL( I, AII, A( I, 1 ), LDA )
+ END IF
+ 20 CONTINUE
+ END IF
+*
+ RETURN
+*
+* End of DLAUU2
+*
+ END
+ SUBROUTINE DLAUUM( UPLO, N, A, LDA, INFO )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, LDA, N
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION A( LDA, * )
+* ..
+*
+* Purpose
+* =======
+*
+* DLAUUM computes the product U * U' or L' * L, where the triangular
+* factor U or L is stored in the upper or lower triangular part of
+* the array A.
+*
+* If UPLO = 'U' or 'u' then the upper triangle of the result is stored,
+* overwriting the factor U in A.
+* If UPLO = 'L' or 'l' then the lower triangle of the result is stored,
+* overwriting the factor L in A.
+*
+* This is the blocked form of the algorithm, calling Level 3 BLAS.
+*
+* Arguments
+* =========
+*
+* UPLO (input) CHARACTER*1
+* Specifies whether the triangular factor stored in the array A
+* is upper or lower triangular:
+* = 'U': Upper triangular
+* = 'L': Lower triangular
+*
+* N (input) INTEGER
+* The order of the triangular factor U or L. N >= 0.
+*
+* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+* On entry, the triangular factor U or L.
+* On exit, if UPLO = 'U', the upper triangle of A is
+* overwritten with the upper triangle of the product U * U';
+* if UPLO = 'L', the lower triangle of A is overwritten with
+* the lower triangle of the product L' * L.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,N).
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -k, the k-th argument had an illegal value
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE
+ PARAMETER ( ONE = 1.0D+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL UPPER
+ INTEGER I, IB, NB
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ILAENV
+ EXTERNAL LSAME, ILAENV
+* ..
+* .. External Subroutines ..
+ EXTERNAL DGEMM, DLAUU2, DSYRK, DTRMM, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -4
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DLAUUM', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+* Determine the block size for this environment.
+*
+ NB = ILAENV( 1, 'DLAUUM', UPLO, N, -1, -1, -1 )
+*
+ IF( NB.LE.1 .OR. NB.GE.N ) THEN
+*
+* Use unblocked code
+*
+ CALL DLAUU2( UPLO, N, A, LDA, INFO )
+ ELSE
+*
+* Use blocked code
+*
+ IF( UPPER ) THEN
+*
+* Compute the product U * U'.
+*
+ DO 10 I = 1, N, NB
+ IB = MIN( NB, N-I+1 )
+ CALL DTRMM( 'Right', 'Upper', 'Transpose', 'Non-unit',
+ $ I-1, IB, ONE, A( I, I ), LDA, A( 1, I ),
+ $ LDA )
+ CALL DLAUU2( 'Upper', IB, A( I, I ), LDA, INFO )
+ IF( I+IB.LE.N ) THEN
+ CALL DGEMM( 'No transpose', 'Transpose', I-1, IB,
+ $ N-I-IB+1, ONE, A( 1, I+IB ), LDA,
+ $ A( I, I+IB ), LDA, ONE, A( 1, I ), LDA )
+ CALL DSYRK( 'Upper', 'No transpose', IB, N-I-IB+1,
+ $ ONE, A( I, I+IB ), LDA, ONE, A( I, I ),
+ $ LDA )
+ END IF
+ 10 CONTINUE
+ ELSE
+*
+* Compute the product L' * L.
+*
+ DO 20 I = 1, N, NB
+ IB = MIN( NB, N-I+1 )
+ CALL DTRMM( 'Left', 'Lower', 'Transpose', 'Non-unit', IB,
+ $ I-1, ONE, A( I, I ), LDA, A( I, 1 ), LDA )
+ CALL DLAUU2( 'Lower', IB, A( I, I ), LDA, INFO )
+ IF( I+IB.LE.N ) THEN
+ CALL DGEMM( 'Transpose', 'No transpose', IB, I-1,
+ $ N-I-IB+1, ONE, A( I+IB, I ), LDA,
+ $ A( I+IB, 1 ), LDA, ONE, A( I, 1 ), LDA )
+ CALL DSYRK( 'Lower', 'Transpose', IB, N-I-IB+1, ONE,
+ $ A( I+IB, I ), LDA, ONE, A( I, I ), LDA )
+ END IF
+ 20 CONTINUE
+ END IF
+ END IF
+*
+ RETURN
+*
+* End of DLAUUM
+*
+ END
+ SUBROUTINE DLAZQ3( I0, N0, Z, PP, DMIN, SIGMA, DESIG, QMAX, NFAIL,
+ $ ITER, NDIV, IEEE, TTYPE, DMIN1, DMIN2, DN, DN1,
+ $ DN2, TAU )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ LOGICAL IEEE
+ INTEGER I0, ITER, N0, NDIV, NFAIL, PP, TTYPE
+ DOUBLE PRECISION DESIG, DMIN, DMIN1, DMIN2, DN, DN1, DN2, QMAX,
+ $ SIGMA, TAU
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION Z( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DLAZQ3 checks for deflation, computes a shift (TAU) and calls dqds.
+* In case of failure it changes shifts, and tries again until output
+* is positive.
+*
+* Arguments
+* =========
+*
+* I0 (input) INTEGER
+* First index.
+*
+* N0 (input) INTEGER
+* Last index.
+*
+* Z (input) DOUBLE PRECISION array, dimension ( 4*N )
+* Z holds the qd array.
+*
+* PP (input) INTEGER
+* PP=0 for ping, PP=1 for pong.
+*
+* DMIN (output) DOUBLE PRECISION
+* Minimum value of d.
+*
+* SIGMA (output) DOUBLE PRECISION
+* Sum of shifts used in current segment.
+*
+* DESIG (input/output) DOUBLE PRECISION
+* Lower order part of SIGMA
+*
+* QMAX (input) DOUBLE PRECISION
+* Maximum value of q.
+*
+* NFAIL (output) INTEGER
+* Number of times shift was too big.
+*
+* ITER (output) INTEGER
+* Number of iterations.
+*
+* NDIV (output) INTEGER
+* Number of divisions.
+*
+* IEEE (input) LOGICAL
+* Flag for IEEE or non IEEE arithmetic (passed to DLASQ5).
+*
+* TTYPE (input/output) INTEGER
+* Shift type. TTYPE is passed as an argument in order to save
+* its value between calls to DLAZQ3
+*
+* DMIN1 (input/output) REAL
+* DMIN2 (input/output) REAL
+* DN (input/output) REAL
+* DN1 (input/output) REAL
+* DN2 (input/output) REAL
+* TAU (input/output) REAL
+* These are passed as arguments in order to save their values
+* between calls to DLAZQ3
+*
+* This is a thread safe version of DLASQ3, which passes TTYPE, DMIN1,
+* DMIN2, DN, DN1. DN2 and TAU through the argument list in place of
+* declaring them in a SAVE statment.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION CBIAS
+ PARAMETER ( CBIAS = 1.50D0 )
+ DOUBLE PRECISION ZERO, QURTR, HALF, ONE, TWO, HUNDRD
+ PARAMETER ( ZERO = 0.0D0, QURTR = 0.250D0, HALF = 0.5D0,
+ $ ONE = 1.0D0, TWO = 2.0D0, HUNDRD = 100.0D0 )
+* ..
+* .. Local Scalars ..
+ INTEGER IPN4, J4, N0IN, NN
+ DOUBLE PRECISION EPS, G, S, SAFMIN, T, TEMP, TOL, TOL2
+* ..
+* .. External Subroutines ..
+ EXTERNAL DLASQ5, DLASQ6, DLAZQ4
+* ..
+* .. External Function ..
+ DOUBLE PRECISION DLAMCH
+ EXTERNAL DLAMCH
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MIN, SQRT
+* ..
+* .. Executable Statements ..
+*
+ N0IN = N0
+ EPS = DLAMCH( 'Precision' )
+ SAFMIN = DLAMCH( 'Safe minimum' )
+ TOL = EPS*HUNDRD
+ TOL2 = TOL**2
+ G = ZERO
+*
+* Check for deflation.
+*
+ 10 CONTINUE
+*
+ IF( N0.LT.I0 )
+ $ RETURN
+ IF( N0.EQ.I0 )
+ $ GO TO 20
+ NN = 4*N0 + PP
+ IF( N0.EQ.( I0+1 ) )
+ $ GO TO 40
+*
+* Check whether E(N0-1) is negligible, 1 eigenvalue.
+*
+ IF( Z( NN-5 ).GT.TOL2*( SIGMA+Z( NN-3 ) ) .AND.
+ $ Z( NN-2*PP-4 ).GT.TOL2*Z( NN-7 ) )
+ $ GO TO 30
+*
+ 20 CONTINUE
+*
+ Z( 4*N0-3 ) = Z( 4*N0+PP-3 ) + SIGMA
+ N0 = N0 - 1
+ GO TO 10
+*
+* Check whether E(N0-2) is negligible, 2 eigenvalues.
+*
+ 30 CONTINUE
+*
+ IF( Z( NN-9 ).GT.TOL2*SIGMA .AND.
+ $ Z( NN-2*PP-8 ).GT.TOL2*Z( NN-11 ) )
+ $ GO TO 50
+*
+ 40 CONTINUE
+*
+ IF( Z( NN-3 ).GT.Z( NN-7 ) ) THEN
+ S = Z( NN-3 )
+ Z( NN-3 ) = Z( NN-7 )
+ Z( NN-7 ) = S
+ END IF
+ IF( Z( NN-5 ).GT.Z( NN-3 )*TOL2 ) THEN
+ T = HALF*( ( Z( NN-7 )-Z( NN-3 ) )+Z( NN-5 ) )
+ S = Z( NN-3 )*( Z( NN-5 ) / T )
+ IF( S.LE.T ) THEN
+ S = Z( NN-3 )*( Z( NN-5 ) /
+ $ ( T*( ONE+SQRT( ONE+S / T ) ) ) )
+ ELSE
+ S = Z( NN-3 )*( Z( NN-5 ) / ( T+SQRT( T )*SQRT( T+S ) ) )
+ END IF
+ T = Z( NN-7 ) + ( S+Z( NN-5 ) )
+ Z( NN-3 ) = Z( NN-3 )*( Z( NN-7 ) / T )
+ Z( NN-7 ) = T
+ END IF
+ Z( 4*N0-7 ) = Z( NN-7 ) + SIGMA
+ Z( 4*N0-3 ) = Z( NN-3 ) + SIGMA
+ N0 = N0 - 2
+ GO TO 10
+*
+ 50 CONTINUE
+*
+* Reverse the qd-array, if warranted.
+*
+ IF( DMIN.LE.ZERO .OR. N0.LT.N0IN ) THEN
+ IF( CBIAS*Z( 4*I0+PP-3 ).LT.Z( 4*N0+PP-3 ) ) THEN
+ IPN4 = 4*( I0+N0 )
+ DO 60 J4 = 4*I0, 2*( I0+N0-1 ), 4
+ TEMP = Z( J4-3 )
+ Z( J4-3 ) = Z( IPN4-J4-3 )
+ Z( IPN4-J4-3 ) = TEMP
+ TEMP = Z( J4-2 )
+ Z( J4-2 ) = Z( IPN4-J4-2 )
+ Z( IPN4-J4-2 ) = TEMP
+ TEMP = Z( J4-1 )
+ Z( J4-1 ) = Z( IPN4-J4-5 )
+ Z( IPN4-J4-5 ) = TEMP
+ TEMP = Z( J4 )
+ Z( J4 ) = Z( IPN4-J4-4 )
+ Z( IPN4-J4-4 ) = TEMP
+ 60 CONTINUE
+ IF( N0-I0.LE.4 ) THEN
+ Z( 4*N0+PP-1 ) = Z( 4*I0+PP-1 )
+ Z( 4*N0-PP ) = Z( 4*I0-PP )
+ END IF
+ DMIN2 = MIN( DMIN2, Z( 4*N0+PP-1 ) )
+ Z( 4*N0+PP-1 ) = MIN( Z( 4*N0+PP-1 ), Z( 4*I0+PP-1 ),
+ $ Z( 4*I0+PP+3 ) )
+ Z( 4*N0-PP ) = MIN( Z( 4*N0-PP ), Z( 4*I0-PP ),
+ $ Z( 4*I0-PP+4 ) )
+ QMAX = MAX( QMAX, Z( 4*I0+PP-3 ), Z( 4*I0+PP+1 ) )
+ DMIN = -ZERO
+ END IF
+ END IF
+*
+ IF( DMIN.LT.ZERO .OR. SAFMIN*QMAX.LT.MIN( Z( 4*N0+PP-1 ),
+ $ Z( 4*N0+PP-9 ), DMIN2+Z( 4*N0-PP ) ) ) THEN
+*
+* Choose a shift.
+*
+ CALL DLAZQ4( I0, N0, Z, PP, N0IN, DMIN, DMIN1, DMIN2, DN, DN1,
+ $ DN2, TAU, TTYPE, G )
+*
+* Call dqds until DMIN > 0.
+*
+ 80 CONTINUE
+*
+ CALL DLASQ5( I0, N0, Z, PP, TAU, DMIN, DMIN1, DMIN2, DN,
+ $ DN1, DN2, IEEE )
+*
+ NDIV = NDIV + ( N0-I0+2 )
+ ITER = ITER + 1
+*
+* Check status.
+*
+ IF( DMIN.GE.ZERO .AND. DMIN1.GT.ZERO ) THEN
+*
+* Success.
+*
+ GO TO 100
+*
+ ELSE IF( DMIN.LT.ZERO .AND. DMIN1.GT.ZERO .AND.
+ $ Z( 4*( N0-1 )-PP ).LT.TOL*( SIGMA+DN1 ) .AND.
+ $ ABS( DN ).LT.TOL*SIGMA ) THEN
+*
+* Convergence hidden by negative DN.
+*
+ Z( 4*( N0-1 )-PP+2 ) = ZERO
+ DMIN = ZERO
+ GO TO 100
+ ELSE IF( DMIN.LT.ZERO ) THEN
+*
+* TAU too big. Select new TAU and try again.
+*
+ NFAIL = NFAIL + 1
+ IF( TTYPE.LT.-22 ) THEN
+*
+* Failed twice. Play it safe.
+*
+ TAU = ZERO
+ ELSE IF( DMIN1.GT.ZERO ) THEN
+*
+* Late failure. Gives excellent shift.
+*
+ TAU = ( TAU+DMIN )*( ONE-TWO*EPS )
+ TTYPE = TTYPE - 11
+ ELSE
+*
+* Early failure. Divide by 4.
+*
+ TAU = QURTR*TAU
+ TTYPE = TTYPE - 12
+ END IF
+ GO TO 80
+ ELSE IF( DMIN.NE.DMIN ) THEN
+*
+* NaN.
+*
+ TAU = ZERO
+ GO TO 80
+ ELSE
+*
+* Possible underflow. Play it safe.
+*
+ GO TO 90
+ END IF
+ END IF
+*
+* Risk of underflow.
+*
+ 90 CONTINUE
+ CALL DLASQ6( I0, N0, Z, PP, DMIN, DMIN1, DMIN2, DN, DN1, DN2 )
+ NDIV = NDIV + ( N0-I0+2 )
+ ITER = ITER + 1
+ TAU = ZERO
+*
+ 100 CONTINUE
+ IF( TAU.LT.SIGMA ) THEN
+ DESIG = DESIG + TAU
+ T = SIGMA + DESIG
+ DESIG = DESIG - ( T-SIGMA )
+ ELSE
+ T = SIGMA + TAU
+ DESIG = SIGMA - ( T-TAU ) + DESIG
+ END IF
+ SIGMA = T
+*
+ RETURN
+*
+* End of DLAZQ3
+*
+ END
+ SUBROUTINE DLAZQ4( I0, N0, Z, PP, N0IN, DMIN, DMIN1, DMIN2, DN,
+ $ DN1, DN2, TAU, TTYPE, G )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER I0, N0, N0IN, PP, TTYPE
+ DOUBLE PRECISION DMIN, DMIN1, DMIN2, DN, DN1, DN2, G, TAU
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION Z( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DLAZQ4 computes an approximation TAU to the smallest eigenvalue
+* using values of d from the previous transform.
+*
+* I0 (input) INTEGER
+* First index.
+*
+* N0 (input) INTEGER
+* Last index.
+*
+* Z (input) DOUBLE PRECISION array, dimension ( 4*N )
+* Z holds the qd array.
+*
+* PP (input) INTEGER
+* PP=0 for ping, PP=1 for pong.
+*
+* N0IN (input) INTEGER
+* The value of N0 at start of EIGTEST.
+*
+* DMIN (input) DOUBLE PRECISION
+* Minimum value of d.
+*
+* DMIN1 (input) DOUBLE PRECISION
+* Minimum value of d, excluding D( N0 ).
+*
+* DMIN2 (input) DOUBLE PRECISION
+* Minimum value of d, excluding D( N0 ) and D( N0-1 ).
+*
+* DN (input) DOUBLE PRECISION
+* d(N)
+*
+* DN1 (input) DOUBLE PRECISION
+* d(N-1)
+*
+* DN2 (input) DOUBLE PRECISION
+* d(N-2)
+*
+* TAU (output) DOUBLE PRECISION
+* This is the shift.
+*
+* TTYPE (output) INTEGER
+* Shift type.
+*
+* G (input/output) DOUBLE PRECISION
+* G is passed as an argument in order to save its value between
+* calls to DLAZQ4
+*
+* Further Details
+* ===============
+* CNST1 = 9/16
+*
+* This is a thread safe version of DLASQ4, which passes G through the
+* argument list in place of declaring G in a SAVE statment.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION CNST1, CNST2, CNST3
+ PARAMETER ( CNST1 = 0.5630D0, CNST2 = 1.010D0,
+ $ CNST3 = 1.050D0 )
+ DOUBLE PRECISION QURTR, THIRD, HALF, ZERO, ONE, TWO, HUNDRD
+ PARAMETER ( QURTR = 0.250D0, THIRD = 0.3330D0,
+ $ HALF = 0.50D0, ZERO = 0.0D0, ONE = 1.0D0,
+ $ TWO = 2.0D0, HUNDRD = 100.0D0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I4, NN, NP
+ DOUBLE PRECISION A2, B1, B2, GAM, GAP1, GAP2, S
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN, SQRT
+* ..
+* .. Executable Statements ..
+*
+* A negative DMIN forces the shift to take that absolute value
+* TTYPE records the type of shift.
+*
+ IF( DMIN.LE.ZERO ) THEN
+ TAU = -DMIN
+ TTYPE = -1
+ RETURN
+ END IF
+*
+ NN = 4*N0 + PP
+ IF( N0IN.EQ.N0 ) THEN
+*
+* No eigenvalues deflated.
+*
+ IF( DMIN.EQ.DN .OR. DMIN.EQ.DN1 ) THEN
+*
+ B1 = SQRT( Z( NN-3 ) )*SQRT( Z( NN-5 ) )
+ B2 = SQRT( Z( NN-7 ) )*SQRT( Z( NN-9 ) )
+ A2 = Z( NN-7 ) + Z( NN-5 )
+*
+* Cases 2 and 3.
+*
+ IF( DMIN.EQ.DN .AND. DMIN1.EQ.DN1 ) THEN
+ GAP2 = DMIN2 - A2 - DMIN2*QURTR
+ IF( GAP2.GT.ZERO .AND. GAP2.GT.B2 ) THEN
+ GAP1 = A2 - DN - ( B2 / GAP2 )*B2
+ ELSE
+ GAP1 = A2 - DN - ( B1+B2 )
+ END IF
+ IF( GAP1.GT.ZERO .AND. GAP1.GT.B1 ) THEN
+ S = MAX( DN-( B1 / GAP1 )*B1, HALF*DMIN )
+ TTYPE = -2
+ ELSE
+ S = ZERO
+ IF( DN.GT.B1 )
+ $ S = DN - B1
+ IF( A2.GT.( B1+B2 ) )
+ $ S = MIN( S, A2-( B1+B2 ) )
+ S = MAX( S, THIRD*DMIN )
+ TTYPE = -3
+ END IF
+ ELSE
+*
+* Case 4.
+*
+ TTYPE = -4
+ S = QURTR*DMIN
+ IF( DMIN.EQ.DN ) THEN
+ GAM = DN
+ A2 = ZERO
+ IF( Z( NN-5 ) .GT. Z( NN-7 ) )
+ $ RETURN
+ B2 = Z( NN-5 ) / Z( NN-7 )
+ NP = NN - 9
+ ELSE
+ NP = NN - 2*PP
+ B2 = Z( NP-2 )
+ GAM = DN1
+ IF( Z( NP-4 ) .GT. Z( NP-2 ) )
+ $ RETURN
+ A2 = Z( NP-4 ) / Z( NP-2 )
+ IF( Z( NN-9 ) .GT. Z( NN-11 ) )
+ $ RETURN
+ B2 = Z( NN-9 ) / Z( NN-11 )
+ NP = NN - 13
+ END IF
+*
+* Approximate contribution to norm squared from I < NN-1.
+*
+ A2 = A2 + B2
+ DO 10 I4 = NP, 4*I0 - 1 + PP, -4
+ IF( B2.EQ.ZERO )
+ $ GO TO 20
+ B1 = B2
+ IF( Z( I4 ) .GT. Z( I4-2 ) )
+ $ RETURN
+ B2 = B2*( Z( I4 ) / Z( I4-2 ) )
+ A2 = A2 + B2
+ IF( HUNDRD*MAX( B2, B1 ).LT.A2 .OR. CNST1.LT.A2 )
+ $ GO TO 20
+ 10 CONTINUE
+ 20 CONTINUE
+ A2 = CNST3*A2
+*
+* Rayleigh quotient residual bound.
+*
+ IF( A2.LT.CNST1 )
+ $ S = GAM*( ONE-SQRT( A2 ) ) / ( ONE+A2 )
+ END IF
+ ELSE IF( DMIN.EQ.DN2 ) THEN
+*
+* Case 5.
+*
+ TTYPE = -5
+ S = QURTR*DMIN
+*
+* Compute contribution to norm squared from I > NN-2.
+*
+ NP = NN - 2*PP
+ B1 = Z( NP-2 )
+ B2 = Z( NP-6 )
+ GAM = DN2
+ IF( Z( NP-8 ).GT.B2 .OR. Z( NP-4 ).GT.B1 )
+ $ RETURN
+ A2 = ( Z( NP-8 ) / B2 )*( ONE+Z( NP-4 ) / B1 )
+*
+* Approximate contribution to norm squared from I < NN-2.
+*
+ IF( N0-I0.GT.2 ) THEN
+ B2 = Z( NN-13 ) / Z( NN-15 )
+ A2 = A2 + B2
+ DO 30 I4 = NN - 17, 4*I0 - 1 + PP, -4
+ IF( B2.EQ.ZERO )
+ $ GO TO 40
+ B1 = B2
+ IF( Z( I4 ) .GT. Z( I4-2 ) )
+ $ RETURN
+ B2 = B2*( Z( I4 ) / Z( I4-2 ) )
+ A2 = A2 + B2
+ IF( HUNDRD*MAX( B2, B1 ).LT.A2 .OR. CNST1.LT.A2 )
+ $ GO TO 40
+ 30 CONTINUE
+ 40 CONTINUE
+ A2 = CNST3*A2
+ END IF
+*
+ IF( A2.LT.CNST1 )
+ $ S = GAM*( ONE-SQRT( A2 ) ) / ( ONE+A2 )
+ ELSE
+*
+* Case 6, no information to guide us.
+*
+ IF( TTYPE.EQ.-6 ) THEN
+ G = G + THIRD*( ONE-G )
+ ELSE IF( TTYPE.EQ.-18 ) THEN
+ G = QURTR*THIRD
+ ELSE
+ G = QURTR
+ END IF
+ S = G*DMIN
+ TTYPE = -6
+ END IF
+*
+ ELSE IF( N0IN.EQ.( N0+1 ) ) THEN
+*
+* One eigenvalue just deflated. Use DMIN1, DN1 for DMIN and DN.
+*
+ IF( DMIN1.EQ.DN1 .AND. DMIN2.EQ.DN2 ) THEN
+*
+* Cases 7 and 8.
+*
+ TTYPE = -7
+ S = THIRD*DMIN1
+ IF( Z( NN-5 ).GT.Z( NN-7 ) )
+ $ RETURN
+ B1 = Z( NN-5 ) / Z( NN-7 )
+ B2 = B1
+ IF( B2.EQ.ZERO )
+ $ GO TO 60
+ DO 50 I4 = 4*N0 - 9 + PP, 4*I0 - 1 + PP, -4
+ A2 = B1
+ IF( Z( I4 ).GT.Z( I4-2 ) )
+ $ RETURN
+ B1 = B1*( Z( I4 ) / Z( I4-2 ) )
+ B2 = B2 + B1
+ IF( HUNDRD*MAX( B1, A2 ).LT.B2 )
+ $ GO TO 60
+ 50 CONTINUE
+ 60 CONTINUE
+ B2 = SQRT( CNST3*B2 )
+ A2 = DMIN1 / ( ONE+B2**2 )
+ GAP2 = HALF*DMIN2 - A2
+ IF( GAP2.GT.ZERO .AND. GAP2.GT.B2*A2 ) THEN
+ S = MAX( S, A2*( ONE-CNST2*A2*( B2 / GAP2 )*B2 ) )
+ ELSE
+ S = MAX( S, A2*( ONE-CNST2*B2 ) )
+ TTYPE = -8
+ END IF
+ ELSE
+*
+* Case 9.
+*
+ S = QURTR*DMIN1
+ IF( DMIN1.EQ.DN1 )
+ $ S = HALF*DMIN1
+ TTYPE = -9
+ END IF
+*
+ ELSE IF( N0IN.EQ.( N0+2 ) ) THEN
+*
+* Two eigenvalues deflated. Use DMIN2, DN2 for DMIN and DN.
+*
+* Cases 10 and 11.
+*
+ IF( DMIN2.EQ.DN2 .AND. TWO*Z( NN-5 ).LT.Z( NN-7 ) ) THEN
+ TTYPE = -10
+ S = THIRD*DMIN2
+ IF( Z( NN-5 ).GT.Z( NN-7 ) )
+ $ RETURN
+ B1 = Z( NN-5 ) / Z( NN-7 )
+ B2 = B1
+ IF( B2.EQ.ZERO )
+ $ GO TO 80
+ DO 70 I4 = 4*N0 - 9 + PP, 4*I0 - 1 + PP, -4
+ IF( Z( I4 ).GT.Z( I4-2 ) )
+ $ RETURN
+ B1 = B1*( Z( I4 ) / Z( I4-2 ) )
+ B2 = B2 + B1
+ IF( HUNDRD*B1.LT.B2 )
+ $ GO TO 80
+ 70 CONTINUE
+ 80 CONTINUE
+ B2 = SQRT( CNST3*B2 )
+ A2 = DMIN2 / ( ONE+B2**2 )
+ GAP2 = Z( NN-7 ) + Z( NN-9 ) -
+ $ SQRT( Z( NN-11 ) )*SQRT( Z( NN-9 ) ) - A2
+ IF( GAP2.GT.ZERO .AND. GAP2.GT.B2*A2 ) THEN
+ S = MAX( S, A2*( ONE-CNST2*A2*( B2 / GAP2 )*B2 ) )
+ ELSE
+ S = MAX( S, A2*( ONE-CNST2*B2 ) )
+ END IF
+ ELSE
+ S = QURTR*DMIN2
+ TTYPE = -11
+ END IF
+ ELSE IF( N0IN.GT.( N0+2 ) ) THEN
+*
+* Case 12, more than two eigenvalues deflated. No information.
+*
+ S = ZERO
+ TTYPE = -12
+ END IF
+*
+ TAU = S
+ RETURN
+*
+* End of DLAZQ4
+*
+ END
+ SUBROUTINE DOPGTR( UPLO, N, AP, TAU, Q, LDQ, WORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, LDQ, N
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION AP( * ), Q( LDQ, * ), TAU( * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DOPGTR generates a real orthogonal matrix Q which is defined as the
+* product of n-1 elementary reflectors H(i) of order n, as returned by
+* DSPTRD using packed storage:
+*
+* if UPLO = 'U', Q = H(n-1) . . . H(2) H(1),
+*
+* if UPLO = 'L', Q = H(1) H(2) . . . H(n-1).
+*
+* Arguments
+* =========
+*
+* UPLO (input) CHARACTER*1
+* = 'U': Upper triangular packed storage used in previous
+* call to DSPTRD;
+* = 'L': Lower triangular packed storage used in previous
+* call to DSPTRD.
+*
+* N (input) INTEGER
+* The order of the matrix Q. N >= 0.
+*
+* AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)
+* The vectors which define the elementary reflectors, as
+* returned by DSPTRD.
+*
+* TAU (input) DOUBLE PRECISION array, dimension (N-1)
+* TAU(i) must contain the scalar factor of the elementary
+* reflector H(i), as returned by DSPTRD.
+*
+* Q (output) DOUBLE PRECISION array, dimension (LDQ,N)
+* The N-by-N orthogonal matrix Q.
+*
+* LDQ (input) INTEGER
+* The leading dimension of the array Q. LDQ >= max(1,N).
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (N-1)
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL UPPER
+ INTEGER I, IINFO, IJ, J
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL DORG2L, DORG2R, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input arguments
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN
+ INFO = -6
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DOPGTR', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+ IF( UPPER ) THEN
+*
+* Q was determined by a call to DSPTRD with UPLO = 'U'
+*
+* Unpack the vectors which define the elementary reflectors and
+* set the last row and column of Q equal to those of the unit
+* matrix
+*
+ IJ = 2
+ DO 20 J = 1, N - 1
+ DO 10 I = 1, J - 1
+ Q( I, J ) = AP( IJ )
+ IJ = IJ + 1
+ 10 CONTINUE
+ IJ = IJ + 2
+ Q( N, J ) = ZERO
+ 20 CONTINUE
+ DO 30 I = 1, N - 1
+ Q( I, N ) = ZERO
+ 30 CONTINUE
+ Q( N, N ) = ONE
+*
+* Generate Q(1:n-1,1:n-1)
+*
+ CALL DORG2L( N-1, N-1, N-1, Q, LDQ, TAU, WORK, IINFO )
+*
+ ELSE
+*
+* Q was determined by a call to DSPTRD with UPLO = 'L'.
+*
+* Unpack the vectors which define the elementary reflectors and
+* set the first row and column of Q equal to those of the unit
+* matrix
+*
+ Q( 1, 1 ) = ONE
+ DO 40 I = 2, N
+ Q( I, 1 ) = ZERO
+ 40 CONTINUE
+ IJ = 3
+ DO 60 J = 2, N
+ Q( 1, J ) = ZERO
+ DO 50 I = J + 1, N
+ Q( I, J ) = AP( IJ )
+ IJ = IJ + 1
+ 50 CONTINUE
+ IJ = IJ + 2
+ 60 CONTINUE
+ IF( N.GT.1 ) THEN
+*
+* Generate Q(2:n,2:n)
+*
+ CALL DORG2R( N-1, N-1, N-1, Q( 2, 2 ), LDQ, TAU, WORK,
+ $ IINFO )
+ END IF
+ END IF
+ RETURN
+*
+* End of DOPGTR
+*
+ END
+ SUBROUTINE DOPMTR( SIDE, UPLO, TRANS, M, N, AP, TAU, C, LDC, WORK,
+ $ INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER SIDE, TRANS, UPLO
+ INTEGER INFO, LDC, M, N
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION AP( * ), C( LDC, * ), TAU( * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DOPMTR overwrites the general real M-by-N matrix C with
+*
+* SIDE = 'L' SIDE = 'R'
+* TRANS = 'N': Q * C C * Q
+* TRANS = 'T': Q**T * C C * Q**T
+*
+* where Q is a real orthogonal matrix of order nq, with nq = m if
+* SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of
+* nq-1 elementary reflectors, as returned by DSPTRD using packed
+* storage:
+*
+* if UPLO = 'U', Q = H(nq-1) . . . H(2) H(1);
+*
+* if UPLO = 'L', Q = H(1) H(2) . . . H(nq-1).
+*
+* Arguments
+* =========
+*
+* SIDE (input) CHARACTER*1
+* = 'L': apply Q or Q**T from the Left;
+* = 'R': apply Q or Q**T from the Right.
+*
+* UPLO (input) CHARACTER*1
+* = 'U': Upper triangular packed storage used in previous
+* call to DSPTRD;
+* = 'L': Lower triangular packed storage used in previous
+* call to DSPTRD.
+*
+* TRANS (input) CHARACTER*1
+* = 'N': No transpose, apply Q;
+* = 'T': Transpose, apply Q**T.
+*
+* M (input) INTEGER
+* The number of rows of the matrix C. M >= 0.
+*
+* N (input) INTEGER
+* The number of columns of the matrix C. N >= 0.
+*
+* AP (input) DOUBLE PRECISION array, dimension
+* (M*(M+1)/2) if SIDE = 'L'
+* (N*(N+1)/2) if SIDE = 'R'
+* The vectors which define the elementary reflectors, as
+* returned by DSPTRD. AP is modified by the routine but
+* restored on exit.
+*
+* TAU (input) DOUBLE PRECISION array, dimension (M-1) if SIDE = 'L'
+* or (N-1) if SIDE = 'R'
+* TAU(i) must contain the scalar factor of the elementary
+* reflector H(i), as returned by DSPTRD.
+*
+* C (input/output) DOUBLE PRECISION array, dimension (LDC,N)
+* On entry, the M-by-N matrix C.
+* On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q.
+*
+* LDC (input) INTEGER
+* The leading dimension of the array C. LDC >= max(1,M).
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension
+* (N) if SIDE = 'L'
+* (M) if SIDE = 'R'
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE
+ PARAMETER ( ONE = 1.0D+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL FORWRD, LEFT, NOTRAN, UPPER
+ INTEGER I, I1, I2, I3, IC, II, JC, MI, NI, NQ
+ DOUBLE PRECISION AII
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL DLARF, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input arguments
+*
+ INFO = 0
+ LEFT = LSAME( SIDE, 'L' )
+ NOTRAN = LSAME( TRANS, 'N' )
+ UPPER = LSAME( UPLO, 'U' )
+*
+* NQ is the order of Q
+*
+ IF( LEFT ) THEN
+ NQ = M
+ ELSE
+ NQ = N
+ END IF
+ IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN
+ INFO = -1
+ ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -2
+ ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN
+ INFO = -3
+ ELSE IF( M.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -5
+ ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
+ INFO = -9
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DOPMTR', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( M.EQ.0 .OR. N.EQ.0 )
+ $ RETURN
+*
+ IF( UPPER ) THEN
+*
+* Q was determined by a call to DSPTRD with UPLO = 'U'
+*
+ FORWRD = ( LEFT .AND. NOTRAN ) .OR.
+ $ ( .NOT.LEFT .AND. .NOT.NOTRAN )
+*
+ IF( FORWRD ) THEN
+ I1 = 1
+ I2 = NQ - 1
+ I3 = 1
+ II = 2
+ ELSE
+ I1 = NQ - 1
+ I2 = 1
+ I3 = -1
+ II = NQ*( NQ+1 ) / 2 - 1
+ END IF
+*
+ IF( LEFT ) THEN
+ NI = N
+ ELSE
+ MI = M
+ END IF
+*
+ DO 10 I = I1, I2, I3
+ IF( LEFT ) THEN
+*
+* H(i) is applied to C(1:i,1:n)
+*
+ MI = I
+ ELSE
+*
+* H(i) is applied to C(1:m,1:i)
+*
+ NI = I
+ END IF
+*
+* Apply H(i)
+*
+ AII = AP( II )
+ AP( II ) = ONE
+ CALL DLARF( SIDE, MI, NI, AP( II-I+1 ), 1, TAU( I ), C, LDC,
+ $ WORK )
+ AP( II ) = AII
+*
+ IF( FORWRD ) THEN
+ II = II + I + 2
+ ELSE
+ II = II - I - 1
+ END IF
+ 10 CONTINUE
+ ELSE
+*
+* Q was determined by a call to DSPTRD with UPLO = 'L'.
+*
+ FORWRD = ( LEFT .AND. .NOT.NOTRAN ) .OR.
+ $ ( .NOT.LEFT .AND. NOTRAN )
+*
+ IF( FORWRD ) THEN
+ I1 = 1
+ I2 = NQ - 1
+ I3 = 1
+ II = 2
+ ELSE
+ I1 = NQ - 1
+ I2 = 1
+ I3 = -1
+ II = NQ*( NQ+1 ) / 2 - 1
+ END IF
+*
+ IF( LEFT ) THEN
+ NI = N
+ JC = 1
+ ELSE
+ MI = M
+ IC = 1
+ END IF
+*
+ DO 20 I = I1, I2, I3
+ AII = AP( II )
+ AP( II ) = ONE
+ IF( LEFT ) THEN
+*
+* H(i) is applied to C(i+1:m,1:n)
+*
+ MI = M - I
+ IC = I + 1
+ ELSE
+*
+* H(i) is applied to C(1:m,i+1:n)
+*
+ NI = N - I
+ JC = I + 1
+ END IF
+*
+* Apply H(i)
+*
+ CALL DLARF( SIDE, MI, NI, AP( II ), 1, TAU( I ),
+ $ C( IC, JC ), LDC, WORK )
+ AP( II ) = AII
+*
+ IF( FORWRD ) THEN
+ II = II + NQ - I + 1
+ ELSE
+ II = II - NQ + I - 2
+ END IF
+ 20 CONTINUE
+ END IF
+ RETURN
+*
+* End of DOPMTR
+*
+ END
+ SUBROUTINE DORG2L( M, N, K, A, LDA, TAU, WORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, K, LDA, M, N
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DORG2L generates an m by n real matrix Q with orthonormal columns,
+* which is defined as the last n columns of a product of k elementary
+* reflectors of order m
+*
+* Q = H(k) . . . H(2) H(1)
+*
+* as returned by DGEQLF.
+*
+* Arguments
+* =========
+*
+* M (input) INTEGER
+* The number of rows of the matrix Q. M >= 0.
+*
+* N (input) INTEGER
+* The number of columns of the matrix Q. M >= N >= 0.
+*
+* K (input) INTEGER
+* The number of elementary reflectors whose product defines the
+* matrix Q. N >= K >= 0.
+*
+* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+* On entry, the (n-k+i)-th column must contain the vector which
+* defines the elementary reflector H(i), for i = 1,2,...,k, as
+* returned by DGEQLF in the last k columns of its array
+* argument A.
+* On exit, the m by n matrix Q.
+*
+* LDA (input) INTEGER
+* The first dimension of the array A. LDA >= max(1,M).
+*
+* TAU (input) DOUBLE PRECISION array, dimension (K)
+* TAU(i) must contain the scalar factor of the elementary
+* reflector H(i), as returned by DGEQLF.
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (N)
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument has an illegal value
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE, ZERO
+ PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, II, J, L
+* ..
+* .. External Subroutines ..
+ EXTERNAL DLARF, DSCAL, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input arguments
+*
+ INFO = 0
+ IF( M.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 .OR. N.GT.M ) THEN
+ INFO = -2
+ ELSE IF( K.LT.0 .OR. K.GT.N ) THEN
+ INFO = -3
+ ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+ INFO = -5
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DORG2L', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.LE.0 )
+ $ RETURN
+*
+* Initialise columns 1:n-k to columns of the unit matrix
+*
+ DO 20 J = 1, N - K
+ DO 10 L = 1, M
+ A( L, J ) = ZERO
+ 10 CONTINUE
+ A( M-N+J, J ) = ONE
+ 20 CONTINUE
+*
+ DO 40 I = 1, K
+ II = N - K + I
+*
+* Apply H(i) to A(1:m-k+i,1:n-k+i) from the left
+*
+ A( M-N+II, II ) = ONE
+ CALL DLARF( 'Left', M-N+II, II-1, A( 1, II ), 1, TAU( I ), A,
+ $ LDA, WORK )
+ CALL DSCAL( M-N+II-1, -TAU( I ), A( 1, II ), 1 )
+ A( M-N+II, II ) = ONE - TAU( I )
+*
+* Set A(m-k+i+1:m,n-k+i) to zero
+*
+ DO 30 L = M - N + II + 1, M
+ A( L, II ) = ZERO
+ 30 CONTINUE
+ 40 CONTINUE
+ RETURN
+*
+* End of DORG2L
+*
+ END
+ SUBROUTINE DORG2R( M, N, K, A, LDA, TAU, WORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, K, LDA, M, N
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DORG2R generates an m by n real matrix Q with orthonormal columns,
+* which is defined as the first n columns of a product of k elementary
+* reflectors of order m
+*
+* Q = H(1) H(2) . . . H(k)
+*
+* as returned by DGEQRF.
+*
+* Arguments
+* =========
+*
+* M (input) INTEGER
+* The number of rows of the matrix Q. M >= 0.
+*
+* N (input) INTEGER
+* The number of columns of the matrix Q. M >= N >= 0.
+*
+* K (input) INTEGER
+* The number of elementary reflectors whose product defines the
+* matrix Q. N >= K >= 0.
+*
+* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+* On entry, the i-th column must contain the vector which
+* defines the elementary reflector H(i), for i = 1,2,...,k, as
+* returned by DGEQRF in the first k columns of its array
+* argument A.
+* On exit, the m-by-n matrix Q.
+*
+* LDA (input) INTEGER
+* The first dimension of the array A. LDA >= max(1,M).
+*
+* TAU (input) DOUBLE PRECISION array, dimension (K)
+* TAU(i) must contain the scalar factor of the elementary
+* reflector H(i), as returned by DGEQRF.
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (N)
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument has an illegal value
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE, ZERO
+ PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, J, L
+* ..
+* .. External Subroutines ..
+ EXTERNAL DLARF, DSCAL, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input arguments
+*
+ INFO = 0
+ IF( M.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 .OR. N.GT.M ) THEN
+ INFO = -2
+ ELSE IF( K.LT.0 .OR. K.GT.N ) THEN
+ INFO = -3
+ ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+ INFO = -5
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DORG2R', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.LE.0 )
+ $ RETURN
+*
+* Initialise columns k+1:n to columns of the unit matrix
+*
+ DO 20 J = K + 1, N
+ DO 10 L = 1, M
+ A( L, J ) = ZERO
+ 10 CONTINUE
+ A( J, J ) = ONE
+ 20 CONTINUE
+*
+ DO 40 I = K, 1, -1
+*
+* Apply H(i) to A(i:m,i:n) from the left
+*
+ IF( I.LT.N ) THEN
+ A( I, I ) = ONE
+ CALL DLARF( 'Left', M-I+1, N-I, A( I, I ), 1, TAU( I ),
+ $ A( I, I+1 ), LDA, WORK )
+ END IF
+ IF( I.LT.M )
+ $ CALL DSCAL( M-I, -TAU( I ), A( I+1, I ), 1 )
+ A( I, I ) = ONE - TAU( I )
+*
+* Set A(1:i-1,i) to zero
+*
+ DO 30 L = 1, I - 1
+ A( L, I ) = ZERO
+ 30 CONTINUE
+ 40 CONTINUE
+ RETURN
+*
+* End of DORG2R
+*
+ END
+ SUBROUTINE DORGBR( VECT, M, N, K, A, LDA, TAU, WORK, LWORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER VECT
+ INTEGER INFO, K, LDA, LWORK, M, N
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DORGBR generates one of the real orthogonal matrices Q or P**T
+* determined by DGEBRD when reducing a real matrix A to bidiagonal
+* form: A = Q * B * P**T. Q and P**T are defined as products of
+* elementary reflectors H(i) or G(i) respectively.
+*
+* If VECT = 'Q', A is assumed to have been an M-by-K matrix, and Q
+* is of order M:
+* if m >= k, Q = H(1) H(2) . . . H(k) and DORGBR returns the first n
+* columns of Q, where m >= n >= k;
+* if m < k, Q = H(1) H(2) . . . H(m-1) and DORGBR returns Q as an
+* M-by-M matrix.
+*
+* If VECT = 'P', A is assumed to have been a K-by-N matrix, and P**T
+* is of order N:
+* if k < n, P**T = G(k) . . . G(2) G(1) and DORGBR returns the first m
+* rows of P**T, where n >= m >= k;
+* if k >= n, P**T = G(n-1) . . . G(2) G(1) and DORGBR returns P**T as
+* an N-by-N matrix.
+*
+* Arguments
+* =========
+*
+* VECT (input) CHARACTER*1
+* Specifies whether the matrix Q or the matrix P**T is
+* required, as defined in the transformation applied by DGEBRD:
+* = 'Q': generate Q;
+* = 'P': generate P**T.
+*
+* M (input) INTEGER
+* The number of rows of the matrix Q or P**T to be returned.
+* M >= 0.
+*
+* N (input) INTEGER
+* The number of columns of the matrix Q or P**T to be returned.
+* N >= 0.
+* If VECT = 'Q', M >= N >= min(M,K);
+* if VECT = 'P', N >= M >= min(N,K).
+*
+* K (input) INTEGER
+* If VECT = 'Q', the number of columns in the original M-by-K
+* matrix reduced by DGEBRD.
+* If VECT = 'P', the number of rows in the original K-by-N
+* matrix reduced by DGEBRD.
+* K >= 0.
+*
+* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+* On entry, the vectors which define the elementary reflectors,
+* as returned by DGEBRD.
+* On exit, the M-by-N matrix Q or P**T.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,M).
+*
+* TAU (input) DOUBLE PRECISION array, dimension
+* (min(M,K)) if VECT = 'Q'
+* (min(N,K)) if VECT = 'P'
+* TAU(i) must contain the scalar factor of the elementary
+* reflector H(i) or G(i), which determines Q or P**T, as
+* returned by DGEBRD in its array argument TAUQ or TAUP.
+*
+* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
+* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+* LWORK (input) INTEGER
+* The dimension of the array WORK. LWORK >= max(1,min(M,N)).
+* For optimum performance LWORK >= min(M,N)*NB, where NB
+* is the optimal blocksize.
+*
+* If LWORK = -1, then a workspace query is assumed; the routine
+* only calculates the optimal size of the WORK array, returns
+* this value as the first entry of the WORK array, and no error
+* message related to LWORK is issued by XERBLA.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL LQUERY, WANTQ
+ INTEGER I, IINFO, J, LWKOPT, MN, NB
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ILAENV
+ EXTERNAL LSAME, ILAENV
+* ..
+* .. External Subroutines ..
+ EXTERNAL DORGLQ, DORGQR, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+* Test the input arguments
+*
+ INFO = 0
+ WANTQ = LSAME( VECT, 'Q' )
+ MN = MIN( M, N )
+ LQUERY = ( LWORK.EQ.-1 )
+ IF( .NOT.WANTQ .AND. .NOT.LSAME( VECT, 'P' ) ) THEN
+ INFO = -1
+ ELSE IF( M.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( N.LT.0 .OR. ( WANTQ .AND. ( N.GT.M .OR. N.LT.MIN( M,
+ $ K ) ) ) .OR. ( .NOT.WANTQ .AND. ( M.GT.N .OR. M.LT.
+ $ MIN( N, K ) ) ) ) THEN
+ INFO = -3
+ ELSE IF( K.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+ INFO = -6
+ ELSE IF( LWORK.LT.MAX( 1, MN ) .AND. .NOT.LQUERY ) THEN
+ INFO = -9
+ END IF
+*
+ IF( INFO.EQ.0 ) THEN
+ IF( WANTQ ) THEN
+ NB = ILAENV( 1, 'DORGQR', ' ', M, N, K, -1 )
+ ELSE
+ NB = ILAENV( 1, 'DORGLQ', ' ', M, N, K, -1 )
+ END IF
+ LWKOPT = MAX( 1, MN )*NB
+ WORK( 1 ) = LWKOPT
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DORGBR', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( M.EQ.0 .OR. N.EQ.0 ) THEN
+ WORK( 1 ) = 1
+ RETURN
+ END IF
+*
+ IF( WANTQ ) THEN
+*
+* Form Q, determined by a call to DGEBRD to reduce an m-by-k
+* matrix
+*
+ IF( M.GE.K ) THEN
+*
+* If m >= k, assume m >= n >= k
+*
+ CALL DORGQR( M, N, K, A, LDA, TAU, WORK, LWORK, IINFO )
+*
+ ELSE
+*
+* If m < k, assume m = n
+*
+* Shift the vectors which define the elementary reflectors one
+* column to the right, and set the first row and column of Q
+* to those of the unit matrix
+*
+ DO 20 J = M, 2, -1
+ A( 1, J ) = ZERO
+ DO 10 I = J + 1, M
+ A( I, J ) = A( I, J-1 )
+ 10 CONTINUE
+ 20 CONTINUE
+ A( 1, 1 ) = ONE
+ DO 30 I = 2, M
+ A( I, 1 ) = ZERO
+ 30 CONTINUE
+ IF( M.GT.1 ) THEN
+*
+* Form Q(2:m,2:m)
+*
+ CALL DORGQR( M-1, M-1, M-1, A( 2, 2 ), LDA, TAU, WORK,
+ $ LWORK, IINFO )
+ END IF
+ END IF
+ ELSE
+*
+* Form P', determined by a call to DGEBRD to reduce a k-by-n
+* matrix
+*
+ IF( K.LT.N ) THEN
+*
+* If k < n, assume k <= m <= n
+*
+ CALL DORGLQ( M, N, K, A, LDA, TAU, WORK, LWORK, IINFO )
+*
+ ELSE
+*
+* If k >= n, assume m = n
+*
+* Shift the vectors which define the elementary reflectors one
+* row downward, and set the first row and column of P' to
+* those of the unit matrix
+*
+ A( 1, 1 ) = ONE
+ DO 40 I = 2, N
+ A( I, 1 ) = ZERO
+ 40 CONTINUE
+ DO 60 J = 2, N
+ DO 50 I = J - 1, 2, -1
+ A( I, J ) = A( I-1, J )
+ 50 CONTINUE
+ A( 1, J ) = ZERO
+ 60 CONTINUE
+ IF( N.GT.1 ) THEN
+*
+* Form P'(2:n,2:n)
+*
+ CALL DORGLQ( N-1, N-1, N-1, A( 2, 2 ), LDA, TAU, WORK,
+ $ LWORK, IINFO )
+ END IF
+ END IF
+ END IF
+ WORK( 1 ) = LWKOPT
+ RETURN
+*
+* End of DORGBR
+*
+ END
+ SUBROUTINE DORGHR( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER IHI, ILO, INFO, LDA, LWORK, N
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DORGHR generates a real orthogonal matrix Q which is defined as the
+* product of IHI-ILO elementary reflectors of order N, as returned by
+* DGEHRD:
+*
+* Q = H(ilo) H(ilo+1) . . . H(ihi-1).
+*
+* Arguments
+* =========
+*
+* N (input) INTEGER
+* The order of the matrix Q. N >= 0.
+*
+* ILO (input) INTEGER
+* IHI (input) INTEGER
+* ILO and IHI must have the same values as in the previous call
+* of DGEHRD. Q is equal to the unit matrix except in the
+* submatrix Q(ilo+1:ihi,ilo+1:ihi).
+* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.
+*
+* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+* On entry, the vectors which define the elementary reflectors,
+* as returned by DGEHRD.
+* On exit, the N-by-N orthogonal matrix Q.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,N).
+*
+* TAU (input) DOUBLE PRECISION array, dimension (N-1)
+* TAU(i) must contain the scalar factor of the elementary
+* reflector H(i), as returned by DGEHRD.
+*
+* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
+* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+* LWORK (input) INTEGER
+* The dimension of the array WORK. LWORK >= IHI-ILO.
+* For optimum performance LWORK >= (IHI-ILO)*NB, where NB is
+* the optimal blocksize.
+*
+* If LWORK = -1, then a workspace query is assumed; the routine
+* only calculates the optimal size of the WORK array, returns
+* this value as the first entry of the WORK array, and no error
+* message related to LWORK is issued by XERBLA.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL LQUERY
+ INTEGER I, IINFO, J, LWKOPT, NB, NH
+* ..
+* .. External Subroutines ..
+ EXTERNAL DORGQR, XERBLA
+* ..
+* .. External Functions ..
+ INTEGER ILAENV
+ EXTERNAL ILAENV
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+* Test the input arguments
+*
+ INFO = 0
+ NH = IHI - ILO
+ LQUERY = ( LWORK.EQ.-1 )
+ IF( N.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN
+ INFO = -2
+ ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN
+ INFO = -3
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -5
+ ELSE IF( LWORK.LT.MAX( 1, NH ) .AND. .NOT.LQUERY ) THEN
+ INFO = -8
+ END IF
+*
+ IF( INFO.EQ.0 ) THEN
+ NB = ILAENV( 1, 'DORGQR', ' ', NH, NH, NH, -1 )
+ LWKOPT = MAX( 1, NH )*NB
+ WORK( 1 ) = LWKOPT
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DORGHR', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 ) THEN
+ WORK( 1 ) = 1
+ RETURN
+ END IF
+*
+* Shift the vectors which define the elementary reflectors one
+* column to the right, and set the first ilo and the last n-ihi
+* rows and columns to those of the unit matrix
+*
+ DO 40 J = IHI, ILO + 1, -1
+ DO 10 I = 1, J - 1
+ A( I, J ) = ZERO
+ 10 CONTINUE
+ DO 20 I = J + 1, IHI
+ A( I, J ) = A( I, J-1 )
+ 20 CONTINUE
+ DO 30 I = IHI + 1, N
+ A( I, J ) = ZERO
+ 30 CONTINUE
+ 40 CONTINUE
+ DO 60 J = 1, ILO
+ DO 50 I = 1, N
+ A( I, J ) = ZERO
+ 50 CONTINUE
+ A( J, J ) = ONE
+ 60 CONTINUE
+ DO 80 J = IHI + 1, N
+ DO 70 I = 1, N
+ A( I, J ) = ZERO
+ 70 CONTINUE
+ A( J, J ) = ONE
+ 80 CONTINUE
+*
+ IF( NH.GT.0 ) THEN
+*
+* Generate Q(ilo+1:ihi,ilo+1:ihi)
+*
+ CALL DORGQR( NH, NH, NH, A( ILO+1, ILO+1 ), LDA, TAU( ILO ),
+ $ WORK, LWORK, IINFO )
+ END IF
+ WORK( 1 ) = LWKOPT
+ RETURN
+*
+* End of DORGHR
+*
+ END
+ SUBROUTINE DORGL2( M, N, K, A, LDA, TAU, WORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, K, LDA, M, N
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DORGL2 generates an m by n real matrix Q with orthonormal rows,
+* which is defined as the first m rows of a product of k elementary
+* reflectors of order n
+*
+* Q = H(k) . . . H(2) H(1)
+*
+* as returned by DGELQF.
+*
+* Arguments
+* =========
+*
+* M (input) INTEGER
+* The number of rows of the matrix Q. M >= 0.
+*
+* N (input) INTEGER
+* The number of columns of the matrix Q. N >= M.
+*
+* K (input) INTEGER
+* The number of elementary reflectors whose product defines the
+* matrix Q. M >= K >= 0.
+*
+* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+* On entry, the i-th row must contain the vector which defines
+* the elementary reflector H(i), for i = 1,2,...,k, as returned
+* by DGELQF in the first k rows of its array argument A.
+* On exit, the m-by-n matrix Q.
+*
+* LDA (input) INTEGER
+* The first dimension of the array A. LDA >= max(1,M).
+*
+* TAU (input) DOUBLE PRECISION array, dimension (K)
+* TAU(i) must contain the scalar factor of the elementary
+* reflector H(i), as returned by DGELQF.
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (M)
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument has an illegal value
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE, ZERO
+ PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, J, L
+* ..
+* .. External Subroutines ..
+ EXTERNAL DLARF, DSCAL, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input arguments
+*
+ INFO = 0
+ IF( M.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( N.LT.M ) THEN
+ INFO = -2
+ ELSE IF( K.LT.0 .OR. K.GT.M ) THEN
+ INFO = -3
+ ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+ INFO = -5
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DORGL2', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( M.LE.0 )
+ $ RETURN
+*
+ IF( K.LT.M ) THEN
+*
+* Initialise rows k+1:m to rows of the unit matrix
+*
+ DO 20 J = 1, N
+ DO 10 L = K + 1, M
+ A( L, J ) = ZERO
+ 10 CONTINUE
+ IF( J.GT.K .AND. J.LE.M )
+ $ A( J, J ) = ONE
+ 20 CONTINUE
+ END IF
+*
+ DO 40 I = K, 1, -1
+*
+* Apply H(i) to A(i:m,i:n) from the right
+*
+ IF( I.LT.N ) THEN
+ IF( I.LT.M ) THEN
+ A( I, I ) = ONE
+ CALL DLARF( 'Right', M-I, N-I+1, A( I, I ), LDA,
+ $ TAU( I ), A( I+1, I ), LDA, WORK )
+ END IF
+ CALL DSCAL( N-I, -TAU( I ), A( I, I+1 ), LDA )
+ END IF
+ A( I, I ) = ONE - TAU( I )
+*
+* Set A(i,1:i-1) to zero
+*
+ DO 30 L = 1, I - 1
+ A( I, L ) = ZERO
+ 30 CONTINUE
+ 40 CONTINUE
+ RETURN
+*
+* End of DORGL2
+*
+ END
+ SUBROUTINE DORGLQ( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, K, LDA, LWORK, M, N
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DORGLQ generates an M-by-N real matrix Q with orthonormal rows,
+* which is defined as the first M rows of a product of K elementary
+* reflectors of order N
+*
+* Q = H(k) . . . H(2) H(1)
+*
+* as returned by DGELQF.
+*
+* Arguments
+* =========
+*
+* M (input) INTEGER
+* The number of rows of the matrix Q. M >= 0.
+*
+* N (input) INTEGER
+* The number of columns of the matrix Q. N >= M.
+*
+* K (input) INTEGER
+* The number of elementary reflectors whose product defines the
+* matrix Q. M >= K >= 0.
+*
+* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+* On entry, the i-th row must contain the vector which defines
+* the elementary reflector H(i), for i = 1,2,...,k, as returned
+* by DGELQF in the first k rows of its array argument A.
+* On exit, the M-by-N matrix Q.
+*
+* LDA (input) INTEGER
+* The first dimension of the array A. LDA >= max(1,M).
+*
+* TAU (input) DOUBLE PRECISION array, dimension (K)
+* TAU(i) must contain the scalar factor of the elementary
+* reflector H(i), as returned by DGELQF.
+*
+* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
+* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+* LWORK (input) INTEGER
+* The dimension of the array WORK. LWORK >= max(1,M).
+* For optimum performance LWORK >= M*NB, where NB is
+* the optimal blocksize.
+*
+* If LWORK = -1, then a workspace query is assumed; the routine
+* only calculates the optimal size of the WORK array, returns
+* this value as the first entry of the WORK array, and no error
+* message related to LWORK is issued by XERBLA.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument has an illegal value
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO
+ PARAMETER ( ZERO = 0.0D+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL LQUERY
+ INTEGER I, IB, IINFO, IWS, J, KI, KK, L, LDWORK,
+ $ LWKOPT, NB, NBMIN, NX
+* ..
+* .. External Subroutines ..
+ EXTERNAL DLARFB, DLARFT, DORGL2, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN
+* ..
+* .. External Functions ..
+ INTEGER ILAENV
+ EXTERNAL ILAENV
+* ..
+* .. Executable Statements ..
+*
+* Test the input arguments
+*
+ INFO = 0
+ NB = ILAENV( 1, 'DORGLQ', ' ', M, N, K, -1 )
+ LWKOPT = MAX( 1, M )*NB
+ WORK( 1 ) = LWKOPT
+ LQUERY = ( LWORK.EQ.-1 )
+ IF( M.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( N.LT.M ) THEN
+ INFO = -2
+ ELSE IF( K.LT.0 .OR. K.GT.M ) THEN
+ INFO = -3
+ ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+ INFO = -5
+ ELSE IF( LWORK.LT.MAX( 1, M ) .AND. .NOT.LQUERY ) THEN
+ INFO = -8
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DORGLQ', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( M.LE.0 ) THEN
+ WORK( 1 ) = 1
+ RETURN
+ END IF
+*
+ NBMIN = 2
+ NX = 0
+ IWS = M
+ IF( NB.GT.1 .AND. NB.LT.K ) THEN
+*
+* Determine when to cross over from blocked to unblocked code.
+*
+ NX = MAX( 0, ILAENV( 3, 'DORGLQ', ' ', M, N, K, -1 ) )
+ IF( NX.LT.K ) THEN
+*
+* Determine if workspace is large enough for blocked code.
+*
+ LDWORK = M
+ IWS = LDWORK*NB
+ IF( LWORK.LT.IWS ) THEN
+*
+* Not enough workspace to use optimal NB: reduce NB and
+* determine the minimum value of NB.
+*
+ NB = LWORK / LDWORK
+ NBMIN = MAX( 2, ILAENV( 2, 'DORGLQ', ' ', M, N, K, -1 ) )
+ END IF
+ END IF
+ END IF
+*
+ IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN
+*
+* Use blocked code after the last block.
+* The first kk rows are handled by the block method.
+*
+ KI = ( ( K-NX-1 ) / NB )*NB
+ KK = MIN( K, KI+NB )
+*
+* Set A(kk+1:m,1:kk) to zero.
+*
+ DO 20 J = 1, KK
+ DO 10 I = KK + 1, M
+ A( I, J ) = ZERO
+ 10 CONTINUE
+ 20 CONTINUE
+ ELSE
+ KK = 0
+ END IF
+*
+* Use unblocked code for the last or only block.
+*
+ IF( KK.LT.M )
+ $ CALL DORGL2( M-KK, N-KK, K-KK, A( KK+1, KK+1 ), LDA,
+ $ TAU( KK+1 ), WORK, IINFO )
+*
+ IF( KK.GT.0 ) THEN
+*
+* Use blocked code
+*
+ DO 50 I = KI + 1, 1, -NB
+ IB = MIN( NB, K-I+1 )
+ IF( I+IB.LE.M ) THEN
+*
+* Form the triangular factor of the block reflector
+* H = H(i) H(i+1) . . . H(i+ib-1)
+*
+ CALL DLARFT( 'Forward', 'Rowwise', N-I+1, IB, A( I, I ),
+ $ LDA, TAU( I ), WORK, LDWORK )
+*
+* Apply H' to A(i+ib:m,i:n) from the right
+*
+ CALL DLARFB( 'Right', 'Transpose', 'Forward', 'Rowwise',
+ $ M-I-IB+1, N-I+1, IB, A( I, I ), LDA, WORK,
+ $ LDWORK, A( I+IB, I ), LDA, WORK( IB+1 ),
+ $ LDWORK )
+ END IF
+*
+* Apply H' to columns i:n of current block
+*
+ CALL DORGL2( IB, N-I+1, IB, A( I, I ), LDA, TAU( I ), WORK,
+ $ IINFO )
+*
+* Set columns 1:i-1 of current block to zero
+*
+ DO 40 J = 1, I - 1
+ DO 30 L = I, I + IB - 1
+ A( L, J ) = ZERO
+ 30 CONTINUE
+ 40 CONTINUE
+ 50 CONTINUE
+ END IF
+*
+ WORK( 1 ) = IWS
+ RETURN
+*
+* End of DORGLQ
+*
+ END
+ SUBROUTINE DORGQL( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, K, LDA, LWORK, M, N
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DORGQL generates an M-by-N real matrix Q with orthonormal columns,
+* which is defined as the last N columns of a product of K elementary
+* reflectors of order M
+*
+* Q = H(k) . . . H(2) H(1)
+*
+* as returned by DGEQLF.
+*
+* Arguments
+* =========
+*
+* M (input) INTEGER
+* The number of rows of the matrix Q. M >= 0.
+*
+* N (input) INTEGER
+* The number of columns of the matrix Q. M >= N >= 0.
+*
+* K (input) INTEGER
+* The number of elementary reflectors whose product defines the
+* matrix Q. N >= K >= 0.
+*
+* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+* On entry, the (n-k+i)-th column must contain the vector which
+* defines the elementary reflector H(i), for i = 1,2,...,k, as
+* returned by DGEQLF in the last k columns of its array
+* argument A.
+* On exit, the M-by-N matrix Q.
+*
+* LDA (input) INTEGER
+* The first dimension of the array A. LDA >= max(1,M).
+*
+* TAU (input) DOUBLE PRECISION array, dimension (K)
+* TAU(i) must contain the scalar factor of the elementary
+* reflector H(i), as returned by DGEQLF.
+*
+* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
+* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+* LWORK (input) INTEGER
+* The dimension of the array WORK. LWORK >= max(1,N).
+* For optimum performance LWORK >= N*NB, where NB is the
+* optimal blocksize.
+*
+* If LWORK = -1, then a workspace query is assumed; the routine
+* only calculates the optimal size of the WORK array, returns
+* this value as the first entry of the WORK array, and no error
+* message related to LWORK is issued by XERBLA.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument has an illegal value
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO
+ PARAMETER ( ZERO = 0.0D+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL LQUERY
+ INTEGER I, IB, IINFO, IWS, J, KK, L, LDWORK, LWKOPT,
+ $ NB, NBMIN, NX
+* ..
+* .. External Subroutines ..
+ EXTERNAL DLARFB, DLARFT, DORG2L, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN
+* ..
+* .. External Functions ..
+ INTEGER ILAENV
+ EXTERNAL ILAENV
+* ..
+* .. Executable Statements ..
+*
+* Test the input arguments
+*
+ INFO = 0
+ LQUERY = ( LWORK.EQ.-1 )
+ IF( M.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 .OR. N.GT.M ) THEN
+ INFO = -2
+ ELSE IF( K.LT.0 .OR. K.GT.N ) THEN
+ INFO = -3
+ ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+ INFO = -5
+ END IF
+*
+ IF( INFO.EQ.0 ) THEN
+ IF( N.EQ.0 ) THEN
+ LWKOPT = 1
+ ELSE
+ NB = ILAENV( 1, 'DORGQL', ' ', M, N, K, -1 )
+ LWKOPT = N*NB
+ END IF
+ WORK( 1 ) = LWKOPT
+*
+ IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN
+ INFO = -8
+ END IF
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DORGQL', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.LE.0 ) THEN
+ RETURN
+ END IF
+*
+ NBMIN = 2
+ NX = 0
+ IWS = N
+ IF( NB.GT.1 .AND. NB.LT.K ) THEN
+*
+* Determine when to cross over from blocked to unblocked code.
+*
+ NX = MAX( 0, ILAENV( 3, 'DORGQL', ' ', M, N, K, -1 ) )
+ IF( NX.LT.K ) THEN
+*
+* Determine if workspace is large enough for blocked code.
+*
+ LDWORK = N
+ IWS = LDWORK*NB
+ IF( LWORK.LT.IWS ) THEN
+*
+* Not enough workspace to use optimal NB: reduce NB and
+* determine the minimum value of NB.
+*
+ NB = LWORK / LDWORK
+ NBMIN = MAX( 2, ILAENV( 2, 'DORGQL', ' ', M, N, K, -1 ) )
+ END IF
+ END IF
+ END IF
+*
+ IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN
+*
+* Use blocked code after the first block.
+* The last kk columns are handled by the block method.
+*
+ KK = MIN( K, ( ( K-NX+NB-1 ) / NB )*NB )
+*
+* Set A(m-kk+1:m,1:n-kk) to zero.
+*
+ DO 20 J = 1, N - KK
+ DO 10 I = M - KK + 1, M
+ A( I, J ) = ZERO
+ 10 CONTINUE
+ 20 CONTINUE
+ ELSE
+ KK = 0
+ END IF
+*
+* Use unblocked code for the first or only block.
+*
+ CALL DORG2L( M-KK, N-KK, K-KK, A, LDA, TAU, WORK, IINFO )
+*
+ IF( KK.GT.0 ) THEN
+*
+* Use blocked code
+*
+ DO 50 I = K - KK + 1, K, NB
+ IB = MIN( NB, K-I+1 )
+ IF( N-K+I.GT.1 ) THEN
+*
+* Form the triangular factor of the block reflector
+* H = H(i+ib-1) . . . H(i+1) H(i)
+*
+ CALL DLARFT( 'Backward', 'Columnwise', M-K+I+IB-1, IB,
+ $ A( 1, N-K+I ), LDA, TAU( I ), WORK, LDWORK )
+*
+* Apply H to A(1:m-k+i+ib-1,1:n-k+i-1) from the left
+*
+ CALL DLARFB( 'Left', 'No transpose', 'Backward',
+ $ 'Columnwise', M-K+I+IB-1, N-K+I-1, IB,
+ $ A( 1, N-K+I ), LDA, WORK, LDWORK, A, LDA,
+ $ WORK( IB+1 ), LDWORK )
+ END IF
+*
+* Apply H to rows 1:m-k+i+ib-1 of current block
+*
+ CALL DORG2L( M-K+I+IB-1, IB, IB, A( 1, N-K+I ), LDA,
+ $ TAU( I ), WORK, IINFO )
+*
+* Set rows m-k+i+ib:m of current block to zero
+*
+ DO 40 J = N - K + I, N - K + I + IB - 1
+ DO 30 L = M - K + I + IB, M
+ A( L, J ) = ZERO
+ 30 CONTINUE
+ 40 CONTINUE
+ 50 CONTINUE
+ END IF
+*
+ WORK( 1 ) = IWS
+ RETURN
+*
+* End of DORGQL
+*
+ END
+ SUBROUTINE DORGQR( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, K, LDA, LWORK, M, N
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DORGQR generates an M-by-N real matrix Q with orthonormal columns,
+* which is defined as the first N columns of a product of K elementary
+* reflectors of order M
+*
+* Q = H(1) H(2) . . . H(k)
+*
+* as returned by DGEQRF.
+*
+* Arguments
+* =========
+*
+* M (input) INTEGER
+* The number of rows of the matrix Q. M >= 0.
+*
+* N (input) INTEGER
+* The number of columns of the matrix Q. M >= N >= 0.
+*
+* K (input) INTEGER
+* The number of elementary reflectors whose product defines the
+* matrix Q. N >= K >= 0.
+*
+* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+* On entry, the i-th column must contain the vector which
+* defines the elementary reflector H(i), for i = 1,2,...,k, as
+* returned by DGEQRF in the first k columns of its array
+* argument A.
+* On exit, the M-by-N matrix Q.
+*
+* LDA (input) INTEGER
+* The first dimension of the array A. LDA >= max(1,M).
+*
+* TAU (input) DOUBLE PRECISION array, dimension (K)
+* TAU(i) must contain the scalar factor of the elementary
+* reflector H(i), as returned by DGEQRF.
+*
+* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
+* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+* LWORK (input) INTEGER
+* The dimension of the array WORK. LWORK >= max(1,N).
+* For optimum performance LWORK >= N*NB, where NB is the
+* optimal blocksize.
+*
+* If LWORK = -1, then a workspace query is assumed; the routine
+* only calculates the optimal size of the WORK array, returns
+* this value as the first entry of the WORK array, and no error
+* message related to LWORK is issued by XERBLA.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument has an illegal value
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO
+ PARAMETER ( ZERO = 0.0D+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL LQUERY
+ INTEGER I, IB, IINFO, IWS, J, KI, KK, L, LDWORK,
+ $ LWKOPT, NB, NBMIN, NX
+* ..
+* .. External Subroutines ..
+ EXTERNAL DLARFB, DLARFT, DORG2R, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN
+* ..
+* .. External Functions ..
+ INTEGER ILAENV
+ EXTERNAL ILAENV
+* ..
+* .. Executable Statements ..
+*
+* Test the input arguments
+*
+ INFO = 0
+ NB = ILAENV( 1, 'DORGQR', ' ', M, N, K, -1 )
+ LWKOPT = MAX( 1, N )*NB
+ WORK( 1 ) = LWKOPT
+ LQUERY = ( LWORK.EQ.-1 )
+ IF( M.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 .OR. N.GT.M ) THEN
+ INFO = -2
+ ELSE IF( K.LT.0 .OR. K.GT.N ) THEN
+ INFO = -3
+ ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+ INFO = -5
+ ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN
+ INFO = -8
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DORGQR', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.LE.0 ) THEN
+ WORK( 1 ) = 1
+ RETURN
+ END IF
+*
+ NBMIN = 2
+ NX = 0
+ IWS = N
+ IF( NB.GT.1 .AND. NB.LT.K ) THEN
+*
+* Determine when to cross over from blocked to unblocked code.
+*
+ NX = MAX( 0, ILAENV( 3, 'DORGQR', ' ', M, N, K, -1 ) )
+ IF( NX.LT.K ) THEN
+*
+* Determine if workspace is large enough for blocked code.
+*
+ LDWORK = N
+ IWS = LDWORK*NB
+ IF( LWORK.LT.IWS ) THEN
+*
+* Not enough workspace to use optimal NB: reduce NB and
+* determine the minimum value of NB.
+*
+ NB = LWORK / LDWORK
+ NBMIN = MAX( 2, ILAENV( 2, 'DORGQR', ' ', M, N, K, -1 ) )
+ END IF
+ END IF
+ END IF
+*
+ IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN
+*
+* Use blocked code after the last block.
+* The first kk columns are handled by the block method.
+*
+ KI = ( ( K-NX-1 ) / NB )*NB
+ KK = MIN( K, KI+NB )
+*
+* Set A(1:kk,kk+1:n) to zero.
+*
+ DO 20 J = KK + 1, N
+ DO 10 I = 1, KK
+ A( I, J ) = ZERO
+ 10 CONTINUE
+ 20 CONTINUE
+ ELSE
+ KK = 0
+ END IF
+*
+* Use unblocked code for the last or only block.
+*
+ IF( KK.LT.N )
+ $ CALL DORG2R( M-KK, N-KK, K-KK, A( KK+1, KK+1 ), LDA,
+ $ TAU( KK+1 ), WORK, IINFO )
+*
+ IF( KK.GT.0 ) THEN
+*
+* Use blocked code
+*
+ DO 50 I = KI + 1, 1, -NB
+ IB = MIN( NB, K-I+1 )
+ IF( I+IB.LE.N ) THEN
+*
+* Form the triangular factor of the block reflector
+* H = H(i) H(i+1) . . . H(i+ib-1)
+*
+ CALL DLARFT( 'Forward', 'Columnwise', M-I+1, IB,
+ $ A( I, I ), LDA, TAU( I ), WORK, LDWORK )
+*
+* Apply H to A(i:m,i+ib:n) from the left
+*
+ CALL DLARFB( 'Left', 'No transpose', 'Forward',
+ $ 'Columnwise', M-I+1, N-I-IB+1, IB,
+ $ A( I, I ), LDA, WORK, LDWORK, A( I, I+IB ),
+ $ LDA, WORK( IB+1 ), LDWORK )
+ END IF
+*
+* Apply H to rows i:m of current block
+*
+ CALL DORG2R( M-I+1, IB, IB, A( I, I ), LDA, TAU( I ), WORK,
+ $ IINFO )
+*
+* Set rows 1:i-1 of current block to zero
+*
+ DO 40 J = I, I + IB - 1
+ DO 30 L = 1, I - 1
+ A( L, J ) = ZERO
+ 30 CONTINUE
+ 40 CONTINUE
+ 50 CONTINUE
+ END IF
+*
+ WORK( 1 ) = IWS
+ RETURN
+*
+* End of DORGQR
+*
+ END
+ SUBROUTINE DORGR2( M, N, K, A, LDA, TAU, WORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, K, LDA, M, N
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DORGR2 generates an m by n real matrix Q with orthonormal rows,
+* which is defined as the last m rows of a product of k elementary
+* reflectors of order n
+*
+* Q = H(1) H(2) . . . H(k)
+*
+* as returned by DGERQF.
+*
+* Arguments
+* =========
+*
+* M (input) INTEGER
+* The number of rows of the matrix Q. M >= 0.
+*
+* N (input) INTEGER
+* The number of columns of the matrix Q. N >= M.
+*
+* K (input) INTEGER
+* The number of elementary reflectors whose product defines the
+* matrix Q. M >= K >= 0.
+*
+* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+* On entry, the (m-k+i)-th row must contain the vector which
+* defines the elementary reflector H(i), for i = 1,2,...,k, as
+* returned by DGERQF in the last k rows of its array argument
+* A.
+* On exit, the m by n matrix Q.
+*
+* LDA (input) INTEGER
+* The first dimension of the array A. LDA >= max(1,M).
+*
+* TAU (input) DOUBLE PRECISION array, dimension (K)
+* TAU(i) must contain the scalar factor of the elementary
+* reflector H(i), as returned by DGERQF.
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (M)
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument has an illegal value
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE, ZERO
+ PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, II, J, L
+* ..
+* .. External Subroutines ..
+ EXTERNAL DLARF, DSCAL, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input arguments
+*
+ INFO = 0
+ IF( M.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( N.LT.M ) THEN
+ INFO = -2
+ ELSE IF( K.LT.0 .OR. K.GT.M ) THEN
+ INFO = -3
+ ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+ INFO = -5
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DORGR2', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( M.LE.0 )
+ $ RETURN
+*
+ IF( K.LT.M ) THEN
+*
+* Initialise rows 1:m-k to rows of the unit matrix
+*
+ DO 20 J = 1, N
+ DO 10 L = 1, M - K
+ A( L, J ) = ZERO
+ 10 CONTINUE
+ IF( J.GT.N-M .AND. J.LE.N-K )
+ $ A( M-N+J, J ) = ONE
+ 20 CONTINUE
+ END IF
+*
+ DO 40 I = 1, K
+ II = M - K + I
+*
+* Apply H(i) to A(1:m-k+i,1:n-k+i) from the right
+*
+ A( II, N-M+II ) = ONE
+ CALL DLARF( 'Right', II-1, N-M+II, A( II, 1 ), LDA, TAU( I ),
+ $ A, LDA, WORK )
+ CALL DSCAL( N-M+II-1, -TAU( I ), A( II, 1 ), LDA )
+ A( II, N-M+II ) = ONE - TAU( I )
+*
+* Set A(m-k+i,n-k+i+1:n) to zero
+*
+ DO 30 L = N - M + II + 1, N
+ A( II, L ) = ZERO
+ 30 CONTINUE
+ 40 CONTINUE
+ RETURN
+*
+* End of DORGR2
+*
+ END
+ SUBROUTINE DORGRQ( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, K, LDA, LWORK, M, N
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DORGRQ generates an M-by-N real matrix Q with orthonormal rows,
+* which is defined as the last M rows of a product of K elementary
+* reflectors of order N
+*
+* Q = H(1) H(2) . . . H(k)
+*
+* as returned by DGERQF.
+*
+* Arguments
+* =========
+*
+* M (input) INTEGER
+* The number of rows of the matrix Q. M >= 0.
+*
+* N (input) INTEGER
+* The number of columns of the matrix Q. N >= M.
+*
+* K (input) INTEGER
+* The number of elementary reflectors whose product defines the
+* matrix Q. M >= K >= 0.
+*
+* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+* On entry, the (m-k+i)-th row must contain the vector which
+* defines the elementary reflector H(i), for i = 1,2,...,k, as
+* returned by DGERQF in the last k rows of its array argument
+* A.
+* On exit, the M-by-N matrix Q.
+*
+* LDA (input) INTEGER
+* The first dimension of the array A. LDA >= max(1,M).
+*
+* TAU (input) DOUBLE PRECISION array, dimension (K)
+* TAU(i) must contain the scalar factor of the elementary
+* reflector H(i), as returned by DGERQF.
+*
+* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
+* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+* LWORK (input) INTEGER
+* The dimension of the array WORK. LWORK >= max(1,M).
+* For optimum performance LWORK >= M*NB, where NB is the
+* optimal blocksize.
+*
+* If LWORK = -1, then a workspace query is assumed; the routine
+* only calculates the optimal size of the WORK array, returns
+* this value as the first entry of the WORK array, and no error
+* message related to LWORK is issued by XERBLA.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument has an illegal value
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO
+ PARAMETER ( ZERO = 0.0D+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL LQUERY
+ INTEGER I, IB, II, IINFO, IWS, J, KK, L, LDWORK,
+ $ LWKOPT, NB, NBMIN, NX
+* ..
+* .. External Subroutines ..
+ EXTERNAL DLARFB, DLARFT, DORGR2, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN
+* ..
+* .. External Functions ..
+ INTEGER ILAENV
+ EXTERNAL ILAENV
+* ..
+* .. Executable Statements ..
+*
+* Test the input arguments
+*
+ INFO = 0
+ LQUERY = ( LWORK.EQ.-1 )
+ IF( M.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( N.LT.M ) THEN
+ INFO = -2
+ ELSE IF( K.LT.0 .OR. K.GT.M ) THEN
+ INFO = -3
+ ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+ INFO = -5
+ END IF
+*
+ IF( INFO.EQ.0 ) THEN
+ IF( M.LE.0 ) THEN
+ LWKOPT = 1
+ ELSE
+ NB = ILAENV( 1, 'DORGRQ', ' ', M, N, K, -1 )
+ LWKOPT = M*NB
+ END IF
+ WORK( 1 ) = LWKOPT
+*
+ IF( LWORK.LT.MAX( 1, M ) .AND. .NOT.LQUERY ) THEN
+ INFO = -8
+ END IF
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DORGRQ', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( M.LE.0 ) THEN
+ RETURN
+ END IF
+*
+ NBMIN = 2
+ NX = 0
+ IWS = M
+ IF( NB.GT.1 .AND. NB.LT.K ) THEN
+*
+* Determine when to cross over from blocked to unblocked code.
+*
+ NX = MAX( 0, ILAENV( 3, 'DORGRQ', ' ', M, N, K, -1 ) )
+ IF( NX.LT.K ) THEN
+*
+* Determine if workspace is large enough for blocked code.
+*
+ LDWORK = M
+ IWS = LDWORK*NB
+ IF( LWORK.LT.IWS ) THEN
+*
+* Not enough workspace to use optimal NB: reduce NB and
+* determine the minimum value of NB.
+*
+ NB = LWORK / LDWORK
+ NBMIN = MAX( 2, ILAENV( 2, 'DORGRQ', ' ', M, N, K, -1 ) )
+ END IF
+ END IF
+ END IF
+*
+ IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN
+*
+* Use blocked code after the first block.
+* The last kk rows are handled by the block method.
+*
+ KK = MIN( K, ( ( K-NX+NB-1 ) / NB )*NB )
+*
+* Set A(1:m-kk,n-kk+1:n) to zero.
+*
+ DO 20 J = N - KK + 1, N
+ DO 10 I = 1, M - KK
+ A( I, J ) = ZERO
+ 10 CONTINUE
+ 20 CONTINUE
+ ELSE
+ KK = 0
+ END IF
+*
+* Use unblocked code for the first or only block.
+*
+ CALL DORGR2( M-KK, N-KK, K-KK, A, LDA, TAU, WORK, IINFO )
+*
+ IF( KK.GT.0 ) THEN
+*
+* Use blocked code
+*
+ DO 50 I = K - KK + 1, K, NB
+ IB = MIN( NB, K-I+1 )
+ II = M - K + I
+ IF( II.GT.1 ) THEN
+*
+* Form the triangular factor of the block reflector
+* H = H(i+ib-1) . . . H(i+1) H(i)
+*
+ CALL DLARFT( 'Backward', 'Rowwise', N-K+I+IB-1, IB,
+ $ A( II, 1 ), LDA, TAU( I ), WORK, LDWORK )
+*
+* Apply H' to A(1:m-k+i-1,1:n-k+i+ib-1) from the right
+*
+ CALL DLARFB( 'Right', 'Transpose', 'Backward', 'Rowwise',
+ $ II-1, N-K+I+IB-1, IB, A( II, 1 ), LDA, WORK,
+ $ LDWORK, A, LDA, WORK( IB+1 ), LDWORK )
+ END IF
+*
+* Apply H' to columns 1:n-k+i+ib-1 of current block
+*
+ CALL DORGR2( IB, N-K+I+IB-1, IB, A( II, 1 ), LDA, TAU( I ),
+ $ WORK, IINFO )
+*
+* Set columns n-k+i+ib:n of current block to zero
+*
+ DO 40 L = N - K + I + IB, N
+ DO 30 J = II, II + IB - 1
+ A( J, L ) = ZERO
+ 30 CONTINUE
+ 40 CONTINUE
+ 50 CONTINUE
+ END IF
+*
+ WORK( 1 ) = IWS
+ RETURN
+*
+* End of DORGRQ
+*
+ END
+ SUBROUTINE DORGTR( UPLO, N, A, LDA, TAU, WORK, LWORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, LDA, LWORK, N
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DORGTR generates a real orthogonal matrix Q which is defined as the
+* product of n-1 elementary reflectors of order N, as returned by
+* DSYTRD:
+*
+* if UPLO = 'U', Q = H(n-1) . . . H(2) H(1),
+*
+* if UPLO = 'L', Q = H(1) H(2) . . . H(n-1).
+*
+* Arguments
+* =========
+*
+* UPLO (input) CHARACTER*1
+* = 'U': Upper triangle of A contains elementary reflectors
+* from DSYTRD;
+* = 'L': Lower triangle of A contains elementary reflectors
+* from DSYTRD.
+*
+* N (input) INTEGER
+* The order of the matrix Q. N >= 0.
+*
+* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+* On entry, the vectors which define the elementary reflectors,
+* as returned by DSYTRD.
+* On exit, the N-by-N orthogonal matrix Q.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,N).
+*
+* TAU (input) DOUBLE PRECISION array, dimension (N-1)
+* TAU(i) must contain the scalar factor of the elementary
+* reflector H(i), as returned by DSYTRD.
+*
+* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
+* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+* LWORK (input) INTEGER
+* The dimension of the array WORK. LWORK >= max(1,N-1).
+* For optimum performance LWORK >= (N-1)*NB, where NB is
+* the optimal blocksize.
+*
+* If LWORK = -1, then a workspace query is assumed; the routine
+* only calculates the optimal size of the WORK array, returns
+* this value as the first entry of the WORK array, and no error
+* message related to LWORK is issued by XERBLA.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL LQUERY, UPPER
+ INTEGER I, IINFO, J, LWKOPT, NB
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ILAENV
+ EXTERNAL LSAME, ILAENV
+* ..
+* .. External Subroutines ..
+ EXTERNAL DORGQL, DORGQR, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input arguments
+*
+ INFO = 0
+ LQUERY = ( LWORK.EQ.-1 )
+ UPPER = LSAME( UPLO, 'U' )
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -4
+ ELSE IF( LWORK.LT.MAX( 1, N-1 ) .AND. .NOT.LQUERY ) THEN
+ INFO = -7
+ END IF
+*
+ IF( INFO.EQ.0 ) THEN
+ IF( UPPER ) THEN
+ NB = ILAENV( 1, 'DORGQL', ' ', N-1, N-1, N-1, -1 )
+ ELSE
+ NB = ILAENV( 1, 'DORGQR', ' ', N-1, N-1, N-1, -1 )
+ END IF
+ LWKOPT = MAX( 1, N-1 )*NB
+ WORK( 1 ) = LWKOPT
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DORGTR', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 ) THEN
+ WORK( 1 ) = 1
+ RETURN
+ END IF
+*
+ IF( UPPER ) THEN
+*
+* Q was determined by a call to DSYTRD with UPLO = 'U'
+*
+* Shift the vectors which define the elementary reflectors one
+* column to the left, and set the last row and column of Q to
+* those of the unit matrix
+*
+ DO 20 J = 1, N - 1
+ DO 10 I = 1, J - 1
+ A( I, J ) = A( I, J+1 )
+ 10 CONTINUE
+ A( N, J ) = ZERO
+ 20 CONTINUE
+ DO 30 I = 1, N - 1
+ A( I, N ) = ZERO
+ 30 CONTINUE
+ A( N, N ) = ONE
+*
+* Generate Q(1:n-1,1:n-1)
+*
+ CALL DORGQL( N-1, N-1, N-1, A, LDA, TAU, WORK, LWORK, IINFO )
+*
+ ELSE
+*
+* Q was determined by a call to DSYTRD with UPLO = 'L'.
+*
+* Shift the vectors which define the elementary reflectors one
+* column to the right, and set the first row and column of Q to
+* those of the unit matrix
+*
+ DO 50 J = N, 2, -1
+ A( 1, J ) = ZERO
+ DO 40 I = J + 1, N
+ A( I, J ) = A( I, J-1 )
+ 40 CONTINUE
+ 50 CONTINUE
+ A( 1, 1 ) = ONE
+ DO 60 I = 2, N
+ A( I, 1 ) = ZERO
+ 60 CONTINUE
+ IF( N.GT.1 ) THEN
+*
+* Generate Q(2:n,2:n)
+*
+ CALL DORGQR( N-1, N-1, N-1, A( 2, 2 ), LDA, TAU, WORK,
+ $ LWORK, IINFO )
+ END IF
+ END IF
+ WORK( 1 ) = LWKOPT
+ RETURN
+*
+* End of DORGTR
+*
+ END
+ SUBROUTINE DORM2L( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
+ $ WORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER SIDE, TRANS
+ INTEGER INFO, K, LDA, LDC, M, N
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DORM2L overwrites the general real m by n matrix C with
+*
+* Q * C if SIDE = 'L' and TRANS = 'N', or
+*
+* Q'* C if SIDE = 'L' and TRANS = 'T', or
+*
+* C * Q if SIDE = 'R' and TRANS = 'N', or
+*
+* C * Q' if SIDE = 'R' and TRANS = 'T',
+*
+* where Q is a real orthogonal matrix defined as the product of k
+* elementary reflectors
+*
+* Q = H(k) . . . H(2) H(1)
+*
+* as returned by DGEQLF. Q is of order m if SIDE = 'L' and of order n
+* if SIDE = 'R'.
+*
+* Arguments
+* =========
+*
+* SIDE (input) CHARACTER*1
+* = 'L': apply Q or Q' from the Left
+* = 'R': apply Q or Q' from the Right
+*
+* TRANS (input) CHARACTER*1
+* = 'N': apply Q (No transpose)
+* = 'T': apply Q' (Transpose)
+*
+* M (input) INTEGER
+* The number of rows of the matrix C. M >= 0.
+*
+* N (input) INTEGER
+* The number of columns of the matrix C. N >= 0.
+*
+* K (input) INTEGER
+* The number of elementary reflectors whose product defines
+* the matrix Q.
+* If SIDE = 'L', M >= K >= 0;
+* if SIDE = 'R', N >= K >= 0.
+*
+* A (input) DOUBLE PRECISION array, dimension (LDA,K)
+* The i-th column must contain the vector which defines the
+* elementary reflector H(i), for i = 1,2,...,k, as returned by
+* DGEQLF in the last k columns of its array argument A.
+* A is modified by the routine but restored on exit.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A.
+* If SIDE = 'L', LDA >= max(1,M);
+* if SIDE = 'R', LDA >= max(1,N).
+*
+* TAU (input) DOUBLE PRECISION array, dimension (K)
+* TAU(i) must contain the scalar factor of the elementary
+* reflector H(i), as returned by DGEQLF.
+*
+* C (input/output) DOUBLE PRECISION array, dimension (LDC,N)
+* On entry, the m by n matrix C.
+* On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q.
+*
+* LDC (input) INTEGER
+* The leading dimension of the array C. LDC >= max(1,M).
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension
+* (N) if SIDE = 'L',
+* (M) if SIDE = 'R'
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE
+ PARAMETER ( ONE = 1.0D+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL LEFT, NOTRAN
+ INTEGER I, I1, I2, I3, MI, NI, NQ
+ DOUBLE PRECISION AII
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL DLARF, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input arguments
+*
+ INFO = 0
+ LEFT = LSAME( SIDE, 'L' )
+ NOTRAN = LSAME( TRANS, 'N' )
+*
+* NQ is the order of Q
+*
+ IF( LEFT ) THEN
+ NQ = M
+ ELSE
+ NQ = N
+ END IF
+ IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN
+ INFO = -1
+ ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN
+ INFO = -2
+ ELSE IF( M.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN
+ INFO = -5
+ ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN
+ INFO = -7
+ ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
+ INFO = -10
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DORM2L', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 )
+ $ RETURN
+*
+ IF( ( LEFT .AND. NOTRAN ) .OR. ( .NOT.LEFT .AND. .NOT.NOTRAN ) )
+ $ THEN
+ I1 = 1
+ I2 = K
+ I3 = 1
+ ELSE
+ I1 = K
+ I2 = 1
+ I3 = -1
+ END IF
+*
+ IF( LEFT ) THEN
+ NI = N
+ ELSE
+ MI = M
+ END IF
+*
+ DO 10 I = I1, I2, I3
+ IF( LEFT ) THEN
+*
+* H(i) is applied to C(1:m-k+i,1:n)
+*
+ MI = M - K + I
+ ELSE
+*
+* H(i) is applied to C(1:m,1:n-k+i)
+*
+ NI = N - K + I
+ END IF
+*
+* Apply H(i)
+*
+ AII = A( NQ-K+I, I )
+ A( NQ-K+I, I ) = ONE
+ CALL DLARF( SIDE, MI, NI, A( 1, I ), 1, TAU( I ), C, LDC,
+ $ WORK )
+ A( NQ-K+I, I ) = AII
+ 10 CONTINUE
+ RETURN
+*
+* End of DORM2L
+*
+ END
+ SUBROUTINE DORM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
+ $ WORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER SIDE, TRANS
+ INTEGER INFO, K, LDA, LDC, M, N
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DORM2R overwrites the general real m by n matrix C with
+*
+* Q * C if SIDE = 'L' and TRANS = 'N', or
+*
+* Q'* C if SIDE = 'L' and TRANS = 'T', or
+*
+* C * Q if SIDE = 'R' and TRANS = 'N', or
+*
+* C * Q' if SIDE = 'R' and TRANS = 'T',
+*
+* where Q is a real orthogonal matrix defined as the product of k
+* elementary reflectors
+*
+* Q = H(1) H(2) . . . H(k)
+*
+* as returned by DGEQRF. Q is of order m if SIDE = 'L' and of order n
+* if SIDE = 'R'.
+*
+* Arguments
+* =========
+*
+* SIDE (input) CHARACTER*1
+* = 'L': apply Q or Q' from the Left
+* = 'R': apply Q or Q' from the Right
+*
+* TRANS (input) CHARACTER*1
+* = 'N': apply Q (No transpose)
+* = 'T': apply Q' (Transpose)
+*
+* M (input) INTEGER
+* The number of rows of the matrix C. M >= 0.
+*
+* N (input) INTEGER
+* The number of columns of the matrix C. N >= 0.
+*
+* K (input) INTEGER
+* The number of elementary reflectors whose product defines
+* the matrix Q.
+* If SIDE = 'L', M >= K >= 0;
+* if SIDE = 'R', N >= K >= 0.
+*
+* A (input) DOUBLE PRECISION array, dimension (LDA,K)
+* The i-th column must contain the vector which defines the
+* elementary reflector H(i), for i = 1,2,...,k, as returned by
+* DGEQRF in the first k columns of its array argument A.
+* A is modified by the routine but restored on exit.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A.
+* If SIDE = 'L', LDA >= max(1,M);
+* if SIDE = 'R', LDA >= max(1,N).
+*
+* TAU (input) DOUBLE PRECISION array, dimension (K)
+* TAU(i) must contain the scalar factor of the elementary
+* reflector H(i), as returned by DGEQRF.
+*
+* C (input/output) DOUBLE PRECISION array, dimension (LDC,N)
+* On entry, the m by n matrix C.
+* On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q.
+*
+* LDC (input) INTEGER
+* The leading dimension of the array C. LDC >= max(1,M).
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension
+* (N) if SIDE = 'L',
+* (M) if SIDE = 'R'
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE
+ PARAMETER ( ONE = 1.0D+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL LEFT, NOTRAN
+ INTEGER I, I1, I2, I3, IC, JC, MI, NI, NQ
+ DOUBLE PRECISION AII
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL DLARF, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input arguments
+*
+ INFO = 0
+ LEFT = LSAME( SIDE, 'L' )
+ NOTRAN = LSAME( TRANS, 'N' )
+*
+* NQ is the order of Q
+*
+ IF( LEFT ) THEN
+ NQ = M
+ ELSE
+ NQ = N
+ END IF
+ IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN
+ INFO = -1
+ ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN
+ INFO = -2
+ ELSE IF( M.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN
+ INFO = -5
+ ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN
+ INFO = -7
+ ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
+ INFO = -10
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DORM2R', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 )
+ $ RETURN
+*
+ IF( ( LEFT .AND. .NOT.NOTRAN ) .OR. ( .NOT.LEFT .AND. NOTRAN ) )
+ $ THEN
+ I1 = 1
+ I2 = K
+ I3 = 1
+ ELSE
+ I1 = K
+ I2 = 1
+ I3 = -1
+ END IF
+*
+ IF( LEFT ) THEN
+ NI = N
+ JC = 1
+ ELSE
+ MI = M
+ IC = 1
+ END IF
+*
+ DO 10 I = I1, I2, I3
+ IF( LEFT ) THEN
+*
+* H(i) is applied to C(i:m,1:n)
+*
+ MI = M - I + 1
+ IC = I
+ ELSE
+*
+* H(i) is applied to C(1:m,i:n)
+*
+ NI = N - I + 1
+ JC = I
+ END IF
+*
+* Apply H(i)
+*
+ AII = A( I, I )
+ A( I, I ) = ONE
+ CALL DLARF( SIDE, MI, NI, A( I, I ), 1, TAU( I ), C( IC, JC ),
+ $ LDC, WORK )
+ A( I, I ) = AII
+ 10 CONTINUE
+ RETURN
+*
+* End of DORM2R
+*
+ END
+ SUBROUTINE DORMBR( VECT, SIDE, TRANS, M, N, K, A, LDA, TAU, C,
+ $ LDC, WORK, LWORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER SIDE, TRANS, VECT
+ INTEGER INFO, K, LDA, LDC, LWORK, M, N
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* If VECT = 'Q', DORMBR overwrites the general real M-by-N matrix C
+* with
+* SIDE = 'L' SIDE = 'R'
+* TRANS = 'N': Q * C C * Q
+* TRANS = 'T': Q**T * C C * Q**T
+*
+* If VECT = 'P', DORMBR overwrites the general real M-by-N matrix C
+* with
+* SIDE = 'L' SIDE = 'R'
+* TRANS = 'N': P * C C * P
+* TRANS = 'T': P**T * C C * P**T
+*
+* Here Q and P**T are the orthogonal matrices determined by DGEBRD when
+* reducing a real matrix A to bidiagonal form: A = Q * B * P**T. Q and
+* P**T are defined as products of elementary reflectors H(i) and G(i)
+* respectively.
+*
+* Let nq = m if SIDE = 'L' and nq = n if SIDE = 'R'. Thus nq is the
+* order of the orthogonal matrix Q or P**T that is applied.
+*
+* If VECT = 'Q', A is assumed to have been an NQ-by-K matrix:
+* if nq >= k, Q = H(1) H(2) . . . H(k);
+* if nq < k, Q = H(1) H(2) . . . H(nq-1).
+*
+* If VECT = 'P', A is assumed to have been a K-by-NQ matrix:
+* if k < nq, P = G(1) G(2) . . . G(k);
+* if k >= nq, P = G(1) G(2) . . . G(nq-1).
+*
+* Arguments
+* =========
+*
+* VECT (input) CHARACTER*1
+* = 'Q': apply Q or Q**T;
+* = 'P': apply P or P**T.
+*
+* SIDE (input) CHARACTER*1
+* = 'L': apply Q, Q**T, P or P**T from the Left;
+* = 'R': apply Q, Q**T, P or P**T from the Right.
+*
+* TRANS (input) CHARACTER*1
+* = 'N': No transpose, apply Q or P;
+* = 'T': Transpose, apply Q**T or P**T.
+*
+* M (input) INTEGER
+* The number of rows of the matrix C. M >= 0.
+*
+* N (input) INTEGER
+* The number of columns of the matrix C. N >= 0.
+*
+* K (input) INTEGER
+* If VECT = 'Q', the number of columns in the original
+* matrix reduced by DGEBRD.
+* If VECT = 'P', the number of rows in the original
+* matrix reduced by DGEBRD.
+* K >= 0.
+*
+* A (input) DOUBLE PRECISION array, dimension
+* (LDA,min(nq,K)) if VECT = 'Q'
+* (LDA,nq) if VECT = 'P'
+* The vectors which define the elementary reflectors H(i) and
+* G(i), whose products determine the matrices Q and P, as
+* returned by DGEBRD.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A.
+* If VECT = 'Q', LDA >= max(1,nq);
+* if VECT = 'P', LDA >= max(1,min(nq,K)).
+*
+* TAU (input) DOUBLE PRECISION array, dimension (min(nq,K))
+* TAU(i) must contain the scalar factor of the elementary
+* reflector H(i) or G(i) which determines Q or P, as returned
+* by DGEBRD in the array argument TAUQ or TAUP.
+*
+* C (input/output) DOUBLE PRECISION array, dimension (LDC,N)
+* On entry, the M-by-N matrix C.
+* On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q
+* or P*C or P**T*C or C*P or C*P**T.
+*
+* LDC (input) INTEGER
+* The leading dimension of the array C. LDC >= max(1,M).
+*
+* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
+* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+* LWORK (input) INTEGER
+* The dimension of the array WORK.
+* If SIDE = 'L', LWORK >= max(1,N);
+* if SIDE = 'R', LWORK >= max(1,M).
+* For optimum performance LWORK >= N*NB if SIDE = 'L', and
+* LWORK >= M*NB if SIDE = 'R', where NB is the optimal
+* blocksize.
+*
+* If LWORK = -1, then a workspace query is assumed; the routine
+* only calculates the optimal size of the WORK array, returns
+* this value as the first entry of the WORK array, and no error
+* message related to LWORK is issued by XERBLA.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ LOGICAL APPLYQ, LEFT, LQUERY, NOTRAN
+ CHARACTER TRANST
+ INTEGER I1, I2, IINFO, LWKOPT, MI, NB, NI, NQ, NW
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ILAENV
+ EXTERNAL LSAME, ILAENV
+* ..
+* .. External Subroutines ..
+ EXTERNAL DORMLQ, DORMQR, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+* Test the input arguments
+*
+ INFO = 0
+ APPLYQ = LSAME( VECT, 'Q' )
+ LEFT = LSAME( SIDE, 'L' )
+ NOTRAN = LSAME( TRANS, 'N' )
+ LQUERY = ( LWORK.EQ.-1 )
+*
+* NQ is the order of Q or P and NW is the minimum dimension of WORK
+*
+ IF( LEFT ) THEN
+ NQ = M
+ NW = N
+ ELSE
+ NQ = N
+ NW = M
+ END IF
+ IF( .NOT.APPLYQ .AND. .NOT.LSAME( VECT, 'P' ) ) THEN
+ INFO = -1
+ ELSE IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN
+ INFO = -2
+ ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN
+ INFO = -3
+ ELSE IF( M.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -5
+ ELSE IF( K.LT.0 ) THEN
+ INFO = -6
+ ELSE IF( ( APPLYQ .AND. LDA.LT.MAX( 1, NQ ) ) .OR.
+ $ ( .NOT.APPLYQ .AND. LDA.LT.MAX( 1, MIN( NQ, K ) ) ) )
+ $ THEN
+ INFO = -8
+ ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
+ INFO = -11
+ ELSE IF( LWORK.LT.MAX( 1, NW ) .AND. .NOT.LQUERY ) THEN
+ INFO = -13
+ END IF
+*
+ IF( INFO.EQ.0 ) THEN
+ IF( APPLYQ ) THEN
+ IF( LEFT ) THEN
+ NB = ILAENV( 1, 'DORMQR', SIDE // TRANS, M-1, N, M-1,
+ $ -1 )
+ ELSE
+ NB = ILAENV( 1, 'DORMQR', SIDE // TRANS, M, N-1, N-1,
+ $ -1 )
+ END IF
+ ELSE
+ IF( LEFT ) THEN
+ NB = ILAENV( 1, 'DORMLQ', SIDE // TRANS, M-1, N, M-1,
+ $ -1 )
+ ELSE
+ NB = ILAENV( 1, 'DORMLQ', SIDE // TRANS, M, N-1, N-1,
+ $ -1 )
+ END IF
+ END IF
+ LWKOPT = MAX( 1, NW )*NB
+ WORK( 1 ) = LWKOPT
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DORMBR', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ WORK( 1 ) = 1
+ IF( M.EQ.0 .OR. N.EQ.0 )
+ $ RETURN
+*
+ IF( APPLYQ ) THEN
+*
+* Apply Q
+*
+ IF( NQ.GE.K ) THEN
+*
+* Q was determined by a call to DGEBRD with nq >= k
+*
+ CALL DORMQR( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
+ $ WORK, LWORK, IINFO )
+ ELSE IF( NQ.GT.1 ) THEN
+*
+* Q was determined by a call to DGEBRD with nq < k
+*
+ IF( LEFT ) THEN
+ MI = M - 1
+ NI = N
+ I1 = 2
+ I2 = 1
+ ELSE
+ MI = M
+ NI = N - 1
+ I1 = 1
+ I2 = 2
+ END IF
+ CALL DORMQR( SIDE, TRANS, MI, NI, NQ-1, A( 2, 1 ), LDA, TAU,
+ $ C( I1, I2 ), LDC, WORK, LWORK, IINFO )
+ END IF
+ ELSE
+*
+* Apply P
+*
+ IF( NOTRAN ) THEN
+ TRANST = 'T'
+ ELSE
+ TRANST = 'N'
+ END IF
+ IF( NQ.GT.K ) THEN
+*
+* P was determined by a call to DGEBRD with nq > k
+*
+ CALL DORMLQ( SIDE, TRANST, M, N, K, A, LDA, TAU, C, LDC,
+ $ WORK, LWORK, IINFO )
+ ELSE IF( NQ.GT.1 ) THEN
+*
+* P was determined by a call to DGEBRD with nq <= k
+*
+ IF( LEFT ) THEN
+ MI = M - 1
+ NI = N
+ I1 = 2
+ I2 = 1
+ ELSE
+ MI = M
+ NI = N - 1
+ I1 = 1
+ I2 = 2
+ END IF
+ CALL DORMLQ( SIDE, TRANST, MI, NI, NQ-1, A( 1, 2 ), LDA,
+ $ TAU, C( I1, I2 ), LDC, WORK, LWORK, IINFO )
+ END IF
+ END IF
+ WORK( 1 ) = LWKOPT
+ RETURN
+*
+* End of DORMBR
+*
+ END
+ SUBROUTINE DORMHR( SIDE, TRANS, M, N, ILO, IHI, A, LDA, TAU, C,
+ $ LDC, WORK, LWORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER SIDE, TRANS
+ INTEGER IHI, ILO, INFO, LDA, LDC, LWORK, M, N
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DORMHR overwrites the general real M-by-N matrix C with
+*
+* SIDE = 'L' SIDE = 'R'
+* TRANS = 'N': Q * C C * Q
+* TRANS = 'T': Q**T * C C * Q**T
+*
+* where Q is a real orthogonal matrix of order nq, with nq = m if
+* SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of
+* IHI-ILO elementary reflectors, as returned by DGEHRD:
+*
+* Q = H(ilo) H(ilo+1) . . . H(ihi-1).
+*
+* Arguments
+* =========
+*
+* SIDE (input) CHARACTER*1
+* = 'L': apply Q or Q**T from the Left;
+* = 'R': apply Q or Q**T from the Right.
+*
+* TRANS (input) CHARACTER*1
+* = 'N': No transpose, apply Q;
+* = 'T': Transpose, apply Q**T.
+*
+* M (input) INTEGER
+* The number of rows of the matrix C. M >= 0.
+*
+* N (input) INTEGER
+* The number of columns of the matrix C. N >= 0.
+*
+* ILO (input) INTEGER
+* IHI (input) INTEGER
+* ILO and IHI must have the same values as in the previous call
+* of DGEHRD. Q is equal to the unit matrix except in the
+* submatrix Q(ilo+1:ihi,ilo+1:ihi).
+* If SIDE = 'L', then 1 <= ILO <= IHI <= M, if M > 0, and
+* ILO = 1 and IHI = 0, if M = 0;
+* if SIDE = 'R', then 1 <= ILO <= IHI <= N, if N > 0, and
+* ILO = 1 and IHI = 0, if N = 0.
+*
+* A (input) DOUBLE PRECISION array, dimension
+* (LDA,M) if SIDE = 'L'
+* (LDA,N) if SIDE = 'R'
+* The vectors which define the elementary reflectors, as
+* returned by DGEHRD.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A.
+* LDA >= max(1,M) if SIDE = 'L'; LDA >= max(1,N) if SIDE = 'R'.
+*
+* TAU (input) DOUBLE PRECISION array, dimension
+* (M-1) if SIDE = 'L'
+* (N-1) if SIDE = 'R'
+* TAU(i) must contain the scalar factor of the elementary
+* reflector H(i), as returned by DGEHRD.
+*
+* C (input/output) DOUBLE PRECISION array, dimension (LDC,N)
+* On entry, the M-by-N matrix C.
+* On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q.
+*
+* LDC (input) INTEGER
+* The leading dimension of the array C. LDC >= max(1,M).
+*
+* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
+* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+* LWORK (input) INTEGER
+* The dimension of the array WORK.
+* If SIDE = 'L', LWORK >= max(1,N);
+* if SIDE = 'R', LWORK >= max(1,M).
+* For optimum performance LWORK >= N*NB if SIDE = 'L', and
+* LWORK >= M*NB if SIDE = 'R', where NB is the optimal
+* blocksize.
+*
+* If LWORK = -1, then a workspace query is assumed; the routine
+* only calculates the optimal size of the WORK array, returns
+* this value as the first entry of the WORK array, and no error
+* message related to LWORK is issued by XERBLA.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ LOGICAL LEFT, LQUERY
+ INTEGER I1, I2, IINFO, LWKOPT, MI, NB, NH, NI, NQ, NW
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ILAENV
+ EXTERNAL LSAME, ILAENV
+* ..
+* .. External Subroutines ..
+ EXTERNAL DORMQR, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+* Test the input arguments
+*
+ INFO = 0
+ NH = IHI - ILO
+ LEFT = LSAME( SIDE, 'L' )
+ LQUERY = ( LWORK.EQ.-1 )
+*
+* NQ is the order of Q and NW is the minimum dimension of WORK
+*
+ IF( LEFT ) THEN
+ NQ = M
+ NW = N
+ ELSE
+ NQ = N
+ NW = M
+ END IF
+ IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN
+ INFO = -1
+ ELSE IF( .NOT.LSAME( TRANS, 'N' ) .AND. .NOT.LSAME( TRANS, 'T' ) )
+ $ THEN
+ INFO = -2
+ ELSE IF( M.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, NQ ) ) THEN
+ INFO = -5
+ ELSE IF( IHI.LT.MIN( ILO, NQ ) .OR. IHI.GT.NQ ) THEN
+ INFO = -6
+ ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN
+ INFO = -8
+ ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
+ INFO = -11
+ ELSE IF( LWORK.LT.MAX( 1, NW ) .AND. .NOT.LQUERY ) THEN
+ INFO = -13
+ END IF
+*
+ IF( INFO.EQ.0 ) THEN
+ IF( LEFT ) THEN
+ NB = ILAENV( 1, 'DORMQR', SIDE // TRANS, NH, N, NH, -1 )
+ ELSE
+ NB = ILAENV( 1, 'DORMQR', SIDE // TRANS, M, NH, NH, -1 )
+ END IF
+ LWKOPT = MAX( 1, NW )*NB
+ WORK( 1 ) = LWKOPT
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DORMHR', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( M.EQ.0 .OR. N.EQ.0 .OR. NH.EQ.0 ) THEN
+ WORK( 1 ) = 1
+ RETURN
+ END IF
+*
+ IF( LEFT ) THEN
+ MI = NH
+ NI = N
+ I1 = ILO + 1
+ I2 = 1
+ ELSE
+ MI = M
+ NI = NH
+ I1 = 1
+ I2 = ILO + 1
+ END IF
+*
+ CALL DORMQR( SIDE, TRANS, MI, NI, NH, A( ILO+1, ILO ), LDA,
+ $ TAU( ILO ), C( I1, I2 ), LDC, WORK, LWORK, IINFO )
+*
+ WORK( 1 ) = LWKOPT
+ RETURN
+*
+* End of DORMHR
+*
+ END
+ SUBROUTINE DORML2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
+ $ WORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER SIDE, TRANS
+ INTEGER INFO, K, LDA, LDC, M, N
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DORML2 overwrites the general real m by n matrix C with
+*
+* Q * C if SIDE = 'L' and TRANS = 'N', or
+*
+* Q'* C if SIDE = 'L' and TRANS = 'T', or
+*
+* C * Q if SIDE = 'R' and TRANS = 'N', or
+*
+* C * Q' if SIDE = 'R' and TRANS = 'T',
+*
+* where Q is a real orthogonal matrix defined as the product of k
+* elementary reflectors
+*
+* Q = H(k) . . . H(2) H(1)
+*
+* as returned by DGELQF. Q is of order m if SIDE = 'L' and of order n
+* if SIDE = 'R'.
+*
+* Arguments
+* =========
+*
+* SIDE (input) CHARACTER*1
+* = 'L': apply Q or Q' from the Left
+* = 'R': apply Q or Q' from the Right
+*
+* TRANS (input) CHARACTER*1
+* = 'N': apply Q (No transpose)
+* = 'T': apply Q' (Transpose)
+*
+* M (input) INTEGER
+* The number of rows of the matrix C. M >= 0.
+*
+* N (input) INTEGER
+* The number of columns of the matrix C. N >= 0.
+*
+* K (input) INTEGER
+* The number of elementary reflectors whose product defines
+* the matrix Q.
+* If SIDE = 'L', M >= K >= 0;
+* if SIDE = 'R', N >= K >= 0.
+*
+* A (input) DOUBLE PRECISION array, dimension
+* (LDA,M) if SIDE = 'L',
+* (LDA,N) if SIDE = 'R'
+* The i-th row must contain the vector which defines the
+* elementary reflector H(i), for i = 1,2,...,k, as returned by
+* DGELQF in the first k rows of its array argument A.
+* A is modified by the routine but restored on exit.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,K).
+*
+* TAU (input) DOUBLE PRECISION array, dimension (K)
+* TAU(i) must contain the scalar factor of the elementary
+* reflector H(i), as returned by DGELQF.
+*
+* C (input/output) DOUBLE PRECISION array, dimension (LDC,N)
+* On entry, the m by n matrix C.
+* On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q.
+*
+* LDC (input) INTEGER
+* The leading dimension of the array C. LDC >= max(1,M).
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension
+* (N) if SIDE = 'L',
+* (M) if SIDE = 'R'
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE
+ PARAMETER ( ONE = 1.0D+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL LEFT, NOTRAN
+ INTEGER I, I1, I2, I3, IC, JC, MI, NI, NQ
+ DOUBLE PRECISION AII
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL DLARF, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input arguments
+*
+ INFO = 0
+ LEFT = LSAME( SIDE, 'L' )
+ NOTRAN = LSAME( TRANS, 'N' )
+*
+* NQ is the order of Q
+*
+ IF( LEFT ) THEN
+ NQ = M
+ ELSE
+ NQ = N
+ END IF
+ IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN
+ INFO = -1
+ ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN
+ INFO = -2
+ ELSE IF( M.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN
+ INFO = -5
+ ELSE IF( LDA.LT.MAX( 1, K ) ) THEN
+ INFO = -7
+ ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
+ INFO = -10
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DORML2', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 )
+ $ RETURN
+*
+ IF( ( LEFT .AND. NOTRAN ) .OR. ( .NOT.LEFT .AND. .NOT.NOTRAN ) )
+ $ THEN
+ I1 = 1
+ I2 = K
+ I3 = 1
+ ELSE
+ I1 = K
+ I2 = 1
+ I3 = -1
+ END IF
+*
+ IF( LEFT ) THEN
+ NI = N
+ JC = 1
+ ELSE
+ MI = M
+ IC = 1
+ END IF
+*
+ DO 10 I = I1, I2, I3
+ IF( LEFT ) THEN
+*
+* H(i) is applied to C(i:m,1:n)
+*
+ MI = M - I + 1
+ IC = I
+ ELSE
+*
+* H(i) is applied to C(1:m,i:n)
+*
+ NI = N - I + 1
+ JC = I
+ END IF
+*
+* Apply H(i)
+*
+ AII = A( I, I )
+ A( I, I ) = ONE
+ CALL DLARF( SIDE, MI, NI, A( I, I ), LDA, TAU( I ),
+ $ C( IC, JC ), LDC, WORK )
+ A( I, I ) = AII
+ 10 CONTINUE
+ RETURN
+*
+* End of DORML2
+*
+ END
+ SUBROUTINE DORMLQ( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
+ $ WORK, LWORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER SIDE, TRANS
+ INTEGER INFO, K, LDA, LDC, LWORK, M, N
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DORMLQ overwrites the general real M-by-N matrix C with
+*
+* SIDE = 'L' SIDE = 'R'
+* TRANS = 'N': Q * C C * Q
+* TRANS = 'T': Q**T * C C * Q**T
+*
+* where Q is a real orthogonal matrix defined as the product of k
+* elementary reflectors
+*
+* Q = H(k) . . . H(2) H(1)
+*
+* as returned by DGELQF. Q is of order M if SIDE = 'L' and of order N
+* if SIDE = 'R'.
+*
+* Arguments
+* =========
+*
+* SIDE (input) CHARACTER*1
+* = 'L': apply Q or Q**T from the Left;
+* = 'R': apply Q or Q**T from the Right.
+*
+* TRANS (input) CHARACTER*1
+* = 'N': No transpose, apply Q;
+* = 'T': Transpose, apply Q**T.
+*
+* M (input) INTEGER
+* The number of rows of the matrix C. M >= 0.
+*
+* N (input) INTEGER
+* The number of columns of the matrix C. N >= 0.
+*
+* K (input) INTEGER
+* The number of elementary reflectors whose product defines
+* the matrix Q.
+* If SIDE = 'L', M >= K >= 0;
+* if SIDE = 'R', N >= K >= 0.
+*
+* A (input) DOUBLE PRECISION array, dimension
+* (LDA,M) if SIDE = 'L',
+* (LDA,N) if SIDE = 'R'
+* The i-th row must contain the vector which defines the
+* elementary reflector H(i), for i = 1,2,...,k, as returned by
+* DGELQF in the first k rows of its array argument A.
+* A is modified by the routine but restored on exit.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,K).
+*
+* TAU (input) DOUBLE PRECISION array, dimension (K)
+* TAU(i) must contain the scalar factor of the elementary
+* reflector H(i), as returned by DGELQF.
+*
+* C (input/output) DOUBLE PRECISION array, dimension (LDC,N)
+* On entry, the M-by-N matrix C.
+* On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q.
+*
+* LDC (input) INTEGER
+* The leading dimension of the array C. LDC >= max(1,M).
+*
+* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
+* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+* LWORK (input) INTEGER
+* The dimension of the array WORK.
+* If SIDE = 'L', LWORK >= max(1,N);
+* if SIDE = 'R', LWORK >= max(1,M).
+* For optimum performance LWORK >= N*NB if SIDE = 'L', and
+* LWORK >= M*NB if SIDE = 'R', where NB is the optimal
+* blocksize.
+*
+* If LWORK = -1, then a workspace query is assumed; the routine
+* only calculates the optimal size of the WORK array, returns
+* this value as the first entry of the WORK array, and no error
+* message related to LWORK is issued by XERBLA.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+*
+* =====================================================================
+*
+* .. Parameters ..
+ INTEGER NBMAX, LDT
+ PARAMETER ( NBMAX = 64, LDT = NBMAX+1 )
+* ..
+* .. Local Scalars ..
+ LOGICAL LEFT, LQUERY, NOTRAN
+ CHARACTER TRANST
+ INTEGER I, I1, I2, I3, IB, IC, IINFO, IWS, JC, LDWORK,
+ $ LWKOPT, MI, NB, NBMIN, NI, NQ, NW
+* ..
+* .. Local Arrays ..
+ DOUBLE PRECISION T( LDT, NBMAX )
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ILAENV
+ EXTERNAL LSAME, ILAENV
+* ..
+* .. External Subroutines ..
+ EXTERNAL DLARFB, DLARFT, DORML2, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+* Test the input arguments
+*
+ INFO = 0
+ LEFT = LSAME( SIDE, 'L' )
+ NOTRAN = LSAME( TRANS, 'N' )
+ LQUERY = ( LWORK.EQ.-1 )
+*
+* NQ is the order of Q and NW is the minimum dimension of WORK
+*
+ IF( LEFT ) THEN
+ NQ = M
+ NW = N
+ ELSE
+ NQ = N
+ NW = M
+ END IF
+ IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN
+ INFO = -1
+ ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN
+ INFO = -2
+ ELSE IF( M.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN
+ INFO = -5
+ ELSE IF( LDA.LT.MAX( 1, K ) ) THEN
+ INFO = -7
+ ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
+ INFO = -10
+ ELSE IF( LWORK.LT.MAX( 1, NW ) .AND. .NOT.LQUERY ) THEN
+ INFO = -12
+ END IF
+*
+ IF( INFO.EQ.0 ) THEN
+*
+* Determine the block size. NB may be at most NBMAX, where NBMAX
+* is used to define the local array T.
+*
+ NB = MIN( NBMAX, ILAENV( 1, 'DORMLQ', SIDE // TRANS, M, N, K,
+ $ -1 ) )
+ LWKOPT = MAX( 1, NW )*NB
+ WORK( 1 ) = LWKOPT
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DORMLQ', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) THEN
+ WORK( 1 ) = 1
+ RETURN
+ END IF
+*
+ NBMIN = 2
+ LDWORK = NW
+ IF( NB.GT.1 .AND. NB.LT.K ) THEN
+ IWS = NW*NB
+ IF( LWORK.LT.IWS ) THEN
+ NB = LWORK / LDWORK
+ NBMIN = MAX( 2, ILAENV( 2, 'DORMLQ', SIDE // TRANS, M, N, K,
+ $ -1 ) )
+ END IF
+ ELSE
+ IWS = NW
+ END IF
+*
+ IF( NB.LT.NBMIN .OR. NB.GE.K ) THEN
+*
+* Use unblocked code
+*
+ CALL DORML2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK,
+ $ IINFO )
+ ELSE
+*
+* Use blocked code
+*
+ IF( ( LEFT .AND. NOTRAN ) .OR.
+ $ ( .NOT.LEFT .AND. .NOT.NOTRAN ) ) THEN
+ I1 = 1
+ I2 = K
+ I3 = NB
+ ELSE
+ I1 = ( ( K-1 ) / NB )*NB + 1
+ I2 = 1
+ I3 = -NB
+ END IF
+*
+ IF( LEFT ) THEN
+ NI = N
+ JC = 1
+ ELSE
+ MI = M
+ IC = 1
+ END IF
+*
+ IF( NOTRAN ) THEN
+ TRANST = 'T'
+ ELSE
+ TRANST = 'N'
+ END IF
+*
+ DO 10 I = I1, I2, I3
+ IB = MIN( NB, K-I+1 )
+*
+* Form the triangular factor of the block reflector
+* H = H(i) H(i+1) . . . H(i+ib-1)
+*
+ CALL DLARFT( 'Forward', 'Rowwise', NQ-I+1, IB, A( I, I ),
+ $ LDA, TAU( I ), T, LDT )
+ IF( LEFT ) THEN
+*
+* H or H' is applied to C(i:m,1:n)
+*
+ MI = M - I + 1
+ IC = I
+ ELSE
+*
+* H or H' is applied to C(1:m,i:n)
+*
+ NI = N - I + 1
+ JC = I
+ END IF
+*
+* Apply H or H'
+*
+ CALL DLARFB( SIDE, TRANST, 'Forward', 'Rowwise', MI, NI, IB,
+ $ A( I, I ), LDA, T, LDT, C( IC, JC ), LDC, WORK,
+ $ LDWORK )
+ 10 CONTINUE
+ END IF
+ WORK( 1 ) = LWKOPT
+ RETURN
+*
+* End of DORMLQ
+*
+ END
+ SUBROUTINE DORMQL( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
+ $ WORK, LWORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER SIDE, TRANS
+ INTEGER INFO, K, LDA, LDC, LWORK, M, N
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DORMQL overwrites the general real M-by-N matrix C with
+*
+* SIDE = 'L' SIDE = 'R'
+* TRANS = 'N': Q * C C * Q
+* TRANS = 'T': Q**T * C C * Q**T
+*
+* where Q is a real orthogonal matrix defined as the product of k
+* elementary reflectors
+*
+* Q = H(k) . . . H(2) H(1)
+*
+* as returned by DGEQLF. Q is of order M if SIDE = 'L' and of order N
+* if SIDE = 'R'.
+*
+* Arguments
+* =========
+*
+* SIDE (input) CHARACTER*1
+* = 'L': apply Q or Q**T from the Left;
+* = 'R': apply Q or Q**T from the Right.
+*
+* TRANS (input) CHARACTER*1
+* = 'N': No transpose, apply Q;
+* = 'T': Transpose, apply Q**T.
+*
+* M (input) INTEGER
+* The number of rows of the matrix C. M >= 0.
+*
+* N (input) INTEGER
+* The number of columns of the matrix C. N >= 0.
+*
+* K (input) INTEGER
+* The number of elementary reflectors whose product defines
+* the matrix Q.
+* If SIDE = 'L', M >= K >= 0;
+* if SIDE = 'R', N >= K >= 0.
+*
+* A (input) DOUBLE PRECISION array, dimension (LDA,K)
+* The i-th column must contain the vector which defines the
+* elementary reflector H(i), for i = 1,2,...,k, as returned by
+* DGEQLF in the last k columns of its array argument A.
+* A is modified by the routine but restored on exit.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A.
+* If SIDE = 'L', LDA >= max(1,M);
+* if SIDE = 'R', LDA >= max(1,N).
+*
+* TAU (input) DOUBLE PRECISION array, dimension (K)
+* TAU(i) must contain the scalar factor of the elementary
+* reflector H(i), as returned by DGEQLF.
+*
+* C (input/output) DOUBLE PRECISION array, dimension (LDC,N)
+* On entry, the M-by-N matrix C.
+* On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q.
+*
+* LDC (input) INTEGER
+* The leading dimension of the array C. LDC >= max(1,M).
+*
+* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
+* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+* LWORK (input) INTEGER
+* The dimension of the array WORK.
+* If SIDE = 'L', LWORK >= max(1,N);
+* if SIDE = 'R', LWORK >= max(1,M).
+* For optimum performance LWORK >= N*NB if SIDE = 'L', and
+* LWORK >= M*NB if SIDE = 'R', where NB is the optimal
+* blocksize.
+*
+* If LWORK = -1, then a workspace query is assumed; the routine
+* only calculates the optimal size of the WORK array, returns
+* this value as the first entry of the WORK array, and no error
+* message related to LWORK is issued by XERBLA.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+*
+* =====================================================================
+*
+* .. Parameters ..
+ INTEGER NBMAX, LDT
+ PARAMETER ( NBMAX = 64, LDT = NBMAX+1 )
+* ..
+* .. Local Scalars ..
+ LOGICAL LEFT, LQUERY, NOTRAN
+ INTEGER I, I1, I2, I3, IB, IINFO, IWS, LDWORK, LWKOPT,
+ $ MI, NB, NBMIN, NI, NQ, NW
+* ..
+* .. Local Arrays ..
+ DOUBLE PRECISION T( LDT, NBMAX )
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ILAENV
+ EXTERNAL LSAME, ILAENV
+* ..
+* .. External Subroutines ..
+ EXTERNAL DLARFB, DLARFT, DORM2L, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+* Test the input arguments
+*
+ INFO = 0
+ LEFT = LSAME( SIDE, 'L' )
+ NOTRAN = LSAME( TRANS, 'N' )
+ LQUERY = ( LWORK.EQ.-1 )
+*
+* NQ is the order of Q and NW is the minimum dimension of WORK
+*
+ IF( LEFT ) THEN
+ NQ = M
+ NW = MAX( 1, N )
+ ELSE
+ NQ = N
+ NW = MAX( 1, M )
+ END IF
+ IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN
+ INFO = -1
+ ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN
+ INFO = -2
+ ELSE IF( M.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN
+ INFO = -5
+ ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN
+ INFO = -7
+ ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
+ INFO = -10
+ END IF
+*
+ IF( INFO.EQ.0 ) THEN
+ IF( M.EQ.0 .OR. N.EQ.0 ) THEN
+ LWKOPT = 1
+ ELSE
+*
+* Determine the block size. NB may be at most NBMAX, where
+* NBMAX is used to define the local array T.
+*
+ NB = MIN( NBMAX, ILAENV( 1, 'DORMQL', SIDE // TRANS, M, N,
+ $ K, -1 ) )
+ LWKOPT = NW*NB
+ END IF
+ WORK( 1 ) = LWKOPT
+*
+ IF( LWORK.LT.NW .AND. .NOT.LQUERY ) THEN
+ INFO = -12
+ END IF
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DORMQL', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( M.EQ.0 .OR. N.EQ.0 ) THEN
+ RETURN
+ END IF
+*
+ NBMIN = 2
+ LDWORK = NW
+ IF( NB.GT.1 .AND. NB.LT.K ) THEN
+ IWS = NW*NB
+ IF( LWORK.LT.IWS ) THEN
+ NB = LWORK / LDWORK
+ NBMIN = MAX( 2, ILAENV( 2, 'DORMQL', SIDE // TRANS, M, N, K,
+ $ -1 ) )
+ END IF
+ ELSE
+ IWS = NW
+ END IF
+*
+ IF( NB.LT.NBMIN .OR. NB.GE.K ) THEN
+*
+* Use unblocked code
+*
+ CALL DORM2L( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK,
+ $ IINFO )
+ ELSE
+*
+* Use blocked code
+*
+ IF( ( LEFT .AND. NOTRAN ) .OR.
+ $ ( .NOT.LEFT .AND. .NOT.NOTRAN ) ) THEN
+ I1 = 1
+ I2 = K
+ I3 = NB
+ ELSE
+ I1 = ( ( K-1 ) / NB )*NB + 1
+ I2 = 1
+ I3 = -NB
+ END IF
+*
+ IF( LEFT ) THEN
+ NI = N
+ ELSE
+ MI = M
+ END IF
+*
+ DO 10 I = I1, I2, I3
+ IB = MIN( NB, K-I+1 )
+*
+* Form the triangular factor of the block reflector
+* H = H(i+ib-1) . . . H(i+1) H(i)
+*
+ CALL DLARFT( 'Backward', 'Columnwise', NQ-K+I+IB-1, IB,
+ $ A( 1, I ), LDA, TAU( I ), T, LDT )
+ IF( LEFT ) THEN
+*
+* H or H' is applied to C(1:m-k+i+ib-1,1:n)
+*
+ MI = M - K + I + IB - 1
+ ELSE
+*
+* H or H' is applied to C(1:m,1:n-k+i+ib-1)
+*
+ NI = N - K + I + IB - 1
+ END IF
+*
+* Apply H or H'
+*
+ CALL DLARFB( SIDE, TRANS, 'Backward', 'Columnwise', MI, NI,
+ $ IB, A( 1, I ), LDA, T, LDT, C, LDC, WORK,
+ $ LDWORK )
+ 10 CONTINUE
+ END IF
+ WORK( 1 ) = LWKOPT
+ RETURN
+*
+* End of DORMQL
+*
+ END
+ SUBROUTINE DORMQR( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
+ $ WORK, LWORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER SIDE, TRANS
+ INTEGER INFO, K, LDA, LDC, LWORK, M, N
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DORMQR overwrites the general real M-by-N matrix C with
+*
+* SIDE = 'L' SIDE = 'R'
+* TRANS = 'N': Q * C C * Q
+* TRANS = 'T': Q**T * C C * Q**T
+*
+* where Q is a real orthogonal matrix defined as the product of k
+* elementary reflectors
+*
+* Q = H(1) H(2) . . . H(k)
+*
+* as returned by DGEQRF. Q is of order M if SIDE = 'L' and of order N
+* if SIDE = 'R'.
+*
+* Arguments
+* =========
+*
+* SIDE (input) CHARACTER*1
+* = 'L': apply Q or Q**T from the Left;
+* = 'R': apply Q or Q**T from the Right.
+*
+* TRANS (input) CHARACTER*1
+* = 'N': No transpose, apply Q;
+* = 'T': Transpose, apply Q**T.
+*
+* M (input) INTEGER
+* The number of rows of the matrix C. M >= 0.
+*
+* N (input) INTEGER
+* The number of columns of the matrix C. N >= 0.
+*
+* K (input) INTEGER
+* The number of elementary reflectors whose product defines
+* the matrix Q.
+* If SIDE = 'L', M >= K >= 0;
+* if SIDE = 'R', N >= K >= 0.
+*
+* A (input) DOUBLE PRECISION array, dimension (LDA,K)
+* The i-th column must contain the vector which defines the
+* elementary reflector H(i), for i = 1,2,...,k, as returned by
+* DGEQRF in the first k columns of its array argument A.
+* A is modified by the routine but restored on exit.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A.
+* If SIDE = 'L', LDA >= max(1,M);
+* if SIDE = 'R', LDA >= max(1,N).
+*
+* TAU (input) DOUBLE PRECISION array, dimension (K)
+* TAU(i) must contain the scalar factor of the elementary
+* reflector H(i), as returned by DGEQRF.
+*
+* C (input/output) DOUBLE PRECISION array, dimension (LDC,N)
+* On entry, the M-by-N matrix C.
+* On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q.
+*
+* LDC (input) INTEGER
+* The leading dimension of the array C. LDC >= max(1,M).
+*
+* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
+* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+* LWORK (input) INTEGER
+* The dimension of the array WORK.
+* If SIDE = 'L', LWORK >= max(1,N);
+* if SIDE = 'R', LWORK >= max(1,M).
+* For optimum performance LWORK >= N*NB if SIDE = 'L', and
+* LWORK >= M*NB if SIDE = 'R', where NB is the optimal
+* blocksize.
+*
+* If LWORK = -1, then a workspace query is assumed; the routine
+* only calculates the optimal size of the WORK array, returns
+* this value as the first entry of the WORK array, and no error
+* message related to LWORK is issued by XERBLA.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+*
+* =====================================================================
+*
+* .. Parameters ..
+ INTEGER NBMAX, LDT
+ PARAMETER ( NBMAX = 64, LDT = NBMAX+1 )
+* ..
+* .. Local Scalars ..
+ LOGICAL LEFT, LQUERY, NOTRAN
+ INTEGER I, I1, I2, I3, IB, IC, IINFO, IWS, JC, LDWORK,
+ $ LWKOPT, MI, NB, NBMIN, NI, NQ, NW
+* ..
+* .. Local Arrays ..
+ DOUBLE PRECISION T( LDT, NBMAX )
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ILAENV
+ EXTERNAL LSAME, ILAENV
+* ..
+* .. External Subroutines ..
+ EXTERNAL DLARFB, DLARFT, DORM2R, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+* Test the input arguments
+*
+ INFO = 0
+ LEFT = LSAME( SIDE, 'L' )
+ NOTRAN = LSAME( TRANS, 'N' )
+ LQUERY = ( LWORK.EQ.-1 )
+*
+* NQ is the order of Q and NW is the minimum dimension of WORK
+*
+ IF( LEFT ) THEN
+ NQ = M
+ NW = N
+ ELSE
+ NQ = N
+ NW = M
+ END IF
+ IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN
+ INFO = -1
+ ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN
+ INFO = -2
+ ELSE IF( M.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN
+ INFO = -5
+ ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN
+ INFO = -7
+ ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
+ INFO = -10
+ ELSE IF( LWORK.LT.MAX( 1, NW ) .AND. .NOT.LQUERY ) THEN
+ INFO = -12
+ END IF
+*
+ IF( INFO.EQ.0 ) THEN
+*
+* Determine the block size. NB may be at most NBMAX, where NBMAX
+* is used to define the local array T.
+*
+ NB = MIN( NBMAX, ILAENV( 1, 'DORMQR', SIDE // TRANS, M, N, K,
+ $ -1 ) )
+ LWKOPT = MAX( 1, NW )*NB
+ WORK( 1 ) = LWKOPT
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DORMQR', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) THEN
+ WORK( 1 ) = 1
+ RETURN
+ END IF
+*
+ NBMIN = 2
+ LDWORK = NW
+ IF( NB.GT.1 .AND. NB.LT.K ) THEN
+ IWS = NW*NB
+ IF( LWORK.LT.IWS ) THEN
+ NB = LWORK / LDWORK
+ NBMIN = MAX( 2, ILAENV( 2, 'DORMQR', SIDE // TRANS, M, N, K,
+ $ -1 ) )
+ END IF
+ ELSE
+ IWS = NW
+ END IF
+*
+ IF( NB.LT.NBMIN .OR. NB.GE.K ) THEN
+*
+* Use unblocked code
+*
+ CALL DORM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK,
+ $ IINFO )
+ ELSE
+*
+* Use blocked code
+*
+ IF( ( LEFT .AND. .NOT.NOTRAN ) .OR.
+ $ ( .NOT.LEFT .AND. NOTRAN ) ) THEN
+ I1 = 1
+ I2 = K
+ I3 = NB
+ ELSE
+ I1 = ( ( K-1 ) / NB )*NB + 1
+ I2 = 1
+ I3 = -NB
+ END IF
+*
+ IF( LEFT ) THEN
+ NI = N
+ JC = 1
+ ELSE
+ MI = M
+ IC = 1
+ END IF
+*
+ DO 10 I = I1, I2, I3
+ IB = MIN( NB, K-I+1 )
+*
+* Form the triangular factor of the block reflector
+* H = H(i) H(i+1) . . . H(i+ib-1)
+*
+ CALL DLARFT( 'Forward', 'Columnwise', NQ-I+1, IB, A( I, I ),
+ $ LDA, TAU( I ), T, LDT )
+ IF( LEFT ) THEN
+*
+* H or H' is applied to C(i:m,1:n)
+*
+ MI = M - I + 1
+ IC = I
+ ELSE
+*
+* H or H' is applied to C(1:m,i:n)
+*
+ NI = N - I + 1
+ JC = I
+ END IF
+*
+* Apply H or H'
+*
+ CALL DLARFB( SIDE, TRANS, 'Forward', 'Columnwise', MI, NI,
+ $ IB, A( I, I ), LDA, T, LDT, C( IC, JC ), LDC,
+ $ WORK, LDWORK )
+ 10 CONTINUE
+ END IF
+ WORK( 1 ) = LWKOPT
+ RETURN
+*
+* End of DORMQR
+*
+ END
+ SUBROUTINE DORMR2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
+ $ WORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER SIDE, TRANS
+ INTEGER INFO, K, LDA, LDC, M, N
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DORMR2 overwrites the general real m by n matrix C with
+*
+* Q * C if SIDE = 'L' and TRANS = 'N', or
+*
+* Q'* C if SIDE = 'L' and TRANS = 'T', or
+*
+* C * Q if SIDE = 'R' and TRANS = 'N', or
+*
+* C * Q' if SIDE = 'R' and TRANS = 'T',
+*
+* where Q is a real orthogonal matrix defined as the product of k
+* elementary reflectors
+*
+* Q = H(1) H(2) . . . H(k)
+*
+* as returned by DGERQF. Q is of order m if SIDE = 'L' and of order n
+* if SIDE = 'R'.
+*
+* Arguments
+* =========
+*
+* SIDE (input) CHARACTER*1
+* = 'L': apply Q or Q' from the Left
+* = 'R': apply Q or Q' from the Right
+*
+* TRANS (input) CHARACTER*1
+* = 'N': apply Q (No transpose)
+* = 'T': apply Q' (Transpose)
+*
+* M (input) INTEGER
+* The number of rows of the matrix C. M >= 0.
+*
+* N (input) INTEGER
+* The number of columns of the matrix C. N >= 0.
+*
+* K (input) INTEGER
+* The number of elementary reflectors whose product defines
+* the matrix Q.
+* If SIDE = 'L', M >= K >= 0;
+* if SIDE = 'R', N >= K >= 0.
+*
+* A (input) DOUBLE PRECISION array, dimension
+* (LDA,M) if SIDE = 'L',
+* (LDA,N) if SIDE = 'R'
+* The i-th row must contain the vector which defines the
+* elementary reflector H(i), for i = 1,2,...,k, as returned by
+* DGERQF in the last k rows of its array argument A.
+* A is modified by the routine but restored on exit.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,K).
+*
+* TAU (input) DOUBLE PRECISION array, dimension (K)
+* TAU(i) must contain the scalar factor of the elementary
+* reflector H(i), as returned by DGERQF.
+*
+* C (input/output) DOUBLE PRECISION array, dimension (LDC,N)
+* On entry, the m by n matrix C.
+* On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q.
+*
+* LDC (input) INTEGER
+* The leading dimension of the array C. LDC >= max(1,M).
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension
+* (N) if SIDE = 'L',
+* (M) if SIDE = 'R'
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE
+ PARAMETER ( ONE = 1.0D+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL LEFT, NOTRAN
+ INTEGER I, I1, I2, I3, MI, NI, NQ
+ DOUBLE PRECISION AII
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL DLARF, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input arguments
+*
+ INFO = 0
+ LEFT = LSAME( SIDE, 'L' )
+ NOTRAN = LSAME( TRANS, 'N' )
+*
+* NQ is the order of Q
+*
+ IF( LEFT ) THEN
+ NQ = M
+ ELSE
+ NQ = N
+ END IF
+ IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN
+ INFO = -1
+ ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN
+ INFO = -2
+ ELSE IF( M.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN
+ INFO = -5
+ ELSE IF( LDA.LT.MAX( 1, K ) ) THEN
+ INFO = -7
+ ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
+ INFO = -10
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DORMR2', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 )
+ $ RETURN
+*
+ IF( ( LEFT .AND. .NOT.NOTRAN ) .OR. ( .NOT.LEFT .AND. NOTRAN ) )
+ $ THEN
+ I1 = 1
+ I2 = K
+ I3 = 1
+ ELSE
+ I1 = K
+ I2 = 1
+ I3 = -1
+ END IF
+*
+ IF( LEFT ) THEN
+ NI = N
+ ELSE
+ MI = M
+ END IF
+*
+ DO 10 I = I1, I2, I3
+ IF( LEFT ) THEN
+*
+* H(i) is applied to C(1:m-k+i,1:n)
+*
+ MI = M - K + I
+ ELSE
+*
+* H(i) is applied to C(1:m,1:n-k+i)
+*
+ NI = N - K + I
+ END IF
+*
+* Apply H(i)
+*
+ AII = A( I, NQ-K+I )
+ A( I, NQ-K+I ) = ONE
+ CALL DLARF( SIDE, MI, NI, A( I, 1 ), LDA, TAU( I ), C, LDC,
+ $ WORK )
+ A( I, NQ-K+I ) = AII
+ 10 CONTINUE
+ RETURN
+*
+* End of DORMR2
+*
+ END
+ SUBROUTINE DORMR3( SIDE, TRANS, M, N, K, L, A, LDA, TAU, C, LDC,
+ $ WORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER SIDE, TRANS
+ INTEGER INFO, K, L, LDA, LDC, M, N
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DORMR3 overwrites the general real m by n matrix C with
+*
+* Q * C if SIDE = 'L' and TRANS = 'N', or
+*
+* Q'* C if SIDE = 'L' and TRANS = 'T', or
+*
+* C * Q if SIDE = 'R' and TRANS = 'N', or
+*
+* C * Q' if SIDE = 'R' and TRANS = 'T',
+*
+* where Q is a real orthogonal matrix defined as the product of k
+* elementary reflectors
+*
+* Q = H(1) H(2) . . . H(k)
+*
+* as returned by DTZRZF. Q is of order m if SIDE = 'L' and of order n
+* if SIDE = 'R'.
+*
+* Arguments
+* =========
+*
+* SIDE (input) CHARACTER*1
+* = 'L': apply Q or Q' from the Left
+* = 'R': apply Q or Q' from the Right
+*
+* TRANS (input) CHARACTER*1
+* = 'N': apply Q (No transpose)
+* = 'T': apply Q' (Transpose)
+*
+* M (input) INTEGER
+* The number of rows of the matrix C. M >= 0.
+*
+* N (input) INTEGER
+* The number of columns of the matrix C. N >= 0.
+*
+* K (input) INTEGER
+* The number of elementary reflectors whose product defines
+* the matrix Q.
+* If SIDE = 'L', M >= K >= 0;
+* if SIDE = 'R', N >= K >= 0.
+*
+* L (input) INTEGER
+* The number of columns of the matrix A containing
+* the meaningful part of the Householder reflectors.
+* If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0.
+*
+* A (input) DOUBLE PRECISION array, dimension
+* (LDA,M) if SIDE = 'L',
+* (LDA,N) if SIDE = 'R'
+* The i-th row must contain the vector which defines the
+* elementary reflector H(i), for i = 1,2,...,k, as returned by
+* DTZRZF in the last k rows of its array argument A.
+* A is modified by the routine but restored on exit.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,K).
+*
+* TAU (input) DOUBLE PRECISION array, dimension (K)
+* TAU(i) must contain the scalar factor of the elementary
+* reflector H(i), as returned by DTZRZF.
+*
+* C (input/output) DOUBLE PRECISION array, dimension (LDC,N)
+* On entry, the m-by-n matrix C.
+* On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q.
+*
+* LDC (input) INTEGER
+* The leading dimension of the array C. LDC >= max(1,M).
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension
+* (N) if SIDE = 'L',
+* (M) if SIDE = 'R'
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+*
+* Further Details
+* ===============
+*
+* Based on contributions by
+* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ LOGICAL LEFT, NOTRAN
+ INTEGER I, I1, I2, I3, IC, JA, JC, MI, NI, NQ
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL DLARZ, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input arguments
+*
+ INFO = 0
+ LEFT = LSAME( SIDE, 'L' )
+ NOTRAN = LSAME( TRANS, 'N' )
+*
+* NQ is the order of Q
+*
+ IF( LEFT ) THEN
+ NQ = M
+ ELSE
+ NQ = N
+ END IF
+ IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN
+ INFO = -1
+ ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN
+ INFO = -2
+ ELSE IF( M.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN
+ INFO = -5
+ ELSE IF( L.LT.0 .OR. ( LEFT .AND. ( L.GT.M ) ) .OR.
+ $ ( .NOT.LEFT .AND. ( L.GT.N ) ) ) THEN
+ INFO = -6
+ ELSE IF( LDA.LT.MAX( 1, K ) ) THEN
+ INFO = -8
+ ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
+ INFO = -11
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DORMR3', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 )
+ $ RETURN
+*
+ IF( ( LEFT .AND. .NOT.NOTRAN .OR. .NOT.LEFT .AND. NOTRAN ) ) THEN
+ I1 = 1
+ I2 = K
+ I3 = 1
+ ELSE
+ I1 = K
+ I2 = 1
+ I3 = -1
+ END IF
+*
+ IF( LEFT ) THEN
+ NI = N
+ JA = M - L + 1
+ JC = 1
+ ELSE
+ MI = M
+ JA = N - L + 1
+ IC = 1
+ END IF
+*
+ DO 10 I = I1, I2, I3
+ IF( LEFT ) THEN
+*
+* H(i) or H(i)' is applied to C(i:m,1:n)
+*
+ MI = M - I + 1
+ IC = I
+ ELSE
+*
+* H(i) or H(i)' is applied to C(1:m,i:n)
+*
+ NI = N - I + 1
+ JC = I
+ END IF
+*
+* Apply H(i) or H(i)'
+*
+ CALL DLARZ( SIDE, MI, NI, L, A( I, JA ), LDA, TAU( I ),
+ $ C( IC, JC ), LDC, WORK )
+*
+ 10 CONTINUE
+*
+ RETURN
+*
+* End of DORMR3
+*
+ END
+ SUBROUTINE DORMRQ( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
+ $ WORK, LWORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER SIDE, TRANS
+ INTEGER INFO, K, LDA, LDC, LWORK, M, N
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DORMRQ overwrites the general real M-by-N matrix C with
+*
+* SIDE = 'L' SIDE = 'R'
+* TRANS = 'N': Q * C C * Q
+* TRANS = 'T': Q**T * C C * Q**T
+*
+* where Q is a real orthogonal matrix defined as the product of k
+* elementary reflectors
+*
+* Q = H(1) H(2) . . . H(k)
+*
+* as returned by DGERQF. Q is of order M if SIDE = 'L' and of order N
+* if SIDE = 'R'.
+*
+* Arguments
+* =========
+*
+* SIDE (input) CHARACTER*1
+* = 'L': apply Q or Q**T from the Left;
+* = 'R': apply Q or Q**T from the Right.
+*
+* TRANS (input) CHARACTER*1
+* = 'N': No transpose, apply Q;
+* = 'T': Transpose, apply Q**T.
+*
+* M (input) INTEGER
+* The number of rows of the matrix C. M >= 0.
+*
+* N (input) INTEGER
+* The number of columns of the matrix C. N >= 0.
+*
+* K (input) INTEGER
+* The number of elementary reflectors whose product defines
+* the matrix Q.
+* If SIDE = 'L', M >= K >= 0;
+* if SIDE = 'R', N >= K >= 0.
+*
+* A (input) DOUBLE PRECISION array, dimension
+* (LDA,M) if SIDE = 'L',
+* (LDA,N) if SIDE = 'R'
+* The i-th row must contain the vector which defines the
+* elementary reflector H(i), for i = 1,2,...,k, as returned by
+* DGERQF in the last k rows of its array argument A.
+* A is modified by the routine but restored on exit.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,K).
+*
+* TAU (input) DOUBLE PRECISION array, dimension (K)
+* TAU(i) must contain the scalar factor of the elementary
+* reflector H(i), as returned by DGERQF.
+*
+* C (input/output) DOUBLE PRECISION array, dimension (LDC,N)
+* On entry, the M-by-N matrix C.
+* On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q.
+*
+* LDC (input) INTEGER
+* The leading dimension of the array C. LDC >= max(1,M).
+*
+* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
+* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+* LWORK (input) INTEGER
+* The dimension of the array WORK.
+* If SIDE = 'L', LWORK >= max(1,N);
+* if SIDE = 'R', LWORK >= max(1,M).
+* For optimum performance LWORK >= N*NB if SIDE = 'L', and
+* LWORK >= M*NB if SIDE = 'R', where NB is the optimal
+* blocksize.
+*
+* If LWORK = -1, then a workspace query is assumed; the routine
+* only calculates the optimal size of the WORK array, returns
+* this value as the first entry of the WORK array, and no error
+* message related to LWORK is issued by XERBLA.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+*
+* =====================================================================
+*
+* .. Parameters ..
+ INTEGER NBMAX, LDT
+ PARAMETER ( NBMAX = 64, LDT = NBMAX+1 )
+* ..
+* .. Local Scalars ..
+ LOGICAL LEFT, LQUERY, NOTRAN
+ CHARACTER TRANST
+ INTEGER I, I1, I2, I3, IB, IINFO, IWS, LDWORK, LWKOPT,
+ $ MI, NB, NBMIN, NI, NQ, NW
+* ..
+* .. Local Arrays ..
+ DOUBLE PRECISION T( LDT, NBMAX )
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ILAENV
+ EXTERNAL LSAME, ILAENV
+* ..
+* .. External Subroutines ..
+ EXTERNAL DLARFB, DLARFT, DORMR2, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+* Test the input arguments
+*
+ INFO = 0
+ LEFT = LSAME( SIDE, 'L' )
+ NOTRAN = LSAME( TRANS, 'N' )
+ LQUERY = ( LWORK.EQ.-1 )
+*
+* NQ is the order of Q and NW is the minimum dimension of WORK
+*
+ IF( LEFT ) THEN
+ NQ = M
+ NW = MAX( 1, N )
+ ELSE
+ NQ = N
+ NW = MAX( 1, M )
+ END IF
+ IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN
+ INFO = -1
+ ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN
+ INFO = -2
+ ELSE IF( M.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN
+ INFO = -5
+ ELSE IF( LDA.LT.MAX( 1, K ) ) THEN
+ INFO = -7
+ ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
+ INFO = -10
+ END IF
+*
+ IF( INFO.EQ.0 ) THEN
+ IF( M.EQ.0 .OR. N.EQ.0 ) THEN
+ LWKOPT = 1
+ ELSE
+*
+* Determine the block size. NB may be at most NBMAX, where
+* NBMAX is used to define the local array T.
+*
+ NB = MIN( NBMAX, ILAENV( 1, 'DORMRQ', SIDE // TRANS, M, N,
+ $ K, -1 ) )
+ LWKOPT = NW*NB
+ END IF
+ WORK( 1 ) = LWKOPT
+*
+ IF( LWORK.LT.NW .AND. .NOT.LQUERY ) THEN
+ INFO = -12
+ END IF
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DORMRQ', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( M.EQ.0 .OR. N.EQ.0 ) THEN
+ RETURN
+ END IF
+*
+ NBMIN = 2
+ LDWORK = NW
+ IF( NB.GT.1 .AND. NB.LT.K ) THEN
+ IWS = NW*NB
+ IF( LWORK.LT.IWS ) THEN
+ NB = LWORK / LDWORK
+ NBMIN = MAX( 2, ILAENV( 2, 'DORMRQ', SIDE // TRANS, M, N, K,
+ $ -1 ) )
+ END IF
+ ELSE
+ IWS = NW
+ END IF
+*
+ IF( NB.LT.NBMIN .OR. NB.GE.K ) THEN
+*
+* Use unblocked code
+*
+ CALL DORMR2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK,
+ $ IINFO )
+ ELSE
+*
+* Use blocked code
+*
+ IF( ( LEFT .AND. .NOT.NOTRAN ) .OR.
+ $ ( .NOT.LEFT .AND. NOTRAN ) ) THEN
+ I1 = 1
+ I2 = K
+ I3 = NB
+ ELSE
+ I1 = ( ( K-1 ) / NB )*NB + 1
+ I2 = 1
+ I3 = -NB
+ END IF
+*
+ IF( LEFT ) THEN
+ NI = N
+ ELSE
+ MI = M
+ END IF
+*
+ IF( NOTRAN ) THEN
+ TRANST = 'T'
+ ELSE
+ TRANST = 'N'
+ END IF
+*
+ DO 10 I = I1, I2, I3
+ IB = MIN( NB, K-I+1 )
+*
+* Form the triangular factor of the block reflector
+* H = H(i+ib-1) . . . H(i+1) H(i)
+*
+ CALL DLARFT( 'Backward', 'Rowwise', NQ-K+I+IB-1, IB,
+ $ A( I, 1 ), LDA, TAU( I ), T, LDT )
+ IF( LEFT ) THEN
+*
+* H or H' is applied to C(1:m-k+i+ib-1,1:n)
+*
+ MI = M - K + I + IB - 1
+ ELSE
+*
+* H or H' is applied to C(1:m,1:n-k+i+ib-1)
+*
+ NI = N - K + I + IB - 1
+ END IF
+*
+* Apply H or H'
+*
+ CALL DLARFB( SIDE, TRANST, 'Backward', 'Rowwise', MI, NI,
+ $ IB, A( I, 1 ), LDA, T, LDT, C, LDC, WORK,
+ $ LDWORK )
+ 10 CONTINUE
+ END IF
+ WORK( 1 ) = LWKOPT
+ RETURN
+*
+* End of DORMRQ
+*
+ END
+ SUBROUTINE DORMRZ( SIDE, TRANS, M, N, K, L, A, LDA, TAU, C, LDC,
+ $ WORK, LWORK, INFO )
+*
+* -- LAPACK routine (version 3.1.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* January 2007
+*
+* .. Scalar Arguments ..
+ CHARACTER SIDE, TRANS
+ INTEGER INFO, K, L, LDA, LDC, LWORK, M, N
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DORMRZ overwrites the general real M-by-N matrix C with
+*
+* SIDE = 'L' SIDE = 'R'
+* TRANS = 'N': Q * C C * Q
+* TRANS = 'T': Q**T * C C * Q**T
+*
+* where Q is a real orthogonal matrix defined as the product of k
+* elementary reflectors
+*
+* Q = H(1) H(2) . . . H(k)
+*
+* as returned by DTZRZF. Q is of order M if SIDE = 'L' and of order N
+* if SIDE = 'R'.
+*
+* Arguments
+* =========
+*
+* SIDE (input) CHARACTER*1
+* = 'L': apply Q or Q**T from the Left;
+* = 'R': apply Q or Q**T from the Right.
+*
+* TRANS (input) CHARACTER*1
+* = 'N': No transpose, apply Q;
+* = 'T': Transpose, apply Q**T.
+*
+* M (input) INTEGER
+* The number of rows of the matrix C. M >= 0.
+*
+* N (input) INTEGER
+* The number of columns of the matrix C. N >= 0.
+*
+* K (input) INTEGER
+* The number of elementary reflectors whose product defines
+* the matrix Q.
+* If SIDE = 'L', M >= K >= 0;
+* if SIDE = 'R', N >= K >= 0.
+*
+* L (input) INTEGER
+* The number of columns of the matrix A containing
+* the meaningful part of the Householder reflectors.
+* If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0.
+*
+* A (input) DOUBLE PRECISION array, dimension
+* (LDA,M) if SIDE = 'L',
+* (LDA,N) if SIDE = 'R'
+* The i-th row must contain the vector which defines the
+* elementary reflector H(i), for i = 1,2,...,k, as returned by
+* DTZRZF in the last k rows of its array argument A.
+* A is modified by the routine but restored on exit.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,K).
+*
+* TAU (input) DOUBLE PRECISION array, dimension (K)
+* TAU(i) must contain the scalar factor of the elementary
+* reflector H(i), as returned by DTZRZF.
+*
+* C (input/output) DOUBLE PRECISION array, dimension (LDC,N)
+* On entry, the M-by-N matrix C.
+* On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q.
+*
+* LDC (input) INTEGER
+* The leading dimension of the array C. LDC >= max(1,M).
+*
+* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
+* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+* LWORK (input) INTEGER
+* The dimension of the array WORK.
+* If SIDE = 'L', LWORK >= max(1,N);
+* if SIDE = 'R', LWORK >= max(1,M).
+* For optimum performance LWORK >= N*NB if SIDE = 'L', and
+* LWORK >= M*NB if SIDE = 'R', where NB is the optimal
+* blocksize.
+*
+* If LWORK = -1, then a workspace query is assumed; the routine
+* only calculates the optimal size of the WORK array, returns
+* this value as the first entry of the WORK array, and no error
+* message related to LWORK is issued by XERBLA.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+*
+* Further Details
+* ===============
+*
+* Based on contributions by
+* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA
+*
+* =====================================================================
+*
+* .. Parameters ..
+ INTEGER NBMAX, LDT
+ PARAMETER ( NBMAX = 64, LDT = NBMAX+1 )
+* ..
+* .. Local Scalars ..
+ LOGICAL LEFT, LQUERY, NOTRAN
+ CHARACTER TRANST
+ INTEGER I, I1, I2, I3, IB, IC, IINFO, IWS, JA, JC,
+ $ LDWORK, LWKOPT, MI, NB, NBMIN, NI, NQ, NW
+* ..
+* .. Local Arrays ..
+ DOUBLE PRECISION T( LDT, NBMAX )
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ILAENV
+ EXTERNAL LSAME, ILAENV
+* ..
+* .. External Subroutines ..
+ EXTERNAL DLARZB, DLARZT, DORMR3, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+* Test the input arguments
+*
+ INFO = 0
+ LEFT = LSAME( SIDE, 'L' )
+ NOTRAN = LSAME( TRANS, 'N' )
+ LQUERY = ( LWORK.EQ.-1 )
+*
+* NQ is the order of Q and NW is the minimum dimension of WORK
+*
+ IF( LEFT ) THEN
+ NQ = M
+ NW = MAX( 1, N )
+ ELSE
+ NQ = N
+ NW = MAX( 1, M )
+ END IF
+ IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN
+ INFO = -1
+ ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN
+ INFO = -2
+ ELSE IF( M.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN
+ INFO = -5
+ ELSE IF( L.LT.0 .OR. ( LEFT .AND. ( L.GT.M ) ) .OR.
+ $ ( .NOT.LEFT .AND. ( L.GT.N ) ) ) THEN
+ INFO = -6
+ ELSE IF( LDA.LT.MAX( 1, K ) ) THEN
+ INFO = -8
+ ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
+ INFO = -11
+ END IF
+*
+ IF( INFO.EQ.0 ) THEN
+ IF( M.EQ.0 .OR. N.EQ.0 ) THEN
+ LWKOPT = 1
+ ELSE
+*
+* Determine the block size. NB may be at most NBMAX, where
+* NBMAX is used to define the local array T.
+*
+ NB = MIN( NBMAX, ILAENV( 1, 'DORMRQ', SIDE // TRANS, M, N,
+ $ K, -1 ) )
+ LWKOPT = NW*NB
+ END IF
+ WORK( 1 ) = LWKOPT
+*
+ IF( LWORK.LT.MAX( 1, NW ) .AND. .NOT.LQUERY ) THEN
+ INFO = -13
+ END IF
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DORMRZ', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( M.EQ.0 .OR. N.EQ.0 ) THEN
+ WORK( 1 ) = 1
+ RETURN
+ END IF
+*
+ NBMIN = 2
+ LDWORK = NW
+ IF( NB.GT.1 .AND. NB.LT.K ) THEN
+ IWS = NW*NB
+ IF( LWORK.LT.IWS ) THEN
+ NB = LWORK / LDWORK
+ NBMIN = MAX( 2, ILAENV( 2, 'DORMRQ', SIDE // TRANS, M, N, K,
+ $ -1 ) )
+ END IF
+ ELSE
+ IWS = NW
+ END IF
+*
+ IF( NB.LT.NBMIN .OR. NB.GE.K ) THEN
+*
+* Use unblocked code
+*
+ CALL DORMR3( SIDE, TRANS, M, N, K, L, A, LDA, TAU, C, LDC,
+ $ WORK, IINFO )
+ ELSE
+*
+* Use blocked code
+*
+ IF( ( LEFT .AND. .NOT.NOTRAN ) .OR.
+ $ ( .NOT.LEFT .AND. NOTRAN ) ) THEN
+ I1 = 1
+ I2 = K
+ I3 = NB
+ ELSE
+ I1 = ( ( K-1 ) / NB )*NB + 1
+ I2 = 1
+ I3 = -NB
+ END IF
+*
+ IF( LEFT ) THEN
+ NI = N
+ JC = 1
+ JA = M - L + 1
+ ELSE
+ MI = M
+ IC = 1
+ JA = N - L + 1
+ END IF
+*
+ IF( NOTRAN ) THEN
+ TRANST = 'T'
+ ELSE
+ TRANST = 'N'
+ END IF
+*
+ DO 10 I = I1, I2, I3
+ IB = MIN( NB, K-I+1 )
+*
+* Form the triangular factor of the block reflector
+* H = H(i+ib-1) . . . H(i+1) H(i)
+*
+ CALL DLARZT( 'Backward', 'Rowwise', L, IB, A( I, JA ), LDA,
+ $ TAU( I ), T, LDT )
+*
+ IF( LEFT ) THEN
+*
+* H or H' is applied to C(i:m,1:n)
+*
+ MI = M - I + 1
+ IC = I
+ ELSE
+*
+* H or H' is applied to C(1:m,i:n)
+*
+ NI = N - I + 1
+ JC = I
+ END IF
+*
+* Apply H or H'
+*
+ CALL DLARZB( SIDE, TRANST, 'Backward', 'Rowwise', MI, NI,
+ $ IB, L, A( I, JA ), LDA, T, LDT, C( IC, JC ),
+ $ LDC, WORK, LDWORK )
+ 10 CONTINUE
+*
+ END IF
+*
+ WORK( 1 ) = LWKOPT
+*
+ RETURN
+*
+* End of DORMRZ
+*
+ END
+ SUBROUTINE DORMTR( SIDE, UPLO, TRANS, M, N, A, LDA, TAU, C, LDC,
+ $ WORK, LWORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER SIDE, TRANS, UPLO
+ INTEGER INFO, LDA, LDC, LWORK, M, N
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DORMTR overwrites the general real M-by-N matrix C with
+*
+* SIDE = 'L' SIDE = 'R'
+* TRANS = 'N': Q * C C * Q
+* TRANS = 'T': Q**T * C C * Q**T
+*
+* where Q is a real orthogonal matrix of order nq, with nq = m if
+* SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of
+* nq-1 elementary reflectors, as returned by DSYTRD:
+*
+* if UPLO = 'U', Q = H(nq-1) . . . H(2) H(1);
+*
+* if UPLO = 'L', Q = H(1) H(2) . . . H(nq-1).
+*
+* Arguments
+* =========
+*
+* SIDE (input) CHARACTER*1
+* = 'L': apply Q or Q**T from the Left;
+* = 'R': apply Q or Q**T from the Right.
+*
+* UPLO (input) CHARACTER*1
+* = 'U': Upper triangle of A contains elementary reflectors
+* from DSYTRD;
+* = 'L': Lower triangle of A contains elementary reflectors
+* from DSYTRD.
+*
+* TRANS (input) CHARACTER*1
+* = 'N': No transpose, apply Q;
+* = 'T': Transpose, apply Q**T.
+*
+* M (input) INTEGER
+* The number of rows of the matrix C. M >= 0.
+*
+* N (input) INTEGER
+* The number of columns of the matrix C. N >= 0.
+*
+* A (input) DOUBLE PRECISION array, dimension
+* (LDA,M) if SIDE = 'L'
+* (LDA,N) if SIDE = 'R'
+* The vectors which define the elementary reflectors, as
+* returned by DSYTRD.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A.
+* LDA >= max(1,M) if SIDE = 'L'; LDA >= max(1,N) if SIDE = 'R'.
+*
+* TAU (input) DOUBLE PRECISION array, dimension
+* (M-1) if SIDE = 'L'
+* (N-1) if SIDE = 'R'
+* TAU(i) must contain the scalar factor of the elementary
+* reflector H(i), as returned by DSYTRD.
+*
+* C (input/output) DOUBLE PRECISION array, dimension (LDC,N)
+* On entry, the M-by-N matrix C.
+* On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q.
+*
+* LDC (input) INTEGER
+* The leading dimension of the array C. LDC >= max(1,M).
+*
+* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
+* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+* LWORK (input) INTEGER
+* The dimension of the array WORK.
+* If SIDE = 'L', LWORK >= max(1,N);
+* if SIDE = 'R', LWORK >= max(1,M).
+* For optimum performance LWORK >= N*NB if SIDE = 'L', and
+* LWORK >= M*NB if SIDE = 'R', where NB is the optimal
+* blocksize.
+*
+* If LWORK = -1, then a workspace query is assumed; the routine
+* only calculates the optimal size of the WORK array, returns
+* this value as the first entry of the WORK array, and no error
+* message related to LWORK is issued by XERBLA.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ LOGICAL LEFT, LQUERY, UPPER
+ INTEGER I1, I2, IINFO, LWKOPT, MI, NB, NI, NQ, NW
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ILAENV
+ EXTERNAL LSAME, ILAENV
+* ..
+* .. External Subroutines ..
+ EXTERNAL DORMQL, DORMQR, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input arguments
+*
+ INFO = 0
+ LEFT = LSAME( SIDE, 'L' )
+ UPPER = LSAME( UPLO, 'U' )
+ LQUERY = ( LWORK.EQ.-1 )
+*
+* NQ is the order of Q and NW is the minimum dimension of WORK
+*
+ IF( LEFT ) THEN
+ NQ = M
+ NW = N
+ ELSE
+ NQ = N
+ NW = M
+ END IF
+ IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN
+ INFO = -1
+ ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -2
+ ELSE IF( .NOT.LSAME( TRANS, 'N' ) .AND. .NOT.LSAME( TRANS, 'T' ) )
+ $ THEN
+ INFO = -3
+ ELSE IF( M.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -5
+ ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN
+ INFO = -7
+ ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
+ INFO = -10
+ ELSE IF( LWORK.LT.MAX( 1, NW ) .AND. .NOT.LQUERY ) THEN
+ INFO = -12
+ END IF
+*
+ IF( INFO.EQ.0 ) THEN
+ IF( UPPER ) THEN
+ IF( LEFT ) THEN
+ NB = ILAENV( 1, 'DORMQL', SIDE // TRANS, M-1, N, M-1,
+ $ -1 )
+ ELSE
+ NB = ILAENV( 1, 'DORMQL', SIDE // TRANS, M, N-1, N-1,
+ $ -1 )
+ END IF
+ ELSE
+ IF( LEFT ) THEN
+ NB = ILAENV( 1, 'DORMQR', SIDE // TRANS, M-1, N, M-1,
+ $ -1 )
+ ELSE
+ NB = ILAENV( 1, 'DORMQR', SIDE // TRANS, M, N-1, N-1,
+ $ -1 )
+ END IF
+ END IF
+ LWKOPT = MAX( 1, NW )*NB
+ WORK( 1 ) = LWKOPT
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DORMTR', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( M.EQ.0 .OR. N.EQ.0 .OR. NQ.EQ.1 ) THEN
+ WORK( 1 ) = 1
+ RETURN
+ END IF
+*
+ IF( LEFT ) THEN
+ MI = M - 1
+ NI = N
+ ELSE
+ MI = M
+ NI = N - 1
+ END IF
+*
+ IF( UPPER ) THEN
+*
+* Q was determined by a call to DSYTRD with UPLO = 'U'
+*
+ CALL DORMQL( SIDE, TRANS, MI, NI, NQ-1, A( 1, 2 ), LDA, TAU, C,
+ $ LDC, WORK, LWORK, IINFO )
+ ELSE
+*
+* Q was determined by a call to DSYTRD with UPLO = 'L'
+*
+ IF( LEFT ) THEN
+ I1 = 2
+ I2 = 1
+ ELSE
+ I1 = 1
+ I2 = 2
+ END IF
+ CALL DORMQR( SIDE, TRANS, MI, NI, NQ-1, A( 2, 1 ), LDA, TAU,
+ $ C( I1, I2 ), LDC, WORK, LWORK, IINFO )
+ END IF
+ WORK( 1 ) = LWKOPT
+ RETURN
+*
+* End of DORMTR
+*
+ END
+ SUBROUTINE DPBCON( UPLO, N, KD, AB, LDAB, ANORM, RCOND, WORK,
+ $ IWORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH.
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, KD, LDAB, N
+ DOUBLE PRECISION ANORM, RCOND
+* ..
+* .. Array Arguments ..
+ INTEGER IWORK( * )
+ DOUBLE PRECISION AB( LDAB, * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DPBCON estimates the reciprocal of the condition number (in the
+* 1-norm) of a real symmetric positive definite band matrix using the
+* Cholesky factorization A = U**T*U or A = L*L**T computed by DPBTRF.
+*
+* An estimate is obtained for norm(inv(A)), and the reciprocal of the
+* condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).
+*
+* Arguments
+* =========
+*
+* UPLO (input) CHARACTER*1
+* = 'U': Upper triangular factor stored in AB;
+* = 'L': Lower triangular factor stored in AB.
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* KD (input) INTEGER
+* The number of superdiagonals of the matrix A if UPLO = 'U',
+* or the number of subdiagonals if UPLO = 'L'. KD >= 0.
+*
+* AB (input) DOUBLE PRECISION array, dimension (LDAB,N)
+* The triangular factor U or L from the Cholesky factorization
+* A = U**T*U or A = L*L**T of the band matrix A, stored in the
+* first KD+1 rows of the array. The j-th column of U or L is
+* stored in the j-th column of the array AB as follows:
+* if UPLO ='U', AB(kd+1+i-j,j) = U(i,j) for max(1,j-kd)<=i<=j;
+* if UPLO ='L', AB(1+i-j,j) = L(i,j) for j<=i<=min(n,j+kd).
+*
+* LDAB (input) INTEGER
+* The leading dimension of the array AB. LDAB >= KD+1.
+*
+* ANORM (input) DOUBLE PRECISION
+* The 1-norm (or infinity-norm) of the symmetric band matrix A.
+*
+* RCOND (output) DOUBLE PRECISION
+* The reciprocal of the condition number of the matrix A,
+* computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an
+* estimate of the 1-norm of inv(A) computed in this routine.
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (3*N)
+*
+* IWORK (workspace) INTEGER array, dimension (N)
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE, ZERO
+ PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL UPPER
+ CHARACTER NORMIN
+ INTEGER IX, KASE
+ DOUBLE PRECISION AINVNM, SCALE, SCALEL, SCALEU, SMLNUM
+* ..
+* .. Local Arrays ..
+ INTEGER ISAVE( 3 )
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER IDAMAX
+ DOUBLE PRECISION DLAMCH
+ EXTERNAL LSAME, IDAMAX, DLAMCH
+* ..
+* .. External Subroutines ..
+ EXTERNAL DLACN2, DLATBS, DRSCL, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( KD.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( LDAB.LT.KD+1 ) THEN
+ INFO = -5
+ ELSE IF( ANORM.LT.ZERO ) THEN
+ INFO = -6
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DPBCON', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ RCOND = ZERO
+ IF( N.EQ.0 ) THEN
+ RCOND = ONE
+ RETURN
+ ELSE IF( ANORM.EQ.ZERO ) THEN
+ RETURN
+ END IF
+*
+ SMLNUM = DLAMCH( 'Safe minimum' )
+*
+* Estimate the 1-norm of the inverse.
+*
+ KASE = 0
+ NORMIN = 'N'
+ 10 CONTINUE
+ CALL DLACN2( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE, ISAVE )
+ IF( KASE.NE.0 ) THEN
+ IF( UPPER ) THEN
+*
+* Multiply by inv(U').
+*
+ CALL DLATBS( 'Upper', 'Transpose', 'Non-unit', NORMIN, N,
+ $ KD, AB, LDAB, WORK, SCALEL, WORK( 2*N+1 ),
+ $ INFO )
+ NORMIN = 'Y'
+*
+* Multiply by inv(U).
+*
+ CALL DLATBS( 'Upper', 'No transpose', 'Non-unit', NORMIN, N,
+ $ KD, AB, LDAB, WORK, SCALEU, WORK( 2*N+1 ),
+ $ INFO )
+ ELSE
+*
+* Multiply by inv(L).
+*
+ CALL DLATBS( 'Lower', 'No transpose', 'Non-unit', NORMIN, N,
+ $ KD, AB, LDAB, WORK, SCALEL, WORK( 2*N+1 ),
+ $ INFO )
+ NORMIN = 'Y'
+*
+* Multiply by inv(L').
+*
+ CALL DLATBS( 'Lower', 'Transpose', 'Non-unit', NORMIN, N,
+ $ KD, AB, LDAB, WORK, SCALEU, WORK( 2*N+1 ),
+ $ INFO )
+ END IF
+*
+* Multiply by 1/SCALE if doing so will not cause overflow.
+*
+ SCALE = SCALEL*SCALEU
+ IF( SCALE.NE.ONE ) THEN
+ IX = IDAMAX( N, WORK, 1 )
+ IF( SCALE.LT.ABS( WORK( IX ) )*SMLNUM .OR. SCALE.EQ.ZERO )
+ $ GO TO 20
+ CALL DRSCL( N, SCALE, WORK, 1 )
+ END IF
+ GO TO 10
+ END IF
+*
+* Compute the estimate of the reciprocal condition number.
+*
+ IF( AINVNM.NE.ZERO )
+ $ RCOND = ( ONE / AINVNM ) / ANORM
+*
+ 20 CONTINUE
+*
+ RETURN
+*
+* End of DPBCON
+*
+ END
+ SUBROUTINE DPBEQU( UPLO, N, KD, AB, LDAB, S, SCOND, AMAX, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, KD, LDAB, N
+ DOUBLE PRECISION AMAX, SCOND
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION AB( LDAB, * ), S( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DPBEQU computes row and column scalings intended to equilibrate a
+* symmetric positive definite band matrix A and reduce its condition
+* number (with respect to the two-norm). S contains the scale factors,
+* S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with
+* elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This
+* choice of S puts the condition number of B within a factor N of the
+* smallest possible condition number over all possible diagonal
+* scalings.
+*
+* Arguments
+* =========
+*
+* UPLO (input) CHARACTER*1
+* = 'U': Upper triangular of A is stored;
+* = 'L': Lower triangular of A is stored.
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* KD (input) INTEGER
+* The number of superdiagonals of the matrix A if UPLO = 'U',
+* or the number of subdiagonals if UPLO = 'L'. KD >= 0.
+*
+* AB (input) DOUBLE PRECISION array, dimension (LDAB,N)
+* The upper or lower triangle of the symmetric band matrix A,
+* stored in the first KD+1 rows of the array. The j-th column
+* of A is stored in the j-th column of the array AB as follows:
+* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
+* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).
+*
+* LDAB (input) INTEGER
+* The leading dimension of the array A. LDAB >= KD+1.
+*
+* S (output) DOUBLE PRECISION array, dimension (N)
+* If INFO = 0, S contains the scale factors for A.
+*
+* SCOND (output) DOUBLE PRECISION
+* If INFO = 0, S contains the ratio of the smallest S(i) to
+* the largest S(i). If SCOND >= 0.1 and AMAX is neither too
+* large nor too small, it is not worth scaling by S.
+*
+* AMAX (output) DOUBLE PRECISION
+* Absolute value of largest matrix element. If AMAX is very
+* close to overflow or very close to underflow, the matrix
+* should be scaled.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value.
+* > 0: if INFO = i, the i-th diagonal element is nonpositive.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL UPPER
+ INTEGER I, J
+ DOUBLE PRECISION SMIN
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN, SQRT
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( KD.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( LDAB.LT.KD+1 ) THEN
+ INFO = -5
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DPBEQU', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 ) THEN
+ SCOND = ONE
+ AMAX = ZERO
+ RETURN
+ END IF
+*
+ IF( UPPER ) THEN
+ J = KD + 1
+ ELSE
+ J = 1
+ END IF
+*
+* Initialize SMIN and AMAX.
+*
+ S( 1 ) = AB( J, 1 )
+ SMIN = S( 1 )
+ AMAX = S( 1 )
+*
+* Find the minimum and maximum diagonal elements.
+*
+ DO 10 I = 2, N
+ S( I ) = AB( J, I )
+ SMIN = MIN( SMIN, S( I ) )
+ AMAX = MAX( AMAX, S( I ) )
+ 10 CONTINUE
+*
+ IF( SMIN.LE.ZERO ) THEN
+*
+* Find the first non-positive diagonal element and return.
+*
+ DO 20 I = 1, N
+ IF( S( I ).LE.ZERO ) THEN
+ INFO = I
+ RETURN
+ END IF
+ 20 CONTINUE
+ ELSE
+*
+* Set the scale factors to the reciprocals
+* of the diagonal elements.
+*
+ DO 30 I = 1, N
+ S( I ) = ONE / SQRT( S( I ) )
+ 30 CONTINUE
+*
+* Compute SCOND = min(S(I)) / max(S(I))
+*
+ SCOND = SQRT( SMIN ) / SQRT( AMAX )
+ END IF
+ RETURN
+*
+* End of DPBEQU
+*
+ END
+ SUBROUTINE DPBRFS( UPLO, N, KD, NRHS, AB, LDAB, AFB, LDAFB, B,
+ $ LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH.
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, KD, LDAB, LDAFB, LDB, LDX, N, NRHS
+* ..
+* .. Array Arguments ..
+ INTEGER IWORK( * )
+ DOUBLE PRECISION AB( LDAB, * ), AFB( LDAFB, * ), B( LDB, * ),
+ $ BERR( * ), FERR( * ), WORK( * ), X( LDX, * )
+* ..
+*
+* Purpose
+* =======
+*
+* DPBRFS improves the computed solution to a system of linear
+* equations when the coefficient matrix is symmetric positive definite
+* and banded, and provides error bounds and backward error estimates
+* for the solution.
+*
+* Arguments
+* =========
+*
+* UPLO (input) CHARACTER*1
+* = 'U': Upper triangle of A is stored;
+* = 'L': Lower triangle of A is stored.
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* KD (input) INTEGER
+* The number of superdiagonals of the matrix A if UPLO = 'U',
+* or the number of subdiagonals if UPLO = 'L'. KD >= 0.
+*
+* NRHS (input) INTEGER
+* The number of right hand sides, i.e., the number of columns
+* of the matrices B and X. NRHS >= 0.
+*
+* AB (input) DOUBLE PRECISION array, dimension (LDAB,N)
+* The upper or lower triangle of the symmetric band matrix A,
+* stored in the first KD+1 rows of the array. The j-th column
+* of A is stored in the j-th column of the array AB as follows:
+* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
+* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).
+*
+* LDAB (input) INTEGER
+* The leading dimension of the array AB. LDAB >= KD+1.
+*
+* AFB (input) DOUBLE PRECISION array, dimension (LDAFB,N)
+* The triangular factor U or L from the Cholesky factorization
+* A = U**T*U or A = L*L**T of the band matrix A as computed by
+* DPBTRF, in the same storage format as A (see AB).
+*
+* LDAFB (input) INTEGER
+* The leading dimension of the array AFB. LDAFB >= KD+1.
+*
+* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS)
+* The right hand side matrix B.
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. LDB >= max(1,N).
+*
+* X (input/output) DOUBLE PRECISION array, dimension (LDX,NRHS)
+* On entry, the solution matrix X, as computed by DPBTRS.
+* On exit, the improved solution matrix X.
+*
+* LDX (input) INTEGER
+* The leading dimension of the array X. LDX >= max(1,N).
+*
+* FERR (output) DOUBLE PRECISION array, dimension (NRHS)
+* The estimated forward error bound for each solution vector
+* X(j) (the j-th column of the solution matrix X).
+* If XTRUE is the true solution corresponding to X(j), FERR(j)
+* is an estimated upper bound for the magnitude of the largest
+* element in (X(j) - XTRUE) divided by the magnitude of the
+* largest element in X(j). The estimate is as reliable as
+* the estimate for RCOND, and is almost always a slight
+* overestimate of the true error.
+*
+* BERR (output) DOUBLE PRECISION array, dimension (NRHS)
+* The componentwise relative backward error of each solution
+* vector X(j) (i.e., the smallest relative change in
+* any element of A or B that makes X(j) an exact solution).
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (3*N)
+*
+* IWORK (workspace) INTEGER array, dimension (N)
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+*
+* Internal Parameters
+* ===================
+*
+* ITMAX is the maximum number of steps of iterative refinement.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ INTEGER ITMAX
+ PARAMETER ( ITMAX = 5 )
+ DOUBLE PRECISION ZERO
+ PARAMETER ( ZERO = 0.0D+0 )
+ DOUBLE PRECISION ONE
+ PARAMETER ( ONE = 1.0D+0 )
+ DOUBLE PRECISION TWO
+ PARAMETER ( TWO = 2.0D+0 )
+ DOUBLE PRECISION THREE
+ PARAMETER ( THREE = 3.0D+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL UPPER
+ INTEGER COUNT, I, J, K, KASE, L, NZ
+ DOUBLE PRECISION EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK
+* ..
+* .. Local Arrays ..
+ INTEGER ISAVE( 3 )
+* ..
+* .. External Subroutines ..
+ EXTERNAL DAXPY, DCOPY, DLACN2, DPBTRS, DSBMV, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, MIN
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ DOUBLE PRECISION DLAMCH
+ EXTERNAL LSAME, DLAMCH
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( KD.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( NRHS.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( LDAB.LT.KD+1 ) THEN
+ INFO = -6
+ ELSE IF( LDAFB.LT.KD+1 ) THEN
+ INFO = -8
+ ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -10
+ ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
+ INFO = -12
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DPBRFS', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN
+ DO 10 J = 1, NRHS
+ FERR( J ) = ZERO
+ BERR( J ) = ZERO
+ 10 CONTINUE
+ RETURN
+ END IF
+*
+* NZ = maximum number of nonzero elements in each row of A, plus 1
+*
+ NZ = MIN( N+1, 2*KD+2 )
+ EPS = DLAMCH( 'Epsilon' )
+ SAFMIN = DLAMCH( 'Safe minimum' )
+ SAFE1 = NZ*SAFMIN
+ SAFE2 = SAFE1 / EPS
+*
+* Do for each right hand side
+*
+ DO 140 J = 1, NRHS
+*
+ COUNT = 1
+ LSTRES = THREE
+ 20 CONTINUE
+*
+* Loop until stopping criterion is satisfied.
+*
+* Compute residual R = B - A * X
+*
+ CALL DCOPY( N, B( 1, J ), 1, WORK( N+1 ), 1 )
+ CALL DSBMV( UPLO, N, KD, -ONE, AB, LDAB, X( 1, J ), 1, ONE,
+ $ WORK( N+1 ), 1 )
+*
+* Compute componentwise relative backward error from formula
+*
+* max(i) ( abs(R(i)) / ( abs(A)*abs(X) + abs(B) )(i) )
+*
+* where abs(Z) is the componentwise absolute value of the matrix
+* or vector Z. If the i-th component of the denominator is less
+* than SAFE2, then SAFE1 is added to the i-th components of the
+* numerator and denominator before dividing.
+*
+ DO 30 I = 1, N
+ WORK( I ) = ABS( B( I, J ) )
+ 30 CONTINUE
+*
+* Compute abs(A)*abs(X) + abs(B).
+*
+ IF( UPPER ) THEN
+ DO 50 K = 1, N
+ S = ZERO
+ XK = ABS( X( K, J ) )
+ L = KD + 1 - K
+ DO 40 I = MAX( 1, K-KD ), K - 1
+ WORK( I ) = WORK( I ) + ABS( AB( L+I, K ) )*XK
+ S = S + ABS( AB( L+I, K ) )*ABS( X( I, J ) )
+ 40 CONTINUE
+ WORK( K ) = WORK( K ) + ABS( AB( KD+1, K ) )*XK + S
+ 50 CONTINUE
+ ELSE
+ DO 70 K = 1, N
+ S = ZERO
+ XK = ABS( X( K, J ) )
+ WORK( K ) = WORK( K ) + ABS( AB( 1, K ) )*XK
+ L = 1 - K
+ DO 60 I = K + 1, MIN( N, K+KD )
+ WORK( I ) = WORK( I ) + ABS( AB( L+I, K ) )*XK
+ S = S + ABS( AB( L+I, K ) )*ABS( X( I, J ) )
+ 60 CONTINUE
+ WORK( K ) = WORK( K ) + S
+ 70 CONTINUE
+ END IF
+ S = ZERO
+ DO 80 I = 1, N
+ IF( WORK( I ).GT.SAFE2 ) THEN
+ S = MAX( S, ABS( WORK( N+I ) ) / WORK( I ) )
+ ELSE
+ S = MAX( S, ( ABS( WORK( N+I ) )+SAFE1 ) /
+ $ ( WORK( I )+SAFE1 ) )
+ END IF
+ 80 CONTINUE
+ BERR( J ) = S
+*
+* Test stopping criterion. Continue iterating if
+* 1) The residual BERR(J) is larger than machine epsilon, and
+* 2) BERR(J) decreased by at least a factor of 2 during the
+* last iteration, and
+* 3) At most ITMAX iterations tried.
+*
+ IF( BERR( J ).GT.EPS .AND. TWO*BERR( J ).LE.LSTRES .AND.
+ $ COUNT.LE.ITMAX ) THEN
+*
+* Update solution and try again.
+*
+ CALL DPBTRS( UPLO, N, KD, 1, AFB, LDAFB, WORK( N+1 ), N,
+ $ INFO )
+ CALL DAXPY( N, ONE, WORK( N+1 ), 1, X( 1, J ), 1 )
+ LSTRES = BERR( J )
+ COUNT = COUNT + 1
+ GO TO 20
+ END IF
+*
+* Bound error from formula
+*
+* norm(X - XTRUE) / norm(X) .le. FERR =
+* norm( abs(inv(A))*
+* ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X)
+*
+* where
+* norm(Z) is the magnitude of the largest component of Z
+* inv(A) is the inverse of A
+* abs(Z) is the componentwise absolute value of the matrix or
+* vector Z
+* NZ is the maximum number of nonzeros in any row of A, plus 1
+* EPS is machine epsilon
+*
+* The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B))
+* is incremented by SAFE1 if the i-th component of
+* abs(A)*abs(X) + abs(B) is less than SAFE2.
+*
+* Use DLACN2 to estimate the infinity-norm of the matrix
+* inv(A) * diag(W),
+* where W = abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) )))
+*
+ DO 90 I = 1, N
+ IF( WORK( I ).GT.SAFE2 ) THEN
+ WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I )
+ ELSE
+ WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I ) + SAFE1
+ END IF
+ 90 CONTINUE
+*
+ KASE = 0
+ 100 CONTINUE
+ CALL DLACN2( N, WORK( 2*N+1 ), WORK( N+1 ), IWORK, FERR( J ),
+ $ KASE, ISAVE )
+ IF( KASE.NE.0 ) THEN
+ IF( KASE.EQ.1 ) THEN
+*
+* Multiply by diag(W)*inv(A').
+*
+ CALL DPBTRS( UPLO, N, KD, 1, AFB, LDAFB, WORK( N+1 ), N,
+ $ INFO )
+ DO 110 I = 1, N
+ WORK( N+I ) = WORK( N+I )*WORK( I )
+ 110 CONTINUE
+ ELSE IF( KASE.EQ.2 ) THEN
+*
+* Multiply by inv(A)*diag(W).
+*
+ DO 120 I = 1, N
+ WORK( N+I ) = WORK( N+I )*WORK( I )
+ 120 CONTINUE
+ CALL DPBTRS( UPLO, N, KD, 1, AFB, LDAFB, WORK( N+1 ), N,
+ $ INFO )
+ END IF
+ GO TO 100
+ END IF
+*
+* Normalize error.
+*
+ LSTRES = ZERO
+ DO 130 I = 1, N
+ LSTRES = MAX( LSTRES, ABS( X( I, J ) ) )
+ 130 CONTINUE
+ IF( LSTRES.NE.ZERO )
+ $ FERR( J ) = FERR( J ) / LSTRES
+*
+ 140 CONTINUE
+*
+ RETURN
+*
+* End of DPBRFS
+*
+ END
+ SUBROUTINE DPBSTF( UPLO, N, KD, AB, LDAB, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, KD, LDAB, N
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION AB( LDAB, * )
+* ..
+*
+* Purpose
+* =======
+*
+* DPBSTF computes a split Cholesky factorization of a real
+* symmetric positive definite band matrix A.
+*
+* This routine is designed to be used in conjunction with DSBGST.
+*
+* The factorization has the form A = S**T*S where S is a band matrix
+* of the same bandwidth as A and the following structure:
+*
+* S = ( U )
+* ( M L )
+*
+* where U is upper triangular of order m = (n+kd)/2, and L is lower
+* triangular of order n-m.
+*
+* Arguments
+* =========
+*
+* UPLO (input) CHARACTER*1
+* = 'U': Upper triangle of A is stored;
+* = 'L': Lower triangle of A is stored.
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* KD (input) INTEGER
+* The number of superdiagonals of the matrix A if UPLO = 'U',
+* or the number of subdiagonals if UPLO = 'L'. KD >= 0.
+*
+* AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N)
+* On entry, the upper or lower triangle of the symmetric band
+* matrix A, stored in the first kd+1 rows of the array. The
+* j-th column of A is stored in the j-th column of the array AB
+* as follows:
+* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
+* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).
+*
+* On exit, if INFO = 0, the factor S from the split Cholesky
+* factorization A = S**T*S. See Further Details.
+*
+* LDAB (input) INTEGER
+* The leading dimension of the array AB. LDAB >= KD+1.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* > 0: if INFO = i, the factorization could not be completed,
+* because the updated element a(i,i) was negative; the
+* matrix A is not positive definite.
+*
+* Further Details
+* ===============
+*
+* The band storage scheme is illustrated by the following example, when
+* N = 7, KD = 2:
+*
+* S = ( s11 s12 s13 )
+* ( s22 s23 s24 )
+* ( s33 s34 )
+* ( s44 )
+* ( s53 s54 s55 )
+* ( s64 s65 s66 )
+* ( s75 s76 s77 )
+*
+* If UPLO = 'U', the array AB holds:
+*
+* on entry: on exit:
+*
+* * * a13 a24 a35 a46 a57 * * s13 s24 s53 s64 s75
+* * a12 a23 a34 a45 a56 a67 * s12 s23 s34 s54 s65 s76
+* a11 a22 a33 a44 a55 a66 a77 s11 s22 s33 s44 s55 s66 s77
+*
+* If UPLO = 'L', the array AB holds:
+*
+* on entry: on exit:
+*
+* a11 a22 a33 a44 a55 a66 a77 s11 s22 s33 s44 s55 s66 s77
+* a21 a32 a43 a54 a65 a76 * s12 s23 s34 s54 s65 s76 *
+* a31 a42 a53 a64 a64 * * s13 s24 s53 s64 s75 * *
+*
+* Array elements marked * are not used by the routine.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE, ZERO
+ PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL UPPER
+ INTEGER J, KLD, KM, M
+ DOUBLE PRECISION AJJ
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL DSCAL, DSYR, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN, SQRT
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( KD.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( LDAB.LT.KD+1 ) THEN
+ INFO = -5
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DPBSTF', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+ KLD = MAX( 1, LDAB-1 )
+*
+* Set the splitting point m.
+*
+ M = ( N+KD ) / 2
+*
+ IF( UPPER ) THEN
+*
+* Factorize A(m+1:n,m+1:n) as L**T*L, and update A(1:m,1:m).
+*
+ DO 10 J = N, M + 1, -1
+*
+* Compute s(j,j) and test for non-positive-definiteness.
+*
+ AJJ = AB( KD+1, J )
+ IF( AJJ.LE.ZERO )
+ $ GO TO 50
+ AJJ = SQRT( AJJ )
+ AB( KD+1, J ) = AJJ
+ KM = MIN( J-1, KD )
+*
+* Compute elements j-km:j-1 of the j-th column and update the
+* the leading submatrix within the band.
+*
+ CALL DSCAL( KM, ONE / AJJ, AB( KD+1-KM, J ), 1 )
+ CALL DSYR( 'Upper', KM, -ONE, AB( KD+1-KM, J ), 1,
+ $ AB( KD+1, J-KM ), KLD )
+ 10 CONTINUE
+*
+* Factorize the updated submatrix A(1:m,1:m) as U**T*U.
+*
+ DO 20 J = 1, M
+*
+* Compute s(j,j) and test for non-positive-definiteness.
+*
+ AJJ = AB( KD+1, J )
+ IF( AJJ.LE.ZERO )
+ $ GO TO 50
+ AJJ = SQRT( AJJ )
+ AB( KD+1, J ) = AJJ
+ KM = MIN( KD, M-J )
+*
+* Compute elements j+1:j+km of the j-th row and update the
+* trailing submatrix within the band.
+*
+ IF( KM.GT.0 ) THEN
+ CALL DSCAL( KM, ONE / AJJ, AB( KD, J+1 ), KLD )
+ CALL DSYR( 'Upper', KM, -ONE, AB( KD, J+1 ), KLD,
+ $ AB( KD+1, J+1 ), KLD )
+ END IF
+ 20 CONTINUE
+ ELSE
+*
+* Factorize A(m+1:n,m+1:n) as L**T*L, and update A(1:m,1:m).
+*
+ DO 30 J = N, M + 1, -1
+*
+* Compute s(j,j) and test for non-positive-definiteness.
+*
+ AJJ = AB( 1, J )
+ IF( AJJ.LE.ZERO )
+ $ GO TO 50
+ AJJ = SQRT( AJJ )
+ AB( 1, J ) = AJJ
+ KM = MIN( J-1, KD )
+*
+* Compute elements j-km:j-1 of the j-th row and update the
+* trailing submatrix within the band.
+*
+ CALL DSCAL( KM, ONE / AJJ, AB( KM+1, J-KM ), KLD )
+ CALL DSYR( 'Lower', KM, -ONE, AB( KM+1, J-KM ), KLD,
+ $ AB( 1, J-KM ), KLD )
+ 30 CONTINUE
+*
+* Factorize the updated submatrix A(1:m,1:m) as U**T*U.
+*
+ DO 40 J = 1, M
+*
+* Compute s(j,j) and test for non-positive-definiteness.
+*
+ AJJ = AB( 1, J )
+ IF( AJJ.LE.ZERO )
+ $ GO TO 50
+ AJJ = SQRT( AJJ )
+ AB( 1, J ) = AJJ
+ KM = MIN( KD, M-J )
+*
+* Compute elements j+1:j+km of the j-th column and update the
+* trailing submatrix within the band.
+*
+ IF( KM.GT.0 ) THEN
+ CALL DSCAL( KM, ONE / AJJ, AB( 2, J ), 1 )
+ CALL DSYR( 'Lower', KM, -ONE, AB( 2, J ), 1,
+ $ AB( 1, J+1 ), KLD )
+ END IF
+ 40 CONTINUE
+ END IF
+ RETURN
+*
+ 50 CONTINUE
+ INFO = J
+ RETURN
+*
+* End of DPBSTF
+*
+ END
+ SUBROUTINE DPBSV( UPLO, N, KD, NRHS, AB, LDAB, B, LDB, INFO )
+*
+* -- LAPACK driver routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, KD, LDAB, LDB, N, NRHS
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION AB( LDAB, * ), B( LDB, * )
+* ..
+*
+* Purpose
+* =======
+*
+* DPBSV computes the solution to a real system of linear equations
+* A * X = B,
+* where A is an N-by-N symmetric positive definite band matrix and X
+* and B are N-by-NRHS matrices.
+*
+* The Cholesky decomposition is used to factor A as
+* A = U**T * U, if UPLO = 'U', or
+* A = L * L**T, if UPLO = 'L',
+* where U is an upper triangular band matrix, and L is a lower
+* triangular band matrix, with the same number of superdiagonals or
+* subdiagonals as A. The factored form of A is then used to solve the
+* system of equations A * X = B.
+*
+* Arguments
+* =========
+*
+* UPLO (input) CHARACTER*1
+* = 'U': Upper triangle of A is stored;
+* = 'L': Lower triangle of A is stored.
+*
+* N (input) INTEGER
+* The number of linear equations, i.e., the order of the
+* matrix A. N >= 0.
+*
+* KD (input) INTEGER
+* The number of superdiagonals of the matrix A if UPLO = 'U',
+* or the number of subdiagonals if UPLO = 'L'. KD >= 0.
+*
+* NRHS (input) INTEGER
+* The number of right hand sides, i.e., the number of columns
+* of the matrix B. NRHS >= 0.
+*
+* AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N)
+* On entry, the upper or lower triangle of the symmetric band
+* matrix A, stored in the first KD+1 rows of the array. The
+* j-th column of A is stored in the j-th column of the array AB
+* as follows:
+* if UPLO = 'U', AB(KD+1+i-j,j) = A(i,j) for max(1,j-KD)<=i<=j;
+* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(N,j+KD).
+* See below for further details.
+*
+* On exit, if INFO = 0, the triangular factor U or L from the
+* Cholesky factorization A = U**T*U or A = L*L**T of the band
+* matrix A, in the same storage format as A.
+*
+* LDAB (input) INTEGER
+* The leading dimension of the array AB. LDAB >= KD+1.
+*
+* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
+* On entry, the N-by-NRHS right hand side matrix B.
+* On exit, if INFO = 0, the N-by-NRHS solution matrix X.
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. LDB >= max(1,N).
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* > 0: if INFO = i, the leading minor of order i of A is not
+* positive definite, so the factorization could not be
+* completed, and the solution has not been computed.
+*
+* Further Details
+* ===============
+*
+* The band storage scheme is illustrated by the following example, when
+* N = 6, KD = 2, and UPLO = 'U':
+*
+* On entry: On exit:
+*
+* * * a13 a24 a35 a46 * * u13 u24 u35 u46
+* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56
+* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66
+*
+* Similarly, if UPLO = 'L' the format of A is as follows:
+*
+* On entry: On exit:
+*
+* a11 a22 a33 a44 a55 a66 l11 l22 l33 l44 l55 l66
+* a21 a32 a43 a54 a65 * l21 l32 l43 l54 l65 *
+* a31 a42 a53 a64 * * l31 l42 l53 l64 * *
+*
+* Array elements marked * are not used by the routine.
+*
+* =====================================================================
+*
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL DPBTRF, DPBTRS, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( KD.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( NRHS.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( LDAB.LT.KD+1 ) THEN
+ INFO = -6
+ ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -8
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DPBSV ', -INFO )
+ RETURN
+ END IF
+*
+* Compute the Cholesky factorization A = U'*U or A = L*L'.
+*
+ CALL DPBTRF( UPLO, N, KD, AB, LDAB, INFO )
+ IF( INFO.EQ.0 ) THEN
+*
+* Solve the system A*X = B, overwriting B with X.
+*
+ CALL DPBTRS( UPLO, N, KD, NRHS, AB, LDAB, B, LDB, INFO )
+*
+ END IF
+ RETURN
+*
+* End of DPBSV
+*
+ END
+ SUBROUTINE DPBSVX( FACT, UPLO, N, KD, NRHS, AB, LDAB, AFB, LDAFB,
+ $ EQUED, S, B, LDB, X, LDX, RCOND, FERR, BERR,
+ $ WORK, IWORK, INFO )
+*
+* -- LAPACK driver routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER EQUED, FACT, UPLO
+ INTEGER INFO, KD, LDAB, LDAFB, LDB, LDX, N, NRHS
+ DOUBLE PRECISION RCOND
+* ..
+* .. Array Arguments ..
+ INTEGER IWORK( * )
+ DOUBLE PRECISION AB( LDAB, * ), AFB( LDAFB, * ), B( LDB, * ),
+ $ BERR( * ), FERR( * ), S( * ), WORK( * ),
+ $ X( LDX, * )
+* ..
+*
+* Purpose
+* =======
+*
+* DPBSVX uses the Cholesky factorization A = U**T*U or A = L*L**T to
+* compute the solution to a real system of linear equations
+* A * X = B,
+* where A is an N-by-N symmetric positive definite band matrix and X
+* and B are N-by-NRHS matrices.
+*
+* Error bounds on the solution and a condition estimate are also
+* provided.
+*
+* Description
+* ===========
+*
+* The following steps are performed:
+*
+* 1. If FACT = 'E', real scaling factors are computed to equilibrate
+* the system:
+* diag(S) * A * diag(S) * inv(diag(S)) * X = diag(S) * B
+* Whether or not the system will be equilibrated depends on the
+* scaling of the matrix A, but if equilibration is used, A is
+* overwritten by diag(S)*A*diag(S) and B by diag(S)*B.
+*
+* 2. If FACT = 'N' or 'E', the Cholesky decomposition is used to
+* factor the matrix A (after equilibration if FACT = 'E') as
+* A = U**T * U, if UPLO = 'U', or
+* A = L * L**T, if UPLO = 'L',
+* where U is an upper triangular band matrix, and L is a lower
+* triangular band matrix.
+*
+* 3. If the leading i-by-i principal minor is not positive definite,
+* then the routine returns with INFO = i. Otherwise, the factored
+* form of A is used to estimate the condition number of the matrix
+* A. If the reciprocal of the condition number is less than machine
+* precision, INFO = N+1 is returned as a warning, but the routine
+* still goes on to solve for X and compute error bounds as
+* described below.
+*
+* 4. The system of equations is solved for X using the factored form
+* of A.
+*
+* 5. Iterative refinement is applied to improve the computed solution
+* matrix and calculate error bounds and backward error estimates
+* for it.
+*
+* 6. If equilibration was used, the matrix X is premultiplied by
+* diag(S) so that it solves the original system before
+* equilibration.
+*
+* Arguments
+* =========
+*
+* FACT (input) CHARACTER*1
+* Specifies whether or not the factored form of the matrix A is
+* supplied on entry, and if not, whether the matrix A should be
+* equilibrated before it is factored.
+* = 'F': On entry, AFB contains the factored form of A.
+* If EQUED = 'Y', the matrix A has been equilibrated
+* with scaling factors given by S. AB and AFB will not
+* be modified.
+* = 'N': The matrix A will be copied to AFB and factored.
+* = 'E': The matrix A will be equilibrated if necessary, then
+* copied to AFB and factored.
+*
+* UPLO (input) CHARACTER*1
+* = 'U': Upper triangle of A is stored;
+* = 'L': Lower triangle of A is stored.
+*
+* N (input) INTEGER
+* The number of linear equations, i.e., the order of the
+* matrix A. N >= 0.
+*
+* KD (input) INTEGER
+* The number of superdiagonals of the matrix A if UPLO = 'U',
+* or the number of subdiagonals if UPLO = 'L'. KD >= 0.
+*
+* NRHS (input) INTEGER
+* The number of right-hand sides, i.e., the number of columns
+* of the matrices B and X. NRHS >= 0.
+*
+* AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N)
+* On entry, the upper or lower triangle of the symmetric band
+* matrix A, stored in the first KD+1 rows of the array, except
+* if FACT = 'F' and EQUED = 'Y', then A must contain the
+* equilibrated matrix diag(S)*A*diag(S). The j-th column of A
+* is stored in the j-th column of the array AB as follows:
+* if UPLO = 'U', AB(KD+1+i-j,j) = A(i,j) for max(1,j-KD)<=i<=j;
+* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(N,j+KD).
+* See below for further details.
+*
+* On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by
+* diag(S)*A*diag(S).
+*
+* LDAB (input) INTEGER
+* The leading dimension of the array A. LDAB >= KD+1.
+*
+* AFB (input or output) DOUBLE PRECISION array, dimension (LDAFB,N)
+* If FACT = 'F', then AFB is an input argument and on entry
+* contains the triangular factor U or L from the Cholesky
+* factorization A = U**T*U or A = L*L**T of the band matrix
+* A, in the same storage format as A (see AB). If EQUED = 'Y',
+* then AFB is the factored form of the equilibrated matrix A.
+*
+* If FACT = 'N', then AFB is an output argument and on exit
+* returns the triangular factor U or L from the Cholesky
+* factorization A = U**T*U or A = L*L**T.
+*
+* If FACT = 'E', then AFB is an output argument and on exit
+* returns the triangular factor U or L from the Cholesky
+* factorization A = U**T*U or A = L*L**T of the equilibrated
+* matrix A (see the description of A for the form of the
+* equilibrated matrix).
+*
+* LDAFB (input) INTEGER
+* The leading dimension of the array AFB. LDAFB >= KD+1.
+*
+* EQUED (input or output) CHARACTER*1
+* Specifies the form of equilibration that was done.
+* = 'N': No equilibration (always true if FACT = 'N').
+* = 'Y': Equilibration was done, i.e., A has been replaced by
+* diag(S) * A * diag(S).
+* EQUED is an input argument if FACT = 'F'; otherwise, it is an
+* output argument.
+*
+* S (input or output) DOUBLE PRECISION array, dimension (N)
+* The scale factors for A; not accessed if EQUED = 'N'. S is
+* an input argument if FACT = 'F'; otherwise, S is an output
+* argument. If FACT = 'F' and EQUED = 'Y', each element of S
+* must be positive.
+*
+* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
+* On entry, the N-by-NRHS right hand side matrix B.
+* On exit, if EQUED = 'N', B is not modified; if EQUED = 'Y',
+* B is overwritten by diag(S) * B.
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. LDB >= max(1,N).
+*
+* X (output) DOUBLE PRECISION array, dimension (LDX,NRHS)
+* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X to
+* the original system of equations. Note that if EQUED = 'Y',
+* A and B are modified on exit, and the solution to the
+* equilibrated system is inv(diag(S))*X.
+*
+* LDX (input) INTEGER
+* The leading dimension of the array X. LDX >= max(1,N).
+*
+* RCOND (output) DOUBLE PRECISION
+* The estimate of the reciprocal condition number of the matrix
+* A after equilibration (if done). If RCOND is less than the
+* machine precision (in particular, if RCOND = 0), the matrix
+* is singular to working precision. This condition is
+* indicated by a return code of INFO > 0.
+*
+* FERR (output) DOUBLE PRECISION array, dimension (NRHS)
+* The estimated forward error bound for each solution vector
+* X(j) (the j-th column of the solution matrix X).
+* If XTRUE is the true solution corresponding to X(j), FERR(j)
+* is an estimated upper bound for the magnitude of the largest
+* element in (X(j) - XTRUE) divided by the magnitude of the
+* largest element in X(j). The estimate is as reliable as
+* the estimate for RCOND, and is almost always a slight
+* overestimate of the true error.
+*
+* BERR (output) DOUBLE PRECISION array, dimension (NRHS)
+* The componentwise relative backward error of each solution
+* vector X(j) (i.e., the smallest relative change in
+* any element of A or B that makes X(j) an exact solution).
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (3*N)
+*
+* IWORK (workspace) INTEGER array, dimension (N)
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* > 0: if INFO = i, and i is
+* <= N: the leading minor of order i of A is
+* not positive definite, so the factorization
+* could not be completed, and the solution has not
+* been computed. RCOND = 0 is returned.
+* = N+1: U is nonsingular, but RCOND is less than machine
+* precision, meaning that the matrix is singular
+* to working precision. Nevertheless, the
+* solution and error bounds are computed because
+* there are a number of situations where the
+* computed solution can be more accurate than the
+* value of RCOND would suggest.
+*
+* Further Details
+* ===============
+*
+* The band storage scheme is illustrated by the following example, when
+* N = 6, KD = 2, and UPLO = 'U':
+*
+* Two-dimensional storage of the symmetric matrix A:
+*
+* a11 a12 a13
+* a22 a23 a24
+* a33 a34 a35
+* a44 a45 a46
+* a55 a56
+* (aij=conjg(aji)) a66
+*
+* Band storage of the upper triangle of A:
+*
+* * * a13 a24 a35 a46
+* * a12 a23 a34 a45 a56
+* a11 a22 a33 a44 a55 a66
+*
+* Similarly, if UPLO = 'L' the format of A is as follows:
+*
+* a11 a22 a33 a44 a55 a66
+* a21 a32 a43 a54 a65 *
+* a31 a42 a53 a64 * *
+*
+* Array elements marked * are not used by the routine.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL EQUIL, NOFACT, RCEQU, UPPER
+ INTEGER I, INFEQU, J, J1, J2
+ DOUBLE PRECISION AMAX, ANORM, BIGNUM, SCOND, SMAX, SMIN, SMLNUM
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ DOUBLE PRECISION DLAMCH, DLANSB
+ EXTERNAL LSAME, DLAMCH, DLANSB
+* ..
+* .. External Subroutines ..
+ EXTERNAL DCOPY, DLACPY, DLAQSB, DPBCON, DPBEQU, DPBRFS,
+ $ DPBTRF, DPBTRS, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+ INFO = 0
+ NOFACT = LSAME( FACT, 'N' )
+ EQUIL = LSAME( FACT, 'E' )
+ UPPER = LSAME( UPLO, 'U' )
+ IF( NOFACT .OR. EQUIL ) THEN
+ EQUED = 'N'
+ RCEQU = .FALSE.
+ ELSE
+ RCEQU = LSAME( EQUED, 'Y' )
+ SMLNUM = DLAMCH( 'Safe minimum' )
+ BIGNUM = ONE / SMLNUM
+ END IF
+*
+* Test the input parameters.
+*
+ IF( .NOT.NOFACT .AND. .NOT.EQUIL .AND. .NOT.LSAME( FACT, 'F' ) )
+ $ THEN
+ INFO = -1
+ ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -2
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( KD.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( NRHS.LT.0 ) THEN
+ INFO = -5
+ ELSE IF( LDAB.LT.KD+1 ) THEN
+ INFO = -7
+ ELSE IF( LDAFB.LT.KD+1 ) THEN
+ INFO = -9
+ ELSE IF( LSAME( FACT, 'F' ) .AND. .NOT.
+ $ ( RCEQU .OR. LSAME( EQUED, 'N' ) ) ) THEN
+ INFO = -10
+ ELSE
+ IF( RCEQU ) THEN
+ SMIN = BIGNUM
+ SMAX = ZERO
+ DO 10 J = 1, N
+ SMIN = MIN( SMIN, S( J ) )
+ SMAX = MAX( SMAX, S( J ) )
+ 10 CONTINUE
+ IF( SMIN.LE.ZERO ) THEN
+ INFO = -11
+ ELSE IF( N.GT.0 ) THEN
+ SCOND = MAX( SMIN, SMLNUM ) / MIN( SMAX, BIGNUM )
+ ELSE
+ SCOND = ONE
+ END IF
+ END IF
+ IF( INFO.EQ.0 ) THEN
+ IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -13
+ ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
+ INFO = -15
+ END IF
+ END IF
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DPBSVX', -INFO )
+ RETURN
+ END IF
+*
+ IF( EQUIL ) THEN
+*
+* Compute row and column scalings to equilibrate the matrix A.
+*
+ CALL DPBEQU( UPLO, N, KD, AB, LDAB, S, SCOND, AMAX, INFEQU )
+ IF( INFEQU.EQ.0 ) THEN
+*
+* Equilibrate the matrix.
+*
+ CALL DLAQSB( UPLO, N, KD, AB, LDAB, S, SCOND, AMAX, EQUED )
+ RCEQU = LSAME( EQUED, 'Y' )
+ END IF
+ END IF
+*
+* Scale the right-hand side.
+*
+ IF( RCEQU ) THEN
+ DO 30 J = 1, NRHS
+ DO 20 I = 1, N
+ B( I, J ) = S( I )*B( I, J )
+ 20 CONTINUE
+ 30 CONTINUE
+ END IF
+*
+ IF( NOFACT .OR. EQUIL ) THEN
+*
+* Compute the Cholesky factorization A = U'*U or A = L*L'.
+*
+ IF( UPPER ) THEN
+ DO 40 J = 1, N
+ J1 = MAX( J-KD, 1 )
+ CALL DCOPY( J-J1+1, AB( KD+1-J+J1, J ), 1,
+ $ AFB( KD+1-J+J1, J ), 1 )
+ 40 CONTINUE
+ ELSE
+ DO 50 J = 1, N
+ J2 = MIN( J+KD, N )
+ CALL DCOPY( J2-J+1, AB( 1, J ), 1, AFB( 1, J ), 1 )
+ 50 CONTINUE
+ END IF
+*
+ CALL DPBTRF( UPLO, N, KD, AFB, LDAFB, INFO )
+*
+* Return if INFO is non-zero.
+*
+ IF( INFO.GT.0 )THEN
+ RCOND = ZERO
+ RETURN
+ END IF
+ END IF
+*
+* Compute the norm of the matrix A.
+*
+ ANORM = DLANSB( '1', UPLO, N, KD, AB, LDAB, WORK )
+*
+* Compute the reciprocal of the condition number of A.
+*
+ CALL DPBCON( UPLO, N, KD, AFB, LDAFB, ANORM, RCOND, WORK, IWORK,
+ $ INFO )
+*
+* Compute the solution matrix X.
+*
+ CALL DLACPY( 'Full', N, NRHS, B, LDB, X, LDX )
+ CALL DPBTRS( UPLO, N, KD, NRHS, AFB, LDAFB, X, LDX, INFO )
+*
+* Use iterative refinement to improve the computed solution and
+* compute error bounds and backward error estimates for it.
+*
+ CALL DPBRFS( UPLO, N, KD, NRHS, AB, LDAB, AFB, LDAFB, B, LDB, X,
+ $ LDX, FERR, BERR, WORK, IWORK, INFO )
+*
+* Transform the solution matrix X to a solution of the original
+* system.
+*
+ IF( RCEQU ) THEN
+ DO 70 J = 1, NRHS
+ DO 60 I = 1, N
+ X( I, J ) = S( I )*X( I, J )
+ 60 CONTINUE
+ 70 CONTINUE
+ DO 80 J = 1, NRHS
+ FERR( J ) = FERR( J ) / SCOND
+ 80 CONTINUE
+ END IF
+*
+* Set INFO = N+1 if the matrix is singular to working precision.
+*
+ IF( RCOND.LT.DLAMCH( 'Epsilon' ) )
+ $ INFO = N + 1
+*
+ RETURN
+*
+* End of DPBSVX
+*
+ END
+ SUBROUTINE DPBTF2( UPLO, N, KD, AB, LDAB, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, KD, LDAB, N
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION AB( LDAB, * )
+* ..
+*
+* Purpose
+* =======
+*
+* DPBTF2 computes the Cholesky factorization of a real symmetric
+* positive definite band matrix A.
+*
+* The factorization has the form
+* A = U' * U , if UPLO = 'U', or
+* A = L * L', if UPLO = 'L',
+* where U is an upper triangular matrix, U' is the transpose of U, and
+* L is lower triangular.
+*
+* This is the unblocked version of the algorithm, calling Level 2 BLAS.
+*
+* Arguments
+* =========
+*
+* UPLO (input) CHARACTER*1
+* Specifies whether the upper or lower triangular part of the
+* symmetric matrix A is stored:
+* = 'U': Upper triangular
+* = 'L': Lower triangular
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* KD (input) INTEGER
+* The number of super-diagonals of the matrix A if UPLO = 'U',
+* or the number of sub-diagonals if UPLO = 'L'. KD >= 0.
+*
+* AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N)
+* On entry, the upper or lower triangle of the symmetric band
+* matrix A, stored in the first KD+1 rows of the array. The
+* j-th column of A is stored in the j-th column of the array AB
+* as follows:
+* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
+* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).
+*
+* On exit, if INFO = 0, the triangular factor U or L from the
+* Cholesky factorization A = U'*U or A = L*L' of the band
+* matrix A, in the same storage format as A.
+*
+* LDAB (input) INTEGER
+* The leading dimension of the array AB. LDAB >= KD+1.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -k, the k-th argument had an illegal value
+* > 0: if INFO = k, the leading minor of order k is not
+* positive definite, and the factorization could not be
+* completed.
+*
+* Further Details
+* ===============
+*
+* The band storage scheme is illustrated by the following example, when
+* N = 6, KD = 2, and UPLO = 'U':
+*
+* On entry: On exit:
+*
+* * * a13 a24 a35 a46 * * u13 u24 u35 u46
+* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56
+* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66
+*
+* Similarly, if UPLO = 'L' the format of A is as follows:
+*
+* On entry: On exit:
+*
+* a11 a22 a33 a44 a55 a66 l11 l22 l33 l44 l55 l66
+* a21 a32 a43 a54 a65 * l21 l32 l43 l54 l65 *
+* a31 a42 a53 a64 * * l31 l42 l53 l64 * *
+*
+* Array elements marked * are not used by the routine.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE, ZERO
+ PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL UPPER
+ INTEGER J, KLD, KN
+ DOUBLE PRECISION AJJ
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL DSCAL, DSYR, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN, SQRT
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( KD.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( LDAB.LT.KD+1 ) THEN
+ INFO = -5
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DPBTF2', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+ KLD = MAX( 1, LDAB-1 )
+*
+ IF( UPPER ) THEN
+*
+* Compute the Cholesky factorization A = U'*U.
+*
+ DO 10 J = 1, N
+*
+* Compute U(J,J) and test for non-positive-definiteness.
+*
+ AJJ = AB( KD+1, J )
+ IF( AJJ.LE.ZERO )
+ $ GO TO 30
+ AJJ = SQRT( AJJ )
+ AB( KD+1, J ) = AJJ
+*
+* Compute elements J+1:J+KN of row J and update the
+* trailing submatrix within the band.
+*
+ KN = MIN( KD, N-J )
+ IF( KN.GT.0 ) THEN
+ CALL DSCAL( KN, ONE / AJJ, AB( KD, J+1 ), KLD )
+ CALL DSYR( 'Upper', KN, -ONE, AB( KD, J+1 ), KLD,
+ $ AB( KD+1, J+1 ), KLD )
+ END IF
+ 10 CONTINUE
+ ELSE
+*
+* Compute the Cholesky factorization A = L*L'.
+*
+ DO 20 J = 1, N
+*
+* Compute L(J,J) and test for non-positive-definiteness.
+*
+ AJJ = AB( 1, J )
+ IF( AJJ.LE.ZERO )
+ $ GO TO 30
+ AJJ = SQRT( AJJ )
+ AB( 1, J ) = AJJ
+*
+* Compute elements J+1:J+KN of column J and update the
+* trailing submatrix within the band.
+*
+ KN = MIN( KD, N-J )
+ IF( KN.GT.0 ) THEN
+ CALL DSCAL( KN, ONE / AJJ, AB( 2, J ), 1 )
+ CALL DSYR( 'Lower', KN, -ONE, AB( 2, J ), 1,
+ $ AB( 1, J+1 ), KLD )
+ END IF
+ 20 CONTINUE
+ END IF
+ RETURN
+*
+ 30 CONTINUE
+ INFO = J
+ RETURN
+*
+* End of DPBTF2
+*
+ END
+ SUBROUTINE DPBTRF( UPLO, N, KD, AB, LDAB, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, KD, LDAB, N
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION AB( LDAB, * )
+* ..
+*
+* Purpose
+* =======
+*
+* DPBTRF computes the Cholesky factorization of a real symmetric
+* positive definite band matrix A.
+*
+* The factorization has the form
+* A = U**T * U, if UPLO = 'U', or
+* A = L * L**T, if UPLO = 'L',
+* where U is an upper triangular matrix and L is lower triangular.
+*
+* Arguments
+* =========
+*
+* UPLO (input) CHARACTER*1
+* = 'U': Upper triangle of A is stored;
+* = 'L': Lower triangle of A is stored.
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* KD (input) INTEGER
+* The number of superdiagonals of the matrix A if UPLO = 'U',
+* or the number of subdiagonals if UPLO = 'L'. KD >= 0.
+*
+* AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N)
+* On entry, the upper or lower triangle of the symmetric band
+* matrix A, stored in the first KD+1 rows of the array. The
+* j-th column of A is stored in the j-th column of the array AB
+* as follows:
+* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
+* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).
+*
+* On exit, if INFO = 0, the triangular factor U or L from the
+* Cholesky factorization A = U**T*U or A = L*L**T of the band
+* matrix A, in the same storage format as A.
+*
+* LDAB (input) INTEGER
+* The leading dimension of the array AB. LDAB >= KD+1.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* > 0: if INFO = i, the leading minor of order i is not
+* positive definite, and the factorization could not be
+* completed.
+*
+* Further Details
+* ===============
+*
+* The band storage scheme is illustrated by the following example, when
+* N = 6, KD = 2, and UPLO = 'U':
+*
+* On entry: On exit:
+*
+* * * a13 a24 a35 a46 * * u13 u24 u35 u46
+* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56
+* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66
+*
+* Similarly, if UPLO = 'L' the format of A is as follows:
+*
+* On entry: On exit:
+*
+* a11 a22 a33 a44 a55 a66 l11 l22 l33 l44 l55 l66
+* a21 a32 a43 a54 a65 * l21 l32 l43 l54 l65 *
+* a31 a42 a53 a64 * * l31 l42 l53 l64 * *
+*
+* Array elements marked * are not used by the routine.
+*
+* Contributed by
+* Peter Mayes and Giuseppe Radicati, IBM ECSEC, Rome, March 23, 1989
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE, ZERO
+ PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
+ INTEGER NBMAX, LDWORK
+ PARAMETER ( NBMAX = 32, LDWORK = NBMAX+1 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, I2, I3, IB, II, J, JJ, NB
+* ..
+* .. Local Arrays ..
+ DOUBLE PRECISION WORK( LDWORK, NBMAX )
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ILAENV
+ EXTERNAL LSAME, ILAENV
+* ..
+* .. External Subroutines ..
+ EXTERNAL DGEMM, DPBTF2, DPOTF2, DSYRK, DTRSM, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MIN
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ IF( ( .NOT.LSAME( UPLO, 'U' ) ) .AND.
+ $ ( .NOT.LSAME( UPLO, 'L' ) ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( KD.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( LDAB.LT.KD+1 ) THEN
+ INFO = -5
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DPBTRF', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+* Determine the block size for this environment
+*
+ NB = ILAENV( 1, 'DPBTRF', UPLO, N, KD, -1, -1 )
+*
+* The block size must not exceed the semi-bandwidth KD, and must not
+* exceed the limit set by the size of the local array WORK.
+*
+ NB = MIN( NB, NBMAX )
+*
+ IF( NB.LE.1 .OR. NB.GT.KD ) THEN
+*
+* Use unblocked code
+*
+ CALL DPBTF2( UPLO, N, KD, AB, LDAB, INFO )
+ ELSE
+*
+* Use blocked code
+*
+ IF( LSAME( UPLO, 'U' ) ) THEN
+*
+* Compute the Cholesky factorization of a symmetric band
+* matrix, given the upper triangle of the matrix in band
+* storage.
+*
+* Zero the upper triangle of the work array.
+*
+ DO 20 J = 1, NB
+ DO 10 I = 1, J - 1
+ WORK( I, J ) = ZERO
+ 10 CONTINUE
+ 20 CONTINUE
+*
+* Process the band matrix one diagonal block at a time.
+*
+ DO 70 I = 1, N, NB
+ IB = MIN( NB, N-I+1 )
+*
+* Factorize the diagonal block
+*
+ CALL DPOTF2( UPLO, IB, AB( KD+1, I ), LDAB-1, II )
+ IF( II.NE.0 ) THEN
+ INFO = I + II - 1
+ GO TO 150
+ END IF
+ IF( I+IB.LE.N ) THEN
+*
+* Update the relevant part of the trailing submatrix.
+* If A11 denotes the diagonal block which has just been
+* factorized, then we need to update the remaining
+* blocks in the diagram:
+*
+* A11 A12 A13
+* A22 A23
+* A33
+*
+* The numbers of rows and columns in the partitioning
+* are IB, I2, I3 respectively. The blocks A12, A22 and
+* A23 are empty if IB = KD. The upper triangle of A13
+* lies outside the band.
+*
+ I2 = MIN( KD-IB, N-I-IB+1 )
+ I3 = MIN( IB, N-I-KD+1 )
+*
+ IF( I2.GT.0 ) THEN
+*
+* Update A12
+*
+ CALL DTRSM( 'Left', 'Upper', 'Transpose',
+ $ 'Non-unit', IB, I2, ONE, AB( KD+1, I ),
+ $ LDAB-1, AB( KD+1-IB, I+IB ), LDAB-1 )
+*
+* Update A22
+*
+ CALL DSYRK( 'Upper', 'Transpose', I2, IB, -ONE,
+ $ AB( KD+1-IB, I+IB ), LDAB-1, ONE,
+ $ AB( KD+1, I+IB ), LDAB-1 )
+ END IF
+*
+ IF( I3.GT.0 ) THEN
+*
+* Copy the lower triangle of A13 into the work array.
+*
+ DO 40 JJ = 1, I3
+ DO 30 II = JJ, IB
+ WORK( II, JJ ) = AB( II-JJ+1, JJ+I+KD-1 )
+ 30 CONTINUE
+ 40 CONTINUE
+*
+* Update A13 (in the work array).
+*
+ CALL DTRSM( 'Left', 'Upper', 'Transpose',
+ $ 'Non-unit', IB, I3, ONE, AB( KD+1, I ),
+ $ LDAB-1, WORK, LDWORK )
+*
+* Update A23
+*
+ IF( I2.GT.0 )
+ $ CALL DGEMM( 'Transpose', 'No Transpose', I2, I3,
+ $ IB, -ONE, AB( KD+1-IB, I+IB ),
+ $ LDAB-1, WORK, LDWORK, ONE,
+ $ AB( 1+IB, I+KD ), LDAB-1 )
+*
+* Update A33
+*
+ CALL DSYRK( 'Upper', 'Transpose', I3, IB, -ONE,
+ $ WORK, LDWORK, ONE, AB( KD+1, I+KD ),
+ $ LDAB-1 )
+*
+* Copy the lower triangle of A13 back into place.
+*
+ DO 60 JJ = 1, I3
+ DO 50 II = JJ, IB
+ AB( II-JJ+1, JJ+I+KD-1 ) = WORK( II, JJ )
+ 50 CONTINUE
+ 60 CONTINUE
+ END IF
+ END IF
+ 70 CONTINUE
+ ELSE
+*
+* Compute the Cholesky factorization of a symmetric band
+* matrix, given the lower triangle of the matrix in band
+* storage.
+*
+* Zero the lower triangle of the work array.
+*
+ DO 90 J = 1, NB
+ DO 80 I = J + 1, NB
+ WORK( I, J ) = ZERO
+ 80 CONTINUE
+ 90 CONTINUE
+*
+* Process the band matrix one diagonal block at a time.
+*
+ DO 140 I = 1, N, NB
+ IB = MIN( NB, N-I+1 )
+*
+* Factorize the diagonal block
+*
+ CALL DPOTF2( UPLO, IB, AB( 1, I ), LDAB-1, II )
+ IF( II.NE.0 ) THEN
+ INFO = I + II - 1
+ GO TO 150
+ END IF
+ IF( I+IB.LE.N ) THEN
+*
+* Update the relevant part of the trailing submatrix.
+* If A11 denotes the diagonal block which has just been
+* factorized, then we need to update the remaining
+* blocks in the diagram:
+*
+* A11
+* A21 A22
+* A31 A32 A33
+*
+* The numbers of rows and columns in the partitioning
+* are IB, I2, I3 respectively. The blocks A21, A22 and
+* A32 are empty if IB = KD. The lower triangle of A31
+* lies outside the band.
+*
+ I2 = MIN( KD-IB, N-I-IB+1 )
+ I3 = MIN( IB, N-I-KD+1 )
+*
+ IF( I2.GT.0 ) THEN
+*
+* Update A21
+*
+ CALL DTRSM( 'Right', 'Lower', 'Transpose',
+ $ 'Non-unit', I2, IB, ONE, AB( 1, I ),
+ $ LDAB-1, AB( 1+IB, I ), LDAB-1 )
+*
+* Update A22
+*
+ CALL DSYRK( 'Lower', 'No Transpose', I2, IB, -ONE,
+ $ AB( 1+IB, I ), LDAB-1, ONE,
+ $ AB( 1, I+IB ), LDAB-1 )
+ END IF
+*
+ IF( I3.GT.0 ) THEN
+*
+* Copy the upper triangle of A31 into the work array.
+*
+ DO 110 JJ = 1, IB
+ DO 100 II = 1, MIN( JJ, I3 )
+ WORK( II, JJ ) = AB( KD+1-JJ+II, JJ+I-1 )
+ 100 CONTINUE
+ 110 CONTINUE
+*
+* Update A31 (in the work array).
+*
+ CALL DTRSM( 'Right', 'Lower', 'Transpose',
+ $ 'Non-unit', I3, IB, ONE, AB( 1, I ),
+ $ LDAB-1, WORK, LDWORK )
+*
+* Update A32
+*
+ IF( I2.GT.0 )
+ $ CALL DGEMM( 'No transpose', 'Transpose', I3, I2,
+ $ IB, -ONE, WORK, LDWORK,
+ $ AB( 1+IB, I ), LDAB-1, ONE,
+ $ AB( 1+KD-IB, I+IB ), LDAB-1 )
+*
+* Update A33
+*
+ CALL DSYRK( 'Lower', 'No Transpose', I3, IB, -ONE,
+ $ WORK, LDWORK, ONE, AB( 1, I+KD ),
+ $ LDAB-1 )
+*
+* Copy the upper triangle of A31 back into place.
+*
+ DO 130 JJ = 1, IB
+ DO 120 II = 1, MIN( JJ, I3 )
+ AB( KD+1-JJ+II, JJ+I-1 ) = WORK( II, JJ )
+ 120 CONTINUE
+ 130 CONTINUE
+ END IF
+ END IF
+ 140 CONTINUE
+ END IF
+ END IF
+ RETURN
+*
+ 150 CONTINUE
+ RETURN
+*
+* End of DPBTRF
+*
+ END
+ SUBROUTINE DPBTRS( UPLO, N, KD, NRHS, AB, LDAB, B, LDB, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, KD, LDAB, LDB, N, NRHS
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION AB( LDAB, * ), B( LDB, * )
+* ..
+*
+* Purpose
+* =======
+*
+* DPBTRS solves a system of linear equations A*X = B with a symmetric
+* positive definite band matrix A using the Cholesky factorization
+* A = U**T*U or A = L*L**T computed by DPBTRF.
+*
+* Arguments
+* =========
+*
+* UPLO (input) CHARACTER*1
+* = 'U': Upper triangular factor stored in AB;
+* = 'L': Lower triangular factor stored in AB.
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* KD (input) INTEGER
+* The number of superdiagonals of the matrix A if UPLO = 'U',
+* or the number of subdiagonals if UPLO = 'L'. KD >= 0.
+*
+* NRHS (input) INTEGER
+* The number of right hand sides, i.e., the number of columns
+* of the matrix B. NRHS >= 0.
+*
+* AB (input) DOUBLE PRECISION array, dimension (LDAB,N)
+* The triangular factor U or L from the Cholesky factorization
+* A = U**T*U or A = L*L**T of the band matrix A, stored in the
+* first KD+1 rows of the array. The j-th column of U or L is
+* stored in the j-th column of the array AB as follows:
+* if UPLO ='U', AB(kd+1+i-j,j) = U(i,j) for max(1,j-kd)<=i<=j;
+* if UPLO ='L', AB(1+i-j,j) = L(i,j) for j<=i<=min(n,j+kd).
+*
+* LDAB (input) INTEGER
+* The leading dimension of the array AB. LDAB >= KD+1.
+*
+* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
+* On entry, the right hand side matrix B.
+* On exit, the solution matrix X.
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. LDB >= max(1,N).
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ LOGICAL UPPER
+ INTEGER J
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL DTBSV, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( KD.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( NRHS.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( LDAB.LT.KD+1 ) THEN
+ INFO = -6
+ ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -8
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DPBTRS', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 .OR. NRHS.EQ.0 )
+ $ RETURN
+*
+ IF( UPPER ) THEN
+*
+* Solve A*X = B where A = U'*U.
+*
+ DO 10 J = 1, NRHS
+*
+* Solve U'*X = B, overwriting B with X.
+*
+ CALL DTBSV( 'Upper', 'Transpose', 'Non-unit', N, KD, AB,
+ $ LDAB, B( 1, J ), 1 )
+*
+* Solve U*X = B, overwriting B with X.
+*
+ CALL DTBSV( 'Upper', 'No transpose', 'Non-unit', N, KD, AB,
+ $ LDAB, B( 1, J ), 1 )
+ 10 CONTINUE
+ ELSE
+*
+* Solve A*X = B where A = L*L'.
+*
+ DO 20 J = 1, NRHS
+*
+* Solve L*X = B, overwriting B with X.
+*
+ CALL DTBSV( 'Lower', 'No transpose', 'Non-unit', N, KD, AB,
+ $ LDAB, B( 1, J ), 1 )
+*
+* Solve L'*X = B, overwriting B with X.
+*
+ CALL DTBSV( 'Lower', 'Transpose', 'Non-unit', N, KD, AB,
+ $ LDAB, B( 1, J ), 1 )
+ 20 CONTINUE
+ END IF
+*
+ RETURN
+*
+* End of DPBTRS
+*
+ END
+ SUBROUTINE DPOCON( UPLO, N, A, LDA, ANORM, RCOND, WORK, IWORK,
+ $ INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH.
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, LDA, N
+ DOUBLE PRECISION ANORM, RCOND
+* ..
+* .. Array Arguments ..
+ INTEGER IWORK( * )
+ DOUBLE PRECISION A( LDA, * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DPOCON estimates the reciprocal of the condition number (in the
+* 1-norm) of a real symmetric positive definite matrix using the
+* Cholesky factorization A = U**T*U or A = L*L**T computed by DPOTRF.
+*
+* An estimate is obtained for norm(inv(A)), and the reciprocal of the
+* condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).
+*
+* Arguments
+* =========
+*
+* UPLO (input) CHARACTER*1
+* = 'U': Upper triangle of A is stored;
+* = 'L': Lower triangle of A is stored.
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* A (input) DOUBLE PRECISION array, dimension (LDA,N)
+* The triangular factor U or L from the Cholesky factorization
+* A = U**T*U or A = L*L**T, as computed by DPOTRF.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,N).
+*
+* ANORM (input) DOUBLE PRECISION
+* The 1-norm (or infinity-norm) of the symmetric matrix A.
+*
+* RCOND (output) DOUBLE PRECISION
+* The reciprocal of the condition number of the matrix A,
+* computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an
+* estimate of the 1-norm of inv(A) computed in this routine.
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (3*N)
+*
+* IWORK (workspace) INTEGER array, dimension (N)
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE, ZERO
+ PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL UPPER
+ CHARACTER NORMIN
+ INTEGER IX, KASE
+ DOUBLE PRECISION AINVNM, SCALE, SCALEL, SCALEU, SMLNUM
+* ..
+* .. Local Arrays ..
+ INTEGER ISAVE( 3 )
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER IDAMAX
+ DOUBLE PRECISION DLAMCH
+ EXTERNAL LSAME, IDAMAX, DLAMCH
+* ..
+* .. External Subroutines ..
+ EXTERNAL DLACN2, DLATRS, DRSCL, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -4
+ ELSE IF( ANORM.LT.ZERO ) THEN
+ INFO = -5
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DPOCON', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ RCOND = ZERO
+ IF( N.EQ.0 ) THEN
+ RCOND = ONE
+ RETURN
+ ELSE IF( ANORM.EQ.ZERO ) THEN
+ RETURN
+ END IF
+*
+ SMLNUM = DLAMCH( 'Safe minimum' )
+*
+* Estimate the 1-norm of inv(A).
+*
+ KASE = 0
+ NORMIN = 'N'
+ 10 CONTINUE
+ CALL DLACN2( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE, ISAVE )
+ IF( KASE.NE.0 ) THEN
+ IF( UPPER ) THEN
+*
+* Multiply by inv(U').
+*
+ CALL DLATRS( 'Upper', 'Transpose', 'Non-unit', NORMIN, N, A,
+ $ LDA, WORK, SCALEL, WORK( 2*N+1 ), INFO )
+ NORMIN = 'Y'
+*
+* Multiply by inv(U).
+*
+ CALL DLATRS( 'Upper', 'No transpose', 'Non-unit', NORMIN, N,
+ $ A, LDA, WORK, SCALEU, WORK( 2*N+1 ), INFO )
+ ELSE
+*
+* Multiply by inv(L).
+*
+ CALL DLATRS( 'Lower', 'No transpose', 'Non-unit', NORMIN, N,
+ $ A, LDA, WORK, SCALEL, WORK( 2*N+1 ), INFO )
+ NORMIN = 'Y'
+*
+* Multiply by inv(L').
+*
+ CALL DLATRS( 'Lower', 'Transpose', 'Non-unit', NORMIN, N, A,
+ $ LDA, WORK, SCALEU, WORK( 2*N+1 ), INFO )
+ END IF
+*
+* Multiply by 1/SCALE if doing so will not cause overflow.
+*
+ SCALE = SCALEL*SCALEU
+ IF( SCALE.NE.ONE ) THEN
+ IX = IDAMAX( N, WORK, 1 )
+ IF( SCALE.LT.ABS( WORK( IX ) )*SMLNUM .OR. SCALE.EQ.ZERO )
+ $ GO TO 20
+ CALL DRSCL( N, SCALE, WORK, 1 )
+ END IF
+ GO TO 10
+ END IF
+*
+* Compute the estimate of the reciprocal condition number.
+*
+ IF( AINVNM.NE.ZERO )
+ $ RCOND = ( ONE / AINVNM ) / ANORM
+*
+ 20 CONTINUE
+ RETURN
+*
+* End of DPOCON
+*
+ END
+ SUBROUTINE DPOEQU( N, A, LDA, S, SCOND, AMAX, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LDA, N
+ DOUBLE PRECISION AMAX, SCOND
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION A( LDA, * ), S( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DPOEQU computes row and column scalings intended to equilibrate a
+* symmetric positive definite matrix A and reduce its condition number
+* (with respect to the two-norm). S contains the scale factors,
+* S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with
+* elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This
+* choice of S puts the condition number of B within a factor N of the
+* smallest possible condition number over all possible diagonal
+* scalings.
+*
+* Arguments
+* =========
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* A (input) DOUBLE PRECISION array, dimension (LDA,N)
+* The N-by-N symmetric positive definite matrix whose scaling
+* factors are to be computed. Only the diagonal elements of A
+* are referenced.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,N).
+*
+* S (output) DOUBLE PRECISION array, dimension (N)
+* If INFO = 0, S contains the scale factors for A.
+*
+* SCOND (output) DOUBLE PRECISION
+* If INFO = 0, S contains the ratio of the smallest S(i) to
+* the largest S(i). If SCOND >= 0.1 and AMAX is neither too
+* large nor too small, it is not worth scaling by S.
+*
+* AMAX (output) DOUBLE PRECISION
+* Absolute value of largest matrix element. If AMAX is very
+* close to overflow or very close to underflow, the matrix
+* should be scaled.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* > 0: if INFO = i, the i-th diagonal element is nonpositive.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I
+ DOUBLE PRECISION SMIN
+* ..
+* .. External Subroutines ..
+ EXTERNAL XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN, SQRT
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ IF( N.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -3
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DPOEQU', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 ) THEN
+ SCOND = ONE
+ AMAX = ZERO
+ RETURN
+ END IF
+*
+* Find the minimum and maximum diagonal elements.
+*
+ S( 1 ) = A( 1, 1 )
+ SMIN = S( 1 )
+ AMAX = S( 1 )
+ DO 10 I = 2, N
+ S( I ) = A( I, I )
+ SMIN = MIN( SMIN, S( I ) )
+ AMAX = MAX( AMAX, S( I ) )
+ 10 CONTINUE
+*
+ IF( SMIN.LE.ZERO ) THEN
+*
+* Find the first non-positive diagonal element and return.
+*
+ DO 20 I = 1, N
+ IF( S( I ).LE.ZERO ) THEN
+ INFO = I
+ RETURN
+ END IF
+ 20 CONTINUE
+ ELSE
+*
+* Set the scale factors to the reciprocals
+* of the diagonal elements.
+*
+ DO 30 I = 1, N
+ S( I ) = ONE / SQRT( S( I ) )
+ 30 CONTINUE
+*
+* Compute SCOND = min(S(I)) / max(S(I))
+*
+ SCOND = SQRT( SMIN ) / SQRT( AMAX )
+ END IF
+ RETURN
+*
+* End of DPOEQU
+*
+ END
+ SUBROUTINE DPORFS( UPLO, N, NRHS, A, LDA, AF, LDAF, B, LDB, X,
+ $ LDX, FERR, BERR, WORK, IWORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH.
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS
+* ..
+* .. Array Arguments ..
+ INTEGER IWORK( * )
+ DOUBLE PRECISION A( LDA, * ), AF( LDAF, * ), B( LDB, * ),
+ $ BERR( * ), FERR( * ), WORK( * ), X( LDX, * )
+* ..
+*
+* Purpose
+* =======
+*
+* DPORFS improves the computed solution to a system of linear
+* equations when the coefficient matrix is symmetric positive definite,
+* and provides error bounds and backward error estimates for the
+* solution.
+*
+* Arguments
+* =========
+*
+* UPLO (input) CHARACTER*1
+* = 'U': Upper triangle of A is stored;
+* = 'L': Lower triangle of A is stored.
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* NRHS (input) INTEGER
+* The number of right hand sides, i.e., the number of columns
+* of the matrices B and X. NRHS >= 0.
+*
+* A (input) DOUBLE PRECISION array, dimension (LDA,N)
+* The symmetric matrix A. If UPLO = 'U', the leading N-by-N
+* upper triangular part of A contains the upper triangular part
+* of the matrix A, and the strictly lower triangular part of A
+* is not referenced. If UPLO = 'L', the leading N-by-N lower
+* triangular part of A contains the lower triangular part of
+* the matrix A, and the strictly upper triangular part of A is
+* not referenced.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,N).
+*
+* AF (input) DOUBLE PRECISION array, dimension (LDAF,N)
+* The triangular factor U or L from the Cholesky factorization
+* A = U**T*U or A = L*L**T, as computed by DPOTRF.
+*
+* LDAF (input) INTEGER
+* The leading dimension of the array AF. LDAF >= max(1,N).
+*
+* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS)
+* The right hand side matrix B.
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. LDB >= max(1,N).
+*
+* X (input/output) DOUBLE PRECISION array, dimension (LDX,NRHS)
+* On entry, the solution matrix X, as computed by DPOTRS.
+* On exit, the improved solution matrix X.
+*
+* LDX (input) INTEGER
+* The leading dimension of the array X. LDX >= max(1,N).
+*
+* FERR (output) DOUBLE PRECISION array, dimension (NRHS)
+* The estimated forward error bound for each solution vector
+* X(j) (the j-th column of the solution matrix X).
+* If XTRUE is the true solution corresponding to X(j), FERR(j)
+* is an estimated upper bound for the magnitude of the largest
+* element in (X(j) - XTRUE) divided by the magnitude of the
+* largest element in X(j). The estimate is as reliable as
+* the estimate for RCOND, and is almost always a slight
+* overestimate of the true error.
+*
+* BERR (output) DOUBLE PRECISION array, dimension (NRHS)
+* The componentwise relative backward error of each solution
+* vector X(j) (i.e., the smallest relative change in
+* any element of A or B that makes X(j) an exact solution).
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (3*N)
+*
+* IWORK (workspace) INTEGER array, dimension (N)
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+*
+* Internal Parameters
+* ===================
+*
+* ITMAX is the maximum number of steps of iterative refinement.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ INTEGER ITMAX
+ PARAMETER ( ITMAX = 5 )
+ DOUBLE PRECISION ZERO
+ PARAMETER ( ZERO = 0.0D+0 )
+ DOUBLE PRECISION ONE
+ PARAMETER ( ONE = 1.0D+0 )
+ DOUBLE PRECISION TWO
+ PARAMETER ( TWO = 2.0D+0 )
+ DOUBLE PRECISION THREE
+ PARAMETER ( THREE = 3.0D+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL UPPER
+ INTEGER COUNT, I, J, K, KASE, NZ
+ DOUBLE PRECISION EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK
+* ..
+* .. Local Arrays ..
+ INTEGER ISAVE( 3 )
+* ..
+* .. External Subroutines ..
+ EXTERNAL DAXPY, DCOPY, DLACN2, DPOTRS, DSYMV, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ DOUBLE PRECISION DLAMCH
+ EXTERNAL LSAME, DLAMCH
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( NRHS.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -5
+ ELSE IF( LDAF.LT.MAX( 1, N ) ) THEN
+ INFO = -7
+ ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -9
+ ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
+ INFO = -11
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DPORFS', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN
+ DO 10 J = 1, NRHS
+ FERR( J ) = ZERO
+ BERR( J ) = ZERO
+ 10 CONTINUE
+ RETURN
+ END IF
+*
+* NZ = maximum number of nonzero elements in each row of A, plus 1
+*
+ NZ = N + 1
+ EPS = DLAMCH( 'Epsilon' )
+ SAFMIN = DLAMCH( 'Safe minimum' )
+ SAFE1 = NZ*SAFMIN
+ SAFE2 = SAFE1 / EPS
+*
+* Do for each right hand side
+*
+ DO 140 J = 1, NRHS
+*
+ COUNT = 1
+ LSTRES = THREE
+ 20 CONTINUE
+*
+* Loop until stopping criterion is satisfied.
+*
+* Compute residual R = B - A * X
+*
+ CALL DCOPY( N, B( 1, J ), 1, WORK( N+1 ), 1 )
+ CALL DSYMV( UPLO, N, -ONE, A, LDA, X( 1, J ), 1, ONE,
+ $ WORK( N+1 ), 1 )
+*
+* Compute componentwise relative backward error from formula
+*
+* max(i) ( abs(R(i)) / ( abs(A)*abs(X) + abs(B) )(i) )
+*
+* where abs(Z) is the componentwise absolute value of the matrix
+* or vector Z. If the i-th component of the denominator is less
+* than SAFE2, then SAFE1 is added to the i-th components of the
+* numerator and denominator before dividing.
+*
+ DO 30 I = 1, N
+ WORK( I ) = ABS( B( I, J ) )
+ 30 CONTINUE
+*
+* Compute abs(A)*abs(X) + abs(B).
+*
+ IF( UPPER ) THEN
+ DO 50 K = 1, N
+ S = ZERO
+ XK = ABS( X( K, J ) )
+ DO 40 I = 1, K - 1
+ WORK( I ) = WORK( I ) + ABS( A( I, K ) )*XK
+ S = S + ABS( A( I, K ) )*ABS( X( I, J ) )
+ 40 CONTINUE
+ WORK( K ) = WORK( K ) + ABS( A( K, K ) )*XK + S
+ 50 CONTINUE
+ ELSE
+ DO 70 K = 1, N
+ S = ZERO
+ XK = ABS( X( K, J ) )
+ WORK( K ) = WORK( K ) + ABS( A( K, K ) )*XK
+ DO 60 I = K + 1, N
+ WORK( I ) = WORK( I ) + ABS( A( I, K ) )*XK
+ S = S + ABS( A( I, K ) )*ABS( X( I, J ) )
+ 60 CONTINUE
+ WORK( K ) = WORK( K ) + S
+ 70 CONTINUE
+ END IF
+ S = ZERO
+ DO 80 I = 1, N
+ IF( WORK( I ).GT.SAFE2 ) THEN
+ S = MAX( S, ABS( WORK( N+I ) ) / WORK( I ) )
+ ELSE
+ S = MAX( S, ( ABS( WORK( N+I ) )+SAFE1 ) /
+ $ ( WORK( I )+SAFE1 ) )
+ END IF
+ 80 CONTINUE
+ BERR( J ) = S
+*
+* Test stopping criterion. Continue iterating if
+* 1) The residual BERR(J) is larger than machine epsilon, and
+* 2) BERR(J) decreased by at least a factor of 2 during the
+* last iteration, and
+* 3) At most ITMAX iterations tried.
+*
+ IF( BERR( J ).GT.EPS .AND. TWO*BERR( J ).LE.LSTRES .AND.
+ $ COUNT.LE.ITMAX ) THEN
+*
+* Update solution and try again.
+*
+ CALL DPOTRS( UPLO, N, 1, AF, LDAF, WORK( N+1 ), N, INFO )
+ CALL DAXPY( N, ONE, WORK( N+1 ), 1, X( 1, J ), 1 )
+ LSTRES = BERR( J )
+ COUNT = COUNT + 1
+ GO TO 20
+ END IF
+*
+* Bound error from formula
+*
+* norm(X - XTRUE) / norm(X) .le. FERR =
+* norm( abs(inv(A))*
+* ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X)
+*
+* where
+* norm(Z) is the magnitude of the largest component of Z
+* inv(A) is the inverse of A
+* abs(Z) is the componentwise absolute value of the matrix or
+* vector Z
+* NZ is the maximum number of nonzeros in any row of A, plus 1
+* EPS is machine epsilon
+*
+* The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B))
+* is incremented by SAFE1 if the i-th component of
+* abs(A)*abs(X) + abs(B) is less than SAFE2.
+*
+* Use DLACN2 to estimate the infinity-norm of the matrix
+* inv(A) * diag(W),
+* where W = abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) )))
+*
+ DO 90 I = 1, N
+ IF( WORK( I ).GT.SAFE2 ) THEN
+ WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I )
+ ELSE
+ WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I ) + SAFE1
+ END IF
+ 90 CONTINUE
+*
+ KASE = 0
+ 100 CONTINUE
+ CALL DLACN2( N, WORK( 2*N+1 ), WORK( N+1 ), IWORK, FERR( J ),
+ $ KASE, ISAVE )
+ IF( KASE.NE.0 ) THEN
+ IF( KASE.EQ.1 ) THEN
+*
+* Multiply by diag(W)*inv(A').
+*
+ CALL DPOTRS( UPLO, N, 1, AF, LDAF, WORK( N+1 ), N, INFO )
+ DO 110 I = 1, N
+ WORK( N+I ) = WORK( I )*WORK( N+I )
+ 110 CONTINUE
+ ELSE IF( KASE.EQ.2 ) THEN
+*
+* Multiply by inv(A)*diag(W).
+*
+ DO 120 I = 1, N
+ WORK( N+I ) = WORK( I )*WORK( N+I )
+ 120 CONTINUE
+ CALL DPOTRS( UPLO, N, 1, AF, LDAF, WORK( N+1 ), N, INFO )
+ END IF
+ GO TO 100
+ END IF
+*
+* Normalize error.
+*
+ LSTRES = ZERO
+ DO 130 I = 1, N
+ LSTRES = MAX( LSTRES, ABS( X( I, J ) ) )
+ 130 CONTINUE
+ IF( LSTRES.NE.ZERO )
+ $ FERR( J ) = FERR( J ) / LSTRES
+*
+ 140 CONTINUE
+*
+ RETURN
+*
+* End of DPORFS
+*
+ END
+ SUBROUTINE DPOSV( UPLO, N, NRHS, A, LDA, B, LDB, INFO )
+*
+* -- LAPACK driver routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, LDA, LDB, N, NRHS
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION A( LDA, * ), B( LDB, * )
+* ..
+*
+* Purpose
+* =======
+*
+* DPOSV computes the solution to a real system of linear equations
+* A * X = B,
+* where A is an N-by-N symmetric positive definite matrix and X and B
+* are N-by-NRHS matrices.
+*
+* The Cholesky decomposition is used to factor A as
+* A = U**T* U, if UPLO = 'U', or
+* A = L * L**T, if UPLO = 'L',
+* where U is an upper triangular matrix and L is a lower triangular
+* matrix. The factored form of A is then used to solve the system of
+* equations A * X = B.
+*
+* Arguments
+* =========
+*
+* UPLO (input) CHARACTER*1
+* = 'U': Upper triangle of A is stored;
+* = 'L': Lower triangle of A is stored.
+*
+* N (input) INTEGER
+* The number of linear equations, i.e., the order of the
+* matrix A. N >= 0.
+*
+* NRHS (input) INTEGER
+* The number of right hand sides, i.e., the number of columns
+* of the matrix B. NRHS >= 0.
+*
+* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+* On entry, the symmetric matrix A. If UPLO = 'U', the leading
+* N-by-N upper triangular part of A contains the upper
+* triangular part of the matrix A, and the strictly lower
+* triangular part of A is not referenced. If UPLO = 'L', the
+* leading N-by-N lower triangular part of A contains the lower
+* triangular part of the matrix A, and the strictly upper
+* triangular part of A is not referenced.
+*
+* On exit, if INFO = 0, the factor U or L from the Cholesky
+* factorization A = U**T*U or A = L*L**T.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,N).
+*
+* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
+* On entry, the N-by-NRHS right hand side matrix B.
+* On exit, if INFO = 0, the N-by-NRHS solution matrix X.
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. LDB >= max(1,N).
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* > 0: if INFO = i, the leading minor of order i of A is not
+* positive definite, so the factorization could not be
+* completed, and the solution has not been computed.
+*
+* =====================================================================
+*
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL DPOTRF, DPOTRS, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( NRHS.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -5
+ ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -7
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DPOSV ', -INFO )
+ RETURN
+ END IF
+*
+* Compute the Cholesky factorization A = U'*U or A = L*L'.
+*
+ CALL DPOTRF( UPLO, N, A, LDA, INFO )
+ IF( INFO.EQ.0 ) THEN
+*
+* Solve the system A*X = B, overwriting B with X.
+*
+ CALL DPOTRS( UPLO, N, NRHS, A, LDA, B, LDB, INFO )
+*
+ END IF
+ RETURN
+*
+* End of DPOSV
+*
+ END
+ SUBROUTINE DPOSVX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, EQUED,
+ $ S, B, LDB, X, LDX, RCOND, FERR, BERR, WORK,
+ $ IWORK, INFO )
+*
+* -- LAPACK driver routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER EQUED, FACT, UPLO
+ INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS
+ DOUBLE PRECISION RCOND
+* ..
+* .. Array Arguments ..
+ INTEGER IWORK( * )
+ DOUBLE PRECISION A( LDA, * ), AF( LDAF, * ), B( LDB, * ),
+ $ BERR( * ), FERR( * ), S( * ), WORK( * ),
+ $ X( LDX, * )
+* ..
+*
+* Purpose
+* =======
+*
+* DPOSVX uses the Cholesky factorization A = U**T*U or A = L*L**T to
+* compute the solution to a real system of linear equations
+* A * X = B,
+* where A is an N-by-N symmetric positive definite matrix and X and B
+* are N-by-NRHS matrices.
+*
+* Error bounds on the solution and a condition estimate are also
+* provided.
+*
+* Description
+* ===========
+*
+* The following steps are performed:
+*
+* 1. If FACT = 'E', real scaling factors are computed to equilibrate
+* the system:
+* diag(S) * A * diag(S) * inv(diag(S)) * X = diag(S) * B
+* Whether or not the system will be equilibrated depends on the
+* scaling of the matrix A, but if equilibration is used, A is
+* overwritten by diag(S)*A*diag(S) and B by diag(S)*B.
+*
+* 2. If FACT = 'N' or 'E', the Cholesky decomposition is used to
+* factor the matrix A (after equilibration if FACT = 'E') as
+* A = U**T* U, if UPLO = 'U', or
+* A = L * L**T, if UPLO = 'L',
+* where U is an upper triangular matrix and L is a lower triangular
+* matrix.
+*
+* 3. If the leading i-by-i principal minor is not positive definite,
+* then the routine returns with INFO = i. Otherwise, the factored
+* form of A is used to estimate the condition number of the matrix
+* A. If the reciprocal of the condition number is less than machine
+* precision, INFO = N+1 is returned as a warning, but the routine
+* still goes on to solve for X and compute error bounds as
+* described below.
+*
+* 4. The system of equations is solved for X using the factored form
+* of A.
+*
+* 5. Iterative refinement is applied to improve the computed solution
+* matrix and calculate error bounds and backward error estimates
+* for it.
+*
+* 6. If equilibration was used, the matrix X is premultiplied by
+* diag(S) so that it solves the original system before
+* equilibration.
+*
+* Arguments
+* =========
+*
+* FACT (input) CHARACTER*1
+* Specifies whether or not the factored form of the matrix A is
+* supplied on entry, and if not, whether the matrix A should be
+* equilibrated before it is factored.
+* = 'F': On entry, AF contains the factored form of A.
+* If EQUED = 'Y', the matrix A has been equilibrated
+* with scaling factors given by S. A and AF will not
+* be modified.
+* = 'N': The matrix A will be copied to AF and factored.
+* = 'E': The matrix A will be equilibrated if necessary, then
+* copied to AF and factored.
+*
+* UPLO (input) CHARACTER*1
+* = 'U': Upper triangle of A is stored;
+* = 'L': Lower triangle of A is stored.
+*
+* N (input) INTEGER
+* The number of linear equations, i.e., the order of the
+* matrix A. N >= 0.
+*
+* NRHS (input) INTEGER
+* The number of right hand sides, i.e., the number of columns
+* of the matrices B and X. NRHS >= 0.
+*
+* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+* On entry, the symmetric matrix A, except if FACT = 'F' and
+* EQUED = 'Y', then A must contain the equilibrated matrix
+* diag(S)*A*diag(S). If UPLO = 'U', the leading
+* N-by-N upper triangular part of A contains the upper
+* triangular part of the matrix A, and the strictly lower
+* triangular part of A is not referenced. If UPLO = 'L', the
+* leading N-by-N lower triangular part of A contains the lower
+* triangular part of the matrix A, and the strictly upper
+* triangular part of A is not referenced. A is not modified if
+* FACT = 'F' or 'N', or if FACT = 'E' and EQUED = 'N' on exit.
+*
+* On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by
+* diag(S)*A*diag(S).
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,N).
+*
+* AF (input or output) DOUBLE PRECISION array, dimension (LDAF,N)
+* If FACT = 'F', then AF is an input argument and on entry
+* contains the triangular factor U or L from the Cholesky
+* factorization A = U**T*U or A = L*L**T, in the same storage
+* format as A. If EQUED .ne. 'N', then AF is the factored form
+* of the equilibrated matrix diag(S)*A*diag(S).
+*
+* If FACT = 'N', then AF is an output argument and on exit
+* returns the triangular factor U or L from the Cholesky
+* factorization A = U**T*U or A = L*L**T of the original
+* matrix A.
+*
+* If FACT = 'E', then AF is an output argument and on exit
+* returns the triangular factor U or L from the Cholesky
+* factorization A = U**T*U or A = L*L**T of the equilibrated
+* matrix A (see the description of A for the form of the
+* equilibrated matrix).
+*
+* LDAF (input) INTEGER
+* The leading dimension of the array AF. LDAF >= max(1,N).
+*
+* EQUED (input or output) CHARACTER*1
+* Specifies the form of equilibration that was done.
+* = 'N': No equilibration (always true if FACT = 'N').
+* = 'Y': Equilibration was done, i.e., A has been replaced by
+* diag(S) * A * diag(S).
+* EQUED is an input argument if FACT = 'F'; otherwise, it is an
+* output argument.
+*
+* S (input or output) DOUBLE PRECISION array, dimension (N)
+* The scale factors for A; not accessed if EQUED = 'N'. S is
+* an input argument if FACT = 'F'; otherwise, S is an output
+* argument. If FACT = 'F' and EQUED = 'Y', each element of S
+* must be positive.
+*
+* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
+* On entry, the N-by-NRHS right hand side matrix B.
+* On exit, if EQUED = 'N', B is not modified; if EQUED = 'Y',
+* B is overwritten by diag(S) * B.
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. LDB >= max(1,N).
+*
+* X (output) DOUBLE PRECISION array, dimension (LDX,NRHS)
+* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X to
+* the original system of equations. Note that if EQUED = 'Y',
+* A and B are modified on exit, and the solution to the
+* equilibrated system is inv(diag(S))*X.
+*
+* LDX (input) INTEGER
+* The leading dimension of the array X. LDX >= max(1,N).
+*
+* RCOND (output) DOUBLE PRECISION
+* The estimate of the reciprocal condition number of the matrix
+* A after equilibration (if done). If RCOND is less than the
+* machine precision (in particular, if RCOND = 0), the matrix
+* is singular to working precision. This condition is
+* indicated by a return code of INFO > 0.
+*
+* FERR (output) DOUBLE PRECISION array, dimension (NRHS)
+* The estimated forward error bound for each solution vector
+* X(j) (the j-th column of the solution matrix X).
+* If XTRUE is the true solution corresponding to X(j), FERR(j)
+* is an estimated upper bound for the magnitude of the largest
+* element in (X(j) - XTRUE) divided by the magnitude of the
+* largest element in X(j). The estimate is as reliable as
+* the estimate for RCOND, and is almost always a slight
+* overestimate of the true error.
+*
+* BERR (output) DOUBLE PRECISION array, dimension (NRHS)
+* The componentwise relative backward error of each solution
+* vector X(j) (i.e., the smallest relative change in
+* any element of A or B that makes X(j) an exact solution).
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (3*N)
+*
+* IWORK (workspace) INTEGER array, dimension (N)
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* > 0: if INFO = i, and i is
+* <= N: the leading minor of order i of A is
+* not positive definite, so the factorization
+* could not be completed, and the solution has not
+* been computed. RCOND = 0 is returned.
+* = N+1: U is nonsingular, but RCOND is less than machine
+* precision, meaning that the matrix is singular
+* to working precision. Nevertheless, the
+* solution and error bounds are computed because
+* there are a number of situations where the
+* computed solution can be more accurate than the
+* value of RCOND would suggest.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL EQUIL, NOFACT, RCEQU
+ INTEGER I, INFEQU, J
+ DOUBLE PRECISION AMAX, ANORM, BIGNUM, SCOND, SMAX, SMIN, SMLNUM
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ DOUBLE PRECISION DLAMCH, DLANSY
+ EXTERNAL LSAME, DLAMCH, DLANSY
+* ..
+* .. External Subroutines ..
+ EXTERNAL DLACPY, DLAQSY, DPOCON, DPOEQU, DPORFS, DPOTRF,
+ $ DPOTRS, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+ INFO = 0
+ NOFACT = LSAME( FACT, 'N' )
+ EQUIL = LSAME( FACT, 'E' )
+ IF( NOFACT .OR. EQUIL ) THEN
+ EQUED = 'N'
+ RCEQU = .FALSE.
+ ELSE
+ RCEQU = LSAME( EQUED, 'Y' )
+ SMLNUM = DLAMCH( 'Safe minimum' )
+ BIGNUM = ONE / SMLNUM
+ END IF
+*
+* Test the input parameters.
+*
+ IF( .NOT.NOFACT .AND. .NOT.EQUIL .AND. .NOT.LSAME( FACT, 'F' ) )
+ $ THEN
+ INFO = -1
+ ELSE IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) )
+ $ THEN
+ INFO = -2
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( NRHS.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -6
+ ELSE IF( LDAF.LT.MAX( 1, N ) ) THEN
+ INFO = -8
+ ELSE IF( LSAME( FACT, 'F' ) .AND. .NOT.
+ $ ( RCEQU .OR. LSAME( EQUED, 'N' ) ) ) THEN
+ INFO = -9
+ ELSE
+ IF( RCEQU ) THEN
+ SMIN = BIGNUM
+ SMAX = ZERO
+ DO 10 J = 1, N
+ SMIN = MIN( SMIN, S( J ) )
+ SMAX = MAX( SMAX, S( J ) )
+ 10 CONTINUE
+ IF( SMIN.LE.ZERO ) THEN
+ INFO = -10
+ ELSE IF( N.GT.0 ) THEN
+ SCOND = MAX( SMIN, SMLNUM ) / MIN( SMAX, BIGNUM )
+ ELSE
+ SCOND = ONE
+ END IF
+ END IF
+ IF( INFO.EQ.0 ) THEN
+ IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -12
+ ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
+ INFO = -14
+ END IF
+ END IF
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DPOSVX', -INFO )
+ RETURN
+ END IF
+*
+ IF( EQUIL ) THEN
+*
+* Compute row and column scalings to equilibrate the matrix A.
+*
+ CALL DPOEQU( N, A, LDA, S, SCOND, AMAX, INFEQU )
+ IF( INFEQU.EQ.0 ) THEN
+*
+* Equilibrate the matrix.
+*
+ CALL DLAQSY( UPLO, N, A, LDA, S, SCOND, AMAX, EQUED )
+ RCEQU = LSAME( EQUED, 'Y' )
+ END IF
+ END IF
+*
+* Scale the right hand side.
+*
+ IF( RCEQU ) THEN
+ DO 30 J = 1, NRHS
+ DO 20 I = 1, N
+ B( I, J ) = S( I )*B( I, J )
+ 20 CONTINUE
+ 30 CONTINUE
+ END IF
+*
+ IF( NOFACT .OR. EQUIL ) THEN
+*
+* Compute the Cholesky factorization A = U'*U or A = L*L'.
+*
+ CALL DLACPY( UPLO, N, N, A, LDA, AF, LDAF )
+ CALL DPOTRF( UPLO, N, AF, LDAF, INFO )
+*
+* Return if INFO is non-zero.
+*
+ IF( INFO.GT.0 )THEN
+ RCOND = ZERO
+ RETURN
+ END IF
+ END IF
+*
+* Compute the norm of the matrix A.
+*
+ ANORM = DLANSY( '1', UPLO, N, A, LDA, WORK )
+*
+* Compute the reciprocal of the condition number of A.
+*
+ CALL DPOCON( UPLO, N, AF, LDAF, ANORM, RCOND, WORK, IWORK, INFO )
+*
+* Compute the solution matrix X.
+*
+ CALL DLACPY( 'Full', N, NRHS, B, LDB, X, LDX )
+ CALL DPOTRS( UPLO, N, NRHS, AF, LDAF, X, LDX, INFO )
+*
+* Use iterative refinement to improve the computed solution and
+* compute error bounds and backward error estimates for it.
+*
+ CALL DPORFS( UPLO, N, NRHS, A, LDA, AF, LDAF, B, LDB, X, LDX,
+ $ FERR, BERR, WORK, IWORK, INFO )
+*
+* Transform the solution matrix X to a solution of the original
+* system.
+*
+ IF( RCEQU ) THEN
+ DO 50 J = 1, NRHS
+ DO 40 I = 1, N
+ X( I, J ) = S( I )*X( I, J )
+ 40 CONTINUE
+ 50 CONTINUE
+ DO 60 J = 1, NRHS
+ FERR( J ) = FERR( J ) / SCOND
+ 60 CONTINUE
+ END IF
+*
+* Set INFO = N+1 if the matrix is singular to working precision.
+*
+ IF( RCOND.LT.DLAMCH( 'Epsilon' ) )
+ $ INFO = N + 1
+*
+ RETURN
+*
+* End of DPOSVX
+*
+ END
+ SUBROUTINE DPOTF2( UPLO, N, A, LDA, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, LDA, N
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION A( LDA, * )
+* ..
+*
+* Purpose
+* =======
+*
+* DPOTF2 computes the Cholesky factorization of a real symmetric
+* positive definite matrix A.
+*
+* The factorization has the form
+* A = U' * U , if UPLO = 'U', or
+* A = L * L', if UPLO = 'L',
+* where U is an upper triangular matrix and L is lower triangular.
+*
+* This is the unblocked version of the algorithm, calling Level 2 BLAS.
+*
+* Arguments
+* =========
+*
+* UPLO (input) CHARACTER*1
+* Specifies whether the upper or lower triangular part of the
+* symmetric matrix A is stored.
+* = 'U': Upper triangular
+* = 'L': Lower triangular
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+* On entry, the symmetric matrix A. If UPLO = 'U', the leading
+* n by n upper triangular part of A contains the upper
+* triangular part of the matrix A, and the strictly lower
+* triangular part of A is not referenced. If UPLO = 'L', the
+* leading n by n lower triangular part of A contains the lower
+* triangular part of the matrix A, and the strictly upper
+* triangular part of A is not referenced.
+*
+* On exit, if INFO = 0, the factor U or L from the Cholesky
+* factorization A = U'*U or A = L*L'.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,N).
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -k, the k-th argument had an illegal value
+* > 0: if INFO = k, the leading minor of order k is not
+* positive definite, and the factorization could not be
+* completed.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE, ZERO
+ PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL UPPER
+ INTEGER J
+ DOUBLE PRECISION AJJ
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ DOUBLE PRECISION DDOT
+ EXTERNAL LSAME, DDOT
+* ..
+* .. External Subroutines ..
+ EXTERNAL DGEMV, DSCAL, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, SQRT
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -4
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DPOTF2', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+ IF( UPPER ) THEN
+*
+* Compute the Cholesky factorization A = U'*U.
+*
+ DO 10 J = 1, N
+*
+* Compute U(J,J) and test for non-positive-definiteness.
+*
+ AJJ = A( J, J ) - DDOT( J-1, A( 1, J ), 1, A( 1, J ), 1 )
+ IF( AJJ.LE.ZERO ) THEN
+ A( J, J ) = AJJ
+ GO TO 30
+ END IF
+ AJJ = SQRT( AJJ )
+ A( J, J ) = AJJ
+*
+* Compute elements J+1:N of row J.
+*
+ IF( J.LT.N ) THEN
+ CALL DGEMV( 'Transpose', J-1, N-J, -ONE, A( 1, J+1 ),
+ $ LDA, A( 1, J ), 1, ONE, A( J, J+1 ), LDA )
+ CALL DSCAL( N-J, ONE / AJJ, A( J, J+1 ), LDA )
+ END IF
+ 10 CONTINUE
+ ELSE
+*
+* Compute the Cholesky factorization A = L*L'.
+*
+ DO 20 J = 1, N
+*
+* Compute L(J,J) and test for non-positive-definiteness.
+*
+ AJJ = A( J, J ) - DDOT( J-1, A( J, 1 ), LDA, A( J, 1 ),
+ $ LDA )
+ IF( AJJ.LE.ZERO ) THEN
+ A( J, J ) = AJJ
+ GO TO 30
+ END IF
+ AJJ = SQRT( AJJ )
+ A( J, J ) = AJJ
+*
+* Compute elements J+1:N of column J.
+*
+ IF( J.LT.N ) THEN
+ CALL DGEMV( 'No transpose', N-J, J-1, -ONE, A( J+1, 1 ),
+ $ LDA, A( J, 1 ), LDA, ONE, A( J+1, J ), 1 )
+ CALL DSCAL( N-J, ONE / AJJ, A( J+1, J ), 1 )
+ END IF
+ 20 CONTINUE
+ END IF
+ GO TO 40
+*
+ 30 CONTINUE
+ INFO = J
+*
+ 40 CONTINUE
+ RETURN
+*
+* End of DPOTF2
+*
+ END
+ SUBROUTINE DPOTRF( UPLO, N, A, LDA, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, LDA, N
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION A( LDA, * )
+* ..
+*
+* Purpose
+* =======
+*
+* DPOTRF computes the Cholesky factorization of a real symmetric
+* positive definite matrix A.
+*
+* The factorization has the form
+* A = U**T * U, if UPLO = 'U', or
+* A = L * L**T, if UPLO = 'L',
+* where U is an upper triangular matrix and L is lower triangular.
+*
+* This is the block version of the algorithm, calling Level 3 BLAS.
+*
+* Arguments
+* =========
+*
+* UPLO (input) CHARACTER*1
+* = 'U': Upper triangle of A is stored;
+* = 'L': Lower triangle of A is stored.
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+* On entry, the symmetric matrix A. If UPLO = 'U', the leading
+* N-by-N upper triangular part of A contains the upper
+* triangular part of the matrix A, and the strictly lower
+* triangular part of A is not referenced. If UPLO = 'L', the
+* leading N-by-N lower triangular part of A contains the lower
+* triangular part of the matrix A, and the strictly upper
+* triangular part of A is not referenced.
+*
+* On exit, if INFO = 0, the factor U or L from the Cholesky
+* factorization A = U**T*U or A = L*L**T.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,N).
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* > 0: if INFO = i, the leading minor of order i is not
+* positive definite, and the factorization could not be
+* completed.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE
+ PARAMETER ( ONE = 1.0D+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL UPPER
+ INTEGER J, JB, NB
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ILAENV
+ EXTERNAL LSAME, ILAENV
+* ..
+* .. External Subroutines ..
+ EXTERNAL DGEMM, DPOTF2, DSYRK, DTRSM, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -4
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DPOTRF', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+* Determine the block size for this environment.
+*
+ NB = ILAENV( 1, 'DPOTRF', UPLO, N, -1, -1, -1 )
+ IF( NB.LE.1 .OR. NB.GE.N ) THEN
+*
+* Use unblocked code.
+*
+ CALL DPOTF2( UPLO, N, A, LDA, INFO )
+ ELSE
+*
+* Use blocked code.
+*
+ IF( UPPER ) THEN
+*
+* Compute the Cholesky factorization A = U'*U.
+*
+ DO 10 J = 1, N, NB
+*
+* Update and factorize the current diagonal block and test
+* for non-positive-definiteness.
+*
+ JB = MIN( NB, N-J+1 )
+ CALL DSYRK( 'Upper', 'Transpose', JB, J-1, -ONE,
+ $ A( 1, J ), LDA, ONE, A( J, J ), LDA )
+ CALL DPOTF2( 'Upper', JB, A( J, J ), LDA, INFO )
+ IF( INFO.NE.0 )
+ $ GO TO 30
+ IF( J+JB.LE.N ) THEN
+*
+* Compute the current block row.
+*
+ CALL DGEMM( 'Transpose', 'No transpose', JB, N-J-JB+1,
+ $ J-1, -ONE, A( 1, J ), LDA, A( 1, J+JB ),
+ $ LDA, ONE, A( J, J+JB ), LDA )
+ CALL DTRSM( 'Left', 'Upper', 'Transpose', 'Non-unit',
+ $ JB, N-J-JB+1, ONE, A( J, J ), LDA,
+ $ A( J, J+JB ), LDA )
+ END IF
+ 10 CONTINUE
+*
+ ELSE
+*
+* Compute the Cholesky factorization A = L*L'.
+*
+ DO 20 J = 1, N, NB
+*
+* Update and factorize the current diagonal block and test
+* for non-positive-definiteness.
+*
+ JB = MIN( NB, N-J+1 )
+ CALL DSYRK( 'Lower', 'No transpose', JB, J-1, -ONE,
+ $ A( J, 1 ), LDA, ONE, A( J, J ), LDA )
+ CALL DPOTF2( 'Lower', JB, A( J, J ), LDA, INFO )
+ IF( INFO.NE.0 )
+ $ GO TO 30
+ IF( J+JB.LE.N ) THEN
+*
+* Compute the current block column.
+*
+ CALL DGEMM( 'No transpose', 'Transpose', N-J-JB+1, JB,
+ $ J-1, -ONE, A( J+JB, 1 ), LDA, A( J, 1 ),
+ $ LDA, ONE, A( J+JB, J ), LDA )
+ CALL DTRSM( 'Right', 'Lower', 'Transpose', 'Non-unit',
+ $ N-J-JB+1, JB, ONE, A( J, J ), LDA,
+ $ A( J+JB, J ), LDA )
+ END IF
+ 20 CONTINUE
+ END IF
+ END IF
+ GO TO 40
+*
+ 30 CONTINUE
+ INFO = INFO + J - 1
+*
+ 40 CONTINUE
+ RETURN
+*
+* End of DPOTRF
+*
+ END
+ SUBROUTINE DPOTRI( UPLO, N, A, LDA, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, LDA, N
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION A( LDA, * )
+* ..
+*
+* Purpose
+* =======
+*
+* DPOTRI computes the inverse of a real symmetric positive definite
+* matrix A using the Cholesky factorization A = U**T*U or A = L*L**T
+* computed by DPOTRF.
+*
+* Arguments
+* =========
+*
+* UPLO (input) CHARACTER*1
+* = 'U': Upper triangle of A is stored;
+* = 'L': Lower triangle of A is stored.
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+* On entry, the triangular factor U or L from the Cholesky
+* factorization A = U**T*U or A = L*L**T, as computed by
+* DPOTRF.
+* On exit, the upper or lower triangle of the (symmetric)
+* inverse of A, overwriting the input factor U or L.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,N).
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* > 0: if INFO = i, the (i,i) element of the factor U or L is
+* zero, and the inverse could not be computed.
+*
+* =====================================================================
+*
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL DLAUUM, DTRTRI, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -4
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DPOTRI', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+* Invert the triangular Cholesky factor U or L.
+*
+ CALL DTRTRI( UPLO, 'Non-unit', N, A, LDA, INFO )
+ IF( INFO.GT.0 )
+ $ RETURN
+*
+* Form inv(U)*inv(U)' or inv(L)'*inv(L).
+*
+ CALL DLAUUM( UPLO, N, A, LDA, INFO )
+*
+ RETURN
+*
+* End of DPOTRI
+*
+ END
+ SUBROUTINE DPOTRS( UPLO, N, NRHS, A, LDA, B, LDB, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, LDA, LDB, N, NRHS
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION A( LDA, * ), B( LDB, * )
+* ..
+*
+* Purpose
+* =======
+*
+* DPOTRS solves a system of linear equations A*X = B with a symmetric
+* positive definite matrix A using the Cholesky factorization
+* A = U**T*U or A = L*L**T computed by DPOTRF.
+*
+* Arguments
+* =========
+*
+* UPLO (input) CHARACTER*1
+* = 'U': Upper triangle of A is stored;
+* = 'L': Lower triangle of A is stored.
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* NRHS (input) INTEGER
+* The number of right hand sides, i.e., the number of columns
+* of the matrix B. NRHS >= 0.
+*
+* A (input) DOUBLE PRECISION array, dimension (LDA,N)
+* The triangular factor U or L from the Cholesky factorization
+* A = U**T*U or A = L*L**T, as computed by DPOTRF.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,N).
+*
+* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
+* On entry, the right hand side matrix B.
+* On exit, the solution matrix X.
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. LDB >= max(1,N).
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE
+ PARAMETER ( ONE = 1.0D+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL UPPER
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL DTRSM, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( NRHS.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -5
+ ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -7
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DPOTRS', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 .OR. NRHS.EQ.0 )
+ $ RETURN
+*
+ IF( UPPER ) THEN
+*
+* Solve A*X = B where A = U'*U.
+*
+* Solve U'*X = B, overwriting B with X.
+*
+ CALL DTRSM( 'Left', 'Upper', 'Transpose', 'Non-unit', N, NRHS,
+ $ ONE, A, LDA, B, LDB )
+*
+* Solve U*X = B, overwriting B with X.
+*
+ CALL DTRSM( 'Left', 'Upper', 'No transpose', 'Non-unit', N,
+ $ NRHS, ONE, A, LDA, B, LDB )
+ ELSE
+*
+* Solve A*X = B where A = L*L'.
+*
+* Solve L*X = B, overwriting B with X.
+*
+ CALL DTRSM( 'Left', 'Lower', 'No transpose', 'Non-unit', N,
+ $ NRHS, ONE, A, LDA, B, LDB )
+*
+* Solve L'*X = B, overwriting B with X.
+*
+ CALL DTRSM( 'Left', 'Lower', 'Transpose', 'Non-unit', N, NRHS,
+ $ ONE, A, LDA, B, LDB )
+ END IF
+*
+ RETURN
+*
+* End of DPOTRS
+*
+ END
+ SUBROUTINE DPPCON( UPLO, N, AP, ANORM, RCOND, WORK, IWORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH.
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, N
+ DOUBLE PRECISION ANORM, RCOND
+* ..
+* .. Array Arguments ..
+ INTEGER IWORK( * )
+ DOUBLE PRECISION AP( * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DPPCON estimates the reciprocal of the condition number (in the
+* 1-norm) of a real symmetric positive definite packed matrix using
+* the Cholesky factorization A = U**T*U or A = L*L**T computed by
+* DPPTRF.
+*
+* An estimate is obtained for norm(inv(A)), and the reciprocal of the
+* condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).
+*
+* Arguments
+* =========
+*
+* UPLO (input) CHARACTER*1
+* = 'U': Upper triangle of A is stored;
+* = 'L': Lower triangle of A is stored.
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)
+* The triangular factor U or L from the Cholesky factorization
+* A = U**T*U or A = L*L**T, packed columnwise in a linear
+* array. The j-th column of U or L is stored in the array AP
+* as follows:
+* if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j;
+* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n.
+*
+* ANORM (input) DOUBLE PRECISION
+* The 1-norm (or infinity-norm) of the symmetric matrix A.
+*
+* RCOND (output) DOUBLE PRECISION
+* The reciprocal of the condition number of the matrix A,
+* computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an
+* estimate of the 1-norm of inv(A) computed in this routine.
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (3*N)
+*
+* IWORK (workspace) INTEGER array, dimension (N)
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE, ZERO
+ PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL UPPER
+ CHARACTER NORMIN
+ INTEGER IX, KASE
+ DOUBLE PRECISION AINVNM, SCALE, SCALEL, SCALEU, SMLNUM
+* ..
+* .. Local Arrays ..
+ INTEGER ISAVE( 3 )
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER IDAMAX
+ DOUBLE PRECISION DLAMCH
+ EXTERNAL LSAME, IDAMAX, DLAMCH
+* ..
+* .. External Subroutines ..
+ EXTERNAL DLACN2, DLATPS, DRSCL, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( ANORM.LT.ZERO ) THEN
+ INFO = -4
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DPPCON', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ RCOND = ZERO
+ IF( N.EQ.0 ) THEN
+ RCOND = ONE
+ RETURN
+ ELSE IF( ANORM.EQ.ZERO ) THEN
+ RETURN
+ END IF
+*
+ SMLNUM = DLAMCH( 'Safe minimum' )
+*
+* Estimate the 1-norm of the inverse.
+*
+ KASE = 0
+ NORMIN = 'N'
+ 10 CONTINUE
+ CALL DLACN2( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE, ISAVE )
+ IF( KASE.NE.0 ) THEN
+ IF( UPPER ) THEN
+*
+* Multiply by inv(U').
+*
+ CALL DLATPS( 'Upper', 'Transpose', 'Non-unit', NORMIN, N,
+ $ AP, WORK, SCALEL, WORK( 2*N+1 ), INFO )
+ NORMIN = 'Y'
+*
+* Multiply by inv(U).
+*
+ CALL DLATPS( 'Upper', 'No transpose', 'Non-unit', NORMIN, N,
+ $ AP, WORK, SCALEU, WORK( 2*N+1 ), INFO )
+ ELSE
+*
+* Multiply by inv(L).
+*
+ CALL DLATPS( 'Lower', 'No transpose', 'Non-unit', NORMIN, N,
+ $ AP, WORK, SCALEL, WORK( 2*N+1 ), INFO )
+ NORMIN = 'Y'
+*
+* Multiply by inv(L').
+*
+ CALL DLATPS( 'Lower', 'Transpose', 'Non-unit', NORMIN, N,
+ $ AP, WORK, SCALEU, WORK( 2*N+1 ), INFO )
+ END IF
+*
+* Multiply by 1/SCALE if doing so will not cause overflow.
+*
+ SCALE = SCALEL*SCALEU
+ IF( SCALE.NE.ONE ) THEN
+ IX = IDAMAX( N, WORK, 1 )
+ IF( SCALE.LT.ABS( WORK( IX ) )*SMLNUM .OR. SCALE.EQ.ZERO )
+ $ GO TO 20
+ CALL DRSCL( N, SCALE, WORK, 1 )
+ END IF
+ GO TO 10
+ END IF
+*
+* Compute the estimate of the reciprocal condition number.
+*
+ IF( AINVNM.NE.ZERO )
+ $ RCOND = ( ONE / AINVNM ) / ANORM
+*
+ 20 CONTINUE
+ RETURN
+*
+* End of DPPCON
+*
+ END
+ SUBROUTINE DPPEQU( UPLO, N, AP, S, SCOND, AMAX, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, N
+ DOUBLE PRECISION AMAX, SCOND
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION AP( * ), S( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DPPEQU computes row and column scalings intended to equilibrate a
+* symmetric positive definite matrix A in packed storage and reduce
+* its condition number (with respect to the two-norm). S contains the
+* scale factors, S(i)=1/sqrt(A(i,i)), chosen so that the scaled matrix
+* B with elements B(i,j)=S(i)*A(i,j)*S(j) has ones on the diagonal.
+* This choice of S puts the condition number of B within a factor N of
+* the smallest possible condition number over all possible diagonal
+* scalings.
+*
+* Arguments
+* =========
+*
+* UPLO (input) CHARACTER*1
+* = 'U': Upper triangle of A is stored;
+* = 'L': Lower triangle of A is stored.
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)
+* The upper or lower triangle of the symmetric matrix A, packed
+* columnwise in a linear array. The j-th column of A is stored
+* in the array AP as follows:
+* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
+* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
+*
+* S (output) DOUBLE PRECISION array, dimension (N)
+* If INFO = 0, S contains the scale factors for A.
+*
+* SCOND (output) DOUBLE PRECISION
+* If INFO = 0, S contains the ratio of the smallest S(i) to
+* the largest S(i). If SCOND >= 0.1 and AMAX is neither too
+* large nor too small, it is not worth scaling by S.
+*
+* AMAX (output) DOUBLE PRECISION
+* Absolute value of largest matrix element. If AMAX is very
+* close to overflow or very close to underflow, the matrix
+* should be scaled.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* > 0: if INFO = i, the i-th diagonal element is nonpositive.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE, ZERO
+ PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL UPPER
+ INTEGER I, JJ
+ DOUBLE PRECISION SMIN
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN, SQRT
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DPPEQU', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 ) THEN
+ SCOND = ONE
+ AMAX = ZERO
+ RETURN
+ END IF
+*
+* Initialize SMIN and AMAX.
+*
+ S( 1 ) = AP( 1 )
+ SMIN = S( 1 )
+ AMAX = S( 1 )
+*
+ IF( UPPER ) THEN
+*
+* UPLO = 'U': Upper triangle of A is stored.
+* Find the minimum and maximum diagonal elements.
+*
+ JJ = 1
+ DO 10 I = 2, N
+ JJ = JJ + I
+ S( I ) = AP( JJ )
+ SMIN = MIN( SMIN, S( I ) )
+ AMAX = MAX( AMAX, S( I ) )
+ 10 CONTINUE
+*
+ ELSE
+*
+* UPLO = 'L': Lower triangle of A is stored.
+* Find the minimum and maximum diagonal elements.
+*
+ JJ = 1
+ DO 20 I = 2, N
+ JJ = JJ + N - I + 2
+ S( I ) = AP( JJ )
+ SMIN = MIN( SMIN, S( I ) )
+ AMAX = MAX( AMAX, S( I ) )
+ 20 CONTINUE
+ END IF
+*
+ IF( SMIN.LE.ZERO ) THEN
+*
+* Find the first non-positive diagonal element and return.
+*
+ DO 30 I = 1, N
+ IF( S( I ).LE.ZERO ) THEN
+ INFO = I
+ RETURN
+ END IF
+ 30 CONTINUE
+ ELSE
+*
+* Set the scale factors to the reciprocals
+* of the diagonal elements.
+*
+ DO 40 I = 1, N
+ S( I ) = ONE / SQRT( S( I ) )
+ 40 CONTINUE
+*
+* Compute SCOND = min(S(I)) / max(S(I))
+*
+ SCOND = SQRT( SMIN ) / SQRT( AMAX )
+ END IF
+ RETURN
+*
+* End of DPPEQU
+*
+ END
+ SUBROUTINE DPPRFS( UPLO, N, NRHS, AP, AFP, B, LDB, X, LDX, FERR,
+ $ BERR, WORK, IWORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH.
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, LDB, LDX, N, NRHS
+* ..
+* .. Array Arguments ..
+ INTEGER IWORK( * )
+ DOUBLE PRECISION AFP( * ), AP( * ), B( LDB, * ), BERR( * ),
+ $ FERR( * ), WORK( * ), X( LDX, * )
+* ..
+*
+* Purpose
+* =======
+*
+* DPPRFS improves the computed solution to a system of linear
+* equations when the coefficient matrix is symmetric positive definite
+* and packed, and provides error bounds and backward error estimates
+* for the solution.
+*
+* Arguments
+* =========
+*
+* UPLO (input) CHARACTER*1
+* = 'U': Upper triangle of A is stored;
+* = 'L': Lower triangle of A is stored.
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* NRHS (input) INTEGER
+* The number of right hand sides, i.e., the number of columns
+* of the matrices B and X. NRHS >= 0.
+*
+* AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)
+* The upper or lower triangle of the symmetric matrix A, packed
+* columnwise in a linear array. The j-th column of A is stored
+* in the array AP as follows:
+* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
+* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
+*
+* AFP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)
+* The triangular factor U or L from the Cholesky factorization
+* A = U**T*U or A = L*L**T, as computed by DPPTRF/ZPPTRF,
+* packed columnwise in a linear array in the same format as A
+* (see AP).
+*
+* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS)
+* The right hand side matrix B.
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. LDB >= max(1,N).
+*
+* X (input/output) DOUBLE PRECISION array, dimension (LDX,NRHS)
+* On entry, the solution matrix X, as computed by DPPTRS.
+* On exit, the improved solution matrix X.
+*
+* LDX (input) INTEGER
+* The leading dimension of the array X. LDX >= max(1,N).
+*
+* FERR (output) DOUBLE PRECISION array, dimension (NRHS)
+* The estimated forward error bound for each solution vector
+* X(j) (the j-th column of the solution matrix X).
+* If XTRUE is the true solution corresponding to X(j), FERR(j)
+* is an estimated upper bound for the magnitude of the largest
+* element in (X(j) - XTRUE) divided by the magnitude of the
+* largest element in X(j). The estimate is as reliable as
+* the estimate for RCOND, and is almost always a slight
+* overestimate of the true error.
+*
+* BERR (output) DOUBLE PRECISION array, dimension (NRHS)
+* The componentwise relative backward error of each solution
+* vector X(j) (i.e., the smallest relative change in
+* any element of A or B that makes X(j) an exact solution).
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (3*N)
+*
+* IWORK (workspace) INTEGER array, dimension (N)
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+*
+* Internal Parameters
+* ===================
+*
+* ITMAX is the maximum number of steps of iterative refinement.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ INTEGER ITMAX
+ PARAMETER ( ITMAX = 5 )
+ DOUBLE PRECISION ZERO
+ PARAMETER ( ZERO = 0.0D+0 )
+ DOUBLE PRECISION ONE
+ PARAMETER ( ONE = 1.0D+0 )
+ DOUBLE PRECISION TWO
+ PARAMETER ( TWO = 2.0D+0 )
+ DOUBLE PRECISION THREE
+ PARAMETER ( THREE = 3.0D+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL UPPER
+ INTEGER COUNT, I, IK, J, K, KASE, KK, NZ
+ DOUBLE PRECISION EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK
+* ..
+* .. Local Arrays ..
+ INTEGER ISAVE( 3 )
+* ..
+* .. External Subroutines ..
+ EXTERNAL DAXPY, DCOPY, DLACN2, DPPTRS, DSPMV, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ DOUBLE PRECISION DLAMCH
+ EXTERNAL LSAME, DLAMCH
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( NRHS.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -7
+ ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
+ INFO = -9
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DPPRFS', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN
+ DO 10 J = 1, NRHS
+ FERR( J ) = ZERO
+ BERR( J ) = ZERO
+ 10 CONTINUE
+ RETURN
+ END IF
+*
+* NZ = maximum number of nonzero elements in each row of A, plus 1
+*
+ NZ = N + 1
+ EPS = DLAMCH( 'Epsilon' )
+ SAFMIN = DLAMCH( 'Safe minimum' )
+ SAFE1 = NZ*SAFMIN
+ SAFE2 = SAFE1 / EPS
+*
+* Do for each right hand side
+*
+ DO 140 J = 1, NRHS
+*
+ COUNT = 1
+ LSTRES = THREE
+ 20 CONTINUE
+*
+* Loop until stopping criterion is satisfied.
+*
+* Compute residual R = B - A * X
+*
+ CALL DCOPY( N, B( 1, J ), 1, WORK( N+1 ), 1 )
+ CALL DSPMV( UPLO, N, -ONE, AP, X( 1, J ), 1, ONE, WORK( N+1 ),
+ $ 1 )
+*
+* Compute componentwise relative backward error from formula
+*
+* max(i) ( abs(R(i)) / ( abs(A)*abs(X) + abs(B) )(i) )
+*
+* where abs(Z) is the componentwise absolute value of the matrix
+* or vector Z. If the i-th component of the denominator is less
+* than SAFE2, then SAFE1 is added to the i-th components of the
+* numerator and denominator before dividing.
+*
+ DO 30 I = 1, N
+ WORK( I ) = ABS( B( I, J ) )
+ 30 CONTINUE
+*
+* Compute abs(A)*abs(X) + abs(B).
+*
+ KK = 1
+ IF( UPPER ) THEN
+ DO 50 K = 1, N
+ S = ZERO
+ XK = ABS( X( K, J ) )
+ IK = KK
+ DO 40 I = 1, K - 1
+ WORK( I ) = WORK( I ) + ABS( AP( IK ) )*XK
+ S = S + ABS( AP( IK ) )*ABS( X( I, J ) )
+ IK = IK + 1
+ 40 CONTINUE
+ WORK( K ) = WORK( K ) + ABS( AP( KK+K-1 ) )*XK + S
+ KK = KK + K
+ 50 CONTINUE
+ ELSE
+ DO 70 K = 1, N
+ S = ZERO
+ XK = ABS( X( K, J ) )
+ WORK( K ) = WORK( K ) + ABS( AP( KK ) )*XK
+ IK = KK + 1
+ DO 60 I = K + 1, N
+ WORK( I ) = WORK( I ) + ABS( AP( IK ) )*XK
+ S = S + ABS( AP( IK ) )*ABS( X( I, J ) )
+ IK = IK + 1
+ 60 CONTINUE
+ WORK( K ) = WORK( K ) + S
+ KK = KK + ( N-K+1 )
+ 70 CONTINUE
+ END IF
+ S = ZERO
+ DO 80 I = 1, N
+ IF( WORK( I ).GT.SAFE2 ) THEN
+ S = MAX( S, ABS( WORK( N+I ) ) / WORK( I ) )
+ ELSE
+ S = MAX( S, ( ABS( WORK( N+I ) )+SAFE1 ) /
+ $ ( WORK( I )+SAFE1 ) )
+ END IF
+ 80 CONTINUE
+ BERR( J ) = S
+*
+* Test stopping criterion. Continue iterating if
+* 1) The residual BERR(J) is larger than machine epsilon, and
+* 2) BERR(J) decreased by at least a factor of 2 during the
+* last iteration, and
+* 3) At most ITMAX iterations tried.
+*
+ IF( BERR( J ).GT.EPS .AND. TWO*BERR( J ).LE.LSTRES .AND.
+ $ COUNT.LE.ITMAX ) THEN
+*
+* Update solution and try again.
+*
+ CALL DPPTRS( UPLO, N, 1, AFP, WORK( N+1 ), N, INFO )
+ CALL DAXPY( N, ONE, WORK( N+1 ), 1, X( 1, J ), 1 )
+ LSTRES = BERR( J )
+ COUNT = COUNT + 1
+ GO TO 20
+ END IF
+*
+* Bound error from formula
+*
+* norm(X - XTRUE) / norm(X) .le. FERR =
+* norm( abs(inv(A))*
+* ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X)
+*
+* where
+* norm(Z) is the magnitude of the largest component of Z
+* inv(A) is the inverse of A
+* abs(Z) is the componentwise absolute value of the matrix or
+* vector Z
+* NZ is the maximum number of nonzeros in any row of A, plus 1
+* EPS is machine epsilon
+*
+* The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B))
+* is incremented by SAFE1 if the i-th component of
+* abs(A)*abs(X) + abs(B) is less than SAFE2.
+*
+* Use DLACN2 to estimate the infinity-norm of the matrix
+* inv(A) * diag(W),
+* where W = abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) )))
+*
+ DO 90 I = 1, N
+ IF( WORK( I ).GT.SAFE2 ) THEN
+ WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I )
+ ELSE
+ WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I ) + SAFE1
+ END IF
+ 90 CONTINUE
+*
+ KASE = 0
+ 100 CONTINUE
+ CALL DLACN2( N, WORK( 2*N+1 ), WORK( N+1 ), IWORK, FERR( J ),
+ $ KASE, ISAVE )
+ IF( KASE.NE.0 ) THEN
+ IF( KASE.EQ.1 ) THEN
+*
+* Multiply by diag(W)*inv(A').
+*
+ CALL DPPTRS( UPLO, N, 1, AFP, WORK( N+1 ), N, INFO )
+ DO 110 I = 1, N
+ WORK( N+I ) = WORK( I )*WORK( N+I )
+ 110 CONTINUE
+ ELSE IF( KASE.EQ.2 ) THEN
+*
+* Multiply by inv(A)*diag(W).
+*
+ DO 120 I = 1, N
+ WORK( N+I ) = WORK( I )*WORK( N+I )
+ 120 CONTINUE
+ CALL DPPTRS( UPLO, N, 1, AFP, WORK( N+1 ), N, INFO )
+ END IF
+ GO TO 100
+ END IF
+*
+* Normalize error.
+*
+ LSTRES = ZERO
+ DO 130 I = 1, N
+ LSTRES = MAX( LSTRES, ABS( X( I, J ) ) )
+ 130 CONTINUE
+ IF( LSTRES.NE.ZERO )
+ $ FERR( J ) = FERR( J ) / LSTRES
+*
+ 140 CONTINUE
+*
+ RETURN
+*
+* End of DPPRFS
+*
+ END
+ SUBROUTINE DPPSV( UPLO, N, NRHS, AP, B, LDB, INFO )
+*
+* -- LAPACK driver routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, LDB, N, NRHS
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION AP( * ), B( LDB, * )
+* ..
+*
+* Purpose
+* =======
+*
+* DPPSV computes the solution to a real system of linear equations
+* A * X = B,
+* where A is an N-by-N symmetric positive definite matrix stored in
+* packed format and X and B are N-by-NRHS matrices.
+*
+* The Cholesky decomposition is used to factor A as
+* A = U**T* U, if UPLO = 'U', or
+* A = L * L**T, if UPLO = 'L',
+* where U is an upper triangular matrix and L is a lower triangular
+* matrix. The factored form of A is then used to solve the system of
+* equations A * X = B.
+*
+* Arguments
+* =========
+*
+* UPLO (input) CHARACTER*1
+* = 'U': Upper triangle of A is stored;
+* = 'L': Lower triangle of A is stored.
+*
+* N (input) INTEGER
+* The number of linear equations, i.e., the order of the
+* matrix A. N >= 0.
+*
+* NRHS (input) INTEGER
+* The number of right hand sides, i.e., the number of columns
+* of the matrix B. NRHS >= 0.
+*
+* AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)
+* On entry, the upper or lower triangle of the symmetric matrix
+* A, packed columnwise in a linear array. The j-th column of A
+* is stored in the array AP as follows:
+* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
+* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
+* See below for further details.
+*
+* On exit, if INFO = 0, the factor U or L from the Cholesky
+* factorization A = U**T*U or A = L*L**T, in the same storage
+* format as A.
+*
+* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
+* On entry, the N-by-NRHS right hand side matrix B.
+* On exit, if INFO = 0, the N-by-NRHS solution matrix X.
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. LDB >= max(1,N).
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* > 0: if INFO = i, the leading minor of order i of A is not
+* positive definite, so the factorization could not be
+* completed, and the solution has not been computed.
+*
+* Further Details
+* ===============
+*
+* The packed storage scheme is illustrated by the following example
+* when N = 4, UPLO = 'U':
+*
+* Two-dimensional storage of the symmetric matrix A:
+*
+* a11 a12 a13 a14
+* a22 a23 a24
+* a33 a34 (aij = conjg(aji))
+* a44
+*
+* Packed storage of the upper triangle of A:
+*
+* AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]
+*
+* =====================================================================
+*
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL DPPTRF, DPPTRS, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( NRHS.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -6
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DPPSV ', -INFO )
+ RETURN
+ END IF
+*
+* Compute the Cholesky factorization A = U'*U or A = L*L'.
+*
+ CALL DPPTRF( UPLO, N, AP, INFO )
+ IF( INFO.EQ.0 ) THEN
+*
+* Solve the system A*X = B, overwriting B with X.
+*
+ CALL DPPTRS( UPLO, N, NRHS, AP, B, LDB, INFO )
+*
+ END IF
+ RETURN
+*
+* End of DPPSV
+*
+ END
+ SUBROUTINE DPPSVX( FACT, UPLO, N, NRHS, AP, AFP, EQUED, S, B, LDB,
+ $ X, LDX, RCOND, FERR, BERR, WORK, IWORK, INFO )
+*
+* -- LAPACK driver routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER EQUED, FACT, UPLO
+ INTEGER INFO, LDB, LDX, N, NRHS
+ DOUBLE PRECISION RCOND
+* ..
+* .. Array Arguments ..
+ INTEGER IWORK( * )
+ DOUBLE PRECISION AFP( * ), AP( * ), B( LDB, * ), BERR( * ),
+ $ FERR( * ), S( * ), WORK( * ), X( LDX, * )
+* ..
+*
+* Purpose
+* =======
+*
+* DPPSVX uses the Cholesky factorization A = U**T*U or A = L*L**T to
+* compute the solution to a real system of linear equations
+* A * X = B,
+* where A is an N-by-N symmetric positive definite matrix stored in
+* packed format and X and B are N-by-NRHS matrices.
+*
+* Error bounds on the solution and a condition estimate are also
+* provided.
+*
+* Description
+* ===========
+*
+* The following steps are performed:
+*
+* 1. If FACT = 'E', real scaling factors are computed to equilibrate
+* the system:
+* diag(S) * A * diag(S) * inv(diag(S)) * X = diag(S) * B
+* Whether or not the system will be equilibrated depends on the
+* scaling of the matrix A, but if equilibration is used, A is
+* overwritten by diag(S)*A*diag(S) and B by diag(S)*B.
+*
+* 2. If FACT = 'N' or 'E', the Cholesky decomposition is used to
+* factor the matrix A (after equilibration if FACT = 'E') as
+* A = U**T* U, if UPLO = 'U', or
+* A = L * L**T, if UPLO = 'L',
+* where U is an upper triangular matrix and L is a lower triangular
+* matrix.
+*
+* 3. If the leading i-by-i principal minor is not positive definite,
+* then the routine returns with INFO = i. Otherwise, the factored
+* form of A is used to estimate the condition number of the matrix
+* A. If the reciprocal of the condition number is less than machine
+* precision, INFO = N+1 is returned as a warning, but the routine
+* still goes on to solve for X and compute error bounds as
+* described below.
+*
+* 4. The system of equations is solved for X using the factored form
+* of A.
+*
+* 5. Iterative refinement is applied to improve the computed solution
+* matrix and calculate error bounds and backward error estimates
+* for it.
+*
+* 6. If equilibration was used, the matrix X is premultiplied by
+* diag(S) so that it solves the original system before
+* equilibration.
+*
+* Arguments
+* =========
+*
+* FACT (input) CHARACTER*1
+* Specifies whether or not the factored form of the matrix A is
+* supplied on entry, and if not, whether the matrix A should be
+* equilibrated before it is factored.
+* = 'F': On entry, AFP contains the factored form of A.
+* If EQUED = 'Y', the matrix A has been equilibrated
+* with scaling factors given by S. AP and AFP will not
+* be modified.
+* = 'N': The matrix A will be copied to AFP and factored.
+* = 'E': The matrix A will be equilibrated if necessary, then
+* copied to AFP and factored.
+*
+* UPLO (input) CHARACTER*1
+* = 'U': Upper triangle of A is stored;
+* = 'L': Lower triangle of A is stored.
+*
+* N (input) INTEGER
+* The number of linear equations, i.e., the order of the
+* matrix A. N >= 0.
+*
+* NRHS (input) INTEGER
+* The number of right hand sides, i.e., the number of columns
+* of the matrices B and X. NRHS >= 0.
+*
+* AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)
+* On entry, the upper or lower triangle of the symmetric matrix
+* A, packed columnwise in a linear array, except if FACT = 'F'
+* and EQUED = 'Y', then A must contain the equilibrated matrix
+* diag(S)*A*diag(S). The j-th column of A is stored in the
+* array AP as follows:
+* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
+* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
+* See below for further details. A is not modified if
+* FACT = 'F' or 'N', or if FACT = 'E' and EQUED = 'N' on exit.
+*
+* On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by
+* diag(S)*A*diag(S).
+*
+* AFP (input or output) DOUBLE PRECISION array, dimension
+* (N*(N+1)/2)
+* If FACT = 'F', then AFP is an input argument and on entry
+* contains the triangular factor U or L from the Cholesky
+* factorization A = U'*U or A = L*L', in the same storage
+* format as A. If EQUED .ne. 'N', then AFP is the factored
+* form of the equilibrated matrix A.
+*
+* If FACT = 'N', then AFP is an output argument and on exit
+* returns the triangular factor U or L from the Cholesky
+* factorization A = U'*U or A = L*L' of the original matrix A.
+*
+* If FACT = 'E', then AFP is an output argument and on exit
+* returns the triangular factor U or L from the Cholesky
+* factorization A = U'*U or A = L*L' of the equilibrated
+* matrix A (see the description of AP for the form of the
+* equilibrated matrix).
+*
+* EQUED (input or output) CHARACTER*1
+* Specifies the form of equilibration that was done.
+* = 'N': No equilibration (always true if FACT = 'N').
+* = 'Y': Equilibration was done, i.e., A has been replaced by
+* diag(S) * A * diag(S).
+* EQUED is an input argument if FACT = 'F'; otherwise, it is an
+* output argument.
+*
+* S (input or output) DOUBLE PRECISION array, dimension (N)
+* The scale factors for A; not accessed if EQUED = 'N'. S is
+* an input argument if FACT = 'F'; otherwise, S is an output
+* argument. If FACT = 'F' and EQUED = 'Y', each element of S
+* must be positive.
+*
+* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
+* On entry, the N-by-NRHS right hand side matrix B.
+* On exit, if EQUED = 'N', B is not modified; if EQUED = 'Y',
+* B is overwritten by diag(S) * B.
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. LDB >= max(1,N).
+*
+* X (output) DOUBLE PRECISION array, dimension (LDX,NRHS)
+* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X to
+* the original system of equations. Note that if EQUED = 'Y',
+* A and B are modified on exit, and the solution to the
+* equilibrated system is inv(diag(S))*X.
+*
+* LDX (input) INTEGER
+* The leading dimension of the array X. LDX >= max(1,N).
+*
+* RCOND (output) DOUBLE PRECISION
+* The estimate of the reciprocal condition number of the matrix
+* A after equilibration (if done). If RCOND is less than the
+* machine precision (in particular, if RCOND = 0), the matrix
+* is singular to working precision. This condition is
+* indicated by a return code of INFO > 0.
+*
+* FERR (output) DOUBLE PRECISION array, dimension (NRHS)
+* The estimated forward error bound for each solution vector
+* X(j) (the j-th column of the solution matrix X).
+* If XTRUE is the true solution corresponding to X(j), FERR(j)
+* is an estimated upper bound for the magnitude of the largest
+* element in (X(j) - XTRUE) divided by the magnitude of the
+* largest element in X(j). The estimate is as reliable as
+* the estimate for RCOND, and is almost always a slight
+* overestimate of the true error.
+*
+* BERR (output) DOUBLE PRECISION array, dimension (NRHS)
+* The componentwise relative backward error of each solution
+* vector X(j) (i.e., the smallest relative change in
+* any element of A or B that makes X(j) an exact solution).
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (3*N)
+*
+* IWORK (workspace) INTEGER array, dimension (N)
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* > 0: if INFO = i, and i is
+* <= N: the leading minor of order i of A is
+* not positive definite, so the factorization
+* could not be completed, and the solution has not
+* been computed. RCOND = 0 is returned.
+* = N+1: U is nonsingular, but RCOND is less than machine
+* precision, meaning that the matrix is singular
+* to working precision. Nevertheless, the
+* solution and error bounds are computed because
+* there are a number of situations where the
+* computed solution can be more accurate than the
+* value of RCOND would suggest.
+*
+* Further Details
+* ===============
+*
+* The packed storage scheme is illustrated by the following example
+* when N = 4, UPLO = 'U':
+*
+* Two-dimensional storage of the symmetric matrix A:
+*
+* a11 a12 a13 a14
+* a22 a23 a24
+* a33 a34 (aij = conjg(aji))
+* a44
+*
+* Packed storage of the upper triangle of A:
+*
+* AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL EQUIL, NOFACT, RCEQU
+ INTEGER I, INFEQU, J
+ DOUBLE PRECISION AMAX, ANORM, BIGNUM, SCOND, SMAX, SMIN, SMLNUM
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ DOUBLE PRECISION DLAMCH, DLANSP
+ EXTERNAL LSAME, DLAMCH, DLANSP
+* ..
+* .. External Subroutines ..
+ EXTERNAL DCOPY, DLACPY, DLAQSP, DPPCON, DPPEQU, DPPRFS,
+ $ DPPTRF, DPPTRS, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+ INFO = 0
+ NOFACT = LSAME( FACT, 'N' )
+ EQUIL = LSAME( FACT, 'E' )
+ IF( NOFACT .OR. EQUIL ) THEN
+ EQUED = 'N'
+ RCEQU = .FALSE.
+ ELSE
+ RCEQU = LSAME( EQUED, 'Y' )
+ SMLNUM = DLAMCH( 'Safe minimum' )
+ BIGNUM = ONE / SMLNUM
+ END IF
+*
+* Test the input parameters.
+*
+ IF( .NOT.NOFACT .AND. .NOT.EQUIL .AND. .NOT.LSAME( FACT, 'F' ) )
+ $ THEN
+ INFO = -1
+ ELSE IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) )
+ $ THEN
+ INFO = -2
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( NRHS.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( LSAME( FACT, 'F' ) .AND. .NOT.
+ $ ( RCEQU .OR. LSAME( EQUED, 'N' ) ) ) THEN
+ INFO = -7
+ ELSE
+ IF( RCEQU ) THEN
+ SMIN = BIGNUM
+ SMAX = ZERO
+ DO 10 J = 1, N
+ SMIN = MIN( SMIN, S( J ) )
+ SMAX = MAX( SMAX, S( J ) )
+ 10 CONTINUE
+ IF( SMIN.LE.ZERO ) THEN
+ INFO = -8
+ ELSE IF( N.GT.0 ) THEN
+ SCOND = MAX( SMIN, SMLNUM ) / MIN( SMAX, BIGNUM )
+ ELSE
+ SCOND = ONE
+ END IF
+ END IF
+ IF( INFO.EQ.0 ) THEN
+ IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -10
+ ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
+ INFO = -12
+ END IF
+ END IF
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DPPSVX', -INFO )
+ RETURN
+ END IF
+*
+ IF( EQUIL ) THEN
+*
+* Compute row and column scalings to equilibrate the matrix A.
+*
+ CALL DPPEQU( UPLO, N, AP, S, SCOND, AMAX, INFEQU )
+ IF( INFEQU.EQ.0 ) THEN
+*
+* Equilibrate the matrix.
+*
+ CALL DLAQSP( UPLO, N, AP, S, SCOND, AMAX, EQUED )
+ RCEQU = LSAME( EQUED, 'Y' )
+ END IF
+ END IF
+*
+* Scale the right-hand side.
+*
+ IF( RCEQU ) THEN
+ DO 30 J = 1, NRHS
+ DO 20 I = 1, N
+ B( I, J ) = S( I )*B( I, J )
+ 20 CONTINUE
+ 30 CONTINUE
+ END IF
+*
+ IF( NOFACT .OR. EQUIL ) THEN
+*
+* Compute the Cholesky factorization A = U'*U or A = L*L'.
+*
+ CALL DCOPY( N*( N+1 ) / 2, AP, 1, AFP, 1 )
+ CALL DPPTRF( UPLO, N, AFP, INFO )
+*
+* Return if INFO is non-zero.
+*
+ IF( INFO.GT.0 )THEN
+ RCOND = ZERO
+ RETURN
+ END IF
+ END IF
+*
+* Compute the norm of the matrix A.
+*
+ ANORM = DLANSP( 'I', UPLO, N, AP, WORK )
+*
+* Compute the reciprocal of the condition number of A.
+*
+ CALL DPPCON( UPLO, N, AFP, ANORM, RCOND, WORK, IWORK, INFO )
+*
+* Compute the solution matrix X.
+*
+ CALL DLACPY( 'Full', N, NRHS, B, LDB, X, LDX )
+ CALL DPPTRS( UPLO, N, NRHS, AFP, X, LDX, INFO )
+*
+* Use iterative refinement to improve the computed solution and
+* compute error bounds and backward error estimates for it.
+*
+ CALL DPPRFS( UPLO, N, NRHS, AP, AFP, B, LDB, X, LDX, FERR, BERR,
+ $ WORK, IWORK, INFO )
+*
+* Transform the solution matrix X to a solution of the original
+* system.
+*
+ IF( RCEQU ) THEN
+ DO 50 J = 1, NRHS
+ DO 40 I = 1, N
+ X( I, J ) = S( I )*X( I, J )
+ 40 CONTINUE
+ 50 CONTINUE
+ DO 60 J = 1, NRHS
+ FERR( J ) = FERR( J ) / SCOND
+ 60 CONTINUE
+ END IF
+*
+* Set INFO = N+1 if the matrix is singular to working precision.
+*
+ IF( RCOND.LT.DLAMCH( 'Epsilon' ) )
+ $ INFO = N + 1
+*
+ RETURN
+*
+* End of DPPSVX
+*
+ END
+ SUBROUTINE DPPTRF( UPLO, N, AP, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, N
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION AP( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DPPTRF computes the Cholesky factorization of a real symmetric
+* positive definite matrix A stored in packed format.
+*
+* The factorization has the form
+* A = U**T * U, if UPLO = 'U', or
+* A = L * L**T, if UPLO = 'L',
+* where U is an upper triangular matrix and L is lower triangular.
+*
+* Arguments
+* =========
+*
+* UPLO (input) CHARACTER*1
+* = 'U': Upper triangle of A is stored;
+* = 'L': Lower triangle of A is stored.
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)
+* On entry, the upper or lower triangle of the symmetric matrix
+* A, packed columnwise in a linear array. The j-th column of A
+* is stored in the array AP as follows:
+* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
+* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
+* See below for further details.
+*
+* On exit, if INFO = 0, the triangular factor U or L from the
+* Cholesky factorization A = U**T*U or A = L*L**T, in the same
+* storage format as A.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* > 0: if INFO = i, the leading minor of order i is not
+* positive definite, and the factorization could not be
+* completed.
+*
+* Further Details
+* ======= =======
+*
+* The packed storage scheme is illustrated by the following example
+* when N = 4, UPLO = 'U':
+*
+* Two-dimensional storage of the symmetric matrix A:
+*
+* a11 a12 a13 a14
+* a22 a23 a24
+* a33 a34 (aij = aji)
+* a44
+*
+* Packed storage of the upper triangle of A:
+*
+* AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE, ZERO
+ PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL UPPER
+ INTEGER J, JC, JJ
+ DOUBLE PRECISION AJJ
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ DOUBLE PRECISION DDOT
+ EXTERNAL LSAME, DDOT
+* ..
+* .. External Subroutines ..
+ EXTERNAL DSCAL, DSPR, DTPSV, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC SQRT
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DPPTRF', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+ IF( UPPER ) THEN
+*
+* Compute the Cholesky factorization A = U'*U.
+*
+ JJ = 0
+ DO 10 J = 1, N
+ JC = JJ + 1
+ JJ = JJ + J
+*
+* Compute elements 1:J-1 of column J.
+*
+ IF( J.GT.1 )
+ $ CALL DTPSV( 'Upper', 'Transpose', 'Non-unit', J-1, AP,
+ $ AP( JC ), 1 )
+*
+* Compute U(J,J) and test for non-positive-definiteness.
+*
+ AJJ = AP( JJ ) - DDOT( J-1, AP( JC ), 1, AP( JC ), 1 )
+ IF( AJJ.LE.ZERO ) THEN
+ AP( JJ ) = AJJ
+ GO TO 30
+ END IF
+ AP( JJ ) = SQRT( AJJ )
+ 10 CONTINUE
+ ELSE
+*
+* Compute the Cholesky factorization A = L*L'.
+*
+ JJ = 1
+ DO 20 J = 1, N
+*
+* Compute L(J,J) and test for non-positive-definiteness.
+*
+ AJJ = AP( JJ )
+ IF( AJJ.LE.ZERO ) THEN
+ AP( JJ ) = AJJ
+ GO TO 30
+ END IF
+ AJJ = SQRT( AJJ )
+ AP( JJ ) = AJJ
+*
+* Compute elements J+1:N of column J and update the trailing
+* submatrix.
+*
+ IF( J.LT.N ) THEN
+ CALL DSCAL( N-J, ONE / AJJ, AP( JJ+1 ), 1 )
+ CALL DSPR( 'Lower', N-J, -ONE, AP( JJ+1 ), 1,
+ $ AP( JJ+N-J+1 ) )
+ JJ = JJ + N - J + 1
+ END IF
+ 20 CONTINUE
+ END IF
+ GO TO 40
+*
+ 30 CONTINUE
+ INFO = J
+*
+ 40 CONTINUE
+ RETURN
+*
+* End of DPPTRF
+*
+ END
+ SUBROUTINE DPPTRI( UPLO, N, AP, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, N
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION AP( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DPPTRI computes the inverse of a real symmetric positive definite
+* matrix A using the Cholesky factorization A = U**T*U or A = L*L**T
+* computed by DPPTRF.
+*
+* Arguments
+* =========
+*
+* UPLO (input) CHARACTER*1
+* = 'U': Upper triangular factor is stored in AP;
+* = 'L': Lower triangular factor is stored in AP.
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)
+* On entry, the triangular factor U or L from the Cholesky
+* factorization A = U**T*U or A = L*L**T, packed columnwise as
+* a linear array. The j-th column of U or L is stored in the
+* array AP as follows:
+* if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j;
+* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n.
+*
+* On exit, the upper or lower triangle of the (symmetric)
+* inverse of A, overwriting the input factor U or L.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* > 0: if INFO = i, the (i,i) element of the factor U or L is
+* zero, and the inverse could not be computed.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE
+ PARAMETER ( ONE = 1.0D+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL UPPER
+ INTEGER J, JC, JJ, JJN
+ DOUBLE PRECISION AJJ
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ DOUBLE PRECISION DDOT
+ EXTERNAL LSAME, DDOT
+* ..
+* .. External Subroutines ..
+ EXTERNAL DSCAL, DSPR, DTPMV, DTPTRI, XERBLA
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DPPTRI', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+* Invert the triangular Cholesky factor U or L.
+*
+ CALL DTPTRI( UPLO, 'Non-unit', N, AP, INFO )
+ IF( INFO.GT.0 )
+ $ RETURN
+*
+ IF( UPPER ) THEN
+*
+* Compute the product inv(U) * inv(U)'.
+*
+ JJ = 0
+ DO 10 J = 1, N
+ JC = JJ + 1
+ JJ = JJ + J
+ IF( J.GT.1 )
+ $ CALL DSPR( 'Upper', J-1, ONE, AP( JC ), 1, AP )
+ AJJ = AP( JJ )
+ CALL DSCAL( J, AJJ, AP( JC ), 1 )
+ 10 CONTINUE
+*
+ ELSE
+*
+* Compute the product inv(L)' * inv(L).
+*
+ JJ = 1
+ DO 20 J = 1, N
+ JJN = JJ + N - J + 1
+ AP( JJ ) = DDOT( N-J+1, AP( JJ ), 1, AP( JJ ), 1 )
+ IF( J.LT.N )
+ $ CALL DTPMV( 'Lower', 'Transpose', 'Non-unit', N-J,
+ $ AP( JJN ), AP( JJ+1 ), 1 )
+ JJ = JJN
+ 20 CONTINUE
+ END IF
+*
+ RETURN
+*
+* End of DPPTRI
+*
+ END
+ SUBROUTINE DPPTRS( UPLO, N, NRHS, AP, B, LDB, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, LDB, N, NRHS
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION AP( * ), B( LDB, * )
+* ..
+*
+* Purpose
+* =======
+*
+* DPPTRS solves a system of linear equations A*X = B with a symmetric
+* positive definite matrix A in packed storage using the Cholesky
+* factorization A = U**T*U or A = L*L**T computed by DPPTRF.
+*
+* Arguments
+* =========
+*
+* UPLO (input) CHARACTER*1
+* = 'U': Upper triangle of A is stored;
+* = 'L': Lower triangle of A is stored.
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* NRHS (input) INTEGER
+* The number of right hand sides, i.e., the number of columns
+* of the matrix B. NRHS >= 0.
+*
+* AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)
+* The triangular factor U or L from the Cholesky factorization
+* A = U**T*U or A = L*L**T, packed columnwise in a linear
+* array. The j-th column of U or L is stored in the array AP
+* as follows:
+* if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j;
+* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n.
+*
+* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
+* On entry, the right hand side matrix B.
+* On exit, the solution matrix X.
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. LDB >= max(1,N).
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ LOGICAL UPPER
+ INTEGER I
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL DTPSV, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( NRHS.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -6
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DPPTRS', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 .OR. NRHS.EQ.0 )
+ $ RETURN
+*
+ IF( UPPER ) THEN
+*
+* Solve A*X = B where A = U'*U.
+*
+ DO 10 I = 1, NRHS
+*
+* Solve U'*X = B, overwriting B with X.
+*
+ CALL DTPSV( 'Upper', 'Transpose', 'Non-unit', N, AP,
+ $ B( 1, I ), 1 )
+*
+* Solve U*X = B, overwriting B with X.
+*
+ CALL DTPSV( 'Upper', 'No transpose', 'Non-unit', N, AP,
+ $ B( 1, I ), 1 )
+ 10 CONTINUE
+ ELSE
+*
+* Solve A*X = B where A = L*L'.
+*
+ DO 20 I = 1, NRHS
+*
+* Solve L*Y = B, overwriting B with X.
+*
+ CALL DTPSV( 'Lower', 'No transpose', 'Non-unit', N, AP,
+ $ B( 1, I ), 1 )
+*
+* Solve L'*X = Y, overwriting B with X.
+*
+ CALL DTPSV( 'Lower', 'Transpose', 'Non-unit', N, AP,
+ $ B( 1, I ), 1 )
+ 20 CONTINUE
+ END IF
+*
+ RETURN
+*
+* End of DPPTRS
+*
+ END
+ SUBROUTINE DPTCON( N, D, E, ANORM, RCOND, WORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, N
+ DOUBLE PRECISION ANORM, RCOND
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION D( * ), E( * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DPTCON computes the reciprocal of the condition number (in the
+* 1-norm) of a real symmetric positive definite tridiagonal matrix
+* using the factorization A = L*D*L**T or A = U**T*D*U computed by
+* DPTTRF.
+*
+* Norm(inv(A)) is computed by a direct method, and the reciprocal of
+* the condition number is computed as
+* RCOND = 1 / (ANORM * norm(inv(A))).
+*
+* Arguments
+* =========
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* D (input) DOUBLE PRECISION array, dimension (N)
+* The n diagonal elements of the diagonal matrix D from the
+* factorization of A, as computed by DPTTRF.
+*
+* E (input) DOUBLE PRECISION array, dimension (N-1)
+* The (n-1) off-diagonal elements of the unit bidiagonal factor
+* U or L from the factorization of A, as computed by DPTTRF.
+*
+* ANORM (input) DOUBLE PRECISION
+* The 1-norm of the original matrix A.
+*
+* RCOND (output) DOUBLE PRECISION
+* The reciprocal of the condition number of the matrix A,
+* computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is the
+* 1-norm of inv(A) computed in this routine.
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (N)
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+*
+* Further Details
+* ===============
+*
+* The method used is described in Nicholas J. Higham, "Efficient
+* Algorithms for Computing the Condition Number of a Tridiagonal
+* Matrix", SIAM J. Sci. Stat. Comput., Vol. 7, No. 1, January 1986.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE, ZERO
+ PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, IX
+ DOUBLE PRECISION AINVNM
+* ..
+* .. External Functions ..
+ INTEGER IDAMAX
+ EXTERNAL IDAMAX
+* ..
+* .. External Subroutines ..
+ EXTERNAL XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS
+* ..
+* .. Executable Statements ..
+*
+* Test the input arguments.
+*
+ INFO = 0
+ IF( N.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( ANORM.LT.ZERO ) THEN
+ INFO = -4
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DPTCON', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ RCOND = ZERO
+ IF( N.EQ.0 ) THEN
+ RCOND = ONE
+ RETURN
+ ELSE IF( ANORM.EQ.ZERO ) THEN
+ RETURN
+ END IF
+*
+* Check that D(1:N) is positive.
+*
+ DO 10 I = 1, N
+ IF( D( I ).LE.ZERO )
+ $ RETURN
+ 10 CONTINUE
+*
+* Solve M(A) * x = e, where M(A) = (m(i,j)) is given by
+*
+* m(i,j) = abs(A(i,j)), i = j,
+* m(i,j) = -abs(A(i,j)), i .ne. j,
+*
+* and e = [ 1, 1, ..., 1 ]'. Note M(A) = M(L)*D*M(L)'.
+*
+* Solve M(L) * x = e.
+*
+ WORK( 1 ) = ONE
+ DO 20 I = 2, N
+ WORK( I ) = ONE + WORK( I-1 )*ABS( E( I-1 ) )
+ 20 CONTINUE
+*
+* Solve D * M(L)' * x = b.
+*
+ WORK( N ) = WORK( N ) / D( N )
+ DO 30 I = N - 1, 1, -1
+ WORK( I ) = WORK( I ) / D( I ) + WORK( I+1 )*ABS( E( I ) )
+ 30 CONTINUE
+*
+* Compute AINVNM = max(x(i)), 1<=i<=n.
+*
+ IX = IDAMAX( N, WORK, 1 )
+ AINVNM = ABS( WORK( IX ) )
+*
+* Compute the reciprocal condition number.
+*
+ IF( AINVNM.NE.ZERO )
+ $ RCOND = ( ONE / AINVNM ) / ANORM
+*
+ RETURN
+*
+* End of DPTCON
+*
+ END
+ SUBROUTINE DPTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER COMPZ
+ INTEGER INFO, LDZ, N
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION D( * ), E( * ), WORK( * ), Z( LDZ, * )
+* ..
+*
+* Purpose
+* =======
+*
+* DPTEQR computes all eigenvalues and, optionally, eigenvectors of a
+* symmetric positive definite tridiagonal matrix by first factoring the
+* matrix using DPTTRF, and then calling DBDSQR to compute the singular
+* values of the bidiagonal factor.
+*
+* This routine computes the eigenvalues of the positive definite
+* tridiagonal matrix to high relative accuracy. This means that if the
+* eigenvalues range over many orders of magnitude in size, then the
+* small eigenvalues and corresponding eigenvectors will be computed
+* more accurately than, for example, with the standard QR method.
+*
+* The eigenvectors of a full or band symmetric positive definite matrix
+* can also be found if DSYTRD, DSPTRD, or DSBTRD has been used to
+* reduce this matrix to tridiagonal form. (The reduction to tridiagonal
+* form, however, may preclude the possibility of obtaining high
+* relative accuracy in the small eigenvalues of the original matrix, if
+* these eigenvalues range over many orders of magnitude.)
+*
+* Arguments
+* =========
+*
+* COMPZ (input) CHARACTER*1
+* = 'N': Compute eigenvalues only.
+* = 'V': Compute eigenvectors of original symmetric
+* matrix also. Array Z contains the orthogonal
+* matrix used to reduce the original matrix to
+* tridiagonal form.
+* = 'I': Compute eigenvectors of tridiagonal matrix also.
+*
+* N (input) INTEGER
+* The order of the matrix. N >= 0.
+*
+* D (input/output) DOUBLE PRECISION array, dimension (N)
+* On entry, the n diagonal elements of the tridiagonal
+* matrix.
+* On normal exit, D contains the eigenvalues, in descending
+* order.
+*
+* E (input/output) DOUBLE PRECISION array, dimension (N-1)
+* On entry, the (n-1) subdiagonal elements of the tridiagonal
+* matrix.
+* On exit, E has been destroyed.
+*
+* Z (input/output) DOUBLE PRECISION array, dimension (LDZ, N)
+* On entry, if COMPZ = 'V', the orthogonal matrix used in the
+* reduction to tridiagonal form.
+* On exit, if COMPZ = 'V', the orthonormal eigenvectors of the
+* original symmetric matrix;
+* if COMPZ = 'I', the orthonormal eigenvectors of the
+* tridiagonal matrix.
+* If INFO > 0 on exit, Z contains the eigenvectors associated
+* with only the stored eigenvalues.
+* If COMPZ = 'N', then Z is not referenced.
+*
+* LDZ (input) INTEGER
+* The leading dimension of the array Z. LDZ >= 1, and if
+* COMPZ = 'V' or 'I', LDZ >= max(1,N).
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (4*N)
+*
+* INFO (output) INTEGER
+* = 0: successful exit.
+* < 0: if INFO = -i, the i-th argument had an illegal value.
+* > 0: if INFO = i, and i is:
+* <= N the Cholesky factorization of the matrix could
+* not be performed because the i-th principal minor
+* was not positive definite.
+* > N the SVD algorithm failed to converge;
+* if INFO = N+i, i off-diagonal elements of the
+* bidiagonal factor did not converge to zero.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL DBDSQR, DLASET, DPTTRF, XERBLA
+* ..
+* .. Local Arrays ..
+ DOUBLE PRECISION C( 1, 1 ), VT( 1, 1 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, ICOMPZ, NRU
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, SQRT
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+*
+ IF( LSAME( COMPZ, 'N' ) ) THEN
+ ICOMPZ = 0
+ ELSE IF( LSAME( COMPZ, 'V' ) ) THEN
+ ICOMPZ = 1
+ ELSE IF( LSAME( COMPZ, 'I' ) ) THEN
+ ICOMPZ = 2
+ ELSE
+ ICOMPZ = -1
+ END IF
+ IF( ICOMPZ.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( ( LDZ.LT.1 ) .OR. ( ICOMPZ.GT.0 .AND. LDZ.LT.MAX( 1,
+ $ N ) ) ) THEN
+ INFO = -6
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DPTEQR', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+ IF( N.EQ.1 ) THEN
+ IF( ICOMPZ.GT.0 )
+ $ Z( 1, 1 ) = ONE
+ RETURN
+ END IF
+ IF( ICOMPZ.EQ.2 )
+ $ CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDZ )
+*
+* Call DPTTRF to factor the matrix.
+*
+ CALL DPTTRF( N, D, E, INFO )
+ IF( INFO.NE.0 )
+ $ RETURN
+ DO 10 I = 1, N
+ D( I ) = SQRT( D( I ) )
+ 10 CONTINUE
+ DO 20 I = 1, N - 1
+ E( I ) = E( I )*D( I )
+ 20 CONTINUE
+*
+* Call DBDSQR to compute the singular values/vectors of the
+* bidiagonal factor.
+*
+ IF( ICOMPZ.GT.0 ) THEN
+ NRU = N
+ ELSE
+ NRU = 0
+ END IF
+ CALL DBDSQR( 'Lower', N, 0, NRU, 0, D, E, VT, 1, Z, LDZ, C, 1,
+ $ WORK, INFO )
+*
+* Square the singular values.
+*
+ IF( INFO.EQ.0 ) THEN
+ DO 30 I = 1, N
+ D( I ) = D( I )*D( I )
+ 30 CONTINUE
+ ELSE
+ INFO = N + INFO
+ END IF
+*
+ RETURN
+*
+* End of DPTEQR
+*
+ END
+ SUBROUTINE DPTRFS( N, NRHS, D, E, DF, EF, B, LDB, X, LDX, FERR,
+ $ BERR, WORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LDB, LDX, N, NRHS
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION B( LDB, * ), BERR( * ), D( * ), DF( * ),
+ $ E( * ), EF( * ), FERR( * ), WORK( * ),
+ $ X( LDX, * )
+* ..
+*
+* Purpose
+* =======
+*
+* DPTRFS improves the computed solution to a system of linear
+* equations when the coefficient matrix is symmetric positive definite
+* and tridiagonal, and provides error bounds and backward error
+* estimates for the solution.
+*
+* Arguments
+* =========
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* NRHS (input) INTEGER
+* The number of right hand sides, i.e., the number of columns
+* of the matrix B. NRHS >= 0.
+*
+* D (input) DOUBLE PRECISION array, dimension (N)
+* The n diagonal elements of the tridiagonal matrix A.
+*
+* E (input) DOUBLE PRECISION array, dimension (N-1)
+* The (n-1) subdiagonal elements of the tridiagonal matrix A.
+*
+* DF (input) DOUBLE PRECISION array, dimension (N)
+* The n diagonal elements of the diagonal matrix D from the
+* factorization computed by DPTTRF.
+*
+* EF (input) DOUBLE PRECISION array, dimension (N-1)
+* The (n-1) subdiagonal elements of the unit bidiagonal factor
+* L from the factorization computed by DPTTRF.
+*
+* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS)
+* The right hand side matrix B.
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. LDB >= max(1,N).
+*
+* X (input/output) DOUBLE PRECISION array, dimension (LDX,NRHS)
+* On entry, the solution matrix X, as computed by DPTTRS.
+* On exit, the improved solution matrix X.
+*
+* LDX (input) INTEGER
+* The leading dimension of the array X. LDX >= max(1,N).
+*
+* FERR (output) DOUBLE PRECISION array, dimension (NRHS)
+* The forward error bound for each solution vector
+* X(j) (the j-th column of the solution matrix X).
+* If XTRUE is the true solution corresponding to X(j), FERR(j)
+* is an estimated upper bound for the magnitude of the largest
+* element in (X(j) - XTRUE) divided by the magnitude of the
+* largest element in X(j).
+*
+* BERR (output) DOUBLE PRECISION array, dimension (NRHS)
+* The componentwise relative backward error of each solution
+* vector X(j) (i.e., the smallest relative change in
+* any element of A or B that makes X(j) an exact solution).
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (2*N)
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+*
+* Internal Parameters
+* ===================
+*
+* ITMAX is the maximum number of steps of iterative refinement.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ INTEGER ITMAX
+ PARAMETER ( ITMAX = 5 )
+ DOUBLE PRECISION ZERO
+ PARAMETER ( ZERO = 0.0D+0 )
+ DOUBLE PRECISION ONE
+ PARAMETER ( ONE = 1.0D+0 )
+ DOUBLE PRECISION TWO
+ PARAMETER ( TWO = 2.0D+0 )
+ DOUBLE PRECISION THREE
+ PARAMETER ( THREE = 3.0D+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER COUNT, I, IX, J, NZ
+ DOUBLE PRECISION BI, CX, DX, EPS, EX, LSTRES, S, SAFE1, SAFE2,
+ $ SAFMIN
+* ..
+* .. External Subroutines ..
+ EXTERNAL DAXPY, DPTTRS, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX
+* ..
+* .. External Functions ..
+ INTEGER IDAMAX
+ DOUBLE PRECISION DLAMCH
+ EXTERNAL IDAMAX, DLAMCH
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ IF( N.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( NRHS.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -8
+ ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
+ INFO = -10
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DPTRFS', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN
+ DO 10 J = 1, NRHS
+ FERR( J ) = ZERO
+ BERR( J ) = ZERO
+ 10 CONTINUE
+ RETURN
+ END IF
+*
+* NZ = maximum number of nonzero elements in each row of A, plus 1
+*
+ NZ = 4
+ EPS = DLAMCH( 'Epsilon' )
+ SAFMIN = DLAMCH( 'Safe minimum' )
+ SAFE1 = NZ*SAFMIN
+ SAFE2 = SAFE1 / EPS
+*
+* Do for each right hand side
+*
+ DO 90 J = 1, NRHS
+*
+ COUNT = 1
+ LSTRES = THREE
+ 20 CONTINUE
+*
+* Loop until stopping criterion is satisfied.
+*
+* Compute residual R = B - A * X. Also compute
+* abs(A)*abs(x) + abs(b) for use in the backward error bound.
+*
+ IF( N.EQ.1 ) THEN
+ BI = B( 1, J )
+ DX = D( 1 )*X( 1, J )
+ WORK( N+1 ) = BI - DX
+ WORK( 1 ) = ABS( BI ) + ABS( DX )
+ ELSE
+ BI = B( 1, J )
+ DX = D( 1 )*X( 1, J )
+ EX = E( 1 )*X( 2, J )
+ WORK( N+1 ) = BI - DX - EX
+ WORK( 1 ) = ABS( BI ) + ABS( DX ) + ABS( EX )
+ DO 30 I = 2, N - 1
+ BI = B( I, J )
+ CX = E( I-1 )*X( I-1, J )
+ DX = D( I )*X( I, J )
+ EX = E( I )*X( I+1, J )
+ WORK( N+I ) = BI - CX - DX - EX
+ WORK( I ) = ABS( BI ) + ABS( CX ) + ABS( DX ) + ABS( EX )
+ 30 CONTINUE
+ BI = B( N, J )
+ CX = E( N-1 )*X( N-1, J )
+ DX = D( N )*X( N, J )
+ WORK( N+N ) = BI - CX - DX
+ WORK( N ) = ABS( BI ) + ABS( CX ) + ABS( DX )
+ END IF
+*
+* Compute componentwise relative backward error from formula
+*
+* max(i) ( abs(R(i)) / ( abs(A)*abs(X) + abs(B) )(i) )
+*
+* where abs(Z) is the componentwise absolute value of the matrix
+* or vector Z. If the i-th component of the denominator is less
+* than SAFE2, then SAFE1 is added to the i-th components of the
+* numerator and denominator before dividing.
+*
+ S = ZERO
+ DO 40 I = 1, N
+ IF( WORK( I ).GT.SAFE2 ) THEN
+ S = MAX( S, ABS( WORK( N+I ) ) / WORK( I ) )
+ ELSE
+ S = MAX( S, ( ABS( WORK( N+I ) )+SAFE1 ) /
+ $ ( WORK( I )+SAFE1 ) )
+ END IF
+ 40 CONTINUE
+ BERR( J ) = S
+*
+* Test stopping criterion. Continue iterating if
+* 1) The residual BERR(J) is larger than machine epsilon, and
+* 2) BERR(J) decreased by at least a factor of 2 during the
+* last iteration, and
+* 3) At most ITMAX iterations tried.
+*
+ IF( BERR( J ).GT.EPS .AND. TWO*BERR( J ).LE.LSTRES .AND.
+ $ COUNT.LE.ITMAX ) THEN
+*
+* Update solution and try again.
+*
+ CALL DPTTRS( N, 1, DF, EF, WORK( N+1 ), N, INFO )
+ CALL DAXPY( N, ONE, WORK( N+1 ), 1, X( 1, J ), 1 )
+ LSTRES = BERR( J )
+ COUNT = COUNT + 1
+ GO TO 20
+ END IF
+*
+* Bound error from formula
+*
+* norm(X - XTRUE) / norm(X) .le. FERR =
+* norm( abs(inv(A))*
+* ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X)
+*
+* where
+* norm(Z) is the magnitude of the largest component of Z
+* inv(A) is the inverse of A
+* abs(Z) is the componentwise absolute value of the matrix or
+* vector Z
+* NZ is the maximum number of nonzeros in any row of A, plus 1
+* EPS is machine epsilon
+*
+* The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B))
+* is incremented by SAFE1 if the i-th component of
+* abs(A)*abs(X) + abs(B) is less than SAFE2.
+*
+ DO 50 I = 1, N
+ IF( WORK( I ).GT.SAFE2 ) THEN
+ WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I )
+ ELSE
+ WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I ) + SAFE1
+ END IF
+ 50 CONTINUE
+ IX = IDAMAX( N, WORK, 1 )
+ FERR( J ) = WORK( IX )
+*
+* Estimate the norm of inv(A).
+*
+* Solve M(A) * x = e, where M(A) = (m(i,j)) is given by
+*
+* m(i,j) = abs(A(i,j)), i = j,
+* m(i,j) = -abs(A(i,j)), i .ne. j,
+*
+* and e = [ 1, 1, ..., 1 ]'. Note M(A) = M(L)*D*M(L)'.
+*
+* Solve M(L) * x = e.
+*
+ WORK( 1 ) = ONE
+ DO 60 I = 2, N
+ WORK( I ) = ONE + WORK( I-1 )*ABS( EF( I-1 ) )
+ 60 CONTINUE
+*
+* Solve D * M(L)' * x = b.
+*
+ WORK( N ) = WORK( N ) / DF( N )
+ DO 70 I = N - 1, 1, -1
+ WORK( I ) = WORK( I ) / DF( I ) + WORK( I+1 )*ABS( EF( I ) )
+ 70 CONTINUE
+*
+* Compute norm(inv(A)) = max(x(i)), 1<=i<=n.
+*
+ IX = IDAMAX( N, WORK, 1 )
+ FERR( J ) = FERR( J )*ABS( WORK( IX ) )
+*
+* Normalize error.
+*
+ LSTRES = ZERO
+ DO 80 I = 1, N
+ LSTRES = MAX( LSTRES, ABS( X( I, J ) ) )
+ 80 CONTINUE
+ IF( LSTRES.NE.ZERO )
+ $ FERR( J ) = FERR( J ) / LSTRES
+*
+ 90 CONTINUE
+*
+ RETURN
+*
+* End of DPTRFS
+*
+ END
+ SUBROUTINE DPTSV( N, NRHS, D, E, B, LDB, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LDB, N, NRHS
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION B( LDB, * ), D( * ), E( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DPTSV computes the solution to a real system of linear equations
+* A*X = B, where A is an N-by-N symmetric positive definite tridiagonal
+* matrix, and X and B are N-by-NRHS matrices.
+*
+* A is factored as A = L*D*L**T, and the factored form of A is then
+* used to solve the system of equations.
+*
+* Arguments
+* =========
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* NRHS (input) INTEGER
+* The number of right hand sides, i.e., the number of columns
+* of the matrix B. NRHS >= 0.
+*
+* D (input/output) DOUBLE PRECISION array, dimension (N)
+* On entry, the n diagonal elements of the tridiagonal matrix
+* A. On exit, the n diagonal elements of the diagonal matrix
+* D from the factorization A = L*D*L**T.
+*
+* E (input/output) DOUBLE PRECISION array, dimension (N-1)
+* On entry, the (n-1) subdiagonal elements of the tridiagonal
+* matrix A. On exit, the (n-1) subdiagonal elements of the
+* unit bidiagonal factor L from the L*D*L**T factorization of
+* A. (E can also be regarded as the superdiagonal of the unit
+* bidiagonal factor U from the U**T*D*U factorization of A.)
+*
+* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
+* On entry, the N-by-NRHS right hand side matrix B.
+* On exit, if INFO = 0, the N-by-NRHS solution matrix X.
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. LDB >= max(1,N).
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* > 0: if INFO = i, the leading minor of order i is not
+* positive definite, and the solution has not been
+* computed. The factorization has not been completed
+* unless i = N.
+*
+* =====================================================================
+*
+* .. External Subroutines ..
+ EXTERNAL DPTTRF, DPTTRS, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ IF( N.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( NRHS.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -6
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DPTSV ', -INFO )
+ RETURN
+ END IF
+*
+* Compute the L*D*L' (or U'*D*U) factorization of A.
+*
+ CALL DPTTRF( N, D, E, INFO )
+ IF( INFO.EQ.0 ) THEN
+*
+* Solve the system A*X = B, overwriting B with X.
+*
+ CALL DPTTRS( N, NRHS, D, E, B, LDB, INFO )
+ END IF
+ RETURN
+*
+* End of DPTSV
+*
+ END
+ SUBROUTINE DPTSVX( FACT, N, NRHS, D, E, DF, EF, B, LDB, X, LDX,
+ $ RCOND, FERR, BERR, WORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER FACT
+ INTEGER INFO, LDB, LDX, N, NRHS
+ DOUBLE PRECISION RCOND
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION B( LDB, * ), BERR( * ), D( * ), DF( * ),
+ $ E( * ), EF( * ), FERR( * ), WORK( * ),
+ $ X( LDX, * )
+* ..
+*
+* Purpose
+* =======
+*
+* DPTSVX uses the factorization A = L*D*L**T to compute the solution
+* to a real system of linear equations A*X = B, where A is an N-by-N
+* symmetric positive definite tridiagonal matrix and X and B are
+* N-by-NRHS matrices.
+*
+* Error bounds on the solution and a condition estimate are also
+* provided.
+*
+* Description
+* ===========
+*
+* The following steps are performed:
+*
+* 1. If FACT = 'N', the matrix A is factored as A = L*D*L**T, where L
+* is a unit lower bidiagonal matrix and D is diagonal. The
+* factorization can also be regarded as having the form
+* A = U**T*D*U.
+*
+* 2. If the leading i-by-i principal minor is not positive definite,
+* then the routine returns with INFO = i. Otherwise, the factored
+* form of A is used to estimate the condition number of the matrix
+* A. If the reciprocal of the condition number is less than machine
+* precision, INFO = N+1 is returned as a warning, but the routine
+* still goes on to solve for X and compute error bounds as
+* described below.
+*
+* 3. The system of equations is solved for X using the factored form
+* of A.
+*
+* 4. Iterative refinement is applied to improve the computed solution
+* matrix and calculate error bounds and backward error estimates
+* for it.
+*
+* Arguments
+* =========
+*
+* FACT (input) CHARACTER*1
+* Specifies whether or not the factored form of A has been
+* supplied on entry.
+* = 'F': On entry, DF and EF contain the factored form of A.
+* D, E, DF, and EF will not be modified.
+* = 'N': The matrix A will be copied to DF and EF and
+* factored.
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* NRHS (input) INTEGER
+* The number of right hand sides, i.e., the number of columns
+* of the matrices B and X. NRHS >= 0.
+*
+* D (input) DOUBLE PRECISION array, dimension (N)
+* The n diagonal elements of the tridiagonal matrix A.
+*
+* E (input) DOUBLE PRECISION array, dimension (N-1)
+* The (n-1) subdiagonal elements of the tridiagonal matrix A.
+*
+* DF (input or output) DOUBLE PRECISION array, dimension (N)
+* If FACT = 'F', then DF is an input argument and on entry
+* contains the n diagonal elements of the diagonal matrix D
+* from the L*D*L**T factorization of A.
+* If FACT = 'N', then DF is an output argument and on exit
+* contains the n diagonal elements of the diagonal matrix D
+* from the L*D*L**T factorization of A.
+*
+* EF (input or output) DOUBLE PRECISION array, dimension (N-1)
+* If FACT = 'F', then EF is an input argument and on entry
+* contains the (n-1) subdiagonal elements of the unit
+* bidiagonal factor L from the L*D*L**T factorization of A.
+* If FACT = 'N', then EF is an output argument and on exit
+* contains the (n-1) subdiagonal elements of the unit
+* bidiagonal factor L from the L*D*L**T factorization of A.
+*
+* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS)
+* The N-by-NRHS right hand side matrix B.
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. LDB >= max(1,N).
+*
+* X (output) DOUBLE PRECISION array, dimension (LDX,NRHS)
+* If INFO = 0 of INFO = N+1, the N-by-NRHS solution matrix X.
+*
+* LDX (input) INTEGER
+* The leading dimension of the array X. LDX >= max(1,N).
+*
+* RCOND (output) DOUBLE PRECISION
+* The reciprocal condition number of the matrix A. If RCOND
+* is less than the machine precision (in particular, if
+* RCOND = 0), the matrix is singular to working precision.
+* This condition is indicated by a return code of INFO > 0.
+*
+* FERR (output) DOUBLE PRECISION array, dimension (NRHS)
+* The forward error bound for each solution vector
+* X(j) (the j-th column of the solution matrix X).
+* If XTRUE is the true solution corresponding to X(j), FERR(j)
+* is an estimated upper bound for the magnitude of the largest
+* element in (X(j) - XTRUE) divided by the magnitude of the
+* largest element in X(j).
+*
+* BERR (output) DOUBLE PRECISION array, dimension (NRHS)
+* The componentwise relative backward error of each solution
+* vector X(j) (i.e., the smallest relative change in any
+* element of A or B that makes X(j) an exact solution).
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (2*N)
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* > 0: if INFO = i, and i is
+* <= N: the leading minor of order i of A is
+* not positive definite, so the factorization
+* could not be completed, and the solution has not
+* been computed. RCOND = 0 is returned.
+* = N+1: U is nonsingular, but RCOND is less than machine
+* precision, meaning that the matrix is singular
+* to working precision. Nevertheless, the
+* solution and error bounds are computed because
+* there are a number of situations where the
+* computed solution can be more accurate than the
+* value of RCOND would suggest.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO
+ PARAMETER ( ZERO = 0.0D+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL NOFACT
+ DOUBLE PRECISION ANORM
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ DOUBLE PRECISION DLAMCH, DLANST
+ EXTERNAL LSAME, DLAMCH, DLANST
+* ..
+* .. External Subroutines ..
+ EXTERNAL DCOPY, DLACPY, DPTCON, DPTRFS, DPTTRF, DPTTRS,
+ $ XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ NOFACT = LSAME( FACT, 'N' )
+ IF( .NOT.NOFACT .AND. .NOT.LSAME( FACT, 'F' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( NRHS.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -9
+ ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
+ INFO = -11
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DPTSVX', -INFO )
+ RETURN
+ END IF
+*
+ IF( NOFACT ) THEN
+*
+* Compute the L*D*L' (or U'*D*U) factorization of A.
+*
+ CALL DCOPY( N, D, 1, DF, 1 )
+ IF( N.GT.1 )
+ $ CALL DCOPY( N-1, E, 1, EF, 1 )
+ CALL DPTTRF( N, DF, EF, INFO )
+*
+* Return if INFO is non-zero.
+*
+ IF( INFO.GT.0 )THEN
+ RCOND = ZERO
+ RETURN
+ END IF
+ END IF
+*
+* Compute the norm of the matrix A.
+*
+ ANORM = DLANST( '1', N, D, E )
+*
+* Compute the reciprocal of the condition number of A.
+*
+ CALL DPTCON( N, DF, EF, ANORM, RCOND, WORK, INFO )
+*
+* Compute the solution vectors X.
+*
+ CALL DLACPY( 'Full', N, NRHS, B, LDB, X, LDX )
+ CALL DPTTRS( N, NRHS, DF, EF, X, LDX, INFO )
+*
+* Use iterative refinement to improve the computed solutions and
+* compute error bounds and backward error estimates for them.
+*
+ CALL DPTRFS( N, NRHS, D, E, DF, EF, B, LDB, X, LDX, FERR, BERR,
+ $ WORK, INFO )
+*
+* Set INFO = N+1 if the matrix is singular to working precision.
+*
+ IF( RCOND.LT.DLAMCH( 'Epsilon' ) )
+ $ INFO = N + 1
+*
+ RETURN
+*
+* End of DPTSVX
+*
+ END
+ SUBROUTINE DPTTRF( N, D, E, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, N
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION D( * ), E( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DPTTRF computes the L*D*L' factorization of a real symmetric
+* positive definite tridiagonal matrix A. The factorization may also
+* be regarded as having the form A = U'*D*U.
+*
+* Arguments
+* =========
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* D (input/output) DOUBLE PRECISION array, dimension (N)
+* On entry, the n diagonal elements of the tridiagonal matrix
+* A. On exit, the n diagonal elements of the diagonal matrix
+* D from the L*D*L' factorization of A.
+*
+* E (input/output) DOUBLE PRECISION array, dimension (N-1)
+* On entry, the (n-1) subdiagonal elements of the tridiagonal
+* matrix A. On exit, the (n-1) subdiagonal elements of the
+* unit bidiagonal factor L from the L*D*L' factorization of A.
+* E can also be regarded as the superdiagonal of the unit
+* bidiagonal factor U from the U'*D*U factorization of A.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -k, the k-th argument had an illegal value
+* > 0: if INFO = k, the leading minor of order k is not
+* positive definite; if k < N, the factorization could not
+* be completed, while if k = N, the factorization was
+* completed, but D(N) <= 0.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO
+ PARAMETER ( ZERO = 0.0D+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, I4
+ DOUBLE PRECISION EI
+* ..
+* .. External Subroutines ..
+ EXTERNAL XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MOD
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ IF( N.LT.0 ) THEN
+ INFO = -1
+ CALL XERBLA( 'DPTTRF', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+* Compute the L*D*L' (or U'*D*U) factorization of A.
+*
+ I4 = MOD( N-1, 4 )
+ DO 10 I = 1, I4
+ IF( D( I ).LE.ZERO ) THEN
+ INFO = I
+ GO TO 30
+ END IF
+ EI = E( I )
+ E( I ) = EI / D( I )
+ D( I+1 ) = D( I+1 ) - E( I )*EI
+ 10 CONTINUE
+*
+ DO 20 I = I4 + 1, N - 4, 4
+*
+* Drop out of the loop if d(i) <= 0: the matrix is not positive
+* definite.
+*
+ IF( D( I ).LE.ZERO ) THEN
+ INFO = I
+ GO TO 30
+ END IF
+*
+* Solve for e(i) and d(i+1).
+*
+ EI = E( I )
+ E( I ) = EI / D( I )
+ D( I+1 ) = D( I+1 ) - E( I )*EI
+*
+ IF( D( I+1 ).LE.ZERO ) THEN
+ INFO = I + 1
+ GO TO 30
+ END IF
+*
+* Solve for e(i+1) and d(i+2).
+*
+ EI = E( I+1 )
+ E( I+1 ) = EI / D( I+1 )
+ D( I+2 ) = D( I+2 ) - E( I+1 )*EI
+*
+ IF( D( I+2 ).LE.ZERO ) THEN
+ INFO = I + 2
+ GO TO 30
+ END IF
+*
+* Solve for e(i+2) and d(i+3).
+*
+ EI = E( I+2 )
+ E( I+2 ) = EI / D( I+2 )
+ D( I+3 ) = D( I+3 ) - E( I+2 )*EI
+*
+ IF( D( I+3 ).LE.ZERO ) THEN
+ INFO = I + 3
+ GO TO 30
+ END IF
+*
+* Solve for e(i+3) and d(i+4).
+*
+ EI = E( I+3 )
+ E( I+3 ) = EI / D( I+3 )
+ D( I+4 ) = D( I+4 ) - E( I+3 )*EI
+ 20 CONTINUE
+*
+* Check d(n) for positive definiteness.
+*
+ IF( D( N ).LE.ZERO )
+ $ INFO = N
+*
+ 30 CONTINUE
+ RETURN
+*
+* End of DPTTRF
+*
+ END
+ SUBROUTINE DPTTRS( N, NRHS, D, E, B, LDB, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LDB, N, NRHS
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION B( LDB, * ), D( * ), E( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DPTTRS solves a tridiagonal system of the form
+* A * X = B
+* using the L*D*L' factorization of A computed by DPTTRF. D is a
+* diagonal matrix specified in the vector D, L is a unit bidiagonal
+* matrix whose subdiagonal is specified in the vector E, and X and B
+* are N by NRHS matrices.
+*
+* Arguments
+* =========
+*
+* N (input) INTEGER
+* The order of the tridiagonal matrix A. N >= 0.
+*
+* NRHS (input) INTEGER
+* The number of right hand sides, i.e., the number of columns
+* of the matrix B. NRHS >= 0.
+*
+* D (input) DOUBLE PRECISION array, dimension (N)
+* The n diagonal elements of the diagonal matrix D from the
+* L*D*L' factorization of A.
+*
+* E (input) DOUBLE PRECISION array, dimension (N-1)
+* The (n-1) subdiagonal elements of the unit bidiagonal factor
+* L from the L*D*L' factorization of A. E can also be regarded
+* as the superdiagonal of the unit bidiagonal factor U from the
+* factorization A = U'*D*U.
+*
+* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
+* On entry, the right hand side vectors B for the system of
+* linear equations.
+* On exit, the solution vectors, X.
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. LDB >= max(1,N).
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -k, the k-th argument had an illegal value
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ INTEGER J, JB, NB
+* ..
+* .. External Functions ..
+ INTEGER ILAENV
+ EXTERNAL ILAENV
+* ..
+* .. External Subroutines ..
+ EXTERNAL DPTTS2, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+* Test the input arguments.
+*
+ INFO = 0
+ IF( N.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( NRHS.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -6
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DPTTRS', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 .OR. NRHS.EQ.0 )
+ $ RETURN
+*
+* Determine the number of right-hand sides to solve at a time.
+*
+ IF( NRHS.EQ.1 ) THEN
+ NB = 1
+ ELSE
+ NB = MAX( 1, ILAENV( 1, 'DPTTRS', ' ', N, NRHS, -1, -1 ) )
+ END IF
+*
+ IF( NB.GE.NRHS ) THEN
+ CALL DPTTS2( N, NRHS, D, E, B, LDB )
+ ELSE
+ DO 10 J = 1, NRHS, NB
+ JB = MIN( NRHS-J+1, NB )
+ CALL DPTTS2( N, JB, D, E, B( 1, J ), LDB )
+ 10 CONTINUE
+ END IF
+*
+ RETURN
+*
+* End of DPTTRS
+*
+ END
+ SUBROUTINE DPTTS2( N, NRHS, D, E, B, LDB )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER LDB, N, NRHS
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION B( LDB, * ), D( * ), E( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DPTTS2 solves a tridiagonal system of the form
+* A * X = B
+* using the L*D*L' factorization of A computed by DPTTRF. D is a
+* diagonal matrix specified in the vector D, L is a unit bidiagonal
+* matrix whose subdiagonal is specified in the vector E, and X and B
+* are N by NRHS matrices.
+*
+* Arguments
+* =========
+*
+* N (input) INTEGER
+* The order of the tridiagonal matrix A. N >= 0.
+*
+* NRHS (input) INTEGER
+* The number of right hand sides, i.e., the number of columns
+* of the matrix B. NRHS >= 0.
+*
+* D (input) DOUBLE PRECISION array, dimension (N)
+* The n diagonal elements of the diagonal matrix D from the
+* L*D*L' factorization of A.
+*
+* E (input) DOUBLE PRECISION array, dimension (N-1)
+* The (n-1) subdiagonal elements of the unit bidiagonal factor
+* L from the L*D*L' factorization of A. E can also be regarded
+* as the superdiagonal of the unit bidiagonal factor U from the
+* factorization A = U'*D*U.
+*
+* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
+* On entry, the right hand side vectors B for the system of
+* linear equations.
+* On exit, the solution vectors, X.
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. LDB >= max(1,N).
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ INTEGER I, J
+* ..
+* .. External Subroutines ..
+ EXTERNAL DSCAL
+* ..
+* .. Executable Statements ..
+*
+* Quick return if possible
+*
+ IF( N.LE.1 ) THEN
+ IF( N.EQ.1 )
+ $ CALL DSCAL( NRHS, 1.D0 / D( 1 ), B, LDB )
+ RETURN
+ END IF
+*
+* Solve A * X = B using the factorization A = L*D*L',
+* overwriting each right hand side vector with its solution.
+*
+ DO 30 J = 1, NRHS
+*
+* Solve L * x = b.
+*
+ DO 10 I = 2, N
+ B( I, J ) = B( I, J ) - B( I-1, J )*E( I-1 )
+ 10 CONTINUE
+*
+* Solve D * L' * x = b.
+*
+ B( N, J ) = B( N, J ) / D( N )
+ DO 20 I = N - 1, 1, -1
+ B( I, J ) = B( I, J ) / D( I ) - B( I+1, J )*E( I )
+ 20 CONTINUE
+ 30 CONTINUE
+*
+ RETURN
+*
+* End of DPTTS2
+*
+ END
+ SUBROUTINE DRSCL( N, SA, SX, INCX )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INCX, N
+ DOUBLE PRECISION SA
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION SX( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DRSCL multiplies an n-element real vector x by the real scalar 1/a.
+* This is done without overflow or underflow as long as
+* the final result x/a does not overflow or underflow.
+*
+* Arguments
+* =========
+*
+* N (input) INTEGER
+* The number of components of the vector x.
+*
+* SA (input) DOUBLE PRECISION
+* The scalar a which is used to divide each component of x.
+* SA must be >= 0, or the subroutine will divide by zero.
+*
+* SX (input/output) DOUBLE PRECISION array, dimension
+* (1+(N-1)*abs(INCX))
+* The n-element vector x.
+*
+* INCX (input) INTEGER
+* The increment between successive values of the vector SX.
+* > 0: SX(1) = X(1) and SX(1+(i-1)*INCX) = x(i), 1< i<= n
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE, ZERO
+ PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL DONE
+ DOUBLE PRECISION BIGNUM, CDEN, CDEN1, CNUM, CNUM1, MUL, SMLNUM
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DLAMCH
+ EXTERNAL DLAMCH
+* ..
+* .. External Subroutines ..
+ EXTERNAL DSCAL
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS
+* ..
+* .. Executable Statements ..
+*
+* Quick return if possible
+*
+ IF( N.LE.0 )
+ $ RETURN
+*
+* Get machine parameters
+*
+ SMLNUM = DLAMCH( 'S' )
+ BIGNUM = ONE / SMLNUM
+ CALL DLABAD( SMLNUM, BIGNUM )
+*
+* Initialize the denominator to SA and the numerator to 1.
+*
+ CDEN = SA
+ CNUM = ONE
+*
+ 10 CONTINUE
+ CDEN1 = CDEN*SMLNUM
+ CNUM1 = CNUM / BIGNUM
+ IF( ABS( CDEN1 ).GT.ABS( CNUM ) .AND. CNUM.NE.ZERO ) THEN
+*
+* Pre-multiply X by SMLNUM if CDEN is large compared to CNUM.
+*
+ MUL = SMLNUM
+ DONE = .FALSE.
+ CDEN = CDEN1
+ ELSE IF( ABS( CNUM1 ).GT.ABS( CDEN ) ) THEN
+*
+* Pre-multiply X by BIGNUM if CDEN is small compared to CNUM.
+*
+ MUL = BIGNUM
+ DONE = .FALSE.
+ CNUM = CNUM1
+ ELSE
+*
+* Multiply X by CNUM / CDEN and return.
+*
+ MUL = CNUM / CDEN
+ DONE = .TRUE.
+ END IF
+*
+* Scale the vector X by MUL
+*
+ CALL DSCAL( N, MUL, SX, INCX )
+*
+ IF( .NOT.DONE )
+ $ GO TO 10
+*
+ RETURN
+*
+* End of DRSCL
+*
+ END
+ SUBROUTINE DSBEV( JOBZ, UPLO, N, KD, AB, LDAB, W, Z, LDZ, WORK,
+ $ INFO )
+*
+* -- LAPACK driver routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER JOBZ, UPLO
+ INTEGER INFO, KD, LDAB, LDZ, N
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION AB( LDAB, * ), W( * ), WORK( * ), Z( LDZ, * )
+* ..
+*
+* Purpose
+* =======
+*
+* DSBEV computes all the eigenvalues and, optionally, eigenvectors of
+* a real symmetric band matrix A.
+*
+* Arguments
+* =========
+*
+* JOBZ (input) CHARACTER*1
+* = 'N': Compute eigenvalues only;
+* = 'V': Compute eigenvalues and eigenvectors.
+*
+* UPLO (input) CHARACTER*1
+* = 'U': Upper triangle of A is stored;
+* = 'L': Lower triangle of A is stored.
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* KD (input) INTEGER
+* The number of superdiagonals of the matrix A if UPLO = 'U',
+* or the number of subdiagonals if UPLO = 'L'. KD >= 0.
+*
+* AB (input/output) DOUBLE PRECISION array, dimension (LDAB, N)
+* On entry, the upper or lower triangle of the symmetric band
+* matrix A, stored in the first KD+1 rows of the array. The
+* j-th column of A is stored in the j-th column of the array AB
+* as follows:
+* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
+* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).
+*
+* On exit, AB is overwritten by values generated during the
+* reduction to tridiagonal form. If UPLO = 'U', the first
+* superdiagonal and the diagonal of the tridiagonal matrix T
+* are returned in rows KD and KD+1 of AB, and if UPLO = 'L',
+* the diagonal and first subdiagonal of T are returned in the
+* first two rows of AB.
+*
+* LDAB (input) INTEGER
+* The leading dimension of the array AB. LDAB >= KD + 1.
+*
+* W (output) DOUBLE PRECISION array, dimension (N)
+* If INFO = 0, the eigenvalues in ascending order.
+*
+* Z (output) DOUBLE PRECISION array, dimension (LDZ, N)
+* If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal
+* eigenvectors of the matrix A, with the i-th column of Z
+* holding the eigenvector associated with W(i).
+* If JOBZ = 'N', then Z is not referenced.
+*
+* LDZ (input) INTEGER
+* The leading dimension of the array Z. LDZ >= 1, and if
+* JOBZ = 'V', LDZ >= max(1,N).
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (max(1,3*N-2))
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* > 0: if INFO = i, the algorithm failed to converge; i
+* off-diagonal elements of an intermediate tridiagonal
+* form did not converge to zero.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL LOWER, WANTZ
+ INTEGER IINFO, IMAX, INDE, INDWRK, ISCALE
+ DOUBLE PRECISION ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA,
+ $ SMLNUM
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ DOUBLE PRECISION DLAMCH, DLANSB
+ EXTERNAL LSAME, DLAMCH, DLANSB
+* ..
+* .. External Subroutines ..
+ EXTERNAL DLASCL, DSBTRD, DSCAL, DSTEQR, DSTERF, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC SQRT
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ WANTZ = LSAME( JOBZ, 'V' )
+ LOWER = LSAME( UPLO, 'L' )
+*
+ INFO = 0
+ IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
+ INFO = -1
+ ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN
+ INFO = -2
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( KD.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( LDAB.LT.KD+1 ) THEN
+ INFO = -6
+ ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
+ INFO = -9
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DSBEV ', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+ IF( N.EQ.1 ) THEN
+ IF( LOWER ) THEN
+ W( 1 ) = AB( 1, 1 )
+ ELSE
+ W( 1 ) = AB( KD+1, 1 )
+ END IF
+ IF( WANTZ )
+ $ Z( 1, 1 ) = ONE
+ RETURN
+ END IF
+*
+* Get machine constants.
+*
+ SAFMIN = DLAMCH( 'Safe minimum' )
+ EPS = DLAMCH( 'Precision' )
+ SMLNUM = SAFMIN / EPS
+ BIGNUM = ONE / SMLNUM
+ RMIN = SQRT( SMLNUM )
+ RMAX = SQRT( BIGNUM )
+*
+* Scale matrix to allowable range, if necessary.
+*
+ ANRM = DLANSB( 'M', UPLO, N, KD, AB, LDAB, WORK )
+ ISCALE = 0
+ IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN
+ ISCALE = 1
+ SIGMA = RMIN / ANRM
+ ELSE IF( ANRM.GT.RMAX ) THEN
+ ISCALE = 1
+ SIGMA = RMAX / ANRM
+ END IF
+ IF( ISCALE.EQ.1 ) THEN
+ IF( LOWER ) THEN
+ CALL DLASCL( 'B', KD, KD, ONE, SIGMA, N, N, AB, LDAB, INFO )
+ ELSE
+ CALL DLASCL( 'Q', KD, KD, ONE, SIGMA, N, N, AB, LDAB, INFO )
+ END IF
+ END IF
+*
+* Call DSBTRD to reduce symmetric band matrix to tridiagonal form.
+*
+ INDE = 1
+ INDWRK = INDE + N
+ CALL DSBTRD( JOBZ, UPLO, N, KD, AB, LDAB, W, WORK( INDE ), Z, LDZ,
+ $ WORK( INDWRK ), IINFO )
+*
+* For eigenvalues only, call DSTERF. For eigenvectors, call SSTEQR.
+*
+ IF( .NOT.WANTZ ) THEN
+ CALL DSTERF( N, W, WORK( INDE ), INFO )
+ ELSE
+ CALL DSTEQR( JOBZ, N, W, WORK( INDE ), Z, LDZ, WORK( INDWRK ),
+ $ INFO )
+ END IF
+*
+* If matrix was scaled, then rescale eigenvalues appropriately.
+*
+ IF( ISCALE.EQ.1 ) THEN
+ IF( INFO.EQ.0 ) THEN
+ IMAX = N
+ ELSE
+ IMAX = INFO - 1
+ END IF
+ CALL DSCAL( IMAX, ONE / SIGMA, W, 1 )
+ END IF
+*
+ RETURN
+*
+* End of DSBEV
+*
+ END
+ SUBROUTINE DSBEVD( JOBZ, UPLO, N, KD, AB, LDAB, W, Z, LDZ, WORK,
+ $ LWORK, IWORK, LIWORK, INFO )
+*
+* -- LAPACK driver routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER JOBZ, UPLO
+ INTEGER INFO, KD, LDAB, LDZ, LIWORK, LWORK, N
+* ..
+* .. Array Arguments ..
+ INTEGER IWORK( * )
+ DOUBLE PRECISION AB( LDAB, * ), W( * ), WORK( * ), Z( LDZ, * )
+* ..
+*
+* Purpose
+* =======
+*
+* DSBEVD computes all the eigenvalues and, optionally, eigenvectors of
+* a real symmetric band matrix A. If eigenvectors are desired, it uses
+* a divide and conquer algorithm.
+*
+* The divide and conquer algorithm makes very mild assumptions about
+* floating point arithmetic. It will work on machines with a guard
+* digit in add/subtract, or on those binary machines without guard
+* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
+* Cray-2. It could conceivably fail on hexadecimal or decimal machines
+* without guard digits, but we know of none.
+*
+* Arguments
+* =========
+*
+* JOBZ (input) CHARACTER*1
+* = 'N': Compute eigenvalues only;
+* = 'V': Compute eigenvalues and eigenvectors.
+*
+* UPLO (input) CHARACTER*1
+* = 'U': Upper triangle of A is stored;
+* = 'L': Lower triangle of A is stored.
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* KD (input) INTEGER
+* The number of superdiagonals of the matrix A if UPLO = 'U',
+* or the number of subdiagonals if UPLO = 'L'. KD >= 0.
+*
+* AB (input/output) DOUBLE PRECISION array, dimension (LDAB, N)
+* On entry, the upper or lower triangle of the symmetric band
+* matrix A, stored in the first KD+1 rows of the array. The
+* j-th column of A is stored in the j-th column of the array AB
+* as follows:
+* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
+* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).
+*
+* On exit, AB is overwritten by values generated during the
+* reduction to tridiagonal form. If UPLO = 'U', the first
+* superdiagonal and the diagonal of the tridiagonal matrix T
+* are returned in rows KD and KD+1 of AB, and if UPLO = 'L',
+* the diagonal and first subdiagonal of T are returned in the
+* first two rows of AB.
+*
+* LDAB (input) INTEGER
+* The leading dimension of the array AB. LDAB >= KD + 1.
+*
+* W (output) DOUBLE PRECISION array, dimension (N)
+* If INFO = 0, the eigenvalues in ascending order.
+*
+* Z (output) DOUBLE PRECISION array, dimension (LDZ, N)
+* If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal
+* eigenvectors of the matrix A, with the i-th column of Z
+* holding the eigenvector associated with W(i).
+* If JOBZ = 'N', then Z is not referenced.
+*
+* LDZ (input) INTEGER
+* The leading dimension of the array Z. LDZ >= 1, and if
+* JOBZ = 'V', LDZ >= max(1,N).
+*
+* WORK (workspace/output) DOUBLE PRECISION array,
+* dimension (LWORK)
+* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+* LWORK (input) INTEGER
+* The dimension of the array WORK.
+* IF N <= 1, LWORK must be at least 1.
+* If JOBZ = 'N' and N > 2, LWORK must be at least 2*N.
+* If JOBZ = 'V' and N > 2, LWORK must be at least
+* ( 1 + 5*N + 2*N**2 ).
+*
+* If LWORK = -1, then a workspace query is assumed; the routine
+* only calculates the optimal sizes of the WORK and IWORK
+* arrays, returns these values as the first entries of the WORK
+* and IWORK arrays, and no error message related to LWORK or
+* LIWORK is issued by XERBLA.
+*
+* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))
+* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
+*
+* LIWORK (input) INTEGER
+* The dimension of the array LIWORK.
+* If JOBZ = 'N' or N <= 1, LIWORK must be at least 1.
+* If JOBZ = 'V' and N > 2, LIWORK must be at least 3 + 5*N.
+*
+* If LIWORK = -1, then a workspace query is assumed; the
+* routine only calculates the optimal sizes of the WORK and
+* IWORK arrays, returns these values as the first entries of
+* the WORK and IWORK arrays, and no error message related to
+* LWORK or LIWORK is issued by XERBLA.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* > 0: if INFO = i, the algorithm failed to converge; i
+* off-diagonal elements of an intermediate tridiagonal
+* form did not converge to zero.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL LOWER, LQUERY, WANTZ
+ INTEGER IINFO, INDE, INDWK2, INDWRK, ISCALE, LIWMIN,
+ $ LLWRK2, LWMIN
+ DOUBLE PRECISION ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA,
+ $ SMLNUM
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ DOUBLE PRECISION DLAMCH, DLANSB
+ EXTERNAL LSAME, DLAMCH, DLANSB
+* ..
+* .. External Subroutines ..
+ EXTERNAL DGEMM, DLACPY, DLASCL, DSBTRD, DSCAL, DSTEDC,
+ $ DSTERF, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC SQRT
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ WANTZ = LSAME( JOBZ, 'V' )
+ LOWER = LSAME( UPLO, 'L' )
+ LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 )
+*
+ INFO = 0
+ IF( N.LE.1 ) THEN
+ LIWMIN = 1
+ LWMIN = 1
+ ELSE
+ IF( WANTZ ) THEN
+ LIWMIN = 3 + 5*N
+ LWMIN = 1 + 5*N + 2*N**2
+ ELSE
+ LIWMIN = 1
+ LWMIN = 2*N
+ END IF
+ END IF
+ IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
+ INFO = -1
+ ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN
+ INFO = -2
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( KD.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( LDAB.LT.KD+1 ) THEN
+ INFO = -6
+ ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
+ INFO = -9
+ END IF
+*
+ IF( INFO.EQ.0 ) THEN
+ WORK( 1 ) = LWMIN
+ IWORK( 1 ) = LIWMIN
+*
+ IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
+ INFO = -11
+ ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN
+ INFO = -13
+ END IF
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DSBEVD', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+ IF( N.EQ.1 ) THEN
+ W( 1 ) = AB( 1, 1 )
+ IF( WANTZ )
+ $ Z( 1, 1 ) = ONE
+ RETURN
+ END IF
+*
+* Get machine constants.
+*
+ SAFMIN = DLAMCH( 'Safe minimum' )
+ EPS = DLAMCH( 'Precision' )
+ SMLNUM = SAFMIN / EPS
+ BIGNUM = ONE / SMLNUM
+ RMIN = SQRT( SMLNUM )
+ RMAX = SQRT( BIGNUM )
+*
+* Scale matrix to allowable range, if necessary.
+*
+ ANRM = DLANSB( 'M', UPLO, N, KD, AB, LDAB, WORK )
+ ISCALE = 0
+ IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN
+ ISCALE = 1
+ SIGMA = RMIN / ANRM
+ ELSE IF( ANRM.GT.RMAX ) THEN
+ ISCALE = 1
+ SIGMA = RMAX / ANRM
+ END IF
+ IF( ISCALE.EQ.1 ) THEN
+ IF( LOWER ) THEN
+ CALL DLASCL( 'B', KD, KD, ONE, SIGMA, N, N, AB, LDAB, INFO )
+ ELSE
+ CALL DLASCL( 'Q', KD, KD, ONE, SIGMA, N, N, AB, LDAB, INFO )
+ END IF
+ END IF
+*
+* Call DSBTRD to reduce symmetric band matrix to tridiagonal form.
+*
+ INDE = 1
+ INDWRK = INDE + N
+ INDWK2 = INDWRK + N*N
+ LLWRK2 = LWORK - INDWK2 + 1
+ CALL DSBTRD( JOBZ, UPLO, N, KD, AB, LDAB, W, WORK( INDE ), Z, LDZ,
+ $ WORK( INDWRK ), IINFO )
+*
+* For eigenvalues only, call DSTERF. For eigenvectors, call SSTEDC.
+*
+ IF( .NOT.WANTZ ) THEN
+ CALL DSTERF( N, W, WORK( INDE ), INFO )
+ ELSE
+ CALL DSTEDC( 'I', N, W, WORK( INDE ), WORK( INDWRK ), N,
+ $ WORK( INDWK2 ), LLWRK2, IWORK, LIWORK, INFO )
+ CALL DGEMM( 'N', 'N', N, N, N, ONE, Z, LDZ, WORK( INDWRK ), N,
+ $ ZERO, WORK( INDWK2 ), N )
+ CALL DLACPY( 'A', N, N, WORK( INDWK2 ), N, Z, LDZ )
+ END IF
+*
+* If matrix was scaled, then rescale eigenvalues appropriately.
+*
+ IF( ISCALE.EQ.1 )
+ $ CALL DSCAL( N, ONE / SIGMA, W, 1 )
+*
+ WORK( 1 ) = LWMIN
+ IWORK( 1 ) = LIWMIN
+ RETURN
+*
+* End of DSBEVD
+*
+ END
+ SUBROUTINE DSBEVX( JOBZ, RANGE, UPLO, N, KD, AB, LDAB, Q, LDQ, VL,
+ $ VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, IWORK,
+ $ IFAIL, INFO )
+*
+* -- LAPACK driver routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER JOBZ, RANGE, UPLO
+ INTEGER IL, INFO, IU, KD, LDAB, LDQ, LDZ, M, N
+ DOUBLE PRECISION ABSTOL, VL, VU
+* ..
+* .. Array Arguments ..
+ INTEGER IFAIL( * ), IWORK( * )
+ DOUBLE PRECISION AB( LDAB, * ), Q( LDQ, * ), W( * ), WORK( * ),
+ $ Z( LDZ, * )
+* ..
+*
+* Purpose
+* =======
+*
+* DSBEVX computes selected eigenvalues and, optionally, eigenvectors
+* of a real symmetric band matrix A. Eigenvalues and eigenvectors can
+* be selected by specifying either a range of values or a range of
+* indices for the desired eigenvalues.
+*
+* Arguments
+* =========
+*
+* JOBZ (input) CHARACTER*1
+* = 'N': Compute eigenvalues only;
+* = 'V': Compute eigenvalues and eigenvectors.
+*
+* RANGE (input) CHARACTER*1
+* = 'A': all eigenvalues will be found;
+* = 'V': all eigenvalues in the half-open interval (VL,VU]
+* will be found;
+* = 'I': the IL-th through IU-th eigenvalues will be found.
+*
+* UPLO (input) CHARACTER*1
+* = 'U': Upper triangle of A is stored;
+* = 'L': Lower triangle of A is stored.
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* KD (input) INTEGER
+* The number of superdiagonals of the matrix A if UPLO = 'U',
+* or the number of subdiagonals if UPLO = 'L'. KD >= 0.
+*
+* AB (input/output) DOUBLE PRECISION array, dimension (LDAB, N)
+* On entry, the upper or lower triangle of the symmetric band
+* matrix A, stored in the first KD+1 rows of the array. The
+* j-th column of A is stored in the j-th column of the array AB
+* as follows:
+* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
+* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).
+*
+* On exit, AB is overwritten by values generated during the
+* reduction to tridiagonal form. If UPLO = 'U', the first
+* superdiagonal and the diagonal of the tridiagonal matrix T
+* are returned in rows KD and KD+1 of AB, and if UPLO = 'L',
+* the diagonal and first subdiagonal of T are returned in the
+* first two rows of AB.
+*
+* LDAB (input) INTEGER
+* The leading dimension of the array AB. LDAB >= KD + 1.
+*
+* Q (output) DOUBLE PRECISION array, dimension (LDQ, N)
+* If JOBZ = 'V', the N-by-N orthogonal matrix used in the
+* reduction to tridiagonal form.
+* If JOBZ = 'N', the array Q is not referenced.
+*
+* LDQ (input) INTEGER
+* The leading dimension of the array Q. If JOBZ = 'V', then
+* LDQ >= max(1,N).
+*
+* VL (input) DOUBLE PRECISION
+* VU (input) DOUBLE PRECISION
+* If RANGE='V', the lower and upper bounds of the interval to
+* be searched for eigenvalues. VL < VU.
+* Not referenced if RANGE = 'A' or 'I'.
+*
+* IL (input) INTEGER
+* IU (input) INTEGER
+* If RANGE='I', the indices (in ascending order) of the
+* smallest and largest eigenvalues to be returned.
+* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
+* Not referenced if RANGE = 'A' or 'V'.
+*
+* ABSTOL (input) DOUBLE PRECISION
+* The absolute error tolerance for the eigenvalues.
+* An approximate eigenvalue is accepted as converged
+* when it is determined to lie in an interval [a,b]
+* of width less than or equal to
+*
+* ABSTOL + EPS * max( |a|,|b| ) ,
+*
+* where EPS is the machine precision. If ABSTOL is less than
+* or equal to zero, then EPS*|T| will be used in its place,
+* where |T| is the 1-norm of the tridiagonal matrix obtained
+* by reducing AB to tridiagonal form.
+*
+* Eigenvalues will be computed most accurately when ABSTOL is
+* set to twice the underflow threshold 2*DLAMCH('S'), not zero.
+* If this routine returns with INFO>0, indicating that some
+* eigenvectors did not converge, try setting ABSTOL to
+* 2*DLAMCH('S').
+*
+* See "Computing Small Singular Values of Bidiagonal Matrices
+* with Guaranteed High Relative Accuracy," by Demmel and
+* Kahan, LAPACK Working Note #3.
+*
+* M (output) INTEGER
+* The total number of eigenvalues found. 0 <= M <= N.
+* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
+*
+* W (output) DOUBLE PRECISION array, dimension (N)
+* The first M elements contain the selected eigenvalues in
+* ascending order.
+*
+* Z (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M))
+* If JOBZ = 'V', then if INFO = 0, the first M columns of Z
+* contain the orthonormal eigenvectors of the matrix A
+* corresponding to the selected eigenvalues, with the i-th
+* column of Z holding the eigenvector associated with W(i).
+* If an eigenvector fails to converge, then that column of Z
+* contains the latest approximation to the eigenvector, and the
+* index of the eigenvector is returned in IFAIL.
+* If JOBZ = 'N', then Z is not referenced.
+* Note: the user must ensure that at least max(1,M) columns are
+* supplied in the array Z; if RANGE = 'V', the exact value of M
+* is not known in advance and an upper bound must be used.
+*
+* LDZ (input) INTEGER
+* The leading dimension of the array Z. LDZ >= 1, and if
+* JOBZ = 'V', LDZ >= max(1,N).
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (7*N)
+*
+* IWORK (workspace) INTEGER array, dimension (5*N)
+*
+* IFAIL (output) INTEGER array, dimension (N)
+* If JOBZ = 'V', then if INFO = 0, the first M elements of
+* IFAIL are zero. If INFO > 0, then IFAIL contains the
+* indices of the eigenvectors that failed to converge.
+* If JOBZ = 'N', then IFAIL is not referenced.
+*
+* INFO (output) INTEGER
+* = 0: successful exit.
+* < 0: if INFO = -i, the i-th argument had an illegal value.
+* > 0: if INFO = i, then i eigenvectors failed to converge.
+* Their indices are stored in array IFAIL.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL ALLEIG, INDEIG, LOWER, TEST, VALEIG, WANTZ
+ CHARACTER ORDER
+ INTEGER I, IINFO, IMAX, INDD, INDE, INDEE, INDIBL,
+ $ INDISP, INDIWO, INDWRK, ISCALE, ITMP1, J, JJ,
+ $ NSPLIT
+ DOUBLE PRECISION ABSTLL, ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN,
+ $ SIGMA, SMLNUM, TMP1, VLL, VUU
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ DOUBLE PRECISION DLAMCH, DLANSB
+ EXTERNAL LSAME, DLAMCH, DLANSB
+* ..
+* .. External Subroutines ..
+ EXTERNAL DCOPY, DGEMV, DLACPY, DLASCL, DSBTRD, DSCAL,
+ $ DSTEBZ, DSTEIN, DSTEQR, DSTERF, DSWAP, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN, SQRT
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ WANTZ = LSAME( JOBZ, 'V' )
+ ALLEIG = LSAME( RANGE, 'A' )
+ VALEIG = LSAME( RANGE, 'V' )
+ INDEIG = LSAME( RANGE, 'I' )
+ LOWER = LSAME( UPLO, 'L' )
+*
+ INFO = 0
+ IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
+ INFO = -1
+ ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN
+ INFO = -2
+ ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN
+ INFO = -3
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( KD.LT.0 ) THEN
+ INFO = -5
+ ELSE IF( LDAB.LT.KD+1 ) THEN
+ INFO = -7
+ ELSE IF( WANTZ .AND. LDQ.LT.MAX( 1, N ) ) THEN
+ INFO = -9
+ ELSE
+ IF( VALEIG ) THEN
+ IF( N.GT.0 .AND. VU.LE.VL )
+ $ INFO = -11
+ ELSE IF( INDEIG ) THEN
+ IF( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) THEN
+ INFO = -12
+ ELSE IF( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) THEN
+ INFO = -13
+ END IF
+ END IF
+ END IF
+ IF( INFO.EQ.0 ) THEN
+ IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) )
+ $ INFO = -18
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DSBEVX', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ M = 0
+ IF( N.EQ.0 )
+ $ RETURN
+*
+ IF( N.EQ.1 ) THEN
+ M = 1
+ IF( LOWER ) THEN
+ TMP1 = AB( 1, 1 )
+ ELSE
+ TMP1 = AB( KD+1, 1 )
+ END IF
+ IF( VALEIG ) THEN
+ IF( .NOT.( VL.LT.TMP1 .AND. VU.GE.TMP1 ) )
+ $ M = 0
+ END IF
+ IF( M.EQ.1 ) THEN
+ W( 1 ) = TMP1
+ IF( WANTZ )
+ $ Z( 1, 1 ) = ONE
+ END IF
+ RETURN
+ END IF
+*
+* Get machine constants.
+*
+ SAFMIN = DLAMCH( 'Safe minimum' )
+ EPS = DLAMCH( 'Precision' )
+ SMLNUM = SAFMIN / EPS
+ BIGNUM = ONE / SMLNUM
+ RMIN = SQRT( SMLNUM )
+ RMAX = MIN( SQRT( BIGNUM ), ONE / SQRT( SQRT( SAFMIN ) ) )
+*
+* Scale matrix to allowable range, if necessary.
+*
+ ISCALE = 0
+ ABSTLL = ABSTOL
+ IF( VALEIG ) THEN
+ VLL = VL
+ VUU = VU
+ ELSE
+ VLL = ZERO
+ VUU = ZERO
+ END IF
+ ANRM = DLANSB( 'M', UPLO, N, KD, AB, LDAB, WORK )
+ IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN
+ ISCALE = 1
+ SIGMA = RMIN / ANRM
+ ELSE IF( ANRM.GT.RMAX ) THEN
+ ISCALE = 1
+ SIGMA = RMAX / ANRM
+ END IF
+ IF( ISCALE.EQ.1 ) THEN
+ IF( LOWER ) THEN
+ CALL DLASCL( 'B', KD, KD, ONE, SIGMA, N, N, AB, LDAB, INFO )
+ ELSE
+ CALL DLASCL( 'Q', KD, KD, ONE, SIGMA, N, N, AB, LDAB, INFO )
+ END IF
+ IF( ABSTOL.GT.0 )
+ $ ABSTLL = ABSTOL*SIGMA
+ IF( VALEIG ) THEN
+ VLL = VL*SIGMA
+ VUU = VU*SIGMA
+ END IF
+ END IF
+*
+* Call DSBTRD to reduce symmetric band matrix to tridiagonal form.
+*
+ INDD = 1
+ INDE = INDD + N
+ INDWRK = INDE + N
+ CALL DSBTRD( JOBZ, UPLO, N, KD, AB, LDAB, WORK( INDD ),
+ $ WORK( INDE ), Q, LDQ, WORK( INDWRK ), IINFO )
+*
+* If all eigenvalues are desired and ABSTOL is less than or equal
+* to zero, then call DSTERF or SSTEQR. If this fails for some
+* eigenvalue, then try DSTEBZ.
+*
+ TEST = .FALSE.
+ IF (INDEIG) THEN
+ IF (IL.EQ.1 .AND. IU.EQ.N) THEN
+ TEST = .TRUE.
+ END IF
+ END IF
+ IF ((ALLEIG .OR. TEST) .AND. (ABSTOL.LE.ZERO)) THEN
+ CALL DCOPY( N, WORK( INDD ), 1, W, 1 )
+ INDEE = INDWRK + 2*N
+ IF( .NOT.WANTZ ) THEN
+ CALL DCOPY( N-1, WORK( INDE ), 1, WORK( INDEE ), 1 )
+ CALL DSTERF( N, W, WORK( INDEE ), INFO )
+ ELSE
+ CALL DLACPY( 'A', N, N, Q, LDQ, Z, LDZ )
+ CALL DCOPY( N-1, WORK( INDE ), 1, WORK( INDEE ), 1 )
+ CALL DSTEQR( JOBZ, N, W, WORK( INDEE ), Z, LDZ,
+ $ WORK( INDWRK ), INFO )
+ IF( INFO.EQ.0 ) THEN
+ DO 10 I = 1, N
+ IFAIL( I ) = 0
+ 10 CONTINUE
+ END IF
+ END IF
+ IF( INFO.EQ.0 ) THEN
+ M = N
+ GO TO 30
+ END IF
+ INFO = 0
+ END IF
+*
+* Otherwise, call DSTEBZ and, if eigenvectors are desired, SSTEIN.
+*
+ IF( WANTZ ) THEN
+ ORDER = 'B'
+ ELSE
+ ORDER = 'E'
+ END IF
+ INDIBL = 1
+ INDISP = INDIBL + N
+ INDIWO = INDISP + N
+ CALL DSTEBZ( RANGE, ORDER, N, VLL, VUU, IL, IU, ABSTLL,
+ $ WORK( INDD ), WORK( INDE ), M, NSPLIT, W,
+ $ IWORK( INDIBL ), IWORK( INDISP ), WORK( INDWRK ),
+ $ IWORK( INDIWO ), INFO )
+*
+ IF( WANTZ ) THEN
+ CALL DSTEIN( N, WORK( INDD ), WORK( INDE ), M, W,
+ $ IWORK( INDIBL ), IWORK( INDISP ), Z, LDZ,
+ $ WORK( INDWRK ), IWORK( INDIWO ), IFAIL, INFO )
+*
+* Apply orthogonal matrix used in reduction to tridiagonal
+* form to eigenvectors returned by DSTEIN.
+*
+ DO 20 J = 1, M
+ CALL DCOPY( N, Z( 1, J ), 1, WORK( 1 ), 1 )
+ CALL DGEMV( 'N', N, N, ONE, Q, LDQ, WORK, 1, ZERO,
+ $ Z( 1, J ), 1 )
+ 20 CONTINUE
+ END IF
+*
+* If matrix was scaled, then rescale eigenvalues appropriately.
+*
+ 30 CONTINUE
+ IF( ISCALE.EQ.1 ) THEN
+ IF( INFO.EQ.0 ) THEN
+ IMAX = M
+ ELSE
+ IMAX = INFO - 1
+ END IF
+ CALL DSCAL( IMAX, ONE / SIGMA, W, 1 )
+ END IF
+*
+* If eigenvalues are not in order, then sort them, along with
+* eigenvectors.
+*
+ IF( WANTZ ) THEN
+ DO 50 J = 1, M - 1
+ I = 0
+ TMP1 = W( J )
+ DO 40 JJ = J + 1, M
+ IF( W( JJ ).LT.TMP1 ) THEN
+ I = JJ
+ TMP1 = W( JJ )
+ END IF
+ 40 CONTINUE
+*
+ IF( I.NE.0 ) THEN
+ ITMP1 = IWORK( INDIBL+I-1 )
+ W( I ) = W( J )
+ IWORK( INDIBL+I-1 ) = IWORK( INDIBL+J-1 )
+ W( J ) = TMP1
+ IWORK( INDIBL+J-1 ) = ITMP1
+ CALL DSWAP( N, Z( 1, I ), 1, Z( 1, J ), 1 )
+ IF( INFO.NE.0 ) THEN
+ ITMP1 = IFAIL( I )
+ IFAIL( I ) = IFAIL( J )
+ IFAIL( J ) = ITMP1
+ END IF
+ END IF
+ 50 CONTINUE
+ END IF
+*
+ RETURN
+*
+* End of DSBEVX
+*
+ END
+ SUBROUTINE DSBGST( VECT, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, X,
+ $ LDX, WORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO, VECT
+ INTEGER INFO, KA, KB, LDAB, LDBB, LDX, N
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION AB( LDAB, * ), BB( LDBB, * ), WORK( * ),
+ $ X( LDX, * )
+* ..
+*
+* Purpose
+* =======
+*
+* DSBGST reduces a real symmetric-definite banded generalized
+* eigenproblem A*x = lambda*B*x to standard form C*y = lambda*y,
+* such that C has the same bandwidth as A.
+*
+* B must have been previously factorized as S**T*S by DPBSTF, using a
+* split Cholesky factorization. A is overwritten by C = X**T*A*X, where
+* X = S**(-1)*Q and Q is an orthogonal matrix chosen to preserve the
+* bandwidth of A.
+*
+* Arguments
+* =========
+*
+* VECT (input) CHARACTER*1
+* = 'N': do not form the transformation matrix X;
+* = 'V': form X.
+*
+* UPLO (input) CHARACTER*1
+* = 'U': Upper triangle of A is stored;
+* = 'L': Lower triangle of A is stored.
+*
+* N (input) INTEGER
+* The order of the matrices A and B. N >= 0.
+*
+* KA (input) INTEGER
+* The number of superdiagonals of the matrix A if UPLO = 'U',
+* or the number of subdiagonals if UPLO = 'L'. KA >= 0.
+*
+* KB (input) INTEGER
+* The number of superdiagonals of the matrix B if UPLO = 'U',
+* or the number of subdiagonals if UPLO = 'L'. KA >= KB >= 0.
+*
+* AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N)
+* On entry, the upper or lower triangle of the symmetric band
+* matrix A, stored in the first ka+1 rows of the array. The
+* j-th column of A is stored in the j-th column of the array AB
+* as follows:
+* if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j;
+* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+ka).
+*
+* On exit, the transformed matrix X**T*A*X, stored in the same
+* format as A.
+*
+* LDAB (input) INTEGER
+* The leading dimension of the array AB. LDAB >= KA+1.
+*
+* BB (input) DOUBLE PRECISION array, dimension (LDBB,N)
+* The banded factor S from the split Cholesky factorization of
+* B, as returned by DPBSTF, stored in the first KB+1 rows of
+* the array.
+*
+* LDBB (input) INTEGER
+* The leading dimension of the array BB. LDBB >= KB+1.
+*
+* X (output) DOUBLE PRECISION array, dimension (LDX,N)
+* If VECT = 'V', the n-by-n matrix X.
+* If VECT = 'N', the array X is not referenced.
+*
+* LDX (input) INTEGER
+* The leading dimension of the array X.
+* LDX >= max(1,N) if VECT = 'V'; LDX >= 1 otherwise.
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (2*N)
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL UPDATE, UPPER, WANTX
+ INTEGER I, I0, I1, I2, INCA, J, J1, J1T, J2, J2T, K,
+ $ KA1, KB1, KBT, L, M, NR, NRT, NX
+ DOUBLE PRECISION BII, RA, RA1, T
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL DGER, DLAR2V, DLARGV, DLARTG, DLARTV, DLASET,
+ $ DROT, DSCAL, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters
+*
+ WANTX = LSAME( VECT, 'V' )
+ UPPER = LSAME( UPLO, 'U' )
+ KA1 = KA + 1
+ KB1 = KB + 1
+ INFO = 0
+ IF( .NOT.WANTX .AND. .NOT.LSAME( VECT, 'N' ) ) THEN
+ INFO = -1
+ ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -2
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( KA.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( KB.LT.0 .OR. KB.GT.KA ) THEN
+ INFO = -5
+ ELSE IF( LDAB.LT.KA+1 ) THEN
+ INFO = -7
+ ELSE IF( LDBB.LT.KB+1 ) THEN
+ INFO = -9
+ ELSE IF( LDX.LT.1 .OR. WANTX .AND. LDX.LT.MAX( 1, N ) ) THEN
+ INFO = -11
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DSBGST', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+ INCA = LDAB*KA1
+*
+* Initialize X to the unit matrix, if needed
+*
+ IF( WANTX )
+ $ CALL DLASET( 'Full', N, N, ZERO, ONE, X, LDX )
+*
+* Set M to the splitting point m. It must be the same value as is
+* used in DPBSTF. The chosen value allows the arrays WORK and RWORK
+* to be of dimension (N).
+*
+ M = ( N+KB ) / 2
+*
+* The routine works in two phases, corresponding to the two halves
+* of the split Cholesky factorization of B as S**T*S where
+*
+* S = ( U )
+* ( M L )
+*
+* with U upper triangular of order m, and L lower triangular of
+* order n-m. S has the same bandwidth as B.
+*
+* S is treated as a product of elementary matrices:
+*
+* S = S(m)*S(m-1)*...*S(2)*S(1)*S(m+1)*S(m+2)*...*S(n-1)*S(n)
+*
+* where S(i) is determined by the i-th row of S.
+*
+* In phase 1, the index i takes the values n, n-1, ... , m+1;
+* in phase 2, it takes the values 1, 2, ... , m.
+*
+* For each value of i, the current matrix A is updated by forming
+* inv(S(i))**T*A*inv(S(i)). This creates a triangular bulge outside
+* the band of A. The bulge is then pushed down toward the bottom of
+* A in phase 1, and up toward the top of A in phase 2, by applying
+* plane rotations.
+*
+* There are kb*(kb+1)/2 elements in the bulge, but at most 2*kb-1
+* of them are linearly independent, so annihilating a bulge requires
+* only 2*kb-1 plane rotations. The rotations are divided into a 1st
+* set of kb-1 rotations, and a 2nd set of kb rotations.
+*
+* Wherever possible, rotations are generated and applied in vector
+* operations of length NR between the indices J1 and J2 (sometimes
+* replaced by modified values NRT, J1T or J2T).
+*
+* The cosines and sines of the rotations are stored in the array
+* WORK. The cosines of the 1st set of rotations are stored in
+* elements n+2:n+m-kb-1 and the sines of the 1st set in elements
+* 2:m-kb-1; the cosines of the 2nd set are stored in elements
+* n+m-kb+1:2*n and the sines of the second set in elements m-kb+1:n.
+*
+* The bulges are not formed explicitly; nonzero elements outside the
+* band are created only when they are required for generating new
+* rotations; they are stored in the array WORK, in positions where
+* they are later overwritten by the sines of the rotations which
+* annihilate them.
+*
+* **************************** Phase 1 *****************************
+*
+* The logical structure of this phase is:
+*
+* UPDATE = .TRUE.
+* DO I = N, M + 1, -1
+* use S(i) to update A and create a new bulge
+* apply rotations to push all bulges KA positions downward
+* END DO
+* UPDATE = .FALSE.
+* DO I = M + KA + 1, N - 1
+* apply rotations to push all bulges KA positions downward
+* END DO
+*
+* To avoid duplicating code, the two loops are merged.
+*
+ UPDATE = .TRUE.
+ I = N + 1
+ 10 CONTINUE
+ IF( UPDATE ) THEN
+ I = I - 1
+ KBT = MIN( KB, I-1 )
+ I0 = I - 1
+ I1 = MIN( N, I+KA )
+ I2 = I - KBT + KA1
+ IF( I.LT.M+1 ) THEN
+ UPDATE = .FALSE.
+ I = I + 1
+ I0 = M
+ IF( KA.EQ.0 )
+ $ GO TO 480
+ GO TO 10
+ END IF
+ ELSE
+ I = I + KA
+ IF( I.GT.N-1 )
+ $ GO TO 480
+ END IF
+*
+ IF( UPPER ) THEN
+*
+* Transform A, working with the upper triangle
+*
+ IF( UPDATE ) THEN
+*
+* Form inv(S(i))**T * A * inv(S(i))
+*
+ BII = BB( KB1, I )
+ DO 20 J = I, I1
+ AB( I-J+KA1, J ) = AB( I-J+KA1, J ) / BII
+ 20 CONTINUE
+ DO 30 J = MAX( 1, I-KA ), I
+ AB( J-I+KA1, I ) = AB( J-I+KA1, I ) / BII
+ 30 CONTINUE
+ DO 60 K = I - KBT, I - 1
+ DO 40 J = I - KBT, K
+ AB( J-K+KA1, K ) = AB( J-K+KA1, K ) -
+ $ BB( J-I+KB1, I )*AB( K-I+KA1, I ) -
+ $ BB( K-I+KB1, I )*AB( J-I+KA1, I ) +
+ $ AB( KA1, I )*BB( J-I+KB1, I )*
+ $ BB( K-I+KB1, I )
+ 40 CONTINUE
+ DO 50 J = MAX( 1, I-KA ), I - KBT - 1
+ AB( J-K+KA1, K ) = AB( J-K+KA1, K ) -
+ $ BB( K-I+KB1, I )*AB( J-I+KA1, I )
+ 50 CONTINUE
+ 60 CONTINUE
+ DO 80 J = I, I1
+ DO 70 K = MAX( J-KA, I-KBT ), I - 1
+ AB( K-J+KA1, J ) = AB( K-J+KA1, J ) -
+ $ BB( K-I+KB1, I )*AB( I-J+KA1, J )
+ 70 CONTINUE
+ 80 CONTINUE
+*
+ IF( WANTX ) THEN
+*
+* post-multiply X by inv(S(i))
+*
+ CALL DSCAL( N-M, ONE / BII, X( M+1, I ), 1 )
+ IF( KBT.GT.0 )
+ $ CALL DGER( N-M, KBT, -ONE, X( M+1, I ), 1,
+ $ BB( KB1-KBT, I ), 1, X( M+1, I-KBT ), LDX )
+ END IF
+*
+* store a(i,i1) in RA1 for use in next loop over K
+*
+ RA1 = AB( I-I1+KA1, I1 )
+ END IF
+*
+* Generate and apply vectors of rotations to chase all the
+* existing bulges KA positions down toward the bottom of the
+* band
+*
+ DO 130 K = 1, KB - 1
+ IF( UPDATE ) THEN
+*
+* Determine the rotations which would annihilate the bulge
+* which has in theory just been created
+*
+ IF( I-K+KA.LT.N .AND. I-K.GT.1 ) THEN
+*
+* generate rotation to annihilate a(i,i-k+ka+1)
+*
+ CALL DLARTG( AB( K+1, I-K+KA ), RA1,
+ $ WORK( N+I-K+KA-M ), WORK( I-K+KA-M ),
+ $ RA )
+*
+* create nonzero element a(i-k,i-k+ka+1) outside the
+* band and store it in WORK(i-k)
+*
+ T = -BB( KB1-K, I )*RA1
+ WORK( I-K ) = WORK( N+I-K+KA-M )*T -
+ $ WORK( I-K+KA-M )*AB( 1, I-K+KA )
+ AB( 1, I-K+KA ) = WORK( I-K+KA-M )*T +
+ $ WORK( N+I-K+KA-M )*AB( 1, I-K+KA )
+ RA1 = RA
+ END IF
+ END IF
+ J2 = I - K - 1 + MAX( 1, K-I0+2 )*KA1
+ NR = ( N-J2+KA ) / KA1
+ J1 = J2 + ( NR-1 )*KA1
+ IF( UPDATE ) THEN
+ J2T = MAX( J2, I+2*KA-K+1 )
+ ELSE
+ J2T = J2
+ END IF
+ NRT = ( N-J2T+KA ) / KA1
+ DO 90 J = J2T, J1, KA1
+*
+* create nonzero element a(j-ka,j+1) outside the band
+* and store it in WORK(j-m)
+*
+ WORK( J-M ) = WORK( J-M )*AB( 1, J+1 )
+ AB( 1, J+1 ) = WORK( N+J-M )*AB( 1, J+1 )
+ 90 CONTINUE
+*
+* generate rotations in 1st set to annihilate elements which
+* have been created outside the band
+*
+ IF( NRT.GT.0 )
+ $ CALL DLARGV( NRT, AB( 1, J2T ), INCA, WORK( J2T-M ), KA1,
+ $ WORK( N+J2T-M ), KA1 )
+ IF( NR.GT.0 ) THEN
+*
+* apply rotations in 1st set from the right
+*
+ DO 100 L = 1, KA - 1
+ CALL DLARTV( NR, AB( KA1-L, J2 ), INCA,
+ $ AB( KA-L, J2+1 ), INCA, WORK( N+J2-M ),
+ $ WORK( J2-M ), KA1 )
+ 100 CONTINUE
+*
+* apply rotations in 1st set from both sides to diagonal
+* blocks
+*
+ CALL DLAR2V( NR, AB( KA1, J2 ), AB( KA1, J2+1 ),
+ $ AB( KA, J2+1 ), INCA, WORK( N+J2-M ),
+ $ WORK( J2-M ), KA1 )
+*
+ END IF
+*
+* start applying rotations in 1st set from the left
+*
+ DO 110 L = KA - 1, KB - K + 1, -1
+ NRT = ( N-J2+L ) / KA1
+ IF( NRT.GT.0 )
+ $ CALL DLARTV( NRT, AB( L, J2+KA1-L ), INCA,
+ $ AB( L+1, J2+KA1-L ), INCA,
+ $ WORK( N+J2-M ), WORK( J2-M ), KA1 )
+ 110 CONTINUE
+*
+ IF( WANTX ) THEN
+*
+* post-multiply X by product of rotations in 1st set
+*
+ DO 120 J = J2, J1, KA1
+ CALL DROT( N-M, X( M+1, J ), 1, X( M+1, J+1 ), 1,
+ $ WORK( N+J-M ), WORK( J-M ) )
+ 120 CONTINUE
+ END IF
+ 130 CONTINUE
+*
+ IF( UPDATE ) THEN
+ IF( I2.LE.N .AND. KBT.GT.0 ) THEN
+*
+* create nonzero element a(i-kbt,i-kbt+ka+1) outside the
+* band and store it in WORK(i-kbt)
+*
+ WORK( I-KBT ) = -BB( KB1-KBT, I )*RA1
+ END IF
+ END IF
+*
+ DO 170 K = KB, 1, -1
+ IF( UPDATE ) THEN
+ J2 = I - K - 1 + MAX( 2, K-I0+1 )*KA1
+ ELSE
+ J2 = I - K - 1 + MAX( 1, K-I0+1 )*KA1
+ END IF
+*
+* finish applying rotations in 2nd set from the left
+*
+ DO 140 L = KB - K, 1, -1
+ NRT = ( N-J2+KA+L ) / KA1
+ IF( NRT.GT.0 )
+ $ CALL DLARTV( NRT, AB( L, J2-L+1 ), INCA,
+ $ AB( L+1, J2-L+1 ), INCA, WORK( N+J2-KA ),
+ $ WORK( J2-KA ), KA1 )
+ 140 CONTINUE
+ NR = ( N-J2+KA ) / KA1
+ J1 = J2 + ( NR-1 )*KA1
+ DO 150 J = J1, J2, -KA1
+ WORK( J ) = WORK( J-KA )
+ WORK( N+J ) = WORK( N+J-KA )
+ 150 CONTINUE
+ DO 160 J = J2, J1, KA1
+*
+* create nonzero element a(j-ka,j+1) outside the band
+* and store it in WORK(j)
+*
+ WORK( J ) = WORK( J )*AB( 1, J+1 )
+ AB( 1, J+1 ) = WORK( N+J )*AB( 1, J+1 )
+ 160 CONTINUE
+ IF( UPDATE ) THEN
+ IF( I-K.LT.N-KA .AND. K.LE.KBT )
+ $ WORK( I-K+KA ) = WORK( I-K )
+ END IF
+ 170 CONTINUE
+*
+ DO 210 K = KB, 1, -1
+ J2 = I - K - 1 + MAX( 1, K-I0+1 )*KA1
+ NR = ( N-J2+KA ) / KA1
+ J1 = J2 + ( NR-1 )*KA1
+ IF( NR.GT.0 ) THEN
+*
+* generate rotations in 2nd set to annihilate elements
+* which have been created outside the band
+*
+ CALL DLARGV( NR, AB( 1, J2 ), INCA, WORK( J2 ), KA1,
+ $ WORK( N+J2 ), KA1 )
+*
+* apply rotations in 2nd set from the right
+*
+ DO 180 L = 1, KA - 1
+ CALL DLARTV( NR, AB( KA1-L, J2 ), INCA,
+ $ AB( KA-L, J2+1 ), INCA, WORK( N+J2 ),
+ $ WORK( J2 ), KA1 )
+ 180 CONTINUE
+*
+* apply rotations in 2nd set from both sides to diagonal
+* blocks
+*
+ CALL DLAR2V( NR, AB( KA1, J2 ), AB( KA1, J2+1 ),
+ $ AB( KA, J2+1 ), INCA, WORK( N+J2 ),
+ $ WORK( J2 ), KA1 )
+*
+ END IF
+*
+* start applying rotations in 2nd set from the left
+*
+ DO 190 L = KA - 1, KB - K + 1, -1
+ NRT = ( N-J2+L ) / KA1
+ IF( NRT.GT.0 )
+ $ CALL DLARTV( NRT, AB( L, J2+KA1-L ), INCA,
+ $ AB( L+1, J2+KA1-L ), INCA, WORK( N+J2 ),
+ $ WORK( J2 ), KA1 )
+ 190 CONTINUE
+*
+ IF( WANTX ) THEN
+*
+* post-multiply X by product of rotations in 2nd set
+*
+ DO 200 J = J2, J1, KA1
+ CALL DROT( N-M, X( M+1, J ), 1, X( M+1, J+1 ), 1,
+ $ WORK( N+J ), WORK( J ) )
+ 200 CONTINUE
+ END IF
+ 210 CONTINUE
+*
+ DO 230 K = 1, KB - 1
+ J2 = I - K - 1 + MAX( 1, K-I0+2 )*KA1
+*
+* finish applying rotations in 1st set from the left
+*
+ DO 220 L = KB - K, 1, -1
+ NRT = ( N-J2+L ) / KA1
+ IF( NRT.GT.0 )
+ $ CALL DLARTV( NRT, AB( L, J2+KA1-L ), INCA,
+ $ AB( L+1, J2+KA1-L ), INCA,
+ $ WORK( N+J2-M ), WORK( J2-M ), KA1 )
+ 220 CONTINUE
+ 230 CONTINUE
+*
+ IF( KB.GT.1 ) THEN
+ DO 240 J = N - 1, I - KB + 2*KA + 1, -1
+ WORK( N+J-M ) = WORK( N+J-KA-M )
+ WORK( J-M ) = WORK( J-KA-M )
+ 240 CONTINUE
+ END IF
+*
+ ELSE
+*
+* Transform A, working with the lower triangle
+*
+ IF( UPDATE ) THEN
+*
+* Form inv(S(i))**T * A * inv(S(i))
+*
+ BII = BB( 1, I )
+ DO 250 J = I, I1
+ AB( J-I+1, I ) = AB( J-I+1, I ) / BII
+ 250 CONTINUE
+ DO 260 J = MAX( 1, I-KA ), I
+ AB( I-J+1, J ) = AB( I-J+1, J ) / BII
+ 260 CONTINUE
+ DO 290 K = I - KBT, I - 1
+ DO 270 J = I - KBT, K
+ AB( K-J+1, J ) = AB( K-J+1, J ) -
+ $ BB( I-J+1, J )*AB( I-K+1, K ) -
+ $ BB( I-K+1, K )*AB( I-J+1, J ) +
+ $ AB( 1, I )*BB( I-J+1, J )*
+ $ BB( I-K+1, K )
+ 270 CONTINUE
+ DO 280 J = MAX( 1, I-KA ), I - KBT - 1
+ AB( K-J+1, J ) = AB( K-J+1, J ) -
+ $ BB( I-K+1, K )*AB( I-J+1, J )
+ 280 CONTINUE
+ 290 CONTINUE
+ DO 310 J = I, I1
+ DO 300 K = MAX( J-KA, I-KBT ), I - 1
+ AB( J-K+1, K ) = AB( J-K+1, K ) -
+ $ BB( I-K+1, K )*AB( J-I+1, I )
+ 300 CONTINUE
+ 310 CONTINUE
+*
+ IF( WANTX ) THEN
+*
+* post-multiply X by inv(S(i))
+*
+ CALL DSCAL( N-M, ONE / BII, X( M+1, I ), 1 )
+ IF( KBT.GT.0 )
+ $ CALL DGER( N-M, KBT, -ONE, X( M+1, I ), 1,
+ $ BB( KBT+1, I-KBT ), LDBB-1,
+ $ X( M+1, I-KBT ), LDX )
+ END IF
+*
+* store a(i1,i) in RA1 for use in next loop over K
+*
+ RA1 = AB( I1-I+1, I )
+ END IF
+*
+* Generate and apply vectors of rotations to chase all the
+* existing bulges KA positions down toward the bottom of the
+* band
+*
+ DO 360 K = 1, KB - 1
+ IF( UPDATE ) THEN
+*
+* Determine the rotations which would annihilate the bulge
+* which has in theory just been created
+*
+ IF( I-K+KA.LT.N .AND. I-K.GT.1 ) THEN
+*
+* generate rotation to annihilate a(i-k+ka+1,i)
+*
+ CALL DLARTG( AB( KA1-K, I ), RA1, WORK( N+I-K+KA-M ),
+ $ WORK( I-K+KA-M ), RA )
+*
+* create nonzero element a(i-k+ka+1,i-k) outside the
+* band and store it in WORK(i-k)
+*
+ T = -BB( K+1, I-K )*RA1
+ WORK( I-K ) = WORK( N+I-K+KA-M )*T -
+ $ WORK( I-K+KA-M )*AB( KA1, I-K )
+ AB( KA1, I-K ) = WORK( I-K+KA-M )*T +
+ $ WORK( N+I-K+KA-M )*AB( KA1, I-K )
+ RA1 = RA
+ END IF
+ END IF
+ J2 = I - K - 1 + MAX( 1, K-I0+2 )*KA1
+ NR = ( N-J2+KA ) / KA1
+ J1 = J2 + ( NR-1 )*KA1
+ IF( UPDATE ) THEN
+ J2T = MAX( J2, I+2*KA-K+1 )
+ ELSE
+ J2T = J2
+ END IF
+ NRT = ( N-J2T+KA ) / KA1
+ DO 320 J = J2T, J1, KA1
+*
+* create nonzero element a(j+1,j-ka) outside the band
+* and store it in WORK(j-m)
+*
+ WORK( J-M ) = WORK( J-M )*AB( KA1, J-KA+1 )
+ AB( KA1, J-KA+1 ) = WORK( N+J-M )*AB( KA1, J-KA+1 )
+ 320 CONTINUE
+*
+* generate rotations in 1st set to annihilate elements which
+* have been created outside the band
+*
+ IF( NRT.GT.0 )
+ $ CALL DLARGV( NRT, AB( KA1, J2T-KA ), INCA, WORK( J2T-M ),
+ $ KA1, WORK( N+J2T-M ), KA1 )
+ IF( NR.GT.0 ) THEN
+*
+* apply rotations in 1st set from the left
+*
+ DO 330 L = 1, KA - 1
+ CALL DLARTV( NR, AB( L+1, J2-L ), INCA,
+ $ AB( L+2, J2-L ), INCA, WORK( N+J2-M ),
+ $ WORK( J2-M ), KA1 )
+ 330 CONTINUE
+*
+* apply rotations in 1st set from both sides to diagonal
+* blocks
+*
+ CALL DLAR2V( NR, AB( 1, J2 ), AB( 1, J2+1 ), AB( 2, J2 ),
+ $ INCA, WORK( N+J2-M ), WORK( J2-M ), KA1 )
+*
+ END IF
+*
+* start applying rotations in 1st set from the right
+*
+ DO 340 L = KA - 1, KB - K + 1, -1
+ NRT = ( N-J2+L ) / KA1
+ IF( NRT.GT.0 )
+ $ CALL DLARTV( NRT, AB( KA1-L+1, J2 ), INCA,
+ $ AB( KA1-L, J2+1 ), INCA, WORK( N+J2-M ),
+ $ WORK( J2-M ), KA1 )
+ 340 CONTINUE
+*
+ IF( WANTX ) THEN
+*
+* post-multiply X by product of rotations in 1st set
+*
+ DO 350 J = J2, J1, KA1
+ CALL DROT( N-M, X( M+1, J ), 1, X( M+1, J+1 ), 1,
+ $ WORK( N+J-M ), WORK( J-M ) )
+ 350 CONTINUE
+ END IF
+ 360 CONTINUE
+*
+ IF( UPDATE ) THEN
+ IF( I2.LE.N .AND. KBT.GT.0 ) THEN
+*
+* create nonzero element a(i-kbt+ka+1,i-kbt) outside the
+* band and store it in WORK(i-kbt)
+*
+ WORK( I-KBT ) = -BB( KBT+1, I-KBT )*RA1
+ END IF
+ END IF
+*
+ DO 400 K = KB, 1, -1
+ IF( UPDATE ) THEN
+ J2 = I - K - 1 + MAX( 2, K-I0+1 )*KA1
+ ELSE
+ J2 = I - K - 1 + MAX( 1, K-I0+1 )*KA1
+ END IF
+*
+* finish applying rotations in 2nd set from the right
+*
+ DO 370 L = KB - K, 1, -1
+ NRT = ( N-J2+KA+L ) / KA1
+ IF( NRT.GT.0 )
+ $ CALL DLARTV( NRT, AB( KA1-L+1, J2-KA ), INCA,
+ $ AB( KA1-L, J2-KA+1 ), INCA,
+ $ WORK( N+J2-KA ), WORK( J2-KA ), KA1 )
+ 370 CONTINUE
+ NR = ( N-J2+KA ) / KA1
+ J1 = J2 + ( NR-1 )*KA1
+ DO 380 J = J1, J2, -KA1
+ WORK( J ) = WORK( J-KA )
+ WORK( N+J ) = WORK( N+J-KA )
+ 380 CONTINUE
+ DO 390 J = J2, J1, KA1
+*
+* create nonzero element a(j+1,j-ka) outside the band
+* and store it in WORK(j)
+*
+ WORK( J ) = WORK( J )*AB( KA1, J-KA+1 )
+ AB( KA1, J-KA+1 ) = WORK( N+J )*AB( KA1, J-KA+1 )
+ 390 CONTINUE
+ IF( UPDATE ) THEN
+ IF( I-K.LT.N-KA .AND. K.LE.KBT )
+ $ WORK( I-K+KA ) = WORK( I-K )
+ END IF
+ 400 CONTINUE
+*
+ DO 440 K = KB, 1, -1
+ J2 = I - K - 1 + MAX( 1, K-I0+1 )*KA1
+ NR = ( N-J2+KA ) / KA1
+ J1 = J2 + ( NR-1 )*KA1
+ IF( NR.GT.0 ) THEN
+*
+* generate rotations in 2nd set to annihilate elements
+* which have been created outside the band
+*
+ CALL DLARGV( NR, AB( KA1, J2-KA ), INCA, WORK( J2 ), KA1,
+ $ WORK( N+J2 ), KA1 )
+*
+* apply rotations in 2nd set from the left
+*
+ DO 410 L = 1, KA - 1
+ CALL DLARTV( NR, AB( L+1, J2-L ), INCA,
+ $ AB( L+2, J2-L ), INCA, WORK( N+J2 ),
+ $ WORK( J2 ), KA1 )
+ 410 CONTINUE
+*
+* apply rotations in 2nd set from both sides to diagonal
+* blocks
+*
+ CALL DLAR2V( NR, AB( 1, J2 ), AB( 1, J2+1 ), AB( 2, J2 ),
+ $ INCA, WORK( N+J2 ), WORK( J2 ), KA1 )
+*
+ END IF
+*
+* start applying rotations in 2nd set from the right
+*
+ DO 420 L = KA - 1, KB - K + 1, -1
+ NRT = ( N-J2+L ) / KA1
+ IF( NRT.GT.0 )
+ $ CALL DLARTV( NRT, AB( KA1-L+1, J2 ), INCA,
+ $ AB( KA1-L, J2+1 ), INCA, WORK( N+J2 ),
+ $ WORK( J2 ), KA1 )
+ 420 CONTINUE
+*
+ IF( WANTX ) THEN
+*
+* post-multiply X by product of rotations in 2nd set
+*
+ DO 430 J = J2, J1, KA1
+ CALL DROT( N-M, X( M+1, J ), 1, X( M+1, J+1 ), 1,
+ $ WORK( N+J ), WORK( J ) )
+ 430 CONTINUE
+ END IF
+ 440 CONTINUE
+*
+ DO 460 K = 1, KB - 1
+ J2 = I - K - 1 + MAX( 1, K-I0+2 )*KA1
+*
+* finish applying rotations in 1st set from the right
+*
+ DO 450 L = KB - K, 1, -1
+ NRT = ( N-J2+L ) / KA1
+ IF( NRT.GT.0 )
+ $ CALL DLARTV( NRT, AB( KA1-L+1, J2 ), INCA,
+ $ AB( KA1-L, J2+1 ), INCA, WORK( N+J2-M ),
+ $ WORK( J2-M ), KA1 )
+ 450 CONTINUE
+ 460 CONTINUE
+*
+ IF( KB.GT.1 ) THEN
+ DO 470 J = N - 1, I - KB + 2*KA + 1, -1
+ WORK( N+J-M ) = WORK( N+J-KA-M )
+ WORK( J-M ) = WORK( J-KA-M )
+ 470 CONTINUE
+ END IF
+*
+ END IF
+*
+ GO TO 10
+*
+ 480 CONTINUE
+*
+* **************************** Phase 2 *****************************
+*
+* The logical structure of this phase is:
+*
+* UPDATE = .TRUE.
+* DO I = 1, M
+* use S(i) to update A and create a new bulge
+* apply rotations to push all bulges KA positions upward
+* END DO
+* UPDATE = .FALSE.
+* DO I = M - KA - 1, 2, -1
+* apply rotations to push all bulges KA positions upward
+* END DO
+*
+* To avoid duplicating code, the two loops are merged.
+*
+ UPDATE = .TRUE.
+ I = 0
+ 490 CONTINUE
+ IF( UPDATE ) THEN
+ I = I + 1
+ KBT = MIN( KB, M-I )
+ I0 = I + 1
+ I1 = MAX( 1, I-KA )
+ I2 = I + KBT - KA1
+ IF( I.GT.M ) THEN
+ UPDATE = .FALSE.
+ I = I - 1
+ I0 = M + 1
+ IF( KA.EQ.0 )
+ $ RETURN
+ GO TO 490
+ END IF
+ ELSE
+ I = I - KA
+ IF( I.LT.2 )
+ $ RETURN
+ END IF
+*
+ IF( I.LT.M-KBT ) THEN
+ NX = M
+ ELSE
+ NX = N
+ END IF
+*
+ IF( UPPER ) THEN
+*
+* Transform A, working with the upper triangle
+*
+ IF( UPDATE ) THEN
+*
+* Form inv(S(i))**T * A * inv(S(i))
+*
+ BII = BB( KB1, I )
+ DO 500 J = I1, I
+ AB( J-I+KA1, I ) = AB( J-I+KA1, I ) / BII
+ 500 CONTINUE
+ DO 510 J = I, MIN( N, I+KA )
+ AB( I-J+KA1, J ) = AB( I-J+KA1, J ) / BII
+ 510 CONTINUE
+ DO 540 K = I + 1, I + KBT
+ DO 520 J = K, I + KBT
+ AB( K-J+KA1, J ) = AB( K-J+KA1, J ) -
+ $ BB( I-J+KB1, J )*AB( I-K+KA1, K ) -
+ $ BB( I-K+KB1, K )*AB( I-J+KA1, J ) +
+ $ AB( KA1, I )*BB( I-J+KB1, J )*
+ $ BB( I-K+KB1, K )
+ 520 CONTINUE
+ DO 530 J = I + KBT + 1, MIN( N, I+KA )
+ AB( K-J+KA1, J ) = AB( K-J+KA1, J ) -
+ $ BB( I-K+KB1, K )*AB( I-J+KA1, J )
+ 530 CONTINUE
+ 540 CONTINUE
+ DO 560 J = I1, I
+ DO 550 K = I + 1, MIN( J+KA, I+KBT )
+ AB( J-K+KA1, K ) = AB( J-K+KA1, K ) -
+ $ BB( I-K+KB1, K )*AB( J-I+KA1, I )
+ 550 CONTINUE
+ 560 CONTINUE
+*
+ IF( WANTX ) THEN
+*
+* post-multiply X by inv(S(i))
+*
+ CALL DSCAL( NX, ONE / BII, X( 1, I ), 1 )
+ IF( KBT.GT.0 )
+ $ CALL DGER( NX, KBT, -ONE, X( 1, I ), 1, BB( KB, I+1 ),
+ $ LDBB-1, X( 1, I+1 ), LDX )
+ END IF
+*
+* store a(i1,i) in RA1 for use in next loop over K
+*
+ RA1 = AB( I1-I+KA1, I )
+ END IF
+*
+* Generate and apply vectors of rotations to chase all the
+* existing bulges KA positions up toward the top of the band
+*
+ DO 610 K = 1, KB - 1
+ IF( UPDATE ) THEN
+*
+* Determine the rotations which would annihilate the bulge
+* which has in theory just been created
+*
+ IF( I+K-KA1.GT.0 .AND. I+K.LT.M ) THEN
+*
+* generate rotation to annihilate a(i+k-ka-1,i)
+*
+ CALL DLARTG( AB( K+1, I ), RA1, WORK( N+I+K-KA ),
+ $ WORK( I+K-KA ), RA )
+*
+* create nonzero element a(i+k-ka-1,i+k) outside the
+* band and store it in WORK(m-kb+i+k)
+*
+ T = -BB( KB1-K, I+K )*RA1
+ WORK( M-KB+I+K ) = WORK( N+I+K-KA )*T -
+ $ WORK( I+K-KA )*AB( 1, I+K )
+ AB( 1, I+K ) = WORK( I+K-KA )*T +
+ $ WORK( N+I+K-KA )*AB( 1, I+K )
+ RA1 = RA
+ END IF
+ END IF
+ J2 = I + K + 1 - MAX( 1, K+I0-M+1 )*KA1
+ NR = ( J2+KA-1 ) / KA1
+ J1 = J2 - ( NR-1 )*KA1
+ IF( UPDATE ) THEN
+ J2T = MIN( J2, I-2*KA+K-1 )
+ ELSE
+ J2T = J2
+ END IF
+ NRT = ( J2T+KA-1 ) / KA1
+ DO 570 J = J1, J2T, KA1
+*
+* create nonzero element a(j-1,j+ka) outside the band
+* and store it in WORK(j)
+*
+ WORK( J ) = WORK( J )*AB( 1, J+KA-1 )
+ AB( 1, J+KA-1 ) = WORK( N+J )*AB( 1, J+KA-1 )
+ 570 CONTINUE
+*
+* generate rotations in 1st set to annihilate elements which
+* have been created outside the band
+*
+ IF( NRT.GT.0 )
+ $ CALL DLARGV( NRT, AB( 1, J1+KA ), INCA, WORK( J1 ), KA1,
+ $ WORK( N+J1 ), KA1 )
+ IF( NR.GT.0 ) THEN
+*
+* apply rotations in 1st set from the left
+*
+ DO 580 L = 1, KA - 1
+ CALL DLARTV( NR, AB( KA1-L, J1+L ), INCA,
+ $ AB( KA-L, J1+L ), INCA, WORK( N+J1 ),
+ $ WORK( J1 ), KA1 )
+ 580 CONTINUE
+*
+* apply rotations in 1st set from both sides to diagonal
+* blocks
+*
+ CALL DLAR2V( NR, AB( KA1, J1 ), AB( KA1, J1-1 ),
+ $ AB( KA, J1 ), INCA, WORK( N+J1 ),
+ $ WORK( J1 ), KA1 )
+*
+ END IF
+*
+* start applying rotations in 1st set from the right
+*
+ DO 590 L = KA - 1, KB - K + 1, -1
+ NRT = ( J2+L-1 ) / KA1
+ J1T = J2 - ( NRT-1 )*KA1
+ IF( NRT.GT.0 )
+ $ CALL DLARTV( NRT, AB( L, J1T ), INCA,
+ $ AB( L+1, J1T-1 ), INCA, WORK( N+J1T ),
+ $ WORK( J1T ), KA1 )
+ 590 CONTINUE
+*
+ IF( WANTX ) THEN
+*
+* post-multiply X by product of rotations in 1st set
+*
+ DO 600 J = J1, J2, KA1
+ CALL DROT( NX, X( 1, J ), 1, X( 1, J-1 ), 1,
+ $ WORK( N+J ), WORK( J ) )
+ 600 CONTINUE
+ END IF
+ 610 CONTINUE
+*
+ IF( UPDATE ) THEN
+ IF( I2.GT.0 .AND. KBT.GT.0 ) THEN
+*
+* create nonzero element a(i+kbt-ka-1,i+kbt) outside the
+* band and store it in WORK(m-kb+i+kbt)
+*
+ WORK( M-KB+I+KBT ) = -BB( KB1-KBT, I+KBT )*RA1
+ END IF
+ END IF
+*
+ DO 650 K = KB, 1, -1
+ IF( UPDATE ) THEN
+ J2 = I + K + 1 - MAX( 2, K+I0-M )*KA1
+ ELSE
+ J2 = I + K + 1 - MAX( 1, K+I0-M )*KA1
+ END IF
+*
+* finish applying rotations in 2nd set from the right
+*
+ DO 620 L = KB - K, 1, -1
+ NRT = ( J2+KA+L-1 ) / KA1
+ J1T = J2 - ( NRT-1 )*KA1
+ IF( NRT.GT.0 )
+ $ CALL DLARTV( NRT, AB( L, J1T+KA ), INCA,
+ $ AB( L+1, J1T+KA-1 ), INCA,
+ $ WORK( N+M-KB+J1T+KA ),
+ $ WORK( M-KB+J1T+KA ), KA1 )
+ 620 CONTINUE
+ NR = ( J2+KA-1 ) / KA1
+ J1 = J2 - ( NR-1 )*KA1
+ DO 630 J = J1, J2, KA1
+ WORK( M-KB+J ) = WORK( M-KB+J+KA )
+ WORK( N+M-KB+J ) = WORK( N+M-KB+J+KA )
+ 630 CONTINUE
+ DO 640 J = J1, J2, KA1
+*
+* create nonzero element a(j-1,j+ka) outside the band
+* and store it in WORK(m-kb+j)
+*
+ WORK( M-KB+J ) = WORK( M-KB+J )*AB( 1, J+KA-1 )
+ AB( 1, J+KA-1 ) = WORK( N+M-KB+J )*AB( 1, J+KA-1 )
+ 640 CONTINUE
+ IF( UPDATE ) THEN
+ IF( I+K.GT.KA1 .AND. K.LE.KBT )
+ $ WORK( M-KB+I+K-KA ) = WORK( M-KB+I+K )
+ END IF
+ 650 CONTINUE
+*
+ DO 690 K = KB, 1, -1
+ J2 = I + K + 1 - MAX( 1, K+I0-M )*KA1
+ NR = ( J2+KA-1 ) / KA1
+ J1 = J2 - ( NR-1 )*KA1
+ IF( NR.GT.0 ) THEN
+*
+* generate rotations in 2nd set to annihilate elements
+* which have been created outside the band
+*
+ CALL DLARGV( NR, AB( 1, J1+KA ), INCA, WORK( M-KB+J1 ),
+ $ KA1, WORK( N+M-KB+J1 ), KA1 )
+*
+* apply rotations in 2nd set from the left
+*
+ DO 660 L = 1, KA - 1
+ CALL DLARTV( NR, AB( KA1-L, J1+L ), INCA,
+ $ AB( KA-L, J1+L ), INCA,
+ $ WORK( N+M-KB+J1 ), WORK( M-KB+J1 ), KA1 )
+ 660 CONTINUE
+*
+* apply rotations in 2nd set from both sides to diagonal
+* blocks
+*
+ CALL DLAR2V( NR, AB( KA1, J1 ), AB( KA1, J1-1 ),
+ $ AB( KA, J1 ), INCA, WORK( N+M-KB+J1 ),
+ $ WORK( M-KB+J1 ), KA1 )
+*
+ END IF
+*
+* start applying rotations in 2nd set from the right
+*
+ DO 670 L = KA - 1, KB - K + 1, -1
+ NRT = ( J2+L-1 ) / KA1
+ J1T = J2 - ( NRT-1 )*KA1
+ IF( NRT.GT.0 )
+ $ CALL DLARTV( NRT, AB( L, J1T ), INCA,
+ $ AB( L+1, J1T-1 ), INCA,
+ $ WORK( N+M-KB+J1T ), WORK( M-KB+J1T ),
+ $ KA1 )
+ 670 CONTINUE
+*
+ IF( WANTX ) THEN
+*
+* post-multiply X by product of rotations in 2nd set
+*
+ DO 680 J = J1, J2, KA1
+ CALL DROT( NX, X( 1, J ), 1, X( 1, J-1 ), 1,
+ $ WORK( N+M-KB+J ), WORK( M-KB+J ) )
+ 680 CONTINUE
+ END IF
+ 690 CONTINUE
+*
+ DO 710 K = 1, KB - 1
+ J2 = I + K + 1 - MAX( 1, K+I0-M+1 )*KA1
+*
+* finish applying rotations in 1st set from the right
+*
+ DO 700 L = KB - K, 1, -1
+ NRT = ( J2+L-1 ) / KA1
+ J1T = J2 - ( NRT-1 )*KA1
+ IF( NRT.GT.0 )
+ $ CALL DLARTV( NRT, AB( L, J1T ), INCA,
+ $ AB( L+1, J1T-1 ), INCA, WORK( N+J1T ),
+ $ WORK( J1T ), KA1 )
+ 700 CONTINUE
+ 710 CONTINUE
+*
+ IF( KB.GT.1 ) THEN
+ DO 720 J = 2, MIN( I+KB, M ) - 2*KA - 1
+ WORK( N+J ) = WORK( N+J+KA )
+ WORK( J ) = WORK( J+KA )
+ 720 CONTINUE
+ END IF
+*
+ ELSE
+*
+* Transform A, working with the lower triangle
+*
+ IF( UPDATE ) THEN
+*
+* Form inv(S(i))**T * A * inv(S(i))
+*
+ BII = BB( 1, I )
+ DO 730 J = I1, I
+ AB( I-J+1, J ) = AB( I-J+1, J ) / BII
+ 730 CONTINUE
+ DO 740 J = I, MIN( N, I+KA )
+ AB( J-I+1, I ) = AB( J-I+1, I ) / BII
+ 740 CONTINUE
+ DO 770 K = I + 1, I + KBT
+ DO 750 J = K, I + KBT
+ AB( J-K+1, K ) = AB( J-K+1, K ) -
+ $ BB( J-I+1, I )*AB( K-I+1, I ) -
+ $ BB( K-I+1, I )*AB( J-I+1, I ) +
+ $ AB( 1, I )*BB( J-I+1, I )*
+ $ BB( K-I+1, I )
+ 750 CONTINUE
+ DO 760 J = I + KBT + 1, MIN( N, I+KA )
+ AB( J-K+1, K ) = AB( J-K+1, K ) -
+ $ BB( K-I+1, I )*AB( J-I+1, I )
+ 760 CONTINUE
+ 770 CONTINUE
+ DO 790 J = I1, I
+ DO 780 K = I + 1, MIN( J+KA, I+KBT )
+ AB( K-J+1, J ) = AB( K-J+1, J ) -
+ $ BB( K-I+1, I )*AB( I-J+1, J )
+ 780 CONTINUE
+ 790 CONTINUE
+*
+ IF( WANTX ) THEN
+*
+* post-multiply X by inv(S(i))
+*
+ CALL DSCAL( NX, ONE / BII, X( 1, I ), 1 )
+ IF( KBT.GT.0 )
+ $ CALL DGER( NX, KBT, -ONE, X( 1, I ), 1, BB( 2, I ), 1,
+ $ X( 1, I+1 ), LDX )
+ END IF
+*
+* store a(i,i1) in RA1 for use in next loop over K
+*
+ RA1 = AB( I-I1+1, I1 )
+ END IF
+*
+* Generate and apply vectors of rotations to chase all the
+* existing bulges KA positions up toward the top of the band
+*
+ DO 840 K = 1, KB - 1
+ IF( UPDATE ) THEN
+*
+* Determine the rotations which would annihilate the bulge
+* which has in theory just been created
+*
+ IF( I+K-KA1.GT.0 .AND. I+K.LT.M ) THEN
+*
+* generate rotation to annihilate a(i,i+k-ka-1)
+*
+ CALL DLARTG( AB( KA1-K, I+K-KA ), RA1,
+ $ WORK( N+I+K-KA ), WORK( I+K-KA ), RA )
+*
+* create nonzero element a(i+k,i+k-ka-1) outside the
+* band and store it in WORK(m-kb+i+k)
+*
+ T = -BB( K+1, I )*RA1
+ WORK( M-KB+I+K ) = WORK( N+I+K-KA )*T -
+ $ WORK( I+K-KA )*AB( KA1, I+K-KA )
+ AB( KA1, I+K-KA ) = WORK( I+K-KA )*T +
+ $ WORK( N+I+K-KA )*AB( KA1, I+K-KA )
+ RA1 = RA
+ END IF
+ END IF
+ J2 = I + K + 1 - MAX( 1, K+I0-M+1 )*KA1
+ NR = ( J2+KA-1 ) / KA1
+ J1 = J2 - ( NR-1 )*KA1
+ IF( UPDATE ) THEN
+ J2T = MIN( J2, I-2*KA+K-1 )
+ ELSE
+ J2T = J2
+ END IF
+ NRT = ( J2T+KA-1 ) / KA1
+ DO 800 J = J1, J2T, KA1
+*
+* create nonzero element a(j+ka,j-1) outside the band
+* and store it in WORK(j)
+*
+ WORK( J ) = WORK( J )*AB( KA1, J-1 )
+ AB( KA1, J-1 ) = WORK( N+J )*AB( KA1, J-1 )
+ 800 CONTINUE
+*
+* generate rotations in 1st set to annihilate elements which
+* have been created outside the band
+*
+ IF( NRT.GT.0 )
+ $ CALL DLARGV( NRT, AB( KA1, J1 ), INCA, WORK( J1 ), KA1,
+ $ WORK( N+J1 ), KA1 )
+ IF( NR.GT.0 ) THEN
+*
+* apply rotations in 1st set from the right
+*
+ DO 810 L = 1, KA - 1
+ CALL DLARTV( NR, AB( L+1, J1 ), INCA, AB( L+2, J1-1 ),
+ $ INCA, WORK( N+J1 ), WORK( J1 ), KA1 )
+ 810 CONTINUE
+*
+* apply rotations in 1st set from both sides to diagonal
+* blocks
+*
+ CALL DLAR2V( NR, AB( 1, J1 ), AB( 1, J1-1 ),
+ $ AB( 2, J1-1 ), INCA, WORK( N+J1 ),
+ $ WORK( J1 ), KA1 )
+*
+ END IF
+*
+* start applying rotations in 1st set from the left
+*
+ DO 820 L = KA - 1, KB - K + 1, -1
+ NRT = ( J2+L-1 ) / KA1
+ J1T = J2 - ( NRT-1 )*KA1
+ IF( NRT.GT.0 )
+ $ CALL DLARTV( NRT, AB( KA1-L+1, J1T-KA1+L ), INCA,
+ $ AB( KA1-L, J1T-KA1+L ), INCA,
+ $ WORK( N+J1T ), WORK( J1T ), KA1 )
+ 820 CONTINUE
+*
+ IF( WANTX ) THEN
+*
+* post-multiply X by product of rotations in 1st set
+*
+ DO 830 J = J1, J2, KA1
+ CALL DROT( NX, X( 1, J ), 1, X( 1, J-1 ), 1,
+ $ WORK( N+J ), WORK( J ) )
+ 830 CONTINUE
+ END IF
+ 840 CONTINUE
+*
+ IF( UPDATE ) THEN
+ IF( I2.GT.0 .AND. KBT.GT.0 ) THEN
+*
+* create nonzero element a(i+kbt,i+kbt-ka-1) outside the
+* band and store it in WORK(m-kb+i+kbt)
+*
+ WORK( M-KB+I+KBT ) = -BB( KBT+1, I )*RA1
+ END IF
+ END IF
+*
+ DO 880 K = KB, 1, -1
+ IF( UPDATE ) THEN
+ J2 = I + K + 1 - MAX( 2, K+I0-M )*KA1
+ ELSE
+ J2 = I + K + 1 - MAX( 1, K+I0-M )*KA1
+ END IF
+*
+* finish applying rotations in 2nd set from the left
+*
+ DO 850 L = KB - K, 1, -1
+ NRT = ( J2+KA+L-1 ) / KA1
+ J1T = J2 - ( NRT-1 )*KA1
+ IF( NRT.GT.0 )
+ $ CALL DLARTV( NRT, AB( KA1-L+1, J1T+L-1 ), INCA,
+ $ AB( KA1-L, J1T+L-1 ), INCA,
+ $ WORK( N+M-KB+J1T+KA ),
+ $ WORK( M-KB+J1T+KA ), KA1 )
+ 850 CONTINUE
+ NR = ( J2+KA-1 ) / KA1
+ J1 = J2 - ( NR-1 )*KA1
+ DO 860 J = J1, J2, KA1
+ WORK( M-KB+J ) = WORK( M-KB+J+KA )
+ WORK( N+M-KB+J ) = WORK( N+M-KB+J+KA )
+ 860 CONTINUE
+ DO 870 J = J1, J2, KA1
+*
+* create nonzero element a(j+ka,j-1) outside the band
+* and store it in WORK(m-kb+j)
+*
+ WORK( M-KB+J ) = WORK( M-KB+J )*AB( KA1, J-1 )
+ AB( KA1, J-1 ) = WORK( N+M-KB+J )*AB( KA1, J-1 )
+ 870 CONTINUE
+ IF( UPDATE ) THEN
+ IF( I+K.GT.KA1 .AND. K.LE.KBT )
+ $ WORK( M-KB+I+K-KA ) = WORK( M-KB+I+K )
+ END IF
+ 880 CONTINUE
+*
+ DO 920 K = KB, 1, -1
+ J2 = I + K + 1 - MAX( 1, K+I0-M )*KA1
+ NR = ( J2+KA-1 ) / KA1
+ J1 = J2 - ( NR-1 )*KA1
+ IF( NR.GT.0 ) THEN
+*
+* generate rotations in 2nd set to annihilate elements
+* which have been created outside the band
+*
+ CALL DLARGV( NR, AB( KA1, J1 ), INCA, WORK( M-KB+J1 ),
+ $ KA1, WORK( N+M-KB+J1 ), KA1 )
+*
+* apply rotations in 2nd set from the right
+*
+ DO 890 L = 1, KA - 1
+ CALL DLARTV( NR, AB( L+1, J1 ), INCA, AB( L+2, J1-1 ),
+ $ INCA, WORK( N+M-KB+J1 ), WORK( M-KB+J1 ),
+ $ KA1 )
+ 890 CONTINUE
+*
+* apply rotations in 2nd set from both sides to diagonal
+* blocks
+*
+ CALL DLAR2V( NR, AB( 1, J1 ), AB( 1, J1-1 ),
+ $ AB( 2, J1-1 ), INCA, WORK( N+M-KB+J1 ),
+ $ WORK( M-KB+J1 ), KA1 )
+*
+ END IF
+*
+* start applying rotations in 2nd set from the left
+*
+ DO 900 L = KA - 1, KB - K + 1, -1
+ NRT = ( J2+L-1 ) / KA1
+ J1T = J2 - ( NRT-1 )*KA1
+ IF( NRT.GT.0 )
+ $ CALL DLARTV( NRT, AB( KA1-L+1, J1T-KA1+L ), INCA,
+ $ AB( KA1-L, J1T-KA1+L ), INCA,
+ $ WORK( N+M-KB+J1T ), WORK( M-KB+J1T ),
+ $ KA1 )
+ 900 CONTINUE
+*
+ IF( WANTX ) THEN
+*
+* post-multiply X by product of rotations in 2nd set
+*
+ DO 910 J = J1, J2, KA1
+ CALL DROT( NX, X( 1, J ), 1, X( 1, J-1 ), 1,
+ $ WORK( N+M-KB+J ), WORK( M-KB+J ) )
+ 910 CONTINUE
+ END IF
+ 920 CONTINUE
+*
+ DO 940 K = 1, KB - 1
+ J2 = I + K + 1 - MAX( 1, K+I0-M+1 )*KA1
+*
+* finish applying rotations in 1st set from the left
+*
+ DO 930 L = KB - K, 1, -1
+ NRT = ( J2+L-1 ) / KA1
+ J1T = J2 - ( NRT-1 )*KA1
+ IF( NRT.GT.0 )
+ $ CALL DLARTV( NRT, AB( KA1-L+1, J1T-KA1+L ), INCA,
+ $ AB( KA1-L, J1T-KA1+L ), INCA,
+ $ WORK( N+J1T ), WORK( J1T ), KA1 )
+ 930 CONTINUE
+ 940 CONTINUE
+*
+ IF( KB.GT.1 ) THEN
+ DO 950 J = 2, MIN( I+KB, M ) - 2*KA - 1
+ WORK( N+J ) = WORK( N+J+KA )
+ WORK( J ) = WORK( J+KA )
+ 950 CONTINUE
+ END IF
+*
+ END IF
+*
+ GO TO 490
+*
+* End of DSBGST
+*
+ END
+ SUBROUTINE DSBGV( JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, W, Z,
+ $ LDZ, WORK, INFO )
+*
+* -- LAPACK driver routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER JOBZ, UPLO
+ INTEGER INFO, KA, KB, LDAB, LDBB, LDZ, N
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION AB( LDAB, * ), BB( LDBB, * ), W( * ),
+ $ WORK( * ), Z( LDZ, * )
+* ..
+*
+* Purpose
+* =======
+*
+* DSBGV computes all the eigenvalues, and optionally, the eigenvectors
+* of a real generalized symmetric-definite banded eigenproblem, of
+* the form A*x=(lambda)*B*x. Here A and B are assumed to be symmetric
+* and banded, and B is also positive definite.
+*
+* Arguments
+* =========
+*
+* JOBZ (input) CHARACTER*1
+* = 'N': Compute eigenvalues only;
+* = 'V': Compute eigenvalues and eigenvectors.
+*
+* UPLO (input) CHARACTER*1
+* = 'U': Upper triangles of A and B are stored;
+* = 'L': Lower triangles of A and B are stored.
+*
+* N (input) INTEGER
+* The order of the matrices A and B. N >= 0.
+*
+* KA (input) INTEGER
+* The number of superdiagonals of the matrix A if UPLO = 'U',
+* or the number of subdiagonals if UPLO = 'L'. KA >= 0.
+*
+* KB (input) INTEGER
+* The number of superdiagonals of the matrix B if UPLO = 'U',
+* or the number of subdiagonals if UPLO = 'L'. KB >= 0.
+*
+* AB (input/output) DOUBLE PRECISION array, dimension (LDAB, N)
+* On entry, the upper or lower triangle of the symmetric band
+* matrix A, stored in the first ka+1 rows of the array. The
+* j-th column of A is stored in the j-th column of the array AB
+* as follows:
+* if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j;
+* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+ka).
+*
+* On exit, the contents of AB are destroyed.
+*
+* LDAB (input) INTEGER
+* The leading dimension of the array AB. LDAB >= KA+1.
+*
+* BB (input/output) DOUBLE PRECISION array, dimension (LDBB, N)
+* On entry, the upper or lower triangle of the symmetric band
+* matrix B, stored in the first kb+1 rows of the array. The
+* j-th column of B is stored in the j-th column of the array BB
+* as follows:
+* if UPLO = 'U', BB(kb+1+i-j,j) = B(i,j) for max(1,j-kb)<=i<=j;
+* if UPLO = 'L', BB(1+i-j,j) = B(i,j) for j<=i<=min(n,j+kb).
+*
+* On exit, the factor S from the split Cholesky factorization
+* B = S**T*S, as returned by DPBSTF.
+*
+* LDBB (input) INTEGER
+* The leading dimension of the array BB. LDBB >= KB+1.
+*
+* W (output) DOUBLE PRECISION array, dimension (N)
+* If INFO = 0, the eigenvalues in ascending order.
+*
+* Z (output) DOUBLE PRECISION array, dimension (LDZ, N)
+* If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of
+* eigenvectors, with the i-th column of Z holding the
+* eigenvector associated with W(i). The eigenvectors are
+* normalized so that Z**T*B*Z = I.
+* If JOBZ = 'N', then Z is not referenced.
+*
+* LDZ (input) INTEGER
+* The leading dimension of the array Z. LDZ >= 1, and if
+* JOBZ = 'V', LDZ >= N.
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (3*N)
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* > 0: if INFO = i, and i is:
+* <= N: the algorithm failed to converge:
+* i off-diagonal elements of an intermediate
+* tridiagonal form did not converge to zero;
+* > N: if INFO = N + i, for 1 <= i <= N, then DPBSTF
+* returned INFO = i: B is not positive definite.
+* The factorization of B could not be completed and
+* no eigenvalues or eigenvectors were computed.
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ LOGICAL UPPER, WANTZ
+ CHARACTER VECT
+ INTEGER IINFO, INDE, INDWRK
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL DPBSTF, DSBGST, DSBTRD, DSTEQR, DSTERF, XERBLA
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ WANTZ = LSAME( JOBZ, 'V' )
+ UPPER = LSAME( UPLO, 'U' )
+*
+ INFO = 0
+ IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
+ INFO = -1
+ ELSE IF( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN
+ INFO = -2
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( KA.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( KB.LT.0 .OR. KB.GT.KA ) THEN
+ INFO = -5
+ ELSE IF( LDAB.LT.KA+1 ) THEN
+ INFO = -7
+ ELSE IF( LDBB.LT.KB+1 ) THEN
+ INFO = -9
+ ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
+ INFO = -12
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DSBGV ', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+* Form a split Cholesky factorization of B.
+*
+ CALL DPBSTF( UPLO, N, KB, BB, LDBB, INFO )
+ IF( INFO.NE.0 ) THEN
+ INFO = N + INFO
+ RETURN
+ END IF
+*
+* Transform problem to standard eigenvalue problem.
+*
+ INDE = 1
+ INDWRK = INDE + N
+ CALL DSBGST( JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, Z, LDZ,
+ $ WORK( INDWRK ), IINFO )
+*
+* Reduce to tridiagonal form.
+*
+ IF( WANTZ ) THEN
+ VECT = 'U'
+ ELSE
+ VECT = 'N'
+ END IF
+ CALL DSBTRD( VECT, UPLO, N, KA, AB, LDAB, W, WORK( INDE ), Z, LDZ,
+ $ WORK( INDWRK ), IINFO )
+*
+* For eigenvalues only, call DSTERF. For eigenvectors, call SSTEQR.
+*
+ IF( .NOT.WANTZ ) THEN
+ CALL DSTERF( N, W, WORK( INDE ), INFO )
+ ELSE
+ CALL DSTEQR( JOBZ, N, W, WORK( INDE ), Z, LDZ, WORK( INDWRK ),
+ $ INFO )
+ END IF
+ RETURN
+*
+* End of DSBGV
+*
+ END
+ SUBROUTINE DSBGVD( JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, W,
+ $ Z, LDZ, WORK, LWORK, IWORK, LIWORK, INFO )
+*
+* -- LAPACK driver routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER JOBZ, UPLO
+ INTEGER INFO, KA, KB, LDAB, LDBB, LDZ, LIWORK, LWORK, N
+* ..
+* .. Array Arguments ..
+ INTEGER IWORK( * )
+ DOUBLE PRECISION AB( LDAB, * ), BB( LDBB, * ), W( * ),
+ $ WORK( * ), Z( LDZ, * )
+* ..
+*
+* Purpose
+* =======
+*
+* DSBGVD computes all the eigenvalues, and optionally, the eigenvectors
+* of a real generalized symmetric-definite banded eigenproblem, of the
+* form A*x=(lambda)*B*x. Here A and B are assumed to be symmetric and
+* banded, and B is also positive definite. If eigenvectors are
+* desired, it uses a divide and conquer algorithm.
+*
+* The divide and conquer algorithm makes very mild assumptions about
+* floating point arithmetic. It will work on machines with a guard
+* digit in add/subtract, or on those binary machines without guard
+* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
+* Cray-2. It could conceivably fail on hexadecimal or decimal machines
+* without guard digits, but we know of none.
+*
+* Arguments
+* =========
+*
+* JOBZ (input) CHARACTER*1
+* = 'N': Compute eigenvalues only;
+* = 'V': Compute eigenvalues and eigenvectors.
+*
+* UPLO (input) CHARACTER*1
+* = 'U': Upper triangles of A and B are stored;
+* = 'L': Lower triangles of A and B are stored.
+*
+* N (input) INTEGER
+* The order of the matrices A and B. N >= 0.
+*
+* KA (input) INTEGER
+* The number of superdiagonals of the matrix A if UPLO = 'U',
+* or the number of subdiagonals if UPLO = 'L'. KA >= 0.
+*
+* KB (input) INTEGER
+* The number of superdiagonals of the matrix B if UPLO = 'U',
+* or the number of subdiagonals if UPLO = 'L'. KB >= 0.
+*
+* AB (input/output) DOUBLE PRECISION array, dimension (LDAB, N)
+* On entry, the upper or lower triangle of the symmetric band
+* matrix A, stored in the first ka+1 rows of the array. The
+* j-th column of A is stored in the j-th column of the array AB
+* as follows:
+* if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j;
+* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+ka).
+*
+* On exit, the contents of AB are destroyed.
+*
+* LDAB (input) INTEGER
+* The leading dimension of the array AB. LDAB >= KA+1.
+*
+* BB (input/output) DOUBLE PRECISION array, dimension (LDBB, N)
+* On entry, the upper or lower triangle of the symmetric band
+* matrix B, stored in the first kb+1 rows of the array. The
+* j-th column of B is stored in the j-th column of the array BB
+* as follows:
+* if UPLO = 'U', BB(ka+1+i-j,j) = B(i,j) for max(1,j-kb)<=i<=j;
+* if UPLO = 'L', BB(1+i-j,j) = B(i,j) for j<=i<=min(n,j+kb).
+*
+* On exit, the factor S from the split Cholesky factorization
+* B = S**T*S, as returned by DPBSTF.
+*
+* LDBB (input) INTEGER
+* The leading dimension of the array BB. LDBB >= KB+1.
+*
+* W (output) DOUBLE PRECISION array, dimension (N)
+* If INFO = 0, the eigenvalues in ascending order.
+*
+* Z (output) DOUBLE PRECISION array, dimension (LDZ, N)
+* If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of
+* eigenvectors, with the i-th column of Z holding the
+* eigenvector associated with W(i). The eigenvectors are
+* normalized so Z**T*B*Z = I.
+* If JOBZ = 'N', then Z is not referenced.
+*
+* LDZ (input) INTEGER
+* The leading dimension of the array Z. LDZ >= 1, and if
+* JOBZ = 'V', LDZ >= max(1,N).
+*
+* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
+* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+* LWORK (input) INTEGER
+* The dimension of the array WORK.
+* If N <= 1, LWORK >= 1.
+* If JOBZ = 'N' and N > 1, LWORK >= 3*N.
+* If JOBZ = 'V' and N > 1, LWORK >= 1 + 5*N + 2*N**2.
+*
+* If LWORK = -1, then a workspace query is assumed; the routine
+* only calculates the optimal sizes of the WORK and IWORK
+* arrays, returns these values as the first entries of the WORK
+* and IWORK arrays, and no error message related to LWORK or
+* LIWORK is issued by XERBLA.
+*
+* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))
+* On exit, if LIWORK > 0, IWORK(1) returns the optimal LIWORK.
+*
+* LIWORK (input) INTEGER
+* The dimension of the array IWORK.
+* If JOBZ = 'N' or N <= 1, LIWORK >= 1.
+* If JOBZ = 'V' and N > 1, LIWORK >= 3 + 5*N.
+*
+* If LIWORK = -1, then a workspace query is assumed; the
+* routine only calculates the optimal sizes of the WORK and
+* IWORK arrays, returns these values as the first entries of
+* the WORK and IWORK arrays, and no error message related to
+* LWORK or LIWORK is issued by XERBLA.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* > 0: if INFO = i, and i is:
+* <= N: the algorithm failed to converge:
+* i off-diagonal elements of an intermediate
+* tridiagonal form did not converge to zero;
+* > N: if INFO = N + i, for 1 <= i <= N, then DPBSTF
+* returned INFO = i: B is not positive definite.
+* The factorization of B could not be completed and
+* no eigenvalues or eigenvectors were computed.
+*
+* Further Details
+* ===============
+*
+* Based on contributions by
+* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE, ZERO
+ PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL LQUERY, UPPER, WANTZ
+ CHARACTER VECT
+ INTEGER IINFO, INDE, INDWK2, INDWRK, LIWMIN, LLWRK2,
+ $ LWMIN
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL DGEMM, DLACPY, DPBSTF, DSBGST, DSBTRD, DSTEDC,
+ $ DSTERF, XERBLA
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ WANTZ = LSAME( JOBZ, 'V' )
+ UPPER = LSAME( UPLO, 'U' )
+ LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 )
+*
+ INFO = 0
+ IF( N.LE.1 ) THEN
+ LIWMIN = 1
+ LWMIN = 1
+ ELSE IF( WANTZ ) THEN
+ LIWMIN = 3 + 5*N
+ LWMIN = 1 + 5*N + 2*N**2
+ ELSE
+ LIWMIN = 1
+ LWMIN = 2*N
+ END IF
+*
+ IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
+ INFO = -1
+ ELSE IF( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN
+ INFO = -2
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( KA.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( KB.LT.0 .OR. KB.GT.KA ) THEN
+ INFO = -5
+ ELSE IF( LDAB.LT.KA+1 ) THEN
+ INFO = -7
+ ELSE IF( LDBB.LT.KB+1 ) THEN
+ INFO = -9
+ ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
+ INFO = -12
+ END IF
+*
+ IF( INFO.EQ.0 ) THEN
+ WORK( 1 ) = LWMIN
+ IWORK( 1 ) = LIWMIN
+*
+ IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
+ INFO = -14
+ ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN
+ INFO = -16
+ END IF
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DSBGVD', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+* Form a split Cholesky factorization of B.
+*
+ CALL DPBSTF( UPLO, N, KB, BB, LDBB, INFO )
+ IF( INFO.NE.0 ) THEN
+ INFO = N + INFO
+ RETURN
+ END IF
+*
+* Transform problem to standard eigenvalue problem.
+*
+ INDE = 1
+ INDWRK = INDE + N
+ INDWK2 = INDWRK + N*N
+ LLWRK2 = LWORK - INDWK2 + 1
+ CALL DSBGST( JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, Z, LDZ,
+ $ WORK( INDWRK ), IINFO )
+*
+* Reduce to tridiagonal form.
+*
+ IF( WANTZ ) THEN
+ VECT = 'U'
+ ELSE
+ VECT = 'N'
+ END IF
+ CALL DSBTRD( VECT, UPLO, N, KA, AB, LDAB, W, WORK( INDE ), Z, LDZ,
+ $ WORK( INDWRK ), IINFO )
+*
+* For eigenvalues only, call DSTERF. For eigenvectors, call SSTEDC.
+*
+ IF( .NOT.WANTZ ) THEN
+ CALL DSTERF( N, W, WORK( INDE ), INFO )
+ ELSE
+ CALL DSTEDC( 'I', N, W, WORK( INDE ), WORK( INDWRK ), N,
+ $ WORK( INDWK2 ), LLWRK2, IWORK, LIWORK, INFO )
+ CALL DGEMM( 'N', 'N', N, N, N, ONE, Z, LDZ, WORK( INDWRK ), N,
+ $ ZERO, WORK( INDWK2 ), N )
+ CALL DLACPY( 'A', N, N, WORK( INDWK2 ), N, Z, LDZ )
+ END IF
+*
+ WORK( 1 ) = LWMIN
+ IWORK( 1 ) = LIWMIN
+*
+ RETURN
+*
+* End of DSBGVD
+*
+ END
+ 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 )
+*
+* -- LAPACK driver routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER JOBZ, RANGE, UPLO
+ INTEGER IL, INFO, IU, KA, KB, LDAB, LDBB, LDQ, LDZ, M,
+ $ N
+ DOUBLE PRECISION ABSTOL, VL, VU
+* ..
+* .. Array Arguments ..
+ INTEGER IFAIL( * ), IWORK( * )
+ DOUBLE PRECISION AB( LDAB, * ), BB( LDBB, * ), Q( LDQ, * ),
+ $ W( * ), WORK( * ), Z( LDZ, * )
+* ..
+*
+* Purpose
+* =======
+*
+* DSBGVX computes selected eigenvalues, and optionally, eigenvectors
+* of a real generalized symmetric-definite banded eigenproblem, of
+* the form A*x=(lambda)*B*x. Here A and B are assumed to be symmetric
+* and banded, and B is also positive definite. Eigenvalues and
+* eigenvectors can be selected by specifying either all eigenvalues,
+* a range of values or a range of indices for the desired eigenvalues.
+*
+* Arguments
+* =========
+*
+* JOBZ (input) CHARACTER*1
+* = 'N': Compute eigenvalues only;
+* = 'V': Compute eigenvalues and eigenvectors.
+*
+* RANGE (input) CHARACTER*1
+* = 'A': all eigenvalues will be found.
+* = 'V': all eigenvalues in the half-open interval (VL,VU]
+* will be found.
+* = 'I': the IL-th through IU-th eigenvalues will be found.
+*
+* UPLO (input) CHARACTER*1
+* = 'U': Upper triangles of A and B are stored;
+* = 'L': Lower triangles of A and B are stored.
+*
+* N (input) INTEGER
+* The order of the matrices A and B. N >= 0.
+*
+* KA (input) INTEGER
+* The number of superdiagonals of the matrix A if UPLO = 'U',
+* or the number of subdiagonals if UPLO = 'L'. KA >= 0.
+*
+* KB (input) INTEGER
+* The number of superdiagonals of the matrix B if UPLO = 'U',
+* or the number of subdiagonals if UPLO = 'L'. KB >= 0.
+*
+* AB (input/output) DOUBLE PRECISION array, dimension (LDAB, N)
+* On entry, the upper or lower triangle of the symmetric band
+* matrix A, stored in the first ka+1 rows of the array. The
+* j-th column of A is stored in the j-th column of the array AB
+* as follows:
+* if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j;
+* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+ka).
+*
+* On exit, the contents of AB are destroyed.
+*
+* LDAB (input) INTEGER
+* The leading dimension of the array AB. LDAB >= KA+1.
+*
+* BB (input/output) DOUBLE PRECISION array, dimension (LDBB, N)
+* On entry, the upper or lower triangle of the symmetric band
+* matrix B, stored in the first kb+1 rows of the array. The
+* j-th column of B is stored in the j-th column of the array BB
+* as follows:
+* if UPLO = 'U', BB(ka+1+i-j,j) = B(i,j) for max(1,j-kb)<=i<=j;
+* if UPLO = 'L', BB(1+i-j,j) = B(i,j) for j<=i<=min(n,j+kb).
+*
+* On exit, the factor S from the split Cholesky factorization
+* B = S**T*S, as returned by DPBSTF.
+*
+* LDBB (input) INTEGER
+* The leading dimension of the array BB. LDBB >= KB+1.
+*
+* Q (output) DOUBLE PRECISION array, dimension (LDQ, N)
+* If JOBZ = 'V', the n-by-n matrix used in the reduction of
+* A*x = (lambda)*B*x to standard form, i.e. C*x = (lambda)*x,
+* and consequently C to tridiagonal form.
+* If JOBZ = 'N', the array Q is not referenced.
+*
+* LDQ (input) INTEGER
+* The leading dimension of the array Q. If JOBZ = 'N',
+* LDQ >= 1. If JOBZ = 'V', LDQ >= max(1,N).
+*
+* VL (input) DOUBLE PRECISION
+* VU (input) DOUBLE PRECISION
+* If RANGE='V', the lower and upper bounds of the interval to
+* be searched for eigenvalues. VL < VU.
+* Not referenced if RANGE = 'A' or 'I'.
+*
+* IL (input) INTEGER
+* IU (input) INTEGER
+* If RANGE='I', the indices (in ascending order) of the
+* smallest and largest eigenvalues to be returned.
+* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
+* Not referenced if RANGE = 'A' or 'V'.
+*
+* ABSTOL (input) DOUBLE PRECISION
+* The absolute error tolerance for the eigenvalues.
+* An approximate eigenvalue is accepted as converged
+* when it is determined to lie in an interval [a,b]
+* of width less than or equal to
+*
+* ABSTOL + EPS * max( |a|,|b| ) ,
+*
+* where EPS is the machine precision. If ABSTOL is less than
+* or equal to zero, then EPS*|T| will be used in its place,
+* where |T| is the 1-norm of the tridiagonal matrix obtained
+* by reducing A to tridiagonal form.
+*
+* Eigenvalues will be computed most accurately when ABSTOL is
+* set to twice the underflow threshold 2*DLAMCH('S'), not zero.
+* If this routine returns with INFO>0, indicating that some
+* eigenvectors did not converge, try setting ABSTOL to
+* 2*DLAMCH('S').
+*
+* M (output) INTEGER
+* The total number of eigenvalues found. 0 <= M <= N.
+* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
+*
+* W (output) DOUBLE PRECISION array, dimension (N)
+* If INFO = 0, the eigenvalues in ascending order.
+*
+* Z (output) DOUBLE PRECISION array, dimension (LDZ, N)
+* If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of
+* eigenvectors, with the i-th column of Z holding the
+* eigenvector associated with W(i). The eigenvectors are
+* normalized so Z**T*B*Z = I.
+* If JOBZ = 'N', then Z is not referenced.
+*
+* LDZ (input) INTEGER
+* The leading dimension of the array Z. LDZ >= 1, and if
+* JOBZ = 'V', LDZ >= max(1,N).
+*
+* WORK (workspace/output) DOUBLE PRECISION array, dimension (7*N)
+*
+* IWORK (workspace/output) INTEGER array, dimension (5*N)
+*
+* IFAIL (output) INTEGER array, dimension (M)
+* If JOBZ = 'V', then if INFO = 0, the first M elements of
+* IFAIL are zero. If INFO > 0, then IFAIL contains the
+* indices of the eigenvalues that failed to converge.
+* If JOBZ = 'N', then IFAIL is not referenced.
+*
+* INFO (output) INTEGER
+* = 0 : successful exit
+* < 0 : if INFO = -i, the i-th argument had an illegal value
+* <= N: if INFO = i, then i eigenvectors failed to converge.
+* Their indices are stored in IFAIL.
+* > N : DPBSTF returned an error code; i.e.,
+* if INFO = N + i, for 1 <= i <= N, then the leading
+* minor of order i of B is not positive definite.
+* The factorization of B could not be completed and
+* no eigenvalues or eigenvectors were computed.
+*
+* Further Details
+* ===============
+*
+* Based on contributions by
+* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL ALLEIG, INDEIG, TEST, UPPER, VALEIG, WANTZ
+ CHARACTER ORDER, VECT
+ INTEGER I, IINFO, INDD, INDE, INDEE, INDIBL, INDISP,
+ $ INDIWO, INDWRK, ITMP1, J, JJ, NSPLIT
+ DOUBLE PRECISION TMP1
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL DCOPY, DGEMV, DLACPY, DPBSTF, DSBGST, DSBTRD,
+ $ DSTEBZ, DSTEIN, DSTEQR, DSTERF, DSWAP, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MIN
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ WANTZ = LSAME( JOBZ, 'V' )
+ UPPER = LSAME( UPLO, 'U' )
+ ALLEIG = LSAME( RANGE, 'A' )
+ VALEIG = LSAME( RANGE, 'V' )
+ INDEIG = LSAME( RANGE, 'I' )
+*
+ INFO = 0
+ IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
+ INFO = -1
+ ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN
+ INFO = -2
+ ELSE IF( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN
+ INFO = -3
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( KA.LT.0 ) THEN
+ INFO = -5
+ ELSE IF( KB.LT.0 .OR. KB.GT.KA ) THEN
+ INFO = -6
+ ELSE IF( LDAB.LT.KA+1 ) THEN
+ INFO = -8
+ ELSE IF( LDBB.LT.KB+1 ) THEN
+ INFO = -10
+ ELSE IF( LDQ.LT.1 .OR. ( WANTZ .AND. LDQ.LT.N ) ) THEN
+ INFO = -12
+ ELSE
+ IF( VALEIG ) THEN
+ IF( N.GT.0 .AND. VU.LE.VL )
+ $ INFO = -14
+ ELSE IF( INDEIG ) THEN
+ IF( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) THEN
+ INFO = -15
+ ELSE IF ( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) THEN
+ INFO = -16
+ END IF
+ END IF
+ END IF
+ IF( INFO.EQ.0) THEN
+ IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
+ INFO = -21
+ END IF
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DSBGVX', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ M = 0
+ IF( N.EQ.0 )
+ $ RETURN
+*
+* Form a split Cholesky factorization of B.
+*
+ CALL DPBSTF( UPLO, N, KB, BB, LDBB, INFO )
+ IF( INFO.NE.0 ) THEN
+ INFO = N + INFO
+ RETURN
+ END IF
+*
+* Transform problem to standard eigenvalue problem.
+*
+ CALL DSBGST( JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, Q, LDQ,
+ $ WORK, IINFO )
+*
+* Reduce symmetric band matrix to tridiagonal form.
+*
+ INDD = 1
+ INDE = INDD + N
+ INDWRK = INDE + N
+ IF( WANTZ ) THEN
+ VECT = 'U'
+ ELSE
+ VECT = 'N'
+ END IF
+ CALL DSBTRD( VECT, UPLO, N, KA, AB, LDAB, WORK( INDD ),
+ $ WORK( INDE ), Q, LDQ, WORK( INDWRK ), IINFO )
+*
+* If all eigenvalues are desired and ABSTOL is less than or equal
+* to zero, then call DSTERF or SSTEQR. If this fails for some
+* eigenvalue, then try DSTEBZ.
+*
+ TEST = .FALSE.
+ IF( INDEIG ) THEN
+ IF( IL.EQ.1 .AND. IU.EQ.N ) THEN
+ TEST = .TRUE.
+ END IF
+ END IF
+ IF( ( ALLEIG .OR. TEST ) .AND. ( ABSTOL.LE.ZERO ) ) THEN
+ CALL DCOPY( N, WORK( INDD ), 1, W, 1 )
+ INDEE = INDWRK + 2*N
+ CALL DCOPY( N-1, WORK( INDE ), 1, WORK( INDEE ), 1 )
+ IF( .NOT.WANTZ ) THEN
+ CALL DSTERF( N, W, WORK( INDEE ), INFO )
+ ELSE
+ CALL DLACPY( 'A', N, N, Q, LDQ, Z, LDZ )
+ CALL DSTEQR( JOBZ, N, W, WORK( INDEE ), Z, LDZ,
+ $ WORK( INDWRK ), INFO )
+ IF( INFO.EQ.0 ) THEN
+ DO 10 I = 1, N
+ IFAIL( I ) = 0
+ 10 CONTINUE
+ END IF
+ END IF
+ IF( INFO.EQ.0 ) THEN
+ M = N
+ GO TO 30
+ END IF
+ INFO = 0
+ END IF
+*
+* Otherwise, call DSTEBZ and, if eigenvectors are desired,
+* call DSTEIN.
+*
+ IF( WANTZ ) THEN
+ ORDER = 'B'
+ ELSE
+ ORDER = 'E'
+ END IF
+ INDIBL = 1
+ INDISP = INDIBL + N
+ INDIWO = INDISP + N
+ CALL DSTEBZ( RANGE, ORDER, N, VL, VU, IL, IU, ABSTOL,
+ $ WORK( INDD ), WORK( INDE ), M, NSPLIT, W,
+ $ IWORK( INDIBL ), IWORK( INDISP ), WORK( INDWRK ),
+ $ IWORK( INDIWO ), INFO )
+*
+ IF( WANTZ ) THEN
+ CALL DSTEIN( N, WORK( INDD ), WORK( INDE ), M, W,
+ $ IWORK( INDIBL ), IWORK( INDISP ), Z, LDZ,
+ $ WORK( INDWRK ), IWORK( INDIWO ), IFAIL, INFO )
+*
+* Apply transformation matrix used in reduction to tridiagonal
+* form to eigenvectors returned by DSTEIN.
+*
+ DO 20 J = 1, M
+ CALL DCOPY( N, Z( 1, J ), 1, WORK( 1 ), 1 )
+ CALL DGEMV( 'N', N, N, ONE, Q, LDQ, WORK, 1, ZERO,
+ $ Z( 1, J ), 1 )
+ 20 CONTINUE
+ END IF
+*
+ 30 CONTINUE
+*
+* If eigenvalues are not in order, then sort them, along with
+* eigenvectors.
+*
+ IF( WANTZ ) THEN
+ DO 50 J = 1, M - 1
+ I = 0
+ TMP1 = W( J )
+ DO 40 JJ = J + 1, M
+ IF( W( JJ ).LT.TMP1 ) THEN
+ I = JJ
+ TMP1 = W( JJ )
+ END IF
+ 40 CONTINUE
+*
+ IF( I.NE.0 ) THEN
+ ITMP1 = IWORK( INDIBL+I-1 )
+ W( I ) = W( J )
+ IWORK( INDIBL+I-1 ) = IWORK( INDIBL+J-1 )
+ W( J ) = TMP1
+ IWORK( INDIBL+J-1 ) = ITMP1
+ CALL DSWAP( N, Z( 1, I ), 1, Z( 1, J ), 1 )
+ IF( INFO.NE.0 ) THEN
+ ITMP1 = IFAIL( I )
+ IFAIL( I ) = IFAIL( J )
+ IFAIL( J ) = ITMP1
+ END IF
+ END IF
+ 50 CONTINUE
+ END IF
+*
+ RETURN
+*
+* End of DSBGVX
+*
+ END
+ SUBROUTINE DSBTRD( VECT, UPLO, N, KD, AB, LDAB, D, E, Q, LDQ,
+ $ WORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO, VECT
+ INTEGER INFO, KD, LDAB, LDQ, N
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION AB( LDAB, * ), D( * ), E( * ), Q( LDQ, * ),
+ $ WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DSBTRD reduces a real symmetric band matrix A to symmetric
+* tridiagonal form T by an orthogonal similarity transformation:
+* Q**T * A * Q = T.
+*
+* Arguments
+* =========
+*
+* VECT (input) CHARACTER*1
+* = 'N': do not form Q;
+* = 'V': form Q;
+* = 'U': update a matrix X, by forming X*Q.
+*
+* UPLO (input) CHARACTER*1
+* = 'U': Upper triangle of A is stored;
+* = 'L': Lower triangle of A is stored.
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* KD (input) INTEGER
+* The number of superdiagonals of the matrix A if UPLO = 'U',
+* or the number of subdiagonals if UPLO = 'L'. KD >= 0.
+*
+* AB (input/output) DOUBLE PRECISION array, dimension (LDAB,N)
+* On entry, the upper or lower triangle of the symmetric band
+* matrix A, stored in the first KD+1 rows of the array. The
+* j-th column of A is stored in the j-th column of the array AB
+* as follows:
+* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
+* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).
+* On exit, the diagonal elements of AB are overwritten by the
+* diagonal elements of the tridiagonal matrix T; if KD > 0, the
+* elements on the first superdiagonal (if UPLO = 'U') or the
+* first subdiagonal (if UPLO = 'L') are overwritten by the
+* off-diagonal elements of T; the rest of AB is overwritten by
+* values generated during the reduction.
+*
+* LDAB (input) INTEGER
+* The leading dimension of the array AB. LDAB >= KD+1.
+*
+* D (output) DOUBLE PRECISION array, dimension (N)
+* The diagonal elements of the tridiagonal matrix T.
+*
+* E (output) DOUBLE PRECISION array, dimension (N-1)
+* The off-diagonal elements of the tridiagonal matrix T:
+* E(i) = T(i,i+1) if UPLO = 'U'; E(i) = T(i+1,i) if UPLO = 'L'.
+*
+* Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N)
+* On entry, if VECT = 'U', then Q must contain an N-by-N
+* matrix X; if VECT = 'N' or 'V', then Q need not be set.
+*
+* On exit:
+* if VECT = 'V', Q contains the N-by-N orthogonal matrix Q;
+* if VECT = 'U', Q contains the product X*Q;
+* if VECT = 'N', the array Q is not referenced.
+*
+* LDQ (input) INTEGER
+* The leading dimension of the array Q.
+* LDQ >= 1, and LDQ >= N if VECT = 'V' or 'U'.
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (N)
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+*
+* Further Details
+* ===============
+*
+* Modified by Linda Kaufman, Bell Labs.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL INITQ, UPPER, WANTQ
+ INTEGER I, I2, IBL, INCA, INCX, IQAEND, IQB, IQEND, J,
+ $ J1, J1END, J1INC, J2, JEND, JIN, JINC, K, KD1,
+ $ KDM1, KDN, L, LAST, LEND, NQ, NR, NRT
+ DOUBLE PRECISION TEMP
+* ..
+* .. External Subroutines ..
+ EXTERNAL DLAR2V, DLARGV, DLARTG, DLARTV, DLASET, DROT,
+ $ XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters
+*
+ INITQ = LSAME( VECT, 'V' )
+ WANTQ = INITQ .OR. LSAME( VECT, 'U' )
+ UPPER = LSAME( UPLO, 'U' )
+ KD1 = KD + 1
+ KDM1 = KD - 1
+ INCX = LDAB - 1
+ IQEND = 1
+*
+ INFO = 0
+ IF( .NOT.WANTQ .AND. .NOT.LSAME( VECT, 'N' ) ) THEN
+ INFO = -1
+ ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -2
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( KD.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( LDAB.LT.KD1 ) THEN
+ INFO = -6
+ ELSE IF( LDQ.LT.MAX( 1, N ) .AND. WANTQ ) THEN
+ INFO = -10
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DSBTRD', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+* Initialize Q to the unit matrix, if needed
+*
+ IF( INITQ )
+ $ CALL DLASET( 'Full', N, N, ZERO, ONE, Q, LDQ )
+*
+* Wherever possible, plane rotations are generated and applied in
+* vector operations of length NR over the index set J1:J2:KD1.
+*
+* The cosines and sines of the plane rotations are stored in the
+* arrays D and WORK.
+*
+ INCA = KD1*LDAB
+ KDN = MIN( N-1, KD )
+ IF( UPPER ) THEN
+*
+ IF( KD.GT.1 ) THEN
+*
+* Reduce to tridiagonal form, working with upper triangle
+*
+ NR = 0
+ J1 = KDN + 2
+ J2 = 1
+*
+ DO 90 I = 1, N - 2
+*
+* Reduce i-th row of matrix to tridiagonal form
+*
+ DO 80 K = KDN + 1, 2, -1
+ J1 = J1 + KDN
+ J2 = J2 + KDN
+*
+ IF( NR.GT.0 ) THEN
+*
+* generate plane rotations to annihilate nonzero
+* elements which have been created outside the band
+*
+ CALL DLARGV( NR, AB( 1, J1-1 ), INCA, WORK( J1 ),
+ $ KD1, D( J1 ), KD1 )
+*
+* apply rotations from the right
+*
+*
+* Dependent on the the number of diagonals either
+* DLARTV or DROT is used
+*
+ IF( NR.GE.2*KD-1 ) THEN
+ DO 10 L = 1, KD - 1
+ CALL DLARTV( NR, AB( L+1, J1-1 ), INCA,
+ $ AB( L, J1 ), INCA, D( J1 ),
+ $ WORK( J1 ), KD1 )
+ 10 CONTINUE
+*
+ ELSE
+ JEND = J1 + ( NR-1 )*KD1
+ DO 20 JINC = J1, JEND, KD1
+ CALL DROT( KDM1, AB( 2, JINC-1 ), 1,
+ $ AB( 1, JINC ), 1, D( JINC ),
+ $ WORK( JINC ) )
+ 20 CONTINUE
+ END IF
+ END IF
+*
+*
+ IF( K.GT.2 ) THEN
+ IF( K.LE.N-I+1 ) THEN
+*
+* generate plane rotation to annihilate a(i,i+k-1)
+* within the band
+*
+ CALL DLARTG( AB( KD-K+3, I+K-2 ),
+ $ AB( KD-K+2, I+K-1 ), D( I+K-1 ),
+ $ WORK( I+K-1 ), TEMP )
+ AB( KD-K+3, I+K-2 ) = TEMP
+*
+* apply rotation from the right
+*
+ CALL DROT( K-3, AB( KD-K+4, I+K-2 ), 1,
+ $ AB( KD-K+3, I+K-1 ), 1, D( I+K-1 ),
+ $ WORK( I+K-1 ) )
+ END IF
+ NR = NR + 1
+ J1 = J1 - KDN - 1
+ END IF
+*
+* apply plane rotations from both sides to diagonal
+* blocks
+*
+ IF( NR.GT.0 )
+ $ CALL DLAR2V( NR, AB( KD1, J1-1 ), AB( KD1, J1 ),
+ $ AB( KD, J1 ), INCA, D( J1 ),
+ $ WORK( J1 ), KD1 )
+*
+* apply plane rotations from the left
+*
+ IF( NR.GT.0 ) THEN
+ IF( 2*KD-1.LT.NR ) THEN
+*
+* Dependent on the the number of diagonals either
+* DLARTV or DROT is used
+*
+ DO 30 L = 1, KD - 1
+ IF( J2+L.GT.N ) THEN
+ NRT = NR - 1
+ ELSE
+ NRT = NR
+ END IF
+ IF( NRT.GT.0 )
+ $ CALL DLARTV( NRT, AB( KD-L, J1+L ), INCA,
+ $ AB( KD-L+1, J1+L ), INCA,
+ $ D( J1 ), WORK( J1 ), KD1 )
+ 30 CONTINUE
+ ELSE
+ J1END = J1 + KD1*( NR-2 )
+ IF( J1END.GE.J1 ) THEN
+ DO 40 JIN = J1, J1END, KD1
+ CALL DROT( KD-1, AB( KD-1, JIN+1 ), INCX,
+ $ AB( KD, JIN+1 ), INCX,
+ $ D( JIN ), WORK( JIN ) )
+ 40 CONTINUE
+ END IF
+ LEND = MIN( KDM1, N-J2 )
+ LAST = J1END + KD1
+ IF( LEND.GT.0 )
+ $ CALL DROT( LEND, AB( KD-1, LAST+1 ), INCX,
+ $ AB( KD, LAST+1 ), INCX, D( LAST ),
+ $ WORK( LAST ) )
+ END IF
+ END IF
+*
+ IF( WANTQ ) THEN
+*
+* accumulate product of plane rotations in Q
+*
+ IF( INITQ ) THEN
+*
+* take advantage of the fact that Q was
+* initially the Identity matrix
+*
+ IQEND = MAX( IQEND, J2 )
+ I2 = MAX( 0, K-3 )
+ IQAEND = 1 + I*KD
+ IF( K.EQ.2 )
+ $ IQAEND = IQAEND + KD
+ IQAEND = MIN( IQAEND, IQEND )
+ DO 50 J = J1, J2, KD1
+ IBL = I - I2 / KDM1
+ I2 = I2 + 1
+ IQB = MAX( 1, J-IBL )
+ NQ = 1 + IQAEND - IQB
+ IQAEND = MIN( IQAEND+KD, IQEND )
+ CALL DROT( NQ, Q( IQB, J-1 ), 1, Q( IQB, J ),
+ $ 1, D( J ), WORK( J ) )
+ 50 CONTINUE
+ ELSE
+*
+ DO 60 J = J1, J2, KD1
+ CALL DROT( N, Q( 1, J-1 ), 1, Q( 1, J ), 1,
+ $ D( J ), WORK( J ) )
+ 60 CONTINUE
+ END IF
+*
+ END IF
+*
+ IF( J2+KDN.GT.N ) THEN
+*
+* adjust J2 to keep within the bounds of the matrix
+*
+ NR = NR - 1
+ J2 = J2 - KDN - 1
+ END IF
+*
+ DO 70 J = J1, J2, KD1
+*
+* create nonzero element a(j-1,j+kd) outside the band
+* and store it in WORK
+*
+ WORK( J+KD ) = WORK( J )*AB( 1, J+KD )
+ AB( 1, J+KD ) = D( J )*AB( 1, J+KD )
+ 70 CONTINUE
+ 80 CONTINUE
+ 90 CONTINUE
+ END IF
+*
+ IF( KD.GT.0 ) THEN
+*
+* copy off-diagonal elements to E
+*
+ DO 100 I = 1, N - 1
+ E( I ) = AB( KD, I+1 )
+ 100 CONTINUE
+ ELSE
+*
+* set E to zero if original matrix was diagonal
+*
+ DO 110 I = 1, N - 1
+ E( I ) = ZERO
+ 110 CONTINUE
+ END IF
+*
+* copy diagonal elements to D
+*
+ DO 120 I = 1, N
+ D( I ) = AB( KD1, I )
+ 120 CONTINUE
+*
+ ELSE
+*
+ IF( KD.GT.1 ) THEN
+*
+* Reduce to tridiagonal form, working with lower triangle
+*
+ NR = 0
+ J1 = KDN + 2
+ J2 = 1
+*
+ DO 210 I = 1, N - 2
+*
+* Reduce i-th column of matrix to tridiagonal form
+*
+ DO 200 K = KDN + 1, 2, -1
+ J1 = J1 + KDN
+ J2 = J2 + KDN
+*
+ IF( NR.GT.0 ) THEN
+*
+* generate plane rotations to annihilate nonzero
+* elements which have been created outside the band
+*
+ CALL DLARGV( NR, AB( KD1, J1-KD1 ), INCA,
+ $ WORK( J1 ), KD1, D( J1 ), KD1 )
+*
+* apply plane rotations from one side
+*
+*
+* Dependent on the the number of diagonals either
+* DLARTV or DROT is used
+*
+ IF( NR.GT.2*KD-1 ) THEN
+ DO 130 L = 1, KD - 1
+ CALL DLARTV( NR, AB( KD1-L, J1-KD1+L ), INCA,
+ $ AB( KD1-L+1, J1-KD1+L ), INCA,
+ $ D( J1 ), WORK( J1 ), KD1 )
+ 130 CONTINUE
+ ELSE
+ JEND = J1 + KD1*( NR-1 )
+ DO 140 JINC = J1, JEND, KD1
+ CALL DROT( KDM1, AB( KD, JINC-KD ), INCX,
+ $ AB( KD1, JINC-KD ), INCX,
+ $ D( JINC ), WORK( JINC ) )
+ 140 CONTINUE
+ END IF
+*
+ END IF
+*
+ IF( K.GT.2 ) THEN
+ IF( K.LE.N-I+1 ) THEN
+*
+* generate plane rotation to annihilate a(i+k-1,i)
+* within the band
+*
+ CALL DLARTG( AB( K-1, I ), AB( K, I ),
+ $ D( I+K-1 ), WORK( I+K-1 ), TEMP )
+ AB( K-1, I ) = TEMP
+*
+* apply rotation from the left
+*
+ CALL DROT( K-3, AB( K-2, I+1 ), LDAB-1,
+ $ AB( K-1, I+1 ), LDAB-1, D( I+K-1 ),
+ $ WORK( I+K-1 ) )
+ END IF
+ NR = NR + 1
+ J1 = J1 - KDN - 1
+ END IF
+*
+* apply plane rotations from both sides to diagonal
+* blocks
+*
+ IF( NR.GT.0 )
+ $ CALL DLAR2V( NR, AB( 1, J1-1 ), AB( 1, J1 ),
+ $ AB( 2, J1-1 ), INCA, D( J1 ),
+ $ WORK( J1 ), KD1 )
+*
+* apply plane rotations from the right
+*
+*
+* Dependent on the the number of diagonals either
+* DLARTV or DROT is used
+*
+ IF( NR.GT.0 ) THEN
+ IF( NR.GT.2*KD-1 ) THEN
+ DO 150 L = 1, KD - 1
+ IF( J2+L.GT.N ) THEN
+ NRT = NR - 1
+ ELSE
+ NRT = NR
+ END IF
+ IF( NRT.GT.0 )
+ $ CALL DLARTV( NRT, AB( L+2, J1-1 ), INCA,
+ $ AB( L+1, J1 ), INCA, D( J1 ),
+ $ WORK( J1 ), KD1 )
+ 150 CONTINUE
+ ELSE
+ J1END = J1 + KD1*( NR-2 )
+ IF( J1END.GE.J1 ) THEN
+ DO 160 J1INC = J1, J1END, KD1
+ CALL DROT( KDM1, AB( 3, J1INC-1 ), 1,
+ $ AB( 2, J1INC ), 1, D( J1INC ),
+ $ WORK( J1INC ) )
+ 160 CONTINUE
+ END IF
+ LEND = MIN( KDM1, N-J2 )
+ LAST = J1END + KD1
+ IF( LEND.GT.0 )
+ $ CALL DROT( LEND, AB( 3, LAST-1 ), 1,
+ $ AB( 2, LAST ), 1, D( LAST ),
+ $ WORK( LAST ) )
+ END IF
+ END IF
+*
+*
+*
+ IF( WANTQ ) THEN
+*
+* accumulate product of plane rotations in Q
+*
+ IF( INITQ ) THEN
+*
+* take advantage of the fact that Q was
+* initially the Identity matrix
+*
+ IQEND = MAX( IQEND, J2 )
+ I2 = MAX( 0, K-3 )
+ IQAEND = 1 + I*KD
+ IF( K.EQ.2 )
+ $ IQAEND = IQAEND + KD
+ IQAEND = MIN( IQAEND, IQEND )
+ DO 170 J = J1, J2, KD1
+ IBL = I - I2 / KDM1
+ I2 = I2 + 1
+ IQB = MAX( 1, J-IBL )
+ NQ = 1 + IQAEND - IQB
+ IQAEND = MIN( IQAEND+KD, IQEND )
+ CALL DROT( NQ, Q( IQB, J-1 ), 1, Q( IQB, J ),
+ $ 1, D( J ), WORK( J ) )
+ 170 CONTINUE
+ ELSE
+*
+ DO 180 J = J1, J2, KD1
+ CALL DROT( N, Q( 1, J-1 ), 1, Q( 1, J ), 1,
+ $ D( J ), WORK( J ) )
+ 180 CONTINUE
+ END IF
+ END IF
+*
+ IF( J2+KDN.GT.N ) THEN
+*
+* adjust J2 to keep within the bounds of the matrix
+*
+ NR = NR - 1
+ J2 = J2 - KDN - 1
+ END IF
+*
+ DO 190 J = J1, J2, KD1
+*
+* create nonzero element a(j+kd,j-1) outside the
+* band and store it in WORK
+*
+ WORK( J+KD ) = WORK( J )*AB( KD1, J )
+ AB( KD1, J ) = D( J )*AB( KD1, J )
+ 190 CONTINUE
+ 200 CONTINUE
+ 210 CONTINUE
+ END IF
+*
+ IF( KD.GT.0 ) THEN
+*
+* copy off-diagonal elements to E
+*
+ DO 220 I = 1, N - 1
+ E( I ) = AB( 2, I )
+ 220 CONTINUE
+ ELSE
+*
+* set E to zero if original matrix was diagonal
+*
+ DO 230 I = 1, N - 1
+ E( I ) = ZERO
+ 230 CONTINUE
+ END IF
+*
+* copy diagonal elements to D
+*
+ DO 240 I = 1, N
+ D( I ) = AB( 1, I )
+ 240 CONTINUE
+ END IF
+*
+ RETURN
+*
+* End of DSBTRD
+*
+ END
+ SUBROUTINE DSGESV( N, NRHS, A, LDA, IPIV, B, LDB, X, LDX, WORK,
+ + SWORK, ITER, INFO)
+*
+* -- LAPACK PROTOTYPE driver routine (version 3.1.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* February 2007
+*
+* ..
+* .. WARNING: PROTOTYPE ..
+* This is an LAPACK PROTOTYPE routine which means that the
+* interface of this routine is likely to be changed in the future
+* based on community feedback.
+*
+* ..
+* .. Scalar Arguments ..
+ INTEGER INFO,ITER,LDA,LDB,LDX,N,NRHS
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV(*)
+ REAL SWORK(*)
+ DOUBLE PRECISION A(LDA,*),B(LDB,*),WORK(N,*),X(LDX,*)
+* ..
+*
+* Purpose
+* =======
+*
+* DSGESV computes the solution to a real system of linear equations
+* A * X = B,
+* where A is an N-by-N matrix and X and B are N-by-NRHS matrices.
+*
+* DSGESV first attempts to factorize the matrix in SINGLE PRECISION
+* and use this factorization within an iterative refinement procedure to
+* produce a solution with DOUBLE PRECISION normwise backward error
+* quality (see below). If the approach fails the method switches to a
+* DOUBLE PRECISION factorization and solve.
+*
+* The iterative refinement is not going to be a winning strategy if
+* the ratio SINGLE PRECISION performance over DOUBLE PRECISION performance
+* is too small. A reasonable strategy should take the number of right-hand
+* sides and the size of the matrix into account. This might be done with a
+* call to ILAENV in the future. Up to now, we always try iterative refinement.
+*
+* The iterative refinement process is stopped if
+* ITER > ITERMAX
+* or for all the RHS we have:
+* RNRM < SQRT(N)*XNRM*ANRM*EPS*BWDMAX
+* where
+* o ITER is the number of the current iteration in the iterative
+* refinement process
+* o RNRM is the infinity-norm of the residual
+* o XNRM is the infinity-norm of the solution
+* o ANRM is the infinity-operator-norm of the matrix A
+* o EPS is the machine epsilon returned by DLAMCH('Epsilon')
+* The value ITERMAX and BWDMAX are fixed to 30 and 1.0D+00 respectively.
+*
+* Arguments
+* =========
+*
+* N (input) INTEGER
+* The number of linear equations, i.e., the order of the
+* matrix A. N >= 0.
+*
+* NRHS (input) INTEGER
+* The number of right hand sides, i.e., the number of columns
+* of the matrix B. NRHS >= 0.
+*
+* A (input or input/ouptut) DOUBLE PRECISION array,
+* dimension (LDA,N)
+* On entry, the N-by-N coefficient matrix A.
+* On exit, if iterative refinement has been successfully used
+* (INFO.EQ.0 and ITER.GE.0, see description below), then A is
+* unchanged, if double precision factorization has been used
+* (INFO.EQ.0 and ITER.LT.0, see description below), then the
+* array A contains the factors L and U from the factorization
+* A = P*L*U; the unit diagonal elements of L are not stored.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,N).
+*
+* IPIV (output) INTEGER array, dimension (N)
+* The pivot indices that define the permutation matrix P;
+* row i of the matrix was interchanged with row IPIV(i).
+* Corresponds either to the single precision factorization
+* (if INFO.EQ.0 and ITER.GE.0) or the double precision
+* factorization (if INFO.EQ.0 and ITER.LT.0).
+*
+* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS)
+* The N-by-NRHS matrix of right hand side matrix B.
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. LDB >= max(1,N).
+*
+* X (output) DOUBLE PRECISION array, dimension (LDX,NRHS)
+* If INFO = 0, the N-by-NRHS solution matrix X.
+*
+* LDX (input) INTEGER
+* The leading dimension of the array X. LDX >= max(1,N).
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (N*NRHS)
+* This array is used to hold the residual vectors.
+*
+* SWORK (workspace) REAL array, dimension (N*(N+NRHS))
+* This array is used to use the single precision matrix and the
+* right-hand sides or solutions in single precision.
+*
+* ITER (output) INTEGER
+* < 0: iterative refinement has failed, double precision
+* factorization has been performed
+* -1 : taking into account machine parameters, N, NRHS, it
+* is a priori not worth working in SINGLE PRECISION
+* -2 : overflow of an entry when moving from double to
+* SINGLE PRECISION
+* -3 : failure of SGETRF
+* -31: stop the iterative refinement after the 30th
+* iterations
+* > 0: iterative refinement has been sucessfully used.
+* Returns the number of iterations
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* > 0: if INFO = i, U(i,i) computed in DOUBLE PRECISION is
+* exactly zero. The factorization has been completed,
+* but the factor U is exactly singular, so the solution
+* could not be computed.
+*
+* =========
+*
+* .. Parameters ..
+ DOUBLE PRECISION NEGONE,ONE
+ PARAMETER (NEGONE=-1.0D+0,ONE=1.0D+0)
+*
+* .. Local Scalars ..
+ LOGICAL DOITREF
+ INTEGER I,IITER,ITERMAX,OK,PTSA,PTSX
+ DOUBLE PRECISION ANRM,BWDMAX,CTE,EPS,RNRM,XNRM
+*
+* .. External Subroutines ..
+ EXTERNAL DAXPY,DGEMM,DLACPY,DLAG2S,SLAG2D,
+ + SGETRF,SGETRS,XERBLA
+* ..
+* .. External Functions ..
+ INTEGER IDAMAX
+ DOUBLE PRECISION DLAMCH,DLANGE
+ EXTERNAL IDAMAX,DLAMCH,DLANGE
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS,DBLE,MAX,SQRT
+* ..
+* .. Executable Statements ..
+*
+ ITERMAX = 30
+ BWDMAX = 1.0E+00
+ DOITREF = .TRUE.
+*
+ OK = 0
+ INFO = 0
+ ITER = 0
+*
+* Test the input parameters.
+*
+ IF (N.LT.0) THEN
+ INFO = -1
+ ELSE IF (NRHS.LT.0) THEN
+ INFO = -2
+ ELSE IF (LDA.LT.MAX(1,N)) THEN
+ INFO = -4
+ ELSE IF (LDB.LT.MAX(1,N)) THEN
+ INFO = -7
+ ELSE IF (LDX.LT.MAX(1,N)) THEN
+ INFO = -9
+ END IF
+ IF (INFO.NE.0) THEN
+ CALL XERBLA('DSGESV',-INFO)
+ RETURN
+ END IF
+*
+* Quick return if (N.EQ.0).
+*
+ IF (N.EQ.0) RETURN
+*
+* Skip single precision iterative refinement if a priori slower
+* than double precision factorization.
+*
+ IF (.NOT.DOITREF) THEN
+ ITER = -1
+ GO TO 40
+ END IF
+*
+* Compute some constants.
+*
+ ANRM = DLANGE('I',N,N,A,LDA,WORK)
+ EPS = DLAMCH('Epsilon')
+ CTE = ANRM*EPS*SQRT(DBLE(N))*BWDMAX
+*
+* Set the pointers PTSA, PTSX for referencing SA and SX in SWORK.
+*
+ PTSA = 1
+ PTSX = PTSA + N*N
+*
+* Convert B from double precision to single precision and store the
+* result in SX.
+*
+ CALL DLAG2S(N,NRHS,B,LDB,SWORK(PTSX),N,INFO)
+*
+ IF (INFO.NE.0) THEN
+ ITER = -2
+ GO TO 40
+ END IF
+*
+* Convert A from double precision to single precision and store the
+* result in SA.
+*
+ CALL DLAG2S(N,N,A,LDA,SWORK(PTSA),N,INFO)
+*
+ IF (INFO.NE.0) THEN
+ ITER = -2
+ GO TO 40
+ END IF
+*
+* Compute the LU factorization of SA.
+*
+ CALL SGETRF(N,N,SWORK(PTSA),N,IPIV,INFO)
+*
+ IF (INFO.NE.0) THEN
+ ITER = -3
+ GO TO 40
+ END IF
+*
+* Solve the system SA*SX = SB.
+*
+ CALL SGETRS('No transpose',N,NRHS,SWORK(PTSA),N,IPIV,
+ + SWORK(PTSX),N,INFO)
+*
+* Convert SX back to double precision
+*
+ CALL SLAG2D(N,NRHS,SWORK(PTSX),N,X,LDX,INFO)
+*
+* Compute R = B - AX (R is WORK).
+*
+ CALL DLACPY('All',N,NRHS,B,LDB,WORK,N)
+*
+ CALL DGEMM('No Transpose','No Transpose',N,NRHS,N,NEGONE,A,LDA,X,
+ + LDX,ONE,WORK,N)
+*
+* Check whether the NRHS normwised backward errors satisfy the
+* stopping criterion. If yes, set ITER=0 and return.
+*
+ DO I = 1,NRHS
+ XNRM = ABS(X(IDAMAX(N,X(1,I),1),I))
+ RNRM = ABS(WORK(IDAMAX(N,WORK(1,I),1),I))
+ IF (RNRM.GT.XNRM*CTE) GOTO 10
+ END DO
+*
+* If we are here, the NRHS normwised backward errors satisfy the
+* stopping criterion. We are good to exit.
+*
+ ITER = 0
+ RETURN
+*
+ 10 CONTINUE
+*
+ DO 30 IITER = 1,ITERMAX
+*
+* Convert R (in WORK) from double precision to single precision
+* and store the result in SX.
+*
+ CALL DLAG2S(N,NRHS,WORK,N,SWORK(PTSX),N,INFO)
+*
+ IF (INFO.NE.0) THEN
+ ITER = -2
+ GO TO 40
+ END IF
+*
+* Solve the system SA*SX = SR.
+*
+ CALL SGETRS('No transpose',N,NRHS,SWORK(PTSA),N,IPIV,
+ + SWORK(PTSX),N,INFO)
+*
+* Convert SX back to double precision and update the current
+* iterate.
+*
+ CALL SLAG2D(N,NRHS,SWORK(PTSX),N,WORK,N,INFO)
+*
+ CALL DAXPY(N*NRHS,ONE,WORK,1,X,1)
+*
+* Compute R = B - AX (R is WORK).
+*
+ CALL DLACPY('All',N,NRHS,B,LDB,WORK,N)
+*
+ CALL DGEMM('No Transpose','No Transpose',N,NRHS,N,NEGONE,A,
+ + LDA,X,LDX,ONE,WORK,N)
+*
+* Check whether the NRHS normwised backward errors satisfy the
+* stopping criterion. If yes, set ITER=IITER>0 and return.
+*
+ DO I = 1,NRHS
+ XNRM = ABS(X(IDAMAX(N,X(1,I),1),I))
+ RNRM = ABS(WORK(IDAMAX(N,WORK(1,I),1),I))
+ IF (RNRM.GT.XNRM*CTE) GOTO 20
+ END DO
+*
+* If we are here, the NRHS normwised backward errors satisfy the
+* stopping criterion, we are good to exit.
+*
+ ITER = IITER
+*
+ RETURN
+*
+ 20 CONTINUE
+*
+ 30 CONTINUE
+*
+* If we are at this place of the code, this is because we have
+* performed ITER=ITERMAX iterations and never satisified the stopping
+* criterion, set up the ITER flag accordingly and follow up on double
+* precision routine.
+*
+ ITER = -ITERMAX - 1
+*
+ 40 CONTINUE
+*
+* Single-precision iterative refinement failed to converge to a
+* satisfactory solution, so we resort to double precision.
+*
+ CALL DGETRF(N,N,A,LDA,IPIV,INFO)
+*
+ CALL DLACPY('All',N,NRHS,B,LDB,X,LDX)
+*
+ IF (INFO.EQ.0) THEN
+ CALL DGETRS('No transpose',N,NRHS,A,LDA,IPIV,X,LDX,INFO)
+ END IF
+*
+ RETURN
+*
+* End of DSGESV.
+*
+ END
+ SUBROUTINE DSPCON( UPLO, N, AP, IPIV, ANORM, RCOND, WORK, IWORK,
+ $ INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH.
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, N
+ DOUBLE PRECISION ANORM, RCOND
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * ), IWORK( * )
+ DOUBLE PRECISION AP( * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DSPCON estimates the reciprocal of the condition number (in the
+* 1-norm) of a real symmetric packed matrix A using the factorization
+* A = U*D*U**T or A = L*D*L**T computed by DSPTRF.
+*
+* An estimate is obtained for norm(inv(A)), and the reciprocal of the
+* condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).
+*
+* Arguments
+* =========
+*
+* UPLO (input) CHARACTER*1
+* Specifies whether the details of the factorization are stored
+* as an upper or lower triangular matrix.
+* = 'U': Upper triangular, form is A = U*D*U**T;
+* = 'L': Lower triangular, form is A = L*D*L**T.
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)
+* The block diagonal matrix D and the multipliers used to
+* obtain the factor U or L as computed by DSPTRF, stored as a
+* packed triangular matrix.
+*
+* IPIV (input) INTEGER array, dimension (N)
+* Details of the interchanges and the block structure of D
+* as determined by DSPTRF.
+*
+* ANORM (input) DOUBLE PRECISION
+* The 1-norm of the original matrix A.
+*
+* RCOND (output) DOUBLE PRECISION
+* The reciprocal of the condition number of the matrix A,
+* computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an
+* estimate of the 1-norm of inv(A) computed in this routine.
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (2*N)
+*
+* IWORK (workspace) INTEGER array, dimension (N)
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE, ZERO
+ PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL UPPER
+ INTEGER I, IP, KASE
+ DOUBLE PRECISION AINVNM
+* ..
+* .. Local Arrays ..
+ INTEGER ISAVE( 3 )
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL DLACN2, DSPTRS, XERBLA
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( ANORM.LT.ZERO ) THEN
+ INFO = -5
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DSPCON', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ RCOND = ZERO
+ IF( N.EQ.0 ) THEN
+ RCOND = ONE
+ RETURN
+ ELSE IF( ANORM.LE.ZERO ) THEN
+ RETURN
+ END IF
+*
+* Check that the diagonal matrix D is nonsingular.
+*
+ IF( UPPER ) THEN
+*
+* Upper triangular storage: examine D from bottom to top
+*
+ IP = N*( N+1 ) / 2
+ DO 10 I = N, 1, -1
+ IF( IPIV( I ).GT.0 .AND. AP( IP ).EQ.ZERO )
+ $ RETURN
+ IP = IP - I
+ 10 CONTINUE
+ ELSE
+*
+* Lower triangular storage: examine D from top to bottom.
+*
+ IP = 1
+ DO 20 I = 1, N
+ IF( IPIV( I ).GT.0 .AND. AP( IP ).EQ.ZERO )
+ $ RETURN
+ IP = IP + N - I + 1
+ 20 CONTINUE
+ END IF
+*
+* Estimate the 1-norm of the inverse.
+*
+ KASE = 0
+ 30 CONTINUE
+ CALL DLACN2( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE, ISAVE )
+ IF( KASE.NE.0 ) THEN
+*
+* Multiply by inv(L*D*L') or inv(U*D*U').
+*
+ CALL DSPTRS( UPLO, N, 1, AP, IPIV, WORK, N, INFO )
+ GO TO 30
+ END IF
+*
+* Compute the estimate of the reciprocal condition number.
+*
+ IF( AINVNM.NE.ZERO )
+ $ RCOND = ( ONE / AINVNM ) / ANORM
+*
+ RETURN
+*
+* End of DSPCON
+*
+ END
+ SUBROUTINE DSPEV( JOBZ, UPLO, N, AP, W, Z, LDZ, WORK, INFO )
+*
+* -- LAPACK driver routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER JOBZ, UPLO
+ INTEGER INFO, LDZ, N
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION AP( * ), W( * ), WORK( * ), Z( LDZ, * )
+* ..
+*
+* Purpose
+* =======
+*
+* DSPEV computes all the eigenvalues and, optionally, eigenvectors of a
+* real symmetric matrix A in packed storage.
+*
+* Arguments
+* =========
+*
+* JOBZ (input) CHARACTER*1
+* = 'N': Compute eigenvalues only;
+* = 'V': Compute eigenvalues and eigenvectors.
+*
+* UPLO (input) CHARACTER*1
+* = 'U': Upper triangle of A is stored;
+* = 'L': Lower triangle of A is stored.
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)
+* On entry, the upper or lower triangle of the symmetric matrix
+* A, packed columnwise in a linear array. The j-th column of A
+* is stored in the array AP as follows:
+* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
+* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
+*
+* On exit, AP is overwritten by values generated during the
+* reduction to tridiagonal form. If UPLO = 'U', the diagonal
+* and first superdiagonal of the tridiagonal matrix T overwrite
+* the corresponding elements of A, and if UPLO = 'L', the
+* diagonal and first subdiagonal of T overwrite the
+* corresponding elements of A.
+*
+* W (output) DOUBLE PRECISION array, dimension (N)
+* If INFO = 0, the eigenvalues in ascending order.
+*
+* Z (output) DOUBLE PRECISION array, dimension (LDZ, N)
+* If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal
+* eigenvectors of the matrix A, with the i-th column of Z
+* holding the eigenvector associated with W(i).
+* If JOBZ = 'N', then Z is not referenced.
+*
+* LDZ (input) INTEGER
+* The leading dimension of the array Z. LDZ >= 1, and if
+* JOBZ = 'V', LDZ >= max(1,N).
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (3*N)
+*
+* INFO (output) INTEGER
+* = 0: successful exit.
+* < 0: if INFO = -i, the i-th argument had an illegal value.
+* > 0: if INFO = i, the algorithm failed to converge; i
+* off-diagonal elements of an intermediate tridiagonal
+* form did not converge to zero.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL WANTZ
+ INTEGER IINFO, IMAX, INDE, INDTAU, INDWRK, ISCALE
+ DOUBLE PRECISION ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA,
+ $ SMLNUM
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ DOUBLE PRECISION DLAMCH, DLANSP
+ EXTERNAL LSAME, DLAMCH, DLANSP
+* ..
+* .. External Subroutines ..
+ EXTERNAL DOPGTR, DSCAL, DSPTRD, DSTEQR, DSTERF, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC SQRT
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ WANTZ = LSAME( JOBZ, 'V' )
+*
+ INFO = 0
+ IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
+ INFO = -1
+ ELSE IF( .NOT.( LSAME( UPLO, 'U' ) .OR. LSAME( UPLO, 'L' ) ) )
+ $ THEN
+ INFO = -2
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
+ INFO = -7
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DSPEV ', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+ IF( N.EQ.1 ) THEN
+ W( 1 ) = AP( 1 )
+ IF( WANTZ )
+ $ Z( 1, 1 ) = ONE
+ RETURN
+ END IF
+*
+* Get machine constants.
+*
+ SAFMIN = DLAMCH( 'Safe minimum' )
+ EPS = DLAMCH( 'Precision' )
+ SMLNUM = SAFMIN / EPS
+ BIGNUM = ONE / SMLNUM
+ RMIN = SQRT( SMLNUM )
+ RMAX = SQRT( BIGNUM )
+*
+* Scale matrix to allowable range, if necessary.
+*
+ ANRM = DLANSP( 'M', UPLO, N, AP, WORK )
+ ISCALE = 0
+ IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN
+ ISCALE = 1
+ SIGMA = RMIN / ANRM
+ ELSE IF( ANRM.GT.RMAX ) THEN
+ ISCALE = 1
+ SIGMA = RMAX / ANRM
+ END IF
+ IF( ISCALE.EQ.1 ) THEN
+ CALL DSCAL( ( N*( N+1 ) ) / 2, SIGMA, AP, 1 )
+ END IF
+*
+* Call DSPTRD to reduce symmetric packed matrix to tridiagonal form.
+*
+ INDE = 1
+ INDTAU = INDE + N
+ CALL DSPTRD( UPLO, N, AP, W, WORK( INDE ), WORK( INDTAU ), IINFO )
+*
+* For eigenvalues only, call DSTERF. For eigenvectors, first call
+* DOPGTR to generate the orthogonal matrix, then call DSTEQR.
+*
+ IF( .NOT.WANTZ ) THEN
+ CALL DSTERF( N, W, WORK( INDE ), INFO )
+ ELSE
+ INDWRK = INDTAU + N
+ CALL DOPGTR( UPLO, N, AP, WORK( INDTAU ), Z, LDZ,
+ $ WORK( INDWRK ), IINFO )
+ CALL DSTEQR( JOBZ, N, W, WORK( INDE ), Z, LDZ, WORK( INDTAU ),
+ $ INFO )
+ END IF
+*
+* If matrix was scaled, then rescale eigenvalues appropriately.
+*
+ IF( ISCALE.EQ.1 ) THEN
+ IF( INFO.EQ.0 ) THEN
+ IMAX = N
+ ELSE
+ IMAX = INFO - 1
+ END IF
+ CALL DSCAL( IMAX, ONE / SIGMA, W, 1 )
+ END IF
+*
+ RETURN
+*
+* End of DSPEV
+*
+ END
+ SUBROUTINE DSPEVD( JOBZ, UPLO, N, AP, W, Z, LDZ, WORK, LWORK,
+ $ IWORK, LIWORK, INFO )
+*
+* -- LAPACK driver routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER JOBZ, UPLO
+ INTEGER INFO, LDZ, LIWORK, LWORK, N
+* ..
+* .. Array Arguments ..
+ INTEGER IWORK( * )
+ DOUBLE PRECISION AP( * ), W( * ), WORK( * ), Z( LDZ, * )
+* ..
+*
+* Purpose
+* =======
+*
+* DSPEVD computes all the eigenvalues and, optionally, eigenvectors
+* of a real symmetric matrix A in packed storage. If eigenvectors are
+* desired, it uses a divide and conquer algorithm.
+*
+* The divide and conquer algorithm makes very mild assumptions about
+* floating point arithmetic. It will work on machines with a guard
+* digit in add/subtract, or on those binary machines without guard
+* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
+* Cray-2. It could conceivably fail on hexadecimal or decimal machines
+* without guard digits, but we know of none.
+*
+* Arguments
+* =========
+*
+* JOBZ (input) CHARACTER*1
+* = 'N': Compute eigenvalues only;
+* = 'V': Compute eigenvalues and eigenvectors.
+*
+* UPLO (input) CHARACTER*1
+* = 'U': Upper triangle of A is stored;
+* = 'L': Lower triangle of A is stored.
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)
+* On entry, the upper or lower triangle of the symmetric matrix
+* A, packed columnwise in a linear array. The j-th column of A
+* is stored in the array AP as follows:
+* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
+* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
+*
+* On exit, AP is overwritten by values generated during the
+* reduction to tridiagonal form. If UPLO = 'U', the diagonal
+* and first superdiagonal of the tridiagonal matrix T overwrite
+* the corresponding elements of A, and if UPLO = 'L', the
+* diagonal and first subdiagonal of T overwrite the
+* corresponding elements of A.
+*
+* W (output) DOUBLE PRECISION array, dimension (N)
+* If INFO = 0, the eigenvalues in ascending order.
+*
+* Z (output) DOUBLE PRECISION array, dimension (LDZ, N)
+* If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal
+* eigenvectors of the matrix A, with the i-th column of Z
+* holding the eigenvector associated with W(i).
+* If JOBZ = 'N', then Z is not referenced.
+*
+* LDZ (input) INTEGER
+* The leading dimension of the array Z. LDZ >= 1, and if
+* JOBZ = 'V', LDZ >= max(1,N).
+*
+* WORK (workspace/output) DOUBLE PRECISION array,
+* dimension (LWORK)
+* On exit, if INFO = 0, WORK(1) returns the required LWORK.
+*
+* LWORK (input) INTEGER
+* The dimension of the array WORK.
+* If N <= 1, LWORK must be at least 1.
+* If JOBZ = 'N' and N > 1, LWORK must be at least 2*N.
+* If JOBZ = 'V' and N > 1, LWORK must be at least
+* 1 + 6*N + N**2.
+*
+* If LWORK = -1, then a workspace query is assumed; the routine
+* only calculates the required sizes of the WORK and IWORK
+* arrays, returns these values as the first entries of the WORK
+* and IWORK arrays, and no error message related to LWORK or
+* LIWORK is issued by XERBLA.
+*
+* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))
+* On exit, if INFO = 0, IWORK(1) returns the required LIWORK.
+*
+* LIWORK (input) INTEGER
+* The dimension of the array IWORK.
+* If JOBZ = 'N' or N <= 1, LIWORK must be at least 1.
+* If JOBZ = 'V' and N > 1, LIWORK must be at least 3 + 5*N.
+*
+* If LIWORK = -1, then a workspace query is assumed; the
+* routine only calculates the required sizes of the WORK and
+* IWORK arrays, returns these values as the first entries of
+* the WORK and IWORK arrays, and no error message related to
+* LWORK or LIWORK is issued by XERBLA.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value.
+* > 0: if INFO = i, the algorithm failed to converge; i
+* off-diagonal elements of an intermediate tridiagonal
+* form did not converge to zero.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL LQUERY, WANTZ
+ INTEGER IINFO, INDE, INDTAU, INDWRK, ISCALE, LIWMIN,
+ $ LLWORK, LWMIN
+ DOUBLE PRECISION ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA,
+ $ SMLNUM
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ DOUBLE PRECISION DLAMCH, DLANSP
+ EXTERNAL LSAME, DLAMCH, DLANSP
+* ..
+* .. External Subroutines ..
+ EXTERNAL DOPMTR, DSCAL, DSPTRD, DSTEDC, DSTERF, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC SQRT
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ WANTZ = LSAME( JOBZ, 'V' )
+ LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 )
+*
+ INFO = 0
+ IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
+ INFO = -1
+ ELSE IF( .NOT.( LSAME( UPLO, 'U' ) .OR. LSAME( UPLO, 'L' ) ) )
+ $ THEN
+ INFO = -2
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
+ INFO = -7
+ END IF
+*
+ IF( INFO.EQ.0 ) THEN
+ IF( N.LE.1 ) THEN
+ LIWMIN = 1
+ LWMIN = 1
+ ELSE
+ IF( WANTZ ) THEN
+ LIWMIN = 3 + 5*N
+ LWMIN = 1 + 6*N + N**2
+ ELSE
+ LIWMIN = 1
+ LWMIN = 2*N
+ END IF
+ END IF
+ IWORK( 1 ) = LIWMIN
+ WORK( 1 ) = LWMIN
+*
+ IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
+ INFO = -9
+ ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN
+ INFO = -11
+ END IF
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DSPEVD', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+ IF( N.EQ.1 ) THEN
+ W( 1 ) = AP( 1 )
+ IF( WANTZ )
+ $ Z( 1, 1 ) = ONE
+ RETURN
+ END IF
+*
+* Get machine constants.
+*
+ SAFMIN = DLAMCH( 'Safe minimum' )
+ EPS = DLAMCH( 'Precision' )
+ SMLNUM = SAFMIN / EPS
+ BIGNUM = ONE / SMLNUM
+ RMIN = SQRT( SMLNUM )
+ RMAX = SQRT( BIGNUM )
+*
+* Scale matrix to allowable range, if necessary.
+*
+ ANRM = DLANSP( 'M', UPLO, N, AP, WORK )
+ ISCALE = 0
+ IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN
+ ISCALE = 1
+ SIGMA = RMIN / ANRM
+ ELSE IF( ANRM.GT.RMAX ) THEN
+ ISCALE = 1
+ SIGMA = RMAX / ANRM
+ END IF
+ IF( ISCALE.EQ.1 ) THEN
+ CALL DSCAL( ( N*( N+1 ) ) / 2, SIGMA, AP, 1 )
+ END IF
+*
+* Call DSPTRD to reduce symmetric packed matrix to tridiagonal form.
+*
+ INDE = 1
+ INDTAU = INDE + N
+ CALL DSPTRD( UPLO, N, AP, W, WORK( INDE ), WORK( INDTAU ), IINFO )
+*
+* For eigenvalues only, call DSTERF. For eigenvectors, first call
+* DSTEDC to generate the eigenvector matrix, WORK(INDWRK), of the
+* tridiagonal matrix, then call DOPMTR to multiply it by the
+* Householder transformations represented in AP.
+*
+ IF( .NOT.WANTZ ) THEN
+ CALL DSTERF( N, W, WORK( INDE ), INFO )
+ ELSE
+ INDWRK = INDTAU + N
+ LLWORK = LWORK - INDWRK + 1
+ CALL DSTEDC( 'I', N, W, WORK( INDE ), Z, LDZ, WORK( INDWRK ),
+ $ LLWORK, IWORK, LIWORK, INFO )
+ CALL DOPMTR( 'L', UPLO, 'N', N, N, AP, WORK( INDTAU ), Z, LDZ,
+ $ WORK( INDWRK ), IINFO )
+ END IF
+*
+* If matrix was scaled, then rescale eigenvalues appropriately.
+*
+ IF( ISCALE.EQ.1 )
+ $ CALL DSCAL( N, ONE / SIGMA, W, 1 )
+*
+ WORK( 1 ) = LWMIN
+ IWORK( 1 ) = LIWMIN
+ RETURN
+*
+* End of DSPEVD
+*
+ END
+ SUBROUTINE DSPEVX( JOBZ, RANGE, UPLO, N, AP, VL, VU, IL, IU,
+ $ ABSTOL, M, W, Z, LDZ, WORK, IWORK, IFAIL,
+ $ INFO )
+*
+* -- LAPACK driver routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER JOBZ, RANGE, UPLO
+ INTEGER IL, INFO, IU, LDZ, M, N
+ DOUBLE PRECISION ABSTOL, VL, VU
+* ..
+* .. Array Arguments ..
+ INTEGER IFAIL( * ), IWORK( * )
+ DOUBLE PRECISION AP( * ), W( * ), WORK( * ), Z( LDZ, * )
+* ..
+*
+* Purpose
+* =======
+*
+* DSPEVX computes selected eigenvalues and, optionally, eigenvectors
+* of a real symmetric matrix A in packed storage. Eigenvalues/vectors
+* can be selected by specifying either a range of values or a range of
+* indices for the desired eigenvalues.
+*
+* Arguments
+* =========
+*
+* JOBZ (input) CHARACTER*1
+* = 'N': Compute eigenvalues only;
+* = 'V': Compute eigenvalues and eigenvectors.
+*
+* RANGE (input) CHARACTER*1
+* = 'A': all eigenvalues will be found;
+* = 'V': all eigenvalues in the half-open interval (VL,VU]
+* will be found;
+* = 'I': the IL-th through IU-th eigenvalues will be found.
+*
+* UPLO (input) CHARACTER*1
+* = 'U': Upper triangle of A is stored;
+* = 'L': Lower triangle of A is stored.
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)
+* On entry, the upper or lower triangle of the symmetric matrix
+* A, packed columnwise in a linear array. The j-th column of A
+* is stored in the array AP as follows:
+* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
+* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
+*
+* On exit, AP is overwritten by values generated during the
+* reduction to tridiagonal form. If UPLO = 'U', the diagonal
+* and first superdiagonal of the tridiagonal matrix T overwrite
+* the corresponding elements of A, and if UPLO = 'L', the
+* diagonal and first subdiagonal of T overwrite the
+* corresponding elements of A.
+*
+* VL (input) DOUBLE PRECISION
+* VU (input) DOUBLE PRECISION
+* If RANGE='V', the lower and upper bounds of the interval to
+* be searched for eigenvalues. VL < VU.
+* Not referenced if RANGE = 'A' or 'I'.
+*
+* IL (input) INTEGER
+* IU (input) INTEGER
+* If RANGE='I', the indices (in ascending order) of the
+* smallest and largest eigenvalues to be returned.
+* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
+* Not referenced if RANGE = 'A' or 'V'.
+*
+* ABSTOL (input) DOUBLE PRECISION
+* The absolute error tolerance for the eigenvalues.
+* An approximate eigenvalue is accepted as converged
+* when it is determined to lie in an interval [a,b]
+* of width less than or equal to
+*
+* ABSTOL + EPS * max( |a|,|b| ) ,
+*
+* where EPS is the machine precision. If ABSTOL is less than
+* or equal to zero, then EPS*|T| will be used in its place,
+* where |T| is the 1-norm of the tridiagonal matrix obtained
+* by reducing AP to tridiagonal form.
+*
+* Eigenvalues will be computed most accurately when ABSTOL is
+* set to twice the underflow threshold 2*DLAMCH('S'), not zero.
+* If this routine returns with INFO>0, indicating that some
+* eigenvectors did not converge, try setting ABSTOL to
+* 2*DLAMCH('S').
+*
+* See "Computing Small Singular Values of Bidiagonal Matrices
+* with Guaranteed High Relative Accuracy," by Demmel and
+* Kahan, LAPACK Working Note #3.
+*
+* M (output) INTEGER
+* The total number of eigenvalues found. 0 <= M <= N.
+* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
+*
+* W (output) DOUBLE PRECISION array, dimension (N)
+* If INFO = 0, the selected eigenvalues in ascending order.
+*
+* Z (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M))
+* If JOBZ = 'V', then if INFO = 0, the first M columns of Z
+* contain the orthonormal eigenvectors of the matrix A
+* corresponding to the selected eigenvalues, with the i-th
+* column of Z holding the eigenvector associated with W(i).
+* If an eigenvector fails to converge, then that column of Z
+* contains the latest approximation to the eigenvector, and the
+* index of the eigenvector is returned in IFAIL.
+* If JOBZ = 'N', then Z is not referenced.
+* Note: the user must ensure that at least max(1,M) columns are
+* supplied in the array Z; if RANGE = 'V', the exact value of M
+* is not known in advance and an upper bound must be used.
+*
+* LDZ (input) INTEGER
+* The leading dimension of the array Z. LDZ >= 1, and if
+* JOBZ = 'V', LDZ >= max(1,N).
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (8*N)
+*
+* IWORK (workspace) INTEGER array, dimension (5*N)
+*
+* IFAIL (output) INTEGER array, dimension (N)
+* If JOBZ = 'V', then if INFO = 0, the first M elements of
+* IFAIL are zero. If INFO > 0, then IFAIL contains the
+* indices of the eigenvectors that failed to converge.
+* If JOBZ = 'N', then IFAIL is not referenced.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* > 0: if INFO = i, then i eigenvectors failed to converge.
+* Their indices are stored in array IFAIL.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL ALLEIG, INDEIG, TEST, VALEIG, WANTZ
+ CHARACTER ORDER
+ INTEGER I, IINFO, IMAX, INDD, INDE, INDEE, INDIBL,
+ $ INDISP, INDIWO, INDTAU, INDWRK, ISCALE, ITMP1,
+ $ J, JJ, NSPLIT
+ DOUBLE PRECISION ABSTLL, ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN,
+ $ SIGMA, SMLNUM, TMP1, VLL, VUU
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ DOUBLE PRECISION DLAMCH, DLANSP
+ EXTERNAL LSAME, DLAMCH, DLANSP
+* ..
+* .. External Subroutines ..
+ EXTERNAL DCOPY, DOPGTR, DOPMTR, DSCAL, DSPTRD, DSTEBZ,
+ $ DSTEIN, DSTEQR, DSTERF, DSWAP, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN, SQRT
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ WANTZ = LSAME( JOBZ, 'V' )
+ ALLEIG = LSAME( RANGE, 'A' )
+ VALEIG = LSAME( RANGE, 'V' )
+ INDEIG = LSAME( RANGE, 'I' )
+*
+ INFO = 0
+ IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
+ INFO = -1
+ ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN
+ INFO = -2
+ ELSE IF( .NOT.( LSAME( UPLO, 'L' ) .OR. LSAME( UPLO, 'U' ) ) )
+ $ THEN
+ INFO = -3
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -4
+ ELSE
+ IF( VALEIG ) THEN
+ IF( N.GT.0 .AND. VU.LE.VL )
+ $ INFO = -7
+ ELSE IF( INDEIG ) THEN
+ IF( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) THEN
+ INFO = -8
+ ELSE IF( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) THEN
+ INFO = -9
+ END IF
+ END IF
+ END IF
+ IF( INFO.EQ.0 ) THEN
+ IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) )
+ $ INFO = -14
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DSPEVX', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ M = 0
+ IF( N.EQ.0 )
+ $ RETURN
+*
+ IF( N.EQ.1 ) THEN
+ IF( ALLEIG .OR. INDEIG ) THEN
+ M = 1
+ W( 1 ) = AP( 1 )
+ ELSE
+ IF( VL.LT.AP( 1 ) .AND. VU.GE.AP( 1 ) ) THEN
+ M = 1
+ W( 1 ) = AP( 1 )
+ END IF
+ END IF
+ IF( WANTZ )
+ $ Z( 1, 1 ) = ONE
+ RETURN
+ END IF
+*
+* Get machine constants.
+*
+ SAFMIN = DLAMCH( 'Safe minimum' )
+ EPS = DLAMCH( 'Precision' )
+ SMLNUM = SAFMIN / EPS
+ BIGNUM = ONE / SMLNUM
+ RMIN = SQRT( SMLNUM )
+ RMAX = MIN( SQRT( BIGNUM ), ONE / SQRT( SQRT( SAFMIN ) ) )
+*
+* Scale matrix to allowable range, if necessary.
+*
+ ISCALE = 0
+ ABSTLL = ABSTOL
+ IF( VALEIG ) THEN
+ VLL = VL
+ VUU = VU
+ ELSE
+ VLL = ZERO
+ VUU = ZERO
+ END IF
+ ANRM = DLANSP( 'M', UPLO, N, AP, WORK )
+ IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN
+ ISCALE = 1
+ SIGMA = RMIN / ANRM
+ ELSE IF( ANRM.GT.RMAX ) THEN
+ ISCALE = 1
+ SIGMA = RMAX / ANRM
+ END IF
+ IF( ISCALE.EQ.1 ) THEN
+ CALL DSCAL( ( N*( N+1 ) ) / 2, SIGMA, AP, 1 )
+ IF( ABSTOL.GT.0 )
+ $ ABSTLL = ABSTOL*SIGMA
+ IF( VALEIG ) THEN
+ VLL = VL*SIGMA
+ VUU = VU*SIGMA
+ END IF
+ END IF
+*
+* Call DSPTRD to reduce symmetric packed matrix to tridiagonal form.
+*
+ INDTAU = 1
+ INDE = INDTAU + N
+ INDD = INDE + N
+ INDWRK = INDD + N
+ CALL DSPTRD( UPLO, N, AP, WORK( INDD ), WORK( INDE ),
+ $ WORK( INDTAU ), IINFO )
+*
+* If all eigenvalues are desired and ABSTOL is less than or equal
+* to zero, then call DSTERF or DOPGTR and SSTEQR. If this fails
+* for some eigenvalue, then try DSTEBZ.
+*
+ TEST = .FALSE.
+ IF (INDEIG) THEN
+ IF (IL.EQ.1 .AND. IU.EQ.N) THEN
+ TEST = .TRUE.
+ END IF
+ END IF
+ IF ((ALLEIG .OR. TEST) .AND. (ABSTOL.LE.ZERO)) THEN
+ CALL DCOPY( N, WORK( INDD ), 1, W, 1 )
+ INDEE = INDWRK + 2*N
+ IF( .NOT.WANTZ ) THEN
+ CALL DCOPY( N-1, WORK( INDE ), 1, WORK( INDEE ), 1 )
+ CALL DSTERF( N, W, WORK( INDEE ), INFO )
+ ELSE
+ CALL DOPGTR( UPLO, N, AP, WORK( INDTAU ), Z, LDZ,
+ $ WORK( INDWRK ), IINFO )
+ CALL DCOPY( N-1, WORK( INDE ), 1, WORK( INDEE ), 1 )
+ CALL DSTEQR( JOBZ, N, W, WORK( INDEE ), Z, LDZ,
+ $ WORK( INDWRK ), INFO )
+ IF( INFO.EQ.0 ) THEN
+ DO 10 I = 1, N
+ IFAIL( I ) = 0
+ 10 CONTINUE
+ END IF
+ END IF
+ IF( INFO.EQ.0 ) THEN
+ M = N
+ GO TO 20
+ END IF
+ INFO = 0
+ END IF
+*
+* Otherwise, call DSTEBZ and, if eigenvectors are desired, SSTEIN.
+*
+ IF( WANTZ ) THEN
+ ORDER = 'B'
+ ELSE
+ ORDER = 'E'
+ END IF
+ INDIBL = 1
+ INDISP = INDIBL + N
+ INDIWO = INDISP + N
+ CALL DSTEBZ( RANGE, ORDER, N, VLL, VUU, IL, IU, ABSTLL,
+ $ WORK( INDD ), WORK( INDE ), M, NSPLIT, W,
+ $ IWORK( INDIBL ), IWORK( INDISP ), WORK( INDWRK ),
+ $ IWORK( INDIWO ), INFO )
+*
+ IF( WANTZ ) THEN
+ CALL DSTEIN( N, WORK( INDD ), WORK( INDE ), M, W,
+ $ IWORK( INDIBL ), IWORK( INDISP ), Z, LDZ,
+ $ WORK( INDWRK ), IWORK( INDIWO ), IFAIL, INFO )
+*
+* Apply orthogonal matrix used in reduction to tridiagonal
+* form to eigenvectors returned by DSTEIN.
+*
+ CALL DOPMTR( 'L', UPLO, 'N', N, M, AP, WORK( INDTAU ), Z, LDZ,
+ $ WORK( INDWRK ), INFO )
+ END IF
+*
+* If matrix was scaled, then rescale eigenvalues appropriately.
+*
+ 20 CONTINUE
+ IF( ISCALE.EQ.1 ) THEN
+ IF( INFO.EQ.0 ) THEN
+ IMAX = M
+ ELSE
+ IMAX = INFO - 1
+ END IF
+ CALL DSCAL( IMAX, ONE / SIGMA, W, 1 )
+ END IF
+*
+* If eigenvalues are not in order, then sort them, along with
+* eigenvectors.
+*
+ IF( WANTZ ) THEN
+ DO 40 J = 1, M - 1
+ I = 0
+ TMP1 = W( J )
+ DO 30 JJ = J + 1, M
+ IF( W( JJ ).LT.TMP1 ) THEN
+ I = JJ
+ TMP1 = W( JJ )
+ END IF
+ 30 CONTINUE
+*
+ IF( I.NE.0 ) THEN
+ ITMP1 = IWORK( INDIBL+I-1 )
+ W( I ) = W( J )
+ IWORK( INDIBL+I-1 ) = IWORK( INDIBL+J-1 )
+ W( J ) = TMP1
+ IWORK( INDIBL+J-1 ) = ITMP1
+ CALL DSWAP( N, Z( 1, I ), 1, Z( 1, J ), 1 )
+ IF( INFO.NE.0 ) THEN
+ ITMP1 = IFAIL( I )
+ IFAIL( I ) = IFAIL( J )
+ IFAIL( J ) = ITMP1
+ END IF
+ END IF
+ 40 CONTINUE
+ END IF
+*
+ RETURN
+*
+* End of DSPEVX
+*
+ END
+ SUBROUTINE DSPGST( ITYPE, UPLO, N, AP, BP, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, ITYPE, N
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION AP( * ), BP( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DSPGST reduces a real symmetric-definite generalized eigenproblem
+* to standard form, using packed storage.
+*
+* If ITYPE = 1, the problem is A*x = lambda*B*x,
+* and A is overwritten by inv(U**T)*A*inv(U) or inv(L)*A*inv(L**T)
+*
+* If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or
+* B*A*x = lambda*x, and A is overwritten by U*A*U**T or L**T*A*L.
+*
+* B must have been previously factorized as U**T*U or L*L**T by DPPTRF.
+*
+* Arguments
+* =========
+*
+* ITYPE (input) INTEGER
+* = 1: compute inv(U**T)*A*inv(U) or inv(L)*A*inv(L**T);
+* = 2 or 3: compute U*A*U**T or L**T*A*L.
+*
+* UPLO (input) CHARACTER*1
+* = 'U': Upper triangle of A is stored and B is factored as
+* U**T*U;
+* = 'L': Lower triangle of A is stored and B is factored as
+* L*L**T.
+*
+* N (input) INTEGER
+* The order of the matrices A and B. N >= 0.
+*
+* AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)
+* On entry, the upper or lower triangle of the symmetric matrix
+* A, packed columnwise in a linear array. The j-th column of A
+* is stored in the array AP as follows:
+* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
+* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
+*
+* On exit, if INFO = 0, the transformed matrix, stored in the
+* same format as A.
+*
+* BP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)
+* The triangular factor from the Cholesky factorization of B,
+* stored in the same format as A, as returned by DPPTRF.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE, HALF
+ PARAMETER ( ONE = 1.0D0, HALF = 0.5D0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL UPPER
+ INTEGER J, J1, J1J1, JJ, K, K1, K1K1, KK
+ DOUBLE PRECISION AJJ, AKK, BJJ, BKK, CT
+* ..
+* .. External Subroutines ..
+ EXTERNAL DAXPY, DSCAL, DSPMV, DSPR2, DTPMV, DTPSV,
+ $ XERBLA
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ DOUBLE PRECISION DDOT
+ EXTERNAL LSAME, DDOT
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN
+ INFO = -1
+ ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -2
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -3
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DSPGST', -INFO )
+ RETURN
+ END IF
+*
+ IF( ITYPE.EQ.1 ) THEN
+ IF( UPPER ) THEN
+*
+* Compute inv(U')*A*inv(U)
+*
+* J1 and JJ are the indices of A(1,j) and A(j,j)
+*
+ JJ = 0
+ DO 10 J = 1, N
+ J1 = JJ + 1
+ JJ = JJ + J
+*
+* Compute the j-th column of the upper triangle of A
+*
+ BJJ = BP( JJ )
+ CALL DTPSV( UPLO, 'Transpose', 'Nonunit', J, BP,
+ $ AP( J1 ), 1 )
+ CALL DSPMV( UPLO, J-1, -ONE, AP, BP( J1 ), 1, ONE,
+ $ AP( J1 ), 1 )
+ CALL DSCAL( J-1, ONE / BJJ, AP( J1 ), 1 )
+ AP( JJ ) = ( AP( JJ )-DDOT( J-1, AP( J1 ), 1, BP( J1 ),
+ $ 1 ) ) / BJJ
+ 10 CONTINUE
+ ELSE
+*
+* Compute inv(L)*A*inv(L')
+*
+* KK and K1K1 are the indices of A(k,k) and A(k+1,k+1)
+*
+ KK = 1
+ DO 20 K = 1, N
+ K1K1 = KK + N - K + 1
+*
+* Update the lower triangle of A(k:n,k:n)
+*
+ AKK = AP( KK )
+ BKK = BP( KK )
+ AKK = AKK / BKK**2
+ AP( KK ) = AKK
+ IF( K.LT.N ) THEN
+ CALL DSCAL( N-K, ONE / BKK, AP( KK+1 ), 1 )
+ CT = -HALF*AKK
+ CALL DAXPY( N-K, CT, BP( KK+1 ), 1, AP( KK+1 ), 1 )
+ CALL DSPR2( UPLO, N-K, -ONE, AP( KK+1 ), 1,
+ $ BP( KK+1 ), 1, AP( K1K1 ) )
+ CALL DAXPY( N-K, CT, BP( KK+1 ), 1, AP( KK+1 ), 1 )
+ CALL DTPSV( UPLO, 'No transpose', 'Non-unit', N-K,
+ $ BP( K1K1 ), AP( KK+1 ), 1 )
+ END IF
+ KK = K1K1
+ 20 CONTINUE
+ END IF
+ ELSE
+ IF( UPPER ) THEN
+*
+* Compute U*A*U'
+*
+* K1 and KK are the indices of A(1,k) and A(k,k)
+*
+ KK = 0
+ DO 30 K = 1, N
+ K1 = KK + 1
+ KK = KK + K
+*
+* Update the upper triangle of A(1:k,1:k)
+*
+ AKK = AP( KK )
+ BKK = BP( KK )
+ CALL DTPMV( UPLO, 'No transpose', 'Non-unit', K-1, BP,
+ $ AP( K1 ), 1 )
+ CT = HALF*AKK
+ CALL DAXPY( K-1, CT, BP( K1 ), 1, AP( K1 ), 1 )
+ CALL DSPR2( UPLO, K-1, ONE, AP( K1 ), 1, BP( K1 ), 1,
+ $ AP )
+ CALL DAXPY( K-1, CT, BP( K1 ), 1, AP( K1 ), 1 )
+ CALL DSCAL( K-1, BKK, AP( K1 ), 1 )
+ AP( KK ) = AKK*BKK**2
+ 30 CONTINUE
+ ELSE
+*
+* Compute L'*A*L
+*
+* JJ and J1J1 are the indices of A(j,j) and A(j+1,j+1)
+*
+ JJ = 1
+ DO 40 J = 1, N
+ J1J1 = JJ + N - J + 1
+*
+* Compute the j-th column of the lower triangle of A
+*
+ AJJ = AP( JJ )
+ BJJ = BP( JJ )
+ AP( JJ ) = AJJ*BJJ + DDOT( N-J, AP( JJ+1 ), 1,
+ $ BP( JJ+1 ), 1 )
+ CALL DSCAL( N-J, BJJ, AP( JJ+1 ), 1 )
+ CALL DSPMV( UPLO, N-J, ONE, AP( J1J1 ), BP( JJ+1 ), 1,
+ $ ONE, AP( JJ+1 ), 1 )
+ CALL DTPMV( UPLO, 'Transpose', 'Non-unit', N-J+1,
+ $ BP( JJ ), AP( JJ ), 1 )
+ JJ = J1J1
+ 40 CONTINUE
+ END IF
+ END IF
+ RETURN
+*
+* End of DSPGST
+*
+ END
+ SUBROUTINE DSPGV( ITYPE, JOBZ, UPLO, N, AP, BP, W, Z, LDZ, WORK,
+ $ INFO )
+*
+* -- LAPACK driver routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER JOBZ, UPLO
+ INTEGER INFO, ITYPE, LDZ, N
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION AP( * ), BP( * ), W( * ), WORK( * ),
+ $ Z( LDZ, * )
+* ..
+*
+* Purpose
+* =======
+*
+* DSPGV computes all the eigenvalues and, optionally, the eigenvectors
+* of a real generalized symmetric-definite eigenproblem, of the form
+* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x.
+* Here A and B are assumed to be symmetric, stored in packed format,
+* and B is also positive definite.
+*
+* Arguments
+* =========
+*
+* ITYPE (input) INTEGER
+* Specifies the problem type to be solved:
+* = 1: A*x = (lambda)*B*x
+* = 2: A*B*x = (lambda)*x
+* = 3: B*A*x = (lambda)*x
+*
+* JOBZ (input) CHARACTER*1
+* = 'N': Compute eigenvalues only;
+* = 'V': Compute eigenvalues and eigenvectors.
+*
+* UPLO (input) CHARACTER*1
+* = 'U': Upper triangles of A and B are stored;
+* = 'L': Lower triangles of A and B are stored.
+*
+* N (input) INTEGER
+* The order of the matrices A and B. N >= 0.
+*
+* AP (input/output) DOUBLE PRECISION array, dimension
+* (N*(N+1)/2)
+* On entry, the upper or lower triangle of the symmetric matrix
+* A, packed columnwise in a linear array. The j-th column of A
+* is stored in the array AP as follows:
+* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
+* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
+*
+* On exit, the contents of AP are destroyed.
+*
+* BP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)
+* On entry, the upper or lower triangle of the symmetric matrix
+* B, packed columnwise in a linear array. The j-th column of B
+* is stored in the array BP as follows:
+* if UPLO = 'U', BP(i + (j-1)*j/2) = B(i,j) for 1<=i<=j;
+* if UPLO = 'L', BP(i + (j-1)*(2*n-j)/2) = B(i,j) for j<=i<=n.
+*
+* On exit, the triangular factor U or L from the Cholesky
+* factorization B = U**T*U or B = L*L**T, in the same storage
+* format as B.
+*
+* W (output) DOUBLE PRECISION array, dimension (N)
+* If INFO = 0, the eigenvalues in ascending order.
+*
+* Z (output) DOUBLE PRECISION array, dimension (LDZ, N)
+* If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of
+* eigenvectors. The eigenvectors are normalized as follows:
+* if ITYPE = 1 or 2, Z**T*B*Z = I;
+* if ITYPE = 3, Z**T*inv(B)*Z = I.
+* If JOBZ = 'N', then Z is not referenced.
+*
+* LDZ (input) INTEGER
+* The leading dimension of the array Z. LDZ >= 1, and if
+* JOBZ = 'V', LDZ >= max(1,N).
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (3*N)
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* > 0: DPPTRF or DSPEV returned an error code:
+* <= N: if INFO = i, DSPEV failed to converge;
+* i off-diagonal elements of an intermediate
+* tridiagonal form did not converge to zero.
+* > N: if INFO = n + i, for 1 <= i <= n, then the leading
+* minor of order i of B is not positive definite.
+* The factorization of B could not be completed and
+* no eigenvalues or eigenvectors were computed.
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ LOGICAL UPPER, WANTZ
+ CHARACTER TRANS
+ INTEGER J, NEIG
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL DPPTRF, DSPEV, DSPGST, DTPMV, DTPSV, XERBLA
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ WANTZ = LSAME( JOBZ, 'V' )
+ UPPER = LSAME( UPLO, 'U' )
+*
+ INFO = 0
+ IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN
+ INFO = -1
+ ELSE IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
+ INFO = -2
+ ELSE IF( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN
+ INFO = -3
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
+ INFO = -9
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DSPGV ', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+* Form a Cholesky factorization of B.
+*
+ CALL DPPTRF( UPLO, N, BP, INFO )
+ IF( INFO.NE.0 ) THEN
+ INFO = N + INFO
+ RETURN
+ END IF
+*
+* Transform problem to standard eigenvalue problem and solve.
+*
+ CALL DSPGST( ITYPE, UPLO, N, AP, BP, INFO )
+ CALL DSPEV( JOBZ, UPLO, N, AP, W, Z, LDZ, WORK, INFO )
+*
+ IF( WANTZ ) THEN
+*
+* Backtransform eigenvectors to the original problem.
+*
+ NEIG = N
+ IF( INFO.GT.0 )
+ $ NEIG = INFO - 1
+ IF( ITYPE.EQ.1 .OR. ITYPE.EQ.2 ) THEN
+*
+* For A*x=(lambda)*B*x and A*B*x=(lambda)*x;
+* backtransform eigenvectors: x = inv(L)'*y or inv(U)*y
+*
+ IF( UPPER ) THEN
+ TRANS = 'N'
+ ELSE
+ TRANS = 'T'
+ END IF
+*
+ DO 10 J = 1, NEIG
+ CALL DTPSV( UPLO, TRANS, 'Non-unit', N, BP, Z( 1, J ),
+ $ 1 )
+ 10 CONTINUE
+*
+ ELSE IF( ITYPE.EQ.3 ) THEN
+*
+* For B*A*x=(lambda)*x;
+* backtransform eigenvectors: x = L*y or U'*y
+*
+ IF( UPPER ) THEN
+ TRANS = 'T'
+ ELSE
+ TRANS = 'N'
+ END IF
+*
+ DO 20 J = 1, NEIG
+ CALL DTPMV( UPLO, TRANS, 'Non-unit', N, BP, Z( 1, J ),
+ $ 1 )
+ 20 CONTINUE
+ END IF
+ END IF
+ RETURN
+*
+* End of DSPGV
+*
+ END
+ SUBROUTINE DSPGVD( ITYPE, JOBZ, UPLO, N, AP, BP, W, Z, LDZ, WORK,
+ $ LWORK, IWORK, LIWORK, INFO )
+*
+* -- LAPACK driver routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER JOBZ, UPLO
+ INTEGER INFO, ITYPE, LDZ, LIWORK, LWORK, N
+* ..
+* .. Array Arguments ..
+ INTEGER IWORK( * )
+ DOUBLE PRECISION AP( * ), BP( * ), W( * ), WORK( * ),
+ $ Z( LDZ, * )
+* ..
+*
+* Purpose
+* =======
+*
+* DSPGVD computes all the eigenvalues, and optionally, the eigenvectors
+* of a real generalized symmetric-definite eigenproblem, of the form
+* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A and
+* B are assumed to be symmetric, stored in packed format, and B is also
+* positive definite.
+* If eigenvectors are desired, it uses a divide and conquer algorithm.
+*
+* The divide and conquer algorithm makes very mild assumptions about
+* floating point arithmetic. It will work on machines with a guard
+* digit in add/subtract, or on those binary machines without guard
+* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
+* Cray-2. It could conceivably fail on hexadecimal or decimal machines
+* without guard digits, but we know of none.
+*
+* Arguments
+* =========
+*
+* ITYPE (input) INTEGER
+* Specifies the problem type to be solved:
+* = 1: A*x = (lambda)*B*x
+* = 2: A*B*x = (lambda)*x
+* = 3: B*A*x = (lambda)*x
+*
+* JOBZ (input) CHARACTER*1
+* = 'N': Compute eigenvalues only;
+* = 'V': Compute eigenvalues and eigenvectors.
+*
+* UPLO (input) CHARACTER*1
+* = 'U': Upper triangles of A and B are stored;
+* = 'L': Lower triangles of A and B are stored.
+*
+* N (input) INTEGER
+* The order of the matrices A and B. N >= 0.
+*
+* AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)
+* On entry, the upper or lower triangle of the symmetric matrix
+* A, packed columnwise in a linear array. The j-th column of A
+* is stored in the array AP as follows:
+* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
+* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
+*
+* On exit, the contents of AP are destroyed.
+*
+* BP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)
+* On entry, the upper or lower triangle of the symmetric matrix
+* B, packed columnwise in a linear array. The j-th column of B
+* is stored in the array BP as follows:
+* if UPLO = 'U', BP(i + (j-1)*j/2) = B(i,j) for 1<=i<=j;
+* if UPLO = 'L', BP(i + (j-1)*(2*n-j)/2) = B(i,j) for j<=i<=n.
+*
+* On exit, the triangular factor U or L from the Cholesky
+* factorization B = U**T*U or B = L*L**T, in the same storage
+* format as B.
+*
+* W (output) DOUBLE PRECISION array, dimension (N)
+* If INFO = 0, the eigenvalues in ascending order.
+*
+* Z (output) DOUBLE PRECISION array, dimension (LDZ, N)
+* If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of
+* eigenvectors. The eigenvectors are normalized as follows:
+* if ITYPE = 1 or 2, Z**T*B*Z = I;
+* if ITYPE = 3, Z**T*inv(B)*Z = I.
+* If JOBZ = 'N', then Z is not referenced.
+*
+* LDZ (input) INTEGER
+* The leading dimension of the array Z. LDZ >= 1, and if
+* JOBZ = 'V', LDZ >= max(1,N).
+*
+* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
+* On exit, if INFO = 0, WORK(1) returns the required LWORK.
+*
+* LWORK (input) INTEGER
+* The dimension of the array WORK.
+* If N <= 1, LWORK >= 1.
+* If JOBZ = 'N' and N > 1, LWORK >= 2*N.
+* If JOBZ = 'V' and N > 1, LWORK >= 1 + 6*N + 2*N**2.
+*
+* If LWORK = -1, then a workspace query is assumed; the routine
+* only calculates the required sizes of the WORK and IWORK
+* arrays, returns these values as the first entries of the WORK
+* and IWORK arrays, and no error message related to LWORK or
+* LIWORK is issued by XERBLA.
+*
+* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))
+* On exit, if INFO = 0, IWORK(1) returns the required LIWORK.
+*
+* LIWORK (input) INTEGER
+* The dimension of the array IWORK.
+* If JOBZ = 'N' or N <= 1, LIWORK >= 1.
+* If JOBZ = 'V' and N > 1, LIWORK >= 3 + 5*N.
+*
+* If LIWORK = -1, then a workspace query is assumed; the
+* routine only calculates the required sizes of the WORK and
+* IWORK arrays, returns these values as the first entries of
+* the WORK and IWORK arrays, and no error message related to
+* LWORK or LIWORK is issued by XERBLA.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* > 0: DPPTRF or DSPEVD returned an error code:
+* <= N: if INFO = i, DSPEVD failed to converge;
+* i off-diagonal elements of an intermediate
+* tridiagonal form did not converge to zero;
+* > N: if INFO = N + i, for 1 <= i <= N, then the leading
+* minor of order i of B is not positive definite.
+* The factorization of B could not be completed and
+* no eigenvalues or eigenvectors were computed.
+*
+* Further Details
+* ===============
+*
+* Based on contributions by
+* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION TWO
+ PARAMETER ( TWO = 2.0D+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL LQUERY, UPPER, WANTZ
+ CHARACTER TRANS
+ INTEGER J, LIWMIN, LWMIN, NEIG
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL DPPTRF, DSPEVD, DSPGST, DTPMV, DTPSV, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC DBLE, MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ WANTZ = LSAME( JOBZ, 'V' )
+ UPPER = LSAME( UPLO, 'U' )
+ LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 )
+*
+ INFO = 0
+ IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN
+ INFO = -1
+ ELSE IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
+ INFO = -2
+ ELSE IF( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN
+ INFO = -3
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
+ INFO = -9
+ END IF
+*
+ IF( INFO.EQ.0 ) THEN
+ IF( N.LE.1 ) THEN
+ LIWMIN = 1
+ LWMIN = 1
+ ELSE
+ IF( WANTZ ) THEN
+ LIWMIN = 3 + 5*N
+ LWMIN = 1 + 6*N + 2*N**2
+ ELSE
+ LIWMIN = 1
+ LWMIN = 2*N
+ END IF
+ END IF
+ WORK( 1 ) = LWMIN
+ IWORK( 1 ) = LIWMIN
+*
+ IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
+ INFO = -11
+ ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN
+ INFO = -13
+ END IF
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DSPGVD', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+* Form a Cholesky factorization of BP.
+*
+ CALL DPPTRF( UPLO, N, BP, INFO )
+ IF( INFO.NE.0 ) THEN
+ INFO = N + INFO
+ RETURN
+ END IF
+*
+* Transform problem to standard eigenvalue problem and solve.
+*
+ CALL DSPGST( ITYPE, UPLO, N, AP, BP, INFO )
+ CALL DSPEVD( JOBZ, UPLO, N, AP, W, Z, LDZ, WORK, LWORK, IWORK,
+ $ LIWORK, INFO )
+ LWMIN = MAX( DBLE( LWMIN ), DBLE( WORK( 1 ) ) )
+ LIWMIN = MAX( DBLE( LIWMIN ), DBLE( IWORK( 1 ) ) )
+*
+ IF( WANTZ ) THEN
+*
+* Backtransform eigenvectors to the original problem.
+*
+ NEIG = N
+ IF( INFO.GT.0 )
+ $ NEIG = INFO - 1
+ IF( ITYPE.EQ.1 .OR. ITYPE.EQ.2 ) THEN
+*
+* For A*x=(lambda)*B*x and A*B*x=(lambda)*x;
+* backtransform eigenvectors: x = inv(L)'*y or inv(U)*y
+*
+ IF( UPPER ) THEN
+ TRANS = 'N'
+ ELSE
+ TRANS = 'T'
+ END IF
+*
+ DO 10 J = 1, NEIG
+ CALL DTPSV( UPLO, TRANS, 'Non-unit', N, BP, Z( 1, J ),
+ $ 1 )
+ 10 CONTINUE
+*
+ ELSE IF( ITYPE.EQ.3 ) THEN
+*
+* For B*A*x=(lambda)*x;
+* backtransform eigenvectors: x = L*y or U'*y
+*
+ IF( UPPER ) THEN
+ TRANS = 'T'
+ ELSE
+ TRANS = 'N'
+ END IF
+*
+ DO 20 J = 1, NEIG
+ CALL DTPMV( UPLO, TRANS, 'Non-unit', N, BP, Z( 1, J ),
+ $ 1 )
+ 20 CONTINUE
+ END IF
+ END IF
+*
+ WORK( 1 ) = LWMIN
+ IWORK( 1 ) = LIWMIN
+*
+ RETURN
+*
+* End of DSPGVD
+*
+ END
+ SUBROUTINE DSPGVX( ITYPE, JOBZ, RANGE, UPLO, N, AP, BP, VL, VU,
+ $ IL, IU, ABSTOL, M, W, Z, LDZ, WORK, IWORK,
+ $ IFAIL, INFO )
+*
+* -- LAPACK driver routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER JOBZ, RANGE, UPLO
+ INTEGER IL, INFO, ITYPE, IU, LDZ, M, N
+ DOUBLE PRECISION ABSTOL, VL, VU
+* ..
+* .. Array Arguments ..
+ INTEGER IFAIL( * ), IWORK( * )
+ DOUBLE PRECISION AP( * ), BP( * ), W( * ), WORK( * ),
+ $ Z( LDZ, * )
+* ..
+*
+* Purpose
+* =======
+*
+* DSPGVX computes selected eigenvalues, and optionally, eigenvectors
+* of a real generalized symmetric-definite eigenproblem, of the form
+* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A
+* and B are assumed to be symmetric, stored in packed storage, and B
+* is also positive definite. Eigenvalues and eigenvectors can be
+* selected by specifying either a range of values or a range of indices
+* for the desired eigenvalues.
+*
+* Arguments
+* =========
+*
+* ITYPE (input) INTEGER
+* Specifies the problem type to be solved:
+* = 1: A*x = (lambda)*B*x
+* = 2: A*B*x = (lambda)*x
+* = 3: B*A*x = (lambda)*x
+*
+* JOBZ (input) CHARACTER*1
+* = 'N': Compute eigenvalues only;
+* = 'V': Compute eigenvalues and eigenvectors.
+*
+* RANGE (input) CHARACTER*1
+* = 'A': all eigenvalues will be found.
+* = 'V': all eigenvalues in the half-open interval (VL,VU]
+* will be found.
+* = 'I': the IL-th through IU-th eigenvalues will be found.
+*
+* UPLO (input) CHARACTER*1
+* = 'U': Upper triangle of A and B are stored;
+* = 'L': Lower triangle of A and B are stored.
+*
+* N (input) INTEGER
+* The order of the matrix pencil (A,B). N >= 0.
+*
+* AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)
+* On entry, the upper or lower triangle of the symmetric matrix
+* A, packed columnwise in a linear array. The j-th column of A
+* is stored in the array AP as follows:
+* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
+* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
+*
+* On exit, the contents of AP are destroyed.
+*
+* BP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)
+* On entry, the upper or lower triangle of the symmetric matrix
+* B, packed columnwise in a linear array. The j-th column of B
+* is stored in the array BP as follows:
+* if UPLO = 'U', BP(i + (j-1)*j/2) = B(i,j) for 1<=i<=j;
+* if UPLO = 'L', BP(i + (j-1)*(2*n-j)/2) = B(i,j) for j<=i<=n.
+*
+* On exit, the triangular factor U or L from the Cholesky
+* factorization B = U**T*U or B = L*L**T, in the same storage
+* format as B.
+*
+* VL (input) DOUBLE PRECISION
+* VU (input) DOUBLE PRECISION
+* If RANGE='V', the lower and upper bounds of the interval to
+* be searched for eigenvalues. VL < VU.
+* Not referenced if RANGE = 'A' or 'I'.
+*
+* IL (input) INTEGER
+* IU (input) INTEGER
+* If RANGE='I', the indices (in ascending order) of the
+* smallest and largest eigenvalues to be returned.
+* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
+* Not referenced if RANGE = 'A' or 'V'.
+*
+* ABSTOL (input) DOUBLE PRECISION
+* The absolute error tolerance for the eigenvalues.
+* An approximate eigenvalue is accepted as converged
+* when it is determined to lie in an interval [a,b]
+* of width less than or equal to
+*
+* ABSTOL + EPS * max( |a|,|b| ) ,
+*
+* where EPS is the machine precision. If ABSTOL is less than
+* or equal to zero, then EPS*|T| will be used in its place,
+* where |T| is the 1-norm of the tridiagonal matrix obtained
+* by reducing A to tridiagonal form.
+*
+* Eigenvalues will be computed most accurately when ABSTOL is
+* set to twice the underflow threshold 2*DLAMCH('S'), not zero.
+* If this routine returns with INFO>0, indicating that some
+* eigenvectors did not converge, try setting ABSTOL to
+* 2*DLAMCH('S').
+*
+* M (output) INTEGER
+* The total number of eigenvalues found. 0 <= M <= N.
+* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
+*
+* W (output) DOUBLE PRECISION array, dimension (N)
+* On normal exit, the first M elements contain the selected
+* eigenvalues in ascending order.
+*
+* Z (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M))
+* If JOBZ = 'N', then Z is not referenced.
+* If JOBZ = 'V', then if INFO = 0, the first M columns of Z
+* contain the orthonormal eigenvectors of the matrix A
+* corresponding to the selected eigenvalues, with the i-th
+* column of Z holding the eigenvector associated with W(i).
+* The eigenvectors are normalized as follows:
+* if ITYPE = 1 or 2, Z**T*B*Z = I;
+* if ITYPE = 3, Z**T*inv(B)*Z = I.
+*
+* If an eigenvector fails to converge, then that column of Z
+* contains the latest approximation to the eigenvector, and the
+* index of the eigenvector is returned in IFAIL.
+* Note: the user must ensure that at least max(1,M) columns are
+* supplied in the array Z; if RANGE = 'V', the exact value of M
+* is not known in advance and an upper bound must be used.
+*
+* LDZ (input) INTEGER
+* The leading dimension of the array Z. LDZ >= 1, and if
+* JOBZ = 'V', LDZ >= max(1,N).
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (8*N)
+*
+* IWORK (workspace) INTEGER array, dimension (5*N)
+*
+* IFAIL (output) INTEGER array, dimension (N)
+* If JOBZ = 'V', then if INFO = 0, the first M elements of
+* IFAIL are zero. If INFO > 0, then IFAIL contains the
+* indices of the eigenvectors that failed to converge.
+* If JOBZ = 'N', then IFAIL is not referenced.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* > 0: DPPTRF or DSPEVX returned an error code:
+* <= N: if INFO = i, DSPEVX failed to converge;
+* i eigenvectors failed to converge. Their indices
+* are stored in array IFAIL.
+* > N: if INFO = N + i, for 1 <= i <= N, then the leading
+* minor of order i of B is not positive definite.
+* The factorization of B could not be completed and
+* no eigenvalues or eigenvectors were computed.
+*
+* Further Details
+* ===============
+*
+* Based on contributions by
+* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ LOGICAL ALLEIG, INDEIG, UPPER, VALEIG, WANTZ
+ CHARACTER TRANS
+ INTEGER J
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL DPPTRF, DSPEVX, DSPGST, DTPMV, DTPSV, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MIN
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ UPPER = LSAME( UPLO, 'U' )
+ WANTZ = LSAME( JOBZ, 'V' )
+ ALLEIG = LSAME( RANGE, 'A' )
+ VALEIG = LSAME( RANGE, 'V' )
+ INDEIG = LSAME( RANGE, 'I' )
+*
+ INFO = 0
+ IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN
+ INFO = -1
+ ELSE IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
+ INFO = -2
+ ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN
+ INFO = -3
+ ELSE IF( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN
+ INFO = -4
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -5
+ ELSE
+ IF( VALEIG ) THEN
+ IF( N.GT.0 .AND. VU.LE.VL ) THEN
+ INFO = -9
+ END IF
+ ELSE IF( INDEIG ) THEN
+ IF( IL.LT.1 ) THEN
+ INFO = -10
+ ELSE IF( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) THEN
+ INFO = -11
+ END IF
+ END IF
+ END IF
+ IF( INFO.EQ.0 ) THEN
+ IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
+ INFO = -16
+ END IF
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DSPGVX', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ M = 0
+ IF( N.EQ.0 )
+ $ RETURN
+*
+* Form a Cholesky factorization of B.
+*
+ CALL DPPTRF( UPLO, N, BP, INFO )
+ IF( INFO.NE.0 ) THEN
+ INFO = N + INFO
+ RETURN
+ END IF
+*
+* Transform problem to standard eigenvalue problem and solve.
+*
+ CALL DSPGST( ITYPE, UPLO, N, AP, BP, INFO )
+ CALL DSPEVX( JOBZ, RANGE, UPLO, N, AP, VL, VU, IL, IU, ABSTOL, M,
+ $ W, Z, LDZ, WORK, IWORK, IFAIL, INFO )
+*
+ IF( WANTZ ) THEN
+*
+* Backtransform eigenvectors to the original problem.
+*
+ IF( INFO.GT.0 )
+ $ M = INFO - 1
+ IF( ITYPE.EQ.1 .OR. ITYPE.EQ.2 ) THEN
+*
+* For A*x=(lambda)*B*x and A*B*x=(lambda)*x;
+* backtransform eigenvectors: x = inv(L)'*y or inv(U)*y
+*
+ IF( UPPER ) THEN
+ TRANS = 'N'
+ ELSE
+ TRANS = 'T'
+ END IF
+*
+ DO 10 J = 1, M
+ CALL DTPSV( UPLO, TRANS, 'Non-unit', N, BP, Z( 1, J ),
+ $ 1 )
+ 10 CONTINUE
+*
+ ELSE IF( ITYPE.EQ.3 ) THEN
+*
+* For B*A*x=(lambda)*x;
+* backtransform eigenvectors: x = L*y or U'*y
+*
+ IF( UPPER ) THEN
+ TRANS = 'T'
+ ELSE
+ TRANS = 'N'
+ END IF
+*
+ DO 20 J = 1, M
+ CALL DTPMV( UPLO, TRANS, 'Non-unit', N, BP, Z( 1, J ),
+ $ 1 )
+ 20 CONTINUE
+ END IF
+ END IF
+*
+ RETURN
+*
+* End of DSPGVX
+*
+ END
+ SUBROUTINE DSPRFS( UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, LDX,
+ $ FERR, BERR, WORK, IWORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH.
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, LDB, LDX, N, NRHS
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * ), IWORK( * )
+ DOUBLE PRECISION AFP( * ), AP( * ), B( LDB, * ), BERR( * ),
+ $ FERR( * ), WORK( * ), X( LDX, * )
+* ..
+*
+* Purpose
+* =======
+*
+* DSPRFS improves the computed solution to a system of linear
+* equations when the coefficient matrix is symmetric indefinite
+* and packed, and provides error bounds and backward error estimates
+* for the solution.
+*
+* Arguments
+* =========
+*
+* UPLO (input) CHARACTER*1
+* = 'U': Upper triangle of A is stored;
+* = 'L': Lower triangle of A is stored.
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* NRHS (input) INTEGER
+* The number of right hand sides, i.e., the number of columns
+* of the matrices B and X. NRHS >= 0.
+*
+* AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)
+* The upper or lower triangle of the symmetric matrix A, packed
+* columnwise in a linear array. The j-th column of A is stored
+* in the array AP as follows:
+* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
+* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
+*
+* AFP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)
+* The factored form of the matrix A. AFP contains the block
+* diagonal matrix D and the multipliers used to obtain the
+* factor U or L from the factorization A = U*D*U**T or
+* A = L*D*L**T as computed by DSPTRF, stored as a packed
+* triangular matrix.
+*
+* IPIV (input) INTEGER array, dimension (N)
+* Details of the interchanges and the block structure of D
+* as determined by DSPTRF.
+*
+* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS)
+* The right hand side matrix B.
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. LDB >= max(1,N).
+*
+* X (input/output) DOUBLE PRECISION array, dimension (LDX,NRHS)
+* On entry, the solution matrix X, as computed by DSPTRS.
+* On exit, the improved solution matrix X.
+*
+* LDX (input) INTEGER
+* The leading dimension of the array X. LDX >= max(1,N).
+*
+* FERR (output) DOUBLE PRECISION array, dimension (NRHS)
+* The estimated forward error bound for each solution vector
+* X(j) (the j-th column of the solution matrix X).
+* If XTRUE is the true solution corresponding to X(j), FERR(j)
+* is an estimated upper bound for the magnitude of the largest
+* element in (X(j) - XTRUE) divided by the magnitude of the
+* largest element in X(j). The estimate is as reliable as
+* the estimate for RCOND, and is almost always a slight
+* overestimate of the true error.
+*
+* BERR (output) DOUBLE PRECISION array, dimension (NRHS)
+* The componentwise relative backward error of each solution
+* vector X(j) (i.e., the smallest relative change in
+* any element of A or B that makes X(j) an exact solution).
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (3*N)
+*
+* IWORK (workspace) INTEGER array, dimension (N)
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+*
+* Internal Parameters
+* ===================
+*
+* ITMAX is the maximum number of steps of iterative refinement.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ INTEGER ITMAX
+ PARAMETER ( ITMAX = 5 )
+ DOUBLE PRECISION ZERO
+ PARAMETER ( ZERO = 0.0D+0 )
+ DOUBLE PRECISION ONE
+ PARAMETER ( ONE = 1.0D+0 )
+ DOUBLE PRECISION TWO
+ PARAMETER ( TWO = 2.0D+0 )
+ DOUBLE PRECISION THREE
+ PARAMETER ( THREE = 3.0D+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL UPPER
+ INTEGER COUNT, I, IK, J, K, KASE, KK, NZ
+ DOUBLE PRECISION EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK
+* ..
+* .. Local Arrays ..
+ INTEGER ISAVE( 3 )
+* ..
+* .. External Subroutines ..
+ EXTERNAL DAXPY, DCOPY, DLACN2, DSPMV, DSPTRS, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ DOUBLE PRECISION DLAMCH
+ EXTERNAL LSAME, DLAMCH
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( NRHS.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -8
+ ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
+ INFO = -10
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DSPRFS', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN
+ DO 10 J = 1, NRHS
+ FERR( J ) = ZERO
+ BERR( J ) = ZERO
+ 10 CONTINUE
+ RETURN
+ END IF
+*
+* NZ = maximum number of nonzero elements in each row of A, plus 1
+*
+ NZ = N + 1
+ EPS = DLAMCH( 'Epsilon' )
+ SAFMIN = DLAMCH( 'Safe minimum' )
+ SAFE1 = NZ*SAFMIN
+ SAFE2 = SAFE1 / EPS
+*
+* Do for each right hand side
+*
+ DO 140 J = 1, NRHS
+*
+ COUNT = 1
+ LSTRES = THREE
+ 20 CONTINUE
+*
+* Loop until stopping criterion is satisfied.
+*
+* Compute residual R = B - A * X
+*
+ CALL DCOPY( N, B( 1, J ), 1, WORK( N+1 ), 1 )
+ CALL DSPMV( UPLO, N, -ONE, AP, X( 1, J ), 1, ONE, WORK( N+1 ),
+ $ 1 )
+*
+* Compute componentwise relative backward error from formula
+*
+* max(i) ( abs(R(i)) / ( abs(A)*abs(X) + abs(B) )(i) )
+*
+* where abs(Z) is the componentwise absolute value of the matrix
+* or vector Z. If the i-th component of the denominator is less
+* than SAFE2, then SAFE1 is added to the i-th components of the
+* numerator and denominator before dividing.
+*
+ DO 30 I = 1, N
+ WORK( I ) = ABS( B( I, J ) )
+ 30 CONTINUE
+*
+* Compute abs(A)*abs(X) + abs(B).
+*
+ KK = 1
+ IF( UPPER ) THEN
+ DO 50 K = 1, N
+ S = ZERO
+ XK = ABS( X( K, J ) )
+ IK = KK
+ DO 40 I = 1, K - 1
+ WORK( I ) = WORK( I ) + ABS( AP( IK ) )*XK
+ S = S + ABS( AP( IK ) )*ABS( X( I, J ) )
+ IK = IK + 1
+ 40 CONTINUE
+ WORK( K ) = WORK( K ) + ABS( AP( KK+K-1 ) )*XK + S
+ KK = KK + K
+ 50 CONTINUE
+ ELSE
+ DO 70 K = 1, N
+ S = ZERO
+ XK = ABS( X( K, J ) )
+ WORK( K ) = WORK( K ) + ABS( AP( KK ) )*XK
+ IK = KK + 1
+ DO 60 I = K + 1, N
+ WORK( I ) = WORK( I ) + ABS( AP( IK ) )*XK
+ S = S + ABS( AP( IK ) )*ABS( X( I, J ) )
+ IK = IK + 1
+ 60 CONTINUE
+ WORK( K ) = WORK( K ) + S
+ KK = KK + ( N-K+1 )
+ 70 CONTINUE
+ END IF
+ S = ZERO
+ DO 80 I = 1, N
+ IF( WORK( I ).GT.SAFE2 ) THEN
+ S = MAX( S, ABS( WORK( N+I ) ) / WORK( I ) )
+ ELSE
+ S = MAX( S, ( ABS( WORK( N+I ) )+SAFE1 ) /
+ $ ( WORK( I )+SAFE1 ) )
+ END IF
+ 80 CONTINUE
+ BERR( J ) = S
+*
+* Test stopping criterion. Continue iterating if
+* 1) The residual BERR(J) is larger than machine epsilon, and
+* 2) BERR(J) decreased by at least a factor of 2 during the
+* last iteration, and
+* 3) At most ITMAX iterations tried.
+*
+ IF( BERR( J ).GT.EPS .AND. TWO*BERR( J ).LE.LSTRES .AND.
+ $ COUNT.LE.ITMAX ) THEN
+*
+* Update solution and try again.
+*
+ CALL DSPTRS( UPLO, N, 1, AFP, IPIV, WORK( N+1 ), N, INFO )
+ CALL DAXPY( N, ONE, WORK( N+1 ), 1, X( 1, J ), 1 )
+ LSTRES = BERR( J )
+ COUNT = COUNT + 1
+ GO TO 20
+ END IF
+*
+* Bound error from formula
+*
+* norm(X - XTRUE) / norm(X) .le. FERR =
+* norm( abs(inv(A))*
+* ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X)
+*
+* where
+* norm(Z) is the magnitude of the largest component of Z
+* inv(A) is the inverse of A
+* abs(Z) is the componentwise absolute value of the matrix or
+* vector Z
+* NZ is the maximum number of nonzeros in any row of A, plus 1
+* EPS is machine epsilon
+*
+* The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B))
+* is incremented by SAFE1 if the i-th component of
+* abs(A)*abs(X) + abs(B) is less than SAFE2.
+*
+* Use DLACN2 to estimate the infinity-norm of the matrix
+* inv(A) * diag(W),
+* where W = abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) )))
+*
+ DO 90 I = 1, N
+ IF( WORK( I ).GT.SAFE2 ) THEN
+ WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I )
+ ELSE
+ WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I ) + SAFE1
+ END IF
+ 90 CONTINUE
+*
+ KASE = 0
+ 100 CONTINUE
+ CALL DLACN2( N, WORK( 2*N+1 ), WORK( N+1 ), IWORK, FERR( J ),
+ $ KASE, ISAVE )
+ IF( KASE.NE.0 ) THEN
+ IF( KASE.EQ.1 ) THEN
+*
+* Multiply by diag(W)*inv(A').
+*
+ CALL DSPTRS( UPLO, N, 1, AFP, IPIV, WORK( N+1 ), N,
+ $ INFO )
+ DO 110 I = 1, N
+ WORK( N+I ) = WORK( I )*WORK( N+I )
+ 110 CONTINUE
+ ELSE IF( KASE.EQ.2 ) THEN
+*
+* Multiply by inv(A)*diag(W).
+*
+ DO 120 I = 1, N
+ WORK( N+I ) = WORK( I )*WORK( N+I )
+ 120 CONTINUE
+ CALL DSPTRS( UPLO, N, 1, AFP, IPIV, WORK( N+1 ), N,
+ $ INFO )
+ END IF
+ GO TO 100
+ END IF
+*
+* Normalize error.
+*
+ LSTRES = ZERO
+ DO 130 I = 1, N
+ LSTRES = MAX( LSTRES, ABS( X( I, J ) ) )
+ 130 CONTINUE
+ IF( LSTRES.NE.ZERO )
+ $ FERR( J ) = FERR( J ) / LSTRES
+*
+ 140 CONTINUE
+*
+ RETURN
+*
+* End of DSPRFS
+*
+ END
+ SUBROUTINE DSPSV( UPLO, N, NRHS, AP, IPIV, B, LDB, INFO )
+*
+* -- LAPACK driver routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, LDB, N, NRHS
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ DOUBLE PRECISION AP( * ), B( LDB, * )
+* ..
+*
+* Purpose
+* =======
+*
+* DSPSV computes the solution to a real system of linear equations
+* A * X = B,
+* where A is an N-by-N symmetric matrix stored in packed format and X
+* and B are N-by-NRHS matrices.
+*
+* The diagonal pivoting method is used to factor A as
+* A = U * D * U**T, if UPLO = 'U', or
+* A = L * D * L**T, if UPLO = 'L',
+* where U (or L) is a product of permutation and unit upper (lower)
+* triangular matrices, D is symmetric and block diagonal with 1-by-1
+* and 2-by-2 diagonal blocks. The factored form of A is then used to
+* solve the system of equations A * X = B.
+*
+* Arguments
+* =========
+*
+* UPLO (input) CHARACTER*1
+* = 'U': Upper triangle of A is stored;
+* = 'L': Lower triangle of A is stored.
+*
+* N (input) INTEGER
+* The number of linear equations, i.e., the order of the
+* matrix A. N >= 0.
+*
+* NRHS (input) INTEGER
+* The number of right hand sides, i.e., the number of columns
+* of the matrix B. NRHS >= 0.
+*
+* AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)
+* On entry, the upper or lower triangle of the symmetric matrix
+* A, packed columnwise in a linear array. The j-th column of A
+* is stored in the array AP as follows:
+* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
+* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
+* See below for further details.
+*
+* On exit, the block diagonal matrix D and the multipliers used
+* to obtain the factor U or L from the factorization
+* A = U*D*U**T or A = L*D*L**T as computed by DSPTRF, stored as
+* a packed triangular matrix in the same storage format as A.
+*
+* IPIV (output) INTEGER array, dimension (N)
+* Details of the interchanges and the block structure of D, as
+* determined by DSPTRF. If IPIV(k) > 0, then rows and columns
+* k and IPIV(k) were interchanged, and D(k,k) is a 1-by-1
+* diagonal block. If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0,
+* then rows and columns k-1 and -IPIV(k) were interchanged and
+* D(k-1:k,k-1:k) is a 2-by-2 diagonal block. If UPLO = 'L' and
+* IPIV(k) = IPIV(k+1) < 0, then rows and columns k+1 and
+* -IPIV(k) were interchanged and D(k:k+1,k:k+1) is a 2-by-2
+* diagonal block.
+*
+* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
+* On entry, the N-by-NRHS right hand side matrix B.
+* On exit, if INFO = 0, the N-by-NRHS solution matrix X.
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. LDB >= max(1,N).
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* > 0: if INFO = i, D(i,i) is exactly zero. The factorization
+* has been completed, but the block diagonal matrix D is
+* exactly singular, so the solution could not be
+* computed.
+*
+* Further Details
+* ===============
+*
+* The packed storage scheme is illustrated by the following example
+* when N = 4, UPLO = 'U':
+*
+* Two-dimensional storage of the symmetric matrix A:
+*
+* a11 a12 a13 a14
+* a22 a23 a24
+* a33 a34 (aij = aji)
+* a44
+*
+* Packed storage of the upper triangle of A:
+*
+* AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]
+*
+* =====================================================================
+*
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL DSPTRF, DSPTRS, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( NRHS.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -7
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DSPSV ', -INFO )
+ RETURN
+ END IF
+*
+* Compute the factorization A = U*D*U' or A = L*D*L'.
+*
+ CALL DSPTRF( UPLO, N, AP, IPIV, INFO )
+ IF( INFO.EQ.0 ) THEN
+*
+* Solve the system A*X = B, overwriting B with X.
+*
+ CALL DSPTRS( UPLO, N, NRHS, AP, IPIV, B, LDB, INFO )
+*
+ END IF
+ RETURN
+*
+* End of DSPSV
+*
+ END
+ SUBROUTINE DSPSVX( FACT, UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X,
+ $ LDX, RCOND, FERR, BERR, WORK, IWORK, INFO )
+*
+* -- LAPACK driver routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER FACT, UPLO
+ INTEGER INFO, LDB, LDX, N, NRHS
+ DOUBLE PRECISION RCOND
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * ), IWORK( * )
+ DOUBLE PRECISION AFP( * ), AP( * ), B( LDB, * ), BERR( * ),
+ $ FERR( * ), WORK( * ), X( LDX, * )
+* ..
+*
+* Purpose
+* =======
+*
+* DSPSVX uses the diagonal pivoting factorization A = U*D*U**T or
+* A = L*D*L**T to compute the solution to a real system of linear
+* equations A * X = B, where A is an N-by-N symmetric matrix stored
+* in packed format and X and B are N-by-NRHS matrices.
+*
+* Error bounds on the solution and a condition estimate are also
+* provided.
+*
+* Description
+* ===========
+*
+* The following steps are performed:
+*
+* 1. If FACT = 'N', the diagonal pivoting method is used to factor A as
+* A = U * D * U**T, if UPLO = 'U', or
+* A = L * D * L**T, if UPLO = 'L',
+* where U (or L) is a product of permutation and unit upper (lower)
+* triangular matrices and D is symmetric and block diagonal with
+* 1-by-1 and 2-by-2 diagonal blocks.
+*
+* 2. If some D(i,i)=0, so that D is exactly singular, then the routine
+* returns with INFO = i. Otherwise, the factored form of A is used
+* to estimate the condition number of the matrix A. If the
+* reciprocal of the condition number is less than machine precision,
+* INFO = N+1 is returned as a warning, but the routine still goes on
+* to solve for X and compute error bounds as described below.
+*
+* 3. The system of equations is solved for X using the factored form
+* of A.
+*
+* 4. Iterative refinement is applied to improve the computed solution
+* matrix and calculate error bounds and backward error estimates
+* for it.
+*
+* Arguments
+* =========
+*
+* FACT (input) CHARACTER*1
+* Specifies whether or not the factored form of A has been
+* supplied on entry.
+* = 'F': On entry, AFP and IPIV contain the factored form of
+* A. AP, AFP and IPIV will not be modified.
+* = 'N': The matrix A will be copied to AFP and factored.
+*
+* UPLO (input) CHARACTER*1
+* = 'U': Upper triangle of A is stored;
+* = 'L': Lower triangle of A is stored.
+*
+* N (input) INTEGER
+* The number of linear equations, i.e., the order of the
+* matrix A. N >= 0.
+*
+* NRHS (input) INTEGER
+* The number of right hand sides, i.e., the number of columns
+* of the matrices B and X. NRHS >= 0.
+*
+* AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)
+* The upper or lower triangle of the symmetric matrix A, packed
+* columnwise in a linear array. The j-th column of A is stored
+* in the array AP as follows:
+* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
+* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
+* See below for further details.
+*
+* AFP (input or output) DOUBLE PRECISION array, dimension
+* (N*(N+1)/2)
+* If FACT = 'F', then AFP is an input argument and on entry
+* contains the block diagonal matrix D and the multipliers used
+* to obtain the factor U or L from the factorization
+* A = U*D*U**T or A = L*D*L**T as computed by DSPTRF, stored as
+* a packed triangular matrix in the same storage format as A.
+*
+* If FACT = 'N', then AFP is an output argument and on exit
+* contains the block diagonal matrix D and the multipliers used
+* to obtain the factor U or L from the factorization
+* A = U*D*U**T or A = L*D*L**T as computed by DSPTRF, stored as
+* a packed triangular matrix in the same storage format as A.
+*
+* IPIV (input or output) INTEGER array, dimension (N)
+* If FACT = 'F', then IPIV is an input argument and on entry
+* contains details of the interchanges and the block structure
+* of D, as determined by DSPTRF.
+* If IPIV(k) > 0, then rows and columns k and IPIV(k) were
+* interchanged and D(k,k) is a 1-by-1 diagonal block.
+* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and
+* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)
+* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =
+* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were
+* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
+*
+* If FACT = 'N', then IPIV is an output argument and on exit
+* contains details of the interchanges and the block structure
+* of D, as determined by DSPTRF.
+*
+* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS)
+* The N-by-NRHS right hand side matrix B.
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. LDB >= max(1,N).
+*
+* X (output) DOUBLE PRECISION array, dimension (LDX,NRHS)
+* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X.
+*
+* LDX (input) INTEGER
+* The leading dimension of the array X. LDX >= max(1,N).
+*
+* RCOND (output) DOUBLE PRECISION
+* The estimate of the reciprocal condition number of the matrix
+* A. If RCOND is less than the machine precision (in
+* particular, if RCOND = 0), the matrix is singular to working
+* precision. This condition is indicated by a return code of
+* INFO > 0.
+*
+* FERR (output) DOUBLE PRECISION array, dimension (NRHS)
+* The estimated forward error bound for each solution vector
+* X(j) (the j-th column of the solution matrix X).
+* If XTRUE is the true solution corresponding to X(j), FERR(j)
+* is an estimated upper bound for the magnitude of the largest
+* element in (X(j) - XTRUE) divided by the magnitude of the
+* largest element in X(j). The estimate is as reliable as
+* the estimate for RCOND, and is almost always a slight
+* overestimate of the true error.
+*
+* BERR (output) DOUBLE PRECISION array, dimension (NRHS)
+* The componentwise relative backward error of each solution
+* vector X(j) (i.e., the smallest relative change in
+* any element of A or B that makes X(j) an exact solution).
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (3*N)
+*
+* IWORK (workspace) INTEGER array, dimension (N)
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* > 0: if INFO = i, and i is
+* <= N: D(i,i) is exactly zero. The factorization
+* has been completed but the factor D is exactly
+* singular, so the solution and error bounds could
+* not be computed. RCOND = 0 is returned.
+* = N+1: D is nonsingular, but RCOND is less than machine
+* precision, meaning that the matrix is singular
+* to working precision. Nevertheless, the
+* solution and error bounds are computed because
+* there are a number of situations where the
+* computed solution can be more accurate than the
+* value of RCOND would suggest.
+*
+* Further Details
+* ===============
+*
+* The packed storage scheme is illustrated by the following example
+* when N = 4, UPLO = 'U':
+*
+* Two-dimensional storage of the symmetric matrix A:
+*
+* a11 a12 a13 a14
+* a22 a23 a24
+* a33 a34 (aij = aji)
+* a44
+*
+* Packed storage of the upper triangle of A:
+*
+* AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO
+ PARAMETER ( ZERO = 0.0D+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL NOFACT
+ DOUBLE PRECISION ANORM
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ DOUBLE PRECISION DLAMCH, DLANSP
+ EXTERNAL LSAME, DLAMCH, DLANSP
+* ..
+* .. External Subroutines ..
+ EXTERNAL DCOPY, DLACPY, DSPCON, DSPRFS, DSPTRF, DSPTRS,
+ $ XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ NOFACT = LSAME( FACT, 'N' )
+ IF( .NOT.NOFACT .AND. .NOT.LSAME( FACT, 'F' ) ) THEN
+ INFO = -1
+ ELSE IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) )
+ $ THEN
+ INFO = -2
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( NRHS.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -9
+ ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
+ INFO = -11
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DSPSVX', -INFO )
+ RETURN
+ END IF
+*
+ IF( NOFACT ) THEN
+*
+* Compute the factorization A = U*D*U' or A = L*D*L'.
+*
+ CALL DCOPY( N*( N+1 ) / 2, AP, 1, AFP, 1 )
+ CALL DSPTRF( UPLO, N, AFP, IPIV, INFO )
+*
+* Return if INFO is non-zero.
+*
+ IF( INFO.GT.0 )THEN
+ RCOND = ZERO
+ RETURN
+ END IF
+ END IF
+*
+* Compute the norm of the matrix A.
+*
+ ANORM = DLANSP( 'I', UPLO, N, AP, WORK )
+*
+* Compute the reciprocal of the condition number of A.
+*
+ CALL DSPCON( UPLO, N, AFP, IPIV, ANORM, RCOND, WORK, IWORK, INFO )
+*
+* Compute the solution vectors X.
+*
+ CALL DLACPY( 'Full', N, NRHS, B, LDB, X, LDX )
+ CALL DSPTRS( UPLO, N, NRHS, AFP, IPIV, X, LDX, INFO )
+*
+* Use iterative refinement to improve the computed solutions and
+* compute error bounds and backward error estimates for them.
+*
+ CALL DSPRFS( UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, LDX, FERR,
+ $ BERR, WORK, IWORK, INFO )
+*
+* Set INFO = N+1 if the matrix is singular to working precision.
+*
+ IF( RCOND.LT.DLAMCH( 'Epsilon' ) )
+ $ INFO = N + 1
+*
+ RETURN
+*
+* End of DSPSVX
+*
+ END
+ SUBROUTINE DSPTRD( UPLO, N, AP, D, E, TAU, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, N
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION AP( * ), D( * ), E( * ), TAU( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DSPTRD reduces a real symmetric matrix A stored in packed form to
+* symmetric tridiagonal form T by an orthogonal similarity
+* transformation: Q**T * A * Q = T.
+*
+* Arguments
+* =========
+*
+* UPLO (input) CHARACTER*1
+* = 'U': Upper triangle of A is stored;
+* = 'L': Lower triangle of A is stored.
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)
+* On entry, the upper or lower triangle of the symmetric matrix
+* A, packed columnwise in a linear array. The j-th column of A
+* is stored in the array AP as follows:
+* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
+* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
+* On exit, if UPLO = 'U', the diagonal and first superdiagonal
+* of A are overwritten by the corresponding elements of the
+* tridiagonal matrix T, and the elements above the first
+* superdiagonal, with the array TAU, represent the orthogonal
+* matrix Q as a product of elementary reflectors; if UPLO
+* = 'L', the diagonal and first subdiagonal of A are over-
+* written by the corresponding elements of the tridiagonal
+* matrix T, and the elements below the first subdiagonal, with
+* the array TAU, represent the orthogonal matrix Q as a product
+* of elementary reflectors. See Further Details.
+*
+* D (output) DOUBLE PRECISION array, dimension (N)
+* The diagonal elements of the tridiagonal matrix T:
+* D(i) = A(i,i).
+*
+* E (output) DOUBLE PRECISION array, dimension (N-1)
+* The off-diagonal elements of the tridiagonal matrix T:
+* E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'.
+*
+* TAU (output) DOUBLE PRECISION array, dimension (N-1)
+* The scalar factors of the elementary reflectors (see Further
+* Details).
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+*
+* Further Details
+* ===============
+*
+* If UPLO = 'U', the matrix Q is represented as a product of elementary
+* reflectors
+*
+* Q = H(n-1) . . . H(2) H(1).
+*
+* Each H(i) has the form
+*
+* H(i) = I - tau * v * v'
+*
+* where tau is a real scalar, and v is a real vector with
+* v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in AP,
+* overwriting A(1:i-1,i+1), and tau is stored in TAU(i).
+*
+* If UPLO = 'L', the matrix Q is represented as a product of elementary
+* reflectors
+*
+* Q = H(1) H(2) . . . H(n-1).
+*
+* Each H(i) has the form
+*
+* H(i) = I - tau * v * v'
+*
+* where tau is a real scalar, and v is a real vector with
+* v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in AP,
+* overwriting A(i+2:n,i), and tau is stored in TAU(i).
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE, ZERO, HALF
+ PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0,
+ $ HALF = 1.0D0 / 2.0D0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL UPPER
+ INTEGER I, I1, I1I1, II
+ DOUBLE PRECISION ALPHA, TAUI
+* ..
+* .. External Subroutines ..
+ EXTERNAL DAXPY, DLARFG, DSPMV, DSPR2, XERBLA
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ DOUBLE PRECISION DDOT
+ EXTERNAL LSAME, DDOT
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DSPTRD', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.LE.0 )
+ $ RETURN
+*
+ IF( UPPER ) THEN
+*
+* Reduce the upper triangle of A.
+* I1 is the index in AP of A(1,I+1).
+*
+ I1 = N*( N-1 ) / 2 + 1
+ DO 10 I = N - 1, 1, -1
+*
+* Generate elementary reflector H(i) = I - tau * v * v'
+* to annihilate A(1:i-1,i+1)
+*
+ CALL DLARFG( I, AP( I1+I-1 ), AP( I1 ), 1, TAUI )
+ E( I ) = AP( I1+I-1 )
+*
+ IF( TAUI.NE.ZERO ) THEN
+*
+* Apply H(i) from both sides to A(1:i,1:i)
+*
+ AP( I1+I-1 ) = ONE
+*
+* Compute y := tau * A * v storing y in TAU(1:i)
+*
+ CALL DSPMV( UPLO, I, TAUI, AP, AP( I1 ), 1, ZERO, TAU,
+ $ 1 )
+*
+* Compute w := y - 1/2 * tau * (y'*v) * v
+*
+ ALPHA = -HALF*TAUI*DDOT( I, TAU, 1, AP( I1 ), 1 )
+ CALL DAXPY( I, ALPHA, AP( I1 ), 1, TAU, 1 )
+*
+* Apply the transformation as a rank-2 update:
+* A := A - v * w' - w * v'
+*
+ CALL DSPR2( UPLO, I, -ONE, AP( I1 ), 1, TAU, 1, AP )
+*
+ AP( I1+I-1 ) = E( I )
+ END IF
+ D( I+1 ) = AP( I1+I )
+ TAU( I ) = TAUI
+ I1 = I1 - I
+ 10 CONTINUE
+ D( 1 ) = AP( 1 )
+ ELSE
+*
+* Reduce the lower triangle of A. II is the index in AP of
+* A(i,i) and I1I1 is the index of A(i+1,i+1).
+*
+ II = 1
+ DO 20 I = 1, N - 1
+ I1I1 = II + N - I + 1
+*
+* Generate elementary reflector H(i) = I - tau * v * v'
+* to annihilate A(i+2:n,i)
+*
+ CALL DLARFG( N-I, AP( II+1 ), AP( II+2 ), 1, TAUI )
+ E( I ) = AP( II+1 )
+*
+ IF( TAUI.NE.ZERO ) THEN
+*
+* Apply H(i) from both sides to A(i+1:n,i+1:n)
+*
+ AP( II+1 ) = ONE
+*
+* Compute y := tau * A * v storing y in TAU(i:n-1)
+*
+ CALL DSPMV( UPLO, N-I, TAUI, AP( I1I1 ), AP( II+1 ), 1,
+ $ ZERO, TAU( I ), 1 )
+*
+* Compute w := y - 1/2 * tau * (y'*v) * v
+*
+ ALPHA = -HALF*TAUI*DDOT( N-I, TAU( I ), 1, AP( II+1 ),
+ $ 1 )
+ CALL DAXPY( N-I, ALPHA, AP( II+1 ), 1, TAU( I ), 1 )
+*
+* Apply the transformation as a rank-2 update:
+* A := A - v * w' - w * v'
+*
+ CALL DSPR2( UPLO, N-I, -ONE, AP( II+1 ), 1, TAU( I ), 1,
+ $ AP( I1I1 ) )
+*
+ AP( II+1 ) = E( I )
+ END IF
+ D( I ) = AP( II )
+ TAU( I ) = TAUI
+ II = I1I1
+ 20 CONTINUE
+ D( N ) = AP( II )
+ END IF
+*
+ RETURN
+*
+* End of DSPTRD
+*
+ END
+ SUBROUTINE DSPTRF( UPLO, N, AP, IPIV, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, N
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ DOUBLE PRECISION AP( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DSPTRF computes the factorization of a real symmetric matrix A stored
+* in packed format using the Bunch-Kaufman diagonal pivoting method:
+*
+* A = U*D*U**T or A = L*D*L**T
+*
+* where U (or L) is a product of permutation and unit upper (lower)
+* triangular matrices, and D is symmetric and block diagonal with
+* 1-by-1 and 2-by-2 diagonal blocks.
+*
+* Arguments
+* =========
+*
+* UPLO (input) CHARACTER*1
+* = 'U': Upper triangle of A is stored;
+* = 'L': Lower triangle of A is stored.
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)
+* On entry, the upper or lower triangle of the symmetric matrix
+* A, packed columnwise in a linear array. The j-th column of A
+* is stored in the array AP as follows:
+* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
+* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
+*
+* On exit, the block diagonal matrix D and the multipliers used
+* to obtain the factor U or L, stored as a packed triangular
+* matrix overwriting A (see below for further details).
+*
+* IPIV (output) INTEGER array, dimension (N)
+* Details of the interchanges and the block structure of D.
+* If IPIV(k) > 0, then rows and columns k and IPIV(k) were
+* interchanged and D(k,k) is a 1-by-1 diagonal block.
+* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and
+* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)
+* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =
+* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were
+* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* > 0: if INFO = i, D(i,i) is exactly zero. The factorization
+* has been completed, but the block diagonal matrix D is
+* exactly singular, and division by zero will occur if it
+* is used to solve a system of equations.
+*
+* Further Details
+* ===============
+*
+* 5-96 - Based on modifications by J. Lewis, Boeing Computer Services
+* Company
+*
+* If UPLO = 'U', then A = U*D*U', where
+* U = P(n)*U(n)* ... *P(k)U(k)* ...,
+* i.e., U is a product of terms P(k)*U(k), where k decreases from n to
+* 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1
+* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as
+* defined by IPIV(k), and U(k) is a unit upper triangular matrix, such
+* that if the diagonal block D(k) is of order s (s = 1 or 2), then
+*
+* ( I v 0 ) k-s
+* U(k) = ( 0 I 0 ) s
+* ( 0 0 I ) n-k
+* k-s s n-k
+*
+* If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k).
+* If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k),
+* and A(k,k), and v overwrites A(1:k-2,k-1:k).
+*
+* If UPLO = 'L', then A = L*D*L', where
+* L = P(1)*L(1)* ... *P(k)*L(k)* ...,
+* i.e., L is a product of terms P(k)*L(k), where k increases from 1 to
+* n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1
+* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as
+* defined by IPIV(k), and L(k) is a unit lower triangular matrix, such
+* that if the diagonal block D(k) is of order s (s = 1 or 2), then
+*
+* ( I 0 0 ) k-1
+* L(k) = ( 0 I 0 ) s
+* ( 0 v I ) n-k-s+1
+* k-1 s n-k-s+1
+*
+* If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k).
+* If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k),
+* and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1).
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+ DOUBLE PRECISION EIGHT, SEVTEN
+ PARAMETER ( EIGHT = 8.0D+0, SEVTEN = 17.0D+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL UPPER
+ INTEGER I, IMAX, J, JMAX, K, KC, KK, KNC, KP, KPC,
+ $ KSTEP, KX, NPP
+ DOUBLE PRECISION ABSAKK, ALPHA, COLMAX, D11, D12, D21, D22, R1,
+ $ ROWMAX, T, WK, WKM1, WKP1
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER IDAMAX
+ EXTERNAL LSAME, IDAMAX
+* ..
+* .. External Subroutines ..
+ EXTERNAL DSCAL, DSPR, DSWAP, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, SQRT
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DSPTRF', -INFO )
+ RETURN
+ END IF
+*
+* Initialize ALPHA for use in choosing pivot block size.
+*
+ ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT
+*
+ IF( UPPER ) THEN
+*
+* Factorize A as U*D*U' using the upper triangle of A
+*
+* K is the main loop index, decreasing from N to 1 in steps of
+* 1 or 2
+*
+ K = N
+ KC = ( N-1 )*N / 2 + 1
+ 10 CONTINUE
+ KNC = KC
+*
+* If K < 1, exit from loop
+*
+ IF( K.LT.1 )
+ $ GO TO 110
+ KSTEP = 1
+*
+* Determine rows and columns to be interchanged and whether
+* a 1-by-1 or 2-by-2 pivot block will be used
+*
+ ABSAKK = ABS( AP( KC+K-1 ) )
+*
+* IMAX is the row-index of the largest off-diagonal element in
+* column K, and COLMAX is its absolute value
+*
+ IF( K.GT.1 ) THEN
+ IMAX = IDAMAX( K-1, AP( KC ), 1 )
+ COLMAX = ABS( AP( KC+IMAX-1 ) )
+ ELSE
+ COLMAX = ZERO
+ END IF
+*
+ IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN
+*
+* Column K is zero: set INFO and continue
+*
+ IF( INFO.EQ.0 )
+ $ INFO = K
+ KP = K
+ ELSE
+ IF( ABSAKK.GE.ALPHA*COLMAX ) THEN
+*
+* no interchange, use 1-by-1 pivot block
+*
+ KP = K
+ ELSE
+*
+* JMAX is the column-index of the largest off-diagonal
+* element in row IMAX, and ROWMAX is its absolute value
+*
+ ROWMAX = ZERO
+ JMAX = IMAX
+ KX = IMAX*( IMAX+1 ) / 2 + IMAX
+ DO 20 J = IMAX + 1, K
+ IF( ABS( AP( KX ) ).GT.ROWMAX ) THEN
+ ROWMAX = ABS( AP( KX ) )
+ JMAX = J
+ END IF
+ KX = KX + J
+ 20 CONTINUE
+ KPC = ( IMAX-1 )*IMAX / 2 + 1
+ IF( IMAX.GT.1 ) THEN
+ JMAX = IDAMAX( IMAX-1, AP( KPC ), 1 )
+ ROWMAX = MAX( ROWMAX, ABS( AP( KPC+JMAX-1 ) ) )
+ END IF
+*
+ IF( ABSAKK.GE.ALPHA*COLMAX*( COLMAX / ROWMAX ) ) THEN
+*
+* no interchange, use 1-by-1 pivot block
+*
+ KP = K
+ ELSE IF( ABS( AP( KPC+IMAX-1 ) ).GE.ALPHA*ROWMAX ) THEN
+*
+* interchange rows and columns K and IMAX, use 1-by-1
+* pivot block
+*
+ KP = IMAX
+ ELSE
+*
+* interchange rows and columns K-1 and IMAX, use 2-by-2
+* pivot block
+*
+ KP = IMAX
+ KSTEP = 2
+ END IF
+ END IF
+*
+ KK = K - KSTEP + 1
+ IF( KSTEP.EQ.2 )
+ $ KNC = KNC - K + 1
+ IF( KP.NE.KK ) THEN
+*
+* Interchange rows and columns KK and KP in the leading
+* submatrix A(1:k,1:k)
+*
+ CALL DSWAP( KP-1, AP( KNC ), 1, AP( KPC ), 1 )
+ KX = KPC + KP - 1
+ DO 30 J = KP + 1, KK - 1
+ KX = KX + J - 1
+ T = AP( KNC+J-1 )
+ AP( KNC+J-1 ) = AP( KX )
+ AP( KX ) = T
+ 30 CONTINUE
+ T = AP( KNC+KK-1 )
+ AP( KNC+KK-1 ) = AP( KPC+KP-1 )
+ AP( KPC+KP-1 ) = T
+ IF( KSTEP.EQ.2 ) THEN
+ T = AP( KC+K-2 )
+ AP( KC+K-2 ) = AP( KC+KP-1 )
+ AP( KC+KP-1 ) = T
+ END IF
+ END IF
+*
+* Update the leading submatrix
+*
+ IF( KSTEP.EQ.1 ) THEN
+*
+* 1-by-1 pivot block D(k): column k now holds
+*
+* W(k) = U(k)*D(k)
+*
+* where U(k) is the k-th column of U
+*
+* Perform a rank-1 update of A(1:k-1,1:k-1) as
+*
+* A := A - U(k)*D(k)*U(k)' = A - W(k)*1/D(k)*W(k)'
+*
+ R1 = ONE / AP( KC+K-1 )
+ CALL DSPR( UPLO, K-1, -R1, AP( KC ), 1, AP )
+*
+* Store U(k) in column k
+*
+ CALL DSCAL( K-1, R1, AP( KC ), 1 )
+ ELSE
+*
+* 2-by-2 pivot block D(k): columns k and k-1 now hold
+*
+* ( W(k-1) W(k) ) = ( U(k-1) U(k) )*D(k)
+*
+* where U(k) and U(k-1) are the k-th and (k-1)-th columns
+* of U
+*
+* Perform a rank-2 update of A(1:k-2,1:k-2) as
+*
+* A := A - ( U(k-1) U(k) )*D(k)*( U(k-1) U(k) )'
+* = A - ( W(k-1) W(k) )*inv(D(k))*( W(k-1) W(k) )'
+*
+ IF( K.GT.2 ) THEN
+*
+ D12 = AP( K-1+( K-1 )*K / 2 )
+ D22 = AP( K-1+( K-2 )*( K-1 ) / 2 ) / D12
+ D11 = AP( K+( K-1 )*K / 2 ) / D12
+ T = ONE / ( D11*D22-ONE )
+ D12 = T / D12
+*
+ DO 50 J = K - 2, 1, -1
+ WKM1 = D12*( D11*AP( J+( K-2 )*( K-1 ) / 2 )-
+ $ AP( J+( K-1 )*K / 2 ) )
+ WK = D12*( D22*AP( J+( K-1 )*K / 2 )-
+ $ AP( J+( K-2 )*( K-1 ) / 2 ) )
+ DO 40 I = J, 1, -1
+ AP( I+( J-1 )*J / 2 ) = AP( I+( J-1 )*J / 2 ) -
+ $ AP( I+( K-1 )*K / 2 )*WK -
+ $ AP( I+( K-2 )*( K-1 ) / 2 )*WKM1
+ 40 CONTINUE
+ AP( J+( K-1 )*K / 2 ) = WK
+ AP( J+( K-2 )*( K-1 ) / 2 ) = WKM1
+ 50 CONTINUE
+*
+ END IF
+*
+ END IF
+ END IF
+*
+* Store details of the interchanges in IPIV
+*
+ IF( KSTEP.EQ.1 ) THEN
+ IPIV( K ) = KP
+ ELSE
+ IPIV( K ) = -KP
+ IPIV( K-1 ) = -KP
+ END IF
+*
+* Decrease K and return to the start of the main loop
+*
+ K = K - KSTEP
+ KC = KNC - K
+ GO TO 10
+*
+ ELSE
+*
+* Factorize A as L*D*L' using the lower triangle of A
+*
+* K is the main loop index, increasing from 1 to N in steps of
+* 1 or 2
+*
+ K = 1
+ KC = 1
+ NPP = N*( N+1 ) / 2
+ 60 CONTINUE
+ KNC = KC
+*
+* If K > N, exit from loop
+*
+ IF( K.GT.N )
+ $ GO TO 110
+ KSTEP = 1
+*
+* Determine rows and columns to be interchanged and whether
+* a 1-by-1 or 2-by-2 pivot block will be used
+*
+ ABSAKK = ABS( AP( KC ) )
+*
+* IMAX is the row-index of the largest off-diagonal element in
+* column K, and COLMAX is its absolute value
+*
+ IF( K.LT.N ) THEN
+ IMAX = K + IDAMAX( N-K, AP( KC+1 ), 1 )
+ COLMAX = ABS( AP( KC+IMAX-K ) )
+ ELSE
+ COLMAX = ZERO
+ END IF
+*
+ IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN
+*
+* Column K is zero: set INFO and continue
+*
+ IF( INFO.EQ.0 )
+ $ INFO = K
+ KP = K
+ ELSE
+ IF( ABSAKK.GE.ALPHA*COLMAX ) THEN
+*
+* no interchange, use 1-by-1 pivot block
+*
+ KP = K
+ ELSE
+*
+* JMAX is the column-index of the largest off-diagonal
+* element in row IMAX, and ROWMAX is its absolute value
+*
+ ROWMAX = ZERO
+ KX = KC + IMAX - K
+ DO 70 J = K, IMAX - 1
+ IF( ABS( AP( KX ) ).GT.ROWMAX ) THEN
+ ROWMAX = ABS( AP( KX ) )
+ JMAX = J
+ END IF
+ KX = KX + N - J
+ 70 CONTINUE
+ KPC = NPP - ( N-IMAX+1 )*( N-IMAX+2 ) / 2 + 1
+ IF( IMAX.LT.N ) THEN
+ JMAX = IMAX + IDAMAX( N-IMAX, AP( KPC+1 ), 1 )
+ ROWMAX = MAX( ROWMAX, ABS( AP( KPC+JMAX-IMAX ) ) )
+ END IF
+*
+ IF( ABSAKK.GE.ALPHA*COLMAX*( COLMAX / ROWMAX ) ) THEN
+*
+* no interchange, use 1-by-1 pivot block
+*
+ KP = K
+ ELSE IF( ABS( AP( KPC ) ).GE.ALPHA*ROWMAX ) THEN
+*
+* interchange rows and columns K and IMAX, use 1-by-1
+* pivot block
+*
+ KP = IMAX
+ ELSE
+*
+* interchange rows and columns K+1 and IMAX, use 2-by-2
+* pivot block
+*
+ KP = IMAX
+ KSTEP = 2
+ END IF
+ END IF
+*
+ KK = K + KSTEP - 1
+ IF( KSTEP.EQ.2 )
+ $ KNC = KNC + N - K + 1
+ IF( KP.NE.KK ) THEN
+*
+* Interchange rows and columns KK and KP in the trailing
+* submatrix A(k:n,k:n)
+*
+ IF( KP.LT.N )
+ $ CALL DSWAP( N-KP, AP( KNC+KP-KK+1 ), 1, AP( KPC+1 ),
+ $ 1 )
+ KX = KNC + KP - KK
+ DO 80 J = KK + 1, KP - 1
+ KX = KX + N - J + 1
+ T = AP( KNC+J-KK )
+ AP( KNC+J-KK ) = AP( KX )
+ AP( KX ) = T
+ 80 CONTINUE
+ T = AP( KNC )
+ AP( KNC ) = AP( KPC )
+ AP( KPC ) = T
+ IF( KSTEP.EQ.2 ) THEN
+ T = AP( KC+1 )
+ AP( KC+1 ) = AP( KC+KP-K )
+ AP( KC+KP-K ) = T
+ END IF
+ END IF
+*
+* Update the trailing submatrix
+*
+ IF( KSTEP.EQ.1 ) THEN
+*
+* 1-by-1 pivot block D(k): column k now holds
+*
+* W(k) = L(k)*D(k)
+*
+* where L(k) is the k-th column of L
+*
+ IF( K.LT.N ) THEN
+*
+* Perform a rank-1 update of A(k+1:n,k+1:n) as
+*
+* A := A - L(k)*D(k)*L(k)' = A - W(k)*(1/D(k))*W(k)'
+*
+ R1 = ONE / AP( KC )
+ CALL DSPR( UPLO, N-K, -R1, AP( KC+1 ), 1,
+ $ AP( KC+N-K+1 ) )
+*
+* Store L(k) in column K
+*
+ CALL DSCAL( N-K, R1, AP( KC+1 ), 1 )
+ END IF
+ ELSE
+*
+* 2-by-2 pivot block D(k): columns K and K+1 now hold
+*
+* ( W(k) W(k+1) ) = ( L(k) L(k+1) )*D(k)
+*
+* where L(k) and L(k+1) are the k-th and (k+1)-th columns
+* of L
+*
+ IF( K.LT.N-1 ) THEN
+*
+* Perform a rank-2 update of A(k+2:n,k+2:n) as
+*
+* A := A - ( L(k) L(k+1) )*D(k)*( L(k) L(k+1) )'
+* = A - ( W(k) W(k+1) )*inv(D(k))*( W(k) W(k+1) )'
+*
+ D21 = AP( K+1+( K-1 )*( 2*N-K ) / 2 )
+ D11 = AP( K+1+K*( 2*N-K-1 ) / 2 ) / D21
+ D22 = AP( K+( K-1 )*( 2*N-K ) / 2 ) / D21
+ T = ONE / ( D11*D22-ONE )
+ D21 = T / D21
+*
+ DO 100 J = K + 2, N
+ WK = D21*( D11*AP( J+( K-1 )*( 2*N-K ) / 2 )-
+ $ AP( J+K*( 2*N-K-1 ) / 2 ) )
+ WKP1 = D21*( D22*AP( J+K*( 2*N-K-1 ) / 2 )-
+ $ AP( J+( K-1 )*( 2*N-K ) / 2 ) )
+*
+ DO 90 I = J, N
+ AP( I+( J-1 )*( 2*N-J ) / 2 ) = AP( I+( J-1 )*
+ $ ( 2*N-J ) / 2 ) - AP( I+( K-1 )*( 2*N-K ) /
+ $ 2 )*WK - AP( I+K*( 2*N-K-1 ) / 2 )*WKP1
+ 90 CONTINUE
+*
+ AP( J+( K-1 )*( 2*N-K ) / 2 ) = WK
+ AP( J+K*( 2*N-K-1 ) / 2 ) = WKP1
+*
+ 100 CONTINUE
+ END IF
+ END IF
+ END IF
+*
+* Store details of the interchanges in IPIV
+*
+ IF( KSTEP.EQ.1 ) THEN
+ IPIV( K ) = KP
+ ELSE
+ IPIV( K ) = -KP
+ IPIV( K+1 ) = -KP
+ END IF
+*
+* Increase K and return to the start of the main loop
+*
+ K = K + KSTEP
+ KC = KNC + N - K + 2
+ GO TO 60
+*
+ END IF
+*
+ 110 CONTINUE
+ RETURN
+*
+* End of DSPTRF
+*
+ END
+ SUBROUTINE DSPTRI( UPLO, N, AP, IPIV, WORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, N
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ DOUBLE PRECISION AP( * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DSPTRI computes the inverse of a real symmetric indefinite matrix
+* A in packed storage using the factorization A = U*D*U**T or
+* A = L*D*L**T computed by DSPTRF.
+*
+* Arguments
+* =========
+*
+* UPLO (input) CHARACTER*1
+* Specifies whether the details of the factorization are stored
+* as an upper or lower triangular matrix.
+* = 'U': Upper triangular, form is A = U*D*U**T;
+* = 'L': Lower triangular, form is A = L*D*L**T.
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)
+* On entry, the block diagonal matrix D and the multipliers
+* used to obtain the factor U or L as computed by DSPTRF,
+* stored as a packed triangular matrix.
+*
+* On exit, if INFO = 0, the (symmetric) inverse of the original
+* matrix, stored as a packed triangular matrix. The j-th column
+* of inv(A) is stored in the array AP as follows:
+* if UPLO = 'U', AP(i + (j-1)*j/2) = inv(A)(i,j) for 1<=i<=j;
+* if UPLO = 'L',
+* AP(i + (j-1)*(2n-j)/2) = inv(A)(i,j) for j<=i<=n.
+*
+* IPIV (input) INTEGER array, dimension (N)
+* Details of the interchanges and the block structure of D
+* as determined by DSPTRF.
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (N)
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its
+* inverse could not be computed.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE, ZERO
+ PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL UPPER
+ INTEGER J, K, KC, KCNEXT, KP, KPC, KSTEP, KX, NPP
+ DOUBLE PRECISION AK, AKKP1, AKP1, D, T, TEMP
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ DOUBLE PRECISION DDOT
+ EXTERNAL LSAME, DDOT
+* ..
+* .. External Subroutines ..
+ EXTERNAL DCOPY, DSPMV, DSWAP, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DSPTRI', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+* Check that the diagonal matrix D is nonsingular.
+*
+ IF( UPPER ) THEN
+*
+* Upper triangular storage: examine D from bottom to top
+*
+ KP = N*( N+1 ) / 2
+ DO 10 INFO = N, 1, -1
+ IF( IPIV( INFO ).GT.0 .AND. AP( KP ).EQ.ZERO )
+ $ RETURN
+ KP = KP - INFO
+ 10 CONTINUE
+ ELSE
+*
+* Lower triangular storage: examine D from top to bottom.
+*
+ KP = 1
+ DO 20 INFO = 1, N
+ IF( IPIV( INFO ).GT.0 .AND. AP( KP ).EQ.ZERO )
+ $ RETURN
+ KP = KP + N - INFO + 1
+ 20 CONTINUE
+ END IF
+ INFO = 0
+*
+ IF( UPPER ) THEN
+*
+* Compute inv(A) from the factorization A = U*D*U'.
+*
+* K is the main loop index, increasing from 1 to N in steps of
+* 1 or 2, depending on the size of the diagonal blocks.
+*
+ K = 1
+ KC = 1
+ 30 CONTINUE
+*
+* If K > N, exit from loop.
+*
+ IF( K.GT.N )
+ $ GO TO 50
+*
+ KCNEXT = KC + K
+ IF( IPIV( K ).GT.0 ) THEN
+*
+* 1 x 1 diagonal block
+*
+* Invert the diagonal block.
+*
+ AP( KC+K-1 ) = ONE / AP( KC+K-1 )
+*
+* Compute column K of the inverse.
+*
+ IF( K.GT.1 ) THEN
+ CALL DCOPY( K-1, AP( KC ), 1, WORK, 1 )
+ CALL DSPMV( UPLO, K-1, -ONE, AP, WORK, 1, ZERO, AP( KC ),
+ $ 1 )
+ AP( KC+K-1 ) = AP( KC+K-1 ) -
+ $ DDOT( K-1, WORK, 1, AP( KC ), 1 )
+ END IF
+ KSTEP = 1
+ ELSE
+*
+* 2 x 2 diagonal block
+*
+* Invert the diagonal block.
+*
+ T = ABS( AP( KCNEXT+K-1 ) )
+ AK = AP( KC+K-1 ) / T
+ AKP1 = AP( KCNEXT+K ) / T
+ AKKP1 = AP( KCNEXT+K-1 ) / T
+ D = T*( AK*AKP1-ONE )
+ AP( KC+K-1 ) = AKP1 / D
+ AP( KCNEXT+K ) = AK / D
+ AP( KCNEXT+K-1 ) = -AKKP1 / D
+*
+* Compute columns K and K+1 of the inverse.
+*
+ IF( K.GT.1 ) THEN
+ CALL DCOPY( K-1, AP( KC ), 1, WORK, 1 )
+ CALL DSPMV( UPLO, K-1, -ONE, AP, WORK, 1, ZERO, AP( KC ),
+ $ 1 )
+ AP( KC+K-1 ) = AP( KC+K-1 ) -
+ $ DDOT( K-1, WORK, 1, AP( KC ), 1 )
+ AP( KCNEXT+K-1 ) = AP( KCNEXT+K-1 ) -
+ $ DDOT( K-1, AP( KC ), 1, AP( KCNEXT ),
+ $ 1 )
+ CALL DCOPY( K-1, AP( KCNEXT ), 1, WORK, 1 )
+ CALL DSPMV( UPLO, K-1, -ONE, AP, WORK, 1, ZERO,
+ $ AP( KCNEXT ), 1 )
+ AP( KCNEXT+K ) = AP( KCNEXT+K ) -
+ $ DDOT( K-1, WORK, 1, AP( KCNEXT ), 1 )
+ END IF
+ KSTEP = 2
+ KCNEXT = KCNEXT + K + 1
+ END IF
+*
+ KP = ABS( IPIV( K ) )
+ IF( KP.NE.K ) THEN
+*
+* Interchange rows and columns K and KP in the leading
+* submatrix A(1:k+1,1:k+1)
+*
+ KPC = ( KP-1 )*KP / 2 + 1
+ CALL DSWAP( KP-1, AP( KC ), 1, AP( KPC ), 1 )
+ KX = KPC + KP - 1
+ DO 40 J = KP + 1, K - 1
+ KX = KX + J - 1
+ TEMP = AP( KC+J-1 )
+ AP( KC+J-1 ) = AP( KX )
+ AP( KX ) = TEMP
+ 40 CONTINUE
+ TEMP = AP( KC+K-1 )
+ AP( KC+K-1 ) = AP( KPC+KP-1 )
+ AP( KPC+KP-1 ) = TEMP
+ IF( KSTEP.EQ.2 ) THEN
+ TEMP = AP( KC+K+K-1 )
+ AP( KC+K+K-1 ) = AP( KC+K+KP-1 )
+ AP( KC+K+KP-1 ) = TEMP
+ END IF
+ END IF
+*
+ K = K + KSTEP
+ KC = KCNEXT
+ GO TO 30
+ 50 CONTINUE
+*
+ ELSE
+*
+* Compute inv(A) from the factorization A = L*D*L'.
+*
+* K is the main loop index, increasing from 1 to N in steps of
+* 1 or 2, depending on the size of the diagonal blocks.
+*
+ NPP = N*( N+1 ) / 2
+ K = N
+ KC = NPP
+ 60 CONTINUE
+*
+* If K < 1, exit from loop.
+*
+ IF( K.LT.1 )
+ $ GO TO 80
+*
+ KCNEXT = KC - ( N-K+2 )
+ IF( IPIV( K ).GT.0 ) THEN
+*
+* 1 x 1 diagonal block
+*
+* Invert the diagonal block.
+*
+ AP( KC ) = ONE / AP( KC )
+*
+* Compute column K of the inverse.
+*
+ IF( K.LT.N ) THEN
+ CALL DCOPY( N-K, AP( KC+1 ), 1, WORK, 1 )
+ CALL DSPMV( UPLO, N-K, -ONE, AP( KC+N-K+1 ), WORK, 1,
+ $ ZERO, AP( KC+1 ), 1 )
+ AP( KC ) = AP( KC ) - DDOT( N-K, WORK, 1, AP( KC+1 ), 1 )
+ END IF
+ KSTEP = 1
+ ELSE
+*
+* 2 x 2 diagonal block
+*
+* Invert the diagonal block.
+*
+ T = ABS( AP( KCNEXT+1 ) )
+ AK = AP( KCNEXT ) / T
+ AKP1 = AP( KC ) / T
+ AKKP1 = AP( KCNEXT+1 ) / T
+ D = T*( AK*AKP1-ONE )
+ AP( KCNEXT ) = AKP1 / D
+ AP( KC ) = AK / D
+ AP( KCNEXT+1 ) = -AKKP1 / D
+*
+* Compute columns K-1 and K of the inverse.
+*
+ IF( K.LT.N ) THEN
+ CALL DCOPY( N-K, AP( KC+1 ), 1, WORK, 1 )
+ CALL DSPMV( UPLO, N-K, -ONE, AP( KC+( N-K+1 ) ), WORK, 1,
+ $ ZERO, AP( KC+1 ), 1 )
+ AP( KC ) = AP( KC ) - DDOT( N-K, WORK, 1, AP( KC+1 ), 1 )
+ AP( KCNEXT+1 ) = AP( KCNEXT+1 ) -
+ $ DDOT( N-K, AP( KC+1 ), 1,
+ $ AP( KCNEXT+2 ), 1 )
+ CALL DCOPY( N-K, AP( KCNEXT+2 ), 1, WORK, 1 )
+ CALL DSPMV( UPLO, N-K, -ONE, AP( KC+( N-K+1 ) ), WORK, 1,
+ $ ZERO, AP( KCNEXT+2 ), 1 )
+ AP( KCNEXT ) = AP( KCNEXT ) -
+ $ DDOT( N-K, WORK, 1, AP( KCNEXT+2 ), 1 )
+ END IF
+ KSTEP = 2
+ KCNEXT = KCNEXT - ( N-K+3 )
+ END IF
+*
+ KP = ABS( IPIV( K ) )
+ IF( KP.NE.K ) THEN
+*
+* Interchange rows and columns K and KP in the trailing
+* submatrix A(k-1:n,k-1:n)
+*
+ KPC = NPP - ( N-KP+1 )*( N-KP+2 ) / 2 + 1
+ IF( KP.LT.N )
+ $ CALL DSWAP( N-KP, AP( KC+KP-K+1 ), 1, AP( KPC+1 ), 1 )
+ KX = KC + KP - K
+ DO 70 J = K + 1, KP - 1
+ KX = KX + N - J + 1
+ TEMP = AP( KC+J-K )
+ AP( KC+J-K ) = AP( KX )
+ AP( KX ) = TEMP
+ 70 CONTINUE
+ TEMP = AP( KC )
+ AP( KC ) = AP( KPC )
+ AP( KPC ) = TEMP
+ IF( KSTEP.EQ.2 ) THEN
+ TEMP = AP( KC-N+K-1 )
+ AP( KC-N+K-1 ) = AP( KC-N+KP-1 )
+ AP( KC-N+KP-1 ) = TEMP
+ END IF
+ END IF
+*
+ K = K - KSTEP
+ KC = KCNEXT
+ GO TO 60
+ 80 CONTINUE
+ END IF
+*
+ RETURN
+*
+* End of DSPTRI
+*
+ END
+ SUBROUTINE DSPTRS( UPLO, N, NRHS, AP, IPIV, B, LDB, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, LDB, N, NRHS
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ DOUBLE PRECISION AP( * ), B( LDB, * )
+* ..
+*
+* Purpose
+* =======
+*
+* DSPTRS solves a system of linear equations A*X = B with a real
+* symmetric matrix A stored in packed format using the factorization
+* A = U*D*U**T or A = L*D*L**T computed by DSPTRF.
+*
+* Arguments
+* =========
+*
+* UPLO (input) CHARACTER*1
+* Specifies whether the details of the factorization are stored
+* as an upper or lower triangular matrix.
+* = 'U': Upper triangular, form is A = U*D*U**T;
+* = 'L': Lower triangular, form is A = L*D*L**T.
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* NRHS (input) INTEGER
+* The number of right hand sides, i.e., the number of columns
+* of the matrix B. NRHS >= 0.
+*
+* AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)
+* The block diagonal matrix D and the multipliers used to
+* obtain the factor U or L as computed by DSPTRF, stored as a
+* packed triangular matrix.
+*
+* IPIV (input) INTEGER array, dimension (N)
+* Details of the interchanges and the block structure of D
+* as determined by DSPTRF.
+*
+* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
+* On entry, the right hand side matrix B.
+* On exit, the solution matrix X.
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. LDB >= max(1,N).
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE
+ PARAMETER ( ONE = 1.0D+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL UPPER
+ INTEGER J, K, KC, KP
+ DOUBLE PRECISION AK, AKM1, AKM1K, BK, BKM1, DENOM
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL DGEMV, DGER, DSCAL, DSWAP, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( NRHS.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -7
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DSPTRS', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 .OR. NRHS.EQ.0 )
+ $ RETURN
+*
+ IF( UPPER ) THEN
+*
+* Solve A*X = B, where A = U*D*U'.
+*
+* First solve U*D*X = B, overwriting B with X.
+*
+* K is the main loop index, decreasing from N to 1 in steps of
+* 1 or 2, depending on the size of the diagonal blocks.
+*
+ K = N
+ KC = N*( N+1 ) / 2 + 1
+ 10 CONTINUE
+*
+* If K < 1, exit from loop.
+*
+ IF( K.LT.1 )
+ $ GO TO 30
+*
+ KC = KC - K
+ IF( IPIV( K ).GT.0 ) THEN
+*
+* 1 x 1 diagonal block
+*
+* Interchange rows K and IPIV(K).
+*
+ KP = IPIV( K )
+ IF( KP.NE.K )
+ $ CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+*
+* Multiply by inv(U(K)), where U(K) is the transformation
+* stored in column K of A.
+*
+ CALL DGER( K-1, NRHS, -ONE, AP( KC ), 1, B( K, 1 ), LDB,
+ $ B( 1, 1 ), LDB )
+*
+* Multiply by the inverse of the diagonal block.
+*
+ CALL DSCAL( NRHS, ONE / AP( KC+K-1 ), B( K, 1 ), LDB )
+ K = K - 1
+ ELSE
+*
+* 2 x 2 diagonal block
+*
+* Interchange rows K-1 and -IPIV(K).
+*
+ KP = -IPIV( K )
+ IF( KP.NE.K-1 )
+ $ CALL DSWAP( NRHS, B( K-1, 1 ), LDB, B( KP, 1 ), LDB )
+*
+* Multiply by inv(U(K)), where U(K) is the transformation
+* stored in columns K-1 and K of A.
+*
+ CALL DGER( K-2, NRHS, -ONE, AP( KC ), 1, B( K, 1 ), LDB,
+ $ B( 1, 1 ), LDB )
+ CALL DGER( K-2, NRHS, -ONE, AP( KC-( K-1 ) ), 1,
+ $ B( K-1, 1 ), LDB, B( 1, 1 ), LDB )
+*
+* Multiply by the inverse of the diagonal block.
+*
+ AKM1K = AP( KC+K-2 )
+ AKM1 = AP( KC-1 ) / AKM1K
+ AK = AP( KC+K-1 ) / AKM1K
+ DENOM = AKM1*AK - ONE
+ DO 20 J = 1, NRHS
+ BKM1 = B( K-1, J ) / AKM1K
+ BK = B( K, J ) / AKM1K
+ B( K-1, J ) = ( AK*BKM1-BK ) / DENOM
+ B( K, J ) = ( AKM1*BK-BKM1 ) / DENOM
+ 20 CONTINUE
+ KC = KC - K + 1
+ K = K - 2
+ END IF
+*
+ GO TO 10
+ 30 CONTINUE
+*
+* Next solve U'*X = B, overwriting B with X.
+*
+* K is the main loop index, increasing from 1 to N in steps of
+* 1 or 2, depending on the size of the diagonal blocks.
+*
+ K = 1
+ KC = 1
+ 40 CONTINUE
+*
+* If K > N, exit from loop.
+*
+ IF( K.GT.N )
+ $ GO TO 50
+*
+ IF( IPIV( K ).GT.0 ) THEN
+*
+* 1 x 1 diagonal block
+*
+* Multiply by inv(U'(K)), where U(K) is the transformation
+* stored in column K of A.
+*
+ CALL DGEMV( 'Transpose', K-1, NRHS, -ONE, B, LDB, AP( KC ),
+ $ 1, ONE, B( K, 1 ), LDB )
+*
+* Interchange rows K and IPIV(K).
+*
+ KP = IPIV( K )
+ IF( KP.NE.K )
+ $ CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+ KC = KC + K
+ K = K + 1
+ ELSE
+*
+* 2 x 2 diagonal block
+*
+* Multiply by inv(U'(K+1)), where U(K+1) is the transformation
+* stored in columns K and K+1 of A.
+*
+ CALL DGEMV( 'Transpose', K-1, NRHS, -ONE, B, LDB, AP( KC ),
+ $ 1, ONE, B( K, 1 ), LDB )
+ CALL DGEMV( 'Transpose', K-1, NRHS, -ONE, B, LDB,
+ $ AP( KC+K ), 1, ONE, B( K+1, 1 ), LDB )
+*
+* Interchange rows K and -IPIV(K).
+*
+ KP = -IPIV( K )
+ IF( KP.NE.K )
+ $ CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+ KC = KC + 2*K + 1
+ K = K + 2
+ END IF
+*
+ GO TO 40
+ 50 CONTINUE
+*
+ ELSE
+*
+* Solve A*X = B, where A = L*D*L'.
+*
+* First solve L*D*X = B, overwriting B with X.
+*
+* K is the main loop index, increasing from 1 to N in steps of
+* 1 or 2, depending on the size of the diagonal blocks.
+*
+ K = 1
+ KC = 1
+ 60 CONTINUE
+*
+* If K > N, exit from loop.
+*
+ IF( K.GT.N )
+ $ GO TO 80
+*
+ IF( IPIV( K ).GT.0 ) THEN
+*
+* 1 x 1 diagonal block
+*
+* Interchange rows K and IPIV(K).
+*
+ KP = IPIV( K )
+ IF( KP.NE.K )
+ $ CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+*
+* Multiply by inv(L(K)), where L(K) is the transformation
+* stored in column K of A.
+*
+ IF( K.LT.N )
+ $ CALL DGER( N-K, NRHS, -ONE, AP( KC+1 ), 1, B( K, 1 ),
+ $ LDB, B( K+1, 1 ), LDB )
+*
+* Multiply by the inverse of the diagonal block.
+*
+ CALL DSCAL( NRHS, ONE / AP( KC ), B( K, 1 ), LDB )
+ KC = KC + N - K + 1
+ K = K + 1
+ ELSE
+*
+* 2 x 2 diagonal block
+*
+* Interchange rows K+1 and -IPIV(K).
+*
+ KP = -IPIV( K )
+ IF( KP.NE.K+1 )
+ $ CALL DSWAP( NRHS, B( K+1, 1 ), LDB, B( KP, 1 ), LDB )
+*
+* Multiply by inv(L(K)), where L(K) is the transformation
+* stored in columns K and K+1 of A.
+*
+ IF( K.LT.N-1 ) THEN
+ CALL DGER( N-K-1, NRHS, -ONE, AP( KC+2 ), 1, B( K, 1 ),
+ $ LDB, B( K+2, 1 ), LDB )
+ CALL DGER( N-K-1, NRHS, -ONE, AP( KC+N-K+2 ), 1,
+ $ B( K+1, 1 ), LDB, B( K+2, 1 ), LDB )
+ END IF
+*
+* Multiply by the inverse of the diagonal block.
+*
+ AKM1K = AP( KC+1 )
+ AKM1 = AP( KC ) / AKM1K
+ AK = AP( KC+N-K+1 ) / AKM1K
+ DENOM = AKM1*AK - ONE
+ DO 70 J = 1, NRHS
+ BKM1 = B( K, J ) / AKM1K
+ BK = B( K+1, J ) / AKM1K
+ B( K, J ) = ( AK*BKM1-BK ) / DENOM
+ B( K+1, J ) = ( AKM1*BK-BKM1 ) / DENOM
+ 70 CONTINUE
+ KC = KC + 2*( N-K ) + 1
+ K = K + 2
+ END IF
+*
+ GO TO 60
+ 80 CONTINUE
+*
+* Next solve L'*X = B, overwriting B with X.
+*
+* K is the main loop index, decreasing from N to 1 in steps of
+* 1 or 2, depending on the size of the diagonal blocks.
+*
+ K = N
+ KC = N*( N+1 ) / 2 + 1
+ 90 CONTINUE
+*
+* If K < 1, exit from loop.
+*
+ IF( K.LT.1 )
+ $ GO TO 100
+*
+ KC = KC - ( N-K+1 )
+ IF( IPIV( K ).GT.0 ) THEN
+*
+* 1 x 1 diagonal block
+*
+* Multiply by inv(L'(K)), where L(K) is the transformation
+* stored in column K of A.
+*
+ IF( K.LT.N )
+ $ CALL DGEMV( 'Transpose', N-K, NRHS, -ONE, B( K+1, 1 ),
+ $ LDB, AP( KC+1 ), 1, ONE, B( K, 1 ), LDB )
+*
+* Interchange rows K and IPIV(K).
+*
+ KP = IPIV( K )
+ IF( KP.NE.K )
+ $ CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+ K = K - 1
+ ELSE
+*
+* 2 x 2 diagonal block
+*
+* Multiply by inv(L'(K-1)), where L(K-1) is the transformation
+* stored in columns K-1 and K of A.
+*
+ IF( K.LT.N ) THEN
+ CALL DGEMV( 'Transpose', N-K, NRHS, -ONE, B( K+1, 1 ),
+ $ LDB, AP( KC+1 ), 1, ONE, B( K, 1 ), LDB )
+ CALL DGEMV( 'Transpose', N-K, NRHS, -ONE, B( K+1, 1 ),
+ $ LDB, AP( KC-( N-K ) ), 1, ONE, B( K-1, 1 ),
+ $ LDB )
+ END IF
+*
+* Interchange rows K and -IPIV(K).
+*
+ KP = -IPIV( K )
+ IF( KP.NE.K )
+ $ CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+ KC = KC - ( N-K+2 )
+ K = K - 2
+ END IF
+*
+ GO TO 90
+ 100 CONTINUE
+ END IF
+*
+ RETURN
+*
+* End of DSPTRS
+*
+ END
+ SUBROUTINE DSTEBZ( RANGE, ORDER, N, VL, VU, IL, IU, ABSTOL, D, E,
+ $ M, NSPLIT, W, IBLOCK, ISPLIT, WORK, IWORK,
+ $ INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+* 8-18-00: Increase FUDGE factor for T3E (eca)
+*
+* .. Scalar Arguments ..
+ CHARACTER ORDER, RANGE
+ INTEGER IL, INFO, IU, M, N, NSPLIT
+ DOUBLE PRECISION ABSTOL, VL, VU
+* ..
+* .. Array Arguments ..
+ INTEGER IBLOCK( * ), ISPLIT( * ), IWORK( * )
+ DOUBLE PRECISION D( * ), E( * ), W( * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DSTEBZ computes the eigenvalues of a symmetric tridiagonal
+* matrix T. The user may ask for all eigenvalues, all eigenvalues
+* in the half-open interval (VL, VU], or the IL-th through IU-th
+* eigenvalues.
+*
+* To avoid overflow, the matrix must be scaled so that its
+* largest element is no greater than overflow**(1/2) *
+* underflow**(1/4) in absolute value, and for greatest
+* accuracy, it should not be much smaller than that.
+*
+* See W. Kahan "Accurate Eigenvalues of a Symmetric Tridiagonal
+* Matrix", Report CS41, Computer Science Dept., Stanford
+* University, July 21, 1966.
+*
+* Arguments
+* =========
+*
+* RANGE (input) CHARACTER*1
+* = 'A': ("All") all eigenvalues will be found.
+* = 'V': ("Value") all eigenvalues in the half-open interval
+* (VL, VU] will be found.
+* = 'I': ("Index") the IL-th through IU-th eigenvalues (of the
+* entire matrix) will be found.
+*
+* ORDER (input) CHARACTER*1
+* = 'B': ("By Block") the eigenvalues will be grouped by
+* split-off block (see IBLOCK, ISPLIT) and
+* ordered from smallest to largest within
+* the block.
+* = 'E': ("Entire matrix")
+* the eigenvalues for the entire matrix
+* will be ordered from smallest to
+* largest.
+*
+* N (input) INTEGER
+* The order of the tridiagonal matrix T. N >= 0.
+*
+* VL (input) DOUBLE PRECISION
+* VU (input) DOUBLE PRECISION
+* If RANGE='V', the lower and upper bounds of the interval to
+* be searched for eigenvalues. Eigenvalues less than or equal
+* to VL, or greater than VU, will not be returned. VL < VU.
+* Not referenced if RANGE = 'A' or 'I'.
+*
+* IL (input) INTEGER
+* IU (input) INTEGER
+* If RANGE='I', the indices (in ascending order) of the
+* smallest and largest eigenvalues to be returned.
+* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
+* Not referenced if RANGE = 'A' or 'V'.
+*
+* ABSTOL (input) DOUBLE PRECISION
+* The absolute tolerance for the eigenvalues. An eigenvalue
+* (or cluster) is considered to be located if it has been
+* determined to lie in an interval whose width is ABSTOL or
+* less. If ABSTOL is less than or equal to zero, then ULP*|T|
+* will be used, where |T| means the 1-norm of T.
+*
+* Eigenvalues will be computed most accurately when ABSTOL is
+* set to twice the underflow threshold 2*DLAMCH('S'), not zero.
+*
+* D (input) DOUBLE PRECISION array, dimension (N)
+* The n diagonal elements of the tridiagonal matrix T.
+*
+* E (input) DOUBLE PRECISION array, dimension (N-1)
+* The (n-1) off-diagonal elements of the tridiagonal matrix T.
+*
+* M (output) INTEGER
+* The actual number of eigenvalues found. 0 <= M <= N.
+* (See also the description of INFO=2,3.)
+*
+* NSPLIT (output) INTEGER
+* The number of diagonal blocks in the matrix T.
+* 1 <= NSPLIT <= N.
+*
+* W (output) DOUBLE PRECISION array, dimension (N)
+* On exit, the first M elements of W will contain the
+* eigenvalues. (DSTEBZ may use the remaining N-M elements as
+* workspace.)
+*
+* IBLOCK (output) INTEGER array, dimension (N)
+* At each row/column j where E(j) is zero or small, the
+* matrix T is considered to split into a block diagonal
+* matrix. On exit, if INFO = 0, IBLOCK(i) specifies to which
+* block (from 1 to the number of blocks) the eigenvalue W(i)
+* belongs. (DSTEBZ may use the remaining N-M elements as
+* workspace.)
+*
+* ISPLIT (output) INTEGER array, dimension (N)
+* The splitting points, at which T breaks up into submatrices.
+* The first submatrix consists of rows/columns 1 to ISPLIT(1),
+* the second of rows/columns ISPLIT(1)+1 through ISPLIT(2),
+* etc., and the NSPLIT-th consists of rows/columns
+* ISPLIT(NSPLIT-1)+1 through ISPLIT(NSPLIT)=N.
+* (Only the first NSPLIT elements will actually be used, but
+* since the user cannot know a priori what value NSPLIT will
+* have, N words must be reserved for ISPLIT.)
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (4*N)
+*
+* IWORK (workspace) INTEGER array, dimension (3*N)
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* > 0: some or all of the eigenvalues failed to converge or
+* were not computed:
+* =1 or 3: Bisection failed to converge for some
+* eigenvalues; these eigenvalues are flagged by a
+* negative block number. The effect is that the
+* eigenvalues may not be as accurate as the
+* absolute and relative tolerances. This is
+* generally caused by unexpectedly inaccurate
+* arithmetic.
+* =2 or 3: RANGE='I' only: Not all of the eigenvalues
+* IL:IU were found.
+* Effect: M < IU+1-IL
+* Cause: non-monotonic arithmetic, causing the
+* Sturm sequence to be non-monotonic.
+* Cure: recalculate, using RANGE='A', and pick
+* out eigenvalues IL:IU. In some cases,
+* increasing the PARAMETER "FUDGE" may
+* make things work.
+* = 4: RANGE='I', and the Gershgorin interval
+* initially used was too small. No eigenvalues
+* were computed.
+* Probable cause: your machine has sloppy
+* floating-point arithmetic.
+* Cure: Increase the PARAMETER "FUDGE",
+* recompile, and try again.
+*
+* Internal Parameters
+* ===================
+*
+* RELFAC DOUBLE PRECISION, default = 2.0e0
+* The relative tolerance. An interval (a,b] lies within
+* "relative tolerance" if b-a < RELFAC*ulp*max(|a|,|b|),
+* where "ulp" is the machine precision (distance from 1 to
+* the next larger floating point number.)
+*
+* FUDGE DOUBLE PRECISION, default = 2
+* A "fudge factor" to widen the Gershgorin intervals. Ideally,
+* a value of 1 should work, but on machines with sloppy
+* arithmetic, this needs to be larger. The default for
+* publicly released versions should be large enough to handle
+* the worst machine around. Note that this has no effect
+* on accuracy of the solution.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE, TWO, HALF
+ PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0,
+ $ HALF = 1.0D0 / TWO )
+ DOUBLE PRECISION FUDGE, RELFAC
+ PARAMETER ( FUDGE = 2.1D0, RELFAC = 2.0D0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL NCNVRG, TOOFEW
+ INTEGER IB, IBEGIN, IDISCL, IDISCU, IE, IEND, IINFO,
+ $ IM, IN, IOFF, IORDER, IOUT, IRANGE, ITMAX,
+ $ ITMP1, IW, IWOFF, J, JB, JDISC, JE, NB, NWL,
+ $ NWU
+ DOUBLE PRECISION ATOLI, BNORM, GL, GU, PIVMIN, RTOLI, SAFEMN,
+ $ TMP1, TMP2, TNORM, ULP, WKILL, WL, WLU, WU, WUL
+* ..
+* .. Local Arrays ..
+ INTEGER IDUMMA( 1 )
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ILAENV
+ DOUBLE PRECISION DLAMCH
+ EXTERNAL LSAME, ILAENV, DLAMCH
+* ..
+* .. External Subroutines ..
+ EXTERNAL DLAEBZ, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, INT, LOG, MAX, MIN, SQRT
+* ..
+* .. Executable Statements ..
+*
+ INFO = 0
+*
+* Decode RANGE
+*
+ IF( LSAME( RANGE, 'A' ) ) THEN
+ IRANGE = 1
+ ELSE IF( LSAME( RANGE, 'V' ) ) THEN
+ IRANGE = 2
+ ELSE IF( LSAME( RANGE, 'I' ) ) THEN
+ IRANGE = 3
+ ELSE
+ IRANGE = 0
+ END IF
+*
+* Decode ORDER
+*
+ IF( LSAME( ORDER, 'B' ) ) THEN
+ IORDER = 2
+ ELSE IF( LSAME( ORDER, 'E' ) ) THEN
+ IORDER = 1
+ ELSE
+ IORDER = 0
+ END IF
+*
+* Check for Errors
+*
+ IF( IRANGE.LE.0 ) THEN
+ INFO = -1
+ ELSE IF( IORDER.LE.0 ) THEN
+ INFO = -2
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( IRANGE.EQ.2 ) THEN
+ IF( VL.GE.VU )
+ $ INFO = -5
+ ELSE IF( IRANGE.EQ.3 .AND. ( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) )
+ $ THEN
+ INFO = -6
+ ELSE IF( IRANGE.EQ.3 .AND. ( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) )
+ $ THEN
+ INFO = -7
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DSTEBZ', -INFO )
+ RETURN
+ END IF
+*
+* Initialize error flags
+*
+ INFO = 0
+ NCNVRG = .FALSE.
+ TOOFEW = .FALSE.
+*
+* Quick return if possible
+*
+ M = 0
+ IF( N.EQ.0 )
+ $ RETURN
+*
+* Simplifications:
+*
+ IF( IRANGE.EQ.3 .AND. IL.EQ.1 .AND. IU.EQ.N )
+ $ IRANGE = 1
+*
+* Get machine constants
+* NB is the minimum vector length for vector bisection, or 0
+* if only scalar is to be done.
+*
+ SAFEMN = DLAMCH( 'S' )
+ ULP = DLAMCH( 'P' )
+ RTOLI = ULP*RELFAC
+ NB = ILAENV( 1, 'DSTEBZ', ' ', N, -1, -1, -1 )
+ IF( NB.LE.1 )
+ $ NB = 0
+*
+* Special Case when N=1
+*
+ IF( N.EQ.1 ) THEN
+ NSPLIT = 1
+ ISPLIT( 1 ) = 1
+ IF( IRANGE.EQ.2 .AND. ( VL.GE.D( 1 ) .OR. VU.LT.D( 1 ) ) ) THEN
+ M = 0
+ ELSE
+ W( 1 ) = D( 1 )
+ IBLOCK( 1 ) = 1
+ M = 1
+ END IF
+ RETURN
+ END IF
+*
+* Compute Splitting Points
+*
+ NSPLIT = 1
+ WORK( N ) = ZERO
+ PIVMIN = ONE
+*
+*DIR$ NOVECTOR
+ DO 10 J = 2, N
+ TMP1 = E( J-1 )**2
+ IF( ABS( D( J )*D( J-1 ) )*ULP**2+SAFEMN.GT.TMP1 ) THEN
+ ISPLIT( NSPLIT ) = J - 1
+ NSPLIT = NSPLIT + 1
+ WORK( J-1 ) = ZERO
+ ELSE
+ WORK( J-1 ) = TMP1
+ PIVMIN = MAX( PIVMIN, TMP1 )
+ END IF
+ 10 CONTINUE
+ ISPLIT( NSPLIT ) = N
+ PIVMIN = PIVMIN*SAFEMN
+*
+* Compute Interval and ATOLI
+*
+ IF( IRANGE.EQ.3 ) THEN
+*
+* RANGE='I': Compute the interval containing eigenvalues
+* IL through IU.
+*
+* Compute Gershgorin interval for entire (split) matrix
+* and use it as the initial interval
+*
+ GU = D( 1 )
+ GL = D( 1 )
+ TMP1 = ZERO
+*
+ DO 20 J = 1, N - 1
+ TMP2 = SQRT( WORK( J ) )
+ GU = MAX( GU, D( J )+TMP1+TMP2 )
+ GL = MIN( GL, D( J )-TMP1-TMP2 )
+ TMP1 = TMP2
+ 20 CONTINUE
+*
+ GU = MAX( GU, D( N )+TMP1 )
+ GL = MIN( GL, D( N )-TMP1 )
+ TNORM = MAX( ABS( GL ), ABS( GU ) )
+ GL = GL - FUDGE*TNORM*ULP*N - FUDGE*TWO*PIVMIN
+ GU = GU + FUDGE*TNORM*ULP*N + FUDGE*PIVMIN
+*
+* Compute Iteration parameters
+*
+ ITMAX = INT( ( LOG( TNORM+PIVMIN )-LOG( PIVMIN ) ) /
+ $ LOG( TWO ) ) + 2
+ IF( ABSTOL.LE.ZERO ) THEN
+ ATOLI = ULP*TNORM
+ ELSE
+ ATOLI = ABSTOL
+ END IF
+*
+ WORK( N+1 ) = GL
+ WORK( N+2 ) = GL
+ WORK( N+3 ) = GU
+ WORK( N+4 ) = GU
+ WORK( N+5 ) = GL
+ WORK( N+6 ) = GU
+ IWORK( 1 ) = -1
+ IWORK( 2 ) = -1
+ IWORK( 3 ) = N + 1
+ IWORK( 4 ) = N + 1
+ IWORK( 5 ) = IL - 1
+ IWORK( 6 ) = IU
+*
+ CALL DLAEBZ( 3, ITMAX, N, 2, 2, NB, ATOLI, RTOLI, PIVMIN, D, E,
+ $ WORK, IWORK( 5 ), WORK( N+1 ), WORK( N+5 ), IOUT,
+ $ IWORK, W, IBLOCK, IINFO )
+*
+ IF( IWORK( 6 ).EQ.IU ) THEN
+ WL = WORK( N+1 )
+ WLU = WORK( N+3 )
+ NWL = IWORK( 1 )
+ WU = WORK( N+4 )
+ WUL = WORK( N+2 )
+ NWU = IWORK( 4 )
+ ELSE
+ WL = WORK( N+2 )
+ WLU = WORK( N+4 )
+ NWL = IWORK( 2 )
+ WU = WORK( N+3 )
+ WUL = WORK( N+1 )
+ NWU = IWORK( 3 )
+ END IF
+*
+ IF( NWL.LT.0 .OR. NWL.GE.N .OR. NWU.LT.1 .OR. NWU.GT.N ) THEN
+ INFO = 4
+ RETURN
+ END IF
+ ELSE
+*
+* RANGE='A' or 'V' -- Set ATOLI
+*
+ TNORM = MAX( ABS( D( 1 ) )+ABS( E( 1 ) ),
+ $ ABS( D( N ) )+ABS( E( N-1 ) ) )
+*
+ DO 30 J = 2, N - 1
+ TNORM = MAX( TNORM, ABS( D( J ) )+ABS( E( J-1 ) )+
+ $ ABS( E( J ) ) )
+ 30 CONTINUE
+*
+ IF( ABSTOL.LE.ZERO ) THEN
+ ATOLI = ULP*TNORM
+ ELSE
+ ATOLI = ABSTOL
+ END IF
+*
+ IF( IRANGE.EQ.2 ) THEN
+ WL = VL
+ WU = VU
+ ELSE
+ WL = ZERO
+ WU = ZERO
+ END IF
+ END IF
+*
+* Find Eigenvalues -- Loop Over Blocks and recompute NWL and NWU.
+* NWL accumulates the number of eigenvalues .le. WL,
+* NWU accumulates the number of eigenvalues .le. WU
+*
+ M = 0
+ IEND = 0
+ INFO = 0
+ NWL = 0
+ NWU = 0
+*
+ DO 70 JB = 1, NSPLIT
+ IOFF = IEND
+ IBEGIN = IOFF + 1
+ IEND = ISPLIT( JB )
+ IN = IEND - IOFF
+*
+ IF( IN.EQ.1 ) THEN
+*
+* Special Case -- IN=1
+*
+ IF( IRANGE.EQ.1 .OR. WL.GE.D( IBEGIN )-PIVMIN )
+ $ NWL = NWL + 1
+ IF( IRANGE.EQ.1 .OR. WU.GE.D( IBEGIN )-PIVMIN )
+ $ NWU = NWU + 1
+ IF( IRANGE.EQ.1 .OR. ( WL.LT.D( IBEGIN )-PIVMIN .AND. WU.GE.
+ $ D( IBEGIN )-PIVMIN ) ) THEN
+ M = M + 1
+ W( M ) = D( IBEGIN )
+ IBLOCK( M ) = JB
+ END IF
+ ELSE
+*
+* General Case -- IN > 1
+*
+* Compute Gershgorin Interval
+* and use it as the initial interval
+*
+ GU = D( IBEGIN )
+ GL = D( IBEGIN )
+ TMP1 = ZERO
+*
+ DO 40 J = IBEGIN, IEND - 1
+ TMP2 = ABS( E( J ) )
+ GU = MAX( GU, D( J )+TMP1+TMP2 )
+ GL = MIN( GL, D( J )-TMP1-TMP2 )
+ TMP1 = TMP2
+ 40 CONTINUE
+*
+ GU = MAX( GU, D( IEND )+TMP1 )
+ GL = MIN( GL, D( IEND )-TMP1 )
+ BNORM = MAX( ABS( GL ), ABS( GU ) )
+ GL = GL - FUDGE*BNORM*ULP*IN - FUDGE*PIVMIN
+ GU = GU + FUDGE*BNORM*ULP*IN + FUDGE*PIVMIN
+*
+* Compute ATOLI for the current submatrix
+*
+ IF( ABSTOL.LE.ZERO ) THEN
+ ATOLI = ULP*MAX( ABS( GL ), ABS( GU ) )
+ ELSE
+ ATOLI = ABSTOL
+ END IF
+*
+ IF( IRANGE.GT.1 ) THEN
+ IF( GU.LT.WL ) THEN
+ NWL = NWL + IN
+ NWU = NWU + IN
+ GO TO 70
+ END IF
+ GL = MAX( GL, WL )
+ GU = MIN( GU, WU )
+ IF( GL.GE.GU )
+ $ GO TO 70
+ END IF
+*
+* Set Up Initial Interval
+*
+ WORK( N+1 ) = GL
+ WORK( N+IN+1 ) = GU
+ CALL DLAEBZ( 1, 0, IN, IN, 1, NB, ATOLI, RTOLI, PIVMIN,
+ $ D( IBEGIN ), E( IBEGIN ), WORK( IBEGIN ),
+ $ IDUMMA, WORK( N+1 ), WORK( N+2*IN+1 ), IM,
+ $ IWORK, W( M+1 ), IBLOCK( M+1 ), IINFO )
+*
+ NWL = NWL + IWORK( 1 )
+ NWU = NWU + IWORK( IN+1 )
+ IWOFF = M - IWORK( 1 )
+*
+* Compute Eigenvalues
+*
+ ITMAX = INT( ( LOG( GU-GL+PIVMIN )-LOG( PIVMIN ) ) /
+ $ LOG( TWO ) ) + 2
+ CALL DLAEBZ( 2, ITMAX, IN, IN, 1, NB, ATOLI, RTOLI, PIVMIN,
+ $ D( IBEGIN ), E( IBEGIN ), WORK( IBEGIN ),
+ $ IDUMMA, WORK( N+1 ), WORK( N+2*IN+1 ), IOUT,
+ $ IWORK, W( M+1 ), IBLOCK( M+1 ), IINFO )
+*
+* Copy Eigenvalues Into W and IBLOCK
+* Use -JB for block number for unconverged eigenvalues.
+*
+ DO 60 J = 1, IOUT
+ TMP1 = HALF*( WORK( J+N )+WORK( J+IN+N ) )
+*
+* Flag non-convergence.
+*
+ IF( J.GT.IOUT-IINFO ) THEN
+ NCNVRG = .TRUE.
+ IB = -JB
+ ELSE
+ IB = JB
+ END IF
+ DO 50 JE = IWORK( J ) + 1 + IWOFF,
+ $ IWORK( J+IN ) + IWOFF
+ W( JE ) = TMP1
+ IBLOCK( JE ) = IB
+ 50 CONTINUE
+ 60 CONTINUE
+*
+ M = M + IM
+ END IF
+ 70 CONTINUE
+*
+* If RANGE='I', then (WL,WU) contains eigenvalues NWL+1,...,NWU
+* If NWL+1 < IL or NWU > IU, discard extra eigenvalues.
+*
+ IF( IRANGE.EQ.3 ) THEN
+ IM = 0
+ IDISCL = IL - 1 - NWL
+ IDISCU = NWU - IU
+*
+ IF( IDISCL.GT.0 .OR. IDISCU.GT.0 ) THEN
+ DO 80 JE = 1, M
+ IF( W( JE ).LE.WLU .AND. IDISCL.GT.0 ) THEN
+ IDISCL = IDISCL - 1
+ ELSE IF( W( JE ).GE.WUL .AND. IDISCU.GT.0 ) THEN
+ IDISCU = IDISCU - 1
+ ELSE
+ IM = IM + 1
+ W( IM ) = W( JE )
+ IBLOCK( IM ) = IBLOCK( JE )
+ END IF
+ 80 CONTINUE
+ M = IM
+ END IF
+ IF( IDISCL.GT.0 .OR. IDISCU.GT.0 ) THEN
+*
+* Code to deal with effects of bad arithmetic:
+* Some low eigenvalues to be discarded are not in (WL,WLU],
+* or high eigenvalues to be discarded are not in (WUL,WU]
+* so just kill off the smallest IDISCL/largest IDISCU
+* eigenvalues, by simply finding the smallest/largest
+* eigenvalue(s).
+*
+* (If N(w) is monotone non-decreasing, this should never
+* happen.)
+*
+ IF( IDISCL.GT.0 ) THEN
+ WKILL = WU
+ DO 100 JDISC = 1, IDISCL
+ IW = 0
+ DO 90 JE = 1, M
+ IF( IBLOCK( JE ).NE.0 .AND.
+ $ ( W( JE ).LT.WKILL .OR. IW.EQ.0 ) ) THEN
+ IW = JE
+ WKILL = W( JE )
+ END IF
+ 90 CONTINUE
+ IBLOCK( IW ) = 0
+ 100 CONTINUE
+ END IF
+ IF( IDISCU.GT.0 ) THEN
+*
+ WKILL = WL
+ DO 120 JDISC = 1, IDISCU
+ IW = 0
+ DO 110 JE = 1, M
+ IF( IBLOCK( JE ).NE.0 .AND.
+ $ ( W( JE ).GT.WKILL .OR. IW.EQ.0 ) ) THEN
+ IW = JE
+ WKILL = W( JE )
+ END IF
+ 110 CONTINUE
+ IBLOCK( IW ) = 0
+ 120 CONTINUE
+ END IF
+ IM = 0
+ DO 130 JE = 1, M
+ IF( IBLOCK( JE ).NE.0 ) THEN
+ IM = IM + 1
+ W( IM ) = W( JE )
+ IBLOCK( IM ) = IBLOCK( JE )
+ END IF
+ 130 CONTINUE
+ M = IM
+ END IF
+ IF( IDISCL.LT.0 .OR. IDISCU.LT.0 ) THEN
+ TOOFEW = .TRUE.
+ END IF
+ END IF
+*
+* If ORDER='B', do nothing -- the eigenvalues are already sorted
+* by block.
+* If ORDER='E', sort the eigenvalues from smallest to largest
+*
+ IF( IORDER.EQ.1 .AND. NSPLIT.GT.1 ) THEN
+ DO 150 JE = 1, M - 1
+ IE = 0
+ TMP1 = W( JE )
+ DO 140 J = JE + 1, M
+ IF( W( J ).LT.TMP1 ) THEN
+ IE = J
+ TMP1 = W( J )
+ END IF
+ 140 CONTINUE
+*
+ IF( IE.NE.0 ) THEN
+ ITMP1 = IBLOCK( IE )
+ W( IE ) = W( JE )
+ IBLOCK( IE ) = IBLOCK( JE )
+ W( JE ) = TMP1
+ IBLOCK( JE ) = ITMP1
+ END IF
+ 150 CONTINUE
+ END IF
+*
+ INFO = 0
+ IF( NCNVRG )
+ $ INFO = INFO + 1
+ IF( TOOFEW )
+ $ INFO = INFO + 2
+ RETURN
+*
+* End of DSTEBZ
+*
+ END
+ SUBROUTINE DSTEDC( COMPZ, N, D, E, Z, LDZ, WORK, LWORK, IWORK,
+ $ LIWORK, INFO )
+*
+* -- LAPACK driver routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER COMPZ
+ INTEGER INFO, LDZ, LIWORK, LWORK, N
+* ..
+* .. Array Arguments ..
+ INTEGER IWORK( * )
+ DOUBLE PRECISION D( * ), E( * ), WORK( * ), Z( LDZ, * )
+* ..
+*
+* Purpose
+* =======
+*
+* DSTEDC computes all eigenvalues and, optionally, eigenvectors of a
+* symmetric tridiagonal matrix using the divide and conquer method.
+* The eigenvectors of a full or band real symmetric matrix can also be
+* found if DSYTRD or DSPTRD or DSBTRD has been used to reduce this
+* matrix to tridiagonal form.
+*
+* This code makes very mild assumptions about floating point
+* arithmetic. It will work on machines with a guard digit in
+* add/subtract, or on those binary machines without guard digits
+* which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2.
+* It could conceivably fail on hexadecimal or decimal machines
+* without guard digits, but we know of none. See DLAED3 for details.
+*
+* Arguments
+* =========
+*
+* COMPZ (input) CHARACTER*1
+* = 'N': Compute eigenvalues only.
+* = 'I': Compute eigenvectors of tridiagonal matrix also.
+* = 'V': Compute eigenvectors of original dense symmetric
+* matrix also. On entry, Z contains the orthogonal
+* matrix used to reduce the original matrix to
+* tridiagonal form.
+*
+* N (input) INTEGER
+* The dimension of the symmetric tridiagonal matrix. N >= 0.
+*
+* D (input/output) DOUBLE PRECISION array, dimension (N)
+* On entry, the diagonal elements of the tridiagonal matrix.
+* On exit, if INFO = 0, the eigenvalues in ascending order.
+*
+* E (input/output) DOUBLE PRECISION array, dimension (N-1)
+* On entry, the subdiagonal elements of the tridiagonal matrix.
+* On exit, E has been destroyed.
+*
+* Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N)
+* On entry, if COMPZ = 'V', then Z contains the orthogonal
+* matrix used in the reduction to tridiagonal form.
+* On exit, if INFO = 0, then if COMPZ = 'V', Z contains the
+* orthonormal eigenvectors of the original symmetric matrix,
+* and if COMPZ = 'I', Z contains the orthonormal eigenvectors
+* of the symmetric tridiagonal matrix.
+* If COMPZ = 'N', then Z is not referenced.
+*
+* LDZ (input) INTEGER
+* The leading dimension of the array Z. LDZ >= 1.
+* If eigenvectors are desired, then LDZ >= max(1,N).
+*
+* WORK (workspace/output) DOUBLE PRECISION array,
+* dimension (LWORK)
+* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+* LWORK (input) INTEGER
+* The dimension of the array WORK.
+* If COMPZ = 'N' or N <= 1 then LWORK must be at least 1.
+* If COMPZ = 'V' and N > 1 then LWORK must be at least
+* ( 1 + 3*N + 2*N*lg N + 3*N**2 ),
+* where lg( N ) = smallest integer k such
+* that 2**k >= N.
+* If COMPZ = 'I' and N > 1 then LWORK must be at least
+* ( 1 + 4*N + N**2 ).
+* Note that for COMPZ = 'I' or 'V', then if N is less than or
+* equal to the minimum divide size, usually 25, then LWORK need
+* only be max(1,2*(N-1)).
+*
+* If LWORK = -1, then a workspace query is assumed; the routine
+* only calculates the optimal size of the WORK array, returns
+* this value as the first entry of the WORK array, and no error
+* message related to LWORK is issued by XERBLA.
+*
+* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))
+* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
+*
+* LIWORK (input) INTEGER
+* The dimension of the array IWORK.
+* If COMPZ = 'N' or N <= 1 then LIWORK must be at least 1.
+* If COMPZ = 'V' and N > 1 then LIWORK must be at least
+* ( 6 + 6*N + 5*N*lg N ).
+* If COMPZ = 'I' and N > 1 then LIWORK must be at least
+* ( 3 + 5*N ).
+* Note that for COMPZ = 'I' or 'V', then if N is less than or
+* equal to the minimum divide size, usually 25, then LIWORK
+* need only be 1.
+*
+* If LIWORK = -1, then a workspace query is assumed; the
+* routine only calculates the optimal size of the IWORK array,
+* returns this value as the first entry of the IWORK array, and
+* no error message related to LIWORK is issued by XERBLA.
+*
+* INFO (output) INTEGER
+* = 0: successful exit.
+* < 0: if INFO = -i, the i-th argument had an illegal value.
+* > 0: The algorithm failed to compute an eigenvalue while
+* working on the submatrix lying in rows and columns
+* INFO/(N+1) through mod(INFO,N+1).
+*
+* Further Details
+* ===============
+*
+* Based on contributions by
+* Jeff Rutter, Computer Science Division, University of California
+* at Berkeley, USA
+* Modified by Francoise Tisseur, University of Tennessee.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE, TWO
+ PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL LQUERY
+ INTEGER FINISH, I, ICOMPZ, II, J, K, LGN, LIWMIN,
+ $ LWMIN, M, SMLSIZ, START, STOREZ, STRTRW
+ DOUBLE PRECISION EPS, ORGNRM, P, TINY
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ILAENV
+ DOUBLE PRECISION DLAMCH, DLANST
+ EXTERNAL LSAME, ILAENV, DLAMCH, DLANST
+* ..
+* .. External Subroutines ..
+ EXTERNAL DGEMM, DLACPY, DLAED0, DLASCL, DLASET, DLASRT,
+ $ DSTEQR, DSTERF, DSWAP, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, DBLE, INT, LOG, MAX, MOD, SQRT
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 )
+*
+ IF( LSAME( COMPZ, 'N' ) ) THEN
+ ICOMPZ = 0
+ ELSE IF( LSAME( COMPZ, 'V' ) ) THEN
+ ICOMPZ = 1
+ ELSE IF( LSAME( COMPZ, 'I' ) ) THEN
+ ICOMPZ = 2
+ ELSE
+ ICOMPZ = -1
+ END IF
+ IF( ICOMPZ.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( ( LDZ.LT.1 ) .OR.
+ $ ( ICOMPZ.GT.0 .AND. LDZ.LT.MAX( 1, N ) ) ) THEN
+ INFO = -6
+ END IF
+*
+ IF( INFO.EQ.0 ) THEN
+*
+* Compute the workspace requirements
+*
+ SMLSIZ = ILAENV( 9, 'DSTEDC', ' ', 0, 0, 0, 0 )
+ IF( N.LE.1 .OR. ICOMPZ.EQ.0 ) THEN
+ LIWMIN = 1
+ LWMIN = 1
+ ELSE IF( N.LE.SMLSIZ ) THEN
+ LIWMIN = 1
+ LWMIN = 2*( N - 1 )
+ ELSE
+ LGN = INT( LOG( DBLE( N ) )/LOG( TWO ) )
+ IF( 2**LGN.LT.N )
+ $ LGN = LGN + 1
+ IF( 2**LGN.LT.N )
+ $ LGN = LGN + 1
+ IF( ICOMPZ.EQ.1 ) THEN
+ LWMIN = 1 + 3*N + 2*N*LGN + 3*N**2
+ LIWMIN = 6 + 6*N + 5*N*LGN
+ ELSE IF( ICOMPZ.EQ.2 ) THEN
+ LWMIN = 1 + 4*N + N**2
+ LIWMIN = 3 + 5*N
+ END IF
+ END IF
+ WORK( 1 ) = LWMIN
+ IWORK( 1 ) = LIWMIN
+*
+ IF( LWORK.LT.LWMIN .AND. .NOT. LQUERY ) THEN
+ INFO = -8
+ ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT. LQUERY ) THEN
+ INFO = -10
+ END IF
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DSTEDC', -INFO )
+ RETURN
+ ELSE IF (LQUERY) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 )
+ $ RETURN
+ IF( N.EQ.1 ) THEN
+ IF( ICOMPZ.NE.0 )
+ $ Z( 1, 1 ) = ONE
+ RETURN
+ END IF
+*
+* If the following conditional clause is removed, then the routine
+* will use the Divide and Conquer routine to compute only the
+* eigenvalues, which requires (3N + 3N**2) real workspace and
+* (2 + 5N + 2N lg(N)) integer workspace.
+* Since on many architectures DSTERF is much faster than any other
+* algorithm for finding eigenvalues only, it is used here
+* as the default. If the conditional clause is removed, then
+* information on the size of workspace needs to be changed.
+*
+* If COMPZ = 'N', use DSTERF to compute the eigenvalues.
+*
+ IF( ICOMPZ.EQ.0 ) THEN
+ CALL DSTERF( N, D, E, INFO )
+ GO TO 50
+ END IF
+*
+* If N is smaller than the minimum divide size (SMLSIZ+1), then
+* solve the problem with another solver.
+*
+ IF( N.LE.SMLSIZ ) THEN
+*
+ CALL DSTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO )
+*
+ ELSE
+*
+* If COMPZ = 'V', the Z matrix must be stored elsewhere for later
+* use.
+*
+ IF( ICOMPZ.EQ.1 ) THEN
+ STOREZ = 1 + N*N
+ ELSE
+ STOREZ = 1
+ END IF
+*
+ IF( ICOMPZ.EQ.2 ) THEN
+ CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDZ )
+ END IF
+*
+* Scale.
+*
+ ORGNRM = DLANST( 'M', N, D, E )
+ IF( ORGNRM.EQ.ZERO )
+ $ GO TO 50
+*
+ EPS = DLAMCH( 'Epsilon' )
+*
+ START = 1
+*
+* while ( START <= N )
+*
+ 10 CONTINUE
+ IF( START.LE.N ) THEN
+*
+* Let FINISH be the position of the next subdiagonal entry
+* such that E( FINISH ) <= TINY or FINISH = N if no such
+* subdiagonal exists. The matrix identified by the elements
+* between START and FINISH constitutes an independent
+* sub-problem.
+*
+ FINISH = START
+ 20 CONTINUE
+ IF( FINISH.LT.N ) THEN
+ TINY = EPS*SQRT( ABS( D( FINISH ) ) )*
+ $ SQRT( ABS( D( FINISH+1 ) ) )
+ IF( ABS( E( FINISH ) ).GT.TINY ) THEN
+ FINISH = FINISH + 1
+ GO TO 20
+ END IF
+ END IF
+*
+* (Sub) Problem determined. Compute its size and solve it.
+*
+ M = FINISH - START + 1
+ IF( M.EQ.1 ) THEN
+ START = FINISH + 1
+ GO TO 10
+ END IF
+ IF( M.GT.SMLSIZ ) THEN
+*
+* Scale.
+*
+ ORGNRM = DLANST( 'M', M, D( START ), E( START ) )
+ CALL DLASCL( 'G', 0, 0, ORGNRM, ONE, M, 1, D( START ), M,
+ $ INFO )
+ CALL DLASCL( 'G', 0, 0, ORGNRM, ONE, M-1, 1, E( START ),
+ $ M-1, INFO )
+*
+ IF( ICOMPZ.EQ.1 ) THEN
+ STRTRW = 1
+ ELSE
+ STRTRW = START
+ END IF
+ CALL DLAED0( ICOMPZ, N, M, D( START ), E( START ),
+ $ Z( STRTRW, START ), LDZ, WORK( 1 ), N,
+ $ WORK( STOREZ ), IWORK, INFO )
+ IF( INFO.NE.0 ) THEN
+ INFO = ( INFO / ( M+1 )+START-1 )*( N+1 ) +
+ $ MOD( INFO, ( M+1 ) ) + START - 1
+ GO TO 50
+ END IF
+*
+* Scale back.
+*
+ CALL DLASCL( 'G', 0, 0, ONE, ORGNRM, M, 1, D( START ), M,
+ $ INFO )
+*
+ ELSE
+ IF( ICOMPZ.EQ.1 ) THEN
+*
+* Since QR won't update a Z matrix which is larger than
+* the length of D, we must solve the sub-problem in a
+* workspace and then multiply back into Z.
+*
+ CALL DSTEQR( 'I', M, D( START ), E( START ), WORK, M,
+ $ WORK( M*M+1 ), INFO )
+ CALL DLACPY( 'A', N, M, Z( 1, START ), LDZ,
+ $ WORK( STOREZ ), N )
+ CALL DGEMM( 'N', 'N', N, M, M, ONE,
+ $ WORK( STOREZ ), N, WORK, M, ZERO,
+ $ Z( 1, START ), LDZ )
+ ELSE IF( ICOMPZ.EQ.2 ) THEN
+ CALL DSTEQR( 'I', M, D( START ), E( START ),
+ $ Z( START, START ), LDZ, WORK, INFO )
+ ELSE
+ CALL DSTERF( M, D( START ), E( START ), INFO )
+ END IF
+ IF( INFO.NE.0 ) THEN
+ INFO = START*( N+1 ) + FINISH
+ GO TO 50
+ END IF
+ END IF
+*
+ START = FINISH + 1
+ GO TO 10
+ END IF
+*
+* endwhile
+*
+* If the problem split any number of times, then the eigenvalues
+* will not be properly ordered. Here we permute the eigenvalues
+* (and the associated eigenvectors) into ascending order.
+*
+ IF( M.NE.N ) THEN
+ IF( ICOMPZ.EQ.0 ) THEN
+*
+* Use Quick Sort
+*
+ CALL DLASRT( 'I', N, D, INFO )
+*
+ ELSE
+*
+* Use Selection Sort to minimize swaps of eigenvectors
+*
+ DO 40 II = 2, N
+ I = II - 1
+ K = I
+ P = D( I )
+ DO 30 J = II, N
+ IF( D( J ).LT.P ) THEN
+ K = J
+ P = D( J )
+ END IF
+ 30 CONTINUE
+ IF( K.NE.I ) THEN
+ D( K ) = D( I )
+ D( I ) = P
+ CALL DSWAP( N, Z( 1, I ), 1, Z( 1, K ), 1 )
+ END IF
+ 40 CONTINUE
+ END IF
+ END IF
+ END IF
+*
+ 50 CONTINUE
+ WORK( 1 ) = LWMIN
+ IWORK( 1 ) = LIWMIN
+*
+ RETURN
+*
+* End of DSTEDC
+*
+ END
+ SUBROUTINE DSTEGR( JOBZ, RANGE, N, D, E, VL, VU, IL, IU,
+ $ ABSTOL, M, W, Z, LDZ, ISUPPZ, WORK, LWORK, IWORK,
+ $ LIWORK, INFO )
+
+ IMPLICIT NONE
+*
+*
+* -- LAPACK computational routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER JOBZ, RANGE
+ INTEGER IL, INFO, IU, LDZ, LIWORK, LWORK, M, N
+ DOUBLE PRECISION ABSTOL, VL, VU
+* ..
+* .. Array Arguments ..
+ INTEGER ISUPPZ( * ), IWORK( * )
+ DOUBLE PRECISION D( * ), E( * ), W( * ), WORK( * )
+ DOUBLE PRECISION Z( LDZ, * )
+* ..
+*
+* Purpose
+* =======
+*
+* DSTEGR computes selected eigenvalues and, optionally, eigenvectors
+* of a real symmetric tridiagonal matrix T. Any such unreduced matrix has
+* a well defined set of pairwise different real eigenvalues, the corresponding
+* real eigenvectors are pairwise orthogonal.
+*
+* The spectrum may be computed either completely or partially by specifying
+* either an interval (VL,VU] or a range of indices IL:IU for the desired
+* eigenvalues.
+*
+* DSTEGR is a compatability wrapper around the improved DSTEMR routine.
+* See DSTEMR for further details.
+*
+* One important change is that the ABSTOL parameter no longer provides any
+* benefit and hence is no longer used.
+*
+* Note : DSTEGR and DSTEMR work only on machines which follow
+* IEEE-754 floating-point standard in their handling of infinities and
+* NaNs. Normal execution may create these exceptiona values and hence
+* may abort due to a floating point exception in environments which
+* do not conform to the IEEE-754 standard.
+*
+* Arguments
+* =========
+*
+* JOBZ (input) CHARACTER*1
+* = 'N': Compute eigenvalues only;
+* = 'V': Compute eigenvalues and eigenvectors.
+*
+* RANGE (input) CHARACTER*1
+* = 'A': all eigenvalues will be found.
+* = 'V': all eigenvalues in the half-open interval (VL,VU]
+* will be found.
+* = 'I': the IL-th through IU-th eigenvalues will be found.
+*
+* N (input) INTEGER
+* The order of the matrix. N >= 0.
+*
+* D (input/output) DOUBLE PRECISION array, dimension (N)
+* On entry, the N diagonal elements of the tridiagonal matrix
+* T. On exit, D is overwritten.
+*
+* E (input/output) DOUBLE PRECISION array, dimension (N)
+* On entry, the (N-1) subdiagonal elements of the tridiagonal
+* matrix T in elements 1 to N-1 of E. E(N) need not be set on
+* input, but is used internally as workspace.
+* On exit, E is overwritten.
+*
+* VL (input) DOUBLE PRECISION
+* VU (input) DOUBLE PRECISION
+* If RANGE='V', the lower and upper bounds of the interval to
+* be searched for eigenvalues. VL < VU.
+* Not referenced if RANGE = 'A' or 'I'.
+*
+* IL (input) INTEGER
+* IU (input) INTEGER
+* If RANGE='I', the indices (in ascending order) of the
+* smallest and largest eigenvalues to be returned.
+* 1 <= IL <= IU <= N, if N > 0.
+* Not referenced if RANGE = 'A' or 'V'.
+*
+* ABSTOL (input) DOUBLE PRECISION
+* Unused. Was the absolute error tolerance for the
+* eigenvalues/eigenvectors in previous versions.
+*
+* M (output) INTEGER
+* The total number of eigenvalues found. 0 <= M <= N.
+* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
+*
+* W (output) DOUBLE PRECISION array, dimension (N)
+* The first M elements contain the selected eigenvalues in
+* ascending order.
+*
+* Z (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M) )
+* If JOBZ = 'V', and if INFO = 0, then the first M columns of Z
+* contain the orthonormal eigenvectors of the matrix T
+* corresponding to the selected eigenvalues, with the i-th
+* column of Z holding the eigenvector associated with W(i).
+* If JOBZ = 'N', then Z is not referenced.
+* Note: the user must ensure that at least max(1,M) columns are
+* supplied in the array Z; if RANGE = 'V', the exact value of M
+* is not known in advance and an upper bound must be used.
+* Supplying N columns is always safe.
+*
+* LDZ (input) INTEGER
+* The leading dimension of the array Z. LDZ >= 1, and if
+* JOBZ = 'V', then LDZ >= max(1,N).
+*
+* ISUPPZ (output) INTEGER ARRAY, dimension ( 2*max(1,M) )
+* The support of the eigenvectors in Z, i.e., the indices
+* indicating the nonzero elements in Z. The i-th computed eigenvector
+* is nonzero only in elements ISUPPZ( 2*i-1 ) through
+* ISUPPZ( 2*i ). This is relevant in the case when the matrix
+* is split. ISUPPZ is only accessed when JOBZ is 'V' and N > 0.
+*
+* WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK)
+* On exit, if INFO = 0, WORK(1) returns the optimal
+* (and minimal) LWORK.
+*
+* LWORK (input) INTEGER
+* The dimension of the array WORK. LWORK >= max(1,18*N)
+* if JOBZ = 'V', and LWORK >= max(1,12*N) if JOBZ = 'N'.
+* If LWORK = -1, then a workspace query is assumed; the routine
+* only calculates the optimal size of the WORK array, returns
+* this value as the first entry of the WORK array, and no error
+* message related to LWORK is issued by XERBLA.
+*
+* IWORK (workspace/output) INTEGER array, dimension (LIWORK)
+* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
+*
+* LIWORK (input) INTEGER
+* The dimension of the array IWORK. LIWORK >= max(1,10*N)
+* if the eigenvectors are desired, and LIWORK >= max(1,8*N)
+* if only the eigenvalues are to be computed.
+* If LIWORK = -1, then a workspace query is assumed; the
+* routine only calculates the optimal size of the IWORK array,
+* returns this value as the first entry of the IWORK array, and
+* no error message related to LIWORK is issued by XERBLA.
+*
+* INFO (output) INTEGER
+* On exit, INFO
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* > 0: if INFO = 1X, internal error in DLARRE,
+* if INFO = 2X, internal error in DLARRV.
+* Here, the digit X = ABS( IINFO ) < 10, where IINFO is
+* the nonzero error code returned by DLARRE or
+* DLARRV, respectively.
+*
+* Further Details
+* ===============
+*
+* Based on contributions by
+* Inderjit Dhillon, IBM Almaden, USA
+* Osni Marques, LBNL/NERSC, USA
+* Christof Voemel, LBNL/NERSC, USA
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ LOGICAL TRYRAC
+* ..
+* .. External Subroutines ..
+ EXTERNAL DSTEMR
+* ..
+* .. Executable Statements ..
+ INFO = 0
+ TRYRAC = .FALSE.
+
+ CALL DSTEMR( JOBZ, RANGE, N, D, E, VL, VU, IL, IU,
+ $ M, W, Z, LDZ, N, ISUPPZ, TRYRAC, WORK, LWORK,
+ $ IWORK, LIWORK, INFO )
+*
+* End of DSTEGR
+*
+ END
+ SUBROUTINE DSTEIN( N, D, E, M, W, IBLOCK, ISPLIT, Z, LDZ, WORK,
+ $ IWORK, IFAIL, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LDZ, M, N
+* ..
+* .. Array Arguments ..
+ INTEGER IBLOCK( * ), IFAIL( * ), ISPLIT( * ),
+ $ IWORK( * )
+ DOUBLE PRECISION D( * ), E( * ), W( * ), WORK( * ), Z( LDZ, * )
+* ..
+*
+* Purpose
+* =======
+*
+* DSTEIN computes the eigenvectors of a real symmetric tridiagonal
+* matrix T corresponding to specified eigenvalues, using inverse
+* iteration.
+*
+* The maximum number of iterations allowed for each eigenvector is
+* specified by an internal parameter MAXITS (currently set to 5).
+*
+* Arguments
+* =========
+*
+* N (input) INTEGER
+* The order of the matrix. N >= 0.
+*
+* D (input) DOUBLE PRECISION array, dimension (N)
+* The n diagonal elements of the tridiagonal matrix T.
+*
+* E (input) DOUBLE PRECISION array, dimension (N-1)
+* The (n-1) subdiagonal elements of the tridiagonal matrix
+* T, in elements 1 to N-1.
+*
+* M (input) INTEGER
+* The number of eigenvectors to be found. 0 <= M <= N.
+*
+* W (input) DOUBLE PRECISION array, dimension (N)
+* The first M elements of W contain the eigenvalues for
+* which eigenvectors are to be computed. The eigenvalues
+* should be grouped by split-off block and ordered from
+* smallest to largest within the block. ( The output array
+* W from DSTEBZ with ORDER = 'B' is expected here. )
+*
+* IBLOCK (input) INTEGER array, dimension (N)
+* The submatrix indices associated with the corresponding
+* eigenvalues in W; IBLOCK(i)=1 if eigenvalue W(i) belongs to
+* the first submatrix from the top, =2 if W(i) belongs to
+* the second submatrix, etc. ( The output array IBLOCK
+* from DSTEBZ is expected here. )
+*
+* ISPLIT (input) INTEGER array, dimension (N)
+* The splitting points, at which T breaks up into submatrices.
+* The first submatrix consists of rows/columns 1 to
+* ISPLIT( 1 ), the second of rows/columns ISPLIT( 1 )+1
+* through ISPLIT( 2 ), etc.
+* ( The output array ISPLIT from DSTEBZ is expected here. )
+*
+* Z (output) DOUBLE PRECISION array, dimension (LDZ, M)
+* The computed eigenvectors. The eigenvector associated
+* with the eigenvalue W(i) is stored in the i-th column of
+* Z. Any vector which fails to converge is set to its current
+* iterate after MAXITS iterations.
+*
+* LDZ (input) INTEGER
+* The leading dimension of the array Z. LDZ >= max(1,N).
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (5*N)
+*
+* IWORK (workspace) INTEGER array, dimension (N)
+*
+* IFAIL (output) INTEGER array, dimension (M)
+* On normal exit, all elements of IFAIL are zero.
+* If one or more eigenvectors fail to converge after
+* MAXITS iterations, then their indices are stored in
+* array IFAIL.
+*
+* INFO (output) INTEGER
+* = 0: successful exit.
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* > 0: if INFO = i, then i eigenvectors failed to converge
+* in MAXITS iterations. Their indices are stored in
+* array IFAIL.
+*
+* Internal Parameters
+* ===================
+*
+* MAXITS INTEGER, default = 5
+* The maximum number of iterations performed.
+*
+* EXTRA INTEGER, default = 2
+* The number of iterations performed after norm growth
+* criterion is satisfied, should be at least 1.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE, TEN, ODM3, ODM1
+ PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TEN = 1.0D+1,
+ $ ODM3 = 1.0D-3, ODM1 = 1.0D-1 )
+ INTEGER MAXITS, EXTRA
+ PARAMETER ( MAXITS = 5, EXTRA = 2 )
+* ..
+* .. Local Scalars ..
+ INTEGER B1, BLKSIZ, BN, GPIND, I, IINFO, INDRV1,
+ $ INDRV2, INDRV3, INDRV4, INDRV5, ITS, J, J1,
+ $ JBLK, JMAX, NBLK, NRMCHK
+ DOUBLE PRECISION DTPCRT, EPS, EPS1, NRM, ONENRM, ORTOL, PERTOL,
+ $ SCL, SEP, TOL, XJ, XJM, ZTR
+* ..
+* .. Local Arrays ..
+ INTEGER ISEED( 4 )
+* ..
+* .. External Functions ..
+ INTEGER IDAMAX
+ DOUBLE PRECISION DASUM, DDOT, DLAMCH, DNRM2
+ EXTERNAL IDAMAX, DASUM, DDOT, DLAMCH, DNRM2
+* ..
+* .. External Subroutines ..
+ EXTERNAL DAXPY, DCOPY, DLAGTF, DLAGTS, DLARNV, DSCAL,
+ $ XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, SQRT
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ DO 10 I = 1, M
+ IFAIL( I ) = 0
+ 10 CONTINUE
+*
+ IF( N.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( M.LT.0 .OR. M.GT.N ) THEN
+ INFO = -4
+ ELSE IF( LDZ.LT.MAX( 1, N ) ) THEN
+ INFO = -9
+ ELSE
+ DO 20 J = 2, M
+ IF( IBLOCK( J ).LT.IBLOCK( J-1 ) ) THEN
+ INFO = -6
+ GO TO 30
+ END IF
+ IF( IBLOCK( J ).EQ.IBLOCK( J-1 ) .AND. W( J ).LT.W( J-1 ) )
+ $ THEN
+ INFO = -5
+ GO TO 30
+ END IF
+ 20 CONTINUE
+ 30 CONTINUE
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DSTEIN', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 .OR. M.EQ.0 ) THEN
+ RETURN
+ ELSE IF( N.EQ.1 ) THEN
+ Z( 1, 1 ) = ONE
+ RETURN
+ END IF
+*
+* Get machine constants.
+*
+ EPS = DLAMCH( 'Precision' )
+*
+* Initialize seed for random number generator DLARNV.
+*
+ DO 40 I = 1, 4
+ ISEED( I ) = 1
+ 40 CONTINUE
+*
+* Initialize pointers.
+*
+ INDRV1 = 0
+ INDRV2 = INDRV1 + N
+ INDRV3 = INDRV2 + N
+ INDRV4 = INDRV3 + N
+ INDRV5 = INDRV4 + N
+*
+* Compute eigenvectors of matrix blocks.
+*
+ J1 = 1
+ DO 160 NBLK = 1, IBLOCK( M )
+*
+* Find starting and ending indices of block nblk.
+*
+ IF( NBLK.EQ.1 ) THEN
+ B1 = 1
+ ELSE
+ B1 = ISPLIT( NBLK-1 ) + 1
+ END IF
+ BN = ISPLIT( NBLK )
+ BLKSIZ = BN - B1 + 1
+ IF( BLKSIZ.EQ.1 )
+ $ GO TO 60
+ GPIND = B1
+*
+* Compute reorthogonalization criterion and stopping criterion.
+*
+ ONENRM = ABS( D( B1 ) ) + ABS( E( B1 ) )
+ ONENRM = MAX( ONENRM, ABS( D( BN ) )+ABS( E( BN-1 ) ) )
+ DO 50 I = B1 + 1, BN - 1
+ ONENRM = MAX( ONENRM, ABS( D( I ) )+ABS( E( I-1 ) )+
+ $ ABS( E( I ) ) )
+ 50 CONTINUE
+ ORTOL = ODM3*ONENRM
+*
+ DTPCRT = SQRT( ODM1 / BLKSIZ )
+*
+* Loop through eigenvalues of block nblk.
+*
+ 60 CONTINUE
+ JBLK = 0
+ DO 150 J = J1, M
+ IF( IBLOCK( J ).NE.NBLK ) THEN
+ J1 = J
+ GO TO 160
+ END IF
+ JBLK = JBLK + 1
+ XJ = W( J )
+*
+* Skip all the work if the block size is one.
+*
+ IF( BLKSIZ.EQ.1 ) THEN
+ WORK( INDRV1+1 ) = ONE
+ GO TO 120
+ END IF
+*
+* If eigenvalues j and j-1 are too close, add a relatively
+* small perturbation.
+*
+ IF( JBLK.GT.1 ) THEN
+ EPS1 = ABS( EPS*XJ )
+ PERTOL = TEN*EPS1
+ SEP = XJ - XJM
+ IF( SEP.LT.PERTOL )
+ $ XJ = XJM + PERTOL
+ END IF
+*
+ ITS = 0
+ NRMCHK = 0
+*
+* Get random starting vector.
+*
+ CALL DLARNV( 2, ISEED, BLKSIZ, WORK( INDRV1+1 ) )
+*
+* Copy the matrix T so it won't be destroyed in factorization.
+*
+ CALL DCOPY( BLKSIZ, D( B1 ), 1, WORK( INDRV4+1 ), 1 )
+ CALL DCOPY( BLKSIZ-1, E( B1 ), 1, WORK( INDRV2+2 ), 1 )
+ CALL DCOPY( BLKSIZ-1, E( B1 ), 1, WORK( INDRV3+1 ), 1 )
+*
+* Compute LU factors with partial pivoting ( PT = LU )
+*
+ TOL = ZERO
+ CALL DLAGTF( BLKSIZ, WORK( INDRV4+1 ), XJ, WORK( INDRV2+2 ),
+ $ WORK( INDRV3+1 ), TOL, WORK( INDRV5+1 ), IWORK,
+ $ IINFO )
+*
+* Update iteration count.
+*
+ 70 CONTINUE
+ ITS = ITS + 1
+ IF( ITS.GT.MAXITS )
+ $ GO TO 100
+*
+* Normalize and scale the righthand side vector Pb.
+*
+ SCL = BLKSIZ*ONENRM*MAX( EPS,
+ $ ABS( WORK( INDRV4+BLKSIZ ) ) ) /
+ $ DASUM( BLKSIZ, WORK( INDRV1+1 ), 1 )
+ CALL DSCAL( BLKSIZ, SCL, WORK( INDRV1+1 ), 1 )
+*
+* Solve the system LU = Pb.
+*
+ CALL DLAGTS( -1, BLKSIZ, WORK( INDRV4+1 ), WORK( INDRV2+2 ),
+ $ WORK( INDRV3+1 ), WORK( INDRV5+1 ), IWORK,
+ $ WORK( INDRV1+1 ), TOL, IINFO )
+*
+* Reorthogonalize by modified Gram-Schmidt if eigenvalues are
+* close enough.
+*
+ IF( JBLK.EQ.1 )
+ $ GO TO 90
+ IF( ABS( XJ-XJM ).GT.ORTOL )
+ $ GPIND = J
+ IF( GPIND.NE.J ) THEN
+ DO 80 I = GPIND, J - 1
+ ZTR = -DDOT( BLKSIZ, WORK( INDRV1+1 ), 1, Z( B1, I ),
+ $ 1 )
+ CALL DAXPY( BLKSIZ, ZTR, Z( B1, I ), 1,
+ $ WORK( INDRV1+1 ), 1 )
+ 80 CONTINUE
+ END IF
+*
+* Check the infinity norm of the iterate.
+*
+ 90 CONTINUE
+ JMAX = IDAMAX( BLKSIZ, WORK( INDRV1+1 ), 1 )
+ NRM = ABS( WORK( INDRV1+JMAX ) )
+*
+* Continue for additional iterations after norm reaches
+* stopping criterion.
+*
+ IF( NRM.LT.DTPCRT )
+ $ GO TO 70
+ NRMCHK = NRMCHK + 1
+ IF( NRMCHK.LT.EXTRA+1 )
+ $ GO TO 70
+*
+ GO TO 110
+*
+* If stopping criterion was not satisfied, update info and
+* store eigenvector number in array ifail.
+*
+ 100 CONTINUE
+ INFO = INFO + 1
+ IFAIL( INFO ) = J
+*
+* Accept iterate as jth eigenvector.
+*
+ 110 CONTINUE
+ SCL = ONE / DNRM2( BLKSIZ, WORK( INDRV1+1 ), 1 )
+ JMAX = IDAMAX( BLKSIZ, WORK( INDRV1+1 ), 1 )
+ IF( WORK( INDRV1+JMAX ).LT.ZERO )
+ $ SCL = -SCL
+ CALL DSCAL( BLKSIZ, SCL, WORK( INDRV1+1 ), 1 )
+ 120 CONTINUE
+ DO 130 I = 1, N
+ Z( I, J ) = ZERO
+ 130 CONTINUE
+ DO 140 I = 1, BLKSIZ
+ Z( B1+I-1, J ) = WORK( INDRV1+I )
+ 140 CONTINUE
+*
+* Save the shift to check eigenvalue spacing at next
+* iteration.
+*
+ XJM = XJ
+*
+ 150 CONTINUE
+ 160 CONTINUE
+*
+ RETURN
+*
+* End of DSTEIN
+*
+ END
+ SUBROUTINE DSTEMR( JOBZ, RANGE, N, D, E, VL, VU, IL, IU,
+ $ M, W, Z, LDZ, NZC, ISUPPZ, TRYRAC, WORK, LWORK,
+ $ IWORK, LIWORK, INFO )
+ IMPLICIT NONE
+*
+* -- LAPACK computational routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER JOBZ, RANGE
+ LOGICAL TRYRAC
+ INTEGER IL, INFO, IU, LDZ, NZC, LIWORK, LWORK, M, N
+ DOUBLE PRECISION VL, VU
+* ..
+* .. Array Arguments ..
+ INTEGER ISUPPZ( * ), IWORK( * )
+ DOUBLE PRECISION D( * ), E( * ), W( * ), WORK( * )
+ DOUBLE PRECISION Z( LDZ, * )
+* ..
+*
+* Purpose
+* =======
+*
+* DSTEMR computes selected eigenvalues and, optionally, eigenvectors
+* of a real symmetric tridiagonal matrix T. Any such unreduced matrix has
+* a well defined set of pairwise different real eigenvalues, the corresponding
+* real eigenvectors are pairwise orthogonal.
+*
+* The spectrum may be computed either completely or partially by specifying
+* either an interval (VL,VU] or a range of indices IL:IU for the desired
+* eigenvalues.
+*
+* Depending on the number of desired eigenvalues, these are computed either
+* by bisection or the dqds algorithm. Numerically orthogonal eigenvectors are
+* computed by the use of various suitable L D L^T factorizations near clusters
+* of close eigenvalues (referred to as RRRs, Relatively Robust
+* Representations). An informal sketch of the algorithm follows.
+*
+* For each unreduced block (submatrix) of T,
+* (a) Compute T - sigma I = L D L^T, so that L and D
+* define all the wanted eigenvalues to high relative accuracy.
+* This means that small relative changes in the entries of D and L
+* cause only small relative changes in the eigenvalues and
+* eigenvectors. The standard (unfactored) representation of the
+* tridiagonal matrix T does not have this property in general.
+* (b) Compute the eigenvalues to suitable accuracy.
+* If the eigenvectors are desired, the algorithm attains full
+* accuracy of the computed eigenvalues only right before
+* the corresponding vectors have to be computed, see steps c) and d).
+* (c) For each cluster of close eigenvalues, select a new
+* shift close to the cluster, find a new factorization, and refine
+* the shifted eigenvalues to suitable accuracy.
+* (d) For each eigenvalue with a large enough relative separation compute
+* the corresponding eigenvector by forming a rank revealing twisted
+* factorization. Go back to (c) for any clusters that remain.
+*
+* For more details, see:
+* - Inderjit S. Dhillon and Beresford N. Parlett: "Multiple representations
+* to compute orthogonal eigenvectors of symmetric tridiagonal matrices,"
+* Linear Algebra and its Applications, 387(1), pp. 1-28, August 2004.
+* - Inderjit Dhillon and Beresford Parlett: "Orthogonal Eigenvectors and
+* Relative Gaps," SIAM Journal on Matrix Analysis and Applications, Vol. 25,
+* 2004. Also LAPACK Working Note 154.
+* - Inderjit Dhillon: "A new O(n^2) algorithm for the symmetric
+* tridiagonal eigenvalue/eigenvector problem",
+* Computer Science Division Technical Report No. UCB/CSD-97-971,
+* UC Berkeley, May 1997.
+*
+* Notes:
+* 1.DSTEMR works only on machines which follow IEEE-754
+* floating-point standard in their handling of infinities and NaNs.
+* This permits the use of efficient inner loops avoiding a check for
+* zero divisors.
+*
+* Arguments
+* =========
+*
+* JOBZ (input) CHARACTER*1
+* = 'N': Compute eigenvalues only;
+* = 'V': Compute eigenvalues and eigenvectors.
+*
+* RANGE (input) CHARACTER*1
+* = 'A': all eigenvalues will be found.
+* = 'V': all eigenvalues in the half-open interval (VL,VU]
+* will be found.
+* = 'I': the IL-th through IU-th eigenvalues will be found.
+*
+* N (input) INTEGER
+* The order of the matrix. N >= 0.
+*
+* D (input/output) DOUBLE PRECISION array, dimension (N)
+* On entry, the N diagonal elements of the tridiagonal matrix
+* T. On exit, D is overwritten.
+*
+* E (input/output) DOUBLE PRECISION array, dimension (N)
+* On entry, the (N-1) subdiagonal elements of the tridiagonal
+* matrix T in elements 1 to N-1 of E. E(N) need not be set on
+* input, but is used internally as workspace.
+* On exit, E is overwritten.
+*
+* VL (input) DOUBLE PRECISION
+* VU (input) DOUBLE PRECISION
+* If RANGE='V', the lower and upper bounds of the interval to
+* be searched for eigenvalues. VL < VU.
+* Not referenced if RANGE = 'A' or 'I'.
+*
+* IL (input) INTEGER
+* IU (input) INTEGER
+* If RANGE='I', the indices (in ascending order) of the
+* smallest and largest eigenvalues to be returned.
+* 1 <= IL <= IU <= N, if N > 0.
+* Not referenced if RANGE = 'A' or 'V'.
+*
+* M (output) INTEGER
+* The total number of eigenvalues found. 0 <= M <= N.
+* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
+*
+* W (output) DOUBLE PRECISION array, dimension (N)
+* The first M elements contain the selected eigenvalues in
+* ascending order.
+*
+* Z (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M) )
+* If JOBZ = 'V', and if INFO = 0, then the first M columns of Z
+* contain the orthonormal eigenvectors of the matrix T
+* corresponding to the selected eigenvalues, with the i-th
+* column of Z holding the eigenvector associated with W(i).
+* If JOBZ = 'N', then Z is not referenced.
+* Note: the user must ensure that at least max(1,M) columns are
+* supplied in the array Z; if RANGE = 'V', the exact value of M
+* is not known in advance and can be computed with a workspace
+* query by setting NZC = -1, see below.
+*
+* LDZ (input) INTEGER
+* The leading dimension of the array Z. LDZ >= 1, and if
+* JOBZ = 'V', then LDZ >= max(1,N).
+*
+* NZC (input) INTEGER
+* The number of eigenvectors to be held in the array Z.
+* If RANGE = 'A', then NZC >= max(1,N).
+* If RANGE = 'V', then NZC >= the number of eigenvalues in (VL,VU].
+* If RANGE = 'I', then NZC >= IU-IL+1.
+* If NZC = -1, then a workspace query is assumed; the
+* routine calculates the number of columns of the array Z that
+* are needed to hold the eigenvectors.
+* This value is returned as the first entry of the Z array, and
+* no error message related to NZC is issued by XERBLA.
+*
+* ISUPPZ (output) INTEGER ARRAY, dimension ( 2*max(1,M) )
+* The support of the eigenvectors in Z, i.e., the indices
+* indicating the nonzero elements in Z. The i-th computed eigenvector
+* is nonzero only in elements ISUPPZ( 2*i-1 ) through
+* ISUPPZ( 2*i ). This is relevant in the case when the matrix
+* is split. ISUPPZ is only accessed when JOBZ is 'V' and N > 0.
+*
+* TRYRAC (input/output) LOGICAL
+* If TRYRAC.EQ..TRUE., indicates that the code should check whether
+* the tridiagonal matrix defines its eigenvalues to high relative
+* accuracy. If so, the code uses relative-accuracy preserving
+* algorithms that might be (a bit) slower depending on the matrix.
+* If the matrix does not define its eigenvalues to high relative
+* accuracy, the code can uses possibly faster algorithms.
+* If TRYRAC.EQ..FALSE., the code is not required to guarantee
+* relatively accurate eigenvalues and can use the fastest possible
+* techniques.
+* On exit, a .TRUE. TRYRAC will be set to .FALSE. if the matrix
+* does not define its eigenvalues to high relative accuracy.
+*
+* WORK (workspace/output) DOUBLE PRECISION array, dimension (LWORK)
+* On exit, if INFO = 0, WORK(1) returns the optimal
+* (and minimal) LWORK.
+*
+* LWORK (input) INTEGER
+* The dimension of the array WORK. LWORK >= max(1,18*N)
+* if JOBZ = 'V', and LWORK >= max(1,12*N) if JOBZ = 'N'.
+* If LWORK = -1, then a workspace query is assumed; the routine
+* only calculates the optimal size of the WORK array, returns
+* this value as the first entry of the WORK array, and no error
+* message related to LWORK is issued by XERBLA.
+*
+* IWORK (workspace/output) INTEGER array, dimension (LIWORK)
+* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
+*
+* LIWORK (input) INTEGER
+* The dimension of the array IWORK. LIWORK >= max(1,10*N)
+* if the eigenvectors are desired, and LIWORK >= max(1,8*N)
+* if only the eigenvalues are to be computed.
+* If LIWORK = -1, then a workspace query is assumed; the
+* routine only calculates the optimal size of the IWORK array,
+* returns this value as the first entry of the IWORK array, and
+* no error message related to LIWORK is issued by XERBLA.
+*
+* INFO (output) INTEGER
+* On exit, INFO
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* > 0: if INFO = 1X, internal error in DLARRE,
+* if INFO = 2X, internal error in DLARRV.
+* Here, the digit X = ABS( IINFO ) < 10, where IINFO is
+* the nonzero error code returned by DLARRE or
+* DLARRV, respectively.
+*
+*
+* Further Details
+* ===============
+*
+* Based on contributions by
+* Beresford Parlett, University of California, Berkeley, USA
+* Jim Demmel, University of California, Berkeley, USA
+* Inderjit Dhillon, University of Texas, Austin, USA
+* Osni Marques, LBNL/NERSC, USA
+* Christof Voemel, University of California, Berkeley, USA
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE, FOUR, MINRGP
+ PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0,
+ $ FOUR = 4.0D0,
+ $ MINRGP = 1.0D-3 )
+* ..
+* .. Local Scalars ..
+ LOGICAL ALLEIG, INDEIG, LQUERY, VALEIG, WANTZ, ZQUERY
+ INTEGER I, IBEGIN, IEND, IFIRST, IIL, IINDBL, IINDW,
+ $ IINDWK, IINFO, IINSPL, IIU, ILAST, IN, INDD,
+ $ INDE2, INDERR, INDGP, INDGRS, INDWRK, ITMP,
+ $ ITMP2, J, JBLK, JJ, LIWMIN, LWMIN, NSPLIT,
+ $ NZCMIN, OFFSET, WBEGIN, WEND
+ DOUBLE PRECISION BIGNUM, CS, EPS, PIVMIN, R1, R2, RMAX, RMIN,
+ $ RTOL1, RTOL2, SAFMIN, SCALE, SMLNUM, SN,
+ $ THRESH, TMP, TNRM, WL, WU
+* ..
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ DOUBLE PRECISION DLAMCH, DLANST
+ EXTERNAL LSAME, DLAMCH, DLANST
+* ..
+* .. External Subroutines ..
+ EXTERNAL DCOPY, DLAE2, DLAEV2, DLARRC, DLARRE, DLARRJ,
+ $ DLARRR, DLARRV, DLASRT, DSCAL, DSWAP, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN, SQRT
+
+
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ WANTZ = LSAME( JOBZ, 'V' )
+ ALLEIG = LSAME( RANGE, 'A' )
+ VALEIG = LSAME( RANGE, 'V' )
+ INDEIG = LSAME( RANGE, 'I' )
+*
+ LQUERY = ( ( LWORK.EQ.-1 ).OR.( LIWORK.EQ.-1 ) )
+ ZQUERY = ( NZC.EQ.-1 )
+ TRYRAC = ( INFO.NE.0 )
+
+* DSTEMR needs WORK of size 6*N, IWORK of size 3*N.
+* In addition, DLARRE needs WORK of size 6*N, IWORK of size 5*N.
+* Furthermore, DLARRV needs WORK of size 12*N, IWORK of size 7*N.
+ IF( WANTZ ) THEN
+ LWMIN = 18*N
+ LIWMIN = 10*N
+ ELSE
+* need less workspace if only the eigenvalues are wanted
+ LWMIN = 12*N
+ LIWMIN = 8*N
+ ENDIF
+
+ WL = ZERO
+ WU = ZERO
+ IIL = 0
+ IIU = 0
+
+ IF( VALEIG ) THEN
+* We do not reference VL, VU in the cases RANGE = 'I','A'
+* The interval (WL, WU] contains all the wanted eigenvalues.
+* It is either given by the user or computed in DLARRE.
+ WL = VL
+ WU = VU
+ ELSEIF( INDEIG ) THEN
+* We do not reference IL, IU in the cases RANGE = 'V','A'
+ IIL = IL
+ IIU = IU
+ ENDIF
+*
+ INFO = 0
+ IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
+ INFO = -1
+ ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN
+ INFO = -2
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( VALEIG .AND. N.GT.0 .AND. WU.LE.WL ) THEN
+ INFO = -7
+ ELSE IF( INDEIG .AND. ( IIL.LT.1 .OR. IIL.GT.N ) ) THEN
+ INFO = -8
+ ELSE IF( INDEIG .AND. ( IIU.LT.IIL .OR. IIU.GT.N ) ) THEN
+ INFO = -9
+ ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
+ INFO = -13
+ ELSE IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
+ INFO = -17
+ ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN
+ INFO = -19
+ END IF
+*
+* Get machine constants.
+*
+ SAFMIN = DLAMCH( 'Safe minimum' )
+ EPS = DLAMCH( 'Precision' )
+ SMLNUM = SAFMIN / EPS
+ BIGNUM = ONE / SMLNUM
+ RMIN = SQRT( SMLNUM )
+ RMAX = MIN( SQRT( BIGNUM ), ONE / SQRT( SQRT( SAFMIN ) ) )
+*
+ IF( INFO.EQ.0 ) THEN
+ WORK( 1 ) = LWMIN
+ IWORK( 1 ) = LIWMIN
+*
+ IF( WANTZ .AND. ALLEIG ) THEN
+ NZCMIN = N
+ ELSE IF( WANTZ .AND. VALEIG ) THEN
+ CALL DLARRC( 'T', N, VL, VU, D, E, SAFMIN,
+ $ NZCMIN, ITMP, ITMP2, INFO )
+ ELSE IF( WANTZ .AND. INDEIG ) THEN
+ NZCMIN = IIU-IIL+1
+ ELSE
+* WANTZ .EQ. FALSE.
+ NZCMIN = 0
+ ENDIF
+ IF( ZQUERY .AND. INFO.EQ.0 ) THEN
+ Z( 1,1 ) = NZCMIN
+ ELSE IF( NZC.LT.NZCMIN .AND. .NOT.ZQUERY ) THEN
+ INFO = -14
+ END IF
+ END IF
+
+ IF( INFO.NE.0 ) THEN
+*
+ CALL XERBLA( 'DSTEMR', -INFO )
+*
+ RETURN
+ ELSE IF( LQUERY .OR. ZQUERY ) THEN
+ RETURN
+ END IF
+*
+* Handle N = 0, 1, and 2 cases immediately
+*
+ M = 0
+ IF( N.EQ.0 )
+ $ RETURN
+*
+ IF( N.EQ.1 ) THEN
+ IF( ALLEIG .OR. INDEIG ) THEN
+ M = 1
+ W( 1 ) = D( 1 )
+ ELSE
+ IF( WL.LT.D( 1 ) .AND. WU.GE.D( 1 ) ) THEN
+ M = 1
+ W( 1 ) = D( 1 )
+ END IF
+ END IF
+ IF( WANTZ.AND.(.NOT.ZQUERY) ) THEN
+ Z( 1, 1 ) = ONE
+ ISUPPZ(1) = 1
+ ISUPPZ(2) = 1
+ END IF
+ RETURN
+ END IF
+*
+ IF( N.EQ.2 ) THEN
+ IF( .NOT.WANTZ ) THEN
+ CALL DLAE2( D(1), E(1), D(2), R1, R2 )
+ ELSE IF( WANTZ.AND.(.NOT.ZQUERY) ) THEN
+ CALL DLAEV2( D(1), E(1), D(2), R1, R2, CS, SN )
+ END IF
+ IF( ALLEIG.OR.
+ $ (VALEIG.AND.(R2.GT.WL).AND.
+ $ (R2.LE.WU)).OR.
+ $ (INDEIG.AND.(IIL.EQ.1)) ) THEN
+ M = M+1
+ W( M ) = R2
+ IF( WANTZ.AND.(.NOT.ZQUERY) ) THEN
+ Z( 1, M ) = -SN
+ Z( 2, M ) = CS
+* Note: At most one of SN and CS can be zero.
+ IF (SN.NE.ZERO) THEN
+ IF (CS.NE.ZERO) THEN
+ ISUPPZ(2*M-1) = 1
+ ISUPPZ(2*M-1) = 2
+ ELSE
+ ISUPPZ(2*M-1) = 1
+ ISUPPZ(2*M-1) = 1
+ END IF
+ ELSE
+ ISUPPZ(2*M-1) = 2
+ ISUPPZ(2*M) = 2
+ END IF
+ ENDIF
+ ENDIF
+ IF( ALLEIG.OR.
+ $ (VALEIG.AND.(R1.GT.WL).AND.
+ $ (R1.LE.WU)).OR.
+ $ (INDEIG.AND.(IIU.EQ.2)) ) THEN
+ M = M+1
+ W( M ) = R1
+ IF( WANTZ.AND.(.NOT.ZQUERY) ) THEN
+ Z( 1, M ) = CS
+ Z( 2, M ) = SN
+* Note: At most one of SN and CS can be zero.
+ IF (SN.NE.ZERO) THEN
+ IF (CS.NE.ZERO) THEN
+ ISUPPZ(2*M-1) = 1
+ ISUPPZ(2*M-1) = 2
+ ELSE
+ ISUPPZ(2*M-1) = 1
+ ISUPPZ(2*M-1) = 1
+ END IF
+ ELSE
+ ISUPPZ(2*M-1) = 2
+ ISUPPZ(2*M) = 2
+ END IF
+ ENDIF
+ ENDIF
+ RETURN
+ END IF
+
+* Continue with general N
+
+ INDGRS = 1
+ INDERR = 2*N + 1
+ INDGP = 3*N + 1
+ INDD = 4*N + 1
+ INDE2 = 5*N + 1
+ INDWRK = 6*N + 1
+*
+ IINSPL = 1
+ IINDBL = N + 1
+ IINDW = 2*N + 1
+ IINDWK = 3*N + 1
+*
+* Scale matrix to allowable range, if necessary.
+* The allowable range is related to the PIVMIN parameter; see the
+* comments in DLARRD. The preference for scaling small values
+* up is heuristic; we expect users' matrices not to be close to the
+* RMAX threshold.
+*
+ SCALE = ONE
+ TNRM = DLANST( 'M', N, D, E )
+ IF( TNRM.GT.ZERO .AND. TNRM.LT.RMIN ) THEN
+ SCALE = RMIN / TNRM
+ ELSE IF( TNRM.GT.RMAX ) THEN
+ SCALE = RMAX / TNRM
+ END IF
+ IF( SCALE.NE.ONE ) THEN
+ CALL DSCAL( N, SCALE, D, 1 )
+ CALL DSCAL( N-1, SCALE, E, 1 )
+ TNRM = TNRM*SCALE
+ IF( VALEIG ) THEN
+* If eigenvalues in interval have to be found,
+* scale (WL, WU] accordingly
+ WL = WL*SCALE
+ WU = WU*SCALE
+ ENDIF
+ END IF
+*
+* Compute the desired eigenvalues of the tridiagonal after splitting
+* into smaller subblocks if the corresponding off-diagonal elements
+* are small
+* THRESH is the splitting parameter for DLARRE
+* A negative THRESH forces the old splitting criterion based on the
+* size of the off-diagonal. A positive THRESH switches to splitting
+* which preserves relative accuracy.
+*
+ IF( TRYRAC ) THEN
+* Test whether the matrix warrants the more expensive relative approach.
+ CALL DLARRR( N, D, E, IINFO )
+ ELSE
+* The user does not care about relative accurately eigenvalues
+ IINFO = -1
+ ENDIF
+* Set the splitting criterion
+ IF (IINFO.EQ.0) THEN
+ THRESH = EPS
+ ELSE
+ THRESH = -EPS
+* relative accuracy is desired but T does not guarantee it
+ TRYRAC = .FALSE.
+ ENDIF
+*
+ IF( TRYRAC ) THEN
+* Copy original diagonal, needed to guarantee relative accuracy
+ CALL DCOPY(N,D,1,WORK(INDD),1)
+ ENDIF
+* Store the squares of the offdiagonal values of T
+ DO 5 J = 1, N-1
+ WORK( INDE2+J-1 ) = E(J)**2
+ 5 CONTINUE
+
+* Set the tolerance parameters for bisection
+ IF( .NOT.WANTZ ) THEN
+* DLARRE computes the eigenvalues to full precision.
+ RTOL1 = FOUR * EPS
+ RTOL2 = FOUR * EPS
+ ELSE
+* DLARRE computes the eigenvalues to less than full precision.
+* DLARRV will refine the eigenvalue approximations, and we can
+* need less accurate initial bisection in DLARRE.
+* Note: these settings do only affect the subset case and DLARRE
+ RTOL1 = SQRT(EPS)
+ RTOL2 = MAX( SQRT(EPS)*5.0D-3, FOUR * EPS )
+ ENDIF
+ CALL DLARRE( RANGE, N, WL, WU, IIL, IIU, D, E,
+ $ WORK(INDE2), RTOL1, RTOL2, THRESH, NSPLIT,
+ $ IWORK( IINSPL ), M, W, WORK( INDERR ),
+ $ WORK( INDGP ), IWORK( IINDBL ),
+ $ IWORK( IINDW ), WORK( INDGRS ), PIVMIN,
+ $ WORK( INDWRK ), IWORK( IINDWK ), IINFO )
+ IF( IINFO.NE.0 ) THEN
+ INFO = 10 + ABS( IINFO )
+ RETURN
+ END IF
+* Note that if RANGE .NE. 'V', DLARRE computes bounds on the desired
+* part of the spectrum. All desired eigenvalues are contained in
+* (WL,WU]
+
+
+ IF( WANTZ ) THEN
+*
+* Compute the desired eigenvectors corresponding to the computed
+* eigenvalues
+*
+ CALL DLARRV( N, WL, WU, D, E,
+ $ PIVMIN, IWORK( IINSPL ), M,
+ $ 1, M, MINRGP, RTOL1, RTOL2,
+ $ W, WORK( INDERR ), WORK( INDGP ), IWORK( IINDBL ),
+ $ IWORK( IINDW ), WORK( INDGRS ), Z, LDZ,
+ $ ISUPPZ, WORK( INDWRK ), IWORK( IINDWK ), IINFO )
+ IF( IINFO.NE.0 ) THEN
+ INFO = 20 + ABS( IINFO )
+ RETURN
+ END IF
+ ELSE
+* DLARRE computes eigenvalues of the (shifted) root representation
+* DLARRV returns the eigenvalues of the unshifted matrix.
+* However, if the eigenvectors are not desired by the user, we need
+* to apply the corresponding shifts from DLARRE to obtain the
+* eigenvalues of the original matrix.
+ DO 20 J = 1, M
+ ITMP = IWORK( IINDBL+J-1 )
+ W( J ) = W( J ) + E( IWORK( IINSPL+ITMP-1 ) )
+ 20 CONTINUE
+ END IF
+*
+
+ IF ( TRYRAC ) THEN
+* Refine computed eigenvalues so that they are relatively accurate
+* with respect to the original matrix T.
+ IBEGIN = 1
+ WBEGIN = 1
+ DO 39 JBLK = 1, IWORK( IINDBL+M-1 )
+ IEND = IWORK( IINSPL+JBLK-1 )
+ IN = IEND - IBEGIN + 1
+ WEND = WBEGIN - 1
+* check if any eigenvalues have to be refined in this block
+ 36 CONTINUE
+ IF( WEND.LT.M ) THEN
+ IF( IWORK( IINDBL+WEND ).EQ.JBLK ) THEN
+ WEND = WEND + 1
+ GO TO 36
+ END IF
+ END IF
+ IF( WEND.LT.WBEGIN ) THEN
+ IBEGIN = IEND + 1
+ GO TO 39
+ END IF
+
+ OFFSET = IWORK(IINDW+WBEGIN-1)-1
+ IFIRST = IWORK(IINDW+WBEGIN-1)
+ ILAST = IWORK(IINDW+WEND-1)
+ RTOL2 = FOUR * EPS
+ CALL DLARRJ( IN,
+ $ WORK(INDD+IBEGIN-1), WORK(INDE2+IBEGIN-1),
+ $ IFIRST, ILAST, RTOL2, OFFSET, W(WBEGIN),
+ $ WORK( INDERR+WBEGIN-1 ),
+ $ WORK( INDWRK ), IWORK( IINDWK ), PIVMIN,
+ $ TNRM, IINFO )
+ IBEGIN = IEND + 1
+ WBEGIN = WEND + 1
+ 39 CONTINUE
+ ENDIF
+*
+* If matrix was scaled, then rescale eigenvalues appropriately.
+*
+ IF( SCALE.NE.ONE ) THEN
+ CALL DSCAL( M, ONE / SCALE, W, 1 )
+ END IF
+*
+* If eigenvalues are not in increasing order, then sort them,
+* possibly along with eigenvectors.
+*
+ IF( NSPLIT.GT.1 ) THEN
+ IF( .NOT. WANTZ ) THEN
+ CALL DLASRT( 'I', M, W, IINFO )
+ IF( IINFO.NE.0 ) THEN
+ INFO = 3
+ RETURN
+ END IF
+ ELSE
+ DO 60 J = 1, M - 1
+ I = 0
+ TMP = W( J )
+ DO 50 JJ = J + 1, M
+ IF( W( JJ ).LT.TMP ) THEN
+ I = JJ
+ TMP = W( JJ )
+ END IF
+ 50 CONTINUE
+ IF( I.NE.0 ) THEN
+ W( I ) = W( J )
+ W( J ) = TMP
+ IF( WANTZ ) THEN
+ CALL DSWAP( N, Z( 1, I ), 1, Z( 1, J ), 1 )
+ ITMP = ISUPPZ( 2*I-1 )
+ ISUPPZ( 2*I-1 ) = ISUPPZ( 2*J-1 )
+ ISUPPZ( 2*J-1 ) = ITMP
+ ITMP = ISUPPZ( 2*I )
+ ISUPPZ( 2*I ) = ISUPPZ( 2*J )
+ ISUPPZ( 2*J ) = ITMP
+ END IF
+ END IF
+ 60 CONTINUE
+ END IF
+ ENDIF
+*
+*
+ WORK( 1 ) = LWMIN
+ IWORK( 1 ) = LIWMIN
+ RETURN
+*
+* End of DSTEMR
+*
+ END
+ SUBROUTINE DSTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER COMPZ
+ INTEGER INFO, LDZ, N
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION D( * ), E( * ), WORK( * ), Z( LDZ, * )
+* ..
+*
+* Purpose
+* =======
+*
+* DSTEQR computes all eigenvalues and, optionally, eigenvectors of a
+* symmetric tridiagonal matrix using the implicit QL or QR method.
+* The eigenvectors of a full or band symmetric matrix can also be found
+* if DSYTRD or DSPTRD or DSBTRD has been used to reduce this matrix to
+* tridiagonal form.
+*
+* Arguments
+* =========
+*
+* COMPZ (input) CHARACTER*1
+* = 'N': Compute eigenvalues only.
+* = 'V': Compute eigenvalues and eigenvectors of the original
+* symmetric matrix. On entry, Z must contain the
+* orthogonal matrix used to reduce the original matrix
+* to tridiagonal form.
+* = 'I': Compute eigenvalues and eigenvectors of the
+* tridiagonal matrix. Z is initialized to the identity
+* matrix.
+*
+* N (input) INTEGER
+* The order of the matrix. N >= 0.
+*
+* D (input/output) DOUBLE PRECISION array, dimension (N)
+* On entry, the diagonal elements of the tridiagonal matrix.
+* On exit, if INFO = 0, the eigenvalues in ascending order.
+*
+* E (input/output) DOUBLE PRECISION array, dimension (N-1)
+* On entry, the (n-1) subdiagonal elements of the tridiagonal
+* matrix.
+* On exit, E has been destroyed.
+*
+* Z (input/output) DOUBLE PRECISION array, dimension (LDZ, N)
+* On entry, if COMPZ = 'V', then Z contains the orthogonal
+* matrix used in the reduction to tridiagonal form.
+* On exit, if INFO = 0, then if COMPZ = 'V', Z contains the
+* orthonormal eigenvectors of the original symmetric matrix,
+* and if COMPZ = 'I', Z contains the orthonormal eigenvectors
+* of the symmetric tridiagonal matrix.
+* If COMPZ = 'N', then Z is not referenced.
+*
+* LDZ (input) INTEGER
+* The leading dimension of the array Z. LDZ >= 1, and if
+* eigenvectors are desired, then LDZ >= max(1,N).
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (max(1,2*N-2))
+* If COMPZ = 'N', then WORK is not referenced.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* > 0: the algorithm has failed to find all the eigenvalues in
+* a total of 30*N iterations; if INFO = i, then i
+* elements of E have not converged to zero; on exit, D
+* and E contain the elements of a symmetric tridiagonal
+* matrix which is orthogonally similar to the original
+* matrix.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE, TWO, THREE
+ PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0,
+ $ THREE = 3.0D0 )
+ INTEGER MAXIT
+ PARAMETER ( MAXIT = 30 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, ICOMPZ, II, ISCALE, J, JTOT, K, L, L1, LEND,
+ $ LENDM1, LENDP1, LENDSV, LM1, LSV, M, MM, MM1,
+ $ NM1, NMAXIT
+ DOUBLE PRECISION ANORM, B, C, EPS, EPS2, F, G, P, R, RT1, RT2,
+ $ S, SAFMAX, SAFMIN, SSFMAX, SSFMIN, TST
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ DOUBLE PRECISION DLAMCH, DLANST, DLAPY2
+ EXTERNAL LSAME, DLAMCH, DLANST, DLAPY2
+* ..
+* .. External Subroutines ..
+ EXTERNAL DLAE2, DLAEV2, DLARTG, DLASCL, DLASET, DLASR,
+ $ DLASRT, DSWAP, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, SIGN, SQRT
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+*
+ IF( LSAME( COMPZ, 'N' ) ) THEN
+ ICOMPZ = 0
+ ELSE IF( LSAME( COMPZ, 'V' ) ) THEN
+ ICOMPZ = 1
+ ELSE IF( LSAME( COMPZ, 'I' ) ) THEN
+ ICOMPZ = 2
+ ELSE
+ ICOMPZ = -1
+ END IF
+ IF( ICOMPZ.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( ( LDZ.LT.1 ) .OR. ( ICOMPZ.GT.0 .AND. LDZ.LT.MAX( 1,
+ $ N ) ) ) THEN
+ INFO = -6
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DSTEQR', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+ IF( N.EQ.1 ) THEN
+ IF( ICOMPZ.EQ.2 )
+ $ Z( 1, 1 ) = ONE
+ RETURN
+ END IF
+*
+* Determine the unit roundoff and over/underflow thresholds.
+*
+ EPS = DLAMCH( 'E' )
+ EPS2 = EPS**2
+ SAFMIN = DLAMCH( 'S' )
+ SAFMAX = ONE / SAFMIN
+ SSFMAX = SQRT( SAFMAX ) / THREE
+ SSFMIN = SQRT( SAFMIN ) / EPS2
+*
+* Compute the eigenvalues and eigenvectors of the tridiagonal
+* matrix.
+*
+ IF( ICOMPZ.EQ.2 )
+ $ CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDZ )
+*
+ NMAXIT = N*MAXIT
+ JTOT = 0
+*
+* Determine where the matrix splits and choose QL or QR iteration
+* for each block, according to whether top or bottom diagonal
+* element is smaller.
+*
+ L1 = 1
+ NM1 = N - 1
+*
+ 10 CONTINUE
+ IF( L1.GT.N )
+ $ GO TO 160
+ IF( L1.GT.1 )
+ $ E( L1-1 ) = ZERO
+ IF( L1.LE.NM1 ) THEN
+ DO 20 M = L1, NM1
+ TST = ABS( E( M ) )
+ IF( TST.EQ.ZERO )
+ $ GO TO 30
+ IF( TST.LE.( SQRT( ABS( D( M ) ) )*SQRT( ABS( D( M+
+ $ 1 ) ) ) )*EPS ) THEN
+ E( M ) = ZERO
+ GO TO 30
+ END IF
+ 20 CONTINUE
+ END IF
+ M = N
+*
+ 30 CONTINUE
+ L = L1
+ LSV = L
+ LEND = M
+ LENDSV = LEND
+ L1 = M + 1
+ IF( LEND.EQ.L )
+ $ GO TO 10
+*
+* Scale submatrix in rows and columns L to LEND
+*
+ ANORM = DLANST( 'I', LEND-L+1, D( L ), E( L ) )
+ ISCALE = 0
+ IF( ANORM.EQ.ZERO )
+ $ GO TO 10
+ IF( ANORM.GT.SSFMAX ) THEN
+ ISCALE = 1
+ CALL DLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L+1, 1, D( L ), N,
+ $ INFO )
+ CALL DLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L, 1, E( L ), N,
+ $ INFO )
+ ELSE IF( ANORM.LT.SSFMIN ) THEN
+ ISCALE = 2
+ CALL DLASCL( 'G', 0, 0, ANORM, SSFMIN, LEND-L+1, 1, D( L ), N,
+ $ INFO )
+ CALL DLASCL( 'G', 0, 0, ANORM, SSFMIN, LEND-L, 1, E( L ), N,
+ $ INFO )
+ END IF
+*
+* Choose between QL and QR iteration
+*
+ IF( ABS( D( LEND ) ).LT.ABS( D( L ) ) ) THEN
+ LEND = LSV
+ L = LENDSV
+ END IF
+*
+ IF( LEND.GT.L ) THEN
+*
+* QL Iteration
+*
+* Look for small subdiagonal element.
+*
+ 40 CONTINUE
+ IF( L.NE.LEND ) THEN
+ LENDM1 = LEND - 1
+ DO 50 M = L, LENDM1
+ TST = ABS( E( M ) )**2
+ IF( TST.LE.( EPS2*ABS( D( M ) ) )*ABS( D( M+1 ) )+
+ $ SAFMIN )GO TO 60
+ 50 CONTINUE
+ END IF
+*
+ M = LEND
+*
+ 60 CONTINUE
+ IF( M.LT.LEND )
+ $ E( M ) = ZERO
+ P = D( L )
+ IF( M.EQ.L )
+ $ GO TO 80
+*
+* If remaining matrix is 2-by-2, use DLAE2 or SLAEV2
+* to compute its eigensystem.
+*
+ IF( M.EQ.L+1 ) THEN
+ IF( ICOMPZ.GT.0 ) THEN
+ CALL DLAEV2( D( L ), E( L ), D( L+1 ), RT1, RT2, C, S )
+ WORK( L ) = C
+ WORK( N-1+L ) = S
+ CALL DLASR( 'R', 'V', 'B', N, 2, WORK( L ),
+ $ WORK( N-1+L ), Z( 1, L ), LDZ )
+ ELSE
+ CALL DLAE2( D( L ), E( L ), D( L+1 ), RT1, RT2 )
+ END IF
+ D( L ) = RT1
+ D( L+1 ) = RT2
+ E( L ) = ZERO
+ L = L + 2
+ IF( L.LE.LEND )
+ $ GO TO 40
+ GO TO 140
+ END IF
+*
+ IF( JTOT.EQ.NMAXIT )
+ $ GO TO 140
+ JTOT = JTOT + 1
+*
+* Form shift.
+*
+ G = ( D( L+1 )-P ) / ( TWO*E( L ) )
+ R = DLAPY2( G, ONE )
+ G = D( M ) - P + ( E( L ) / ( G+SIGN( R, G ) ) )
+*
+ S = ONE
+ C = ONE
+ P = ZERO
+*
+* Inner loop
+*
+ MM1 = M - 1
+ DO 70 I = MM1, L, -1
+ F = S*E( I )
+ B = C*E( I )
+ CALL DLARTG( G, F, C, S, R )
+ IF( I.NE.M-1 )
+ $ E( I+1 ) = R
+ G = D( I+1 ) - P
+ R = ( D( I )-G )*S + TWO*C*B
+ P = S*R
+ D( I+1 ) = G + P
+ G = C*R - B
+*
+* If eigenvectors are desired, then save rotations.
+*
+ IF( ICOMPZ.GT.0 ) THEN
+ WORK( I ) = C
+ WORK( N-1+I ) = -S
+ END IF
+*
+ 70 CONTINUE
+*
+* If eigenvectors are desired, then apply saved rotations.
+*
+ IF( ICOMPZ.GT.0 ) THEN
+ MM = M - L + 1
+ CALL DLASR( 'R', 'V', 'B', N, MM, WORK( L ), WORK( N-1+L ),
+ $ Z( 1, L ), LDZ )
+ END IF
+*
+ D( L ) = D( L ) - P
+ E( L ) = G
+ GO TO 40
+*
+* Eigenvalue found.
+*
+ 80 CONTINUE
+ D( L ) = P
+*
+ L = L + 1
+ IF( L.LE.LEND )
+ $ GO TO 40
+ GO TO 140
+*
+ ELSE
+*
+* QR Iteration
+*
+* Look for small superdiagonal element.
+*
+ 90 CONTINUE
+ IF( L.NE.LEND ) THEN
+ LENDP1 = LEND + 1
+ DO 100 M = L, LENDP1, -1
+ TST = ABS( E( M-1 ) )**2
+ IF( TST.LE.( EPS2*ABS( D( M ) ) )*ABS( D( M-1 ) )+
+ $ SAFMIN )GO TO 110
+ 100 CONTINUE
+ END IF
+*
+ M = LEND
+*
+ 110 CONTINUE
+ IF( M.GT.LEND )
+ $ E( M-1 ) = ZERO
+ P = D( L )
+ IF( M.EQ.L )
+ $ GO TO 130
+*
+* If remaining matrix is 2-by-2, use DLAE2 or SLAEV2
+* to compute its eigensystem.
+*
+ IF( M.EQ.L-1 ) THEN
+ IF( ICOMPZ.GT.0 ) THEN
+ CALL DLAEV2( D( L-1 ), E( L-1 ), D( L ), RT1, RT2, C, S )
+ WORK( M ) = C
+ WORK( N-1+M ) = S
+ CALL DLASR( 'R', 'V', 'F', N, 2, WORK( M ),
+ $ WORK( N-1+M ), Z( 1, L-1 ), LDZ )
+ ELSE
+ CALL DLAE2( D( L-1 ), E( L-1 ), D( L ), RT1, RT2 )
+ END IF
+ D( L-1 ) = RT1
+ D( L ) = RT2
+ E( L-1 ) = ZERO
+ L = L - 2
+ IF( L.GE.LEND )
+ $ GO TO 90
+ GO TO 140
+ END IF
+*
+ IF( JTOT.EQ.NMAXIT )
+ $ GO TO 140
+ JTOT = JTOT + 1
+*
+* Form shift.
+*
+ G = ( D( L-1 )-P ) / ( TWO*E( L-1 ) )
+ R = DLAPY2( G, ONE )
+ G = D( M ) - P + ( E( L-1 ) / ( G+SIGN( R, G ) ) )
+*
+ S = ONE
+ C = ONE
+ P = ZERO
+*
+* Inner loop
+*
+ LM1 = L - 1
+ DO 120 I = M, LM1
+ F = S*E( I )
+ B = C*E( I )
+ CALL DLARTG( G, F, C, S, R )
+ IF( I.NE.M )
+ $ E( I-1 ) = R
+ G = D( I ) - P
+ R = ( D( I+1 )-G )*S + TWO*C*B
+ P = S*R
+ D( I ) = G + P
+ G = C*R - B
+*
+* If eigenvectors are desired, then save rotations.
+*
+ IF( ICOMPZ.GT.0 ) THEN
+ WORK( I ) = C
+ WORK( N-1+I ) = S
+ END IF
+*
+ 120 CONTINUE
+*
+* If eigenvectors are desired, then apply saved rotations.
+*
+ IF( ICOMPZ.GT.0 ) THEN
+ MM = L - M + 1
+ CALL DLASR( 'R', 'V', 'F', N, MM, WORK( M ), WORK( N-1+M ),
+ $ Z( 1, M ), LDZ )
+ END IF
+*
+ D( L ) = D( L ) - P
+ E( LM1 ) = G
+ GO TO 90
+*
+* Eigenvalue found.
+*
+ 130 CONTINUE
+ D( L ) = P
+*
+ L = L - 1
+ IF( L.GE.LEND )
+ $ GO TO 90
+ GO TO 140
+*
+ END IF
+*
+* Undo scaling if necessary
+*
+ 140 CONTINUE
+ IF( ISCALE.EQ.1 ) THEN
+ CALL DLASCL( 'G', 0, 0, SSFMAX, ANORM, LENDSV-LSV+1, 1,
+ $ D( LSV ), N, INFO )
+ CALL DLASCL( 'G', 0, 0, SSFMAX, ANORM, LENDSV-LSV, 1, E( LSV ),
+ $ N, INFO )
+ ELSE IF( ISCALE.EQ.2 ) THEN
+ CALL DLASCL( 'G', 0, 0, SSFMIN, ANORM, LENDSV-LSV+1, 1,
+ $ D( LSV ), N, INFO )
+ CALL DLASCL( 'G', 0, 0, SSFMIN, ANORM, LENDSV-LSV, 1, E( LSV ),
+ $ N, INFO )
+ END IF
+*
+* Check for no convergence to an eigenvalue after a total
+* of N*MAXIT iterations.
+*
+ IF( JTOT.LT.NMAXIT )
+ $ GO TO 10
+ DO 150 I = 1, N - 1
+ IF( E( I ).NE.ZERO )
+ $ INFO = INFO + 1
+ 150 CONTINUE
+ GO TO 190
+*
+* Order eigenvalues and eigenvectors.
+*
+ 160 CONTINUE
+ IF( ICOMPZ.EQ.0 ) THEN
+*
+* Use Quick Sort
+*
+ CALL DLASRT( 'I', N, D, INFO )
+*
+ ELSE
+*
+* Use Selection Sort to minimize swaps of eigenvectors
+*
+ DO 180 II = 2, N
+ I = II - 1
+ K = I
+ P = D( I )
+ DO 170 J = II, N
+ IF( D( J ).LT.P ) THEN
+ K = J
+ P = D( J )
+ END IF
+ 170 CONTINUE
+ IF( K.NE.I ) THEN
+ D( K ) = D( I )
+ D( I ) = P
+ CALL DSWAP( N, Z( 1, I ), 1, Z( 1, K ), 1 )
+ END IF
+ 180 CONTINUE
+ END IF
+*
+ 190 CONTINUE
+ RETURN
+*
+* End of DSTEQR
+*
+ END
+ SUBROUTINE DSTERF( N, D, E, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, N
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION D( * ), E( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DSTERF computes all eigenvalues of a symmetric tridiagonal matrix
+* using the Pal-Walker-Kahan variant of the QL or QR algorithm.
+*
+* Arguments
+* =========
+*
+* N (input) INTEGER
+* The order of the matrix. N >= 0.
+*
+* D (input/output) DOUBLE PRECISION array, dimension (N)
+* On entry, the n diagonal elements of the tridiagonal matrix.
+* On exit, if INFO = 0, the eigenvalues in ascending order.
+*
+* E (input/output) DOUBLE PRECISION array, dimension (N-1)
+* On entry, the (n-1) subdiagonal elements of the tridiagonal
+* matrix.
+* On exit, E has been destroyed.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* > 0: the algorithm failed to find all of the eigenvalues in
+* a total of 30*N iterations; if INFO = i, then i
+* elements of E have not converged to zero.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE, TWO, THREE
+ PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0,
+ $ THREE = 3.0D0 )
+ INTEGER MAXIT
+ PARAMETER ( MAXIT = 30 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, ISCALE, JTOT, L, L1, LEND, LENDSV, LSV, M,
+ $ NMAXIT
+ DOUBLE PRECISION ALPHA, ANORM, BB, C, EPS, EPS2, GAMMA, OLDC,
+ $ OLDGAM, P, R, RT1, RT2, RTE, S, SAFMAX, SAFMIN,
+ $ SIGMA, SSFMAX, SSFMIN
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DLAMCH, DLANST, DLAPY2
+ EXTERNAL DLAMCH, DLANST, DLAPY2
+* ..
+* .. External Subroutines ..
+ EXTERNAL DLAE2, DLASCL, DLASRT, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, SIGN, SQRT
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+*
+* Quick return if possible
+*
+ IF( N.LT.0 ) THEN
+ INFO = -1
+ CALL XERBLA( 'DSTERF', -INFO )
+ RETURN
+ END IF
+ IF( N.LE.1 )
+ $ RETURN
+*
+* Determine the unit roundoff for this environment.
+*
+ EPS = DLAMCH( 'E' )
+ EPS2 = EPS**2
+ SAFMIN = DLAMCH( 'S' )
+ SAFMAX = ONE / SAFMIN
+ SSFMAX = SQRT( SAFMAX ) / THREE
+ SSFMIN = SQRT( SAFMIN ) / EPS2
+*
+* Compute the eigenvalues of the tridiagonal matrix.
+*
+ NMAXIT = N*MAXIT
+ SIGMA = ZERO
+ JTOT = 0
+*
+* Determine where the matrix splits and choose QL or QR iteration
+* for each block, according to whether top or bottom diagonal
+* element is smaller.
+*
+ L1 = 1
+*
+ 10 CONTINUE
+ IF( L1.GT.N )
+ $ GO TO 170
+ IF( L1.GT.1 )
+ $ E( L1-1 ) = ZERO
+ DO 20 M = L1, N - 1
+ IF( ABS( E( M ) ).LE.( SQRT( ABS( D( M ) ) )*SQRT( ABS( D( M+
+ $ 1 ) ) ) )*EPS ) THEN
+ E( M ) = ZERO
+ GO TO 30
+ END IF
+ 20 CONTINUE
+ M = N
+*
+ 30 CONTINUE
+ L = L1
+ LSV = L
+ LEND = M
+ LENDSV = LEND
+ L1 = M + 1
+ IF( LEND.EQ.L )
+ $ GO TO 10
+*
+* Scale submatrix in rows and columns L to LEND
+*
+ ANORM = DLANST( 'I', LEND-L+1, D( L ), E( L ) )
+ ISCALE = 0
+ IF( ANORM.GT.SSFMAX ) THEN
+ ISCALE = 1
+ CALL DLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L+1, 1, D( L ), N,
+ $ INFO )
+ CALL DLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L, 1, E( L ), N,
+ $ INFO )
+ ELSE IF( ANORM.LT.SSFMIN ) THEN
+ ISCALE = 2
+ CALL DLASCL( 'G', 0, 0, ANORM, SSFMIN, LEND-L+1, 1, D( L ), N,
+ $ INFO )
+ CALL DLASCL( 'G', 0, 0, ANORM, SSFMIN, LEND-L, 1, E( L ), N,
+ $ INFO )
+ END IF
+*
+ DO 40 I = L, LEND - 1
+ E( I ) = E( I )**2
+ 40 CONTINUE
+*
+* Choose between QL and QR iteration
+*
+ IF( ABS( D( LEND ) ).LT.ABS( D( L ) ) ) THEN
+ LEND = LSV
+ L = LENDSV
+ END IF
+*
+ IF( LEND.GE.L ) THEN
+*
+* QL Iteration
+*
+* Look for small subdiagonal element.
+*
+ 50 CONTINUE
+ IF( L.NE.LEND ) THEN
+ DO 60 M = L, LEND - 1
+ IF( ABS( E( M ) ).LE.EPS2*ABS( D( M )*D( M+1 ) ) )
+ $ GO TO 70
+ 60 CONTINUE
+ END IF
+ M = LEND
+*
+ 70 CONTINUE
+ IF( M.LT.LEND )
+ $ E( M ) = ZERO
+ P = D( L )
+ IF( M.EQ.L )
+ $ GO TO 90
+*
+* If remaining matrix is 2 by 2, use DLAE2 to compute its
+* eigenvalues.
+*
+ IF( M.EQ.L+1 ) THEN
+ RTE = SQRT( E( L ) )
+ CALL DLAE2( D( L ), RTE, D( L+1 ), RT1, RT2 )
+ D( L ) = RT1
+ D( L+1 ) = RT2
+ E( L ) = ZERO
+ L = L + 2
+ IF( L.LE.LEND )
+ $ GO TO 50
+ GO TO 150
+ END IF
+*
+ IF( JTOT.EQ.NMAXIT )
+ $ GO TO 150
+ JTOT = JTOT + 1
+*
+* Form shift.
+*
+ RTE = SQRT( E( L ) )
+ SIGMA = ( D( L+1 )-P ) / ( TWO*RTE )
+ R = DLAPY2( SIGMA, ONE )
+ SIGMA = P - ( RTE / ( SIGMA+SIGN( R, SIGMA ) ) )
+*
+ C = ONE
+ S = ZERO
+ GAMMA = D( M ) - SIGMA
+ P = GAMMA*GAMMA
+*
+* Inner loop
+*
+ DO 80 I = M - 1, L, -1
+ BB = E( I )
+ R = P + BB
+ IF( I.NE.M-1 )
+ $ E( I+1 ) = S*R
+ OLDC = C
+ C = P / R
+ S = BB / R
+ OLDGAM = GAMMA
+ ALPHA = D( I )
+ GAMMA = C*( ALPHA-SIGMA ) - S*OLDGAM
+ D( I+1 ) = OLDGAM + ( ALPHA-GAMMA )
+ IF( C.NE.ZERO ) THEN
+ P = ( GAMMA*GAMMA ) / C
+ ELSE
+ P = OLDC*BB
+ END IF
+ 80 CONTINUE
+*
+ E( L ) = S*P
+ D( L ) = SIGMA + GAMMA
+ GO TO 50
+*
+* Eigenvalue found.
+*
+ 90 CONTINUE
+ D( L ) = P
+*
+ L = L + 1
+ IF( L.LE.LEND )
+ $ GO TO 50
+ GO TO 150
+*
+ ELSE
+*
+* QR Iteration
+*
+* Look for small superdiagonal element.
+*
+ 100 CONTINUE
+ DO 110 M = L, LEND + 1, -1
+ IF( ABS( E( M-1 ) ).LE.EPS2*ABS( D( M )*D( M-1 ) ) )
+ $ GO TO 120
+ 110 CONTINUE
+ M = LEND
+*
+ 120 CONTINUE
+ IF( M.GT.LEND )
+ $ E( M-1 ) = ZERO
+ P = D( L )
+ IF( M.EQ.L )
+ $ GO TO 140
+*
+* If remaining matrix is 2 by 2, use DLAE2 to compute its
+* eigenvalues.
+*
+ IF( M.EQ.L-1 ) THEN
+ RTE = SQRT( E( L-1 ) )
+ CALL DLAE2( D( L ), RTE, D( L-1 ), RT1, RT2 )
+ D( L ) = RT1
+ D( L-1 ) = RT2
+ E( L-1 ) = ZERO
+ L = L - 2
+ IF( L.GE.LEND )
+ $ GO TO 100
+ GO TO 150
+ END IF
+*
+ IF( JTOT.EQ.NMAXIT )
+ $ GO TO 150
+ JTOT = JTOT + 1
+*
+* Form shift.
+*
+ RTE = SQRT( E( L-1 ) )
+ SIGMA = ( D( L-1 )-P ) / ( TWO*RTE )
+ R = DLAPY2( SIGMA, ONE )
+ SIGMA = P - ( RTE / ( SIGMA+SIGN( R, SIGMA ) ) )
+*
+ C = ONE
+ S = ZERO
+ GAMMA = D( M ) - SIGMA
+ P = GAMMA*GAMMA
+*
+* Inner loop
+*
+ DO 130 I = M, L - 1
+ BB = E( I )
+ R = P + BB
+ IF( I.NE.M )
+ $ E( I-1 ) = S*R
+ OLDC = C
+ C = P / R
+ S = BB / R
+ OLDGAM = GAMMA
+ ALPHA = D( I+1 )
+ GAMMA = C*( ALPHA-SIGMA ) - S*OLDGAM
+ D( I ) = OLDGAM + ( ALPHA-GAMMA )
+ IF( C.NE.ZERO ) THEN
+ P = ( GAMMA*GAMMA ) / C
+ ELSE
+ P = OLDC*BB
+ END IF
+ 130 CONTINUE
+*
+ E( L-1 ) = S*P
+ D( L ) = SIGMA + GAMMA
+ GO TO 100
+*
+* Eigenvalue found.
+*
+ 140 CONTINUE
+ D( L ) = P
+*
+ L = L - 1
+ IF( L.GE.LEND )
+ $ GO TO 100
+ GO TO 150
+*
+ END IF
+*
+* Undo scaling if necessary
+*
+ 150 CONTINUE
+ IF( ISCALE.EQ.1 )
+ $ CALL DLASCL( 'G', 0, 0, SSFMAX, ANORM, LENDSV-LSV+1, 1,
+ $ D( LSV ), N, INFO )
+ IF( ISCALE.EQ.2 )
+ $ CALL DLASCL( 'G', 0, 0, SSFMIN, ANORM, LENDSV-LSV+1, 1,
+ $ D( LSV ), N, INFO )
+*
+* Check for no convergence to an eigenvalue after a total
+* of N*MAXIT iterations.
+*
+ IF( JTOT.LT.NMAXIT )
+ $ GO TO 10
+ DO 160 I = 1, N - 1
+ IF( E( I ).NE.ZERO )
+ $ INFO = INFO + 1
+ 160 CONTINUE
+ GO TO 180
+*
+* Sort eigenvalues in increasing order.
+*
+ 170 CONTINUE
+ CALL DLASRT( 'I', N, D, INFO )
+*
+ 180 CONTINUE
+ RETURN
+*
+* End of DSTERF
+*
+ END
+ SUBROUTINE DSTEV( JOBZ, N, D, E, Z, LDZ, WORK, INFO )
+*
+* -- LAPACK driver routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER JOBZ
+ INTEGER INFO, LDZ, N
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION D( * ), E( * ), WORK( * ), Z( LDZ, * )
+* ..
+*
+* Purpose
+* =======
+*
+* DSTEV computes all eigenvalues and, optionally, eigenvectors of a
+* real symmetric tridiagonal matrix A.
+*
+* Arguments
+* =========
+*
+* JOBZ (input) CHARACTER*1
+* = 'N': Compute eigenvalues only;
+* = 'V': Compute eigenvalues and eigenvectors.
+*
+* N (input) INTEGER
+* The order of the matrix. N >= 0.
+*
+* D (input/output) DOUBLE PRECISION array, dimension (N)
+* On entry, the n diagonal elements of the tridiagonal matrix
+* A.
+* On exit, if INFO = 0, the eigenvalues in ascending order.
+*
+* E (input/output) DOUBLE PRECISION array, dimension (N-1)
+* On entry, the (n-1) subdiagonal elements of the tridiagonal
+* matrix A, stored in elements 1 to N-1 of E.
+* On exit, the contents of E are destroyed.
+*
+* Z (output) DOUBLE PRECISION array, dimension (LDZ, N)
+* If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal
+* eigenvectors of the matrix A, with the i-th column of Z
+* holding the eigenvector associated with D(i).
+* If JOBZ = 'N', then Z is not referenced.
+*
+* LDZ (input) INTEGER
+* The leading dimension of the array Z. LDZ >= 1, and if
+* JOBZ = 'V', LDZ >= max(1,N).
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (max(1,2*N-2))
+* If JOBZ = 'N', WORK is not referenced.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* > 0: if INFO = i, the algorithm failed to converge; i
+* off-diagonal elements of E did not converge to zero.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL WANTZ
+ INTEGER IMAX, ISCALE
+ DOUBLE PRECISION BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA, SMLNUM,
+ $ TNRM
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ DOUBLE PRECISION DLAMCH, DLANST
+ EXTERNAL LSAME, DLAMCH, DLANST
+* ..
+* .. External Subroutines ..
+ EXTERNAL DSCAL, DSTEQR, DSTERF, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC SQRT
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ WANTZ = LSAME( JOBZ, 'V' )
+*
+ INFO = 0
+ IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
+ INFO = -6
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DSTEV ', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+ IF( N.EQ.1 ) THEN
+ IF( WANTZ )
+ $ Z( 1, 1 ) = ONE
+ RETURN
+ END IF
+*
+* Get machine constants.
+*
+ SAFMIN = DLAMCH( 'Safe minimum' )
+ EPS = DLAMCH( 'Precision' )
+ SMLNUM = SAFMIN / EPS
+ BIGNUM = ONE / SMLNUM
+ RMIN = SQRT( SMLNUM )
+ RMAX = SQRT( BIGNUM )
+*
+* Scale matrix to allowable range, if necessary.
+*
+ ISCALE = 0
+ TNRM = DLANST( 'M', N, D, E )
+ IF( TNRM.GT.ZERO .AND. TNRM.LT.RMIN ) THEN
+ ISCALE = 1
+ SIGMA = RMIN / TNRM
+ ELSE IF( TNRM.GT.RMAX ) THEN
+ ISCALE = 1
+ SIGMA = RMAX / TNRM
+ END IF
+ IF( ISCALE.EQ.1 ) THEN
+ CALL DSCAL( N, SIGMA, D, 1 )
+ CALL DSCAL( N-1, SIGMA, E( 1 ), 1 )
+ END IF
+*
+* For eigenvalues only, call DSTERF. For eigenvalues and
+* eigenvectors, call DSTEQR.
+*
+ IF( .NOT.WANTZ ) THEN
+ CALL DSTERF( N, D, E, INFO )
+ ELSE
+ CALL DSTEQR( 'I', N, D, E, Z, LDZ, WORK, INFO )
+ END IF
+*
+* If matrix was scaled, then rescale eigenvalues appropriately.
+*
+ IF( ISCALE.EQ.1 ) THEN
+ IF( INFO.EQ.0 ) THEN
+ IMAX = N
+ ELSE
+ IMAX = INFO - 1
+ END IF
+ CALL DSCAL( IMAX, ONE / SIGMA, D, 1 )
+ END IF
+*
+ RETURN
+*
+* End of DSTEV
+*
+ END
+ SUBROUTINE DSTEVD( JOBZ, N, D, E, Z, LDZ, WORK, LWORK, IWORK,
+ $ LIWORK, INFO )
+*
+* -- LAPACK driver routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER JOBZ
+ INTEGER INFO, LDZ, LIWORK, LWORK, N
+* ..
+* .. Array Arguments ..
+ INTEGER IWORK( * )
+ DOUBLE PRECISION D( * ), E( * ), WORK( * ), Z( LDZ, * )
+* ..
+*
+* Purpose
+* =======
+*
+* DSTEVD computes all eigenvalues and, optionally, eigenvectors of a
+* real symmetric tridiagonal matrix. If eigenvectors are desired, it
+* uses a divide and conquer algorithm.
+*
+* The divide and conquer algorithm makes very mild assumptions about
+* floating point arithmetic. It will work on machines with a guard
+* digit in add/subtract, or on those binary machines without guard
+* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
+* Cray-2. It could conceivably fail on hexadecimal or decimal machines
+* without guard digits, but we know of none.
+*
+* Arguments
+* =========
+*
+* JOBZ (input) CHARACTER*1
+* = 'N': Compute eigenvalues only;
+* = 'V': Compute eigenvalues and eigenvectors.
+*
+* N (input) INTEGER
+* The order of the matrix. N >= 0.
+*
+* D (input/output) DOUBLE PRECISION array, dimension (N)
+* On entry, the n diagonal elements of the tridiagonal matrix
+* A.
+* On exit, if INFO = 0, the eigenvalues in ascending order.
+*
+* E (input/output) DOUBLE PRECISION array, dimension (N-1)
+* On entry, the (n-1) subdiagonal elements of the tridiagonal
+* matrix A, stored in elements 1 to N-1 of E.
+* On exit, the contents of E are destroyed.
+*
+* Z (output) DOUBLE PRECISION array, dimension (LDZ, N)
+* If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal
+* eigenvectors of the matrix A, with the i-th column of Z
+* holding the eigenvector associated with D(i).
+* If JOBZ = 'N', then Z is not referenced.
+*
+* LDZ (input) INTEGER
+* The leading dimension of the array Z. LDZ >= 1, and if
+* JOBZ = 'V', LDZ >= max(1,N).
+*
+* WORK (workspace/output) DOUBLE PRECISION array,
+* dimension (LWORK)
+* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+* LWORK (input) INTEGER
+* The dimension of the array WORK.
+* If JOBZ = 'N' or N <= 1 then LWORK must be at least 1.
+* If JOBZ = 'V' and N > 1 then LWORK must be at least
+* ( 1 + 4*N + N**2 ).
+*
+* If LWORK = -1, then a workspace query is assumed; the routine
+* only calculates the optimal sizes of the WORK and IWORK
+* arrays, returns these values as the first entries of the WORK
+* and IWORK arrays, and no error message related to LWORK or
+* LIWORK is issued by XERBLA.
+*
+* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))
+* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
+*
+* LIWORK (input) INTEGER
+* The dimension of the array IWORK.
+* If JOBZ = 'N' or N <= 1 then LIWORK must be at least 1.
+* If JOBZ = 'V' and N > 1 then LIWORK must be at least 3+5*N.
+*
+* If LIWORK = -1, then a workspace query is assumed; the
+* routine only calculates the optimal sizes of the WORK and
+* IWORK arrays, returns these values as the first entries of
+* the WORK and IWORK arrays, and no error message related to
+* LWORK or LIWORK is issued by XERBLA.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* > 0: if INFO = i, the algorithm failed to converge; i
+* off-diagonal elements of E did not converge to zero.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL LQUERY, WANTZ
+ INTEGER ISCALE, LIWMIN, LWMIN
+ DOUBLE PRECISION BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA, SMLNUM,
+ $ TNRM
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ DOUBLE PRECISION DLAMCH, DLANST
+ EXTERNAL LSAME, DLAMCH, DLANST
+* ..
+* .. External Subroutines ..
+ EXTERNAL DSCAL, DSTEDC, DSTERF, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC SQRT
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ WANTZ = LSAME( JOBZ, 'V' )
+ LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 )
+*
+ INFO = 0
+ LIWMIN = 1
+ LWMIN = 1
+ IF( N.GT.1 .AND. WANTZ ) THEN
+ LWMIN = 1 + 4*N + N**2
+ LIWMIN = 3 + 5*N
+ END IF
+*
+ IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
+ INFO = -6
+ END IF
+*
+ IF( INFO.EQ.0 ) THEN
+ WORK( 1 ) = LWMIN
+ IWORK( 1 ) = LIWMIN
+*
+ IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
+ INFO = -8
+ ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN
+ INFO = -10
+ END IF
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DSTEVD', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+ IF( N.EQ.1 ) THEN
+ IF( WANTZ )
+ $ Z( 1, 1 ) = ONE
+ RETURN
+ END IF
+*
+* Get machine constants.
+*
+ SAFMIN = DLAMCH( 'Safe minimum' )
+ EPS = DLAMCH( 'Precision' )
+ SMLNUM = SAFMIN / EPS
+ BIGNUM = ONE / SMLNUM
+ RMIN = SQRT( SMLNUM )
+ RMAX = SQRT( BIGNUM )
+*
+* Scale matrix to allowable range, if necessary.
+*
+ ISCALE = 0
+ TNRM = DLANST( 'M', N, D, E )
+ IF( TNRM.GT.ZERO .AND. TNRM.LT.RMIN ) THEN
+ ISCALE = 1
+ SIGMA = RMIN / TNRM
+ ELSE IF( TNRM.GT.RMAX ) THEN
+ ISCALE = 1
+ SIGMA = RMAX / TNRM
+ END IF
+ IF( ISCALE.EQ.1 ) THEN
+ CALL DSCAL( N, SIGMA, D, 1 )
+ CALL DSCAL( N-1, SIGMA, E( 1 ), 1 )
+ END IF
+*
+* For eigenvalues only, call DSTERF. For eigenvalues and
+* eigenvectors, call DSTEDC.
+*
+ IF( .NOT.WANTZ ) THEN
+ CALL DSTERF( N, D, E, INFO )
+ ELSE
+ CALL DSTEDC( 'I', N, D, E, Z, LDZ, WORK, LWORK, IWORK, LIWORK,
+ $ INFO )
+ END IF
+*
+* If matrix was scaled, then rescale eigenvalues appropriately.
+*
+ IF( ISCALE.EQ.1 )
+ $ CALL DSCAL( N, ONE / SIGMA, D, 1 )
+*
+ WORK( 1 ) = LWMIN
+ IWORK( 1 ) = LIWMIN
+*
+ RETURN
+*
+* End of DSTEVD
+*
+ END
+ SUBROUTINE DSTEVR( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, ABSTOL,
+ $ M, W, Z, LDZ, ISUPPZ, WORK, LWORK, IWORK,
+ $ LIWORK, INFO )
+*
+* -- LAPACK driver routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER JOBZ, RANGE
+ INTEGER IL, INFO, IU, LDZ, LIWORK, LWORK, M, N
+ DOUBLE PRECISION ABSTOL, VL, VU
+* ..
+* .. Array Arguments ..
+ INTEGER ISUPPZ( * ), IWORK( * )
+ DOUBLE PRECISION D( * ), E( * ), W( * ), WORK( * ), Z( LDZ, * )
+* ..
+*
+* Purpose
+* =======
+*
+* DSTEVR computes selected eigenvalues and, optionally, eigenvectors
+* of a real symmetric tridiagonal matrix T. Eigenvalues and
+* eigenvectors can be selected by specifying either a range of values
+* or a range of indices for the desired eigenvalues.
+*
+* Whenever possible, DSTEVR calls DSTEMR to compute the
+* eigenspectrum using Relatively Robust Representations. DSTEMR
+* computes eigenvalues by the dqds algorithm, while orthogonal
+* eigenvectors are computed from various "good" L D L^T representations
+* (also known as Relatively Robust Representations). Gram-Schmidt
+* orthogonalization is avoided as far as possible. More specifically,
+* the various steps of the algorithm are as follows. For the i-th
+* unreduced block of T,
+* (a) Compute T - sigma_i = L_i D_i L_i^T, such that L_i D_i L_i^T
+* is a relatively robust representation,
+* (b) Compute the eigenvalues, lambda_j, of L_i D_i L_i^T to high
+* relative accuracy by the dqds algorithm,
+* (c) If there is a cluster of close eigenvalues, "choose" sigma_i
+* close to the cluster, and go to step (a),
+* (d) Given the approximate eigenvalue lambda_j of L_i D_i L_i^T,
+* compute the corresponding eigenvector by forming a
+* rank-revealing twisted factorization.
+* The desired accuracy of the output can be specified by the input
+* parameter ABSTOL.
+*
+* For more details, see "A new O(n^2) algorithm for the symmetric
+* tridiagonal eigenvalue/eigenvector problem", by Inderjit Dhillon,
+* Computer Science Division Technical Report No. UCB//CSD-97-971,
+* UC Berkeley, May 1997.
+*
+*
+* Note 1 : DSTEVR calls DSTEMR when the full spectrum is requested
+* on machines which conform to the ieee-754 floating point standard.
+* DSTEVR calls DSTEBZ and DSTEIN on non-ieee machines and
+* when partial spectrum requests are made.
+*
+* Normal execution of DSTEMR may create NaNs and infinities and
+* hence may abort due to a floating point exception in environments
+* which do not handle NaNs and infinities in the ieee standard default
+* manner.
+*
+* Arguments
+* =========
+*
+* JOBZ (input) CHARACTER*1
+* = 'N': Compute eigenvalues only;
+* = 'V': Compute eigenvalues and eigenvectors.
+*
+* RANGE (input) CHARACTER*1
+* = 'A': all eigenvalues will be found.
+* = 'V': all eigenvalues in the half-open interval (VL,VU]
+* will be found.
+* = 'I': the IL-th through IU-th eigenvalues will be found.
+********** For RANGE = 'V' or 'I' and IU - IL < N - 1, DSTEBZ and
+********** DSTEIN are called
+*
+* N (input) INTEGER
+* The order of the matrix. N >= 0.
+*
+* D (input/output) DOUBLE PRECISION array, dimension (N)
+* On entry, the n diagonal elements of the tridiagonal matrix
+* A.
+* On exit, D may be multiplied by a constant factor chosen
+* to avoid over/underflow in computing the eigenvalues.
+*
+* E (input/output) DOUBLE PRECISION array, dimension (max(1,N-1))
+* On entry, the (n-1) subdiagonal elements of the tridiagonal
+* matrix A in elements 1 to N-1 of E.
+* On exit, E may be multiplied by a constant factor chosen
+* to avoid over/underflow in computing the eigenvalues.
+*
+* VL (input) DOUBLE PRECISION
+* VU (input) DOUBLE PRECISION
+* If RANGE='V', the lower and upper bounds of the interval to
+* be searched for eigenvalues. VL < VU.
+* Not referenced if RANGE = 'A' or 'I'.
+*
+* IL (input) INTEGER
+* IU (input) INTEGER
+* If RANGE='I', the indices (in ascending order) of the
+* smallest and largest eigenvalues to be returned.
+* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
+* Not referenced if RANGE = 'A' or 'V'.
+*
+* ABSTOL (input) DOUBLE PRECISION
+* The absolute error tolerance for the eigenvalues.
+* An approximate eigenvalue is accepted as converged
+* when it is determined to lie in an interval [a,b]
+* of width less than or equal to
+*
+* ABSTOL + EPS * max( |a|,|b| ) ,
+*
+* where EPS is the machine precision. If ABSTOL is less than
+* or equal to zero, then EPS*|T| will be used in its place,
+* where |T| is the 1-norm of the tridiagonal matrix obtained
+* by reducing A to tridiagonal form.
+*
+* See "Computing Small Singular Values of Bidiagonal Matrices
+* with Guaranteed High Relative Accuracy," by Demmel and
+* Kahan, LAPACK Working Note #3.
+*
+* If high relative accuracy is important, set ABSTOL to
+* DLAMCH( 'Safe minimum' ). Doing so will guarantee that
+* eigenvalues are computed to high relative accuracy when
+* possible in future releases. The current code does not
+* make any guarantees about high relative accuracy, but
+* future releases will. See J. Barlow and J. Demmel,
+* "Computing Accurate Eigensystems of Scaled Diagonally
+* Dominant Matrices", LAPACK Working Note #7, for a discussion
+* of which matrices define their eigenvalues to high relative
+* accuracy.
+*
+* M (output) INTEGER
+* The total number of eigenvalues found. 0 <= M <= N.
+* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
+*
+* W (output) DOUBLE PRECISION array, dimension (N)
+* The first M elements contain the selected eigenvalues in
+* ascending order.
+*
+* Z (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M) )
+* If JOBZ = 'V', then if INFO = 0, the first M columns of Z
+* contain the orthonormal eigenvectors of the matrix A
+* corresponding to the selected eigenvalues, with the i-th
+* column of Z holding the eigenvector associated with W(i).
+* Note: the user must ensure that at least max(1,M) columns are
+* supplied in the array Z; if RANGE = 'V', the exact value of M
+* is not known in advance and an upper bound must be used.
+*
+* LDZ (input) INTEGER
+* The leading dimension of the array Z. LDZ >= 1, and if
+* JOBZ = 'V', LDZ >= max(1,N).
+*
+* ISUPPZ (output) INTEGER array, dimension ( 2*max(1,M) )
+* The support of the eigenvectors in Z, i.e., the indices
+* indicating the nonzero elements in Z. The i-th eigenvector
+* is nonzero only in elements ISUPPZ( 2*i-1 ) through
+* ISUPPZ( 2*i ).
+********** Implemented only for RANGE = 'A' or 'I' and IU - IL = N - 1
+*
+* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
+* On exit, if INFO = 0, WORK(1) returns the optimal (and
+* minimal) LWORK.
+*
+* LWORK (input) INTEGER
+* The dimension of the array WORK. LWORK >= max(1,20*N).
+*
+* If LWORK = -1, then a workspace query is assumed; the routine
+* only calculates the optimal sizes of the WORK and IWORK
+* arrays, returns these values as the first entries of the WORK
+* and IWORK arrays, and no error message related to LWORK or
+* LIWORK is issued by XERBLA.
+*
+* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))
+* On exit, if INFO = 0, IWORK(1) returns the optimal (and
+* minimal) LIWORK.
+*
+* LIWORK (input) INTEGER
+* The dimension of the array IWORK. LIWORK >= max(1,10*N).
+*
+* If LIWORK = -1, then a workspace query is assumed; the
+* routine only calculates the optimal sizes of the WORK and
+* IWORK arrays, returns these values as the first entries of
+* the WORK and IWORK arrays, and no error message related to
+* LWORK or LIWORK is issued by XERBLA.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* > 0: Internal error
+*
+* Further Details
+* ===============
+*
+* Based on contributions by
+* Inderjit Dhillon, IBM Almaden, USA
+* Osni Marques, LBNL/NERSC, USA
+* Ken Stanley, Computer Science Division, University of
+* California at Berkeley, USA
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE, TWO
+ PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL ALLEIG, INDEIG, TEST, LQUERY, VALEIG, WANTZ,
+ $ TRYRAC
+ CHARACTER ORDER
+ INTEGER I, IEEEOK, IMAX, INDIBL, INDIFL, INDISP,
+ $ INDIWO, ISCALE, ITMP1, J, JJ, LIWMIN, LWMIN,
+ $ NSPLIT
+ DOUBLE PRECISION BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA, SMLNUM,
+ $ TMP1, TNRM, VLL, VUU
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ILAENV
+ DOUBLE PRECISION DLAMCH, DLANST
+ EXTERNAL LSAME, ILAENV, DLAMCH, DLANST
+* ..
+* .. External Subroutines ..
+ EXTERNAL DCOPY, DSCAL, DSTEBZ, DSTEMR, DSTEIN, DSTERF,
+ $ DSWAP, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN, SQRT
+* ..
+* .. Executable Statements ..
+*
+*
+* Test the input parameters.
+*
+ IEEEOK = ILAENV( 10, 'DSTEVR', 'N', 1, 2, 3, 4 )
+*
+ WANTZ = LSAME( JOBZ, 'V' )
+ ALLEIG = LSAME( RANGE, 'A' )
+ VALEIG = LSAME( RANGE, 'V' )
+ INDEIG = LSAME( RANGE, 'I' )
+*
+ LQUERY = ( ( LWORK.EQ.-1 ) .OR. ( LIWORK.EQ.-1 ) )
+ LWMIN = MAX( 1, 20*N )
+ LIWMIN = MAX( 1, 10*N )
+*
+*
+ INFO = 0
+ IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
+ INFO = -1
+ ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN
+ INFO = -2
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -3
+ ELSE
+ IF( VALEIG ) THEN
+ IF( N.GT.0 .AND. VU.LE.VL )
+ $ INFO = -7
+ ELSE IF( INDEIG ) THEN
+ IF( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) THEN
+ INFO = -8
+ ELSE IF( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) THEN
+ INFO = -9
+ END IF
+ END IF
+ END IF
+ IF( INFO.EQ.0 ) THEN
+ IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
+ INFO = -14
+ END IF
+ END IF
+*
+ IF( INFO.EQ.0 ) THEN
+ WORK( 1 ) = LWMIN
+ IWORK( 1 ) = LIWMIN
+*
+ IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
+ INFO = -17
+ ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN
+ INFO = -19
+ END IF
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DSTEVR', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ M = 0
+ IF( N.EQ.0 )
+ $ RETURN
+*
+ IF( N.EQ.1 ) THEN
+ IF( ALLEIG .OR. INDEIG ) THEN
+ M = 1
+ W( 1 ) = D( 1 )
+ ELSE
+ IF( VL.LT.D( 1 ) .AND. VU.GE.D( 1 ) ) THEN
+ M = 1
+ W( 1 ) = D( 1 )
+ END IF
+ END IF
+ IF( WANTZ )
+ $ Z( 1, 1 ) = ONE
+ RETURN
+ END IF
+*
+* Get machine constants.
+*
+ SAFMIN = DLAMCH( 'Safe minimum' )
+ EPS = DLAMCH( 'Precision' )
+ SMLNUM = SAFMIN / EPS
+ BIGNUM = ONE / SMLNUM
+ RMIN = SQRT( SMLNUM )
+ RMAX = MIN( SQRT( BIGNUM ), ONE / SQRT( SQRT( SAFMIN ) ) )
+*
+*
+* Scale matrix to allowable range, if necessary.
+*
+ ISCALE = 0
+ VLL = VL
+ VUU = VU
+*
+ TNRM = DLANST( 'M', N, D, E )
+ IF( TNRM.GT.ZERO .AND. TNRM.LT.RMIN ) THEN
+ ISCALE = 1
+ SIGMA = RMIN / TNRM
+ ELSE IF( TNRM.GT.RMAX ) THEN
+ ISCALE = 1
+ SIGMA = RMAX / TNRM
+ END IF
+ IF( ISCALE.EQ.1 ) THEN
+ CALL DSCAL( N, SIGMA, D, 1 )
+ CALL DSCAL( N-1, SIGMA, E( 1 ), 1 )
+ IF( VALEIG ) THEN
+ VLL = VL*SIGMA
+ VUU = VU*SIGMA
+ END IF
+ END IF
+
+* Initialize indices into workspaces. Note: These indices are used only
+* if DSTERF or DSTEMR fail.
+
+* IWORK(INDIBL:INDIBL+M-1) corresponds to IBLOCK in DSTEBZ and
+* stores the block indices of each of the M<=N eigenvalues.
+ INDIBL = 1
+* IWORK(INDISP:INDISP+NSPLIT-1) corresponds to ISPLIT in DSTEBZ and
+* stores the starting and finishing indices of each block.
+ INDISP = INDIBL + N
+* IWORK(INDIFL:INDIFL+N-1) stores the indices of eigenvectors
+* that corresponding to eigenvectors that fail to converge in
+* DSTEIN. This information is discarded; if any fail, the driver
+* returns INFO > 0.
+ INDIFL = INDISP + N
+* INDIWO is the offset of the remaining integer workspace.
+ INDIWO = INDISP + N
+*
+* If all eigenvalues are desired, then
+* call DSTERF or DSTEMR. If this fails for some eigenvalue, then
+* try DSTEBZ.
+*
+*
+ TEST = .FALSE.
+ IF( INDEIG ) THEN
+ IF( IL.EQ.1 .AND. IU.EQ.N ) THEN
+ TEST = .TRUE.
+ END IF
+ END IF
+ IF( ( ALLEIG .OR. TEST ) .AND. IEEEOK.EQ.1 ) THEN
+ CALL DCOPY( N-1, E( 1 ), 1, WORK( 1 ), 1 )
+ IF( .NOT.WANTZ ) THEN
+ CALL DCOPY( N, D, 1, W, 1 )
+ CALL DSTERF( N, W, WORK, INFO )
+ ELSE
+ CALL DCOPY( N, D, 1, WORK( N+1 ), 1 )
+ IF (ABSTOL .LE. TWO*N*EPS) THEN
+ TRYRAC = .TRUE.
+ ELSE
+ TRYRAC = .FALSE.
+ END IF
+ CALL DSTEMR( JOBZ, 'A', N, WORK( N+1 ), WORK, VL, VU, IL,
+ $ IU, M, W, Z, LDZ, N, ISUPPZ, TRYRAC,
+ $ WORK( 2*N+1 ), LWORK-2*N, IWORK, LIWORK, INFO )
+*
+ END IF
+ IF( INFO.EQ.0 ) THEN
+ M = N
+ GO TO 10
+ END IF
+ INFO = 0
+ END IF
+*
+* Otherwise, call DSTEBZ and, if eigenvectors are desired, DSTEIN.
+*
+ IF( WANTZ ) THEN
+ ORDER = 'B'
+ ELSE
+ ORDER = 'E'
+ END IF
+
+ CALL DSTEBZ( RANGE, ORDER, N, VLL, VUU, IL, IU, ABSTOL, D, E, M,
+ $ NSPLIT, W, IWORK( INDIBL ), IWORK( INDISP ), WORK,
+ $ IWORK( INDIWO ), INFO )
+*
+ IF( WANTZ ) THEN
+ CALL DSTEIN( N, D, E, M, W, IWORK( INDIBL ), IWORK( INDISP ),
+ $ Z, LDZ, WORK, IWORK( INDIWO ), IWORK( INDIFL ),
+ $ INFO )
+ END IF
+*
+* If matrix was scaled, then rescale eigenvalues appropriately.
+*
+ 10 CONTINUE
+ IF( ISCALE.EQ.1 ) THEN
+ IF( INFO.EQ.0 ) THEN
+ IMAX = M
+ ELSE
+ IMAX = INFO - 1
+ END IF
+ CALL DSCAL( IMAX, ONE / SIGMA, W, 1 )
+ END IF
+*
+* If eigenvalues are not in order, then sort them, along with
+* eigenvectors.
+*
+ IF( WANTZ ) THEN
+ DO 30 J = 1, M - 1
+ I = 0
+ TMP1 = W( J )
+ DO 20 JJ = J + 1, M
+ IF( W( JJ ).LT.TMP1 ) THEN
+ I = JJ
+ TMP1 = W( JJ )
+ END IF
+ 20 CONTINUE
+*
+ IF( I.NE.0 ) THEN
+ ITMP1 = IWORK( I )
+ W( I ) = W( J )
+ IWORK( I ) = IWORK( J )
+ W( J ) = TMP1
+ IWORK( J ) = ITMP1
+ CALL DSWAP( N, Z( 1, I ), 1, Z( 1, J ), 1 )
+ END IF
+ 30 CONTINUE
+ END IF
+*
+* Causes problems with tests 19 & 20:
+* IF (wantz .and. INDEIG ) Z( 1,1) = Z(1,1) / 1.002 + .002
+*
+*
+ WORK( 1 ) = LWMIN
+ IWORK( 1 ) = LIWMIN
+ RETURN
+*
+* End of DSTEVR
+*
+ END
+ SUBROUTINE DSTEVX( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, ABSTOL,
+ $ M, W, Z, LDZ, WORK, IWORK, IFAIL, INFO )
+*
+* -- LAPACK driver routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER JOBZ, RANGE
+ INTEGER IL, INFO, IU, LDZ, M, N
+ DOUBLE PRECISION ABSTOL, VL, VU
+* ..
+* .. Array Arguments ..
+ INTEGER IFAIL( * ), IWORK( * )
+ DOUBLE PRECISION D( * ), E( * ), W( * ), WORK( * ), Z( LDZ, * )
+* ..
+*
+* Purpose
+* =======
+*
+* DSTEVX computes selected eigenvalues and, optionally, eigenvectors
+* of a real symmetric tridiagonal matrix A. Eigenvalues and
+* eigenvectors can be selected by specifying either a range of values
+* or a range of indices for the desired eigenvalues.
+*
+* Arguments
+* =========
+*
+* JOBZ (input) CHARACTER*1
+* = 'N': Compute eigenvalues only;
+* = 'V': Compute eigenvalues and eigenvectors.
+*
+* RANGE (input) CHARACTER*1
+* = 'A': all eigenvalues will be found.
+* = 'V': all eigenvalues in the half-open interval (VL,VU]
+* will be found.
+* = 'I': the IL-th through IU-th eigenvalues will be found.
+*
+* N (input) INTEGER
+* The order of the matrix. N >= 0.
+*
+* D (input/output) DOUBLE PRECISION array, dimension (N)
+* On entry, the n diagonal elements of the tridiagonal matrix
+* A.
+* On exit, D may be multiplied by a constant factor chosen
+* to avoid over/underflow in computing the eigenvalues.
+*
+* E (input/output) DOUBLE PRECISION array, dimension (max(1,N-1))
+* On entry, the (n-1) subdiagonal elements of the tridiagonal
+* matrix A in elements 1 to N-1 of E.
+* On exit, E may be multiplied by a constant factor chosen
+* to avoid over/underflow in computing the eigenvalues.
+*
+* VL (input) DOUBLE PRECISION
+* VU (input) DOUBLE PRECISION
+* If RANGE='V', the lower and upper bounds of the interval to
+* be searched for eigenvalues. VL < VU.
+* Not referenced if RANGE = 'A' or 'I'.
+*
+* IL (input) INTEGER
+* IU (input) INTEGER
+* If RANGE='I', the indices (in ascending order) of the
+* smallest and largest eigenvalues to be returned.
+* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
+* Not referenced if RANGE = 'A' or 'V'.
+*
+* ABSTOL (input) DOUBLE PRECISION
+* The absolute error tolerance for the eigenvalues.
+* An approximate eigenvalue is accepted as converged
+* when it is determined to lie in an interval [a,b]
+* of width less than or equal to
+*
+* ABSTOL + EPS * max( |a|,|b| ) ,
+*
+* where EPS is the machine precision. If ABSTOL is less
+* than or equal to zero, then EPS*|T| will be used in
+* its place, where |T| is the 1-norm of the tridiagonal
+* matrix.
+*
+* Eigenvalues will be computed most accurately when ABSTOL is
+* set to twice the underflow threshold 2*DLAMCH('S'), not zero.
+* If this routine returns with INFO>0, indicating that some
+* eigenvectors did not converge, try setting ABSTOL to
+* 2*DLAMCH('S').
+*
+* See "Computing Small Singular Values of Bidiagonal Matrices
+* with Guaranteed High Relative Accuracy," by Demmel and
+* Kahan, LAPACK Working Note #3.
+*
+* M (output) INTEGER
+* The total number of eigenvalues found. 0 <= M <= N.
+* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
+*
+* W (output) DOUBLE PRECISION array, dimension (N)
+* The first M elements contain the selected eigenvalues in
+* ascending order.
+*
+* Z (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M) )
+* If JOBZ = 'V', then if INFO = 0, the first M columns of Z
+* contain the orthonormal eigenvectors of the matrix A
+* corresponding to the selected eigenvalues, with the i-th
+* column of Z holding the eigenvector associated with W(i).
+* If an eigenvector fails to converge (INFO > 0), then that
+* column of Z contains the latest approximation to the
+* eigenvector, and the index of the eigenvector is returned
+* in IFAIL. If JOBZ = 'N', then Z is not referenced.
+* Note: the user must ensure that at least max(1,M) columns are
+* supplied in the array Z; if RANGE = 'V', the exact value of M
+* is not known in advance and an upper bound must be used.
+*
+* LDZ (input) INTEGER
+* The leading dimension of the array Z. LDZ >= 1, and if
+* JOBZ = 'V', LDZ >= max(1,N).
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (5*N)
+*
+* IWORK (workspace) INTEGER array, dimension (5*N)
+*
+* IFAIL (output) INTEGER array, dimension (N)
+* If JOBZ = 'V', then if INFO = 0, the first M elements of
+* IFAIL are zero. If INFO > 0, then IFAIL contains the
+* indices of the eigenvectors that failed to converge.
+* If JOBZ = 'N', then IFAIL is not referenced.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* > 0: if INFO = i, then i eigenvectors failed to converge.
+* Their indices are stored in array IFAIL.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL ALLEIG, INDEIG, TEST, VALEIG, WANTZ
+ CHARACTER ORDER
+ INTEGER I, IMAX, INDIBL, INDISP, INDIWO, INDWRK,
+ $ ISCALE, ITMP1, J, JJ, NSPLIT
+ DOUBLE PRECISION BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA, SMLNUM,
+ $ TMP1, TNRM, VLL, VUU
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ DOUBLE PRECISION DLAMCH, DLANST
+ EXTERNAL LSAME, DLAMCH, DLANST
+* ..
+* .. External Subroutines ..
+ EXTERNAL DCOPY, DSCAL, DSTEBZ, DSTEIN, DSTEQR, DSTERF,
+ $ DSWAP, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN, SQRT
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ WANTZ = LSAME( JOBZ, 'V' )
+ ALLEIG = LSAME( RANGE, 'A' )
+ VALEIG = LSAME( RANGE, 'V' )
+ INDEIG = LSAME( RANGE, 'I' )
+*
+ INFO = 0
+ IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
+ INFO = -1
+ ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN
+ INFO = -2
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -3
+ ELSE
+ IF( VALEIG ) THEN
+ IF( N.GT.0 .AND. VU.LE.VL )
+ $ INFO = -7
+ ELSE IF( INDEIG ) THEN
+ IF( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) THEN
+ INFO = -8
+ ELSE IF( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) THEN
+ INFO = -9
+ END IF
+ END IF
+ END IF
+ IF( INFO.EQ.0 ) THEN
+ IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) )
+ $ INFO = -14
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DSTEVX', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ M = 0
+ IF( N.EQ.0 )
+ $ RETURN
+*
+ IF( N.EQ.1 ) THEN
+ IF( ALLEIG .OR. INDEIG ) THEN
+ M = 1
+ W( 1 ) = D( 1 )
+ ELSE
+ IF( VL.LT.D( 1 ) .AND. VU.GE.D( 1 ) ) THEN
+ M = 1
+ W( 1 ) = D( 1 )
+ END IF
+ END IF
+ IF( WANTZ )
+ $ Z( 1, 1 ) = ONE
+ RETURN
+ END IF
+*
+* Get machine constants.
+*
+ SAFMIN = DLAMCH( 'Safe minimum' )
+ EPS = DLAMCH( 'Precision' )
+ SMLNUM = SAFMIN / EPS
+ BIGNUM = ONE / SMLNUM
+ RMIN = SQRT( SMLNUM )
+ RMAX = MIN( SQRT( BIGNUM ), ONE / SQRT( SQRT( SAFMIN ) ) )
+*
+* Scale matrix to allowable range, if necessary.
+*
+ ISCALE = 0
+ IF( VALEIG ) THEN
+ VLL = VL
+ VUU = VU
+ ELSE
+ VLL = ZERO
+ VUU = ZERO
+ END IF
+ TNRM = DLANST( 'M', N, D, E )
+ IF( TNRM.GT.ZERO .AND. TNRM.LT.RMIN ) THEN
+ ISCALE = 1
+ SIGMA = RMIN / TNRM
+ ELSE IF( TNRM.GT.RMAX ) THEN
+ ISCALE = 1
+ SIGMA = RMAX / TNRM
+ END IF
+ IF( ISCALE.EQ.1 ) THEN
+ CALL DSCAL( N, SIGMA, D, 1 )
+ CALL DSCAL( N-1, SIGMA, E( 1 ), 1 )
+ IF( VALEIG ) THEN
+ VLL = VL*SIGMA
+ VUU = VU*SIGMA
+ END IF
+ END IF
+*
+* If all eigenvalues are desired and ABSTOL is less than zero, then
+* call DSTERF or SSTEQR. If this fails for some eigenvalue, then
+* try DSTEBZ.
+*
+ TEST = .FALSE.
+ IF( INDEIG ) THEN
+ IF( IL.EQ.1 .AND. IU.EQ.N ) THEN
+ TEST = .TRUE.
+ END IF
+ END IF
+ IF( ( ALLEIG .OR. TEST ) .AND. ( ABSTOL.LE.ZERO ) ) THEN
+ CALL DCOPY( N, D, 1, W, 1 )
+ CALL DCOPY( N-1, E( 1 ), 1, WORK( 1 ), 1 )
+ INDWRK = N + 1
+ IF( .NOT.WANTZ ) THEN
+ CALL DSTERF( N, W, WORK, INFO )
+ ELSE
+ CALL DSTEQR( 'I', N, W, WORK, Z, LDZ, WORK( INDWRK ), INFO )
+ IF( INFO.EQ.0 ) THEN
+ DO 10 I = 1, N
+ IFAIL( I ) = 0
+ 10 CONTINUE
+ END IF
+ END IF
+ IF( INFO.EQ.0 ) THEN
+ M = N
+ GO TO 20
+ END IF
+ INFO = 0
+ END IF
+*
+* Otherwise, call DSTEBZ and, if eigenvectors are desired, SSTEIN.
+*
+ IF( WANTZ ) THEN
+ ORDER = 'B'
+ ELSE
+ ORDER = 'E'
+ END IF
+ INDWRK = 1
+ INDIBL = 1
+ INDISP = INDIBL + N
+ INDIWO = INDISP + N
+ CALL DSTEBZ( RANGE, ORDER, N, VLL, VUU, IL, IU, ABSTOL, D, E, M,
+ $ NSPLIT, W, IWORK( INDIBL ), IWORK( INDISP ),
+ $ WORK( INDWRK ), IWORK( INDIWO ), INFO )
+*
+ IF( WANTZ ) THEN
+ CALL DSTEIN( N, D, E, M, W, IWORK( INDIBL ), IWORK( INDISP ),
+ $ Z, LDZ, WORK( INDWRK ), IWORK( INDIWO ), IFAIL,
+ $ INFO )
+ END IF
+*
+* If matrix was scaled, then rescale eigenvalues appropriately.
+*
+ 20 CONTINUE
+ IF( ISCALE.EQ.1 ) THEN
+ IF( INFO.EQ.0 ) THEN
+ IMAX = M
+ ELSE
+ IMAX = INFO - 1
+ END IF
+ CALL DSCAL( IMAX, ONE / SIGMA, W, 1 )
+ END IF
+*
+* If eigenvalues are not in order, then sort them, along with
+* eigenvectors.
+*
+ IF( WANTZ ) THEN
+ DO 40 J = 1, M - 1
+ I = 0
+ TMP1 = W( J )
+ DO 30 JJ = J + 1, M
+ IF( W( JJ ).LT.TMP1 ) THEN
+ I = JJ
+ TMP1 = W( JJ )
+ END IF
+ 30 CONTINUE
+*
+ IF( I.NE.0 ) THEN
+ ITMP1 = IWORK( INDIBL+I-1 )
+ W( I ) = W( J )
+ IWORK( INDIBL+I-1 ) = IWORK( INDIBL+J-1 )
+ W( J ) = TMP1
+ IWORK( INDIBL+J-1 ) = ITMP1
+ CALL DSWAP( N, Z( 1, I ), 1, Z( 1, J ), 1 )
+ IF( INFO.NE.0 ) THEN
+ ITMP1 = IFAIL( I )
+ IFAIL( I ) = IFAIL( J )
+ IFAIL( J ) = ITMP1
+ END IF
+ END IF
+ 40 CONTINUE
+ END IF
+*
+ RETURN
+*
+* End of DSTEVX
+*
+ END
+ SUBROUTINE DSYCON( UPLO, N, A, LDA, IPIV, ANORM, RCOND, WORK,
+ $ IWORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH.
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, LDA, N
+ DOUBLE PRECISION ANORM, RCOND
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * ), IWORK( * )
+ DOUBLE PRECISION A( LDA, * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DSYCON estimates the reciprocal of the condition number (in the
+* 1-norm) of a real symmetric matrix A using the factorization
+* A = U*D*U**T or A = L*D*L**T computed by DSYTRF.
+*
+* An estimate is obtained for norm(inv(A)), and the reciprocal of the
+* condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).
+*
+* Arguments
+* =========
+*
+* UPLO (input) CHARACTER*1
+* Specifies whether the details of the factorization are stored
+* as an upper or lower triangular matrix.
+* = 'U': Upper triangular, form is A = U*D*U**T;
+* = 'L': Lower triangular, form is A = L*D*L**T.
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* A (input) DOUBLE PRECISION array, dimension (LDA,N)
+* The block diagonal matrix D and the multipliers used to
+* obtain the factor U or L as computed by DSYTRF.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,N).
+*
+* IPIV (input) INTEGER array, dimension (N)
+* Details of the interchanges and the block structure of D
+* as determined by DSYTRF.
+*
+* ANORM (input) DOUBLE PRECISION
+* The 1-norm of the original matrix A.
+*
+* RCOND (output) DOUBLE PRECISION
+* The reciprocal of the condition number of the matrix A,
+* computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an
+* estimate of the 1-norm of inv(A) computed in this routine.
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (2*N)
+*
+* IWORK (workspace) INTEGER array, dimension (N)
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE, ZERO
+ PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL UPPER
+ INTEGER I, KASE
+ DOUBLE PRECISION AINVNM
+* ..
+* .. Local Arrays ..
+ INTEGER ISAVE( 3 )
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL DLACN2, DSYTRS, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -4
+ ELSE IF( ANORM.LT.ZERO ) THEN
+ INFO = -6
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DSYCON', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ RCOND = ZERO
+ IF( N.EQ.0 ) THEN
+ RCOND = ONE
+ RETURN
+ ELSE IF( ANORM.LE.ZERO ) THEN
+ RETURN
+ END IF
+*
+* Check that the diagonal matrix D is nonsingular.
+*
+ IF( UPPER ) THEN
+*
+* Upper triangular storage: examine D from bottom to top
+*
+ DO 10 I = N, 1, -1
+ IF( IPIV( I ).GT.0 .AND. A( I, I ).EQ.ZERO )
+ $ RETURN
+ 10 CONTINUE
+ ELSE
+*
+* Lower triangular storage: examine D from top to bottom.
+*
+ DO 20 I = 1, N
+ IF( IPIV( I ).GT.0 .AND. A( I, I ).EQ.ZERO )
+ $ RETURN
+ 20 CONTINUE
+ END IF
+*
+* Estimate the 1-norm of the inverse.
+*
+ KASE = 0
+ 30 CONTINUE
+ CALL DLACN2( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE, ISAVE )
+ IF( KASE.NE.0 ) THEN
+*
+* Multiply by inv(L*D*L') or inv(U*D*U').
+*
+ CALL DSYTRS( UPLO, N, 1, A, LDA, IPIV, WORK, N, INFO )
+ GO TO 30
+ END IF
+*
+* Compute the estimate of the reciprocal condition number.
+*
+ IF( AINVNM.NE.ZERO )
+ $ RCOND = ( ONE / AINVNM ) / ANORM
+*
+ RETURN
+*
+* End of DSYCON
+*
+ END
+ SUBROUTINE DSYEV( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, INFO )
+*
+* -- LAPACK driver routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER JOBZ, UPLO
+ INTEGER INFO, LDA, LWORK, N
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION A( LDA, * ), W( * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DSYEV computes all eigenvalues and, optionally, eigenvectors of a
+* real symmetric matrix A.
+*
+* Arguments
+* =========
+*
+* JOBZ (input) CHARACTER*1
+* = 'N': Compute eigenvalues only;
+* = 'V': Compute eigenvalues and eigenvectors.
+*
+* UPLO (input) CHARACTER*1
+* = 'U': Upper triangle of A is stored;
+* = 'L': Lower triangle of A is stored.
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* A (input/output) DOUBLE PRECISION array, dimension (LDA, N)
+* On entry, the symmetric matrix A. If UPLO = 'U', the
+* leading N-by-N upper triangular part of A contains the
+* upper triangular part of the matrix A. If UPLO = 'L',
+* the leading N-by-N lower triangular part of A contains
+* the lower triangular part of the matrix A.
+* On exit, if JOBZ = 'V', then if INFO = 0, A contains the
+* orthonormal eigenvectors of the matrix A.
+* If JOBZ = 'N', then on exit the lower triangle (if UPLO='L')
+* or the upper triangle (if UPLO='U') of A, including the
+* diagonal, is destroyed.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,N).
+*
+* W (output) DOUBLE PRECISION array, dimension (N)
+* If INFO = 0, the eigenvalues in ascending order.
+*
+* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
+* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+* LWORK (input) INTEGER
+* The length of the array WORK. LWORK >= max(1,3*N-1).
+* For optimal efficiency, LWORK >= (NB+2)*N,
+* where NB is the blocksize for DSYTRD returned by ILAENV.
+*
+* If LWORK = -1, then a workspace query is assumed; the routine
+* only calculates the optimal size of the WORK array, returns
+* this value as the first entry of the WORK array, and no error
+* message related to LWORK is issued by XERBLA.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* > 0: if INFO = i, the algorithm failed to converge; i
+* off-diagonal elements of an intermediate tridiagonal
+* form did not converge to zero.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL LOWER, LQUERY, WANTZ
+ INTEGER IINFO, IMAX, INDE, INDTAU, INDWRK, ISCALE,
+ $ LLWORK, LWKOPT, NB
+ DOUBLE PRECISION ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA,
+ $ SMLNUM
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ILAENV
+ DOUBLE PRECISION DLAMCH, DLANSY
+ EXTERNAL LSAME, ILAENV, DLAMCH, DLANSY
+* ..
+* .. External Subroutines ..
+ EXTERNAL DLASCL, DORGTR, DSCAL, DSTEQR, DSTERF, DSYTRD,
+ $ XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, SQRT
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ WANTZ = LSAME( JOBZ, 'V' )
+ LOWER = LSAME( UPLO, 'L' )
+ LQUERY = ( LWORK.EQ.-1 )
+*
+ INFO = 0
+ IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
+ INFO = -1
+ ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN
+ INFO = -2
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -5
+ END IF
+*
+ IF( INFO.EQ.0 ) THEN
+ NB = ILAENV( 1, 'DSYTRD', UPLO, N, -1, -1, -1 )
+ LWKOPT = MAX( 1, ( NB+2 )*N )
+ WORK( 1 ) = LWKOPT
+*
+ IF( LWORK.LT.MAX( 1, 3*N-1 ) .AND. .NOT.LQUERY )
+ $ INFO = -8
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DSYEV ', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 ) THEN
+ RETURN
+ END IF
+*
+ IF( N.EQ.1 ) THEN
+ W( 1 ) = A( 1, 1 )
+ WORK( 1 ) = 2
+ IF( WANTZ )
+ $ A( 1, 1 ) = ONE
+ RETURN
+ END IF
+*
+* Get machine constants.
+*
+ SAFMIN = DLAMCH( 'Safe minimum' )
+ EPS = DLAMCH( 'Precision' )
+ SMLNUM = SAFMIN / EPS
+ BIGNUM = ONE / SMLNUM
+ RMIN = SQRT( SMLNUM )
+ RMAX = SQRT( BIGNUM )
+*
+* Scale matrix to allowable range, if necessary.
+*
+ ANRM = DLANSY( 'M', UPLO, N, A, LDA, WORK )
+ ISCALE = 0
+ IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN
+ ISCALE = 1
+ SIGMA = RMIN / ANRM
+ ELSE IF( ANRM.GT.RMAX ) THEN
+ ISCALE = 1
+ SIGMA = RMAX / ANRM
+ END IF
+ IF( ISCALE.EQ.1 )
+ $ CALL DLASCL( UPLO, 0, 0, ONE, SIGMA, N, N, A, LDA, INFO )
+*
+* Call DSYTRD to reduce symmetric matrix to tridiagonal form.
+*
+ INDE = 1
+ INDTAU = INDE + N
+ INDWRK = INDTAU + N
+ LLWORK = LWORK - INDWRK + 1
+ CALL DSYTRD( UPLO, N, A, LDA, W, WORK( INDE ), WORK( INDTAU ),
+ $ WORK( INDWRK ), LLWORK, IINFO )
+*
+* For eigenvalues only, call DSTERF. For eigenvectors, first call
+* DORGTR to generate the orthogonal matrix, then call DSTEQR.
+*
+ IF( .NOT.WANTZ ) THEN
+ CALL DSTERF( N, W, WORK( INDE ), INFO )
+ ELSE
+ CALL DORGTR( UPLO, N, A, LDA, WORK( INDTAU ), WORK( INDWRK ),
+ $ LLWORK, IINFO )
+ CALL DSTEQR( JOBZ, N, W, WORK( INDE ), A, LDA, WORK( INDTAU ),
+ $ INFO )
+ END IF
+*
+* If matrix was scaled, then rescale eigenvalues appropriately.
+*
+ IF( ISCALE.EQ.1 ) THEN
+ IF( INFO.EQ.0 ) THEN
+ IMAX = N
+ ELSE
+ IMAX = INFO - 1
+ END IF
+ CALL DSCAL( IMAX, ONE / SIGMA, W, 1 )
+ END IF
+*
+* Set WORK(1) to optimal workspace size.
+*
+ WORK( 1 ) = LWKOPT
+*
+ RETURN
+*
+* End of DSYEV
+*
+ END
+ SUBROUTINE DSYEVD( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, IWORK,
+ $ LIWORK, INFO )
+*
+* -- LAPACK driver routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER JOBZ, UPLO
+ INTEGER INFO, LDA, LIWORK, LWORK, N
+* ..
+* .. Array Arguments ..
+ INTEGER IWORK( * )
+ DOUBLE PRECISION A( LDA, * ), W( * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DSYEVD computes all eigenvalues and, optionally, eigenvectors of a
+* real symmetric matrix A. If eigenvectors are desired, it uses a
+* divide and conquer algorithm.
+*
+* The divide and conquer algorithm makes very mild assumptions about
+* floating point arithmetic. It will work on machines with a guard
+* digit in add/subtract, or on those binary machines without guard
+* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
+* Cray-2. It could conceivably fail on hexadecimal or decimal machines
+* without guard digits, but we know of none.
+*
+* Because of large use of BLAS of level 3, DSYEVD needs N**2 more
+* workspace than DSYEVX.
+*
+* Arguments
+* =========
+*
+* JOBZ (input) CHARACTER*1
+* = 'N': Compute eigenvalues only;
+* = 'V': Compute eigenvalues and eigenvectors.
+*
+* UPLO (input) CHARACTER*1
+* = 'U': Upper triangle of A is stored;
+* = 'L': Lower triangle of A is stored.
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* A (input/output) DOUBLE PRECISION array, dimension (LDA, N)
+* On entry, the symmetric matrix A. If UPLO = 'U', the
+* leading N-by-N upper triangular part of A contains the
+* upper triangular part of the matrix A. If UPLO = 'L',
+* the leading N-by-N lower triangular part of A contains
+* the lower triangular part of the matrix A.
+* On exit, if JOBZ = 'V', then if INFO = 0, A contains the
+* orthonormal eigenvectors of the matrix A.
+* If JOBZ = 'N', then on exit the lower triangle (if UPLO='L')
+* or the upper triangle (if UPLO='U') of A, including the
+* diagonal, is destroyed.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,N).
+*
+* W (output) DOUBLE PRECISION array, dimension (N)
+* If INFO = 0, the eigenvalues in ascending order.
+*
+* WORK (workspace/output) DOUBLE PRECISION array,
+* dimension (LWORK)
+* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+* LWORK (input) INTEGER
+* The dimension of the array WORK.
+* If N <= 1, LWORK must be at least 1.
+* If JOBZ = 'N' and N > 1, LWORK must be at least 2*N+1.
+* If JOBZ = 'V' and N > 1, LWORK must be at least
+* 1 + 6*N + 2*N**2.
+*
+* If LWORK = -1, then a workspace query is assumed; the routine
+* only calculates the optimal sizes of the WORK and IWORK
+* arrays, returns these values as the first entries of the WORK
+* and IWORK arrays, and no error message related to LWORK or
+* LIWORK is issued by XERBLA.
+*
+* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))
+* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
+*
+* LIWORK (input) INTEGER
+* The dimension of the array IWORK.
+* If N <= 1, LIWORK must be at least 1.
+* If JOBZ = 'N' and N > 1, LIWORK must be at least 1.
+* If JOBZ = 'V' and N > 1, LIWORK must be at least 3 + 5*N.
+*
+* If LIWORK = -1, then a workspace query is assumed; the
+* routine only calculates the optimal sizes of the WORK and
+* IWORK arrays, returns these values as the first entries of
+* the WORK and IWORK arrays, and no error message related to
+* LWORK or LIWORK is issued by XERBLA.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* > 0: if INFO = i and JOBZ = 'N', then the algorithm failed
+* to converge; i off-diagonal elements of an intermediate
+* tridiagonal form did not converge to zero;
+* if INFO = i and JOBZ = 'V', then the algorithm failed
+* to compute an eigenvalue while working on the submatrix
+* lying in rows and columns INFO/(N+1) through
+* mod(INFO,N+1).
+*
+* Further Details
+* ===============
+*
+* Based on contributions by
+* Jeff Rutter, Computer Science Division, University of California
+* at Berkeley, USA
+* Modified by Francoise Tisseur, University of Tennessee.
+*
+* Modified description of INFO. Sven, 16 Feb 05.
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+* ..
+* .. Local Scalars ..
+*
+ LOGICAL LOWER, LQUERY, WANTZ
+ INTEGER IINFO, INDE, INDTAU, INDWK2, INDWRK, ISCALE,
+ $ LIOPT, LIWMIN, LLWORK, LLWRK2, LOPT, LWMIN
+ DOUBLE PRECISION ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA,
+ $ SMLNUM
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ILAENV
+ DOUBLE PRECISION DLAMCH, DLANSY
+ EXTERNAL LSAME, DLAMCH, DLANSY, ILAENV
+* ..
+* .. External Subroutines ..
+ EXTERNAL DLACPY, DLASCL, DORMTR, DSCAL, DSTEDC, DSTERF,
+ $ DSYTRD, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, SQRT
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ WANTZ = LSAME( JOBZ, 'V' )
+ LOWER = LSAME( UPLO, 'L' )
+ LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 )
+*
+ INFO = 0
+ IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
+ INFO = -1
+ ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN
+ INFO = -2
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -5
+ END IF
+*
+ IF( INFO.EQ.0 ) THEN
+ IF( N.LE.1 ) THEN
+ LIWMIN = 1
+ LWMIN = 1
+ LOPT = LWMIN
+ LIOPT = LIWMIN
+ ELSE
+ IF( WANTZ ) THEN
+ LIWMIN = 3 + 5*N
+ LWMIN = 1 + 6*N + 2*N**2
+ ELSE
+ LIWMIN = 1
+ LWMIN = 2*N + 1
+ END IF
+ LOPT = MAX( LWMIN, 2*N +
+ $ ILAENV( 1, 'DSYTRD', UPLO, N, -1, -1, -1 ) )
+ LIOPT = LIWMIN
+ END IF
+ WORK( 1 ) = LOPT
+ IWORK( 1 ) = LIOPT
+*
+ IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
+ INFO = -8
+ ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN
+ INFO = -10
+ END IF
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DSYEVD', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+ IF( N.EQ.1 ) THEN
+ W( 1 ) = A( 1, 1 )
+ IF( WANTZ )
+ $ A( 1, 1 ) = ONE
+ RETURN
+ END IF
+*
+* Get machine constants.
+*
+ SAFMIN = DLAMCH( 'Safe minimum' )
+ EPS = DLAMCH( 'Precision' )
+ SMLNUM = SAFMIN / EPS
+ BIGNUM = ONE / SMLNUM
+ RMIN = SQRT( SMLNUM )
+ RMAX = SQRT( BIGNUM )
+*
+* Scale matrix to allowable range, if necessary.
+*
+ ANRM = DLANSY( 'M', UPLO, N, A, LDA, WORK )
+ ISCALE = 0
+ IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN
+ ISCALE = 1
+ SIGMA = RMIN / ANRM
+ ELSE IF( ANRM.GT.RMAX ) THEN
+ ISCALE = 1
+ SIGMA = RMAX / ANRM
+ END IF
+ IF( ISCALE.EQ.1 )
+ $ CALL DLASCL( UPLO, 0, 0, ONE, SIGMA, N, N, A, LDA, INFO )
+*
+* Call DSYTRD to reduce symmetric matrix to tridiagonal form.
+*
+ INDE = 1
+ INDTAU = INDE + N
+ INDWRK = INDTAU + N
+ LLWORK = LWORK - INDWRK + 1
+ INDWK2 = INDWRK + N*N
+ LLWRK2 = LWORK - INDWK2 + 1
+*
+ CALL DSYTRD( UPLO, N, A, LDA, W, WORK( INDE ), WORK( INDTAU ),
+ $ WORK( INDWRK ), LLWORK, IINFO )
+ LOPT = 2*N + WORK( INDWRK )
+*
+* For eigenvalues only, call DSTERF. For eigenvectors, first call
+* DSTEDC to generate the eigenvector matrix, WORK(INDWRK), of the
+* tridiagonal matrix, then call DORMTR to multiply it by the
+* Householder transformations stored in A.
+*
+ IF( .NOT.WANTZ ) THEN
+ CALL DSTERF( N, W, WORK( INDE ), INFO )
+ ELSE
+ CALL DSTEDC( 'I', N, W, WORK( INDE ), WORK( INDWRK ), N,
+ $ WORK( INDWK2 ), LLWRK2, IWORK, LIWORK, INFO )
+ CALL DORMTR( 'L', UPLO, 'N', N, N, A, LDA, WORK( INDTAU ),
+ $ WORK( INDWRK ), N, WORK( INDWK2 ), LLWRK2, IINFO )
+ CALL DLACPY( 'A', N, N, WORK( INDWRK ), N, A, LDA )
+ LOPT = MAX( LOPT, 1+6*N+2*N**2 )
+ END IF
+*
+* If matrix was scaled, then rescale eigenvalues appropriately.
+*
+ IF( ISCALE.EQ.1 )
+ $ CALL DSCAL( N, ONE / SIGMA, W, 1 )
+*
+ WORK( 1 ) = LOPT
+ IWORK( 1 ) = LIOPT
+*
+ RETURN
+*
+* End of DSYEVD
+*
+ END
+ SUBROUTINE DSYEVR( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU,
+ $ ABSTOL, M, W, Z, LDZ, ISUPPZ, WORK, LWORK,
+ $ IWORK, LIWORK, INFO )
+*
+* -- LAPACK driver routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER JOBZ, RANGE, UPLO
+ INTEGER IL, INFO, IU, LDA, LDZ, LIWORK, LWORK, M, N
+ DOUBLE PRECISION ABSTOL, VL, VU
+* ..
+* .. Array Arguments ..
+ INTEGER ISUPPZ( * ), IWORK( * )
+ DOUBLE PRECISION A( LDA, * ), W( * ), WORK( * ), Z( LDZ, * )
+* ..
+*
+* Purpose
+* =======
+*
+* DSYEVR computes selected eigenvalues and, optionally, eigenvectors
+* of a real symmetric matrix A. Eigenvalues and eigenvectors can be
+* selected by specifying either a range of values or a range of
+* indices for the desired eigenvalues.
+*
+* DSYEVR first reduces the matrix A to tridiagonal form T with a call
+* to DSYTRD. Then, whenever possible, DSYEVR calls DSTEMR to compute
+* the eigenspectrum using Relatively Robust Representations. DSTEMR
+* computes eigenvalues by the dqds algorithm, while orthogonal
+* eigenvectors are computed from various "good" L D L^T representations
+* (also known as Relatively Robust Representations). Gram-Schmidt
+* orthogonalization is avoided as far as possible. More specifically,
+* the various steps of the algorithm are as follows.
+*
+* For each unreduced block (submatrix) of T,
+* (a) Compute T - sigma I = L D L^T, so that L and D
+* define all the wanted eigenvalues to high relative accuracy.
+* This means that small relative changes in the entries of D and L
+* cause only small relative changes in the eigenvalues and
+* eigenvectors. The standard (unfactored) representation of the
+* tridiagonal matrix T does not have this property in general.
+* (b) Compute the eigenvalues to suitable accuracy.
+* If the eigenvectors are desired, the algorithm attains full
+* accuracy of the computed eigenvalues only right before
+* the corresponding vectors have to be computed, see steps c) and d).
+* (c) For each cluster of close eigenvalues, select a new
+* shift close to the cluster, find a new factorization, and refine
+* the shifted eigenvalues to suitable accuracy.
+* (d) For each eigenvalue with a large enough relative separation compute
+* the corresponding eigenvector by forming a rank revealing twisted
+* factorization. Go back to (c) for any clusters that remain.
+*
+* The desired accuracy of the output can be specified by the input
+* parameter ABSTOL.
+*
+* For more details, see DSTEMR's documentation and:
+* - Inderjit S. Dhillon and Beresford N. Parlett: "Multiple representations
+* to compute orthogonal eigenvectors of symmetric tridiagonal matrices,"
+* Linear Algebra and its Applications, 387(1), pp. 1-28, August 2004.
+* - Inderjit Dhillon and Beresford Parlett: "Orthogonal Eigenvectors and
+* Relative Gaps," SIAM Journal on Matrix Analysis and Applications, Vol. 25,
+* 2004. Also LAPACK Working Note 154.
+* - Inderjit Dhillon: "A new O(n^2) algorithm for the symmetric
+* tridiagonal eigenvalue/eigenvector problem",
+* Computer Science Division Technical Report No. UCB/CSD-97-971,
+* UC Berkeley, May 1997.
+*
+*
+* Note 1 : DSYEVR calls DSTEMR when the full spectrum is requested
+* on machines which conform to the ieee-754 floating point standard.
+* DSYEVR calls DSTEBZ and SSTEIN on non-ieee machines and
+* when partial spectrum requests are made.
+*
+* Normal execution of DSTEMR may create NaNs and infinities and
+* hence may abort due to a floating point exception in environments
+* which do not handle NaNs and infinities in the ieee standard default
+* manner.
+*
+* Arguments
+* =========
+*
+* JOBZ (input) CHARACTER*1
+* = 'N': Compute eigenvalues only;
+* = 'V': Compute eigenvalues and eigenvectors.
+*
+* RANGE (input) CHARACTER*1
+* = 'A': all eigenvalues will be found.
+* = 'V': all eigenvalues in the half-open interval (VL,VU]
+* will be found.
+* = 'I': the IL-th through IU-th eigenvalues will be found.
+********** For RANGE = 'V' or 'I' and IU - IL < N - 1, DSTEBZ and
+********** DSTEIN are called
+*
+* UPLO (input) CHARACTER*1
+* = 'U': Upper triangle of A is stored;
+* = 'L': Lower triangle of A is stored.
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* A (input/output) DOUBLE PRECISION array, dimension (LDA, N)
+* On entry, the symmetric matrix A. If UPLO = 'U', the
+* leading N-by-N upper triangular part of A contains the
+* upper triangular part of the matrix A. If UPLO = 'L',
+* the leading N-by-N lower triangular part of A contains
+* the lower triangular part of the matrix A.
+* On exit, the lower triangle (if UPLO='L') or the upper
+* triangle (if UPLO='U') of A, including the diagonal, is
+* destroyed.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,N).
+*
+* VL (input) DOUBLE PRECISION
+* VU (input) DOUBLE PRECISION
+* If RANGE='V', the lower and upper bounds of the interval to
+* be searched for eigenvalues. VL < VU.
+* Not referenced if RANGE = 'A' or 'I'.
+*
+* IL (input) INTEGER
+* IU (input) INTEGER
+* If RANGE='I', the indices (in ascending order) of the
+* smallest and largest eigenvalues to be returned.
+* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
+* Not referenced if RANGE = 'A' or 'V'.
+*
+* ABSTOL (input) DOUBLE PRECISION
+* The absolute error tolerance for the eigenvalues.
+* An approximate eigenvalue is accepted as converged
+* when it is determined to lie in an interval [a,b]
+* of width less than or equal to
+*
+* ABSTOL + EPS * max( |a|,|b| ) ,
+*
+* where EPS is the machine precision. If ABSTOL is less than
+* or equal to zero, then EPS*|T| will be used in its place,
+* where |T| is the 1-norm of the tridiagonal matrix obtained
+* by reducing A to tridiagonal form.
+*
+* See "Computing Small Singular Values of Bidiagonal Matrices
+* with Guaranteed High Relative Accuracy," by Demmel and
+* Kahan, LAPACK Working Note #3.
+*
+* If high relative accuracy is important, set ABSTOL to
+* DLAMCH( 'Safe minimum' ). Doing so will guarantee that
+* eigenvalues are computed to high relative accuracy when
+* possible in future releases. The current code does not
+* make any guarantees about high relative accuracy, but
+* future releases will. See J. Barlow and J. Demmel,
+* "Computing Accurate Eigensystems of Scaled Diagonally
+* Dominant Matrices", LAPACK Working Note #7, for a discussion
+* of which matrices define their eigenvalues to high relative
+* accuracy.
+*
+* M (output) INTEGER
+* The total number of eigenvalues found. 0 <= M <= N.
+* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
+*
+* W (output) DOUBLE PRECISION array, dimension (N)
+* The first M elements contain the selected eigenvalues in
+* ascending order.
+*
+* Z (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M))
+* If JOBZ = 'V', then if INFO = 0, the first M columns of Z
+* contain the orthonormal eigenvectors of the matrix A
+* corresponding to the selected eigenvalues, with the i-th
+* column of Z holding the eigenvector associated with W(i).
+* If JOBZ = 'N', then Z is not referenced.
+* Note: the user must ensure that at least max(1,M) columns are
+* supplied in the array Z; if RANGE = 'V', the exact value of M
+* is not known in advance and an upper bound must be used.
+* Supplying N columns is always safe.
+*
+* LDZ (input) INTEGER
+* The leading dimension of the array Z. LDZ >= 1, and if
+* JOBZ = 'V', LDZ >= max(1,N).
+*
+* ISUPPZ (output) INTEGER array, dimension ( 2*max(1,M) )
+* The support of the eigenvectors in Z, i.e., the indices
+* indicating the nonzero elements in Z. The i-th eigenvector
+* is nonzero only in elements ISUPPZ( 2*i-1 ) through
+* ISUPPZ( 2*i ).
+********** Implemented only for RANGE = 'A' or 'I' and IU - IL = N - 1
+*
+* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
+* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+* LWORK (input) INTEGER
+* The dimension of the array WORK. LWORK >= max(1,26*N).
+* For optimal efficiency, LWORK >= (NB+6)*N,
+* where NB is the max of the blocksize for DSYTRD and DORMTR
+* returned by ILAENV.
+*
+* If LWORK = -1, then a workspace query is assumed; the routine
+* only calculates the optimal size of the WORK array, returns
+* this value as the first entry of the WORK array, and no error
+* message related to LWORK is issued by XERBLA.
+*
+* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))
+* On exit, if INFO = 0, IWORK(1) returns the optimal LWORK.
+*
+* LIWORK (input) INTEGER
+* The dimension of the array IWORK. LIWORK >= max(1,10*N).
+*
+* If LIWORK = -1, then a workspace query is assumed; the
+* routine only calculates the optimal size of the IWORK array,
+* returns this value as the first entry of the IWORK array, and
+* no error message related to LIWORK is issued by XERBLA.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* > 0: Internal error
+*
+* Further Details
+* ===============
+*
+* Based on contributions by
+* Inderjit Dhillon, IBM Almaden, USA
+* Osni Marques, LBNL/NERSC, USA
+* Ken Stanley, Computer Science Division, University of
+* California at Berkeley, USA
+* Jason Riedy, Computer Science Division, University of
+* California at Berkeley, USA
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE, TWO
+ PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 0.0D+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL ALLEIG, INDEIG, LOWER, LQUERY, VALEIG, WANTZ,
+ $ TRYRAC
+ CHARACTER ORDER
+ INTEGER I, IEEEOK, IINFO, IMAX, INDD, INDDD, INDE,
+ $ INDEE, INDIBL, INDIFL, INDISP, INDIWO, INDTAU,
+ $ INDWK, INDWKN, ISCALE, J, JJ, LIWMIN,
+ $ LLWORK, LLWRKN, LWKOPT, LWMIN, NB, NSPLIT
+ DOUBLE PRECISION ABSTLL, ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN,
+ $ SIGMA, SMLNUM, TMP1, VLL, VUU
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ILAENV
+ DOUBLE PRECISION DLAMCH, DLANSY
+ EXTERNAL LSAME, ILAENV, DLAMCH, DLANSY
+* ..
+* .. External Subroutines ..
+ EXTERNAL DCOPY, DORMTR, DSCAL, DSTEBZ, DSTEMR, DSTEIN,
+ $ DSTERF, DSWAP, DSYTRD, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN, SQRT
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ IEEEOK = ILAENV( 10, 'DSYEVR', 'N', 1, 2, 3, 4 )
+*
+ LOWER = LSAME( UPLO, 'L' )
+ WANTZ = LSAME( JOBZ, 'V' )
+ ALLEIG = LSAME( RANGE, 'A' )
+ VALEIG = LSAME( RANGE, 'V' )
+ INDEIG = LSAME( RANGE, 'I' )
+*
+ LQUERY = ( ( LWORK.EQ.-1 ) .OR. ( LIWORK.EQ.-1 ) )
+*
+ LWMIN = MAX( 1, 26*N )
+ LIWMIN = MAX( 1, 10*N )
+*
+ INFO = 0
+ IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
+ INFO = -1
+ ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN
+ INFO = -2
+ ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN
+ INFO = -3
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -6
+ ELSE
+ IF( VALEIG ) THEN
+ IF( N.GT.0 .AND. VU.LE.VL )
+ $ INFO = -8
+ ELSE IF( INDEIG ) THEN
+ IF( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) THEN
+ INFO = -9
+ ELSE IF( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) THEN
+ INFO = -10
+ END IF
+ END IF
+ END IF
+ IF( INFO.EQ.0 ) THEN
+ IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
+ INFO = -15
+ ELSE IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
+ INFO = -18
+ ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN
+ INFO = -20
+ END IF
+ END IF
+*
+ IF( INFO.EQ.0 ) THEN
+ NB = ILAENV( 1, 'DSYTRD', UPLO, N, -1, -1, -1 )
+ NB = MAX( NB, ILAENV( 1, 'DORMTR', UPLO, N, -1, -1, -1 ) )
+ LWKOPT = MAX( ( NB+1 )*N, LWMIN )
+ WORK( 1 ) = LWKOPT
+ IWORK( 1 ) = LIWMIN
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DSYEVR', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ M = 0
+ IF( N.EQ.0 ) THEN
+ WORK( 1 ) = 1
+ RETURN
+ END IF
+*
+ IF( N.EQ.1 ) THEN
+ WORK( 1 ) = 7
+ IF( ALLEIG .OR. INDEIG ) THEN
+ M = 1
+ W( 1 ) = A( 1, 1 )
+ ELSE
+ IF( VL.LT.A( 1, 1 ) .AND. VU.GE.A( 1, 1 ) ) THEN
+ M = 1
+ W( 1 ) = A( 1, 1 )
+ END IF
+ END IF
+ IF( WANTZ )
+ $ Z( 1, 1 ) = ONE
+ RETURN
+ END IF
+*
+* Get machine constants.
+*
+ SAFMIN = DLAMCH( 'Safe minimum' )
+ EPS = DLAMCH( 'Precision' )
+ SMLNUM = SAFMIN / EPS
+ BIGNUM = ONE / SMLNUM
+ RMIN = SQRT( SMLNUM )
+ RMAX = MIN( SQRT( BIGNUM ), ONE / SQRT( SQRT( SAFMIN ) ) )
+*
+* Scale matrix to allowable range, if necessary.
+*
+ ISCALE = 0
+ ABSTLL = ABSTOL
+ VLL = VL
+ VUU = VU
+ ANRM = DLANSY( 'M', UPLO, N, A, LDA, WORK )
+ IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN
+ ISCALE = 1
+ SIGMA = RMIN / ANRM
+ ELSE IF( ANRM.GT.RMAX ) THEN
+ ISCALE = 1
+ SIGMA = RMAX / ANRM
+ END IF
+ IF( ISCALE.EQ.1 ) THEN
+ IF( LOWER ) THEN
+ DO 10 J = 1, N
+ CALL DSCAL( N-J+1, SIGMA, A( J, J ), 1 )
+ 10 CONTINUE
+ ELSE
+ DO 20 J = 1, N
+ CALL DSCAL( J, SIGMA, A( 1, J ), 1 )
+ 20 CONTINUE
+ END IF
+ IF( ABSTOL.GT.0 )
+ $ ABSTLL = ABSTOL*SIGMA
+ IF( VALEIG ) THEN
+ VLL = VL*SIGMA
+ VUU = VU*SIGMA
+ END IF
+ END IF
+
+* Initialize indices into workspaces. Note: The IWORK indices are
+* used only if DSTERF or DSTEMR fail.
+
+* WORK(INDTAU:INDTAU+N-1) stores the scalar factors of the
+* elementary reflectors used in DSYTRD.
+ INDTAU = 1
+* WORK(INDD:INDD+N-1) stores the tridiagonal's diagonal entries.
+ INDD = INDTAU + N
+* WORK(INDE:INDE+N-1) stores the off-diagonal entries of the
+* tridiagonal matrix from DSYTRD.
+ INDE = INDD + N
+* WORK(INDDD:INDDD+N-1) is a copy of the diagonal entries over
+* -written by DSTEMR (the DSTERF path copies the diagonal to W).
+ INDDD = INDE + N
+* WORK(INDEE:INDEE+N-1) is a copy of the off-diagonal entries over
+* -written while computing the eigenvalues in DSTERF and DSTEMR.
+ INDEE = INDDD + N
+* INDWK is the starting offset of the left-over workspace, and
+* LLWORK is the remaining workspace size.
+ INDWK = INDEE + N
+ LLWORK = LWORK - INDWK + 1
+
+* IWORK(INDIBL:INDIBL+M-1) corresponds to IBLOCK in DSTEBZ and
+* stores the block indices of each of the M<=N eigenvalues.
+ INDIBL = 1
+* IWORK(INDISP:INDISP+NSPLIT-1) corresponds to ISPLIT in DSTEBZ and
+* stores the starting and finishing indices of each block.
+ INDISP = INDIBL + N
+* IWORK(INDIFL:INDIFL+N-1) stores the indices of eigenvectors
+* that corresponding to eigenvectors that fail to converge in
+* DSTEIN. This information is discarded; if any fail, the driver
+* returns INFO > 0.
+ INDIFL = INDISP + N
+* INDIWO is the offset of the remaining integer workspace.
+ INDIWO = INDISP + N
+
+*
+* Call DSYTRD to reduce symmetric matrix to tridiagonal form.
+*
+ CALL DSYTRD( UPLO, N, A, LDA, WORK( INDD ), WORK( INDE ),
+ $ WORK( INDTAU ), WORK( INDWK ), LLWORK, IINFO )
+*
+* If all eigenvalues are desired
+* then call DSTERF or DSTEMR and DORMTR.
+*
+ IF( ( ALLEIG .OR. ( INDEIG .AND. IL.EQ.1 .AND. IU.EQ.N ) ) .AND.
+ $ IEEEOK.EQ.1 ) THEN
+ IF( .NOT.WANTZ ) THEN
+ CALL DCOPY( N, WORK( INDD ), 1, W, 1 )
+ CALL DCOPY( N-1, WORK( INDE ), 1, WORK( INDEE ), 1 )
+ CALL DSTERF( N, W, WORK( INDEE ), INFO )
+ ELSE
+ CALL DCOPY( N-1, WORK( INDE ), 1, WORK( INDEE ), 1 )
+ CALL DCOPY( N, WORK( INDD ), 1, WORK( INDDD ), 1 )
+*
+ IF (ABSTOL .LE. TWO*N*EPS) THEN
+ TRYRAC = .TRUE.
+ ELSE
+ TRYRAC = .FALSE.
+ END IF
+ CALL DSTEMR( JOBZ, 'A', N, WORK( INDDD ), WORK( INDEE ),
+ $ VL, VU, IL, IU, M, W, Z, LDZ, N, ISUPPZ,
+ $ TRYRAC, WORK( INDWK ), LWORK, IWORK, LIWORK,
+ $ INFO )
+*
+*
+*
+* Apply orthogonal matrix used in reduction to tridiagonal
+* form to eigenvectors returned by DSTEIN.
+*
+ IF( WANTZ .AND. INFO.EQ.0 ) THEN
+ INDWKN = INDE
+ LLWRKN = LWORK - INDWKN + 1
+ CALL DORMTR( 'L', UPLO, 'N', N, M, A, LDA,
+ $ WORK( INDTAU ), Z, LDZ, WORK( INDWKN ),
+ $ LLWRKN, IINFO )
+ END IF
+ END IF
+*
+*
+ IF( INFO.EQ.0 ) THEN
+* Everything worked. Skip DSTEBZ/DSTEIN. IWORK(:) are
+* undefined.
+ M = N
+ GO TO 30
+ END IF
+ INFO = 0
+ END IF
+*
+* Otherwise, call DSTEBZ and, if eigenvectors are desired, DSTEIN.
+* Also call DSTEBZ and DSTEIN if DSTEMR fails.
+*
+ IF( WANTZ ) THEN
+ ORDER = 'B'
+ ELSE
+ ORDER = 'E'
+ END IF
+
+ CALL DSTEBZ( RANGE, ORDER, N, VLL, VUU, IL, IU, ABSTLL,
+ $ WORK( INDD ), WORK( INDE ), M, NSPLIT, W,
+ $ IWORK( INDIBL ), IWORK( INDISP ), WORK( INDWK ),
+ $ IWORK( INDIWO ), INFO )
+*
+ IF( WANTZ ) THEN
+ CALL DSTEIN( N, WORK( INDD ), WORK( INDE ), M, W,
+ $ IWORK( INDIBL ), IWORK( INDISP ), Z, LDZ,
+ $ WORK( INDWK ), IWORK( INDIWO ), IWORK( INDIFL ),
+ $ INFO )
+*
+* Apply orthogonal matrix used in reduction to tridiagonal
+* form to eigenvectors returned by DSTEIN.
+*
+ INDWKN = INDE
+ LLWRKN = LWORK - INDWKN + 1
+ CALL DORMTR( 'L', UPLO, 'N', N, M, A, LDA, WORK( INDTAU ), Z,
+ $ LDZ, WORK( INDWKN ), LLWRKN, IINFO )
+ END IF
+*
+* If matrix was scaled, then rescale eigenvalues appropriately.
+*
+* Jump here if DSTEMR/DSTEIN succeeded.
+ 30 CONTINUE
+ IF( ISCALE.EQ.1 ) THEN
+ IF( INFO.EQ.0 ) THEN
+ IMAX = M
+ ELSE
+ IMAX = INFO - 1
+ END IF
+ CALL DSCAL( IMAX, ONE / SIGMA, W, 1 )
+ END IF
+*
+* If eigenvalues are not in order, then sort them, along with
+* eigenvectors. Note: We do not sort the IFAIL portion of IWORK.
+* It may not be initialized (if DSTEMR/DSTEIN succeeded), and we do
+* not return this detailed information to the user.
+*
+ IF( WANTZ ) THEN
+ DO 50 J = 1, M - 1
+ I = 0
+ TMP1 = W( J )
+ DO 40 JJ = J + 1, M
+ IF( W( JJ ).LT.TMP1 ) THEN
+ I = JJ
+ TMP1 = W( JJ )
+ END IF
+ 40 CONTINUE
+*
+ IF( I.NE.0 ) THEN
+ W( I ) = W( J )
+ W( J ) = TMP1
+ CALL DSWAP( N, Z( 1, I ), 1, Z( 1, J ), 1 )
+ END IF
+ 50 CONTINUE
+ END IF
+*
+* Set WORK(1) to optimal workspace size.
+*
+ WORK( 1 ) = LWKOPT
+ IWORK( 1 ) = LIWMIN
+*
+ RETURN
+*
+* End of DSYEVR
+*
+ END
+ SUBROUTINE DSYEVX( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU,
+ $ ABSTOL, M, W, Z, LDZ, WORK, LWORK, IWORK,
+ $ IFAIL, INFO )
+*
+* -- LAPACK driver routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER JOBZ, RANGE, UPLO
+ INTEGER IL, INFO, IU, LDA, LDZ, LWORK, M, N
+ DOUBLE PRECISION ABSTOL, VL, VU
+* ..
+* .. Array Arguments ..
+ INTEGER IFAIL( * ), IWORK( * )
+ DOUBLE PRECISION A( LDA, * ), W( * ), WORK( * ), Z( LDZ, * )
+* ..
+*
+* Purpose
+* =======
+*
+* DSYEVX computes selected eigenvalues and, optionally, eigenvectors
+* of a real symmetric matrix A. Eigenvalues and eigenvectors can be
+* selected by specifying either a range of values or a range of indices
+* for the desired eigenvalues.
+*
+* Arguments
+* =========
+*
+* JOBZ (input) CHARACTER*1
+* = 'N': Compute eigenvalues only;
+* = 'V': Compute eigenvalues and eigenvectors.
+*
+* RANGE (input) CHARACTER*1
+* = 'A': all eigenvalues will be found.
+* = 'V': all eigenvalues in the half-open interval (VL,VU]
+* will be found.
+* = 'I': the IL-th through IU-th eigenvalues will be found.
+*
+* UPLO (input) CHARACTER*1
+* = 'U': Upper triangle of A is stored;
+* = 'L': Lower triangle of A is stored.
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* A (input/output) DOUBLE PRECISION array, dimension (LDA, N)
+* On entry, the symmetric matrix A. If UPLO = 'U', the
+* leading N-by-N upper triangular part of A contains the
+* upper triangular part of the matrix A. If UPLO = 'L',
+* the leading N-by-N lower triangular part of A contains
+* the lower triangular part of the matrix A.
+* On exit, the lower triangle (if UPLO='L') or the upper
+* triangle (if UPLO='U') of A, including the diagonal, is
+* destroyed.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,N).
+*
+* VL (input) DOUBLE PRECISION
+* VU (input) DOUBLE PRECISION
+* If RANGE='V', the lower and upper bounds of the interval to
+* be searched for eigenvalues. VL < VU.
+* Not referenced if RANGE = 'A' or 'I'.
+*
+* IL (input) INTEGER
+* IU (input) INTEGER
+* If RANGE='I', the indices (in ascending order) of the
+* smallest and largest eigenvalues to be returned.
+* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
+* Not referenced if RANGE = 'A' or 'V'.
+*
+* ABSTOL (input) DOUBLE PRECISION
+* The absolute error tolerance for the eigenvalues.
+* An approximate eigenvalue is accepted as converged
+* when it is determined to lie in an interval [a,b]
+* of width less than or equal to
+*
+* ABSTOL + EPS * max( |a|,|b| ) ,
+*
+* where EPS is the machine precision. If ABSTOL is less than
+* or equal to zero, then EPS*|T| will be used in its place,
+* where |T| is the 1-norm of the tridiagonal matrix obtained
+* by reducing A to tridiagonal form.
+*
+* Eigenvalues will be computed most accurately when ABSTOL is
+* set to twice the underflow threshold 2*DLAMCH('S'), not zero.
+* If this routine returns with INFO>0, indicating that some
+* eigenvectors did not converge, try setting ABSTOL to
+* 2*DLAMCH('S').
+*
+* See "Computing Small Singular Values of Bidiagonal Matrices
+* with Guaranteed High Relative Accuracy," by Demmel and
+* Kahan, LAPACK Working Note #3.
+*
+* M (output) INTEGER
+* The total number of eigenvalues found. 0 <= M <= N.
+* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
+*
+* W (output) DOUBLE PRECISION array, dimension (N)
+* On normal exit, the first M elements contain the selected
+* eigenvalues in ascending order.
+*
+* Z (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M))
+* If JOBZ = 'V', then if INFO = 0, the first M columns of Z
+* contain the orthonormal eigenvectors of the matrix A
+* corresponding to the selected eigenvalues, with the i-th
+* column of Z holding the eigenvector associated with W(i).
+* If an eigenvector fails to converge, then that column of Z
+* contains the latest approximation to the eigenvector, and the
+* index of the eigenvector is returned in IFAIL.
+* If JOBZ = 'N', then Z is not referenced.
+* Note: the user must ensure that at least max(1,M) columns are
+* supplied in the array Z; if RANGE = 'V', the exact value of M
+* is not known in advance and an upper bound must be used.
+*
+* LDZ (input) INTEGER
+* The leading dimension of the array Z. LDZ >= 1, and if
+* JOBZ = 'V', LDZ >= max(1,N).
+*
+* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
+* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+* LWORK (input) INTEGER
+* The length of the array WORK. LWORK >= 1, when N <= 1;
+* otherwise 8*N.
+* For optimal efficiency, LWORK >= (NB+3)*N,
+* where NB is the max of the blocksize for DSYTRD and DORMTR
+* returned by ILAENV.
+*
+* If LWORK = -1, then a workspace query is assumed; the routine
+* only calculates the optimal size of the WORK array, returns
+* this value as the first entry of the WORK array, and no error
+* message related to LWORK is issued by XERBLA.
+*
+* IWORK (workspace) INTEGER array, dimension (5*N)
+*
+* IFAIL (output) INTEGER array, dimension (N)
+* If JOBZ = 'V', then if INFO = 0, the first M elements of
+* IFAIL are zero. If INFO > 0, then IFAIL contains the
+* indices of the eigenvectors that failed to converge.
+* If JOBZ = 'N', then IFAIL is not referenced.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* > 0: if INFO = i, then i eigenvectors failed to converge.
+* Their indices are stored in array IFAIL.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL ALLEIG, INDEIG, LOWER, LQUERY, TEST, VALEIG,
+ $ WANTZ
+ CHARACTER ORDER
+ INTEGER I, IINFO, IMAX, INDD, INDE, INDEE, INDIBL,
+ $ INDISP, INDIWO, INDTAU, INDWKN, INDWRK, ISCALE,
+ $ ITMP1, J, JJ, LLWORK, LLWRKN, LWKMIN,
+ $ LWKOPT, NB, NSPLIT
+ DOUBLE PRECISION ABSTLL, ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN,
+ $ SIGMA, SMLNUM, TMP1, VLL, VUU
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ILAENV
+ DOUBLE PRECISION DLAMCH, DLANSY
+ EXTERNAL LSAME, ILAENV, DLAMCH, DLANSY
+* ..
+* .. External Subroutines ..
+ EXTERNAL DCOPY, DLACPY, DORGTR, DORMTR, DSCAL, DSTEBZ,
+ $ DSTEIN, DSTEQR, DSTERF, DSWAP, DSYTRD, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN, SQRT
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ LOWER = LSAME( UPLO, 'L' )
+ WANTZ = LSAME( JOBZ, 'V' )
+ ALLEIG = LSAME( RANGE, 'A' )
+ VALEIG = LSAME( RANGE, 'V' )
+ INDEIG = LSAME( RANGE, 'I' )
+ LQUERY = ( LWORK.EQ.-1 )
+*
+ INFO = 0
+ IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
+ INFO = -1
+ ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN
+ INFO = -2
+ ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN
+ INFO = -3
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -6
+ ELSE
+ IF( VALEIG ) THEN
+ IF( N.GT.0 .AND. VU.LE.VL )
+ $ INFO = -8
+ ELSE IF( INDEIG ) THEN
+ IF( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) THEN
+ INFO = -9
+ ELSE IF( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) THEN
+ INFO = -10
+ END IF
+ END IF
+ END IF
+ IF( INFO.EQ.0 ) THEN
+ IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
+ INFO = -15
+ END IF
+ END IF
+*
+ IF( INFO.EQ.0 ) THEN
+ IF( N.LE.1 ) THEN
+ LWKMIN = 1
+ WORK( 1 ) = LWKMIN
+ ELSE
+ LWKMIN = 8*N
+ NB = ILAENV( 1, 'DSYTRD', UPLO, N, -1, -1, -1 )
+ NB = MAX( NB, ILAENV( 1, 'DORMTR', UPLO, N, -1, -1, -1 ) )
+ LWKOPT = MAX( LWKMIN, ( NB + 3 )*N )
+ WORK( 1 ) = LWKOPT
+ END IF
+*
+ IF( LWORK.LT.LWKMIN .AND. .NOT.LQUERY )
+ $ INFO = -17
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DSYEVX', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ M = 0
+ IF( N.EQ.0 ) THEN
+ RETURN
+ END IF
+*
+ IF( N.EQ.1 ) THEN
+ IF( ALLEIG .OR. INDEIG ) THEN
+ M = 1
+ W( 1 ) = A( 1, 1 )
+ ELSE
+ IF( VL.LT.A( 1, 1 ) .AND. VU.GE.A( 1, 1 ) ) THEN
+ M = 1
+ W( 1 ) = A( 1, 1 )
+ END IF
+ END IF
+ IF( WANTZ )
+ $ Z( 1, 1 ) = ONE
+ RETURN
+ END IF
+*
+* Get machine constants.
+*
+ SAFMIN = DLAMCH( 'Safe minimum' )
+ EPS = DLAMCH( 'Precision' )
+ SMLNUM = SAFMIN / EPS
+ BIGNUM = ONE / SMLNUM
+ RMIN = SQRT( SMLNUM )
+ RMAX = MIN( SQRT( BIGNUM ), ONE / SQRT( SQRT( SAFMIN ) ) )
+*
+* Scale matrix to allowable range, if necessary.
+*
+ ISCALE = 0
+ ABSTLL = ABSTOL
+ IF( VALEIG ) THEN
+ VLL = VL
+ VUU = VU
+ END IF
+ ANRM = DLANSY( 'M', UPLO, N, A, LDA, WORK )
+ IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN
+ ISCALE = 1
+ SIGMA = RMIN / ANRM
+ ELSE IF( ANRM.GT.RMAX ) THEN
+ ISCALE = 1
+ SIGMA = RMAX / ANRM
+ END IF
+ IF( ISCALE.EQ.1 ) THEN
+ IF( LOWER ) THEN
+ DO 10 J = 1, N
+ CALL DSCAL( N-J+1, SIGMA, A( J, J ), 1 )
+ 10 CONTINUE
+ ELSE
+ DO 20 J = 1, N
+ CALL DSCAL( J, SIGMA, A( 1, J ), 1 )
+ 20 CONTINUE
+ END IF
+ IF( ABSTOL.GT.0 )
+ $ ABSTLL = ABSTOL*SIGMA
+ IF( VALEIG ) THEN
+ VLL = VL*SIGMA
+ VUU = VU*SIGMA
+ END IF
+ END IF
+*
+* Call DSYTRD to reduce symmetric matrix to tridiagonal form.
+*
+ INDTAU = 1
+ INDE = INDTAU + N
+ INDD = INDE + N
+ INDWRK = INDD + N
+ LLWORK = LWORK - INDWRK + 1
+ CALL DSYTRD( UPLO, N, A, LDA, WORK( INDD ), WORK( INDE ),
+ $ WORK( INDTAU ), WORK( INDWRK ), LLWORK, IINFO )
+*
+* If all eigenvalues are desired and ABSTOL is less than or equal to
+* zero, then call DSTERF or DORGTR and SSTEQR. If this fails for
+* some eigenvalue, then try DSTEBZ.
+*
+ TEST = .FALSE.
+ IF( INDEIG ) THEN
+ IF( IL.EQ.1 .AND. IU.EQ.N ) THEN
+ TEST = .TRUE.
+ END IF
+ END IF
+ IF( ( ALLEIG .OR. TEST ) .AND. ( ABSTOL.LE.ZERO ) ) THEN
+ CALL DCOPY( N, WORK( INDD ), 1, W, 1 )
+ INDEE = INDWRK + 2*N
+ IF( .NOT.WANTZ ) THEN
+ CALL DCOPY( N-1, WORK( INDE ), 1, WORK( INDEE ), 1 )
+ CALL DSTERF( N, W, WORK( INDEE ), INFO )
+ ELSE
+ CALL DLACPY( 'A', N, N, A, LDA, Z, LDZ )
+ CALL DORGTR( UPLO, N, Z, LDZ, WORK( INDTAU ),
+ $ WORK( INDWRK ), LLWORK, IINFO )
+ CALL DCOPY( N-1, WORK( INDE ), 1, WORK( INDEE ), 1 )
+ CALL DSTEQR( JOBZ, N, W, WORK( INDEE ), Z, LDZ,
+ $ WORK( INDWRK ), INFO )
+ IF( INFO.EQ.0 ) THEN
+ DO 30 I = 1, N
+ IFAIL( I ) = 0
+ 30 CONTINUE
+ END IF
+ END IF
+ IF( INFO.EQ.0 ) THEN
+ M = N
+ GO TO 40
+ END IF
+ INFO = 0
+ END IF
+*
+* Otherwise, call DSTEBZ and, if eigenvectors are desired, SSTEIN.
+*
+ IF( WANTZ ) THEN
+ ORDER = 'B'
+ ELSE
+ ORDER = 'E'
+ END IF
+ INDIBL = 1
+ INDISP = INDIBL + N
+ INDIWO = INDISP + N
+ CALL DSTEBZ( RANGE, ORDER, N, VLL, VUU, IL, IU, ABSTLL,
+ $ WORK( INDD ), WORK( INDE ), M, NSPLIT, W,
+ $ IWORK( INDIBL ), IWORK( INDISP ), WORK( INDWRK ),
+ $ IWORK( INDIWO ), INFO )
+*
+ IF( WANTZ ) THEN
+ CALL DSTEIN( N, WORK( INDD ), WORK( INDE ), M, W,
+ $ IWORK( INDIBL ), IWORK( INDISP ), Z, LDZ,
+ $ WORK( INDWRK ), IWORK( INDIWO ), IFAIL, INFO )
+*
+* Apply orthogonal matrix used in reduction to tridiagonal
+* form to eigenvectors returned by DSTEIN.
+*
+ INDWKN = INDE
+ LLWRKN = LWORK - INDWKN + 1
+ CALL DORMTR( 'L', UPLO, 'N', N, M, A, LDA, WORK( INDTAU ), Z,
+ $ LDZ, WORK( INDWKN ), LLWRKN, IINFO )
+ END IF
+*
+* If matrix was scaled, then rescale eigenvalues appropriately.
+*
+ 40 CONTINUE
+ IF( ISCALE.EQ.1 ) THEN
+ IF( INFO.EQ.0 ) THEN
+ IMAX = M
+ ELSE
+ IMAX = INFO - 1
+ END IF
+ CALL DSCAL( IMAX, ONE / SIGMA, W, 1 )
+ END IF
+*
+* If eigenvalues are not in order, then sort them, along with
+* eigenvectors.
+*
+ IF( WANTZ ) THEN
+ DO 60 J = 1, M - 1
+ I = 0
+ TMP1 = W( J )
+ DO 50 JJ = J + 1, M
+ IF( W( JJ ).LT.TMP1 ) THEN
+ I = JJ
+ TMP1 = W( JJ )
+ END IF
+ 50 CONTINUE
+*
+ IF( I.NE.0 ) THEN
+ ITMP1 = IWORK( INDIBL+I-1 )
+ W( I ) = W( J )
+ IWORK( INDIBL+I-1 ) = IWORK( INDIBL+J-1 )
+ W( J ) = TMP1
+ IWORK( INDIBL+J-1 ) = ITMP1
+ CALL DSWAP( N, Z( 1, I ), 1, Z( 1, J ), 1 )
+ IF( INFO.NE.0 ) THEN
+ ITMP1 = IFAIL( I )
+ IFAIL( I ) = IFAIL( J )
+ IFAIL( J ) = ITMP1
+ END IF
+ END IF
+ 60 CONTINUE
+ END IF
+*
+* Set WORK(1) to optimal workspace size.
+*
+ WORK( 1 ) = LWKOPT
+*
+ RETURN
+*
+* End of DSYEVX
+*
+ END
+ SUBROUTINE DSYGS2( ITYPE, UPLO, N, A, LDA, B, LDB, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, ITYPE, LDA, LDB, N
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION A( LDA, * ), B( LDB, * )
+* ..
+*
+* Purpose
+* =======
+*
+* DSYGS2 reduces a real symmetric-definite generalized eigenproblem
+* to standard form.
+*
+* If ITYPE = 1, the problem is A*x = lambda*B*x,
+* and A is overwritten by inv(U')*A*inv(U) or inv(L)*A*inv(L')
+*
+* If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or
+* B*A*x = lambda*x, and A is overwritten by U*A*U` or L'*A*L.
+*
+* B must have been previously factorized as U'*U or L*L' by DPOTRF.
+*
+* Arguments
+* =========
+*
+* ITYPE (input) INTEGER
+* = 1: compute inv(U')*A*inv(U) or inv(L)*A*inv(L');
+* = 2 or 3: compute U*A*U' or L'*A*L.
+*
+* UPLO (input) CHARACTER*1
+* Specifies whether the upper or lower triangular part of the
+* symmetric matrix A is stored, and how B has been factorized.
+* = 'U': Upper triangular
+* = 'L': Lower triangular
+*
+* N (input) INTEGER
+* The order of the matrices A and B. N >= 0.
+*
+* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+* On entry, the symmetric matrix A. If UPLO = 'U', the leading
+* n by n upper triangular part of A contains the upper
+* triangular part of the matrix A, and the strictly lower
+* triangular part of A is not referenced. If UPLO = 'L', the
+* leading n by n lower triangular part of A contains the lower
+* triangular part of the matrix A, and the strictly upper
+* triangular part of A is not referenced.
+*
+* On exit, if INFO = 0, the transformed matrix, stored in the
+* same format as A.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,N).
+*
+* B (input) DOUBLE PRECISION array, dimension (LDB,N)
+* The triangular factor from the Cholesky factorization of B,
+* as returned by DPOTRF.
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. LDB >= max(1,N).
+*
+* INFO (output) INTEGER
+* = 0: successful exit.
+* < 0: if INFO = -i, the i-th argument had an illegal value.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE, HALF
+ PARAMETER ( ONE = 1.0D0, HALF = 0.5D0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL UPPER
+ INTEGER K
+ DOUBLE PRECISION AKK, BKK, CT
+* ..
+* .. External Subroutines ..
+ EXTERNAL DAXPY, DSCAL, DSYR2, DTRMV, DTRSV, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN
+ INFO = -1
+ ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -2
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -5
+ ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -7
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DSYGS2', -INFO )
+ RETURN
+ END IF
+*
+ IF( ITYPE.EQ.1 ) THEN
+ IF( UPPER ) THEN
+*
+* Compute inv(U')*A*inv(U)
+*
+ DO 10 K = 1, N
+*
+* Update the upper triangle of A(k:n,k:n)
+*
+ AKK = A( K, K )
+ BKK = B( K, K )
+ AKK = AKK / BKK**2
+ A( K, K ) = AKK
+ IF( K.LT.N ) THEN
+ CALL DSCAL( N-K, ONE / BKK, A( K, K+1 ), LDA )
+ CT = -HALF*AKK
+ CALL DAXPY( N-K, CT, B( K, K+1 ), LDB, A( K, K+1 ),
+ $ LDA )
+ CALL DSYR2( UPLO, N-K, -ONE, A( K, K+1 ), LDA,
+ $ B( K, K+1 ), LDB, A( K+1, K+1 ), LDA )
+ CALL DAXPY( N-K, CT, B( K, K+1 ), LDB, A( K, K+1 ),
+ $ LDA )
+ CALL DTRSV( UPLO, 'Transpose', 'Non-unit', N-K,
+ $ B( K+1, K+1 ), LDB, A( K, K+1 ), LDA )
+ END IF
+ 10 CONTINUE
+ ELSE
+*
+* Compute inv(L)*A*inv(L')
+*
+ DO 20 K = 1, N
+*
+* Update the lower triangle of A(k:n,k:n)
+*
+ AKK = A( K, K )
+ BKK = B( K, K )
+ AKK = AKK / BKK**2
+ A( K, K ) = AKK
+ IF( K.LT.N ) THEN
+ CALL DSCAL( N-K, ONE / BKK, A( K+1, K ), 1 )
+ CT = -HALF*AKK
+ CALL DAXPY( N-K, CT, B( K+1, K ), 1, A( K+1, K ), 1 )
+ CALL DSYR2( UPLO, N-K, -ONE, A( K+1, K ), 1,
+ $ B( K+1, K ), 1, A( K+1, K+1 ), LDA )
+ CALL DAXPY( N-K, CT, B( K+1, K ), 1, A( K+1, K ), 1 )
+ CALL DTRSV( UPLO, 'No transpose', 'Non-unit', N-K,
+ $ B( K+1, K+1 ), LDB, A( K+1, K ), 1 )
+ END IF
+ 20 CONTINUE
+ END IF
+ ELSE
+ IF( UPPER ) THEN
+*
+* Compute U*A*U'
+*
+ DO 30 K = 1, N
+*
+* Update the upper triangle of A(1:k,1:k)
+*
+ AKK = A( K, K )
+ BKK = B( K, K )
+ CALL DTRMV( UPLO, 'No transpose', 'Non-unit', K-1, B,
+ $ LDB, A( 1, K ), 1 )
+ CT = HALF*AKK
+ CALL DAXPY( K-1, CT, B( 1, K ), 1, A( 1, K ), 1 )
+ CALL DSYR2( UPLO, K-1, ONE, A( 1, K ), 1, B( 1, K ), 1,
+ $ A, LDA )
+ CALL DAXPY( K-1, CT, B( 1, K ), 1, A( 1, K ), 1 )
+ CALL DSCAL( K-1, BKK, A( 1, K ), 1 )
+ A( K, K ) = AKK*BKK**2
+ 30 CONTINUE
+ ELSE
+*
+* Compute L'*A*L
+*
+ DO 40 K = 1, N
+*
+* Update the lower triangle of A(1:k,1:k)
+*
+ AKK = A( K, K )
+ BKK = B( K, K )
+ CALL DTRMV( UPLO, 'Transpose', 'Non-unit', K-1, B, LDB,
+ $ A( K, 1 ), LDA )
+ CT = HALF*AKK
+ CALL DAXPY( K-1, CT, B( K, 1 ), LDB, A( K, 1 ), LDA )
+ CALL DSYR2( UPLO, K-1, ONE, A( K, 1 ), LDA, B( K, 1 ),
+ $ LDB, A, LDA )
+ CALL DAXPY( K-1, CT, B( K, 1 ), LDB, A( K, 1 ), LDA )
+ CALL DSCAL( K-1, BKK, A( K, 1 ), LDA )
+ A( K, K ) = AKK*BKK**2
+ 40 CONTINUE
+ END IF
+ END IF
+ RETURN
+*
+* End of DSYGS2
+*
+ END
+ SUBROUTINE DSYGST( ITYPE, UPLO, N, A, LDA, B, LDB, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, ITYPE, LDA, LDB, N
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION A( LDA, * ), B( LDB, * )
+* ..
+*
+* Purpose
+* =======
+*
+* DSYGST reduces a real symmetric-definite generalized eigenproblem
+* to standard form.
+*
+* If ITYPE = 1, the problem is A*x = lambda*B*x,
+* and A is overwritten by inv(U**T)*A*inv(U) or inv(L)*A*inv(L**T)
+*
+* If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or
+* B*A*x = lambda*x, and A is overwritten by U*A*U**T or L**T*A*L.
+*
+* B must have been previously factorized as U**T*U or L*L**T by DPOTRF.
+*
+* Arguments
+* =========
+*
+* ITYPE (input) INTEGER
+* = 1: compute inv(U**T)*A*inv(U) or inv(L)*A*inv(L**T);
+* = 2 or 3: compute U*A*U**T or L**T*A*L.
+*
+* UPLO (input) CHARACTER*1
+* = 'U': Upper triangle of A is stored and B is factored as
+* U**T*U;
+* = 'L': Lower triangle of A is stored and B is factored as
+* L*L**T.
+*
+* N (input) INTEGER
+* The order of the matrices A and B. N >= 0.
+*
+* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+* On entry, the symmetric matrix A. If UPLO = 'U', the leading
+* N-by-N upper triangular part of A contains the upper
+* triangular part of the matrix A, and the strictly lower
+* triangular part of A is not referenced. If UPLO = 'L', the
+* leading N-by-N lower triangular part of A contains the lower
+* triangular part of the matrix A, and the strictly upper
+* triangular part of A is not referenced.
+*
+* On exit, if INFO = 0, the transformed matrix, stored in the
+* same format as A.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,N).
+*
+* B (input) DOUBLE PRECISION array, dimension (LDB,N)
+* The triangular factor from the Cholesky factorization of B,
+* as returned by DPOTRF.
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. LDB >= max(1,N).
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE, HALF
+ PARAMETER ( ONE = 1.0D0, HALF = 0.5D0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL UPPER
+ INTEGER K, KB, NB
+* ..
+* .. External Subroutines ..
+ EXTERNAL DSYGS2, DSYMM, DSYR2K, DTRMM, DTRSM, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ILAENV
+ EXTERNAL LSAME, ILAENV
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN
+ INFO = -1
+ ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -2
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -5
+ ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -7
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DSYGST', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+* Determine the block size for this environment.
+*
+ NB = ILAENV( 1, 'DSYGST', UPLO, N, -1, -1, -1 )
+*
+ IF( NB.LE.1 .OR. NB.GE.N ) THEN
+*
+* Use unblocked code
+*
+ CALL DSYGS2( ITYPE, UPLO, N, A, LDA, B, LDB, INFO )
+ ELSE
+*
+* Use blocked code
+*
+ IF( ITYPE.EQ.1 ) THEN
+ IF( UPPER ) THEN
+*
+* Compute inv(U')*A*inv(U)
+*
+ DO 10 K = 1, N, NB
+ KB = MIN( N-K+1, NB )
+*
+* Update the upper triangle of A(k:n,k:n)
+*
+ CALL DSYGS2( ITYPE, UPLO, KB, A( K, K ), LDA,
+ $ B( K, K ), LDB, INFO )
+ IF( K+KB.LE.N ) THEN
+ CALL DTRSM( 'Left', UPLO, 'Transpose', 'Non-unit',
+ $ KB, N-K-KB+1, ONE, B( K, K ), LDB,
+ $ A( K, K+KB ), LDA )
+ CALL DSYMM( 'Left', UPLO, KB, N-K-KB+1, -HALF,
+ $ A( K, K ), LDA, B( K, K+KB ), LDB, ONE,
+ $ A( K, K+KB ), LDA )
+ CALL DSYR2K( UPLO, 'Transpose', N-K-KB+1, KB, -ONE,
+ $ A( K, K+KB ), LDA, B( K, K+KB ), LDB,
+ $ ONE, A( K+KB, K+KB ), LDA )
+ CALL DSYMM( 'Left', UPLO, KB, N-K-KB+1, -HALF,
+ $ A( K, K ), LDA, B( K, K+KB ), LDB, ONE,
+ $ A( K, K+KB ), LDA )
+ CALL DTRSM( 'Right', UPLO, 'No transpose',
+ $ 'Non-unit', KB, N-K-KB+1, ONE,
+ $ B( K+KB, K+KB ), LDB, A( K, K+KB ),
+ $ LDA )
+ END IF
+ 10 CONTINUE
+ ELSE
+*
+* Compute inv(L)*A*inv(L')
+*
+ DO 20 K = 1, N, NB
+ KB = MIN( N-K+1, NB )
+*
+* Update the lower triangle of A(k:n,k:n)
+*
+ CALL DSYGS2( ITYPE, UPLO, KB, A( K, K ), LDA,
+ $ B( K, K ), LDB, INFO )
+ IF( K+KB.LE.N ) THEN
+ CALL DTRSM( 'Right', UPLO, 'Transpose', 'Non-unit',
+ $ N-K-KB+1, KB, ONE, B( K, K ), LDB,
+ $ A( K+KB, K ), LDA )
+ CALL DSYMM( 'Right', UPLO, N-K-KB+1, KB, -HALF,
+ $ A( K, K ), LDA, B( K+KB, K ), LDB, ONE,
+ $ A( K+KB, K ), LDA )
+ CALL DSYR2K( UPLO, 'No transpose', N-K-KB+1, KB,
+ $ -ONE, A( K+KB, K ), LDA, B( K+KB, K ),
+ $ LDB, ONE, A( K+KB, K+KB ), LDA )
+ CALL DSYMM( 'Right', UPLO, N-K-KB+1, KB, -HALF,
+ $ A( K, K ), LDA, B( K+KB, K ), LDB, ONE,
+ $ A( K+KB, K ), LDA )
+ CALL DTRSM( 'Left', UPLO, 'No transpose',
+ $ 'Non-unit', N-K-KB+1, KB, ONE,
+ $ B( K+KB, K+KB ), LDB, A( K+KB, K ),
+ $ LDA )
+ END IF
+ 20 CONTINUE
+ END IF
+ ELSE
+ IF( UPPER ) THEN
+*
+* Compute U*A*U'
+*
+ DO 30 K = 1, N, NB
+ KB = MIN( N-K+1, NB )
+*
+* Update the upper triangle of A(1:k+kb-1,1:k+kb-1)
+*
+ CALL DTRMM( 'Left', UPLO, 'No transpose', 'Non-unit',
+ $ K-1, KB, ONE, B, LDB, A( 1, K ), LDA )
+ CALL DSYMM( 'Right', UPLO, K-1, KB, HALF, A( K, K ),
+ $ LDA, B( 1, K ), LDB, ONE, A( 1, K ), LDA )
+ CALL DSYR2K( UPLO, 'No transpose', K-1, KB, ONE,
+ $ A( 1, K ), LDA, B( 1, K ), LDB, ONE, A,
+ $ LDA )
+ CALL DSYMM( 'Right', UPLO, K-1, KB, HALF, A( K, K ),
+ $ LDA, B( 1, K ), LDB, ONE, A( 1, K ), LDA )
+ CALL DTRMM( 'Right', UPLO, 'Transpose', 'Non-unit',
+ $ K-1, KB, ONE, B( K, K ), LDB, A( 1, K ),
+ $ LDA )
+ CALL DSYGS2( ITYPE, UPLO, KB, A( K, K ), LDA,
+ $ B( K, K ), LDB, INFO )
+ 30 CONTINUE
+ ELSE
+*
+* Compute L'*A*L
+*
+ DO 40 K = 1, N, NB
+ KB = MIN( N-K+1, NB )
+*
+* Update the lower triangle of A(1:k+kb-1,1:k+kb-1)
+*
+ CALL DTRMM( 'Right', UPLO, 'No transpose', 'Non-unit',
+ $ KB, K-1, ONE, B, LDB, A( K, 1 ), LDA )
+ CALL DSYMM( 'Left', UPLO, KB, K-1, HALF, A( K, K ),
+ $ LDA, B( K, 1 ), LDB, ONE, A( K, 1 ), LDA )
+ CALL DSYR2K( UPLO, 'Transpose', K-1, KB, ONE,
+ $ A( K, 1 ), LDA, B( K, 1 ), LDB, ONE, A,
+ $ LDA )
+ CALL DSYMM( 'Left', UPLO, KB, K-1, HALF, A( K, K ),
+ $ LDA, B( K, 1 ), LDB, ONE, A( K, 1 ), LDA )
+ CALL DTRMM( 'Left', UPLO, 'Transpose', 'Non-unit', KB,
+ $ K-1, ONE, B( K, K ), LDB, A( K, 1 ), LDA )
+ CALL DSYGS2( ITYPE, UPLO, KB, A( K, K ), LDA,
+ $ B( K, K ), LDB, INFO )
+ 40 CONTINUE
+ END IF
+ END IF
+ END IF
+ RETURN
+*
+* End of DSYGST
+*
+ END
+ SUBROUTINE DSYGV( ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, W, WORK,
+ $ LWORK, INFO )
+*
+* -- LAPACK driver routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER JOBZ, UPLO
+ INTEGER INFO, ITYPE, LDA, LDB, LWORK, N
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION A( LDA, * ), B( LDB, * ), W( * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DSYGV computes all the eigenvalues, and optionally, the eigenvectors
+* of a real generalized symmetric-definite eigenproblem, of the form
+* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x.
+* Here A and B are assumed to be symmetric and B is also
+* positive definite.
+*
+* Arguments
+* =========
+*
+* ITYPE (input) INTEGER
+* Specifies the problem type to be solved:
+* = 1: A*x = (lambda)*B*x
+* = 2: A*B*x = (lambda)*x
+* = 3: B*A*x = (lambda)*x
+*
+* JOBZ (input) CHARACTER*1
+* = 'N': Compute eigenvalues only;
+* = 'V': Compute eigenvalues and eigenvectors.
+*
+* UPLO (input) CHARACTER*1
+* = 'U': Upper triangles of A and B are stored;
+* = 'L': Lower triangles of A and B are stored.
+*
+* N (input) INTEGER
+* The order of the matrices A and B. N >= 0.
+*
+* A (input/output) DOUBLE PRECISION array, dimension (LDA, N)
+* On entry, the symmetric matrix A. If UPLO = 'U', the
+* leading N-by-N upper triangular part of A contains the
+* upper triangular part of the matrix A. If UPLO = 'L',
+* the leading N-by-N lower triangular part of A contains
+* the lower triangular part of the matrix A.
+*
+* On exit, if JOBZ = 'V', then if INFO = 0, A contains the
+* matrix Z of eigenvectors. The eigenvectors are normalized
+* as follows:
+* if ITYPE = 1 or 2, Z**T*B*Z = I;
+* if ITYPE = 3, Z**T*inv(B)*Z = I.
+* If JOBZ = 'N', then on exit the upper triangle (if UPLO='U')
+* or the lower triangle (if UPLO='L') of A, including the
+* diagonal, is destroyed.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,N).
+*
+* B (input/output) DOUBLE PRECISION array, dimension (LDB, N)
+* On entry, the symmetric positive definite matrix B.
+* If UPLO = 'U', the leading N-by-N upper triangular part of B
+* contains the upper triangular part of the matrix B.
+* If UPLO = 'L', the leading N-by-N lower triangular part of B
+* contains the lower triangular part of the matrix B.
+*
+* On exit, if INFO <= N, the part of B containing the matrix is
+* overwritten by the triangular factor U or L from the Cholesky
+* factorization B = U**T*U or B = L*L**T.
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. LDB >= max(1,N).
+*
+* W (output) DOUBLE PRECISION array, dimension (N)
+* If INFO = 0, the eigenvalues in ascending order.
+*
+* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
+* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+* LWORK (input) INTEGER
+* The length of the array WORK. LWORK >= max(1,3*N-1).
+* For optimal efficiency, LWORK >= (NB+2)*N,
+* where NB is the blocksize for DSYTRD returned by ILAENV.
+*
+* If LWORK = -1, then a workspace query is assumed; the routine
+* only calculates the optimal size of the WORK array, returns
+* this value as the first entry of the WORK array, and no error
+* message related to LWORK is issued by XERBLA.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* > 0: DPOTRF or DSYEV returned an error code:
+* <= N: if INFO = i, DSYEV failed to converge;
+* i off-diagonal elements of an intermediate
+* tridiagonal form did not converge to zero;
+* > N: if INFO = N + i, for 1 <= i <= N, then the leading
+* minor of order i of B is not positive definite.
+* The factorization of B could not be completed and
+* no eigenvalues or eigenvectors were computed.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE
+ PARAMETER ( ONE = 1.0D+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL LQUERY, UPPER, WANTZ
+ CHARACTER TRANS
+ INTEGER LWKMIN, LWKOPT, NB, NEIG
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ILAENV
+ EXTERNAL LSAME, ILAENV
+* ..
+* .. External Subroutines ..
+ EXTERNAL DPOTRF, DSYEV, DSYGST, DTRMM, DTRSM, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ WANTZ = LSAME( JOBZ, 'V' )
+ UPPER = LSAME( UPLO, 'U' )
+ LQUERY = ( LWORK.EQ.-1 )
+*
+ INFO = 0
+ IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN
+ INFO = -1
+ ELSE IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
+ INFO = -2
+ ELSE IF( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN
+ INFO = -3
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -6
+ ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -8
+ END IF
+*
+ IF( INFO.EQ.0 ) THEN
+ LWKMIN = MAX( 1, 3*N - 1 )
+ NB = ILAENV( 1, 'DSYTRD', UPLO, N, -1, -1, -1 )
+ LWKOPT = MAX( LWKMIN, ( NB + 2 )*N )
+ WORK( 1 ) = LWKOPT
+*
+ IF( LWORK.LT.LWKMIN .AND. .NOT.LQUERY ) THEN
+ INFO = -11
+ END IF
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DSYGV ', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+* Form a Cholesky factorization of B.
+*
+ CALL DPOTRF( UPLO, N, B, LDB, INFO )
+ IF( INFO.NE.0 ) THEN
+ INFO = N + INFO
+ RETURN
+ END IF
+*
+* Transform problem to standard eigenvalue problem and solve.
+*
+ CALL DSYGST( ITYPE, UPLO, N, A, LDA, B, LDB, INFO )
+ CALL DSYEV( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, INFO )
+*
+ IF( WANTZ ) THEN
+*
+* Backtransform eigenvectors to the original problem.
+*
+ NEIG = N
+ IF( INFO.GT.0 )
+ $ NEIG = INFO - 1
+ IF( ITYPE.EQ.1 .OR. ITYPE.EQ.2 ) THEN
+*
+* For A*x=(lambda)*B*x and A*B*x=(lambda)*x;
+* backtransform eigenvectors: x = inv(L)'*y or inv(U)*y
+*
+ IF( UPPER ) THEN
+ TRANS = 'N'
+ ELSE
+ TRANS = 'T'
+ END IF
+*
+ CALL DTRSM( 'Left', UPLO, TRANS, 'Non-unit', N, NEIG, ONE,
+ $ B, LDB, A, LDA )
+*
+ ELSE IF( ITYPE.EQ.3 ) THEN
+*
+* For B*A*x=(lambda)*x;
+* backtransform eigenvectors: x = L*y or U'*y
+*
+ IF( UPPER ) THEN
+ TRANS = 'T'
+ ELSE
+ TRANS = 'N'
+ END IF
+*
+ CALL DTRMM( 'Left', UPLO, TRANS, 'Non-unit', N, NEIG, ONE,
+ $ B, LDB, A, LDA )
+ END IF
+ END IF
+*
+ WORK( 1 ) = LWKOPT
+ RETURN
+*
+* End of DSYGV
+*
+ END
+ SUBROUTINE DSYGVD( ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, W, WORK,
+ $ LWORK, IWORK, LIWORK, INFO )
+*
+* -- LAPACK driver routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER JOBZ, UPLO
+ INTEGER INFO, ITYPE, LDA, LDB, LIWORK, LWORK, N
+* ..
+* .. Array Arguments ..
+ INTEGER IWORK( * )
+ DOUBLE PRECISION A( LDA, * ), B( LDB, * ), W( * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DSYGVD computes all the eigenvalues, and optionally, the eigenvectors
+* of a real generalized symmetric-definite eigenproblem, of the form
+* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A and
+* B are assumed to be symmetric and B is also positive definite.
+* If eigenvectors are desired, it uses a divide and conquer algorithm.
+*
+* The divide and conquer algorithm makes very mild assumptions about
+* floating point arithmetic. It will work on machines with a guard
+* digit in add/subtract, or on those binary machines without guard
+* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
+* Cray-2. It could conceivably fail on hexadecimal or decimal machines
+* without guard digits, but we know of none.
+*
+* Arguments
+* =========
+*
+* ITYPE (input) INTEGER
+* Specifies the problem type to be solved:
+* = 1: A*x = (lambda)*B*x
+* = 2: A*B*x = (lambda)*x
+* = 3: B*A*x = (lambda)*x
+*
+* JOBZ (input) CHARACTER*1
+* = 'N': Compute eigenvalues only;
+* = 'V': Compute eigenvalues and eigenvectors.
+*
+* UPLO (input) CHARACTER*1
+* = 'U': Upper triangles of A and B are stored;
+* = 'L': Lower triangles of A and B are stored.
+*
+* N (input) INTEGER
+* The order of the matrices A and B. N >= 0.
+*
+* A (input/output) DOUBLE PRECISION array, dimension (LDA, N)
+* On entry, the symmetric matrix A. If UPLO = 'U', the
+* leading N-by-N upper triangular part of A contains the
+* upper triangular part of the matrix A. If UPLO = 'L',
+* the leading N-by-N lower triangular part of A contains
+* the lower triangular part of the matrix A.
+*
+* On exit, if JOBZ = 'V', then if INFO = 0, A contains the
+* matrix Z of eigenvectors. The eigenvectors are normalized
+* as follows:
+* if ITYPE = 1 or 2, Z**T*B*Z = I;
+* if ITYPE = 3, Z**T*inv(B)*Z = I.
+* If JOBZ = 'N', then on exit the upper triangle (if UPLO='U')
+* or the lower triangle (if UPLO='L') of A, including the
+* diagonal, is destroyed.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,N).
+*
+* B (input/output) DOUBLE PRECISION array, dimension (LDB, N)
+* On entry, the symmetric matrix B. If UPLO = 'U', the
+* leading N-by-N upper triangular part of B contains the
+* upper triangular part of the matrix B. If UPLO = 'L',
+* the leading N-by-N lower triangular part of B contains
+* the lower triangular part of the matrix B.
+*
+* On exit, if INFO <= N, the part of B containing the matrix is
+* overwritten by the triangular factor U or L from the Cholesky
+* factorization B = U**T*U or B = L*L**T.
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. LDB >= max(1,N).
+*
+* W (output) DOUBLE PRECISION array, dimension (N)
+* If INFO = 0, the eigenvalues in ascending order.
+*
+* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
+* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+* LWORK (input) INTEGER
+* The dimension of the array WORK.
+* If N <= 1, LWORK >= 1.
+* If JOBZ = 'N' and N > 1, LWORK >= 2*N+1.
+* If JOBZ = 'V' and N > 1, LWORK >= 1 + 6*N + 2*N**2.
+*
+* If LWORK = -1, then a workspace query is assumed; the routine
+* only calculates the optimal sizes of the WORK and IWORK
+* arrays, returns these values as the first entries of the WORK
+* and IWORK arrays, and no error message related to LWORK or
+* LIWORK is issued by XERBLA.
+*
+* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))
+* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
+*
+* LIWORK (input) INTEGER
+* The dimension of the array IWORK.
+* If N <= 1, LIWORK >= 1.
+* If JOBZ = 'N' and N > 1, LIWORK >= 1.
+* If JOBZ = 'V' and N > 1, LIWORK >= 3 + 5*N.
+*
+* If LIWORK = -1, then a workspace query is assumed; the
+* routine only calculates the optimal sizes of the WORK and
+* IWORK arrays, returns these values as the first entries of
+* the WORK and IWORK arrays, and no error message related to
+* LWORK or LIWORK is issued by XERBLA.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* > 0: DPOTRF or DSYEVD returned an error code:
+* <= N: if INFO = i and JOBZ = 'N', then the algorithm
+* failed to converge; i off-diagonal elements of an
+* intermediate tridiagonal form did not converge to
+* zero;
+* if INFO = i and JOBZ = 'V', then the algorithm
+* failed to compute an eigenvalue while working on
+* the submatrix lying in rows and columns INFO/(N+1)
+* through mod(INFO,N+1);
+* > N: if INFO = N + i, for 1 <= i <= N, then the leading
+* minor of order i of B is not positive definite.
+* The factorization of B could not be completed and
+* no eigenvalues or eigenvectors were computed.
+*
+* Further Details
+* ===============
+*
+* Based on contributions by
+* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA
+*
+* Modified so that no backsubstitution is performed if DSYEVD fails to
+* converge (NEIG in old code could be greater than N causing out of
+* bounds reference to A - reported by Ralf Meyer). Also corrected the
+* description of INFO and the test on ITYPE. Sven, 16 Feb 05.
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE
+ PARAMETER ( ONE = 1.0D+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL LQUERY, UPPER, WANTZ
+ CHARACTER TRANS
+ INTEGER LIOPT, LIWMIN, LOPT, LWMIN
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL DPOTRF, DSYEVD, DSYGST, DTRMM, DTRSM, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC DBLE, MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ WANTZ = LSAME( JOBZ, 'V' )
+ UPPER = LSAME( UPLO, 'U' )
+ LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 )
+*
+ INFO = 0
+ IF( N.LE.1 ) THEN
+ LIWMIN = 1
+ LWMIN = 1
+ ELSE IF( WANTZ ) THEN
+ LIWMIN = 3 + 5*N
+ LWMIN = 1 + 6*N + 2*N**2
+ ELSE
+ LIWMIN = 1
+ LWMIN = 2*N + 1
+ END IF
+ LOPT = LWMIN
+ LIOPT = LIWMIN
+ IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN
+ INFO = -1
+ ELSE IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
+ INFO = -2
+ ELSE IF( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN
+ INFO = -3
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -6
+ ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -8
+ END IF
+*
+ IF( INFO.EQ.0 ) THEN
+ WORK( 1 ) = LOPT
+ IWORK( 1 ) = LIOPT
+*
+ IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
+ INFO = -11
+ ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN
+ INFO = -13
+ END IF
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DSYGVD', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+* Form a Cholesky factorization of B.
+*
+ CALL DPOTRF( UPLO, N, B, LDB, INFO )
+ IF( INFO.NE.0 ) THEN
+ INFO = N + INFO
+ RETURN
+ END IF
+*
+* Transform problem to standard eigenvalue problem and solve.
+*
+ CALL DSYGST( ITYPE, UPLO, N, A, LDA, B, LDB, INFO )
+ CALL DSYEVD( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, IWORK, LIWORK,
+ $ INFO )
+ LOPT = MAX( DBLE( LOPT ), DBLE( WORK( 1 ) ) )
+ LIOPT = MAX( DBLE( LIOPT ), DBLE( IWORK( 1 ) ) )
+*
+ IF( WANTZ .AND. INFO.EQ.0 ) THEN
+*
+* Backtransform eigenvectors to the original problem.
+*
+ IF( ITYPE.EQ.1 .OR. ITYPE.EQ.2 ) THEN
+*
+* For A*x=(lambda)*B*x and A*B*x=(lambda)*x;
+* backtransform eigenvectors: x = inv(L)'*y or inv(U)*y
+*
+ IF( UPPER ) THEN
+ TRANS = 'N'
+ ELSE
+ TRANS = 'T'
+ END IF
+*
+ CALL DTRSM( 'Left', UPLO, TRANS, 'Non-unit', N, N, ONE,
+ $ B, LDB, A, LDA )
+*
+ ELSE IF( ITYPE.EQ.3 ) THEN
+*
+* For B*A*x=(lambda)*x;
+* backtransform eigenvectors: x = L*y or U'*y
+*
+ IF( UPPER ) THEN
+ TRANS = 'T'
+ ELSE
+ TRANS = 'N'
+ END IF
+*
+ CALL DTRMM( 'Left', UPLO, TRANS, 'Non-unit', N, N, ONE,
+ $ B, LDB, A, LDA )
+ END IF
+ END IF
+*
+ WORK( 1 ) = LOPT
+ IWORK( 1 ) = LIOPT
+*
+ RETURN
+*
+* End of DSYGVD
+*
+ END
+ 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 )
+*
+* -- LAPACK driver routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER JOBZ, RANGE, UPLO
+ INTEGER IL, INFO, ITYPE, IU, LDA, LDB, LDZ, LWORK, M, N
+ DOUBLE PRECISION ABSTOL, VL, VU
+* ..
+* .. Array Arguments ..
+ INTEGER IFAIL( * ), IWORK( * )
+ DOUBLE PRECISION A( LDA, * ), B( LDB, * ), W( * ), WORK( * ),
+ $ Z( LDZ, * )
+* ..
+*
+* Purpose
+* =======
+*
+* DSYGVX computes selected eigenvalues, and optionally, eigenvectors
+* of a real generalized symmetric-definite eigenproblem, of the form
+* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A
+* and B are assumed to be symmetric and B is also positive definite.
+* Eigenvalues and eigenvectors can be selected by specifying either a
+* range of values or a range of indices for the desired eigenvalues.
+*
+* Arguments
+* =========
+*
+* ITYPE (input) INTEGER
+* Specifies the problem type to be solved:
+* = 1: A*x = (lambda)*B*x
+* = 2: A*B*x = (lambda)*x
+* = 3: B*A*x = (lambda)*x
+*
+* JOBZ (input) CHARACTER*1
+* = 'N': Compute eigenvalues only;
+* = 'V': Compute eigenvalues and eigenvectors.
+*
+* RANGE (input) CHARACTER*1
+* = 'A': all eigenvalues will be found.
+* = 'V': all eigenvalues in the half-open interval (VL,VU]
+* will be found.
+* = 'I': the IL-th through IU-th eigenvalues will be found.
+*
+* UPLO (input) CHARACTER*1
+* = 'U': Upper triangle of A and B are stored;
+* = 'L': Lower triangle of A and B are stored.
+*
+* N (input) INTEGER
+* The order of the matrix pencil (A,B). N >= 0.
+*
+* A (input/output) DOUBLE PRECISION array, dimension (LDA, N)
+* On entry, the symmetric matrix A. If UPLO = 'U', the
+* leading N-by-N upper triangular part of A contains the
+* upper triangular part of the matrix A. If UPLO = 'L',
+* the leading N-by-N lower triangular part of A contains
+* the lower triangular part of the matrix A.
+*
+* On exit, the lower triangle (if UPLO='L') or the upper
+* triangle (if UPLO='U') of A, including the diagonal, is
+* destroyed.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,N).
+*
+* B (input/output) DOUBLE PRECISION array, dimension (LDA, N)
+* On entry, the symmetric matrix B. If UPLO = 'U', the
+* leading N-by-N upper triangular part of B contains the
+* upper triangular part of the matrix B. If UPLO = 'L',
+* the leading N-by-N lower triangular part of B contains
+* the lower triangular part of the matrix B.
+*
+* On exit, if INFO <= N, the part of B containing the matrix is
+* overwritten by the triangular factor U or L from the Cholesky
+* factorization B = U**T*U or B = L*L**T.
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. LDB >= max(1,N).
+*
+* VL (input) DOUBLE PRECISION
+* VU (input) DOUBLE PRECISION
+* If RANGE='V', the lower and upper bounds of the interval to
+* be searched for eigenvalues. VL < VU.
+* Not referenced if RANGE = 'A' or 'I'.
+*
+* IL (input) INTEGER
+* IU (input) INTEGER
+* If RANGE='I', the indices (in ascending order) of the
+* smallest and largest eigenvalues to be returned.
+* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
+* Not referenced if RANGE = 'A' or 'V'.
+*
+* ABSTOL (input) DOUBLE PRECISION
+* The absolute error tolerance for the eigenvalues.
+* An approximate eigenvalue is accepted as converged
+* when it is determined to lie in an interval [a,b]
+* of width less than or equal to
+*
+* ABSTOL + EPS * max( |a|,|b| ) ,
+*
+* where EPS is the machine precision. If ABSTOL is less than
+* or equal to zero, then EPS*|T| will be used in its place,
+* where |T| is the 1-norm of the tridiagonal matrix obtained
+* by reducing A to tridiagonal form.
+*
+* Eigenvalues will be computed most accurately when ABSTOL is
+* set to twice the underflow threshold 2*DLAMCH('S'), not zero.
+* If this routine returns with INFO>0, indicating that some
+* eigenvectors did not converge, try setting ABSTOL to
+* 2*DLAMCH('S').
+*
+* M (output) INTEGER
+* The total number of eigenvalues found. 0 <= M <= N.
+* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
+*
+* W (output) DOUBLE PRECISION array, dimension (N)
+* On normal exit, the first M elements contain the selected
+* eigenvalues in ascending order.
+*
+* Z (output) DOUBLE PRECISION array, dimension (LDZ, max(1,M))
+* If JOBZ = 'N', then Z is not referenced.
+* If JOBZ = 'V', then if INFO = 0, the first M columns of Z
+* contain the orthonormal eigenvectors of the matrix A
+* corresponding to the selected eigenvalues, with the i-th
+* column of Z holding the eigenvector associated with W(i).
+* The eigenvectors are normalized as follows:
+* if ITYPE = 1 or 2, Z**T*B*Z = I;
+* if ITYPE = 3, Z**T*inv(B)*Z = I.
+*
+* If an eigenvector fails to converge, then that column of Z
+* contains the latest approximation to the eigenvector, and the
+* index of the eigenvector is returned in IFAIL.
+* Note: the user must ensure that at least max(1,M) columns are
+* supplied in the array Z; if RANGE = 'V', the exact value of M
+* is not known in advance and an upper bound must be used.
+*
+* LDZ (input) INTEGER
+* The leading dimension of the array Z. LDZ >= 1, and if
+* JOBZ = 'V', LDZ >= max(1,N).
+*
+* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
+* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+* LWORK (input) INTEGER
+* The length of the array WORK. LWORK >= max(1,8*N).
+* For optimal efficiency, LWORK >= (NB+3)*N,
+* where NB is the blocksize for DSYTRD returned by ILAENV.
+*
+* If LWORK = -1, then a workspace query is assumed; the routine
+* only calculates the optimal size of the WORK array, returns
+* this value as the first entry of the WORK array, and no error
+* message related to LWORK is issued by XERBLA.
+*
+* IWORK (workspace) INTEGER array, dimension (5*N)
+*
+* IFAIL (output) INTEGER array, dimension (N)
+* If JOBZ = 'V', then if INFO = 0, the first M elements of
+* IFAIL are zero. If INFO > 0, then IFAIL contains the
+* indices of the eigenvectors that failed to converge.
+* If JOBZ = 'N', then IFAIL is not referenced.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* > 0: DPOTRF or DSYEVX returned an error code:
+* <= N: if INFO = i, DSYEVX failed to converge;
+* i eigenvectors failed to converge. Their indices
+* are stored in array IFAIL.
+* > N: if INFO = N + i, for 1 <= i <= N, then the leading
+* minor of order i of B is not positive definite.
+* The factorization of B could not be completed and
+* no eigenvalues or eigenvectors were computed.
+*
+* Further Details
+* ===============
+*
+* Based on contributions by
+* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE
+ PARAMETER ( ONE = 1.0D+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL ALLEIG, INDEIG, LQUERY, UPPER, VALEIG, WANTZ
+ CHARACTER TRANS
+ INTEGER LWKMIN, LWKOPT, NB
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ILAENV
+ EXTERNAL LSAME, ILAENV
+* ..
+* .. External Subroutines ..
+ EXTERNAL DPOTRF, DSYEVX, DSYGST, DTRMM, DTRSM, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ UPPER = LSAME( UPLO, 'U' )
+ WANTZ = LSAME( JOBZ, 'V' )
+ ALLEIG = LSAME( RANGE, 'A' )
+ VALEIG = LSAME( RANGE, 'V' )
+ INDEIG = LSAME( RANGE, 'I' )
+ LQUERY = ( LWORK.EQ.-1 )
+*
+ INFO = 0
+ IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN
+ INFO = -1
+ ELSE IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
+ INFO = -2
+ ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN
+ INFO = -3
+ ELSE IF( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN
+ INFO = -4
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -5
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -7
+ ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -9
+ ELSE
+ IF( VALEIG ) THEN
+ IF( N.GT.0 .AND. VU.LE.VL )
+ $ INFO = -11
+ ELSE IF( INDEIG ) THEN
+ IF( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) THEN
+ INFO = -12
+ ELSE IF( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) THEN
+ INFO = -13
+ END IF
+ END IF
+ END IF
+ IF (INFO.EQ.0) THEN
+ IF (LDZ.LT.1 .OR. (WANTZ .AND. LDZ.LT.N)) THEN
+ INFO = -18
+ END IF
+ END IF
+*
+ IF( INFO.EQ.0 ) THEN
+ LWKMIN = MAX( 1, 8*N )
+ NB = ILAENV( 1, 'DSYTRD', UPLO, N, -1, -1, -1 )
+ LWKOPT = MAX( LWKMIN, ( NB + 3 )*N )
+ WORK( 1 ) = LWKOPT
+*
+ IF( LWORK.LT.LWKMIN .AND. .NOT.LQUERY ) THEN
+ INFO = -20
+ END IF
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DSYGVX', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ M = 0
+ IF( N.EQ.0 ) THEN
+ RETURN
+ END IF
+*
+* Form a Cholesky factorization of B.
+*
+ CALL DPOTRF( UPLO, N, B, LDB, INFO )
+ IF( INFO.NE.0 ) THEN
+ INFO = N + INFO
+ RETURN
+ END IF
+*
+* Transform problem to standard eigenvalue problem and solve.
+*
+ CALL DSYGST( ITYPE, UPLO, N, A, LDA, B, LDB, INFO )
+ CALL DSYEVX( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, ABSTOL,
+ $ M, W, Z, LDZ, WORK, LWORK, IWORK, IFAIL, INFO )
+*
+ IF( WANTZ ) THEN
+*
+* Backtransform eigenvectors to the original problem.
+*
+ IF( INFO.GT.0 )
+ $ M = INFO - 1
+ IF( ITYPE.EQ.1 .OR. ITYPE.EQ.2 ) THEN
+*
+* For A*x=(lambda)*B*x and A*B*x=(lambda)*x;
+* backtransform eigenvectors: x = inv(L)'*y or inv(U)*y
+*
+ IF( UPPER ) THEN
+ TRANS = 'N'
+ ELSE
+ TRANS = 'T'
+ END IF
+*
+ CALL DTRSM( 'Left', UPLO, TRANS, 'Non-unit', N, M, ONE, B,
+ $ LDB, Z, LDZ )
+*
+ ELSE IF( ITYPE.EQ.3 ) THEN
+*
+* For B*A*x=(lambda)*x;
+* backtransform eigenvectors: x = L*y or U'*y
+*
+ IF( UPPER ) THEN
+ TRANS = 'T'
+ ELSE
+ TRANS = 'N'
+ END IF
+*
+ CALL DTRMM( 'Left', UPLO, TRANS, 'Non-unit', N, M, ONE, B,
+ $ LDB, Z, LDZ )
+ END IF
+ END IF
+*
+* Set WORK(1) to optimal workspace size.
+*
+ WORK( 1 ) = LWKOPT
+*
+ RETURN
+*
+* End of DSYGVX
+*
+ END
+ SUBROUTINE DSYRFS( UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB,
+ $ X, LDX, FERR, BERR, WORK, IWORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH.
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * ), IWORK( * )
+ DOUBLE PRECISION A( LDA, * ), AF( LDAF, * ), B( LDB, * ),
+ $ BERR( * ), FERR( * ), WORK( * ), X( LDX, * )
+* ..
+*
+* Purpose
+* =======
+*
+* DSYRFS improves the computed solution to a system of linear
+* equations when the coefficient matrix is symmetric indefinite, and
+* provides error bounds and backward error estimates for the solution.
+*
+* Arguments
+* =========
+*
+* UPLO (input) CHARACTER*1
+* = 'U': Upper triangle of A is stored;
+* = 'L': Lower triangle of A is stored.
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* NRHS (input) INTEGER
+* The number of right hand sides, i.e., the number of columns
+* of the matrices B and X. NRHS >= 0.
+*
+* A (input) DOUBLE PRECISION array, dimension (LDA,N)
+* The symmetric matrix A. If UPLO = 'U', the leading N-by-N
+* upper triangular part of A contains the upper triangular part
+* of the matrix A, and the strictly lower triangular part of A
+* is not referenced. If UPLO = 'L', the leading N-by-N lower
+* triangular part of A contains the lower triangular part of
+* the matrix A, and the strictly upper triangular part of A is
+* not referenced.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,N).
+*
+* AF (input) DOUBLE PRECISION array, dimension (LDAF,N)
+* The factored form of the matrix A. AF contains the block
+* diagonal matrix D and the multipliers used to obtain the
+* factor U or L from the factorization A = U*D*U**T or
+* A = L*D*L**T as computed by DSYTRF.
+*
+* LDAF (input) INTEGER
+* The leading dimension of the array AF. LDAF >= max(1,N).
+*
+* IPIV (input) INTEGER array, dimension (N)
+* Details of the interchanges and the block structure of D
+* as determined by DSYTRF.
+*
+* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS)
+* The right hand side matrix B.
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. LDB >= max(1,N).
+*
+* X (input/output) DOUBLE PRECISION array, dimension (LDX,NRHS)
+* On entry, the solution matrix X, as computed by DSYTRS.
+* On exit, the improved solution matrix X.
+*
+* LDX (input) INTEGER
+* The leading dimension of the array X. LDX >= max(1,N).
+*
+* FERR (output) DOUBLE PRECISION array, dimension (NRHS)
+* The estimated forward error bound for each solution vector
+* X(j) (the j-th column of the solution matrix X).
+* If XTRUE is the true solution corresponding to X(j), FERR(j)
+* is an estimated upper bound for the magnitude of the largest
+* element in (X(j) - XTRUE) divided by the magnitude of the
+* largest element in X(j). The estimate is as reliable as
+* the estimate for RCOND, and is almost always a slight
+* overestimate of the true error.
+*
+* BERR (output) DOUBLE PRECISION array, dimension (NRHS)
+* The componentwise relative backward error of each solution
+* vector X(j) (i.e., the smallest relative change in
+* any element of A or B that makes X(j) an exact solution).
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (3*N)
+*
+* IWORK (workspace) INTEGER array, dimension (N)
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+*
+* Internal Parameters
+* ===================
+*
+* ITMAX is the maximum number of steps of iterative refinement.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ INTEGER ITMAX
+ PARAMETER ( ITMAX = 5 )
+ DOUBLE PRECISION ZERO
+ PARAMETER ( ZERO = 0.0D+0 )
+ DOUBLE PRECISION ONE
+ PARAMETER ( ONE = 1.0D+0 )
+ DOUBLE PRECISION TWO
+ PARAMETER ( TWO = 2.0D+0 )
+ DOUBLE PRECISION THREE
+ PARAMETER ( THREE = 3.0D+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL UPPER
+ INTEGER COUNT, I, J, K, KASE, NZ
+ DOUBLE PRECISION EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK
+* ..
+* .. Local Arrays ..
+ INTEGER ISAVE( 3 )
+* ..
+* .. External Subroutines ..
+ EXTERNAL DAXPY, DCOPY, DLACN2, DSYMV, DSYTRS, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ DOUBLE PRECISION DLAMCH
+ EXTERNAL LSAME, DLAMCH
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( NRHS.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -5
+ ELSE IF( LDAF.LT.MAX( 1, N ) ) THEN
+ INFO = -7
+ ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -10
+ ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
+ INFO = -12
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DSYRFS', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN
+ DO 10 J = 1, NRHS
+ FERR( J ) = ZERO
+ BERR( J ) = ZERO
+ 10 CONTINUE
+ RETURN
+ END IF
+*
+* NZ = maximum number of nonzero elements in each row of A, plus 1
+*
+ NZ = N + 1
+ EPS = DLAMCH( 'Epsilon' )
+ SAFMIN = DLAMCH( 'Safe minimum' )
+ SAFE1 = NZ*SAFMIN
+ SAFE2 = SAFE1 / EPS
+*
+* Do for each right hand side
+*
+ DO 140 J = 1, NRHS
+*
+ COUNT = 1
+ LSTRES = THREE
+ 20 CONTINUE
+*
+* Loop until stopping criterion is satisfied.
+*
+* Compute residual R = B - A * X
+*
+ CALL DCOPY( N, B( 1, J ), 1, WORK( N+1 ), 1 )
+ CALL DSYMV( UPLO, N, -ONE, A, LDA, X( 1, J ), 1, ONE,
+ $ WORK( N+1 ), 1 )
+*
+* Compute componentwise relative backward error from formula
+*
+* max(i) ( abs(R(i)) / ( abs(A)*abs(X) + abs(B) )(i) )
+*
+* where abs(Z) is the componentwise absolute value of the matrix
+* or vector Z. If the i-th component of the denominator is less
+* than SAFE2, then SAFE1 is added to the i-th components of the
+* numerator and denominator before dividing.
+*
+ DO 30 I = 1, N
+ WORK( I ) = ABS( B( I, J ) )
+ 30 CONTINUE
+*
+* Compute abs(A)*abs(X) + abs(B).
+*
+ IF( UPPER ) THEN
+ DO 50 K = 1, N
+ S = ZERO
+ XK = ABS( X( K, J ) )
+ DO 40 I = 1, K - 1
+ WORK( I ) = WORK( I ) + ABS( A( I, K ) )*XK
+ S = S + ABS( A( I, K ) )*ABS( X( I, J ) )
+ 40 CONTINUE
+ WORK( K ) = WORK( K ) + ABS( A( K, K ) )*XK + S
+ 50 CONTINUE
+ ELSE
+ DO 70 K = 1, N
+ S = ZERO
+ XK = ABS( X( K, J ) )
+ WORK( K ) = WORK( K ) + ABS( A( K, K ) )*XK
+ DO 60 I = K + 1, N
+ WORK( I ) = WORK( I ) + ABS( A( I, K ) )*XK
+ S = S + ABS( A( I, K ) )*ABS( X( I, J ) )
+ 60 CONTINUE
+ WORK( K ) = WORK( K ) + S
+ 70 CONTINUE
+ END IF
+ S = ZERO
+ DO 80 I = 1, N
+ IF( WORK( I ).GT.SAFE2 ) THEN
+ S = MAX( S, ABS( WORK( N+I ) ) / WORK( I ) )
+ ELSE
+ S = MAX( S, ( ABS( WORK( N+I ) )+SAFE1 ) /
+ $ ( WORK( I )+SAFE1 ) )
+ END IF
+ 80 CONTINUE
+ BERR( J ) = S
+*
+* Test stopping criterion. Continue iterating if
+* 1) The residual BERR(J) is larger than machine epsilon, and
+* 2) BERR(J) decreased by at least a factor of 2 during the
+* last iteration, and
+* 3) At most ITMAX iterations tried.
+*
+ IF( BERR( J ).GT.EPS .AND. TWO*BERR( J ).LE.LSTRES .AND.
+ $ COUNT.LE.ITMAX ) THEN
+*
+* Update solution and try again.
+*
+ CALL DSYTRS( UPLO, N, 1, AF, LDAF, IPIV, WORK( N+1 ), N,
+ $ INFO )
+ CALL DAXPY( N, ONE, WORK( N+1 ), 1, X( 1, J ), 1 )
+ LSTRES = BERR( J )
+ COUNT = COUNT + 1
+ GO TO 20
+ END IF
+*
+* Bound error from formula
+*
+* norm(X - XTRUE) / norm(X) .le. FERR =
+* norm( abs(inv(A))*
+* ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X)
+*
+* where
+* norm(Z) is the magnitude of the largest component of Z
+* inv(A) is the inverse of A
+* abs(Z) is the componentwise absolute value of the matrix or
+* vector Z
+* NZ is the maximum number of nonzeros in any row of A, plus 1
+* EPS is machine epsilon
+*
+* The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B))
+* is incremented by SAFE1 if the i-th component of
+* abs(A)*abs(X) + abs(B) is less than SAFE2.
+*
+* Use DLACN2 to estimate the infinity-norm of the matrix
+* inv(A) * diag(W),
+* where W = abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) )))
+*
+ DO 90 I = 1, N
+ IF( WORK( I ).GT.SAFE2 ) THEN
+ WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I )
+ ELSE
+ WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I ) + SAFE1
+ END IF
+ 90 CONTINUE
+*
+ KASE = 0
+ 100 CONTINUE
+ CALL DLACN2( N, WORK( 2*N+1 ), WORK( N+1 ), IWORK, FERR( J ),
+ $ KASE, ISAVE )
+ IF( KASE.NE.0 ) THEN
+ IF( KASE.EQ.1 ) THEN
+*
+* Multiply by diag(W)*inv(A').
+*
+ CALL DSYTRS( UPLO, N, 1, AF, LDAF, IPIV, WORK( N+1 ), N,
+ $ INFO )
+ DO 110 I = 1, N
+ WORK( N+I ) = WORK( I )*WORK( N+I )
+ 110 CONTINUE
+ ELSE IF( KASE.EQ.2 ) THEN
+*
+* Multiply by inv(A)*diag(W).
+*
+ DO 120 I = 1, N
+ WORK( N+I ) = WORK( I )*WORK( N+I )
+ 120 CONTINUE
+ CALL DSYTRS( UPLO, N, 1, AF, LDAF, IPIV, WORK( N+1 ), N,
+ $ INFO )
+ END IF
+ GO TO 100
+ END IF
+*
+* Normalize error.
+*
+ LSTRES = ZERO
+ DO 130 I = 1, N
+ LSTRES = MAX( LSTRES, ABS( X( I, J ) ) )
+ 130 CONTINUE
+ IF( LSTRES.NE.ZERO )
+ $ FERR( J ) = FERR( J ) / LSTRES
+*
+ 140 CONTINUE
+*
+ RETURN
+*
+* End of DSYRFS
+*
+ END
+ SUBROUTINE DSYSV( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK,
+ $ LWORK, INFO )
+*
+* -- LAPACK driver routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, LDA, LDB, LWORK, N, NRHS
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ DOUBLE PRECISION A( LDA, * ), B( LDB, * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DSYSV computes the solution to a real system of linear equations
+* A * X = B,
+* where A is an N-by-N symmetric matrix and X and B are N-by-NRHS
+* matrices.
+*
+* The diagonal pivoting method is used to factor A as
+* A = U * D * U**T, if UPLO = 'U', or
+* A = L * D * L**T, if UPLO = 'L',
+* where U (or L) is a product of permutation and unit upper (lower)
+* triangular matrices, and D is symmetric and block diagonal with
+* 1-by-1 and 2-by-2 diagonal blocks. The factored form of A is then
+* used to solve the system of equations A * X = B.
+*
+* Arguments
+* =========
+*
+* UPLO (input) CHARACTER*1
+* = 'U': Upper triangle of A is stored;
+* = 'L': Lower triangle of A is stored.
+*
+* N (input) INTEGER
+* The number of linear equations, i.e., the order of the
+* matrix A. N >= 0.
+*
+* NRHS (input) INTEGER
+* The number of right hand sides, i.e., the number of columns
+* of the matrix B. NRHS >= 0.
+*
+* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+* On entry, the symmetric matrix A. If UPLO = 'U', the leading
+* N-by-N upper triangular part of A contains the upper
+* triangular part of the matrix A, and the strictly lower
+* triangular part of A is not referenced. If UPLO = 'L', the
+* leading N-by-N lower triangular part of A contains the lower
+* triangular part of the matrix A, and the strictly upper
+* triangular part of A is not referenced.
+*
+* On exit, if INFO = 0, the block diagonal matrix D and the
+* multipliers used to obtain the factor U or L from the
+* factorization A = U*D*U**T or A = L*D*L**T as computed by
+* DSYTRF.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,N).
+*
+* IPIV (output) INTEGER array, dimension (N)
+* Details of the interchanges and the block structure of D, as
+* determined by DSYTRF. If IPIV(k) > 0, then rows and columns
+* k and IPIV(k) were interchanged, and D(k,k) is a 1-by-1
+* diagonal block. If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0,
+* then rows and columns k-1 and -IPIV(k) were interchanged and
+* D(k-1:k,k-1:k) is a 2-by-2 diagonal block. If UPLO = 'L' and
+* IPIV(k) = IPIV(k+1) < 0, then rows and columns k+1 and
+* -IPIV(k) were interchanged and D(k:k+1,k:k+1) is a 2-by-2
+* diagonal block.
+*
+* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
+* On entry, the N-by-NRHS right hand side matrix B.
+* On exit, if INFO = 0, the N-by-NRHS solution matrix X.
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. LDB >= max(1,N).
+*
+* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
+* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+* LWORK (input) INTEGER
+* The length of WORK. LWORK >= 1, and for best performance
+* LWORK >= max(1,N*NB), where NB is the optimal blocksize for
+* DSYTRF.
+*
+* If LWORK = -1, then a workspace query is assumed; the routine
+* only calculates the optimal size of the WORK array, returns
+* this value as the first entry of the WORK array, and no error
+* message related to LWORK is issued by XERBLA.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* > 0: if INFO = i, D(i,i) is exactly zero. The factorization
+* has been completed, but the block diagonal matrix D is
+* exactly singular, so the solution could not be computed.
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ LOGICAL LQUERY
+ INTEGER LWKOPT, NB
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ILAENV
+ EXTERNAL LSAME, ILAENV
+* ..
+* .. External Subroutines ..
+ EXTERNAL DSYTRF, DSYTRS, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ LQUERY = ( LWORK.EQ.-1 )
+ IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( NRHS.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -5
+ ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -8
+ ELSE IF( LWORK.LT.1 .AND. .NOT.LQUERY ) THEN
+ INFO = -10
+ END IF
+*
+ IF( INFO.EQ.0 ) THEN
+ IF( N.EQ.0 ) THEN
+ LWKOPT = 1
+ ELSE
+ NB = ILAENV( 1, 'DSYTRF', UPLO, N, -1, -1, -1 )
+ LWKOPT = N*NB
+ END IF
+ WORK( 1 ) = LWKOPT
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DSYSV ', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Compute the factorization A = U*D*U' or A = L*D*L'.
+*
+ CALL DSYTRF( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO )
+ IF( INFO.EQ.0 ) THEN
+*
+* Solve the system A*X = B, overwriting B with X.
+*
+ CALL DSYTRS( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO )
+*
+ END IF
+*
+ WORK( 1 ) = LWKOPT
+*
+ RETURN
+*
+* End of DSYSV
+*
+ END
+ SUBROUTINE DSYSVX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, B,
+ $ LDB, X, LDX, RCOND, FERR, BERR, WORK, LWORK,
+ $ IWORK, INFO )
+*
+* -- LAPACK driver routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER FACT, UPLO
+ INTEGER INFO, LDA, LDAF, LDB, LDX, LWORK, N, NRHS
+ DOUBLE PRECISION RCOND
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * ), IWORK( * )
+ DOUBLE PRECISION A( LDA, * ), AF( LDAF, * ), B( LDB, * ),
+ $ BERR( * ), FERR( * ), WORK( * ), X( LDX, * )
+* ..
+*
+* Purpose
+* =======
+*
+* DSYSVX uses the diagonal pivoting factorization to compute the
+* solution to a real system of linear equations A * X = B,
+* where A is an N-by-N symmetric matrix and X and B are N-by-NRHS
+* matrices.
+*
+* Error bounds on the solution and a condition estimate are also
+* provided.
+*
+* Description
+* ===========
+*
+* The following steps are performed:
+*
+* 1. If FACT = 'N', the diagonal pivoting method is used to factor A.
+* The form of the factorization is
+* A = U * D * U**T, if UPLO = 'U', or
+* A = L * D * L**T, if UPLO = 'L',
+* where U (or L) is a product of permutation and unit upper (lower)
+* triangular matrices, and D is symmetric and block diagonal with
+* 1-by-1 and 2-by-2 diagonal blocks.
+*
+* 2. If some D(i,i)=0, so that D is exactly singular, then the routine
+* returns with INFO = i. Otherwise, the factored form of A is used
+* to estimate the condition number of the matrix A. If the
+* reciprocal of the condition number is less than machine precision,
+* INFO = N+1 is returned as a warning, but the routine still goes on
+* to solve for X and compute error bounds as described below.
+*
+* 3. The system of equations is solved for X using the factored form
+* of A.
+*
+* 4. Iterative refinement is applied to improve the computed solution
+* matrix and calculate error bounds and backward error estimates
+* for it.
+*
+* Arguments
+* =========
+*
+* FACT (input) CHARACTER*1
+* Specifies whether or not the factored form of A has been
+* supplied on entry.
+* = 'F': On entry, AF and IPIV contain the factored form of
+* A. AF and IPIV will not be modified.
+* = 'N': The matrix A will be copied to AF and factored.
+*
+* UPLO (input) CHARACTER*1
+* = 'U': Upper triangle of A is stored;
+* = 'L': Lower triangle of A is stored.
+*
+* N (input) INTEGER
+* The number of linear equations, i.e., the order of the
+* matrix A. N >= 0.
+*
+* NRHS (input) INTEGER
+* The number of right hand sides, i.e., the number of columns
+* of the matrices B and X. NRHS >= 0.
+*
+* A (input) DOUBLE PRECISION array, dimension (LDA,N)
+* The symmetric matrix A. If UPLO = 'U', the leading N-by-N
+* upper triangular part of A contains the upper triangular part
+* of the matrix A, and the strictly lower triangular part of A
+* is not referenced. If UPLO = 'L', the leading N-by-N lower
+* triangular part of A contains the lower triangular part of
+* the matrix A, and the strictly upper triangular part of A is
+* not referenced.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,N).
+*
+* AF (input or output) DOUBLE PRECISION array, dimension (LDAF,N)
+* If FACT = 'F', then AF is an input argument and on entry
+* contains the block diagonal matrix D and the multipliers used
+* to obtain the factor U or L from the factorization
+* A = U*D*U**T or A = L*D*L**T as computed by DSYTRF.
+*
+* If FACT = 'N', then AF is an output argument and on exit
+* returns the block diagonal matrix D and the multipliers used
+* to obtain the factor U or L from the factorization
+* A = U*D*U**T or A = L*D*L**T.
+*
+* LDAF (input) INTEGER
+* The leading dimension of the array AF. LDAF >= max(1,N).
+*
+* IPIV (input or output) INTEGER array, dimension (N)
+* If FACT = 'F', then IPIV is an input argument and on entry
+* contains details of the interchanges and the block structure
+* of D, as determined by DSYTRF.
+* If IPIV(k) > 0, then rows and columns k and IPIV(k) were
+* interchanged and D(k,k) is a 1-by-1 diagonal block.
+* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and
+* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)
+* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =
+* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were
+* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
+*
+* If FACT = 'N', then IPIV is an output argument and on exit
+* contains details of the interchanges and the block structure
+* of D, as determined by DSYTRF.
+*
+* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS)
+* The N-by-NRHS right hand side matrix B.
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. LDB >= max(1,N).
+*
+* X (output) DOUBLE PRECISION array, dimension (LDX,NRHS)
+* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X.
+*
+* LDX (input) INTEGER
+* The leading dimension of the array X. LDX >= max(1,N).
+*
+* RCOND (output) DOUBLE PRECISION
+* The estimate of the reciprocal condition number of the matrix
+* A. If RCOND is less than the machine precision (in
+* particular, if RCOND = 0), the matrix is singular to working
+* precision. This condition is indicated by a return code of
+* INFO > 0.
+*
+* FERR (output) DOUBLE PRECISION array, dimension (NRHS)
+* The estimated forward error bound for each solution vector
+* X(j) (the j-th column of the solution matrix X).
+* If XTRUE is the true solution corresponding to X(j), FERR(j)
+* is an estimated upper bound for the magnitude of the largest
+* element in (X(j) - XTRUE) divided by the magnitude of the
+* largest element in X(j). The estimate is as reliable as
+* the estimate for RCOND, and is almost always a slight
+* overestimate of the true error.
+*
+* BERR (output) DOUBLE PRECISION array, dimension (NRHS)
+* The componentwise relative backward error of each solution
+* vector X(j) (i.e., the smallest relative change in
+* any element of A or B that makes X(j) an exact solution).
+*
+* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
+* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+* LWORK (input) INTEGER
+* The length of WORK. LWORK >= max(1,3*N), and for best
+* performance, when FACT = 'N', LWORK >= max(1,3*N,N*NB), where
+* NB is the optimal blocksize for DSYTRF.
+*
+* If LWORK = -1, then a workspace query is assumed; the routine
+* only calculates the optimal size of the WORK array, returns
+* this value as the first entry of the WORK array, and no error
+* message related to LWORK is issued by XERBLA.
+*
+* IWORK (workspace) INTEGER array, dimension (N)
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* > 0: if INFO = i, and i is
+* <= N: D(i,i) is exactly zero. The factorization
+* has been completed but the factor D is exactly
+* singular, so the solution and error bounds could
+* not be computed. RCOND = 0 is returned.
+* = N+1: D is nonsingular, but RCOND is less than machine
+* precision, meaning that the matrix is singular
+* to working precision. Nevertheless, the
+* solution and error bounds are computed because
+* there are a number of situations where the
+* computed solution can be more accurate than the
+* value of RCOND would suggest.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO
+ PARAMETER ( ZERO = 0.0D+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL LQUERY, NOFACT
+ INTEGER LWKOPT, NB
+ DOUBLE PRECISION ANORM
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ILAENV
+ DOUBLE PRECISION DLAMCH, DLANSY
+ EXTERNAL LSAME, ILAENV, DLAMCH, DLANSY
+* ..
+* .. External Subroutines ..
+ EXTERNAL DLACPY, DSYCON, DSYRFS, DSYTRF, DSYTRS, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ NOFACT = LSAME( FACT, 'N' )
+ LQUERY = ( LWORK.EQ.-1 )
+ IF( .NOT.NOFACT .AND. .NOT.LSAME( FACT, 'F' ) ) THEN
+ INFO = -1
+ ELSE IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) )
+ $ THEN
+ INFO = -2
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( NRHS.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -6
+ ELSE IF( LDAF.LT.MAX( 1, N ) ) THEN
+ INFO = -8
+ ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -11
+ ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
+ INFO = -13
+ ELSE IF( LWORK.LT.MAX( 1, 3*N ) .AND. .NOT.LQUERY ) THEN
+ INFO = -18
+ END IF
+*
+ IF( INFO.EQ.0 ) THEN
+ LWKOPT = MAX( 1, 3*N )
+ IF( NOFACT ) THEN
+ NB = ILAENV( 1, 'DSYTRF', UPLO, N, -1, -1, -1 )
+ LWKOPT = MAX( LWKOPT, N*NB )
+ END IF
+ WORK( 1 ) = LWKOPT
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DSYSVX', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+ IF( NOFACT ) THEN
+*
+* Compute the factorization A = U*D*U' or A = L*D*L'.
+*
+ CALL DLACPY( UPLO, N, N, A, LDA, AF, LDAF )
+ CALL DSYTRF( UPLO, N, AF, LDAF, IPIV, WORK, LWORK, INFO )
+*
+* Return if INFO is non-zero.
+*
+ IF( INFO.GT.0 )THEN
+ RCOND = ZERO
+ RETURN
+ END IF
+ END IF
+*
+* Compute the norm of the matrix A.
+*
+ ANORM = DLANSY( 'I', UPLO, N, A, LDA, WORK )
+*
+* Compute the reciprocal of the condition number of A.
+*
+ CALL DSYCON( UPLO, N, AF, LDAF, IPIV, ANORM, RCOND, WORK, IWORK,
+ $ INFO )
+*
+* Compute the solution vectors X.
+*
+ CALL DLACPY( 'Full', N, NRHS, B, LDB, X, LDX )
+ CALL DSYTRS( UPLO, N, NRHS, AF, LDAF, IPIV, X, LDX, INFO )
+*
+* Use iterative refinement to improve the computed solutions and
+* compute error bounds and backward error estimates for them.
+*
+ CALL DSYRFS( UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, X,
+ $ LDX, FERR, BERR, WORK, IWORK, INFO )
+*
+* Set INFO = N+1 if the matrix is singular to working precision.
+*
+ IF( RCOND.LT.DLAMCH( 'Epsilon' ) )
+ $ INFO = N + 1
+*
+ WORK( 1 ) = LWKOPT
+*
+ RETURN
+*
+* End of DSYSVX
+*
+ END
+ SUBROUTINE DSYTD2( UPLO, N, A, LDA, D, E, TAU, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, LDA, N
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION A( LDA, * ), D( * ), E( * ), TAU( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DSYTD2 reduces a real symmetric matrix A to symmetric tridiagonal
+* form T by an orthogonal similarity transformation: Q' * A * Q = T.
+*
+* Arguments
+* =========
+*
+* UPLO (input) CHARACTER*1
+* Specifies whether the upper or lower triangular part of the
+* symmetric matrix A is stored:
+* = 'U': Upper triangular
+* = 'L': Lower triangular
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+* On entry, the symmetric matrix A. If UPLO = 'U', the leading
+* n-by-n upper triangular part of A contains the upper
+* triangular part of the matrix A, and the strictly lower
+* triangular part of A is not referenced. If UPLO = 'L', the
+* leading n-by-n lower triangular part of A contains the lower
+* triangular part of the matrix A, and the strictly upper
+* triangular part of A is not referenced.
+* On exit, if UPLO = 'U', the diagonal and first superdiagonal
+* of A are overwritten by the corresponding elements of the
+* tridiagonal matrix T, and the elements above the first
+* superdiagonal, with the array TAU, represent the orthogonal
+* matrix Q as a product of elementary reflectors; if UPLO
+* = 'L', the diagonal and first subdiagonal of A are over-
+* written by the corresponding elements of the tridiagonal
+* matrix T, and the elements below the first subdiagonal, with
+* the array TAU, represent the orthogonal matrix Q as a product
+* of elementary reflectors. See Further Details.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,N).
+*
+* D (output) DOUBLE PRECISION array, dimension (N)
+* The diagonal elements of the tridiagonal matrix T:
+* D(i) = A(i,i).
+*
+* E (output) DOUBLE PRECISION array, dimension (N-1)
+* The off-diagonal elements of the tridiagonal matrix T:
+* E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'.
+*
+* TAU (output) DOUBLE PRECISION array, dimension (N-1)
+* The scalar factors of the elementary reflectors (see Further
+* Details).
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value.
+*
+* Further Details
+* ===============
+*
+* If UPLO = 'U', the matrix Q is represented as a product of elementary
+* reflectors
+*
+* Q = H(n-1) . . . H(2) H(1).
+*
+* Each H(i) has the form
+*
+* H(i) = I - tau * v * v'
+*
+* where tau is a real scalar, and v is a real vector with
+* v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in
+* A(1:i-1,i+1), and tau in TAU(i).
+*
+* If UPLO = 'L', the matrix Q is represented as a product of elementary
+* reflectors
+*
+* Q = H(1) H(2) . . . H(n-1).
+*
+* Each H(i) has the form
+*
+* H(i) = I - tau * v * v'
+*
+* where tau is a real scalar, and v is a real vector with
+* v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in A(i+2:n,i),
+* and tau in TAU(i).
+*
+* The contents of A on exit are illustrated by the following examples
+* with n = 5:
+*
+* if UPLO = 'U': if UPLO = 'L':
+*
+* ( d e v2 v3 v4 ) ( d )
+* ( d e v3 v4 ) ( e d )
+* ( d e v4 ) ( v1 e d )
+* ( d e ) ( v1 v2 e d )
+* ( d ) ( v1 v2 v3 e d )
+*
+* where d and e denote diagonal and off-diagonal elements of T, and vi
+* denotes an element of the vector defining H(i).
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE, ZERO, HALF
+ PARAMETER ( ONE = 1.0D0, ZERO = 0.0D0,
+ $ HALF = 1.0D0 / 2.0D0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL UPPER
+ INTEGER I
+ DOUBLE PRECISION ALPHA, TAUI
+* ..
+* .. External Subroutines ..
+ EXTERNAL DAXPY, DLARFG, DSYMV, DSYR2, XERBLA
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ DOUBLE PRECISION DDOT
+ EXTERNAL LSAME, DDOT
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -4
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DSYTD2', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.LE.0 )
+ $ RETURN
+*
+ IF( UPPER ) THEN
+*
+* Reduce the upper triangle of A
+*
+ DO 10 I = N - 1, 1, -1
+*
+* Generate elementary reflector H(i) = I - tau * v * v'
+* to annihilate A(1:i-1,i+1)
+*
+ CALL DLARFG( I, A( I, I+1 ), A( 1, I+1 ), 1, TAUI )
+ E( I ) = A( I, I+1 )
+*
+ IF( TAUI.NE.ZERO ) THEN
+*
+* Apply H(i) from both sides to A(1:i,1:i)
+*
+ A( I, I+1 ) = ONE
+*
+* Compute x := tau * A * v storing x in TAU(1:i)
+*
+ CALL DSYMV( UPLO, I, TAUI, A, LDA, A( 1, I+1 ), 1, ZERO,
+ $ TAU, 1 )
+*
+* Compute w := x - 1/2 * tau * (x'*v) * v
+*
+ ALPHA = -HALF*TAUI*DDOT( I, TAU, 1, A( 1, I+1 ), 1 )
+ CALL DAXPY( I, ALPHA, A( 1, I+1 ), 1, TAU, 1 )
+*
+* Apply the transformation as a rank-2 update:
+* A := A - v * w' - w * v'
+*
+ CALL DSYR2( UPLO, I, -ONE, A( 1, I+1 ), 1, TAU, 1, A,
+ $ LDA )
+*
+ A( I, I+1 ) = E( I )
+ END IF
+ D( I+1 ) = A( I+1, I+1 )
+ TAU( I ) = TAUI
+ 10 CONTINUE
+ D( 1 ) = A( 1, 1 )
+ ELSE
+*
+* Reduce the lower triangle of A
+*
+ DO 20 I = 1, N - 1
+*
+* Generate elementary reflector H(i) = I - tau * v * v'
+* to annihilate A(i+2:n,i)
+*
+ CALL DLARFG( N-I, A( I+1, I ), A( MIN( I+2, N ), I ), 1,
+ $ TAUI )
+ E( I ) = A( I+1, I )
+*
+ IF( TAUI.NE.ZERO ) THEN
+*
+* Apply H(i) from both sides to A(i+1:n,i+1:n)
+*
+ A( I+1, I ) = ONE
+*
+* Compute x := tau * A * v storing y in TAU(i:n-1)
+*
+ CALL DSYMV( UPLO, N-I, TAUI, A( I+1, I+1 ), LDA,
+ $ A( I+1, I ), 1, ZERO, TAU( I ), 1 )
+*
+* Compute w := x - 1/2 * tau * (x'*v) * v
+*
+ ALPHA = -HALF*TAUI*DDOT( N-I, TAU( I ), 1, A( I+1, I ),
+ $ 1 )
+ CALL DAXPY( N-I, ALPHA, A( I+1, I ), 1, TAU( I ), 1 )
+*
+* Apply the transformation as a rank-2 update:
+* A := A - v * w' - w * v'
+*
+ CALL DSYR2( UPLO, N-I, -ONE, A( I+1, I ), 1, TAU( I ), 1,
+ $ A( I+1, I+1 ), LDA )
+*
+ A( I+1, I ) = E( I )
+ END IF
+ D( I ) = A( I, I )
+ TAU( I ) = TAUI
+ 20 CONTINUE
+ D( N ) = A( N, N )
+ END IF
+*
+ RETURN
+*
+* End of DSYTD2
+*
+ END
+ SUBROUTINE DSYTF2( UPLO, N, A, LDA, IPIV, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, LDA, N
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ DOUBLE PRECISION A( LDA, * )
+* ..
+*
+* Purpose
+* =======
+*
+* DSYTF2 computes the factorization of a real symmetric matrix A using
+* the Bunch-Kaufman diagonal pivoting method:
+*
+* A = U*D*U' or A = L*D*L'
+*
+* where U (or L) is a product of permutation and unit upper (lower)
+* triangular matrices, U' is the transpose of U, and D is symmetric and
+* block diagonal with 1-by-1 and 2-by-2 diagonal blocks.
+*
+* This is the unblocked version of the algorithm, calling Level 2 BLAS.
+*
+* Arguments
+* =========
+*
+* UPLO (input) CHARACTER*1
+* Specifies whether the upper or lower triangular part of the
+* symmetric matrix A is stored:
+* = 'U': Upper triangular
+* = 'L': Lower triangular
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+* On entry, the symmetric matrix A. If UPLO = 'U', the leading
+* n-by-n upper triangular part of A contains the upper
+* triangular part of the matrix A, and the strictly lower
+* triangular part of A is not referenced. If UPLO = 'L', the
+* leading n-by-n lower triangular part of A contains the lower
+* triangular part of the matrix A, and the strictly upper
+* triangular part of A is not referenced.
+*
+* On exit, the block diagonal matrix D and the multipliers used
+* to obtain the factor U or L (see below for further details).
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,N).
+*
+* IPIV (output) INTEGER array, dimension (N)
+* Details of the interchanges and the block structure of D.
+* If IPIV(k) > 0, then rows and columns k and IPIV(k) were
+* interchanged and D(k,k) is a 1-by-1 diagonal block.
+* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and
+* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)
+* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =
+* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were
+* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -k, the k-th argument had an illegal value
+* > 0: if INFO = k, D(k,k) is exactly zero. The factorization
+* has been completed, but the block diagonal matrix D is
+* exactly singular, and division by zero will occur if it
+* is used to solve a system of equations.
+*
+* Further Details
+* ===============
+*
+* 09-29-06 - patch from
+* Bobby Cheng, MathWorks
+*
+* Replace l.204 and l.372
+* IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN
+* by
+* IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) .OR. DISNAN(ABSAKK) ) THEN
+*
+* 01-01-96 - Based on modifications by
+* J. Lewis, Boeing Computer Services Company
+* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA
+* 1-96 - Based on modifications by J. Lewis, Boeing Computer Services
+* Company
+*
+* If UPLO = 'U', then A = U*D*U', where
+* U = P(n)*U(n)* ... *P(k)U(k)* ...,
+* i.e., U is a product of terms P(k)*U(k), where k decreases from n to
+* 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1
+* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as
+* defined by IPIV(k), and U(k) is a unit upper triangular matrix, such
+* that if the diagonal block D(k) is of order s (s = 1 or 2), then
+*
+* ( I v 0 ) k-s
+* U(k) = ( 0 I 0 ) s
+* ( 0 0 I ) n-k
+* k-s s n-k
+*
+* If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k).
+* If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k),
+* and A(k,k), and v overwrites A(1:k-2,k-1:k).
+*
+* If UPLO = 'L', then A = L*D*L', where
+* L = P(1)*L(1)* ... *P(k)*L(k)* ...,
+* i.e., L is a product of terms P(k)*L(k), where k increases from 1 to
+* n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1
+* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as
+* defined by IPIV(k), and L(k) is a unit lower triangular matrix, such
+* that if the diagonal block D(k) is of order s (s = 1 or 2), then
+*
+* ( I 0 0 ) k-1
+* L(k) = ( 0 I 0 ) s
+* ( 0 v I ) n-k-s+1
+* k-1 s n-k-s+1
+*
+* If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k).
+* If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k),
+* and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1).
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+ DOUBLE PRECISION EIGHT, SEVTEN
+ PARAMETER ( EIGHT = 8.0D+0, SEVTEN = 17.0D+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL UPPER
+ INTEGER I, IMAX, J, JMAX, K, KK, KP, KSTEP
+ DOUBLE PRECISION ABSAKK, ALPHA, COLMAX, D11, D12, D21, D22, R1,
+ $ ROWMAX, T, WK, WKM1, WKP1
+* ..
+* .. External Functions ..
+ LOGICAL LSAME, DISNAN
+ INTEGER IDAMAX
+ EXTERNAL LSAME, IDAMAX, DISNAN
+* ..
+* .. External Subroutines ..
+ EXTERNAL DSCAL, DSWAP, DSYR, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, SQRT
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -4
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DSYTF2', -INFO )
+ RETURN
+ END IF
+*
+* Initialize ALPHA for use in choosing pivot block size.
+*
+ ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT
+*
+ IF( UPPER ) THEN
+*
+* Factorize A as U*D*U' using the upper triangle of A
+*
+* K is the main loop index, decreasing from N to 1 in steps of
+* 1 or 2
+*
+ K = N
+ 10 CONTINUE
+*
+* If K < 1, exit from loop
+*
+ IF( K.LT.1 )
+ $ GO TO 70
+ KSTEP = 1
+*
+* Determine rows and columns to be interchanged and whether
+* a 1-by-1 or 2-by-2 pivot block will be used
+*
+ ABSAKK = ABS( A( K, K ) )
+*
+* IMAX is the row-index of the largest off-diagonal element in
+* column K, and COLMAX is its absolute value
+*
+ IF( K.GT.1 ) THEN
+ IMAX = IDAMAX( K-1, A( 1, K ), 1 )
+ COLMAX = ABS( A( IMAX, K ) )
+ ELSE
+ COLMAX = ZERO
+ END IF
+*
+ IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) .OR. DISNAN(ABSAKK) ) THEN
+*
+* Column K is zero or contains a NaN: set INFO and continue
+*
+ IF( INFO.EQ.0 )
+ $ INFO = K
+ KP = K
+ ELSE
+ IF( ABSAKK.GE.ALPHA*COLMAX ) THEN
+*
+* no interchange, use 1-by-1 pivot block
+*
+ KP = K
+ ELSE
+*
+* JMAX is the column-index of the largest off-diagonal
+* element in row IMAX, and ROWMAX is its absolute value
+*
+ JMAX = IMAX + IDAMAX( K-IMAX, A( IMAX, IMAX+1 ), LDA )
+ ROWMAX = ABS( A( IMAX, JMAX ) )
+ IF( IMAX.GT.1 ) THEN
+ JMAX = IDAMAX( IMAX-1, A( 1, IMAX ), 1 )
+ ROWMAX = MAX( ROWMAX, ABS( A( JMAX, IMAX ) ) )
+ END IF
+*
+ IF( ABSAKK.GE.ALPHA*COLMAX*( COLMAX / ROWMAX ) ) THEN
+*
+* no interchange, use 1-by-1 pivot block
+*
+ KP = K
+ ELSE IF( ABS( A( IMAX, IMAX ) ).GE.ALPHA*ROWMAX ) THEN
+*
+* interchange rows and columns K and IMAX, use 1-by-1
+* pivot block
+*
+ KP = IMAX
+ ELSE
+*
+* interchange rows and columns K-1 and IMAX, use 2-by-2
+* pivot block
+*
+ KP = IMAX
+ KSTEP = 2
+ END IF
+ END IF
+*
+ KK = K - KSTEP + 1
+ IF( KP.NE.KK ) THEN
+*
+* Interchange rows and columns KK and KP in the leading
+* submatrix A(1:k,1:k)
+*
+ CALL DSWAP( KP-1, A( 1, KK ), 1, A( 1, KP ), 1 )
+ CALL DSWAP( KK-KP-1, A( KP+1, KK ), 1, A( KP, KP+1 ),
+ $ LDA )
+ T = A( KK, KK )
+ A( KK, KK ) = A( KP, KP )
+ A( KP, KP ) = T
+ IF( KSTEP.EQ.2 ) THEN
+ T = A( K-1, K )
+ A( K-1, K ) = A( KP, K )
+ A( KP, K ) = T
+ END IF
+ END IF
+*
+* Update the leading submatrix
+*
+ IF( KSTEP.EQ.1 ) THEN
+*
+* 1-by-1 pivot block D(k): column k now holds
+*
+* W(k) = U(k)*D(k)
+*
+* where U(k) is the k-th column of U
+*
+* Perform a rank-1 update of A(1:k-1,1:k-1) as
+*
+* A := A - U(k)*D(k)*U(k)' = A - W(k)*1/D(k)*W(k)'
+*
+ R1 = ONE / A( K, K )
+ CALL DSYR( UPLO, K-1, -R1, A( 1, K ), 1, A, LDA )
+*
+* Store U(k) in column k
+*
+ CALL DSCAL( K-1, R1, A( 1, K ), 1 )
+ ELSE
+*
+* 2-by-2 pivot block D(k): columns k and k-1 now hold
+*
+* ( W(k-1) W(k) ) = ( U(k-1) U(k) )*D(k)
+*
+* where U(k) and U(k-1) are the k-th and (k-1)-th columns
+* of U
+*
+* Perform a rank-2 update of A(1:k-2,1:k-2) as
+*
+* A := A - ( U(k-1) U(k) )*D(k)*( U(k-1) U(k) )'
+* = A - ( W(k-1) W(k) )*inv(D(k))*( W(k-1) W(k) )'
+*
+ IF( K.GT.2 ) THEN
+*
+ D12 = A( K-1, K )
+ D22 = A( K-1, K-1 ) / D12
+ D11 = A( K, K ) / D12
+ T = ONE / ( D11*D22-ONE )
+ D12 = T / D12
+*
+ DO 30 J = K - 2, 1, -1
+ WKM1 = D12*( D11*A( J, K-1 )-A( J, K ) )
+ WK = D12*( D22*A( J, K )-A( J, K-1 ) )
+ DO 20 I = J, 1, -1
+ A( I, J ) = A( I, J ) - A( I, K )*WK -
+ $ A( I, K-1 )*WKM1
+ 20 CONTINUE
+ A( J, K ) = WK
+ A( J, K-1 ) = WKM1
+ 30 CONTINUE
+*
+ END IF
+*
+ END IF
+ END IF
+*
+* Store details of the interchanges in IPIV
+*
+ IF( KSTEP.EQ.1 ) THEN
+ IPIV( K ) = KP
+ ELSE
+ IPIV( K ) = -KP
+ IPIV( K-1 ) = -KP
+ END IF
+*
+* Decrease K and return to the start of the main loop
+*
+ K = K - KSTEP
+ GO TO 10
+*
+ ELSE
+*
+* Factorize A as L*D*L' using the lower triangle of A
+*
+* K is the main loop index, increasing from 1 to N in steps of
+* 1 or 2
+*
+ K = 1
+ 40 CONTINUE
+*
+* If K > N, exit from loop
+*
+ IF( K.GT.N )
+ $ GO TO 70
+ KSTEP = 1
+*
+* Determine rows and columns to be interchanged and whether
+* a 1-by-1 or 2-by-2 pivot block will be used
+*
+ ABSAKK = ABS( A( K, K ) )
+*
+* IMAX is the row-index of the largest off-diagonal element in
+* column K, and COLMAX is its absolute value
+*
+ IF( K.LT.N ) THEN
+ IMAX = K + IDAMAX( N-K, A( K+1, K ), 1 )
+ COLMAX = ABS( A( IMAX, K ) )
+ ELSE
+ COLMAX = ZERO
+ END IF
+*
+ IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) .OR. DISNAN(ABSAKK) ) THEN
+*
+* Column K is zero or contains a NaN: set INFO and continue
+*
+ IF( INFO.EQ.0 )
+ $ INFO = K
+ KP = K
+ ELSE
+ IF( ABSAKK.GE.ALPHA*COLMAX ) THEN
+*
+* no interchange, use 1-by-1 pivot block
+*
+ KP = K
+ ELSE
+*
+* JMAX is the column-index of the largest off-diagonal
+* element in row IMAX, and ROWMAX is its absolute value
+*
+ JMAX = K - 1 + IDAMAX( IMAX-K, A( IMAX, K ), LDA )
+ ROWMAX = ABS( A( IMAX, JMAX ) )
+ IF( IMAX.LT.N ) THEN
+ JMAX = IMAX + IDAMAX( N-IMAX, A( IMAX+1, IMAX ), 1 )
+ ROWMAX = MAX( ROWMAX, ABS( A( JMAX, IMAX ) ) )
+ END IF
+*
+ IF( ABSAKK.GE.ALPHA*COLMAX*( COLMAX / ROWMAX ) ) THEN
+*
+* no interchange, use 1-by-1 pivot block
+*
+ KP = K
+ ELSE IF( ABS( A( IMAX, IMAX ) ).GE.ALPHA*ROWMAX ) THEN
+*
+* interchange rows and columns K and IMAX, use 1-by-1
+* pivot block
+*
+ KP = IMAX
+ ELSE
+*
+* interchange rows and columns K+1 and IMAX, use 2-by-2
+* pivot block
+*
+ KP = IMAX
+ KSTEP = 2
+ END IF
+ END IF
+*
+ KK = K + KSTEP - 1
+ IF( KP.NE.KK ) THEN
+*
+* Interchange rows and columns KK and KP in the trailing
+* submatrix A(k:n,k:n)
+*
+ IF( KP.LT.N )
+ $ CALL DSWAP( N-KP, A( KP+1, KK ), 1, A( KP+1, KP ), 1 )
+ CALL DSWAP( KP-KK-1, A( KK+1, KK ), 1, A( KP, KK+1 ),
+ $ LDA )
+ T = A( KK, KK )
+ A( KK, KK ) = A( KP, KP )
+ A( KP, KP ) = T
+ IF( KSTEP.EQ.2 ) THEN
+ T = A( K+1, K )
+ A( K+1, K ) = A( KP, K )
+ A( KP, K ) = T
+ END IF
+ END IF
+*
+* Update the trailing submatrix
+*
+ IF( KSTEP.EQ.1 ) THEN
+*
+* 1-by-1 pivot block D(k): column k now holds
+*
+* W(k) = L(k)*D(k)
+*
+* where L(k) is the k-th column of L
+*
+ IF( K.LT.N ) THEN
+*
+* Perform a rank-1 update of A(k+1:n,k+1:n) as
+*
+* A := A - L(k)*D(k)*L(k)' = A - W(k)*(1/D(k))*W(k)'
+*
+ D11 = ONE / A( K, K )
+ CALL DSYR( UPLO, N-K, -D11, A( K+1, K ), 1,
+ $ A( K+1, K+1 ), LDA )
+*
+* Store L(k) in column K
+*
+ CALL DSCAL( N-K, D11, A( K+1, K ), 1 )
+ END IF
+ ELSE
+*
+* 2-by-2 pivot block D(k)
+*
+ IF( K.LT.N-1 ) THEN
+*
+* Perform a rank-2 update of A(k+2:n,k+2:n) as
+*
+* A := A - ( (A(k) A(k+1))*D(k)**(-1) ) * (A(k) A(k+1))'
+*
+* where L(k) and L(k+1) are the k-th and (k+1)-th
+* columns of L
+*
+ D21 = A( K+1, K )
+ D11 = A( K+1, K+1 ) / D21
+ D22 = A( K, K ) / D21
+ T = ONE / ( D11*D22-ONE )
+ D21 = T / D21
+*
+ DO 60 J = K + 2, N
+*
+ WK = D21*( D11*A( J, K )-A( J, K+1 ) )
+ WKP1 = D21*( D22*A( J, K+1 )-A( J, K ) )
+*
+ DO 50 I = J, N
+ A( I, J ) = A( I, J ) - A( I, K )*WK -
+ $ A( I, K+1 )*WKP1
+ 50 CONTINUE
+*
+ A( J, K ) = WK
+ A( J, K+1 ) = WKP1
+*
+ 60 CONTINUE
+ END IF
+ END IF
+ END IF
+*
+* Store details of the interchanges in IPIV
+*
+ IF( KSTEP.EQ.1 ) THEN
+ IPIV( K ) = KP
+ ELSE
+ IPIV( K ) = -KP
+ IPIV( K+1 ) = -KP
+ END IF
+*
+* Increase K and return to the start of the main loop
+*
+ K = K + KSTEP
+ GO TO 40
+*
+ END IF
+*
+ 70 CONTINUE
+*
+ RETURN
+*
+* End of DSYTF2
+*
+ END
+ SUBROUTINE DSYTRD( UPLO, N, A, LDA, D, E, TAU, WORK, LWORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, LDA, LWORK, N
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION A( LDA, * ), D( * ), E( * ), TAU( * ),
+ $ WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DSYTRD reduces a real symmetric matrix A to real symmetric
+* tridiagonal form T by an orthogonal similarity transformation:
+* Q**T * A * Q = T.
+*
+* Arguments
+* =========
+*
+* UPLO (input) CHARACTER*1
+* = 'U': Upper triangle of A is stored;
+* = 'L': Lower triangle of A is stored.
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+* On entry, the symmetric matrix A. If UPLO = 'U', the leading
+* N-by-N upper triangular part of A contains the upper
+* triangular part of the matrix A, and the strictly lower
+* triangular part of A is not referenced. If UPLO = 'L', the
+* leading N-by-N lower triangular part of A contains the lower
+* triangular part of the matrix A, and the strictly upper
+* triangular part of A is not referenced.
+* On exit, if UPLO = 'U', the diagonal and first superdiagonal
+* of A are overwritten by the corresponding elements of the
+* tridiagonal matrix T, and the elements above the first
+* superdiagonal, with the array TAU, represent the orthogonal
+* matrix Q as a product of elementary reflectors; if UPLO
+* = 'L', the diagonal and first subdiagonal of A are over-
+* written by the corresponding elements of the tridiagonal
+* matrix T, and the elements below the first subdiagonal, with
+* the array TAU, represent the orthogonal matrix Q as a product
+* of elementary reflectors. See Further Details.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,N).
+*
+* D (output) DOUBLE PRECISION array, dimension (N)
+* The diagonal elements of the tridiagonal matrix T:
+* D(i) = A(i,i).
+*
+* E (output) DOUBLE PRECISION array, dimension (N-1)
+* The off-diagonal elements of the tridiagonal matrix T:
+* E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'.
+*
+* TAU (output) DOUBLE PRECISION array, dimension (N-1)
+* The scalar factors of the elementary reflectors (see Further
+* Details).
+*
+* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
+* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+* LWORK (input) INTEGER
+* The dimension of the array WORK. LWORK >= 1.
+* For optimum performance LWORK >= N*NB, where NB is the
+* optimal blocksize.
+*
+* If LWORK = -1, then a workspace query is assumed; the routine
+* only calculates the optimal size of the WORK array, returns
+* this value as the first entry of the WORK array, and no error
+* message related to LWORK is issued by XERBLA.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+*
+* Further Details
+* ===============
+*
+* If UPLO = 'U', the matrix Q is represented as a product of elementary
+* reflectors
+*
+* Q = H(n-1) . . . H(2) H(1).
+*
+* Each H(i) has the form
+*
+* H(i) = I - tau * v * v'
+*
+* where tau is a real scalar, and v is a real vector with
+* v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in
+* A(1:i-1,i+1), and tau in TAU(i).
+*
+* If UPLO = 'L', the matrix Q is represented as a product of elementary
+* reflectors
+*
+* Q = H(1) H(2) . . . H(n-1).
+*
+* Each H(i) has the form
+*
+* H(i) = I - tau * v * v'
+*
+* where tau is a real scalar, and v is a real vector with
+* v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in A(i+2:n,i),
+* and tau in TAU(i).
+*
+* The contents of A on exit are illustrated by the following examples
+* with n = 5:
+*
+* if UPLO = 'U': if UPLO = 'L':
+*
+* ( d e v2 v3 v4 ) ( d )
+* ( d e v3 v4 ) ( e d )
+* ( d e v4 ) ( v1 e d )
+* ( d e ) ( v1 v2 e d )
+* ( d ) ( v1 v2 v3 e d )
+*
+* where d and e denote diagonal and off-diagonal elements of T, and vi
+* denotes an element of the vector defining H(i).
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE
+ PARAMETER ( ONE = 1.0D+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL LQUERY, UPPER
+ INTEGER I, IINFO, IWS, J, KK, LDWORK, LWKOPT, NB,
+ $ NBMIN, NX
+* ..
+* .. External Subroutines ..
+ EXTERNAL DLATRD, DSYR2K, DSYTD2, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ILAENV
+ EXTERNAL LSAME, ILAENV
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ LQUERY = ( LWORK.EQ.-1 )
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -4
+ ELSE IF( LWORK.LT.1 .AND. .NOT.LQUERY ) THEN
+ INFO = -9
+ END IF
+*
+ IF( INFO.EQ.0 ) THEN
+*
+* Determine the block size.
+*
+ NB = ILAENV( 1, 'DSYTRD', UPLO, N, -1, -1, -1 )
+ LWKOPT = N*NB
+ WORK( 1 ) = LWKOPT
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DSYTRD', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 ) THEN
+ WORK( 1 ) = 1
+ RETURN
+ END IF
+*
+ NX = N
+ IWS = 1
+ IF( NB.GT.1 .AND. NB.LT.N ) THEN
+*
+* Determine when to cross over from blocked to unblocked code
+* (last block is always handled by unblocked code).
+*
+ NX = MAX( NB, ILAENV( 3, 'DSYTRD', UPLO, N, -1, -1, -1 ) )
+ IF( NX.LT.N ) THEN
+*
+* Determine if workspace is large enough for blocked code.
+*
+ LDWORK = N
+ IWS = LDWORK*NB
+ IF( LWORK.LT.IWS ) THEN
+*
+* Not enough workspace to use optimal NB: determine the
+* minimum value of NB, and reduce NB or force use of
+* unblocked code by setting NX = N.
+*
+ NB = MAX( LWORK / LDWORK, 1 )
+ NBMIN = ILAENV( 2, 'DSYTRD', UPLO, N, -1, -1, -1 )
+ IF( NB.LT.NBMIN )
+ $ NX = N
+ END IF
+ ELSE
+ NX = N
+ END IF
+ ELSE
+ NB = 1
+ END IF
+*
+ IF( UPPER ) THEN
+*
+* Reduce the upper triangle of A.
+* Columns 1:kk are handled by the unblocked method.
+*
+ KK = N - ( ( N-NX+NB-1 ) / NB )*NB
+ DO 20 I = N - NB + 1, KK + 1, -NB
+*
+* Reduce columns i:i+nb-1 to tridiagonal form and form the
+* matrix W which is needed to update the unreduced part of
+* the matrix
+*
+ CALL DLATRD( UPLO, I+NB-1, NB, A, LDA, E, TAU, WORK,
+ $ LDWORK )
+*
+* Update the unreduced submatrix A(1:i-1,1:i-1), using an
+* update of the form: A := A - V*W' - W*V'
+*
+ CALL DSYR2K( UPLO, 'No transpose', I-1, NB, -ONE, A( 1, I ),
+ $ LDA, WORK, LDWORK, ONE, A, LDA )
+*
+* Copy superdiagonal elements back into A, and diagonal
+* elements into D
+*
+ DO 10 J = I, I + NB - 1
+ A( J-1, J ) = E( J-1 )
+ D( J ) = A( J, J )
+ 10 CONTINUE
+ 20 CONTINUE
+*
+* Use unblocked code to reduce the last or only block
+*
+ CALL DSYTD2( UPLO, KK, A, LDA, D, E, TAU, IINFO )
+ ELSE
+*
+* Reduce the lower triangle of A
+*
+ DO 40 I = 1, N - NX, NB
+*
+* Reduce columns i:i+nb-1 to tridiagonal form and form the
+* matrix W which is needed to update the unreduced part of
+* the matrix
+*
+ CALL DLATRD( UPLO, N-I+1, NB, A( I, I ), LDA, E( I ),
+ $ TAU( I ), WORK, LDWORK )
+*
+* Update the unreduced submatrix A(i+ib:n,i+ib:n), using
+* an update of the form: A := A - V*W' - W*V'
+*
+ CALL DSYR2K( UPLO, 'No transpose', N-I-NB+1, NB, -ONE,
+ $ A( I+NB, I ), LDA, WORK( NB+1 ), LDWORK, ONE,
+ $ A( I+NB, I+NB ), LDA )
+*
+* Copy subdiagonal elements back into A, and diagonal
+* elements into D
+*
+ DO 30 J = I, I + NB - 1
+ A( J+1, J ) = E( J )
+ D( J ) = A( J, J )
+ 30 CONTINUE
+ 40 CONTINUE
+*
+* Use unblocked code to reduce the last or only block
+*
+ CALL DSYTD2( UPLO, N-I+1, A( I, I ), LDA, D( I ), E( I ),
+ $ TAU( I ), IINFO )
+ END IF
+*
+ WORK( 1 ) = LWKOPT
+ RETURN
+*
+* End of DSYTRD
+*
+ END
+ SUBROUTINE DSYTRF( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, LDA, LWORK, N
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ DOUBLE PRECISION A( LDA, * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DSYTRF computes the factorization of a real symmetric matrix A using
+* the Bunch-Kaufman diagonal pivoting method. The form of the
+* factorization is
+*
+* A = U*D*U**T or A = L*D*L**T
+*
+* where U (or L) is a product of permutation and unit upper (lower)
+* triangular matrices, and D is symmetric and block diagonal with
+* 1-by-1 and 2-by-2 diagonal blocks.
+*
+* This is the blocked version of the algorithm, calling Level 3 BLAS.
+*
+* Arguments
+* =========
+*
+* UPLO (input) CHARACTER*1
+* = 'U': Upper triangle of A is stored;
+* = 'L': Lower triangle of A is stored.
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+* On entry, the symmetric matrix A. If UPLO = 'U', the leading
+* N-by-N upper triangular part of A contains the upper
+* triangular part of the matrix A, and the strictly lower
+* triangular part of A is not referenced. If UPLO = 'L', the
+* leading N-by-N lower triangular part of A contains the lower
+* triangular part of the matrix A, and the strictly upper
+* triangular part of A is not referenced.
+*
+* On exit, the block diagonal matrix D and the multipliers used
+* to obtain the factor U or L (see below for further details).
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,N).
+*
+* IPIV (output) INTEGER array, dimension (N)
+* Details of the interchanges and the block structure of D.
+* If IPIV(k) > 0, then rows and columns k and IPIV(k) were
+* interchanged and D(k,k) is a 1-by-1 diagonal block.
+* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and
+* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)
+* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =
+* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were
+* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
+*
+* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
+* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+* LWORK (input) INTEGER
+* The length of WORK. LWORK >=1. For best performance
+* LWORK >= N*NB, where NB is the block size returned by ILAENV.
+*
+* If LWORK = -1, then a workspace query is assumed; the routine
+* only calculates the optimal size of the WORK array, returns
+* this value as the first entry of the WORK array, and no error
+* message related to LWORK is issued by XERBLA.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* > 0: if INFO = i, D(i,i) is exactly zero. The factorization
+* has been completed, but the block diagonal matrix D is
+* exactly singular, and division by zero will occur if it
+* is used to solve a system of equations.
+*
+* Further Details
+* ===============
+*
+* If UPLO = 'U', then A = U*D*U', where
+* U = P(n)*U(n)* ... *P(k)U(k)* ...,
+* i.e., U is a product of terms P(k)*U(k), where k decreases from n to
+* 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1
+* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as
+* defined by IPIV(k), and U(k) is a unit upper triangular matrix, such
+* that if the diagonal block D(k) is of order s (s = 1 or 2), then
+*
+* ( I v 0 ) k-s
+* U(k) = ( 0 I 0 ) s
+* ( 0 0 I ) n-k
+* k-s s n-k
+*
+* If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k).
+* If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k),
+* and A(k,k), and v overwrites A(1:k-2,k-1:k).
+*
+* If UPLO = 'L', then A = L*D*L', where
+* L = P(1)*L(1)* ... *P(k)*L(k)* ...,
+* i.e., L is a product of terms P(k)*L(k), where k increases from 1 to
+* n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1
+* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as
+* defined by IPIV(k), and L(k) is a unit lower triangular matrix, such
+* that if the diagonal block D(k) is of order s (s = 1 or 2), then
+*
+* ( I 0 0 ) k-1
+* L(k) = ( 0 I 0 ) s
+* ( 0 v I ) n-k-s+1
+* k-1 s n-k-s+1
+*
+* If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k).
+* If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k),
+* and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1).
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ LOGICAL LQUERY, UPPER
+ INTEGER IINFO, IWS, J, K, KB, LDWORK, LWKOPT, NB, NBMIN
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ILAENV
+ EXTERNAL LSAME, ILAENV
+* ..
+* .. External Subroutines ..
+ EXTERNAL DLASYF, DSYTF2, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ LQUERY = ( LWORK.EQ.-1 )
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -4
+ ELSE IF( LWORK.LT.1 .AND. .NOT.LQUERY ) THEN
+ INFO = -7
+ END IF
+*
+ IF( INFO.EQ.0 ) THEN
+*
+* Determine the block size
+*
+ NB = ILAENV( 1, 'DSYTRF', UPLO, N, -1, -1, -1 )
+ LWKOPT = N*NB
+ WORK( 1 ) = LWKOPT
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DSYTRF', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+ NBMIN = 2
+ LDWORK = N
+ IF( NB.GT.1 .AND. NB.LT.N ) THEN
+ IWS = LDWORK*NB
+ IF( LWORK.LT.IWS ) THEN
+ NB = MAX( LWORK / LDWORK, 1 )
+ NBMIN = MAX( 2, ILAENV( 2, 'DSYTRF', UPLO, N, -1, -1, -1 ) )
+ END IF
+ ELSE
+ IWS = 1
+ END IF
+ IF( NB.LT.NBMIN )
+ $ NB = N
+*
+ IF( UPPER ) THEN
+*
+* Factorize A as U*D*U' using the upper triangle of A
+*
+* K is the main loop index, decreasing from N to 1 in steps of
+* KB, where KB is the number of columns factorized by DLASYF;
+* KB is either NB or NB-1, or K for the last block
+*
+ K = N
+ 10 CONTINUE
+*
+* If K < 1, exit from loop
+*
+ IF( K.LT.1 )
+ $ GO TO 40
+*
+ IF( K.GT.NB ) THEN
+*
+* Factorize columns k-kb+1:k of A and use blocked code to
+* update columns 1:k-kb
+*
+ CALL DLASYF( UPLO, K, NB, KB, A, LDA, IPIV, WORK, LDWORK,
+ $ IINFO )
+ ELSE
+*
+* Use unblocked code to factorize columns 1:k of A
+*
+ CALL DSYTF2( UPLO, K, A, LDA, IPIV, IINFO )
+ KB = K
+ END IF
+*
+* Set INFO on the first occurrence of a zero pivot
+*
+ IF( INFO.EQ.0 .AND. IINFO.GT.0 )
+ $ INFO = IINFO
+*
+* Decrease K and return to the start of the main loop
+*
+ K = K - KB
+ GO TO 10
+*
+ ELSE
+*
+* Factorize A as L*D*L' using the lower triangle of A
+*
+* K is the main loop index, increasing from 1 to N in steps of
+* KB, where KB is the number of columns factorized by DLASYF;
+* KB is either NB or NB-1, or N-K+1 for the last block
+*
+ K = 1
+ 20 CONTINUE
+*
+* If K > N, exit from loop
+*
+ IF( K.GT.N )
+ $ GO TO 40
+*
+ IF( K.LE.N-NB ) THEN
+*
+* Factorize columns k:k+kb-1 of A and use blocked code to
+* update columns k+kb:n
+*
+ CALL DLASYF( UPLO, N-K+1, NB, KB, A( K, K ), LDA, IPIV( K ),
+ $ WORK, LDWORK, IINFO )
+ ELSE
+*
+* Use unblocked code to factorize columns k:n of A
+*
+ CALL DSYTF2( UPLO, N-K+1, A( K, K ), LDA, IPIV( K ), IINFO )
+ KB = N - K + 1
+ END IF
+*
+* Set INFO on the first occurrence of a zero pivot
+*
+ IF( INFO.EQ.0 .AND. IINFO.GT.0 )
+ $ INFO = IINFO + K - 1
+*
+* Adjust IPIV
+*
+ DO 30 J = K, K + KB - 1
+ IF( IPIV( J ).GT.0 ) THEN
+ IPIV( J ) = IPIV( J ) + K - 1
+ ELSE
+ IPIV( J ) = IPIV( J ) - K + 1
+ END IF
+ 30 CONTINUE
+*
+* Increase K and return to the start of the main loop
+*
+ K = K + KB
+ GO TO 20
+*
+ END IF
+*
+ 40 CONTINUE
+ WORK( 1 ) = LWKOPT
+ RETURN
+*
+* End of DSYTRF
+*
+ END
+ SUBROUTINE DSYTRI( UPLO, N, A, LDA, IPIV, WORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, LDA, N
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ DOUBLE PRECISION A( LDA, * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DSYTRI computes the inverse of a real symmetric indefinite matrix
+* A using the factorization A = U*D*U**T or A = L*D*L**T computed by
+* DSYTRF.
+*
+* Arguments
+* =========
+*
+* UPLO (input) CHARACTER*1
+* Specifies whether the details of the factorization are stored
+* as an upper or lower triangular matrix.
+* = 'U': Upper triangular, form is A = U*D*U**T;
+* = 'L': Lower triangular, form is A = L*D*L**T.
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+* On entry, the block diagonal matrix D and the multipliers
+* used to obtain the factor U or L as computed by DSYTRF.
+*
+* On exit, if INFO = 0, the (symmetric) inverse of the original
+* matrix. If UPLO = 'U', the upper triangular part of the
+* inverse is formed and the part of A below the diagonal is not
+* referenced; if UPLO = 'L' the lower triangular part of the
+* inverse is formed and the part of A above the diagonal is
+* not referenced.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,N).
+*
+* IPIV (input) INTEGER array, dimension (N)
+* Details of the interchanges and the block structure of D
+* as determined by DSYTRF.
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (N)
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its
+* inverse could not be computed.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE, ZERO
+ PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL UPPER
+ INTEGER K, KP, KSTEP
+ DOUBLE PRECISION AK, AKKP1, AKP1, D, T, TEMP
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ DOUBLE PRECISION DDOT
+ EXTERNAL LSAME, DDOT
+* ..
+* .. External Subroutines ..
+ EXTERNAL DCOPY, DSWAP, DSYMV, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -4
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DSYTRI', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+* Check that the diagonal matrix D is nonsingular.
+*
+ IF( UPPER ) THEN
+*
+* Upper triangular storage: examine D from bottom to top
+*
+ DO 10 INFO = N, 1, -1
+ IF( IPIV( INFO ).GT.0 .AND. A( INFO, INFO ).EQ.ZERO )
+ $ RETURN
+ 10 CONTINUE
+ ELSE
+*
+* Lower triangular storage: examine D from top to bottom.
+*
+ DO 20 INFO = 1, N
+ IF( IPIV( INFO ).GT.0 .AND. A( INFO, INFO ).EQ.ZERO )
+ $ RETURN
+ 20 CONTINUE
+ END IF
+ INFO = 0
+*
+ IF( UPPER ) THEN
+*
+* Compute inv(A) from the factorization A = U*D*U'.
+*
+* K is the main loop index, increasing from 1 to N in steps of
+* 1 or 2, depending on the size of the diagonal blocks.
+*
+ K = 1
+ 30 CONTINUE
+*
+* If K > N, exit from loop.
+*
+ IF( K.GT.N )
+ $ GO TO 40
+*
+ IF( IPIV( K ).GT.0 ) THEN
+*
+* 1 x 1 diagonal block
+*
+* Invert the diagonal block.
+*
+ A( K, K ) = ONE / A( K, K )
+*
+* Compute column K of the inverse.
+*
+ IF( K.GT.1 ) THEN
+ CALL DCOPY( K-1, A( 1, K ), 1, WORK, 1 )
+ CALL DSYMV( UPLO, K-1, -ONE, A, LDA, WORK, 1, ZERO,
+ $ A( 1, K ), 1 )
+ A( K, K ) = A( K, K ) - DDOT( K-1, WORK, 1, A( 1, K ),
+ $ 1 )
+ END IF
+ KSTEP = 1
+ ELSE
+*
+* 2 x 2 diagonal block
+*
+* Invert the diagonal block.
+*
+ T = ABS( A( K, K+1 ) )
+ AK = A( K, K ) / T
+ AKP1 = A( K+1, K+1 ) / T
+ AKKP1 = A( K, K+1 ) / T
+ D = T*( AK*AKP1-ONE )
+ A( K, K ) = AKP1 / D
+ A( K+1, K+1 ) = AK / D
+ A( K, K+1 ) = -AKKP1 / D
+*
+* Compute columns K and K+1 of the inverse.
+*
+ IF( K.GT.1 ) THEN
+ CALL DCOPY( K-1, A( 1, K ), 1, WORK, 1 )
+ CALL DSYMV( UPLO, K-1, -ONE, A, LDA, WORK, 1, ZERO,
+ $ A( 1, K ), 1 )
+ A( K, K ) = A( K, K ) - DDOT( K-1, WORK, 1, A( 1, K ),
+ $ 1 )
+ A( K, K+1 ) = A( K, K+1 ) -
+ $ DDOT( K-1, A( 1, K ), 1, A( 1, K+1 ), 1 )
+ CALL DCOPY( K-1, A( 1, K+1 ), 1, WORK, 1 )
+ CALL DSYMV( UPLO, K-1, -ONE, A, LDA, WORK, 1, ZERO,
+ $ A( 1, K+1 ), 1 )
+ A( K+1, K+1 ) = A( K+1, K+1 ) -
+ $ DDOT( K-1, WORK, 1, A( 1, K+1 ), 1 )
+ END IF
+ KSTEP = 2
+ END IF
+*
+ KP = ABS( IPIV( K ) )
+ IF( KP.NE.K ) THEN
+*
+* Interchange rows and columns K and KP in the leading
+* submatrix A(1:k+1,1:k+1)
+*
+ CALL DSWAP( KP-1, A( 1, K ), 1, A( 1, KP ), 1 )
+ CALL DSWAP( K-KP-1, A( KP+1, K ), 1, A( KP, KP+1 ), LDA )
+ TEMP = A( K, K )
+ A( K, K ) = A( KP, KP )
+ A( KP, KP ) = TEMP
+ IF( KSTEP.EQ.2 ) THEN
+ TEMP = A( K, K+1 )
+ A( K, K+1 ) = A( KP, K+1 )
+ A( KP, K+1 ) = TEMP
+ END IF
+ END IF
+*
+ K = K + KSTEP
+ GO TO 30
+ 40 CONTINUE
+*
+ ELSE
+*
+* Compute inv(A) from the factorization A = L*D*L'.
+*
+* K is the main loop index, increasing from 1 to N in steps of
+* 1 or 2, depending on the size of the diagonal blocks.
+*
+ K = N
+ 50 CONTINUE
+*
+* If K < 1, exit from loop.
+*
+ IF( K.LT.1 )
+ $ GO TO 60
+*
+ IF( IPIV( K ).GT.0 ) THEN
+*
+* 1 x 1 diagonal block
+*
+* Invert the diagonal block.
+*
+ A( K, K ) = ONE / A( K, K )
+*
+* Compute column K of the inverse.
+*
+ IF( K.LT.N ) THEN
+ CALL DCOPY( N-K, A( K+1, K ), 1, WORK, 1 )
+ CALL DSYMV( UPLO, N-K, -ONE, A( K+1, K+1 ), LDA, WORK, 1,
+ $ ZERO, A( K+1, K ), 1 )
+ A( K, K ) = A( K, K ) - DDOT( N-K, WORK, 1, A( K+1, K ),
+ $ 1 )
+ END IF
+ KSTEP = 1
+ ELSE
+*
+* 2 x 2 diagonal block
+*
+* Invert the diagonal block.
+*
+ T = ABS( A( K, K-1 ) )
+ AK = A( K-1, K-1 ) / T
+ AKP1 = A( K, K ) / T
+ AKKP1 = A( K, K-1 ) / T
+ D = T*( AK*AKP1-ONE )
+ A( K-1, K-1 ) = AKP1 / D
+ A( K, K ) = AK / D
+ A( K, K-1 ) = -AKKP1 / D
+*
+* Compute columns K-1 and K of the inverse.
+*
+ IF( K.LT.N ) THEN
+ CALL DCOPY( N-K, A( K+1, K ), 1, WORK, 1 )
+ CALL DSYMV( UPLO, N-K, -ONE, A( K+1, K+1 ), LDA, WORK, 1,
+ $ ZERO, A( K+1, K ), 1 )
+ A( K, K ) = A( K, K ) - DDOT( N-K, WORK, 1, A( K+1, K ),
+ $ 1 )
+ A( K, K-1 ) = A( K, K-1 ) -
+ $ DDOT( N-K, A( K+1, K ), 1, A( K+1, K-1 ),
+ $ 1 )
+ CALL DCOPY( N-K, A( K+1, K-1 ), 1, WORK, 1 )
+ CALL DSYMV( UPLO, N-K, -ONE, A( K+1, K+1 ), LDA, WORK, 1,
+ $ ZERO, A( K+1, K-1 ), 1 )
+ A( K-1, K-1 ) = A( K-1, K-1 ) -
+ $ DDOT( N-K, WORK, 1, A( K+1, K-1 ), 1 )
+ END IF
+ KSTEP = 2
+ END IF
+*
+ KP = ABS( IPIV( K ) )
+ IF( KP.NE.K ) THEN
+*
+* Interchange rows and columns K and KP in the trailing
+* submatrix A(k-1:n,k-1:n)
+*
+ IF( KP.LT.N )
+ $ CALL DSWAP( N-KP, A( KP+1, K ), 1, A( KP+1, KP ), 1 )
+ CALL DSWAP( KP-K-1, A( K+1, K ), 1, A( KP, K+1 ), LDA )
+ TEMP = A( K, K )
+ A( K, K ) = A( KP, KP )
+ A( KP, KP ) = TEMP
+ IF( KSTEP.EQ.2 ) THEN
+ TEMP = A( K, K-1 )
+ A( K, K-1 ) = A( KP, K-1 )
+ A( KP, K-1 ) = TEMP
+ END IF
+ END IF
+*
+ K = K - KSTEP
+ GO TO 50
+ 60 CONTINUE
+ END IF
+*
+ RETURN
+*
+* End of DSYTRI
+*
+ END
+ SUBROUTINE DSYTRS( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, LDA, LDB, N, NRHS
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ DOUBLE PRECISION A( LDA, * ), B( LDB, * )
+* ..
+*
+* Purpose
+* =======
+*
+* DSYTRS solves a system of linear equations A*X = B with a real
+* symmetric matrix A using the factorization A = U*D*U**T or
+* A = L*D*L**T computed by DSYTRF.
+*
+* Arguments
+* =========
+*
+* UPLO (input) CHARACTER*1
+* Specifies whether the details of the factorization are stored
+* as an upper or lower triangular matrix.
+* = 'U': Upper triangular, form is A = U*D*U**T;
+* = 'L': Lower triangular, form is A = L*D*L**T.
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* NRHS (input) INTEGER
+* The number of right hand sides, i.e., the number of columns
+* of the matrix B. NRHS >= 0.
+*
+* A (input) DOUBLE PRECISION array, dimension (LDA,N)
+* The block diagonal matrix D and the multipliers used to
+* obtain the factor U or L as computed by DSYTRF.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,N).
+*
+* IPIV (input) INTEGER array, dimension (N)
+* Details of the interchanges and the block structure of D
+* as determined by DSYTRF.
+*
+* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
+* On entry, the right hand side matrix B.
+* On exit, the solution matrix X.
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. LDB >= max(1,N).
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE
+ PARAMETER ( ONE = 1.0D+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL UPPER
+ INTEGER J, K, KP
+ DOUBLE PRECISION AK, AKM1, AKM1K, BK, BKM1, DENOM
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL DGEMV, DGER, DSCAL, DSWAP, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( NRHS.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -5
+ ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -8
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DSYTRS', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 .OR. NRHS.EQ.0 )
+ $ RETURN
+*
+ IF( UPPER ) THEN
+*
+* Solve A*X = B, where A = U*D*U'.
+*
+* First solve U*D*X = B, overwriting B with X.
+*
+* K is the main loop index, decreasing from N to 1 in steps of
+* 1 or 2, depending on the size of the diagonal blocks.
+*
+ K = N
+ 10 CONTINUE
+*
+* If K < 1, exit from loop.
+*
+ IF( K.LT.1 )
+ $ GO TO 30
+*
+ IF( IPIV( K ).GT.0 ) THEN
+*
+* 1 x 1 diagonal block
+*
+* Interchange rows K and IPIV(K).
+*
+ KP = IPIV( K )
+ IF( KP.NE.K )
+ $ CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+*
+* Multiply by inv(U(K)), where U(K) is the transformation
+* stored in column K of A.
+*
+ CALL DGER( K-1, NRHS, -ONE, A( 1, K ), 1, B( K, 1 ), LDB,
+ $ B( 1, 1 ), LDB )
+*
+* Multiply by the inverse of the diagonal block.
+*
+ CALL DSCAL( NRHS, ONE / A( K, K ), B( K, 1 ), LDB )
+ K = K - 1
+ ELSE
+*
+* 2 x 2 diagonal block
+*
+* Interchange rows K-1 and -IPIV(K).
+*
+ KP = -IPIV( K )
+ IF( KP.NE.K-1 )
+ $ CALL DSWAP( NRHS, B( K-1, 1 ), LDB, B( KP, 1 ), LDB )
+*
+* Multiply by inv(U(K)), where U(K) is the transformation
+* stored in columns K-1 and K of A.
+*
+ CALL DGER( K-2, NRHS, -ONE, A( 1, K ), 1, B( K, 1 ), LDB,
+ $ B( 1, 1 ), LDB )
+ CALL DGER( K-2, NRHS, -ONE, A( 1, K-1 ), 1, B( K-1, 1 ),
+ $ LDB, B( 1, 1 ), LDB )
+*
+* Multiply by the inverse of the diagonal block.
+*
+ AKM1K = A( K-1, K )
+ AKM1 = A( K-1, K-1 ) / AKM1K
+ AK = A( K, K ) / AKM1K
+ DENOM = AKM1*AK - ONE
+ DO 20 J = 1, NRHS
+ BKM1 = B( K-1, J ) / AKM1K
+ BK = B( K, J ) / AKM1K
+ B( K-1, J ) = ( AK*BKM1-BK ) / DENOM
+ B( K, J ) = ( AKM1*BK-BKM1 ) / DENOM
+ 20 CONTINUE
+ K = K - 2
+ END IF
+*
+ GO TO 10
+ 30 CONTINUE
+*
+* Next solve U'*X = B, overwriting B with X.
+*
+* K is the main loop index, increasing from 1 to N in steps of
+* 1 or 2, depending on the size of the diagonal blocks.
+*
+ K = 1
+ 40 CONTINUE
+*
+* If K > N, exit from loop.
+*
+ IF( K.GT.N )
+ $ GO TO 50
+*
+ IF( IPIV( K ).GT.0 ) THEN
+*
+* 1 x 1 diagonal block
+*
+* Multiply by inv(U'(K)), where U(K) is the transformation
+* stored in column K of A.
+*
+ CALL DGEMV( 'Transpose', K-1, NRHS, -ONE, B, LDB, A( 1, K ),
+ $ 1, ONE, B( K, 1 ), LDB )
+*
+* Interchange rows K and IPIV(K).
+*
+ KP = IPIV( K )
+ IF( KP.NE.K )
+ $ CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+ K = K + 1
+ ELSE
+*
+* 2 x 2 diagonal block
+*
+* Multiply by inv(U'(K+1)), where U(K+1) is the transformation
+* stored in columns K and K+1 of A.
+*
+ CALL DGEMV( 'Transpose', K-1, NRHS, -ONE, B, LDB, A( 1, K ),
+ $ 1, ONE, B( K, 1 ), LDB )
+ CALL DGEMV( 'Transpose', K-1, NRHS, -ONE, B, LDB,
+ $ A( 1, K+1 ), 1, ONE, B( K+1, 1 ), LDB )
+*
+* Interchange rows K and -IPIV(K).
+*
+ KP = -IPIV( K )
+ IF( KP.NE.K )
+ $ CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+ K = K + 2
+ END IF
+*
+ GO TO 40
+ 50 CONTINUE
+*
+ ELSE
+*
+* Solve A*X = B, where A = L*D*L'.
+*
+* First solve L*D*X = B, overwriting B with X.
+*
+* K is the main loop index, increasing from 1 to N in steps of
+* 1 or 2, depending on the size of the diagonal blocks.
+*
+ K = 1
+ 60 CONTINUE
+*
+* If K > N, exit from loop.
+*
+ IF( K.GT.N )
+ $ GO TO 80
+*
+ IF( IPIV( K ).GT.0 ) THEN
+*
+* 1 x 1 diagonal block
+*
+* Interchange rows K and IPIV(K).
+*
+ KP = IPIV( K )
+ IF( KP.NE.K )
+ $ CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+*
+* Multiply by inv(L(K)), where L(K) is the transformation
+* stored in column K of A.
+*
+ IF( K.LT.N )
+ $ CALL DGER( N-K, NRHS, -ONE, A( K+1, K ), 1, B( K, 1 ),
+ $ LDB, B( K+1, 1 ), LDB )
+*
+* Multiply by the inverse of the diagonal block.
+*
+ CALL DSCAL( NRHS, ONE / A( K, K ), B( K, 1 ), LDB )
+ K = K + 1
+ ELSE
+*
+* 2 x 2 diagonal block
+*
+* Interchange rows K+1 and -IPIV(K).
+*
+ KP = -IPIV( K )
+ IF( KP.NE.K+1 )
+ $ CALL DSWAP( NRHS, B( K+1, 1 ), LDB, B( KP, 1 ), LDB )
+*
+* Multiply by inv(L(K)), where L(K) is the transformation
+* stored in columns K and K+1 of A.
+*
+ IF( K.LT.N-1 ) THEN
+ CALL DGER( N-K-1, NRHS, -ONE, A( K+2, K ), 1, B( K, 1 ),
+ $ LDB, B( K+2, 1 ), LDB )
+ CALL DGER( N-K-1, NRHS, -ONE, A( K+2, K+1 ), 1,
+ $ B( K+1, 1 ), LDB, B( K+2, 1 ), LDB )
+ END IF
+*
+* Multiply by the inverse of the diagonal block.
+*
+ AKM1K = A( K+1, K )
+ AKM1 = A( K, K ) / AKM1K
+ AK = A( K+1, K+1 ) / AKM1K
+ DENOM = AKM1*AK - ONE
+ DO 70 J = 1, NRHS
+ BKM1 = B( K, J ) / AKM1K
+ BK = B( K+1, J ) / AKM1K
+ B( K, J ) = ( AK*BKM1-BK ) / DENOM
+ B( K+1, J ) = ( AKM1*BK-BKM1 ) / DENOM
+ 70 CONTINUE
+ K = K + 2
+ END IF
+*
+ GO TO 60
+ 80 CONTINUE
+*
+* Next solve L'*X = B, overwriting B with X.
+*
+* K is the main loop index, decreasing from N to 1 in steps of
+* 1 or 2, depending on the size of the diagonal blocks.
+*
+ K = N
+ 90 CONTINUE
+*
+* If K < 1, exit from loop.
+*
+ IF( K.LT.1 )
+ $ GO TO 100
+*
+ IF( IPIV( K ).GT.0 ) THEN
+*
+* 1 x 1 diagonal block
+*
+* Multiply by inv(L'(K)), where L(K) is the transformation
+* stored in column K of A.
+*
+ IF( K.LT.N )
+ $ CALL DGEMV( 'Transpose', N-K, NRHS, -ONE, B( K+1, 1 ),
+ $ LDB, A( K+1, K ), 1, ONE, B( K, 1 ), LDB )
+*
+* Interchange rows K and IPIV(K).
+*
+ KP = IPIV( K )
+ IF( KP.NE.K )
+ $ CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+ K = K - 1
+ ELSE
+*
+* 2 x 2 diagonal block
+*
+* Multiply by inv(L'(K-1)), where L(K-1) is the transformation
+* stored in columns K-1 and K of A.
+*
+ IF( K.LT.N ) THEN
+ CALL DGEMV( 'Transpose', N-K, NRHS, -ONE, B( K+1, 1 ),
+ $ LDB, A( K+1, K ), 1, ONE, B( K, 1 ), LDB )
+ CALL DGEMV( 'Transpose', N-K, NRHS, -ONE, B( K+1, 1 ),
+ $ LDB, A( K+1, K-1 ), 1, ONE, B( K-1, 1 ),
+ $ LDB )
+ END IF
+*
+* Interchange rows K and -IPIV(K).
+*
+ KP = -IPIV( K )
+ IF( KP.NE.K )
+ $ CALL DSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+ K = K - 2
+ END IF
+*
+ GO TO 90
+ 100 CONTINUE
+ END IF
+*
+ RETURN
+*
+* End of DSYTRS
+*
+ END
+ SUBROUTINE DTBCON( NORM, UPLO, DIAG, N, KD, AB, LDAB, RCOND, WORK,
+ $ IWORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH.
+*
+* .. Scalar Arguments ..
+ CHARACTER DIAG, NORM, UPLO
+ INTEGER INFO, KD, LDAB, N
+ DOUBLE PRECISION RCOND
+* ..
+* .. Array Arguments ..
+ INTEGER IWORK( * )
+ DOUBLE PRECISION AB( LDAB, * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DTBCON estimates the reciprocal of the condition number of a
+* triangular band matrix A, in either the 1-norm or the infinity-norm.
+*
+* The norm of A is computed and an estimate is obtained for
+* norm(inv(A)), then the reciprocal of the condition number is
+* computed as
+* RCOND = 1 / ( norm(A) * norm(inv(A)) ).
+*
+* Arguments
+* =========
+*
+* NORM (input) CHARACTER*1
+* Specifies whether the 1-norm condition number or the
+* infinity-norm condition number is required:
+* = '1' or 'O': 1-norm;
+* = 'I': Infinity-norm.
+*
+* UPLO (input) CHARACTER*1
+* = 'U': A is upper triangular;
+* = 'L': A is lower triangular.
+*
+* DIAG (input) CHARACTER*1
+* = 'N': A is non-unit triangular;
+* = 'U': A is unit triangular.
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* KD (input) INTEGER
+* The number of superdiagonals or subdiagonals of the
+* triangular band matrix A. KD >= 0.
+*
+* AB (input) DOUBLE PRECISION array, dimension (LDAB,N)
+* The upper or lower triangular band matrix A, stored in the
+* first kd+1 rows of the array. The j-th column of A is stored
+* in the j-th column of the array AB as follows:
+* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
+* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).
+* If DIAG = 'U', the diagonal elements of A are not referenced
+* and are assumed to be 1.
+*
+* LDAB (input) INTEGER
+* The leading dimension of the array AB. LDAB >= KD+1.
+*
+* RCOND (output) DOUBLE PRECISION
+* The reciprocal of the condition number of the matrix A,
+* computed as RCOND = 1/(norm(A) * norm(inv(A))).
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (3*N)
+*
+* IWORK (workspace) INTEGER array, dimension (N)
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE, ZERO
+ PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL NOUNIT, ONENRM, UPPER
+ CHARACTER NORMIN
+ INTEGER IX, KASE, KASE1
+ DOUBLE PRECISION AINVNM, ANORM, SCALE, SMLNUM, XNORM
+* ..
+* .. Local Arrays ..
+ INTEGER ISAVE( 3 )
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER IDAMAX
+ DOUBLE PRECISION DLAMCH, DLANTB
+ EXTERNAL LSAME, IDAMAX, DLAMCH, DLANTB
+* ..
+* .. External Subroutines ..
+ EXTERNAL DLACN2, DLATBS, DRSCL, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, DBLE, MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ ONENRM = NORM.EQ.'1' .OR. LSAME( NORM, 'O' )
+ NOUNIT = LSAME( DIAG, 'N' )
+*
+ IF( .NOT.ONENRM .AND. .NOT.LSAME( NORM, 'I' ) ) THEN
+ INFO = -1
+ ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -2
+ ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
+ INFO = -3
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( KD.LT.0 ) THEN
+ INFO = -5
+ ELSE IF( LDAB.LT.KD+1 ) THEN
+ INFO = -7
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DTBCON', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 ) THEN
+ RCOND = ONE
+ RETURN
+ END IF
+*
+ RCOND = ZERO
+ SMLNUM = DLAMCH( 'Safe minimum' )*DBLE( MAX( 1, N ) )
+*
+* Compute the norm of the triangular matrix A.
+*
+ ANORM = DLANTB( NORM, UPLO, DIAG, N, KD, AB, LDAB, WORK )
+*
+* Continue only if ANORM > 0.
+*
+ IF( ANORM.GT.ZERO ) THEN
+*
+* Estimate the norm of the inverse of A.
+*
+ AINVNM = ZERO
+ NORMIN = 'N'
+ IF( ONENRM ) THEN
+ KASE1 = 1
+ ELSE
+ KASE1 = 2
+ END IF
+ KASE = 0
+ 10 CONTINUE
+ CALL DLACN2( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE, ISAVE )
+ IF( KASE.NE.0 ) THEN
+ IF( KASE.EQ.KASE1 ) THEN
+*
+* Multiply by inv(A).
+*
+ CALL DLATBS( UPLO, 'No transpose', DIAG, NORMIN, N, KD,
+ $ AB, LDAB, WORK, SCALE, WORK( 2*N+1 ), INFO )
+ ELSE
+*
+* Multiply by inv(A').
+*
+ CALL DLATBS( UPLO, 'Transpose', DIAG, NORMIN, N, KD, AB,
+ $ LDAB, WORK, SCALE, WORK( 2*N+1 ), INFO )
+ END IF
+ NORMIN = 'Y'
+*
+* Multiply by 1/SCALE if doing so will not cause overflow.
+*
+ IF( SCALE.NE.ONE ) THEN
+ IX = IDAMAX( N, WORK, 1 )
+ XNORM = ABS( WORK( IX ) )
+ IF( SCALE.LT.XNORM*SMLNUM .OR. SCALE.EQ.ZERO )
+ $ GO TO 20
+ CALL DRSCL( N, SCALE, WORK, 1 )
+ END IF
+ GO TO 10
+ END IF
+*
+* Compute the estimate of the reciprocal condition number.
+*
+ IF( AINVNM.NE.ZERO )
+ $ RCOND = ( ONE / ANORM ) / AINVNM
+ END IF
+*
+ 20 CONTINUE
+ RETURN
+*
+* End of DTBCON
+*
+ END
+ SUBROUTINE DTBRFS( UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, B,
+ $ LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH.
+*
+* .. Scalar Arguments ..
+ CHARACTER DIAG, TRANS, UPLO
+ INTEGER INFO, KD, LDAB, LDB, LDX, N, NRHS
+* ..
+* .. Array Arguments ..
+ INTEGER IWORK( * )
+ DOUBLE PRECISION AB( LDAB, * ), B( LDB, * ), BERR( * ),
+ $ FERR( * ), WORK( * ), X( LDX, * )
+* ..
+*
+* Purpose
+* =======
+*
+* DTBRFS provides error bounds and backward error estimates for the
+* solution to a system of linear equations with a triangular band
+* coefficient matrix.
+*
+* The solution matrix X must be computed by DTBTRS or some other
+* means before entering this routine. DTBRFS does not do iterative
+* refinement because doing so cannot improve the backward error.
+*
+* Arguments
+* =========
+*
+* UPLO (input) CHARACTER*1
+* = 'U': A is upper triangular;
+* = 'L': A is lower triangular.
+*
+* TRANS (input) CHARACTER*1
+* Specifies the form of the system of equations:
+* = 'N': A * X = B (No transpose)
+* = 'T': A**T * X = B (Transpose)
+* = 'C': A**H * X = B (Conjugate transpose = Transpose)
+*
+* DIAG (input) CHARACTER*1
+* = 'N': A is non-unit triangular;
+* = 'U': A is unit triangular.
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* KD (input) INTEGER
+* The number of superdiagonals or subdiagonals of the
+* triangular band matrix A. KD >= 0.
+*
+* NRHS (input) INTEGER
+* The number of right hand sides, i.e., the number of columns
+* of the matrices B and X. NRHS >= 0.
+*
+* AB (input) DOUBLE PRECISION array, dimension (LDAB,N)
+* The upper or lower triangular band matrix A, stored in the
+* first kd+1 rows of the array. The j-th column of A is stored
+* in the j-th column of the array AB as follows:
+* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
+* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).
+* If DIAG = 'U', the diagonal elements of A are not referenced
+* and are assumed to be 1.
+*
+* LDAB (input) INTEGER
+* The leading dimension of the array AB. LDAB >= KD+1.
+*
+* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS)
+* The right hand side matrix B.
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. LDB >= max(1,N).
+*
+* X (input) DOUBLE PRECISION array, dimension (LDX,NRHS)
+* The solution matrix X.
+*
+* LDX (input) INTEGER
+* The leading dimension of the array X. LDX >= max(1,N).
+*
+* FERR (output) DOUBLE PRECISION array, dimension (NRHS)
+* The estimated forward error bound for each solution vector
+* X(j) (the j-th column of the solution matrix X).
+* If XTRUE is the true solution corresponding to X(j), FERR(j)
+* is an estimated upper bound for the magnitude of the largest
+* element in (X(j) - XTRUE) divided by the magnitude of the
+* largest element in X(j). The estimate is as reliable as
+* the estimate for RCOND, and is almost always a slight
+* overestimate of the true error.
+*
+* BERR (output) DOUBLE PRECISION array, dimension (NRHS)
+* The componentwise relative backward error of each solution
+* vector X(j) (i.e., the smallest relative change in
+* any element of A or B that makes X(j) an exact solution).
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (3*N)
+*
+* IWORK (workspace) INTEGER array, dimension (N)
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO
+ PARAMETER ( ZERO = 0.0D+0 )
+ DOUBLE PRECISION ONE
+ PARAMETER ( ONE = 1.0D+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL NOTRAN, NOUNIT, UPPER
+ CHARACTER TRANST
+ INTEGER I, J, K, KASE, NZ
+ DOUBLE PRECISION EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK
+* ..
+* .. Local Arrays ..
+ INTEGER ISAVE( 3 )
+* ..
+* .. External Subroutines ..
+ EXTERNAL DAXPY, DCOPY, DLACN2, DTBMV, DTBSV, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, MIN
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ DOUBLE PRECISION DLAMCH
+ EXTERNAL LSAME, DLAMCH
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ NOTRAN = LSAME( TRANS, 'N' )
+ NOUNIT = LSAME( DIAG, 'N' )
+*
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT.
+ $ LSAME( TRANS, 'C' ) ) THEN
+ INFO = -2
+ ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
+ INFO = -3
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( KD.LT.0 ) THEN
+ INFO = -5
+ ELSE IF( NRHS.LT.0 ) THEN
+ INFO = -6
+ ELSE IF( LDAB.LT.KD+1 ) THEN
+ INFO = -8
+ ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -10
+ ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
+ INFO = -12
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DTBRFS', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN
+ DO 10 J = 1, NRHS
+ FERR( J ) = ZERO
+ BERR( J ) = ZERO
+ 10 CONTINUE
+ RETURN
+ END IF
+*
+ IF( NOTRAN ) THEN
+ TRANST = 'T'
+ ELSE
+ TRANST = 'N'
+ END IF
+*
+* NZ = maximum number of nonzero elements in each row of A, plus 1
+*
+ NZ = KD + 2
+ EPS = DLAMCH( 'Epsilon' )
+ SAFMIN = DLAMCH( 'Safe minimum' )
+ SAFE1 = NZ*SAFMIN
+ SAFE2 = SAFE1 / EPS
+*
+* Do for each right hand side
+*
+ DO 250 J = 1, NRHS
+*
+* Compute residual R = B - op(A) * X,
+* where op(A) = A or A', depending on TRANS.
+*
+ CALL DCOPY( N, X( 1, J ), 1, WORK( N+1 ), 1 )
+ CALL DTBMV( UPLO, TRANS, DIAG, N, KD, AB, LDAB, WORK( N+1 ),
+ $ 1 )
+ CALL DAXPY( N, -ONE, B( 1, J ), 1, WORK( N+1 ), 1 )
+*
+* Compute componentwise relative backward error from formula
+*
+* max(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) )
+*
+* where abs(Z) is the componentwise absolute value of the matrix
+* or vector Z. If the i-th component of the denominator is less
+* than SAFE2, then SAFE1 is added to the i-th components of the
+* numerator and denominator before dividing.
+*
+ DO 20 I = 1, N
+ WORK( I ) = ABS( B( I, J ) )
+ 20 CONTINUE
+*
+ IF( NOTRAN ) THEN
+*
+* Compute abs(A)*abs(X) + abs(B).
+*
+ IF( UPPER ) THEN
+ IF( NOUNIT ) THEN
+ DO 40 K = 1, N
+ XK = ABS( X( K, J ) )
+ DO 30 I = MAX( 1, K-KD ), K
+ WORK( I ) = WORK( I ) +
+ $ ABS( AB( KD+1+I-K, K ) )*XK
+ 30 CONTINUE
+ 40 CONTINUE
+ ELSE
+ DO 60 K = 1, N
+ XK = ABS( X( K, J ) )
+ DO 50 I = MAX( 1, K-KD ), K - 1
+ WORK( I ) = WORK( I ) +
+ $ ABS( AB( KD+1+I-K, K ) )*XK
+ 50 CONTINUE
+ WORK( K ) = WORK( K ) + XK
+ 60 CONTINUE
+ END IF
+ ELSE
+ IF( NOUNIT ) THEN
+ DO 80 K = 1, N
+ XK = ABS( X( K, J ) )
+ DO 70 I = K, MIN( N, K+KD )
+ WORK( I ) = WORK( I ) + ABS( AB( 1+I-K, K ) )*XK
+ 70 CONTINUE
+ 80 CONTINUE
+ ELSE
+ DO 100 K = 1, N
+ XK = ABS( X( K, J ) )
+ DO 90 I = K + 1, MIN( N, K+KD )
+ WORK( I ) = WORK( I ) + ABS( AB( 1+I-K, K ) )*XK
+ 90 CONTINUE
+ WORK( K ) = WORK( K ) + XK
+ 100 CONTINUE
+ END IF
+ END IF
+ ELSE
+*
+* Compute abs(A')*abs(X) + abs(B).
+*
+ IF( UPPER ) THEN
+ IF( NOUNIT ) THEN
+ DO 120 K = 1, N
+ S = ZERO
+ DO 110 I = MAX( 1, K-KD ), K
+ S = S + ABS( AB( KD+1+I-K, K ) )*
+ $ ABS( X( I, J ) )
+ 110 CONTINUE
+ WORK( K ) = WORK( K ) + S
+ 120 CONTINUE
+ ELSE
+ DO 140 K = 1, N
+ S = ABS( X( K, J ) )
+ DO 130 I = MAX( 1, K-KD ), K - 1
+ S = S + ABS( AB( KD+1+I-K, K ) )*
+ $ ABS( X( I, J ) )
+ 130 CONTINUE
+ WORK( K ) = WORK( K ) + S
+ 140 CONTINUE
+ END IF
+ ELSE
+ IF( NOUNIT ) THEN
+ DO 160 K = 1, N
+ S = ZERO
+ DO 150 I = K, MIN( N, K+KD )
+ S = S + ABS( AB( 1+I-K, K ) )*ABS( X( I, J ) )
+ 150 CONTINUE
+ WORK( K ) = WORK( K ) + S
+ 160 CONTINUE
+ ELSE
+ DO 180 K = 1, N
+ S = ABS( X( K, J ) )
+ DO 170 I = K + 1, MIN( N, K+KD )
+ S = S + ABS( AB( 1+I-K, K ) )*ABS( X( I, J ) )
+ 170 CONTINUE
+ WORK( K ) = WORK( K ) + S
+ 180 CONTINUE
+ END IF
+ END IF
+ END IF
+ S = ZERO
+ DO 190 I = 1, N
+ IF( WORK( I ).GT.SAFE2 ) THEN
+ S = MAX( S, ABS( WORK( N+I ) ) / WORK( I ) )
+ ELSE
+ S = MAX( S, ( ABS( WORK( N+I ) )+SAFE1 ) /
+ $ ( WORK( I )+SAFE1 ) )
+ END IF
+ 190 CONTINUE
+ BERR( J ) = S
+*
+* Bound error from formula
+*
+* norm(X - XTRUE) / norm(X) .le. FERR =
+* norm( abs(inv(op(A)))*
+* ( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X)
+*
+* where
+* norm(Z) is the magnitude of the largest component of Z
+* inv(op(A)) is the inverse of op(A)
+* abs(Z) is the componentwise absolute value of the matrix or
+* vector Z
+* NZ is the maximum number of nonzeros in any row of A, plus 1
+* EPS is machine epsilon
+*
+* The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B))
+* is incremented by SAFE1 if the i-th component of
+* abs(op(A))*abs(X) + abs(B) is less than SAFE2.
+*
+* Use DLACN2 to estimate the infinity-norm of the matrix
+* inv(op(A)) * diag(W),
+* where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) )))
+*
+ DO 200 I = 1, N
+ IF( WORK( I ).GT.SAFE2 ) THEN
+ WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I )
+ ELSE
+ WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I ) + SAFE1
+ END IF
+ 200 CONTINUE
+*
+ KASE = 0
+ 210 CONTINUE
+ CALL DLACN2( N, WORK( 2*N+1 ), WORK( N+1 ), IWORK, FERR( J ),
+ $ KASE, ISAVE )
+ IF( KASE.NE.0 ) THEN
+ IF( KASE.EQ.1 ) THEN
+*
+* Multiply by diag(W)*inv(op(A)').
+*
+ CALL DTBSV( UPLO, TRANST, DIAG, N, KD, AB, LDAB,
+ $ WORK( N+1 ), 1 )
+ DO 220 I = 1, N
+ WORK( N+I ) = WORK( I )*WORK( N+I )
+ 220 CONTINUE
+ ELSE
+*
+* Multiply by inv(op(A))*diag(W).
+*
+ DO 230 I = 1, N
+ WORK( N+I ) = WORK( I )*WORK( N+I )
+ 230 CONTINUE
+ CALL DTBSV( UPLO, TRANS, DIAG, N, KD, AB, LDAB,
+ $ WORK( N+1 ), 1 )
+ END IF
+ GO TO 210
+ END IF
+*
+* Normalize error.
+*
+ LSTRES = ZERO
+ DO 240 I = 1, N
+ LSTRES = MAX( LSTRES, ABS( X( I, J ) ) )
+ 240 CONTINUE
+ IF( LSTRES.NE.ZERO )
+ $ FERR( J ) = FERR( J ) / LSTRES
+*
+ 250 CONTINUE
+*
+ RETURN
+*
+* End of DTBRFS
+*
+ END
+ SUBROUTINE DTBTRS( UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, B,
+ $ LDB, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER DIAG, TRANS, UPLO
+ INTEGER INFO, KD, LDAB, LDB, N, NRHS
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION AB( LDAB, * ), B( LDB, * )
+* ..
+*
+* Purpose
+* =======
+*
+* DTBTRS solves a triangular system of the form
+*
+* A * X = B or A**T * X = B,
+*
+* where A is a triangular band matrix of order N, and B is an
+* N-by NRHS matrix. A check is made to verify that A is nonsingular.
+*
+* Arguments
+* =========
+*
+* UPLO (input) CHARACTER*1
+* = 'U': A is upper triangular;
+* = 'L': A is lower triangular.
+*
+* TRANS (input) CHARACTER*1
+* Specifies the form the system of equations:
+* = 'N': A * X = B (No transpose)
+* = 'T': A**T * X = B (Transpose)
+* = 'C': A**H * X = B (Conjugate transpose = Transpose)
+*
+* DIAG (input) CHARACTER*1
+* = 'N': A is non-unit triangular;
+* = 'U': A is unit triangular.
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* KD (input) INTEGER
+* The number of superdiagonals or subdiagonals of the
+* triangular band matrix A. KD >= 0.
+*
+* NRHS (input) INTEGER
+* The number of right hand sides, i.e., the number of columns
+* of the matrix B. NRHS >= 0.
+*
+* AB (input) DOUBLE PRECISION array, dimension (LDAB,N)
+* The upper or lower triangular band matrix A, stored in the
+* first kd+1 rows of AB. The j-th column of A is stored
+* in the j-th column of the array AB as follows:
+* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
+* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).
+* If DIAG = 'U', the diagonal elements of A are not referenced
+* and are assumed to be 1.
+*
+* LDAB (input) INTEGER
+* The leading dimension of the array AB. LDAB >= KD+1.
+*
+* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
+* On entry, the right hand side matrix B.
+* On exit, if INFO = 0, the solution matrix X.
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. LDB >= max(1,N).
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* > 0: if INFO = i, the i-th diagonal element of A is zero,
+* indicating that the matrix is singular and the
+* solutions X have not been computed.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO
+ PARAMETER ( ZERO = 0.0D+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL NOUNIT, UPPER
+ INTEGER J
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL DTBSV, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ NOUNIT = LSAME( DIAG, 'N' )
+ UPPER = LSAME( UPLO, 'U' )
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( .NOT.LSAME( TRANS, 'N' ) .AND. .NOT.
+ $ LSAME( TRANS, 'T' ) .AND. .NOT.LSAME( TRANS, 'C' ) ) THEN
+ INFO = -2
+ ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
+ INFO = -3
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( KD.LT.0 ) THEN
+ INFO = -5
+ ELSE IF( NRHS.LT.0 ) THEN
+ INFO = -6
+ ELSE IF( LDAB.LT.KD+1 ) THEN
+ INFO = -8
+ ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -10
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DTBTRS', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+* Check for singularity.
+*
+ IF( NOUNIT ) THEN
+ IF( UPPER ) THEN
+ DO 10 INFO = 1, N
+ IF( AB( KD+1, INFO ).EQ.ZERO )
+ $ RETURN
+ 10 CONTINUE
+ ELSE
+ DO 20 INFO = 1, N
+ IF( AB( 1, INFO ).EQ.ZERO )
+ $ RETURN
+ 20 CONTINUE
+ END IF
+ END IF
+ INFO = 0
+*
+* Solve A * X = B or A' * X = B.
+*
+ DO 30 J = 1, NRHS
+ CALL DTBSV( UPLO, TRANS, DIAG, N, KD, AB, LDAB, B( 1, J ), 1 )
+ 30 CONTINUE
+*
+ RETURN
+*
+* End of DTBTRS
+*
+ END
+ SUBROUTINE DTGEVC( SIDE, HOWMNY, SELECT, N, S, LDS, P, LDP, VL,
+ $ LDVL, VR, LDVR, MM, M, WORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER HOWMNY, SIDE
+ INTEGER INFO, LDP, LDS, LDVL, LDVR, M, MM, N
+* ..
+* .. Array Arguments ..
+ LOGICAL SELECT( * )
+ DOUBLE PRECISION P( LDP, * ), S( LDS, * ), VL( LDVL, * ),
+ $ VR( LDVR, * ), WORK( * )
+* ..
+*
+*
+* Purpose
+* =======
+*
+* DTGEVC computes some or all of the right and/or left eigenvectors of
+* a pair of real matrices (S,P), where S is a quasi-triangular matrix
+* and P is upper triangular. Matrix pairs of this type are produced by
+* the generalized Schur factorization of a matrix pair (A,B):
+*
+* A = Q*S*Z**T, B = Q*P*Z**T
+*
+* as computed by DGGHRD + DHGEQZ.
+*
+* The right eigenvector x and the left eigenvector y of (S,P)
+* corresponding to an eigenvalue w are defined by:
+*
+* S*x = w*P*x, (y**H)*S = w*(y**H)*P,
+*
+* where y**H denotes the conjugate tranpose of y.
+* The eigenvalues are not input to this routine, but are computed
+* directly from the diagonal blocks of S and P.
+*
+* This routine returns the matrices X and/or Y of right and left
+* eigenvectors of (S,P), or the products Z*X and/or Q*Y,
+* where Z and Q are input matrices.
+* If Q and Z are the orthogonal factors from the generalized Schur
+* factorization of a matrix pair (A,B), then Z*X and Q*Y
+* are the matrices of right and left eigenvectors of (A,B).
+*
+* Arguments
+* =========
+*
+* SIDE (input) CHARACTER*1
+* = 'R': compute right eigenvectors only;
+* = 'L': compute left eigenvectors only;
+* = 'B': compute both right and left eigenvectors.
+*
+* HOWMNY (input) CHARACTER*1
+* = 'A': compute all right and/or left eigenvectors;
+* = 'B': compute all right and/or left eigenvectors,
+* backtransformed by the matrices in VR and/or VL;
+* = 'S': compute selected right and/or left eigenvectors,
+* specified by the logical array SELECT.
+*
+* SELECT (input) LOGICAL array, dimension (N)
+* If HOWMNY='S', SELECT specifies the eigenvectors to be
+* computed. If w(j) is a real eigenvalue, the corresponding
+* real eigenvector is computed if SELECT(j) is .TRUE..
+* If w(j) and w(j+1) are the real and imaginary parts of a
+* complex eigenvalue, the corresponding complex eigenvector
+* is computed if either SELECT(j) or SELECT(j+1) is .TRUE.,
+* and on exit SELECT(j) is set to .TRUE. and SELECT(j+1) is
+* set to .FALSE..
+* Not referenced if HOWMNY = 'A' or 'B'.
+*
+* N (input) INTEGER
+* The order of the matrices S and P. N >= 0.
+*
+* S (input) DOUBLE PRECISION array, dimension (LDS,N)
+* The upper quasi-triangular matrix S from a generalized Schur
+* factorization, as computed by DHGEQZ.
+*
+* LDS (input) INTEGER
+* The leading dimension of array S. LDS >= max(1,N).
+*
+* P (input) DOUBLE PRECISION array, dimension (LDP,N)
+* The upper triangular matrix P from a generalized Schur
+* factorization, as computed by DHGEQZ.
+* 2-by-2 diagonal blocks of P corresponding to 2-by-2 blocks
+* of S must be in positive diagonal form.
+*
+* LDP (input) INTEGER
+* The leading dimension of array P. LDP >= max(1,N).
+*
+* VL (input/output) DOUBLE PRECISION array, dimension (LDVL,MM)
+* On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must
+* contain an N-by-N matrix Q (usually the orthogonal matrix Q
+* of left Schur vectors returned by DHGEQZ).
+* On exit, if SIDE = 'L' or 'B', VL contains:
+* if HOWMNY = 'A', the matrix Y of left eigenvectors of (S,P);
+* if HOWMNY = 'B', the matrix Q*Y;
+* if HOWMNY = 'S', the left eigenvectors of (S,P) specified by
+* SELECT, stored consecutively in the columns of
+* VL, in the same order as their eigenvalues.
+*
+* A complex eigenvector corresponding to a complex eigenvalue
+* is stored in two consecutive columns, the first holding the
+* real part, and the second the imaginary part.
+*
+* Not referenced if SIDE = 'R'.
+*
+* LDVL (input) INTEGER
+* The leading dimension of array VL. LDVL >= 1, and if
+* SIDE = 'L' or 'B', LDVL >= N.
+*
+* VR (input/output) DOUBLE PRECISION array, dimension (LDVR,MM)
+* On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must
+* contain an N-by-N matrix Z (usually the orthogonal matrix Z
+* of right Schur vectors returned by DHGEQZ).
+*
+* On exit, if SIDE = 'R' or 'B', VR contains:
+* if HOWMNY = 'A', the matrix X of right eigenvectors of (S,P);
+* if HOWMNY = 'B' or 'b', the matrix Z*X;
+* if HOWMNY = 'S' or 's', the right eigenvectors of (S,P)
+* specified by SELECT, stored consecutively in the
+* columns of VR, in the same order as their
+* eigenvalues.
+*
+* A complex eigenvector corresponding to a complex eigenvalue
+* is stored in two consecutive columns, the first holding the
+* real part and the second the imaginary part.
+*
+* Not referenced if SIDE = 'L'.
+*
+* LDVR (input) INTEGER
+* The leading dimension of the array VR. LDVR >= 1, and if
+* SIDE = 'R' or 'B', LDVR >= N.
+*
+* MM (input) INTEGER
+* The number of columns in the arrays VL and/or VR. MM >= M.
+*
+* M (output) INTEGER
+* The number of columns in the arrays VL and/or VR actually
+* used to store the eigenvectors. If HOWMNY = 'A' or 'B', M
+* is set to N. Each selected real eigenvector occupies one
+* column and each selected complex eigenvector occupies two
+* columns.
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (6*N)
+*
+* INFO (output) INTEGER
+* = 0: successful exit.
+* < 0: if INFO = -i, the i-th argument had an illegal value.
+* > 0: the 2-by-2 block (INFO:INFO+1) does not have a complex
+* eigenvalue.
+*
+* Further Details
+* ===============
+*
+* Allocation of workspace:
+* ---------- -- ---------
+*
+* WORK( j ) = 1-norm of j-th column of A, above the diagonal
+* WORK( N+j ) = 1-norm of j-th column of B, above the diagonal
+* WORK( 2*N+1:3*N ) = real part of eigenvector
+* WORK( 3*N+1:4*N ) = imaginary part of eigenvector
+* WORK( 4*N+1:5*N ) = real part of back-transformed eigenvector
+* WORK( 5*N+1:6*N ) = imaginary part of back-transformed eigenvector
+*
+* Rowwise vs. columnwise solution methods:
+* ------- -- ---------- -------- -------
+*
+* Finding a generalized eigenvector consists basically of solving the
+* singular triangular system
+*
+* (A - w B) x = 0 (for right) or: (A - w B)**H y = 0 (for left)
+*
+* Consider finding the i-th right eigenvector (assume all eigenvalues
+* are real). The equation to be solved is:
+* n i
+* 0 = sum C(j,k) v(k) = sum C(j,k) v(k) for j = i,. . .,1
+* k=j k=j
+*
+* where C = (A - w B) (The components v(i+1:n) are 0.)
+*
+* The "rowwise" method is:
+*
+* (1) v(i) := 1
+* for j = i-1,. . .,1:
+* i
+* (2) compute s = - sum C(j,k) v(k) and
+* k=j+1
+*
+* (3) v(j) := s / C(j,j)
+*
+* Step 2 is sometimes called the "dot product" step, since it is an
+* inner product between the j-th row and the portion of the eigenvector
+* that has been computed so far.
+*
+* The "columnwise" method consists basically in doing the sums
+* for all the rows in parallel. As each v(j) is computed, the
+* contribution of v(j) times the j-th column of C is added to the
+* partial sums. Since FORTRAN arrays are stored columnwise, this has
+* the advantage that at each step, the elements of C that are accessed
+* are adjacent to one another, whereas with the rowwise method, the
+* elements accessed at a step are spaced LDS (and LDP) words apart.
+*
+* When finding left eigenvectors, the matrix in question is the
+* transpose of the one in storage, so the rowwise method then
+* actually accesses columns of A and B at each step, and so is the
+* preferred method.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE, SAFETY
+ PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0,
+ $ SAFETY = 1.0D+2 )
+* ..
+* .. Local Scalars ..
+ LOGICAL COMPL, COMPR, IL2BY2, ILABAD, ILALL, ILBACK,
+ $ ILBBAD, ILCOMP, ILCPLX, LSA, LSB
+ INTEGER I, IBEG, IEIG, IEND, IHWMNY, IINFO, IM, ISIDE,
+ $ J, JA, JC, JE, JR, JW, NA, NW
+ DOUBLE PRECISION ACOEF, ACOEFA, ANORM, ASCALE, BCOEFA, BCOEFI,
+ $ BCOEFR, BIG, BIGNUM, BNORM, BSCALE, CIM2A,
+ $ CIM2B, CIMAGA, CIMAGB, CRE2A, CRE2B, CREALA,
+ $ CREALB, DMIN, SAFMIN, SALFAR, SBETA, SCALE,
+ $ SMALL, TEMP, TEMP2, TEMP2I, TEMP2R, ULP, XMAX,
+ $ XSCALE
+* ..
+* .. Local Arrays ..
+ DOUBLE PRECISION BDIAG( 2 ), SUM( 2, 2 ), SUMS( 2, 2 ),
+ $ SUMP( 2, 2 )
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ DOUBLE PRECISION DLAMCH
+ EXTERNAL LSAME, DLAMCH
+* ..
+* .. External Subroutines ..
+ EXTERNAL DGEMV, DLABAD, DLACPY, DLAG2, DLALN2, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+* Decode and Test the input parameters
+*
+ IF( LSAME( HOWMNY, 'A' ) ) THEN
+ IHWMNY = 1
+ ILALL = .TRUE.
+ ILBACK = .FALSE.
+ ELSE IF( LSAME( HOWMNY, 'S' ) ) THEN
+ IHWMNY = 2
+ ILALL = .FALSE.
+ ILBACK = .FALSE.
+ ELSE IF( LSAME( HOWMNY, 'B' ) ) THEN
+ IHWMNY = 3
+ ILALL = .TRUE.
+ ILBACK = .TRUE.
+ ELSE
+ IHWMNY = -1
+ ILALL = .TRUE.
+ END IF
+*
+ IF( LSAME( SIDE, 'R' ) ) THEN
+ ISIDE = 1
+ COMPL = .FALSE.
+ COMPR = .TRUE.
+ ELSE IF( LSAME( SIDE, 'L' ) ) THEN
+ ISIDE = 2
+ COMPL = .TRUE.
+ COMPR = .FALSE.
+ ELSE IF( LSAME( SIDE, 'B' ) ) THEN
+ ISIDE = 3
+ COMPL = .TRUE.
+ COMPR = .TRUE.
+ ELSE
+ ISIDE = -1
+ END IF
+*
+ INFO = 0
+ IF( ISIDE.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( IHWMNY.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( LDS.LT.MAX( 1, N ) ) THEN
+ INFO = -6
+ ELSE IF( LDP.LT.MAX( 1, N ) ) THEN
+ INFO = -8
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DTGEVC', -INFO )
+ RETURN
+ END IF
+*
+* Count the number of eigenvectors to be computed
+*
+ IF( .NOT.ILALL ) THEN
+ IM = 0
+ ILCPLX = .FALSE.
+ DO 10 J = 1, N
+ IF( ILCPLX ) THEN
+ ILCPLX = .FALSE.
+ GO TO 10
+ END IF
+ IF( J.LT.N ) THEN
+ IF( S( J+1, J ).NE.ZERO )
+ $ ILCPLX = .TRUE.
+ END IF
+ IF( ILCPLX ) THEN
+ IF( SELECT( J ) .OR. SELECT( J+1 ) )
+ $ IM = IM + 2
+ ELSE
+ IF( SELECT( J ) )
+ $ IM = IM + 1
+ END IF
+ 10 CONTINUE
+ ELSE
+ IM = N
+ END IF
+*
+* Check 2-by-2 diagonal blocks of A, B
+*
+ ILABAD = .FALSE.
+ ILBBAD = .FALSE.
+ DO 20 J = 1, N - 1
+ IF( S( J+1, J ).NE.ZERO ) THEN
+ IF( P( J, J ).EQ.ZERO .OR. P( J+1, J+1 ).EQ.ZERO .OR.
+ $ P( J, J+1 ).NE.ZERO )ILBBAD = .TRUE.
+ IF( J.LT.N-1 ) THEN
+ IF( S( J+2, J+1 ).NE.ZERO )
+ $ ILABAD = .TRUE.
+ END IF
+ END IF
+ 20 CONTINUE
+*
+ IF( ILABAD ) THEN
+ INFO = -5
+ ELSE IF( ILBBAD ) THEN
+ INFO = -7
+ ELSE IF( COMPL .AND. LDVL.LT.N .OR. LDVL.LT.1 ) THEN
+ INFO = -10
+ ELSE IF( COMPR .AND. LDVR.LT.N .OR. LDVR.LT.1 ) THEN
+ INFO = -12
+ ELSE IF( MM.LT.IM ) THEN
+ INFO = -13
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DTGEVC', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ M = IM
+ IF( N.EQ.0 )
+ $ RETURN
+*
+* Machine Constants
+*
+ SAFMIN = DLAMCH( 'Safe minimum' )
+ BIG = ONE / SAFMIN
+ CALL DLABAD( SAFMIN, BIG )
+ ULP = DLAMCH( 'Epsilon' )*DLAMCH( 'Base' )
+ SMALL = SAFMIN*N / ULP
+ BIG = ONE / SMALL
+ BIGNUM = ONE / ( SAFMIN*N )
+*
+* Compute the 1-norm of each column of the strictly upper triangular
+* part (i.e., excluding all elements belonging to the diagonal
+* blocks) of A and B to check for possible overflow in the
+* triangular solver.
+*
+ ANORM = ABS( S( 1, 1 ) )
+ IF( N.GT.1 )
+ $ ANORM = ANORM + ABS( S( 2, 1 ) )
+ BNORM = ABS( P( 1, 1 ) )
+ WORK( 1 ) = ZERO
+ WORK( N+1 ) = ZERO
+*
+ DO 50 J = 2, N
+ TEMP = ZERO
+ TEMP2 = ZERO
+ IF( S( J, J-1 ).EQ.ZERO ) THEN
+ IEND = J - 1
+ ELSE
+ IEND = J - 2
+ END IF
+ DO 30 I = 1, IEND
+ TEMP = TEMP + ABS( S( I, J ) )
+ TEMP2 = TEMP2 + ABS( P( I, J ) )
+ 30 CONTINUE
+ WORK( J ) = TEMP
+ WORK( N+J ) = TEMP2
+ DO 40 I = IEND + 1, MIN( J+1, N )
+ TEMP = TEMP + ABS( S( I, J ) )
+ TEMP2 = TEMP2 + ABS( P( I, J ) )
+ 40 CONTINUE
+ ANORM = MAX( ANORM, TEMP )
+ BNORM = MAX( BNORM, TEMP2 )
+ 50 CONTINUE
+*
+ ASCALE = ONE / MAX( ANORM, SAFMIN )
+ BSCALE = ONE / MAX( BNORM, SAFMIN )
+*
+* Left eigenvectors
+*
+ IF( COMPL ) THEN
+ IEIG = 0
+*
+* Main loop over eigenvalues
+*
+ ILCPLX = .FALSE.
+ DO 220 JE = 1, N
+*
+* Skip this iteration if (a) HOWMNY='S' and SELECT=.FALSE., or
+* (b) this would be the second of a complex pair.
+* Check for complex eigenvalue, so as to be sure of which
+* entry(-ies) of SELECT to look at.
+*
+ IF( ILCPLX ) THEN
+ ILCPLX = .FALSE.
+ GO TO 220
+ END IF
+ NW = 1
+ IF( JE.LT.N ) THEN
+ IF( S( JE+1, JE ).NE.ZERO ) THEN
+ ILCPLX = .TRUE.
+ NW = 2
+ END IF
+ END IF
+ IF( ILALL ) THEN
+ ILCOMP = .TRUE.
+ ELSE IF( ILCPLX ) THEN
+ ILCOMP = SELECT( JE ) .OR. SELECT( JE+1 )
+ ELSE
+ ILCOMP = SELECT( JE )
+ END IF
+ IF( .NOT.ILCOMP )
+ $ GO TO 220
+*
+* Decide if (a) singular pencil, (b) real eigenvalue, or
+* (c) complex eigenvalue.
+*
+ IF( .NOT.ILCPLX ) THEN
+ IF( ABS( S( JE, JE ) ).LE.SAFMIN .AND.
+ $ ABS( P( JE, JE ) ).LE.SAFMIN ) THEN
+*
+* Singular matrix pencil -- return unit eigenvector
+*
+ IEIG = IEIG + 1
+ DO 60 JR = 1, N
+ VL( JR, IEIG ) = ZERO
+ 60 CONTINUE
+ VL( IEIG, IEIG ) = ONE
+ GO TO 220
+ END IF
+ END IF
+*
+* Clear vector
+*
+ DO 70 JR = 1, NW*N
+ WORK( 2*N+JR ) = ZERO
+ 70 CONTINUE
+* T
+* Compute coefficients in ( a A - b B ) y = 0
+* a is ACOEF
+* b is BCOEFR + i*BCOEFI
+*
+ IF( .NOT.ILCPLX ) THEN
+*
+* Real eigenvalue
+*
+ TEMP = ONE / MAX( ABS( S( JE, JE ) )*ASCALE,
+ $ ABS( P( JE, JE ) )*BSCALE, SAFMIN )
+ SALFAR = ( TEMP*S( JE, JE ) )*ASCALE
+ SBETA = ( TEMP*P( JE, JE ) )*BSCALE
+ ACOEF = SBETA*ASCALE
+ BCOEFR = SALFAR*BSCALE
+ BCOEFI = ZERO
+*
+* Scale to avoid underflow
+*
+ SCALE = ONE
+ LSA = ABS( SBETA ).GE.SAFMIN .AND. ABS( ACOEF ).LT.SMALL
+ LSB = ABS( SALFAR ).GE.SAFMIN .AND. ABS( BCOEFR ).LT.
+ $ SMALL
+ IF( LSA )
+ $ SCALE = ( SMALL / ABS( SBETA ) )*MIN( ANORM, BIG )
+ IF( LSB )
+ $ SCALE = MAX( SCALE, ( SMALL / ABS( SALFAR ) )*
+ $ MIN( BNORM, BIG ) )
+ IF( LSA .OR. LSB ) THEN
+ SCALE = MIN( SCALE, ONE /
+ $ ( SAFMIN*MAX( ONE, ABS( ACOEF ),
+ $ ABS( BCOEFR ) ) ) )
+ IF( LSA ) THEN
+ ACOEF = ASCALE*( SCALE*SBETA )
+ ELSE
+ ACOEF = SCALE*ACOEF
+ END IF
+ IF( LSB ) THEN
+ BCOEFR = BSCALE*( SCALE*SALFAR )
+ ELSE
+ BCOEFR = SCALE*BCOEFR
+ END IF
+ END IF
+ ACOEFA = ABS( ACOEF )
+ BCOEFA = ABS( BCOEFR )
+*
+* First component is 1
+*
+ WORK( 2*N+JE ) = ONE
+ XMAX = ONE
+ ELSE
+*
+* Complex eigenvalue
+*
+ CALL DLAG2( S( JE, JE ), LDS, P( JE, JE ), LDP,
+ $ SAFMIN*SAFETY, ACOEF, TEMP, BCOEFR, TEMP2,
+ $ BCOEFI )
+ BCOEFI = -BCOEFI
+ IF( BCOEFI.EQ.ZERO ) THEN
+ INFO = JE
+ RETURN
+ END IF
+*
+* Scale to avoid over/underflow
+*
+ ACOEFA = ABS( ACOEF )
+ BCOEFA = ABS( BCOEFR ) + ABS( BCOEFI )
+ SCALE = ONE
+ IF( ACOEFA*ULP.LT.SAFMIN .AND. ACOEFA.GE.SAFMIN )
+ $ SCALE = ( SAFMIN / ULP ) / ACOEFA
+ IF( BCOEFA*ULP.LT.SAFMIN .AND. BCOEFA.GE.SAFMIN )
+ $ SCALE = MAX( SCALE, ( SAFMIN / ULP ) / BCOEFA )
+ IF( SAFMIN*ACOEFA.GT.ASCALE )
+ $ SCALE = ASCALE / ( SAFMIN*ACOEFA )
+ IF( SAFMIN*BCOEFA.GT.BSCALE )
+ $ SCALE = MIN( SCALE, BSCALE / ( SAFMIN*BCOEFA ) )
+ IF( SCALE.NE.ONE ) THEN
+ ACOEF = SCALE*ACOEF
+ ACOEFA = ABS( ACOEF )
+ BCOEFR = SCALE*BCOEFR
+ BCOEFI = SCALE*BCOEFI
+ BCOEFA = ABS( BCOEFR ) + ABS( BCOEFI )
+ END IF
+*
+* Compute first two components of eigenvector
+*
+ TEMP = ACOEF*S( JE+1, JE )
+ TEMP2R = ACOEF*S( JE, JE ) - BCOEFR*P( JE, JE )
+ TEMP2I = -BCOEFI*P( JE, JE )
+ IF( ABS( TEMP ).GT.ABS( TEMP2R )+ABS( TEMP2I ) ) THEN
+ WORK( 2*N+JE ) = ONE
+ WORK( 3*N+JE ) = ZERO
+ WORK( 2*N+JE+1 ) = -TEMP2R / TEMP
+ WORK( 3*N+JE+1 ) = -TEMP2I / TEMP
+ ELSE
+ WORK( 2*N+JE+1 ) = ONE
+ WORK( 3*N+JE+1 ) = ZERO
+ TEMP = ACOEF*S( JE, JE+1 )
+ WORK( 2*N+JE ) = ( BCOEFR*P( JE+1, JE+1 )-ACOEF*
+ $ S( JE+1, JE+1 ) ) / TEMP
+ WORK( 3*N+JE ) = BCOEFI*P( JE+1, JE+1 ) / TEMP
+ END IF
+ XMAX = MAX( ABS( WORK( 2*N+JE ) )+ABS( WORK( 3*N+JE ) ),
+ $ ABS( WORK( 2*N+JE+1 ) )+ABS( WORK( 3*N+JE+1 ) ) )
+ END IF
+*
+ DMIN = MAX( ULP*ACOEFA*ANORM, ULP*BCOEFA*BNORM, SAFMIN )
+*
+* T
+* Triangular solve of (a A - b B) y = 0
+*
+* T
+* (rowwise in (a A - b B) , or columnwise in (a A - b B) )
+*
+ IL2BY2 = .FALSE.
+*
+ DO 160 J = JE + NW, N
+ IF( IL2BY2 ) THEN
+ IL2BY2 = .FALSE.
+ GO TO 160
+ END IF
+*
+ NA = 1
+ BDIAG( 1 ) = P( J, J )
+ IF( J.LT.N ) THEN
+ IF( S( J+1, J ).NE.ZERO ) THEN
+ IL2BY2 = .TRUE.
+ BDIAG( 2 ) = P( J+1, J+1 )
+ NA = 2
+ END IF
+ END IF
+*
+* Check whether scaling is necessary for dot products
+*
+ XSCALE = ONE / MAX( ONE, XMAX )
+ TEMP = MAX( WORK( J ), WORK( N+J ),
+ $ ACOEFA*WORK( J )+BCOEFA*WORK( N+J ) )
+ IF( IL2BY2 )
+ $ TEMP = MAX( TEMP, WORK( J+1 ), WORK( N+J+1 ),
+ $ ACOEFA*WORK( J+1 )+BCOEFA*WORK( N+J+1 ) )
+ IF( TEMP.GT.BIGNUM*XSCALE ) THEN
+ DO 90 JW = 0, NW - 1
+ DO 80 JR = JE, J - 1
+ WORK( ( JW+2 )*N+JR ) = XSCALE*
+ $ WORK( ( JW+2 )*N+JR )
+ 80 CONTINUE
+ 90 CONTINUE
+ XMAX = XMAX*XSCALE
+ END IF
+*
+* Compute dot products
+*
+* j-1
+* SUM = sum conjg( a*S(k,j) - b*P(k,j) )*x(k)
+* k=je
+*
+* To reduce the op count, this is done as
+*
+* _ j-1 _ j-1
+* a*conjg( sum S(k,j)*x(k) ) - b*conjg( sum P(k,j)*x(k) )
+* k=je k=je
+*
+* which may cause underflow problems if A or B are close
+* to underflow. (E.g., less than SMALL.)
+*
+*
+* A series of compiler directives to defeat vectorization
+* for the next loop
+*
+*$PL$ CMCHAR=' '
+CDIR$ NEXTSCALAR
+C$DIR SCALAR
+CDIR$ NEXT SCALAR
+CVD$L NOVECTOR
+CDEC$ NOVECTOR
+CVD$ NOVECTOR
+*VDIR NOVECTOR
+*VOCL LOOP,SCALAR
+CIBM PREFER SCALAR
+*$PL$ CMCHAR='*'
+*
+ DO 120 JW = 1, NW
+*
+*$PL$ CMCHAR=' '
+CDIR$ NEXTSCALAR
+C$DIR SCALAR
+CDIR$ NEXT SCALAR
+CVD$L NOVECTOR
+CDEC$ NOVECTOR
+CVD$ NOVECTOR
+*VDIR NOVECTOR
+*VOCL LOOP,SCALAR
+CIBM PREFER SCALAR
+*$PL$ CMCHAR='*'
+*
+ DO 110 JA = 1, NA
+ SUMS( JA, JW ) = ZERO
+ SUMP( JA, JW ) = ZERO
+*
+ DO 100 JR = JE, J - 1
+ SUMS( JA, JW ) = SUMS( JA, JW ) +
+ $ S( JR, J+JA-1 )*
+ $ WORK( ( JW+1 )*N+JR )
+ SUMP( JA, JW ) = SUMP( JA, JW ) +
+ $ P( JR, J+JA-1 )*
+ $ WORK( ( JW+1 )*N+JR )
+ 100 CONTINUE
+ 110 CONTINUE
+ 120 CONTINUE
+*
+*$PL$ CMCHAR=' '
+CDIR$ NEXTSCALAR
+C$DIR SCALAR
+CDIR$ NEXT SCALAR
+CVD$L NOVECTOR
+CDEC$ NOVECTOR
+CVD$ NOVECTOR
+*VDIR NOVECTOR
+*VOCL LOOP,SCALAR
+CIBM PREFER SCALAR
+*$PL$ CMCHAR='*'
+*
+ DO 130 JA = 1, NA
+ IF( ILCPLX ) THEN
+ SUM( JA, 1 ) = -ACOEF*SUMS( JA, 1 ) +
+ $ BCOEFR*SUMP( JA, 1 ) -
+ $ BCOEFI*SUMP( JA, 2 )
+ SUM( JA, 2 ) = -ACOEF*SUMS( JA, 2 ) +
+ $ BCOEFR*SUMP( JA, 2 ) +
+ $ BCOEFI*SUMP( JA, 1 )
+ ELSE
+ SUM( JA, 1 ) = -ACOEF*SUMS( JA, 1 ) +
+ $ BCOEFR*SUMP( JA, 1 )
+ END IF
+ 130 CONTINUE
+*
+* T
+* Solve ( a A - b B ) y = SUM(,)
+* with scaling and perturbation of the denominator
+*
+ CALL DLALN2( .TRUE., NA, NW, DMIN, ACOEF, S( J, J ), LDS,
+ $ BDIAG( 1 ), BDIAG( 2 ), SUM, 2, BCOEFR,
+ $ BCOEFI, WORK( 2*N+J ), N, SCALE, TEMP,
+ $ IINFO )
+ IF( SCALE.LT.ONE ) THEN
+ DO 150 JW = 0, NW - 1
+ DO 140 JR = JE, J - 1
+ WORK( ( JW+2 )*N+JR ) = SCALE*
+ $ WORK( ( JW+2 )*N+JR )
+ 140 CONTINUE
+ 150 CONTINUE
+ XMAX = SCALE*XMAX
+ END IF
+ XMAX = MAX( XMAX, TEMP )
+ 160 CONTINUE
+*
+* Copy eigenvector to VL, back transforming if
+* HOWMNY='B'.
+*
+ IEIG = IEIG + 1
+ IF( ILBACK ) THEN
+ DO 170 JW = 0, NW - 1
+ CALL DGEMV( 'N', N, N+1-JE, ONE, VL( 1, JE ), LDVL,
+ $ WORK( ( JW+2 )*N+JE ), 1, ZERO,
+ $ WORK( ( JW+4 )*N+1 ), 1 )
+ 170 CONTINUE
+ CALL DLACPY( ' ', N, NW, WORK( 4*N+1 ), N, VL( 1, JE ),
+ $ LDVL )
+ IBEG = 1
+ ELSE
+ CALL DLACPY( ' ', N, NW, WORK( 2*N+1 ), N, VL( 1, IEIG ),
+ $ LDVL )
+ IBEG = JE
+ END IF
+*
+* Scale eigenvector
+*
+ XMAX = ZERO
+ IF( ILCPLX ) THEN
+ DO 180 J = IBEG, N
+ XMAX = MAX( XMAX, ABS( VL( J, IEIG ) )+
+ $ ABS( VL( J, IEIG+1 ) ) )
+ 180 CONTINUE
+ ELSE
+ DO 190 J = IBEG, N
+ XMAX = MAX( XMAX, ABS( VL( J, IEIG ) ) )
+ 190 CONTINUE
+ END IF
+*
+ IF( XMAX.GT.SAFMIN ) THEN
+ XSCALE = ONE / XMAX
+*
+ DO 210 JW = 0, NW - 1
+ DO 200 JR = IBEG, N
+ VL( JR, IEIG+JW ) = XSCALE*VL( JR, IEIG+JW )
+ 200 CONTINUE
+ 210 CONTINUE
+ END IF
+ IEIG = IEIG + NW - 1
+*
+ 220 CONTINUE
+ END IF
+*
+* Right eigenvectors
+*
+ IF( COMPR ) THEN
+ IEIG = IM + 1
+*
+* Main loop over eigenvalues
+*
+ ILCPLX = .FALSE.
+ DO 500 JE = N, 1, -1
+*
+* Skip this iteration if (a) HOWMNY='S' and SELECT=.FALSE., or
+* (b) this would be the second of a complex pair.
+* Check for complex eigenvalue, so as to be sure of which
+* entry(-ies) of SELECT to look at -- if complex, SELECT(JE)
+* or SELECT(JE-1).
+* If this is a complex pair, the 2-by-2 diagonal block
+* corresponding to the eigenvalue is in rows/columns JE-1:JE
+*
+ IF( ILCPLX ) THEN
+ ILCPLX = .FALSE.
+ GO TO 500
+ END IF
+ NW = 1
+ IF( JE.GT.1 ) THEN
+ IF( S( JE, JE-1 ).NE.ZERO ) THEN
+ ILCPLX = .TRUE.
+ NW = 2
+ END IF
+ END IF
+ IF( ILALL ) THEN
+ ILCOMP = .TRUE.
+ ELSE IF( ILCPLX ) THEN
+ ILCOMP = SELECT( JE ) .OR. SELECT( JE-1 )
+ ELSE
+ ILCOMP = SELECT( JE )
+ END IF
+ IF( .NOT.ILCOMP )
+ $ GO TO 500
+*
+* Decide if (a) singular pencil, (b) real eigenvalue, or
+* (c) complex eigenvalue.
+*
+ IF( .NOT.ILCPLX ) THEN
+ IF( ABS( S( JE, JE ) ).LE.SAFMIN .AND.
+ $ ABS( P( JE, JE ) ).LE.SAFMIN ) THEN
+*
+* Singular matrix pencil -- unit eigenvector
+*
+ IEIG = IEIG - 1
+ DO 230 JR = 1, N
+ VR( JR, IEIG ) = ZERO
+ 230 CONTINUE
+ VR( IEIG, IEIG ) = ONE
+ GO TO 500
+ END IF
+ END IF
+*
+* Clear vector
+*
+ DO 250 JW = 0, NW - 1
+ DO 240 JR = 1, N
+ WORK( ( JW+2 )*N+JR ) = ZERO
+ 240 CONTINUE
+ 250 CONTINUE
+*
+* Compute coefficients in ( a A - b B ) x = 0
+* a is ACOEF
+* b is BCOEFR + i*BCOEFI
+*
+ IF( .NOT.ILCPLX ) THEN
+*
+* Real eigenvalue
+*
+ TEMP = ONE / MAX( ABS( S( JE, JE ) )*ASCALE,
+ $ ABS( P( JE, JE ) )*BSCALE, SAFMIN )
+ SALFAR = ( TEMP*S( JE, JE ) )*ASCALE
+ SBETA = ( TEMP*P( JE, JE ) )*BSCALE
+ ACOEF = SBETA*ASCALE
+ BCOEFR = SALFAR*BSCALE
+ BCOEFI = ZERO
+*
+* Scale to avoid underflow
+*
+ SCALE = ONE
+ LSA = ABS( SBETA ).GE.SAFMIN .AND. ABS( ACOEF ).LT.SMALL
+ LSB = ABS( SALFAR ).GE.SAFMIN .AND. ABS( BCOEFR ).LT.
+ $ SMALL
+ IF( LSA )
+ $ SCALE = ( SMALL / ABS( SBETA ) )*MIN( ANORM, BIG )
+ IF( LSB )
+ $ SCALE = MAX( SCALE, ( SMALL / ABS( SALFAR ) )*
+ $ MIN( BNORM, BIG ) )
+ IF( LSA .OR. LSB ) THEN
+ SCALE = MIN( SCALE, ONE /
+ $ ( SAFMIN*MAX( ONE, ABS( ACOEF ),
+ $ ABS( BCOEFR ) ) ) )
+ IF( LSA ) THEN
+ ACOEF = ASCALE*( SCALE*SBETA )
+ ELSE
+ ACOEF = SCALE*ACOEF
+ END IF
+ IF( LSB ) THEN
+ BCOEFR = BSCALE*( SCALE*SALFAR )
+ ELSE
+ BCOEFR = SCALE*BCOEFR
+ END IF
+ END IF
+ ACOEFA = ABS( ACOEF )
+ BCOEFA = ABS( BCOEFR )
+*
+* First component is 1
+*
+ WORK( 2*N+JE ) = ONE
+ XMAX = ONE
+*
+* Compute contribution from column JE of A and B to sum
+* (See "Further Details", above.)
+*
+ DO 260 JR = 1, JE - 1
+ WORK( 2*N+JR ) = BCOEFR*P( JR, JE ) -
+ $ ACOEF*S( JR, JE )
+ 260 CONTINUE
+ ELSE
+*
+* Complex eigenvalue
+*
+ CALL DLAG2( S( JE-1, JE-1 ), LDS, P( JE-1, JE-1 ), LDP,
+ $ SAFMIN*SAFETY, ACOEF, TEMP, BCOEFR, TEMP2,
+ $ BCOEFI )
+ IF( BCOEFI.EQ.ZERO ) THEN
+ INFO = JE - 1
+ RETURN
+ END IF
+*
+* Scale to avoid over/underflow
+*
+ ACOEFA = ABS( ACOEF )
+ BCOEFA = ABS( BCOEFR ) + ABS( BCOEFI )
+ SCALE = ONE
+ IF( ACOEFA*ULP.LT.SAFMIN .AND. ACOEFA.GE.SAFMIN )
+ $ SCALE = ( SAFMIN / ULP ) / ACOEFA
+ IF( BCOEFA*ULP.LT.SAFMIN .AND. BCOEFA.GE.SAFMIN )
+ $ SCALE = MAX( SCALE, ( SAFMIN / ULP ) / BCOEFA )
+ IF( SAFMIN*ACOEFA.GT.ASCALE )
+ $ SCALE = ASCALE / ( SAFMIN*ACOEFA )
+ IF( SAFMIN*BCOEFA.GT.BSCALE )
+ $ SCALE = MIN( SCALE, BSCALE / ( SAFMIN*BCOEFA ) )
+ IF( SCALE.NE.ONE ) THEN
+ ACOEF = SCALE*ACOEF
+ ACOEFA = ABS( ACOEF )
+ BCOEFR = SCALE*BCOEFR
+ BCOEFI = SCALE*BCOEFI
+ BCOEFA = ABS( BCOEFR ) + ABS( BCOEFI )
+ END IF
+*
+* Compute first two components of eigenvector
+* and contribution to sums
+*
+ TEMP = ACOEF*S( JE, JE-1 )
+ TEMP2R = ACOEF*S( JE, JE ) - BCOEFR*P( JE, JE )
+ TEMP2I = -BCOEFI*P( JE, JE )
+ IF( ABS( TEMP ).GE.ABS( TEMP2R )+ABS( TEMP2I ) ) THEN
+ WORK( 2*N+JE ) = ONE
+ WORK( 3*N+JE ) = ZERO
+ WORK( 2*N+JE-1 ) = -TEMP2R / TEMP
+ WORK( 3*N+JE-1 ) = -TEMP2I / TEMP
+ ELSE
+ WORK( 2*N+JE-1 ) = ONE
+ WORK( 3*N+JE-1 ) = ZERO
+ TEMP = ACOEF*S( JE-1, JE )
+ WORK( 2*N+JE ) = ( BCOEFR*P( JE-1, JE-1 )-ACOEF*
+ $ S( JE-1, JE-1 ) ) / TEMP
+ WORK( 3*N+JE ) = BCOEFI*P( JE-1, JE-1 ) / TEMP
+ END IF
+*
+ XMAX = MAX( ABS( WORK( 2*N+JE ) )+ABS( WORK( 3*N+JE ) ),
+ $ ABS( WORK( 2*N+JE-1 ) )+ABS( WORK( 3*N+JE-1 ) ) )
+*
+* Compute contribution from columns JE and JE-1
+* of A and B to the sums.
+*
+ CREALA = ACOEF*WORK( 2*N+JE-1 )
+ CIMAGA = ACOEF*WORK( 3*N+JE-1 )
+ CREALB = BCOEFR*WORK( 2*N+JE-1 ) -
+ $ BCOEFI*WORK( 3*N+JE-1 )
+ CIMAGB = BCOEFI*WORK( 2*N+JE-1 ) +
+ $ BCOEFR*WORK( 3*N+JE-1 )
+ CRE2A = ACOEF*WORK( 2*N+JE )
+ CIM2A = ACOEF*WORK( 3*N+JE )
+ CRE2B = BCOEFR*WORK( 2*N+JE ) - BCOEFI*WORK( 3*N+JE )
+ CIM2B = BCOEFI*WORK( 2*N+JE ) + BCOEFR*WORK( 3*N+JE )
+ DO 270 JR = 1, JE - 2
+ WORK( 2*N+JR ) = -CREALA*S( JR, JE-1 ) +
+ $ CREALB*P( JR, JE-1 ) -
+ $ CRE2A*S( JR, JE ) + CRE2B*P( JR, JE )
+ WORK( 3*N+JR ) = -CIMAGA*S( JR, JE-1 ) +
+ $ CIMAGB*P( JR, JE-1 ) -
+ $ CIM2A*S( JR, JE ) + CIM2B*P( JR, JE )
+ 270 CONTINUE
+ END IF
+*
+ DMIN = MAX( ULP*ACOEFA*ANORM, ULP*BCOEFA*BNORM, SAFMIN )
+*
+* Columnwise triangular solve of (a A - b B) x = 0
+*
+ IL2BY2 = .FALSE.
+ DO 370 J = JE - NW, 1, -1
+*
+* If a 2-by-2 block, is in position j-1:j, wait until
+* next iteration to process it (when it will be j:j+1)
+*
+ IF( .NOT.IL2BY2 .AND. J.GT.1 ) THEN
+ IF( S( J, J-1 ).NE.ZERO ) THEN
+ IL2BY2 = .TRUE.
+ GO TO 370
+ END IF
+ END IF
+ BDIAG( 1 ) = P( J, J )
+ IF( IL2BY2 ) THEN
+ NA = 2
+ BDIAG( 2 ) = P( J+1, J+1 )
+ ELSE
+ NA = 1
+ END IF
+*
+* Compute x(j) (and x(j+1), if 2-by-2 block)
+*
+ CALL DLALN2( .FALSE., NA, NW, DMIN, ACOEF, S( J, J ),
+ $ LDS, BDIAG( 1 ), BDIAG( 2 ), WORK( 2*N+J ),
+ $ N, BCOEFR, BCOEFI, SUM, 2, SCALE, TEMP,
+ $ IINFO )
+ IF( SCALE.LT.ONE ) THEN
+*
+ DO 290 JW = 0, NW - 1
+ DO 280 JR = 1, JE
+ WORK( ( JW+2 )*N+JR ) = SCALE*
+ $ WORK( ( JW+2 )*N+JR )
+ 280 CONTINUE
+ 290 CONTINUE
+ END IF
+ XMAX = MAX( SCALE*XMAX, TEMP )
+*
+ DO 310 JW = 1, NW
+ DO 300 JA = 1, NA
+ WORK( ( JW+1 )*N+J+JA-1 ) = SUM( JA, JW )
+ 300 CONTINUE
+ 310 CONTINUE
+*
+* w = w + x(j)*(a S(*,j) - b P(*,j) ) with scaling
+*
+ IF( J.GT.1 ) THEN
+*
+* Check whether scaling is necessary for sum.
+*
+ XSCALE = ONE / MAX( ONE, XMAX )
+ TEMP = ACOEFA*WORK( J ) + BCOEFA*WORK( N+J )
+ IF( IL2BY2 )
+ $ TEMP = MAX( TEMP, ACOEFA*WORK( J+1 )+BCOEFA*
+ $ WORK( N+J+1 ) )
+ TEMP = MAX( TEMP, ACOEFA, BCOEFA )
+ IF( TEMP.GT.BIGNUM*XSCALE ) THEN
+*
+ DO 330 JW = 0, NW - 1
+ DO 320 JR = 1, JE
+ WORK( ( JW+2 )*N+JR ) = XSCALE*
+ $ WORK( ( JW+2 )*N+JR )
+ 320 CONTINUE
+ 330 CONTINUE
+ XMAX = XMAX*XSCALE
+ END IF
+*
+* Compute the contributions of the off-diagonals of
+* column j (and j+1, if 2-by-2 block) of A and B to the
+* sums.
+*
+*
+ DO 360 JA = 1, NA
+ IF( ILCPLX ) THEN
+ CREALA = ACOEF*WORK( 2*N+J+JA-1 )
+ CIMAGA = ACOEF*WORK( 3*N+J+JA-1 )
+ CREALB = BCOEFR*WORK( 2*N+J+JA-1 ) -
+ $ BCOEFI*WORK( 3*N+J+JA-1 )
+ CIMAGB = BCOEFI*WORK( 2*N+J+JA-1 ) +
+ $ BCOEFR*WORK( 3*N+J+JA-1 )
+ DO 340 JR = 1, J - 1
+ WORK( 2*N+JR ) = WORK( 2*N+JR ) -
+ $ CREALA*S( JR, J+JA-1 ) +
+ $ CREALB*P( JR, J+JA-1 )
+ WORK( 3*N+JR ) = WORK( 3*N+JR ) -
+ $ CIMAGA*S( JR, J+JA-1 ) +
+ $ CIMAGB*P( JR, J+JA-1 )
+ 340 CONTINUE
+ ELSE
+ CREALA = ACOEF*WORK( 2*N+J+JA-1 )
+ CREALB = BCOEFR*WORK( 2*N+J+JA-1 )
+ DO 350 JR = 1, J - 1
+ WORK( 2*N+JR ) = WORK( 2*N+JR ) -
+ $ CREALA*S( JR, J+JA-1 ) +
+ $ CREALB*P( JR, J+JA-1 )
+ 350 CONTINUE
+ END IF
+ 360 CONTINUE
+ END IF
+*
+ IL2BY2 = .FALSE.
+ 370 CONTINUE
+*
+* Copy eigenvector to VR, back transforming if
+* HOWMNY='B'.
+*
+ IEIG = IEIG - NW
+ IF( ILBACK ) THEN
+*
+ DO 410 JW = 0, NW - 1
+ DO 380 JR = 1, N
+ WORK( ( JW+4 )*N+JR ) = WORK( ( JW+2 )*N+1 )*
+ $ VR( JR, 1 )
+ 380 CONTINUE
+*
+* A series of compiler directives to defeat
+* vectorization for the next loop
+*
+*
+ DO 400 JC = 2, JE
+ DO 390 JR = 1, N
+ WORK( ( JW+4 )*N+JR ) = WORK( ( JW+4 )*N+JR ) +
+ $ WORK( ( JW+2 )*N+JC )*VR( JR, JC )
+ 390 CONTINUE
+ 400 CONTINUE
+ 410 CONTINUE
+*
+ DO 430 JW = 0, NW - 1
+ DO 420 JR = 1, N
+ VR( JR, IEIG+JW ) = WORK( ( JW+4 )*N+JR )
+ 420 CONTINUE
+ 430 CONTINUE
+*
+ IEND = N
+ ELSE
+ DO 450 JW = 0, NW - 1
+ DO 440 JR = 1, N
+ VR( JR, IEIG+JW ) = WORK( ( JW+2 )*N+JR )
+ 440 CONTINUE
+ 450 CONTINUE
+*
+ IEND = JE
+ END IF
+*
+* Scale eigenvector
+*
+ XMAX = ZERO
+ IF( ILCPLX ) THEN
+ DO 460 J = 1, IEND
+ XMAX = MAX( XMAX, ABS( VR( J, IEIG ) )+
+ $ ABS( VR( J, IEIG+1 ) ) )
+ 460 CONTINUE
+ ELSE
+ DO 470 J = 1, IEND
+ XMAX = MAX( XMAX, ABS( VR( J, IEIG ) ) )
+ 470 CONTINUE
+ END IF
+*
+ IF( XMAX.GT.SAFMIN ) THEN
+ XSCALE = ONE / XMAX
+ DO 490 JW = 0, NW - 1
+ DO 480 JR = 1, IEND
+ VR( JR, IEIG+JW ) = XSCALE*VR( JR, IEIG+JW )
+ 480 CONTINUE
+ 490 CONTINUE
+ END IF
+ 500 CONTINUE
+ END IF
+*
+ RETURN
+*
+* End of DTGEVC
+*
+ END
+ SUBROUTINE DTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z,
+ $ LDZ, J1, N1, N2, WORK, LWORK, INFO )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ LOGICAL WANTQ, WANTZ
+ INTEGER INFO, J1, LDA, LDB, LDQ, LDZ, LWORK, N, N1, N2
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION A( LDA, * ), B( LDB, * ), Q( LDQ, * ),
+ $ WORK( * ), Z( LDZ, * )
+* ..
+*
+* Purpose
+* =======
+*
+* DTGEX2 swaps adjacent diagonal blocks (A11, B11) and (A22, B22)
+* of size 1-by-1 or 2-by-2 in an upper (quasi) triangular matrix pair
+* (A, B) by an orthogonal equivalence transformation.
+*
+* (A, B) must be in generalized real Schur canonical form (as returned
+* by DGGES), i.e. A is block upper triangular with 1-by-1 and 2-by-2
+* diagonal blocks. B is upper triangular.
+*
+* Optionally, the matrices Q and Z of generalized Schur vectors are
+* updated.
+*
+* Q(in) * A(in) * Z(in)' = Q(out) * A(out) * Z(out)'
+* Q(in) * B(in) * Z(in)' = Q(out) * B(out) * Z(out)'
+*
+*
+* Arguments
+* =========
+*
+* WANTQ (input) LOGICAL
+* .TRUE. : update the left transformation matrix Q;
+* .FALSE.: do not update Q.
+*
+* WANTZ (input) LOGICAL
+* .TRUE. : update the right transformation matrix Z;
+* .FALSE.: do not update Z.
+*
+* N (input) INTEGER
+* The order of the matrices A and B. N >= 0.
+*
+* A (input/output) DOUBLE PRECISION arrays, dimensions (LDA,N)
+* On entry, the matrix A in the pair (A, B).
+* On exit, the updated matrix A.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,N).
+*
+* B (input/output) DOUBLE PRECISION arrays, dimensions (LDB,N)
+* On entry, the matrix B in the pair (A, B).
+* On exit, the updated matrix B.
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. LDB >= max(1,N).
+*
+* Q (input/output) DOUBLE PRECISION array, dimension (LDZ,N)
+* On entry, if WANTQ = .TRUE., the orthogonal matrix Q.
+* On exit, the updated matrix Q.
+* Not referenced if WANTQ = .FALSE..
+*
+* LDQ (input) INTEGER
+* The leading dimension of the array Q. LDQ >= 1.
+* If WANTQ = .TRUE., LDQ >= N.
+*
+* Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N)
+* On entry, if WANTZ =.TRUE., the orthogonal matrix Z.
+* On exit, the updated matrix Z.
+* Not referenced if WANTZ = .FALSE..
+*
+* LDZ (input) INTEGER
+* The leading dimension of the array Z. LDZ >= 1.
+* If WANTZ = .TRUE., LDZ >= N.
+*
+* J1 (input) INTEGER
+* The index to the first block (A11, B11). 1 <= J1 <= N.
+*
+* N1 (input) INTEGER
+* The order of the first block (A11, B11). N1 = 0, 1 or 2.
+*
+* N2 (input) INTEGER
+* The order of the second block (A22, B22). N2 = 0, 1 or 2.
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (MAX(1,LWORK)).
+*
+* LWORK (input) INTEGER
+* The dimension of the array WORK.
+* LWORK >= MAX( 1, N*(N2+N1), (N2+N1)*(N2+N1)*2 )
+*
+* INFO (output) INTEGER
+* =0: Successful exit
+* >0: If INFO = 1, the transformed matrix (A, B) would be
+* too far from generalized Schur form; the blocks are
+* not swapped and (A, B) and (Q, Z) are unchanged.
+* The problem of swapping is too ill-conditioned.
+* <0: If INFO = -16: LWORK is too small. Appropriate value
+* for LWORK is returned in WORK(1).
+*
+* Further Details
+* ===============
+*
+* Based on contributions by
+* Bo Kagstrom and Peter Poromaa, Department of Computing Science,
+* Umea University, S-901 87 Umea, Sweden.
+*
+* In the current code both weak and strong stability tests are
+* performed. The user can omit the strong stability test by changing
+* the internal logical parameter WANDS to .FALSE.. See ref. [2] for
+* details.
+*
+* [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the
+* Generalized Real Schur Form of a Regular Matrix Pair (A, B), in
+* M.S. Moonen et al (eds), Linear Algebra for Large Scale and
+* Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218.
+*
+* [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified
+* Eigenvalues of a Regular Matrix Pair (A, B) and Condition
+* Estimation: Theory, Algorithms and Software,
+* Report UMINF - 94.04, Department of Computing Science, Umea
+* University, S-901 87 Umea, Sweden, 1994. Also as LAPACK Working
+* Note 87. To appear in Numerical Algorithms, 1996.
+*
+* =====================================================================
+* Replaced various illegal calls to DCOPY by calls to DLASET, or by DO
+* loops. Sven Hammarling, 1/5/02.
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+ DOUBLE PRECISION TEN
+ PARAMETER ( TEN = 1.0D+01 )
+ INTEGER LDST
+ PARAMETER ( LDST = 4 )
+ LOGICAL WANDS
+ PARAMETER ( WANDS = .TRUE. )
+* ..
+* .. Local Scalars ..
+ LOGICAL DTRONG, WEAK
+ INTEGER I, IDUM, LINFO, M
+ DOUBLE PRECISION BQRA21, BRQA21, DDUM, DNORM, DSCALE, DSUM, EPS,
+ $ F, G, SA, SB, SCALE, SMLNUM, SS, THRESH, WS
+* ..
+* .. Local Arrays ..
+ INTEGER IWORK( LDST )
+ DOUBLE PRECISION AI( 2 ), AR( 2 ), BE( 2 ), IR( LDST, LDST ),
+ $ IRCOP( LDST, LDST ), LI( LDST, LDST ),
+ $ LICOP( LDST, LDST ), S( LDST, LDST ),
+ $ SCPY( LDST, LDST ), T( LDST, LDST ),
+ $ TAUL( LDST ), TAUR( LDST ), TCPY( LDST, LDST )
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DLAMCH
+ EXTERNAL DLAMCH
+* ..
+* .. External Subroutines ..
+ EXTERNAL DGEMM, DGEQR2, DGERQ2, DLACPY, DLAGV2, DLARTG,
+ $ DLASET, DLASSQ, DORG2R, DORGR2, DORM2R, DORMR2,
+ $ DROT, DSCAL, DTGSY2
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, SQRT
+* ..
+* .. Executable Statements ..
+*
+ INFO = 0
+*
+* Quick return if possible
+*
+ IF( N.LE.1 .OR. N1.LE.0 .OR. N2.LE.0 )
+ $ RETURN
+ IF( N1.GT.N .OR. ( J1+N1 ).GT.N )
+ $ RETURN
+ M = N1 + N2
+ IF( LWORK.LT.MAX( 1, N*M, M*M*2 ) ) THEN
+ INFO = -16
+ WORK( 1 ) = MAX( 1, N*M, M*M*2 )
+ RETURN
+ END IF
+*
+ WEAK = .FALSE.
+ DTRONG = .FALSE.
+*
+* Make a local copy of selected block
+*
+ CALL DLASET( 'Full', LDST, LDST, ZERO, ZERO, LI, LDST )
+ CALL DLASET( 'Full', LDST, LDST, ZERO, ZERO, IR, LDST )
+ CALL DLACPY( 'Full', M, M, A( J1, J1 ), LDA, S, LDST )
+ CALL DLACPY( 'Full', M, M, B( J1, J1 ), LDB, T, LDST )
+*
+* Compute threshold for testing acceptance of swapping.
+*
+ EPS = DLAMCH( 'P' )
+ SMLNUM = DLAMCH( 'S' ) / EPS
+ DSCALE = ZERO
+ DSUM = ONE
+ CALL DLACPY( 'Full', M, M, S, LDST, WORK, M )
+ CALL DLASSQ( M*M, WORK, 1, DSCALE, DSUM )
+ CALL DLACPY( 'Full', M, M, T, LDST, WORK, M )
+ CALL DLASSQ( M*M, WORK, 1, DSCALE, DSUM )
+ DNORM = DSCALE*SQRT( DSUM )
+ THRESH = MAX( TEN*EPS*DNORM, SMLNUM )
+*
+ IF( M.EQ.2 ) THEN
+*
+* CASE 1: Swap 1-by-1 and 1-by-1 blocks.
+*
+* Compute orthogonal QL and RQ that swap 1-by-1 and 1-by-1 blocks
+* using Givens rotations and perform the swap tentatively.
+*
+ F = S( 2, 2 )*T( 1, 1 ) - T( 2, 2 )*S( 1, 1 )
+ G = S( 2, 2 )*T( 1, 2 ) - T( 2, 2 )*S( 1, 2 )
+ SB = ABS( T( 2, 2 ) )
+ SA = ABS( S( 2, 2 ) )
+ CALL DLARTG( F, G, IR( 1, 2 ), IR( 1, 1 ), DDUM )
+ IR( 2, 1 ) = -IR( 1, 2 )
+ IR( 2, 2 ) = IR( 1, 1 )
+ CALL DROT( 2, S( 1, 1 ), 1, S( 1, 2 ), 1, IR( 1, 1 ),
+ $ IR( 2, 1 ) )
+ CALL DROT( 2, T( 1, 1 ), 1, T( 1, 2 ), 1, IR( 1, 1 ),
+ $ IR( 2, 1 ) )
+ IF( SA.GE.SB ) THEN
+ CALL DLARTG( S( 1, 1 ), S( 2, 1 ), LI( 1, 1 ), LI( 2, 1 ),
+ $ DDUM )
+ ELSE
+ CALL DLARTG( T( 1, 1 ), T( 2, 1 ), LI( 1, 1 ), LI( 2, 1 ),
+ $ DDUM )
+ END IF
+ CALL DROT( 2, S( 1, 1 ), LDST, S( 2, 1 ), LDST, LI( 1, 1 ),
+ $ LI( 2, 1 ) )
+ CALL DROT( 2, T( 1, 1 ), LDST, T( 2, 1 ), LDST, LI( 1, 1 ),
+ $ LI( 2, 1 ) )
+ LI( 2, 2 ) = LI( 1, 1 )
+ LI( 1, 2 ) = -LI( 2, 1 )
+*
+* Weak stability test:
+* |S21| + |T21| <= O(EPS * F-norm((S, T)))
+*
+ WS = ABS( S( 2, 1 ) ) + ABS( T( 2, 1 ) )
+ WEAK = WS.LE.THRESH
+ IF( .NOT.WEAK )
+ $ GO TO 70
+*
+ IF( WANDS ) THEN
+*
+* Strong stability test:
+* F-norm((A-QL'*S*QR, B-QL'*T*QR)) <= O(EPS*F-norm((A,B)))
+*
+ CALL DLACPY( 'Full', M, M, A( J1, J1 ), LDA, WORK( M*M+1 ),
+ $ M )
+ CALL DGEMM( 'N', 'N', M, M, M, ONE, LI, LDST, S, LDST, ZERO,
+ $ WORK, M )
+ CALL DGEMM( 'N', 'T', M, M, M, -ONE, WORK, M, IR, LDST, ONE,
+ $ WORK( M*M+1 ), M )
+ DSCALE = ZERO
+ DSUM = ONE
+ CALL DLASSQ( M*M, WORK( M*M+1 ), 1, DSCALE, DSUM )
+*
+ CALL DLACPY( 'Full', M, M, B( J1, J1 ), LDB, WORK( M*M+1 ),
+ $ M )
+ CALL DGEMM( 'N', 'N', M, M, M, ONE, LI, LDST, T, LDST, ZERO,
+ $ WORK, M )
+ CALL DGEMM( 'N', 'T', M, M, M, -ONE, WORK, M, IR, LDST, ONE,
+ $ WORK( M*M+1 ), M )
+ CALL DLASSQ( M*M, WORK( M*M+1 ), 1, DSCALE, DSUM )
+ SS = DSCALE*SQRT( DSUM )
+ DTRONG = SS.LE.THRESH
+ IF( .NOT.DTRONG )
+ $ GO TO 70
+ END IF
+*
+* Update (A(J1:J1+M-1, M+J1:N), B(J1:J1+M-1, M+J1:N)) and
+* (A(1:J1-1, J1:J1+M), B(1:J1-1, J1:J1+M)).
+*
+ CALL DROT( J1+1, A( 1, J1 ), 1, A( 1, J1+1 ), 1, IR( 1, 1 ),
+ $ IR( 2, 1 ) )
+ CALL DROT( J1+1, B( 1, J1 ), 1, B( 1, J1+1 ), 1, IR( 1, 1 ),
+ $ IR( 2, 1 ) )
+ CALL DROT( N-J1+1, A( J1, J1 ), LDA, A( J1+1, J1 ), LDA,
+ $ LI( 1, 1 ), LI( 2, 1 ) )
+ CALL DROT( N-J1+1, B( J1, J1 ), LDB, B( J1+1, J1 ), LDB,
+ $ LI( 1, 1 ), LI( 2, 1 ) )
+*
+* Set N1-by-N2 (2,1) - blocks to ZERO.
+*
+ A( J1+1, J1 ) = ZERO
+ B( J1+1, J1 ) = ZERO
+*
+* Accumulate transformations into Q and Z if requested.
+*
+ IF( WANTZ )
+ $ CALL DROT( N, Z( 1, J1 ), 1, Z( 1, J1+1 ), 1, IR( 1, 1 ),
+ $ IR( 2, 1 ) )
+ IF( WANTQ )
+ $ CALL DROT( N, Q( 1, J1 ), 1, Q( 1, J1+1 ), 1, LI( 1, 1 ),
+ $ LI( 2, 1 ) )
+*
+* Exit with INFO = 0 if swap was successfully performed.
+*
+ RETURN
+*
+ ELSE
+*
+* CASE 2: Swap 1-by-1 and 2-by-2 blocks, or 2-by-2
+* and 2-by-2 blocks.
+*
+* Solve the generalized Sylvester equation
+* S11 * R - L * S22 = SCALE * S12
+* T11 * R - L * T22 = SCALE * T12
+* for R and L. Solutions in LI and IR.
+*
+ CALL DLACPY( 'Full', N1, N2, T( 1, N1+1 ), LDST, LI, LDST )
+ CALL DLACPY( 'Full', N1, N2, S( 1, N1+1 ), LDST,
+ $ IR( N2+1, N1+1 ), LDST )
+ CALL DTGSY2( 'N', 0, N1, N2, S, LDST, S( N1+1, N1+1 ), LDST,
+ $ IR( N2+1, N1+1 ), LDST, T, LDST, T( N1+1, N1+1 ),
+ $ LDST, LI, LDST, SCALE, DSUM, DSCALE, IWORK, IDUM,
+ $ LINFO )
+*
+* Compute orthogonal matrix QL:
+*
+* QL' * LI = [ TL ]
+* [ 0 ]
+* where
+* LI = [ -L ]
+* [ SCALE * identity(N2) ]
+*
+ DO 10 I = 1, N2
+ CALL DSCAL( N1, -ONE, LI( 1, I ), 1 )
+ LI( N1+I, I ) = SCALE
+ 10 CONTINUE
+ CALL DGEQR2( M, N2, LI, LDST, TAUL, WORK, LINFO )
+ IF( LINFO.NE.0 )
+ $ GO TO 70
+ CALL DORG2R( M, M, N2, LI, LDST, TAUL, WORK, LINFO )
+ IF( LINFO.NE.0 )
+ $ GO TO 70
+*
+* Compute orthogonal matrix RQ:
+*
+* IR * RQ' = [ 0 TR],
+*
+* where IR = [ SCALE * identity(N1), R ]
+*
+ DO 20 I = 1, N1
+ IR( N2+I, I ) = SCALE
+ 20 CONTINUE
+ CALL DGERQ2( N1, M, IR( N2+1, 1 ), LDST, TAUR, WORK, LINFO )
+ IF( LINFO.NE.0 )
+ $ GO TO 70
+ CALL DORGR2( M, M, N1, IR, LDST, TAUR, WORK, LINFO )
+ IF( LINFO.NE.0 )
+ $ GO TO 70
+*
+* Perform the swapping tentatively:
+*
+ CALL DGEMM( 'T', 'N', M, M, M, ONE, LI, LDST, S, LDST, ZERO,
+ $ WORK, M )
+ CALL DGEMM( 'N', 'T', M, M, M, ONE, WORK, M, IR, LDST, ZERO, S,
+ $ LDST )
+ CALL DGEMM( 'T', 'N', M, M, M, ONE, LI, LDST, T, LDST, ZERO,
+ $ WORK, M )
+ CALL DGEMM( 'N', 'T', M, M, M, ONE, WORK, M, IR, LDST, ZERO, T,
+ $ LDST )
+ CALL DLACPY( 'F', M, M, S, LDST, SCPY, LDST )
+ CALL DLACPY( 'F', M, M, T, LDST, TCPY, LDST )
+ CALL DLACPY( 'F', M, M, IR, LDST, IRCOP, LDST )
+ CALL DLACPY( 'F', M, M, LI, LDST, LICOP, LDST )
+*
+* Triangularize the B-part by an RQ factorization.
+* Apply transformation (from left) to A-part, giving S.
+*
+ CALL DGERQ2( M, M, T, LDST, TAUR, WORK, LINFO )
+ IF( LINFO.NE.0 )
+ $ GO TO 70
+ CALL DORMR2( 'R', 'T', M, M, M, T, LDST, TAUR, S, LDST, WORK,
+ $ LINFO )
+ IF( LINFO.NE.0 )
+ $ GO TO 70
+ CALL DORMR2( 'L', 'N', M, M, M, T, LDST, TAUR, IR, LDST, WORK,
+ $ LINFO )
+ IF( LINFO.NE.0 )
+ $ GO TO 70
+*
+* Compute F-norm(S21) in BRQA21. (T21 is 0.)
+*
+ DSCALE = ZERO
+ DSUM = ONE
+ DO 30 I = 1, N2
+ CALL DLASSQ( N1, S( N2+1, I ), 1, DSCALE, DSUM )
+ 30 CONTINUE
+ BRQA21 = DSCALE*SQRT( DSUM )
+*
+* Triangularize the B-part by a QR factorization.
+* Apply transformation (from right) to A-part, giving S.
+*
+ CALL DGEQR2( M, M, TCPY, LDST, TAUL, WORK, LINFO )
+ IF( LINFO.NE.0 )
+ $ GO TO 70
+ CALL DORM2R( 'L', 'T', M, M, M, TCPY, LDST, TAUL, SCPY, LDST,
+ $ WORK, INFO )
+ CALL DORM2R( 'R', 'N', M, M, M, TCPY, LDST, TAUL, LICOP, LDST,
+ $ WORK, INFO )
+ IF( LINFO.NE.0 )
+ $ GO TO 70
+*
+* Compute F-norm(S21) in BQRA21. (T21 is 0.)
+*
+ DSCALE = ZERO
+ DSUM = ONE
+ DO 40 I = 1, N2
+ CALL DLASSQ( N1, SCPY( N2+1, I ), 1, DSCALE, DSUM )
+ 40 CONTINUE
+ BQRA21 = DSCALE*SQRT( DSUM )
+*
+* Decide which method to use.
+* Weak stability test:
+* F-norm(S21) <= O(EPS * F-norm((S, T)))
+*
+ IF( BQRA21.LE.BRQA21 .AND. BQRA21.LE.THRESH ) THEN
+ CALL DLACPY( 'F', M, M, SCPY, LDST, S, LDST )
+ CALL DLACPY( 'F', M, M, TCPY, LDST, T, LDST )
+ CALL DLACPY( 'F', M, M, IRCOP, LDST, IR, LDST )
+ CALL DLACPY( 'F', M, M, LICOP, LDST, LI, LDST )
+ ELSE IF( BRQA21.GE.THRESH ) THEN
+ GO TO 70
+ END IF
+*
+* Set lower triangle of B-part to zero
+*
+ CALL DLASET( 'Lower', M-1, M-1, ZERO, ZERO, T(2,1), LDST )
+*
+ IF( WANDS ) THEN
+*
+* Strong stability test:
+* F-norm((A-QL*S*QR', B-QL*T*QR')) <= O(EPS*F-norm((A,B)))
+*
+ CALL DLACPY( 'Full', M, M, A( J1, J1 ), LDA, WORK( M*M+1 ),
+ $ M )
+ CALL DGEMM( 'N', 'N', M, M, M, ONE, LI, LDST, S, LDST, ZERO,
+ $ WORK, M )
+ CALL DGEMM( 'N', 'N', M, M, M, -ONE, WORK, M, IR, LDST, ONE,
+ $ WORK( M*M+1 ), M )
+ DSCALE = ZERO
+ DSUM = ONE
+ CALL DLASSQ( M*M, WORK( M*M+1 ), 1, DSCALE, DSUM )
+*
+ CALL DLACPY( 'Full', M, M, B( J1, J1 ), LDB, WORK( M*M+1 ),
+ $ M )
+ CALL DGEMM( 'N', 'N', M, M, M, ONE, LI, LDST, T, LDST, ZERO,
+ $ WORK, M )
+ CALL DGEMM( 'N', 'N', M, M, M, -ONE, WORK, M, IR, LDST, ONE,
+ $ WORK( M*M+1 ), M )
+ CALL DLASSQ( M*M, WORK( M*M+1 ), 1, DSCALE, DSUM )
+ SS = DSCALE*SQRT( DSUM )
+ DTRONG = ( SS.LE.THRESH )
+ IF( .NOT.DTRONG )
+ $ GO TO 70
+*
+ END IF
+*
+* If the swap is accepted ("weakly" and "strongly"), apply the
+* transformations and set N1-by-N2 (2,1)-block to zero.
+*
+ CALL DLASET( 'Full', N1, N2, ZERO, ZERO, S(N2+1,1), LDST )
+*
+* copy back M-by-M diagonal block starting at index J1 of (A, B)
+*
+ CALL DLACPY( 'F', M, M, S, LDST, A( J1, J1 ), LDA )
+ CALL DLACPY( 'F', M, M, T, LDST, B( J1, J1 ), LDB )
+ CALL DLASET( 'Full', LDST, LDST, ZERO, ZERO, T, LDST )
+*
+* Standardize existing 2-by-2 blocks.
+*
+ DO 50 I = 1, M*M
+ WORK(I) = ZERO
+ 50 CONTINUE
+ WORK( 1 ) = ONE
+ T( 1, 1 ) = ONE
+ IDUM = LWORK - M*M - 2
+ IF( N2.GT.1 ) THEN
+ CALL DLAGV2( A( J1, J1 ), LDA, B( J1, J1 ), LDB, AR, AI, BE,
+ $ WORK( 1 ), WORK( 2 ), T( 1, 1 ), T( 2, 1 ) )
+ WORK( M+1 ) = -WORK( 2 )
+ WORK( M+2 ) = WORK( 1 )
+ T( N2, N2 ) = T( 1, 1 )
+ T( 1, 2 ) = -T( 2, 1 )
+ END IF
+ WORK( M*M ) = ONE
+ T( M, M ) = ONE
+*
+ IF( N1.GT.1 ) THEN
+ CALL DLAGV2( A( J1+N2, J1+N2 ), LDA, B( J1+N2, J1+N2 ), LDB,
+ $ TAUR, TAUL, WORK( M*M+1 ), WORK( N2*M+N2+1 ),
+ $ WORK( N2*M+N2+2 ), T( N2+1, N2+1 ),
+ $ T( M, M-1 ) )
+ WORK( M*M ) = WORK( N2*M+N2+1 )
+ WORK( M*M-1 ) = -WORK( N2*M+N2+2 )
+ T( M, M ) = T( N2+1, N2+1 )
+ T( M-1, M ) = -T( M, M-1 )
+ END IF
+ CALL DGEMM( 'T', 'N', N2, N1, N2, ONE, WORK, M, A( J1, J1+N2 ),
+ $ LDA, ZERO, WORK( M*M+1 ), N2 )
+ CALL DLACPY( 'Full', N2, N1, WORK( M*M+1 ), N2, A( J1, J1+N2 ),
+ $ LDA )
+ CALL DGEMM( 'T', 'N', N2, N1, N2, ONE, WORK, M, B( J1, J1+N2 ),
+ $ LDB, ZERO, WORK( M*M+1 ), N2 )
+ CALL DLACPY( 'Full', N2, N1, WORK( M*M+1 ), N2, B( J1, J1+N2 ),
+ $ LDB )
+ CALL DGEMM( 'N', 'N', M, M, M, ONE, LI, LDST, WORK, M, ZERO,
+ $ WORK( M*M+1 ), M )
+ CALL DLACPY( 'Full', M, M, WORK( M*M+1 ), M, LI, LDST )
+ CALL DGEMM( 'N', 'N', N2, N1, N1, ONE, A( J1, J1+N2 ), LDA,
+ $ T( N2+1, N2+1 ), LDST, ZERO, WORK, N2 )
+ CALL DLACPY( 'Full', N2, N1, WORK, N2, A( J1, J1+N2 ), LDA )
+ CALL DGEMM( 'N', 'N', N2, N1, N1, ONE, B( J1, J1+N2 ), LDB,
+ $ T( N2+1, N2+1 ), LDST, ZERO, WORK, N2 )
+ CALL DLACPY( 'Full', N2, N1, WORK, N2, B( J1, J1+N2 ), LDB )
+ CALL DGEMM( 'T', 'N', M, M, M, ONE, IR, LDST, T, LDST, ZERO,
+ $ WORK, M )
+ CALL DLACPY( 'Full', M, M, WORK, M, IR, LDST )
+*
+* Accumulate transformations into Q and Z if requested.
+*
+ IF( WANTQ ) THEN
+ CALL DGEMM( 'N', 'N', N, M, M, ONE, Q( 1, J1 ), LDQ, LI,
+ $ LDST, ZERO, WORK, N )
+ CALL DLACPY( 'Full', N, M, WORK, N, Q( 1, J1 ), LDQ )
+*
+ END IF
+*
+ IF( WANTZ ) THEN
+ CALL DGEMM( 'N', 'N', N, M, M, ONE, Z( 1, J1 ), LDZ, IR,
+ $ LDST, ZERO, WORK, N )
+ CALL DLACPY( 'Full', N, M, WORK, N, Z( 1, J1 ), LDZ )
+*
+ END IF
+*
+* Update (A(J1:J1+M-1, M+J1:N), B(J1:J1+M-1, M+J1:N)) and
+* (A(1:J1-1, J1:J1+M), B(1:J1-1, J1:J1+M)).
+*
+ I = J1 + M
+ IF( I.LE.N ) THEN
+ CALL DGEMM( 'T', 'N', M, N-I+1, M, ONE, LI, LDST,
+ $ A( J1, I ), LDA, ZERO, WORK, M )
+ CALL DLACPY( 'Full', M, N-I+1, WORK, M, A( J1, I ), LDA )
+ CALL DGEMM( 'T', 'N', M, N-I+1, M, ONE, LI, LDST,
+ $ B( J1, I ), LDA, ZERO, WORK, M )
+ CALL DLACPY( 'Full', M, N-I+1, WORK, M, B( J1, I ), LDB )
+ END IF
+ I = J1 - 1
+ IF( I.GT.0 ) THEN
+ CALL DGEMM( 'N', 'N', I, M, M, ONE, A( 1, J1 ), LDA, IR,
+ $ LDST, ZERO, WORK, I )
+ CALL DLACPY( 'Full', I, M, WORK, I, A( 1, J1 ), LDA )
+ CALL DGEMM( 'N', 'N', I, M, M, ONE, B( 1, J1 ), LDB, IR,
+ $ LDST, ZERO, WORK, I )
+ CALL DLACPY( 'Full', I, M, WORK, I, B( 1, J1 ), LDB )
+ END IF
+*
+* Exit with INFO = 0 if swap was successfully performed.
+*
+ RETURN
+*
+ END IF
+*
+* Exit with INFO = 1 if swap was rejected.
+*
+ 70 CONTINUE
+*
+ INFO = 1
+ RETURN
+*
+* End of DTGEX2
+*
+ END
+ SUBROUTINE DTGEXC( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z,
+ $ LDZ, IFST, ILST, WORK, LWORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ LOGICAL WANTQ, WANTZ
+ INTEGER IFST, ILST, INFO, LDA, LDB, LDQ, LDZ, LWORK, N
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION A( LDA, * ), B( LDB, * ), Q( LDQ, * ),
+ $ WORK( * ), Z( LDZ, * )
+* ..
+*
+* Purpose
+* =======
+*
+* DTGEXC reorders the generalized real Schur decomposition of a real
+* matrix pair (A,B) using an orthogonal equivalence transformation
+*
+* (A, B) = Q * (A, B) * Z',
+*
+* so that the diagonal block of (A, B) with row index IFST is moved
+* to row ILST.
+*
+* (A, B) must be in generalized real Schur canonical form (as returned
+* by DGGES), i.e. A is block upper triangular with 1-by-1 and 2-by-2
+* diagonal blocks. B is upper triangular.
+*
+* Optionally, the matrices Q and Z of generalized Schur vectors are
+* updated.
+*
+* Q(in) * A(in) * Z(in)' = Q(out) * A(out) * Z(out)'
+* Q(in) * B(in) * Z(in)' = Q(out) * B(out) * Z(out)'
+*
+*
+* Arguments
+* =========
+*
+* WANTQ (input) LOGICAL
+* .TRUE. : update the left transformation matrix Q;
+* .FALSE.: do not update Q.
+*
+* WANTZ (input) LOGICAL
+* .TRUE. : update the right transformation matrix Z;
+* .FALSE.: do not update Z.
+*
+* N (input) INTEGER
+* The order of the matrices A and B. N >= 0.
+*
+* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+* On entry, the matrix A in generalized real Schur canonical
+* form.
+* On exit, the updated matrix A, again in generalized
+* real Schur canonical form.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,N).
+*
+* B (input/output) DOUBLE PRECISION array, dimension (LDB,N)
+* On entry, the matrix B in generalized real Schur canonical
+* form (A,B).
+* On exit, the updated matrix B, again in generalized
+* real Schur canonical form (A,B).
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. LDB >= max(1,N).
+*
+* Q (input/output) DOUBLE PRECISION array, dimension (LDZ,N)
+* On entry, if WANTQ = .TRUE., the orthogonal matrix Q.
+* On exit, the updated matrix Q.
+* If WANTQ = .FALSE., Q is not referenced.
+*
+* LDQ (input) INTEGER
+* The leading dimension of the array Q. LDQ >= 1.
+* If WANTQ = .TRUE., LDQ >= N.
+*
+* Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N)
+* On entry, if WANTZ = .TRUE., the orthogonal matrix Z.
+* On exit, the updated matrix Z.
+* If WANTZ = .FALSE., Z is not referenced.
+*
+* LDZ (input) INTEGER
+* The leading dimension of the array Z. LDZ >= 1.
+* If WANTZ = .TRUE., LDZ >= N.
+*
+* IFST (input/output) INTEGER
+* ILST (input/output) INTEGER
+* Specify the reordering of the diagonal blocks of (A, B).
+* The block with row index IFST is moved to row ILST, by a
+* sequence of swapping between adjacent blocks.
+* On exit, if IFST pointed on entry to the second row of
+* a 2-by-2 block, it is changed to point to the first row;
+* ILST always points to the first row of the block in its
+* final position (which may differ from its input value by
+* +1 or -1). 1 <= IFST, ILST <= N.
+*
+* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
+* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+* LWORK (input) INTEGER
+* The dimension of the array WORK.
+* LWORK >= 1 when N <= 1, otherwise LWORK >= 4*N + 16.
+*
+* If LWORK = -1, then a workspace query is assumed; the routine
+* only calculates the optimal size of the WORK array, returns
+* this value as the first entry of the WORK array, and no error
+* message related to LWORK is issued by XERBLA.
+*
+* INFO (output) INTEGER
+* =0: successful exit.
+* <0: if INFO = -i, the i-th argument had an illegal value.
+* =1: The transformed matrix pair (A, B) would be too far
+* from generalized Schur form; the problem is ill-
+* conditioned. (A, B) may have been partially reordered,
+* and ILST points to the first row of the current
+* position of the block being moved.
+*
+* Further Details
+* ===============
+*
+* Based on contributions by
+* Bo Kagstrom and Peter Poromaa, Department of Computing Science,
+* Umea University, S-901 87 Umea, Sweden.
+*
+* [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the
+* Generalized Real Schur Form of a Regular Matrix Pair (A, B), in
+* M.S. Moonen et al (eds), Linear Algebra for Large Scale and
+* Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO
+ PARAMETER ( ZERO = 0.0D+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL LQUERY
+ INTEGER HERE, LWMIN, NBF, NBL, NBNEXT
+* ..
+* .. External Subroutines ..
+ EXTERNAL DTGEX2, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+* Decode and test input arguments.
+*
+ INFO = 0
+ LQUERY = ( LWORK.EQ.-1 )
+ IF( N.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -5
+ ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -7
+ ELSE IF( LDQ.LT.1 .OR. WANTQ .AND. ( LDQ.LT.MAX( 1, N ) ) ) THEN
+ INFO = -9
+ ELSE IF( LDZ.LT.1 .OR. WANTZ .AND. ( LDZ.LT.MAX( 1, N ) ) ) THEN
+ INFO = -11
+ ELSE IF( IFST.LT.1 .OR. IFST.GT.N ) THEN
+ INFO = -12
+ ELSE IF( ILST.LT.1 .OR. ILST.GT.N ) THEN
+ INFO = -13
+ END IF
+*
+ IF( INFO.EQ.0 ) THEN
+ IF( N.LE.1 ) THEN
+ LWMIN = 1
+ ELSE
+ LWMIN = 4*N + 16
+ END IF
+ WORK(1) = LWMIN
+*
+ IF (LWORK.LT.LWMIN .AND. .NOT.LQUERY) THEN
+ INFO = -15
+ END IF
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DTGEXC', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.LE.1 )
+ $ RETURN
+*
+* Determine the first row of the specified block and find out
+* if it is 1-by-1 or 2-by-2.
+*
+ IF( IFST.GT.1 ) THEN
+ IF( A( IFST, IFST-1 ).NE.ZERO )
+ $ IFST = IFST - 1
+ END IF
+ NBF = 1
+ IF( IFST.LT.N ) THEN
+ IF( A( IFST+1, IFST ).NE.ZERO )
+ $ NBF = 2
+ END IF
+*
+* Determine the first row of the final block
+* and find out if it is 1-by-1 or 2-by-2.
+*
+ IF( ILST.GT.1 ) THEN
+ IF( A( ILST, ILST-1 ).NE.ZERO )
+ $ ILST = ILST - 1
+ END IF
+ NBL = 1
+ IF( ILST.LT.N ) THEN
+ IF( A( ILST+1, ILST ).NE.ZERO )
+ $ NBL = 2
+ END IF
+ IF( IFST.EQ.ILST )
+ $ RETURN
+*
+ IF( IFST.LT.ILST ) THEN
+*
+* Update ILST.
+*
+ IF( NBF.EQ.2 .AND. NBL.EQ.1 )
+ $ ILST = ILST - 1
+ IF( NBF.EQ.1 .AND. NBL.EQ.2 )
+ $ ILST = ILST + 1
+*
+ HERE = IFST
+*
+ 10 CONTINUE
+*
+* Swap with next one below.
+*
+ IF( NBF.EQ.1 .OR. NBF.EQ.2 ) THEN
+*
+* Current block either 1-by-1 or 2-by-2.
+*
+ NBNEXT = 1
+ IF( HERE+NBF+1.LE.N ) THEN
+ IF( A( HERE+NBF+1, HERE+NBF ).NE.ZERO )
+ $ NBNEXT = 2
+ END IF
+ CALL DTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z,
+ $ LDZ, HERE, NBF, NBNEXT, WORK, LWORK, INFO )
+ IF( INFO.NE.0 ) THEN
+ ILST = HERE
+ RETURN
+ END IF
+ HERE = HERE + NBNEXT
+*
+* Test if 2-by-2 block breaks into two 1-by-1 blocks.
+*
+ IF( NBF.EQ.2 ) THEN
+ IF( A( HERE+1, HERE ).EQ.ZERO )
+ $ NBF = 3
+ END IF
+*
+ ELSE
+*
+* Current block consists of two 1-by-1 blocks, each of which
+* must be swapped individually.
+*
+ NBNEXT = 1
+ IF( HERE+3.LE.N ) THEN
+ IF( A( HERE+3, HERE+2 ).NE.ZERO )
+ $ NBNEXT = 2
+ END IF
+ CALL DTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z,
+ $ LDZ, HERE+1, 1, NBNEXT, WORK, LWORK, INFO )
+ IF( INFO.NE.0 ) THEN
+ ILST = HERE
+ RETURN
+ END IF
+ IF( NBNEXT.EQ.1 ) THEN
+*
+* Swap two 1-by-1 blocks.
+*
+ CALL DTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z,
+ $ LDZ, HERE, 1, 1, WORK, LWORK, INFO )
+ IF( INFO.NE.0 ) THEN
+ ILST = HERE
+ RETURN
+ END IF
+ HERE = HERE + 1
+*
+ ELSE
+*
+* Recompute NBNEXT in case of 2-by-2 split.
+*
+ IF( A( HERE+2, HERE+1 ).EQ.ZERO )
+ $ NBNEXT = 1
+ IF( NBNEXT.EQ.2 ) THEN
+*
+* 2-by-2 block did not split.
+*
+ CALL DTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ,
+ $ Z, LDZ, HERE, 1, NBNEXT, WORK, LWORK,
+ $ INFO )
+ IF( INFO.NE.0 ) THEN
+ ILST = HERE
+ RETURN
+ END IF
+ HERE = HERE + 2
+ ELSE
+*
+* 2-by-2 block did split.
+*
+ CALL DTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ,
+ $ Z, LDZ, HERE, 1, 1, WORK, LWORK, INFO )
+ IF( INFO.NE.0 ) THEN
+ ILST = HERE
+ RETURN
+ END IF
+ HERE = HERE + 1
+ CALL DTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ,
+ $ Z, LDZ, HERE, 1, 1, WORK, LWORK, INFO )
+ IF( INFO.NE.0 ) THEN
+ ILST = HERE
+ RETURN
+ END IF
+ HERE = HERE + 1
+ END IF
+*
+ END IF
+ END IF
+ IF( HERE.LT.ILST )
+ $ GO TO 10
+ ELSE
+ HERE = IFST
+*
+ 20 CONTINUE
+*
+* Swap with next one below.
+*
+ IF( NBF.EQ.1 .OR. NBF.EQ.2 ) THEN
+*
+* Current block either 1-by-1 or 2-by-2.
+*
+ NBNEXT = 1
+ IF( HERE.GE.3 ) THEN
+ IF( A( HERE-1, HERE-2 ).NE.ZERO )
+ $ NBNEXT = 2
+ END IF
+ CALL DTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z,
+ $ LDZ, HERE-NBNEXT, NBNEXT, NBF, WORK, LWORK,
+ $ INFO )
+ IF( INFO.NE.0 ) THEN
+ ILST = HERE
+ RETURN
+ END IF
+ HERE = HERE - NBNEXT
+*
+* Test if 2-by-2 block breaks into two 1-by-1 blocks.
+*
+ IF( NBF.EQ.2 ) THEN
+ IF( A( HERE+1, HERE ).EQ.ZERO )
+ $ NBF = 3
+ END IF
+*
+ ELSE
+*
+* Current block consists of two 1-by-1 blocks, each of which
+* must be swapped individually.
+*
+ NBNEXT = 1
+ IF( HERE.GE.3 ) THEN
+ IF( A( HERE-1, HERE-2 ).NE.ZERO )
+ $ NBNEXT = 2
+ END IF
+ CALL DTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z,
+ $ LDZ, HERE-NBNEXT, NBNEXT, 1, WORK, LWORK,
+ $ INFO )
+ IF( INFO.NE.0 ) THEN
+ ILST = HERE
+ RETURN
+ END IF
+ IF( NBNEXT.EQ.1 ) THEN
+*
+* Swap two 1-by-1 blocks.
+*
+ CALL DTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z,
+ $ LDZ, HERE, NBNEXT, 1, WORK, LWORK, INFO )
+ IF( INFO.NE.0 ) THEN
+ ILST = HERE
+ RETURN
+ END IF
+ HERE = HERE - 1
+ ELSE
+*
+* Recompute NBNEXT in case of 2-by-2 split.
+*
+ IF( A( HERE, HERE-1 ).EQ.ZERO )
+ $ NBNEXT = 1
+ IF( NBNEXT.EQ.2 ) THEN
+*
+* 2-by-2 block did not split.
+*
+ CALL DTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ,
+ $ Z, LDZ, HERE-1, 2, 1, WORK, LWORK, INFO )
+ IF( INFO.NE.0 ) THEN
+ ILST = HERE
+ RETURN
+ END IF
+ HERE = HERE - 2
+ ELSE
+*
+* 2-by-2 block did split.
+*
+ CALL DTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ,
+ $ Z, LDZ, HERE, 1, 1, WORK, LWORK, INFO )
+ IF( INFO.NE.0 ) THEN
+ ILST = HERE
+ RETURN
+ END IF
+ HERE = HERE - 1
+ CALL DTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ,
+ $ Z, LDZ, HERE, 1, 1, WORK, LWORK, INFO )
+ IF( INFO.NE.0 ) THEN
+ ILST = HERE
+ RETURN
+ END IF
+ HERE = HERE - 1
+ END IF
+ END IF
+ END IF
+ IF( HERE.GT.ILST )
+ $ GO TO 20
+ END IF
+ ILST = HERE
+ WORK( 1 ) = LWMIN
+ RETURN
+*
+* End of DTGEXC
+*
+ END
+ 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 )
+*
+* -- LAPACK routine (version 3.1.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* January 2007
+*
+* Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH.
+*
+* .. Scalar Arguments ..
+ LOGICAL WANTQ, WANTZ
+ INTEGER IJOB, INFO, LDA, LDB, LDQ, LDZ, LIWORK, LWORK,
+ $ M, N
+ DOUBLE PRECISION PL, PR
+* ..
+* .. Array Arguments ..
+ LOGICAL SELECT( * )
+ INTEGER IWORK( * )
+ DOUBLE PRECISION A( LDA, * ), ALPHAI( * ), ALPHAR( * ),
+ $ B( LDB, * ), BETA( * ), DIF( * ), Q( LDQ, * ),
+ $ WORK( * ), Z( LDZ, * )
+* ..
+*
+* Purpose
+* =======
+*
+* DTGSEN reorders the generalized real Schur decomposition of a real
+* matrix pair (A, B) (in terms of an orthonormal equivalence trans-
+* formation Q' * (A, B) * Z), so that a selected cluster of eigenvalues
+* appears in the leading diagonal blocks of the upper quasi-triangular
+* matrix A and the upper triangular B. The leading columns of Q and
+* Z form orthonormal bases of the corresponding left and right eigen-
+* spaces (deflating subspaces). (A, B) must be in generalized real
+* Schur canonical form (as returned by DGGES), i.e. A is block upper
+* triangular with 1-by-1 and 2-by-2 diagonal blocks. B is upper
+* triangular.
+*
+* DTGSEN also computes the generalized eigenvalues
+*
+* w(j) = (ALPHAR(j) + i*ALPHAI(j))/BETA(j)
+*
+* of the reordered matrix pair (A, B).
+*
+* Optionally, DTGSEN computes the estimates of reciprocal condition
+* numbers for eigenvalues and eigenspaces. These are Difu[(A11,B11),
+* (A22,B22)] and Difl[(A11,B11), (A22,B22)], i.e. the separation(s)
+* between the matrix pairs (A11, B11) and (A22,B22) that correspond to
+* the selected cluster and the eigenvalues outside the cluster, resp.,
+* and norms of "projections" onto left and right eigenspaces w.r.t.
+* the selected cluster in the (1,1)-block.
+*
+* Arguments
+* =========
+*
+* IJOB (input) INTEGER
+* Specifies whether condition numbers are required for the
+* cluster of eigenvalues (PL and PR) or the deflating subspaces
+* (Difu and Difl):
+* =0: Only reorder w.r.t. SELECT. No extras.
+* =1: Reciprocal of norms of "projections" onto left and right
+* eigenspaces w.r.t. the selected cluster (PL and PR).
+* =2: Upper bounds on Difu and Difl. F-norm-based estimate
+* (DIF(1:2)).
+* =3: Estimate of Difu and Difl. 1-norm-based estimate
+* (DIF(1:2)).
+* About 5 times as expensive as IJOB = 2.
+* =4: Compute PL, PR and DIF (i.e. 0, 1 and 2 above): Economic
+* version to get it all.
+* =5: Compute PL, PR and DIF (i.e. 0, 1 and 3 above)
+*
+* WANTQ (input) LOGICAL
+* .TRUE. : update the left transformation matrix Q;
+* .FALSE.: do not update Q.
+*
+* WANTZ (input) LOGICAL
+* .TRUE. : update the right transformation matrix Z;
+* .FALSE.: do not update Z.
+*
+* SELECT (input) LOGICAL array, dimension (N)
+* SELECT specifies the eigenvalues in the selected cluster.
+* To select a real eigenvalue w(j), SELECT(j) must be set to
+* .TRUE.. To select a complex conjugate pair of eigenvalues
+* w(j) and w(j+1), corresponding to a 2-by-2 diagonal block,
+* either SELECT(j) or SELECT(j+1) or both must be set to
+* .TRUE.; a complex conjugate pair of eigenvalues must be
+* either both included in the cluster or both excluded.
+*
+* N (input) INTEGER
+* The order of the matrices A and B. N >= 0.
+*
+* A (input/output) DOUBLE PRECISION array, dimension(LDA,N)
+* On entry, the upper quasi-triangular matrix A, with (A, B) in
+* generalized real Schur canonical form.
+* On exit, A is overwritten by the reordered matrix A.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,N).
+*
+* B (input/output) DOUBLE PRECISION array, dimension(LDB,N)
+* On entry, the upper triangular matrix B, with (A, B) in
+* generalized real Schur canonical form.
+* On exit, B is overwritten by the reordered matrix B.
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. LDB >= max(1,N).
+*
+* ALPHAR (output) DOUBLE PRECISION array, dimension (N)
+* ALPHAI (output) DOUBLE PRECISION array, dimension (N)
+* BETA (output) DOUBLE PRECISION array, dimension (N)
+* On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, will
+* be the generalized eigenvalues. ALPHAR(j) + ALPHAI(j)*i
+* and BETA(j),j=1,...,N are the diagonals of the complex Schur
+* form (S,T) that would result if the 2-by-2 diagonal blocks of
+* the real generalized Schur form of (A,B) were further reduced
+* to triangular form using complex unitary transformations.
+* If ALPHAI(j) is zero, then the j-th eigenvalue is real; if
+* positive, then the j-th and (j+1)-st eigenvalues are a
+* complex conjugate pair, with ALPHAI(j+1) negative.
+*
+* Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N)
+* On entry, if WANTQ = .TRUE., Q is an N-by-N matrix.
+* On exit, Q has been postmultiplied by the left orthogonal
+* transformation matrix which reorder (A, B); The leading M
+* columns of Q form orthonormal bases for the specified pair of
+* left eigenspaces (deflating subspaces).
+* If WANTQ = .FALSE., Q is not referenced.
+*
+* LDQ (input) INTEGER
+* The leading dimension of the array Q. LDQ >= 1;
+* and if WANTQ = .TRUE., LDQ >= N.
+*
+* Z (input/output) DOUBLE PRECISION array, dimension (LDZ,N)
+* On entry, if WANTZ = .TRUE., Z is an N-by-N matrix.
+* On exit, Z has been postmultiplied by the left orthogonal
+* transformation matrix which reorder (A, B); The leading M
+* columns of Z form orthonormal bases for the specified pair of
+* left eigenspaces (deflating subspaces).
+* If WANTZ = .FALSE., Z is not referenced.
+*
+* LDZ (input) INTEGER
+* The leading dimension of the array Z. LDZ >= 1;
+* If WANTZ = .TRUE., LDZ >= N.
+*
+* M (output) INTEGER
+* The dimension of the specified pair of left and right eigen-
+* spaces (deflating subspaces). 0 <= M <= N.
+*
+* PL (output) DOUBLE PRECISION
+* PR (output) DOUBLE PRECISION
+* If IJOB = 1, 4 or 5, PL, PR are lower bounds on the
+* reciprocal of the norm of "projections" onto left and right
+* eigenspaces with respect to the selected cluster.
+* 0 < PL, PR <= 1.
+* If M = 0 or M = N, PL = PR = 1.
+* If IJOB = 0, 2 or 3, PL and PR are not referenced.
+*
+* DIF (output) DOUBLE PRECISION array, dimension (2).
+* If IJOB >= 2, DIF(1:2) store the estimates of Difu and Difl.
+* If IJOB = 2 or 4, DIF(1:2) are F-norm-based upper bounds on
+* Difu and Difl. If IJOB = 3 or 5, DIF(1:2) are 1-norm-based
+* estimates of Difu and Difl.
+* If M = 0 or N, DIF(1:2) = F-norm([A, B]).
+* If IJOB = 0 or 1, DIF is not referenced.
+*
+* WORK (workspace/output) DOUBLE PRECISION array,
+* dimension (MAX(1,LWORK))
+* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+* LWORK (input) INTEGER
+* The dimension of the array WORK. LWORK >= 4*N+16.
+* If IJOB = 1, 2 or 4, LWORK >= MAX(4*N+16, 2*M*(N-M)).
+* If IJOB = 3 or 5, LWORK >= MAX(4*N+16, 4*M*(N-M)).
+*
+* If LWORK = -1, then a workspace query is assumed; the routine
+* only calculates the optimal size of the WORK array, returns
+* this value as the first entry of the WORK array, and no error
+* message related to LWORK is issued by XERBLA.
+*
+* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))
+* IF IJOB = 0, IWORK is not referenced. Otherwise,
+* on exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
+*
+* LIWORK (input) INTEGER
+* The dimension of the array IWORK. LIWORK >= 1.
+* If IJOB = 1, 2 or 4, LIWORK >= N+6.
+* If IJOB = 3 or 5, LIWORK >= MAX(2*M*(N-M), N+6).
+*
+* If LIWORK = -1, then a workspace query is assumed; the
+* routine only calculates the optimal size of the IWORK array,
+* returns this value as the first entry of the IWORK array, and
+* no error message related to LIWORK is issued by XERBLA.
+*
+* INFO (output) INTEGER
+* =0: Successful exit.
+* <0: If INFO = -i, the i-th argument had an illegal value.
+* =1: Reordering of (A, B) failed because the transformed
+* matrix pair (A, B) would be too far from generalized
+* Schur form; the problem is very ill-conditioned.
+* (A, B) may have been partially reordered.
+* If requested, 0 is returned in DIF(*), PL and PR.
+*
+* Further Details
+* ===============
+*
+* DTGSEN first collects the selected eigenvalues by computing
+* orthogonal U and W that move them to the top left corner of (A, B).
+* In other words, the selected eigenvalues are the eigenvalues of
+* (A11, B11) in:
+*
+* U'*(A, B)*W = (A11 A12) (B11 B12) n1
+* ( 0 A22),( 0 B22) n2
+* n1 n2 n1 n2
+*
+* where N = n1+n2 and U' means the transpose of U. The first n1 columns
+* of U and W span the specified pair of left and right eigenspaces
+* (deflating subspaces) of (A, B).
+*
+* If (A, B) has been obtained from the generalized real Schur
+* decomposition of a matrix pair (C, D) = Q*(A, B)*Z', then the
+* reordered generalized real Schur form of (C, D) is given by
+*
+* (C, D) = (Q*U)*(U'*(A, B)*W)*(Z*W)',
+*
+* and the first n1 columns of Q*U and Z*W span the corresponding
+* deflating subspaces of (C, D) (Q and Z store Q*U and Z*W, resp.).
+*
+* Note that if the selected eigenvalue is sufficiently ill-conditioned,
+* then its value may differ significantly from its value before
+* reordering.
+*
+* The reciprocal condition numbers of the left and right eigenspaces
+* spanned by the first n1 columns of U and W (or Q*U and Z*W) may
+* be returned in DIF(1:2), corresponding to Difu and Difl, resp.
+*
+* The Difu and Difl are defined as:
+*
+* Difu[(A11, B11), (A22, B22)] = sigma-min( Zu )
+* and
+* Difl[(A11, B11), (A22, B22)] = Difu[(A22, B22), (A11, B11)],
+*
+* where sigma-min(Zu) is the smallest singular value of the
+* (2*n1*n2)-by-(2*n1*n2) matrix
+*
+* Zu = [ kron(In2, A11) -kron(A22', In1) ]
+* [ kron(In2, B11) -kron(B22', In1) ].
+*
+* Here, Inx is the identity matrix of size nx and A22' is the
+* transpose of A22. kron(X, Y) is the Kronecker product between
+* the matrices X and Y.
+*
+* When DIF(2) is small, small changes in (A, B) can cause large changes
+* in the deflating subspace. An approximate (asymptotic) bound on the
+* maximum angular error in the computed deflating subspaces is
+*
+* EPS * norm((A, B)) / DIF(2),
+*
+* where EPS is the machine precision.
+*
+* The reciprocal norm of the projectors on the left and right
+* eigenspaces associated with (A11, B11) may be returned in PL and PR.
+* They are computed as follows. First we compute L and R so that
+* P*(A, B)*Q is block diagonal, where
+*
+* P = ( I -L ) n1 Q = ( I R ) n1
+* ( 0 I ) n2 and ( 0 I ) n2
+* n1 n2 n1 n2
+*
+* and (L, R) is the solution to the generalized Sylvester equation
+*
+* A11*R - L*A22 = -A12
+* B11*R - L*B22 = -B12
+*
+* Then PL = (F-norm(L)**2+1)**(-1/2) and PR = (F-norm(R)**2+1)**(-1/2).
+* An approximate (asymptotic) bound on the average absolute error of
+* the selected eigenvalues is
+*
+* EPS * norm((A, B)) / PL.
+*
+* There are also global error bounds which valid for perturbations up
+* to a certain restriction: A lower bound (x) on the smallest
+* F-norm(E,F) for which an eigenvalue of (A11, B11) may move and
+* coalesce with an eigenvalue of (A22, B22) under perturbation (E,F),
+* (i.e. (A + E, B + F), is
+*
+* x = min(Difu,Difl)/((1/(PL*PL)+1/(PR*PR))**(1/2)+2*max(1/PL,1/PR)).
+*
+* An approximate bound on x can be computed from DIF(1:2), PL and PR.
+*
+* If y = ( F-norm(E,F) / x) <= 1, the angles between the perturbed
+* (L', R') and unperturbed (L, R) left and right deflating subspaces
+* associated with the selected cluster in the (1,1)-blocks can be
+* bounded as
+*
+* max-angle(L, L') <= arctan( y * PL / (1 - y * (1 - PL * PL)**(1/2))
+* max-angle(R, R') <= arctan( y * PR / (1 - y * (1 - PR * PR)**(1/2))
+*
+* See LAPACK User's Guide section 4.11 or the following references
+* for more information.
+*
+* Note that if the default method for computing the Frobenius-norm-
+* based estimate DIF is not wanted (see DLATDF), then the parameter
+* IDIFJB (see below) should be changed from 3 to 4 (routine DLATDF
+* (IJOB = 2 will be used)). See DTGSYL for more details.
+*
+* Based on contributions by
+* Bo Kagstrom and Peter Poromaa, Department of Computing Science,
+* Umea University, S-901 87 Umea, Sweden.
+*
+* References
+* ==========
+*
+* [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the
+* Generalized Real Schur Form of a Regular Matrix Pair (A, B), in
+* M.S. Moonen et al (eds), Linear Algebra for Large Scale and
+* Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218.
+*
+* [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified
+* Eigenvalues of a Regular Matrix Pair (A, B) and Condition
+* Estimation: Theory, Algorithms and Software,
+* Report UMINF - 94.04, Department of Computing Science, Umea
+* University, S-901 87 Umea, Sweden, 1994. Also as LAPACK Working
+* Note 87. To appear in Numerical Algorithms, 1996.
+*
+* [3] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software
+* for Solving the Generalized Sylvester Equation and Estimating the
+* Separation between Regular Matrix Pairs, Report UMINF - 93.23,
+* Department of Computing Science, Umea University, S-901 87 Umea,
+* Sweden, December 1993, Revised April 1994, Also as LAPACK Working
+* Note 75. To appear in ACM Trans. on Math. Software, Vol 22, No 1,
+* 1996.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ INTEGER IDIFJB
+ PARAMETER ( IDIFJB = 3 )
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL LQUERY, PAIR, SWAP, WANTD, WANTD1, WANTD2,
+ $ WANTP
+ INTEGER I, IERR, IJB, K, KASE, KK, KS, LIWMIN, LWMIN,
+ $ MN2, N1, N2
+ DOUBLE PRECISION DSCALE, DSUM, EPS, RDSCAL, SMLNUM
+* ..
+* .. Local Arrays ..
+ INTEGER ISAVE( 3 )
+* ..
+* .. External Subroutines ..
+ EXTERNAL DLACN2, DLACPY, DLAG2, DLASSQ, DTGEXC, DTGSYL,
+ $ XERBLA
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DLAMCH
+ EXTERNAL DLAMCH
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, SIGN, SQRT
+* ..
+* .. Executable Statements ..
+*
+* Decode and test the input parameters
+*
+ INFO = 0
+ LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 )
+*
+ IF( IJOB.LT.0 .OR. IJOB.GT.5 ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -5
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -7
+ ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -9
+ ELSE IF( LDQ.LT.1 .OR. ( WANTQ .AND. LDQ.LT.N ) ) THEN
+ INFO = -14
+ ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
+ INFO = -16
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DTGSEN', -INFO )
+ RETURN
+ END IF
+*
+* Get machine constants
+*
+ EPS = DLAMCH( 'P' )
+ SMLNUM = DLAMCH( 'S' ) / EPS
+ IERR = 0
+*
+ WANTP = IJOB.EQ.1 .OR. IJOB.GE.4
+ WANTD1 = IJOB.EQ.2 .OR. IJOB.EQ.4
+ WANTD2 = IJOB.EQ.3 .OR. IJOB.EQ.5
+ WANTD = WANTD1 .OR. WANTD2
+*
+* Set M to the dimension of the specified pair of deflating
+* subspaces.
+*
+ M = 0
+ PAIR = .FALSE.
+ DO 10 K = 1, N
+ IF( PAIR ) THEN
+ PAIR = .FALSE.
+ ELSE
+ IF( K.LT.N ) THEN
+ IF( A( K+1, K ).EQ.ZERO ) THEN
+ IF( SELECT( K ) )
+ $ M = M + 1
+ ELSE
+ PAIR = .TRUE.
+ IF( SELECT( K ) .OR. SELECT( K+1 ) )
+ $ M = M + 2
+ END IF
+ ELSE
+ IF( SELECT( N ) )
+ $ M = M + 1
+ END IF
+ END IF
+ 10 CONTINUE
+*
+ IF( IJOB.EQ.1 .OR. IJOB.EQ.2 .OR. IJOB.EQ.4 ) THEN
+ LWMIN = MAX( 1, 4*N+16, 2*M*( N-M ) )
+ LIWMIN = MAX( 1, N+6 )
+ ELSE IF( IJOB.EQ.3 .OR. IJOB.EQ.5 ) THEN
+ LWMIN = MAX( 1, 4*N+16, 4*M*( N-M ) )
+ LIWMIN = MAX( 1, 2*M*( N-M ), N+6 )
+ ELSE
+ LWMIN = MAX( 1, 4*N+16 )
+ LIWMIN = 1
+ END IF
+*
+ WORK( 1 ) = LWMIN
+ IWORK( 1 ) = LIWMIN
+*
+ IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
+ INFO = -22
+ ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN
+ INFO = -24
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DTGSEN', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible.
+*
+ IF( M.EQ.N .OR. M.EQ.0 ) THEN
+ IF( WANTP ) THEN
+ PL = ONE
+ PR = ONE
+ END IF
+ IF( WANTD ) THEN
+ DSCALE = ZERO
+ DSUM = ONE
+ DO 20 I = 1, N
+ CALL DLASSQ( N, A( 1, I ), 1, DSCALE, DSUM )
+ CALL DLASSQ( N, B( 1, I ), 1, DSCALE, DSUM )
+ 20 CONTINUE
+ DIF( 1 ) = DSCALE*SQRT( DSUM )
+ DIF( 2 ) = DIF( 1 )
+ END IF
+ GO TO 60
+ END IF
+*
+* Collect the selected blocks at the top-left corner of (A, B).
+*
+ KS = 0
+ PAIR = .FALSE.
+ DO 30 K = 1, N
+ IF( PAIR ) THEN
+ PAIR = .FALSE.
+ ELSE
+*
+ SWAP = SELECT( K )
+ IF( K.LT.N ) THEN
+ IF( A( K+1, K ).NE.ZERO ) THEN
+ PAIR = .TRUE.
+ SWAP = SWAP .OR. SELECT( K+1 )
+ END IF
+ END IF
+*
+ IF( SWAP ) THEN
+ KS = KS + 1
+*
+* Swap the K-th block to position KS.
+* Perform the reordering of diagonal blocks in (A, B)
+* by orthogonal transformation matrices and update
+* Q and Z accordingly (if requested):
+*
+ KK = K
+ IF( K.NE.KS )
+ $ CALL DTGEXC( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ,
+ $ Z, LDZ, KK, KS, WORK, LWORK, IERR )
+*
+ IF( IERR.GT.0 ) THEN
+*
+* Swap is rejected: exit.
+*
+ INFO = 1
+ IF( WANTP ) THEN
+ PL = ZERO
+ PR = ZERO
+ END IF
+ IF( WANTD ) THEN
+ DIF( 1 ) = ZERO
+ DIF( 2 ) = ZERO
+ END IF
+ GO TO 60
+ END IF
+*
+ IF( PAIR )
+ $ KS = KS + 1
+ END IF
+ END IF
+ 30 CONTINUE
+ IF( WANTP ) THEN
+*
+* Solve generalized Sylvester equation for R and L
+* and compute PL and PR.
+*
+ N1 = M
+ N2 = N - M
+ I = N1 + 1
+ IJB = 0
+ CALL DLACPY( 'Full', N1, N2, A( 1, I ), LDA, WORK, N1 )
+ CALL DLACPY( 'Full', N1, N2, B( 1, I ), LDB, WORK( N1*N2+1 ),
+ $ N1 )
+ CALL DTGSYL( 'N', IJB, N1, N2, A, LDA, A( I, I ), LDA, WORK,
+ $ N1, B, LDB, B( I, I ), LDB, WORK( N1*N2+1 ), N1,
+ $ DSCALE, DIF( 1 ), WORK( N1*N2*2+1 ),
+ $ LWORK-2*N1*N2, IWORK, IERR )
+*
+* Estimate the reciprocal of norms of "projections" onto left
+* and right eigenspaces.
+*
+ RDSCAL = ZERO
+ DSUM = ONE
+ CALL DLASSQ( N1*N2, WORK, 1, RDSCAL, DSUM )
+ PL = RDSCAL*SQRT( DSUM )
+ IF( PL.EQ.ZERO ) THEN
+ PL = ONE
+ ELSE
+ PL = DSCALE / ( SQRT( DSCALE*DSCALE / PL+PL )*SQRT( PL ) )
+ END IF
+ RDSCAL = ZERO
+ DSUM = ONE
+ CALL DLASSQ( N1*N2, WORK( N1*N2+1 ), 1, RDSCAL, DSUM )
+ PR = RDSCAL*SQRT( DSUM )
+ IF( PR.EQ.ZERO ) THEN
+ PR = ONE
+ ELSE
+ PR = DSCALE / ( SQRT( DSCALE*DSCALE / PR+PR )*SQRT( PR ) )
+ END IF
+ END IF
+*
+ IF( WANTD ) THEN
+*
+* Compute estimates of Difu and Difl.
+*
+ IF( WANTD1 ) THEN
+ N1 = M
+ N2 = N - M
+ I = N1 + 1
+ IJB = IDIFJB
+*
+* Frobenius norm-based Difu-estimate.
+*
+ CALL DTGSYL( 'N', IJB, N1, N2, A, LDA, A( I, I ), LDA, WORK,
+ $ N1, B, LDB, B( I, I ), LDB, WORK( N1*N2+1 ),
+ $ N1, DSCALE, DIF( 1 ), WORK( 2*N1*N2+1 ),
+ $ LWORK-2*N1*N2, IWORK, IERR )
+*
+* Frobenius norm-based Difl-estimate.
+*
+ CALL DTGSYL( 'N', IJB, N2, N1, A( I, I ), LDA, A, LDA, WORK,
+ $ N2, B( I, I ), LDB, B, LDB, WORK( N1*N2+1 ),
+ $ N2, DSCALE, DIF( 2 ), WORK( 2*N1*N2+1 ),
+ $ LWORK-2*N1*N2, IWORK, IERR )
+ ELSE
+*
+*
+* Compute 1-norm-based estimates of Difu and Difl using
+* reversed communication with DLACN2. In each step a
+* generalized Sylvester equation or a transposed variant
+* is solved.
+*
+ KASE = 0
+ N1 = M
+ N2 = N - M
+ I = N1 + 1
+ IJB = 0
+ MN2 = 2*N1*N2
+*
+* 1-norm-based estimate of Difu.
+*
+ 40 CONTINUE
+ CALL DLACN2( MN2, WORK( MN2+1 ), WORK, IWORK, DIF( 1 ),
+ $ KASE, ISAVE )
+ IF( KASE.NE.0 ) THEN
+ IF( KASE.EQ.1 ) THEN
+*
+* Solve generalized Sylvester equation.
+*
+ CALL DTGSYL( 'N', IJB, N1, N2, A, LDA, A( I, I ), LDA,
+ $ WORK, N1, B, LDB, B( I, I ), LDB,
+ $ WORK( N1*N2+1 ), N1, DSCALE, DIF( 1 ),
+ $ WORK( 2*N1*N2+1 ), LWORK-2*N1*N2, IWORK,
+ $ IERR )
+ ELSE
+*
+* Solve the transposed variant.
+*
+ CALL DTGSYL( 'T', IJB, N1, N2, A, LDA, A( I, I ), LDA,
+ $ WORK, N1, B, LDB, B( I, I ), LDB,
+ $ WORK( N1*N2+1 ), N1, DSCALE, DIF( 1 ),
+ $ WORK( 2*N1*N2+1 ), LWORK-2*N1*N2, IWORK,
+ $ IERR )
+ END IF
+ GO TO 40
+ END IF
+ DIF( 1 ) = DSCALE / DIF( 1 )
+*
+* 1-norm-based estimate of Difl.
+*
+ 50 CONTINUE
+ CALL DLACN2( MN2, WORK( MN2+1 ), WORK, IWORK, DIF( 2 ),
+ $ KASE, ISAVE )
+ IF( KASE.NE.0 ) THEN
+ IF( KASE.EQ.1 ) THEN
+*
+* Solve generalized Sylvester equation.
+*
+ CALL DTGSYL( 'N', IJB, N2, N1, A( I, I ), LDA, A, LDA,
+ $ WORK, N2, B( I, I ), LDB, B, LDB,
+ $ WORK( N1*N2+1 ), N2, DSCALE, DIF( 2 ),
+ $ WORK( 2*N1*N2+1 ), LWORK-2*N1*N2, IWORK,
+ $ IERR )
+ ELSE
+*
+* Solve the transposed variant.
+*
+ CALL DTGSYL( 'T', IJB, N2, N1, A( I, I ), LDA, A, LDA,
+ $ WORK, N2, B( I, I ), LDB, B, LDB,
+ $ WORK( N1*N2+1 ), N2, DSCALE, DIF( 2 ),
+ $ WORK( 2*N1*N2+1 ), LWORK-2*N1*N2, IWORK,
+ $ IERR )
+ END IF
+ GO TO 50
+ END IF
+ DIF( 2 ) = DSCALE / DIF( 2 )
+*
+ END IF
+ END IF
+*
+ 60 CONTINUE
+*
+* Compute generalized eigenvalues of reordered pair (A, B) and
+* normalize the generalized Schur form.
+*
+ PAIR = .FALSE.
+ DO 80 K = 1, N
+ IF( PAIR ) THEN
+ PAIR = .FALSE.
+ ELSE
+*
+ IF( K.LT.N ) THEN
+ IF( A( K+1, K ).NE.ZERO ) THEN
+ PAIR = .TRUE.
+ END IF
+ END IF
+*
+ IF( PAIR ) THEN
+*
+* Compute the eigenvalue(s) at position K.
+*
+ WORK( 1 ) = A( K, K )
+ WORK( 2 ) = A( K+1, K )
+ WORK( 3 ) = A( K, K+1 )
+ WORK( 4 ) = A( K+1, K+1 )
+ WORK( 5 ) = B( K, K )
+ WORK( 6 ) = B( K+1, K )
+ WORK( 7 ) = B( K, K+1 )
+ WORK( 8 ) = B( K+1, K+1 )
+ CALL DLAG2( WORK, 2, WORK( 5 ), 2, SMLNUM*EPS, BETA( K ),
+ $ BETA( K+1 ), ALPHAR( K ), ALPHAR( K+1 ),
+ $ ALPHAI( K ) )
+ ALPHAI( K+1 ) = -ALPHAI( K )
+*
+ ELSE
+*
+ IF( SIGN( ONE, B( K, K ) ).LT.ZERO ) THEN
+*
+* If B(K,K) is negative, make it positive
+*
+ DO 70 I = 1, N
+ A( K, I ) = -A( K, I )
+ B( K, I ) = -B( K, I )
+ Q( I, K ) = -Q( I, K )
+ 70 CONTINUE
+ END IF
+*
+ ALPHAR( K ) = A( K, K )
+ ALPHAI( K ) = ZERO
+ BETA( K ) = B( K, K )
+*
+ END IF
+ END IF
+ 80 CONTINUE
+*
+ WORK( 1 ) = LWMIN
+ IWORK( 1 ) = LIWMIN
+*
+ RETURN
+*
+* End of DTGSEN
+*
+ END
+ 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 )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER JOBQ, JOBU, JOBV
+ INTEGER INFO, K, L, LDA, LDB, LDQ, LDU, LDV, M, N,
+ $ NCYCLE, P
+ DOUBLE PRECISION TOLA, TOLB
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION A( LDA, * ), ALPHA( * ), B( LDB, * ),
+ $ BETA( * ), Q( LDQ, * ), U( LDU, * ),
+ $ V( LDV, * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DTGSJA computes the generalized singular value decomposition (GSVD)
+* of two real upper triangular (or trapezoidal) matrices A and B.
+*
+* On entry, it is assumed that matrices A and B have the following
+* forms, which may be obtained by the preprocessing subroutine DGGSVP
+* from a general M-by-N matrix A and P-by-N matrix B:
+*
+* N-K-L K L
+* A = K ( 0 A12 A13 ) if M-K-L >= 0;
+* L ( 0 0 A23 )
+* M-K-L ( 0 0 0 )
+*
+* N-K-L K L
+* A = K ( 0 A12 A13 ) if M-K-L < 0;
+* M-K ( 0 0 A23 )
+*
+* N-K-L K L
+* B = L ( 0 0 B13 )
+* P-L ( 0 0 0 )
+*
+* where the K-by-K matrix A12 and L-by-L matrix B13 are nonsingular
+* upper triangular; A23 is L-by-L upper triangular if M-K-L >= 0,
+* otherwise A23 is (M-K)-by-L upper trapezoidal.
+*
+* On exit,
+*
+* U'*A*Q = D1*( 0 R ), V'*B*Q = D2*( 0 R ),
+*
+* where U, V and Q are orthogonal matrices, Z' denotes the transpose
+* of Z, R is a nonsingular upper triangular matrix, and D1 and D2 are
+* ``diagonal'' matrices, which are of the following structures:
+*
+* If M-K-L >= 0,
+*
+* K L
+* D1 = K ( I 0 )
+* L ( 0 C )
+* M-K-L ( 0 0 )
+*
+* K L
+* D2 = L ( 0 S )
+* P-L ( 0 0 )
+*
+* N-K-L K L
+* ( 0 R ) = K ( 0 R11 R12 ) K
+* L ( 0 0 R22 ) L
+*
+* where
+*
+* C = diag( ALPHA(K+1), ... , ALPHA(K+L) ),
+* S = diag( BETA(K+1), ... , BETA(K+L) ),
+* C**2 + S**2 = I.
+*
+* R is stored in A(1:K+L,N-K-L+1:N) on exit.
+*
+* If M-K-L < 0,
+*
+* K M-K K+L-M
+* D1 = K ( I 0 0 )
+* M-K ( 0 C 0 )
+*
+* K M-K K+L-M
+* D2 = M-K ( 0 S 0 )
+* K+L-M ( 0 0 I )
+* P-L ( 0 0 0 )
+*
+* N-K-L K M-K K+L-M
+* ( 0 R ) = K ( 0 R11 R12 R13 )
+* M-K ( 0 0 R22 R23 )
+* K+L-M ( 0 0 0 R33 )
+*
+* where
+* C = diag( ALPHA(K+1), ... , ALPHA(M) ),
+* S = diag( BETA(K+1), ... , BETA(M) ),
+* C**2 + S**2 = I.
+*
+* R = ( R11 R12 R13 ) is stored in A(1:M, N-K-L+1:N) and R33 is stored
+* ( 0 R22 R23 )
+* in B(M-K+1:L,N+M-K-L+1:N) on exit.
+*
+* The computation of the orthogonal transformation matrices U, V or Q
+* is optional. These matrices may either be formed explicitly, or they
+* may be postmultiplied into input matrices U1, V1, or Q1.
+*
+* Arguments
+* =========
+*
+* JOBU (input) CHARACTER*1
+* = 'U': U must contain an orthogonal matrix U1 on entry, and
+* the product U1*U is returned;
+* = 'I': U is initialized to the unit matrix, and the
+* orthogonal matrix U is returned;
+* = 'N': U is not computed.
+*
+* JOBV (input) CHARACTER*1
+* = 'V': V must contain an orthogonal matrix V1 on entry, and
+* the product V1*V is returned;
+* = 'I': V is initialized to the unit matrix, and the
+* orthogonal matrix V is returned;
+* = 'N': V is not computed.
+*
+* JOBQ (input) CHARACTER*1
+* = 'Q': Q must contain an orthogonal matrix Q1 on entry, and
+* the product Q1*Q is returned;
+* = 'I': Q is initialized to the unit matrix, and the
+* orthogonal matrix Q is returned;
+* = 'N': Q is not computed.
+*
+* M (input) INTEGER
+* The number of rows of the matrix A. M >= 0.
+*
+* P (input) INTEGER
+* The number of rows of the matrix B. P >= 0.
+*
+* N (input) INTEGER
+* The number of columns of the matrices A and B. N >= 0.
+*
+* K (input) INTEGER
+* L (input) INTEGER
+* K and L specify the subblocks in the input matrices A and B:
+* A23 = A(K+1:MIN(K+L,M),N-L+1:N) and B13 = B(1:L,N-L+1:N)
+* of A and B, whose GSVD is going to be computed by DTGSJA.
+* See Further details.
+*
+* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+* On entry, the M-by-N matrix A.
+* On exit, A(N-K+1:N,1:MIN(K+L,M) ) contains the triangular
+* matrix R or part of R. See Purpose for details.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,M).
+*
+* B (input/output) DOUBLE PRECISION array, dimension (LDB,N)
+* On entry, the P-by-N matrix B.
+* On exit, if necessary, B(M-K+1:L,N+M-K-L+1:N) contains
+* a part of R. See Purpose for details.
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. LDB >= max(1,P).
+*
+* TOLA (input) DOUBLE PRECISION
+* TOLB (input) DOUBLE PRECISION
+* TOLA and TOLB are the convergence criteria for the Jacobi-
+* Kogbetliantz iteration procedure. Generally, they are the
+* same as used in the preprocessing step, say
+* TOLA = max(M,N)*norm(A)*MAZHEPS,
+* TOLB = max(P,N)*norm(B)*MAZHEPS.
+*
+* ALPHA (output) DOUBLE PRECISION array, dimension (N)
+* BETA (output) DOUBLE PRECISION array, dimension (N)
+* On exit, ALPHA and BETA contain the generalized singular
+* value pairs of A and B;
+* ALPHA(1:K) = 1,
+* BETA(1:K) = 0,
+* and if M-K-L >= 0,
+* ALPHA(K+1:K+L) = diag(C),
+* BETA(K+1:K+L) = diag(S),
+* or if M-K-L < 0,
+* ALPHA(K+1:M)= C, ALPHA(M+1:K+L)= 0
+* BETA(K+1:M) = S, BETA(M+1:K+L) = 1.
+* Furthermore, if K+L < N,
+* ALPHA(K+L+1:N) = 0 and
+* BETA(K+L+1:N) = 0.
+*
+* U (input/output) DOUBLE PRECISION array, dimension (LDU,M)
+* On entry, if JOBU = 'U', U must contain a matrix U1 (usually
+* the orthogonal matrix returned by DGGSVP).
+* On exit,
+* if JOBU = 'I', U contains the orthogonal matrix U;
+* if JOBU = 'U', U contains the product U1*U.
+* If JOBU = 'N', U is not referenced.
+*
+* LDU (input) INTEGER
+* The leading dimension of the array U. LDU >= max(1,M) if
+* JOBU = 'U'; LDU >= 1 otherwise.
+*
+* V (input/output) DOUBLE PRECISION array, dimension (LDV,P)
+* On entry, if JOBV = 'V', V must contain a matrix V1 (usually
+* the orthogonal matrix returned by DGGSVP).
+* On exit,
+* if JOBV = 'I', V contains the orthogonal matrix V;
+* if JOBV = 'V', V contains the product V1*V.
+* If JOBV = 'N', V is not referenced.
+*
+* LDV (input) INTEGER
+* The leading dimension of the array V. LDV >= max(1,P) if
+* JOBV = 'V'; LDV >= 1 otherwise.
+*
+* Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N)
+* On entry, if JOBQ = 'Q', Q must contain a matrix Q1 (usually
+* the orthogonal matrix returned by DGGSVP).
+* On exit,
+* if JOBQ = 'I', Q contains the orthogonal matrix Q;
+* if JOBQ = 'Q', Q contains the product Q1*Q.
+* If JOBQ = 'N', Q is not referenced.
+*
+* LDQ (input) INTEGER
+* The leading dimension of the array Q. LDQ >= max(1,N) if
+* JOBQ = 'Q'; LDQ >= 1 otherwise.
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (2*N)
+*
+* NCYCLE (output) INTEGER
+* The number of cycles required for convergence.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value.
+* = 1: the procedure does not converge after MAXIT cycles.
+*
+* Internal Parameters
+* ===================
+*
+* MAXIT INTEGER
+* MAXIT specifies the total loops that the iterative procedure
+* may take. If after MAXIT cycles, the routine fails to
+* converge, we return INFO = 1.
+*
+* Further Details
+* ===============
+*
+* DTGSJA essentially uses a variant of Kogbetliantz algorithm to reduce
+* min(L,M-K)-by-L triangular (or trapezoidal) matrix A23 and L-by-L
+* matrix B13 to the form:
+*
+* U1'*A13*Q1 = C1*R1; V1'*B13*Q1 = S1*R1,
+*
+* where U1, V1 and Q1 are orthogonal matrix, and Z' is the transpose
+* of Z. C1 and S1 are diagonal matrices satisfying
+*
+* C1**2 + S1**2 = I,
+*
+* and R1 is an L-by-L nonsingular upper triangular matrix.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ INTEGER MAXIT
+ PARAMETER ( MAXIT = 40 )
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+* ..
+* .. Local Scalars ..
+*
+ LOGICAL INITQ, INITU, INITV, UPPER, WANTQ, WANTU, WANTV
+ INTEGER I, J, KCYCLE
+ DOUBLE PRECISION A1, A2, A3, B1, B2, B3, CSQ, CSU, CSV, ERROR,
+ $ GAMMA, RWK, SNQ, SNU, SNV, SSMIN
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL DCOPY, DLAGS2, DLAPLL, DLARTG, DLASET, DROT,
+ $ DSCAL, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+* Decode and test the input parameters
+*
+ INITU = LSAME( JOBU, 'I' )
+ WANTU = INITU .OR. LSAME( JOBU, 'U' )
+*
+ INITV = LSAME( JOBV, 'I' )
+ WANTV = INITV .OR. LSAME( JOBV, 'V' )
+*
+ INITQ = LSAME( JOBQ, 'I' )
+ WANTQ = INITQ .OR. LSAME( JOBQ, 'Q' )
+*
+ INFO = 0
+ IF( .NOT.( INITU .OR. WANTU .OR. LSAME( JOBU, 'N' ) ) ) THEN
+ INFO = -1
+ ELSE IF( .NOT.( INITV .OR. WANTV .OR. LSAME( JOBV, 'N' ) ) ) THEN
+ INFO = -2
+ ELSE IF( .NOT.( INITQ .OR. WANTQ .OR. LSAME( JOBQ, 'N' ) ) ) THEN
+ INFO = -3
+ ELSE IF( M.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( P.LT.0 ) THEN
+ INFO = -5
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -6
+ ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+ INFO = -10
+ ELSE IF( LDB.LT.MAX( 1, P ) ) THEN
+ INFO = -12
+ ELSE IF( LDU.LT.1 .OR. ( WANTU .AND. LDU.LT.M ) ) THEN
+ INFO = -18
+ ELSE IF( LDV.LT.1 .OR. ( WANTV .AND. LDV.LT.P ) ) THEN
+ INFO = -20
+ ELSE IF( LDQ.LT.1 .OR. ( WANTQ .AND. LDQ.LT.N ) ) THEN
+ INFO = -22
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DTGSJA', -INFO )
+ RETURN
+ END IF
+*
+* Initialize U, V and Q, if necessary
+*
+ IF( INITU )
+ $ CALL DLASET( 'Full', M, M, ZERO, ONE, U, LDU )
+ IF( INITV )
+ $ CALL DLASET( 'Full', P, P, ZERO, ONE, V, LDV )
+ IF( INITQ )
+ $ CALL DLASET( 'Full', N, N, ZERO, ONE, Q, LDQ )
+*
+* Loop until convergence
+*
+ UPPER = .FALSE.
+ DO 40 KCYCLE = 1, MAXIT
+*
+ UPPER = .NOT.UPPER
+*
+ DO 20 I = 1, L - 1
+ DO 10 J = I + 1, L
+*
+ A1 = ZERO
+ A2 = ZERO
+ A3 = ZERO
+ IF( K+I.LE.M )
+ $ A1 = A( K+I, N-L+I )
+ IF( K+J.LE.M )
+ $ A3 = A( K+J, N-L+J )
+*
+ B1 = B( I, N-L+I )
+ B3 = B( J, N-L+J )
+*
+ IF( UPPER ) THEN
+ IF( K+I.LE.M )
+ $ A2 = A( K+I, N-L+J )
+ B2 = B( I, N-L+J )
+ ELSE
+ IF( K+J.LE.M )
+ $ A2 = A( K+J, N-L+I )
+ B2 = B( J, N-L+I )
+ END IF
+*
+ CALL DLAGS2( UPPER, A1, A2, A3, B1, B2, B3, CSU, SNU,
+ $ CSV, SNV, CSQ, SNQ )
+*
+* Update (K+I)-th and (K+J)-th rows of matrix A: U'*A
+*
+ IF( K+J.LE.M )
+ $ CALL DROT( L, A( K+J, N-L+1 ), LDA, A( K+I, N-L+1 ),
+ $ LDA, CSU, SNU )
+*
+* Update I-th and J-th rows of matrix B: V'*B
+*
+ CALL DROT( L, B( J, N-L+1 ), LDB, B( I, N-L+1 ), LDB,
+ $ CSV, SNV )
+*
+* Update (N-L+I)-th and (N-L+J)-th columns of matrices
+* A and B: A*Q and B*Q
+*
+ CALL DROT( MIN( K+L, M ), A( 1, N-L+J ), 1,
+ $ A( 1, N-L+I ), 1, CSQ, SNQ )
+*
+ CALL DROT( L, B( 1, N-L+J ), 1, B( 1, N-L+I ), 1, CSQ,
+ $ SNQ )
+*
+ IF( UPPER ) THEN
+ IF( K+I.LE.M )
+ $ A( K+I, N-L+J ) = ZERO
+ B( I, N-L+J ) = ZERO
+ ELSE
+ IF( K+J.LE.M )
+ $ A( K+J, N-L+I ) = ZERO
+ B( J, N-L+I ) = ZERO
+ END IF
+*
+* Update orthogonal matrices U, V, Q, if desired.
+*
+ IF( WANTU .AND. K+J.LE.M )
+ $ CALL DROT( M, U( 1, K+J ), 1, U( 1, K+I ), 1, CSU,
+ $ SNU )
+*
+ IF( WANTV )
+ $ CALL DROT( P, V( 1, J ), 1, V( 1, I ), 1, CSV, SNV )
+*
+ IF( WANTQ )
+ $ CALL DROT( N, Q( 1, N-L+J ), 1, Q( 1, N-L+I ), 1, CSQ,
+ $ SNQ )
+*
+ 10 CONTINUE
+ 20 CONTINUE
+*
+ IF( .NOT.UPPER ) THEN
+*
+* The matrices A13 and B13 were lower triangular at the start
+* of the cycle, and are now upper triangular.
+*
+* Convergence test: test the parallelism of the corresponding
+* rows of A and B.
+*
+ ERROR = ZERO
+ DO 30 I = 1, MIN( L, M-K )
+ CALL DCOPY( L-I+1, A( K+I, N-L+I ), LDA, WORK, 1 )
+ CALL DCOPY( L-I+1, B( I, N-L+I ), LDB, WORK( L+1 ), 1 )
+ CALL DLAPLL( L-I+1, WORK, 1, WORK( L+1 ), 1, SSMIN )
+ ERROR = MAX( ERROR, SSMIN )
+ 30 CONTINUE
+*
+ IF( ABS( ERROR ).LE.MIN( TOLA, TOLB ) )
+ $ GO TO 50
+ END IF
+*
+* End of cycle loop
+*
+ 40 CONTINUE
+*
+* The algorithm has not converged after MAXIT cycles.
+*
+ INFO = 1
+ GO TO 100
+*
+ 50 CONTINUE
+*
+* If ERROR <= MIN(TOLA,TOLB), then the algorithm has converged.
+* Compute the generalized singular value pairs (ALPHA, BETA), and
+* set the triangular matrix R to array A.
+*
+ DO 60 I = 1, K
+ ALPHA( I ) = ONE
+ BETA( I ) = ZERO
+ 60 CONTINUE
+*
+ DO 70 I = 1, MIN( L, M-K )
+*
+ A1 = A( K+I, N-L+I )
+ B1 = B( I, N-L+I )
+*
+ IF( A1.NE.ZERO ) THEN
+ GAMMA = B1 / A1
+*
+* change sign if necessary
+*
+ IF( GAMMA.LT.ZERO ) THEN
+ CALL DSCAL( L-I+1, -ONE, B( I, N-L+I ), LDB )
+ IF( WANTV )
+ $ CALL DSCAL( P, -ONE, V( 1, I ), 1 )
+ END IF
+*
+ CALL DLARTG( ABS( GAMMA ), ONE, BETA( K+I ), ALPHA( K+I ),
+ $ RWK )
+*
+ IF( ALPHA( K+I ).GE.BETA( K+I ) ) THEN
+ CALL DSCAL( L-I+1, ONE / ALPHA( K+I ), A( K+I, N-L+I ),
+ $ LDA )
+ ELSE
+ CALL DSCAL( L-I+1, ONE / BETA( K+I ), B( I, N-L+I ),
+ $ LDB )
+ CALL DCOPY( L-I+1, B( I, N-L+I ), LDB, A( K+I, N-L+I ),
+ $ LDA )
+ END IF
+*
+ ELSE
+*
+ ALPHA( K+I ) = ZERO
+ BETA( K+I ) = ONE
+ CALL DCOPY( L-I+1, B( I, N-L+I ), LDB, A( K+I, N-L+I ),
+ $ LDA )
+*
+ END IF
+*
+ 70 CONTINUE
+*
+* Post-assignment
+*
+ DO 80 I = M + 1, K + L
+ ALPHA( I ) = ZERO
+ BETA( I ) = ONE
+ 80 CONTINUE
+*
+ IF( K+L.LT.N ) THEN
+ DO 90 I = K + L + 1, N
+ ALPHA( I ) = ZERO
+ BETA( I ) = ZERO
+ 90 CONTINUE
+ END IF
+*
+ 100 CONTINUE
+ NCYCLE = KCYCLE
+ RETURN
+*
+* End of DTGSJA
+*
+ END
+ SUBROUTINE DTGSNA( JOB, HOWMNY, SELECT, N, A, LDA, B, LDB, VL,
+ $ LDVL, VR, LDVR, S, DIF, MM, M, WORK, LWORK,
+ $ IWORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER HOWMNY, JOB
+ INTEGER INFO, LDA, LDB, LDVL, LDVR, LWORK, M, MM, N
+* ..
+* .. Array Arguments ..
+ LOGICAL SELECT( * )
+ INTEGER IWORK( * )
+ DOUBLE PRECISION A( LDA, * ), B( LDB, * ), DIF( * ), S( * ),
+ $ VL( LDVL, * ), VR( LDVR, * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DTGSNA estimates reciprocal condition numbers for specified
+* eigenvalues and/or eigenvectors of a matrix pair (A, B) in
+* generalized real Schur canonical form (or of any matrix pair
+* (Q*A*Z', Q*B*Z') with orthogonal matrices Q and Z, where
+* Z' denotes the transpose of Z.
+*
+* (A, B) must be in generalized real Schur form (as returned by DGGES),
+* i.e. A is block upper triangular with 1-by-1 and 2-by-2 diagonal
+* blocks. B is upper triangular.
+*
+*
+* Arguments
+* =========
+*
+* JOB (input) CHARACTER*1
+* Specifies whether condition numbers are required for
+* eigenvalues (S) or eigenvectors (DIF):
+* = 'E': for eigenvalues only (S);
+* = 'V': for eigenvectors only (DIF);
+* = 'B': for both eigenvalues and eigenvectors (S and DIF).
+*
+* HOWMNY (input) CHARACTER*1
+* = 'A': compute condition numbers for all eigenpairs;
+* = 'S': compute condition numbers for selected eigenpairs
+* specified by the array SELECT.
+*
+* SELECT (input) LOGICAL array, dimension (N)
+* If HOWMNY = 'S', SELECT specifies the eigenpairs for which
+* condition numbers are required. To select condition numbers
+* for the eigenpair corresponding to a real eigenvalue w(j),
+* SELECT(j) must be set to .TRUE.. To select condition numbers
+* corresponding to a complex conjugate pair of eigenvalues w(j)
+* and w(j+1), either SELECT(j) or SELECT(j+1) or both, must be
+* set to .TRUE..
+* If HOWMNY = 'A', SELECT is not referenced.
+*
+* N (input) INTEGER
+* The order of the square matrix pair (A, B). N >= 0.
+*
+* A (input) DOUBLE PRECISION array, dimension (LDA,N)
+* The upper quasi-triangular matrix A in the pair (A,B).
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,N).
+*
+* B (input) DOUBLE PRECISION array, dimension (LDB,N)
+* The upper triangular matrix B in the pair (A,B).
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. LDB >= max(1,N).
+*
+* VL (input) DOUBLE PRECISION array, dimension (LDVL,M)
+* If JOB = 'E' or 'B', VL must contain left eigenvectors of
+* (A, B), corresponding to the eigenpairs specified by HOWMNY
+* and SELECT. The eigenvectors must be stored in consecutive
+* columns of VL, as returned by DTGEVC.
+* If JOB = 'V', VL is not referenced.
+*
+* LDVL (input) INTEGER
+* The leading dimension of the array VL. LDVL >= 1.
+* If JOB = 'E' or 'B', LDVL >= N.
+*
+* VR (input) DOUBLE PRECISION array, dimension (LDVR,M)
+* If JOB = 'E' or 'B', VR must contain right eigenvectors of
+* (A, B), corresponding to the eigenpairs specified by HOWMNY
+* and SELECT. The eigenvectors must be stored in consecutive
+* columns ov VR, as returned by DTGEVC.
+* If JOB = 'V', VR is not referenced.
+*
+* LDVR (input) INTEGER
+* The leading dimension of the array VR. LDVR >= 1.
+* If JOB = 'E' or 'B', LDVR >= N.
+*
+* S (output) DOUBLE PRECISION array, dimension (MM)
+* If JOB = 'E' or 'B', the reciprocal condition numbers of the
+* selected eigenvalues, stored in consecutive elements of the
+* array. For a complex conjugate pair of eigenvalues two
+* consecutive elements of S are set to the same value. Thus
+* S(j), DIF(j), and the j-th columns of VL and VR all
+* correspond to the same eigenpair (but not in general the
+* j-th eigenpair, unless all eigenpairs are selected).
+* If JOB = 'V', S is not referenced.
+*
+* DIF (output) DOUBLE PRECISION array, dimension (MM)
+* If JOB = 'V' or 'B', the estimated reciprocal condition
+* numbers of the selected eigenvectors, stored in consecutive
+* elements of the array. For a complex eigenvector two
+* consecutive elements of DIF are set to the same value. If
+* the eigenvalues cannot be reordered to compute DIF(j), DIF(j)
+* is set to 0; this can only occur when the true value would be
+* very small anyway.
+* If JOB = 'E', DIF is not referenced.
+*
+* MM (input) INTEGER
+* The number of elements in the arrays S and DIF. MM >= M.
+*
+* M (output) INTEGER
+* The number of elements of the arrays S and DIF used to store
+* the specified condition numbers; for each selected real
+* eigenvalue one element is used, and for each selected complex
+* conjugate pair of eigenvalues, two elements are used.
+* If HOWMNY = 'A', M is set to N.
+*
+* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
+* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+* LWORK (input) INTEGER
+* The dimension of the array WORK. LWORK >= max(1,N).
+* If JOB = 'V' or 'B' LWORK >= 2*N*(N+2)+16.
+*
+* If LWORK = -1, then a workspace query is assumed; the routine
+* only calculates the optimal size of the WORK array, returns
+* this value as the first entry of the WORK array, and no error
+* message related to LWORK is issued by XERBLA.
+*
+* IWORK (workspace) INTEGER array, dimension (N + 6)
+* If JOB = 'E', IWORK is not referenced.
+*
+* INFO (output) INTEGER
+* =0: Successful exit
+* <0: If INFO = -i, the i-th argument had an illegal value
+*
+*
+* Further Details
+* ===============
+*
+* The reciprocal of the condition number of a generalized eigenvalue
+* w = (a, b) is defined as
+*
+* S(w) = (|u'Av|**2 + |u'Bv|**2)**(1/2) / (norm(u)*norm(v))
+*
+* where u and v are the left and right eigenvectors of (A, B)
+* corresponding to w; |z| denotes the absolute value of the complex
+* number, and norm(u) denotes the 2-norm of the vector u.
+* The pair (a, b) corresponds to an eigenvalue w = a/b (= u'Av/u'Bv)
+* of the matrix pair (A, B). If both a and b equal zero, then (A B) is
+* singular and S(I) = -1 is returned.
+*
+* An approximate error bound on the chordal distance between the i-th
+* computed generalized eigenvalue w and the corresponding exact
+* eigenvalue lambda is
+*
+* chord(w, lambda) <= EPS * norm(A, B) / S(I)
+*
+* where EPS is the machine precision.
+*
+* The reciprocal of the condition number DIF(i) of right eigenvector u
+* and left eigenvector v corresponding to the generalized eigenvalue w
+* is defined as follows:
+*
+* a) If the i-th eigenvalue w = (a,b) is real
+*
+* Suppose U and V are orthogonal transformations such that
+*
+* U'*(A, B)*V = (S, T) = ( a * ) ( b * ) 1
+* ( 0 S22 ),( 0 T22 ) n-1
+* 1 n-1 1 n-1
+*
+* Then the reciprocal condition number DIF(i) is
+*
+* Difl((a, b), (S22, T22)) = sigma-min( Zl ),
+*
+* where sigma-min(Zl) denotes the smallest singular value of the
+* 2(n-1)-by-2(n-1) matrix
+*
+* Zl = [ kron(a, In-1) -kron(1, S22) ]
+* [ kron(b, In-1) -kron(1, T22) ] .
+*
+* Here In-1 is the identity matrix of size n-1. kron(X, Y) is the
+* Kronecker product between the matrices X and Y.
+*
+* Note that if the default method for computing DIF(i) is wanted
+* (see DLATDF), then the parameter DIFDRI (see below) should be
+* changed from 3 to 4 (routine DLATDF(IJOB = 2 will be used)).
+* See DTGSYL for more details.
+*
+* b) If the i-th and (i+1)-th eigenvalues are complex conjugate pair,
+*
+* Suppose U and V are orthogonal transformations such that
+*
+* U'*(A, B)*V = (S, T) = ( S11 * ) ( T11 * ) 2
+* ( 0 S22 ),( 0 T22) n-2
+* 2 n-2 2 n-2
+*
+* and (S11, T11) corresponds to the complex conjugate eigenvalue
+* pair (w, conjg(w)). There exist unitary matrices U1 and V1 such
+* that
+*
+* U1'*S11*V1 = ( s11 s12 ) and U1'*T11*V1 = ( t11 t12 )
+* ( 0 s22 ) ( 0 t22 )
+*
+* where the generalized eigenvalues w = s11/t11 and
+* conjg(w) = s22/t22.
+*
+* Then the reciprocal condition number DIF(i) is bounded by
+*
+* min( d1, max( 1, |real(s11)/real(s22)| )*d2 )
+*
+* where, d1 = Difl((s11, t11), (s22, t22)) = sigma-min(Z1), where
+* Z1 is the complex 2-by-2 matrix
+*
+* Z1 = [ s11 -s22 ]
+* [ t11 -t22 ],
+*
+* This is done by computing (using real arithmetic) the
+* roots of the characteristical polynomial det(Z1' * Z1 - lambda I),
+* where Z1' denotes the conjugate transpose of Z1 and det(X) denotes
+* the determinant of X.
+*
+* and d2 is an upper bound on Difl((S11, T11), (S22, T22)), i.e. an
+* upper bound on sigma-min(Z2), where Z2 is (2n-2)-by-(2n-2)
+*
+* Z2 = [ kron(S11', In-2) -kron(I2, S22) ]
+* [ kron(T11', In-2) -kron(I2, T22) ]
+*
+* Note that if the default method for computing DIF is wanted (see
+* DLATDF), then the parameter DIFDRI (see below) should be changed
+* from 3 to 4 (routine DLATDF(IJOB = 2 will be used)). See DTGSYL
+* for more details.
+*
+* For each eigenvalue/vector specified by SELECT, DIF stores a
+* Frobenius norm-based estimate of Difl.
+*
+* An approximate error bound for the i-th computed eigenvector VL(i) or
+* VR(i) is given by
+*
+* EPS * norm(A, B) / DIF(i).
+*
+* See ref. [2-3] for more details and further references.
+*
+* Based on contributions by
+* Bo Kagstrom and Peter Poromaa, Department of Computing Science,
+* Umea University, S-901 87 Umea, Sweden.
+*
+* References
+* ==========
+*
+* [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the
+* Generalized Real Schur Form of a Regular Matrix Pair (A, B), in
+* M.S. Moonen et al (eds), Linear Algebra for Large Scale and
+* Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218.
+*
+* [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified
+* Eigenvalues of a Regular Matrix Pair (A, B) and Condition
+* Estimation: Theory, Algorithms and Software,
+* Report UMINF - 94.04, Department of Computing Science, Umea
+* University, S-901 87 Umea, Sweden, 1994. Also as LAPACK Working
+* Note 87. To appear in Numerical Algorithms, 1996.
+*
+* [3] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software
+* for Solving the Generalized Sylvester Equation and Estimating the
+* Separation between Regular Matrix Pairs, Report UMINF - 93.23,
+* Department of Computing Science, Umea University, S-901 87 Umea,
+* Sweden, December 1993, Revised April 1994, Also as LAPACK Working
+* Note 75. To appear in ACM Trans. on Math. Software, Vol 22,
+* No 1, 1996.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ INTEGER DIFDRI
+ PARAMETER ( DIFDRI = 3 )
+ DOUBLE PRECISION ZERO, ONE, TWO, FOUR
+ PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0,
+ $ FOUR = 4.0D+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL LQUERY, PAIR, SOMCON, WANTBH, WANTDF, WANTS
+ INTEGER I, IERR, IFST, ILST, IZ, K, KS, LWMIN, N1, N2
+ DOUBLE PRECISION ALPHAI, ALPHAR, ALPRQT, BETA, C1, C2, COND,
+ $ EPS, LNRM, RNRM, ROOT1, ROOT2, SCALE, SMLNUM,
+ $ TMPII, TMPIR, TMPRI, TMPRR, UHAV, UHAVI, UHBV,
+ $ UHBVI
+* ..
+* .. Local Arrays ..
+ DOUBLE PRECISION DUMMY( 1 ), DUMMY1( 1 )
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ DOUBLE PRECISION DDOT, DLAMCH, DLAPY2, DNRM2
+ EXTERNAL LSAME, DDOT, DLAMCH, DLAPY2, DNRM2
+* ..
+* .. External Subroutines ..
+ EXTERNAL DGEMV, DLACPY, DLAG2, DTGEXC, DTGSYL, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN, SQRT
+* ..
+* .. Executable Statements ..
+*
+* Decode and test the input parameters
+*
+ WANTBH = LSAME( JOB, 'B' )
+ WANTS = LSAME( JOB, 'E' ) .OR. WANTBH
+ WANTDF = LSAME( JOB, 'V' ) .OR. WANTBH
+*
+ SOMCON = LSAME( HOWMNY, 'S' )
+*
+ INFO = 0
+ LQUERY = ( LWORK.EQ.-1 )
+*
+ IF( .NOT.WANTS .AND. .NOT.WANTDF ) THEN
+ INFO = -1
+ ELSE IF( .NOT.LSAME( HOWMNY, 'A' ) .AND. .NOT.SOMCON ) THEN
+ INFO = -2
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -6
+ ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -8
+ ELSE IF( WANTS .AND. LDVL.LT.N ) THEN
+ INFO = -10
+ ELSE IF( WANTS .AND. LDVR.LT.N ) THEN
+ INFO = -12
+ ELSE
+*
+* Set M to the number of eigenpairs for which condition numbers
+* are required, and test MM.
+*
+ IF( SOMCON ) THEN
+ M = 0
+ PAIR = .FALSE.
+ DO 10 K = 1, N
+ IF( PAIR ) THEN
+ PAIR = .FALSE.
+ ELSE
+ IF( K.LT.N ) THEN
+ IF( A( K+1, K ).EQ.ZERO ) THEN
+ IF( SELECT( K ) )
+ $ M = M + 1
+ ELSE
+ PAIR = .TRUE.
+ IF( SELECT( K ) .OR. SELECT( K+1 ) )
+ $ M = M + 2
+ END IF
+ ELSE
+ IF( SELECT( N ) )
+ $ M = M + 1
+ END IF
+ END IF
+ 10 CONTINUE
+ ELSE
+ M = N
+ END IF
+*
+ IF( N.EQ.0 ) THEN
+ LWMIN = 1
+ ELSE IF( LSAME( JOB, 'V' ) .OR. LSAME( JOB, 'B' ) ) THEN
+ LWMIN = 2*N*( N + 2 ) + 16
+ ELSE
+ LWMIN = N
+ END IF
+ WORK( 1 ) = LWMIN
+*
+ IF( MM.LT.M ) THEN
+ INFO = -15
+ ELSE IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
+ INFO = -18
+ END IF
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DTGSNA', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+* Get machine constants
+*
+ EPS = DLAMCH( 'P' )
+ SMLNUM = DLAMCH( 'S' ) / EPS
+ KS = 0
+ PAIR = .FALSE.
+*
+ DO 20 K = 1, N
+*
+* Determine whether A(k,k) begins a 1-by-1 or 2-by-2 block.
+*
+ IF( PAIR ) THEN
+ PAIR = .FALSE.
+ GO TO 20
+ ELSE
+ IF( K.LT.N )
+ $ PAIR = A( K+1, K ).NE.ZERO
+ END IF
+*
+* Determine whether condition numbers are required for the k-th
+* eigenpair.
+*
+ IF( SOMCON ) THEN
+ IF( PAIR ) THEN
+ IF( .NOT.SELECT( K ) .AND. .NOT.SELECT( K+1 ) )
+ $ GO TO 20
+ ELSE
+ IF( .NOT.SELECT( K ) )
+ $ GO TO 20
+ END IF
+ END IF
+*
+ KS = KS + 1
+*
+ IF( WANTS ) THEN
+*
+* Compute the reciprocal condition number of the k-th
+* eigenvalue.
+*
+ IF( PAIR ) THEN
+*
+* Complex eigenvalue pair.
+*
+ RNRM = DLAPY2( DNRM2( N, VR( 1, KS ), 1 ),
+ $ DNRM2( N, VR( 1, KS+1 ), 1 ) )
+ LNRM = DLAPY2( DNRM2( N, VL( 1, KS ), 1 ),
+ $ DNRM2( N, VL( 1, KS+1 ), 1 ) )
+ CALL DGEMV( 'N', N, N, ONE, A, LDA, VR( 1, KS ), 1, ZERO,
+ $ WORK, 1 )
+ TMPRR = DDOT( N, WORK, 1, VL( 1, KS ), 1 )
+ TMPRI = DDOT( N, WORK, 1, VL( 1, KS+1 ), 1 )
+ CALL DGEMV( 'N', N, N, ONE, A, LDA, VR( 1, KS+1 ), 1,
+ $ ZERO, WORK, 1 )
+ TMPII = DDOT( N, WORK, 1, VL( 1, KS+1 ), 1 )
+ TMPIR = DDOT( N, WORK, 1, VL( 1, KS ), 1 )
+ UHAV = TMPRR + TMPII
+ UHAVI = TMPIR - TMPRI
+ CALL DGEMV( 'N', N, N, ONE, B, LDB, VR( 1, KS ), 1, ZERO,
+ $ WORK, 1 )
+ TMPRR = DDOT( N, WORK, 1, VL( 1, KS ), 1 )
+ TMPRI = DDOT( N, WORK, 1, VL( 1, KS+1 ), 1 )
+ CALL DGEMV( 'N', N, N, ONE, B, LDB, VR( 1, KS+1 ), 1,
+ $ ZERO, WORK, 1 )
+ TMPII = DDOT( N, WORK, 1, VL( 1, KS+1 ), 1 )
+ TMPIR = DDOT( N, WORK, 1, VL( 1, KS ), 1 )
+ UHBV = TMPRR + TMPII
+ UHBVI = TMPIR - TMPRI
+ UHAV = DLAPY2( UHAV, UHAVI )
+ UHBV = DLAPY2( UHBV, UHBVI )
+ COND = DLAPY2( UHAV, UHBV )
+ S( KS ) = COND / ( RNRM*LNRM )
+ S( KS+1 ) = S( KS )
+*
+ ELSE
+*
+* Real eigenvalue.
+*
+ RNRM = DNRM2( N, VR( 1, KS ), 1 )
+ LNRM = DNRM2( N, VL( 1, KS ), 1 )
+ CALL DGEMV( 'N', N, N, ONE, A, LDA, VR( 1, KS ), 1, ZERO,
+ $ WORK, 1 )
+ UHAV = DDOT( N, WORK, 1, VL( 1, KS ), 1 )
+ CALL DGEMV( 'N', N, N, ONE, B, LDB, VR( 1, KS ), 1, ZERO,
+ $ WORK, 1 )
+ UHBV = DDOT( N, WORK, 1, VL( 1, KS ), 1 )
+ COND = DLAPY2( UHAV, UHBV )
+ IF( COND.EQ.ZERO ) THEN
+ S( KS ) = -ONE
+ ELSE
+ S( KS ) = COND / ( RNRM*LNRM )
+ END IF
+ END IF
+ END IF
+*
+ IF( WANTDF ) THEN
+ IF( N.EQ.1 ) THEN
+ DIF( KS ) = DLAPY2( A( 1, 1 ), B( 1, 1 ) )
+ GO TO 20
+ END IF
+*
+* Estimate the reciprocal condition number of the k-th
+* eigenvectors.
+ IF( PAIR ) THEN
+*
+* Copy the 2-by 2 pencil beginning at (A(k,k), B(k, k)).
+* Compute the eigenvalue(s) at position K.
+*
+ WORK( 1 ) = A( K, K )
+ WORK( 2 ) = A( K+1, K )
+ WORK( 3 ) = A( K, K+1 )
+ WORK( 4 ) = A( K+1, K+1 )
+ WORK( 5 ) = B( K, K )
+ WORK( 6 ) = B( K+1, K )
+ WORK( 7 ) = B( K, K+1 )
+ WORK( 8 ) = B( K+1, K+1 )
+ CALL DLAG2( WORK, 2, WORK( 5 ), 2, SMLNUM*EPS, BETA,
+ $ DUMMY1( 1 ), ALPHAR, DUMMY( 1 ), ALPHAI )
+ ALPRQT = ONE
+ C1 = TWO*( ALPHAR*ALPHAR+ALPHAI*ALPHAI+BETA*BETA )
+ C2 = FOUR*BETA*BETA*ALPHAI*ALPHAI
+ ROOT1 = C1 + SQRT( C1*C1-4.0D0*C2 )
+ ROOT2 = C2 / ROOT1
+ ROOT1 = ROOT1 / TWO
+ COND = MIN( SQRT( ROOT1 ), SQRT( ROOT2 ) )
+ END IF
+*
+* Copy the matrix (A, B) to the array WORK and swap the
+* diagonal block beginning at A(k,k) to the (1,1) position.
+*
+ CALL DLACPY( 'Full', N, N, A, LDA, WORK, N )
+ CALL DLACPY( 'Full', N, N, B, LDB, WORK( N*N+1 ), N )
+ IFST = K
+ ILST = 1
+*
+ CALL DTGEXC( .FALSE., .FALSE., N, WORK, N, WORK( N*N+1 ), N,
+ $ DUMMY, 1, DUMMY1, 1, IFST, ILST,
+ $ WORK( N*N*2+1 ), LWORK-2*N*N, IERR )
+*
+ IF( IERR.GT.0 ) THEN
+*
+* Ill-conditioned problem - swap rejected.
+*
+ DIF( KS ) = ZERO
+ ELSE
+*
+* Reordering successful, solve generalized Sylvester
+* equation for R and L,
+* A22 * R - L * A11 = A12
+* B22 * R - L * B11 = B12,
+* and compute estimate of Difl((A11,B11), (A22, B22)).
+*
+ N1 = 1
+ IF( WORK( 2 ).NE.ZERO )
+ $ N1 = 2
+ N2 = N - N1
+ IF( N2.EQ.0 ) THEN
+ DIF( KS ) = COND
+ ELSE
+ I = N*N + 1
+ IZ = 2*N*N + 1
+ CALL DTGSYL( 'N', DIFDRI, N2, N1, WORK( N*N1+N1+1 ),
+ $ N, WORK, N, WORK( N1+1 ), N,
+ $ WORK( N*N1+N1+I ), N, WORK( I ), N,
+ $ WORK( N1+I ), N, SCALE, DIF( KS ),
+ $ WORK( IZ+1 ), LWORK-2*N*N, IWORK, IERR )
+*
+ IF( PAIR )
+ $ DIF( KS ) = MIN( MAX( ONE, ALPRQT )*DIF( KS ),
+ $ COND )
+ END IF
+ END IF
+ IF( PAIR )
+ $ DIF( KS+1 ) = DIF( KS )
+ END IF
+ IF( PAIR )
+ $ KS = KS + 1
+*
+ 20 CONTINUE
+ WORK( 1 ) = LWMIN
+ RETURN
+*
+* End of DTGSNA
+*
+ END
+ SUBROUTINE DTGSY2( TRANS, IJOB, M, N, A, LDA, B, LDB, C, LDC, D,
+ $ LDD, E, LDE, F, LDF, SCALE, RDSUM, RDSCAL,
+ $ IWORK, PQ, INFO )
+*
+* -- LAPACK auxiliary routine (version 3.1.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* January 2007
+*
+* .. Scalar Arguments ..
+ CHARACTER TRANS
+ INTEGER IJOB, INFO, LDA, LDB, LDC, LDD, LDE, LDF, M, N,
+ $ PQ
+ DOUBLE PRECISION RDSCAL, RDSUM, SCALE
+* ..
+* .. Array Arguments ..
+ INTEGER IWORK( * )
+ DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ),
+ $ D( LDD, * ), E( LDE, * ), F( LDF, * )
+* ..
+*
+* Purpose
+* =======
+*
+* DTGSY2 solves the generalized Sylvester equation:
+*
+* A * R - L * B = scale * C (1)
+* D * R - L * E = scale * F,
+*
+* using Level 1 and 2 BLAS. where R and L are unknown M-by-N matrices,
+* (A, D), (B, E) and (C, F) are given matrix pairs of size M-by-M,
+* N-by-N and M-by-N, respectively, with real entries. (A, D) and (B, E)
+* must be in generalized Schur canonical form, i.e. A, B are upper
+* quasi triangular and D, E are upper triangular. The solution (R, L)
+* overwrites (C, F). 0 <= SCALE <= 1 is an output scaling factor
+* chosen to avoid overflow.
+*
+* In matrix notation solving equation (1) corresponds to solve
+* Z*x = scale*b, where Z is defined as
+*
+* Z = [ kron(In, A) -kron(B', Im) ] (2)
+* [ kron(In, D) -kron(E', Im) ],
+*
+* Ik is the identity matrix of size k and X' is the transpose of X.
+* kron(X, Y) is the Kronecker product between the matrices X and Y.
+* In the process of solving (1), we solve a number of such systems
+* where Dim(In), Dim(In) = 1 or 2.
+*
+* If TRANS = 'T', solve the transposed system Z'*y = scale*b for y,
+* which is equivalent to solve for R and L in
+*
+* A' * R + D' * L = scale * C (3)
+* R * B' + L * E' = scale * -F
+*
+* This case is used to compute an estimate of Dif[(A, D), (B, E)] =
+* sigma_min(Z) using reverse communicaton with DLACON.
+*
+* DTGSY2 also (IJOB >= 1) contributes to the computation in DTGSYL
+* of an upper bound on the separation between to matrix pairs. Then
+* the input (A, D), (B, E) are sub-pencils of the matrix pair in
+* DTGSYL. See DTGSYL for details.
+*
+* Arguments
+* =========
+*
+* TRANS (input) CHARACTER*1
+* = 'N', solve the generalized Sylvester equation (1).
+* = 'T': solve the 'transposed' system (3).
+*
+* IJOB (input) INTEGER
+* Specifies what kind of functionality to be performed.
+* = 0: solve (1) only.
+* = 1: A contribution from this subsystem to a Frobenius
+* norm-based estimate of the separation between two matrix
+* pairs is computed. (look ahead strategy is used).
+* = 2: A contribution from this subsystem to a Frobenius
+* norm-based estimate of the separation between two matrix
+* pairs is computed. (DGECON on sub-systems is used.)
+* Not referenced if TRANS = 'T'.
+*
+* M (input) INTEGER
+* On entry, M specifies the order of A and D, and the row
+* dimension of C, F, R and L.
+*
+* N (input) INTEGER
+* On entry, N specifies the order of B and E, and the column
+* dimension of C, F, R and L.
+*
+* A (input) DOUBLE PRECISION array, dimension (LDA, M)
+* On entry, A contains an upper quasi triangular matrix.
+*
+* LDA (input) INTEGER
+* The leading dimension of the matrix A. LDA >= max(1, M).
+*
+* B (input) DOUBLE PRECISION array, dimension (LDB, N)
+* On entry, B contains an upper quasi triangular matrix.
+*
+* LDB (input) INTEGER
+* The leading dimension of the matrix B. LDB >= max(1, N).
+*
+* C (input/output) DOUBLE PRECISION array, dimension (LDC, N)
+* On entry, C contains the right-hand-side of the first matrix
+* equation in (1).
+* On exit, if IJOB = 0, C has been overwritten by the
+* solution R.
+*
+* LDC (input) INTEGER
+* The leading dimension of the matrix C. LDC >= max(1, M).
+*
+* D (input) DOUBLE PRECISION array, dimension (LDD, M)
+* On entry, D contains an upper triangular matrix.
+*
+* LDD (input) INTEGER
+* The leading dimension of the matrix D. LDD >= max(1, M).
+*
+* E (input) DOUBLE PRECISION array, dimension (LDE, N)
+* On entry, E contains an upper triangular matrix.
+*
+* LDE (input) INTEGER
+* The leading dimension of the matrix E. LDE >= max(1, N).
+*
+* F (input/output) DOUBLE PRECISION array, dimension (LDF, N)
+* On entry, F contains the right-hand-side of the second matrix
+* equation in (1).
+* On exit, if IJOB = 0, F has been overwritten by the
+* solution L.
+*
+* LDF (input) INTEGER
+* The leading dimension of the matrix F. LDF >= max(1, M).
+*
+* SCALE (output) DOUBLE PRECISION
+* On exit, 0 <= SCALE <= 1. If 0 < SCALE < 1, the solutions
+* R and L (C and F on entry) will hold the solutions to a
+* slightly perturbed system but the input matrices A, B, D and
+* E have not been changed. If SCALE = 0, R and L will hold the
+* solutions to the homogeneous system with C = F = 0. Normally,
+* SCALE = 1.
+*
+* RDSUM (input/output) DOUBLE PRECISION
+* On entry, the sum of squares of computed contributions to
+* the Dif-estimate under computation by DTGSYL, where the
+* scaling factor RDSCAL (see below) has been factored out.
+* On exit, the corresponding sum of squares updated with the
+* contributions from the current sub-system.
+* If TRANS = 'T' RDSUM is not touched.
+* NOTE: RDSUM only makes sense when DTGSY2 is called by DTGSYL.
+*
+* RDSCAL (input/output) DOUBLE PRECISION
+* On entry, scaling factor used to prevent overflow in RDSUM.
+* On exit, RDSCAL is updated w.r.t. the current contributions
+* in RDSUM.
+* If TRANS = 'T', RDSCAL is not touched.
+* NOTE: RDSCAL only makes sense when DTGSY2 is called by
+* DTGSYL.
+*
+* IWORK (workspace) INTEGER array, dimension (M+N+2)
+*
+* PQ (output) INTEGER
+* On exit, the number of subsystems (of size 2-by-2, 4-by-4 and
+* 8-by-8) solved by this routine.
+*
+* INFO (output) INTEGER
+* On exit, if INFO is set to
+* =0: Successful exit
+* <0: If INFO = -i, the i-th argument had an illegal value.
+* >0: The matrix pairs (A, D) and (B, E) have common or very
+* close eigenvalues.
+*
+* Further Details
+* ===============
+*
+* Based on contributions by
+* Bo Kagstrom and Peter Poromaa, Department of Computing Science,
+* Umea University, S-901 87 Umea, Sweden.
+*
+* =====================================================================
+* Replaced various illegal calls to DCOPY by calls to DLASET.
+* Sven Hammarling, 27/5/02.
+*
+* .. Parameters ..
+ INTEGER LDZ
+ PARAMETER ( LDZ = 8 )
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL NOTRAN
+ INTEGER I, IE, IERR, II, IS, ISP1, J, JE, JJ, JS, JSP1,
+ $ K, MB, NB, P, Q, ZDIM
+ DOUBLE PRECISION ALPHA, SCALOC
+* ..
+* .. Local Arrays ..
+ INTEGER IPIV( LDZ ), JPIV( LDZ )
+ DOUBLE PRECISION RHS( LDZ ), Z( LDZ, LDZ )
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL DAXPY, DCOPY, DGEMM, DGEMV, DGER, DGESC2,
+ $ DGETC2, DLASET, DLATDF, DSCAL, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+* Decode and test input parameters
+*
+ INFO = 0
+ IERR = 0
+ NOTRAN = LSAME( TRANS, 'N' )
+ IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN
+ INFO = -1
+ ELSE IF( NOTRAN ) THEN
+ IF( ( IJOB.LT.0 ) .OR. ( IJOB.GT.2 ) ) THEN
+ INFO = -2
+ END IF
+ END IF
+ IF( INFO.EQ.0 ) THEN
+ IF( M.LE.0 ) THEN
+ INFO = -3
+ ELSE IF( N.LE.0 ) THEN
+ INFO = -4
+ ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+ INFO = -5
+ ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -8
+ ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
+ INFO = -10
+ ELSE IF( LDD.LT.MAX( 1, M ) ) THEN
+ INFO = -12
+ ELSE IF( LDE.LT.MAX( 1, N ) ) THEN
+ INFO = -14
+ ELSE IF( LDF.LT.MAX( 1, M ) ) THEN
+ INFO = -16
+ END IF
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DTGSY2', -INFO )
+ RETURN
+ END IF
+*
+* Determine block structure of A
+*
+ PQ = 0
+ P = 0
+ I = 1
+ 10 CONTINUE
+ IF( I.GT.M )
+ $ GO TO 20
+ P = P + 1
+ IWORK( P ) = I
+ IF( I.EQ.M )
+ $ GO TO 20
+ IF( A( I+1, I ).NE.ZERO ) THEN
+ I = I + 2
+ ELSE
+ I = I + 1
+ END IF
+ GO TO 10
+ 20 CONTINUE
+ IWORK( P+1 ) = M + 1
+*
+* Determine block structure of B
+*
+ Q = P + 1
+ J = 1
+ 30 CONTINUE
+ IF( J.GT.N )
+ $ GO TO 40
+ Q = Q + 1
+ IWORK( Q ) = J
+ IF( J.EQ.N )
+ $ GO TO 40
+ IF( B( J+1, J ).NE.ZERO ) THEN
+ J = J + 2
+ ELSE
+ J = J + 1
+ END IF
+ GO TO 30
+ 40 CONTINUE
+ IWORK( Q+1 ) = N + 1
+ PQ = P*( Q-P-1 )
+*
+ IF( NOTRAN ) THEN
+*
+* Solve (I, J) - subsystem
+* A(I, I) * R(I, J) - L(I, J) * B(J, J) = C(I, J)
+* D(I, I) * R(I, J) - L(I, J) * E(J, J) = F(I, J)
+* for I = P, P - 1, ..., 1; J = 1, 2, ..., Q
+*
+ SCALE = ONE
+ SCALOC = ONE
+ DO 120 J = P + 2, Q
+ JS = IWORK( J )
+ JSP1 = JS + 1
+ JE = IWORK( J+1 ) - 1
+ NB = JE - JS + 1
+ DO 110 I = P, 1, -1
+*
+ IS = IWORK( I )
+ ISP1 = IS + 1
+ IE = IWORK( I+1 ) - 1
+ MB = IE - IS + 1
+ ZDIM = MB*NB*2
+*
+ IF( ( MB.EQ.1 ) .AND. ( NB.EQ.1 ) ) THEN
+*
+* Build a 2-by-2 system Z * x = RHS
+*
+ Z( 1, 1 ) = A( IS, IS )
+ Z( 2, 1 ) = D( IS, IS )
+ Z( 1, 2 ) = -B( JS, JS )
+ Z( 2, 2 ) = -E( JS, JS )
+*
+* Set up right hand side(s)
+*
+ RHS( 1 ) = C( IS, JS )
+ RHS( 2 ) = F( IS, JS )
+*
+* Solve Z * x = RHS
+*
+ CALL DGETC2( ZDIM, Z, LDZ, IPIV, JPIV, IERR )
+ IF( IERR.GT.0 )
+ $ INFO = IERR
+*
+ IF( IJOB.EQ.0 ) THEN
+ CALL DGESC2( ZDIM, Z, LDZ, RHS, IPIV, JPIV,
+ $ SCALOC )
+ IF( SCALOC.NE.ONE ) THEN
+ DO 50 K = 1, N
+ CALL DSCAL( M, SCALOC, C( 1, K ), 1 )
+ CALL DSCAL( M, SCALOC, F( 1, K ), 1 )
+ 50 CONTINUE
+ SCALE = SCALE*SCALOC
+ END IF
+ ELSE
+ CALL DLATDF( IJOB, ZDIM, Z, LDZ, RHS, RDSUM,
+ $ RDSCAL, IPIV, JPIV )
+ END IF
+*
+* Unpack solution vector(s)
+*
+ C( IS, JS ) = RHS( 1 )
+ F( IS, JS ) = RHS( 2 )
+*
+* Substitute R(I, J) and L(I, J) into remaining
+* equation.
+*
+ IF( I.GT.1 ) THEN
+ ALPHA = -RHS( 1 )
+ CALL DAXPY( IS-1, ALPHA, A( 1, IS ), 1, C( 1, JS ),
+ $ 1 )
+ CALL DAXPY( IS-1, ALPHA, D( 1, IS ), 1, F( 1, JS ),
+ $ 1 )
+ END IF
+ IF( J.LT.Q ) THEN
+ CALL DAXPY( N-JE, RHS( 2 ), B( JS, JE+1 ), LDB,
+ $ C( IS, JE+1 ), LDC )
+ CALL DAXPY( N-JE, RHS( 2 ), E( JS, JE+1 ), LDE,
+ $ F( IS, JE+1 ), LDF )
+ END IF
+*
+ ELSE IF( ( MB.EQ.1 ) .AND. ( NB.EQ.2 ) ) THEN
+*
+* Build a 4-by-4 system Z * x = RHS
+*
+ Z( 1, 1 ) = A( IS, IS )
+ Z( 2, 1 ) = ZERO
+ Z( 3, 1 ) = D( IS, IS )
+ Z( 4, 1 ) = ZERO
+*
+ Z( 1, 2 ) = ZERO
+ Z( 2, 2 ) = A( IS, IS )
+ Z( 3, 2 ) = ZERO
+ Z( 4, 2 ) = D( IS, IS )
+*
+ Z( 1, 3 ) = -B( JS, JS )
+ Z( 2, 3 ) = -B( JS, JSP1 )
+ Z( 3, 3 ) = -E( JS, JS )
+ Z( 4, 3 ) = -E( JS, JSP1 )
+*
+ Z( 1, 4 ) = -B( JSP1, JS )
+ Z( 2, 4 ) = -B( JSP1, JSP1 )
+ Z( 3, 4 ) = ZERO
+ Z( 4, 4 ) = -E( JSP1, JSP1 )
+*
+* Set up right hand side(s)
+*
+ RHS( 1 ) = C( IS, JS )
+ RHS( 2 ) = C( IS, JSP1 )
+ RHS( 3 ) = F( IS, JS )
+ RHS( 4 ) = F( IS, JSP1 )
+*
+* Solve Z * x = RHS
+*
+ CALL DGETC2( ZDIM, Z, LDZ, IPIV, JPIV, IERR )
+ IF( IERR.GT.0 )
+ $ INFO = IERR
+*
+ IF( IJOB.EQ.0 ) THEN
+ CALL DGESC2( ZDIM, Z, LDZ, RHS, IPIV, JPIV,
+ $ SCALOC )
+ IF( SCALOC.NE.ONE ) THEN
+ DO 60 K = 1, N
+ CALL DSCAL( M, SCALOC, C( 1, K ), 1 )
+ CALL DSCAL( M, SCALOC, F( 1, K ), 1 )
+ 60 CONTINUE
+ SCALE = SCALE*SCALOC
+ END IF
+ ELSE
+ CALL DLATDF( IJOB, ZDIM, Z, LDZ, RHS, RDSUM,
+ $ RDSCAL, IPIV, JPIV )
+ END IF
+*
+* Unpack solution vector(s)
+*
+ C( IS, JS ) = RHS( 1 )
+ C( IS, JSP1 ) = RHS( 2 )
+ F( IS, JS ) = RHS( 3 )
+ F( IS, JSP1 ) = RHS( 4 )
+*
+* Substitute R(I, J) and L(I, J) into remaining
+* equation.
+*
+ IF( I.GT.1 ) THEN
+ CALL DGER( IS-1, NB, -ONE, A( 1, IS ), 1, RHS( 1 ),
+ $ 1, C( 1, JS ), LDC )
+ CALL DGER( IS-1, NB, -ONE, D( 1, IS ), 1, RHS( 1 ),
+ $ 1, F( 1, JS ), LDF )
+ END IF
+ IF( J.LT.Q ) THEN
+ CALL DAXPY( N-JE, RHS( 3 ), B( JS, JE+1 ), LDB,
+ $ C( IS, JE+1 ), LDC )
+ CALL DAXPY( N-JE, RHS( 3 ), E( JS, JE+1 ), LDE,
+ $ F( IS, JE+1 ), LDF )
+ CALL DAXPY( N-JE, RHS( 4 ), B( JSP1, JE+1 ), LDB,
+ $ C( IS, JE+1 ), LDC )
+ CALL DAXPY( N-JE, RHS( 4 ), E( JSP1, JE+1 ), LDE,
+ $ F( IS, JE+1 ), LDF )
+ END IF
+*
+ ELSE IF( ( MB.EQ.2 ) .AND. ( NB.EQ.1 ) ) THEN
+*
+* Build a 4-by-4 system Z * x = RHS
+*
+ Z( 1, 1 ) = A( IS, IS )
+ Z( 2, 1 ) = A( ISP1, IS )
+ Z( 3, 1 ) = D( IS, IS )
+ Z( 4, 1 ) = ZERO
+*
+ Z( 1, 2 ) = A( IS, ISP1 )
+ Z( 2, 2 ) = A( ISP1, ISP1 )
+ Z( 3, 2 ) = D( IS, ISP1 )
+ Z( 4, 2 ) = D( ISP1, ISP1 )
+*
+ Z( 1, 3 ) = -B( JS, JS )
+ Z( 2, 3 ) = ZERO
+ Z( 3, 3 ) = -E( JS, JS )
+ Z( 4, 3 ) = ZERO
+*
+ Z( 1, 4 ) = ZERO
+ Z( 2, 4 ) = -B( JS, JS )
+ Z( 3, 4 ) = ZERO
+ Z( 4, 4 ) = -E( JS, JS )
+*
+* Set up right hand side(s)
+*
+ RHS( 1 ) = C( IS, JS )
+ RHS( 2 ) = C( ISP1, JS )
+ RHS( 3 ) = F( IS, JS )
+ RHS( 4 ) = F( ISP1, JS )
+*
+* Solve Z * x = RHS
+*
+ CALL DGETC2( ZDIM, Z, LDZ, IPIV, JPIV, IERR )
+ IF( IERR.GT.0 )
+ $ INFO = IERR
+ IF( IJOB.EQ.0 ) THEN
+ CALL DGESC2( ZDIM, Z, LDZ, RHS, IPIV, JPIV,
+ $ SCALOC )
+ IF( SCALOC.NE.ONE ) THEN
+ DO 70 K = 1, N
+ CALL DSCAL( M, SCALOC, C( 1, K ), 1 )
+ CALL DSCAL( M, SCALOC, F( 1, K ), 1 )
+ 70 CONTINUE
+ SCALE = SCALE*SCALOC
+ END IF
+ ELSE
+ CALL DLATDF( IJOB, ZDIM, Z, LDZ, RHS, RDSUM,
+ $ RDSCAL, IPIV, JPIV )
+ END IF
+*
+* Unpack solution vector(s)
+*
+ C( IS, JS ) = RHS( 1 )
+ C( ISP1, JS ) = RHS( 2 )
+ F( IS, JS ) = RHS( 3 )
+ F( ISP1, JS ) = RHS( 4 )
+*
+* Substitute R(I, J) and L(I, J) into remaining
+* equation.
+*
+ IF( I.GT.1 ) THEN
+ CALL DGEMV( 'N', IS-1, MB, -ONE, A( 1, IS ), LDA,
+ $ RHS( 1 ), 1, ONE, C( 1, JS ), 1 )
+ CALL DGEMV( 'N', IS-1, MB, -ONE, D( 1, IS ), LDD,
+ $ RHS( 1 ), 1, ONE, F( 1, JS ), 1 )
+ END IF
+ IF( J.LT.Q ) THEN
+ CALL DGER( MB, N-JE, ONE, RHS( 3 ), 1,
+ $ B( JS, JE+1 ), LDB, C( IS, JE+1 ), LDC )
+ CALL DGER( MB, N-JE, ONE, RHS( 3 ), 1,
+ $ E( JS, JE+1 ), LDE, F( IS, JE+1 ), LDF )
+ END IF
+*
+ ELSE IF( ( MB.EQ.2 ) .AND. ( NB.EQ.2 ) ) THEN
+*
+* Build an 8-by-8 system Z * x = RHS
+*
+ CALL DLASET( 'F', LDZ, LDZ, ZERO, ZERO, Z, LDZ )
+*
+ Z( 1, 1 ) = A( IS, IS )
+ Z( 2, 1 ) = A( ISP1, IS )
+ Z( 5, 1 ) = D( IS, IS )
+*
+ Z( 1, 2 ) = A( IS, ISP1 )
+ Z( 2, 2 ) = A( ISP1, ISP1 )
+ Z( 5, 2 ) = D( IS, ISP1 )
+ Z( 6, 2 ) = D( ISP1, ISP1 )
+*
+ Z( 3, 3 ) = A( IS, IS )
+ Z( 4, 3 ) = A( ISP1, IS )
+ Z( 7, 3 ) = D( IS, IS )
+*
+ Z( 3, 4 ) = A( IS, ISP1 )
+ Z( 4, 4 ) = A( ISP1, ISP1 )
+ Z( 7, 4 ) = D( IS, ISP1 )
+ Z( 8, 4 ) = D( ISP1, ISP1 )
+*
+ Z( 1, 5 ) = -B( JS, JS )
+ Z( 3, 5 ) = -B( JS, JSP1 )
+ Z( 5, 5 ) = -E( JS, JS )
+ Z( 7, 5 ) = -E( JS, JSP1 )
+*
+ Z( 2, 6 ) = -B( JS, JS )
+ Z( 4, 6 ) = -B( JS, JSP1 )
+ Z( 6, 6 ) = -E( JS, JS )
+ Z( 8, 6 ) = -E( JS, JSP1 )
+*
+ Z( 1, 7 ) = -B( JSP1, JS )
+ Z( 3, 7 ) = -B( JSP1, JSP1 )
+ Z( 7, 7 ) = -E( JSP1, JSP1 )
+*
+ Z( 2, 8 ) = -B( JSP1, JS )
+ Z( 4, 8 ) = -B( JSP1, JSP1 )
+ Z( 8, 8 ) = -E( JSP1, JSP1 )
+*
+* Set up right hand side(s)
+*
+ K = 1
+ II = MB*NB + 1
+ DO 80 JJ = 0, NB - 1
+ CALL DCOPY( MB, C( IS, JS+JJ ), 1, RHS( K ), 1 )
+ CALL DCOPY( MB, F( IS, JS+JJ ), 1, RHS( II ), 1 )
+ K = K + MB
+ II = II + MB
+ 80 CONTINUE
+*
+* Solve Z * x = RHS
+*
+ CALL DGETC2( ZDIM, Z, LDZ, IPIV, JPIV, IERR )
+ IF( IERR.GT.0 )
+ $ INFO = IERR
+ IF( IJOB.EQ.0 ) THEN
+ CALL DGESC2( ZDIM, Z, LDZ, RHS, IPIV, JPIV,
+ $ SCALOC )
+ IF( SCALOC.NE.ONE ) THEN
+ DO 90 K = 1, N
+ CALL DSCAL( M, SCALOC, C( 1, K ), 1 )
+ CALL DSCAL( M, SCALOC, F( 1, K ), 1 )
+ 90 CONTINUE
+ SCALE = SCALE*SCALOC
+ END IF
+ ELSE
+ CALL DLATDF( IJOB, ZDIM, Z, LDZ, RHS, RDSUM,
+ $ RDSCAL, IPIV, JPIV )
+ END IF
+*
+* Unpack solution vector(s)
+*
+ K = 1
+ II = MB*NB + 1
+ DO 100 JJ = 0, NB - 1
+ CALL DCOPY( MB, RHS( K ), 1, C( IS, JS+JJ ), 1 )
+ CALL DCOPY( MB, RHS( II ), 1, F( IS, JS+JJ ), 1 )
+ K = K + MB
+ II = II + MB
+ 100 CONTINUE
+*
+* Substitute R(I, J) and L(I, J) into remaining
+* equation.
+*
+ IF( I.GT.1 ) THEN
+ CALL DGEMM( 'N', 'N', IS-1, NB, MB, -ONE,
+ $ A( 1, IS ), LDA, RHS( 1 ), MB, ONE,
+ $ C( 1, JS ), LDC )
+ CALL DGEMM( 'N', 'N', IS-1, NB, MB, -ONE,
+ $ D( 1, IS ), LDD, RHS( 1 ), MB, ONE,
+ $ F( 1, JS ), LDF )
+ END IF
+ IF( J.LT.Q ) THEN
+ K = MB*NB + 1
+ CALL DGEMM( 'N', 'N', MB, N-JE, NB, ONE, RHS( K ),
+ $ MB, B( JS, JE+1 ), LDB, ONE,
+ $ C( IS, JE+1 ), LDC )
+ CALL DGEMM( 'N', 'N', MB, N-JE, NB, ONE, RHS( K ),
+ $ MB, E( JS, JE+1 ), LDE, ONE,
+ $ F( IS, JE+1 ), LDF )
+ END IF
+*
+ END IF
+*
+ 110 CONTINUE
+ 120 CONTINUE
+ ELSE
+*
+* Solve (I, J) - subsystem
+* A(I, I)' * R(I, J) + D(I, I)' * L(J, J) = C(I, J)
+* R(I, I) * B(J, J) + L(I, J) * E(J, J) = -F(I, J)
+* for I = 1, 2, ..., P, J = Q, Q - 1, ..., 1
+*
+ SCALE = ONE
+ SCALOC = ONE
+ DO 200 I = 1, P
+*
+ IS = IWORK( I )
+ ISP1 = IS + 1
+ IE = ( I+1 ) - 1
+ MB = IE - IS + 1
+ DO 190 J = Q, P + 2, -1
+*
+ JS = IWORK( J )
+ JSP1 = JS + 1
+ JE = IWORK( J+1 ) - 1
+ NB = JE - JS + 1
+ ZDIM = MB*NB*2
+ IF( ( MB.EQ.1 ) .AND. ( NB.EQ.1 ) ) THEN
+*
+* Build a 2-by-2 system Z' * x = RHS
+*
+ Z( 1, 1 ) = A( IS, IS )
+ Z( 2, 1 ) = -B( JS, JS )
+ Z( 1, 2 ) = D( IS, IS )
+ Z( 2, 2 ) = -E( JS, JS )
+*
+* Set up right hand side(s)
+*
+ RHS( 1 ) = C( IS, JS )
+ RHS( 2 ) = F( IS, JS )
+*
+* Solve Z' * x = RHS
+*
+ CALL DGETC2( ZDIM, Z, LDZ, IPIV, JPIV, IERR )
+ IF( IERR.GT.0 )
+ $ INFO = IERR
+*
+ CALL DGESC2( ZDIM, Z, LDZ, RHS, IPIV, JPIV, SCALOC )
+ IF( SCALOC.NE.ONE ) THEN
+ DO 130 K = 1, N
+ CALL DSCAL( M, SCALOC, C( 1, K ), 1 )
+ CALL DSCAL( M, SCALOC, F( 1, K ), 1 )
+ 130 CONTINUE
+ SCALE = SCALE*SCALOC
+ END IF
+*
+* Unpack solution vector(s)
+*
+ C( IS, JS ) = RHS( 1 )
+ F( IS, JS ) = RHS( 2 )
+*
+* Substitute R(I, J) and L(I, J) into remaining
+* equation.
+*
+ IF( J.GT.P+2 ) THEN
+ ALPHA = RHS( 1 )
+ CALL DAXPY( JS-1, ALPHA, B( 1, JS ), 1, F( IS, 1 ),
+ $ LDF )
+ ALPHA = RHS( 2 )
+ CALL DAXPY( JS-1, ALPHA, E( 1, JS ), 1, F( IS, 1 ),
+ $ LDF )
+ END IF
+ IF( I.LT.P ) THEN
+ ALPHA = -RHS( 1 )
+ CALL DAXPY( M-IE, ALPHA, A( IS, IE+1 ), LDA,
+ $ C( IE+1, JS ), 1 )
+ ALPHA = -RHS( 2 )
+ CALL DAXPY( M-IE, ALPHA, D( IS, IE+1 ), LDD,
+ $ C( IE+1, JS ), 1 )
+ END IF
+*
+ ELSE IF( ( MB.EQ.1 ) .AND. ( NB.EQ.2 ) ) THEN
+*
+* Build a 4-by-4 system Z' * x = RHS
+*
+ Z( 1, 1 ) = A( IS, IS )
+ Z( 2, 1 ) = ZERO
+ Z( 3, 1 ) = -B( JS, JS )
+ Z( 4, 1 ) = -B( JSP1, JS )
+*
+ Z( 1, 2 ) = ZERO
+ Z( 2, 2 ) = A( IS, IS )
+ Z( 3, 2 ) = -B( JS, JSP1 )
+ Z( 4, 2 ) = -B( JSP1, JSP1 )
+*
+ Z( 1, 3 ) = D( IS, IS )
+ Z( 2, 3 ) = ZERO
+ Z( 3, 3 ) = -E( JS, JS )
+ Z( 4, 3 ) = ZERO
+*
+ Z( 1, 4 ) = ZERO
+ Z( 2, 4 ) = D( IS, IS )
+ Z( 3, 4 ) = -E( JS, JSP1 )
+ Z( 4, 4 ) = -E( JSP1, JSP1 )
+*
+* Set up right hand side(s)
+*
+ RHS( 1 ) = C( IS, JS )
+ RHS( 2 ) = C( IS, JSP1 )
+ RHS( 3 ) = F( IS, JS )
+ RHS( 4 ) = F( IS, JSP1 )
+*
+* Solve Z' * x = RHS
+*
+ CALL DGETC2( ZDIM, Z, LDZ, IPIV, JPIV, IERR )
+ IF( IERR.GT.0 )
+ $ INFO = IERR
+ CALL DGESC2( ZDIM, Z, LDZ, RHS, IPIV, JPIV, SCALOC )
+ IF( SCALOC.NE.ONE ) THEN
+ DO 140 K = 1, N
+ CALL DSCAL( M, SCALOC, C( 1, K ), 1 )
+ CALL DSCAL( M, SCALOC, F( 1, K ), 1 )
+ 140 CONTINUE
+ SCALE = SCALE*SCALOC
+ END IF
+*
+* Unpack solution vector(s)
+*
+ C( IS, JS ) = RHS( 1 )
+ C( IS, JSP1 ) = RHS( 2 )
+ F( IS, JS ) = RHS( 3 )
+ F( IS, JSP1 ) = RHS( 4 )
+*
+* Substitute R(I, J) and L(I, J) into remaining
+* equation.
+*
+ IF( J.GT.P+2 ) THEN
+ CALL DAXPY( JS-1, RHS( 1 ), B( 1, JS ), 1,
+ $ F( IS, 1 ), LDF )
+ CALL DAXPY( JS-1, RHS( 2 ), B( 1, JSP1 ), 1,
+ $ F( IS, 1 ), LDF )
+ CALL DAXPY( JS-1, RHS( 3 ), E( 1, JS ), 1,
+ $ F( IS, 1 ), LDF )
+ CALL DAXPY( JS-1, RHS( 4 ), E( 1, JSP1 ), 1,
+ $ F( IS, 1 ), LDF )
+ END IF
+ IF( I.LT.P ) THEN
+ CALL DGER( M-IE, NB, -ONE, A( IS, IE+1 ), LDA,
+ $ RHS( 1 ), 1, C( IE+1, JS ), LDC )
+ CALL DGER( M-IE, NB, -ONE, D( IS, IE+1 ), LDD,
+ $ RHS( 3 ), 1, C( IE+1, JS ), LDC )
+ END IF
+*
+ ELSE IF( ( MB.EQ.2 ) .AND. ( NB.EQ.1 ) ) THEN
+*
+* Build a 4-by-4 system Z' * x = RHS
+*
+ Z( 1, 1 ) = A( IS, IS )
+ Z( 2, 1 ) = A( IS, ISP1 )
+ Z( 3, 1 ) = -B( JS, JS )
+ Z( 4, 1 ) = ZERO
+*
+ Z( 1, 2 ) = A( ISP1, IS )
+ Z( 2, 2 ) = A( ISP1, ISP1 )
+ Z( 3, 2 ) = ZERO
+ Z( 4, 2 ) = -B( JS, JS )
+*
+ Z( 1, 3 ) = D( IS, IS )
+ Z( 2, 3 ) = D( IS, ISP1 )
+ Z( 3, 3 ) = -E( JS, JS )
+ Z( 4, 3 ) = ZERO
+*
+ Z( 1, 4 ) = ZERO
+ Z( 2, 4 ) = D( ISP1, ISP1 )
+ Z( 3, 4 ) = ZERO
+ Z( 4, 4 ) = -E( JS, JS )
+*
+* Set up right hand side(s)
+*
+ RHS( 1 ) = C( IS, JS )
+ RHS( 2 ) = C( ISP1, JS )
+ RHS( 3 ) = F( IS, JS )
+ RHS( 4 ) = F( ISP1, JS )
+*
+* Solve Z' * x = RHS
+*
+ CALL DGETC2( ZDIM, Z, LDZ, IPIV, JPIV, IERR )
+ IF( IERR.GT.0 )
+ $ INFO = IERR
+*
+ CALL DGESC2( ZDIM, Z, LDZ, RHS, IPIV, JPIV, SCALOC )
+ IF( SCALOC.NE.ONE ) THEN
+ DO 150 K = 1, N
+ CALL DSCAL( M, SCALOC, C( 1, K ), 1 )
+ CALL DSCAL( M, SCALOC, F( 1, K ), 1 )
+ 150 CONTINUE
+ SCALE = SCALE*SCALOC
+ END IF
+*
+* Unpack solution vector(s)
+*
+ C( IS, JS ) = RHS( 1 )
+ C( ISP1, JS ) = RHS( 2 )
+ F( IS, JS ) = RHS( 3 )
+ F( ISP1, JS ) = RHS( 4 )
+*
+* Substitute R(I, J) and L(I, J) into remaining
+* equation.
+*
+ IF( J.GT.P+2 ) THEN
+ CALL DGER( MB, JS-1, ONE, RHS( 1 ), 1, B( 1, JS ),
+ $ 1, F( IS, 1 ), LDF )
+ CALL DGER( MB, JS-1, ONE, RHS( 3 ), 1, E( 1, JS ),
+ $ 1, F( IS, 1 ), LDF )
+ END IF
+ IF( I.LT.P ) THEN
+ CALL DGEMV( 'T', MB, M-IE, -ONE, A( IS, IE+1 ),
+ $ LDA, RHS( 1 ), 1, ONE, C( IE+1, JS ),
+ $ 1 )
+ CALL DGEMV( 'T', MB, M-IE, -ONE, D( IS, IE+1 ),
+ $ LDD, RHS( 3 ), 1, ONE, C( IE+1, JS ),
+ $ 1 )
+ END IF
+*
+ ELSE IF( ( MB.EQ.2 ) .AND. ( NB.EQ.2 ) ) THEN
+*
+* Build an 8-by-8 system Z' * x = RHS
+*
+ CALL DLASET( 'F', LDZ, LDZ, ZERO, ZERO, Z, LDZ )
+*
+ Z( 1, 1 ) = A( IS, IS )
+ Z( 2, 1 ) = A( IS, ISP1 )
+ Z( 5, 1 ) = -B( JS, JS )
+ Z( 7, 1 ) = -B( JSP1, JS )
+*
+ Z( 1, 2 ) = A( ISP1, IS )
+ Z( 2, 2 ) = A( ISP1, ISP1 )
+ Z( 6, 2 ) = -B( JS, JS )
+ Z( 8, 2 ) = -B( JSP1, JS )
+*
+ Z( 3, 3 ) = A( IS, IS )
+ Z( 4, 3 ) = A( IS, ISP1 )
+ Z( 5, 3 ) = -B( JS, JSP1 )
+ Z( 7, 3 ) = -B( JSP1, JSP1 )
+*
+ Z( 3, 4 ) = A( ISP1, IS )
+ Z( 4, 4 ) = A( ISP1, ISP1 )
+ Z( 6, 4 ) = -B( JS, JSP1 )
+ Z( 8, 4 ) = -B( JSP1, JSP1 )
+*
+ Z( 1, 5 ) = D( IS, IS )
+ Z( 2, 5 ) = D( IS, ISP1 )
+ Z( 5, 5 ) = -E( JS, JS )
+*
+ Z( 2, 6 ) = D( ISP1, ISP1 )
+ Z( 6, 6 ) = -E( JS, JS )
+*
+ Z( 3, 7 ) = D( IS, IS )
+ Z( 4, 7 ) = D( IS, ISP1 )
+ Z( 5, 7 ) = -E( JS, JSP1 )
+ Z( 7, 7 ) = -E( JSP1, JSP1 )
+*
+ Z( 4, 8 ) = D( ISP1, ISP1 )
+ Z( 6, 8 ) = -E( JS, JSP1 )
+ Z( 8, 8 ) = -E( JSP1, JSP1 )
+*
+* Set up right hand side(s)
+*
+ K = 1
+ II = MB*NB + 1
+ DO 160 JJ = 0, NB - 1
+ CALL DCOPY( MB, C( IS, JS+JJ ), 1, RHS( K ), 1 )
+ CALL DCOPY( MB, F( IS, JS+JJ ), 1, RHS( II ), 1 )
+ K = K + MB
+ II = II + MB
+ 160 CONTINUE
+*
+*
+* Solve Z' * x = RHS
+*
+ CALL DGETC2( ZDIM, Z, LDZ, IPIV, JPIV, IERR )
+ IF( IERR.GT.0 )
+ $ INFO = IERR
+*
+ CALL DGESC2( ZDIM, Z, LDZ, RHS, IPIV, JPIV, SCALOC )
+ IF( SCALOC.NE.ONE ) THEN
+ DO 170 K = 1, N
+ CALL DSCAL( M, SCALOC, C( 1, K ), 1 )
+ CALL DSCAL( M, SCALOC, F( 1, K ), 1 )
+ 170 CONTINUE
+ SCALE = SCALE*SCALOC
+ END IF
+*
+* Unpack solution vector(s)
+*
+ K = 1
+ II = MB*NB + 1
+ DO 180 JJ = 0, NB - 1
+ CALL DCOPY( MB, RHS( K ), 1, C( IS, JS+JJ ), 1 )
+ CALL DCOPY( MB, RHS( II ), 1, F( IS, JS+JJ ), 1 )
+ K = K + MB
+ II = II + MB
+ 180 CONTINUE
+*
+* Substitute R(I, J) and L(I, J) into remaining
+* equation.
+*
+ IF( J.GT.P+2 ) THEN
+ CALL DGEMM( 'N', 'T', MB, JS-1, NB, ONE,
+ $ C( IS, JS ), LDC, B( 1, JS ), LDB, ONE,
+ $ F( IS, 1 ), LDF )
+ CALL DGEMM( 'N', 'T', MB, JS-1, NB, ONE,
+ $ F( IS, JS ), LDF, E( 1, JS ), LDE, ONE,
+ $ F( IS, 1 ), LDF )
+ END IF
+ IF( I.LT.P ) THEN
+ CALL DGEMM( 'T', 'N', M-IE, NB, MB, -ONE,
+ $ A( IS, IE+1 ), LDA, C( IS, JS ), LDC,
+ $ ONE, C( IE+1, JS ), LDC )
+ CALL DGEMM( 'T', 'N', M-IE, NB, MB, -ONE,
+ $ D( IS, IE+1 ), LDD, F( IS, JS ), LDF,
+ $ ONE, C( IE+1, JS ), LDC )
+ END IF
+*
+ END IF
+*
+ 190 CONTINUE
+ 200 CONTINUE
+*
+ END IF
+ RETURN
+*
+* End of DTGSY2
+*
+ END
+ SUBROUTINE DTGSYL( TRANS, IJOB, M, N, A, LDA, B, LDB, C, LDC, D,
+ $ LDD, E, LDE, F, LDF, SCALE, DIF, WORK, LWORK,
+ $ IWORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER TRANS
+ INTEGER IJOB, INFO, LDA, LDB, LDC, LDD, LDE, LDF,
+ $ LWORK, M, N
+ DOUBLE PRECISION DIF, SCALE
+* ..
+* .. Array Arguments ..
+ INTEGER IWORK( * )
+ DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ),
+ $ D( LDD, * ), E( LDE, * ), F( LDF, * ),
+ $ WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DTGSYL solves the generalized Sylvester equation:
+*
+* A * R - L * B = scale * C (1)
+* D * R - L * E = scale * F
+*
+* where R and L are unknown m-by-n matrices, (A, D), (B, E) and
+* (C, F) are given matrix pairs of size m-by-m, n-by-n and m-by-n,
+* respectively, with real entries. (A, D) and (B, E) must be in
+* generalized (real) Schur canonical form, i.e. A, B are upper quasi
+* triangular and D, E are upper triangular.
+*
+* The solution (R, L) overwrites (C, F). 0 <= SCALE <= 1 is an output
+* scaling factor chosen to avoid overflow.
+*
+* In matrix notation (1) is equivalent to solve Zx = scale b, where
+* Z is defined as
+*
+* Z = [ kron(In, A) -kron(B', Im) ] (2)
+* [ kron(In, D) -kron(E', Im) ].
+*
+* Here Ik is the identity matrix of size k and X' is the transpose of
+* X. kron(X, Y) is the Kronecker product between the matrices X and Y.
+*
+* If TRANS = 'T', DTGSYL solves the transposed system Z'*y = scale*b,
+* which is equivalent to solve for R and L in
+*
+* A' * R + D' * L = scale * C (3)
+* R * B' + L * E' = scale * (-F)
+*
+* This case (TRANS = 'T') is used to compute an one-norm-based estimate
+* of Dif[(A,D), (B,E)], the separation between the matrix pairs (A,D)
+* and (B,E), using DLACON.
+*
+* If IJOB >= 1, DTGSYL computes a Frobenius norm-based estimate
+* of Dif[(A,D),(B,E)]. That is, the reciprocal of a lower bound on the
+* reciprocal of the smallest singular value of Z. See [1-2] for more
+* information.
+*
+* This is a level 3 BLAS algorithm.
+*
+* Arguments
+* =========
+*
+* TRANS (input) CHARACTER*1
+* = 'N', solve the generalized Sylvester equation (1).
+* = 'T', solve the 'transposed' system (3).
+*
+* IJOB (input) INTEGER
+* Specifies what kind of functionality to be performed.
+* =0: solve (1) only.
+* =1: The functionality of 0 and 3.
+* =2: The functionality of 0 and 4.
+* =3: Only an estimate of Dif[(A,D), (B,E)] is computed.
+* (look ahead strategy IJOB = 1 is used).
+* =4: Only an estimate of Dif[(A,D), (B,E)] is computed.
+* ( DGECON on sub-systems is used ).
+* Not referenced if TRANS = 'T'.
+*
+* M (input) INTEGER
+* The order of the matrices A and D, and the row dimension of
+* the matrices C, F, R and L.
+*
+* N (input) INTEGER
+* The order of the matrices B and E, and the column dimension
+* of the matrices C, F, R and L.
+*
+* A (input) DOUBLE PRECISION array, dimension (LDA, M)
+* The upper quasi triangular matrix A.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1, M).
+*
+* B (input) DOUBLE PRECISION array, dimension (LDB, N)
+* The upper quasi triangular matrix B.
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. LDB >= max(1, N).
+*
+* C (input/output) DOUBLE PRECISION array, dimension (LDC, N)
+* On entry, C contains the right-hand-side of the first matrix
+* equation in (1) or (3).
+* On exit, if IJOB = 0, 1 or 2, C has been overwritten by
+* the solution R. If IJOB = 3 or 4 and TRANS = 'N', C holds R,
+* the solution achieved during the computation of the
+* Dif-estimate.
+*
+* LDC (input) INTEGER
+* The leading dimension of the array C. LDC >= max(1, M).
+*
+* D (input) DOUBLE PRECISION array, dimension (LDD, M)
+* The upper triangular matrix D.
+*
+* LDD (input) INTEGER
+* The leading dimension of the array D. LDD >= max(1, M).
+*
+* E (input) DOUBLE PRECISION array, dimension (LDE, N)
+* The upper triangular matrix E.
+*
+* LDE (input) INTEGER
+* The leading dimension of the array E. LDE >= max(1, N).
+*
+* F (input/output) DOUBLE PRECISION array, dimension (LDF, N)
+* On entry, F contains the right-hand-side of the second matrix
+* equation in (1) or (3).
+* On exit, if IJOB = 0, 1 or 2, F has been overwritten by
+* the solution L. If IJOB = 3 or 4 and TRANS = 'N', F holds L,
+* the solution achieved during the computation of the
+* Dif-estimate.
+*
+* LDF (input) INTEGER
+* The leading dimension of the array F. LDF >= max(1, M).
+*
+* DIF (output) DOUBLE PRECISION
+* On exit DIF is the reciprocal of a lower bound of the
+* reciprocal of the Dif-function, i.e. DIF is an upper bound of
+* Dif[(A,D), (B,E)] = sigma_min(Z), where Z as in (2).
+* IF IJOB = 0 or TRANS = 'T', DIF is not touched.
+*
+* SCALE (output) DOUBLE PRECISION
+* On exit SCALE is the scaling factor in (1) or (3).
+* If 0 < SCALE < 1, C and F hold the solutions R and L, resp.,
+* to a slightly perturbed system but the input matrices A, B, D
+* and E have not been changed. If SCALE = 0, C and F hold the
+* solutions R and L, respectively, to the homogeneous system
+* with C = F = 0. Normally, SCALE = 1.
+*
+* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
+* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+* LWORK (input) INTEGER
+* The dimension of the array WORK. LWORK > = 1.
+* If IJOB = 1 or 2 and TRANS = 'N', LWORK >= max(1,2*M*N).
+*
+* If LWORK = -1, then a workspace query is assumed; the routine
+* only calculates the optimal size of the WORK array, returns
+* this value as the first entry of the WORK array, and no error
+* message related to LWORK is issued by XERBLA.
+*
+* IWORK (workspace) INTEGER array, dimension (M+N+6)
+*
+* INFO (output) INTEGER
+* =0: successful exit
+* <0: If INFO = -i, the i-th argument had an illegal value.
+* >0: (A, D) and (B, E) have common or close eigenvalues.
+*
+* Further Details
+* ===============
+*
+* Based on contributions by
+* Bo Kagstrom and Peter Poromaa, Department of Computing Science,
+* Umea University, S-901 87 Umea, Sweden.
+*
+* [1] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software
+* for Solving the Generalized Sylvester Equation and Estimating the
+* Separation between Regular Matrix Pairs, Report UMINF - 93.23,
+* Department of Computing Science, Umea University, S-901 87 Umea,
+* Sweden, December 1993, Revised April 1994, Also as LAPACK Working
+* Note 75. To appear in ACM Trans. on Math. Software, Vol 22,
+* No 1, 1996.
+*
+* [2] B. Kagstrom, A Perturbation Analysis of the Generalized Sylvester
+* Equation (AR - LB, DR - LE ) = (C, F), SIAM J. Matrix Anal.
+* Appl., 15(4):1045-1060, 1994
+*
+* [3] B. Kagstrom and L. Westin, Generalized Schur Methods with
+* Condition Estimators for Solving the Generalized Sylvester
+* Equation, IEEE Transactions on Automatic Control, Vol. 34, No. 7,
+* July 1989, pp 745-751.
+*
+* =====================================================================
+* Replaced various illegal calls to DCOPY by calls to DLASET.
+* Sven Hammarling, 1/5/02.
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL LQUERY, NOTRAN
+ INTEGER I, IE, IFUNC, IROUND, IS, ISOLVE, J, JE, JS, K,
+ $ LINFO, LWMIN, MB, NB, P, PPQQ, PQ, Q
+ DOUBLE PRECISION DSCALE, DSUM, SCALE2, SCALOC
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ILAENV
+ EXTERNAL LSAME, ILAENV
+* ..
+* .. External Subroutines ..
+ EXTERNAL DGEMM, DLACPY, DLASET, DSCAL, DTGSY2, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC DBLE, MAX, SQRT
+* ..
+* .. Executable Statements ..
+*
+* Decode and test input parameters
+*
+ INFO = 0
+ NOTRAN = LSAME( TRANS, 'N' )
+ LQUERY = ( LWORK.EQ.-1 )
+*
+ IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN
+ INFO = -1
+ ELSE IF( NOTRAN ) THEN
+ IF( ( IJOB.LT.0 ) .OR. ( IJOB.GT.4 ) ) THEN
+ INFO = -2
+ END IF
+ END IF
+ IF( INFO.EQ.0 ) THEN
+ IF( M.LE.0 ) THEN
+ INFO = -3
+ ELSE IF( N.LE.0 ) THEN
+ INFO = -4
+ ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+ INFO = -6
+ ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -8
+ ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
+ INFO = -10
+ ELSE IF( LDD.LT.MAX( 1, M ) ) THEN
+ INFO = -12
+ ELSE IF( LDE.LT.MAX( 1, N ) ) THEN
+ INFO = -14
+ ELSE IF( LDF.LT.MAX( 1, M ) ) THEN
+ INFO = -16
+ END IF
+ END IF
+*
+ IF( INFO.EQ.0 ) THEN
+ IF( NOTRAN ) THEN
+ IF( IJOB.EQ.1 .OR. IJOB.EQ.2 ) THEN
+ LWMIN = MAX( 1, 2*M*N )
+ ELSE
+ LWMIN = 1
+ END IF
+ ELSE
+ LWMIN = 1
+ END IF
+ WORK( 1 ) = LWMIN
+*
+ IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
+ INFO = -20
+ END IF
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DTGSYL', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( M.EQ.0 .OR. N.EQ.0 ) THEN
+ SCALE = 1
+ IF( NOTRAN ) THEN
+ IF( IJOB.NE.0 ) THEN
+ DIF = 0
+ END IF
+ END IF
+ RETURN
+ END IF
+*
+* Determine optimal block sizes MB and NB
+*
+ MB = ILAENV( 2, 'DTGSYL', TRANS, M, N, -1, -1 )
+ NB = ILAENV( 5, 'DTGSYL', TRANS, M, N, -1, -1 )
+*
+ ISOLVE = 1
+ IFUNC = 0
+ IF( NOTRAN ) THEN
+ IF( IJOB.GE.3 ) THEN
+ IFUNC = IJOB - 2
+ CALL DLASET( 'F', M, N, ZERO, ZERO, C, LDC )
+ CALL DLASET( 'F', M, N, ZERO, ZERO, F, LDF )
+ ELSE IF( IJOB.GE.1 ) THEN
+ ISOLVE = 2
+ END IF
+ END IF
+*
+ IF( ( MB.LE.1 .AND. NB.LE.1 ) .OR. ( MB.GE.M .AND. NB.GE.N ) )
+ $ THEN
+*
+ DO 30 IROUND = 1, ISOLVE
+*
+* Use unblocked Level 2 solver
+*
+ DSCALE = ZERO
+ DSUM = ONE
+ PQ = 0
+ CALL DTGSY2( TRANS, IFUNC, M, N, A, LDA, B, LDB, C, LDC, D,
+ $ LDD, E, LDE, F, LDF, SCALE, DSUM, DSCALE,
+ $ IWORK, PQ, INFO )
+ IF( DSCALE.NE.ZERO ) THEN
+ IF( IJOB.EQ.1 .OR. IJOB.EQ.3 ) THEN
+ DIF = SQRT( DBLE( 2*M*N ) ) / ( DSCALE*SQRT( DSUM ) )
+ ELSE
+ DIF = SQRT( DBLE( PQ ) ) / ( DSCALE*SQRT( DSUM ) )
+ END IF
+ END IF
+*
+ IF( ISOLVE.EQ.2 .AND. IROUND.EQ.1 ) THEN
+ IF( NOTRAN ) THEN
+ IFUNC = IJOB
+ END IF
+ SCALE2 = SCALE
+ CALL DLACPY( 'F', M, N, C, LDC, WORK, M )
+ CALL DLACPY( 'F', M, N, F, LDF, WORK( M*N+1 ), M )
+ CALL DLASET( 'F', M, N, ZERO, ZERO, C, LDC )
+ CALL DLASET( 'F', M, N, ZERO, ZERO, F, LDF )
+ ELSE IF( ISOLVE.EQ.2 .AND. IROUND.EQ.2 ) THEN
+ CALL DLACPY( 'F', M, N, WORK, M, C, LDC )
+ CALL DLACPY( 'F', M, N, WORK( M*N+1 ), M, F, LDF )
+ SCALE = SCALE2
+ END IF
+ 30 CONTINUE
+*
+ RETURN
+ END IF
+*
+* Determine block structure of A
+*
+ P = 0
+ I = 1
+ 40 CONTINUE
+ IF( I.GT.M )
+ $ GO TO 50
+ P = P + 1
+ IWORK( P ) = I
+ I = I + MB
+ IF( I.GE.M )
+ $ GO TO 50
+ IF( A( I, I-1 ).NE.ZERO )
+ $ I = I + 1
+ GO TO 40
+ 50 CONTINUE
+*
+ IWORK( P+1 ) = M + 1
+ IF( IWORK( P ).EQ.IWORK( P+1 ) )
+ $ P = P - 1
+*
+* Determine block structure of B
+*
+ Q = P + 1
+ J = 1
+ 60 CONTINUE
+ IF( J.GT.N )
+ $ GO TO 70
+ Q = Q + 1
+ IWORK( Q ) = J
+ J = J + NB
+ IF( J.GE.N )
+ $ GO TO 70
+ IF( B( J, J-1 ).NE.ZERO )
+ $ J = J + 1
+ GO TO 60
+ 70 CONTINUE
+*
+ IWORK( Q+1 ) = N + 1
+ IF( IWORK( Q ).EQ.IWORK( Q+1 ) )
+ $ Q = Q - 1
+*
+ IF( NOTRAN ) THEN
+*
+ DO 150 IROUND = 1, ISOLVE
+*
+* Solve (I, J)-subsystem
+* A(I, I) * R(I, J) - L(I, J) * B(J, J) = C(I, J)
+* D(I, I) * R(I, J) - L(I, J) * E(J, J) = F(I, J)
+* for I = P, P - 1,..., 1; J = 1, 2,..., Q
+*
+ DSCALE = ZERO
+ DSUM = ONE
+ PQ = 0
+ SCALE = ONE
+ DO 130 J = P + 2, Q
+ JS = IWORK( J )
+ JE = IWORK( J+1 ) - 1
+ NB = JE - JS + 1
+ DO 120 I = P, 1, -1
+ IS = IWORK( I )
+ IE = IWORK( I+1 ) - 1
+ MB = IE - IS + 1
+ PPQQ = 0
+ CALL DTGSY2( TRANS, IFUNC, MB, NB, A( IS, IS ), LDA,
+ $ B( JS, JS ), LDB, C( IS, JS ), LDC,
+ $ D( IS, IS ), LDD, E( JS, JS ), LDE,
+ $ F( IS, JS ), LDF, SCALOC, DSUM, DSCALE,
+ $ IWORK( Q+2 ), PPQQ, LINFO )
+ IF( LINFO.GT.0 )
+ $ INFO = LINFO
+*
+ PQ = PQ + PPQQ
+ IF( SCALOC.NE.ONE ) THEN
+ DO 80 K = 1, JS - 1
+ CALL DSCAL( M, SCALOC, C( 1, K ), 1 )
+ CALL DSCAL( M, SCALOC, F( 1, K ), 1 )
+ 80 CONTINUE
+ DO 90 K = JS, JE
+ CALL DSCAL( IS-1, SCALOC, C( 1, K ), 1 )
+ CALL DSCAL( IS-1, SCALOC, F( 1, K ), 1 )
+ 90 CONTINUE
+ DO 100 K = JS, JE
+ CALL DSCAL( M-IE, SCALOC, C( IE+1, K ), 1 )
+ CALL DSCAL( M-IE, SCALOC, F( IE+1, K ), 1 )
+ 100 CONTINUE
+ DO 110 K = JE + 1, N
+ CALL DSCAL( M, SCALOC, C( 1, K ), 1 )
+ CALL DSCAL( M, SCALOC, F( 1, K ), 1 )
+ 110 CONTINUE
+ SCALE = SCALE*SCALOC
+ END IF
+*
+* Substitute R(I, J) and L(I, J) into remaining
+* equation.
+*
+ IF( I.GT.1 ) THEN
+ CALL DGEMM( 'N', 'N', IS-1, NB, MB, -ONE,
+ $ A( 1, IS ), LDA, C( IS, JS ), LDC, ONE,
+ $ C( 1, JS ), LDC )
+ CALL DGEMM( 'N', 'N', IS-1, NB, MB, -ONE,
+ $ D( 1, IS ), LDD, C( IS, JS ), LDC, ONE,
+ $ F( 1, JS ), LDF )
+ END IF
+ IF( J.LT.Q ) THEN
+ CALL DGEMM( 'N', 'N', MB, N-JE, NB, ONE,
+ $ F( IS, JS ), LDF, B( JS, JE+1 ), LDB,
+ $ ONE, C( IS, JE+1 ), LDC )
+ CALL DGEMM( 'N', 'N', MB, N-JE, NB, ONE,
+ $ F( IS, JS ), LDF, E( JS, JE+1 ), LDE,
+ $ ONE, F( IS, JE+1 ), LDF )
+ END IF
+ 120 CONTINUE
+ 130 CONTINUE
+ IF( DSCALE.NE.ZERO ) THEN
+ IF( IJOB.EQ.1 .OR. IJOB.EQ.3 ) THEN
+ DIF = SQRT( DBLE( 2*M*N ) ) / ( DSCALE*SQRT( DSUM ) )
+ ELSE
+ DIF = SQRT( DBLE( PQ ) ) / ( DSCALE*SQRT( DSUM ) )
+ END IF
+ END IF
+ IF( ISOLVE.EQ.2 .AND. IROUND.EQ.1 ) THEN
+ IF( NOTRAN ) THEN
+ IFUNC = IJOB
+ END IF
+ SCALE2 = SCALE
+ CALL DLACPY( 'F', M, N, C, LDC, WORK, M )
+ CALL DLACPY( 'F', M, N, F, LDF, WORK( M*N+1 ), M )
+ CALL DLASET( 'F', M, N, ZERO, ZERO, C, LDC )
+ CALL DLASET( 'F', M, N, ZERO, ZERO, F, LDF )
+ ELSE IF( ISOLVE.EQ.2 .AND. IROUND.EQ.2 ) THEN
+ CALL DLACPY( 'F', M, N, WORK, M, C, LDC )
+ CALL DLACPY( 'F', M, N, WORK( M*N+1 ), M, F, LDF )
+ SCALE = SCALE2
+ END IF
+ 150 CONTINUE
+*
+ ELSE
+*
+* Solve transposed (I, J)-subsystem
+* A(I, I)' * R(I, J) + D(I, I)' * L(I, J) = C(I, J)
+* R(I, J) * B(J, J)' + L(I, J) * E(J, J)' = -F(I, J)
+* for I = 1,2,..., P; J = Q, Q-1,..., 1
+*
+ SCALE = ONE
+ DO 210 I = 1, P
+ IS = IWORK( I )
+ IE = IWORK( I+1 ) - 1
+ MB = IE - IS + 1
+ DO 200 J = Q, P + 2, -1
+ JS = IWORK( J )
+ JE = IWORK( J+1 ) - 1
+ NB = JE - JS + 1
+ CALL DTGSY2( TRANS, IFUNC, MB, NB, A( IS, IS ), LDA,
+ $ B( JS, JS ), LDB, C( IS, JS ), LDC,
+ $ D( IS, IS ), LDD, E( JS, JS ), LDE,
+ $ F( IS, JS ), LDF, SCALOC, DSUM, DSCALE,
+ $ IWORK( Q+2 ), PPQQ, LINFO )
+ IF( LINFO.GT.0 )
+ $ INFO = LINFO
+ IF( SCALOC.NE.ONE ) THEN
+ DO 160 K = 1, JS - 1
+ CALL DSCAL( M, SCALOC, C( 1, K ), 1 )
+ CALL DSCAL( M, SCALOC, F( 1, K ), 1 )
+ 160 CONTINUE
+ DO 170 K = JS, JE
+ CALL DSCAL( IS-1, SCALOC, C( 1, K ), 1 )
+ CALL DSCAL( IS-1, SCALOC, F( 1, K ), 1 )
+ 170 CONTINUE
+ DO 180 K = JS, JE
+ CALL DSCAL( M-IE, SCALOC, C( IE+1, K ), 1 )
+ CALL DSCAL( M-IE, SCALOC, F( IE+1, K ), 1 )
+ 180 CONTINUE
+ DO 190 K = JE + 1, N
+ CALL DSCAL( M, SCALOC, C( 1, K ), 1 )
+ CALL DSCAL( M, SCALOC, F( 1, K ), 1 )
+ 190 CONTINUE
+ SCALE = SCALE*SCALOC
+ END IF
+*
+* Substitute R(I, J) and L(I, J) into remaining equation.
+*
+ IF( J.GT.P+2 ) THEN
+ CALL DGEMM( 'N', 'T', MB, JS-1, NB, ONE, C( IS, JS ),
+ $ LDC, B( 1, JS ), LDB, ONE, F( IS, 1 ),
+ $ LDF )
+ CALL DGEMM( 'N', 'T', MB, JS-1, NB, ONE, F( IS, JS ),
+ $ LDF, E( 1, JS ), LDE, ONE, F( IS, 1 ),
+ $ LDF )
+ END IF
+ IF( I.LT.P ) THEN
+ CALL DGEMM( 'T', 'N', M-IE, NB, MB, -ONE,
+ $ A( IS, IE+1 ), LDA, C( IS, JS ), LDC, ONE,
+ $ C( IE+1, JS ), LDC )
+ CALL DGEMM( 'T', 'N', M-IE, NB, MB, -ONE,
+ $ D( IS, IE+1 ), LDD, F( IS, JS ), LDF, ONE,
+ $ C( IE+1, JS ), LDC )
+ END IF
+ 200 CONTINUE
+ 210 CONTINUE
+*
+ END IF
+*
+ WORK( 1 ) = LWMIN
+*
+ RETURN
+*
+* End of DTGSYL
+*
+ END
+ SUBROUTINE DTPCON( NORM, UPLO, DIAG, N, AP, RCOND, WORK, IWORK,
+ $ INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH.
+*
+* .. Scalar Arguments ..
+ CHARACTER DIAG, NORM, UPLO
+ INTEGER INFO, N
+ DOUBLE PRECISION RCOND
+* ..
+* .. Array Arguments ..
+ INTEGER IWORK( * )
+ DOUBLE PRECISION AP( * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DTPCON estimates the reciprocal of the condition number of a packed
+* triangular matrix A, in either the 1-norm or the infinity-norm.
+*
+* The norm of A is computed and an estimate is obtained for
+* norm(inv(A)), then the reciprocal of the condition number is
+* computed as
+* RCOND = 1 / ( norm(A) * norm(inv(A)) ).
+*
+* Arguments
+* =========
+*
+* NORM (input) CHARACTER*1
+* Specifies whether the 1-norm condition number or the
+* infinity-norm condition number is required:
+* = '1' or 'O': 1-norm;
+* = 'I': Infinity-norm.
+*
+* UPLO (input) CHARACTER*1
+* = 'U': A is upper triangular;
+* = 'L': A is lower triangular.
+*
+* DIAG (input) CHARACTER*1
+* = 'N': A is non-unit triangular;
+* = 'U': A is unit triangular.
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)
+* The upper or lower triangular matrix A, packed columnwise in
+* a linear array. The j-th column of A is stored in the array
+* AP as follows:
+* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
+* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
+* If DIAG = 'U', the diagonal elements of A are not referenced
+* and are assumed to be 1.
+*
+* RCOND (output) DOUBLE PRECISION
+* The reciprocal of the condition number of the matrix A,
+* computed as RCOND = 1/(norm(A) * norm(inv(A))).
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (3*N)
+*
+* IWORK (workspace) INTEGER array, dimension (N)
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE, ZERO
+ PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL NOUNIT, ONENRM, UPPER
+ CHARACTER NORMIN
+ INTEGER IX, KASE, KASE1
+ DOUBLE PRECISION AINVNM, ANORM, SCALE, SMLNUM, XNORM
+* ..
+* .. Local Arrays ..
+ INTEGER ISAVE( 3 )
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER IDAMAX
+ DOUBLE PRECISION DLAMCH, DLANTP
+ EXTERNAL LSAME, IDAMAX, DLAMCH, DLANTP
+* ..
+* .. External Subroutines ..
+ EXTERNAL DLACN2, DLATPS, DRSCL, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, DBLE, MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ ONENRM = NORM.EQ.'1' .OR. LSAME( NORM, 'O' )
+ NOUNIT = LSAME( DIAG, 'N' )
+*
+ IF( .NOT.ONENRM .AND. .NOT.LSAME( NORM, 'I' ) ) THEN
+ INFO = -1
+ ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -2
+ ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
+ INFO = -3
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -4
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DTPCON', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 ) THEN
+ RCOND = ONE
+ RETURN
+ END IF
+*
+ RCOND = ZERO
+ SMLNUM = DLAMCH( 'Safe minimum' )*DBLE( MAX( 1, N ) )
+*
+* Compute the norm of the triangular matrix A.
+*
+ ANORM = DLANTP( NORM, UPLO, DIAG, N, AP, WORK )
+*
+* Continue only if ANORM > 0.
+*
+ IF( ANORM.GT.ZERO ) THEN
+*
+* Estimate the norm of the inverse of A.
+*
+ AINVNM = ZERO
+ NORMIN = 'N'
+ IF( ONENRM ) THEN
+ KASE1 = 1
+ ELSE
+ KASE1 = 2
+ END IF
+ KASE = 0
+ 10 CONTINUE
+ CALL DLACN2( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE, ISAVE )
+ IF( KASE.NE.0 ) THEN
+ IF( KASE.EQ.KASE1 ) THEN
+*
+* Multiply by inv(A).
+*
+ CALL DLATPS( UPLO, 'No transpose', DIAG, NORMIN, N, AP,
+ $ WORK, SCALE, WORK( 2*N+1 ), INFO )
+ ELSE
+*
+* Multiply by inv(A').
+*
+ CALL DLATPS( UPLO, 'Transpose', DIAG, NORMIN, N, AP,
+ $ WORK, SCALE, WORK( 2*N+1 ), INFO )
+ END IF
+ NORMIN = 'Y'
+*
+* Multiply by 1/SCALE if doing so will not cause overflow.
+*
+ IF( SCALE.NE.ONE ) THEN
+ IX = IDAMAX( N, WORK, 1 )
+ XNORM = ABS( WORK( IX ) )
+ IF( SCALE.LT.XNORM*SMLNUM .OR. SCALE.EQ.ZERO )
+ $ GO TO 20
+ CALL DRSCL( N, SCALE, WORK, 1 )
+ END IF
+ GO TO 10
+ END IF
+*
+* Compute the estimate of the reciprocal condition number.
+*
+ IF( AINVNM.NE.ZERO )
+ $ RCOND = ( ONE / ANORM ) / AINVNM
+ END IF
+*
+ 20 CONTINUE
+ RETURN
+*
+* End of DTPCON
+*
+ END
+ SUBROUTINE DTPRFS( UPLO, TRANS, DIAG, N, NRHS, AP, B, LDB, X, LDX,
+ $ FERR, BERR, WORK, IWORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH.
+*
+* .. Scalar Arguments ..
+ CHARACTER DIAG, TRANS, UPLO
+ INTEGER INFO, LDB, LDX, N, NRHS
+* ..
+* .. Array Arguments ..
+ INTEGER IWORK( * )
+ DOUBLE PRECISION AP( * ), B( LDB, * ), BERR( * ), FERR( * ),
+ $ WORK( * ), X( LDX, * )
+* ..
+*
+* Purpose
+* =======
+*
+* DTPRFS provides error bounds and backward error estimates for the
+* solution to a system of linear equations with a triangular packed
+* coefficient matrix.
+*
+* The solution matrix X must be computed by DTPTRS or some other
+* means before entering this routine. DTPRFS does not do iterative
+* refinement because doing so cannot improve the backward error.
+*
+* Arguments
+* =========
+*
+* UPLO (input) CHARACTER*1
+* = 'U': A is upper triangular;
+* = 'L': A is lower triangular.
+*
+* TRANS (input) CHARACTER*1
+* Specifies the form of the system of equations:
+* = 'N': A * X = B (No transpose)
+* = 'T': A**T * X = B (Transpose)
+* = 'C': A**H * X = B (Conjugate transpose = Transpose)
+*
+* DIAG (input) CHARACTER*1
+* = 'N': A is non-unit triangular;
+* = 'U': A is unit triangular.
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* NRHS (input) INTEGER
+* The number of right hand sides, i.e., the number of columns
+* of the matrices B and X. NRHS >= 0.
+*
+* AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)
+* The upper or lower triangular matrix A, packed columnwise in
+* a linear array. The j-th column of A is stored in the array
+* AP as follows:
+* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
+* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
+* If DIAG = 'U', the diagonal elements of A are not referenced
+* and are assumed to be 1.
+*
+* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS)
+* The right hand side matrix B.
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. LDB >= max(1,N).
+*
+* X (input) DOUBLE PRECISION array, dimension (LDX,NRHS)
+* The solution matrix X.
+*
+* LDX (input) INTEGER
+* The leading dimension of the array X. LDX >= max(1,N).
+*
+* FERR (output) DOUBLE PRECISION array, dimension (NRHS)
+* The estimated forward error bound for each solution vector
+* X(j) (the j-th column of the solution matrix X).
+* If XTRUE is the true solution corresponding to X(j), FERR(j)
+* is an estimated upper bound for the magnitude of the largest
+* element in (X(j) - XTRUE) divided by the magnitude of the
+* largest element in X(j). The estimate is as reliable as
+* the estimate for RCOND, and is almost always a slight
+* overestimate of the true error.
+*
+* BERR (output) DOUBLE PRECISION array, dimension (NRHS)
+* The componentwise relative backward error of each solution
+* vector X(j) (i.e., the smallest relative change in
+* any element of A or B that makes X(j) an exact solution).
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (3*N)
+*
+* IWORK (workspace) INTEGER array, dimension (N)
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO
+ PARAMETER ( ZERO = 0.0D+0 )
+ DOUBLE PRECISION ONE
+ PARAMETER ( ONE = 1.0D+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL NOTRAN, NOUNIT, UPPER
+ CHARACTER TRANST
+ INTEGER I, J, K, KASE, KC, NZ
+ DOUBLE PRECISION EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK
+* ..
+* .. Local Arrays ..
+ INTEGER ISAVE( 3 )
+* ..
+* .. External Subroutines ..
+ EXTERNAL DAXPY, DCOPY, DLACN2, DTPMV, DTPSV, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ DOUBLE PRECISION DLAMCH
+ EXTERNAL LSAME, DLAMCH
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ NOTRAN = LSAME( TRANS, 'N' )
+ NOUNIT = LSAME( DIAG, 'N' )
+*
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT.
+ $ LSAME( TRANS, 'C' ) ) THEN
+ INFO = -2
+ ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
+ INFO = -3
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( NRHS.LT.0 ) THEN
+ INFO = -5
+ ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -8
+ ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
+ INFO = -10
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DTPRFS', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN
+ DO 10 J = 1, NRHS
+ FERR( J ) = ZERO
+ BERR( J ) = ZERO
+ 10 CONTINUE
+ RETURN
+ END IF
+*
+ IF( NOTRAN ) THEN
+ TRANST = 'T'
+ ELSE
+ TRANST = 'N'
+ END IF
+*
+* NZ = maximum number of nonzero elements in each row of A, plus 1
+*
+ NZ = N + 1
+ EPS = DLAMCH( 'Epsilon' )
+ SAFMIN = DLAMCH( 'Safe minimum' )
+ SAFE1 = NZ*SAFMIN
+ SAFE2 = SAFE1 / EPS
+*
+* Do for each right hand side
+*
+ DO 250 J = 1, NRHS
+*
+* Compute residual R = B - op(A) * X,
+* where op(A) = A or A', depending on TRANS.
+*
+ CALL DCOPY( N, X( 1, J ), 1, WORK( N+1 ), 1 )
+ CALL DTPMV( UPLO, TRANS, DIAG, N, AP, WORK( N+1 ), 1 )
+ CALL DAXPY( N, -ONE, B( 1, J ), 1, WORK( N+1 ), 1 )
+*
+* Compute componentwise relative backward error from formula
+*
+* max(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) )
+*
+* where abs(Z) is the componentwise absolute value of the matrix
+* or vector Z. If the i-th component of the denominator is less
+* than SAFE2, then SAFE1 is added to the i-th components of the
+* numerator and denominator before dividing.
+*
+ DO 20 I = 1, N
+ WORK( I ) = ABS( B( I, J ) )
+ 20 CONTINUE
+*
+ IF( NOTRAN ) THEN
+*
+* Compute abs(A)*abs(X) + abs(B).
+*
+ IF( UPPER ) THEN
+ KC = 1
+ IF( NOUNIT ) THEN
+ DO 40 K = 1, N
+ XK = ABS( X( K, J ) )
+ DO 30 I = 1, K
+ WORK( I ) = WORK( I ) + ABS( AP( KC+I-1 ) )*XK
+ 30 CONTINUE
+ KC = KC + K
+ 40 CONTINUE
+ ELSE
+ DO 60 K = 1, N
+ XK = ABS( X( K, J ) )
+ DO 50 I = 1, K - 1
+ WORK( I ) = WORK( I ) + ABS( AP( KC+I-1 ) )*XK
+ 50 CONTINUE
+ WORK( K ) = WORK( K ) + XK
+ KC = KC + K
+ 60 CONTINUE
+ END IF
+ ELSE
+ KC = 1
+ IF( NOUNIT ) THEN
+ DO 80 K = 1, N
+ XK = ABS( X( K, J ) )
+ DO 70 I = K, N
+ WORK( I ) = WORK( I ) + ABS( AP( KC+I-K ) )*XK
+ 70 CONTINUE
+ KC = KC + N - K + 1
+ 80 CONTINUE
+ ELSE
+ DO 100 K = 1, N
+ XK = ABS( X( K, J ) )
+ DO 90 I = K + 1, N
+ WORK( I ) = WORK( I ) + ABS( AP( KC+I-K ) )*XK
+ 90 CONTINUE
+ WORK( K ) = WORK( K ) + XK
+ KC = KC + N - K + 1
+ 100 CONTINUE
+ END IF
+ END IF
+ ELSE
+*
+* Compute abs(A')*abs(X) + abs(B).
+*
+ IF( UPPER ) THEN
+ KC = 1
+ IF( NOUNIT ) THEN
+ DO 120 K = 1, N
+ S = ZERO
+ DO 110 I = 1, K
+ S = S + ABS( AP( KC+I-1 ) )*ABS( X( I, J ) )
+ 110 CONTINUE
+ WORK( K ) = WORK( K ) + S
+ KC = KC + K
+ 120 CONTINUE
+ ELSE
+ DO 140 K = 1, N
+ S = ABS( X( K, J ) )
+ DO 130 I = 1, K - 1
+ S = S + ABS( AP( KC+I-1 ) )*ABS( X( I, J ) )
+ 130 CONTINUE
+ WORK( K ) = WORK( K ) + S
+ KC = KC + K
+ 140 CONTINUE
+ END IF
+ ELSE
+ KC = 1
+ IF( NOUNIT ) THEN
+ DO 160 K = 1, N
+ S = ZERO
+ DO 150 I = K, N
+ S = S + ABS( AP( KC+I-K ) )*ABS( X( I, J ) )
+ 150 CONTINUE
+ WORK( K ) = WORK( K ) + S
+ KC = KC + N - K + 1
+ 160 CONTINUE
+ ELSE
+ DO 180 K = 1, N
+ S = ABS( X( K, J ) )
+ DO 170 I = K + 1, N
+ S = S + ABS( AP( KC+I-K ) )*ABS( X( I, J ) )
+ 170 CONTINUE
+ WORK( K ) = WORK( K ) + S
+ KC = KC + N - K + 1
+ 180 CONTINUE
+ END IF
+ END IF
+ END IF
+ S = ZERO
+ DO 190 I = 1, N
+ IF( WORK( I ).GT.SAFE2 ) THEN
+ S = MAX( S, ABS( WORK( N+I ) ) / WORK( I ) )
+ ELSE
+ S = MAX( S, ( ABS( WORK( N+I ) )+SAFE1 ) /
+ $ ( WORK( I )+SAFE1 ) )
+ END IF
+ 190 CONTINUE
+ BERR( J ) = S
+*
+* Bound error from formula
+*
+* norm(X - XTRUE) / norm(X) .le. FERR =
+* norm( abs(inv(op(A)))*
+* ( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X)
+*
+* where
+* norm(Z) is the magnitude of the largest component of Z
+* inv(op(A)) is the inverse of op(A)
+* abs(Z) is the componentwise absolute value of the matrix or
+* vector Z
+* NZ is the maximum number of nonzeros in any row of A, plus 1
+* EPS is machine epsilon
+*
+* The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B))
+* is incremented by SAFE1 if the i-th component of
+* abs(op(A))*abs(X) + abs(B) is less than SAFE2.
+*
+* Use DLACN2 to estimate the infinity-norm of the matrix
+* inv(op(A)) * diag(W),
+* where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) )))
+*
+ DO 200 I = 1, N
+ IF( WORK( I ).GT.SAFE2 ) THEN
+ WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I )
+ ELSE
+ WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I ) + SAFE1
+ END IF
+ 200 CONTINUE
+*
+ KASE = 0
+ 210 CONTINUE
+ CALL DLACN2( N, WORK( 2*N+1 ), WORK( N+1 ), IWORK, FERR( J ),
+ $ KASE, ISAVE )
+ IF( KASE.NE.0 ) THEN
+ IF( KASE.EQ.1 ) THEN
+*
+* Multiply by diag(W)*inv(op(A)').
+*
+ CALL DTPSV( UPLO, TRANST, DIAG, N, AP, WORK( N+1 ), 1 )
+ DO 220 I = 1, N
+ WORK( N+I ) = WORK( I )*WORK( N+I )
+ 220 CONTINUE
+ ELSE
+*
+* Multiply by inv(op(A))*diag(W).
+*
+ DO 230 I = 1, N
+ WORK( N+I ) = WORK( I )*WORK( N+I )
+ 230 CONTINUE
+ CALL DTPSV( UPLO, TRANS, DIAG, N, AP, WORK( N+1 ), 1 )
+ END IF
+ GO TO 210
+ END IF
+*
+* Normalize error.
+*
+ LSTRES = ZERO
+ DO 240 I = 1, N
+ LSTRES = MAX( LSTRES, ABS( X( I, J ) ) )
+ 240 CONTINUE
+ IF( LSTRES.NE.ZERO )
+ $ FERR( J ) = FERR( J ) / LSTRES
+*
+ 250 CONTINUE
+*
+ RETURN
+*
+* End of DTPRFS
+*
+ END
+ SUBROUTINE DTPTRI( UPLO, DIAG, N, AP, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER DIAG, UPLO
+ INTEGER INFO, N
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION AP( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DTPTRI computes the inverse of a real upper or lower triangular
+* matrix A stored in packed format.
+*
+* Arguments
+* =========
+*
+* UPLO (input) CHARACTER*1
+* = 'U': A is upper triangular;
+* = 'L': A is lower triangular.
+*
+* DIAG (input) CHARACTER*1
+* = 'N': A is non-unit triangular;
+* = 'U': A is unit triangular.
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* AP (input/output) DOUBLE PRECISION array, dimension (N*(N+1)/2)
+* On entry, the upper or lower triangular matrix A, stored
+* columnwise in a linear array. The j-th column of A is stored
+* in the array AP as follows:
+* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
+* if UPLO = 'L', AP(i + (j-1)*((2*n-j)/2) = A(i,j) for j<=i<=n.
+* See below for further details.
+* On exit, the (triangular) inverse of the original matrix, in
+* the same packed storage format.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* > 0: if INFO = i, A(i,i) is exactly zero. The triangular
+* matrix is singular and its inverse can not be computed.
+*
+* Further Details
+* ===============
+*
+* A triangular matrix A can be transferred to packed storage using one
+* of the following program segments:
+*
+* UPLO = 'U': UPLO = 'L':
+*
+* JC = 1 JC = 1
+* DO 2 J = 1, N DO 2 J = 1, N
+* DO 1 I = 1, J DO 1 I = J, N
+* AP(JC+I-1) = A(I,J) AP(JC+I-J) = A(I,J)
+* 1 CONTINUE 1 CONTINUE
+* JC = JC + J JC = JC + N - J + 1
+* 2 CONTINUE 2 CONTINUE
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE, ZERO
+ PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL NOUNIT, UPPER
+ INTEGER J, JC, JCLAST, JJ
+ DOUBLE PRECISION AJJ
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL DSCAL, DTPMV, XERBLA
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ NOUNIT = LSAME( DIAG, 'N' )
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
+ INFO = -2
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -3
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DTPTRI', -INFO )
+ RETURN
+ END IF
+*
+* Check for singularity if non-unit.
+*
+ IF( NOUNIT ) THEN
+ IF( UPPER ) THEN
+ JJ = 0
+ DO 10 INFO = 1, N
+ JJ = JJ + INFO
+ IF( AP( JJ ).EQ.ZERO )
+ $ RETURN
+ 10 CONTINUE
+ ELSE
+ JJ = 1
+ DO 20 INFO = 1, N
+ IF( AP( JJ ).EQ.ZERO )
+ $ RETURN
+ JJ = JJ + N - INFO + 1
+ 20 CONTINUE
+ END IF
+ INFO = 0
+ END IF
+*
+ IF( UPPER ) THEN
+*
+* Compute inverse of upper triangular matrix.
+*
+ JC = 1
+ DO 30 J = 1, N
+ IF( NOUNIT ) THEN
+ AP( JC+J-1 ) = ONE / AP( JC+J-1 )
+ AJJ = -AP( JC+J-1 )
+ ELSE
+ AJJ = -ONE
+ END IF
+*
+* Compute elements 1:j-1 of j-th column.
+*
+ CALL DTPMV( 'Upper', 'No transpose', DIAG, J-1, AP,
+ $ AP( JC ), 1 )
+ CALL DSCAL( J-1, AJJ, AP( JC ), 1 )
+ JC = JC + J
+ 30 CONTINUE
+*
+ ELSE
+*
+* Compute inverse of lower triangular matrix.
+*
+ JC = N*( N+1 ) / 2
+ DO 40 J = N, 1, -1
+ IF( NOUNIT ) THEN
+ AP( JC ) = ONE / AP( JC )
+ AJJ = -AP( JC )
+ ELSE
+ AJJ = -ONE
+ END IF
+ IF( J.LT.N ) THEN
+*
+* Compute elements j+1:n of j-th column.
+*
+ CALL DTPMV( 'Lower', 'No transpose', DIAG, N-J,
+ $ AP( JCLAST ), AP( JC+1 ), 1 )
+ CALL DSCAL( N-J, AJJ, AP( JC+1 ), 1 )
+ END IF
+ JCLAST = JC
+ JC = JC - N + J - 2
+ 40 CONTINUE
+ END IF
+*
+ RETURN
+*
+* End of DTPTRI
+*
+ END
+ SUBROUTINE DTPTRS( UPLO, TRANS, DIAG, N, NRHS, AP, B, LDB, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER DIAG, TRANS, UPLO
+ INTEGER INFO, LDB, N, NRHS
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION AP( * ), B( LDB, * )
+* ..
+*
+* Purpose
+* =======
+*
+* DTPTRS solves a triangular system of the form
+*
+* A * X = B or A**T * X = B,
+*
+* where A is a triangular matrix of order N stored in packed format,
+* and B is an N-by-NRHS matrix. A check is made to verify that A is
+* nonsingular.
+*
+* Arguments
+* =========
+*
+* UPLO (input) CHARACTER*1
+* = 'U': A is upper triangular;
+* = 'L': A is lower triangular.
+*
+* TRANS (input) CHARACTER*1
+* Specifies the form of the system of equations:
+* = 'N': A * X = B (No transpose)
+* = 'T': A**T * X = B (Transpose)
+* = 'C': A**H * X = B (Conjugate transpose = Transpose)
+*
+* DIAG (input) CHARACTER*1
+* = 'N': A is non-unit triangular;
+* = 'U': A is unit triangular.
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* NRHS (input) INTEGER
+* The number of right hand sides, i.e., the number of columns
+* of the matrix B. NRHS >= 0.
+*
+* AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)
+* The upper or lower triangular matrix A, packed columnwise in
+* a linear array. The j-th column of A is stored in the array
+* AP as follows:
+* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
+* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
+*
+* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
+* On entry, the right hand side matrix B.
+* On exit, if INFO = 0, the solution matrix X.
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. LDB >= max(1,N).
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* > 0: if INFO = i, the i-th diagonal element of A is zero,
+* indicating that the matrix is singular and the
+* solutions X have not been computed.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO
+ PARAMETER ( ZERO = 0.0D+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL NOUNIT, UPPER
+ INTEGER J, JC
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL DTPSV, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ NOUNIT = LSAME( DIAG, 'N' )
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( .NOT.LSAME( TRANS, 'N' ) .AND. .NOT.
+ $ LSAME( TRANS, 'T' ) .AND. .NOT.LSAME( TRANS, 'C' ) ) THEN
+ INFO = -2
+ ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
+ INFO = -3
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( NRHS.LT.0 ) THEN
+ INFO = -5
+ ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -8
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DTPTRS', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+* Check for singularity.
+*
+ IF( NOUNIT ) THEN
+ IF( UPPER ) THEN
+ JC = 1
+ DO 10 INFO = 1, N
+ IF( AP( JC+INFO-1 ).EQ.ZERO )
+ $ RETURN
+ JC = JC + INFO
+ 10 CONTINUE
+ ELSE
+ JC = 1
+ DO 20 INFO = 1, N
+ IF( AP( JC ).EQ.ZERO )
+ $ RETURN
+ JC = JC + N - INFO + 1
+ 20 CONTINUE
+ END IF
+ END IF
+ INFO = 0
+*
+* Solve A * x = b or A' * x = b.
+*
+ DO 30 J = 1, NRHS
+ CALL DTPSV( UPLO, TRANS, DIAG, N, AP, B( 1, J ), 1 )
+ 30 CONTINUE
+*
+ RETURN
+*
+* End of DTPTRS
+*
+ END
+ SUBROUTINE DTRCON( NORM, UPLO, DIAG, N, A, LDA, RCOND, WORK,
+ $ IWORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH.
+*
+* .. Scalar Arguments ..
+ CHARACTER DIAG, NORM, UPLO
+ INTEGER INFO, LDA, N
+ DOUBLE PRECISION RCOND
+* ..
+* .. Array Arguments ..
+ INTEGER IWORK( * )
+ DOUBLE PRECISION A( LDA, * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DTRCON estimates the reciprocal of the condition number of a
+* triangular matrix A, in either the 1-norm or the infinity-norm.
+*
+* The norm of A is computed and an estimate is obtained for
+* norm(inv(A)), then the reciprocal of the condition number is
+* computed as
+* RCOND = 1 / ( norm(A) * norm(inv(A)) ).
+*
+* Arguments
+* =========
+*
+* NORM (input) CHARACTER*1
+* Specifies whether the 1-norm condition number or the
+* infinity-norm condition number is required:
+* = '1' or 'O': 1-norm;
+* = 'I': Infinity-norm.
+*
+* UPLO (input) CHARACTER*1
+* = 'U': A is upper triangular;
+* = 'L': A is lower triangular.
+*
+* DIAG (input) CHARACTER*1
+* = 'N': A is non-unit triangular;
+* = 'U': A is unit triangular.
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* A (input) DOUBLE PRECISION array, dimension (LDA,N)
+* The triangular matrix A. If UPLO = 'U', the leading N-by-N
+* upper triangular part of the array A contains the upper
+* triangular matrix, and the strictly lower triangular part of
+* A is not referenced. If UPLO = 'L', the leading N-by-N lower
+* triangular part of the array A contains the lower triangular
+* matrix, and the strictly upper triangular part of A is not
+* referenced. If DIAG = 'U', the diagonal elements of A are
+* also not referenced and are assumed to be 1.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,N).
+*
+* RCOND (output) DOUBLE PRECISION
+* The reciprocal of the condition number of the matrix A,
+* computed as RCOND = 1/(norm(A) * norm(inv(A))).
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (3*N)
+*
+* IWORK (workspace) INTEGER array, dimension (N)
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE, ZERO
+ PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL NOUNIT, ONENRM, UPPER
+ CHARACTER NORMIN
+ INTEGER IX, KASE, KASE1
+ DOUBLE PRECISION AINVNM, ANORM, SCALE, SMLNUM, XNORM
+* ..
+* .. Local Arrays ..
+ INTEGER ISAVE( 3 )
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER IDAMAX
+ DOUBLE PRECISION DLAMCH, DLANTR
+ EXTERNAL LSAME, IDAMAX, DLAMCH, DLANTR
+* ..
+* .. External Subroutines ..
+ EXTERNAL DLACN2, DLATRS, DRSCL, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, DBLE, MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ ONENRM = NORM.EQ.'1' .OR. LSAME( NORM, 'O' )
+ NOUNIT = LSAME( DIAG, 'N' )
+*
+ IF( .NOT.ONENRM .AND. .NOT.LSAME( NORM, 'I' ) ) THEN
+ INFO = -1
+ ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -2
+ ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
+ INFO = -3
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -6
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DTRCON', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 ) THEN
+ RCOND = ONE
+ RETURN
+ END IF
+*
+ RCOND = ZERO
+ SMLNUM = DLAMCH( 'Safe minimum' )*DBLE( MAX( 1, N ) )
+*
+* Compute the norm of the triangular matrix A.
+*
+ ANORM = DLANTR( NORM, UPLO, DIAG, N, N, A, LDA, WORK )
+*
+* Continue only if ANORM > 0.
+*
+ IF( ANORM.GT.ZERO ) THEN
+*
+* Estimate the norm of the inverse of A.
+*
+ AINVNM = ZERO
+ NORMIN = 'N'
+ IF( ONENRM ) THEN
+ KASE1 = 1
+ ELSE
+ KASE1 = 2
+ END IF
+ KASE = 0
+ 10 CONTINUE
+ CALL DLACN2( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE, ISAVE )
+ IF( KASE.NE.0 ) THEN
+ IF( KASE.EQ.KASE1 ) THEN
+*
+* Multiply by inv(A).
+*
+ CALL DLATRS( UPLO, 'No transpose', DIAG, NORMIN, N, A,
+ $ LDA, WORK, SCALE, WORK( 2*N+1 ), INFO )
+ ELSE
+*
+* Multiply by inv(A').
+*
+ CALL DLATRS( UPLO, 'Transpose', DIAG, NORMIN, N, A, LDA,
+ $ WORK, SCALE, WORK( 2*N+1 ), INFO )
+ END IF
+ NORMIN = 'Y'
+*
+* Multiply by 1/SCALE if doing so will not cause overflow.
+*
+ IF( SCALE.NE.ONE ) THEN
+ IX = IDAMAX( N, WORK, 1 )
+ XNORM = ABS( WORK( IX ) )
+ IF( SCALE.LT.XNORM*SMLNUM .OR. SCALE.EQ.ZERO )
+ $ GO TO 20
+ CALL DRSCL( N, SCALE, WORK, 1 )
+ END IF
+ GO TO 10
+ END IF
+*
+* Compute the estimate of the reciprocal condition number.
+*
+ IF( AINVNM.NE.ZERO )
+ $ RCOND = ( ONE / ANORM ) / AINVNM
+ END IF
+*
+ 20 CONTINUE
+ RETURN
+*
+* End of DTRCON
+*
+ END
+ SUBROUTINE DTREVC( SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR,
+ $ LDVR, MM, M, WORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER HOWMNY, SIDE
+ INTEGER INFO, LDT, LDVL, LDVR, M, MM, N
+* ..
+* .. Array Arguments ..
+ LOGICAL SELECT( * )
+ DOUBLE PRECISION T( LDT, * ), VL( LDVL, * ), VR( LDVR, * ),
+ $ WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DTREVC computes some or all of the right and/or left eigenvectors of
+* a real upper quasi-triangular matrix T.
+* Matrices of this type are produced by the Schur factorization of
+* a real general matrix: A = Q*T*Q**T, as computed by DHSEQR.
+*
+* The right eigenvector x and the left eigenvector y of T corresponding
+* to an eigenvalue w are defined by:
+*
+* T*x = w*x, (y**H)*T = w*(y**H)
+*
+* where y**H denotes the conjugate transpose of y.
+* The eigenvalues are not input to this routine, but are read directly
+* from the diagonal blocks of T.
+*
+* This routine returns the matrices X and/or Y of right and left
+* eigenvectors of T, or the products Q*X and/or Q*Y, where Q is an
+* input matrix. If Q is the orthogonal factor that reduces a matrix
+* A to Schur form T, then Q*X and Q*Y are the matrices of right and
+* left eigenvectors of A.
+*
+* Arguments
+* =========
+*
+* SIDE (input) CHARACTER*1
+* = 'R': compute right eigenvectors only;
+* = 'L': compute left eigenvectors only;
+* = 'B': compute both right and left eigenvectors.
+*
+* HOWMNY (input) CHARACTER*1
+* = 'A': compute all right and/or left eigenvectors;
+* = 'B': compute all right and/or left eigenvectors,
+* backtransformed by the matrices in VR and/or VL;
+* = 'S': compute selected right and/or left eigenvectors,
+* as indicated by the logical array SELECT.
+*
+* SELECT (input/output) LOGICAL array, dimension (N)
+* If HOWMNY = 'S', SELECT specifies the eigenvectors to be
+* computed.
+* If w(j) is a real eigenvalue, the corresponding real
+* eigenvector is computed if SELECT(j) is .TRUE..
+* If w(j) and w(j+1) are the real and imaginary parts of a
+* complex eigenvalue, the corresponding complex eigenvector is
+* computed if either SELECT(j) or SELECT(j+1) is .TRUE., and
+* on exit SELECT(j) is set to .TRUE. and SELECT(j+1) is set to
+* .FALSE..
+* Not referenced if HOWMNY = 'A' or 'B'.
+*
+* N (input) INTEGER
+* The order of the matrix T. N >= 0.
+*
+* T (input) DOUBLE PRECISION array, dimension (LDT,N)
+* The upper quasi-triangular matrix T in Schur canonical form.
+*
+* LDT (input) INTEGER
+* The leading dimension of the array T. LDT >= max(1,N).
+*
+* VL (input/output) DOUBLE PRECISION array, dimension (LDVL,MM)
+* On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must
+* contain an N-by-N matrix Q (usually the orthogonal matrix Q
+* of Schur vectors returned by DHSEQR).
+* On exit, if SIDE = 'L' or 'B', VL contains:
+* if HOWMNY = 'A', the matrix Y of left eigenvectors of T;
+* if HOWMNY = 'B', the matrix Q*Y;
+* if HOWMNY = 'S', the left eigenvectors of T specified by
+* SELECT, stored consecutively in the columns
+* of VL, in the same order as their
+* eigenvalues.
+* A complex eigenvector corresponding to a complex eigenvalue
+* is stored in two consecutive columns, the first holding the
+* real part, and the second the imaginary part.
+* Not referenced if SIDE = 'R'.
+*
+* LDVL (input) INTEGER
+* The leading dimension of the array VL. LDVL >= 1, and if
+* SIDE = 'L' or 'B', LDVL >= N.
+*
+* VR (input/output) DOUBLE PRECISION array, dimension (LDVR,MM)
+* On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must
+* contain an N-by-N matrix Q (usually the orthogonal matrix Q
+* of Schur vectors returned by DHSEQR).
+* On exit, if SIDE = 'R' or 'B', VR contains:
+* if HOWMNY = 'A', the matrix X of right eigenvectors of T;
+* if HOWMNY = 'B', the matrix Q*X;
+* if HOWMNY = 'S', the right eigenvectors of T specified by
+* SELECT, stored consecutively in the columns
+* of VR, in the same order as their
+* eigenvalues.
+* A complex eigenvector corresponding to a complex eigenvalue
+* is stored in two consecutive columns, the first holding the
+* real part and the second the imaginary part.
+* Not referenced if SIDE = 'L'.
+*
+* LDVR (input) INTEGER
+* The leading dimension of the array VR. LDVR >= 1, and if
+* SIDE = 'R' or 'B', LDVR >= N.
+*
+* MM (input) INTEGER
+* The number of columns in the arrays VL and/or VR. MM >= M.
+*
+* M (output) INTEGER
+* The number of columns in the arrays VL and/or VR actually
+* used to store the eigenvectors.
+* If HOWMNY = 'A' or 'B', M is set to N.
+* Each selected real eigenvector occupies one column and each
+* selected complex eigenvector occupies two columns.
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (3*N)
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+*
+* Further Details
+* ===============
+*
+* The algorithm used in this program is basically backward (forward)
+* substitution, with scaling to make the the code robust against
+* possible overflow.
+*
+* Each eigenvector is normalized so that the element of largest
+* magnitude has magnitude 1; here the magnitude of a complex number
+* (x,y) is taken to be |x| + |y|.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL ALLV, BOTHV, LEFTV, OVER, PAIR, RIGHTV, SOMEV
+ INTEGER I, IERR, II, IP, IS, J, J1, J2, JNXT, K, KI, N2
+ DOUBLE PRECISION BETA, BIGNUM, EMAX, OVFL, REC, REMAX, SCALE,
+ $ SMIN, SMLNUM, ULP, UNFL, VCRIT, VMAX, WI, WR,
+ $ XNORM
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER IDAMAX
+ DOUBLE PRECISION DDOT, DLAMCH
+ EXTERNAL LSAME, IDAMAX, DDOT, DLAMCH
+* ..
+* .. External Subroutines ..
+ EXTERNAL DAXPY, DCOPY, DGEMV, DLALN2, DSCAL, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, SQRT
+* ..
+* .. Local Arrays ..
+ DOUBLE PRECISION X( 2, 2 )
+* ..
+* .. Executable Statements ..
+*
+* Decode and test the input parameters
+*
+ BOTHV = LSAME( SIDE, 'B' )
+ RIGHTV = LSAME( SIDE, 'R' ) .OR. BOTHV
+ LEFTV = LSAME( SIDE, 'L' ) .OR. BOTHV
+*
+ ALLV = LSAME( HOWMNY, 'A' )
+ OVER = LSAME( HOWMNY, 'B' )
+ SOMEV = LSAME( HOWMNY, 'S' )
+*
+ INFO = 0
+ IF( .NOT.RIGHTV .AND. .NOT.LEFTV ) THEN
+ INFO = -1
+ ELSE IF( .NOT.ALLV .AND. .NOT.OVER .AND. .NOT.SOMEV ) THEN
+ INFO = -2
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( LDT.LT.MAX( 1, N ) ) THEN
+ INFO = -6
+ ELSE IF( LDVL.LT.1 .OR. ( LEFTV .AND. LDVL.LT.N ) ) THEN
+ INFO = -8
+ ELSE IF( LDVR.LT.1 .OR. ( RIGHTV .AND. LDVR.LT.N ) ) THEN
+ INFO = -10
+ ELSE
+*
+* Set M to the number of columns required to store the selected
+* eigenvectors, standardize the array SELECT if necessary, and
+* test MM.
+*
+ IF( SOMEV ) THEN
+ M = 0
+ PAIR = .FALSE.
+ DO 10 J = 1, N
+ IF( PAIR ) THEN
+ PAIR = .FALSE.
+ SELECT( J ) = .FALSE.
+ ELSE
+ IF( J.LT.N ) THEN
+ IF( T( J+1, J ).EQ.ZERO ) THEN
+ IF( SELECT( J ) )
+ $ M = M + 1
+ ELSE
+ PAIR = .TRUE.
+ IF( SELECT( J ) .OR. SELECT( J+1 ) ) THEN
+ SELECT( J ) = .TRUE.
+ M = M + 2
+ END IF
+ END IF
+ ELSE
+ IF( SELECT( N ) )
+ $ M = M + 1
+ END IF
+ END IF
+ 10 CONTINUE
+ ELSE
+ M = N
+ END IF
+*
+ IF( MM.LT.M ) THEN
+ INFO = -11
+ END IF
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DTREVC', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible.
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+* Set the constants to control overflow.
+*
+ UNFL = DLAMCH( 'Safe minimum' )
+ OVFL = ONE / UNFL
+ CALL DLABAD( UNFL, OVFL )
+ ULP = DLAMCH( 'Precision' )
+ SMLNUM = UNFL*( N / ULP )
+ BIGNUM = ( ONE-ULP ) / SMLNUM
+*
+* Compute 1-norm of each column of strictly upper triangular
+* part of T to control overflow in triangular solver.
+*
+ WORK( 1 ) = ZERO
+ DO 30 J = 2, N
+ WORK( J ) = ZERO
+ DO 20 I = 1, J - 1
+ WORK( J ) = WORK( J ) + ABS( T( I, J ) )
+ 20 CONTINUE
+ 30 CONTINUE
+*
+* Index IP is used to specify the real or complex eigenvalue:
+* IP = 0, real eigenvalue,
+* 1, first of conjugate complex pair: (wr,wi)
+* -1, second of conjugate complex pair: (wr,wi)
+*
+ N2 = 2*N
+*
+ IF( RIGHTV ) THEN
+*
+* Compute right eigenvectors.
+*
+ IP = 0
+ IS = M
+ DO 140 KI = N, 1, -1
+*
+ IF( IP.EQ.1 )
+ $ GO TO 130
+ IF( KI.EQ.1 )
+ $ GO TO 40
+ IF( T( KI, KI-1 ).EQ.ZERO )
+ $ GO TO 40
+ IP = -1
+*
+ 40 CONTINUE
+ IF( SOMEV ) THEN
+ IF( IP.EQ.0 ) THEN
+ IF( .NOT.SELECT( KI ) )
+ $ GO TO 130
+ ELSE
+ IF( .NOT.SELECT( KI-1 ) )
+ $ GO TO 130
+ END IF
+ END IF
+*
+* Compute the KI-th eigenvalue (WR,WI).
+*
+ WR = T( KI, KI )
+ WI = ZERO
+ IF( IP.NE.0 )
+ $ WI = SQRT( ABS( T( KI, KI-1 ) ) )*
+ $ SQRT( ABS( T( KI-1, KI ) ) )
+ SMIN = MAX( ULP*( ABS( WR )+ABS( WI ) ), SMLNUM )
+*
+ IF( IP.EQ.0 ) THEN
+*
+* Real right eigenvector
+*
+ WORK( KI+N ) = ONE
+*
+* Form right-hand side
+*
+ DO 50 K = 1, KI - 1
+ WORK( K+N ) = -T( K, KI )
+ 50 CONTINUE
+*
+* Solve the upper quasi-triangular system:
+* (T(1:KI-1,1:KI-1) - WR)*X = SCALE*WORK.
+*
+ JNXT = KI - 1
+ DO 60 J = KI - 1, 1, -1
+ IF( J.GT.JNXT )
+ $ GO TO 60
+ J1 = J
+ J2 = J
+ JNXT = J - 1
+ IF( J.GT.1 ) THEN
+ IF( T( J, J-1 ).NE.ZERO ) THEN
+ J1 = J - 1
+ JNXT = J - 2
+ END IF
+ END IF
+*
+ IF( J1.EQ.J2 ) THEN
+*
+* 1-by-1 diagonal block
+*
+ CALL DLALN2( .FALSE., 1, 1, SMIN, ONE, T( J, J ),
+ $ LDT, ONE, ONE, WORK( J+N ), N, WR,
+ $ ZERO, X, 2, SCALE, XNORM, IERR )
+*
+* Scale X(1,1) to avoid overflow when updating
+* the right-hand side.
+*
+ IF( XNORM.GT.ONE ) THEN
+ IF( WORK( J ).GT.BIGNUM / XNORM ) THEN
+ X( 1, 1 ) = X( 1, 1 ) / XNORM
+ SCALE = SCALE / XNORM
+ END IF
+ END IF
+*
+* Scale if necessary
+*
+ IF( SCALE.NE.ONE )
+ $ CALL DSCAL( KI, SCALE, WORK( 1+N ), 1 )
+ WORK( J+N ) = X( 1, 1 )
+*
+* Update right-hand side
+*
+ CALL DAXPY( J-1, -X( 1, 1 ), T( 1, J ), 1,
+ $ WORK( 1+N ), 1 )
+*
+ ELSE
+*
+* 2-by-2 diagonal block
+*
+ CALL DLALN2( .FALSE., 2, 1, SMIN, ONE,
+ $ T( J-1, J-1 ), LDT, ONE, ONE,
+ $ WORK( J-1+N ), N, WR, ZERO, X, 2,
+ $ SCALE, XNORM, IERR )
+*
+* Scale X(1,1) and X(2,1) to avoid overflow when
+* updating the right-hand side.
+*
+ IF( XNORM.GT.ONE ) THEN
+ BETA = MAX( WORK( J-1 ), WORK( J ) )
+ IF( BETA.GT.BIGNUM / XNORM ) THEN
+ X( 1, 1 ) = X( 1, 1 ) / XNORM
+ X( 2, 1 ) = X( 2, 1 ) / XNORM
+ SCALE = SCALE / XNORM
+ END IF
+ END IF
+*
+* Scale if necessary
+*
+ IF( SCALE.NE.ONE )
+ $ CALL DSCAL( KI, SCALE, WORK( 1+N ), 1 )
+ WORK( J-1+N ) = X( 1, 1 )
+ WORK( J+N ) = X( 2, 1 )
+*
+* Update right-hand side
+*
+ CALL DAXPY( J-2, -X( 1, 1 ), T( 1, J-1 ), 1,
+ $ WORK( 1+N ), 1 )
+ CALL DAXPY( J-2, -X( 2, 1 ), T( 1, J ), 1,
+ $ WORK( 1+N ), 1 )
+ END IF
+ 60 CONTINUE
+*
+* Copy the vector x or Q*x to VR and normalize.
+*
+ IF( .NOT.OVER ) THEN
+ CALL DCOPY( KI, WORK( 1+N ), 1, VR( 1, IS ), 1 )
+*
+ II = IDAMAX( KI, VR( 1, IS ), 1 )
+ REMAX = ONE / ABS( VR( II, IS ) )
+ CALL DSCAL( KI, REMAX, VR( 1, IS ), 1 )
+*
+ DO 70 K = KI + 1, N
+ VR( K, IS ) = ZERO
+ 70 CONTINUE
+ ELSE
+ IF( KI.GT.1 )
+ $ CALL DGEMV( 'N', N, KI-1, ONE, VR, LDVR,
+ $ WORK( 1+N ), 1, WORK( KI+N ),
+ $ VR( 1, KI ), 1 )
+*
+ II = IDAMAX( N, VR( 1, KI ), 1 )
+ REMAX = ONE / ABS( VR( II, KI ) )
+ CALL DSCAL( N, REMAX, VR( 1, KI ), 1 )
+ END IF
+*
+ ELSE
+*
+* Complex right eigenvector.
+*
+* Initial solve
+* [ (T(KI-1,KI-1) T(KI-1,KI) ) - (WR + I* WI)]*X = 0.
+* [ (T(KI,KI-1) T(KI,KI) ) ]
+*
+ IF( ABS( T( KI-1, KI ) ).GE.ABS( T( KI, KI-1 ) ) ) THEN
+ WORK( KI-1+N ) = ONE
+ WORK( KI+N2 ) = WI / T( KI-1, KI )
+ ELSE
+ WORK( KI-1+N ) = -WI / T( KI, KI-1 )
+ WORK( KI+N2 ) = ONE
+ END IF
+ WORK( KI+N ) = ZERO
+ WORK( KI-1+N2 ) = ZERO
+*
+* Form right-hand side
+*
+ DO 80 K = 1, KI - 2
+ WORK( K+N ) = -WORK( KI-1+N )*T( K, KI-1 )
+ WORK( K+N2 ) = -WORK( KI+N2 )*T( K, KI )
+ 80 CONTINUE
+*
+* Solve upper quasi-triangular system:
+* (T(1:KI-2,1:KI-2) - (WR+i*WI))*X = SCALE*(WORK+i*WORK2)
+*
+ JNXT = KI - 2
+ DO 90 J = KI - 2, 1, -1
+ IF( J.GT.JNXT )
+ $ GO TO 90
+ J1 = J
+ J2 = J
+ JNXT = J - 1
+ IF( J.GT.1 ) THEN
+ IF( T( J, J-1 ).NE.ZERO ) THEN
+ J1 = J - 1
+ JNXT = J - 2
+ END IF
+ END IF
+*
+ IF( J1.EQ.J2 ) THEN
+*
+* 1-by-1 diagonal block
+*
+ CALL DLALN2( .FALSE., 1, 2, SMIN, ONE, T( J, J ),
+ $ LDT, ONE, ONE, WORK( J+N ), N, WR, WI,
+ $ X, 2, SCALE, XNORM, IERR )
+*
+* Scale X(1,1) and X(1,2) to avoid overflow when
+* updating the right-hand side.
+*
+ IF( XNORM.GT.ONE ) THEN
+ IF( WORK( J ).GT.BIGNUM / XNORM ) THEN
+ X( 1, 1 ) = X( 1, 1 ) / XNORM
+ X( 1, 2 ) = X( 1, 2 ) / XNORM
+ SCALE = SCALE / XNORM
+ END IF
+ END IF
+*
+* Scale if necessary
+*
+ IF( SCALE.NE.ONE ) THEN
+ CALL DSCAL( KI, SCALE, WORK( 1+N ), 1 )
+ CALL DSCAL( KI, SCALE, WORK( 1+N2 ), 1 )
+ END IF
+ WORK( J+N ) = X( 1, 1 )
+ WORK( J+N2 ) = X( 1, 2 )
+*
+* Update the right-hand side
+*
+ CALL DAXPY( J-1, -X( 1, 1 ), T( 1, J ), 1,
+ $ WORK( 1+N ), 1 )
+ CALL DAXPY( J-1, -X( 1, 2 ), T( 1, J ), 1,
+ $ WORK( 1+N2 ), 1 )
+*
+ ELSE
+*
+* 2-by-2 diagonal block
+*
+ CALL DLALN2( .FALSE., 2, 2, SMIN, ONE,
+ $ T( J-1, J-1 ), LDT, ONE, ONE,
+ $ WORK( J-1+N ), N, WR, WI, X, 2, SCALE,
+ $ XNORM, IERR )
+*
+* Scale X to avoid overflow when updating
+* the right-hand side.
+*
+ IF( XNORM.GT.ONE ) THEN
+ BETA = MAX( WORK( J-1 ), WORK( J ) )
+ IF( BETA.GT.BIGNUM / XNORM ) THEN
+ REC = ONE / XNORM
+ X( 1, 1 ) = X( 1, 1 )*REC
+ X( 1, 2 ) = X( 1, 2 )*REC
+ X( 2, 1 ) = X( 2, 1 )*REC
+ X( 2, 2 ) = X( 2, 2 )*REC
+ SCALE = SCALE*REC
+ END IF
+ END IF
+*
+* Scale if necessary
+*
+ IF( SCALE.NE.ONE ) THEN
+ CALL DSCAL( KI, SCALE, WORK( 1+N ), 1 )
+ CALL DSCAL( KI, SCALE, WORK( 1+N2 ), 1 )
+ END IF
+ WORK( J-1+N ) = X( 1, 1 )
+ WORK( J+N ) = X( 2, 1 )
+ WORK( J-1+N2 ) = X( 1, 2 )
+ WORK( J+N2 ) = X( 2, 2 )
+*
+* Update the right-hand side
+*
+ CALL DAXPY( J-2, -X( 1, 1 ), T( 1, J-1 ), 1,
+ $ WORK( 1+N ), 1 )
+ CALL DAXPY( J-2, -X( 2, 1 ), T( 1, J ), 1,
+ $ WORK( 1+N ), 1 )
+ CALL DAXPY( J-2, -X( 1, 2 ), T( 1, J-1 ), 1,
+ $ WORK( 1+N2 ), 1 )
+ CALL DAXPY( J-2, -X( 2, 2 ), T( 1, J ), 1,
+ $ WORK( 1+N2 ), 1 )
+ END IF
+ 90 CONTINUE
+*
+* Copy the vector x or Q*x to VR and normalize.
+*
+ IF( .NOT.OVER ) THEN
+ CALL DCOPY( KI, WORK( 1+N ), 1, VR( 1, IS-1 ), 1 )
+ CALL DCOPY( KI, WORK( 1+N2 ), 1, VR( 1, IS ), 1 )
+*
+ EMAX = ZERO
+ DO 100 K = 1, KI
+ EMAX = MAX( EMAX, ABS( VR( K, IS-1 ) )+
+ $ ABS( VR( K, IS ) ) )
+ 100 CONTINUE
+*
+ REMAX = ONE / EMAX
+ CALL DSCAL( KI, REMAX, VR( 1, IS-1 ), 1 )
+ CALL DSCAL( KI, REMAX, VR( 1, IS ), 1 )
+*
+ DO 110 K = KI + 1, N
+ VR( K, IS-1 ) = ZERO
+ VR( K, IS ) = ZERO
+ 110 CONTINUE
+*
+ ELSE
+*
+ IF( KI.GT.2 ) THEN
+ CALL DGEMV( 'N', N, KI-2, ONE, VR, LDVR,
+ $ WORK( 1+N ), 1, WORK( KI-1+N ),
+ $ VR( 1, KI-1 ), 1 )
+ CALL DGEMV( 'N', N, KI-2, ONE, VR, LDVR,
+ $ WORK( 1+N2 ), 1, WORK( KI+N2 ),
+ $ VR( 1, KI ), 1 )
+ ELSE
+ CALL DSCAL( N, WORK( KI-1+N ), VR( 1, KI-1 ), 1 )
+ CALL DSCAL( N, WORK( KI+N2 ), VR( 1, KI ), 1 )
+ END IF
+*
+ EMAX = ZERO
+ DO 120 K = 1, N
+ EMAX = MAX( EMAX, ABS( VR( K, KI-1 ) )+
+ $ ABS( VR( K, KI ) ) )
+ 120 CONTINUE
+ REMAX = ONE / EMAX
+ CALL DSCAL( N, REMAX, VR( 1, KI-1 ), 1 )
+ CALL DSCAL( N, REMAX, VR( 1, KI ), 1 )
+ END IF
+ END IF
+*
+ IS = IS - 1
+ IF( IP.NE.0 )
+ $ IS = IS - 1
+ 130 CONTINUE
+ IF( IP.EQ.1 )
+ $ IP = 0
+ IF( IP.EQ.-1 )
+ $ IP = 1
+ 140 CONTINUE
+ END IF
+*
+ IF( LEFTV ) THEN
+*
+* Compute left eigenvectors.
+*
+ IP = 0
+ IS = 1
+ DO 260 KI = 1, N
+*
+ IF( IP.EQ.-1 )
+ $ GO TO 250
+ IF( KI.EQ.N )
+ $ GO TO 150
+ IF( T( KI+1, KI ).EQ.ZERO )
+ $ GO TO 150
+ IP = 1
+*
+ 150 CONTINUE
+ IF( SOMEV ) THEN
+ IF( .NOT.SELECT( KI ) )
+ $ GO TO 250
+ END IF
+*
+* Compute the KI-th eigenvalue (WR,WI).
+*
+ WR = T( KI, KI )
+ WI = ZERO
+ IF( IP.NE.0 )
+ $ WI = SQRT( ABS( T( KI, KI+1 ) ) )*
+ $ SQRT( ABS( T( KI+1, KI ) ) )
+ SMIN = MAX( ULP*( ABS( WR )+ABS( WI ) ), SMLNUM )
+*
+ IF( IP.EQ.0 ) THEN
+*
+* Real left eigenvector.
+*
+ WORK( KI+N ) = ONE
+*
+* Form right-hand side
+*
+ DO 160 K = KI + 1, N
+ WORK( K+N ) = -T( KI, K )
+ 160 CONTINUE
+*
+* Solve the quasi-triangular system:
+* (T(KI+1:N,KI+1:N) - WR)'*X = SCALE*WORK
+*
+ VMAX = ONE
+ VCRIT = BIGNUM
+*
+ JNXT = KI + 1
+ DO 170 J = KI + 1, N
+ IF( J.LT.JNXT )
+ $ GO TO 170
+ J1 = J
+ J2 = J
+ JNXT = J + 1
+ IF( J.LT.N ) THEN
+ IF( T( J+1, J ).NE.ZERO ) THEN
+ J2 = J + 1
+ JNXT = J + 2
+ END IF
+ END IF
+*
+ IF( J1.EQ.J2 ) THEN
+*
+* 1-by-1 diagonal block
+*
+* Scale if necessary to avoid overflow when forming
+* the right-hand side.
+*
+ IF( WORK( J ).GT.VCRIT ) THEN
+ REC = ONE / VMAX
+ CALL DSCAL( N-KI+1, REC, WORK( KI+N ), 1 )
+ VMAX = ONE
+ VCRIT = BIGNUM
+ END IF
+*
+ WORK( J+N ) = WORK( J+N ) -
+ $ DDOT( J-KI-1, T( KI+1, J ), 1,
+ $ WORK( KI+1+N ), 1 )
+*
+* Solve (T(J,J)-WR)'*X = WORK
+*
+ CALL DLALN2( .FALSE., 1, 1, SMIN, ONE, T( J, J ),
+ $ LDT, ONE, ONE, WORK( J+N ), N, WR,
+ $ ZERO, X, 2, SCALE, XNORM, IERR )
+*
+* Scale if necessary
+*
+ IF( SCALE.NE.ONE )
+ $ CALL DSCAL( N-KI+1, SCALE, WORK( KI+N ), 1 )
+ WORK( J+N ) = X( 1, 1 )
+ VMAX = MAX( ABS( WORK( J+N ) ), VMAX )
+ VCRIT = BIGNUM / VMAX
+*
+ ELSE
+*
+* 2-by-2 diagonal block
+*
+* Scale if necessary to avoid overflow when forming
+* the right-hand side.
+*
+ BETA = MAX( WORK( J ), WORK( J+1 ) )
+ IF( BETA.GT.VCRIT ) THEN
+ REC = ONE / VMAX
+ CALL DSCAL( N-KI+1, REC, WORK( KI+N ), 1 )
+ VMAX = ONE
+ VCRIT = BIGNUM
+ END IF
+*
+ WORK( J+N ) = WORK( J+N ) -
+ $ DDOT( J-KI-1, T( KI+1, J ), 1,
+ $ WORK( KI+1+N ), 1 )
+*
+ WORK( J+1+N ) = WORK( J+1+N ) -
+ $ DDOT( J-KI-1, T( KI+1, J+1 ), 1,
+ $ WORK( KI+1+N ), 1 )
+*
+* Solve
+* [T(J,J)-WR T(J,J+1) ]'* X = SCALE*( WORK1 )
+* [T(J+1,J) T(J+1,J+1)-WR] ( WORK2 )
+*
+ CALL DLALN2( .TRUE., 2, 1, SMIN, ONE, T( J, J ),
+ $ LDT, ONE, ONE, WORK( J+N ), N, WR,
+ $ ZERO, X, 2, SCALE, XNORM, IERR )
+*
+* Scale if necessary
+*
+ IF( SCALE.NE.ONE )
+ $ CALL DSCAL( N-KI+1, SCALE, WORK( KI+N ), 1 )
+ WORK( J+N ) = X( 1, 1 )
+ WORK( J+1+N ) = X( 2, 1 )
+*
+ VMAX = MAX( ABS( WORK( J+N ) ),
+ $ ABS( WORK( J+1+N ) ), VMAX )
+ VCRIT = BIGNUM / VMAX
+*
+ END IF
+ 170 CONTINUE
+*
+* Copy the vector x or Q*x to VL and normalize.
+*
+ IF( .NOT.OVER ) THEN
+ CALL DCOPY( N-KI+1, WORK( KI+N ), 1, VL( KI, IS ), 1 )
+*
+ II = IDAMAX( N-KI+1, VL( KI, IS ), 1 ) + KI - 1
+ REMAX = ONE / ABS( VL( II, IS ) )
+ CALL DSCAL( N-KI+1, REMAX, VL( KI, IS ), 1 )
+*
+ DO 180 K = 1, KI - 1
+ VL( K, IS ) = ZERO
+ 180 CONTINUE
+*
+ ELSE
+*
+ IF( KI.LT.N )
+ $ CALL DGEMV( 'N', N, N-KI, ONE, VL( 1, KI+1 ), LDVL,
+ $ WORK( KI+1+N ), 1, WORK( KI+N ),
+ $ VL( 1, KI ), 1 )
+*
+ II = IDAMAX( N, VL( 1, KI ), 1 )
+ REMAX = ONE / ABS( VL( II, KI ) )
+ CALL DSCAL( N, REMAX, VL( 1, KI ), 1 )
+*
+ END IF
+*
+ ELSE
+*
+* Complex left eigenvector.
+*
+* Initial solve:
+* ((T(KI,KI) T(KI,KI+1) )' - (WR - I* WI))*X = 0.
+* ((T(KI+1,KI) T(KI+1,KI+1)) )
+*
+ IF( ABS( T( KI, KI+1 ) ).GE.ABS( T( KI+1, KI ) ) ) THEN
+ WORK( KI+N ) = WI / T( KI, KI+1 )
+ WORK( KI+1+N2 ) = ONE
+ ELSE
+ WORK( KI+N ) = ONE
+ WORK( KI+1+N2 ) = -WI / T( KI+1, KI )
+ END IF
+ WORK( KI+1+N ) = ZERO
+ WORK( KI+N2 ) = ZERO
+*
+* Form right-hand side
+*
+ DO 190 K = KI + 2, N
+ WORK( K+N ) = -WORK( KI+N )*T( KI, K )
+ WORK( K+N2 ) = -WORK( KI+1+N2 )*T( KI+1, K )
+ 190 CONTINUE
+*
+* Solve complex quasi-triangular system:
+* ( T(KI+2,N:KI+2,N) - (WR-i*WI) )*X = WORK1+i*WORK2
+*
+ VMAX = ONE
+ VCRIT = BIGNUM
+*
+ JNXT = KI + 2
+ DO 200 J = KI + 2, N
+ IF( J.LT.JNXT )
+ $ GO TO 200
+ J1 = J
+ J2 = J
+ JNXT = J + 1
+ IF( J.LT.N ) THEN
+ IF( T( J+1, J ).NE.ZERO ) THEN
+ J2 = J + 1
+ JNXT = J + 2
+ END IF
+ END IF
+*
+ IF( J1.EQ.J2 ) THEN
+*
+* 1-by-1 diagonal block
+*
+* Scale if necessary to avoid overflow when
+* forming the right-hand side elements.
+*
+ IF( WORK( J ).GT.VCRIT ) THEN
+ REC = ONE / VMAX
+ CALL DSCAL( N-KI+1, REC, WORK( KI+N ), 1 )
+ CALL DSCAL( N-KI+1, REC, WORK( KI+N2 ), 1 )
+ VMAX = ONE
+ VCRIT = BIGNUM
+ END IF
+*
+ WORK( J+N ) = WORK( J+N ) -
+ $ DDOT( J-KI-2, T( KI+2, J ), 1,
+ $ WORK( KI+2+N ), 1 )
+ WORK( J+N2 ) = WORK( J+N2 ) -
+ $ DDOT( J-KI-2, T( KI+2, J ), 1,
+ $ WORK( KI+2+N2 ), 1 )
+*
+* Solve (T(J,J)-(WR-i*WI))*(X11+i*X12)= WK+I*WK2
+*
+ CALL DLALN2( .FALSE., 1, 2, SMIN, ONE, T( J, J ),
+ $ LDT, ONE, ONE, WORK( J+N ), N, WR,
+ $ -WI, X, 2, SCALE, XNORM, IERR )
+*
+* Scale if necessary
+*
+ IF( SCALE.NE.ONE ) THEN
+ CALL DSCAL( N-KI+1, SCALE, WORK( KI+N ), 1 )
+ CALL DSCAL( N-KI+1, SCALE, WORK( KI+N2 ), 1 )
+ END IF
+ WORK( J+N ) = X( 1, 1 )
+ WORK( J+N2 ) = X( 1, 2 )
+ VMAX = MAX( ABS( WORK( J+N ) ),
+ $ ABS( WORK( J+N2 ) ), VMAX )
+ VCRIT = BIGNUM / VMAX
+*
+ ELSE
+*
+* 2-by-2 diagonal block
+*
+* Scale if necessary to avoid overflow when forming
+* the right-hand side elements.
+*
+ BETA = MAX( WORK( J ), WORK( J+1 ) )
+ IF( BETA.GT.VCRIT ) THEN
+ REC = ONE / VMAX
+ CALL DSCAL( N-KI+1, REC, WORK( KI+N ), 1 )
+ CALL DSCAL( N-KI+1, REC, WORK( KI+N2 ), 1 )
+ VMAX = ONE
+ VCRIT = BIGNUM
+ END IF
+*
+ WORK( J+N ) = WORK( J+N ) -
+ $ DDOT( J-KI-2, T( KI+2, J ), 1,
+ $ WORK( KI+2+N ), 1 )
+*
+ WORK( J+N2 ) = WORK( J+N2 ) -
+ $ DDOT( J-KI-2, T( KI+2, J ), 1,
+ $ WORK( KI+2+N2 ), 1 )
+*
+ WORK( J+1+N ) = WORK( J+1+N ) -
+ $ DDOT( J-KI-2, T( KI+2, J+1 ), 1,
+ $ WORK( KI+2+N ), 1 )
+*
+ WORK( J+1+N2 ) = WORK( J+1+N2 ) -
+ $ DDOT( J-KI-2, T( KI+2, J+1 ), 1,
+ $ WORK( KI+2+N2 ), 1 )
+*
+* Solve 2-by-2 complex linear equation
+* ([T(j,j) T(j,j+1) ]'-(wr-i*wi)*I)*X = SCALE*B
+* ([T(j+1,j) T(j+1,j+1)] )
+*
+ CALL DLALN2( .TRUE., 2, 2, SMIN, ONE, T( J, J ),
+ $ LDT, ONE, ONE, WORK( J+N ), N, WR,
+ $ -WI, X, 2, SCALE, XNORM, IERR )
+*
+* Scale if necessary
+*
+ IF( SCALE.NE.ONE ) THEN
+ CALL DSCAL( N-KI+1, SCALE, WORK( KI+N ), 1 )
+ CALL DSCAL( N-KI+1, SCALE, WORK( KI+N2 ), 1 )
+ END IF
+ WORK( J+N ) = X( 1, 1 )
+ WORK( J+N2 ) = X( 1, 2 )
+ WORK( J+1+N ) = X( 2, 1 )
+ WORK( J+1+N2 ) = X( 2, 2 )
+ VMAX = MAX( ABS( X( 1, 1 ) ), ABS( X( 1, 2 ) ),
+ $ ABS( X( 2, 1 ) ), ABS( X( 2, 2 ) ), VMAX )
+ VCRIT = BIGNUM / VMAX
+*
+ END IF
+ 200 CONTINUE
+*
+* Copy the vector x or Q*x to VL and normalize.
+*
+ IF( .NOT.OVER ) THEN
+ CALL DCOPY( N-KI+1, WORK( KI+N ), 1, VL( KI, IS ), 1 )
+ CALL DCOPY( N-KI+1, WORK( KI+N2 ), 1, VL( KI, IS+1 ),
+ $ 1 )
+*
+ EMAX = ZERO
+ DO 220 K = KI, N
+ EMAX = MAX( EMAX, ABS( VL( K, IS ) )+
+ $ ABS( VL( K, IS+1 ) ) )
+ 220 CONTINUE
+ REMAX = ONE / EMAX
+ CALL DSCAL( N-KI+1, REMAX, VL( KI, IS ), 1 )
+ CALL DSCAL( N-KI+1, REMAX, VL( KI, IS+1 ), 1 )
+*
+ DO 230 K = 1, KI - 1
+ VL( K, IS ) = ZERO
+ VL( K, IS+1 ) = ZERO
+ 230 CONTINUE
+ ELSE
+ IF( KI.LT.N-1 ) THEN
+ CALL DGEMV( 'N', N, N-KI-1, ONE, VL( 1, KI+2 ),
+ $ LDVL, WORK( KI+2+N ), 1, WORK( KI+N ),
+ $ VL( 1, KI ), 1 )
+ CALL DGEMV( 'N', N, N-KI-1, ONE, VL( 1, KI+2 ),
+ $ LDVL, WORK( KI+2+N2 ), 1,
+ $ WORK( KI+1+N2 ), VL( 1, KI+1 ), 1 )
+ ELSE
+ CALL DSCAL( N, WORK( KI+N ), VL( 1, KI ), 1 )
+ CALL DSCAL( N, WORK( KI+1+N2 ), VL( 1, KI+1 ), 1 )
+ END IF
+*
+ EMAX = ZERO
+ DO 240 K = 1, N
+ EMAX = MAX( EMAX, ABS( VL( K, KI ) )+
+ $ ABS( VL( K, KI+1 ) ) )
+ 240 CONTINUE
+ REMAX = ONE / EMAX
+ CALL DSCAL( N, REMAX, VL( 1, KI ), 1 )
+ CALL DSCAL( N, REMAX, VL( 1, KI+1 ), 1 )
+*
+ END IF
+*
+ END IF
+*
+ IS = IS + 1
+ IF( IP.NE.0 )
+ $ IS = IS + 1
+ 250 CONTINUE
+ IF( IP.EQ.-1 )
+ $ IP = 0
+ IF( IP.EQ.1 )
+ $ IP = -1
+*
+ 260 CONTINUE
+*
+ END IF
+*
+ RETURN
+*
+* End of DTREVC
+*
+ END
+ SUBROUTINE DTREXC( COMPQ, N, T, LDT, Q, LDQ, IFST, ILST, WORK,
+ $ INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER COMPQ
+ INTEGER IFST, ILST, INFO, LDQ, LDT, N
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION Q( LDQ, * ), T( LDT, * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DTREXC reorders the real Schur factorization of a real matrix
+* A = Q*T*Q**T, so that the diagonal block of T with row index IFST is
+* moved to row ILST.
+*
+* The real Schur form T is reordered by an orthogonal similarity
+* transformation Z**T*T*Z, and optionally the matrix Q of Schur vectors
+* is updated by postmultiplying it with Z.
+*
+* T must be in Schur canonical form (as returned by DHSEQR), that is,
+* block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; each
+* 2-by-2 diagonal block has its diagonal elements equal and its
+* off-diagonal elements of opposite sign.
+*
+* Arguments
+* =========
+*
+* COMPQ (input) CHARACTER*1
+* = 'V': update the matrix Q of Schur vectors;
+* = 'N': do not update Q.
+*
+* N (input) INTEGER
+* The order of the matrix T. N >= 0.
+*
+* T (input/output) DOUBLE PRECISION array, dimension (LDT,N)
+* On entry, the upper quasi-triangular matrix T, in Schur
+* Schur canonical form.
+* On exit, the reordered upper quasi-triangular matrix, again
+* in Schur canonical form.
+*
+* LDT (input) INTEGER
+* The leading dimension of the array T. LDT >= max(1,N).
+*
+* Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N)
+* On entry, if COMPQ = 'V', the matrix Q of Schur vectors.
+* On exit, if COMPQ = 'V', Q has been postmultiplied by the
+* orthogonal transformation matrix Z which reorders T.
+* If COMPQ = 'N', Q is not referenced.
+*
+* LDQ (input) INTEGER
+* The leading dimension of the array Q. LDQ >= max(1,N).
+*
+* IFST (input/output) INTEGER
+* ILST (input/output) INTEGER
+* Specify the reordering of the diagonal blocks of T.
+* The block with row index IFST is moved to row ILST, by a
+* sequence of transpositions between adjacent blocks.
+* On exit, if IFST pointed on entry to the second row of a
+* 2-by-2 block, it is changed to point to the first row; ILST
+* always points to the first row of the block in its final
+* position (which may differ from its input value by +1 or -1).
+* 1 <= IFST <= N; 1 <= ILST <= N.
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (N)
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* = 1: two adjacent blocks were too close to swap (the problem
+* is very ill-conditioned); T may have been partially
+* reordered, and ILST points to the first row of the
+* current position of the block being moved.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO
+ PARAMETER ( ZERO = 0.0D+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL WANTQ
+ INTEGER HERE, NBF, NBL, NBNEXT
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL DLAEXC, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+* Decode and test the input arguments.
+*
+ INFO = 0
+ WANTQ = LSAME( COMPQ, 'V' )
+ IF( .NOT.WANTQ .AND. .NOT.LSAME( COMPQ, 'N' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( LDT.LT.MAX( 1, N ) ) THEN
+ INFO = -4
+ ELSE IF( LDQ.LT.1 .OR. ( WANTQ .AND. LDQ.LT.MAX( 1, N ) ) ) THEN
+ INFO = -6
+ ELSE IF( IFST.LT.1 .OR. IFST.GT.N ) THEN
+ INFO = -7
+ ELSE IF( ILST.LT.1 .OR. ILST.GT.N ) THEN
+ INFO = -8
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DTREXC', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.LE.1 )
+ $ RETURN
+*
+* Determine the first row of specified block
+* and find out it is 1 by 1 or 2 by 2.
+*
+ IF( IFST.GT.1 ) THEN
+ IF( T( IFST, IFST-1 ).NE.ZERO )
+ $ IFST = IFST - 1
+ END IF
+ NBF = 1
+ IF( IFST.LT.N ) THEN
+ IF( T( IFST+1, IFST ).NE.ZERO )
+ $ NBF = 2
+ END IF
+*
+* Determine the first row of the final block
+* and find out it is 1 by 1 or 2 by 2.
+*
+ IF( ILST.GT.1 ) THEN
+ IF( T( ILST, ILST-1 ).NE.ZERO )
+ $ ILST = ILST - 1
+ END IF
+ NBL = 1
+ IF( ILST.LT.N ) THEN
+ IF( T( ILST+1, ILST ).NE.ZERO )
+ $ NBL = 2
+ END IF
+*
+ IF( IFST.EQ.ILST )
+ $ RETURN
+*
+ IF( IFST.LT.ILST ) THEN
+*
+* Update ILST
+*
+ IF( NBF.EQ.2 .AND. NBL.EQ.1 )
+ $ ILST = ILST - 1
+ IF( NBF.EQ.1 .AND. NBL.EQ.2 )
+ $ ILST = ILST + 1
+*
+ HERE = IFST
+*
+ 10 CONTINUE
+*
+* Swap block with next one below
+*
+ IF( NBF.EQ.1 .OR. NBF.EQ.2 ) THEN
+*
+* Current block either 1 by 1 or 2 by 2
+*
+ NBNEXT = 1
+ IF( HERE+NBF+1.LE.N ) THEN
+ IF( T( HERE+NBF+1, HERE+NBF ).NE.ZERO )
+ $ NBNEXT = 2
+ END IF
+ CALL DLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE, NBF, NBNEXT,
+ $ WORK, INFO )
+ IF( INFO.NE.0 ) THEN
+ ILST = HERE
+ RETURN
+ END IF
+ HERE = HERE + NBNEXT
+*
+* Test if 2 by 2 block breaks into two 1 by 1 blocks
+*
+ IF( NBF.EQ.2 ) THEN
+ IF( T( HERE+1, HERE ).EQ.ZERO )
+ $ NBF = 3
+ END IF
+*
+ ELSE
+*
+* Current block consists of two 1 by 1 blocks each of which
+* must be swapped individually
+*
+ NBNEXT = 1
+ IF( HERE+3.LE.N ) THEN
+ IF( T( HERE+3, HERE+2 ).NE.ZERO )
+ $ NBNEXT = 2
+ END IF
+ CALL DLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE+1, 1, NBNEXT,
+ $ WORK, INFO )
+ IF( INFO.NE.0 ) THEN
+ ILST = HERE
+ RETURN
+ END IF
+ IF( NBNEXT.EQ.1 ) THEN
+*
+* Swap two 1 by 1 blocks, no problems possible
+*
+ CALL DLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE, 1, NBNEXT,
+ $ WORK, INFO )
+ HERE = HERE + 1
+ ELSE
+*
+* Recompute NBNEXT in case 2 by 2 split
+*
+ IF( T( HERE+2, HERE+1 ).EQ.ZERO )
+ $ NBNEXT = 1
+ IF( NBNEXT.EQ.2 ) THEN
+*
+* 2 by 2 Block did not split
+*
+ CALL DLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE, 1,
+ $ NBNEXT, WORK, INFO )
+ IF( INFO.NE.0 ) THEN
+ ILST = HERE
+ RETURN
+ END IF
+ HERE = HERE + 2
+ ELSE
+*
+* 2 by 2 Block did split
+*
+ CALL DLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE, 1, 1,
+ $ WORK, INFO )
+ CALL DLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE+1, 1, 1,
+ $ WORK, INFO )
+ HERE = HERE + 2
+ END IF
+ END IF
+ END IF
+ IF( HERE.LT.ILST )
+ $ GO TO 10
+*
+ ELSE
+*
+ HERE = IFST
+ 20 CONTINUE
+*
+* Swap block with next one above
+*
+ IF( NBF.EQ.1 .OR. NBF.EQ.2 ) THEN
+*
+* Current block either 1 by 1 or 2 by 2
+*
+ NBNEXT = 1
+ IF( HERE.GE.3 ) THEN
+ IF( T( HERE-1, HERE-2 ).NE.ZERO )
+ $ NBNEXT = 2
+ END IF
+ CALL DLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE-NBNEXT, NBNEXT,
+ $ NBF, WORK, INFO )
+ IF( INFO.NE.0 ) THEN
+ ILST = HERE
+ RETURN
+ END IF
+ HERE = HERE - NBNEXT
+*
+* Test if 2 by 2 block breaks into two 1 by 1 blocks
+*
+ IF( NBF.EQ.2 ) THEN
+ IF( T( HERE+1, HERE ).EQ.ZERO )
+ $ NBF = 3
+ END IF
+*
+ ELSE
+*
+* Current block consists of two 1 by 1 blocks each of which
+* must be swapped individually
+*
+ NBNEXT = 1
+ IF( HERE.GE.3 ) THEN
+ IF( T( HERE-1, HERE-2 ).NE.ZERO )
+ $ NBNEXT = 2
+ END IF
+ CALL DLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE-NBNEXT, NBNEXT,
+ $ 1, WORK, INFO )
+ IF( INFO.NE.0 ) THEN
+ ILST = HERE
+ RETURN
+ END IF
+ IF( NBNEXT.EQ.1 ) THEN
+*
+* Swap two 1 by 1 blocks, no problems possible
+*
+ CALL DLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE, NBNEXT, 1,
+ $ WORK, INFO )
+ HERE = HERE - 1
+ ELSE
+*
+* Recompute NBNEXT in case 2 by 2 split
+*
+ IF( T( HERE, HERE-1 ).EQ.ZERO )
+ $ NBNEXT = 1
+ IF( NBNEXT.EQ.2 ) THEN
+*
+* 2 by 2 Block did not split
+*
+ CALL DLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE-1, 2, 1,
+ $ WORK, INFO )
+ IF( INFO.NE.0 ) THEN
+ ILST = HERE
+ RETURN
+ END IF
+ HERE = HERE - 2
+ ELSE
+*
+* 2 by 2 Block did split
+*
+ CALL DLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE, 1, 1,
+ $ WORK, INFO )
+ CALL DLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE-1, 1, 1,
+ $ WORK, INFO )
+ HERE = HERE - 2
+ END IF
+ END IF
+ END IF
+ IF( HERE.GT.ILST )
+ $ GO TO 20
+ END IF
+ ILST = HERE
+*
+ RETURN
+*
+* End of DTREXC
+*
+ END
+ SUBROUTINE DTRRFS( UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB, X,
+ $ LDX, FERR, BERR, WORK, IWORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH.
+*
+* .. Scalar Arguments ..
+ CHARACTER DIAG, TRANS, UPLO
+ INTEGER INFO, LDA, LDB, LDX, N, NRHS
+* ..
+* .. Array Arguments ..
+ INTEGER IWORK( * )
+ DOUBLE PRECISION A( LDA, * ), B( LDB, * ), BERR( * ), FERR( * ),
+ $ WORK( * ), X( LDX, * )
+* ..
+*
+* Purpose
+* =======
+*
+* DTRRFS provides error bounds and backward error estimates for the
+* solution to a system of linear equations with a triangular
+* coefficient matrix.
+*
+* The solution matrix X must be computed by DTRTRS or some other
+* means before entering this routine. DTRRFS does not do iterative
+* refinement because doing so cannot improve the backward error.
+*
+* Arguments
+* =========
+*
+* UPLO (input) CHARACTER*1
+* = 'U': A is upper triangular;
+* = 'L': A is lower triangular.
+*
+* TRANS (input) CHARACTER*1
+* Specifies the form of the system of equations:
+* = 'N': A * X = B (No transpose)
+* = 'T': A**T * X = B (Transpose)
+* = 'C': A**H * X = B (Conjugate transpose = Transpose)
+*
+* DIAG (input) CHARACTER*1
+* = 'N': A is non-unit triangular;
+* = 'U': A is unit triangular.
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* NRHS (input) INTEGER
+* The number of right hand sides, i.e., the number of columns
+* of the matrices B and X. NRHS >= 0.
+*
+* A (input) DOUBLE PRECISION array, dimension (LDA,N)
+* The triangular matrix A. If UPLO = 'U', the leading N-by-N
+* upper triangular part of the array A contains the upper
+* triangular matrix, and the strictly lower triangular part of
+* A is not referenced. If UPLO = 'L', the leading N-by-N lower
+* triangular part of the array A contains the lower triangular
+* matrix, and the strictly upper triangular part of A is not
+* referenced. If DIAG = 'U', the diagonal elements of A are
+* also not referenced and are assumed to be 1.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,N).
+*
+* B (input) DOUBLE PRECISION array, dimension (LDB,NRHS)
+* The right hand side matrix B.
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. LDB >= max(1,N).
+*
+* X (input) DOUBLE PRECISION array, dimension (LDX,NRHS)
+* The solution matrix X.
+*
+* LDX (input) INTEGER
+* The leading dimension of the array X. LDX >= max(1,N).
+*
+* FERR (output) DOUBLE PRECISION array, dimension (NRHS)
+* The estimated forward error bound for each solution vector
+* X(j) (the j-th column of the solution matrix X).
+* If XTRUE is the true solution corresponding to X(j), FERR(j)
+* is an estimated upper bound for the magnitude of the largest
+* element in (X(j) - XTRUE) divided by the magnitude of the
+* largest element in X(j). The estimate is as reliable as
+* the estimate for RCOND, and is almost always a slight
+* overestimate of the true error.
+*
+* BERR (output) DOUBLE PRECISION array, dimension (NRHS)
+* The componentwise relative backward error of each solution
+* vector X(j) (i.e., the smallest relative change in
+* any element of A or B that makes X(j) an exact solution).
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (3*N)
+*
+* IWORK (workspace) INTEGER array, dimension (N)
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO
+ PARAMETER ( ZERO = 0.0D+0 )
+ DOUBLE PRECISION ONE
+ PARAMETER ( ONE = 1.0D+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL NOTRAN, NOUNIT, UPPER
+ CHARACTER TRANST
+ INTEGER I, J, K, KASE, NZ
+ DOUBLE PRECISION EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK
+* ..
+* .. Local Arrays ..
+ INTEGER ISAVE( 3 )
+* ..
+* .. External Subroutines ..
+ EXTERNAL DAXPY, DCOPY, DLACN2, DTRMV, DTRSV, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ DOUBLE PRECISION DLAMCH
+ EXTERNAL LSAME, DLAMCH
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ NOTRAN = LSAME( TRANS, 'N' )
+ NOUNIT = LSAME( DIAG, 'N' )
+*
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT.
+ $ LSAME( TRANS, 'C' ) ) THEN
+ INFO = -2
+ ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
+ INFO = -3
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( NRHS.LT.0 ) THEN
+ INFO = -5
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -7
+ ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -9
+ ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
+ INFO = -11
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DTRRFS', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN
+ DO 10 J = 1, NRHS
+ FERR( J ) = ZERO
+ BERR( J ) = ZERO
+ 10 CONTINUE
+ RETURN
+ END IF
+*
+ IF( NOTRAN ) THEN
+ TRANST = 'T'
+ ELSE
+ TRANST = 'N'
+ END IF
+*
+* NZ = maximum number of nonzero elements in each row of A, plus 1
+*
+ NZ = N + 1
+ EPS = DLAMCH( 'Epsilon' )
+ SAFMIN = DLAMCH( 'Safe minimum' )
+ SAFE1 = NZ*SAFMIN
+ SAFE2 = SAFE1 / EPS
+*
+* Do for each right hand side
+*
+ DO 250 J = 1, NRHS
+*
+* Compute residual R = B - op(A) * X,
+* where op(A) = A or A', depending on TRANS.
+*
+ CALL DCOPY( N, X( 1, J ), 1, WORK( N+1 ), 1 )
+ CALL DTRMV( UPLO, TRANS, DIAG, N, A, LDA, WORK( N+1 ), 1 )
+ CALL DAXPY( N, -ONE, B( 1, J ), 1, WORK( N+1 ), 1 )
+*
+* Compute componentwise relative backward error from formula
+*
+* max(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) )
+*
+* where abs(Z) is the componentwise absolute value of the matrix
+* or vector Z. If the i-th component of the denominator is less
+* than SAFE2, then SAFE1 is added to the i-th components of the
+* numerator and denominator before dividing.
+*
+ DO 20 I = 1, N
+ WORK( I ) = ABS( B( I, J ) )
+ 20 CONTINUE
+*
+ IF( NOTRAN ) THEN
+*
+* Compute abs(A)*abs(X) + abs(B).
+*
+ IF( UPPER ) THEN
+ IF( NOUNIT ) THEN
+ DO 40 K = 1, N
+ XK = ABS( X( K, J ) )
+ DO 30 I = 1, K
+ WORK( I ) = WORK( I ) + ABS( A( I, K ) )*XK
+ 30 CONTINUE
+ 40 CONTINUE
+ ELSE
+ DO 60 K = 1, N
+ XK = ABS( X( K, J ) )
+ DO 50 I = 1, K - 1
+ WORK( I ) = WORK( I ) + ABS( A( I, K ) )*XK
+ 50 CONTINUE
+ WORK( K ) = WORK( K ) + XK
+ 60 CONTINUE
+ END IF
+ ELSE
+ IF( NOUNIT ) THEN
+ DO 80 K = 1, N
+ XK = ABS( X( K, J ) )
+ DO 70 I = K, N
+ WORK( I ) = WORK( I ) + ABS( A( I, K ) )*XK
+ 70 CONTINUE
+ 80 CONTINUE
+ ELSE
+ DO 100 K = 1, N
+ XK = ABS( X( K, J ) )
+ DO 90 I = K + 1, N
+ WORK( I ) = WORK( I ) + ABS( A( I, K ) )*XK
+ 90 CONTINUE
+ WORK( K ) = WORK( K ) + XK
+ 100 CONTINUE
+ END IF
+ END IF
+ ELSE
+*
+* Compute abs(A')*abs(X) + abs(B).
+*
+ IF( UPPER ) THEN
+ IF( NOUNIT ) THEN
+ DO 120 K = 1, N
+ S = ZERO
+ DO 110 I = 1, K
+ S = S + ABS( A( I, K ) )*ABS( X( I, J ) )
+ 110 CONTINUE
+ WORK( K ) = WORK( K ) + S
+ 120 CONTINUE
+ ELSE
+ DO 140 K = 1, N
+ S = ABS( X( K, J ) )
+ DO 130 I = 1, K - 1
+ S = S + ABS( A( I, K ) )*ABS( X( I, J ) )
+ 130 CONTINUE
+ WORK( K ) = WORK( K ) + S
+ 140 CONTINUE
+ END IF
+ ELSE
+ IF( NOUNIT ) THEN
+ DO 160 K = 1, N
+ S = ZERO
+ DO 150 I = K, N
+ S = S + ABS( A( I, K ) )*ABS( X( I, J ) )
+ 150 CONTINUE
+ WORK( K ) = WORK( K ) + S
+ 160 CONTINUE
+ ELSE
+ DO 180 K = 1, N
+ S = ABS( X( K, J ) )
+ DO 170 I = K + 1, N
+ S = S + ABS( A( I, K ) )*ABS( X( I, J ) )
+ 170 CONTINUE
+ WORK( K ) = WORK( K ) + S
+ 180 CONTINUE
+ END IF
+ END IF
+ END IF
+ S = ZERO
+ DO 190 I = 1, N
+ IF( WORK( I ).GT.SAFE2 ) THEN
+ S = MAX( S, ABS( WORK( N+I ) ) / WORK( I ) )
+ ELSE
+ S = MAX( S, ( ABS( WORK( N+I ) )+SAFE1 ) /
+ $ ( WORK( I )+SAFE1 ) )
+ END IF
+ 190 CONTINUE
+ BERR( J ) = S
+*
+* Bound error from formula
+*
+* norm(X - XTRUE) / norm(X) .le. FERR =
+* norm( abs(inv(op(A)))*
+* ( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X)
+*
+* where
+* norm(Z) is the magnitude of the largest component of Z
+* inv(op(A)) is the inverse of op(A)
+* abs(Z) is the componentwise absolute value of the matrix or
+* vector Z
+* NZ is the maximum number of nonzeros in any row of A, plus 1
+* EPS is machine epsilon
+*
+* The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B))
+* is incremented by SAFE1 if the i-th component of
+* abs(op(A))*abs(X) + abs(B) is less than SAFE2.
+*
+* Use DLACN2 to estimate the infinity-norm of the matrix
+* inv(op(A)) * diag(W),
+* where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) )))
+*
+ DO 200 I = 1, N
+ IF( WORK( I ).GT.SAFE2 ) THEN
+ WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I )
+ ELSE
+ WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I ) + SAFE1
+ END IF
+ 200 CONTINUE
+*
+ KASE = 0
+ 210 CONTINUE
+ CALL DLACN2( N, WORK( 2*N+1 ), WORK( N+1 ), IWORK, FERR( J ),
+ $ KASE, ISAVE )
+ IF( KASE.NE.0 ) THEN
+ IF( KASE.EQ.1 ) THEN
+*
+* Multiply by diag(W)*inv(op(A)').
+*
+ CALL DTRSV( UPLO, TRANST, DIAG, N, A, LDA, WORK( N+1 ),
+ $ 1 )
+ DO 220 I = 1, N
+ WORK( N+I ) = WORK( I )*WORK( N+I )
+ 220 CONTINUE
+ ELSE
+*
+* Multiply by inv(op(A))*diag(W).
+*
+ DO 230 I = 1, N
+ WORK( N+I ) = WORK( I )*WORK( N+I )
+ 230 CONTINUE
+ CALL DTRSV( UPLO, TRANS, DIAG, N, A, LDA, WORK( N+1 ),
+ $ 1 )
+ END IF
+ GO TO 210
+ END IF
+*
+* Normalize error.
+*
+ LSTRES = ZERO
+ DO 240 I = 1, N
+ LSTRES = MAX( LSTRES, ABS( X( I, J ) ) )
+ 240 CONTINUE
+ IF( LSTRES.NE.ZERO )
+ $ FERR( J ) = FERR( J ) / LSTRES
+*
+ 250 CONTINUE
+*
+ RETURN
+*
+* End of DTRRFS
+*
+ END
+ SUBROUTINE DTRSEN( JOB, COMPQ, SELECT, N, T, LDT, Q, LDQ, WR, WI,
+ $ M, S, SEP, WORK, LWORK, IWORK, LIWORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER COMPQ, JOB
+ INTEGER INFO, LDQ, LDT, LIWORK, LWORK, M, N
+ DOUBLE PRECISION S, SEP
+* ..
+* .. Array Arguments ..
+ LOGICAL SELECT( * )
+ INTEGER IWORK( * )
+ DOUBLE PRECISION Q( LDQ, * ), T( LDT, * ), WI( * ), WORK( * ),
+ $ WR( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DTRSEN reorders the real Schur factorization of a real matrix
+* A = Q*T*Q**T, so that a selected cluster of eigenvalues appears in
+* the leading diagonal blocks of the upper quasi-triangular matrix T,
+* and the leading columns of Q form an orthonormal basis of the
+* corresponding right invariant subspace.
+*
+* Optionally the routine computes the reciprocal condition numbers of
+* the cluster of eigenvalues and/or the invariant subspace.
+*
+* T must be in Schur canonical form (as returned by DHSEQR), that is,
+* block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; each
+* 2-by-2 diagonal block has its diagonal elemnts equal and its
+* off-diagonal elements of opposite sign.
+*
+* Arguments
+* =========
+*
+* JOB (input) CHARACTER*1
+* Specifies whether condition numbers are required for the
+* cluster of eigenvalues (S) or the invariant subspace (SEP):
+* = 'N': none;
+* = 'E': for eigenvalues only (S);
+* = 'V': for invariant subspace only (SEP);
+* = 'B': for both eigenvalues and invariant subspace (S and
+* SEP).
+*
+* COMPQ (input) CHARACTER*1
+* = 'V': update the matrix Q of Schur vectors;
+* = 'N': do not update Q.
+*
+* SELECT (input) LOGICAL array, dimension (N)
+* SELECT specifies the eigenvalues in the selected cluster. To
+* select a real eigenvalue w(j), SELECT(j) must be set to
+* .TRUE.. To select a complex conjugate pair of eigenvalues
+* w(j) and w(j+1), corresponding to a 2-by-2 diagonal block,
+* either SELECT(j) or SELECT(j+1) or both must be set to
+* .TRUE.; a complex conjugate pair of eigenvalues must be
+* either both included in the cluster or both excluded.
+*
+* N (input) INTEGER
+* The order of the matrix T. N >= 0.
+*
+* T (input/output) DOUBLE PRECISION array, dimension (LDT,N)
+* On entry, the upper quasi-triangular matrix T, in Schur
+* canonical form.
+* On exit, T is overwritten by the reordered matrix T, again in
+* Schur canonical form, with the selected eigenvalues in the
+* leading diagonal blocks.
+*
+* LDT (input) INTEGER
+* The leading dimension of the array T. LDT >= max(1,N).
+*
+* Q (input/output) DOUBLE PRECISION array, dimension (LDQ,N)
+* On entry, if COMPQ = 'V', the matrix Q of Schur vectors.
+* On exit, if COMPQ = 'V', Q has been postmultiplied by the
+* orthogonal transformation matrix which reorders T; the
+* leading M columns of Q form an orthonormal basis for the
+* specified invariant subspace.
+* If COMPQ = 'N', Q is not referenced.
+*
+* LDQ (input) INTEGER
+* The leading dimension of the array Q.
+* LDQ >= 1; and if COMPQ = 'V', LDQ >= N.
+*
+* WR (output) DOUBLE PRECISION array, dimension (N)
+* WI (output) DOUBLE PRECISION array, dimension (N)
+* The real and imaginary parts, respectively, of the reordered
+* eigenvalues of T. The eigenvalues are stored in the same
+* order as on the diagonal of T, with WR(i) = T(i,i) and, if
+* T(i:i+1,i:i+1) is a 2-by-2 diagonal block, WI(i) > 0 and
+* WI(i+1) = -WI(i). Note that if a complex eigenvalue is
+* sufficiently ill-conditioned, then its value may differ
+* significantly from its value before reordering.
+*
+* M (output) INTEGER
+* The dimension of the specified invariant subspace.
+* 0 < = M <= N.
+*
+* S (output) DOUBLE PRECISION
+* If JOB = 'E' or 'B', S is a lower bound on the reciprocal
+* condition number for the selected cluster of eigenvalues.
+* S cannot underestimate the true reciprocal condition number
+* by more than a factor of sqrt(N). If M = 0 or N, S = 1.
+* If JOB = 'N' or 'V', S is not referenced.
+*
+* SEP (output) DOUBLE PRECISION
+* If JOB = 'V' or 'B', SEP is the estimated reciprocal
+* condition number of the specified invariant subspace. If
+* M = 0 or N, SEP = norm(T).
+* If JOB = 'N' or 'E', SEP is not referenced.
+*
+* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
+* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+* LWORK (input) INTEGER
+* The dimension of the array WORK.
+* If JOB = 'N', LWORK >= max(1,N);
+* if JOB = 'E', LWORK >= max(1,M*(N-M));
+* if JOB = 'V' or 'B', LWORK >= max(1,2*M*(N-M)).
+*
+* If LWORK = -1, then a workspace query is assumed; the routine
+* only calculates the optimal size of the WORK array, returns
+* this value as the first entry of the WORK array, and no error
+* message related to LWORK is issued by XERBLA.
+*
+* IWORK (workspace) INTEGER array, dimension (MAX(1,LIWORK))
+* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
+*
+* LIWORK (input) INTEGER
+* The dimension of the array IWORK.
+* If JOB = 'N' or 'E', LIWORK >= 1;
+* if JOB = 'V' or 'B', LIWORK >= max(1,M*(N-M)).
+*
+* If LIWORK = -1, then a workspace query is assumed; the
+* routine only calculates the optimal size of the IWORK array,
+* returns this value as the first entry of the IWORK array, and
+* no error message related to LIWORK is issued by XERBLA.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* = 1: reordering of T failed because some eigenvalues are too
+* close to separate (the problem is very ill-conditioned);
+* T may have been partially reordered, and WR and WI
+* contain the eigenvalues in the same order as in T; S and
+* SEP (if requested) are set to zero.
+*
+* Further Details
+* ===============
+*
+* DTRSEN first collects the selected eigenvalues by computing an
+* orthogonal transformation Z to move them to the top left corner of T.
+* In other words, the selected eigenvalues are the eigenvalues of T11
+* in:
+*
+* Z'*T*Z = ( T11 T12 ) n1
+* ( 0 T22 ) n2
+* n1 n2
+*
+* where N = n1+n2 and Z' means the transpose of Z. The first n1 columns
+* of Z span the specified invariant subspace of T.
+*
+* If T has been obtained from the real Schur factorization of a matrix
+* A = Q*T*Q', then the reordered real Schur factorization of A is given
+* by A = (Q*Z)*(Z'*T*Z)*(Q*Z)', and the first n1 columns of Q*Z span
+* the corresponding invariant subspace of A.
+*
+* The reciprocal condition number of the average of the eigenvalues of
+* T11 may be returned in S. S lies between 0 (very badly conditioned)
+* and 1 (very well conditioned). It is computed as follows. First we
+* compute R so that
+*
+* P = ( I R ) n1
+* ( 0 0 ) n2
+* n1 n2
+*
+* is the projector on the invariant subspace associated with T11.
+* R is the solution of the Sylvester equation:
+*
+* T11*R - R*T22 = T12.
+*
+* Let F-norm(M) denote the Frobenius-norm of M and 2-norm(M) denote
+* the two-norm of M. Then S is computed as the lower bound
+*
+* (1 + F-norm(R)**2)**(-1/2)
+*
+* on the reciprocal of 2-norm(P), the true reciprocal condition number.
+* S cannot underestimate 1 / 2-norm(P) by more than a factor of
+* sqrt(N).
+*
+* An approximate error bound for the computed average of the
+* eigenvalues of T11 is
+*
+* EPS * norm(T) / S
+*
+* where EPS is the machine precision.
+*
+* The reciprocal condition number of the right invariant subspace
+* spanned by the first n1 columns of Z (or of Q*Z) is returned in SEP.
+* SEP is defined as the separation of T11 and T22:
+*
+* sep( T11, T22 ) = sigma-min( C )
+*
+* where sigma-min(C) is the smallest singular value of the
+* n1*n2-by-n1*n2 matrix
+*
+* C = kprod( I(n2), T11 ) - kprod( transpose(T22), I(n1) )
+*
+* I(m) is an m by m identity matrix, and kprod denotes the Kronecker
+* product. We estimate sigma-min(C) by the reciprocal of an estimate of
+* the 1-norm of inverse(C). The true reciprocal 1-norm of inverse(C)
+* cannot differ from sigma-min(C) by more than a factor of sqrt(n1*n2).
+*
+* When SEP is small, small changes in T can cause large changes in
+* the invariant subspace. An approximate bound on the maximum angular
+* error in the computed right invariant subspace is
+*
+* EPS * norm(T) / SEP
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL LQUERY, PAIR, SWAP, WANTBH, WANTQ, WANTS,
+ $ WANTSP
+ INTEGER IERR, K, KASE, KK, KS, LIWMIN, LWMIN, N1, N2,
+ $ NN
+ DOUBLE PRECISION EST, RNORM, SCALE
+* ..
+* .. Local Arrays ..
+ INTEGER ISAVE( 3 )
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ DOUBLE PRECISION DLANGE
+ EXTERNAL LSAME, DLANGE
+* ..
+* .. External Subroutines ..
+ EXTERNAL DLACN2, DLACPY, DTREXC, DTRSYL, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, SQRT
+* ..
+* .. Executable Statements ..
+*
+* Decode and test the input parameters
+*
+ WANTBH = LSAME( JOB, 'B' )
+ WANTS = LSAME( JOB, 'E' ) .OR. WANTBH
+ WANTSP = LSAME( JOB, 'V' ) .OR. WANTBH
+ WANTQ = LSAME( COMPQ, 'V' )
+*
+ INFO = 0
+ LQUERY = ( LWORK.EQ.-1 )
+ IF( .NOT.LSAME( JOB, 'N' ) .AND. .NOT.WANTS .AND. .NOT.WANTSP )
+ $ THEN
+ INFO = -1
+ ELSE IF( .NOT.LSAME( COMPQ, 'N' ) .AND. .NOT.WANTQ ) THEN
+ INFO = -2
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( LDT.LT.MAX( 1, N ) ) THEN
+ INFO = -6
+ ELSE IF( LDQ.LT.1 .OR. ( WANTQ .AND. LDQ.LT.N ) ) THEN
+ INFO = -8
+ ELSE
+*
+* Set M to the dimension of the specified invariant subspace,
+* and test LWORK and LIWORK.
+*
+ M = 0
+ PAIR = .FALSE.
+ DO 10 K = 1, N
+ IF( PAIR ) THEN
+ PAIR = .FALSE.
+ ELSE
+ IF( K.LT.N ) THEN
+ IF( T( K+1, K ).EQ.ZERO ) THEN
+ IF( SELECT( K ) )
+ $ M = M + 1
+ ELSE
+ PAIR = .TRUE.
+ IF( SELECT( K ) .OR. SELECT( K+1 ) )
+ $ M = M + 2
+ END IF
+ ELSE
+ IF( SELECT( N ) )
+ $ M = M + 1
+ END IF
+ END IF
+ 10 CONTINUE
+*
+ N1 = M
+ N2 = N - M
+ NN = N1*N2
+*
+ IF( WANTSP ) THEN
+ LWMIN = MAX( 1, 2*NN )
+ LIWMIN = MAX( 1, NN )
+ ELSE IF( LSAME( JOB, 'N' ) ) THEN
+ LWMIN = MAX( 1, N )
+ LIWMIN = 1
+ ELSE IF( LSAME( JOB, 'E' ) ) THEN
+ LWMIN = MAX( 1, NN )
+ LIWMIN = 1
+ END IF
+*
+ IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
+ INFO = -15
+ ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN
+ INFO = -17
+ END IF
+ END IF
+*
+ IF( INFO.EQ.0 ) THEN
+ WORK( 1 ) = LWMIN
+ IWORK( 1 ) = LIWMIN
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DTRSEN', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible.
+*
+ IF( M.EQ.N .OR. M.EQ.0 ) THEN
+ IF( WANTS )
+ $ S = ONE
+ IF( WANTSP )
+ $ SEP = DLANGE( '1', N, N, T, LDT, WORK )
+ GO TO 40
+ END IF
+*
+* Collect the selected blocks at the top-left corner of T.
+*
+ KS = 0
+ PAIR = .FALSE.
+ DO 20 K = 1, N
+ IF( PAIR ) THEN
+ PAIR = .FALSE.
+ ELSE
+ SWAP = SELECT( K )
+ IF( K.LT.N ) THEN
+ IF( T( K+1, K ).NE.ZERO ) THEN
+ PAIR = .TRUE.
+ SWAP = SWAP .OR. SELECT( K+1 )
+ END IF
+ END IF
+ IF( SWAP ) THEN
+ KS = KS + 1
+*
+* Swap the K-th block to position KS.
+*
+ IERR = 0
+ KK = K
+ IF( K.NE.KS )
+ $ CALL DTREXC( COMPQ, N, T, LDT, Q, LDQ, KK, KS, WORK,
+ $ IERR )
+ IF( IERR.EQ.1 .OR. IERR.EQ.2 ) THEN
+*
+* Blocks too close to swap: exit.
+*
+ INFO = 1
+ IF( WANTS )
+ $ S = ZERO
+ IF( WANTSP )
+ $ SEP = ZERO
+ GO TO 40
+ END IF
+ IF( PAIR )
+ $ KS = KS + 1
+ END IF
+ END IF
+ 20 CONTINUE
+*
+ IF( WANTS ) THEN
+*
+* Solve Sylvester equation for R:
+*
+* T11*R - R*T22 = scale*T12
+*
+ CALL DLACPY( 'F', N1, N2, T( 1, N1+1 ), LDT, WORK, N1 )
+ CALL DTRSYL( 'N', 'N', -1, N1, N2, T, LDT, T( N1+1, N1+1 ),
+ $ LDT, WORK, N1, SCALE, IERR )
+*
+* Estimate the reciprocal of the condition number of the cluster
+* of eigenvalues.
+*
+ RNORM = DLANGE( 'F', N1, N2, WORK, N1, WORK )
+ IF( RNORM.EQ.ZERO ) THEN
+ S = ONE
+ ELSE
+ S = SCALE / ( SQRT( SCALE*SCALE / RNORM+RNORM )*
+ $ SQRT( RNORM ) )
+ END IF
+ END IF
+*
+ IF( WANTSP ) THEN
+*
+* Estimate sep(T11,T22).
+*
+ EST = ZERO
+ KASE = 0
+ 30 CONTINUE
+ CALL DLACN2( NN, WORK( NN+1 ), WORK, IWORK, EST, KASE, ISAVE )
+ IF( KASE.NE.0 ) THEN
+ IF( KASE.EQ.1 ) THEN
+*
+* Solve T11*R - R*T22 = scale*X.
+*
+ CALL DTRSYL( 'N', 'N', -1, N1, N2, T, LDT,
+ $ T( N1+1, N1+1 ), LDT, WORK, N1, SCALE,
+ $ IERR )
+ ELSE
+*
+* Solve T11'*R - R*T22' = scale*X.
+*
+ CALL DTRSYL( 'T', 'T', -1, N1, N2, T, LDT,
+ $ T( N1+1, N1+1 ), LDT, WORK, N1, SCALE,
+ $ IERR )
+ END IF
+ GO TO 30
+ END IF
+*
+ SEP = SCALE / EST
+ END IF
+*
+ 40 CONTINUE
+*
+* Store the output eigenvalues in WR and WI.
+*
+ DO 50 K = 1, N
+ WR( K ) = T( K, K )
+ WI( K ) = ZERO
+ 50 CONTINUE
+ DO 60 K = 1, N - 1
+ IF( T( K+1, K ).NE.ZERO ) THEN
+ WI( K ) = SQRT( ABS( T( K, K+1 ) ) )*
+ $ SQRT( ABS( T( K+1, K ) ) )
+ WI( K+1 ) = -WI( K )
+ END IF
+ 60 CONTINUE
+*
+ WORK( 1 ) = LWMIN
+ IWORK( 1 ) = LIWMIN
+*
+ RETURN
+*
+* End of DTRSEN
+*
+ END
+ SUBROUTINE DTRSNA( JOB, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR,
+ $ LDVR, S, SEP, MM, M, WORK, LDWORK, IWORK,
+ $ INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* Modified to call DLACN2 in place of DLACON, 5 Feb 03, SJH.
+*
+* .. Scalar Arguments ..
+ CHARACTER HOWMNY, JOB
+ INTEGER INFO, LDT, LDVL, LDVR, LDWORK, M, MM, N
+* ..
+* .. Array Arguments ..
+ LOGICAL SELECT( * )
+ INTEGER IWORK( * )
+ DOUBLE PRECISION S( * ), SEP( * ), T( LDT, * ), VL( LDVL, * ),
+ $ VR( LDVR, * ), WORK( LDWORK, * )
+* ..
+*
+* Purpose
+* =======
+*
+* DTRSNA estimates reciprocal condition numbers for specified
+* eigenvalues and/or right eigenvectors of a real upper
+* quasi-triangular matrix T (or of any matrix Q*T*Q**T with Q
+* orthogonal).
+*
+* T must be in Schur canonical form (as returned by DHSEQR), that is,
+* block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; each
+* 2-by-2 diagonal block has its diagonal elements equal and its
+* off-diagonal elements of opposite sign.
+*
+* Arguments
+* =========
+*
+* JOB (input) CHARACTER*1
+* Specifies whether condition numbers are required for
+* eigenvalues (S) or eigenvectors (SEP):
+* = 'E': for eigenvalues only (S);
+* = 'V': for eigenvectors only (SEP);
+* = 'B': for both eigenvalues and eigenvectors (S and SEP).
+*
+* HOWMNY (input) CHARACTER*1
+* = 'A': compute condition numbers for all eigenpairs;
+* = 'S': compute condition numbers for selected eigenpairs
+* specified by the array SELECT.
+*
+* SELECT (input) LOGICAL array, dimension (N)
+* If HOWMNY = 'S', SELECT specifies the eigenpairs for which
+* condition numbers are required. To select condition numbers
+* for the eigenpair corresponding to a real eigenvalue w(j),
+* SELECT(j) must be set to .TRUE.. To select condition numbers
+* corresponding to a complex conjugate pair of eigenvalues w(j)
+* and w(j+1), either SELECT(j) or SELECT(j+1) or both, must be
+* set to .TRUE..
+* If HOWMNY = 'A', SELECT is not referenced.
+*
+* N (input) INTEGER
+* The order of the matrix T. N >= 0.
+*
+* T (input) DOUBLE PRECISION array, dimension (LDT,N)
+* The upper quasi-triangular matrix T, in Schur canonical form.
+*
+* LDT (input) INTEGER
+* The leading dimension of the array T. LDT >= max(1,N).
+*
+* VL (input) DOUBLE PRECISION array, dimension (LDVL,M)
+* If JOB = 'E' or 'B', VL must contain left eigenvectors of T
+* (or of any Q*T*Q**T with Q orthogonal), corresponding to the
+* eigenpairs specified by HOWMNY and SELECT. The eigenvectors
+* must be stored in consecutive columns of VL, as returned by
+* DHSEIN or DTREVC.
+* If JOB = 'V', VL is not referenced.
+*
+* LDVL (input) INTEGER
+* The leading dimension of the array VL.
+* LDVL >= 1; and if JOB = 'E' or 'B', LDVL >= N.
+*
+* VR (input) DOUBLE PRECISION array, dimension (LDVR,M)
+* If JOB = 'E' or 'B', VR must contain right eigenvectors of T
+* (or of any Q*T*Q**T with Q orthogonal), corresponding to the
+* eigenpairs specified by HOWMNY and SELECT. The eigenvectors
+* must be stored in consecutive columns of VR, as returned by
+* DHSEIN or DTREVC.
+* If JOB = 'V', VR is not referenced.
+*
+* LDVR (input) INTEGER
+* The leading dimension of the array VR.
+* LDVR >= 1; and if JOB = 'E' or 'B', LDVR >= N.
+*
+* S (output) DOUBLE PRECISION array, dimension (MM)
+* If JOB = 'E' or 'B', the reciprocal condition numbers of the
+* selected eigenvalues, stored in consecutive elements of the
+* array. For a complex conjugate pair of eigenvalues two
+* consecutive elements of S are set to the same value. Thus
+* S(j), SEP(j), and the j-th columns of VL and VR all
+* correspond to the same eigenpair (but not in general the
+* j-th eigenpair, unless all eigenpairs are selected).
+* If JOB = 'V', S is not referenced.
+*
+* SEP (output) DOUBLE PRECISION array, dimension (MM)
+* If JOB = 'V' or 'B', the estimated reciprocal condition
+* numbers of the selected eigenvectors, stored in consecutive
+* elements of the array. For a complex eigenvector two
+* consecutive elements of SEP are set to the same value. If
+* the eigenvalues cannot be reordered to compute SEP(j), SEP(j)
+* is set to 0; this can only occur when the true value would be
+* very small anyway.
+* If JOB = 'E', SEP is not referenced.
+*
+* MM (input) INTEGER
+* The number of elements in the arrays S (if JOB = 'E' or 'B')
+* and/or SEP (if JOB = 'V' or 'B'). MM >= M.
+*
+* M (output) INTEGER
+* The number of elements of the arrays S and/or SEP actually
+* used to store the estimated condition numbers.
+* If HOWMNY = 'A', M is set to N.
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (LDWORK,N+6)
+* If JOB = 'E', WORK is not referenced.
+*
+* LDWORK (input) INTEGER
+* The leading dimension of the array WORK.
+* LDWORK >= 1; and if JOB = 'V' or 'B', LDWORK >= N.
+*
+* IWORK (workspace) INTEGER array, dimension (2*(N-1))
+* If JOB = 'E', IWORK is not referenced.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+*
+* Further Details
+* ===============
+*
+* The reciprocal of the condition number of an eigenvalue lambda is
+* defined as
+*
+* S(lambda) = |v'*u| / (norm(u)*norm(v))
+*
+* where u and v are the right and left eigenvectors of T corresponding
+* to lambda; v' denotes the conjugate-transpose of v, and norm(u)
+* denotes the Euclidean norm. These reciprocal condition numbers always
+* lie between zero (very badly conditioned) and one (very well
+* conditioned). If n = 1, S(lambda) is defined to be 1.
+*
+* An approximate error bound for a computed eigenvalue W(i) is given by
+*
+* EPS * norm(T) / S(i)
+*
+* where EPS is the machine precision.
+*
+* The reciprocal of the condition number of the right eigenvector u
+* corresponding to lambda is defined as follows. Suppose
+*
+* T = ( lambda c )
+* ( 0 T22 )
+*
+* Then the reciprocal condition number is
+*
+* SEP( lambda, T22 ) = sigma-min( T22 - lambda*I )
+*
+* where sigma-min denotes the smallest singular value. We approximate
+* the smallest singular value by the reciprocal of an estimate of the
+* one-norm of the inverse of T22 - lambda*I. If n = 1, SEP(1) is
+* defined to be abs(T(1,1)).
+*
+* An approximate error bound for a computed right eigenvector VR(i)
+* is given by
+*
+* EPS * norm(T) / SEP(i)
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE, TWO
+ PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL PAIR, SOMCON, WANTBH, WANTS, WANTSP
+ INTEGER I, IERR, IFST, ILST, J, K, KASE, KS, N2, NN
+ DOUBLE PRECISION BIGNUM, COND, CS, DELTA, DUMM, EPS, EST, LNRM,
+ $ MU, PROD, PROD1, PROD2, RNRM, SCALE, SMLNUM, SN
+* ..
+* .. Local Arrays ..
+ INTEGER ISAVE( 3 )
+ DOUBLE PRECISION DUMMY( 1 )
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ DOUBLE PRECISION DDOT, DLAMCH, DLAPY2, DNRM2
+ EXTERNAL LSAME, DDOT, DLAMCH, DLAPY2, DNRM2
+* ..
+* .. External Subroutines ..
+ EXTERNAL DLACN2, DLACPY, DLAQTR, DTREXC, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, SQRT
+* ..
+* .. Executable Statements ..
+*
+* Decode and test the input parameters
+*
+ WANTBH = LSAME( JOB, 'B' )
+ WANTS = LSAME( JOB, 'E' ) .OR. WANTBH
+ WANTSP = LSAME( JOB, 'V' ) .OR. WANTBH
+*
+ SOMCON = LSAME( HOWMNY, 'S' )
+*
+ INFO = 0
+ IF( .NOT.WANTS .AND. .NOT.WANTSP ) THEN
+ INFO = -1
+ ELSE IF( .NOT.LSAME( HOWMNY, 'A' ) .AND. .NOT.SOMCON ) THEN
+ INFO = -2
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( LDT.LT.MAX( 1, N ) ) THEN
+ INFO = -6
+ ELSE IF( LDVL.LT.1 .OR. ( WANTS .AND. LDVL.LT.N ) ) THEN
+ INFO = -8
+ ELSE IF( LDVR.LT.1 .OR. ( WANTS .AND. LDVR.LT.N ) ) THEN
+ INFO = -10
+ ELSE
+*
+* Set M to the number of eigenpairs for which condition numbers
+* are required, and test MM.
+*
+ IF( SOMCON ) THEN
+ M = 0
+ PAIR = .FALSE.
+ DO 10 K = 1, N
+ IF( PAIR ) THEN
+ PAIR = .FALSE.
+ ELSE
+ IF( K.LT.N ) THEN
+ IF( T( K+1, K ).EQ.ZERO ) THEN
+ IF( SELECT( K ) )
+ $ M = M + 1
+ ELSE
+ PAIR = .TRUE.
+ IF( SELECT( K ) .OR. SELECT( K+1 ) )
+ $ M = M + 2
+ END IF
+ ELSE
+ IF( SELECT( N ) )
+ $ M = M + 1
+ END IF
+ END IF
+ 10 CONTINUE
+ ELSE
+ M = N
+ END IF
+*
+ IF( MM.LT.M ) THEN
+ INFO = -13
+ ELSE IF( LDWORK.LT.1 .OR. ( WANTSP .AND. LDWORK.LT.N ) ) THEN
+ INFO = -16
+ END IF
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DTRSNA', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+ IF( N.EQ.1 ) THEN
+ IF( SOMCON ) THEN
+ IF( .NOT.SELECT( 1 ) )
+ $ RETURN
+ END IF
+ IF( WANTS )
+ $ S( 1 ) = ONE
+ IF( WANTSP )
+ $ SEP( 1 ) = ABS( T( 1, 1 ) )
+ RETURN
+ END IF
+*
+* Get machine constants
+*
+ EPS = DLAMCH( 'P' )
+ SMLNUM = DLAMCH( 'S' ) / EPS
+ BIGNUM = ONE / SMLNUM
+ CALL DLABAD( SMLNUM, BIGNUM )
+*
+ KS = 0
+ PAIR = .FALSE.
+ DO 60 K = 1, N
+*
+* Determine whether T(k,k) begins a 1-by-1 or 2-by-2 block.
+*
+ IF( PAIR ) THEN
+ PAIR = .FALSE.
+ GO TO 60
+ ELSE
+ IF( K.LT.N )
+ $ PAIR = T( K+1, K ).NE.ZERO
+ END IF
+*
+* Determine whether condition numbers are required for the k-th
+* eigenpair.
+*
+ IF( SOMCON ) THEN
+ IF( PAIR ) THEN
+ IF( .NOT.SELECT( K ) .AND. .NOT.SELECT( K+1 ) )
+ $ GO TO 60
+ ELSE
+ IF( .NOT.SELECT( K ) )
+ $ GO TO 60
+ END IF
+ END IF
+*
+ KS = KS + 1
+*
+ IF( WANTS ) THEN
+*
+* Compute the reciprocal condition number of the k-th
+* eigenvalue.
+*
+ IF( .NOT.PAIR ) THEN
+*
+* Real eigenvalue.
+*
+ PROD = DDOT( N, VR( 1, KS ), 1, VL( 1, KS ), 1 )
+ RNRM = DNRM2( N, VR( 1, KS ), 1 )
+ LNRM = DNRM2( N, VL( 1, KS ), 1 )
+ S( KS ) = ABS( PROD ) / ( RNRM*LNRM )
+ ELSE
+*
+* Complex eigenvalue.
+*
+ PROD1 = DDOT( N, VR( 1, KS ), 1, VL( 1, KS ), 1 )
+ PROD1 = PROD1 + DDOT( N, VR( 1, KS+1 ), 1, VL( 1, KS+1 ),
+ $ 1 )
+ PROD2 = DDOT( N, VL( 1, KS ), 1, VR( 1, KS+1 ), 1 )
+ PROD2 = PROD2 - DDOT( N, VL( 1, KS+1 ), 1, VR( 1, KS ),
+ $ 1 )
+ RNRM = DLAPY2( DNRM2( N, VR( 1, KS ), 1 ),
+ $ DNRM2( N, VR( 1, KS+1 ), 1 ) )
+ LNRM = DLAPY2( DNRM2( N, VL( 1, KS ), 1 ),
+ $ DNRM2( N, VL( 1, KS+1 ), 1 ) )
+ COND = DLAPY2( PROD1, PROD2 ) / ( RNRM*LNRM )
+ S( KS ) = COND
+ S( KS+1 ) = COND
+ END IF
+ END IF
+*
+ IF( WANTSP ) THEN
+*
+* Estimate the reciprocal condition number of the k-th
+* eigenvector.
+*
+* Copy the matrix T to the array WORK and swap the diagonal
+* block beginning at T(k,k) to the (1,1) position.
+*
+ CALL DLACPY( 'Full', N, N, T, LDT, WORK, LDWORK )
+ IFST = K
+ ILST = 1
+ CALL DTREXC( 'No Q', N, WORK, LDWORK, DUMMY, 1, IFST, ILST,
+ $ WORK( 1, N+1 ), IERR )
+*
+ IF( IERR.EQ.1 .OR. IERR.EQ.2 ) THEN
+*
+* Could not swap because blocks not well separated
+*
+ SCALE = ONE
+ EST = BIGNUM
+ ELSE
+*
+* Reordering successful
+*
+ IF( WORK( 2, 1 ).EQ.ZERO ) THEN
+*
+* Form C = T22 - lambda*I in WORK(2:N,2:N).
+*
+ DO 20 I = 2, N
+ WORK( I, I ) = WORK( I, I ) - WORK( 1, 1 )
+ 20 CONTINUE
+ N2 = 1
+ NN = N - 1
+ ELSE
+*
+* Triangularize the 2 by 2 block by unitary
+* transformation U = [ cs i*ss ]
+* [ i*ss cs ].
+* such that the (1,1) position of WORK is complex
+* eigenvalue lambda with positive imaginary part. (2,2)
+* position of WORK is the complex eigenvalue lambda
+* with negative imaginary part.
+*
+ MU = SQRT( ABS( WORK( 1, 2 ) ) )*
+ $ SQRT( ABS( WORK( 2, 1 ) ) )
+ DELTA = DLAPY2( MU, WORK( 2, 1 ) )
+ CS = MU / DELTA
+ SN = -WORK( 2, 1 ) / DELTA
+*
+* Form
+*
+* C' = WORK(2:N,2:N) + i*[rwork(1) ..... rwork(n-1) ]
+* [ mu ]
+* [ .. ]
+* [ .. ]
+* [ mu ]
+* where C' is conjugate transpose of complex matrix C,
+* and RWORK is stored starting in the N+1-st column of
+* WORK.
+*
+ DO 30 J = 3, N
+ WORK( 2, J ) = CS*WORK( 2, J )
+ WORK( J, J ) = WORK( J, J ) - WORK( 1, 1 )
+ 30 CONTINUE
+ WORK( 2, 2 ) = ZERO
+*
+ WORK( 1, N+1 ) = TWO*MU
+ DO 40 I = 2, N - 1
+ WORK( I, N+1 ) = SN*WORK( 1, I+1 )
+ 40 CONTINUE
+ N2 = 2
+ NN = 2*( N-1 )
+ END IF
+*
+* Estimate norm(inv(C'))
+*
+ EST = ZERO
+ KASE = 0
+ 50 CONTINUE
+ CALL DLACN2( NN, WORK( 1, N+2 ), WORK( 1, N+4 ), IWORK,
+ $ EST, KASE, ISAVE )
+ IF( KASE.NE.0 ) THEN
+ IF( KASE.EQ.1 ) THEN
+ IF( N2.EQ.1 ) THEN
+*
+* Real eigenvalue: solve C'*x = scale*c.
+*
+ CALL DLAQTR( .TRUE., .TRUE., N-1, WORK( 2, 2 ),
+ $ LDWORK, DUMMY, DUMM, SCALE,
+ $ WORK( 1, N+4 ), WORK( 1, N+6 ),
+ $ IERR )
+ ELSE
+*
+* Complex eigenvalue: solve
+* C'*(p+iq) = scale*(c+id) in real arithmetic.
+*
+ CALL DLAQTR( .TRUE., .FALSE., N-1, WORK( 2, 2 ),
+ $ LDWORK, WORK( 1, N+1 ), MU, SCALE,
+ $ WORK( 1, N+4 ), WORK( 1, N+6 ),
+ $ IERR )
+ END IF
+ ELSE
+ IF( N2.EQ.1 ) THEN
+*
+* Real eigenvalue: solve C*x = scale*c.
+*
+ CALL DLAQTR( .FALSE., .TRUE., N-1, WORK( 2, 2 ),
+ $ LDWORK, DUMMY, DUMM, SCALE,
+ $ WORK( 1, N+4 ), WORK( 1, N+6 ),
+ $ IERR )
+ ELSE
+*
+* Complex eigenvalue: solve
+* C*(p+iq) = scale*(c+id) in real arithmetic.
+*
+ CALL DLAQTR( .FALSE., .FALSE., N-1,
+ $ WORK( 2, 2 ), LDWORK,
+ $ WORK( 1, N+1 ), MU, SCALE,
+ $ WORK( 1, N+4 ), WORK( 1, N+6 ),
+ $ IERR )
+*
+ END IF
+ END IF
+*
+ GO TO 50
+ END IF
+ END IF
+*
+ SEP( KS ) = SCALE / MAX( EST, SMLNUM )
+ IF( PAIR )
+ $ SEP( KS+1 ) = SEP( KS )
+ END IF
+*
+ IF( PAIR )
+ $ KS = KS + 1
+*
+ 60 CONTINUE
+ RETURN
+*
+* End of DTRSNA
+*
+ END
+ SUBROUTINE DTRSYL( TRANA, TRANB, ISGN, M, N, A, LDA, B, LDB, C,
+ $ LDC, SCALE, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER TRANA, TRANB
+ INTEGER INFO, ISGN, LDA, LDB, LDC, M, N
+ DOUBLE PRECISION SCALE
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * )
+* ..
+*
+* Purpose
+* =======
+*
+* DTRSYL solves the real Sylvester matrix equation:
+*
+* op(A)*X + X*op(B) = scale*C or
+* op(A)*X - X*op(B) = scale*C,
+*
+* where op(A) = A or A**T, and A and B are both upper quasi-
+* triangular. A is M-by-M and B is N-by-N; the right hand side C and
+* the solution X are M-by-N; and scale is an output scale factor, set
+* <= 1 to avoid overflow in X.
+*
+* A and B must be in Schur canonical form (as returned by DHSEQR), that
+* is, block upper triangular with 1-by-1 and 2-by-2 diagonal blocks;
+* each 2-by-2 diagonal block has its diagonal elements equal and its
+* off-diagonal elements of opposite sign.
+*
+* Arguments
+* =========
+*
+* TRANA (input) CHARACTER*1
+* Specifies the option op(A):
+* = 'N': op(A) = A (No transpose)
+* = 'T': op(A) = A**T (Transpose)
+* = 'C': op(A) = A**H (Conjugate transpose = Transpose)
+*
+* TRANB (input) CHARACTER*1
+* Specifies the option op(B):
+* = 'N': op(B) = B (No transpose)
+* = 'T': op(B) = B**T (Transpose)
+* = 'C': op(B) = B**H (Conjugate transpose = Transpose)
+*
+* ISGN (input) INTEGER
+* Specifies the sign in the equation:
+* = +1: solve op(A)*X + X*op(B) = scale*C
+* = -1: solve op(A)*X - X*op(B) = scale*C
+*
+* M (input) INTEGER
+* The order of the matrix A, and the number of rows in the
+* matrices X and C. M >= 0.
+*
+* N (input) INTEGER
+* The order of the matrix B, and the number of columns in the
+* matrices X and C. N >= 0.
+*
+* A (input) DOUBLE PRECISION array, dimension (LDA,M)
+* The upper quasi-triangular matrix A, in Schur canonical form.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,M).
+*
+* B (input) DOUBLE PRECISION array, dimension (LDB,N)
+* The upper quasi-triangular matrix B, in Schur canonical form.
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. LDB >= max(1,N).
+*
+* C (input/output) DOUBLE PRECISION array, dimension (LDC,N)
+* On entry, the M-by-N right hand side matrix C.
+* On exit, C is overwritten by the solution matrix X.
+*
+* LDC (input) INTEGER
+* The leading dimension of the array C. LDC >= max(1,M)
+*
+* SCALE (output) DOUBLE PRECISION
+* The scale factor, scale, set <= 1 to avoid overflow in X.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* = 1: A and B have common or very close eigenvalues; perturbed
+* values were used to solve the equation (but the matrices
+* A and B are unchanged).
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL NOTRNA, NOTRNB
+ INTEGER IERR, J, K, K1, K2, KNEXT, L, L1, L2, LNEXT
+ DOUBLE PRECISION A11, BIGNUM, DA11, DB, EPS, SCALOC, SGN, SMIN,
+ $ SMLNUM, SUML, SUMR, XNORM
+* ..
+* .. Local Arrays ..
+ DOUBLE PRECISION DUM( 1 ), VEC( 2, 2 ), X( 2, 2 )
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ DOUBLE PRECISION DDOT, DLAMCH, DLANGE
+ EXTERNAL LSAME, DDOT, DLAMCH, DLANGE
+* ..
+* .. External Subroutines ..
+ EXTERNAL DLABAD, DLALN2, DLASY2, DSCAL, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, DBLE, MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+* Decode and Test input parameters
+*
+ NOTRNA = LSAME( TRANA, 'N' )
+ NOTRNB = LSAME( TRANB, 'N' )
+*
+ INFO = 0
+ IF( .NOT.NOTRNA .AND. .NOT.LSAME( TRANA, 'T' ) .AND. .NOT.
+ $ LSAME( TRANA, 'C' ) ) THEN
+ INFO = -1
+ ELSE IF( .NOT.NOTRNB .AND. .NOT.LSAME( TRANB, 'T' ) .AND. .NOT.
+ $ LSAME( TRANB, 'C' ) ) THEN
+ INFO = -2
+ ELSE IF( ISGN.NE.1 .AND. ISGN.NE.-1 ) THEN
+ INFO = -3
+ ELSE IF( M.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -5
+ ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+ INFO = -7
+ ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -9
+ ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
+ INFO = -11
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DTRSYL', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( M.EQ.0 .OR. N.EQ.0 )
+ $ RETURN
+*
+* Set constants to control overflow
+*
+ EPS = DLAMCH( 'P' )
+ SMLNUM = DLAMCH( 'S' )
+ BIGNUM = ONE / SMLNUM
+ CALL DLABAD( SMLNUM, BIGNUM )
+ SMLNUM = SMLNUM*DBLE( M*N ) / EPS
+ BIGNUM = ONE / SMLNUM
+*
+ SMIN = MAX( SMLNUM, EPS*DLANGE( 'M', M, M, A, LDA, DUM ),
+ $ EPS*DLANGE( 'M', N, N, B, LDB, DUM ) )
+*
+ SCALE = ONE
+ SGN = ISGN
+*
+ IF( NOTRNA .AND. NOTRNB ) THEN
+*
+* Solve A*X + ISGN*X*B = scale*C.
+*
+* The (K,L)th block of X is determined starting from
+* bottom-left corner column by column by
+*
+* A(K,K)*X(K,L) + ISGN*X(K,L)*B(L,L) = C(K,L) - R(K,L)
+*
+* Where
+* M L-1
+* R(K,L) = SUM [A(K,I)*X(I,L)] + ISGN*SUM [X(K,J)*B(J,L)].
+* I=K+1 J=1
+*
+* Start column loop (index = L)
+* L1 (L2) : column index of the first (first) row of X(K,L).
+*
+ LNEXT = 1
+ DO 60 L = 1, N
+ IF( L.LT.LNEXT )
+ $ GO TO 60
+ IF( L.EQ.N ) THEN
+ L1 = L
+ L2 = L
+ ELSE
+ IF( B( L+1, L ).NE.ZERO ) THEN
+ L1 = L
+ L2 = L + 1
+ LNEXT = L + 2
+ ELSE
+ L1 = L
+ L2 = L
+ LNEXT = L + 1
+ END IF
+ END IF
+*
+* Start row loop (index = K)
+* K1 (K2): row index of the first (last) row of X(K,L).
+*
+ KNEXT = M
+ DO 50 K = M, 1, -1
+ IF( K.GT.KNEXT )
+ $ GO TO 50
+ IF( K.EQ.1 ) THEN
+ K1 = K
+ K2 = K
+ ELSE
+ IF( A( K, K-1 ).NE.ZERO ) THEN
+ K1 = K - 1
+ K2 = K
+ KNEXT = K - 2
+ ELSE
+ K1 = K
+ K2 = K
+ KNEXT = K - 1
+ END IF
+ END IF
+*
+ IF( L1.EQ.L2 .AND. K1.EQ.K2 ) THEN
+ SUML = DDOT( M-K1, A( K1, MIN( K1+1, M ) ), LDA,
+ $ C( MIN( K1+1, M ), L1 ), 1 )
+ SUMR = DDOT( L1-1, C( K1, 1 ), LDC, B( 1, L1 ), 1 )
+ VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR )
+ SCALOC = ONE
+*
+ A11 = A( K1, K1 ) + SGN*B( L1, L1 )
+ DA11 = ABS( A11 )
+ IF( DA11.LE.SMIN ) THEN
+ A11 = SMIN
+ DA11 = SMIN
+ INFO = 1
+ END IF
+ DB = ABS( VEC( 1, 1 ) )
+ IF( DA11.LT.ONE .AND. DB.GT.ONE ) THEN
+ IF( DB.GT.BIGNUM*DA11 )
+ $ SCALOC = ONE / DB
+ END IF
+ X( 1, 1 ) = ( VEC( 1, 1 )*SCALOC ) / A11
+*
+ IF( SCALOC.NE.ONE ) THEN
+ DO 10 J = 1, N
+ CALL DSCAL( M, SCALOC, C( 1, J ), 1 )
+ 10 CONTINUE
+ SCALE = SCALE*SCALOC
+ END IF
+ C( K1, L1 ) = X( 1, 1 )
+*
+ ELSE IF( L1.EQ.L2 .AND. K1.NE.K2 ) THEN
+*
+ SUML = DDOT( M-K2, A( K1, MIN( K2+1, M ) ), LDA,
+ $ C( MIN( K2+1, M ), L1 ), 1 )
+ SUMR = DDOT( L1-1, C( K1, 1 ), LDC, B( 1, L1 ), 1 )
+ VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR )
+*
+ SUML = DDOT( M-K2, A( K2, MIN( K2+1, M ) ), LDA,
+ $ C( MIN( K2+1, M ), L1 ), 1 )
+ SUMR = DDOT( L1-1, C( K2, 1 ), LDC, B( 1, L1 ), 1 )
+ VEC( 2, 1 ) = C( K2, L1 ) - ( SUML+SGN*SUMR )
+*
+ CALL DLALN2( .FALSE., 2, 1, SMIN, ONE, A( K1, K1 ),
+ $ LDA, ONE, ONE, VEC, 2, -SGN*B( L1, L1 ),
+ $ ZERO, X, 2, SCALOC, XNORM, IERR )
+ IF( IERR.NE.0 )
+ $ INFO = 1
+*
+ IF( SCALOC.NE.ONE ) THEN
+ DO 20 J = 1, N
+ CALL DSCAL( M, SCALOC, C( 1, J ), 1 )
+ 20 CONTINUE
+ SCALE = SCALE*SCALOC
+ END IF
+ C( K1, L1 ) = X( 1, 1 )
+ C( K2, L1 ) = X( 2, 1 )
+*
+ ELSE IF( L1.NE.L2 .AND. K1.EQ.K2 ) THEN
+*
+ SUML = DDOT( M-K1, A( K1, MIN( K1+1, M ) ), LDA,
+ $ C( MIN( K1+1, M ), L1 ), 1 )
+ SUMR = DDOT( L1-1, C( K1, 1 ), LDC, B( 1, L1 ), 1 )
+ VEC( 1, 1 ) = SGN*( C( K1, L1 )-( SUML+SGN*SUMR ) )
+*
+ SUML = DDOT( M-K1, A( K1, MIN( K1+1, M ) ), LDA,
+ $ C( MIN( K1+1, M ), L2 ), 1 )
+ SUMR = DDOT( L1-1, C( K1, 1 ), LDC, B( 1, L2 ), 1 )
+ VEC( 2, 1 ) = SGN*( C( K1, L2 )-( SUML+SGN*SUMR ) )
+*
+ CALL DLALN2( .TRUE., 2, 1, SMIN, ONE, B( L1, L1 ),
+ $ LDB, ONE, ONE, VEC, 2, -SGN*A( K1, K1 ),
+ $ ZERO, X, 2, SCALOC, XNORM, IERR )
+ IF( IERR.NE.0 )
+ $ INFO = 1
+*
+ IF( SCALOC.NE.ONE ) THEN
+ DO 30 J = 1, N
+ CALL DSCAL( M, SCALOC, C( 1, J ), 1 )
+ 30 CONTINUE
+ SCALE = SCALE*SCALOC
+ END IF
+ C( K1, L1 ) = X( 1, 1 )
+ C( K1, L2 ) = X( 2, 1 )
+*
+ ELSE IF( L1.NE.L2 .AND. K1.NE.K2 ) THEN
+*
+ SUML = DDOT( M-K2, A( K1, MIN( K2+1, M ) ), LDA,
+ $ C( MIN( K2+1, M ), L1 ), 1 )
+ SUMR = DDOT( L1-1, C( K1, 1 ), LDC, B( 1, L1 ), 1 )
+ VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR )
+*
+ SUML = DDOT( M-K2, A( K1, MIN( K2+1, M ) ), LDA,
+ $ C( MIN( K2+1, M ), L2 ), 1 )
+ SUMR = DDOT( L1-1, C( K1, 1 ), LDC, B( 1, L2 ), 1 )
+ VEC( 1, 2 ) = C( K1, L2 ) - ( SUML+SGN*SUMR )
+*
+ SUML = DDOT( M-K2, A( K2, MIN( K2+1, M ) ), LDA,
+ $ C( MIN( K2+1, M ), L1 ), 1 )
+ SUMR = DDOT( L1-1, C( K2, 1 ), LDC, B( 1, L1 ), 1 )
+ VEC( 2, 1 ) = C( K2, L1 ) - ( SUML+SGN*SUMR )
+*
+ SUML = DDOT( M-K2, A( K2, MIN( K2+1, M ) ), LDA,
+ $ C( MIN( K2+1, M ), L2 ), 1 )
+ SUMR = DDOT( L1-1, C( K2, 1 ), LDC, B( 1, L2 ), 1 )
+ VEC( 2, 2 ) = C( K2, L2 ) - ( SUML+SGN*SUMR )
+*
+ CALL DLASY2( .FALSE., .FALSE., ISGN, 2, 2,
+ $ A( K1, K1 ), LDA, B( L1, L1 ), LDB, VEC,
+ $ 2, SCALOC, X, 2, XNORM, IERR )
+ IF( IERR.NE.0 )
+ $ INFO = 1
+*
+ IF( SCALOC.NE.ONE ) THEN
+ DO 40 J = 1, N
+ CALL DSCAL( M, SCALOC, C( 1, J ), 1 )
+ 40 CONTINUE
+ SCALE = SCALE*SCALOC
+ END IF
+ C( K1, L1 ) = X( 1, 1 )
+ C( K1, L2 ) = X( 1, 2 )
+ C( K2, L1 ) = X( 2, 1 )
+ C( K2, L2 ) = X( 2, 2 )
+ END IF
+*
+ 50 CONTINUE
+*
+ 60 CONTINUE
+*
+ ELSE IF( .NOT.NOTRNA .AND. NOTRNB ) THEN
+*
+* Solve A' *X + ISGN*X*B = scale*C.
+*
+* The (K,L)th block of X is determined starting from
+* upper-left corner column by column by
+*
+* A(K,K)'*X(K,L) + ISGN*X(K,L)*B(L,L) = C(K,L) - R(K,L)
+*
+* Where
+* K-1 L-1
+* R(K,L) = SUM [A(I,K)'*X(I,L)] +ISGN*SUM [X(K,J)*B(J,L)]
+* I=1 J=1
+*
+* Start column loop (index = L)
+* L1 (L2): column index of the first (last) row of X(K,L)
+*
+ LNEXT = 1
+ DO 120 L = 1, N
+ IF( L.LT.LNEXT )
+ $ GO TO 120
+ IF( L.EQ.N ) THEN
+ L1 = L
+ L2 = L
+ ELSE
+ IF( B( L+1, L ).NE.ZERO ) THEN
+ L1 = L
+ L2 = L + 1
+ LNEXT = L + 2
+ ELSE
+ L1 = L
+ L2 = L
+ LNEXT = L + 1
+ END IF
+ END IF
+*
+* Start row loop (index = K)
+* K1 (K2): row index of the first (last) row of X(K,L)
+*
+ KNEXT = 1
+ DO 110 K = 1, M
+ IF( K.LT.KNEXT )
+ $ GO TO 110
+ IF( K.EQ.M ) THEN
+ K1 = K
+ K2 = K
+ ELSE
+ IF( A( K+1, K ).NE.ZERO ) THEN
+ K1 = K
+ K2 = K + 1
+ KNEXT = K + 2
+ ELSE
+ K1 = K
+ K2 = K
+ KNEXT = K + 1
+ END IF
+ END IF
+*
+ IF( L1.EQ.L2 .AND. K1.EQ.K2 ) THEN
+ SUML = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 )
+ SUMR = DDOT( L1-1, C( K1, 1 ), LDC, B( 1, L1 ), 1 )
+ VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR )
+ SCALOC = ONE
+*
+ A11 = A( K1, K1 ) + SGN*B( L1, L1 )
+ DA11 = ABS( A11 )
+ IF( DA11.LE.SMIN ) THEN
+ A11 = SMIN
+ DA11 = SMIN
+ INFO = 1
+ END IF
+ DB = ABS( VEC( 1, 1 ) )
+ IF( DA11.LT.ONE .AND. DB.GT.ONE ) THEN
+ IF( DB.GT.BIGNUM*DA11 )
+ $ SCALOC = ONE / DB
+ END IF
+ X( 1, 1 ) = ( VEC( 1, 1 )*SCALOC ) / A11
+*
+ IF( SCALOC.NE.ONE ) THEN
+ DO 70 J = 1, N
+ CALL DSCAL( M, SCALOC, C( 1, J ), 1 )
+ 70 CONTINUE
+ SCALE = SCALE*SCALOC
+ END IF
+ C( K1, L1 ) = X( 1, 1 )
+*
+ ELSE IF( L1.EQ.L2 .AND. K1.NE.K2 ) THEN
+*
+ SUML = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 )
+ SUMR = DDOT( L1-1, C( K1, 1 ), LDC, B( 1, L1 ), 1 )
+ VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR )
+*
+ SUML = DDOT( K1-1, A( 1, K2 ), 1, C( 1, L1 ), 1 )
+ SUMR = DDOT( L1-1, C( K2, 1 ), LDC, B( 1, L1 ), 1 )
+ VEC( 2, 1 ) = C( K2, L1 ) - ( SUML+SGN*SUMR )
+*
+ CALL DLALN2( .TRUE., 2, 1, SMIN, ONE, A( K1, K1 ),
+ $ LDA, ONE, ONE, VEC, 2, -SGN*B( L1, L1 ),
+ $ ZERO, X, 2, SCALOC, XNORM, IERR )
+ IF( IERR.NE.0 )
+ $ INFO = 1
+*
+ IF( SCALOC.NE.ONE ) THEN
+ DO 80 J = 1, N
+ CALL DSCAL( M, SCALOC, C( 1, J ), 1 )
+ 80 CONTINUE
+ SCALE = SCALE*SCALOC
+ END IF
+ C( K1, L1 ) = X( 1, 1 )
+ C( K2, L1 ) = X( 2, 1 )
+*
+ ELSE IF( L1.NE.L2 .AND. K1.EQ.K2 ) THEN
+*
+ SUML = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 )
+ SUMR = DDOT( L1-1, C( K1, 1 ), LDC, B( 1, L1 ), 1 )
+ VEC( 1, 1 ) = SGN*( C( K1, L1 )-( SUML+SGN*SUMR ) )
+*
+ SUML = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L2 ), 1 )
+ SUMR = DDOT( L1-1, C( K1, 1 ), LDC, B( 1, L2 ), 1 )
+ VEC( 2, 1 ) = SGN*( C( K1, L2 )-( SUML+SGN*SUMR ) )
+*
+ CALL DLALN2( .TRUE., 2, 1, SMIN, ONE, B( L1, L1 ),
+ $ LDB, ONE, ONE, VEC, 2, -SGN*A( K1, K1 ),
+ $ ZERO, X, 2, SCALOC, XNORM, IERR )
+ IF( IERR.NE.0 )
+ $ INFO = 1
+*
+ IF( SCALOC.NE.ONE ) THEN
+ DO 90 J = 1, N
+ CALL DSCAL( M, SCALOC, C( 1, J ), 1 )
+ 90 CONTINUE
+ SCALE = SCALE*SCALOC
+ END IF
+ C( K1, L1 ) = X( 1, 1 )
+ C( K1, L2 ) = X( 2, 1 )
+*
+ ELSE IF( L1.NE.L2 .AND. K1.NE.K2 ) THEN
+*
+ SUML = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 )
+ SUMR = DDOT( L1-1, C( K1, 1 ), LDC, B( 1, L1 ), 1 )
+ VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR )
+*
+ SUML = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L2 ), 1 )
+ SUMR = DDOT( L1-1, C( K1, 1 ), LDC, B( 1, L2 ), 1 )
+ VEC( 1, 2 ) = C( K1, L2 ) - ( SUML+SGN*SUMR )
+*
+ SUML = DDOT( K1-1, A( 1, K2 ), 1, C( 1, L1 ), 1 )
+ SUMR = DDOT( L1-1, C( K2, 1 ), LDC, B( 1, L1 ), 1 )
+ VEC( 2, 1 ) = C( K2, L1 ) - ( SUML+SGN*SUMR )
+*
+ SUML = DDOT( K1-1, A( 1, K2 ), 1, C( 1, L2 ), 1 )
+ SUMR = DDOT( L1-1, C( K2, 1 ), LDC, B( 1, L2 ), 1 )
+ VEC( 2, 2 ) = C( K2, L2 ) - ( SUML+SGN*SUMR )
+*
+ CALL DLASY2( .TRUE., .FALSE., ISGN, 2, 2, A( K1, K1 ),
+ $ LDA, B( L1, L1 ), LDB, VEC, 2, SCALOC, X,
+ $ 2, XNORM, IERR )
+ IF( IERR.NE.0 )
+ $ INFO = 1
+*
+ IF( SCALOC.NE.ONE ) THEN
+ DO 100 J = 1, N
+ CALL DSCAL( M, SCALOC, C( 1, J ), 1 )
+ 100 CONTINUE
+ SCALE = SCALE*SCALOC
+ END IF
+ C( K1, L1 ) = X( 1, 1 )
+ C( K1, L2 ) = X( 1, 2 )
+ C( K2, L1 ) = X( 2, 1 )
+ C( K2, L2 ) = X( 2, 2 )
+ END IF
+*
+ 110 CONTINUE
+ 120 CONTINUE
+*
+ ELSE IF( .NOT.NOTRNA .AND. .NOT.NOTRNB ) THEN
+*
+* Solve A'*X + ISGN*X*B' = scale*C.
+*
+* The (K,L)th block of X is determined starting from
+* top-right corner column by column by
+*
+* A(K,K)'*X(K,L) + ISGN*X(K,L)*B(L,L)' = C(K,L) - R(K,L)
+*
+* Where
+* K-1 N
+* R(K,L) = SUM [A(I,K)'*X(I,L)] + ISGN*SUM [X(K,J)*B(L,J)'].
+* I=1 J=L+1
+*
+* Start column loop (index = L)
+* L1 (L2): column index of the first (last) row of X(K,L)
+*
+ LNEXT = N
+ DO 180 L = N, 1, -1
+ IF( L.GT.LNEXT )
+ $ GO TO 180
+ IF( L.EQ.1 ) THEN
+ L1 = L
+ L2 = L
+ ELSE
+ IF( B( L, L-1 ).NE.ZERO ) THEN
+ L1 = L - 1
+ L2 = L
+ LNEXT = L - 2
+ ELSE
+ L1 = L
+ L2 = L
+ LNEXT = L - 1
+ END IF
+ END IF
+*
+* Start row loop (index = K)
+* K1 (K2): row index of the first (last) row of X(K,L)
+*
+ KNEXT = 1
+ DO 170 K = 1, M
+ IF( K.LT.KNEXT )
+ $ GO TO 170
+ IF( K.EQ.M ) THEN
+ K1 = K
+ K2 = K
+ ELSE
+ IF( A( K+1, K ).NE.ZERO ) THEN
+ K1 = K
+ K2 = K + 1
+ KNEXT = K + 2
+ ELSE
+ K1 = K
+ K2 = K
+ KNEXT = K + 1
+ END IF
+ END IF
+*
+ IF( L1.EQ.L2 .AND. K1.EQ.K2 ) THEN
+ SUML = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 )
+ SUMR = DDOT( N-L1, C( K1, MIN( L1+1, N ) ), LDC,
+ $ B( L1, MIN( L1+1, N ) ), LDB )
+ VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR )
+ SCALOC = ONE
+*
+ A11 = A( K1, K1 ) + SGN*B( L1, L1 )
+ DA11 = ABS( A11 )
+ IF( DA11.LE.SMIN ) THEN
+ A11 = SMIN
+ DA11 = SMIN
+ INFO = 1
+ END IF
+ DB = ABS( VEC( 1, 1 ) )
+ IF( DA11.LT.ONE .AND. DB.GT.ONE ) THEN
+ IF( DB.GT.BIGNUM*DA11 )
+ $ SCALOC = ONE / DB
+ END IF
+ X( 1, 1 ) = ( VEC( 1, 1 )*SCALOC ) / A11
+*
+ IF( SCALOC.NE.ONE ) THEN
+ DO 130 J = 1, N
+ CALL DSCAL( M, SCALOC, C( 1, J ), 1 )
+ 130 CONTINUE
+ SCALE = SCALE*SCALOC
+ END IF
+ C( K1, L1 ) = X( 1, 1 )
+*
+ ELSE IF( L1.EQ.L2 .AND. K1.NE.K2 ) THEN
+*
+ SUML = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 )
+ SUMR = DDOT( N-L2, C( K1, MIN( L2+1, N ) ), LDC,
+ $ B( L1, MIN( L2+1, N ) ), LDB )
+ VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR )
+*
+ SUML = DDOT( K1-1, A( 1, K2 ), 1, C( 1, L1 ), 1 )
+ SUMR = DDOT( N-L2, C( K2, MIN( L2+1, N ) ), LDC,
+ $ B( L1, MIN( L2+1, N ) ), LDB )
+ VEC( 2, 1 ) = C( K2, L1 ) - ( SUML+SGN*SUMR )
+*
+ CALL DLALN2( .TRUE., 2, 1, SMIN, ONE, A( K1, K1 ),
+ $ LDA, ONE, ONE, VEC, 2, -SGN*B( L1, L1 ),
+ $ ZERO, X, 2, SCALOC, XNORM, IERR )
+ IF( IERR.NE.0 )
+ $ INFO = 1
+*
+ IF( SCALOC.NE.ONE ) THEN
+ DO 140 J = 1, N
+ CALL DSCAL( M, SCALOC, C( 1, J ), 1 )
+ 140 CONTINUE
+ SCALE = SCALE*SCALOC
+ END IF
+ C( K1, L1 ) = X( 1, 1 )
+ C( K2, L1 ) = X( 2, 1 )
+*
+ ELSE IF( L1.NE.L2 .AND. K1.EQ.K2 ) THEN
+*
+ SUML = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 )
+ SUMR = DDOT( N-L2, C( K1, MIN( L2+1, N ) ), LDC,
+ $ B( L1, MIN( L2+1, N ) ), LDB )
+ VEC( 1, 1 ) = SGN*( C( K1, L1 )-( SUML+SGN*SUMR ) )
+*
+ SUML = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L2 ), 1 )
+ SUMR = DDOT( N-L2, C( K1, MIN( L2+1, N ) ), LDC,
+ $ B( L2, MIN( L2+1, N ) ), LDB )
+ VEC( 2, 1 ) = SGN*( C( K1, L2 )-( SUML+SGN*SUMR ) )
+*
+ CALL DLALN2( .FALSE., 2, 1, SMIN, ONE, B( L1, L1 ),
+ $ LDB, ONE, ONE, VEC, 2, -SGN*A( K1, K1 ),
+ $ ZERO, X, 2, SCALOC, XNORM, IERR )
+ IF( IERR.NE.0 )
+ $ INFO = 1
+*
+ IF( SCALOC.NE.ONE ) THEN
+ DO 150 J = 1, N
+ CALL DSCAL( M, SCALOC, C( 1, J ), 1 )
+ 150 CONTINUE
+ SCALE = SCALE*SCALOC
+ END IF
+ C( K1, L1 ) = X( 1, 1 )
+ C( K1, L2 ) = X( 2, 1 )
+*
+ ELSE IF( L1.NE.L2 .AND. K1.NE.K2 ) THEN
+*
+ SUML = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 )
+ SUMR = DDOT( N-L2, C( K1, MIN( L2+1, N ) ), LDC,
+ $ B( L1, MIN( L2+1, N ) ), LDB )
+ VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR )
+*
+ SUML = DDOT( K1-1, A( 1, K1 ), 1, C( 1, L2 ), 1 )
+ SUMR = DDOT( N-L2, C( K1, MIN( L2+1, N ) ), LDC,
+ $ B( L2, MIN( L2+1, N ) ), LDB )
+ VEC( 1, 2 ) = C( K1, L2 ) - ( SUML+SGN*SUMR )
+*
+ SUML = DDOT( K1-1, A( 1, K2 ), 1, C( 1, L1 ), 1 )
+ SUMR = DDOT( N-L2, C( K2, MIN( L2+1, N ) ), LDC,
+ $ B( L1, MIN( L2+1, N ) ), LDB )
+ VEC( 2, 1 ) = C( K2, L1 ) - ( SUML+SGN*SUMR )
+*
+ SUML = DDOT( K1-1, A( 1, K2 ), 1, C( 1, L2 ), 1 )
+ SUMR = DDOT( N-L2, C( K2, MIN( L2+1, N ) ), LDC,
+ $ B( L2, MIN( L2+1, N ) ), LDB )
+ VEC( 2, 2 ) = C( K2, L2 ) - ( SUML+SGN*SUMR )
+*
+ CALL DLASY2( .TRUE., .TRUE., ISGN, 2, 2, A( K1, K1 ),
+ $ LDA, B( L1, L1 ), LDB, VEC, 2, SCALOC, X,
+ $ 2, XNORM, IERR )
+ IF( IERR.NE.0 )
+ $ INFO = 1
+*
+ IF( SCALOC.NE.ONE ) THEN
+ DO 160 J = 1, N
+ CALL DSCAL( M, SCALOC, C( 1, J ), 1 )
+ 160 CONTINUE
+ SCALE = SCALE*SCALOC
+ END IF
+ C( K1, L1 ) = X( 1, 1 )
+ C( K1, L2 ) = X( 1, 2 )
+ C( K2, L1 ) = X( 2, 1 )
+ C( K2, L2 ) = X( 2, 2 )
+ END IF
+*
+ 170 CONTINUE
+ 180 CONTINUE
+*
+ ELSE IF( NOTRNA .AND. .NOT.NOTRNB ) THEN
+*
+* Solve A*X + ISGN*X*B' = scale*C.
+*
+* The (K,L)th block of X is determined starting from
+* bottom-right corner column by column by
+*
+* A(K,K)*X(K,L) + ISGN*X(K,L)*B(L,L)' = C(K,L) - R(K,L)
+*
+* Where
+* M N
+* R(K,L) = SUM [A(K,I)*X(I,L)] + ISGN*SUM [X(K,J)*B(L,J)'].
+* I=K+1 J=L+1
+*
+* Start column loop (index = L)
+* L1 (L2): column index of the first (last) row of X(K,L)
+*
+ LNEXT = N
+ DO 240 L = N, 1, -1
+ IF( L.GT.LNEXT )
+ $ GO TO 240
+ IF( L.EQ.1 ) THEN
+ L1 = L
+ L2 = L
+ ELSE
+ IF( B( L, L-1 ).NE.ZERO ) THEN
+ L1 = L - 1
+ L2 = L
+ LNEXT = L - 2
+ ELSE
+ L1 = L
+ L2 = L
+ LNEXT = L - 1
+ END IF
+ END IF
+*
+* Start row loop (index = K)
+* K1 (K2): row index of the first (last) row of X(K,L)
+*
+ KNEXT = M
+ DO 230 K = M, 1, -1
+ IF( K.GT.KNEXT )
+ $ GO TO 230
+ IF( K.EQ.1 ) THEN
+ K1 = K
+ K2 = K
+ ELSE
+ IF( A( K, K-1 ).NE.ZERO ) THEN
+ K1 = K - 1
+ K2 = K
+ KNEXT = K - 2
+ ELSE
+ K1 = K
+ K2 = K
+ KNEXT = K - 1
+ END IF
+ END IF
+*
+ IF( L1.EQ.L2 .AND. K1.EQ.K2 ) THEN
+ SUML = DDOT( M-K1, A( K1, MIN( K1+1, M ) ), LDA,
+ $ C( MIN( K1+1, M ), L1 ), 1 )
+ SUMR = DDOT( N-L1, C( K1, MIN( L1+1, N ) ), LDC,
+ $ B( L1, MIN( L1+1, N ) ), LDB )
+ VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR )
+ SCALOC = ONE
+*
+ A11 = A( K1, K1 ) + SGN*B( L1, L1 )
+ DA11 = ABS( A11 )
+ IF( DA11.LE.SMIN ) THEN
+ A11 = SMIN
+ DA11 = SMIN
+ INFO = 1
+ END IF
+ DB = ABS( VEC( 1, 1 ) )
+ IF( DA11.LT.ONE .AND. DB.GT.ONE ) THEN
+ IF( DB.GT.BIGNUM*DA11 )
+ $ SCALOC = ONE / DB
+ END IF
+ X( 1, 1 ) = ( VEC( 1, 1 )*SCALOC ) / A11
+*
+ IF( SCALOC.NE.ONE ) THEN
+ DO 190 J = 1, N
+ CALL DSCAL( M, SCALOC, C( 1, J ), 1 )
+ 190 CONTINUE
+ SCALE = SCALE*SCALOC
+ END IF
+ C( K1, L1 ) = X( 1, 1 )
+*
+ ELSE IF( L1.EQ.L2 .AND. K1.NE.K2 ) THEN
+*
+ SUML = DDOT( M-K2, A( K1, MIN( K2+1, M ) ), LDA,
+ $ C( MIN( K2+1, M ), L1 ), 1 )
+ SUMR = DDOT( N-L2, C( K1, MIN( L2+1, N ) ), LDC,
+ $ B( L1, MIN( L2+1, N ) ), LDB )
+ VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR )
+*
+ SUML = DDOT( M-K2, A( K2, MIN( K2+1, M ) ), LDA,
+ $ C( MIN( K2+1, M ), L1 ), 1 )
+ SUMR = DDOT( N-L2, C( K2, MIN( L2+1, N ) ), LDC,
+ $ B( L1, MIN( L2+1, N ) ), LDB )
+ VEC( 2, 1 ) = C( K2, L1 ) - ( SUML+SGN*SUMR )
+*
+ CALL DLALN2( .FALSE., 2, 1, SMIN, ONE, A( K1, K1 ),
+ $ LDA, ONE, ONE, VEC, 2, -SGN*B( L1, L1 ),
+ $ ZERO, X, 2, SCALOC, XNORM, IERR )
+ IF( IERR.NE.0 )
+ $ INFO = 1
+*
+ IF( SCALOC.NE.ONE ) THEN
+ DO 200 J = 1, N
+ CALL DSCAL( M, SCALOC, C( 1, J ), 1 )
+ 200 CONTINUE
+ SCALE = SCALE*SCALOC
+ END IF
+ C( K1, L1 ) = X( 1, 1 )
+ C( K2, L1 ) = X( 2, 1 )
+*
+ ELSE IF( L1.NE.L2 .AND. K1.EQ.K2 ) THEN
+*
+ SUML = DDOT( M-K1, A( K1, MIN( K1+1, M ) ), LDA,
+ $ C( MIN( K1+1, M ), L1 ), 1 )
+ SUMR = DDOT( N-L2, C( K1, MIN( L2+1, N ) ), LDC,
+ $ B( L1, MIN( L2+1, N ) ), LDB )
+ VEC( 1, 1 ) = SGN*( C( K1, L1 )-( SUML+SGN*SUMR ) )
+*
+ SUML = DDOT( M-K1, A( K1, MIN( K1+1, M ) ), LDA,
+ $ C( MIN( K1+1, M ), L2 ), 1 )
+ SUMR = DDOT( N-L2, C( K1, MIN( L2+1, N ) ), LDC,
+ $ B( L2, MIN( L2+1, N ) ), LDB )
+ VEC( 2, 1 ) = SGN*( C( K1, L2 )-( SUML+SGN*SUMR ) )
+*
+ CALL DLALN2( .FALSE., 2, 1, SMIN, ONE, B( L1, L1 ),
+ $ LDB, ONE, ONE, VEC, 2, -SGN*A( K1, K1 ),
+ $ ZERO, X, 2, SCALOC, XNORM, IERR )
+ IF( IERR.NE.0 )
+ $ INFO = 1
+*
+ IF( SCALOC.NE.ONE ) THEN
+ DO 210 J = 1, N
+ CALL DSCAL( M, SCALOC, C( 1, J ), 1 )
+ 210 CONTINUE
+ SCALE = SCALE*SCALOC
+ END IF
+ C( K1, L1 ) = X( 1, 1 )
+ C( K1, L2 ) = X( 2, 1 )
+*
+ ELSE IF( L1.NE.L2 .AND. K1.NE.K2 ) THEN
+*
+ SUML = DDOT( M-K2, A( K1, MIN( K2+1, M ) ), LDA,
+ $ C( MIN( K2+1, M ), L1 ), 1 )
+ SUMR = DDOT( N-L2, C( K1, MIN( L2+1, N ) ), LDC,
+ $ B( L1, MIN( L2+1, N ) ), LDB )
+ VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR )
+*
+ SUML = DDOT( M-K2, A( K1, MIN( K2+1, M ) ), LDA,
+ $ C( MIN( K2+1, M ), L2 ), 1 )
+ SUMR = DDOT( N-L2, C( K1, MIN( L2+1, N ) ), LDC,
+ $ B( L2, MIN( L2+1, N ) ), LDB )
+ VEC( 1, 2 ) = C( K1, L2 ) - ( SUML+SGN*SUMR )
+*
+ SUML = DDOT( M-K2, A( K2, MIN( K2+1, M ) ), LDA,
+ $ C( MIN( K2+1, M ), L1 ), 1 )
+ SUMR = DDOT( N-L2, C( K2, MIN( L2+1, N ) ), LDC,
+ $ B( L1, MIN( L2+1, N ) ), LDB )
+ VEC( 2, 1 ) = C( K2, L1 ) - ( SUML+SGN*SUMR )
+*
+ SUML = DDOT( M-K2, A( K2, MIN( K2+1, M ) ), LDA,
+ $ C( MIN( K2+1, M ), L2 ), 1 )
+ SUMR = DDOT( N-L2, C( K2, MIN( L2+1, N ) ), LDC,
+ $ B( L2, MIN( L2+1, N ) ), LDB )
+ VEC( 2, 2 ) = C( K2, L2 ) - ( SUML+SGN*SUMR )
+*
+ CALL DLASY2( .FALSE., .TRUE., ISGN, 2, 2, A( K1, K1 ),
+ $ LDA, B( L1, L1 ), LDB, VEC, 2, SCALOC, X,
+ $ 2, XNORM, IERR )
+ IF( IERR.NE.0 )
+ $ INFO = 1
+*
+ IF( SCALOC.NE.ONE ) THEN
+ DO 220 J = 1, N
+ CALL DSCAL( M, SCALOC, C( 1, J ), 1 )
+ 220 CONTINUE
+ SCALE = SCALE*SCALOC
+ END IF
+ C( K1, L1 ) = X( 1, 1 )
+ C( K1, L2 ) = X( 1, 2 )
+ C( K2, L1 ) = X( 2, 1 )
+ C( K2, L2 ) = X( 2, 2 )
+ END IF
+*
+ 230 CONTINUE
+ 240 CONTINUE
+*
+ END IF
+*
+ RETURN
+*
+* End of DTRSYL
+*
+ END
+ SUBROUTINE DTRTI2( UPLO, DIAG, N, A, LDA, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER DIAG, UPLO
+ INTEGER INFO, LDA, N
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION A( LDA, * )
+* ..
+*
+* Purpose
+* =======
+*
+* DTRTI2 computes the inverse of a real upper or lower triangular
+* matrix.
+*
+* This is the Level 2 BLAS version of the algorithm.
+*
+* Arguments
+* =========
+*
+* UPLO (input) CHARACTER*1
+* Specifies whether the matrix A is upper or lower triangular.
+* = 'U': Upper triangular
+* = 'L': Lower triangular
+*
+* DIAG (input) CHARACTER*1
+* Specifies whether or not the matrix A is unit triangular.
+* = 'N': Non-unit triangular
+* = 'U': Unit triangular
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+* On entry, the triangular matrix A. If UPLO = 'U', the
+* leading n by n upper triangular part of the array A contains
+* the upper triangular matrix, and the strictly lower
+* triangular part of A is not referenced. If UPLO = 'L', the
+* leading n by n lower triangular part of the array A contains
+* the lower triangular matrix, and the strictly upper
+* triangular part of A is not referenced. If DIAG = 'U', the
+* diagonal elements of A are also not referenced and are
+* assumed to be 1.
+*
+* On exit, the (triangular) inverse of the original matrix, in
+* the same storage format.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,N).
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -k, the k-th argument had an illegal value
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE
+ PARAMETER ( ONE = 1.0D+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL NOUNIT, UPPER
+ INTEGER J
+ DOUBLE PRECISION AJJ
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL DSCAL, DTRMV, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ NOUNIT = LSAME( DIAG, 'N' )
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
+ INFO = -2
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -5
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DTRTI2', -INFO )
+ RETURN
+ END IF
+*
+ IF( UPPER ) THEN
+*
+* Compute inverse of upper triangular matrix.
+*
+ DO 10 J = 1, N
+ IF( NOUNIT ) THEN
+ A( J, J ) = ONE / A( J, J )
+ AJJ = -A( J, J )
+ ELSE
+ AJJ = -ONE
+ END IF
+*
+* Compute elements 1:j-1 of j-th column.
+*
+ CALL DTRMV( 'Upper', 'No transpose', DIAG, J-1, A, LDA,
+ $ A( 1, J ), 1 )
+ CALL DSCAL( J-1, AJJ, A( 1, J ), 1 )
+ 10 CONTINUE
+ ELSE
+*
+* Compute inverse of lower triangular matrix.
+*
+ DO 20 J = N, 1, -1
+ IF( NOUNIT ) THEN
+ A( J, J ) = ONE / A( J, J )
+ AJJ = -A( J, J )
+ ELSE
+ AJJ = -ONE
+ END IF
+ IF( J.LT.N ) THEN
+*
+* Compute elements j+1:n of j-th column.
+*
+ CALL DTRMV( 'Lower', 'No transpose', DIAG, N-J,
+ $ A( J+1, J+1 ), LDA, A( J+1, J ), 1 )
+ CALL DSCAL( N-J, AJJ, A( J+1, J ), 1 )
+ END IF
+ 20 CONTINUE
+ END IF
+*
+ RETURN
+*
+* End of DTRTI2
+*
+ END
+ SUBROUTINE DTRTRI( UPLO, DIAG, N, A, LDA, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER DIAG, UPLO
+ INTEGER INFO, LDA, N
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION A( LDA, * )
+* ..
+*
+* Purpose
+* =======
+*
+* DTRTRI computes the inverse of a real upper or lower triangular
+* matrix A.
+*
+* This is the Level 3 BLAS version of the algorithm.
+*
+* Arguments
+* =========
+*
+* UPLO (input) CHARACTER*1
+* = 'U': A is upper triangular;
+* = 'L': A is lower triangular.
+*
+* DIAG (input) CHARACTER*1
+* = 'N': A is non-unit triangular;
+* = 'U': A is unit triangular.
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+* On entry, the triangular matrix A. If UPLO = 'U', the
+* leading N-by-N upper triangular part of the array A contains
+* the upper triangular matrix, and the strictly lower
+* triangular part of A is not referenced. If UPLO = 'L', the
+* leading N-by-N lower triangular part of the array A contains
+* the lower triangular matrix, and the strictly upper
+* triangular part of A is not referenced. If DIAG = 'U', the
+* diagonal elements of A are also not referenced and are
+* assumed to be 1.
+* On exit, the (triangular) inverse of the original matrix, in
+* the same storage format.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,N).
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* > 0: if INFO = i, A(i,i) is exactly zero. The triangular
+* matrix is singular and its inverse can not be computed.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE, ZERO
+ PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL NOUNIT, UPPER
+ INTEGER J, JB, NB, NN
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ILAENV
+ EXTERNAL LSAME, ILAENV
+* ..
+* .. External Subroutines ..
+ EXTERNAL DTRMM, DTRSM, DTRTI2, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ NOUNIT = LSAME( DIAG, 'N' )
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
+ INFO = -2
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -5
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DTRTRI', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+* Check for singularity if non-unit.
+*
+ IF( NOUNIT ) THEN
+ DO 10 INFO = 1, N
+ IF( A( INFO, INFO ).EQ.ZERO )
+ $ RETURN
+ 10 CONTINUE
+ INFO = 0
+ END IF
+*
+* Determine the block size for this environment.
+*
+ NB = ILAENV( 1, 'DTRTRI', UPLO // DIAG, N, -1, -1, -1 )
+ IF( NB.LE.1 .OR. NB.GE.N ) THEN
+*
+* Use unblocked code
+*
+ CALL DTRTI2( UPLO, DIAG, N, A, LDA, INFO )
+ ELSE
+*
+* Use blocked code
+*
+ IF( UPPER ) THEN
+*
+* Compute inverse of upper triangular matrix
+*
+ DO 20 J = 1, N, NB
+ JB = MIN( NB, N-J+1 )
+*
+* Compute rows 1:j-1 of current block column
+*
+ CALL DTRMM( 'Left', 'Upper', 'No transpose', DIAG, J-1,
+ $ JB, ONE, A, LDA, A( 1, J ), LDA )
+ CALL DTRSM( 'Right', 'Upper', 'No transpose', DIAG, J-1,
+ $ JB, -ONE, A( J, J ), LDA, A( 1, J ), LDA )
+*
+* Compute inverse of current diagonal block
+*
+ CALL DTRTI2( 'Upper', DIAG, JB, A( J, J ), LDA, INFO )
+ 20 CONTINUE
+ ELSE
+*
+* Compute inverse of lower triangular matrix
+*
+ NN = ( ( N-1 ) / NB )*NB + 1
+ DO 30 J = NN, 1, -NB
+ JB = MIN( NB, N-J+1 )
+ IF( J+JB.LE.N ) THEN
+*
+* Compute rows j+jb:n of current block column
+*
+ CALL DTRMM( 'Left', 'Lower', 'No transpose', DIAG,
+ $ N-J-JB+1, JB, ONE, A( J+JB, J+JB ), LDA,
+ $ A( J+JB, J ), LDA )
+ CALL DTRSM( 'Right', 'Lower', 'No transpose', DIAG,
+ $ N-J-JB+1, JB, -ONE, A( J, J ), LDA,
+ $ A( J+JB, J ), LDA )
+ END IF
+*
+* Compute inverse of current diagonal block
+*
+ CALL DTRTI2( 'Lower', DIAG, JB, A( J, J ), LDA, INFO )
+ 30 CONTINUE
+ END IF
+ END IF
+*
+ RETURN
+*
+* End of DTRTRI
+*
+ END
+ SUBROUTINE DTRTRS( UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB,
+ $ INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER DIAG, TRANS, UPLO
+ INTEGER INFO, LDA, LDB, N, NRHS
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION A( LDA, * ), B( LDB, * )
+* ..
+*
+* Purpose
+* =======
+*
+* DTRTRS solves a triangular system of the form
+*
+* A * X = B or A**T * X = B,
+*
+* where A is a triangular matrix of order N, and B is an N-by-NRHS
+* matrix. A check is made to verify that A is nonsingular.
+*
+* Arguments
+* =========
+*
+* UPLO (input) CHARACTER*1
+* = 'U': A is upper triangular;
+* = 'L': A is lower triangular.
+*
+* TRANS (input) CHARACTER*1
+* Specifies the form of the system of equations:
+* = 'N': A * X = B (No transpose)
+* = 'T': A**T * X = B (Transpose)
+* = 'C': A**H * X = B (Conjugate transpose = Transpose)
+*
+* DIAG (input) CHARACTER*1
+* = 'N': A is non-unit triangular;
+* = 'U': A is unit triangular.
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* NRHS (input) INTEGER
+* The number of right hand sides, i.e., the number of columns
+* of the matrix B. NRHS >= 0.
+*
+* A (input) DOUBLE PRECISION array, dimension (LDA,N)
+* The triangular matrix A. If UPLO = 'U', the leading N-by-N
+* upper triangular part of the array A contains the upper
+* triangular matrix, and the strictly lower triangular part of
+* A is not referenced. If UPLO = 'L', the leading N-by-N lower
+* triangular part of the array A contains the lower triangular
+* matrix, and the strictly upper triangular part of A is not
+* referenced. If DIAG = 'U', the diagonal elements of A are
+* also not referenced and are assumed to be 1.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,N).
+*
+* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
+* On entry, the right hand side matrix B.
+* On exit, if INFO = 0, the solution matrix X.
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. LDB >= max(1,N).
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* > 0: if INFO = i, the i-th diagonal element of A is zero,
+* indicating that the matrix is singular and the solutions
+* X have not been computed.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL NOUNIT
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL DTRSM, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ NOUNIT = LSAME( DIAG, 'N' )
+ IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( .NOT.LSAME( TRANS, 'N' ) .AND. .NOT.
+ $ LSAME( TRANS, 'T' ) .AND. .NOT.LSAME( TRANS, 'C' ) ) THEN
+ INFO = -2
+ ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
+ INFO = -3
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( NRHS.LT.0 ) THEN
+ INFO = -5
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -7
+ ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -9
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DTRTRS', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+* Check for singularity.
+*
+ IF( NOUNIT ) THEN
+ DO 10 INFO = 1, N
+ IF( A( INFO, INFO ).EQ.ZERO )
+ $ RETURN
+ 10 CONTINUE
+ END IF
+ INFO = 0
+*
+* Solve A * x = b or A' * x = b.
+*
+ CALL DTRSM( 'Left', UPLO, TRANS, DIAG, N, NRHS, ONE, A, LDA, B,
+ $ LDB )
+*
+ RETURN
+*
+* End of DTRTRS
+*
+ END
+ SUBROUTINE DTZRQF( M, N, A, LDA, TAU, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LDA, M, N
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION A( LDA, * ), TAU( * )
+* ..
+*
+* Purpose
+* =======
+*
+* This routine is deprecated and has been replaced by routine DTZRZF.
+*
+* DTZRQF reduces the M-by-N ( M<=N ) real upper trapezoidal matrix A
+* to upper triangular form by means of orthogonal transformations.
+*
+* The upper trapezoidal matrix A is factored as
+*
+* A = ( R 0 ) * Z,
+*
+* where Z is an N-by-N orthogonal matrix and R is an M-by-M upper
+* triangular matrix.
+*
+* Arguments
+* =========
+*
+* M (input) INTEGER
+* The number of rows of the matrix A. M >= 0.
+*
+* N (input) INTEGER
+* The number of columns of the matrix A. N >= M.
+*
+* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+* On entry, the leading M-by-N upper trapezoidal part of the
+* array A must contain the matrix to be factorized.
+* On exit, the leading M-by-M upper triangular part of A
+* contains the upper triangular matrix R, and elements M+1 to
+* N of the first M rows of A, with the array TAU, represent the
+* orthogonal matrix Z as a product of M elementary reflectors.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,M).
+*
+* TAU (output) DOUBLE PRECISION array, dimension (M)
+* The scalar factors of the elementary reflectors.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+*
+* Further Details
+* ===============
+*
+* The factorization is obtained by Householder's method. The kth
+* transformation matrix, Z( k ), which is used to introduce zeros into
+* the ( m - k + 1 )th row of A, is given in the form
+*
+* Z( k ) = ( I 0 ),
+* ( 0 T( k ) )
+*
+* where
+*
+* T( k ) = I - tau*u( k )*u( k )', u( k ) = ( 1 ),
+* ( 0 )
+* ( z( k ) )
+*
+* tau is a scalar and z( k ) is an ( n - m ) element vector.
+* tau and z( k ) are chosen to annihilate the elements of the kth row
+* of X.
+*
+* The scalar tau is returned in the kth element of TAU and the vector
+* u( k ) in the kth row of A, such that the elements of z( k ) are
+* in a( k, m + 1 ), ..., a( k, n ). The elements of R are returned in
+* the upper triangular part of A.
+*
+* Z is given by
+*
+* Z = Z( 1 ) * Z( 2 ) * ... * Z( m ).
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE, ZERO
+ PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, K, M1
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN
+* ..
+* .. External Subroutines ..
+ EXTERNAL DAXPY, DCOPY, DGEMV, DGER, DLARFG, XERBLA
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ IF( M.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( N.LT.M ) THEN
+ INFO = -2
+ ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+ INFO = -4
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DTZRQF', -INFO )
+ RETURN
+ END IF
+*
+* Perform the factorization.
+*
+ IF( M.EQ.0 )
+ $ RETURN
+ IF( M.EQ.N ) THEN
+ DO 10 I = 1, N
+ TAU( I ) = ZERO
+ 10 CONTINUE
+ ELSE
+ M1 = MIN( M+1, N )
+ DO 20 K = M, 1, -1
+*
+* Use a Householder reflection to zero the kth row of A.
+* First set up the reflection.
+*
+ CALL DLARFG( N-M+1, A( K, K ), A( K, M1 ), LDA, TAU( K ) )
+*
+ IF( ( TAU( K ).NE.ZERO ) .AND. ( K.GT.1 ) ) THEN
+*
+* We now perform the operation A := A*P( k ).
+*
+* Use the first ( k - 1 ) elements of TAU to store a( k ),
+* where a( k ) consists of the first ( k - 1 ) elements of
+* the kth column of A. Also let B denote the first
+* ( k - 1 ) rows of the last ( n - m ) columns of A.
+*
+ CALL DCOPY( K-1, A( 1, K ), 1, TAU, 1 )
+*
+* Form w = a( k ) + B*z( k ) in TAU.
+*
+ CALL DGEMV( 'No transpose', K-1, N-M, ONE, A( 1, M1 ),
+ $ LDA, A( K, M1 ), LDA, ONE, TAU, 1 )
+*
+* Now form a( k ) := a( k ) - tau*w
+* and B := B - tau*w*z( k )'.
+*
+ CALL DAXPY( K-1, -TAU( K ), TAU, 1, A( 1, K ), 1 )
+ CALL DGER( K-1, N-M, -TAU( K ), TAU, 1, A( K, M1 ), LDA,
+ $ A( 1, M1 ), LDA )
+ END IF
+ 20 CONTINUE
+ END IF
+*
+ RETURN
+*
+* End of DTZRQF
+*
+ END
+ SUBROUTINE DTZRZF( M, N, A, LDA, TAU, WORK, LWORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LDA, LWORK, M, N
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DTZRZF reduces the M-by-N ( M<=N ) real upper trapezoidal matrix A
+* to upper triangular form by means of orthogonal transformations.
+*
+* The upper trapezoidal matrix A is factored as
+*
+* A = ( R 0 ) * Z,
+*
+* where Z is an N-by-N orthogonal matrix and R is an M-by-M upper
+* triangular matrix.
+*
+* Arguments
+* =========
+*
+* M (input) INTEGER
+* The number of rows of the matrix A. M >= 0.
+*
+* N (input) INTEGER
+* The number of columns of the matrix A. N >= M.
+*
+* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+* On entry, the leading M-by-N upper trapezoidal part of the
+* array A must contain the matrix to be factorized.
+* On exit, the leading M-by-M upper triangular part of A
+* contains the upper triangular matrix R, and elements M+1 to
+* N of the first M rows of A, with the array TAU, represent the
+* orthogonal matrix Z as a product of M elementary reflectors.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,M).
+*
+* TAU (output) DOUBLE PRECISION array, dimension (M)
+* The scalar factors of the elementary reflectors.
+*
+* WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK))
+* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+* LWORK (input) INTEGER
+* The dimension of the array WORK. LWORK >= max(1,M).
+* For optimum performance LWORK >= M*NB, where NB is
+* the optimal blocksize.
+*
+* If LWORK = -1, then a workspace query is assumed; the routine
+* only calculates the optimal size of the WORK array, returns
+* this value as the first entry of the WORK array, and no error
+* message related to LWORK is issued by XERBLA.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+*
+* Further Details
+* ===============
+*
+* Based on contributions by
+* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA
+*
+* The factorization is obtained by Householder's method. The kth
+* transformation matrix, Z( k ), which is used to introduce zeros into
+* the ( m - k + 1 )th row of A, is given in the form
+*
+* Z( k ) = ( I 0 ),
+* ( 0 T( k ) )
+*
+* where
+*
+* T( k ) = I - tau*u( k )*u( k )', u( k ) = ( 1 ),
+* ( 0 )
+* ( z( k ) )
+*
+* tau is a scalar and z( k ) is an ( n - m ) element vector.
+* tau and z( k ) are chosen to annihilate the elements of the kth row
+* of X.
+*
+* The scalar tau is returned in the kth element of TAU and the vector
+* u( k ) in the kth row of A, such that the elements of z( k ) are
+* in a( k, m + 1 ), ..., a( k, n ). The elements of R are returned in
+* the upper triangular part of A.
+*
+* Z is given by
+*
+* Z = Z( 1 ) * Z( 2 ) * ... * Z( m ).
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO
+ PARAMETER ( ZERO = 0.0D+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL LQUERY
+ INTEGER I, IB, IWS, KI, KK, LDWORK, LWKOPT, M1, MU, NB,
+ $ NBMIN, NX
+* ..
+* .. External Subroutines ..
+ EXTERNAL DLARZB, DLARZT, DLATRZ, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN
+* ..
+* .. External Functions ..
+ INTEGER ILAENV
+ EXTERNAL ILAENV
+* ..
+* .. Executable Statements ..
+*
+* Test the input arguments
+*
+ INFO = 0
+ LQUERY = ( LWORK.EQ.-1 )
+ IF( M.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( N.LT.M ) THEN
+ INFO = -2
+ ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+ INFO = -4
+ END IF
+*
+ IF( INFO.EQ.0 ) THEN
+ IF( M.EQ.0 .OR. M.EQ.N ) THEN
+ LWKOPT = 1
+ ELSE
+*
+* Determine the block size.
+*
+ NB = ILAENV( 1, 'DGERQF', ' ', M, N, -1, -1 )
+ LWKOPT = M*NB
+ END IF
+ WORK( 1 ) = LWKOPT
+*
+ IF( LWORK.LT.MAX( 1, M ) .AND. .NOT.LQUERY ) THEN
+ INFO = -7
+ END IF
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DTZRZF', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( M.EQ.0 ) THEN
+ RETURN
+ ELSE IF( M.EQ.N ) THEN
+ DO 10 I = 1, N
+ TAU( I ) = ZERO
+ 10 CONTINUE
+ RETURN
+ END IF
+*
+ NBMIN = 2
+ NX = 1
+ IWS = M
+ IF( NB.GT.1 .AND. NB.LT.M ) THEN
+*
+* Determine when to cross over from blocked to unblocked code.
+*
+ NX = MAX( 0, ILAENV( 3, 'DGERQF', ' ', M, N, -1, -1 ) )
+ IF( NX.LT.M ) THEN
+*
+* Determine if workspace is large enough for blocked code.
+*
+ LDWORK = M
+ IWS = LDWORK*NB
+ IF( LWORK.LT.IWS ) THEN
+*
+* Not enough workspace to use optimal NB: reduce NB and
+* determine the minimum value of NB.
+*
+ NB = LWORK / LDWORK
+ NBMIN = MAX( 2, ILAENV( 2, 'DGERQF', ' ', M, N, -1,
+ $ -1 ) )
+ END IF
+ END IF
+ END IF
+*
+ IF( NB.GE.NBMIN .AND. NB.LT.M .AND. NX.LT.M ) THEN
+*
+* Use blocked code initially.
+* The last kk rows are handled by the block method.
+*
+ M1 = MIN( M+1, N )
+ KI = ( ( M-NX-1 ) / NB )*NB
+ KK = MIN( M, KI+NB )
+*
+ DO 20 I = M - KK + KI + 1, M - KK + 1, -NB
+ IB = MIN( M-I+1, NB )
+*
+* Compute the TZ factorization of the current block
+* A(i:i+ib-1,i:n)
+*
+ CALL DLATRZ( IB, N-I+1, N-M, A( I, I ), LDA, TAU( I ),
+ $ WORK )
+ IF( I.GT.1 ) THEN
+*
+* Form the triangular factor of the block reflector
+* H = H(i+ib-1) . . . H(i+1) H(i)
+*
+ CALL DLARZT( 'Backward', 'Rowwise', N-M, IB, A( I, M1 ),
+ $ LDA, TAU( I ), WORK, LDWORK )
+*
+* Apply H to A(1:i-1,i:n) from the right
+*
+ CALL DLARZB( 'Right', 'No transpose', 'Backward',
+ $ 'Rowwise', I-1, N-I+1, IB, N-M, A( I, M1 ),
+ $ LDA, WORK, LDWORK, A( 1, I ), LDA,
+ $ WORK( IB+1 ), LDWORK )
+ END IF
+ 20 CONTINUE
+ MU = I + NB - 1
+ ELSE
+ MU = M
+ END IF
+*
+* Use unblocked code to factor the last or only block
+*
+ IF( MU.GT.0 )
+ $ CALL DLATRZ( MU, N, N-M, A, LDA, TAU, WORK )
+*
+ WORK( 1 ) = LWKOPT
+*
+ RETURN
+*
+* End of DTZRZF
+*
+ END
+ INTEGER FUNCTION IEEECK( ISPEC, ZERO, ONE )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER ISPEC
+ REAL ONE, ZERO
+* ..
+*
+* Purpose
+* =======
+*
+* IEEECK is called from the ILAENV to verify that Infinity and
+* possibly NaN arithmetic is safe (i.e. will not trap).
+*
+* Arguments
+* =========
+*
+* ISPEC (input) INTEGER
+* Specifies whether to test just for inifinity arithmetic
+* or whether to test for infinity and NaN arithmetic.
+* = 0: Verify infinity arithmetic only.
+* = 1: Verify infinity and NaN arithmetic.
+*
+* ZERO (input) REAL
+* Must contain the value 0.0
+* This is passed to prevent the compiler from optimizing
+* away this code.
+*
+* ONE (input) REAL
+* Must contain the value 1.0
+* This is passed to prevent the compiler from optimizing
+* away this code.
+*
+* RETURN VALUE: INTEGER
+* = 0: Arithmetic failed to produce the correct answers
+* = 1: Arithmetic produced the correct answers
+*
+* .. Local Scalars ..
+ REAL NAN1, NAN2, NAN3, NAN4, NAN5, NAN6, NEGINF,
+ $ NEGZRO, NEWZRO, POSINF
+* ..
+* .. Executable Statements ..
+ IEEECK = 1
+*
+ POSINF = ONE / ZERO
+ IF( POSINF.LE.ONE ) THEN
+ IEEECK = 0
+ RETURN
+ END IF
+*
+ NEGINF = -ONE / ZERO
+ IF( NEGINF.GE.ZERO ) THEN
+ IEEECK = 0
+ RETURN
+ END IF
+*
+ NEGZRO = ONE / ( NEGINF+ONE )
+ IF( NEGZRO.NE.ZERO ) THEN
+ IEEECK = 0
+ RETURN
+ END IF
+*
+ NEGINF = ONE / NEGZRO
+ IF( NEGINF.GE.ZERO ) THEN
+ IEEECK = 0
+ RETURN
+ END IF
+*
+ NEWZRO = NEGZRO + ZERO
+ IF( NEWZRO.NE.ZERO ) THEN
+ IEEECK = 0
+ RETURN
+ END IF
+*
+ POSINF = ONE / NEWZRO
+ IF( POSINF.LE.ONE ) THEN
+ IEEECK = 0
+ RETURN
+ END IF
+*
+ NEGINF = NEGINF*POSINF
+ IF( NEGINF.GE.ZERO ) THEN
+ IEEECK = 0
+ RETURN
+ END IF
+*
+ POSINF = POSINF*POSINF
+ IF( POSINF.LE.ONE ) THEN
+ IEEECK = 0
+ RETURN
+ END IF
+*
+*
+*
+*
+* Return if we were only asked to check infinity arithmetic
+*
+ IF( ISPEC.EQ.0 )
+ $ RETURN
+*
+ NAN1 = POSINF + NEGINF
+*
+ NAN2 = POSINF / NEGINF
+*
+ NAN3 = POSINF / POSINF
+*
+ NAN4 = POSINF*ZERO
+*
+ NAN5 = NEGINF*NEGZRO
+*
+ NAN6 = NAN5*0.0
+*
+ IF( NAN1.EQ.NAN1 ) THEN
+ IEEECK = 0
+ RETURN
+ END IF
+*
+ IF( NAN2.EQ.NAN2 ) THEN
+ IEEECK = 0
+ RETURN
+ END IF
+*
+ IF( NAN3.EQ.NAN3 ) THEN
+ IEEECK = 0
+ RETURN
+ END IF
+*
+ IF( NAN4.EQ.NAN4 ) THEN
+ IEEECK = 0
+ RETURN
+ END IF
+*
+ IF( NAN5.EQ.NAN5 ) THEN
+ IEEECK = 0
+ RETURN
+ END IF
+*
+ IF( NAN6.EQ.NAN6 ) THEN
+ IEEECK = 0
+ RETURN
+ END IF
+*
+ RETURN
+ END
+ INTEGER FUNCTION ILAENV( ISPEC, NAME, OPTS, N1, N2, N3, N4 )
+*
+* -- LAPACK auxiliary routine (version 3.1.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* January 2007
+*
+* .. Scalar Arguments ..
+ CHARACTER*( * ) NAME, OPTS
+ INTEGER ISPEC, N1, N2, N3, N4
+* ..
+*
+* Purpose
+* =======
+*
+* ILAENV is called from the LAPACK routines to choose problem-dependent
+* parameters for the local environment. See ISPEC for a description of
+* the parameters.
+*
+* ILAENV returns an INTEGER
+* if ILAENV >= 0: ILAENV returns the value of the parameter specified by ISPEC
+* if ILAENV < 0: if ILAENV = -k, the k-th argument had an illegal value.
+*
+* This version provides a set of parameters which should give good,
+* but not optimal, performance on many of the currently available
+* computers. Users are encouraged to modify this subroutine to set
+* the tuning parameters for their particular machine using the option
+* and problem size information in the arguments.
+*
+* This routine will not function correctly if it is converted to all
+* lower case. Converting it to all upper case is allowed.
+*
+* Arguments
+* =========
+*
+* ISPEC (input) INTEGER
+* Specifies the parameter to be returned as the value of
+* ILAENV.
+* = 1: the optimal blocksize; if this value is 1, an unblocked
+* algorithm will give the best performance.
+* = 2: the minimum block size for which the block routine
+* should be used; if the usable block size is less than
+* this value, an unblocked routine should be used.
+* = 3: the crossover point (in a block routine, for N less
+* than this value, an unblocked routine should be used)
+* = 4: the number of shifts, used in the nonsymmetric
+* eigenvalue routines (DEPRECATED)
+* = 5: the minimum column dimension for blocking to be used;
+* rectangular blocks must have dimension at least k by m,
+* where k is given by ILAENV(2,...) and m by ILAENV(5,...)
+* = 6: the crossover point for the SVD (when reducing an m by n
+* matrix to bidiagonal form, if max(m,n)/min(m,n) exceeds
+* this value, a QR factorization is used first to reduce
+* the matrix to a triangular form.)
+* = 7: the number of processors
+* = 8: the crossover point for the multishift QR method
+* for nonsymmetric eigenvalue problems (DEPRECATED)
+* = 9: maximum size of the subproblems at the bottom of the
+* computation tree in the divide-and-conquer algorithm
+* (used by xGELSD and xGESDD)
+* =10: ieee NaN arithmetic can be trusted not to trap
+* =11: infinity arithmetic can be trusted not to trap
+* 12 <= ISPEC <= 16:
+* xHSEQR or one of its subroutines,
+* see IPARMQ for detailed explanation
+*
+* NAME (input) CHARACTER*(*)
+* The name of the calling subroutine, in either upper case or
+* lower case.
+*
+* OPTS (input) CHARACTER*(*)
+* The character options to the subroutine NAME, concatenated
+* into a single character string. For example, UPLO = 'U',
+* TRANS = 'T', and DIAG = 'N' for a triangular routine would
+* be specified as OPTS = 'UTN'.
+*
+* N1 (input) INTEGER
+* N2 (input) INTEGER
+* N3 (input) INTEGER
+* N4 (input) INTEGER
+* Problem dimensions for the subroutine NAME; these may not all
+* be required.
+*
+* Further Details
+* ===============
+*
+* The following conventions have been used when calling ILAENV from the
+* LAPACK routines:
+* 1) OPTS is a concatenation of all of the character options to
+* subroutine NAME, in the same order that they appear in the
+* argument list for NAME, even if they are not used in determining
+* the value of the parameter specified by ISPEC.
+* 2) The problem dimensions N1, N2, N3, N4 are specified in the order
+* that they appear in the argument list for NAME. N1 is used
+* first, N2 second, and so on, and unused problem dimensions are
+* passed a value of -1.
+* 3) The parameter value returned by ILAENV is checked for validity in
+* the calling subroutine. For example, ILAENV is used to retrieve
+* the optimal blocksize for STRTRI as follows:
+*
+* NB = ILAENV( 1, 'STRTRI', UPLO // DIAG, N, -1, -1, -1 )
+* IF( NB.LE.1 ) NB = MAX( 1, N )
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ INTEGER I, IC, IZ, NB, NBMIN, NX
+ LOGICAL CNAME, SNAME
+ CHARACTER C1*1, C2*2, C4*2, C3*3, SUBNAM*6
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC CHAR, ICHAR, INT, MIN, REAL
+* ..
+* .. External Functions ..
+ INTEGER IEEECK, IPARMQ
+ EXTERNAL IEEECK, IPARMQ
+* ..
+* .. Executable Statements ..
+*
+ GO TO ( 10, 10, 10, 80, 90, 100, 110, 120,
+ $ 130, 140, 150, 160, 160, 160, 160, 160 )ISPEC
+*
+* Invalid value for ISPEC
+*
+ ILAENV = -1
+ RETURN
+*
+ 10 CONTINUE
+*
+* Convert NAME to upper case if the first character is lower case.
+*
+ ILAENV = 1
+ SUBNAM = NAME
+ IC = ICHAR( SUBNAM( 1: 1 ) )
+ IZ = ICHAR( 'Z' )
+ IF( IZ.EQ.90 .OR. IZ.EQ.122 ) THEN
+*
+* ASCII character set
+*
+ IF( IC.GE.97 .AND. IC.LE.122 ) THEN
+ SUBNAM( 1: 1 ) = CHAR( IC-32 )
+ DO 20 I = 2, 6
+ IC = ICHAR( SUBNAM( I: I ) )
+ IF( IC.GE.97 .AND. IC.LE.122 )
+ $ SUBNAM( I: I ) = CHAR( IC-32 )
+ 20 CONTINUE
+ END IF
+*
+ ELSE IF( IZ.EQ.233 .OR. IZ.EQ.169 ) THEN
+*
+* EBCDIC character set
+*
+ IF( ( IC.GE.129 .AND. IC.LE.137 ) .OR.
+ $ ( IC.GE.145 .AND. IC.LE.153 ) .OR.
+ $ ( IC.GE.162 .AND. IC.LE.169 ) ) THEN
+ SUBNAM( 1: 1 ) = CHAR( IC+64 )
+ DO 30 I = 2, 6
+ IC = ICHAR( SUBNAM( I: I ) )
+ IF( ( IC.GE.129 .AND. IC.LE.137 ) .OR.
+ $ ( IC.GE.145 .AND. IC.LE.153 ) .OR.
+ $ ( IC.GE.162 .AND. IC.LE.169 ) )SUBNAM( I:
+ $ I ) = CHAR( IC+64 )
+ 30 CONTINUE
+ END IF
+*
+ ELSE IF( IZ.EQ.218 .OR. IZ.EQ.250 ) THEN
+*
+* Prime machines: ASCII+128
+*
+ IF( IC.GE.225 .AND. IC.LE.250 ) THEN
+ SUBNAM( 1: 1 ) = CHAR( IC-32 )
+ DO 40 I = 2, 6
+ IC = ICHAR( SUBNAM( I: I ) )
+ IF( IC.GE.225 .AND. IC.LE.250 )
+ $ SUBNAM( I: I ) = CHAR( IC-32 )
+ 40 CONTINUE
+ END IF
+ END IF
+*
+ C1 = SUBNAM( 1: 1 )
+ SNAME = C1.EQ.'S' .OR. C1.EQ.'D'
+ CNAME = C1.EQ.'C' .OR. C1.EQ.'Z'
+ IF( .NOT.( CNAME .OR. SNAME ) )
+ $ RETURN
+ C2 = SUBNAM( 2: 3 )
+ C3 = SUBNAM( 4: 6 )
+ C4 = C3( 2: 3 )
+*
+ GO TO ( 50, 60, 70 )ISPEC
+*
+ 50 CONTINUE
+*
+* ISPEC = 1: block size
+*
+* In these examples, separate code is provided for setting NB for
+* real and complex. We assume that NB will take the same value in
+* single or double precision.
+*
+ NB = 1
+*
+ IF( C2.EQ.'GE' ) THEN
+ IF( C3.EQ.'TRF' ) THEN
+ IF( SNAME ) THEN
+ NB = 64
+ ELSE
+ NB = 64
+ END IF
+ ELSE IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR.
+ $ C3.EQ.'QLF' ) THEN
+ IF( SNAME ) THEN
+ NB = 32
+ ELSE
+ NB = 32
+ END IF
+ ELSE IF( C3.EQ.'HRD' ) THEN
+ IF( SNAME ) THEN
+ NB = 32
+ ELSE
+ NB = 32
+ END IF
+ ELSE IF( C3.EQ.'BRD' ) THEN
+ IF( SNAME ) THEN
+ NB = 32
+ ELSE
+ NB = 32
+ END IF
+ ELSE IF( C3.EQ.'TRI' ) THEN
+ IF( SNAME ) THEN
+ NB = 64
+ ELSE
+ NB = 64
+ END IF
+ END IF
+ ELSE IF( C2.EQ.'PO' ) THEN
+ IF( C3.EQ.'TRF' ) THEN
+ IF( SNAME ) THEN
+ NB = 64
+ ELSE
+ NB = 64
+ END IF
+ END IF
+ ELSE IF( C2.EQ.'SY' ) THEN
+ IF( C3.EQ.'TRF' ) THEN
+ IF( SNAME ) THEN
+ NB = 64
+ ELSE
+ NB = 64
+ END IF
+ ELSE IF( SNAME .AND. C3.EQ.'TRD' ) THEN
+ NB = 32
+ ELSE IF( SNAME .AND. C3.EQ.'GST' ) THEN
+ NB = 64
+ END IF
+ ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN
+ IF( C3.EQ.'TRF' ) THEN
+ NB = 64
+ ELSE IF( C3.EQ.'TRD' ) THEN
+ NB = 32
+ ELSE IF( C3.EQ.'GST' ) THEN
+ NB = 64
+ END IF
+ ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN
+ IF( C3( 1: 1 ).EQ.'G' ) THEN
+ IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ.
+ $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' )
+ $ THEN
+ NB = 32
+ END IF
+ ELSE IF( C3( 1: 1 ).EQ.'M' ) THEN
+ IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ.
+ $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' )
+ $ THEN
+ NB = 32
+ END IF
+ END IF
+ ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN
+ IF( C3( 1: 1 ).EQ.'G' ) THEN
+ IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ.
+ $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' )
+ $ THEN
+ NB = 32
+ END IF
+ ELSE IF( C3( 1: 1 ).EQ.'M' ) THEN
+ IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ.
+ $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' )
+ $ THEN
+ NB = 32
+ END IF
+ END IF
+ ELSE IF( C2.EQ.'GB' ) THEN
+ IF( C3.EQ.'TRF' ) THEN
+ IF( SNAME ) THEN
+ IF( N4.LE.64 ) THEN
+ NB = 1
+ ELSE
+ NB = 32
+ END IF
+ ELSE
+ IF( N4.LE.64 ) THEN
+ NB = 1
+ ELSE
+ NB = 32
+ END IF
+ END IF
+ END IF
+ ELSE IF( C2.EQ.'PB' ) THEN
+ IF( C3.EQ.'TRF' ) THEN
+ IF( SNAME ) THEN
+ IF( N2.LE.64 ) THEN
+ NB = 1
+ ELSE
+ NB = 32
+ END IF
+ ELSE
+ IF( N2.LE.64 ) THEN
+ NB = 1
+ ELSE
+ NB = 32
+ END IF
+ END IF
+ END IF
+ ELSE IF( C2.EQ.'TR' ) THEN
+ IF( C3.EQ.'TRI' ) THEN
+ IF( SNAME ) THEN
+ NB = 64
+ ELSE
+ NB = 64
+ END IF
+ END IF
+ ELSE IF( C2.EQ.'LA' ) THEN
+ IF( C3.EQ.'UUM' ) THEN
+ IF( SNAME ) THEN
+ NB = 64
+ ELSE
+ NB = 64
+ END IF
+ END IF
+ ELSE IF( SNAME .AND. C2.EQ.'ST' ) THEN
+ IF( C3.EQ.'EBZ' ) THEN
+ NB = 1
+ END IF
+ END IF
+ ILAENV = NB
+ RETURN
+*
+ 60 CONTINUE
+*
+* ISPEC = 2: minimum block size
+*
+ NBMIN = 2
+ IF( C2.EQ.'GE' ) THEN
+ IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR. C3.EQ.
+ $ 'QLF' ) THEN
+ IF( SNAME ) THEN
+ NBMIN = 2
+ ELSE
+ NBMIN = 2
+ END IF
+ ELSE IF( C3.EQ.'HRD' ) THEN
+ IF( SNAME ) THEN
+ NBMIN = 2
+ ELSE
+ NBMIN = 2
+ END IF
+ ELSE IF( C3.EQ.'BRD' ) THEN
+ IF( SNAME ) THEN
+ NBMIN = 2
+ ELSE
+ NBMIN = 2
+ END IF
+ ELSE IF( C3.EQ.'TRI' ) THEN
+ IF( SNAME ) THEN
+ NBMIN = 2
+ ELSE
+ NBMIN = 2
+ END IF
+ END IF
+ ELSE IF( C2.EQ.'SY' ) THEN
+ IF( C3.EQ.'TRF' ) THEN
+ IF( SNAME ) THEN
+ NBMIN = 8
+ ELSE
+ NBMIN = 8
+ END IF
+ ELSE IF( SNAME .AND. C3.EQ.'TRD' ) THEN
+ NBMIN = 2
+ END IF
+ ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN
+ IF( C3.EQ.'TRD' ) THEN
+ NBMIN = 2
+ END IF
+ ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN
+ IF( C3( 1: 1 ).EQ.'G' ) THEN
+ IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ.
+ $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' )
+ $ THEN
+ NBMIN = 2
+ END IF
+ ELSE IF( C3( 1: 1 ).EQ.'M' ) THEN
+ IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ.
+ $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' )
+ $ THEN
+ NBMIN = 2
+ END IF
+ END IF
+ ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN
+ IF( C3( 1: 1 ).EQ.'G' ) THEN
+ IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ.
+ $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' )
+ $ THEN
+ NBMIN = 2
+ END IF
+ ELSE IF( C3( 1: 1 ).EQ.'M' ) THEN
+ IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ.
+ $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' )
+ $ THEN
+ NBMIN = 2
+ END IF
+ END IF
+ END IF
+ ILAENV = NBMIN
+ RETURN
+*
+ 70 CONTINUE
+*
+* ISPEC = 3: crossover point
+*
+ NX = 0
+ IF( C2.EQ.'GE' ) THEN
+ IF( C3.EQ.'QRF' .OR. C3.EQ.'RQF' .OR. C3.EQ.'LQF' .OR. C3.EQ.
+ $ 'QLF' ) THEN
+ IF( SNAME ) THEN
+ NX = 128
+ ELSE
+ NX = 128
+ END IF
+ ELSE IF( C3.EQ.'HRD' ) THEN
+ IF( SNAME ) THEN
+ NX = 128
+ ELSE
+ NX = 128
+ END IF
+ ELSE IF( C3.EQ.'BRD' ) THEN
+ IF( SNAME ) THEN
+ NX = 128
+ ELSE
+ NX = 128
+ END IF
+ END IF
+ ELSE IF( C2.EQ.'SY' ) THEN
+ IF( SNAME .AND. C3.EQ.'TRD' ) THEN
+ NX = 32
+ END IF
+ ELSE IF( CNAME .AND. C2.EQ.'HE' ) THEN
+ IF( C3.EQ.'TRD' ) THEN
+ NX = 32
+ END IF
+ ELSE IF( SNAME .AND. C2.EQ.'OR' ) THEN
+ IF( C3( 1: 1 ).EQ.'G' ) THEN
+ IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ.
+ $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' )
+ $ THEN
+ NX = 128
+ END IF
+ END IF
+ ELSE IF( CNAME .AND. C2.EQ.'UN' ) THEN
+ IF( C3( 1: 1 ).EQ.'G' ) THEN
+ IF( C4.EQ.'QR' .OR. C4.EQ.'RQ' .OR. C4.EQ.'LQ' .OR. C4.EQ.
+ $ 'QL' .OR. C4.EQ.'HR' .OR. C4.EQ.'TR' .OR. C4.EQ.'BR' )
+ $ THEN
+ NX = 128
+ END IF
+ END IF
+ END IF
+ ILAENV = NX
+ RETURN
+*
+ 80 CONTINUE
+*
+* ISPEC = 4: number of shifts (used by xHSEQR)
+*
+ ILAENV = 6
+ RETURN
+*
+ 90 CONTINUE
+*
+* ISPEC = 5: minimum column dimension (not used)
+*
+ ILAENV = 2
+ RETURN
+*
+ 100 CONTINUE
+*
+* ISPEC = 6: crossover point for SVD (used by xGELSS and xGESVD)
+*
+ ILAENV = INT( REAL( MIN( N1, N2 ) )*1.6E0 )
+ RETURN
+*
+ 110 CONTINUE
+*
+* ISPEC = 7: number of processors (not used)
+*
+ ILAENV = 1
+ RETURN
+*
+ 120 CONTINUE
+*
+* ISPEC = 8: crossover point for multishift (used by xHSEQR)
+*
+ ILAENV = 50
+ RETURN
+*
+ 130 CONTINUE
+*
+* ISPEC = 9: maximum size of the subproblems at the bottom of the
+* computation tree in the divide-and-conquer algorithm
+* (used by xGELSD and xGESDD)
+*
+ ILAENV = 25
+ RETURN
+*
+ 140 CONTINUE
+*
+* ISPEC = 10: ieee NaN arithmetic can be trusted not to trap
+*
+* ILAENV = 0
+ ILAENV = 1
+ IF( ILAENV.EQ.1 ) THEN
+ ILAENV = IEEECK( 0, 0.0, 1.0 )
+ END IF
+ RETURN
+*
+ 150 CONTINUE
+*
+* ISPEC = 11: infinity arithmetic can be trusted not to trap
+*
+* ILAENV = 0
+ ILAENV = 1
+ IF( ILAENV.EQ.1 ) THEN
+ ILAENV = IEEECK( 1, 0.0, 1.0 )
+ END IF
+ RETURN
+*
+ 160 CONTINUE
+*
+* 12 <= ISPEC <= 16: xHSEQR or one of its subroutines.
+*
+ ILAENV = IPARMQ( ISPEC, NAME, OPTS, N1, N2, N3, N4 )
+ RETURN
+*
+* End of ILAENV
+*
+ END
+ SUBROUTINE ILAVER( VERS_MAJOR, VERS_MINOR, VERS_PATCH )
+*
+* -- LAPACK routine (version 3.1.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* January 2007
+* ..
+*
+* Purpose
+* =======
+*
+* This subroutine return the Lapack version
+*
+* Arguments
+* =========
+* VERS_MAJOR (output) INTEGER
+* return the lapack major version
+* VERS_MINOR (output) INTEGER
+* return the lapack minor version from the major version
+* VERS_PATCH (output) INTEGER
+* return the lapack patch version from the minor version
+* =====================================================================
+*
+ INTEGER VERS_MAJOR, VERS_MINOR, VERS_PATCH
+* =====================================================================
+ VERS_MAJOR = 3
+ VERS_MINOR = 1
+ VERS_PATCH = 1
+* =====================================================================
+*
+ RETURN
+ END
+ INTEGER FUNCTION IPARMQ( ISPEC, NAME, OPTS, N, ILO, IHI, LWORK )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER IHI, ILO, ISPEC, LWORK, N
+ CHARACTER NAME*( * ), OPTS*( * )
+*
+* Purpose
+* =======
+*
+* This program sets problem and machine dependent parameters
+* useful for xHSEQR and its subroutines. It is called whenever
+* ILAENV is called with 12 <= ISPEC <= 16
+*
+* Arguments
+* =========
+*
+* ISPEC (input) integer scalar
+* ISPEC specifies which tunable parameter IPARMQ should
+* return.
+*
+* ISPEC=12: (INMIN) Matrices of order nmin or less
+* are sent directly to xLAHQR, the implicit
+* double shift QR algorithm. NMIN must be
+* at least 11.
+*
+* ISPEC=13: (INWIN) Size of the deflation window.
+* This is best set greater than or equal to
+* the number of simultaneous shifts NS.
+* Larger matrices benefit from larger deflation
+* windows.
+*
+* ISPEC=14: (INIBL) Determines when to stop nibbling and
+* invest in an (expensive) multi-shift QR sweep.
+* If the aggressive early deflation subroutine
+* finds LD converged eigenvalues from an order
+* NW deflation window and LD.GT.(NW*NIBBLE)/100,
+* then the next QR sweep is skipped and early
+* deflation is applied immediately to the
+* remaining active diagonal block. Setting
+* IPARMQ(ISPEC=14) = 0 causes TTQRE to skip a
+* multi-shift QR sweep whenever early deflation
+* finds a converged eigenvalue. Setting
+* IPARMQ(ISPEC=14) greater than or equal to 100
+* prevents TTQRE from skipping a multi-shift
+* QR sweep.
+*
+* ISPEC=15: (NSHFTS) The number of simultaneous shifts in
+* a multi-shift QR iteration.
+*
+* ISPEC=16: (IACC22) IPARMQ is set to 0, 1 or 2 with the
+* following meanings.
+* 0: During the multi-shift QR sweep,
+* xLAQR5 does not accumulate reflections and
+* does not use matrix-matrix multiply to
+* update the far-from-diagonal matrix
+* entries.
+* 1: During the multi-shift QR sweep,
+* xLAQR5 and/or xLAQRaccumulates reflections and uses
+* matrix-matrix multiply to update the
+* far-from-diagonal matrix entries.
+* 2: During the multi-shift QR sweep.
+* xLAQR5 accumulates reflections and takes
+* advantage of 2-by-2 block structure during
+* matrix-matrix multiplies.
+* (If xTRMM is slower than xGEMM, then
+* IPARMQ(ISPEC=16)=1 may be more efficient than
+* IPARMQ(ISPEC=16)=2 despite the greater level of
+* arithmetic work implied by the latter choice.)
+*
+* NAME (input) character string
+* Name of the calling subroutine
+*
+* OPTS (input) character string
+* This is a concatenation of the string arguments to
+* TTQRE.
+*
+* N (input) integer scalar
+* N is the order of the Hessenberg matrix H.
+*
+* ILO (input) INTEGER
+* IHI (input) INTEGER
+* It is assumed that H is already upper triangular
+* in rows and columns 1:ILO-1 and IHI+1:N.
+*
+* LWORK (input) integer scalar
+* The amount of workspace available.
+*
+* Further Details
+* ===============
+*
+* Little is known about how best to choose these parameters.
+* It is possible to use different values of the parameters
+* for each of CHSEQR, DHSEQR, SHSEQR and ZHSEQR.
+*
+* It is probably best to choose different parameters for
+* different matrices and different parameters at different
+* times during the iteration, but this has not been
+* implemented --- yet.
+*
+*
+* The best choices of most of the parameters depend
+* in an ill-understood way on the relative execution
+* rate of xLAQR3 and xLAQR5 and on the nature of each
+* particular eigenvalue problem. Experiment may be the
+* only practical way to determine which choices are most
+* effective.
+*
+* Following is a list of default values supplied by IPARMQ.
+* These defaults may be adjusted in order to attain better
+* performance in any particular computational environment.
+*
+* IPARMQ(ISPEC=12) The xLAHQR vs xLAQR0 crossover point.
+* Default: 75. (Must be at least 11.)
+*
+* IPARMQ(ISPEC=13) Recommended deflation window size.
+* This depends on ILO, IHI and NS, the
+* number of simultaneous shifts returned
+* by IPARMQ(ISPEC=15). The default for
+* (IHI-ILO+1).LE.500 is NS. The default
+* for (IHI-ILO+1).GT.500 is 3*NS/2.
+*
+* IPARMQ(ISPEC=14) Nibble crossover point. Default: 14.
+*
+* IPARMQ(ISPEC=15) Number of simultaneous shifts, NS.
+* a multi-shift QR iteration.
+*
+* If IHI-ILO+1 is ...
+*
+* greater than ...but less ... the
+* or equal to ... than default is
+*
+* 0 30 NS = 2+
+* 30 60 NS = 4+
+* 60 150 NS = 10
+* 150 590 NS = **
+* 590 3000 NS = 64
+* 3000 6000 NS = 128
+* 6000 infinity NS = 256
+*
+* (+) By default matrices of this order are
+* passed to the implicit double shift routine
+* xLAHQR. See IPARMQ(ISPEC=12) above. These
+* values of NS are used only in case of a rare
+* xLAHQR failure.
+*
+* (**) The asterisks (**) indicate an ad-hoc
+* function increasing from 10 to 64.
+*
+* IPARMQ(ISPEC=16) Select structured matrix multiply.
+* (See ISPEC=16 above for details.)
+* Default: 3.
+*
+* ================================================================
+* .. Parameters ..
+ INTEGER INMIN, INWIN, INIBL, ISHFTS, IACC22
+ PARAMETER ( INMIN = 12, INWIN = 13, INIBL = 14,
+ $ ISHFTS = 15, IACC22 = 16 )
+ INTEGER NMIN, K22MIN, KACMIN, NIBBLE, KNWSWP
+ PARAMETER ( NMIN = 75, K22MIN = 14, KACMIN = 14,
+ $ NIBBLE = 14, KNWSWP = 500 )
+ REAL TWO
+ PARAMETER ( TWO = 2.0 )
+* ..
+* .. Local Scalars ..
+ INTEGER NH, NS
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC LOG, MAX, MOD, NINT, REAL
+* ..
+* .. Executable Statements ..
+ IF( ( ISPEC.EQ.ISHFTS ) .OR. ( ISPEC.EQ.INWIN ) .OR.
+ $ ( ISPEC.EQ.IACC22 ) ) THEN
+*
+* ==== Set the number simultaneous shifts ====
+*
+ NH = IHI - ILO + 1
+ NS = 2
+ IF( NH.GE.30 )
+ $ NS = 4
+ IF( NH.GE.60 )
+ $ NS = 10
+ IF( NH.GE.150 )
+ $ NS = MAX( 10, NH / NINT( LOG( REAL( NH ) ) / LOG( TWO ) ) )
+ IF( NH.GE.590 )
+ $ NS = 64
+ IF( NH.GE.3000 )
+ $ NS = 128
+ IF( NH.GE.6000 )
+ $ NS = 256
+ NS = MAX( 2, NS-MOD( NS, 2 ) )
+ END IF
+*
+ IF( ISPEC.EQ.INMIN ) THEN
+*
+*
+* ===== Matrices of order smaller than NMIN get sent
+* . to xLAHQR, the classic double shift algorithm.
+* . This must be at least 11. ====
+*
+ IPARMQ = NMIN
+*
+ ELSE IF( ISPEC.EQ.INIBL ) THEN
+*
+* ==== INIBL: skip a multi-shift qr iteration and
+* . whenever aggressive early deflation finds
+* . at least (NIBBLE*(window size)/100) deflations. ====
+*
+ IPARMQ = NIBBLE
+*
+ ELSE IF( ISPEC.EQ.ISHFTS ) THEN
+*
+* ==== NSHFTS: The number of simultaneous shifts =====
+*
+ IPARMQ = NS
+*
+ ELSE IF( ISPEC.EQ.INWIN ) THEN
+*
+* ==== NW: deflation window size. ====
+*
+ IF( NH.LE.KNWSWP ) THEN
+ IPARMQ = NS
+ ELSE
+ IPARMQ = 3*NS / 2
+ END IF
+*
+ ELSE IF( ISPEC.EQ.IACC22 ) THEN
+*
+* ==== IACC22: Whether to accumulate reflections
+* . before updating the far-from-diagonal elements
+* . and whether to use 2-by-2 block structure while
+* . doing it. A small amount of work could be saved
+* . by making this choice dependent also upon the
+* . NH=IHI-ILO+1.
+*
+ IPARMQ = 0
+ IF( NS.GE.KACMIN )
+ $ IPARMQ = 1
+ IF( NS.GE.K22MIN )
+ $ IPARMQ = 2
+*
+ ELSE
+* ===== invalid value of ispec =====
+ IPARMQ = -1
+*
+ END IF
+*
+* ==== End of IPARMQ ====
+*
+ END
+ LOGICAL FUNCTION LSAMEN( N, CA, CB )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER*( * ) CA, CB
+ INTEGER N
+* ..
+*
+* Purpose
+* =======
+*
+* LSAMEN tests if the first N letters of CA are the same as the
+* first N letters of CB, regardless of case.
+* LSAMEN returns .TRUE. if CA and CB are equivalent except for case
+* and .FALSE. otherwise. LSAMEN also returns .FALSE. if LEN( CA )
+* or LEN( CB ) is less than N.
+*
+* Arguments
+* =========
+*
+* N (input) INTEGER
+* The number of characters in CA and CB to be compared.
+*
+* CA (input) CHARACTER*(*)
+* CB (input) CHARACTER*(*)
+* CA and CB specify two character strings of length at least N.
+* Only the first N characters of each string will be accessed.
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ INTEGER I
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC LEN
+* ..
+* .. Executable Statements ..
+*
+ LSAMEN = .FALSE.
+ IF( LEN( CA ).LT.N .OR. LEN( CB ).LT.N )
+ $ GO TO 20
+*
+* Do for each character in the two strings.
+*
+ DO 10 I = 1, N
+*
+* Test if the characters are equal using LSAME.
+*
+ IF( .NOT.LSAME( CA( I: I ), CB( I: I ) ) )
+ $ GO TO 20
+*
+ 10 CONTINUE
+ LSAMEN = .TRUE.
+*
+ 20 CONTINUE
+ RETURN
+*
+* End of LSAMEN
+*
+ END
+ SUBROUTINE SBDSDC( UPLO, COMPQ, N, D, E, U, LDU, VT, LDVT, Q, IQ,
+ $ WORK, IWORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER COMPQ, UPLO
+ INTEGER INFO, LDU, LDVT, N
+* ..
+* .. Array Arguments ..
+ INTEGER IQ( * ), IWORK( * )
+ REAL D( * ), E( * ), Q( * ), U( LDU, * ),
+ $ VT( LDVT, * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SBDSDC computes the singular value decomposition (SVD) of a real
+* N-by-N (upper or lower) bidiagonal matrix B: B = U * S * VT,
+* using a divide and conquer method, where S is a diagonal matrix
+* with non-negative diagonal elements (the singular values of B), and
+* U and VT are orthogonal matrices of left and right singular vectors,
+* respectively. SBDSDC can be used to compute all singular values,
+* and optionally, singular vectors or singular vectors in compact form.
+*
+* This code makes very mild assumptions about floating point
+* arithmetic. It will work on machines with a guard digit in
+* add/subtract, or on those binary machines without guard digits
+* which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2.
+* It could conceivably fail on hexadecimal or decimal machines
+* without guard digits, but we know of none. See SLASD3 for details.
+*
+* The code currently calls SLASDQ if singular values only are desired.
+* However, it can be slightly modified to compute singular values
+* using the divide and conquer method.
+*
+* Arguments
+* =========
+*
+* UPLO (input) CHARACTER*1
+* = 'U': B is upper bidiagonal.
+* = 'L': B is lower bidiagonal.
+*
+* COMPQ (input) CHARACTER*1
+* Specifies whether singular vectors are to be computed
+* as follows:
+* = 'N': Compute singular values only;
+* = 'P': Compute singular values and compute singular
+* vectors in compact form;
+* = 'I': Compute singular values and singular vectors.
+*
+* N (input) INTEGER
+* The order of the matrix B. N >= 0.
+*
+* D (input/output) REAL array, dimension (N)
+* On entry, the n diagonal elements of the bidiagonal matrix B.
+* On exit, if INFO=0, the singular values of B.
+*
+* E (input/output) REAL array, dimension (N-1)
+* On entry, the elements of E contain the offdiagonal
+* elements of the bidiagonal matrix whose SVD is desired.
+* On exit, E has been destroyed.
+*
+* U (output) REAL array, dimension (LDU,N)
+* If COMPQ = 'I', then:
+* On exit, if INFO = 0, U contains the left singular vectors
+* of the bidiagonal matrix.
+* For other values of COMPQ, U is not referenced.
+*
+* LDU (input) INTEGER
+* The leading dimension of the array U. LDU >= 1.
+* If singular vectors are desired, then LDU >= max( 1, N ).
+*
+* VT (output) REAL array, dimension (LDVT,N)
+* If COMPQ = 'I', then:
+* On exit, if INFO = 0, VT' contains the right singular
+* vectors of the bidiagonal matrix.
+* For other values of COMPQ, VT is not referenced.
+*
+* LDVT (input) INTEGER
+* The leading dimension of the array VT. LDVT >= 1.
+* If singular vectors are desired, then LDVT >= max( 1, N ).
+*
+* Q (output) REAL array, dimension (LDQ)
+* If COMPQ = 'P', then:
+* On exit, if INFO = 0, Q and IQ contain the left
+* and right singular vectors in a compact form,
+* requiring O(N log N) space instead of 2*N**2.
+* In particular, Q contains all the REAL data in
+* LDQ >= N*(11 + 2*SMLSIZ + 8*INT(LOG_2(N/(SMLSIZ+1))))
+* words of memory, where SMLSIZ is returned by ILAENV and
+* is equal to the maximum size of the subproblems at the
+* bottom of the computation tree (usually about 25).
+* For other values of COMPQ, Q is not referenced.
+*
+* IQ (output) INTEGER array, dimension (LDIQ)
+* If COMPQ = 'P', then:
+* On exit, if INFO = 0, Q and IQ contain the left
+* and right singular vectors in a compact form,
+* requiring O(N log N) space instead of 2*N**2.
+* In particular, IQ contains all INTEGER data in
+* LDIQ >= N*(3 + 3*INT(LOG_2(N/(SMLSIZ+1))))
+* words of memory, where SMLSIZ is returned by ILAENV and
+* is equal to the maximum size of the subproblems at the
+* bottom of the computation tree (usually about 25).
+* For other values of COMPQ, IQ is not referenced.
+*
+* WORK (workspace) REAL array, dimension (MAX(1,LWORK))
+* If COMPQ = 'N' then LWORK >= (4 * N).
+* If COMPQ = 'P' then LWORK >= (6 * N).
+* If COMPQ = 'I' then LWORK >= (3 * N**2 + 4 * N).
+*
+* IWORK (workspace) INTEGER array, dimension (8*N)
+*
+* INFO (output) INTEGER
+* = 0: successful exit.
+* < 0: if INFO = -i, the i-th argument had an illegal value.
+* > 0: The algorithm failed to compute an singular value.
+* The update process of divide and conquer failed.
+*
+* Further Details
+* ===============
+*
+* Based on contributions by
+* Ming Gu and Huan Ren, Computer Science Division, University of
+* California at Berkeley, USA
+* =====================================================================
+* Changed dimension statement in comment describing E from (N) to
+* (N-1). Sven, 17 Feb 05.
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO, ONE, TWO
+ PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0, TWO = 2.0E+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER DIFL, DIFR, GIVCOL, GIVNUM, GIVPTR, I, IC,
+ $ ICOMPQ, IERR, II, IS, IU, IUPLO, IVT, J, K, KK,
+ $ MLVL, NM1, NSIZE, PERM, POLES, QSTART, SMLSIZ,
+ $ SMLSZP, SQRE, START, WSTART, Z
+ REAL CS, EPS, ORGNRM, P, R, SN
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ILAENV
+ REAL SLAMCH, SLANST
+ EXTERNAL SLAMCH, SLANST, ILAENV, LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL SCOPY, SLARTG, SLASCL, SLASD0, SLASDA, SLASDQ,
+ $ SLASET, SLASR, SSWAP, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC REAL, ABS, INT, LOG, SIGN
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+*
+ IUPLO = 0
+ IF( LSAME( UPLO, 'U' ) )
+ $ IUPLO = 1
+ IF( LSAME( UPLO, 'L' ) )
+ $ IUPLO = 2
+ IF( LSAME( COMPQ, 'N' ) ) THEN
+ ICOMPQ = 0
+ ELSE IF( LSAME( COMPQ, 'P' ) ) THEN
+ ICOMPQ = 1
+ ELSE IF( LSAME( COMPQ, 'I' ) ) THEN
+ ICOMPQ = 2
+ ELSE
+ ICOMPQ = -1
+ END IF
+ IF( IUPLO.EQ.0 ) THEN
+ INFO = -1
+ ELSE IF( ICOMPQ.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( ( LDU.LT.1 ) .OR. ( ( ICOMPQ.EQ.2 ) .AND. ( LDU.LT.
+ $ N ) ) ) THEN
+ INFO = -7
+ ELSE IF( ( LDVT.LT.1 ) .OR. ( ( ICOMPQ.EQ.2 ) .AND. ( LDVT.LT.
+ $ N ) ) ) THEN
+ INFO = -9
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SBDSDC', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 )
+ $ RETURN
+ SMLSIZ = ILAENV( 9, 'SBDSDC', ' ', 0, 0, 0, 0 )
+ IF( N.EQ.1 ) THEN
+ IF( ICOMPQ.EQ.1 ) THEN
+ Q( 1 ) = SIGN( ONE, D( 1 ) )
+ Q( 1+SMLSIZ*N ) = ONE
+ ELSE IF( ICOMPQ.EQ.2 ) THEN
+ U( 1, 1 ) = SIGN( ONE, D( 1 ) )
+ VT( 1, 1 ) = ONE
+ END IF
+ D( 1 ) = ABS( D( 1 ) )
+ RETURN
+ END IF
+ NM1 = N - 1
+*
+* If matrix lower bidiagonal, rotate to be upper bidiagonal
+* by applying Givens rotations on the left
+*
+ WSTART = 1
+ QSTART = 3
+ IF( ICOMPQ.EQ.1 ) THEN
+ CALL SCOPY( N, D, 1, Q( 1 ), 1 )
+ CALL SCOPY( N-1, E, 1, Q( N+1 ), 1 )
+ END IF
+ IF( IUPLO.EQ.2 ) THEN
+ QSTART = 5
+ WSTART = 2*N - 1
+ DO 10 I = 1, N - 1
+ CALL SLARTG( D( I ), E( I ), CS, SN, R )
+ D( I ) = R
+ E( I ) = SN*D( I+1 )
+ D( I+1 ) = CS*D( I+1 )
+ IF( ICOMPQ.EQ.1 ) THEN
+ Q( I+2*N ) = CS
+ Q( I+3*N ) = SN
+ ELSE IF( ICOMPQ.EQ.2 ) THEN
+ WORK( I ) = CS
+ WORK( NM1+I ) = -SN
+ END IF
+ 10 CONTINUE
+ END IF
+*
+* If ICOMPQ = 0, use SLASDQ to compute the singular values.
+*
+ IF( ICOMPQ.EQ.0 ) THEN
+ CALL SLASDQ( 'U', 0, N, 0, 0, 0, D, E, VT, LDVT, U, LDU, U,
+ $ LDU, WORK( WSTART ), INFO )
+ GO TO 40
+ END IF
+*
+* If N is smaller than the minimum divide size SMLSIZ, then solve
+* the problem with another solver.
+*
+ IF( N.LE.SMLSIZ ) THEN
+ IF( ICOMPQ.EQ.2 ) THEN
+ CALL SLASET( 'A', N, N, ZERO, ONE, U, LDU )
+ CALL SLASET( 'A', N, N, ZERO, ONE, VT, LDVT )
+ CALL SLASDQ( 'U', 0, N, N, N, 0, D, E, VT, LDVT, U, LDU, U,
+ $ LDU, WORK( WSTART ), INFO )
+ ELSE IF( ICOMPQ.EQ.1 ) THEN
+ IU = 1
+ IVT = IU + N
+ CALL SLASET( 'A', N, N, ZERO, ONE, Q( IU+( QSTART-1 )*N ),
+ $ N )
+ CALL SLASET( 'A', N, N, ZERO, ONE, Q( IVT+( QSTART-1 )*N ),
+ $ N )
+ CALL SLASDQ( 'U', 0, N, N, N, 0, D, E,
+ $ Q( IVT+( QSTART-1 )*N ), N,
+ $ Q( IU+( QSTART-1 )*N ), N,
+ $ Q( IU+( QSTART-1 )*N ), N, WORK( WSTART ),
+ $ INFO )
+ END IF
+ GO TO 40
+ END IF
+*
+ IF( ICOMPQ.EQ.2 ) THEN
+ CALL SLASET( 'A', N, N, ZERO, ONE, U, LDU )
+ CALL SLASET( 'A', N, N, ZERO, ONE, VT, LDVT )
+ END IF
+*
+* Scale.
+*
+ ORGNRM = SLANST( 'M', N, D, E )
+ IF( ORGNRM.EQ.ZERO )
+ $ RETURN
+ CALL SLASCL( 'G', 0, 0, ORGNRM, ONE, N, 1, D, N, IERR )
+ CALL SLASCL( 'G', 0, 0, ORGNRM, ONE, NM1, 1, E, NM1, IERR )
+*
+ EPS = SLAMCH( 'Epsilon' )
+*
+ MLVL = INT( LOG( REAL( N ) / REAL( SMLSIZ+1 ) ) / LOG( TWO ) ) + 1
+ SMLSZP = SMLSIZ + 1
+*
+ IF( ICOMPQ.EQ.1 ) THEN
+ IU = 1
+ IVT = 1 + SMLSIZ
+ DIFL = IVT + SMLSZP
+ DIFR = DIFL + MLVL
+ Z = DIFR + MLVL*2
+ IC = Z + MLVL
+ IS = IC + 1
+ POLES = IS + 1
+ GIVNUM = POLES + 2*MLVL
+*
+ K = 1
+ GIVPTR = 2
+ PERM = 3
+ GIVCOL = PERM + MLVL
+ END IF
+*
+ DO 20 I = 1, N
+ IF( ABS( D( I ) ).LT.EPS ) THEN
+ D( I ) = SIGN( EPS, D( I ) )
+ END IF
+ 20 CONTINUE
+*
+ START = 1
+ SQRE = 0
+*
+ DO 30 I = 1, NM1
+ IF( ( ABS( E( I ) ).LT.EPS ) .OR. ( I.EQ.NM1 ) ) THEN
+*
+* Subproblem found. First determine its size and then
+* apply divide and conquer on it.
+*
+ IF( I.LT.NM1 ) THEN
+*
+* A subproblem with E(I) small for I < NM1.
+*
+ NSIZE = I - START + 1
+ ELSE IF( ABS( E( I ) ).GE.EPS ) THEN
+*
+* A subproblem with E(NM1) not too small but I = NM1.
+*
+ NSIZE = N - START + 1
+ ELSE
+*
+* A subproblem with E(NM1) small. This implies an
+* 1-by-1 subproblem at D(N). Solve this 1-by-1 problem
+* first.
+*
+ NSIZE = I - START + 1
+ IF( ICOMPQ.EQ.2 ) THEN
+ U( N, N ) = SIGN( ONE, D( N ) )
+ VT( N, N ) = ONE
+ ELSE IF( ICOMPQ.EQ.1 ) THEN
+ Q( N+( QSTART-1 )*N ) = SIGN( ONE, D( N ) )
+ Q( N+( SMLSIZ+QSTART-1 )*N ) = ONE
+ END IF
+ D( N ) = ABS( D( N ) )
+ END IF
+ IF( ICOMPQ.EQ.2 ) THEN
+ CALL SLASD0( NSIZE, SQRE, D( START ), E( START ),
+ $ U( START, START ), LDU, VT( START, START ),
+ $ LDVT, SMLSIZ, IWORK, WORK( WSTART ), INFO )
+ ELSE
+ CALL SLASDA( ICOMPQ, SMLSIZ, NSIZE, SQRE, D( START ),
+ $ E( START ), Q( START+( IU+QSTART-2 )*N ), N,
+ $ Q( START+( IVT+QSTART-2 )*N ),
+ $ IQ( START+K*N ), Q( START+( DIFL+QSTART-2 )*
+ $ N ), Q( START+( DIFR+QSTART-2 )*N ),
+ $ Q( START+( Z+QSTART-2 )*N ),
+ $ Q( START+( POLES+QSTART-2 )*N ),
+ $ IQ( START+GIVPTR*N ), IQ( START+GIVCOL*N ),
+ $ N, IQ( START+PERM*N ),
+ $ Q( START+( GIVNUM+QSTART-2 )*N ),
+ $ Q( START+( IC+QSTART-2 )*N ),
+ $ Q( START+( IS+QSTART-2 )*N ),
+ $ WORK( WSTART ), IWORK, INFO )
+ IF( INFO.NE.0 ) THEN
+ RETURN
+ END IF
+ END IF
+ START = I + 1
+ END IF
+ 30 CONTINUE
+*
+* Unscale
+*
+ CALL SLASCL( 'G', 0, 0, ONE, ORGNRM, N, 1, D, N, IERR )
+ 40 CONTINUE
+*
+* Use Selection Sort to minimize swaps of singular vectors
+*
+ DO 60 II = 2, N
+ I = II - 1
+ KK = I
+ P = D( I )
+ DO 50 J = II, N
+ IF( D( J ).GT.P ) THEN
+ KK = J
+ P = D( J )
+ END IF
+ 50 CONTINUE
+ IF( KK.NE.I ) THEN
+ D( KK ) = D( I )
+ D( I ) = P
+ IF( ICOMPQ.EQ.1 ) THEN
+ IQ( I ) = KK
+ ELSE IF( ICOMPQ.EQ.2 ) THEN
+ CALL SSWAP( N, U( 1, I ), 1, U( 1, KK ), 1 )
+ CALL SSWAP( N, VT( I, 1 ), LDVT, VT( KK, 1 ), LDVT )
+ END IF
+ ELSE IF( ICOMPQ.EQ.1 ) THEN
+ IQ( I ) = I
+ END IF
+ 60 CONTINUE
+*
+* If ICOMPQ = 1, use IQ(N,1) as the indicator for UPLO
+*
+ IF( ICOMPQ.EQ.1 ) THEN
+ IF( IUPLO.EQ.1 ) THEN
+ IQ( N ) = 1
+ ELSE
+ IQ( N ) = 0
+ END IF
+ END IF
+*
+* If B is lower bidiagonal, update U by those Givens rotations
+* which rotated B to be upper bidiagonal
+*
+ IF( ( IUPLO.EQ.2 ) .AND. ( ICOMPQ.EQ.2 ) )
+ $ CALL SLASR( 'L', 'V', 'B', N, N, WORK( 1 ), WORK( N ), U, LDU )
+*
+ RETURN
+*
+* End of SBDSDC
+*
+ END
+ SUBROUTINE SBDSQR( UPLO, N, NCVT, NRU, NCC, D, E, VT, LDVT, U,
+ $ LDU, C, LDC, WORK, INFO )
+*
+* -- LAPACK routine (version 3.1.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* January 2007
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, LDC, LDU, LDVT, N, NCC, NCVT, NRU
+* ..
+* .. Array Arguments ..
+ REAL C( LDC, * ), D( * ), E( * ), U( LDU, * ),
+ $ VT( LDVT, * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SBDSQR computes the singular values and, optionally, the right and/or
+* left singular vectors from the singular value decomposition (SVD) of
+* a real N-by-N (upper or lower) bidiagonal matrix B using the implicit
+* zero-shift QR algorithm. The SVD of B has the form
+*
+* B = Q * S * P**T
+*
+* where S is the diagonal matrix of singular values, Q is an orthogonal
+* matrix of left singular vectors, and P is an orthogonal matrix of
+* right singular vectors. If left singular vectors are requested, this
+* subroutine actually returns U*Q instead of Q, and, if right singular
+* vectors are requested, this subroutine returns P**T*VT instead of
+* P**T, for given real input matrices U and VT. When U and VT are the
+* orthogonal matrices that reduce a general matrix A to bidiagonal
+* form: A = U*B*VT, as computed by SGEBRD, then
+*
+* A = (U*Q) * S * (P**T*VT)
+*
+* is the SVD of A. Optionally, the subroutine may also compute Q**T*C
+* for a given real input matrix C.
+*
+* See "Computing Small Singular Values of Bidiagonal Matrices With
+* Guaranteed High Relative Accuracy," by J. Demmel and W. Kahan,
+* LAPACK Working Note #3 (or SIAM J. Sci. Statist. Comput. vol. 11,
+* no. 5, pp. 873-912, Sept 1990) and
+* "Accurate singular values and differential qd algorithms," by
+* B. Parlett and V. Fernando, Technical Report CPAM-554, Mathematics
+* Department, University of California at Berkeley, July 1992
+* for a detailed description of the algorithm.
+*
+* Arguments
+* =========
+*
+* UPLO (input) CHARACTER*1
+* = 'U': B is upper bidiagonal;
+* = 'L': B is lower bidiagonal.
+*
+* N (input) INTEGER
+* The order of the matrix B. N >= 0.
+*
+* NCVT (input) INTEGER
+* The number of columns of the matrix VT. NCVT >= 0.
+*
+* NRU (input) INTEGER
+* The number of rows of the matrix U. NRU >= 0.
+*
+* NCC (input) INTEGER
+* The number of columns of the matrix C. NCC >= 0.
+*
+* D (input/output) REAL array, dimension (N)
+* On entry, the n diagonal elements of the bidiagonal matrix B.
+* On exit, if INFO=0, the singular values of B in decreasing
+* order.
+*
+* E (input/output) REAL array, dimension (N-1)
+* On entry, the N-1 offdiagonal elements of the bidiagonal
+* matrix B.
+* On exit, if INFO = 0, E is destroyed; if INFO > 0, D and E
+* will contain the diagonal and superdiagonal elements of a
+* bidiagonal matrix orthogonally equivalent to the one given
+* as input.
+*
+* VT (input/output) REAL array, dimension (LDVT, NCVT)
+* On entry, an N-by-NCVT matrix VT.
+* On exit, VT is overwritten by P**T * VT.
+* Not referenced if NCVT = 0.
+*
+* LDVT (input) INTEGER
+* The leading dimension of the array VT.
+* LDVT >= max(1,N) if NCVT > 0; LDVT >= 1 if NCVT = 0.
+*
+* U (input/output) REAL array, dimension (LDU, N)
+* On entry, an NRU-by-N matrix U.
+* On exit, U is overwritten by U * Q.
+* Not referenced if NRU = 0.
+*
+* LDU (input) INTEGER
+* The leading dimension of the array U. LDU >= max(1,NRU).
+*
+* C (input/output) REAL array, dimension (LDC, NCC)
+* On entry, an N-by-NCC matrix C.
+* On exit, C is overwritten by Q**T * C.
+* Not referenced if NCC = 0.
+*
+* LDC (input) INTEGER
+* The leading dimension of the array C.
+* LDC >= max(1,N) if NCC > 0; LDC >=1 if NCC = 0.
+*
+* WORK (workspace) REAL array, dimension (2*N)
+* if NCVT = NRU = NCC = 0, (max(1, 4*N)) otherwise
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: If INFO = -i, the i-th argument had an illegal value
+* > 0: the algorithm did not converge; D and E contain the
+* elements of a bidiagonal matrix which is orthogonally
+* similar to the input matrix B; if INFO = i, i
+* elements of E have not converged to zero.
+*
+* Internal Parameters
+* ===================
+*
+* TOLMUL REAL, default = max(10,min(100,EPS**(-1/8)))
+* TOLMUL controls the convergence criterion of the QR loop.
+* If it is positive, TOLMUL*EPS is the desired relative
+* precision in the computed singular values.
+* If it is negative, abs(TOLMUL*EPS*sigma_max) is the
+* desired absolute accuracy in the computed singular
+* values (corresponds to relative accuracy
+* abs(TOLMUL*EPS) in the largest singular value.
+* abs(TOLMUL) should be between 1 and 1/EPS, and preferably
+* between 10 (for fast convergence) and .1/EPS
+* (for there to be some accuracy in the results).
+* Default is to lose at either one eighth or 2 of the
+* available decimal digits in each computed singular value
+* (whichever is smaller).
+*
+* MAXITR INTEGER, default = 6
+* MAXITR controls the maximum number of passes of the
+* algorithm through its inner loop. The algorithms stops
+* (and so fails to converge) if the number of passes
+* through the inner loop exceeds MAXITR*N**2.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO
+ PARAMETER ( ZERO = 0.0E0 )
+ REAL ONE
+ PARAMETER ( ONE = 1.0E0 )
+ REAL NEGONE
+ PARAMETER ( NEGONE = -1.0E0 )
+ REAL HNDRTH
+ PARAMETER ( HNDRTH = 0.01E0 )
+ REAL TEN
+ PARAMETER ( TEN = 10.0E0 )
+ REAL HNDRD
+ PARAMETER ( HNDRD = 100.0E0 )
+ REAL MEIGTH
+ PARAMETER ( MEIGTH = -0.125E0 )
+ INTEGER MAXITR
+ PARAMETER ( MAXITR = 6 )
+* ..
+* .. Local Scalars ..
+ LOGICAL LOWER, ROTATE
+ INTEGER I, IDIR, ISUB, ITER, J, LL, LLL, M, MAXIT, NM1,
+ $ NM12, NM13, OLDLL, OLDM
+ REAL ABSE, ABSS, COSL, COSR, CS, EPS, F, G, H, MU,
+ $ OLDCS, OLDSN, R, SHIFT, SIGMN, SIGMX, SINL,
+ $ SINR, SLL, SMAX, SMIN, SMINL, SMINOA,
+ $ SN, THRESH, TOL, TOLMUL, UNFL
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ REAL SLAMCH
+ EXTERNAL LSAME, SLAMCH
+* ..
+* .. External Subroutines ..
+ EXTERNAL SLARTG, SLAS2, SLASQ1, SLASR, SLASV2, SROT,
+ $ SSCAL, SSWAP, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, MIN, REAL, SIGN, SQRT
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ LOWER = LSAME( UPLO, 'L' )
+ IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LOWER ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( NCVT.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( NRU.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( NCC.LT.0 ) THEN
+ INFO = -5
+ ELSE IF( ( NCVT.EQ.0 .AND. LDVT.LT.1 ) .OR.
+ $ ( NCVT.GT.0 .AND. LDVT.LT.MAX( 1, N ) ) ) THEN
+ INFO = -9
+ ELSE IF( LDU.LT.MAX( 1, NRU ) ) THEN
+ INFO = -11
+ ELSE IF( ( NCC.EQ.0 .AND. LDC.LT.1 ) .OR.
+ $ ( NCC.GT.0 .AND. LDC.LT.MAX( 1, N ) ) ) THEN
+ INFO = -13
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SBDSQR', -INFO )
+ RETURN
+ END IF
+ IF( N.EQ.0 )
+ $ RETURN
+ IF( N.EQ.1 )
+ $ GO TO 160
+*
+* ROTATE is true if any singular vectors desired, false otherwise
+*
+ ROTATE = ( NCVT.GT.0 ) .OR. ( NRU.GT.0 ) .OR. ( NCC.GT.0 )
+*
+* If no singular vectors desired, use qd algorithm
+*
+ IF( .NOT.ROTATE ) THEN
+ CALL SLASQ1( N, D, E, WORK, INFO )
+ RETURN
+ END IF
+*
+ NM1 = N - 1
+ NM12 = NM1 + NM1
+ NM13 = NM12 + NM1
+ IDIR = 0
+*
+* Get machine constants
+*
+ EPS = SLAMCH( 'Epsilon' )
+ UNFL = SLAMCH( 'Safe minimum' )
+*
+* If matrix lower bidiagonal, rotate to be upper bidiagonal
+* by applying Givens rotations on the left
+*
+ IF( LOWER ) THEN
+ DO 10 I = 1, N - 1
+ CALL SLARTG( D( I ), E( I ), CS, SN, R )
+ D( I ) = R
+ E( I ) = SN*D( I+1 )
+ D( I+1 ) = CS*D( I+1 )
+ WORK( I ) = CS
+ WORK( NM1+I ) = SN
+ 10 CONTINUE
+*
+* Update singular vectors if desired
+*
+ IF( NRU.GT.0 )
+ $ CALL SLASR( 'R', 'V', 'F', NRU, N, WORK( 1 ), WORK( N ), U,
+ $ LDU )
+ IF( NCC.GT.0 )
+ $ CALL SLASR( 'L', 'V', 'F', N, NCC, WORK( 1 ), WORK( N ), C,
+ $ LDC )
+ END IF
+*
+* Compute singular values to relative accuracy TOL
+* (By setting TOL to be negative, algorithm will compute
+* singular values to absolute accuracy ABS(TOL)*norm(input matrix))
+*
+ TOLMUL = MAX( TEN, MIN( HNDRD, EPS**MEIGTH ) )
+ TOL = TOLMUL*EPS
+*
+* Compute approximate maximum, minimum singular values
+*
+ SMAX = ZERO
+ DO 20 I = 1, N
+ SMAX = MAX( SMAX, ABS( D( I ) ) )
+ 20 CONTINUE
+ DO 30 I = 1, N - 1
+ SMAX = MAX( SMAX, ABS( E( I ) ) )
+ 30 CONTINUE
+ SMINL = ZERO
+ IF( TOL.GE.ZERO ) THEN
+*
+* Relative accuracy desired
+*
+ SMINOA = ABS( D( 1 ) )
+ IF( SMINOA.EQ.ZERO )
+ $ GO TO 50
+ MU = SMINOA
+ DO 40 I = 2, N
+ MU = ABS( D( I ) )*( MU / ( MU+ABS( E( I-1 ) ) ) )
+ SMINOA = MIN( SMINOA, MU )
+ IF( SMINOA.EQ.ZERO )
+ $ GO TO 50
+ 40 CONTINUE
+ 50 CONTINUE
+ SMINOA = SMINOA / SQRT( REAL( N ) )
+ THRESH = MAX( TOL*SMINOA, MAXITR*N*N*UNFL )
+ ELSE
+*
+* Absolute accuracy desired
+*
+ THRESH = MAX( ABS( TOL )*SMAX, MAXITR*N*N*UNFL )
+ END IF
+*
+* Prepare for main iteration loop for the singular values
+* (MAXIT is the maximum number of passes through the inner
+* loop permitted before nonconvergence signalled.)
+*
+ MAXIT = MAXITR*N*N
+ ITER = 0
+ OLDLL = -1
+ OLDM = -1
+*
+* M points to last element of unconverged part of matrix
+*
+ M = N
+*
+* Begin main iteration loop
+*
+ 60 CONTINUE
+*
+* Check for convergence or exceeding iteration count
+*
+ IF( M.LE.1 )
+ $ GO TO 160
+ IF( ITER.GT.MAXIT )
+ $ GO TO 200
+*
+* Find diagonal block of matrix to work on
+*
+ IF( TOL.LT.ZERO .AND. ABS( D( M ) ).LE.THRESH )
+ $ D( M ) = ZERO
+ SMAX = ABS( D( M ) )
+ SMIN = SMAX
+ DO 70 LLL = 1, M - 1
+ LL = M - LLL
+ ABSS = ABS( D( LL ) )
+ ABSE = ABS( E( LL ) )
+ IF( TOL.LT.ZERO .AND. ABSS.LE.THRESH )
+ $ D( LL ) = ZERO
+ IF( ABSE.LE.THRESH )
+ $ GO TO 80
+ SMIN = MIN( SMIN, ABSS )
+ SMAX = MAX( SMAX, ABSS, ABSE )
+ 70 CONTINUE
+ LL = 0
+ GO TO 90
+ 80 CONTINUE
+ E( LL ) = ZERO
+*
+* Matrix splits since E(LL) = 0
+*
+ IF( LL.EQ.M-1 ) THEN
+*
+* Convergence of bottom singular value, return to top of loop
+*
+ M = M - 1
+ GO TO 60
+ END IF
+ 90 CONTINUE
+ LL = LL + 1
+*
+* E(LL) through E(M-1) are nonzero, E(LL-1) is zero
+*
+ IF( LL.EQ.M-1 ) THEN
+*
+* 2 by 2 block, handle separately
+*
+ CALL SLASV2( D( M-1 ), E( M-1 ), D( M ), SIGMN, SIGMX, SINR,
+ $ COSR, SINL, COSL )
+ D( M-1 ) = SIGMX
+ E( M-1 ) = ZERO
+ D( M ) = SIGMN
+*
+* Compute singular vectors, if desired
+*
+ IF( NCVT.GT.0 )
+ $ CALL SROT( NCVT, VT( M-1, 1 ), LDVT, VT( M, 1 ), LDVT, COSR,
+ $ SINR )
+ IF( NRU.GT.0 )
+ $ CALL SROT( NRU, U( 1, M-1 ), 1, U( 1, M ), 1, COSL, SINL )
+ IF( NCC.GT.0 )
+ $ CALL SROT( NCC, C( M-1, 1 ), LDC, C( M, 1 ), LDC, COSL,
+ $ SINL )
+ M = M - 2
+ GO TO 60
+ END IF
+*
+* If working on new submatrix, choose shift direction
+* (from larger end diagonal element towards smaller)
+*
+ IF( LL.GT.OLDM .OR. M.LT.OLDLL ) THEN
+ IF( ABS( D( LL ) ).GE.ABS( D( M ) ) ) THEN
+*
+* Chase bulge from top (big end) to bottom (small end)
+*
+ IDIR = 1
+ ELSE
+*
+* Chase bulge from bottom (big end) to top (small end)
+*
+ IDIR = 2
+ END IF
+ END IF
+*
+* Apply convergence tests
+*
+ IF( IDIR.EQ.1 ) THEN
+*
+* Run convergence test in forward direction
+* First apply standard test to bottom of matrix
+*
+ IF( ABS( E( M-1 ) ).LE.ABS( TOL )*ABS( D( M ) ) .OR.
+ $ ( TOL.LT.ZERO .AND. ABS( E( M-1 ) ).LE.THRESH ) ) THEN
+ E( M-1 ) = ZERO
+ GO TO 60
+ END IF
+*
+ IF( TOL.GE.ZERO ) THEN
+*
+* If relative accuracy desired,
+* apply convergence criterion forward
+*
+ MU = ABS( D( LL ) )
+ SMINL = MU
+ DO 100 LLL = LL, M - 1
+ IF( ABS( E( LLL ) ).LE.TOL*MU ) THEN
+ E( LLL ) = ZERO
+ GO TO 60
+ END IF
+ MU = ABS( D( LLL+1 ) )*( MU / ( MU+ABS( E( LLL ) ) ) )
+ SMINL = MIN( SMINL, MU )
+ 100 CONTINUE
+ END IF
+*
+ ELSE
+*
+* Run convergence test in backward direction
+* First apply standard test to top of matrix
+*
+ IF( ABS( E( LL ) ).LE.ABS( TOL )*ABS( D( LL ) ) .OR.
+ $ ( TOL.LT.ZERO .AND. ABS( E( LL ) ).LE.THRESH ) ) THEN
+ E( LL ) = ZERO
+ GO TO 60
+ END IF
+*
+ IF( TOL.GE.ZERO ) THEN
+*
+* If relative accuracy desired,
+* apply convergence criterion backward
+*
+ MU = ABS( D( M ) )
+ SMINL = MU
+ DO 110 LLL = M - 1, LL, -1
+ IF( ABS( E( LLL ) ).LE.TOL*MU ) THEN
+ E( LLL ) = ZERO
+ GO TO 60
+ END IF
+ MU = ABS( D( LLL ) )*( MU / ( MU+ABS( E( LLL ) ) ) )
+ SMINL = MIN( SMINL, MU )
+ 110 CONTINUE
+ END IF
+ END IF
+ OLDLL = LL
+ OLDM = M
+*
+* Compute shift. First, test if shifting would ruin relative
+* accuracy, and if so set the shift to zero.
+*
+ IF( TOL.GE.ZERO .AND. N*TOL*( SMINL / SMAX ).LE.
+ $ MAX( EPS, HNDRTH*TOL ) ) THEN
+*
+* Use a zero shift to avoid loss of relative accuracy
+*
+ SHIFT = ZERO
+ ELSE
+*
+* Compute the shift from 2-by-2 block at end of matrix
+*
+ IF( IDIR.EQ.1 ) THEN
+ SLL = ABS( D( LL ) )
+ CALL SLAS2( D( M-1 ), E( M-1 ), D( M ), SHIFT, R )
+ ELSE
+ SLL = ABS( D( M ) )
+ CALL SLAS2( D( LL ), E( LL ), D( LL+1 ), SHIFT, R )
+ END IF
+*
+* Test if shift negligible, and if so set to zero
+*
+ IF( SLL.GT.ZERO ) THEN
+ IF( ( SHIFT / SLL )**2.LT.EPS )
+ $ SHIFT = ZERO
+ END IF
+ END IF
+*
+* Increment iteration count
+*
+ ITER = ITER + M - LL
+*
+* If SHIFT = 0, do simplified QR iteration
+*
+ IF( SHIFT.EQ.ZERO ) THEN
+ IF( IDIR.EQ.1 ) THEN
+*
+* Chase bulge from top to bottom
+* Save cosines and sines for later singular vector updates
+*
+ CS = ONE
+ OLDCS = ONE
+ DO 120 I = LL, M - 1
+ CALL SLARTG( D( I )*CS, E( I ), CS, SN, R )
+ IF( I.GT.LL )
+ $ E( I-1 ) = OLDSN*R
+ CALL SLARTG( OLDCS*R, D( I+1 )*SN, OLDCS, OLDSN, D( I ) )
+ WORK( I-LL+1 ) = CS
+ WORK( I-LL+1+NM1 ) = SN
+ WORK( I-LL+1+NM12 ) = OLDCS
+ WORK( I-LL+1+NM13 ) = OLDSN
+ 120 CONTINUE
+ H = D( M )*CS
+ D( M ) = H*OLDCS
+ E( M-1 ) = H*OLDSN
+*
+* Update singular vectors
+*
+ IF( NCVT.GT.0 )
+ $ CALL SLASR( 'L', 'V', 'F', M-LL+1, NCVT, WORK( 1 ),
+ $ WORK( N ), VT( LL, 1 ), LDVT )
+ IF( NRU.GT.0 )
+ $ CALL SLASR( 'R', 'V', 'F', NRU, M-LL+1, WORK( NM12+1 ),
+ $ WORK( NM13+1 ), U( 1, LL ), LDU )
+ IF( NCC.GT.0 )
+ $ CALL SLASR( 'L', 'V', 'F', M-LL+1, NCC, WORK( NM12+1 ),
+ $ WORK( NM13+1 ), C( LL, 1 ), LDC )
+*
+* Test convergence
+*
+ IF( ABS( E( M-1 ) ).LE.THRESH )
+ $ E( M-1 ) = ZERO
+*
+ ELSE
+*
+* Chase bulge from bottom to top
+* Save cosines and sines for later singular vector updates
+*
+ CS = ONE
+ OLDCS = ONE
+ DO 130 I = M, LL + 1, -1
+ CALL SLARTG( D( I )*CS, E( I-1 ), CS, SN, R )
+ IF( I.LT.M )
+ $ E( I ) = OLDSN*R
+ CALL SLARTG( OLDCS*R, D( I-1 )*SN, OLDCS, OLDSN, D( I ) )
+ WORK( I-LL ) = CS
+ WORK( I-LL+NM1 ) = -SN
+ WORK( I-LL+NM12 ) = OLDCS
+ WORK( I-LL+NM13 ) = -OLDSN
+ 130 CONTINUE
+ H = D( LL )*CS
+ D( LL ) = H*OLDCS
+ E( LL ) = H*OLDSN
+*
+* Update singular vectors
+*
+ IF( NCVT.GT.0 )
+ $ CALL SLASR( 'L', 'V', 'B', M-LL+1, NCVT, WORK( NM12+1 ),
+ $ WORK( NM13+1 ), VT( LL, 1 ), LDVT )
+ IF( NRU.GT.0 )
+ $ CALL SLASR( 'R', 'V', 'B', NRU, M-LL+1, WORK( 1 ),
+ $ WORK( N ), U( 1, LL ), LDU )
+ IF( NCC.GT.0 )
+ $ CALL SLASR( 'L', 'V', 'B', M-LL+1, NCC, WORK( 1 ),
+ $ WORK( N ), C( LL, 1 ), LDC )
+*
+* Test convergence
+*
+ IF( ABS( E( LL ) ).LE.THRESH )
+ $ E( LL ) = ZERO
+ END IF
+ ELSE
+*
+* Use nonzero shift
+*
+ IF( IDIR.EQ.1 ) THEN
+*
+* Chase bulge from top to bottom
+* Save cosines and sines for later singular vector updates
+*
+ F = ( ABS( D( LL ) )-SHIFT )*
+ $ ( SIGN( ONE, D( LL ) )+SHIFT / D( LL ) )
+ G = E( LL )
+ DO 140 I = LL, M - 1
+ CALL SLARTG( F, G, COSR, SINR, R )
+ IF( I.GT.LL )
+ $ E( I-1 ) = R
+ F = COSR*D( I ) + SINR*E( I )
+ E( I ) = COSR*E( I ) - SINR*D( I )
+ G = SINR*D( I+1 )
+ D( I+1 ) = COSR*D( I+1 )
+ CALL SLARTG( F, G, COSL, SINL, R )
+ D( I ) = R
+ F = COSL*E( I ) + SINL*D( I+1 )
+ D( I+1 ) = COSL*D( I+1 ) - SINL*E( I )
+ IF( I.LT.M-1 ) THEN
+ G = SINL*E( I+1 )
+ E( I+1 ) = COSL*E( I+1 )
+ END IF
+ WORK( I-LL+1 ) = COSR
+ WORK( I-LL+1+NM1 ) = SINR
+ WORK( I-LL+1+NM12 ) = COSL
+ WORK( I-LL+1+NM13 ) = SINL
+ 140 CONTINUE
+ E( M-1 ) = F
+*
+* Update singular vectors
+*
+ IF( NCVT.GT.0 )
+ $ CALL SLASR( 'L', 'V', 'F', M-LL+1, NCVT, WORK( 1 ),
+ $ WORK( N ), VT( LL, 1 ), LDVT )
+ IF( NRU.GT.0 )
+ $ CALL SLASR( 'R', 'V', 'F', NRU, M-LL+1, WORK( NM12+1 ),
+ $ WORK( NM13+1 ), U( 1, LL ), LDU )
+ IF( NCC.GT.0 )
+ $ CALL SLASR( 'L', 'V', 'F', M-LL+1, NCC, WORK( NM12+1 ),
+ $ WORK( NM13+1 ), C( LL, 1 ), LDC )
+*
+* Test convergence
+*
+ IF( ABS( E( M-1 ) ).LE.THRESH )
+ $ E( M-1 ) = ZERO
+*
+ ELSE
+*
+* Chase bulge from bottom to top
+* Save cosines and sines for later singular vector updates
+*
+ F = ( ABS( D( M ) )-SHIFT )*( SIGN( ONE, D( M ) )+SHIFT /
+ $ D( M ) )
+ G = E( M-1 )
+ DO 150 I = M, LL + 1, -1
+ CALL SLARTG( F, G, COSR, SINR, R )
+ IF( I.LT.M )
+ $ E( I ) = R
+ F = COSR*D( I ) + SINR*E( I-1 )
+ E( I-1 ) = COSR*E( I-1 ) - SINR*D( I )
+ G = SINR*D( I-1 )
+ D( I-1 ) = COSR*D( I-1 )
+ CALL SLARTG( F, G, COSL, SINL, R )
+ D( I ) = R
+ F = COSL*E( I-1 ) + SINL*D( I-1 )
+ D( I-1 ) = COSL*D( I-1 ) - SINL*E( I-1 )
+ IF( I.GT.LL+1 ) THEN
+ G = SINL*E( I-2 )
+ E( I-2 ) = COSL*E( I-2 )
+ END IF
+ WORK( I-LL ) = COSR
+ WORK( I-LL+NM1 ) = -SINR
+ WORK( I-LL+NM12 ) = COSL
+ WORK( I-LL+NM13 ) = -SINL
+ 150 CONTINUE
+ E( LL ) = F
+*
+* Test convergence
+*
+ IF( ABS( E( LL ) ).LE.THRESH )
+ $ E( LL ) = ZERO
+*
+* Update singular vectors if desired
+*
+ IF( NCVT.GT.0 )
+ $ CALL SLASR( 'L', 'V', 'B', M-LL+1, NCVT, WORK( NM12+1 ),
+ $ WORK( NM13+1 ), VT( LL, 1 ), LDVT )
+ IF( NRU.GT.0 )
+ $ CALL SLASR( 'R', 'V', 'B', NRU, M-LL+1, WORK( 1 ),
+ $ WORK( N ), U( 1, LL ), LDU )
+ IF( NCC.GT.0 )
+ $ CALL SLASR( 'L', 'V', 'B', M-LL+1, NCC, WORK( 1 ),
+ $ WORK( N ), C( LL, 1 ), LDC )
+ END IF
+ END IF
+*
+* QR iteration finished, go back and check convergence
+*
+ GO TO 60
+*
+* All singular values converged, so make them positive
+*
+ 160 CONTINUE
+ DO 170 I = 1, N
+ IF( D( I ).LT.ZERO ) THEN
+ D( I ) = -D( I )
+*
+* Change sign of singular vectors, if desired
+*
+ IF( NCVT.GT.0 )
+ $ CALL SSCAL( NCVT, NEGONE, VT( I, 1 ), LDVT )
+ END IF
+ 170 CONTINUE
+*
+* Sort the singular values into decreasing order (insertion sort on
+* singular values, but only one transposition per singular vector)
+*
+ DO 190 I = 1, N - 1
+*
+* Scan for smallest D(I)
+*
+ ISUB = 1
+ SMIN = D( 1 )
+ DO 180 J = 2, N + 1 - I
+ IF( D( J ).LE.SMIN ) THEN
+ ISUB = J
+ SMIN = D( J )
+ END IF
+ 180 CONTINUE
+ IF( ISUB.NE.N+1-I ) THEN
+*
+* Swap singular values and vectors
+*
+ D( ISUB ) = D( N+1-I )
+ D( N+1-I ) = SMIN
+ IF( NCVT.GT.0 )
+ $ CALL SSWAP( NCVT, VT( ISUB, 1 ), LDVT, VT( N+1-I, 1 ),
+ $ LDVT )
+ IF( NRU.GT.0 )
+ $ CALL SSWAP( NRU, U( 1, ISUB ), 1, U( 1, N+1-I ), 1 )
+ IF( NCC.GT.0 )
+ $ CALL SSWAP( NCC, C( ISUB, 1 ), LDC, C( N+1-I, 1 ), LDC )
+ END IF
+ 190 CONTINUE
+ GO TO 220
+*
+* Maximum number of iterations exceeded, failure to converge
+*
+ 200 CONTINUE
+ INFO = 0
+ DO 210 I = 1, N - 1
+ IF( E( I ).NE.ZERO )
+ $ INFO = INFO + 1
+ 210 CONTINUE
+ 220 CONTINUE
+ RETURN
+*
+* End of SBDSQR
+*
+ END
+ SUBROUTINE SDISNA( JOB, M, N, D, SEP, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER JOB
+ INTEGER INFO, M, N
+* ..
+* .. Array Arguments ..
+ REAL D( * ), SEP( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SDISNA computes the reciprocal condition numbers for the eigenvectors
+* of a real symmetric or complex Hermitian matrix or for the left or
+* right singular vectors of a general m-by-n matrix. The reciprocal
+* condition number is the 'gap' between the corresponding eigenvalue or
+* singular value and the nearest other one.
+*
+* The bound on the error, measured by angle in radians, in the I-th
+* computed vector is given by
+*
+* SLAMCH( 'E' ) * ( ANORM / SEP( I ) )
+*
+* where ANORM = 2-norm(A) = max( abs( D(j) ) ). SEP(I) is not allowed
+* to be smaller than SLAMCH( 'E' )*ANORM in order to limit the size of
+* the error bound.
+*
+* SDISNA may also be used to compute error bounds for eigenvectors of
+* the generalized symmetric definite eigenproblem.
+*
+* Arguments
+* =========
+*
+* JOB (input) CHARACTER*1
+* Specifies for which problem the reciprocal condition numbers
+* should be computed:
+* = 'E': the eigenvectors of a symmetric/Hermitian matrix;
+* = 'L': the left singular vectors of a general matrix;
+* = 'R': the right singular vectors of a general matrix.
+*
+* M (input) INTEGER
+* The number of rows of the matrix. M >= 0.
+*
+* N (input) INTEGER
+* If JOB = 'L' or 'R', the number of columns of the matrix,
+* in which case N >= 0. Ignored if JOB = 'E'.
+*
+* D (input) REAL array, dimension (M) if JOB = 'E'
+* dimension (min(M,N)) if JOB = 'L' or 'R'
+* The eigenvalues (if JOB = 'E') or singular values (if JOB =
+* 'L' or 'R') of the matrix, in either increasing or decreasing
+* order. If singular values, they must be non-negative.
+*
+* SEP (output) REAL array, dimension (M) if JOB = 'E'
+* dimension (min(M,N)) if JOB = 'L' or 'R'
+* The reciprocal condition numbers of the vectors.
+*
+* INFO (output) INTEGER
+* = 0: successful exit.
+* < 0: if INFO = -i, the i-th argument had an illegal value.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO
+ PARAMETER ( ZERO = 0.0E+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL DECR, EIGEN, INCR, LEFT, RIGHT, SING
+ INTEGER I, K
+ REAL ANORM, EPS, NEWGAP, OLDGAP, SAFMIN, THRESH
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ REAL SLAMCH
+ EXTERNAL LSAME, SLAMCH
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, MIN
+* ..
+* .. External Subroutines ..
+ EXTERNAL XERBLA
+* ..
+* .. Executable Statements ..
+*
+* Test the input arguments
+*
+ INFO = 0
+ EIGEN = LSAME( JOB, 'E' )
+ LEFT = LSAME( JOB, 'L' )
+ RIGHT = LSAME( JOB, 'R' )
+ SING = LEFT .OR. RIGHT
+ IF( EIGEN ) THEN
+ K = M
+ ELSE IF( SING ) THEN
+ K = MIN( M, N )
+ END IF
+ IF( .NOT.EIGEN .AND. .NOT.SING ) THEN
+ INFO = -1
+ ELSE IF( M.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( K.LT.0 ) THEN
+ INFO = -3
+ ELSE
+ INCR = .TRUE.
+ DECR = .TRUE.
+ DO 10 I = 1, K - 1
+ IF( INCR )
+ $ INCR = INCR .AND. D( I ).LE.D( I+1 )
+ IF( DECR )
+ $ DECR = DECR .AND. D( I ).GE.D( I+1 )
+ 10 CONTINUE
+ IF( SING .AND. K.GT.0 ) THEN
+ IF( INCR )
+ $ INCR = INCR .AND. ZERO.LE.D( 1 )
+ IF( DECR )
+ $ DECR = DECR .AND. D( K ).GE.ZERO
+ END IF
+ IF( .NOT.( INCR .OR. DECR ) )
+ $ INFO = -4
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SDISNA', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( K.EQ.0 )
+ $ RETURN
+*
+* Compute reciprocal condition numbers
+*
+ IF( K.EQ.1 ) THEN
+ SEP( 1 ) = SLAMCH( 'O' )
+ ELSE
+ OLDGAP = ABS( D( 2 )-D( 1 ) )
+ SEP( 1 ) = OLDGAP
+ DO 20 I = 2, K - 1
+ NEWGAP = ABS( D( I+1 )-D( I ) )
+ SEP( I ) = MIN( OLDGAP, NEWGAP )
+ OLDGAP = NEWGAP
+ 20 CONTINUE
+ SEP( K ) = OLDGAP
+ END IF
+ IF( SING ) THEN
+ IF( ( LEFT .AND. M.GT.N ) .OR. ( RIGHT .AND. M.LT.N ) ) THEN
+ IF( INCR )
+ $ SEP( 1 ) = MIN( SEP( 1 ), D( 1 ) )
+ IF( DECR )
+ $ SEP( K ) = MIN( SEP( K ), D( K ) )
+ END IF
+ END IF
+*
+* Ensure that reciprocal condition numbers are not less than
+* threshold, in order to limit the size of the error bound
+*
+ EPS = SLAMCH( 'E' )
+ SAFMIN = SLAMCH( 'S' )
+ ANORM = MAX( ABS( D( 1 ) ), ABS( D( K ) ) )
+ IF( ANORM.EQ.ZERO ) THEN
+ THRESH = EPS
+ ELSE
+ THRESH = MAX( EPS*ANORM, SAFMIN )
+ END IF
+ DO 30 I = 1, K
+ SEP( I ) = MAX( SEP( I ), THRESH )
+ 30 CONTINUE
+*
+ RETURN
+*
+* End of SDISNA
+*
+ END
+ SUBROUTINE SGBBRD( VECT, M, N, NCC, KL, KU, AB, LDAB, D, E, Q,
+ $ LDQ, PT, LDPT, C, LDC, WORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER VECT
+ INTEGER INFO, KL, KU, LDAB, LDC, LDPT, LDQ, M, N, NCC
+* ..
+* .. Array Arguments ..
+ REAL AB( LDAB, * ), C( LDC, * ), D( * ), E( * ),
+ $ PT( LDPT, * ), Q( LDQ, * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SGBBRD reduces a real general m-by-n band matrix A to upper
+* bidiagonal form B by an orthogonal transformation: Q' * A * P = B.
+*
+* The routine computes B, and optionally forms Q or P', or computes
+* Q'*C for a given matrix C.
+*
+* Arguments
+* =========
+*
+* VECT (input) CHARACTER*1
+* Specifies whether or not the matrices Q and P' are to be
+* formed.
+* = 'N': do not form Q or P';
+* = 'Q': form Q only;
+* = 'P': form P' only;
+* = 'B': form both.
+*
+* M (input) INTEGER
+* The number of rows of the matrix A. M >= 0.
+*
+* N (input) INTEGER
+* The number of columns of the matrix A. N >= 0.
+*
+* NCC (input) INTEGER
+* The number of columns of the matrix C. NCC >= 0.
+*
+* KL (input) INTEGER
+* The number of subdiagonals of the matrix A. KL >= 0.
+*
+* KU (input) INTEGER
+* The number of superdiagonals of the matrix A. KU >= 0.
+*
+* AB (input/output) REAL array, dimension (LDAB,N)
+* On entry, the m-by-n band matrix A, stored in rows 1 to
+* KL+KU+1. The j-th column of A is stored in the j-th column of
+* the array AB as follows:
+* AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl).
+* On exit, A is overwritten by values generated during the
+* reduction.
+*
+* LDAB (input) INTEGER
+* The leading dimension of the array A. LDAB >= KL+KU+1.
+*
+* D (output) REAL array, dimension (min(M,N))
+* The diagonal elements of the bidiagonal matrix B.
+*
+* E (output) REAL array, dimension (min(M,N)-1)
+* The superdiagonal elements of the bidiagonal matrix B.
+*
+* Q (output) REAL array, dimension (LDQ,M)
+* If VECT = 'Q' or 'B', the m-by-m orthogonal matrix Q.
+* If VECT = 'N' or 'P', the array Q is not referenced.
+*
+* LDQ (input) INTEGER
+* The leading dimension of the array Q.
+* LDQ >= max(1,M) if VECT = 'Q' or 'B'; LDQ >= 1 otherwise.
+*
+* PT (output) REAL array, dimension (LDPT,N)
+* If VECT = 'P' or 'B', the n-by-n orthogonal matrix P'.
+* If VECT = 'N' or 'Q', the array PT is not referenced.
+*
+* LDPT (input) INTEGER
+* The leading dimension of the array PT.
+* LDPT >= max(1,N) if VECT = 'P' or 'B'; LDPT >= 1 otherwise.
+*
+* C (input/output) REAL array, dimension (LDC,NCC)
+* On entry, an m-by-ncc matrix C.
+* On exit, C is overwritten by Q'*C.
+* C is not referenced if NCC = 0.
+*
+* LDC (input) INTEGER
+* The leading dimension of the array C.
+* LDC >= max(1,M) if NCC > 0; LDC >= 1 if NCC = 0.
+*
+* WORK (workspace) REAL array, dimension (2*max(M,N))
+*
+* INFO (output) INTEGER
+* = 0: successful exit.
+* < 0: if INFO = -i, the i-th argument had an illegal value.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO, ONE
+ PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL WANTB, WANTC, WANTPT, WANTQ
+ INTEGER I, INCA, J, J1, J2, KB, KB1, KK, KLM, KLU1,
+ $ KUN, L, MINMN, ML, ML0, MN, MU, MU0, NR, NRT
+ REAL RA, RB, RC, RS
+* ..
+* .. External Subroutines ..
+ EXTERNAL SLARGV, SLARTG, SLARTV, SLASET, SROT, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters
+*
+ WANTB = LSAME( VECT, 'B' )
+ WANTQ = LSAME( VECT, 'Q' ) .OR. WANTB
+ WANTPT = LSAME( VECT, 'P' ) .OR. WANTB
+ WANTC = NCC.GT.0
+ KLU1 = KL + KU + 1
+ INFO = 0
+ IF( .NOT.WANTQ .AND. .NOT.WANTPT .AND. .NOT.LSAME( VECT, 'N' ) )
+ $ THEN
+ INFO = -1
+ ELSE IF( M.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( NCC.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( KL.LT.0 ) THEN
+ INFO = -5
+ ELSE IF( KU.LT.0 ) THEN
+ INFO = -6
+ ELSE IF( LDAB.LT.KLU1 ) THEN
+ INFO = -8
+ ELSE IF( LDQ.LT.1 .OR. WANTQ .AND. LDQ.LT.MAX( 1, M ) ) THEN
+ INFO = -12
+ ELSE IF( LDPT.LT.1 .OR. WANTPT .AND. LDPT.LT.MAX( 1, N ) ) THEN
+ INFO = -14
+ ELSE IF( LDC.LT.1 .OR. WANTC .AND. LDC.LT.MAX( 1, M ) ) THEN
+ INFO = -16
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SGBBRD', -INFO )
+ RETURN
+ END IF
+*
+* Initialize Q and P' to the unit matrix, if needed
+*
+ IF( WANTQ )
+ $ CALL SLASET( 'Full', M, M, ZERO, ONE, Q, LDQ )
+ IF( WANTPT )
+ $ CALL SLASET( 'Full', N, N, ZERO, ONE, PT, LDPT )
+*
+* Quick return if possible.
+*
+ IF( M.EQ.0 .OR. N.EQ.0 )
+ $ RETURN
+*
+ MINMN = MIN( M, N )
+*
+ IF( KL+KU.GT.1 ) THEN
+*
+* Reduce to upper bidiagonal form if KU > 0; if KU = 0, reduce
+* first to lower bidiagonal form and then transform to upper
+* bidiagonal
+*
+ IF( KU.GT.0 ) THEN
+ ML0 = 1
+ MU0 = 2
+ ELSE
+ ML0 = 2
+ MU0 = 1
+ END IF
+*
+* Wherever possible, plane rotations are generated and applied in
+* vector operations of length NR over the index set J1:J2:KLU1.
+*
+* The sines of the plane rotations are stored in WORK(1:max(m,n))
+* and the cosines in WORK(max(m,n)+1:2*max(m,n)).
+*
+ MN = MAX( M, N )
+ KLM = MIN( M-1, KL )
+ KUN = MIN( N-1, KU )
+ KB = KLM + KUN
+ KB1 = KB + 1
+ INCA = KB1*LDAB
+ NR = 0
+ J1 = KLM + 2
+ J2 = 1 - KUN
+*
+ DO 90 I = 1, MINMN
+*
+* Reduce i-th column and i-th row of matrix to bidiagonal form
+*
+ ML = KLM + 1
+ MU = KUN + 1
+ DO 80 KK = 1, KB
+ J1 = J1 + KB
+ J2 = J2 + KB
+*
+* generate plane rotations to annihilate nonzero elements
+* which have been created below the band
+*
+ IF( NR.GT.0 )
+ $ CALL SLARGV( NR, AB( KLU1, J1-KLM-1 ), INCA,
+ $ WORK( J1 ), KB1, WORK( MN+J1 ), KB1 )
+*
+* apply plane rotations from the left
+*
+ DO 10 L = 1, KB
+ IF( J2-KLM+L-1.GT.N ) THEN
+ NRT = NR - 1
+ ELSE
+ NRT = NR
+ END IF
+ IF( NRT.GT.0 )
+ $ CALL SLARTV( NRT, AB( KLU1-L, J1-KLM+L-1 ), INCA,
+ $ AB( KLU1-L+1, J1-KLM+L-1 ), INCA,
+ $ WORK( MN+J1 ), WORK( J1 ), KB1 )
+ 10 CONTINUE
+*
+ IF( ML.GT.ML0 ) THEN
+ IF( ML.LE.M-I+1 ) THEN
+*
+* generate plane rotation to annihilate a(i+ml-1,i)
+* within the band, and apply rotation from the left
+*
+ CALL SLARTG( AB( KU+ML-1, I ), AB( KU+ML, I ),
+ $ WORK( MN+I+ML-1 ), WORK( I+ML-1 ),
+ $ RA )
+ AB( KU+ML-1, I ) = RA
+ IF( I.LT.N )
+ $ CALL SROT( MIN( KU+ML-2, N-I ),
+ $ AB( KU+ML-2, I+1 ), LDAB-1,
+ $ AB( KU+ML-1, I+1 ), LDAB-1,
+ $ WORK( MN+I+ML-1 ), WORK( I+ML-1 ) )
+ END IF
+ NR = NR + 1
+ J1 = J1 - KB1
+ END IF
+*
+ IF( WANTQ ) THEN
+*
+* accumulate product of plane rotations in Q
+*
+ DO 20 J = J1, J2, KB1
+ CALL SROT( M, Q( 1, J-1 ), 1, Q( 1, J ), 1,
+ $ WORK( MN+J ), WORK( J ) )
+ 20 CONTINUE
+ END IF
+*
+ IF( WANTC ) THEN
+*
+* apply plane rotations to C
+*
+ DO 30 J = J1, J2, KB1
+ CALL SROT( NCC, C( J-1, 1 ), LDC, C( J, 1 ), LDC,
+ $ WORK( MN+J ), WORK( J ) )
+ 30 CONTINUE
+ END IF
+*
+ IF( J2+KUN.GT.N ) THEN
+*
+* adjust J2 to keep within the bounds of the matrix
+*
+ NR = NR - 1
+ J2 = J2 - KB1
+ END IF
+*
+ DO 40 J = J1, J2, KB1
+*
+* create nonzero element a(j-1,j+ku) above the band
+* and store it in WORK(n+1:2*n)
+*
+ WORK( J+KUN ) = WORK( J )*AB( 1, J+KUN )
+ AB( 1, J+KUN ) = WORK( MN+J )*AB( 1, J+KUN )
+ 40 CONTINUE
+*
+* generate plane rotations to annihilate nonzero elements
+* which have been generated above the band
+*
+ IF( NR.GT.0 )
+ $ CALL SLARGV( NR, AB( 1, J1+KUN-1 ), INCA,
+ $ WORK( J1+KUN ), KB1, WORK( MN+J1+KUN ),
+ $ KB1 )
+*
+* apply plane rotations from the right
+*
+ DO 50 L = 1, KB
+ IF( J2+L-1.GT.M ) THEN
+ NRT = NR - 1
+ ELSE
+ NRT = NR
+ END IF
+ IF( NRT.GT.0 )
+ $ CALL SLARTV( NRT, AB( L+1, J1+KUN-1 ), INCA,
+ $ AB( L, J1+KUN ), INCA,
+ $ WORK( MN+J1+KUN ), WORK( J1+KUN ),
+ $ KB1 )
+ 50 CONTINUE
+*
+ IF( ML.EQ.ML0 .AND. MU.GT.MU0 ) THEN
+ IF( MU.LE.N-I+1 ) THEN
+*
+* generate plane rotation to annihilate a(i,i+mu-1)
+* within the band, and apply rotation from the right
+*
+ CALL SLARTG( AB( KU-MU+3, I+MU-2 ),
+ $ AB( KU-MU+2, I+MU-1 ),
+ $ WORK( MN+I+MU-1 ), WORK( I+MU-1 ),
+ $ RA )
+ AB( KU-MU+3, I+MU-2 ) = RA
+ CALL SROT( MIN( KL+MU-2, M-I ),
+ $ AB( KU-MU+4, I+MU-2 ), 1,
+ $ AB( KU-MU+3, I+MU-1 ), 1,
+ $ WORK( MN+I+MU-1 ), WORK( I+MU-1 ) )
+ END IF
+ NR = NR + 1
+ J1 = J1 - KB1
+ END IF
+*
+ IF( WANTPT ) THEN
+*
+* accumulate product of plane rotations in P'
+*
+ DO 60 J = J1, J2, KB1
+ CALL SROT( N, PT( J+KUN-1, 1 ), LDPT,
+ $ PT( J+KUN, 1 ), LDPT, WORK( MN+J+KUN ),
+ $ WORK( J+KUN ) )
+ 60 CONTINUE
+ END IF
+*
+ IF( J2+KB.GT.M ) THEN
+*
+* adjust J2 to keep within the bounds of the matrix
+*
+ NR = NR - 1
+ J2 = J2 - KB1
+ END IF
+*
+ DO 70 J = J1, J2, KB1
+*
+* create nonzero element a(j+kl+ku,j+ku-1) below the
+* band and store it in WORK(1:n)
+*
+ WORK( J+KB ) = WORK( J+KUN )*AB( KLU1, J+KUN )
+ AB( KLU1, J+KUN ) = WORK( MN+J+KUN )*AB( KLU1, J+KUN )
+ 70 CONTINUE
+*
+ IF( ML.GT.ML0 ) THEN
+ ML = ML - 1
+ ELSE
+ MU = MU - 1
+ END IF
+ 80 CONTINUE
+ 90 CONTINUE
+ END IF
+*
+ IF( KU.EQ.0 .AND. KL.GT.0 ) THEN
+*
+* A has been reduced to lower bidiagonal form
+*
+* Transform lower bidiagonal form to upper bidiagonal by applying
+* plane rotations from the left, storing diagonal elements in D
+* and off-diagonal elements in E
+*
+ DO 100 I = 1, MIN( M-1, N )
+ CALL SLARTG( AB( 1, I ), AB( 2, I ), RC, RS, RA )
+ D( I ) = RA
+ IF( I.LT.N ) THEN
+ E( I ) = RS*AB( 1, I+1 )
+ AB( 1, I+1 ) = RC*AB( 1, I+1 )
+ END IF
+ IF( WANTQ )
+ $ CALL SROT( M, Q( 1, I ), 1, Q( 1, I+1 ), 1, RC, RS )
+ IF( WANTC )
+ $ CALL SROT( NCC, C( I, 1 ), LDC, C( I+1, 1 ), LDC, RC,
+ $ RS )
+ 100 CONTINUE
+ IF( M.LE.N )
+ $ D( M ) = AB( 1, M )
+ ELSE IF( KU.GT.0 ) THEN
+*
+* A has been reduced to upper bidiagonal form
+*
+ IF( M.LT.N ) THEN
+*
+* Annihilate a(m,m+1) by applying plane rotations from the
+* right, storing diagonal elements in D and off-diagonal
+* elements in E
+*
+ RB = AB( KU, M+1 )
+ DO 110 I = M, 1, -1
+ CALL SLARTG( AB( KU+1, I ), RB, RC, RS, RA )
+ D( I ) = RA
+ IF( I.GT.1 ) THEN
+ RB = -RS*AB( KU, I )
+ E( I-1 ) = RC*AB( KU, I )
+ END IF
+ IF( WANTPT )
+ $ CALL SROT( N, PT( I, 1 ), LDPT, PT( M+1, 1 ), LDPT,
+ $ RC, RS )
+ 110 CONTINUE
+ ELSE
+*
+* Copy off-diagonal elements to E and diagonal elements to D
+*
+ DO 120 I = 1, MINMN - 1
+ E( I ) = AB( KU, I+1 )
+ 120 CONTINUE
+ DO 130 I = 1, MINMN
+ D( I ) = AB( KU+1, I )
+ 130 CONTINUE
+ END IF
+ ELSE
+*
+* A is diagonal. Set elements of E to zero and copy diagonal
+* elements to D.
+*
+ DO 140 I = 1, MINMN - 1
+ E( I ) = ZERO
+ 140 CONTINUE
+ DO 150 I = 1, MINMN
+ D( I ) = AB( 1, I )
+ 150 CONTINUE
+ END IF
+ RETURN
+*
+* End of SGBBRD
+*
+ END
+ SUBROUTINE SGBCON( NORM, N, KL, KU, AB, LDAB, IPIV, ANORM, RCOND,
+ $ WORK, IWORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* Modified to call SLACN2 in place of SLACON, 7 Feb 03, SJH.
+*
+* .. Scalar Arguments ..
+ CHARACTER NORM
+ INTEGER INFO, KL, KU, LDAB, N
+ REAL ANORM, RCOND
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * ), IWORK( * )
+ REAL AB( LDAB, * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SGBCON estimates the reciprocal of the condition number of a real
+* general band matrix A, in either the 1-norm or the infinity-norm,
+* using the LU factorization computed by SGBTRF.
+*
+* An estimate is obtained for norm(inv(A)), and the reciprocal of the
+* condition number is computed as
+* RCOND = 1 / ( norm(A) * norm(inv(A)) ).
+*
+* Arguments
+* =========
+*
+* NORM (input) CHARACTER*1
+* Specifies whether the 1-norm condition number or the
+* infinity-norm condition number is required:
+* = '1' or 'O': 1-norm;
+* = 'I': Infinity-norm.
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* KL (input) INTEGER
+* The number of subdiagonals within the band of A. KL >= 0.
+*
+* KU (input) INTEGER
+* The number of superdiagonals within the band of A. KU >= 0.
+*
+* AB (input) REAL array, dimension (LDAB,N)
+* Details of the LU factorization of the band matrix A, as
+* computed by SGBTRF. U is stored as an upper triangular band
+* matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and
+* the multipliers used during the factorization are stored in
+* rows KL+KU+2 to 2*KL+KU+1.
+*
+* LDAB (input) INTEGER
+* The leading dimension of the array AB. LDAB >= 2*KL+KU+1.
+*
+* IPIV (input) INTEGER array, dimension (N)
+* The pivot indices; for 1 <= i <= N, row i of the matrix was
+* interchanged with row IPIV(i).
+*
+* ANORM (input) REAL
+* If NORM = '1' or 'O', the 1-norm of the original matrix A.
+* If NORM = 'I', the infinity-norm of the original matrix A.
+*
+* RCOND (output) REAL
+* The reciprocal of the condition number of the matrix A,
+* computed as RCOND = 1/(norm(A) * norm(inv(A))).
+*
+* WORK (workspace) REAL array, dimension (3*N)
+*
+* IWORK (workspace) INTEGER array, dimension (N)
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ONE, ZERO
+ PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL LNOTI, ONENRM
+ CHARACTER NORMIN
+ INTEGER IX, J, JP, KASE, KASE1, KD, LM
+ REAL AINVNM, SCALE, SMLNUM, T
+* ..
+* .. Local Arrays ..
+ INTEGER ISAVE( 3 )
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ISAMAX
+ REAL SDOT, SLAMCH
+ EXTERNAL LSAME, ISAMAX, SDOT, SLAMCH
+* ..
+* .. External Subroutines ..
+ EXTERNAL SAXPY, SLACN2, SLATBS, SRSCL, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MIN
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ ONENRM = NORM.EQ.'1' .OR. LSAME( NORM, 'O' )
+ IF( .NOT.ONENRM .AND. .NOT.LSAME( NORM, 'I' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( KL.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( KU.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( LDAB.LT.2*KL+KU+1 ) THEN
+ INFO = -6
+ ELSE IF( ANORM.LT.ZERO ) THEN
+ INFO = -8
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SGBCON', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ RCOND = ZERO
+ IF( N.EQ.0 ) THEN
+ RCOND = ONE
+ RETURN
+ ELSE IF( ANORM.EQ.ZERO ) THEN
+ RETURN
+ END IF
+*
+ SMLNUM = SLAMCH( 'Safe minimum' )
+*
+* Estimate the norm of inv(A).
+*
+ AINVNM = ZERO
+ NORMIN = 'N'
+ IF( ONENRM ) THEN
+ KASE1 = 1
+ ELSE
+ KASE1 = 2
+ END IF
+ KD = KL + KU + 1
+ LNOTI = KL.GT.0
+ KASE = 0
+ 10 CONTINUE
+ CALL SLACN2( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE, ISAVE )
+ IF( KASE.NE.0 ) THEN
+ IF( KASE.EQ.KASE1 ) THEN
+*
+* Multiply by inv(L).
+*
+ IF( LNOTI ) THEN
+ DO 20 J = 1, N - 1
+ LM = MIN( KL, N-J )
+ JP = IPIV( J )
+ T = WORK( JP )
+ IF( JP.NE.J ) THEN
+ WORK( JP ) = WORK( J )
+ WORK( J ) = T
+ END IF
+ CALL SAXPY( LM, -T, AB( KD+1, J ), 1, WORK( J+1 ), 1 )
+ 20 CONTINUE
+ END IF
+*
+* Multiply by inv(U).
+*
+ CALL SLATBS( 'Upper', 'No transpose', 'Non-unit', NORMIN, N,
+ $ KL+KU, AB, LDAB, WORK, SCALE, WORK( 2*N+1 ),
+ $ INFO )
+ ELSE
+*
+* Multiply by inv(U').
+*
+ CALL SLATBS( 'Upper', 'Transpose', 'Non-unit', NORMIN, N,
+ $ KL+KU, AB, LDAB, WORK, SCALE, WORK( 2*N+1 ),
+ $ INFO )
+*
+* Multiply by inv(L').
+*
+ IF( LNOTI ) THEN
+ DO 30 J = N - 1, 1, -1
+ LM = MIN( KL, N-J )
+ WORK( J ) = WORK( J ) - SDOT( LM, AB( KD+1, J ), 1,
+ $ WORK( J+1 ), 1 )
+ JP = IPIV( J )
+ IF( JP.NE.J ) THEN
+ T = WORK( JP )
+ WORK( JP ) = WORK( J )
+ WORK( J ) = T
+ END IF
+ 30 CONTINUE
+ END IF
+ END IF
+*
+* Divide X by 1/SCALE if doing so will not cause overflow.
+*
+ NORMIN = 'Y'
+ IF( SCALE.NE.ONE ) THEN
+ IX = ISAMAX( N, WORK, 1 )
+ IF( SCALE.LT.ABS( WORK( IX ) )*SMLNUM .OR. SCALE.EQ.ZERO )
+ $ GO TO 40
+ CALL SRSCL( N, SCALE, WORK, 1 )
+ END IF
+ GO TO 10
+ END IF
+*
+* Compute the estimate of the reciprocal condition number.
+*
+ IF( AINVNM.NE.ZERO )
+ $ RCOND = ( ONE / AINVNM ) / ANORM
+*
+ 40 CONTINUE
+ RETURN
+*
+* End of SGBCON
+*
+ END
+ SUBROUTINE SGBEQU( M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND,
+ $ AMAX, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, KL, KU, LDAB, M, N
+ REAL AMAX, COLCND, ROWCND
+* ..
+* .. Array Arguments ..
+ REAL AB( LDAB, * ), C( * ), R( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SGBEQU computes row and column scalings intended to equilibrate an
+* M-by-N band matrix A and reduce its condition number. R returns the
+* row scale factors and C the column scale factors, chosen to try to
+* make the largest element in each row and column of the matrix B with
+* elements B(i,j)=R(i)*A(i,j)*C(j) have absolute value 1.
+*
+* R(i) and C(j) are restricted to be between SMLNUM = smallest safe
+* number and BIGNUM = largest safe number. Use of these scaling
+* factors is not guaranteed to reduce the condition number of A but
+* works well in practice.
+*
+* Arguments
+* =========
+*
+* M (input) INTEGER
+* The number of rows of the matrix A. M >= 0.
+*
+* N (input) INTEGER
+* The number of columns of the matrix A. N >= 0.
+*
+* KL (input) INTEGER
+* The number of subdiagonals within the band of A. KL >= 0.
+*
+* KU (input) INTEGER
+* The number of superdiagonals within the band of A. KU >= 0.
+*
+* AB (input) REAL array, dimension (LDAB,N)
+* The band matrix A, stored in rows 1 to KL+KU+1. The j-th
+* column of A is stored in the j-th column of the array AB as
+* follows:
+* AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl).
+*
+* LDAB (input) INTEGER
+* The leading dimension of the array AB. LDAB >= KL+KU+1.
+*
+* R (output) REAL array, dimension (M)
+* If INFO = 0, or INFO > M, R contains the row scale factors
+* for A.
+*
+* C (output) REAL array, dimension (N)
+* If INFO = 0, C contains the column scale factors for A.
+*
+* ROWCND (output) REAL
+* If INFO = 0 or INFO > M, ROWCND contains the ratio of the
+* smallest R(i) to the largest R(i). If ROWCND >= 0.1 and
+* AMAX is neither too large nor too small, it is not worth
+* scaling by R.
+*
+* COLCND (output) REAL
+* If INFO = 0, COLCND contains the ratio of the smallest
+* C(i) to the largest C(i). If COLCND >= 0.1, it is not
+* worth scaling by C.
+*
+* AMAX (output) REAL
+* Absolute value of largest matrix element. If AMAX is very
+* close to overflow or very close to underflow, the matrix
+* should be scaled.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* > 0: if INFO = i, and i is
+* <= M: the i-th row of A is exactly zero
+* > M: the (i-M)-th column of A is exactly zero
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ONE, ZERO
+ PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, J, KD
+ REAL BIGNUM, RCMAX, RCMIN, SMLNUM
+* ..
+* .. External Functions ..
+ REAL SLAMCH
+ EXTERNAL SLAMCH
+* ..
+* .. External Subroutines ..
+ EXTERNAL XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters
+*
+ INFO = 0
+ IF( M.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( KL.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( KU.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( LDAB.LT.KL+KU+1 ) THEN
+ INFO = -6
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SGBEQU', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( M.EQ.0 .OR. N.EQ.0 ) THEN
+ ROWCND = ONE
+ COLCND = ONE
+ AMAX = ZERO
+ RETURN
+ END IF
+*
+* Get machine constants.
+*
+ SMLNUM = SLAMCH( 'S' )
+ BIGNUM = ONE / SMLNUM
+*
+* Compute row scale factors.
+*
+ DO 10 I = 1, M
+ R( I ) = ZERO
+ 10 CONTINUE
+*
+* Find the maximum element in each row.
+*
+ KD = KU + 1
+ DO 30 J = 1, N
+ DO 20 I = MAX( J-KU, 1 ), MIN( J+KL, M )
+ R( I ) = MAX( R( I ), ABS( AB( KD+I-J, J ) ) )
+ 20 CONTINUE
+ 30 CONTINUE
+*
+* Find the maximum and minimum scale factors.
+*
+ RCMIN = BIGNUM
+ RCMAX = ZERO
+ DO 40 I = 1, M
+ RCMAX = MAX( RCMAX, R( I ) )
+ RCMIN = MIN( RCMIN, R( I ) )
+ 40 CONTINUE
+ AMAX = RCMAX
+*
+ IF( RCMIN.EQ.ZERO ) THEN
+*
+* Find the first zero scale factor and return an error code.
+*
+ DO 50 I = 1, M
+ IF( R( I ).EQ.ZERO ) THEN
+ INFO = I
+ RETURN
+ END IF
+ 50 CONTINUE
+ ELSE
+*
+* Invert the scale factors.
+*
+ DO 60 I = 1, M
+ R( I ) = ONE / MIN( MAX( R( I ), SMLNUM ), BIGNUM )
+ 60 CONTINUE
+*
+* Compute ROWCND = min(R(I)) / max(R(I))
+*
+ ROWCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM )
+ END IF
+*
+* Compute column scale factors
+*
+ DO 70 J = 1, N
+ C( J ) = ZERO
+ 70 CONTINUE
+*
+* Find the maximum element in each column,
+* assuming the row scaling computed above.
+*
+ KD = KU + 1
+ DO 90 J = 1, N
+ DO 80 I = MAX( J-KU, 1 ), MIN( J+KL, M )
+ C( J ) = MAX( C( J ), ABS( AB( KD+I-J, J ) )*R( I ) )
+ 80 CONTINUE
+ 90 CONTINUE
+*
+* Find the maximum and minimum scale factors.
+*
+ RCMIN = BIGNUM
+ RCMAX = ZERO
+ DO 100 J = 1, N
+ RCMIN = MIN( RCMIN, C( J ) )
+ RCMAX = MAX( RCMAX, C( J ) )
+ 100 CONTINUE
+*
+ IF( RCMIN.EQ.ZERO ) THEN
+*
+* Find the first zero scale factor and return an error code.
+*
+ DO 110 J = 1, N
+ IF( C( J ).EQ.ZERO ) THEN
+ INFO = M + J
+ RETURN
+ END IF
+ 110 CONTINUE
+ ELSE
+*
+* Invert the scale factors.
+*
+ DO 120 J = 1, N
+ C( J ) = ONE / MIN( MAX( C( J ), SMLNUM ), BIGNUM )
+ 120 CONTINUE
+*
+* Compute COLCND = min(C(J)) / max(C(J))
+*
+ COLCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM )
+ END IF
+*
+ RETURN
+*
+* End of SGBEQU
+*
+ END
+ SUBROUTINE SGBRFS( TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB,
+ $ IPIV, B, LDB, X, LDX, FERR, BERR, WORK, IWORK,
+ $ INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* Modified to call SLACN2 in place of SLACON, 7 Feb 03, SJH.
+*
+* .. Scalar Arguments ..
+ CHARACTER TRANS
+ INTEGER INFO, KL, KU, LDAB, LDAFB, LDB, LDX, N, NRHS
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * ), IWORK( * )
+ REAL AB( LDAB, * ), AFB( LDAFB, * ), B( LDB, * ),
+ $ BERR( * ), FERR( * ), WORK( * ), X( LDX, * )
+* ..
+*
+* Purpose
+* =======
+*
+* SGBRFS improves the computed solution to a system of linear
+* equations when the coefficient matrix is banded, and provides
+* error bounds and backward error estimates for the solution.
+*
+* Arguments
+* =========
+*
+* TRANS (input) CHARACTER*1
+* Specifies the form of the system of equations:
+* = 'N': A * X = B (No transpose)
+* = 'T': A**T * X = B (Transpose)
+* = 'C': A**H * X = B (Conjugate transpose = Transpose)
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* KL (input) INTEGER
+* The number of subdiagonals within the band of A. KL >= 0.
+*
+* KU (input) INTEGER
+* The number of superdiagonals within the band of A. KU >= 0.
+*
+* NRHS (input) INTEGER
+* The number of right hand sides, i.e., the number of columns
+* of the matrices B and X. NRHS >= 0.
+*
+* AB (input) REAL array, dimension (LDAB,N)
+* The original band matrix A, stored in rows 1 to KL+KU+1.
+* The j-th column of A is stored in the j-th column of the
+* array AB as follows:
+* AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(n,j+kl).
+*
+* LDAB (input) INTEGER
+* The leading dimension of the array AB. LDAB >= KL+KU+1.
+*
+* AFB (input) REAL array, dimension (LDAFB,N)
+* Details of the LU factorization of the band matrix A, as
+* computed by SGBTRF. U is stored as an upper triangular band
+* matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and
+* the multipliers used during the factorization are stored in
+* rows KL+KU+2 to 2*KL+KU+1.
+*
+* LDAFB (input) INTEGER
+* The leading dimension of the array AFB. LDAFB >= 2*KL*KU+1.
+*
+* IPIV (input) INTEGER array, dimension (N)
+* The pivot indices from SGBTRF; for 1<=i<=N, row i of the
+* matrix was interchanged with row IPIV(i).
+*
+* B (input) REAL array, dimension (LDB,NRHS)
+* The right hand side matrix B.
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. LDB >= max(1,N).
+*
+* X (input/output) REAL array, dimension (LDX,NRHS)
+* On entry, the solution matrix X, as computed by SGBTRS.
+* On exit, the improved solution matrix X.
+*
+* LDX (input) INTEGER
+* The leading dimension of the array X. LDX >= max(1,N).
+*
+* FERR (output) REAL array, dimension (NRHS)
+* The estimated forward error bound for each solution vector
+* X(j) (the j-th column of the solution matrix X).
+* If XTRUE is the true solution corresponding to X(j), FERR(j)
+* is an estimated upper bound for the magnitude of the largest
+* element in (X(j) - XTRUE) divided by the magnitude of the
+* largest element in X(j). The estimate is as reliable as
+* the estimate for RCOND, and is almost always a slight
+* overestimate of the true error.
+*
+* BERR (output) REAL array, dimension (NRHS)
+* The componentwise relative backward error of each solution
+* vector X(j) (i.e., the smallest relative change in
+* any element of A or B that makes X(j) an exact solution).
+*
+* WORK (workspace) REAL array, dimension (3*N)
+*
+* IWORK (workspace) INTEGER array, dimension (N)
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+*
+* Internal Parameters
+* ===================
+*
+* ITMAX is the maximum number of steps of iterative refinement.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ INTEGER ITMAX
+ PARAMETER ( ITMAX = 5 )
+ REAL ZERO
+ PARAMETER ( ZERO = 0.0E+0 )
+ REAL ONE
+ PARAMETER ( ONE = 1.0E+0 )
+ REAL TWO
+ PARAMETER ( TWO = 2.0E+0 )
+ REAL THREE
+ PARAMETER ( THREE = 3.0E+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL NOTRAN
+ CHARACTER TRANST
+ INTEGER COUNT, I, J, K, KASE, KK, NZ
+ REAL EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK
+* ..
+* .. Local Arrays ..
+ INTEGER ISAVE( 3 )
+* ..
+* .. External Subroutines ..
+ EXTERNAL SAXPY, SCOPY, SGBMV, SGBTRS, SLACN2, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, MIN
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ REAL SLAMCH
+ EXTERNAL LSAME, SLAMCH
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ NOTRAN = LSAME( TRANS, 'N' )
+ IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT.
+ $ LSAME( TRANS, 'C' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( KL.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( KU.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( NRHS.LT.0 ) THEN
+ INFO = -5
+ ELSE IF( LDAB.LT.KL+KU+1 ) THEN
+ INFO = -7
+ ELSE IF( LDAFB.LT.2*KL+KU+1 ) THEN
+ INFO = -9
+ ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -12
+ ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
+ INFO = -14
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SGBRFS', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN
+ DO 10 J = 1, NRHS
+ FERR( J ) = ZERO
+ BERR( J ) = ZERO
+ 10 CONTINUE
+ RETURN
+ END IF
+*
+ IF( NOTRAN ) THEN
+ TRANST = 'T'
+ ELSE
+ TRANST = 'N'
+ END IF
+*
+* NZ = maximum number of nonzero elements in each row of A, plus 1
+*
+ NZ = MIN( KL+KU+2, N+1 )
+ EPS = SLAMCH( 'Epsilon' )
+ SAFMIN = SLAMCH( 'Safe minimum' )
+ SAFE1 = NZ*SAFMIN
+ SAFE2 = SAFE1 / EPS
+*
+* Do for each right hand side
+*
+ DO 140 J = 1, NRHS
+*
+ COUNT = 1
+ LSTRES = THREE
+ 20 CONTINUE
+*
+* Loop until stopping criterion is satisfied.
+*
+* Compute residual R = B - op(A) * X,
+* where op(A) = A, A**T, or A**H, depending on TRANS.
+*
+ CALL SCOPY( N, B( 1, J ), 1, WORK( N+1 ), 1 )
+ CALL SGBMV( TRANS, N, N, KL, KU, -ONE, AB, LDAB, X( 1, J ), 1,
+ $ ONE, WORK( N+1 ), 1 )
+*
+* Compute componentwise relative backward error from formula
+*
+* max(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) )
+*
+* where abs(Z) is the componentwise absolute value of the matrix
+* or vector Z. If the i-th component of the denominator is less
+* than SAFE2, then SAFE1 is added to the i-th components of the
+* numerator and denominator before dividing.
+*
+ DO 30 I = 1, N
+ WORK( I ) = ABS( B( I, J ) )
+ 30 CONTINUE
+*
+* Compute abs(op(A))*abs(X) + abs(B).
+*
+ IF( NOTRAN ) THEN
+ DO 50 K = 1, N
+ KK = KU + 1 - K
+ XK = ABS( X( K, J ) )
+ DO 40 I = MAX( 1, K-KU ), MIN( N, K+KL )
+ WORK( I ) = WORK( I ) + ABS( AB( KK+I, K ) )*XK
+ 40 CONTINUE
+ 50 CONTINUE
+ ELSE
+ DO 70 K = 1, N
+ S = ZERO
+ KK = KU + 1 - K
+ DO 60 I = MAX( 1, K-KU ), MIN( N, K+KL )
+ S = S + ABS( AB( KK+I, K ) )*ABS( X( I, J ) )
+ 60 CONTINUE
+ WORK( K ) = WORK( K ) + S
+ 70 CONTINUE
+ END IF
+ S = ZERO
+ DO 80 I = 1, N
+ IF( WORK( I ).GT.SAFE2 ) THEN
+ S = MAX( S, ABS( WORK( N+I ) ) / WORK( I ) )
+ ELSE
+ S = MAX( S, ( ABS( WORK( N+I ) )+SAFE1 ) /
+ $ ( WORK( I )+SAFE1 ) )
+ END IF
+ 80 CONTINUE
+ BERR( J ) = S
+*
+* Test stopping criterion. Continue iterating if
+* 1) The residual BERR(J) is larger than machine epsilon, and
+* 2) BERR(J) decreased by at least a factor of 2 during the
+* last iteration, and
+* 3) At most ITMAX iterations tried.
+*
+ IF( BERR( J ).GT.EPS .AND. TWO*BERR( J ).LE.LSTRES .AND.
+ $ COUNT.LE.ITMAX ) THEN
+*
+* Update solution and try again.
+*
+ CALL SGBTRS( TRANS, N, KL, KU, 1, AFB, LDAFB, IPIV,
+ $ WORK( N+1 ), N, INFO )
+ CALL SAXPY( N, ONE, WORK( N+1 ), 1, X( 1, J ), 1 )
+ LSTRES = BERR( J )
+ COUNT = COUNT + 1
+ GO TO 20
+ END IF
+*
+* Bound error from formula
+*
+* norm(X - XTRUE) / norm(X) .le. FERR =
+* norm( abs(inv(op(A)))*
+* ( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X)
+*
+* where
+* norm(Z) is the magnitude of the largest component of Z
+* inv(op(A)) is the inverse of op(A)
+* abs(Z) is the componentwise absolute value of the matrix or
+* vector Z
+* NZ is the maximum number of nonzeros in any row of A, plus 1
+* EPS is machine epsilon
+*
+* The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B))
+* is incremented by SAFE1 if the i-th component of
+* abs(op(A))*abs(X) + abs(B) is less than SAFE2.
+*
+* Use SLACN2 to estimate the infinity-norm of the matrix
+* inv(op(A)) * diag(W),
+* where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) )))
+*
+ DO 90 I = 1, N
+ IF( WORK( I ).GT.SAFE2 ) THEN
+ WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I )
+ ELSE
+ WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I ) + SAFE1
+ END IF
+ 90 CONTINUE
+*
+ KASE = 0
+ 100 CONTINUE
+ CALL SLACN2( N, WORK( 2*N+1 ), WORK( N+1 ), IWORK, FERR( J ),
+ $ KASE, ISAVE )
+ IF( KASE.NE.0 ) THEN
+ IF( KASE.EQ.1 ) THEN
+*
+* Multiply by diag(W)*inv(op(A)**T).
+*
+ CALL SGBTRS( TRANST, N, KL, KU, 1, AFB, LDAFB, IPIV,
+ $ WORK( N+1 ), N, INFO )
+ DO 110 I = 1, N
+ WORK( N+I ) = WORK( N+I )*WORK( I )
+ 110 CONTINUE
+ ELSE
+*
+* Multiply by inv(op(A))*diag(W).
+*
+ DO 120 I = 1, N
+ WORK( N+I ) = WORK( N+I )*WORK( I )
+ 120 CONTINUE
+ CALL SGBTRS( TRANS, N, KL, KU, 1, AFB, LDAFB, IPIV,
+ $ WORK( N+1 ), N, INFO )
+ END IF
+ GO TO 100
+ END IF
+*
+* Normalize error.
+*
+ LSTRES = ZERO
+ DO 130 I = 1, N
+ LSTRES = MAX( LSTRES, ABS( X( I, J ) ) )
+ 130 CONTINUE
+ IF( LSTRES.NE.ZERO )
+ $ FERR( J ) = FERR( J ) / LSTRES
+*
+ 140 CONTINUE
+*
+ RETURN
+*
+* End of SGBRFS
+*
+ END
+ SUBROUTINE SGBSV( N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB, INFO )
+*
+* -- LAPACK driver routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, KL, KU, LDAB, LDB, N, NRHS
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ REAL AB( LDAB, * ), B( LDB, * )
+* ..
+*
+* Purpose
+* =======
+*
+* SGBSV computes the solution to a real system of linear equations
+* A * X = B, where A is a band matrix of order N with KL subdiagonals
+* and KU superdiagonals, and X and B are N-by-NRHS matrices.
+*
+* The LU decomposition with partial pivoting and row interchanges is
+* used to factor A as A = L * U, where L is a product of permutation
+* and unit lower triangular matrices with KL subdiagonals, and U is
+* upper triangular with KL+KU superdiagonals. The factored form of A
+* is then used to solve the system of equations A * X = B.
+*
+* Arguments
+* =========
+*
+* N (input) INTEGER
+* The number of linear equations, i.e., the order of the
+* matrix A. N >= 0.
+*
+* KL (input) INTEGER
+* The number of subdiagonals within the band of A. KL >= 0.
+*
+* KU (input) INTEGER
+* The number of superdiagonals within the band of A. KU >= 0.
+*
+* NRHS (input) INTEGER
+* The number of right hand sides, i.e., the number of columns
+* of the matrix B. NRHS >= 0.
+*
+* AB (input/output) REAL array, dimension (LDAB,N)
+* On entry, the matrix A in band storage, in rows KL+1 to
+* 2*KL+KU+1; rows 1 to KL of the array need not be set.
+* The j-th column of A is stored in the j-th column of the
+* array AB as follows:
+* AB(KL+KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+KL)
+* On exit, details of the factorization: U is stored as an
+* upper triangular band matrix with KL+KU superdiagonals in
+* rows 1 to KL+KU+1, and the multipliers used during the
+* factorization are stored in rows KL+KU+2 to 2*KL+KU+1.
+* See below for further details.
+*
+* LDAB (input) INTEGER
+* The leading dimension of the array AB. LDAB >= 2*KL+KU+1.
+*
+* IPIV (output) INTEGER array, dimension (N)
+* The pivot indices that define the permutation matrix P;
+* row i of the matrix was interchanged with row IPIV(i).
+*
+* B (input/output) REAL array, dimension (LDB,NRHS)
+* On entry, the N-by-NRHS right hand side matrix B.
+* On exit, if INFO = 0, the N-by-NRHS solution matrix X.
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. LDB >= max(1,N).
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* > 0: if INFO = i, U(i,i) is exactly zero. The factorization
+* has been completed, but the factor U is exactly
+* singular, and the solution has not been computed.
+*
+* Further Details
+* ===============
+*
+* The band storage scheme is illustrated by the following example, when
+* M = N = 6, KL = 2, KU = 1:
+*
+* On entry: On exit:
+*
+* * * * + + + * * * u14 u25 u36
+* * * + + + + * * u13 u24 u35 u46
+* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56
+* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66
+* a21 a32 a43 a54 a65 * m21 m32 m43 m54 m65 *
+* a31 a42 a53 a64 * * m31 m42 m53 m64 * *
+*
+* Array elements marked * are not used by the routine; elements marked
+* + need not be set on entry, but are required by the routine to store
+* elements of U because of fill-in resulting from the row interchanges.
+*
+* =====================================================================
+*
+* .. External Subroutines ..
+ EXTERNAL SGBTRF, SGBTRS, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ IF( N.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( KL.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( KU.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( NRHS.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( LDAB.LT.2*KL+KU+1 ) THEN
+ INFO = -6
+ ELSE IF( LDB.LT.MAX( N, 1 ) ) THEN
+ INFO = -9
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SGBSV ', -INFO )
+ RETURN
+ END IF
+*
+* Compute the LU factorization of the band matrix A.
+*
+ CALL SGBTRF( N, N, KL, KU, AB, LDAB, IPIV, INFO )
+ IF( INFO.EQ.0 ) THEN
+*
+* Solve the system A*X = B, overwriting B with X.
+*
+ CALL SGBTRS( 'No transpose', N, KL, KU, NRHS, AB, LDAB, IPIV,
+ $ B, LDB, INFO )
+ END IF
+ RETURN
+*
+* End of SGBSV
+*
+ END
+ 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 )
+*
+* -- LAPACK driver routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER EQUED, FACT, TRANS
+ INTEGER INFO, KL, KU, LDAB, LDAFB, LDB, LDX, N, NRHS
+ REAL RCOND
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * ), IWORK( * )
+ REAL AB( LDAB, * ), AFB( LDAFB, * ), B( LDB, * ),
+ $ BERR( * ), C( * ), FERR( * ), R( * ),
+ $ WORK( * ), X( LDX, * )
+* ..
+*
+* Purpose
+* =======
+*
+* SGBSVX uses the LU factorization to compute the solution to a real
+* system of linear equations A * X = B, A**T * X = B, or A**H * X = B,
+* where A is a band matrix of order N with KL subdiagonals and KU
+* superdiagonals, and X and B are N-by-NRHS matrices.
+*
+* Error bounds on the solution and a condition estimate are also
+* provided.
+*
+* Description
+* ===========
+*
+* The following steps are performed by this subroutine:
+*
+* 1. If FACT = 'E', real scaling factors are computed to equilibrate
+* the system:
+* TRANS = 'N': diag(R)*A*diag(C) *inv(diag(C))*X = diag(R)*B
+* TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B
+* TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B
+* Whether or not the system will be equilibrated depends on the
+* scaling of the matrix A, but if equilibration is used, A is
+* overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N')
+* or diag(C)*B (if TRANS = 'T' or 'C').
+*
+* 2. If FACT = 'N' or 'E', the LU decomposition is used to factor the
+* matrix A (after equilibration if FACT = 'E') as
+* A = L * U,
+* where L is a product of permutation and unit lower triangular
+* matrices with KL subdiagonals, and U is upper triangular with
+* KL+KU superdiagonals.
+*
+* 3. If some U(i,i)=0, so that U is exactly singular, then the routine
+* returns with INFO = i. Otherwise, the factored form of A is used
+* to estimate the condition number of the matrix A. If the
+* reciprocal of the condition number is less than machine precision,
+* INFO = N+1 is returned as a warning, but the routine still goes on
+* to solve for X and compute error bounds as described below.
+*
+* 4. The system of equations is solved for X using the factored form
+* of A.
+*
+* 5. Iterative refinement is applied to improve the computed solution
+* matrix and calculate error bounds and backward error estimates
+* for it.
+*
+* 6. If equilibration was used, the matrix X is premultiplied by
+* diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so
+* that it solves the original system before equilibration.
+*
+* Arguments
+* =========
+*
+* FACT (input) CHARACTER*1
+* Specifies whether or not the factored form of the matrix A is
+* supplied on entry, and if not, whether the matrix A should be
+* equilibrated before it is factored.
+* = 'F': On entry, AFB and IPIV contain the factored form of
+* A. If EQUED is not 'N', the matrix A has been
+* equilibrated with scaling factors given by R and C.
+* AB, AFB, and IPIV are not modified.
+* = 'N': The matrix A will be copied to AFB and factored.
+* = 'E': The matrix A will be equilibrated if necessary, then
+* copied to AFB and factored.
+*
+* TRANS (input) CHARACTER*1
+* Specifies the form of the system of equations.
+* = 'N': A * X = B (No transpose)
+* = 'T': A**T * X = B (Transpose)
+* = 'C': A**H * X = B (Transpose)
+*
+* N (input) INTEGER
+* The number of linear equations, i.e., the order of the
+* matrix A. N >= 0.
+*
+* KL (input) INTEGER
+* The number of subdiagonals within the band of A. KL >= 0.
+*
+* KU (input) INTEGER
+* The number of superdiagonals within the band of A. KU >= 0.
+*
+* NRHS (input) INTEGER
+* The number of right hand sides, i.e., the number of columns
+* of the matrices B and X. NRHS >= 0.
+*
+* AB (input/output) REAL array, dimension (LDAB,N)
+* On entry, the matrix A in band storage, in rows 1 to KL+KU+1.
+* The j-th column of A is stored in the j-th column of the
+* array AB as follows:
+* AB(KU+1+i-j,j) = A(i,j) for max(1,j-KU)<=i<=min(N,j+kl)
+*
+* If FACT = 'F' and EQUED is not 'N', then A must have been
+* equilibrated by the scaling factors in R and/or C. AB is not
+* modified if FACT = 'F' or 'N', or if FACT = 'E' and
+* EQUED = 'N' on exit.
+*
+* On exit, if EQUED .ne. 'N', A is scaled as follows:
+* EQUED = 'R': A := diag(R) * A
+* EQUED = 'C': A := A * diag(C)
+* EQUED = 'B': A := diag(R) * A * diag(C).
+*
+* LDAB (input) INTEGER
+* The leading dimension of the array AB. LDAB >= KL+KU+1.
+*
+* AFB (input or output) REAL array, dimension (LDAFB,N)
+* If FACT = 'F', then AFB is an input argument and on entry
+* contains details of the LU factorization of the band matrix
+* A, as computed by SGBTRF. U is stored as an upper triangular
+* band matrix with KL+KU superdiagonals in rows 1 to KL+KU+1,
+* and the multipliers used during the factorization are stored
+* in rows KL+KU+2 to 2*KL+KU+1. If EQUED .ne. 'N', then AFB is
+* the factored form of the equilibrated matrix A.
+*
+* If FACT = 'N', then AFB is an output argument and on exit
+* returns details of the LU factorization of A.
+*
+* If FACT = 'E', then AFB is an output argument and on exit
+* returns details of the LU factorization of the equilibrated
+* matrix A (see the description of AB for the form of the
+* equilibrated matrix).
+*
+* LDAFB (input) INTEGER
+* The leading dimension of the array AFB. LDAFB >= 2*KL+KU+1.
+*
+* IPIV (input or output) INTEGER array, dimension (N)
+* If FACT = 'F', then IPIV is an input argument and on entry
+* contains the pivot indices from the factorization A = L*U
+* as computed by SGBTRF; row i of the matrix was interchanged
+* with row IPIV(i).
+*
+* If FACT = 'N', then IPIV is an output argument and on exit
+* contains the pivot indices from the factorization A = L*U
+* of the original matrix A.
+*
+* If FACT = 'E', then IPIV is an output argument and on exit
+* contains the pivot indices from the factorization A = L*U
+* of the equilibrated matrix A.
+*
+* EQUED (input or output) CHARACTER*1
+* Specifies the form of equilibration that was done.
+* = 'N': No equilibration (always true if FACT = 'N').
+* = 'R': Row equilibration, i.e., A has been premultiplied by
+* diag(R).
+* = 'C': Column equilibration, i.e., A has been postmultiplied
+* by diag(C).
+* = 'B': Both row and column equilibration, i.e., A has been
+* replaced by diag(R) * A * diag(C).
+* EQUED is an input argument if FACT = 'F'; otherwise, it is an
+* output argument.
+*
+* R (input or output) REAL array, dimension (N)
+* The row scale factors for A. If EQUED = 'R' or 'B', A is
+* multiplied on the left by diag(R); if EQUED = 'N' or 'C', R
+* is not accessed. R is an input argument if FACT = 'F';
+* otherwise, R is an output argument. If FACT = 'F' and
+* EQUED = 'R' or 'B', each element of R must be positive.
+*
+* C (input or output) REAL array, dimension (N)
+* The column scale factors for A. If EQUED = 'C' or 'B', A is
+* multiplied on the right by diag(C); if EQUED = 'N' or 'R', C
+* is not accessed. C is an input argument if FACT = 'F';
+* otherwise, C is an output argument. If FACT = 'F' and
+* EQUED = 'C' or 'B', each element of C must be positive.
+*
+* B (input/output) REAL array, dimension (LDB,NRHS)
+* On entry, the right hand side matrix B.
+* On exit,
+* if EQUED = 'N', B is not modified;
+* if TRANS = 'N' and EQUED = 'R' or 'B', B is overwritten by
+* diag(R)*B;
+* if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', B is
+* overwritten by diag(C)*B.
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. LDB >= max(1,N).
+*
+* X (output) REAL array, dimension (LDX,NRHS)
+* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X
+* to the original system of equations. Note that A and B are
+* modified on exit if EQUED .ne. 'N', and the solution to the
+* equilibrated system is inv(diag(C))*X if TRANS = 'N' and
+* EQUED = 'C' or 'B', or inv(diag(R))*X if TRANS = 'T' or 'C'
+* and EQUED = 'R' or 'B'.
+*
+* LDX (input) INTEGER
+* The leading dimension of the array X. LDX >= max(1,N).
+*
+* RCOND (output) REAL
+* The estimate of the reciprocal condition number of the matrix
+* A after equilibration (if done). If RCOND is less than the
+* machine precision (in particular, if RCOND = 0), the matrix
+* is singular to working precision. This condition is
+* indicated by a return code of INFO > 0.
+*
+* FERR (output) REAL array, dimension (NRHS)
+* The estimated forward error bound for each solution vector
+* X(j) (the j-th column of the solution matrix X).
+* If XTRUE is the true solution corresponding to X(j), FERR(j)
+* is an estimated upper bound for the magnitude of the largest
+* element in (X(j) - XTRUE) divided by the magnitude of the
+* largest element in X(j). The estimate is as reliable as
+* the estimate for RCOND, and is almost always a slight
+* overestimate of the true error.
+*
+* BERR (output) REAL array, dimension (NRHS)
+* The componentwise relative backward error of each solution
+* vector X(j) (i.e., the smallest relative change in
+* any element of A or B that makes X(j) an exact solution).
+*
+* WORK (workspace/output) REAL array, dimension (3*N)
+* On exit, WORK(1) contains the reciprocal pivot growth
+* factor norm(A)/norm(U). The "max absolute element" norm is
+* used. If WORK(1) is much less than 1, then the stability
+* of the LU factorization of the (equilibrated) matrix A
+* could be poor. This also means that the solution X, condition
+* estimator RCOND, and forward error bound FERR could be
+* unreliable. If factorization fails with 0<INFO<=N, then
+* WORK(1) contains the reciprocal pivot growth factor for the
+* leading INFO columns of A.
+*
+* IWORK (workspace) INTEGER array, dimension (N)
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* > 0: if INFO = i, and i is
+* <= N: U(i,i) is exactly zero. The factorization
+* has been completed, but the factor U is exactly
+* singular, so the solution and error bounds
+* could not be computed. RCOND = 0 is returned.
+* = N+1: U is nonsingular, but RCOND is less than machine
+* precision, meaning that the matrix is singular
+* to working precision. Nevertheless, the
+* solution and error bounds are computed because
+* there are a number of situations where the
+* computed solution can be more accurate than the
+*
+* value of RCOND would suggest.
+* =====================================================================
+* Moved setting of INFO = N+1 so INFO does not subsequently get
+* overwritten. Sven, 17 Mar 05.
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO, ONE
+ PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL COLEQU, EQUIL, NOFACT, NOTRAN, ROWEQU
+ CHARACTER NORM
+ INTEGER I, INFEQU, J, J1, J2
+ REAL AMAX, ANORM, BIGNUM, COLCND, RCMAX, RCMIN,
+ $ ROWCND, RPVGRW, SMLNUM
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ REAL SLAMCH, SLANGB, SLANTB
+ EXTERNAL LSAME, SLAMCH, SLANGB, SLANTB
+* ..
+* .. External Subroutines ..
+ EXTERNAL SCOPY, SGBCON, SGBEQU, SGBRFS, SGBTRF, SGBTRS,
+ $ SLACPY, SLAQGB, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+ INFO = 0
+ NOFACT = LSAME( FACT, 'N' )
+ EQUIL = LSAME( FACT, 'E' )
+ NOTRAN = LSAME( TRANS, 'N' )
+ IF( NOFACT .OR. EQUIL ) THEN
+ EQUED = 'N'
+ ROWEQU = .FALSE.
+ COLEQU = .FALSE.
+ ELSE
+ ROWEQU = LSAME( EQUED, 'R' ) .OR. LSAME( EQUED, 'B' )
+ COLEQU = LSAME( EQUED, 'C' ) .OR. LSAME( EQUED, 'B' )
+ SMLNUM = SLAMCH( 'Safe minimum' )
+ BIGNUM = ONE / SMLNUM
+ END IF
+*
+* Test the input parameters.
+*
+ IF( .NOT.NOFACT .AND. .NOT.EQUIL .AND. .NOT.LSAME( FACT, 'F' ) )
+ $ THEN
+ INFO = -1
+ ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT.
+ $ LSAME( TRANS, 'C' ) ) THEN
+ INFO = -2
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( KL.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( KU.LT.0 ) THEN
+ INFO = -5
+ ELSE IF( NRHS.LT.0 ) THEN
+ INFO = -6
+ ELSE IF( LDAB.LT.KL+KU+1 ) THEN
+ INFO = -8
+ ELSE IF( LDAFB.LT.2*KL+KU+1 ) THEN
+ INFO = -10
+ ELSE IF( LSAME( FACT, 'F' ) .AND. .NOT.
+ $ ( ROWEQU .OR. COLEQU .OR. LSAME( EQUED, 'N' ) ) ) THEN
+ INFO = -12
+ ELSE
+ IF( ROWEQU ) THEN
+ RCMIN = BIGNUM
+ RCMAX = ZERO
+ DO 10 J = 1, N
+ RCMIN = MIN( RCMIN, R( J ) )
+ RCMAX = MAX( RCMAX, R( J ) )
+ 10 CONTINUE
+ IF( RCMIN.LE.ZERO ) THEN
+ INFO = -13
+ ELSE IF( N.GT.0 ) THEN
+ ROWCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM )
+ ELSE
+ ROWCND = ONE
+ END IF
+ END IF
+ IF( COLEQU .AND. INFO.EQ.0 ) THEN
+ RCMIN = BIGNUM
+ RCMAX = ZERO
+ DO 20 J = 1, N
+ RCMIN = MIN( RCMIN, C( J ) )
+ RCMAX = MAX( RCMAX, C( J ) )
+ 20 CONTINUE
+ IF( RCMIN.LE.ZERO ) THEN
+ INFO = -14
+ ELSE IF( N.GT.0 ) THEN
+ COLCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM )
+ ELSE
+ COLCND = ONE
+ END IF
+ END IF
+ IF( INFO.EQ.0 ) THEN
+ IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -16
+ ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
+ INFO = -18
+ END IF
+ END IF
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SGBSVX', -INFO )
+ RETURN
+ END IF
+*
+ IF( EQUIL ) THEN
+*
+* Compute row and column scalings to equilibrate the matrix A.
+*
+ CALL SGBEQU( N, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND,
+ $ AMAX, INFEQU )
+ IF( INFEQU.EQ.0 ) THEN
+*
+* Equilibrate the matrix.
+*
+ CALL SLAQGB( N, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND,
+ $ AMAX, EQUED )
+ ROWEQU = LSAME( EQUED, 'R' ) .OR. LSAME( EQUED, 'B' )
+ COLEQU = LSAME( EQUED, 'C' ) .OR. LSAME( EQUED, 'B' )
+ END IF
+ END IF
+*
+* Scale the right hand side.
+*
+ IF( NOTRAN ) THEN
+ IF( ROWEQU ) THEN
+ DO 40 J = 1, NRHS
+ DO 30 I = 1, N
+ B( I, J ) = R( I )*B( I, J )
+ 30 CONTINUE
+ 40 CONTINUE
+ END IF
+ ELSE IF( COLEQU ) THEN
+ DO 60 J = 1, NRHS
+ DO 50 I = 1, N
+ B( I, J ) = C( I )*B( I, J )
+ 50 CONTINUE
+ 60 CONTINUE
+ END IF
+*
+ IF( NOFACT .OR. EQUIL ) THEN
+*
+* Compute the LU factorization of the band matrix A.
+*
+ DO 70 J = 1, N
+ J1 = MAX( J-KU, 1 )
+ J2 = MIN( J+KL, N )
+ CALL SCOPY( J2-J1+1, AB( KU+1-J+J1, J ), 1,
+ $ AFB( KL+KU+1-J+J1, J ), 1 )
+ 70 CONTINUE
+*
+ CALL SGBTRF( N, N, KL, KU, AFB, LDAFB, IPIV, INFO )
+*
+* Return if INFO is non-zero.
+*
+ IF( INFO.GT.0 ) THEN
+*
+* Compute the reciprocal pivot growth factor of the
+* leading rank-deficient INFO columns of A.
+*
+ ANORM = ZERO
+ DO 90 J = 1, INFO
+ DO 80 I = MAX( KU+2-J, 1 ), MIN( N+KU+1-J, KL+KU+1 )
+ ANORM = MAX( ANORM, ABS( AB( I, J ) ) )
+ 80 CONTINUE
+ 90 CONTINUE
+ RPVGRW = SLANTB( 'M', 'U', 'N', INFO, MIN( INFO-1, KL+KU ),
+ $ AFB( MAX( 1, KL+KU+2-INFO ), 1 ), LDAFB,
+ $ WORK )
+ IF( RPVGRW.EQ.ZERO ) THEN
+ RPVGRW = ONE
+ ELSE
+ RPVGRW = ANORM / RPVGRW
+ END IF
+ WORK( 1 ) = RPVGRW
+ RCOND = ZERO
+ RETURN
+ END IF
+ END IF
+*
+* Compute the norm of the matrix A and the
+* reciprocal pivot growth factor RPVGRW.
+*
+ IF( NOTRAN ) THEN
+ NORM = '1'
+ ELSE
+ NORM = 'I'
+ END IF
+ ANORM = SLANGB( NORM, N, KL, KU, AB, LDAB, WORK )
+ RPVGRW = SLANTB( 'M', 'U', 'N', N, KL+KU, AFB, LDAFB, WORK )
+ IF( RPVGRW.EQ.ZERO ) THEN
+ RPVGRW = ONE
+ ELSE
+ RPVGRW = SLANGB( 'M', N, KL, KU, AB, LDAB, WORK ) / RPVGRW
+ END IF
+*
+* Compute the reciprocal of the condition number of A.
+*
+ CALL SGBCON( NORM, N, KL, KU, AFB, LDAFB, IPIV, ANORM, RCOND,
+ $ WORK, IWORK, INFO )
+*
+* Compute the solution matrix X.
+*
+ CALL SLACPY( 'Full', N, NRHS, B, LDB, X, LDX )
+ CALL SGBTRS( TRANS, N, KL, KU, NRHS, AFB, LDAFB, IPIV, X, LDX,
+ $ INFO )
+*
+* Use iterative refinement to improve the computed solution and
+* compute error bounds and backward error estimates for it.
+*
+ CALL SGBRFS( TRANS, N, KL, KU, NRHS, AB, LDAB, AFB, LDAFB, IPIV,
+ $ B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO )
+*
+* Transform the solution matrix X to a solution of the original
+* system.
+*
+ IF( NOTRAN ) THEN
+ IF( COLEQU ) THEN
+ DO 110 J = 1, NRHS
+ DO 100 I = 1, N
+ X( I, J ) = C( I )*X( I, J )
+ 100 CONTINUE
+ 110 CONTINUE
+ DO 120 J = 1, NRHS
+ FERR( J ) = FERR( J ) / COLCND
+ 120 CONTINUE
+ END IF
+ ELSE IF( ROWEQU ) THEN
+ DO 140 J = 1, NRHS
+ DO 130 I = 1, N
+ X( I, J ) = R( I )*X( I, J )
+ 130 CONTINUE
+ 140 CONTINUE
+ DO 150 J = 1, NRHS
+ FERR( J ) = FERR( J ) / ROWCND
+ 150 CONTINUE
+ END IF
+*
+* Set INFO = N+1 if the matrix is singular to working precision.
+*
+ IF( RCOND.LT.SLAMCH( 'Epsilon' ) )
+ $ INFO = N + 1
+*
+ WORK( 1 ) = RPVGRW
+ RETURN
+*
+* End of SGBSVX
+*
+ END
+ SUBROUTINE SGBTF2( M, N, KL, KU, AB, LDAB, IPIV, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, KL, KU, LDAB, M, N
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ REAL AB( LDAB, * )
+* ..
+*
+* Purpose
+* =======
+*
+* SGBTF2 computes an LU factorization of a real m-by-n band matrix A
+* using partial pivoting with row interchanges.
+*
+* This is the unblocked version of the algorithm, calling Level 2 BLAS.
+*
+* Arguments
+* =========
+*
+* M (input) INTEGER
+* The number of rows of the matrix A. M >= 0.
+*
+* N (input) INTEGER
+* The number of columns of the matrix A. N >= 0.
+*
+* KL (input) INTEGER
+* The number of subdiagonals within the band of A. KL >= 0.
+*
+* KU (input) INTEGER
+* The number of superdiagonals within the band of A. KU >= 0.
+*
+* AB (input/output) REAL array, dimension (LDAB,N)
+* On entry, the matrix A in band storage, in rows KL+1 to
+* 2*KL+KU+1; rows 1 to KL of the array need not be set.
+* The j-th column of A is stored in the j-th column of the
+* array AB as follows:
+* AB(kl+ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl)
+*
+* On exit, details of the factorization: U is stored as an
+* upper triangular band matrix with KL+KU superdiagonals in
+* rows 1 to KL+KU+1, and the multipliers used during the
+* factorization are stored in rows KL+KU+2 to 2*KL+KU+1.
+* See below for further details.
+*
+* LDAB (input) INTEGER
+* The leading dimension of the array AB. LDAB >= 2*KL+KU+1.
+*
+* IPIV (output) INTEGER array, dimension (min(M,N))
+* The pivot indices; for 1 <= i <= min(M,N), row i of the
+* matrix was interchanged with row IPIV(i).
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* > 0: if INFO = +i, U(i,i) is exactly zero. The factorization
+* has been completed, but the factor U is exactly
+* singular, and division by zero will occur if it is used
+* to solve a system of equations.
+*
+* Further Details
+* ===============
+*
+* The band storage scheme is illustrated by the following example, when
+* M = N = 6, KL = 2, KU = 1:
+*
+* On entry: On exit:
+*
+* * * * + + + * * * u14 u25 u36
+* * * + + + + * * u13 u24 u35 u46
+* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56
+* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66
+* a21 a32 a43 a54 a65 * m21 m32 m43 m54 m65 *
+* a31 a42 a53 a64 * * m31 m42 m53 m64 * *
+*
+* Array elements marked * are not used by the routine; elements marked
+* + need not be set on entry, but are required by the routine to store
+* elements of U, because of fill-in resulting from the row
+* interchanges.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ONE, ZERO
+ PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, J, JP, JU, KM, KV
+* ..
+* .. External Functions ..
+ INTEGER ISAMAX
+ EXTERNAL ISAMAX
+* ..
+* .. External Subroutines ..
+ EXTERNAL SGER, SSCAL, SSWAP, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+* KV is the number of superdiagonals in the factor U, allowing for
+* fill-in.
+*
+ KV = KU + KL
+*
+* Test the input parameters.
+*
+ INFO = 0
+ IF( M.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( KL.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( KU.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( LDAB.LT.KL+KV+1 ) THEN
+ INFO = -6
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SGBTF2', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( M.EQ.0 .OR. N.EQ.0 )
+ $ RETURN
+*
+* Gaussian elimination with partial pivoting
+*
+* Set fill-in elements in columns KU+2 to KV to zero.
+*
+ DO 20 J = KU + 2, MIN( KV, N )
+ DO 10 I = KV - J + 2, KL
+ AB( I, J ) = ZERO
+ 10 CONTINUE
+ 20 CONTINUE
+*
+* JU is the index of the last column affected by the current stage
+* of the factorization.
+*
+ JU = 1
+*
+ DO 40 J = 1, MIN( M, N )
+*
+* Set fill-in elements in column J+KV to zero.
+*
+ IF( J+KV.LE.N ) THEN
+ DO 30 I = 1, KL
+ AB( I, J+KV ) = ZERO
+ 30 CONTINUE
+ END IF
+*
+* Find pivot and test for singularity. KM is the number of
+* subdiagonal elements in the current column.
+*
+ KM = MIN( KL, M-J )
+ JP = ISAMAX( KM+1, AB( KV+1, J ), 1 )
+ IPIV( J ) = JP + J - 1
+ IF( AB( KV+JP, J ).NE.ZERO ) THEN
+ JU = MAX( JU, MIN( J+KU+JP-1, N ) )
+*
+* Apply interchange to columns J to JU.
+*
+ IF( JP.NE.1 )
+ $ CALL SSWAP( JU-J+1, AB( KV+JP, J ), LDAB-1,
+ $ AB( KV+1, J ), LDAB-1 )
+*
+ IF( KM.GT.0 ) THEN
+*
+* Compute multipliers.
+*
+ CALL SSCAL( KM, ONE / AB( KV+1, J ), AB( KV+2, J ), 1 )
+*
+* Update trailing submatrix within the band.
+*
+ IF( JU.GT.J )
+ $ CALL SGER( KM, JU-J, -ONE, AB( KV+2, J ), 1,
+ $ AB( KV, J+1 ), LDAB-1, AB( KV+1, J+1 ),
+ $ LDAB-1 )
+ END IF
+ ELSE
+*
+* If pivot is zero, set INFO to the index of the pivot
+* unless a zero pivot has already been found.
+*
+ IF( INFO.EQ.0 )
+ $ INFO = J
+ END IF
+ 40 CONTINUE
+ RETURN
+*
+* End of SGBTF2
+*
+ END
+ SUBROUTINE SGBTRF( M, N, KL, KU, AB, LDAB, IPIV, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, KL, KU, LDAB, M, N
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ REAL AB( LDAB, * )
+* ..
+*
+* Purpose
+* =======
+*
+* SGBTRF computes an LU factorization of a real m-by-n band matrix A
+* using partial pivoting with row interchanges.
+*
+* This is the blocked version of the algorithm, calling Level 3 BLAS.
+*
+* Arguments
+* =========
+*
+* M (input) INTEGER
+* The number of rows of the matrix A. M >= 0.
+*
+* N (input) INTEGER
+* The number of columns of the matrix A. N >= 0.
+*
+* KL (input) INTEGER
+* The number of subdiagonals within the band of A. KL >= 0.
+*
+* KU (input) INTEGER
+* The number of superdiagonals within the band of A. KU >= 0.
+*
+* AB (input/output) REAL array, dimension (LDAB,N)
+* On entry, the matrix A in band storage, in rows KL+1 to
+* 2*KL+KU+1; rows 1 to KL of the array need not be set.
+* The j-th column of A is stored in the j-th column of the
+* array AB as follows:
+* AB(kl+ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl)
+*
+* On exit, details of the factorization: U is stored as an
+* upper triangular band matrix with KL+KU superdiagonals in
+* rows 1 to KL+KU+1, and the multipliers used during the
+* factorization are stored in rows KL+KU+2 to 2*KL+KU+1.
+* See below for further details.
+*
+* LDAB (input) INTEGER
+* The leading dimension of the array AB. LDAB >= 2*KL+KU+1.
+*
+* IPIV (output) INTEGER array, dimension (min(M,N))
+* The pivot indices; for 1 <= i <= min(M,N), row i of the
+* matrix was interchanged with row IPIV(i).
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* > 0: if INFO = +i, U(i,i) is exactly zero. The factorization
+* has been completed, but the factor U is exactly
+* singular, and division by zero will occur if it is used
+* to solve a system of equations.
+*
+* Further Details
+* ===============
+*
+* The band storage scheme is illustrated by the following example, when
+* M = N = 6, KL = 2, KU = 1:
+*
+* On entry: On exit:
+*
+* * * * + + + * * * u14 u25 u36
+* * * + + + + * * u13 u24 u35 u46
+* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56
+* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66
+* a21 a32 a43 a54 a65 * m21 m32 m43 m54 m65 *
+* a31 a42 a53 a64 * * m31 m42 m53 m64 * *
+*
+* Array elements marked * are not used by the routine; elements marked
+* + need not be set on entry, but are required by the routine to store
+* elements of U because of fill-in resulting from the row interchanges.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ONE, ZERO
+ PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+ INTEGER NBMAX, LDWORK
+ PARAMETER ( NBMAX = 64, LDWORK = NBMAX+1 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, I2, I3, II, IP, J, J2, J3, JB, JJ, JM, JP,
+ $ JU, K2, KM, KV, NB, NW
+ REAL TEMP
+* ..
+* .. Local Arrays ..
+ REAL WORK13( LDWORK, NBMAX ),
+ $ WORK31( LDWORK, NBMAX )
+* ..
+* .. External Functions ..
+ INTEGER ILAENV, ISAMAX
+ EXTERNAL ILAENV, ISAMAX
+* ..
+* .. External Subroutines ..
+ EXTERNAL SCOPY, SGBTF2, SGEMM, SGER, SLASWP, SSCAL,
+ $ SSWAP, STRSM, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+* KV is the number of superdiagonals in the factor U, allowing for
+* fill-in
+*
+ KV = KU + KL
+*
+* Test the input parameters.
+*
+ INFO = 0
+ IF( M.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( KL.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( KU.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( LDAB.LT.KL+KV+1 ) THEN
+ INFO = -6
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SGBTRF', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( M.EQ.0 .OR. N.EQ.0 )
+ $ RETURN
+*
+* Determine the block size for this environment
+*
+ NB = ILAENV( 1, 'SGBTRF', ' ', M, N, KL, KU )
+*
+* The block size must not exceed the limit set by the size of the
+* local arrays WORK13 and WORK31.
+*
+ NB = MIN( NB, NBMAX )
+*
+ IF( NB.LE.1 .OR. NB.GT.KL ) THEN
+*
+* Use unblocked code
+*
+ CALL SGBTF2( M, N, KL, KU, AB, LDAB, IPIV, INFO )
+ ELSE
+*
+* Use blocked code
+*
+* Zero the superdiagonal elements of the work array WORK13
+*
+ DO 20 J = 1, NB
+ DO 10 I = 1, J - 1
+ WORK13( I, J ) = ZERO
+ 10 CONTINUE
+ 20 CONTINUE
+*
+* Zero the subdiagonal elements of the work array WORK31
+*
+ DO 40 J = 1, NB
+ DO 30 I = J + 1, NB
+ WORK31( I, J ) = ZERO
+ 30 CONTINUE
+ 40 CONTINUE
+*
+* Gaussian elimination with partial pivoting
+*
+* Set fill-in elements in columns KU+2 to KV to zero
+*
+ DO 60 J = KU + 2, MIN( KV, N )
+ DO 50 I = KV - J + 2, KL
+ AB( I, J ) = ZERO
+ 50 CONTINUE
+ 60 CONTINUE
+*
+* JU is the index of the last column affected by the current
+* stage of the factorization
+*
+ JU = 1
+*
+ DO 180 J = 1, MIN( M, N ), NB
+ JB = MIN( NB, MIN( M, N )-J+1 )
+*
+* The active part of the matrix is partitioned
+*
+* A11 A12 A13
+* A21 A22 A23
+* A31 A32 A33
+*
+* Here A11, A21 and A31 denote the current block of JB columns
+* which is about to be factorized. The number of rows in the
+* partitioning are JB, I2, I3 respectively, and the numbers
+* of columns are JB, J2, J3. The superdiagonal elements of A13
+* and the subdiagonal elements of A31 lie outside the band.
+*
+ I2 = MIN( KL-JB, M-J-JB+1 )
+ I3 = MIN( JB, M-J-KL+1 )
+*
+* J2 and J3 are computed after JU has been updated.
+*
+* Factorize the current block of JB columns
+*
+ DO 80 JJ = J, J + JB - 1
+*
+* Set fill-in elements in column JJ+KV to zero
+*
+ IF( JJ+KV.LE.N ) THEN
+ DO 70 I = 1, KL
+ AB( I, JJ+KV ) = ZERO
+ 70 CONTINUE
+ END IF
+*
+* Find pivot and test for singularity. KM is the number of
+* subdiagonal elements in the current column.
+*
+ KM = MIN( KL, M-JJ )
+ JP = ISAMAX( KM+1, AB( KV+1, JJ ), 1 )
+ IPIV( JJ ) = JP + JJ - J
+ IF( AB( KV+JP, JJ ).NE.ZERO ) THEN
+ JU = MAX( JU, MIN( JJ+KU+JP-1, N ) )
+ IF( JP.NE.1 ) THEN
+*
+* Apply interchange to columns J to J+JB-1
+*
+ IF( JP+JJ-1.LT.J+KL ) THEN
+*
+ CALL SSWAP( JB, AB( KV+1+JJ-J, J ), LDAB-1,
+ $ AB( KV+JP+JJ-J, J ), LDAB-1 )
+ ELSE
+*
+* The interchange affects columns J to JJ-1 of A31
+* which are stored in the work array WORK31
+*
+ CALL SSWAP( JJ-J, AB( KV+1+JJ-J, J ), LDAB-1,
+ $ WORK31( JP+JJ-J-KL, 1 ), LDWORK )
+ CALL SSWAP( J+JB-JJ, AB( KV+1, JJ ), LDAB-1,
+ $ AB( KV+JP, JJ ), LDAB-1 )
+ END IF
+ END IF
+*
+* Compute multipliers
+*
+ CALL SSCAL( KM, ONE / AB( KV+1, JJ ), AB( KV+2, JJ ),
+ $ 1 )
+*
+* Update trailing submatrix within the band and within
+* the current block. JM is the index of the last column
+* which needs to be updated.
+*
+ JM = MIN( JU, J+JB-1 )
+ IF( JM.GT.JJ )
+ $ CALL SGER( KM, JM-JJ, -ONE, AB( KV+2, JJ ), 1,
+ $ AB( KV, JJ+1 ), LDAB-1,
+ $ AB( KV+1, JJ+1 ), LDAB-1 )
+ ELSE
+*
+* If pivot is zero, set INFO to the index of the pivot
+* unless a zero pivot has already been found.
+*
+ IF( INFO.EQ.0 )
+ $ INFO = JJ
+ END IF
+*
+* Copy current column of A31 into the work array WORK31
+*
+ NW = MIN( JJ-J+1, I3 )
+ IF( NW.GT.0 )
+ $ CALL SCOPY( NW, AB( KV+KL+1-JJ+J, JJ ), 1,
+ $ WORK31( 1, JJ-J+1 ), 1 )
+ 80 CONTINUE
+ IF( J+JB.LE.N ) THEN
+*
+* Apply the row interchanges to the other blocks.
+*
+ J2 = MIN( JU-J+1, KV ) - JB
+ J3 = MAX( 0, JU-J-KV+1 )
+*
+* Use SLASWP to apply the row interchanges to A12, A22, and
+* A32.
+*
+ CALL SLASWP( J2, AB( KV+1-JB, J+JB ), LDAB-1, 1, JB,
+ $ IPIV( J ), 1 )
+*
+* Adjust the pivot indices.
+*
+ DO 90 I = J, J + JB - 1
+ IPIV( I ) = IPIV( I ) + J - 1
+ 90 CONTINUE
+*
+* Apply the row interchanges to A13, A23, and A33
+* columnwise.
+*
+ K2 = J - 1 + JB + J2
+ DO 110 I = 1, J3
+ JJ = K2 + I
+ DO 100 II = J + I - 1, J + JB - 1
+ IP = IPIV( II )
+ IF( IP.NE.II ) THEN
+ TEMP = AB( KV+1+II-JJ, JJ )
+ AB( KV+1+II-JJ, JJ ) = AB( KV+1+IP-JJ, JJ )
+ AB( KV+1+IP-JJ, JJ ) = TEMP
+ END IF
+ 100 CONTINUE
+ 110 CONTINUE
+*
+* Update the relevant part of the trailing submatrix
+*
+ IF( J2.GT.0 ) THEN
+*
+* Update A12
+*
+ CALL STRSM( 'Left', 'Lower', 'No transpose', 'Unit',
+ $ JB, J2, ONE, AB( KV+1, J ), LDAB-1,
+ $ AB( KV+1-JB, J+JB ), LDAB-1 )
+*
+ IF( I2.GT.0 ) THEN
+*
+* Update A22
+*
+ CALL SGEMM( 'No transpose', 'No transpose', I2, J2,
+ $ JB, -ONE, AB( KV+1+JB, J ), LDAB-1,
+ $ AB( KV+1-JB, J+JB ), LDAB-1, ONE,
+ $ AB( KV+1, J+JB ), LDAB-1 )
+ END IF
+*
+ IF( I3.GT.0 ) THEN
+*
+* Update A32
+*
+ CALL SGEMM( 'No transpose', 'No transpose', I3, J2,
+ $ JB, -ONE, WORK31, LDWORK,
+ $ AB( KV+1-JB, J+JB ), LDAB-1, ONE,
+ $ AB( KV+KL+1-JB, J+JB ), LDAB-1 )
+ END IF
+ END IF
+*
+ IF( J3.GT.0 ) THEN
+*
+* Copy the lower triangle of A13 into the work array
+* WORK13
+*
+ DO 130 JJ = 1, J3
+ DO 120 II = JJ, JB
+ WORK13( II, JJ ) = AB( II-JJ+1, JJ+J+KV-1 )
+ 120 CONTINUE
+ 130 CONTINUE
+*
+* Update A13 in the work array
+*
+ CALL STRSM( 'Left', 'Lower', 'No transpose', 'Unit',
+ $ JB, J3, ONE, AB( KV+1, J ), LDAB-1,
+ $ WORK13, LDWORK )
+*
+ IF( I2.GT.0 ) THEN
+*
+* Update A23
+*
+ CALL SGEMM( 'No transpose', 'No transpose', I2, J3,
+ $ JB, -ONE, AB( KV+1+JB, J ), LDAB-1,
+ $ WORK13, LDWORK, ONE, AB( 1+JB, J+KV ),
+ $ LDAB-1 )
+ END IF
+*
+ IF( I3.GT.0 ) THEN
+*
+* Update A33
+*
+ CALL SGEMM( 'No transpose', 'No transpose', I3, J3,
+ $ JB, -ONE, WORK31, LDWORK, WORK13,
+ $ LDWORK, ONE, AB( 1+KL, J+KV ), LDAB-1 )
+ END IF
+*
+* Copy the lower triangle of A13 back into place
+*
+ DO 150 JJ = 1, J3
+ DO 140 II = JJ, JB
+ AB( II-JJ+1, JJ+J+KV-1 ) = WORK13( II, JJ )
+ 140 CONTINUE
+ 150 CONTINUE
+ END IF
+ ELSE
+*
+* Adjust the pivot indices.
+*
+ DO 160 I = J, J + JB - 1
+ IPIV( I ) = IPIV( I ) + J - 1
+ 160 CONTINUE
+ END IF
+*
+* Partially undo the interchanges in the current block to
+* restore the upper triangular form of A31 and copy the upper
+* triangle of A31 back into place
+*
+ DO 170 JJ = J + JB - 1, J, -1
+ JP = IPIV( JJ ) - JJ + 1
+ IF( JP.NE.1 ) THEN
+*
+* Apply interchange to columns J to JJ-1
+*
+ IF( JP+JJ-1.LT.J+KL ) THEN
+*
+* The interchange does not affect A31
+*
+ CALL SSWAP( JJ-J, AB( KV+1+JJ-J, J ), LDAB-1,
+ $ AB( KV+JP+JJ-J, J ), LDAB-1 )
+ ELSE
+*
+* The interchange does affect A31
+*
+ CALL SSWAP( JJ-J, AB( KV+1+JJ-J, J ), LDAB-1,
+ $ WORK31( JP+JJ-J-KL, 1 ), LDWORK )
+ END IF
+ END IF
+*
+* Copy the current column of A31 back into place
+*
+ NW = MIN( I3, JJ-J+1 )
+ IF( NW.GT.0 )
+ $ CALL SCOPY( NW, WORK31( 1, JJ-J+1 ), 1,
+ $ AB( KV+KL+1-JJ+J, JJ ), 1 )
+ 170 CONTINUE
+ 180 CONTINUE
+ END IF
+*
+ RETURN
+*
+* End of SGBTRF
+*
+ END
+ SUBROUTINE SGBTRS( TRANS, N, KL, KU, NRHS, AB, LDAB, IPIV, B, LDB,
+ $ INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER TRANS
+ INTEGER INFO, KL, KU, LDAB, LDB, N, NRHS
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ REAL AB( LDAB, * ), B( LDB, * )
+* ..
+*
+* Purpose
+* =======
+*
+* SGBTRS solves a system of linear equations
+* A * X = B or A' * X = B
+* with a general band matrix A using the LU factorization computed
+* by SGBTRF.
+*
+* Arguments
+* =========
+*
+* TRANS (input) CHARACTER*1
+* Specifies the form of the system of equations.
+* = 'N': A * X = B (No transpose)
+* = 'T': A'* X = B (Transpose)
+* = 'C': A'* X = B (Conjugate transpose = Transpose)
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* KL (input) INTEGER
+* The number of subdiagonals within the band of A. KL >= 0.
+*
+* KU (input) INTEGER
+* The number of superdiagonals within the band of A. KU >= 0.
+*
+* NRHS (input) INTEGER
+* The number of right hand sides, i.e., the number of columns
+* of the matrix B. NRHS >= 0.
+*
+* AB (input) REAL array, dimension (LDAB,N)
+* Details of the LU factorization of the band matrix A, as
+* computed by SGBTRF. U is stored as an upper triangular band
+* matrix with KL+KU superdiagonals in rows 1 to KL+KU+1, and
+* the multipliers used during the factorization are stored in
+* rows KL+KU+2 to 2*KL+KU+1.
+*
+* LDAB (input) INTEGER
+* The leading dimension of the array AB. LDAB >= 2*KL+KU+1.
+*
+* IPIV (input) INTEGER array, dimension (N)
+* The pivot indices; for 1 <= i <= N, row i of the matrix was
+* interchanged with row IPIV(i).
+*
+* B (input/output) REAL array, dimension (LDB,NRHS)
+* On entry, the right hand side matrix B.
+* On exit, the solution matrix X.
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. LDB >= max(1,N).
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ONE
+ PARAMETER ( ONE = 1.0E+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL LNOTI, NOTRAN
+ INTEGER I, J, KD, L, LM
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL SGEMV, SGER, SSWAP, STBSV, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ NOTRAN = LSAME( TRANS, 'N' )
+ IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT.
+ $ LSAME( TRANS, 'C' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( KL.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( KU.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( NRHS.LT.0 ) THEN
+ INFO = -5
+ ELSE IF( LDAB.LT.( 2*KL+KU+1 ) ) THEN
+ INFO = -7
+ ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -10
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SGBTRS', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 .OR. NRHS.EQ.0 )
+ $ RETURN
+*
+ KD = KU + KL + 1
+ LNOTI = KL.GT.0
+*
+ IF( NOTRAN ) THEN
+*
+* Solve A*X = B.
+*
+* Solve L*X = B, overwriting B with X.
+*
+* L is represented as a product of permutations and unit lower
+* triangular matrices L = P(1) * L(1) * ... * P(n-1) * L(n-1),
+* where each transformation L(i) is a rank-one modification of
+* the identity matrix.
+*
+ IF( LNOTI ) THEN
+ DO 10 J = 1, N - 1
+ LM = MIN( KL, N-J )
+ L = IPIV( J )
+ IF( L.NE.J )
+ $ CALL SSWAP( NRHS, B( L, 1 ), LDB, B( J, 1 ), LDB )
+ CALL SGER( LM, NRHS, -ONE, AB( KD+1, J ), 1, B( J, 1 ),
+ $ LDB, B( J+1, 1 ), LDB )
+ 10 CONTINUE
+ END IF
+*
+ DO 20 I = 1, NRHS
+*
+* Solve U*X = B, overwriting B with X.
+*
+ CALL STBSV( 'Upper', 'No transpose', 'Non-unit', N, KL+KU,
+ $ AB, LDAB, B( 1, I ), 1 )
+ 20 CONTINUE
+*
+ ELSE
+*
+* Solve A'*X = B.
+*
+ DO 30 I = 1, NRHS
+*
+* Solve U'*X = B, overwriting B with X.
+*
+ CALL STBSV( 'Upper', 'Transpose', 'Non-unit', N, KL+KU, AB,
+ $ LDAB, B( 1, I ), 1 )
+ 30 CONTINUE
+*
+* Solve L'*X = B, overwriting B with X.
+*
+ IF( LNOTI ) THEN
+ DO 40 J = N - 1, 1, -1
+ LM = MIN( KL, N-J )
+ CALL SGEMV( 'Transpose', LM, NRHS, -ONE, B( J+1, 1 ),
+ $ LDB, AB( KD+1, J ), 1, ONE, B( J, 1 ), LDB )
+ L = IPIV( J )
+ IF( L.NE.J )
+ $ CALL SSWAP( NRHS, B( L, 1 ), LDB, B( J, 1 ), LDB )
+ 40 CONTINUE
+ END IF
+ END IF
+ RETURN
+*
+* End of SGBTRS
+*
+ END
+ SUBROUTINE SGEBAK( JOB, SIDE, N, ILO, IHI, SCALE, M, V, LDV,
+ $ INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER JOB, SIDE
+ INTEGER IHI, ILO, INFO, LDV, M, N
+* ..
+* .. Array Arguments ..
+ REAL V( LDV, * ), SCALE( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SGEBAK forms the right or left eigenvectors of a real general matrix
+* by backward transformation on the computed eigenvectors of the
+* balanced matrix output by SGEBAL.
+*
+* Arguments
+* =========
+*
+* JOB (input) CHARACTER*1
+* Specifies the type of backward transformation required:
+* = 'N', do nothing, return immediately;
+* = 'P', do backward transformation for permutation only;
+* = 'S', do backward transformation for scaling only;
+* = 'B', do backward transformations for both permutation and
+* scaling.
+* JOB must be the same as the argument JOB supplied to SGEBAL.
+*
+* SIDE (input) CHARACTER*1
+* = 'R': V contains right eigenvectors;
+* = 'L': V contains left eigenvectors.
+*
+* N (input) INTEGER
+* The number of rows of the matrix V. N >= 0.
+*
+* ILO (input) INTEGER
+* IHI (input) INTEGER
+* The integers ILO and IHI determined by SGEBAL.
+* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.
+*
+* SCALE (input) REAL array, dimension (N)
+* Details of the permutation and scaling factors, as returned
+* by SGEBAL.
+*
+* M (input) INTEGER
+* The number of columns of the matrix V. M >= 0.
+*
+* V (input/output) REAL array, dimension (LDV,M)
+* On entry, the matrix of right or left eigenvectors to be
+* transformed, as returned by SHSEIN or STREVC.
+* On exit, V is overwritten by the transformed eigenvectors.
+*
+* LDV (input) INTEGER
+* The leading dimension of the array V. LDV >= max(1,N).
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ONE
+ PARAMETER ( ONE = 1.0E+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL LEFTV, RIGHTV
+ INTEGER I, II, K
+ REAL S
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL SSCAL, SSWAP, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+* Decode and Test the input parameters
+*
+ RIGHTV = LSAME( SIDE, 'R' )
+ LEFTV = LSAME( SIDE, 'L' )
+*
+ INFO = 0
+ IF( .NOT.LSAME( JOB, 'N' ) .AND. .NOT.LSAME( JOB, 'P' ) .AND.
+ $ .NOT.LSAME( JOB, 'S' ) .AND. .NOT.LSAME( JOB, 'B' ) ) THEN
+ INFO = -1
+ ELSE IF( .NOT.RIGHTV .AND. .NOT.LEFTV ) THEN
+ INFO = -2
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN
+ INFO = -4
+ ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN
+ INFO = -5
+ ELSE IF( M.LT.0 ) THEN
+ INFO = -7
+ ELSE IF( LDV.LT.MAX( 1, N ) ) THEN
+ INFO = -9
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SGEBAK', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 )
+ $ RETURN
+ IF( M.EQ.0 )
+ $ RETURN
+ IF( LSAME( JOB, 'N' ) )
+ $ RETURN
+*
+ IF( ILO.EQ.IHI )
+ $ GO TO 30
+*
+* Backward balance
+*
+ IF( LSAME( JOB, 'S' ) .OR. LSAME( JOB, 'B' ) ) THEN
+*
+ IF( RIGHTV ) THEN
+ DO 10 I = ILO, IHI
+ S = SCALE( I )
+ CALL SSCAL( M, S, V( I, 1 ), LDV )
+ 10 CONTINUE
+ END IF
+*
+ IF( LEFTV ) THEN
+ DO 20 I = ILO, IHI
+ S = ONE / SCALE( I )
+ CALL SSCAL( M, S, V( I, 1 ), LDV )
+ 20 CONTINUE
+ END IF
+*
+ END IF
+*
+* Backward permutation
+*
+* For I = ILO-1 step -1 until 1,
+* IHI+1 step 1 until N do --
+*
+ 30 CONTINUE
+ IF( LSAME( JOB, 'P' ) .OR. LSAME( JOB, 'B' ) ) THEN
+ IF( RIGHTV ) THEN
+ DO 40 II = 1, N
+ I = II
+ IF( I.GE.ILO .AND. I.LE.IHI )
+ $ GO TO 40
+ IF( I.LT.ILO )
+ $ I = ILO - II
+ K = SCALE( I )
+ IF( K.EQ.I )
+ $ GO TO 40
+ CALL SSWAP( M, V( I, 1 ), LDV, V( K, 1 ), LDV )
+ 40 CONTINUE
+ END IF
+*
+ IF( LEFTV ) THEN
+ DO 50 II = 1, N
+ I = II
+ IF( I.GE.ILO .AND. I.LE.IHI )
+ $ GO TO 50
+ IF( I.LT.ILO )
+ $ I = ILO - II
+ K = SCALE( I )
+ IF( K.EQ.I )
+ $ GO TO 50
+ CALL SSWAP( M, V( I, 1 ), LDV, V( K, 1 ), LDV )
+ 50 CONTINUE
+ END IF
+ END IF
+*
+ RETURN
+*
+* End of SGEBAK
+*
+ END
+ SUBROUTINE SGEBAL( JOB, N, A, LDA, ILO, IHI, SCALE, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER JOB
+ INTEGER IHI, ILO, INFO, LDA, N
+* ..
+* .. Array Arguments ..
+ REAL A( LDA, * ), SCALE( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SGEBAL balances a general real matrix A. This involves, first,
+* permuting A by a similarity transformation to isolate eigenvalues
+* in the first 1 to ILO-1 and last IHI+1 to N elements on the
+* diagonal; and second, applying a diagonal similarity transformation
+* to rows and columns ILO to IHI to make the rows and columns as
+* close in norm as possible. Both steps are optional.
+*
+* Balancing may reduce the 1-norm of the matrix, and improve the
+* accuracy of the computed eigenvalues and/or eigenvectors.
+*
+* Arguments
+* =========
+*
+* JOB (input) CHARACTER*1
+* Specifies the operations to be performed on A:
+* = 'N': none: simply set ILO = 1, IHI = N, SCALE(I) = 1.0
+* for i = 1,...,N;
+* = 'P': permute only;
+* = 'S': scale only;
+* = 'B': both permute and scale.
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* A (input/output) REAL array, dimension (LDA,N)
+* On entry, the input matrix A.
+* On exit, A is overwritten by the balanced matrix.
+* If JOB = 'N', A is not referenced.
+* See Further Details.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,N).
+*
+* ILO (output) INTEGER
+* IHI (output) INTEGER
+* ILO and IHI are set to integers such that on exit
+* A(i,j) = 0 if i > j and j = 1,...,ILO-1 or I = IHI+1,...,N.
+* If JOB = 'N' or 'S', ILO = 1 and IHI = N.
+*
+* SCALE (output) REAL array, dimension (N)
+* Details of the permutations and scaling factors applied to
+* A. If P(j) is the index of the row and column interchanged
+* with row and column j and D(j) is the scaling factor
+* applied to row and column j, then
+* SCALE(j) = P(j) for j = 1,...,ILO-1
+* = D(j) for j = ILO,...,IHI
+* = P(j) for j = IHI+1,...,N.
+* The order in which the interchanges are made is N to IHI+1,
+* then 1 to ILO-1.
+*
+* INFO (output) INTEGER
+* = 0: successful exit.
+* < 0: if INFO = -i, the i-th argument had an illegal value.
+*
+* Further Details
+* ===============
+*
+* The permutations consist of row and column interchanges which put
+* the matrix in the form
+*
+* ( T1 X Y )
+* P A P = ( 0 B Z )
+* ( 0 0 T2 )
+*
+* where T1 and T2 are upper triangular matrices whose eigenvalues lie
+* along the diagonal. The column indices ILO and IHI mark the starting
+* and ending columns of the submatrix B. Balancing consists of applying
+* a diagonal similarity transformation inv(D) * B * D to make the
+* 1-norms of each row of B and its corresponding column nearly equal.
+* The output matrix is
+*
+* ( T1 X*D Y )
+* ( 0 inv(D)*B*D inv(D)*Z ).
+* ( 0 0 T2 )
+*
+* Information about the permutations P and the diagonal matrix D is
+* returned in the vector SCALE.
+*
+* This subroutine is based on the EISPACK routine BALANC.
+*
+* Modified by Tzu-Yi Chen, Computer Science Division, University of
+* California at Berkeley, USA
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO, ONE
+ PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+ REAL SCLFAC
+ PARAMETER ( SCLFAC = 2.0E+0 )
+ REAL FACTOR
+ PARAMETER ( FACTOR = 0.95E+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL NOCONV
+ INTEGER I, ICA, IEXC, IRA, J, K, L, M
+ REAL C, CA, F, G, R, RA, S, SFMAX1, SFMAX2, SFMIN1,
+ $ SFMIN2
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ISAMAX
+ REAL SLAMCH
+ EXTERNAL LSAME, ISAMAX, SLAMCH
+* ..
+* .. External Subroutines ..
+ EXTERNAL SSCAL, SSWAP, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters
+*
+ INFO = 0
+ IF( .NOT.LSAME( JOB, 'N' ) .AND. .NOT.LSAME( JOB, 'P' ) .AND.
+ $ .NOT.LSAME( JOB, 'S' ) .AND. .NOT.LSAME( JOB, 'B' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -4
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SGEBAL', -INFO )
+ RETURN
+ END IF
+*
+ K = 1
+ L = N
+*
+ IF( N.EQ.0 )
+ $ GO TO 210
+*
+ IF( LSAME( JOB, 'N' ) ) THEN
+ DO 10 I = 1, N
+ SCALE( I ) = ONE
+ 10 CONTINUE
+ GO TO 210
+ END IF
+*
+ IF( LSAME( JOB, 'S' ) )
+ $ GO TO 120
+*
+* Permutation to isolate eigenvalues if possible
+*
+ GO TO 50
+*
+* Row and column exchange.
+*
+ 20 CONTINUE
+ SCALE( M ) = J
+ IF( J.EQ.M )
+ $ GO TO 30
+*
+ CALL SSWAP( L, A( 1, J ), 1, A( 1, M ), 1 )
+ CALL SSWAP( N-K+1, A( J, K ), LDA, A( M, K ), LDA )
+*
+ 30 CONTINUE
+ GO TO ( 40, 80 )IEXC
+*
+* Search for rows isolating an eigenvalue and push them down.
+*
+ 40 CONTINUE
+ IF( L.EQ.1 )
+ $ GO TO 210
+ L = L - 1
+*
+ 50 CONTINUE
+ DO 70 J = L, 1, -1
+*
+ DO 60 I = 1, L
+ IF( I.EQ.J )
+ $ GO TO 60
+ IF( A( J, I ).NE.ZERO )
+ $ GO TO 70
+ 60 CONTINUE
+*
+ M = L
+ IEXC = 1
+ GO TO 20
+ 70 CONTINUE
+*
+ GO TO 90
+*
+* Search for columns isolating an eigenvalue and push them left.
+*
+ 80 CONTINUE
+ K = K + 1
+*
+ 90 CONTINUE
+ DO 110 J = K, L
+*
+ DO 100 I = K, L
+ IF( I.EQ.J )
+ $ GO TO 100
+ IF( A( I, J ).NE.ZERO )
+ $ GO TO 110
+ 100 CONTINUE
+*
+ M = K
+ IEXC = 2
+ GO TO 20
+ 110 CONTINUE
+*
+ 120 CONTINUE
+ DO 130 I = K, L
+ SCALE( I ) = ONE
+ 130 CONTINUE
+*
+ IF( LSAME( JOB, 'P' ) )
+ $ GO TO 210
+*
+* Balance the submatrix in rows K to L.
+*
+* Iterative loop for norm reduction
+*
+ SFMIN1 = SLAMCH( 'S' ) / SLAMCH( 'P' )
+ SFMAX1 = ONE / SFMIN1
+ SFMIN2 = SFMIN1*SCLFAC
+ SFMAX2 = ONE / SFMIN2
+ 140 CONTINUE
+ NOCONV = .FALSE.
+*
+ DO 200 I = K, L
+ C = ZERO
+ R = ZERO
+*
+ DO 150 J = K, L
+ IF( J.EQ.I )
+ $ GO TO 150
+ C = C + ABS( A( J, I ) )
+ R = R + ABS( A( I, J ) )
+ 150 CONTINUE
+ ICA = ISAMAX( L, A( 1, I ), 1 )
+ CA = ABS( A( ICA, I ) )
+ IRA = ISAMAX( N-K+1, A( I, K ), LDA )
+ RA = ABS( A( I, IRA+K-1 ) )
+*
+* Guard against zero C or R due to underflow.
+*
+ IF( C.EQ.ZERO .OR. R.EQ.ZERO )
+ $ GO TO 200
+ G = R / SCLFAC
+ F = ONE
+ S = C + R
+ 160 CONTINUE
+ IF( C.GE.G .OR. MAX( F, C, CA ).GE.SFMAX2 .OR.
+ $ MIN( R, G, RA ).LE.SFMIN2 )GO TO 170
+ F = F*SCLFAC
+ C = C*SCLFAC
+ CA = CA*SCLFAC
+ R = R / SCLFAC
+ G = G / SCLFAC
+ RA = RA / SCLFAC
+ GO TO 160
+*
+ 170 CONTINUE
+ G = C / SCLFAC
+ 180 CONTINUE
+ IF( G.LT.R .OR. MAX( R, RA ).GE.SFMAX2 .OR.
+ $ MIN( F, C, G, CA ).LE.SFMIN2 )GO TO 190
+ F = F / SCLFAC
+ C = C / SCLFAC
+ G = G / SCLFAC
+ CA = CA / SCLFAC
+ R = R*SCLFAC
+ RA = RA*SCLFAC
+ GO TO 180
+*
+* Now balance.
+*
+ 190 CONTINUE
+ IF( ( C+R ).GE.FACTOR*S )
+ $ GO TO 200
+ IF( F.LT.ONE .AND. SCALE( I ).LT.ONE ) THEN
+ IF( F*SCALE( I ).LE.SFMIN1 )
+ $ GO TO 200
+ END IF
+ IF( F.GT.ONE .AND. SCALE( I ).GT.ONE ) THEN
+ IF( SCALE( I ).GE.SFMAX1 / F )
+ $ GO TO 200
+ END IF
+ G = ONE / F
+ SCALE( I ) = SCALE( I )*F
+ NOCONV = .TRUE.
+*
+ CALL SSCAL( N-K+1, G, A( I, K ), LDA )
+ CALL SSCAL( L, F, A( 1, I ), 1 )
+*
+ 200 CONTINUE
+*
+ IF( NOCONV )
+ $ GO TO 140
+*
+ 210 CONTINUE
+ ILO = K
+ IHI = L
+*
+ RETURN
+*
+* End of SGEBAL
+*
+ END
+ SUBROUTINE SGEBD2( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LDA, M, N
+* ..
+* .. Array Arguments ..
+ REAL A( LDA, * ), D( * ), E( * ), TAUP( * ),
+ $ TAUQ( * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SGEBD2 reduces a real general m by n matrix A to upper or lower
+* bidiagonal form B by an orthogonal transformation: Q' * A * P = B.
+*
+* If m >= n, B is upper bidiagonal; if m < n, B is lower bidiagonal.
+*
+* Arguments
+* =========
+*
+* M (input) INTEGER
+* The number of rows in the matrix A. M >= 0.
+*
+* N (input) INTEGER
+* The number of columns in the matrix A. N >= 0.
+*
+* A (input/output) REAL array, dimension (LDA,N)
+* On entry, the m by n general matrix to be reduced.
+* On exit,
+* if m >= n, the diagonal and the first superdiagonal are
+* overwritten with the upper bidiagonal matrix B; the
+* elements below the diagonal, with the array TAUQ, represent
+* the orthogonal matrix Q as a product of elementary
+* reflectors, and the elements above the first superdiagonal,
+* with the array TAUP, represent the orthogonal matrix P as
+* a product of elementary reflectors;
+* if m < n, the diagonal and the first subdiagonal are
+* overwritten with the lower bidiagonal matrix B; the
+* elements below the first subdiagonal, with the array TAUQ,
+* represent the orthogonal matrix Q as a product of
+* elementary reflectors, and the elements above the diagonal,
+* with the array TAUP, represent the orthogonal matrix P as
+* a product of elementary reflectors.
+* See Further Details.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,M).
+*
+* D (output) REAL array, dimension (min(M,N))
+* The diagonal elements of the bidiagonal matrix B:
+* D(i) = A(i,i).
+*
+* E (output) REAL array, dimension (min(M,N)-1)
+* The off-diagonal elements of the bidiagonal matrix B:
+* if m >= n, E(i) = A(i,i+1) for i = 1,2,...,n-1;
+* if m < n, E(i) = A(i+1,i) for i = 1,2,...,m-1.
+*
+* TAUQ (output) REAL array dimension (min(M,N))
+* The scalar factors of the elementary reflectors which
+* represent the orthogonal matrix Q. See Further Details.
+*
+* TAUP (output) REAL array, dimension (min(M,N))
+* The scalar factors of the elementary reflectors which
+* represent the orthogonal matrix P. See Further Details.
+*
+* WORK (workspace) REAL array, dimension (max(M,N))
+*
+* INFO (output) INTEGER
+* = 0: successful exit.
+* < 0: if INFO = -i, the i-th argument had an illegal value.
+*
+* Further Details
+* ===============
+*
+* The matrices Q and P are represented as products of elementary
+* reflectors:
+*
+* If m >= n,
+*
+* Q = H(1) H(2) . . . H(n) and P = G(1) G(2) . . . G(n-1)
+*
+* Each H(i) and G(i) has the form:
+*
+* H(i) = I - tauq * v * v' and G(i) = I - taup * u * u'
+*
+* where tauq and taup are real scalars, and v and u are real vectors;
+* v(1:i-1) = 0, v(i) = 1, and v(i+1:m) is stored on exit in A(i+1:m,i);
+* u(1:i) = 0, u(i+1) = 1, and u(i+2:n) is stored on exit in A(i,i+2:n);
+* tauq is stored in TAUQ(i) and taup in TAUP(i).
+*
+* If m < n,
+*
+* Q = H(1) H(2) . . . H(m-1) and P = G(1) G(2) . . . G(m)
+*
+* Each H(i) and G(i) has the form:
+*
+* H(i) = I - tauq * v * v' and G(i) = I - taup * u * u'
+*
+* where tauq and taup are real scalars, and v and u are real vectors;
+* v(1:i) = 0, v(i+1) = 1, and v(i+2:m) is stored on exit in A(i+2:m,i);
+* u(1:i-1) = 0, u(i) = 1, and u(i+1:n) is stored on exit in A(i,i+1:n);
+* tauq is stored in TAUQ(i) and taup in TAUP(i).
+*
+* The contents of A on exit are illustrated by the following examples:
+*
+* m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n):
+*
+* ( d e u1 u1 u1 ) ( d u1 u1 u1 u1 u1 )
+* ( v1 d e u2 u2 ) ( e d u2 u2 u2 u2 )
+* ( v1 v2 d e u3 ) ( v1 e d u3 u3 u3 )
+* ( v1 v2 v3 d e ) ( v1 v2 e d u4 u4 )
+* ( v1 v2 v3 v4 d ) ( v1 v2 v3 e d u5 )
+* ( v1 v2 v3 v4 v5 )
+*
+* where d and e denote diagonal and off-diagonal elements of B, vi
+* denotes an element of the vector defining H(i), and ui an element of
+* the vector defining G(i).
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO, ONE
+ PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I
+* ..
+* .. External Subroutines ..
+ EXTERNAL SLARF, SLARFG, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters
+*
+ INFO = 0
+ IF( M.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+ INFO = -4
+ END IF
+ IF( INFO.LT.0 ) THEN
+ CALL XERBLA( 'SGEBD2', -INFO )
+ RETURN
+ END IF
+*
+ IF( M.GE.N ) THEN
+*
+* Reduce to upper bidiagonal form
+*
+ DO 10 I = 1, N
+*
+* Generate elementary reflector H(i) to annihilate A(i+1:m,i)
+*
+ CALL SLARFG( M-I+1, A( I, I ), A( MIN( I+1, M ), I ), 1,
+ $ TAUQ( I ) )
+ D( I ) = A( I, I )
+ A( I, I ) = ONE
+*
+* Apply H(i) to A(i:m,i+1:n) from the left
+*
+ IF( I.LT.N )
+ $ CALL SLARF( 'Left', M-I+1, N-I, A( I, I ), 1, TAUQ( I ),
+ $ A( I, I+1 ), LDA, WORK )
+ A( I, I ) = D( I )
+*
+ IF( I.LT.N ) THEN
+*
+* Generate elementary reflector G(i) to annihilate
+* A(i,i+2:n)
+*
+ CALL SLARFG( N-I, A( I, I+1 ), A( I, MIN( I+2, N ) ),
+ $ LDA, TAUP( I ) )
+ E( I ) = A( I, I+1 )
+ A( I, I+1 ) = ONE
+*
+* Apply G(i) to A(i+1:m,i+1:n) from the right
+*
+ CALL SLARF( 'Right', M-I, N-I, A( I, I+1 ), LDA,
+ $ TAUP( I ), A( I+1, I+1 ), LDA, WORK )
+ A( I, I+1 ) = E( I )
+ ELSE
+ TAUP( I ) = ZERO
+ END IF
+ 10 CONTINUE
+ ELSE
+*
+* Reduce to lower bidiagonal form
+*
+ DO 20 I = 1, M
+*
+* Generate elementary reflector G(i) to annihilate A(i,i+1:n)
+*
+ CALL SLARFG( N-I+1, A( I, I ), A( I, MIN( I+1, N ) ), LDA,
+ $ TAUP( I ) )
+ D( I ) = A( I, I )
+ A( I, I ) = ONE
+*
+* Apply G(i) to A(i+1:m,i:n) from the right
+*
+ IF( I.LT.M )
+ $ CALL SLARF( 'Right', M-I, N-I+1, A( I, I ), LDA,
+ $ TAUP( I ), A( I+1, I ), LDA, WORK )
+ A( I, I ) = D( I )
+*
+ IF( I.LT.M ) THEN
+*
+* Generate elementary reflector H(i) to annihilate
+* A(i+2:m,i)
+*
+ CALL SLARFG( M-I, A( I+1, I ), A( MIN( I+2, M ), I ), 1,
+ $ TAUQ( I ) )
+ E( I ) = A( I+1, I )
+ A( I+1, I ) = ONE
+*
+* Apply H(i) to A(i+1:m,i+1:n) from the left
+*
+ CALL SLARF( 'Left', M-I, N-I, A( I+1, I ), 1, TAUQ( I ),
+ $ A( I+1, I+1 ), LDA, WORK )
+ A( I+1, I ) = E( I )
+ ELSE
+ TAUQ( I ) = ZERO
+ END IF
+ 20 CONTINUE
+ END IF
+ RETURN
+*
+* End of SGEBD2
+*
+ END
+ SUBROUTINE SGEBRD( M, N, A, LDA, D, E, TAUQ, TAUP, WORK, LWORK,
+ $ INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LDA, LWORK, M, N
+* ..
+* .. Array Arguments ..
+ REAL A( LDA, * ), D( * ), E( * ), TAUP( * ),
+ $ TAUQ( * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SGEBRD reduces a general real M-by-N matrix A to upper or lower
+* bidiagonal form B by an orthogonal transformation: Q**T * A * P = B.
+*
+* If m >= n, B is upper bidiagonal; if m < n, B is lower bidiagonal.
+*
+* Arguments
+* =========
+*
+* M (input) INTEGER
+* The number of rows in the matrix A. M >= 0.
+*
+* N (input) INTEGER
+* The number of columns in the matrix A. N >= 0.
+*
+* A (input/output) REAL array, dimension (LDA,N)
+* On entry, the M-by-N general matrix to be reduced.
+* On exit,
+* if m >= n, the diagonal and the first superdiagonal are
+* overwritten with the upper bidiagonal matrix B; the
+* elements below the diagonal, with the array TAUQ, represent
+* the orthogonal matrix Q as a product of elementary
+* reflectors, and the elements above the first superdiagonal,
+* with the array TAUP, represent the orthogonal matrix P as
+* a product of elementary reflectors;
+* if m < n, the diagonal and the first subdiagonal are
+* overwritten with the lower bidiagonal matrix B; the
+* elements below the first subdiagonal, with the array TAUQ,
+* represent the orthogonal matrix Q as a product of
+* elementary reflectors, and the elements above the diagonal,
+* with the array TAUP, represent the orthogonal matrix P as
+* a product of elementary reflectors.
+* See Further Details.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,M).
+*
+* D (output) REAL array, dimension (min(M,N))
+* The diagonal elements of the bidiagonal matrix B:
+* D(i) = A(i,i).
+*
+* E (output) REAL array, dimension (min(M,N)-1)
+* The off-diagonal elements of the bidiagonal matrix B:
+* if m >= n, E(i) = A(i,i+1) for i = 1,2,...,n-1;
+* if m < n, E(i) = A(i+1,i) for i = 1,2,...,m-1.
+*
+* TAUQ (output) REAL array dimension (min(M,N))
+* The scalar factors of the elementary reflectors which
+* represent the orthogonal matrix Q. See Further Details.
+*
+* TAUP (output) REAL array, dimension (min(M,N))
+* The scalar factors of the elementary reflectors which
+* represent the orthogonal matrix P. See Further Details.
+*
+* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))
+* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+* LWORK (input) INTEGER
+* The length of the array WORK. LWORK >= max(1,M,N).
+* For optimum performance LWORK >= (M+N)*NB, where NB
+* is the optimal blocksize.
+*
+* If LWORK = -1, then a workspace query is assumed; the routine
+* only calculates the optimal size of the WORK array, returns
+* this value as the first entry of the WORK array, and no error
+* message related to LWORK is issued by XERBLA.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value.
+*
+* Further Details
+* ===============
+*
+* The matrices Q and P are represented as products of elementary
+* reflectors:
+*
+* If m >= n,
+*
+* Q = H(1) H(2) . . . H(n) and P = G(1) G(2) . . . G(n-1)
+*
+* Each H(i) and G(i) has the form:
+*
+* H(i) = I - tauq * v * v' and G(i) = I - taup * u * u'
+*
+* where tauq and taup are real scalars, and v and u are real vectors;
+* v(1:i-1) = 0, v(i) = 1, and v(i+1:m) is stored on exit in A(i+1:m,i);
+* u(1:i) = 0, u(i+1) = 1, and u(i+2:n) is stored on exit in A(i,i+2:n);
+* tauq is stored in TAUQ(i) and taup in TAUP(i).
+*
+* If m < n,
+*
+* Q = H(1) H(2) . . . H(m-1) and P = G(1) G(2) . . . G(m)
+*
+* Each H(i) and G(i) has the form:
+*
+* H(i) = I - tauq * v * v' and G(i) = I - taup * u * u'
+*
+* where tauq and taup are real scalars, and v and u are real vectors;
+* v(1:i) = 0, v(i+1) = 1, and v(i+2:m) is stored on exit in A(i+2:m,i);
+* u(1:i-1) = 0, u(i) = 1, and u(i+1:n) is stored on exit in A(i,i+1:n);
+* tauq is stored in TAUQ(i) and taup in TAUP(i).
+*
+* The contents of A on exit are illustrated by the following examples:
+*
+* m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n):
+*
+* ( d e u1 u1 u1 ) ( d u1 u1 u1 u1 u1 )
+* ( v1 d e u2 u2 ) ( e d u2 u2 u2 u2 )
+* ( v1 v2 d e u3 ) ( v1 e d u3 u3 u3 )
+* ( v1 v2 v3 d e ) ( v1 v2 e d u4 u4 )
+* ( v1 v2 v3 v4 d ) ( v1 v2 v3 e d u5 )
+* ( v1 v2 v3 v4 v5 )
+*
+* where d and e denote diagonal and off-diagonal elements of B, vi
+* denotes an element of the vector defining H(i), and ui an element of
+* the vector defining G(i).
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ONE
+ PARAMETER ( ONE = 1.0E+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL LQUERY
+ INTEGER I, IINFO, J, LDWRKX, LDWRKY, LWKOPT, MINMN, NB,
+ $ NBMIN, NX
+ REAL WS
+* ..
+* .. External Subroutines ..
+ EXTERNAL SGEBD2, SGEMM, SLABRD, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN, REAL
+* ..
+* .. External Functions ..
+ INTEGER ILAENV
+ EXTERNAL ILAENV
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters
+*
+ INFO = 0
+ NB = MAX( 1, ILAENV( 1, 'SGEBRD', ' ', M, N, -1, -1 ) )
+ LWKOPT = ( M+N )*NB
+ WORK( 1 ) = REAL( LWKOPT )
+ LQUERY = ( LWORK.EQ.-1 )
+ IF( M.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+ INFO = -4
+ ELSE IF( LWORK.LT.MAX( 1, M, N ) .AND. .NOT.LQUERY ) THEN
+ INFO = -10
+ END IF
+ IF( INFO.LT.0 ) THEN
+ CALL XERBLA( 'SGEBRD', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ MINMN = MIN( M, N )
+ IF( MINMN.EQ.0 ) THEN
+ WORK( 1 ) = 1
+ RETURN
+ END IF
+*
+ WS = MAX( M, N )
+ LDWRKX = M
+ LDWRKY = N
+*
+ IF( NB.GT.1 .AND. NB.LT.MINMN ) THEN
+*
+* Set the crossover point NX.
+*
+ NX = MAX( NB, ILAENV( 3, 'SGEBRD', ' ', M, N, -1, -1 ) )
+*
+* Determine when to switch from blocked to unblocked code.
+*
+ IF( NX.LT.MINMN ) THEN
+ WS = ( M+N )*NB
+ IF( LWORK.LT.WS ) THEN
+*
+* Not enough work space for the optimal NB, consider using
+* a smaller block size.
+*
+ NBMIN = ILAENV( 2, 'SGEBRD', ' ', M, N, -1, -1 )
+ IF( LWORK.GE.( M+N )*NBMIN ) THEN
+ NB = LWORK / ( M+N )
+ ELSE
+ NB = 1
+ NX = MINMN
+ END IF
+ END IF
+ END IF
+ ELSE
+ NX = MINMN
+ END IF
+*
+ DO 30 I = 1, MINMN - NX, NB
+*
+* Reduce rows and columns i:i+nb-1 to bidiagonal form and return
+* the matrices X and Y which are needed to update the unreduced
+* part of the matrix
+*
+ CALL SLABRD( M-I+1, N-I+1, NB, A( I, I ), LDA, D( I ), E( I ),
+ $ TAUQ( I ), TAUP( I ), WORK, LDWRKX,
+ $ WORK( LDWRKX*NB+1 ), LDWRKY )
+*
+* Update the trailing submatrix A(i+nb:m,i+nb:n), using an update
+* of the form A := A - V*Y' - X*U'
+*
+ CALL SGEMM( 'No transpose', 'Transpose', M-I-NB+1, N-I-NB+1,
+ $ NB, -ONE, A( I+NB, I ), LDA,
+ $ WORK( LDWRKX*NB+NB+1 ), LDWRKY, ONE,
+ $ A( I+NB, I+NB ), LDA )
+ CALL SGEMM( 'No transpose', 'No transpose', M-I-NB+1, N-I-NB+1,
+ $ NB, -ONE, WORK( NB+1 ), LDWRKX, A( I, I+NB ), LDA,
+ $ ONE, A( I+NB, I+NB ), LDA )
+*
+* Copy diagonal and off-diagonal elements of B back into A
+*
+ IF( M.GE.N ) THEN
+ DO 10 J = I, I + NB - 1
+ A( J, J ) = D( J )
+ A( J, J+1 ) = E( J )
+ 10 CONTINUE
+ ELSE
+ DO 20 J = I, I + NB - 1
+ A( J, J ) = D( J )
+ A( J+1, J ) = E( J )
+ 20 CONTINUE
+ END IF
+ 30 CONTINUE
+*
+* Use unblocked code to reduce the remainder of the matrix
+*
+ CALL SGEBD2( M-I+1, N-I+1, A( I, I ), LDA, D( I ), E( I ),
+ $ TAUQ( I ), TAUP( I ), WORK, IINFO )
+ WORK( 1 ) = WS
+ RETURN
+*
+* End of SGEBRD
+*
+ END
+ SUBROUTINE SGECON( NORM, N, A, LDA, ANORM, RCOND, WORK, IWORK,
+ $ INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* Modified to call SLACN2 in place of SLACON, 7 Feb 03, SJH.
+*
+* .. Scalar Arguments ..
+ CHARACTER NORM
+ INTEGER INFO, LDA, N
+ REAL ANORM, RCOND
+* ..
+* .. Array Arguments ..
+ INTEGER IWORK( * )
+ REAL A( LDA, * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SGECON estimates the reciprocal of the condition number of a general
+* real matrix A, in either the 1-norm or the infinity-norm, using
+* the LU factorization computed by SGETRF.
+*
+* An estimate is obtained for norm(inv(A)), and the reciprocal of the
+* condition number is computed as
+* RCOND = 1 / ( norm(A) * norm(inv(A)) ).
+*
+* Arguments
+* =========
+*
+* NORM (input) CHARACTER*1
+* Specifies whether the 1-norm condition number or the
+* infinity-norm condition number is required:
+* = '1' or 'O': 1-norm;
+* = 'I': Infinity-norm.
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* A (input) REAL array, dimension (LDA,N)
+* The factors L and U from the factorization A = P*L*U
+* as computed by SGETRF.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,N).
+*
+* ANORM (input) REAL
+* If NORM = '1' or 'O', the 1-norm of the original matrix A.
+* If NORM = 'I', the infinity-norm of the original matrix A.
+*
+* RCOND (output) REAL
+* The reciprocal of the condition number of the matrix A,
+* computed as RCOND = 1/(norm(A) * norm(inv(A))).
+*
+* WORK (workspace) REAL array, dimension (4*N)
+*
+* IWORK (workspace) INTEGER array, dimension (N)
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ONE, ZERO
+ PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL ONENRM
+ CHARACTER NORMIN
+ INTEGER IX, KASE, KASE1
+ REAL AINVNM, SCALE, SL, SMLNUM, SU
+* ..
+* .. Local Arrays ..
+ INTEGER ISAVE( 3 )
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ISAMAX
+ REAL SLAMCH
+ EXTERNAL LSAME, ISAMAX, SLAMCH
+* ..
+* .. External Subroutines ..
+ EXTERNAL SLACN2, SLATRS, SRSCL, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ ONENRM = NORM.EQ.'1' .OR. LSAME( NORM, 'O' )
+ IF( .NOT.ONENRM .AND. .NOT.LSAME( NORM, 'I' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -4
+ ELSE IF( ANORM.LT.ZERO ) THEN
+ INFO = -5
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SGECON', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ RCOND = ZERO
+ IF( N.EQ.0 ) THEN
+ RCOND = ONE
+ RETURN
+ ELSE IF( ANORM.EQ.ZERO ) THEN
+ RETURN
+ END IF
+*
+ SMLNUM = SLAMCH( 'Safe minimum' )
+*
+* Estimate the norm of inv(A).
+*
+ AINVNM = ZERO
+ NORMIN = 'N'
+ IF( ONENRM ) THEN
+ KASE1 = 1
+ ELSE
+ KASE1 = 2
+ END IF
+ KASE = 0
+ 10 CONTINUE
+ CALL SLACN2( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE, ISAVE )
+ IF( KASE.NE.0 ) THEN
+ IF( KASE.EQ.KASE1 ) THEN
+*
+* Multiply by inv(L).
+*
+ CALL SLATRS( 'Lower', 'No transpose', 'Unit', NORMIN, N, A,
+ $ LDA, WORK, SL, WORK( 2*N+1 ), INFO )
+*
+* Multiply by inv(U).
+*
+ CALL SLATRS( 'Upper', 'No transpose', 'Non-unit', NORMIN, N,
+ $ A, LDA, WORK, SU, WORK( 3*N+1 ), INFO )
+ ELSE
+*
+* Multiply by inv(U').
+*
+ CALL SLATRS( 'Upper', 'Transpose', 'Non-unit', NORMIN, N, A,
+ $ LDA, WORK, SU, WORK( 3*N+1 ), INFO )
+*
+* Multiply by inv(L').
+*
+ CALL SLATRS( 'Lower', 'Transpose', 'Unit', NORMIN, N, A,
+ $ LDA, WORK, SL, WORK( 2*N+1 ), INFO )
+ END IF
+*
+* Divide X by 1/(SL*SU) if doing so will not cause overflow.
+*
+ SCALE = SL*SU
+ NORMIN = 'Y'
+ IF( SCALE.NE.ONE ) THEN
+ IX = ISAMAX( N, WORK, 1 )
+ IF( SCALE.LT.ABS( WORK( IX ) )*SMLNUM .OR. SCALE.EQ.ZERO )
+ $ GO TO 20
+ CALL SRSCL( N, SCALE, WORK, 1 )
+ END IF
+ GO TO 10
+ END IF
+*
+* Compute the estimate of the reciprocal condition number.
+*
+ IF( AINVNM.NE.ZERO )
+ $ RCOND = ( ONE / AINVNM ) / ANORM
+*
+ 20 CONTINUE
+ RETURN
+*
+* End of SGECON
+*
+ END
+ SUBROUTINE SGEEQU( M, N, A, LDA, R, C, ROWCND, COLCND, AMAX,
+ $ INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LDA, M, N
+ REAL AMAX, COLCND, ROWCND
+* ..
+* .. Array Arguments ..
+ REAL A( LDA, * ), C( * ), R( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SGEEQU computes row and column scalings intended to equilibrate an
+* M-by-N matrix A and reduce its condition number. R returns the row
+* scale factors and C the column scale factors, chosen to try to make
+* the largest element in each row and column of the matrix B with
+* elements B(i,j)=R(i)*A(i,j)*C(j) have absolute value 1.
+*
+* R(i) and C(j) are restricted to be between SMLNUM = smallest safe
+* number and BIGNUM = largest safe number. Use of these scaling
+* factors is not guaranteed to reduce the condition number of A but
+* works well in practice.
+*
+* Arguments
+* =========
+*
+* M (input) INTEGER
+* The number of rows of the matrix A. M >= 0.
+*
+* N (input) INTEGER
+* The number of columns of the matrix A. N >= 0.
+*
+* A (input) REAL array, dimension (LDA,N)
+* The M-by-N matrix whose equilibration factors are
+* to be computed.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,M).
+*
+* R (output) REAL array, dimension (M)
+* If INFO = 0 or INFO > M, R contains the row scale factors
+* for A.
+*
+* C (output) REAL array, dimension (N)
+* If INFO = 0, C contains the column scale factors for A.
+*
+* ROWCND (output) REAL
+* If INFO = 0 or INFO > M, ROWCND contains the ratio of the
+* smallest R(i) to the largest R(i). If ROWCND >= 0.1 and
+* AMAX is neither too large nor too small, it is not worth
+* scaling by R.
+*
+* COLCND (output) REAL
+* If INFO = 0, COLCND contains the ratio of the smallest
+* C(i) to the largest C(i). If COLCND >= 0.1, it is not
+* worth scaling by C.
+*
+* AMAX (output) REAL
+* Absolute value of largest matrix element. If AMAX is very
+* close to overflow or very close to underflow, the matrix
+* should be scaled.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* > 0: if INFO = i, and i is
+* <= M: the i-th row of A is exactly zero
+* > M: the (i-M)-th column of A is exactly zero
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ONE, ZERO
+ PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, J
+ REAL BIGNUM, RCMAX, RCMIN, SMLNUM
+* ..
+* .. External Functions ..
+ REAL SLAMCH
+ EXTERNAL SLAMCH
+* ..
+* .. External Subroutines ..
+ EXTERNAL XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ IF( M.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+ INFO = -4
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SGEEQU', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( M.EQ.0 .OR. N.EQ.0 ) THEN
+ ROWCND = ONE
+ COLCND = ONE
+ AMAX = ZERO
+ RETURN
+ END IF
+*
+* Get machine constants.
+*
+ SMLNUM = SLAMCH( 'S' )
+ BIGNUM = ONE / SMLNUM
+*
+* Compute row scale factors.
+*
+ DO 10 I = 1, M
+ R( I ) = ZERO
+ 10 CONTINUE
+*
+* Find the maximum element in each row.
+*
+ DO 30 J = 1, N
+ DO 20 I = 1, M
+ R( I ) = MAX( R( I ), ABS( A( I, J ) ) )
+ 20 CONTINUE
+ 30 CONTINUE
+*
+* Find the maximum and minimum scale factors.
+*
+ RCMIN = BIGNUM
+ RCMAX = ZERO
+ DO 40 I = 1, M
+ RCMAX = MAX( RCMAX, R( I ) )
+ RCMIN = MIN( RCMIN, R( I ) )
+ 40 CONTINUE
+ AMAX = RCMAX
+*
+ IF( RCMIN.EQ.ZERO ) THEN
+*
+* Find the first zero scale factor and return an error code.
+*
+ DO 50 I = 1, M
+ IF( R( I ).EQ.ZERO ) THEN
+ INFO = I
+ RETURN
+ END IF
+ 50 CONTINUE
+ ELSE
+*
+* Invert the scale factors.
+*
+ DO 60 I = 1, M
+ R( I ) = ONE / MIN( MAX( R( I ), SMLNUM ), BIGNUM )
+ 60 CONTINUE
+*
+* Compute ROWCND = min(R(I)) / max(R(I))
+*
+ ROWCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM )
+ END IF
+*
+* Compute column scale factors
+*
+ DO 70 J = 1, N
+ C( J ) = ZERO
+ 70 CONTINUE
+*
+* Find the maximum element in each column,
+* assuming the row scaling computed above.
+*
+ DO 90 J = 1, N
+ DO 80 I = 1, M
+ C( J ) = MAX( C( J ), ABS( A( I, J ) )*R( I ) )
+ 80 CONTINUE
+ 90 CONTINUE
+*
+* Find the maximum and minimum scale factors.
+*
+ RCMIN = BIGNUM
+ RCMAX = ZERO
+ DO 100 J = 1, N
+ RCMIN = MIN( RCMIN, C( J ) )
+ RCMAX = MAX( RCMAX, C( J ) )
+ 100 CONTINUE
+*
+ IF( RCMIN.EQ.ZERO ) THEN
+*
+* Find the first zero scale factor and return an error code.
+*
+ DO 110 J = 1, N
+ IF( C( J ).EQ.ZERO ) THEN
+ INFO = M + J
+ RETURN
+ END IF
+ 110 CONTINUE
+ ELSE
+*
+* Invert the scale factors.
+*
+ DO 120 J = 1, N
+ C( J ) = ONE / MIN( MAX( C( J ), SMLNUM ), BIGNUM )
+ 120 CONTINUE
+*
+* Compute COLCND = min(C(J)) / max(C(J))
+*
+ COLCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM )
+ END IF
+*
+ RETURN
+*
+* End of SGEEQU
+*
+ END
+ SUBROUTINE SGEES( JOBVS, SORT, SELECT, N, A, LDA, SDIM, WR, WI,
+ $ VS, LDVS, WORK, LWORK, BWORK, INFO )
+*
+* -- LAPACK driver routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER JOBVS, SORT
+ INTEGER INFO, LDA, LDVS, LWORK, N, SDIM
+* ..
+* .. Array Arguments ..
+ LOGICAL BWORK( * )
+ REAL A( LDA, * ), VS( LDVS, * ), WI( * ), WORK( * ),
+ $ WR( * )
+* ..
+* .. Function Arguments ..
+ LOGICAL SELECT
+ EXTERNAL SELECT
+* ..
+*
+* Purpose
+* =======
+*
+* SGEES computes for an N-by-N real nonsymmetric matrix A, the
+* eigenvalues, the real Schur form T, and, optionally, the matrix of
+* Schur vectors Z. This gives the Schur factorization A = Z*T*(Z**T).
+*
+* Optionally, it also orders the eigenvalues on the diagonal of the
+* real Schur form so that selected eigenvalues are at the top left.
+* The leading columns of Z then form an orthonormal basis for the
+* invariant subspace corresponding to the selected eigenvalues.
+*
+* A matrix is in real Schur form if it is upper quasi-triangular with
+* 1-by-1 and 2-by-2 blocks. 2-by-2 blocks will be standardized in the
+* form
+* [ a b ]
+* [ c a ]
+*
+* where b*c < 0. The eigenvalues of such a block are a +- sqrt(bc).
+*
+* Arguments
+* =========
+*
+* JOBVS (input) CHARACTER*1
+* = 'N': Schur vectors are not computed;
+* = 'V': Schur vectors are computed.
+*
+* SORT (input) CHARACTER*1
+* Specifies whether or not to order the eigenvalues on the
+* diagonal of the Schur form.
+* = 'N': Eigenvalues are not ordered;
+* = 'S': Eigenvalues are ordered (see SELECT).
+*
+* SELECT (external procedure) LOGICAL FUNCTION of two REAL arguments
+* SELECT must be declared EXTERNAL in the calling subroutine.
+* If SORT = 'S', SELECT is used to select eigenvalues to sort
+* to the top left of the Schur form.
+* If SORT = 'N', SELECT is not referenced.
+* An eigenvalue WR(j)+sqrt(-1)*WI(j) is selected if
+* SELECT(WR(j),WI(j)) is true; i.e., if either one of a complex
+* conjugate pair of eigenvalues is selected, then both complex
+* eigenvalues are selected.
+* Note that a selected complex eigenvalue may no longer
+* satisfy SELECT(WR(j),WI(j)) = .TRUE. after ordering, since
+* ordering may change the value of complex eigenvalues
+* (especially if the eigenvalue is ill-conditioned); in this
+* case INFO is set to N+2 (see INFO below).
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* A (input/output) REAL array, dimension (LDA,N)
+* On entry, the N-by-N matrix A.
+* On exit, A has been overwritten by its real Schur form T.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,N).
+*
+* SDIM (output) INTEGER
+* If SORT = 'N', SDIM = 0.
+* If SORT = 'S', SDIM = number of eigenvalues (after sorting)
+* for which SELECT is true. (Complex conjugate
+* pairs for which SELECT is true for either
+* eigenvalue count as 2.)
+*
+* WR (output) REAL array, dimension (N)
+* WI (output) REAL array, dimension (N)
+* WR and WI contain the real and imaginary parts,
+* respectively, of the computed eigenvalues in the same order
+* that they appear on the diagonal of the output Schur form T.
+* Complex conjugate pairs of eigenvalues will appear
+* consecutively with the eigenvalue having the positive
+* imaginary part first.
+*
+* VS (output) REAL array, dimension (LDVS,N)
+* If JOBVS = 'V', VS contains the orthogonal matrix Z of Schur
+* vectors.
+* If JOBVS = 'N', VS is not referenced.
+*
+* LDVS (input) INTEGER
+* The leading dimension of the array VS. LDVS >= 1; if
+* JOBVS = 'V', LDVS >= N.
+*
+* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))
+* On exit, if INFO = 0, WORK(1) contains the optimal LWORK.
+*
+* LWORK (input) INTEGER
+* The dimension of the array WORK. LWORK >= max(1,3*N).
+* For good performance, LWORK must generally be larger.
+*
+* If LWORK = -1, then a workspace query is assumed; the routine
+* only calculates the optimal size of the WORK array, returns
+* this value as the first entry of the WORK array, and no error
+* message related to LWORK is issued by XERBLA.
+*
+* BWORK (workspace) LOGICAL array, dimension (N)
+* Not referenced if SORT = 'N'.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value.
+* > 0: if INFO = i, and i is
+* <= N: the QR algorithm failed to compute all the
+* eigenvalues; elements 1:ILO-1 and i+1:N of WR and WI
+* contain those eigenvalues which have converged; if
+* JOBVS = 'V', VS contains the matrix which reduces A
+* to its partially converged Schur form.
+* = N+1: the eigenvalues could not be reordered because some
+* eigenvalues were too close to separate (the problem
+* is very ill-conditioned);
+* = N+2: after reordering, roundoff changed values of some
+* complex eigenvalues so that leading eigenvalues in
+* the Schur form no longer satisfy SELECT=.TRUE. This
+* could also be caused by underflow due to scaling.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO, ONE
+ PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL CURSL, LASTSL, LQUERY, LST2SL, SCALEA, WANTST,
+ $ WANTVS
+ INTEGER HSWORK, I, I1, I2, IBAL, ICOND, IERR, IEVAL,
+ $ IHI, ILO, INXT, IP, ITAU, IWRK, MAXWRK, MINWRK
+ REAL ANRM, BIGNUM, CSCALE, EPS, S, SEP, SMLNUM
+* ..
+* .. Local Arrays ..
+ INTEGER IDUM( 1 )
+ REAL DUM( 1 )
+* ..
+* .. External Subroutines ..
+ EXTERNAL SCOPY, SGEBAK, SGEBAL, SGEHRD, SHSEQR, SLABAD,
+ $ SLACPY, SLASCL, SORGHR, SSWAP, STRSEN, XERBLA
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ILAENV
+ REAL SLAMCH, SLANGE
+ EXTERNAL LSAME, ILAENV, SLAMCH, SLANGE
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, SQRT
+* ..
+* .. Executable Statements ..
+*
+* Test the input arguments
+*
+ INFO = 0
+ LQUERY = ( LWORK.EQ.-1 )
+ WANTVS = LSAME( JOBVS, 'V' )
+ WANTST = LSAME( SORT, 'S' )
+ IF( ( .NOT.WANTVS ) .AND. ( .NOT.LSAME( JOBVS, 'N' ) ) ) THEN
+ INFO = -1
+ ELSE IF( ( .NOT.WANTST ) .AND. ( .NOT.LSAME( SORT, 'N' ) ) ) THEN
+ INFO = -2
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -6
+ ELSE IF( LDVS.LT.1 .OR. ( WANTVS .AND. LDVS.LT.N ) ) THEN
+ INFO = -11
+ END IF
+*
+* Compute workspace
+* (Note: Comments in the code beginning "Workspace:" describe the
+* minimal amount of workspace needed at that point in the code,
+* as well as the preferred amount for good performance.
+* NB refers to the optimal block size for the immediately
+* following subroutine, as returned by ILAENV.
+* HSWORK refers to the workspace preferred by SHSEQR, as
+* calculated below. HSWORK is computed assuming ILO=1 and IHI=N,
+* the worst case.)
+*
+ IF( INFO.EQ.0 ) THEN
+ IF( N.EQ.0 ) THEN
+ MINWRK = 1
+ MAXWRK = 1
+ ELSE
+ MAXWRK = 2*N + N*ILAENV( 1, 'SGEHRD', ' ', N, 1, N, 0 )
+ MINWRK = 3*N
+*
+ CALL SHSEQR( 'S', JOBVS, N, 1, N, A, LDA, WR, WI, VS, LDVS,
+ $ WORK, -1, IEVAL )
+ HSWORK = WORK( 1 )
+*
+ IF( .NOT.WANTVS ) THEN
+ MAXWRK = MAX( MAXWRK, N + HSWORK )
+ ELSE
+ MAXWRK = MAX( MAXWRK, 2*N + ( N - 1 )*ILAENV( 1,
+ $ 'SORGHR', ' ', N, 1, N, -1 ) )
+ MAXWRK = MAX( MAXWRK, N + HSWORK )
+ END IF
+ END IF
+ WORK( 1 ) = MAXWRK
+*
+ IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN
+ INFO = -13
+ END IF
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SGEES ', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 ) THEN
+ SDIM = 0
+ RETURN
+ END IF
+*
+* Get machine constants
+*
+ EPS = SLAMCH( 'P' )
+ SMLNUM = SLAMCH( 'S' )
+ BIGNUM = ONE / SMLNUM
+ CALL SLABAD( SMLNUM, BIGNUM )
+ SMLNUM = SQRT( SMLNUM ) / EPS
+ BIGNUM = ONE / SMLNUM
+*
+* Scale A if max element outside range [SMLNUM,BIGNUM]
+*
+ ANRM = SLANGE( 'M', N, N, A, LDA, DUM )
+ SCALEA = .FALSE.
+ IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
+ SCALEA = .TRUE.
+ CSCALE = SMLNUM
+ ELSE IF( ANRM.GT.BIGNUM ) THEN
+ SCALEA = .TRUE.
+ CSCALE = BIGNUM
+ END IF
+ IF( SCALEA )
+ $ CALL SLASCL( 'G', 0, 0, ANRM, CSCALE, N, N, A, LDA, IERR )
+*
+* Permute the matrix to make it more nearly triangular
+* (Workspace: need N)
+*
+ IBAL = 1
+ CALL SGEBAL( 'P', N, A, LDA, ILO, IHI, WORK( IBAL ), IERR )
+*
+* Reduce to upper Hessenberg form
+* (Workspace: need 3*N, prefer 2*N+N*NB)
+*
+ ITAU = N + IBAL
+ IWRK = N + ITAU
+ CALL SGEHRD( N, ILO, IHI, A, LDA, WORK( ITAU ), WORK( IWRK ),
+ $ LWORK-IWRK+1, IERR )
+*
+ IF( WANTVS ) THEN
+*
+* Copy Householder vectors to VS
+*
+ CALL SLACPY( 'L', N, N, A, LDA, VS, LDVS )
+*
+* Generate orthogonal matrix in VS
+* (Workspace: need 3*N-1, prefer 2*N+(N-1)*NB)
+*
+ CALL SORGHR( N, ILO, IHI, VS, LDVS, WORK( ITAU ), WORK( IWRK ),
+ $ LWORK-IWRK+1, IERR )
+ END IF
+*
+ SDIM = 0
+*
+* Perform QR iteration, accumulating Schur vectors in VS if desired
+* (Workspace: need N+1, prefer N+HSWORK (see comments) )
+*
+ IWRK = ITAU
+ CALL SHSEQR( 'S', JOBVS, N, ILO, IHI, A, LDA, WR, WI, VS, LDVS,
+ $ WORK( IWRK ), LWORK-IWRK+1, IEVAL )
+ IF( IEVAL.GT.0 )
+ $ INFO = IEVAL
+*
+* Sort eigenvalues if desired
+*
+ IF( WANTST .AND. INFO.EQ.0 ) THEN
+ IF( SCALEA ) THEN
+ CALL SLASCL( 'G', 0, 0, CSCALE, ANRM, N, 1, WR, N, IERR )
+ CALL SLASCL( 'G', 0, 0, CSCALE, ANRM, N, 1, WI, N, IERR )
+ END IF
+ DO 10 I = 1, N
+ BWORK( I ) = SELECT( WR( I ), WI( I ) )
+ 10 CONTINUE
+*
+* Reorder eigenvalues and transform Schur vectors
+* (Workspace: none needed)
+*
+ CALL STRSEN( 'N', JOBVS, BWORK, N, A, LDA, VS, LDVS, WR, WI,
+ $ SDIM, S, SEP, WORK( IWRK ), LWORK-IWRK+1, IDUM, 1,
+ $ ICOND )
+ IF( ICOND.GT.0 )
+ $ INFO = N + ICOND
+ END IF
+*
+ IF( WANTVS ) THEN
+*
+* Undo balancing
+* (Workspace: need N)
+*
+ CALL SGEBAK( 'P', 'R', N, ILO, IHI, WORK( IBAL ), N, VS, LDVS,
+ $ IERR )
+ END IF
+*
+ IF( SCALEA ) THEN
+*
+* Undo scaling for the Schur form of A
+*
+ CALL SLASCL( 'H', 0, 0, CSCALE, ANRM, N, N, A, LDA, IERR )
+ CALL SCOPY( N, A, LDA+1, WR, 1 )
+ IF( CSCALE.EQ.SMLNUM ) THEN
+*
+* If scaling back towards underflow, adjust WI if an
+* offdiagonal element of a 2-by-2 block in the Schur form
+* underflows.
+*
+ IF( IEVAL.GT.0 ) THEN
+ I1 = IEVAL + 1
+ I2 = IHI - 1
+ CALL SLASCL( 'G', 0, 0, CSCALE, ANRM, ILO-1, 1, WI,
+ $ MAX( ILO-1, 1 ), IERR )
+ ELSE IF( WANTST ) THEN
+ I1 = 1
+ I2 = N - 1
+ ELSE
+ I1 = ILO
+ I2 = IHI - 1
+ END IF
+ INXT = I1 - 1
+ DO 20 I = I1, I2
+ IF( I.LT.INXT )
+ $ GO TO 20
+ IF( WI( I ).EQ.ZERO ) THEN
+ INXT = I + 1
+ ELSE
+ IF( A( I+1, I ).EQ.ZERO ) THEN
+ WI( I ) = ZERO
+ WI( I+1 ) = ZERO
+ ELSE IF( A( I+1, I ).NE.ZERO .AND. A( I, I+1 ).EQ.
+ $ ZERO ) THEN
+ WI( I ) = ZERO
+ WI( I+1 ) = ZERO
+ IF( I.GT.1 )
+ $ CALL SSWAP( I-1, A( 1, I ), 1, A( 1, I+1 ), 1 )
+ IF( N.GT.I+1 )
+ $ CALL SSWAP( N-I-1, A( I, I+2 ), LDA,
+ $ A( I+1, I+2 ), LDA )
+ IF( WANTVS ) THEN
+ CALL SSWAP( N, VS( 1, I ), 1, VS( 1, I+1 ), 1 )
+ END IF
+ A( I, I+1 ) = A( I+1, I )
+ A( I+1, I ) = ZERO
+ END IF
+ INXT = I + 2
+ END IF
+ 20 CONTINUE
+ END IF
+*
+* Undo scaling for the imaginary part of the eigenvalues
+*
+ CALL SLASCL( 'G', 0, 0, CSCALE, ANRM, N-IEVAL, 1,
+ $ WI( IEVAL+1 ), MAX( N-IEVAL, 1 ), IERR )
+ END IF
+*
+ IF( WANTST .AND. INFO.EQ.0 ) THEN
+*
+* Check if reordering successful
+*
+ LASTSL = .TRUE.
+ LST2SL = .TRUE.
+ SDIM = 0
+ IP = 0
+ DO 30 I = 1, N
+ CURSL = SELECT( WR( I ), WI( I ) )
+ IF( WI( I ).EQ.ZERO ) THEN
+ IF( CURSL )
+ $ SDIM = SDIM + 1
+ IP = 0
+ IF( CURSL .AND. .NOT.LASTSL )
+ $ INFO = N + 2
+ ELSE
+ IF( IP.EQ.1 ) THEN
+*
+* Last eigenvalue of conjugate pair
+*
+ CURSL = CURSL .OR. LASTSL
+ LASTSL = CURSL
+ IF( CURSL )
+ $ SDIM = SDIM + 2
+ IP = -1
+ IF( CURSL .AND. .NOT.LST2SL )
+ $ INFO = N + 2
+ ELSE
+*
+* First eigenvalue of conjugate pair
+*
+ IP = 1
+ END IF
+ END IF
+ LST2SL = LASTSL
+ LASTSL = CURSL
+ 30 CONTINUE
+ END IF
+*
+ WORK( 1 ) = MAXWRK
+ RETURN
+*
+* End of SGEES
+*
+ END
+ SUBROUTINE SGEESX( JOBVS, SORT, SELECT, SENSE, N, A, LDA, SDIM,
+ $ WR, WI, VS, LDVS, RCONDE, RCONDV, WORK, LWORK,
+ $ IWORK, LIWORK, BWORK, INFO )
+*
+* -- LAPACK driver routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER JOBVS, SENSE, SORT
+ INTEGER INFO, LDA, LDVS, LIWORK, LWORK, N, SDIM
+ REAL RCONDE, RCONDV
+* ..
+* .. Array Arguments ..
+ LOGICAL BWORK( * )
+ INTEGER IWORK( * )
+ REAL A( LDA, * ), VS( LDVS, * ), WI( * ), WORK( * ),
+ $ WR( * )
+* ..
+* .. Function Arguments ..
+ LOGICAL SELECT
+ EXTERNAL SELECT
+* ..
+*
+* Purpose
+* =======
+*
+* SGEESX computes for an N-by-N real nonsymmetric matrix A, the
+* eigenvalues, the real Schur form T, and, optionally, the matrix of
+* Schur vectors Z. This gives the Schur factorization A = Z*T*(Z**T).
+*
+* Optionally, it also orders the eigenvalues on the diagonal of the
+* real Schur form so that selected eigenvalues are at the top left;
+* computes a reciprocal condition number for the average of the
+* selected eigenvalues (RCONDE); and computes a reciprocal condition
+* number for the right invariant subspace corresponding to the
+* selected eigenvalues (RCONDV). The leading columns of Z form an
+* orthonormal basis for this invariant subspace.
+*
+* For further explanation of the reciprocal condition numbers RCONDE
+* and RCONDV, see Section 4.10 of the LAPACK Users' Guide (where
+* these quantities are called s and sep respectively).
+*
+* A real matrix is in real Schur form if it is upper quasi-triangular
+* with 1-by-1 and 2-by-2 blocks. 2-by-2 blocks will be standardized in
+* the form
+* [ a b ]
+* [ c a ]
+*
+* where b*c < 0. The eigenvalues of such a block are a +- sqrt(bc).
+*
+* Arguments
+* =========
+*
+* JOBVS (input) CHARACTER*1
+* = 'N': Schur vectors are not computed;
+* = 'V': Schur vectors are computed.
+*
+* SORT (input) CHARACTER*1
+* Specifies whether or not to order the eigenvalues on the
+* diagonal of the Schur form.
+* = 'N': Eigenvalues are not ordered;
+* = 'S': Eigenvalues are ordered (see SELECT).
+*
+* SELECT (external procedure) LOGICAL FUNCTION of two REAL arguments
+* SELECT must be declared EXTERNAL in the calling subroutine.
+* If SORT = 'S', SELECT is used to select eigenvalues to sort
+* to the top left of the Schur form.
+* If SORT = 'N', SELECT is not referenced.
+* An eigenvalue WR(j)+sqrt(-1)*WI(j) is selected if
+* SELECT(WR(j),WI(j)) is true; i.e., if either one of a
+* complex conjugate pair of eigenvalues is selected, then both
+* are. Note that a selected complex eigenvalue may no longer
+* satisfy SELECT(WR(j),WI(j)) = .TRUE. after ordering, since
+* ordering may change the value of complex eigenvalues
+* (especially if the eigenvalue is ill-conditioned); in this
+* case INFO may be set to N+3 (see INFO below).
+*
+* SENSE (input) CHARACTER*1
+* Determines which reciprocal condition numbers are computed.
+* = 'N': None are computed;
+* = 'E': Computed for average of selected eigenvalues only;
+* = 'V': Computed for selected right invariant subspace only;
+* = 'B': Computed for both.
+* If SENSE = 'E', 'V' or 'B', SORT must equal 'S'.
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* A (input/output) REAL array, dimension (LDA, N)
+* On entry, the N-by-N matrix A.
+* On exit, A is overwritten by its real Schur form T.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,N).
+*
+* SDIM (output) INTEGER
+* If SORT = 'N', SDIM = 0.
+* If SORT = 'S', SDIM = number of eigenvalues (after sorting)
+* for which SELECT is true. (Complex conjugate
+* pairs for which SELECT is true for either
+* eigenvalue count as 2.)
+*
+* WR (output) REAL array, dimension (N)
+* WI (output) REAL array, dimension (N)
+* WR and WI contain the real and imaginary parts, respectively,
+* of the computed eigenvalues, in the same order that they
+* appear on the diagonal of the output Schur form T. Complex
+* conjugate pairs of eigenvalues appear consecutively with the
+* eigenvalue having the positive imaginary part first.
+*
+* VS (output) REAL array, dimension (LDVS,N)
+* If JOBVS = 'V', VS contains the orthogonal matrix Z of Schur
+* vectors.
+* If JOBVS = 'N', VS is not referenced.
+*
+* LDVS (input) INTEGER
+* The leading dimension of the array VS. LDVS >= 1, and if
+* JOBVS = 'V', LDVS >= N.
+*
+* RCONDE (output) REAL
+* If SENSE = 'E' or 'B', RCONDE contains the reciprocal
+* condition number for the average of the selected eigenvalues.
+* Not referenced if SENSE = 'N' or 'V'.
+*
+* RCONDV (output) REAL
+* If SENSE = 'V' or 'B', RCONDV contains the reciprocal
+* condition number for the selected right invariant subspace.
+* Not referenced if SENSE = 'N' or 'E'.
+*
+* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))
+* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+* LWORK (input) INTEGER
+* The dimension of the array WORK. LWORK >= max(1,3*N).
+* Also, if SENSE = 'E' or 'V' or 'B',
+* LWORK >= N+2*SDIM*(N-SDIM), where SDIM is the number of
+* selected eigenvalues computed by this routine. Note that
+* N+2*SDIM*(N-SDIM) <= N+N*N/2. Note also that an error is only
+* returned if LWORK < max(1,3*N), but if SENSE = 'E' or 'V' or
+* 'B' this may not be large enough.
+* For good performance, LWORK must generally be larger.
+*
+* If LWORK = -1, then a workspace query is assumed; the routine
+* only calculates upper bounds on the optimal sizes of the
+* arrays WORK and IWORK, returns these values as the first
+* entries of the WORK and IWORK arrays, and no error messages
+* related to LWORK or LIWORK are issued by XERBLA.
+*
+* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))
+* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
+*
+* LIWORK (input) INTEGER
+* The dimension of the array IWORK.
+* LIWORK >= 1; if SENSE = 'V' or 'B', LIWORK >= SDIM*(N-SDIM).
+* Note that SDIM*(N-SDIM) <= N*N/4. Note also that an error is
+* only returned if LIWORK < 1, but if SENSE = 'V' or 'B' this
+* may not be large enough.
+*
+* If LIWORK = -1, then a workspace query is assumed; the
+* routine only calculates upper bounds on the optimal sizes of
+* the arrays WORK and IWORK, returns these values as the first
+* entries of the WORK and IWORK arrays, and no error messages
+* related to LWORK or LIWORK are issued by XERBLA.
+*
+* BWORK (workspace) LOGICAL array, dimension (N)
+* Not referenced if SORT = 'N'.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value.
+* > 0: if INFO = i, and i is
+* <= N: the QR algorithm failed to compute all the
+* eigenvalues; elements 1:ILO-1 and i+1:N of WR and WI
+* contain those eigenvalues which have converged; if
+* JOBVS = 'V', VS contains the transformation which
+* reduces A to its partially converged Schur form.
+* = N+1: the eigenvalues could not be reordered because some
+* eigenvalues were too close to separate (the problem
+* is very ill-conditioned);
+* = N+2: after reordering, roundoff changed values of some
+* complex eigenvalues so that leading eigenvalues in
+* the Schur form no longer satisfy SELECT=.TRUE. This
+* could also be caused by underflow due to scaling.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO, ONE
+ PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL CURSL, LASTSL, LQUERY, LST2SL, SCALEA, WANTSB,
+ $ WANTSE, WANTSN, WANTST, WANTSV, WANTVS
+ INTEGER HSWORK, I, I1, I2, IBAL, ICOND, IERR, IEVAL,
+ $ IHI, ILO, INXT, IP, ITAU, IWRK, LWRK, LIWRK,
+ $ MAXWRK, MINWRK
+ REAL ANRM, BIGNUM, CSCALE, EPS, SMLNUM
+* ..
+* .. Local Arrays ..
+ REAL DUM( 1 )
+* ..
+* .. External Subroutines ..
+ EXTERNAL SCOPY, SGEBAK, SGEBAL, SGEHRD, SHSEQR, SLABAD,
+ $ SLACPY, SLASCL, SORGHR, SSWAP, STRSEN, XERBLA
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ILAENV
+ REAL SLAMCH, SLANGE
+ EXTERNAL LSAME, ILAENV, SLAMCH, SLANGE
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, SQRT
+* ..
+* .. Executable Statements ..
+*
+* Test the input arguments
+*
+ INFO = 0
+ WANTVS = LSAME( JOBVS, 'V' )
+ WANTST = LSAME( SORT, 'S' )
+ WANTSN = LSAME( SENSE, 'N' )
+ WANTSE = LSAME( SENSE, 'E' )
+ WANTSV = LSAME( SENSE, 'V' )
+ WANTSB = LSAME( SENSE, 'B' )
+ LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 )
+ IF( ( .NOT.WANTVS ) .AND. ( .NOT.LSAME( JOBVS, 'N' ) ) ) THEN
+ INFO = -1
+ ELSE IF( ( .NOT.WANTST ) .AND. ( .NOT.LSAME( SORT, 'N' ) ) ) THEN
+ INFO = -2
+ ELSE IF( .NOT.( WANTSN .OR. WANTSE .OR. WANTSV .OR. WANTSB ) .OR.
+ $ ( .NOT.WANTST .AND. .NOT.WANTSN ) ) THEN
+ INFO = -4
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -5
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -7
+ ELSE IF( LDVS.LT.1 .OR. ( WANTVS .AND. LDVS.LT.N ) ) THEN
+ INFO = -12
+ END IF
+*
+* Compute workspace
+* (Note: Comments in the code beginning "RWorkspace:" describe the
+* minimal amount of real workspace needed at that point in the
+* code, as well as the preferred amount for good performance.
+* IWorkspace refers to integer workspace.
+* NB refers to the optimal block size for the immediately
+* following subroutine, as returned by ILAENV.
+* HSWORK refers to the workspace preferred by SHSEQR, as
+* calculated below. HSWORK is computed assuming ILO=1 and IHI=N,
+* the worst case.
+* If SENSE = 'E', 'V' or 'B', then the amount of workspace needed
+* depends on SDIM, which is computed by the routine STRSEN later
+* in the code.)
+*
+ IF( INFO.EQ.0 ) THEN
+ LIWRK = 1
+ IF( N.EQ.0 ) THEN
+ MINWRK = 1
+ LWRK = 1
+ ELSE
+ MAXWRK = 2*N + N*ILAENV( 1, 'SGEHRD', ' ', N, 1, N, 0 )
+ MINWRK = 3*N
+*
+ CALL SHSEQR( 'S', JOBVS, N, 1, N, A, LDA, WR, WI, VS, LDVS,
+ $ WORK, -1, IEVAL )
+ HSWORK = WORK( 1 )
+*
+ IF( .NOT.WANTVS ) THEN
+ MAXWRK = MAX( MAXWRK, N + HSWORK )
+ ELSE
+ MAXWRK = MAX( MAXWRK, 2*N + ( N - 1 )*ILAENV( 1,
+ $ 'SORGHR', ' ', N, 1, N, -1 ) )
+ MAXWRK = MAX( MAXWRK, N + HSWORK )
+ END IF
+ LWRK = MAXWRK
+ IF( .NOT.WANTSN )
+ $ LWRK = MAX( LWRK, N + ( N*N )/2 )
+ IF( WANTSV .OR. WANTSB )
+ $ LIWRK = ( N*N )/4
+ END IF
+ IWORK( 1 ) = LIWRK
+ WORK( 1 ) = LWRK
+*
+ IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN
+ INFO = -16
+ ELSE IF( LIWORK.LT.1 .AND. .NOT.LQUERY ) THEN
+ INFO = -18
+ END IF
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SGEESX', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 ) THEN
+ SDIM = 0
+ RETURN
+ END IF
+*
+* Get machine constants
+*
+ EPS = SLAMCH( 'P' )
+ SMLNUM = SLAMCH( 'S' )
+ BIGNUM = ONE / SMLNUM
+ CALL SLABAD( SMLNUM, BIGNUM )
+ SMLNUM = SQRT( SMLNUM ) / EPS
+ BIGNUM = ONE / SMLNUM
+*
+* Scale A if max element outside range [SMLNUM,BIGNUM]
+*
+ ANRM = SLANGE( 'M', N, N, A, LDA, DUM )
+ SCALEA = .FALSE.
+ IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
+ SCALEA = .TRUE.
+ CSCALE = SMLNUM
+ ELSE IF( ANRM.GT.BIGNUM ) THEN
+ SCALEA = .TRUE.
+ CSCALE = BIGNUM
+ END IF
+ IF( SCALEA )
+ $ CALL SLASCL( 'G', 0, 0, ANRM, CSCALE, N, N, A, LDA, IERR )
+*
+* Permute the matrix to make it more nearly triangular
+* (RWorkspace: need N)
+*
+ IBAL = 1
+ CALL SGEBAL( 'P', N, A, LDA, ILO, IHI, WORK( IBAL ), IERR )
+*
+* Reduce to upper Hessenberg form
+* (RWorkspace: need 3*N, prefer 2*N+N*NB)
+*
+ ITAU = N + IBAL
+ IWRK = N + ITAU
+ CALL SGEHRD( N, ILO, IHI, A, LDA, WORK( ITAU ), WORK( IWRK ),
+ $ LWORK-IWRK+1, IERR )
+*
+ IF( WANTVS ) THEN
+*
+* Copy Householder vectors to VS
+*
+ CALL SLACPY( 'L', N, N, A, LDA, VS, LDVS )
+*
+* Generate orthogonal matrix in VS
+* (RWorkspace: need 3*N-1, prefer 2*N+(N-1)*NB)
+*
+ CALL SORGHR( N, ILO, IHI, VS, LDVS, WORK( ITAU ), WORK( IWRK ),
+ $ LWORK-IWRK+1, IERR )
+ END IF
+*
+ SDIM = 0
+*
+* Perform QR iteration, accumulating Schur vectors in VS if desired
+* (RWorkspace: need N+1, prefer N+HSWORK (see comments) )
+*
+ IWRK = ITAU
+ CALL SHSEQR( 'S', JOBVS, N, ILO, IHI, A, LDA, WR, WI, VS, LDVS,
+ $ WORK( IWRK ), LWORK-IWRK+1, IEVAL )
+ IF( IEVAL.GT.0 )
+ $ INFO = IEVAL
+*
+* Sort eigenvalues if desired
+*
+ IF( WANTST .AND. INFO.EQ.0 ) THEN
+ IF( SCALEA ) THEN
+ CALL SLASCL( 'G', 0, 0, CSCALE, ANRM, N, 1, WR, N, IERR )
+ CALL SLASCL( 'G', 0, 0, CSCALE, ANRM, N, 1, WI, N, IERR )
+ END IF
+ DO 10 I = 1, N
+ BWORK( I ) = SELECT( WR( I ), WI( I ) )
+ 10 CONTINUE
+*
+* Reorder eigenvalues, transform Schur vectors, and compute
+* reciprocal condition numbers
+* (RWorkspace: if SENSE is not 'N', need N+2*SDIM*(N-SDIM)
+* otherwise, need N )
+* (IWorkspace: if SENSE is 'V' or 'B', need SDIM*(N-SDIM)
+* otherwise, need 0 )
+*
+ CALL STRSEN( SENSE, JOBVS, BWORK, N, A, LDA, VS, LDVS, WR, WI,
+ $ SDIM, RCONDE, RCONDV, WORK( IWRK ), LWORK-IWRK+1,
+ $ IWORK, LIWORK, ICOND )
+ IF( .NOT.WANTSN )
+ $ MAXWRK = MAX( MAXWRK, N+2*SDIM*( N-SDIM ) )
+ IF( ICOND.EQ.-15 ) THEN
+*
+* Not enough real workspace
+*
+ INFO = -16
+ ELSE IF( ICOND.EQ.-17 ) THEN
+*
+* Not enough integer workspace
+*
+ INFO = -18
+ ELSE IF( ICOND.GT.0 ) THEN
+*
+* STRSEN failed to reorder or to restore standard Schur form
+*
+ INFO = ICOND + N
+ END IF
+ END IF
+*
+ IF( WANTVS ) THEN
+*
+* Undo balancing
+* (RWorkspace: need N)
+*
+ CALL SGEBAK( 'P', 'R', N, ILO, IHI, WORK( IBAL ), N, VS, LDVS,
+ $ IERR )
+ END IF
+*
+ IF( SCALEA ) THEN
+*
+* Undo scaling for the Schur form of A
+*
+ CALL SLASCL( 'H', 0, 0, CSCALE, ANRM, N, N, A, LDA, IERR )
+ CALL SCOPY( N, A, LDA+1, WR, 1 )
+ IF( ( WANTSV .OR. WANTSB ) .AND. INFO.EQ.0 ) THEN
+ DUM( 1 ) = RCONDV
+ CALL SLASCL( 'G', 0, 0, CSCALE, ANRM, 1, 1, DUM, 1, IERR )
+ RCONDV = DUM( 1 )
+ END IF
+ IF( CSCALE.EQ.SMLNUM ) THEN
+*
+* If scaling back towards underflow, adjust WI if an
+* offdiagonal element of a 2-by-2 block in the Schur form
+* underflows.
+*
+ IF( IEVAL.GT.0 ) THEN
+ I1 = IEVAL + 1
+ I2 = IHI - 1
+ CALL SLASCL( 'G', 0, 0, CSCALE, ANRM, ILO-1, 1, WI, N,
+ $ IERR )
+ ELSE IF( WANTST ) THEN
+ I1 = 1
+ I2 = N - 1
+ ELSE
+ I1 = ILO
+ I2 = IHI - 1
+ END IF
+ INXT = I1 - 1
+ DO 20 I = I1, I2
+ IF( I.LT.INXT )
+ $ GO TO 20
+ IF( WI( I ).EQ.ZERO ) THEN
+ INXT = I + 1
+ ELSE
+ IF( A( I+1, I ).EQ.ZERO ) THEN
+ WI( I ) = ZERO
+ WI( I+1 ) = ZERO
+ ELSE IF( A( I+1, I ).NE.ZERO .AND. A( I, I+1 ).EQ.
+ $ ZERO ) THEN
+ WI( I ) = ZERO
+ WI( I+1 ) = ZERO
+ IF( I.GT.1 )
+ $ CALL SSWAP( I-1, A( 1, I ), 1, A( 1, I+1 ), 1 )
+ IF( N.GT.I+1 )
+ $ CALL SSWAP( N-I-1, A( I, I+2 ), LDA,
+ $ A( I+1, I+2 ), LDA )
+ CALL SSWAP( N, VS( 1, I ), 1, VS( 1, I+1 ), 1 )
+ A( I, I+1 ) = A( I+1, I )
+ A( I+1, I ) = ZERO
+ END IF
+ INXT = I + 2
+ END IF
+ 20 CONTINUE
+ END IF
+ CALL SLASCL( 'G', 0, 0, CSCALE, ANRM, N-IEVAL, 1,
+ $ WI( IEVAL+1 ), MAX( N-IEVAL, 1 ), IERR )
+ END IF
+*
+ IF( WANTST .AND. INFO.EQ.0 ) THEN
+*
+* Check if reordering successful
+*
+ LASTSL = .TRUE.
+ LST2SL = .TRUE.
+ SDIM = 0
+ IP = 0
+ DO 30 I = 1, N
+ CURSL = SELECT( WR( I ), WI( I ) )
+ IF( WI( I ).EQ.ZERO ) THEN
+ IF( CURSL )
+ $ SDIM = SDIM + 1
+ IP = 0
+ IF( CURSL .AND. .NOT.LASTSL )
+ $ INFO = N + 2
+ ELSE
+ IF( IP.EQ.1 ) THEN
+*
+* Last eigenvalue of conjugate pair
+*
+ CURSL = CURSL .OR. LASTSL
+ LASTSL = CURSL
+ IF( CURSL )
+ $ SDIM = SDIM + 2
+ IP = -1
+ IF( CURSL .AND. .NOT.LST2SL )
+ $ INFO = N + 2
+ ELSE
+*
+* First eigenvalue of conjugate pair
+*
+ IP = 1
+ END IF
+ END IF
+ LST2SL = LASTSL
+ LASTSL = CURSL
+ 30 CONTINUE
+ END IF
+*
+ WORK( 1 ) = MAXWRK
+ IF( WANTSV .OR. WANTSB ) THEN
+ IWORK( 1 ) = SDIM*(N-SDIM)
+ ELSE
+ IWORK( 1 ) = 1
+ END IF
+*
+ RETURN
+*
+* End of SGEESX
+*
+ END
+ SUBROUTINE SGEEV( JOBVL, JOBVR, N, A, LDA, WR, WI, VL, LDVL, VR,
+ $ LDVR, WORK, LWORK, INFO )
+*
+* -- LAPACK driver routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER JOBVL, JOBVR
+ INTEGER INFO, LDA, LDVL, LDVR, LWORK, N
+* ..
+* .. Array Arguments ..
+ REAL A( LDA, * ), VL( LDVL, * ), VR( LDVR, * ),
+ $ WI( * ), WORK( * ), WR( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SGEEV computes for an N-by-N real nonsymmetric matrix A, the
+* eigenvalues and, optionally, the left and/or right eigenvectors.
+*
+* The right eigenvector v(j) of A satisfies
+* A * v(j) = lambda(j) * v(j)
+* where lambda(j) is its eigenvalue.
+* The left eigenvector u(j) of A satisfies
+* u(j)**H * A = lambda(j) * u(j)**H
+* where u(j)**H denotes the conjugate transpose of u(j).
+*
+* The computed eigenvectors are normalized to have Euclidean norm
+* equal to 1 and largest component real.
+*
+* Arguments
+* =========
+*
+* JOBVL (input) CHARACTER*1
+* = 'N': left eigenvectors of A are not computed;
+* = 'V': left eigenvectors of A are computed.
+*
+* JOBVR (input) CHARACTER*1
+* = 'N': right eigenvectors of A are not computed;
+* = 'V': right eigenvectors of A are computed.
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* A (input/output) REAL array, dimension (LDA,N)
+* On entry, the N-by-N matrix A.
+* On exit, A has been overwritten.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,N).
+*
+* WR (output) REAL array, dimension (N)
+* WI (output) REAL array, dimension (N)
+* WR and WI contain the real and imaginary parts,
+* respectively, of the computed eigenvalues. Complex
+* conjugate pairs of eigenvalues appear consecutively
+* with the eigenvalue having the positive imaginary part
+* first.
+*
+* VL (output) REAL array, dimension (LDVL,N)
+* If JOBVL = 'V', the left eigenvectors u(j) are stored one
+* after another in the columns of VL, in the same order
+* as their eigenvalues.
+* If JOBVL = 'N', VL is not referenced.
+* If the j-th eigenvalue is real, then u(j) = VL(:,j),
+* the j-th column of VL.
+* If the j-th and (j+1)-st eigenvalues form a complex
+* conjugate pair, then u(j) = VL(:,j) + i*VL(:,j+1) and
+* u(j+1) = VL(:,j) - i*VL(:,j+1).
+*
+* LDVL (input) INTEGER
+* The leading dimension of the array VL. LDVL >= 1; if
+* JOBVL = 'V', LDVL >= N.
+*
+* VR (output) REAL array, dimension (LDVR,N)
+* If JOBVR = 'V', the right eigenvectors v(j) are stored one
+* after another in the columns of VR, in the same order
+* as their eigenvalues.
+* If JOBVR = 'N', VR is not referenced.
+* If the j-th eigenvalue is real, then v(j) = VR(:,j),
+* the j-th column of VR.
+* If the j-th and (j+1)-st eigenvalues form a complex
+* conjugate pair, then v(j) = VR(:,j) + i*VR(:,j+1) and
+* v(j+1) = VR(:,j) - i*VR(:,j+1).
+*
+* LDVR (input) INTEGER
+* The leading dimension of the array VR. LDVR >= 1; if
+* JOBVR = 'V', LDVR >= N.
+*
+* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))
+* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+* LWORK (input) INTEGER
+* The dimension of the array WORK. LWORK >= max(1,3*N), and
+* if JOBVL = 'V' or JOBVR = 'V', LWORK >= 4*N. For good
+* performance, LWORK must generally be larger.
+*
+* If LWORK = -1, then a workspace query is assumed; the routine
+* only calculates the optimal size of the WORK array, returns
+* this value as the first entry of the WORK array, and no error
+* message related to LWORK is issued by XERBLA.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value.
+* > 0: if INFO = i, the QR algorithm failed to compute all the
+* eigenvalues, and no eigenvectors have been computed;
+* elements i+1:N of WR and WI contain eigenvalues which
+* have converged.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO, ONE
+ PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL LQUERY, SCALEA, WANTVL, WANTVR
+ CHARACTER SIDE
+ INTEGER HSWORK, I, IBAL, IERR, IHI, ILO, ITAU, IWRK, K,
+ $ MAXWRK, MINWRK, NOUT
+ REAL ANRM, BIGNUM, CS, CSCALE, EPS, R, SCL, SMLNUM,
+ $ SN
+* ..
+* .. Local Arrays ..
+ LOGICAL SELECT( 1 )
+ REAL DUM( 1 )
+* ..
+* .. External Subroutines ..
+ EXTERNAL SGEBAK, SGEBAL, SGEHRD, SHSEQR, SLABAD, SLACPY,
+ $ SLARTG, SLASCL, SORGHR, SROT, SSCAL, STREVC,
+ $ XERBLA
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ILAENV, ISAMAX
+ REAL SLAMCH, SLANGE, SLAPY2, SNRM2
+ EXTERNAL LSAME, ILAENV, ISAMAX, SLAMCH, SLANGE, SLAPY2,
+ $ SNRM2
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, SQRT
+* ..
+* .. Executable Statements ..
+*
+* Test the input arguments
+*
+ INFO = 0
+ LQUERY = ( LWORK.EQ.-1 )
+ WANTVL = LSAME( JOBVL, 'V' )
+ WANTVR = LSAME( JOBVR, 'V' )
+ IF( ( .NOT.WANTVL ) .AND. ( .NOT.LSAME( JOBVL, 'N' ) ) ) THEN
+ INFO = -1
+ ELSE IF( ( .NOT.WANTVR ) .AND. ( .NOT.LSAME( JOBVR, 'N' ) ) ) THEN
+ INFO = -2
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -5
+ ELSE IF( LDVL.LT.1 .OR. ( WANTVL .AND. LDVL.LT.N ) ) THEN
+ INFO = -9
+ ELSE IF( LDVR.LT.1 .OR. ( WANTVR .AND. LDVR.LT.N ) ) THEN
+ INFO = -11
+ END IF
+*
+* Compute workspace
+* (Note: Comments in the code beginning "Workspace:" describe the
+* minimal amount of workspace needed at that point in the code,
+* as well as the preferred amount for good performance.
+* NB refers to the optimal block size for the immediately
+* following subroutine, as returned by ILAENV.
+* HSWORK refers to the workspace preferred by SHSEQR, as
+* calculated below. HSWORK is computed assuming ILO=1 and IHI=N,
+* the worst case.)
+*
+ IF( INFO.EQ.0 ) THEN
+ IF( N.EQ.0 ) THEN
+ MINWRK = 1
+ MAXWRK = 1
+ ELSE
+ MAXWRK = 2*N + N*ILAENV( 1, 'SGEHRD', ' ', N, 1, N, 0 )
+ IF( WANTVL ) THEN
+ MINWRK = 4*N
+ MAXWRK = MAX( MAXWRK, 2*N + ( N - 1 )*ILAENV( 1,
+ $ 'SORGHR', ' ', N, 1, N, -1 ) )
+ CALL SHSEQR( 'S', 'V', N, 1, N, A, LDA, WR, WI, VL, LDVL,
+ $ WORK, -1, INFO )
+ HSWORK = WORK( 1 )
+ MAXWRK = MAX( MAXWRK, N + 1, N + HSWORK )
+ MAXWRK = MAX( MAXWRK, 4*N )
+ ELSE IF( WANTVR ) THEN
+ MINWRK = 4*N
+ MAXWRK = MAX( MAXWRK, 2*N + ( N - 1 )*ILAENV( 1,
+ $ 'SORGHR', ' ', N, 1, N, -1 ) )
+ CALL SHSEQR( 'S', 'V', N, 1, N, A, LDA, WR, WI, VR, LDVR,
+ $ WORK, -1, INFO )
+ HSWORK = WORK( 1 )
+ MAXWRK = MAX( MAXWRK, N + 1, N + HSWORK )
+ MAXWRK = MAX( MAXWRK, 4*N )
+ ELSE
+ MINWRK = 3*N
+ CALL SHSEQR( 'E', 'N', N, 1, N, A, LDA, WR, WI, VR, LDVR,
+ $ WORK, -1, INFO )
+ HSWORK = WORK( 1 )
+ MAXWRK = MAX( MAXWRK, N + 1, N + HSWORK )
+ END IF
+ MAXWRK = MAX( MAXWRK, MINWRK )
+ END IF
+ WORK( 1 ) = MAXWRK
+*
+ IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN
+ INFO = -13
+ END IF
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SGEEV ', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+* Get machine constants
+*
+ EPS = SLAMCH( 'P' )
+ SMLNUM = SLAMCH( 'S' )
+ BIGNUM = ONE / SMLNUM
+ CALL SLABAD( SMLNUM, BIGNUM )
+ SMLNUM = SQRT( SMLNUM ) / EPS
+ BIGNUM = ONE / SMLNUM
+*
+* Scale A if max element outside range [SMLNUM,BIGNUM]
+*
+ ANRM = SLANGE( 'M', N, N, A, LDA, DUM )
+ SCALEA = .FALSE.
+ IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
+ SCALEA = .TRUE.
+ CSCALE = SMLNUM
+ ELSE IF( ANRM.GT.BIGNUM ) THEN
+ SCALEA = .TRUE.
+ CSCALE = BIGNUM
+ END IF
+ IF( SCALEA )
+ $ CALL SLASCL( 'G', 0, 0, ANRM, CSCALE, N, N, A, LDA, IERR )
+*
+* Balance the matrix
+* (Workspace: need N)
+*
+ IBAL = 1
+ CALL SGEBAL( 'B', N, A, LDA, ILO, IHI, WORK( IBAL ), IERR )
+*
+* Reduce to upper Hessenberg form
+* (Workspace: need 3*N, prefer 2*N+N*NB)
+*
+ ITAU = IBAL + N
+ IWRK = ITAU + N
+ CALL SGEHRD( N, ILO, IHI, A, LDA, WORK( ITAU ), WORK( IWRK ),
+ $ LWORK-IWRK+1, IERR )
+*
+ IF( WANTVL ) THEN
+*
+* Want left eigenvectors
+* Copy Householder vectors to VL
+*
+ SIDE = 'L'
+ CALL SLACPY( 'L', N, N, A, LDA, VL, LDVL )
+*
+* Generate orthogonal matrix in VL
+* (Workspace: need 3*N-1, prefer 2*N+(N-1)*NB)
+*
+ CALL SORGHR( N, ILO, IHI, VL, LDVL, WORK( ITAU ), WORK( IWRK ),
+ $ LWORK-IWRK+1, IERR )
+*
+* Perform QR iteration, accumulating Schur vectors in VL
+* (Workspace: need N+1, prefer N+HSWORK (see comments) )
+*
+ IWRK = ITAU
+ CALL SHSEQR( 'S', 'V', N, ILO, IHI, A, LDA, WR, WI, VL, LDVL,
+ $ WORK( IWRK ), LWORK-IWRK+1, INFO )
+*
+ IF( WANTVR ) THEN
+*
+* Want left and right eigenvectors
+* Copy Schur vectors to VR
+*
+ SIDE = 'B'
+ CALL SLACPY( 'F', N, N, VL, LDVL, VR, LDVR )
+ END IF
+*
+ ELSE IF( WANTVR ) THEN
+*
+* Want right eigenvectors
+* Copy Householder vectors to VR
+*
+ SIDE = 'R'
+ CALL SLACPY( 'L', N, N, A, LDA, VR, LDVR )
+*
+* Generate orthogonal matrix in VR
+* (Workspace: need 3*N-1, prefer 2*N+(N-1)*NB)
+*
+ CALL SORGHR( N, ILO, IHI, VR, LDVR, WORK( ITAU ), WORK( IWRK ),
+ $ LWORK-IWRK+1, IERR )
+*
+* Perform QR iteration, accumulating Schur vectors in VR
+* (Workspace: need N+1, prefer N+HSWORK (see comments) )
+*
+ IWRK = ITAU
+ CALL SHSEQR( 'S', 'V', N, ILO, IHI, A, LDA, WR, WI, VR, LDVR,
+ $ WORK( IWRK ), LWORK-IWRK+1, INFO )
+*
+ ELSE
+*
+* Compute eigenvalues only
+* (Workspace: need N+1, prefer N+HSWORK (see comments) )
+*
+ IWRK = ITAU
+ CALL SHSEQR( 'E', 'N', N, ILO, IHI, A, LDA, WR, WI, VR, LDVR,
+ $ WORK( IWRK ), LWORK-IWRK+1, INFO )
+ END IF
+*
+* If INFO > 0 from SHSEQR, then quit
+*
+ IF( INFO.GT.0 )
+ $ GO TO 50
+*
+ IF( WANTVL .OR. WANTVR ) THEN
+*
+* Compute left and/or right eigenvectors
+* (Workspace: need 4*N)
+*
+ CALL STREVC( SIDE, 'B', SELECT, N, A, LDA, VL, LDVL, VR, LDVR,
+ $ N, NOUT, WORK( IWRK ), IERR )
+ END IF
+*
+ IF( WANTVL ) THEN
+*
+* Undo balancing of left eigenvectors
+* (Workspace: need N)
+*
+ CALL SGEBAK( 'B', 'L', N, ILO, IHI, WORK( IBAL ), N, VL, LDVL,
+ $ IERR )
+*
+* Normalize left eigenvectors and make largest component real
+*
+ DO 20 I = 1, N
+ IF( WI( I ).EQ.ZERO ) THEN
+ SCL = ONE / SNRM2( N, VL( 1, I ), 1 )
+ CALL SSCAL( N, SCL, VL( 1, I ), 1 )
+ ELSE IF( WI( I ).GT.ZERO ) THEN
+ SCL = ONE / SLAPY2( SNRM2( N, VL( 1, I ), 1 ),
+ $ SNRM2( N, VL( 1, I+1 ), 1 ) )
+ CALL SSCAL( N, SCL, VL( 1, I ), 1 )
+ CALL SSCAL( N, SCL, VL( 1, I+1 ), 1 )
+ DO 10 K = 1, N
+ WORK( IWRK+K-1 ) = VL( K, I )**2 + VL( K, I+1 )**2
+ 10 CONTINUE
+ K = ISAMAX( N, WORK( IWRK ), 1 )
+ CALL SLARTG( VL( K, I ), VL( K, I+1 ), CS, SN, R )
+ CALL SROT( N, VL( 1, I ), 1, VL( 1, I+1 ), 1, CS, SN )
+ VL( K, I+1 ) = ZERO
+ END IF
+ 20 CONTINUE
+ END IF
+*
+ IF( WANTVR ) THEN
+*
+* Undo balancing of right eigenvectors
+* (Workspace: need N)
+*
+ CALL SGEBAK( 'B', 'R', N, ILO, IHI, WORK( IBAL ), N, VR, LDVR,
+ $ IERR )
+*
+* Normalize right eigenvectors and make largest component real
+*
+ DO 40 I = 1, N
+ IF( WI( I ).EQ.ZERO ) THEN
+ SCL = ONE / SNRM2( N, VR( 1, I ), 1 )
+ CALL SSCAL( N, SCL, VR( 1, I ), 1 )
+ ELSE IF( WI( I ).GT.ZERO ) THEN
+ SCL = ONE / SLAPY2( SNRM2( N, VR( 1, I ), 1 ),
+ $ SNRM2( N, VR( 1, I+1 ), 1 ) )
+ CALL SSCAL( N, SCL, VR( 1, I ), 1 )
+ CALL SSCAL( N, SCL, VR( 1, I+1 ), 1 )
+ DO 30 K = 1, N
+ WORK( IWRK+K-1 ) = VR( K, I )**2 + VR( K, I+1 )**2
+ 30 CONTINUE
+ K = ISAMAX( N, WORK( IWRK ), 1 )
+ CALL SLARTG( VR( K, I ), VR( K, I+1 ), CS, SN, R )
+ CALL SROT( N, VR( 1, I ), 1, VR( 1, I+1 ), 1, CS, SN )
+ VR( K, I+1 ) = ZERO
+ END IF
+ 40 CONTINUE
+ END IF
+*
+* Undo scaling if necessary
+*
+ 50 CONTINUE
+ IF( SCALEA ) THEN
+ CALL SLASCL( 'G', 0, 0, CSCALE, ANRM, N-INFO, 1, WR( INFO+1 ),
+ $ MAX( N-INFO, 1 ), IERR )
+ CALL SLASCL( 'G', 0, 0, CSCALE, ANRM, N-INFO, 1, WI( INFO+1 ),
+ $ MAX( N-INFO, 1 ), IERR )
+ IF( INFO.GT.0 ) THEN
+ CALL SLASCL( 'G', 0, 0, CSCALE, ANRM, ILO-1, 1, WR, N,
+ $ IERR )
+ CALL SLASCL( 'G', 0, 0, CSCALE, ANRM, ILO-1, 1, WI, N,
+ $ IERR )
+ END IF
+ END IF
+*
+ WORK( 1 ) = MAXWRK
+ RETURN
+*
+* End of SGEEV
+*
+ END
+ 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 )
+*
+* -- LAPACK driver routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER BALANC, JOBVL, JOBVR, SENSE
+ INTEGER IHI, ILO, INFO, LDA, LDVL, LDVR, LWORK, N
+ REAL ABNRM
+* ..
+* .. Array Arguments ..
+ INTEGER IWORK( * )
+ REAL A( LDA, * ), RCONDE( * ), RCONDV( * ),
+ $ SCALE( * ), VL( LDVL, * ), VR( LDVR, * ),
+ $ WI( * ), WORK( * ), WR( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SGEEVX computes for an N-by-N real nonsymmetric matrix A, the
+* eigenvalues and, optionally, the left and/or right eigenvectors.
+*
+* Optionally also, it computes a balancing transformation to improve
+* the conditioning of the eigenvalues and eigenvectors (ILO, IHI,
+* SCALE, and ABNRM), reciprocal condition numbers for the eigenvalues
+* (RCONDE), and reciprocal condition numbers for the right
+* eigenvectors (RCONDV).
+*
+* The right eigenvector v(j) of A satisfies
+* A * v(j) = lambda(j) * v(j)
+* where lambda(j) is its eigenvalue.
+* The left eigenvector u(j) of A satisfies
+* u(j)**H * A = lambda(j) * u(j)**H
+* where u(j)**H denotes the conjugate transpose of u(j).
+*
+* The computed eigenvectors are normalized to have Euclidean norm
+* equal to 1 and largest component real.
+*
+* Balancing a matrix means permuting the rows and columns to make it
+* more nearly upper triangular, and applying a diagonal similarity
+* transformation D * A * D**(-1), where D is a diagonal matrix, to
+* make its rows and columns closer in norm and the condition numbers
+* of its eigenvalues and eigenvectors smaller. The computed
+* reciprocal condition numbers correspond to the balanced matrix.
+* Permuting rows and columns will not change the condition numbers
+* (in exact arithmetic) but diagonal scaling will. For further
+* explanation of balancing, see section 4.10.2 of the LAPACK
+* Users' Guide.
+*
+* Arguments
+* =========
+*
+* BALANC (input) CHARACTER*1
+* Indicates how the input matrix should be diagonally scaled
+* and/or permuted to improve the conditioning of its
+* eigenvalues.
+* = 'N': Do not diagonally scale or permute;
+* = 'P': Perform permutations to make the matrix more nearly
+* upper triangular. Do not diagonally scale;
+* = 'S': Diagonally scale the matrix, i.e. replace A by
+* D*A*D**(-1), where D is a diagonal matrix chosen
+* to make the rows and columns of A more equal in
+* norm. Do not permute;
+* = 'B': Both diagonally scale and permute A.
+*
+* Computed reciprocal condition numbers will be for the matrix
+* after balancing and/or permuting. Permuting does not change
+* condition numbers (in exact arithmetic), but balancing does.
+*
+* JOBVL (input) CHARACTER*1
+* = 'N': left eigenvectors of A are not computed;
+* = 'V': left eigenvectors of A are computed.
+* If SENSE = 'E' or 'B', JOBVL must = 'V'.
+*
+* JOBVR (input) CHARACTER*1
+* = 'N': right eigenvectors of A are not computed;
+* = 'V': right eigenvectors of A are computed.
+* If SENSE = 'E' or 'B', JOBVR must = 'V'.
+*
+* SENSE (input) CHARACTER*1
+* Determines which reciprocal condition numbers are computed.
+* = 'N': None are computed;
+* = 'E': Computed for eigenvalues only;
+* = 'V': Computed for right eigenvectors only;
+* = 'B': Computed for eigenvalues and right eigenvectors.
+*
+* If SENSE = 'E' or 'B', both left and right eigenvectors
+* must also be computed (JOBVL = 'V' and JOBVR = 'V').
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* A (input/output) REAL array, dimension (LDA,N)
+* On entry, the N-by-N matrix A.
+* On exit, A has been overwritten. If JOBVL = 'V' or
+* JOBVR = 'V', A contains the real Schur form of the balanced
+* version of the input matrix A.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,N).
+*
+* WR (output) REAL array, dimension (N)
+* WI (output) REAL array, dimension (N)
+* WR and WI contain the real and imaginary parts,
+* respectively, of the computed eigenvalues. Complex
+* conjugate pairs of eigenvalues will appear consecutively
+* with the eigenvalue having the positive imaginary part
+* first.
+*
+* VL (output) REAL array, dimension (LDVL,N)
+* If JOBVL = 'V', the left eigenvectors u(j) are stored one
+* after another in the columns of VL, in the same order
+* as their eigenvalues.
+* If JOBVL = 'N', VL is not referenced.
+* If the j-th eigenvalue is real, then u(j) = VL(:,j),
+* the j-th column of VL.
+* If the j-th and (j+1)-st eigenvalues form a complex
+* conjugate pair, then u(j) = VL(:,j) + i*VL(:,j+1) and
+* u(j+1) = VL(:,j) - i*VL(:,j+1).
+*
+* LDVL (input) INTEGER
+* The leading dimension of the array VL. LDVL >= 1; if
+* JOBVL = 'V', LDVL >= N.
+*
+* VR (output) REAL array, dimension (LDVR,N)
+* If JOBVR = 'V', the right eigenvectors v(j) are stored one
+* after another in the columns of VR, in the same order
+* as their eigenvalues.
+* If JOBVR = 'N', VR is not referenced.
+* If the j-th eigenvalue is real, then v(j) = VR(:,j),
+* the j-th column of VR.
+* If the j-th and (j+1)-st eigenvalues form a complex
+* conjugate pair, then v(j) = VR(:,j) + i*VR(:,j+1) and
+* v(j+1) = VR(:,j) - i*VR(:,j+1).
+*
+* LDVR (input) INTEGER
+* The leading dimension of the array VR. LDVR >= 1, and if
+* JOBVR = 'V', LDVR >= N.
+*
+* ILO (output) INTEGER
+* IHI (output) INTEGER
+* ILO and IHI are integer values determined when A was
+* balanced. The balanced A(i,j) = 0 if I > J and
+* J = 1,...,ILO-1 or I = IHI+1,...,N.
+*
+* SCALE (output) REAL array, dimension (N)
+* Details of the permutations and scaling factors applied
+* when balancing A. If P(j) is the index of the row and column
+* interchanged with row and column j, and D(j) is the scaling
+* factor applied to row and column j, then
+* SCALE(J) = P(J), for J = 1,...,ILO-1
+* = D(J), for J = ILO,...,IHI
+* = P(J) for J = IHI+1,...,N.
+* The order in which the interchanges are made is N to IHI+1,
+* then 1 to ILO-1.
+*
+* ABNRM (output) REAL
+* The one-norm of the balanced matrix (the maximum
+* of the sum of absolute values of elements of any column).
+*
+* RCONDE (output) REAL array, dimension (N)
+* RCONDE(j) is the reciprocal condition number of the j-th
+* eigenvalue.
+*
+* RCONDV (output) REAL array, dimension (N)
+* RCONDV(j) is the reciprocal condition number of the j-th
+* right eigenvector.
+*
+* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))
+* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+* LWORK (input) INTEGER
+* The dimension of the array WORK. If SENSE = 'N' or 'E',
+* LWORK >= max(1,2*N), and if JOBVL = 'V' or JOBVR = 'V',
+* LWORK >= 3*N. If SENSE = 'V' or 'B', LWORK >= N*(N+6).
+* For good performance, LWORK must generally be larger.
+*
+* If LWORK = -1, then a workspace query is assumed; the routine
+* only calculates the optimal size of the WORK array, returns
+* this value as the first entry of the WORK array, and no error
+* message related to LWORK is issued by XERBLA.
+*
+* IWORK (workspace) INTEGER array, dimension (2*N-2)
+* If SENSE = 'N' or 'E', not referenced.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value.
+* > 0: if INFO = i, the QR algorithm failed to compute all the
+* eigenvalues, and no eigenvectors or condition numbers
+* have been computed; elements 1:ILO-1 and i+1:N of WR
+* and WI contain eigenvalues which have converged.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO, ONE
+ PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL LQUERY, SCALEA, WANTVL, WANTVR, WNTSNB, WNTSNE,
+ $ WNTSNN, WNTSNV
+ CHARACTER JOB, SIDE
+ INTEGER HSWORK, I, ICOND, IERR, ITAU, IWRK, K, MAXWRK,
+ $ MINWRK, NOUT
+ REAL ANRM, BIGNUM, CS, CSCALE, EPS, R, SCL, SMLNUM,
+ $ SN
+* ..
+* .. Local Arrays ..
+ LOGICAL SELECT( 1 )
+ REAL DUM( 1 )
+* ..
+* .. External Subroutines ..
+ EXTERNAL SGEBAK, SGEBAL, SGEHRD, SHSEQR, SLABAD, SLACPY,
+ $ SLARTG, SLASCL, SORGHR, SROT, SSCAL, STREVC,
+ $ STRSNA, XERBLA
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ILAENV, ISAMAX
+ REAL SLAMCH, SLANGE, SLAPY2, SNRM2
+ EXTERNAL LSAME, ILAENV, ISAMAX, SLAMCH, SLANGE, SLAPY2,
+ $ SNRM2
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, SQRT
+* ..
+* .. Executable Statements ..
+*
+* Test the input arguments
+*
+ INFO = 0
+ LQUERY = ( LWORK.EQ.-1 )
+ WANTVL = LSAME( JOBVL, 'V' )
+ WANTVR = LSAME( JOBVR, 'V' )
+ WNTSNN = LSAME( SENSE, 'N' )
+ WNTSNE = LSAME( SENSE, 'E' )
+ WNTSNV = LSAME( SENSE, 'V' )
+ WNTSNB = LSAME( SENSE, 'B' )
+ IF( .NOT.( LSAME( BALANC, 'N' ) .OR. LSAME( BALANC, 'S' ) .OR.
+ $ LSAME( BALANC, 'P' ) .OR. LSAME( BALANC, 'B' ) ) ) THEN
+ INFO = -1
+ ELSE IF( ( .NOT.WANTVL ) .AND. ( .NOT.LSAME( JOBVL, 'N' ) ) ) THEN
+ INFO = -2
+ ELSE IF( ( .NOT.WANTVR ) .AND. ( .NOT.LSAME( JOBVR, 'N' ) ) ) THEN
+ INFO = -3
+ ELSE IF( .NOT.( WNTSNN .OR. WNTSNE .OR. WNTSNB .OR. WNTSNV ) .OR.
+ $ ( ( WNTSNE .OR. WNTSNB ) .AND. .NOT.( WANTVL .AND.
+ $ WANTVR ) ) ) THEN
+ INFO = -4
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -5
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -7
+ ELSE IF( LDVL.LT.1 .OR. ( WANTVL .AND. LDVL.LT.N ) ) THEN
+ INFO = -11
+ ELSE IF( LDVR.LT.1 .OR. ( WANTVR .AND. LDVR.LT.N ) ) THEN
+ INFO = -13
+ END IF
+*
+* Compute workspace
+* (Note: Comments in the code beginning "Workspace:" describe the
+* minimal amount of workspace needed at that point in the code,
+* as well as the preferred amount for good performance.
+* NB refers to the optimal block size for the immediately
+* following subroutine, as returned by ILAENV.
+* HSWORK refers to the workspace preferred by SHSEQR, as
+* calculated below. HSWORK is computed assuming ILO=1 and IHI=N,
+* the worst case.)
+*
+ IF( INFO.EQ.0 ) THEN
+ IF( N.EQ.0 ) THEN
+ MINWRK = 1
+ MAXWRK = 1
+ ELSE
+ MAXWRK = N + N*ILAENV( 1, 'SGEHRD', ' ', N, 1, N, 0 )
+*
+ IF( WANTVL ) THEN
+ CALL SHSEQR( 'S', 'V', N, 1, N, A, LDA, WR, WI, VL, LDVL,
+ $ WORK, -1, INFO )
+ ELSE IF( WANTVR ) THEN
+ CALL SHSEQR( 'S', 'V', N, 1, N, A, LDA, WR, WI, VR, LDVR,
+ $ WORK, -1, INFO )
+ ELSE
+ IF( WNTSNN ) THEN
+ CALL SHSEQR( 'E', 'N', N, 1, N, A, LDA, WR, WI, VR,
+ $ LDVR, WORK, -1, INFO )
+ ELSE
+ CALL SHSEQR( 'S', 'N', N, 1, N, A, LDA, WR, WI, VR,
+ $ LDVR, WORK, -1, INFO )
+ END IF
+ END IF
+ HSWORK = WORK( 1 )
+*
+ IF( ( .NOT.WANTVL ) .AND. ( .NOT.WANTVR ) ) THEN
+ MINWRK = 2*N
+ IF( .NOT.WNTSNN )
+ $ MINWRK = MAX( MINWRK, N*N+6*N )
+ MAXWRK = MAX( MAXWRK, HSWORK )
+ IF( .NOT.WNTSNN )
+ $ MAXWRK = MAX( MAXWRK, N*N + 6*N )
+ ELSE
+ MINWRK = 3*N
+ IF( ( .NOT.WNTSNN ) .AND. ( .NOT.WNTSNE ) )
+ $ MINWRK = MAX( MINWRK, N*N + 6*N )
+ MAXWRK = MAX( MAXWRK, HSWORK )
+ MAXWRK = MAX( MAXWRK, N + ( N - 1 )*ILAENV( 1, 'SORGHR',
+ $ ' ', N, 1, N, -1 ) )
+ IF( ( .NOT.WNTSNN ) .AND. ( .NOT.WNTSNE ) )
+ $ MAXWRK = MAX( MAXWRK, N*N + 6*N )
+ MAXWRK = MAX( MAXWRK, 3*N )
+ END IF
+ MAXWRK = MAX( MAXWRK, MINWRK )
+ END IF
+ WORK( 1 ) = MAXWRK
+*
+ IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN
+ INFO = -21
+ END IF
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SGEEVX', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+* Get machine constants
+*
+ EPS = SLAMCH( 'P' )
+ SMLNUM = SLAMCH( 'S' )
+ BIGNUM = ONE / SMLNUM
+ CALL SLABAD( SMLNUM, BIGNUM )
+ SMLNUM = SQRT( SMLNUM ) / EPS
+ BIGNUM = ONE / SMLNUM
+*
+* Scale A if max element outside range [SMLNUM,BIGNUM]
+*
+ ICOND = 0
+ ANRM = SLANGE( 'M', N, N, A, LDA, DUM )
+ SCALEA = .FALSE.
+ IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
+ SCALEA = .TRUE.
+ CSCALE = SMLNUM
+ ELSE IF( ANRM.GT.BIGNUM ) THEN
+ SCALEA = .TRUE.
+ CSCALE = BIGNUM
+ END IF
+ IF( SCALEA )
+ $ CALL SLASCL( 'G', 0, 0, ANRM, CSCALE, N, N, A, LDA, IERR )
+*
+* Balance the matrix and compute ABNRM
+*
+ CALL SGEBAL( BALANC, N, A, LDA, ILO, IHI, SCALE, IERR )
+ ABNRM = SLANGE( '1', N, N, A, LDA, DUM )
+ IF( SCALEA ) THEN
+ DUM( 1 ) = ABNRM
+ CALL SLASCL( 'G', 0, 0, CSCALE, ANRM, 1, 1, DUM, 1, IERR )
+ ABNRM = DUM( 1 )
+ END IF
+*
+* Reduce to upper Hessenberg form
+* (Workspace: need 2*N, prefer N+N*NB)
+*
+ ITAU = 1
+ IWRK = ITAU + N
+ CALL SGEHRD( N, ILO, IHI, A, LDA, WORK( ITAU ), WORK( IWRK ),
+ $ LWORK-IWRK+1, IERR )
+*
+ IF( WANTVL ) THEN
+*
+* Want left eigenvectors
+* Copy Householder vectors to VL
+*
+ SIDE = 'L'
+ CALL SLACPY( 'L', N, N, A, LDA, VL, LDVL )
+*
+* Generate orthogonal matrix in VL
+* (Workspace: need 2*N-1, prefer N+(N-1)*NB)
+*
+ CALL SORGHR( N, ILO, IHI, VL, LDVL, WORK( ITAU ), WORK( IWRK ),
+ $ LWORK-IWRK+1, IERR )
+*
+* Perform QR iteration, accumulating Schur vectors in VL
+* (Workspace: need 1, prefer HSWORK (see comments) )
+*
+ IWRK = ITAU
+ CALL SHSEQR( 'S', 'V', N, ILO, IHI, A, LDA, WR, WI, VL, LDVL,
+ $ WORK( IWRK ), LWORK-IWRK+1, INFO )
+*
+ IF( WANTVR ) THEN
+*
+* Want left and right eigenvectors
+* Copy Schur vectors to VR
+*
+ SIDE = 'B'
+ CALL SLACPY( 'F', N, N, VL, LDVL, VR, LDVR )
+ END IF
+*
+ ELSE IF( WANTVR ) THEN
+*
+* Want right eigenvectors
+* Copy Householder vectors to VR
+*
+ SIDE = 'R'
+ CALL SLACPY( 'L', N, N, A, LDA, VR, LDVR )
+*
+* Generate orthogonal matrix in VR
+* (Workspace: need 2*N-1, prefer N+(N-1)*NB)
+*
+ CALL SORGHR( N, ILO, IHI, VR, LDVR, WORK( ITAU ), WORK( IWRK ),
+ $ LWORK-IWRK+1, IERR )
+*
+* Perform QR iteration, accumulating Schur vectors in VR
+* (Workspace: need 1, prefer HSWORK (see comments) )
+*
+ IWRK = ITAU
+ CALL SHSEQR( 'S', 'V', N, ILO, IHI, A, LDA, WR, WI, VR, LDVR,
+ $ WORK( IWRK ), LWORK-IWRK+1, INFO )
+*
+ ELSE
+*
+* Compute eigenvalues only
+* If condition numbers desired, compute Schur form
+*
+ IF( WNTSNN ) THEN
+ JOB = 'E'
+ ELSE
+ JOB = 'S'
+ END IF
+*
+* (Workspace: need 1, prefer HSWORK (see comments) )
+*
+ IWRK = ITAU
+ CALL SHSEQR( JOB, 'N', N, ILO, IHI, A, LDA, WR, WI, VR, LDVR,
+ $ WORK( IWRK ), LWORK-IWRK+1, INFO )
+ END IF
+*
+* If INFO > 0 from SHSEQR, then quit
+*
+ IF( INFO.GT.0 )
+ $ GO TO 50
+*
+ IF( WANTVL .OR. WANTVR ) THEN
+*
+* Compute left and/or right eigenvectors
+* (Workspace: need 3*N)
+*
+ CALL STREVC( SIDE, 'B', SELECT, N, A, LDA, VL, LDVL, VR, LDVR,
+ $ N, NOUT, WORK( IWRK ), IERR )
+ END IF
+*
+* Compute condition numbers if desired
+* (Workspace: need N*N+6*N unless SENSE = 'E')
+*
+ IF( .NOT.WNTSNN ) THEN
+ CALL STRSNA( SENSE, 'A', SELECT, N, A, LDA, VL, LDVL, VR, LDVR,
+ $ RCONDE, RCONDV, N, NOUT, WORK( IWRK ), N, IWORK,
+ $ ICOND )
+ END IF
+*
+ IF( WANTVL ) THEN
+*
+* Undo balancing of left eigenvectors
+*
+ CALL SGEBAK( BALANC, 'L', N, ILO, IHI, SCALE, N, VL, LDVL,
+ $ IERR )
+*
+* Normalize left eigenvectors and make largest component real
+*
+ DO 20 I = 1, N
+ IF( WI( I ).EQ.ZERO ) THEN
+ SCL = ONE / SNRM2( N, VL( 1, I ), 1 )
+ CALL SSCAL( N, SCL, VL( 1, I ), 1 )
+ ELSE IF( WI( I ).GT.ZERO ) THEN
+ SCL = ONE / SLAPY2( SNRM2( N, VL( 1, I ), 1 ),
+ $ SNRM2( N, VL( 1, I+1 ), 1 ) )
+ CALL SSCAL( N, SCL, VL( 1, I ), 1 )
+ CALL SSCAL( N, SCL, VL( 1, I+1 ), 1 )
+ DO 10 K = 1, N
+ WORK( K ) = VL( K, I )**2 + VL( K, I+1 )**2
+ 10 CONTINUE
+ K = ISAMAX( N, WORK, 1 )
+ CALL SLARTG( VL( K, I ), VL( K, I+1 ), CS, SN, R )
+ CALL SROT( N, VL( 1, I ), 1, VL( 1, I+1 ), 1, CS, SN )
+ VL( K, I+1 ) = ZERO
+ END IF
+ 20 CONTINUE
+ END IF
+*
+ IF( WANTVR ) THEN
+*
+* Undo balancing of right eigenvectors
+*
+ CALL SGEBAK( BALANC, 'R', N, ILO, IHI, SCALE, N, VR, LDVR,
+ $ IERR )
+*
+* Normalize right eigenvectors and make largest component real
+*
+ DO 40 I = 1, N
+ IF( WI( I ).EQ.ZERO ) THEN
+ SCL = ONE / SNRM2( N, VR( 1, I ), 1 )
+ CALL SSCAL( N, SCL, VR( 1, I ), 1 )
+ ELSE IF( WI( I ).GT.ZERO ) THEN
+ SCL = ONE / SLAPY2( SNRM2( N, VR( 1, I ), 1 ),
+ $ SNRM2( N, VR( 1, I+1 ), 1 ) )
+ CALL SSCAL( N, SCL, VR( 1, I ), 1 )
+ CALL SSCAL( N, SCL, VR( 1, I+1 ), 1 )
+ DO 30 K = 1, N
+ WORK( K ) = VR( K, I )**2 + VR( K, I+1 )**2
+ 30 CONTINUE
+ K = ISAMAX( N, WORK, 1 )
+ CALL SLARTG( VR( K, I ), VR( K, I+1 ), CS, SN, R )
+ CALL SROT( N, VR( 1, I ), 1, VR( 1, I+1 ), 1, CS, SN )
+ VR( K, I+1 ) = ZERO
+ END IF
+ 40 CONTINUE
+ END IF
+*
+* Undo scaling if necessary
+*
+ 50 CONTINUE
+ IF( SCALEA ) THEN
+ CALL SLASCL( 'G', 0, 0, CSCALE, ANRM, N-INFO, 1, WR( INFO+1 ),
+ $ MAX( N-INFO, 1 ), IERR )
+ CALL SLASCL( 'G', 0, 0, CSCALE, ANRM, N-INFO, 1, WI( INFO+1 ),
+ $ MAX( N-INFO, 1 ), IERR )
+ IF( INFO.EQ.0 ) THEN
+ IF( ( WNTSNV .OR. WNTSNB ) .AND. ICOND.EQ.0 )
+ $ CALL SLASCL( 'G', 0, 0, CSCALE, ANRM, N, 1, RCONDV, N,
+ $ IERR )
+ ELSE
+ CALL SLASCL( 'G', 0, 0, CSCALE, ANRM, ILO-1, 1, WR, N,
+ $ IERR )
+ CALL SLASCL( 'G', 0, 0, CSCALE, ANRM, ILO-1, 1, WI, N,
+ $ IERR )
+ END IF
+ END IF
+*
+ WORK( 1 ) = MAXWRK
+ RETURN
+*
+* End of SGEEVX
+*
+ END
+ SUBROUTINE SGEGS( JOBVSL, JOBVSR, N, A, LDA, B, LDB, ALPHAR,
+ $ ALPHAI, BETA, VSL, LDVSL, VSR, LDVSR, WORK,
+ $ LWORK, INFO )
+*
+* -- LAPACK driver routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER JOBVSL, JOBVSR
+ INTEGER INFO, LDA, LDB, LDVSL, LDVSR, LWORK, N
+* ..
+* .. Array Arguments ..
+ REAL A( LDA, * ), ALPHAI( * ), ALPHAR( * ),
+ $ B( LDB, * ), BETA( * ), VSL( LDVSL, * ),
+ $ VSR( LDVSR, * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* This routine is deprecated and has been replaced by routine SGGES.
+*
+* SGEGS computes the eigenvalues, real Schur form, and, optionally,
+* left and or/right Schur vectors of a real matrix pair (A,B).
+* Given two square matrices A and B, the generalized real Schur
+* factorization has the form
+*
+* A = Q*S*Z**T, B = Q*T*Z**T
+*
+* where Q and Z are orthogonal matrices, T is upper triangular, and S
+* is an upper quasi-triangular matrix with 1-by-1 and 2-by-2 diagonal
+* blocks, the 2-by-2 blocks corresponding to complex conjugate pairs
+* of eigenvalues of (A,B). The columns of Q are the left Schur vectors
+* and the columns of Z are the right Schur vectors.
+*
+* If only the eigenvalues of (A,B) are needed, the driver routine
+* SGEGV should be used instead. See SGEGV for a description of the
+* eigenvalues of the generalized nonsymmetric eigenvalue problem
+* (GNEP).
+*
+* Arguments
+* =========
+*
+* JOBVSL (input) CHARACTER*1
+* = 'N': do not compute the left Schur vectors;
+* = 'V': compute the left Schur vectors (returned in VSL).
+*
+* JOBVSR (input) CHARACTER*1
+* = 'N': do not compute the right Schur vectors;
+* = 'V': compute the right Schur vectors (returned in VSR).
+*
+* N (input) INTEGER
+* The order of the matrices A, B, VSL, and VSR. N >= 0.
+*
+* A (input/output) REAL array, dimension (LDA, N)
+* On entry, the matrix A.
+* On exit, the upper quasi-triangular matrix S from the
+* generalized real Schur factorization.
+*
+* LDA (input) INTEGER
+* The leading dimension of A. LDA >= max(1,N).
+*
+* B (input/output) REAL array, dimension (LDB, N)
+* On entry, the matrix B.
+* On exit, the upper triangular matrix T from the generalized
+* real Schur factorization.
+*
+* LDB (input) INTEGER
+* The leading dimension of B. LDB >= max(1,N).
+*
+* ALPHAR (output) REAL array, dimension (N)
+* The real parts of each scalar alpha defining an eigenvalue
+* of GNEP.
+*
+* ALPHAI (output) REAL array, dimension (N)
+* The imaginary parts of each scalar alpha defining an
+* eigenvalue of GNEP. If ALPHAI(j) is zero, then the j-th
+* eigenvalue is real; if positive, then the j-th and (j+1)-st
+* eigenvalues are a complex conjugate pair, with
+* ALPHAI(j+1) = -ALPHAI(j).
+*
+* BETA (output) REAL array, dimension (N)
+* The scalars beta that define the eigenvalues of GNEP.
+* Together, the quantities alpha = (ALPHAR(j),ALPHAI(j)) and
+* beta = BETA(j) represent the j-th eigenvalue of the matrix
+* pair (A,B), in one of the forms lambda = alpha/beta or
+* mu = beta/alpha. Since either lambda or mu may overflow,
+* they should not, in general, be computed.
+*
+* VSL (output) REAL array, dimension (LDVSL,N)
+* If JOBVSL = 'V', the matrix of left Schur vectors Q.
+* Not referenced if JOBVSL = 'N'.
+*
+* LDVSL (input) INTEGER
+* The leading dimension of the matrix VSL. LDVSL >=1, and
+* if JOBVSL = 'V', LDVSL >= N.
+*
+* VSR (output) REAL array, dimension (LDVSR,N)
+* If JOBVSR = 'V', the matrix of right Schur vectors Z.
+* Not referenced if JOBVSR = 'N'.
+*
+* LDVSR (input) INTEGER
+* The leading dimension of the matrix VSR. LDVSR >= 1, and
+* if JOBVSR = 'V', LDVSR >= N.
+*
+* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))
+* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+* LWORK (input) INTEGER
+* The dimension of the array WORK. LWORK >= max(1,4*N).
+* For good performance, LWORK must generally be larger.
+* To compute the optimal value of LWORK, call ILAENV to get
+* blocksizes (for SGEQRF, SORMQR, and SORGQR.) Then compute:
+* NB -- MAX of the blocksizes for SGEQRF, SORMQR, and SORGQR
+* The optimal LWORK is 2*N + N*(NB+1).
+*
+* If LWORK = -1, then a workspace query is assumed; the routine
+* only calculates the optimal size of the WORK array, returns
+* this value as the first entry of the WORK array, and no error
+* message related to LWORK is issued by XERBLA.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value.
+* = 1,...,N:
+* The QZ iteration failed. (A,B) are not in Schur
+* form, but ALPHAR(j), ALPHAI(j), and BETA(j) should
+* be correct for j=INFO+1,...,N.
+* > N: errors that usually indicate LAPACK problems:
+* =N+1: error return from SGGBAL
+* =N+2: error return from SGEQRF
+* =N+3: error return from SORMQR
+* =N+4: error return from SORGQR
+* =N+5: error return from SGGHRD
+* =N+6: error return from SHGEQZ (other than failed
+* iteration)
+* =N+7: error return from SGGBAK (computing VSL)
+* =N+8: error return from SGGBAK (computing VSR)
+* =N+9: error return from SLASCL (various places)
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO, ONE
+ PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL ILASCL, ILBSCL, ILVSL, ILVSR, LQUERY
+ INTEGER ICOLS, IHI, IINFO, IJOBVL, IJOBVR, ILEFT,
+ $ ILO, IRIGHT, IROWS, ITAU, IWORK, LOPT, LWKMIN,
+ $ LWKOPT, NB, NB1, NB2, NB3
+ REAL ANRM, ANRMTO, BIGNUM, BNRM, BNRMTO, EPS,
+ $ SAFMIN, SMLNUM
+* ..
+* .. External Subroutines ..
+ EXTERNAL SGEQRF, SGGBAK, SGGBAL, SGGHRD, SHGEQZ, SLACPY,
+ $ SLASCL, SLASET, SORGQR, SORMQR, XERBLA
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ILAENV
+ REAL SLAMCH, SLANGE
+ EXTERNAL ILAENV, LSAME, SLAMCH, SLANGE
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC INT, MAX
+* ..
+* .. Executable Statements ..
+*
+* Decode the input arguments
+*
+ IF( LSAME( JOBVSL, 'N' ) ) THEN
+ IJOBVL = 1
+ ILVSL = .FALSE.
+ ELSE IF( LSAME( JOBVSL, 'V' ) ) THEN
+ IJOBVL = 2
+ ILVSL = .TRUE.
+ ELSE
+ IJOBVL = -1
+ ILVSL = .FALSE.
+ END IF
+*
+ IF( LSAME( JOBVSR, 'N' ) ) THEN
+ IJOBVR = 1
+ ILVSR = .FALSE.
+ ELSE IF( LSAME( JOBVSR, 'V' ) ) THEN
+ IJOBVR = 2
+ ILVSR = .TRUE.
+ ELSE
+ IJOBVR = -1
+ ILVSR = .FALSE.
+ END IF
+*
+* Test the input arguments
+*
+ LWKMIN = MAX( 4*N, 1 )
+ LWKOPT = LWKMIN
+ WORK( 1 ) = LWKOPT
+ LQUERY = ( LWORK.EQ.-1 )
+ INFO = 0
+ IF( IJOBVL.LE.0 ) THEN
+ INFO = -1
+ ELSE IF( IJOBVR.LE.0 ) THEN
+ INFO = -2
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -5
+ ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -7
+ ELSE IF( LDVSL.LT.1 .OR. ( ILVSL .AND. LDVSL.LT.N ) ) THEN
+ INFO = -12
+ ELSE IF( LDVSR.LT.1 .OR. ( ILVSR .AND. LDVSR.LT.N ) ) THEN
+ INFO = -14
+ ELSE IF( LWORK.LT.LWKMIN .AND. .NOT.LQUERY ) THEN
+ INFO = -16
+ END IF
+*
+ IF( INFO.EQ.0 ) THEN
+ NB1 = ILAENV( 1, 'SGEQRF', ' ', N, N, -1, -1 )
+ NB2 = ILAENV( 1, 'SORMQR', ' ', N, N, N, -1 )
+ NB3 = ILAENV( 1, 'SORGQR', ' ', N, N, N, -1 )
+ NB = MAX( NB1, NB2, NB3 )
+ LOPT = 2*N+N*(NB+1)
+ WORK( 1 ) = LOPT
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SGEGS ', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+* Get machine constants
+*
+ EPS = SLAMCH( 'E' )*SLAMCH( 'B' )
+ SAFMIN = SLAMCH( 'S' )
+ SMLNUM = N*SAFMIN / EPS
+ BIGNUM = ONE / SMLNUM
+*
+* Scale A if max element outside range [SMLNUM,BIGNUM]
+*
+ ANRM = SLANGE( 'M', N, N, A, LDA, WORK )
+ ILASCL = .FALSE.
+ IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
+ ANRMTO = SMLNUM
+ ILASCL = .TRUE.
+ ELSE IF( ANRM.GT.BIGNUM ) THEN
+ ANRMTO = BIGNUM
+ ILASCL = .TRUE.
+ END IF
+*
+ IF( ILASCL ) THEN
+ CALL SLASCL( 'G', -1, -1, ANRM, ANRMTO, N, N, A, LDA, IINFO )
+ IF( IINFO.NE.0 ) THEN
+ INFO = N + 9
+ RETURN
+ END IF
+ END IF
+*
+* Scale B if max element outside range [SMLNUM,BIGNUM]
+*
+ BNRM = SLANGE( 'M', N, N, B, LDB, WORK )
+ ILBSCL = .FALSE.
+ IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN
+ BNRMTO = SMLNUM
+ ILBSCL = .TRUE.
+ ELSE IF( BNRM.GT.BIGNUM ) THEN
+ BNRMTO = BIGNUM
+ ILBSCL = .TRUE.
+ END IF
+*
+ IF( ILBSCL ) THEN
+ CALL SLASCL( 'G', -1, -1, BNRM, BNRMTO, N, N, B, LDB, IINFO )
+ IF( IINFO.NE.0 ) THEN
+ INFO = N + 9
+ RETURN
+ END IF
+ END IF
+*
+* Permute the matrix to make it more nearly triangular
+* Workspace layout: (2*N words -- "work..." not actually used)
+* left_permutation, right_permutation, work...
+*
+ ILEFT = 1
+ IRIGHT = N + 1
+ IWORK = IRIGHT + N
+ CALL SGGBAL( 'P', N, A, LDA, B, LDB, ILO, IHI, WORK( ILEFT ),
+ $ WORK( IRIGHT ), WORK( IWORK ), IINFO )
+ IF( IINFO.NE.0 ) THEN
+ INFO = N + 1
+ GO TO 10
+ END IF
+*
+* Reduce B to triangular form, and initialize VSL and/or VSR
+* Workspace layout: ("work..." must have at least N words)
+* left_permutation, right_permutation, tau, work...
+*
+ IROWS = IHI + 1 - ILO
+ ICOLS = N + 1 - ILO
+ ITAU = IWORK
+ IWORK = ITAU + IROWS
+ CALL SGEQRF( IROWS, ICOLS, B( ILO, ILO ), LDB, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK+1-IWORK, IINFO )
+ IF( IINFO.GE.0 )
+ $ LWKOPT = MAX( LWKOPT, INT( WORK( IWORK ) )+IWORK-1 )
+ IF( IINFO.NE.0 ) THEN
+ INFO = N + 2
+ GO TO 10
+ END IF
+*
+ CALL SORMQR( 'L', 'T', IROWS, ICOLS, IROWS, B( ILO, ILO ), LDB,
+ $ WORK( ITAU ), A( ILO, ILO ), LDA, WORK( IWORK ),
+ $ LWORK+1-IWORK, IINFO )
+ IF( IINFO.GE.0 )
+ $ LWKOPT = MAX( LWKOPT, INT( WORK( IWORK ) )+IWORK-1 )
+ IF( IINFO.NE.0 ) THEN
+ INFO = N + 3
+ GO TO 10
+ END IF
+*
+ IF( ILVSL ) THEN
+ CALL SLASET( 'Full', N, N, ZERO, ONE, VSL, LDVSL )
+ CALL SLACPY( 'L', IROWS-1, IROWS-1, B( ILO+1, ILO ), LDB,
+ $ VSL( ILO+1, ILO ), LDVSL )
+ CALL SORGQR( IROWS, IROWS, IROWS, VSL( ILO, ILO ), LDVSL,
+ $ WORK( ITAU ), WORK( IWORK ), LWORK+1-IWORK,
+ $ IINFO )
+ IF( IINFO.GE.0 )
+ $ LWKOPT = MAX( LWKOPT, INT( WORK( IWORK ) )+IWORK-1 )
+ IF( IINFO.NE.0 ) THEN
+ INFO = N + 4
+ GO TO 10
+ END IF
+ END IF
+*
+ IF( ILVSR )
+ $ CALL SLASET( 'Full', N, N, ZERO, ONE, VSR, LDVSR )
+*
+* Reduce to generalized Hessenberg form
+*
+ CALL SGGHRD( JOBVSL, JOBVSR, N, ILO, IHI, A, LDA, B, LDB, VSL,
+ $ LDVSL, VSR, LDVSR, IINFO )
+ IF( IINFO.NE.0 ) THEN
+ INFO = N + 5
+ GO TO 10
+ END IF
+*
+* Perform QZ algorithm, computing Schur vectors if desired
+* Workspace layout: ("work..." must have at least 1 word)
+* left_permutation, right_permutation, work...
+*
+ IWORK = ITAU
+ CALL SHGEQZ( 'S', JOBVSL, JOBVSR, N, ILO, IHI, A, LDA, B, LDB,
+ $ ALPHAR, ALPHAI, BETA, VSL, LDVSL, VSR, LDVSR,
+ $ WORK( IWORK ), LWORK+1-IWORK, IINFO )
+ IF( IINFO.GE.0 )
+ $ LWKOPT = MAX( LWKOPT, INT( WORK( IWORK ) )+IWORK-1 )
+ IF( IINFO.NE.0 ) THEN
+ IF( IINFO.GT.0 .AND. IINFO.LE.N ) THEN
+ INFO = IINFO
+ ELSE IF( IINFO.GT.N .AND. IINFO.LE.2*N ) THEN
+ INFO = IINFO - N
+ ELSE
+ INFO = N + 6
+ END IF
+ GO TO 10
+ END IF
+*
+* Apply permutation to VSL and VSR
+*
+ IF( ILVSL ) THEN
+ CALL SGGBAK( 'P', 'L', N, ILO, IHI, WORK( ILEFT ),
+ $ WORK( IRIGHT ), N, VSL, LDVSL, IINFO )
+ IF( IINFO.NE.0 ) THEN
+ INFO = N + 7
+ GO TO 10
+ END IF
+ END IF
+ IF( ILVSR ) THEN
+ CALL SGGBAK( 'P', 'R', N, ILO, IHI, WORK( ILEFT ),
+ $ WORK( IRIGHT ), N, VSR, LDVSR, IINFO )
+ IF( IINFO.NE.0 ) THEN
+ INFO = N + 8
+ GO TO 10
+ END IF
+ END IF
+*
+* Undo scaling
+*
+ IF( ILASCL ) THEN
+ CALL SLASCL( 'H', -1, -1, ANRMTO, ANRM, N, N, A, LDA, IINFO )
+ IF( IINFO.NE.0 ) THEN
+ INFO = N + 9
+ RETURN
+ END IF
+ CALL SLASCL( 'G', -1, -1, ANRMTO, ANRM, N, 1, ALPHAR, N,
+ $ IINFO )
+ IF( IINFO.NE.0 ) THEN
+ INFO = N + 9
+ RETURN
+ END IF
+ CALL SLASCL( 'G', -1, -1, ANRMTO, ANRM, N, 1, ALPHAI, N,
+ $ IINFO )
+ IF( IINFO.NE.0 ) THEN
+ INFO = N + 9
+ RETURN
+ END IF
+ END IF
+*
+ IF( ILBSCL ) THEN
+ CALL SLASCL( 'U', -1, -1, BNRMTO, BNRM, N, N, B, LDB, IINFO )
+ IF( IINFO.NE.0 ) THEN
+ INFO = N + 9
+ RETURN
+ END IF
+ CALL SLASCL( 'G', -1, -1, BNRMTO, BNRM, N, 1, BETA, N, IINFO )
+ IF( IINFO.NE.0 ) THEN
+ INFO = N + 9
+ RETURN
+ END IF
+ END IF
+*
+ 10 CONTINUE
+ WORK( 1 ) = LWKOPT
+*
+ RETURN
+*
+* End of SGEGS
+*
+ END
+ SUBROUTINE SGEGV( JOBVL, JOBVR, N, A, LDA, B, LDB, ALPHAR, ALPHAI,
+ $ BETA, VL, LDVL, VR, LDVR, WORK, LWORK, INFO )
+*
+* -- LAPACK driver routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER JOBVL, JOBVR
+ INTEGER INFO, LDA, LDB, LDVL, LDVR, LWORK, N
+* ..
+* .. Array Arguments ..
+ REAL A( LDA, * ), ALPHAI( * ), ALPHAR( * ),
+ $ B( LDB, * ), BETA( * ), VL( LDVL, * ),
+ $ VR( LDVR, * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* This routine is deprecated and has been replaced by routine SGGEV.
+*
+* SGEGV computes the eigenvalues and, optionally, the left and/or right
+* eigenvectors of a real matrix pair (A,B).
+* Given two square matrices A and B,
+* the generalized nonsymmetric eigenvalue problem (GNEP) is to find the
+* eigenvalues lambda and corresponding (non-zero) eigenvectors x such
+* that
+*
+* A*x = lambda*B*x.
+*
+* An alternate form is to find the eigenvalues mu and corresponding
+* eigenvectors y such that
+*
+* mu*A*y = B*y.
+*
+* These two forms are equivalent with mu = 1/lambda and x = y if
+* neither lambda nor mu is zero. In order to deal with the case that
+* lambda or mu is zero or small, two values alpha and beta are returned
+* for each eigenvalue, such that lambda = alpha/beta and
+* mu = beta/alpha.
+*
+* The vectors x and y in the above equations are right eigenvectors of
+* the matrix pair (A,B). Vectors u and v satisfying
+*
+* u**H*A = lambda*u**H*B or mu*v**H*A = v**H*B
+*
+* are left eigenvectors of (A,B).
+*
+* Note: this routine performs "full balancing" on A and B -- see
+* "Further Details", below.
+*
+* Arguments
+* =========
+*
+* JOBVL (input) CHARACTER*1
+* = 'N': do not compute the left generalized eigenvectors;
+* = 'V': compute the left generalized eigenvectors (returned
+* in VL).
+*
+* JOBVR (input) CHARACTER*1
+* = 'N': do not compute the right generalized eigenvectors;
+* = 'V': compute the right generalized eigenvectors (returned
+* in VR).
+*
+* N (input) INTEGER
+* The order of the matrices A, B, VL, and VR. N >= 0.
+*
+* A (input/output) REAL array, dimension (LDA, N)
+* On entry, the matrix A.
+* If JOBVL = 'V' or JOBVR = 'V', then on exit A
+* contains the real Schur form of A from the generalized Schur
+* factorization of the pair (A,B) after balancing.
+* If no eigenvectors were computed, then only the diagonal
+* blocks from the Schur form will be correct. See SGGHRD and
+* SHGEQZ for details.
+*
+* LDA (input) INTEGER
+* The leading dimension of A. LDA >= max(1,N).
+*
+* B (input/output) REAL array, dimension (LDB, N)
+* On entry, the matrix B.
+* If JOBVL = 'V' or JOBVR = 'V', then on exit B contains the
+* upper triangular matrix obtained from B in the generalized
+* Schur factorization of the pair (A,B) after balancing.
+* If no eigenvectors were computed, then only those elements of
+* B corresponding to the diagonal blocks from the Schur form of
+* A will be correct. See SGGHRD and SHGEQZ for details.
+*
+* LDB (input) INTEGER
+* The leading dimension of B. LDB >= max(1,N).
+*
+* ALPHAR (output) REAL array, dimension (N)
+* The real parts of each scalar alpha defining an eigenvalue of
+* GNEP.
+*
+* ALPHAI (output) REAL array, dimension (N)
+* The imaginary parts of each scalar alpha defining an
+* eigenvalue of GNEP. If ALPHAI(j) is zero, then the j-th
+* eigenvalue is real; if positive, then the j-th and
+* (j+1)-st eigenvalues are a complex conjugate pair, with
+* ALPHAI(j+1) = -ALPHAI(j).
+*
+* BETA (output) REAL array, dimension (N)
+* The scalars beta that define the eigenvalues of GNEP.
+*
+* Together, the quantities alpha = (ALPHAR(j),ALPHAI(j)) and
+* beta = BETA(j) represent the j-th eigenvalue of the matrix
+* pair (A,B), in one of the forms lambda = alpha/beta or
+* mu = beta/alpha. Since either lambda or mu may overflow,
+* they should not, in general, be computed.
+*
+* VL (output) REAL array, dimension (LDVL,N)
+* If JOBVL = 'V', the left eigenvectors u(j) are stored
+* in the columns of VL, in the same order as their eigenvalues.
+* If the j-th eigenvalue is real, then u(j) = VL(:,j).
+* If the j-th and (j+1)-st eigenvalues form a complex conjugate
+* pair, then
+* u(j) = VL(:,j) + i*VL(:,j+1)
+* and
+* u(j+1) = VL(:,j) - i*VL(:,j+1).
+*
+* Each eigenvector is scaled so that its largest component has
+* abs(real part) + abs(imag. part) = 1, except for eigenvectors
+* corresponding to an eigenvalue with alpha = beta = 0, which
+* are set to zero.
+* Not referenced if JOBVL = 'N'.
+*
+* LDVL (input) INTEGER
+* The leading dimension of the matrix VL. LDVL >= 1, and
+* if JOBVL = 'V', LDVL >= N.
+*
+* VR (output) REAL array, dimension (LDVR,N)
+* If JOBVR = 'V', the right eigenvectors x(j) are stored
+* in the columns of VR, in the same order as their eigenvalues.
+* If the j-th eigenvalue is real, then x(j) = VR(:,j).
+* If the j-th and (j+1)-st eigenvalues form a complex conjugate
+* pair, then
+* x(j) = VR(:,j) + i*VR(:,j+1)
+* and
+* x(j+1) = VR(:,j) - i*VR(:,j+1).
+*
+* Each eigenvector is scaled so that its largest component has
+* abs(real part) + abs(imag. part) = 1, except for eigenvalues
+* corresponding to an eigenvalue with alpha = beta = 0, which
+* are set to zero.
+* Not referenced if JOBVR = 'N'.
+*
+* LDVR (input) INTEGER
+* The leading dimension of the matrix VR. LDVR >= 1, and
+* if JOBVR = 'V', LDVR >= N.
+*
+* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))
+* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+* LWORK (input) INTEGER
+* The dimension of the array WORK. LWORK >= max(1,8*N).
+* For good performance, LWORK must generally be larger.
+* To compute the optimal value of LWORK, call ILAENV to get
+* blocksizes (for SGEQRF, SORMQR, and SORGQR.) Then compute:
+* NB -- MAX of the blocksizes for SGEQRF, SORMQR, and SORGQR;
+* The optimal LWORK is:
+* 2*N + MAX( 6*N, N*(NB+1) ).
+*
+* If LWORK = -1, then a workspace query is assumed; the routine
+* only calculates the optimal size of the WORK array, returns
+* this value as the first entry of the WORK array, and no error
+* message related to LWORK is issued by XERBLA.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value.
+* = 1,...,N:
+* The QZ iteration failed. No eigenvectors have been
+* calculated, but ALPHAR(j), ALPHAI(j), and BETA(j)
+* should be correct for j=INFO+1,...,N.
+* > N: errors that usually indicate LAPACK problems:
+* =N+1: error return from SGGBAL
+* =N+2: error return from SGEQRF
+* =N+3: error return from SORMQR
+* =N+4: error return from SORGQR
+* =N+5: error return from SGGHRD
+* =N+6: error return from SHGEQZ (other than failed
+* iteration)
+* =N+7: error return from STGEVC
+* =N+8: error return from SGGBAK (computing VL)
+* =N+9: error return from SGGBAK (computing VR)
+* =N+10: error return from SLASCL (various calls)
+*
+* Further Details
+* ===============
+*
+* Balancing
+* ---------
+*
+* This driver calls SGGBAL to both permute and scale rows and columns
+* of A and B. The permutations PL and PR are chosen so that PL*A*PR
+* and PL*B*R will be upper triangular except for the diagonal blocks
+* A(i:j,i:j) and B(i:j,i:j), with i and j as close together as
+* possible. The diagonal scaling matrices DL and DR are chosen so
+* that the pair DL*PL*A*PR*DR, DL*PL*B*PR*DR have elements close to
+* one (except for the elements that start out zero.)
+*
+* After the eigenvalues and eigenvectors of the balanced matrices
+* have been computed, SGGBAK transforms the eigenvectors back to what
+* they would have been (in perfect arithmetic) if they had not been
+* balanced.
+*
+* Contents of A and B on Exit
+* -------- -- - --- - -- ----
+*
+* If any eigenvectors are computed (either JOBVL='V' or JOBVR='V' or
+* both), then on exit the arrays A and B will contain the real Schur
+* form[*] of the "balanced" versions of A and B. If no eigenvectors
+* are computed, then only the diagonal blocks will be correct.
+*
+* [*] See SHGEQZ, SGEGS, or read the book "Matrix Computations",
+* by Golub & van Loan, pub. by Johns Hopkins U. Press.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO, ONE
+ PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL ILIMIT, ILV, ILVL, ILVR, LQUERY
+ CHARACTER CHTEMP
+ INTEGER ICOLS, IHI, IINFO, IJOBVL, IJOBVR, ILEFT, ILO,
+ $ IN, IRIGHT, IROWS, ITAU, IWORK, JC, JR, LOPT,
+ $ LWKMIN, LWKOPT, NB, NB1, NB2, NB3
+ REAL ABSAI, ABSAR, ABSB, ANRM, ANRM1, ANRM2, BNRM,
+ $ BNRM1, BNRM2, EPS, ONEPLS, SAFMAX, SAFMIN,
+ $ SALFAI, SALFAR, SBETA, SCALE, TEMP
+* ..
+* .. Local Arrays ..
+ LOGICAL LDUMMA( 1 )
+* ..
+* .. External Subroutines ..
+ EXTERNAL SGEQRF, SGGBAK, SGGBAL, SGGHRD, SHGEQZ, SLACPY,
+ $ SLASCL, SLASET, SORGQR, SORMQR, STGEVC, XERBLA
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ILAENV
+ REAL SLAMCH, SLANGE
+ EXTERNAL ILAENV, LSAME, SLAMCH, SLANGE
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, INT, MAX
+* ..
+* .. Executable Statements ..
+*
+* Decode the input arguments
+*
+ IF( LSAME( JOBVL, 'N' ) ) THEN
+ IJOBVL = 1
+ ILVL = .FALSE.
+ ELSE IF( LSAME( JOBVL, 'V' ) ) THEN
+ IJOBVL = 2
+ ILVL = .TRUE.
+ ELSE
+ IJOBVL = -1
+ ILVL = .FALSE.
+ END IF
+*
+ IF( LSAME( JOBVR, 'N' ) ) THEN
+ IJOBVR = 1
+ ILVR = .FALSE.
+ ELSE IF( LSAME( JOBVR, 'V' ) ) THEN
+ IJOBVR = 2
+ ILVR = .TRUE.
+ ELSE
+ IJOBVR = -1
+ ILVR = .FALSE.
+ END IF
+ ILV = ILVL .OR. ILVR
+*
+* Test the input arguments
+*
+ LWKMIN = MAX( 8*N, 1 )
+ LWKOPT = LWKMIN
+ WORK( 1 ) = LWKOPT
+ LQUERY = ( LWORK.EQ.-1 )
+ INFO = 0
+ IF( IJOBVL.LE.0 ) THEN
+ INFO = -1
+ ELSE IF( IJOBVR.LE.0 ) THEN
+ INFO = -2
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -5
+ ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -7
+ ELSE IF( LDVL.LT.1 .OR. ( ILVL .AND. LDVL.LT.N ) ) THEN
+ INFO = -12
+ ELSE IF( LDVR.LT.1 .OR. ( ILVR .AND. LDVR.LT.N ) ) THEN
+ INFO = -14
+ ELSE IF( LWORK.LT.LWKMIN .AND. .NOT.LQUERY ) THEN
+ INFO = -16
+ END IF
+*
+ IF( INFO.EQ.0 ) THEN
+ NB1 = ILAENV( 1, 'SGEQRF', ' ', N, N, -1, -1 )
+ NB2 = ILAENV( 1, 'SORMQR', ' ', N, N, N, -1 )
+ NB3 = ILAENV( 1, 'SORGQR', ' ', N, N, N, -1 )
+ NB = MAX( NB1, NB2, NB3 )
+ LOPT = 2*N + MAX( 6*N, N*(NB+1) )
+ WORK( 1 ) = LOPT
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SGEGV ', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+* Get machine constants
+*
+ EPS = SLAMCH( 'E' )*SLAMCH( 'B' )
+ SAFMIN = SLAMCH( 'S' )
+ SAFMIN = SAFMIN + SAFMIN
+ SAFMAX = ONE / SAFMIN
+ ONEPLS = ONE + ( 4*EPS )
+*
+* Scale A
+*
+ ANRM = SLANGE( 'M', N, N, A, LDA, WORK )
+ ANRM1 = ANRM
+ ANRM2 = ONE
+ IF( ANRM.LT.ONE ) THEN
+ IF( SAFMAX*ANRM.LT.ONE ) THEN
+ ANRM1 = SAFMIN
+ ANRM2 = SAFMAX*ANRM
+ END IF
+ END IF
+*
+ IF( ANRM.GT.ZERO ) THEN
+ CALL SLASCL( 'G', -1, -1, ANRM, ONE, N, N, A, LDA, IINFO )
+ IF( IINFO.NE.0 ) THEN
+ INFO = N + 10
+ RETURN
+ END IF
+ END IF
+*
+* Scale B
+*
+ BNRM = SLANGE( 'M', N, N, B, LDB, WORK )
+ BNRM1 = BNRM
+ BNRM2 = ONE
+ IF( BNRM.LT.ONE ) THEN
+ IF( SAFMAX*BNRM.LT.ONE ) THEN
+ BNRM1 = SAFMIN
+ BNRM2 = SAFMAX*BNRM
+ END IF
+ END IF
+*
+ IF( BNRM.GT.ZERO ) THEN
+ CALL SLASCL( 'G', -1, -1, BNRM, ONE, N, N, B, LDB, IINFO )
+ IF( IINFO.NE.0 ) THEN
+ INFO = N + 10
+ RETURN
+ END IF
+ END IF
+*
+* Permute the matrix to make it more nearly triangular
+* Workspace layout: (8*N words -- "work" requires 6*N words)
+* left_permutation, right_permutation, work...
+*
+ ILEFT = 1
+ IRIGHT = N + 1
+ IWORK = IRIGHT + N
+ CALL SGGBAL( 'P', N, A, LDA, B, LDB, ILO, IHI, WORK( ILEFT ),
+ $ WORK( IRIGHT ), WORK( IWORK ), IINFO )
+ IF( IINFO.NE.0 ) THEN
+ INFO = N + 1
+ GO TO 120
+ END IF
+*
+* Reduce B to triangular form, and initialize VL and/or VR
+* Workspace layout: ("work..." must have at least N words)
+* left_permutation, right_permutation, tau, work...
+*
+ IROWS = IHI + 1 - ILO
+ IF( ILV ) THEN
+ ICOLS = N + 1 - ILO
+ ELSE
+ ICOLS = IROWS
+ END IF
+ ITAU = IWORK
+ IWORK = ITAU + IROWS
+ CALL SGEQRF( IROWS, ICOLS, B( ILO, ILO ), LDB, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK+1-IWORK, IINFO )
+ IF( IINFO.GE.0 )
+ $ LWKOPT = MAX( LWKOPT, INT( WORK( IWORK ) )+IWORK-1 )
+ IF( IINFO.NE.0 ) THEN
+ INFO = N + 2
+ GO TO 120
+ END IF
+*
+ CALL SORMQR( 'L', 'T', IROWS, ICOLS, IROWS, B( ILO, ILO ), LDB,
+ $ WORK( ITAU ), A( ILO, ILO ), LDA, WORK( IWORK ),
+ $ LWORK+1-IWORK, IINFO )
+ IF( IINFO.GE.0 )
+ $ LWKOPT = MAX( LWKOPT, INT( WORK( IWORK ) )+IWORK-1 )
+ IF( IINFO.NE.0 ) THEN
+ INFO = N + 3
+ GO TO 120
+ END IF
+*
+ IF( ILVL ) THEN
+ CALL SLASET( 'Full', N, N, ZERO, ONE, VL, LDVL )
+ CALL SLACPY( 'L', IROWS-1, IROWS-1, B( ILO+1, ILO ), LDB,
+ $ VL( ILO+1, ILO ), LDVL )
+ CALL SORGQR( IROWS, IROWS, IROWS, VL( ILO, ILO ), LDVL,
+ $ WORK( ITAU ), WORK( IWORK ), LWORK+1-IWORK,
+ $ IINFO )
+ IF( IINFO.GE.0 )
+ $ LWKOPT = MAX( LWKOPT, INT( WORK( IWORK ) )+IWORK-1 )
+ IF( IINFO.NE.0 ) THEN
+ INFO = N + 4
+ GO TO 120
+ END IF
+ END IF
+*
+ IF( ILVR )
+ $ CALL SLASET( 'Full', N, N, ZERO, ONE, VR, LDVR )
+*
+* Reduce to generalized Hessenberg form
+*
+ IF( ILV ) THEN
+*
+* Eigenvectors requested -- work on whole matrix.
+*
+ CALL SGGHRD( JOBVL, JOBVR, N, ILO, IHI, A, LDA, B, LDB, VL,
+ $ LDVL, VR, LDVR, IINFO )
+ ELSE
+ CALL SGGHRD( 'N', 'N', IROWS, 1, IROWS, A( ILO, ILO ), LDA,
+ $ B( ILO, ILO ), LDB, VL, LDVL, VR, LDVR, IINFO )
+ END IF
+ IF( IINFO.NE.0 ) THEN
+ INFO = N + 5
+ GO TO 120
+ END IF
+*
+* Perform QZ algorithm
+* Workspace layout: ("work..." must have at least 1 word)
+* left_permutation, right_permutation, work...
+*
+ IWORK = ITAU
+ IF( ILV ) THEN
+ CHTEMP = 'S'
+ ELSE
+ CHTEMP = 'E'
+ END IF
+ CALL SHGEQZ( CHTEMP, JOBVL, JOBVR, N, ILO, IHI, A, LDA, B, LDB,
+ $ ALPHAR, ALPHAI, BETA, VL, LDVL, VR, LDVR,
+ $ WORK( IWORK ), LWORK+1-IWORK, IINFO )
+ IF( IINFO.GE.0 )
+ $ LWKOPT = MAX( LWKOPT, INT( WORK( IWORK ) )+IWORK-1 )
+ IF( IINFO.NE.0 ) THEN
+ IF( IINFO.GT.0 .AND. IINFO.LE.N ) THEN
+ INFO = IINFO
+ ELSE IF( IINFO.GT.N .AND. IINFO.LE.2*N ) THEN
+ INFO = IINFO - N
+ ELSE
+ INFO = N + 6
+ END IF
+ GO TO 120
+ END IF
+*
+ IF( ILV ) THEN
+*
+* Compute Eigenvectors (STGEVC requires 6*N words of workspace)
+*
+ IF( ILVL ) THEN
+ IF( ILVR ) THEN
+ CHTEMP = 'B'
+ ELSE
+ CHTEMP = 'L'
+ END IF
+ ELSE
+ CHTEMP = 'R'
+ END IF
+*
+ CALL STGEVC( CHTEMP, 'B', LDUMMA, N, A, LDA, B, LDB, VL, LDVL,
+ $ VR, LDVR, N, IN, WORK( IWORK ), IINFO )
+ IF( IINFO.NE.0 ) THEN
+ INFO = N + 7
+ GO TO 120
+ END IF
+*
+* Undo balancing on VL and VR, rescale
+*
+ IF( ILVL ) THEN
+ CALL SGGBAK( 'P', 'L', N, ILO, IHI, WORK( ILEFT ),
+ $ WORK( IRIGHT ), N, VL, LDVL, IINFO )
+ IF( IINFO.NE.0 ) THEN
+ INFO = N + 8
+ GO TO 120
+ END IF
+ DO 50 JC = 1, N
+ IF( ALPHAI( JC ).LT.ZERO )
+ $ GO TO 50
+ TEMP = ZERO
+ IF( ALPHAI( JC ).EQ.ZERO ) THEN
+ DO 10 JR = 1, N
+ TEMP = MAX( TEMP, ABS( VL( JR, JC ) ) )
+ 10 CONTINUE
+ ELSE
+ DO 20 JR = 1, N
+ TEMP = MAX( TEMP, ABS( VL( JR, JC ) )+
+ $ ABS( VL( JR, JC+1 ) ) )
+ 20 CONTINUE
+ END IF
+ IF( TEMP.LT.SAFMIN )
+ $ GO TO 50
+ TEMP = ONE / TEMP
+ IF( ALPHAI( JC ).EQ.ZERO ) THEN
+ DO 30 JR = 1, N
+ VL( JR, JC ) = VL( JR, JC )*TEMP
+ 30 CONTINUE
+ ELSE
+ DO 40 JR = 1, N
+ VL( JR, JC ) = VL( JR, JC )*TEMP
+ VL( JR, JC+1 ) = VL( JR, JC+1 )*TEMP
+ 40 CONTINUE
+ END IF
+ 50 CONTINUE
+ END IF
+ IF( ILVR ) THEN
+ CALL SGGBAK( 'P', 'R', N, ILO, IHI, WORK( ILEFT ),
+ $ WORK( IRIGHT ), N, VR, LDVR, IINFO )
+ IF( IINFO.NE.0 ) THEN
+ INFO = N + 9
+ GO TO 120
+ END IF
+ DO 100 JC = 1, N
+ IF( ALPHAI( JC ).LT.ZERO )
+ $ GO TO 100
+ TEMP = ZERO
+ IF( ALPHAI( JC ).EQ.ZERO ) THEN
+ DO 60 JR = 1, N
+ TEMP = MAX( TEMP, ABS( VR( JR, JC ) ) )
+ 60 CONTINUE
+ ELSE
+ DO 70 JR = 1, N
+ TEMP = MAX( TEMP, ABS( VR( JR, JC ) )+
+ $ ABS( VR( JR, JC+1 ) ) )
+ 70 CONTINUE
+ END IF
+ IF( TEMP.LT.SAFMIN )
+ $ GO TO 100
+ TEMP = ONE / TEMP
+ IF( ALPHAI( JC ).EQ.ZERO ) THEN
+ DO 80 JR = 1, N
+ VR( JR, JC ) = VR( JR, JC )*TEMP
+ 80 CONTINUE
+ ELSE
+ DO 90 JR = 1, N
+ VR( JR, JC ) = VR( JR, JC )*TEMP
+ VR( JR, JC+1 ) = VR( JR, JC+1 )*TEMP
+ 90 CONTINUE
+ END IF
+ 100 CONTINUE
+ END IF
+*
+* End of eigenvector calculation
+*
+ END IF
+*
+* Undo scaling in alpha, beta
+*
+* Note: this does not give the alpha and beta for the unscaled
+* problem.
+*
+* Un-scaling is limited to avoid underflow in alpha and beta
+* if they are significant.
+*
+ DO 110 JC = 1, N
+ ABSAR = ABS( ALPHAR( JC ) )
+ ABSAI = ABS( ALPHAI( JC ) )
+ ABSB = ABS( BETA( JC ) )
+ SALFAR = ANRM*ALPHAR( JC )
+ SALFAI = ANRM*ALPHAI( JC )
+ SBETA = BNRM*BETA( JC )
+ ILIMIT = .FALSE.
+ SCALE = ONE
+*
+* Check for significant underflow in ALPHAI
+*
+ IF( ABS( SALFAI ).LT.SAFMIN .AND. ABSAI.GE.
+ $ MAX( SAFMIN, EPS*ABSAR, EPS*ABSB ) ) THEN
+ ILIMIT = .TRUE.
+ SCALE = ( ONEPLS*SAFMIN / ANRM1 ) /
+ $ MAX( ONEPLS*SAFMIN, ANRM2*ABSAI )
+*
+ ELSE IF( SALFAI.EQ.ZERO ) THEN
+*
+* If insignificant underflow in ALPHAI, then make the
+* conjugate eigenvalue real.
+*
+ IF( ALPHAI( JC ).LT.ZERO .AND. JC.GT.1 ) THEN
+ ALPHAI( JC-1 ) = ZERO
+ ELSE IF( ALPHAI( JC ).GT.ZERO .AND. JC.LT.N ) THEN
+ ALPHAI( JC+1 ) = ZERO
+ END IF
+ END IF
+*
+* Check for significant underflow in ALPHAR
+*
+ IF( ABS( SALFAR ).LT.SAFMIN .AND. ABSAR.GE.
+ $ MAX( SAFMIN, EPS*ABSAI, EPS*ABSB ) ) THEN
+ ILIMIT = .TRUE.
+ SCALE = MAX( SCALE, ( ONEPLS*SAFMIN / ANRM1 ) /
+ $ MAX( ONEPLS*SAFMIN, ANRM2*ABSAR ) )
+ END IF
+*
+* Check for significant underflow in BETA
+*
+ IF( ABS( SBETA ).LT.SAFMIN .AND. ABSB.GE.
+ $ MAX( SAFMIN, EPS*ABSAR, EPS*ABSAI ) ) THEN
+ ILIMIT = .TRUE.
+ SCALE = MAX( SCALE, ( ONEPLS*SAFMIN / BNRM1 ) /
+ $ MAX( ONEPLS*SAFMIN, BNRM2*ABSB ) )
+ END IF
+*
+* Check for possible overflow when limiting scaling
+*
+ IF( ILIMIT ) THEN
+ TEMP = ( SCALE*SAFMIN )*MAX( ABS( SALFAR ), ABS( SALFAI ),
+ $ ABS( SBETA ) )
+ IF( TEMP.GT.ONE )
+ $ SCALE = SCALE / TEMP
+ IF( SCALE.LT.ONE )
+ $ ILIMIT = .FALSE.
+ END IF
+*
+* Recompute un-scaled ALPHAR, ALPHAI, BETA if necessary.
+*
+ IF( ILIMIT ) THEN
+ SALFAR = ( SCALE*ALPHAR( JC ) )*ANRM
+ SALFAI = ( SCALE*ALPHAI( JC ) )*ANRM
+ SBETA = ( SCALE*BETA( JC ) )*BNRM
+ END IF
+ ALPHAR( JC ) = SALFAR
+ ALPHAI( JC ) = SALFAI
+ BETA( JC ) = SBETA
+ 110 CONTINUE
+*
+ 120 CONTINUE
+ WORK( 1 ) = LWKOPT
+*
+ RETURN
+*
+* End of SGEGV
+*
+ END
+ SUBROUTINE SGEHD2( N, ILO, IHI, A, LDA, TAU, WORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER IHI, ILO, INFO, LDA, N
+* ..
+* .. Array Arguments ..
+ REAL A( LDA, * ), TAU( * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SGEHD2 reduces a real general matrix A to upper Hessenberg form H by
+* an orthogonal similarity transformation: Q' * A * Q = H .
+*
+* Arguments
+* =========
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* ILO (input) INTEGER
+* IHI (input) INTEGER
+* It is assumed that A is already upper triangular in rows
+* and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally
+* set by a previous call to SGEBAL; otherwise they should be
+* set to 1 and N respectively. See Further Details.
+* 1 <= ILO <= IHI <= max(1,N).
+*
+* A (input/output) REAL array, dimension (LDA,N)
+* On entry, the n by n general matrix to be reduced.
+* On exit, the upper triangle and the first subdiagonal of A
+* are overwritten with the upper Hessenberg matrix H, and the
+* elements below the first subdiagonal, with the array TAU,
+* represent the orthogonal matrix Q as a product of elementary
+* reflectors. See Further Details.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,N).
+*
+* TAU (output) REAL array, dimension (N-1)
+* The scalar factors of the elementary reflectors (see Further
+* Details).
+*
+* WORK (workspace) REAL array, dimension (N)
+*
+* INFO (output) INTEGER
+* = 0: successful exit.
+* < 0: if INFO = -i, the i-th argument had an illegal value.
+*
+* Further Details
+* ===============
+*
+* The matrix Q is represented as a product of (ihi-ilo) elementary
+* reflectors
+*
+* Q = H(ilo) H(ilo+1) . . . H(ihi-1).
+*
+* Each H(i) has the form
+*
+* H(i) = I - tau * v * v'
+*
+* where tau is a real scalar, and v is a real vector with
+* v(1:i) = 0, v(i+1) = 1 and v(ihi+1:n) = 0; v(i+2:ihi) is stored on
+* exit in A(i+2:ihi,i), and tau in TAU(i).
+*
+* The contents of A are illustrated by the following example, with
+* n = 7, ilo = 2 and ihi = 6:
+*
+* on entry, on exit,
+*
+* ( a a a a a a a ) ( a a h h h h a )
+* ( a a a a a a ) ( a h h h h a )
+* ( a a a a a a ) ( h h h h h h )
+* ( a a a a a a ) ( v2 h h h h h )
+* ( a a a a a a ) ( v2 v3 h h h h )
+* ( a a a a a a ) ( v2 v3 v4 h h h )
+* ( a ) ( a )
+*
+* where a denotes an element of the original matrix A, h denotes a
+* modified element of the upper Hessenberg matrix H, and vi denotes an
+* element of the vector defining H(i).
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ONE
+ PARAMETER ( ONE = 1.0E+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I
+ REAL AII
+* ..
+* .. External Subroutines ..
+ EXTERNAL SLARF, SLARFG, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters
+*
+ INFO = 0
+ IF( N.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN
+ INFO = -2
+ ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN
+ INFO = -3
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -5
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SGEHD2', -INFO )
+ RETURN
+ END IF
+*
+ DO 10 I = ILO, IHI - 1
+*
+* Compute elementary reflector H(i) to annihilate A(i+2:ihi,i)
+*
+ CALL SLARFG( IHI-I, A( I+1, I ), A( MIN( I+2, N ), I ), 1,
+ $ TAU( I ) )
+ AII = A( I+1, I )
+ A( I+1, I ) = ONE
+*
+* Apply H(i) to A(1:ihi,i+1:ihi) from the right
+*
+ CALL SLARF( 'Right', IHI, IHI-I, A( I+1, I ), 1, TAU( I ),
+ $ A( 1, I+1 ), LDA, WORK )
+*
+* Apply H(i) to A(i+1:ihi,i+1:n) from the left
+*
+ CALL SLARF( 'Left', IHI-I, N-I, A( I+1, I ), 1, TAU( I ),
+ $ A( I+1, I+1 ), LDA, WORK )
+*
+ A( I+1, I ) = AII
+ 10 CONTINUE
+*
+ RETURN
+*
+* End of SGEHD2
+*
+ END
+ SUBROUTINE SGEHRD( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER IHI, ILO, INFO, LDA, LWORK, N
+* ..
+* .. Array Arguments ..
+ REAL A( LDA, * ), TAU( * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SGEHRD reduces a real general matrix A to upper Hessenberg form H by
+* an orthogonal similarity transformation: Q' * A * Q = H .
+*
+* Arguments
+* =========
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* ILO (input) INTEGER
+* IHI (input) INTEGER
+* It is assumed that A is already upper triangular in rows
+* and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally
+* set by a previous call to SGEBAL; otherwise they should be
+* set to 1 and N respectively. See Further Details.
+* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.
+*
+* A (input/output) REAL array, dimension (LDA,N)
+* On entry, the N-by-N general matrix to be reduced.
+* On exit, the upper triangle and the first subdiagonal of A
+* are overwritten with the upper Hessenberg matrix H, and the
+* elements below the first subdiagonal, with the array TAU,
+* represent the orthogonal matrix Q as a product of elementary
+* reflectors. See Further Details.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,N).
+*
+* TAU (output) REAL array, dimension (N-1)
+* The scalar factors of the elementary reflectors (see Further
+* Details). Elements 1:ILO-1 and IHI:N-1 of TAU are set to
+* zero.
+*
+* WORK (workspace/output) REAL array, dimension (LWORK)
+* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+* LWORK (input) INTEGER
+* The length of the array WORK. LWORK >= max(1,N).
+* For optimum performance LWORK >= N*NB, where NB is the
+* optimal blocksize.
+*
+* If LWORK = -1, then a workspace query is assumed; the routine
+* only calculates the optimal size of the WORK array, returns
+* this value as the first entry of the WORK array, and no error
+* message related to LWORK is issued by XERBLA.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value.
+*
+* Further Details
+* ===============
+*
+* The matrix Q is represented as a product of (ihi-ilo) elementary
+* reflectors
+*
+* Q = H(ilo) H(ilo+1) . . . H(ihi-1).
+*
+* Each H(i) has the form
+*
+* H(i) = I - tau * v * v'
+*
+* where tau is a real scalar, and v is a real vector with
+* v(1:i) = 0, v(i+1) = 1 and v(ihi+1:n) = 0; v(i+2:ihi) is stored on
+* exit in A(i+2:ihi,i), and tau in TAU(i).
+*
+* The contents of A are illustrated by the following example, with
+* n = 7, ilo = 2 and ihi = 6:
+*
+* on entry, on exit,
+*
+* ( a a a a a a a ) ( a a h h h h a )
+* ( a a a a a a ) ( a h h h h a )
+* ( a a a a a a ) ( h h h h h h )
+* ( a a a a a a ) ( v2 h h h h h )
+* ( a a a a a a ) ( v2 v3 h h h h )
+* ( a a a a a a ) ( v2 v3 v4 h h h )
+* ( a ) ( a )
+*
+* where a denotes an element of the original matrix A, h denotes a
+* modified element of the upper Hessenberg matrix H, and vi denotes an
+* element of the vector defining H(i).
+*
+* This file is a slight modification of LAPACK-3.0's SGEHRD
+* subroutine incorporating improvements proposed by Quintana-Orti and
+* Van de Geijn (2005).
+*
+* =====================================================================
+*
+* .. Parameters ..
+ INTEGER NBMAX, LDT
+ PARAMETER ( NBMAX = 64, LDT = NBMAX+1 )
+ REAL ZERO, ONE
+ PARAMETER ( ZERO = 0.0E+0,
+ $ ONE = 1.0E+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL LQUERY
+ INTEGER I, IB, IINFO, IWS, J, LDWORK, LWKOPT, NB,
+ $ NBMIN, NH, NX
+ REAL EI
+* ..
+* .. Local Arrays ..
+ REAL T( LDT, NBMAX )
+* ..
+* .. External Subroutines ..
+ EXTERNAL SAXPY, SGEHD2, SGEMM, SLAHR2, SLARFB, STRMM,
+ $ XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN
+* ..
+* .. External Functions ..
+ INTEGER ILAENV
+ EXTERNAL ILAENV
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters
+*
+ INFO = 0
+ NB = MIN( NBMAX, ILAENV( 1, 'SGEHRD', ' ', N, ILO, IHI, -1 ) )
+ LWKOPT = N*NB
+ WORK( 1 ) = LWKOPT
+ LQUERY = ( LWORK.EQ.-1 )
+ IF( N.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN
+ INFO = -2
+ ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN
+ INFO = -3
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -5
+ ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN
+ INFO = -8
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SGEHRD', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Set elements 1:ILO-1 and IHI:N-1 of TAU to zero
+*
+ DO 10 I = 1, ILO - 1
+ TAU( I ) = ZERO
+ 10 CONTINUE
+ DO 20 I = MAX( 1, IHI ), N - 1
+ TAU( I ) = ZERO
+ 20 CONTINUE
+*
+* Quick return if possible
+*
+ NH = IHI - ILO + 1
+ IF( NH.LE.1 ) THEN
+ WORK( 1 ) = 1
+ RETURN
+ END IF
+*
+* Determine the block size
+*
+ NB = MIN( NBMAX, ILAENV( 1, 'SGEHRD', ' ', N, ILO, IHI, -1 ) )
+ NBMIN = 2
+ IWS = 1
+ IF( NB.GT.1 .AND. NB.LT.NH ) THEN
+*
+* Determine when to cross over from blocked to unblocked code
+* (last block is always handled by unblocked code)
+*
+ NX = MAX( NB, ILAENV( 3, 'SGEHRD', ' ', N, ILO, IHI, -1 ) )
+ IF( NX.LT.NH ) THEN
+*
+* Determine if workspace is large enough for blocked code
+*
+ IWS = N*NB
+ IF( LWORK.LT.IWS ) THEN
+*
+* Not enough workspace to use optimal NB: determine the
+* minimum value of NB, and reduce NB or force use of
+* unblocked code
+*
+ NBMIN = MAX( 2, ILAENV( 2, 'SGEHRD', ' ', N, ILO, IHI,
+ $ -1 ) )
+ IF( LWORK.GE.N*NBMIN ) THEN
+ NB = LWORK / N
+ ELSE
+ NB = 1
+ END IF
+ END IF
+ END IF
+ END IF
+ LDWORK = N
+*
+ IF( NB.LT.NBMIN .OR. NB.GE.NH ) THEN
+*
+* Use unblocked code below
+*
+ I = ILO
+*
+ ELSE
+*
+* Use blocked code
+*
+ DO 40 I = ILO, IHI - 1 - NX, NB
+ IB = MIN( NB, IHI-I )
+*
+* Reduce columns i:i+ib-1 to Hessenberg form, returning the
+* matrices V and T of the block reflector H = I - V*T*V'
+* which performs the reduction, and also the matrix Y = A*V*T
+*
+ CALL SLAHR2( IHI, I, IB, A( 1, I ), LDA, TAU( I ), T, LDT,
+ $ WORK, LDWORK )
+*
+* Apply the block reflector H to A(1:ihi,i+ib:ihi) from the
+* right, computing A := A - Y * V'. V(i+ib,ib-1) must be set
+* to 1
+*
+ EI = A( I+IB, I+IB-1 )
+ A( I+IB, I+IB-1 ) = ONE
+ CALL SGEMM( 'No transpose', 'Transpose',
+ $ IHI, IHI-I-IB+1,
+ $ IB, -ONE, WORK, LDWORK, A( I+IB, I ), LDA, ONE,
+ $ A( 1, I+IB ), LDA )
+ A( I+IB, I+IB-1 ) = EI
+*
+* Apply the block reflector H to A(1:i,i+1:i+ib-1) from the
+* right
+*
+ CALL STRMM( 'Right', 'Lower', 'Transpose',
+ $ 'Unit', I, IB-1,
+ $ ONE, A( I+1, I ), LDA, WORK, LDWORK )
+ DO 30 J = 0, IB-2
+ CALL SAXPY( I, -ONE, WORK( LDWORK*J+1 ), 1,
+ $ A( 1, I+J+1 ), 1 )
+ 30 CONTINUE
+*
+* Apply the block reflector H to A(i+1:ihi,i+ib:n) from the
+* left
+*
+ CALL SLARFB( 'Left', 'Transpose', 'Forward',
+ $ 'Columnwise',
+ $ IHI-I, N-I-IB+1, IB, A( I+1, I ), LDA, T, LDT,
+ $ A( I+1, I+IB ), LDA, WORK, LDWORK )
+ 40 CONTINUE
+ END IF
+*
+* Use unblocked code to reduce the rest of the matrix
+*
+ CALL SGEHD2( N, I, IHI, A, LDA, TAU, WORK, IINFO )
+ WORK( 1 ) = IWS
+*
+ RETURN
+*
+* End of SGEHRD
+*
+ END
+ SUBROUTINE SGELQ2( M, N, A, LDA, TAU, WORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LDA, M, N
+* ..
+* .. Array Arguments ..
+ REAL A( LDA, * ), TAU( * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SGELQ2 computes an LQ factorization of a real m by n matrix A:
+* A = L * Q.
+*
+* Arguments
+* =========
+*
+* M (input) INTEGER
+* The number of rows of the matrix A. M >= 0.
+*
+* N (input) INTEGER
+* The number of columns of the matrix A. N >= 0.
+*
+* A (input/output) REAL array, dimension (LDA,N)
+* On entry, the m by n matrix A.
+* On exit, the elements on and below the diagonal of the array
+* contain the m by min(m,n) lower trapezoidal matrix L (L is
+* lower triangular if m <= n); the elements above the diagonal,
+* with the array TAU, represent the orthogonal matrix Q as a
+* product of elementary reflectors (see Further Details).
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,M).
+*
+* TAU (output) REAL array, dimension (min(M,N))
+* The scalar factors of the elementary reflectors (see Further
+* Details).
+*
+* WORK (workspace) REAL array, dimension (M)
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+*
+* Further Details
+* ===============
+*
+* The matrix Q is represented as a product of elementary reflectors
+*
+* Q = H(k) . . . H(2) H(1), where k = min(m,n).
+*
+* Each H(i) has the form
+*
+* H(i) = I - tau * v * v'
+*
+* where tau is a real scalar, and v is a real vector with
+* v(1:i-1) = 0 and v(i) = 1; v(i+1:n) is stored on exit in A(i,i+1:n),
+* and tau in TAU(i).
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ONE
+ PARAMETER ( ONE = 1.0E+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, K
+ REAL AII
+* ..
+* .. External Subroutines ..
+ EXTERNAL SLARF, SLARFG, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+* Test the input arguments
+*
+ INFO = 0
+ IF( M.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+ INFO = -4
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SGELQ2', -INFO )
+ RETURN
+ END IF
+*
+ K = MIN( M, N )
+*
+ DO 10 I = 1, K
+*
+* Generate elementary reflector H(i) to annihilate A(i,i+1:n)
+*
+ CALL SLARFG( N-I+1, A( I, I ), A( I, MIN( I+1, N ) ), LDA,
+ $ TAU( I ) )
+ IF( I.LT.M ) THEN
+*
+* Apply H(i) to A(i+1:m,i:n) from the right
+*
+ AII = A( I, I )
+ A( I, I ) = ONE
+ CALL SLARF( 'Right', M-I, N-I+1, A( I, I ), LDA, TAU( I ),
+ $ A( I+1, I ), LDA, WORK )
+ A( I, I ) = AII
+ END IF
+ 10 CONTINUE
+ RETURN
+*
+* End of SGELQ2
+*
+ END
+ SUBROUTINE SGELQF( M, N, A, LDA, TAU, WORK, LWORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LDA, LWORK, M, N
+* ..
+* .. Array Arguments ..
+ REAL A( LDA, * ), TAU( * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SGELQF computes an LQ factorization of a real M-by-N matrix A:
+* A = L * Q.
+*
+* Arguments
+* =========
+*
+* M (input) INTEGER
+* The number of rows of the matrix A. M >= 0.
+*
+* N (input) INTEGER
+* The number of columns of the matrix A. N >= 0.
+*
+* A (input/output) REAL array, dimension (LDA,N)
+* On entry, the M-by-N matrix A.
+* On exit, the elements on and below the diagonal of the array
+* contain the m-by-min(m,n) lower trapezoidal matrix L (L is
+* lower triangular if m <= n); the elements above the diagonal,
+* with the array TAU, represent the orthogonal matrix Q as a
+* product of elementary reflectors (see Further Details).
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,M).
+*
+* TAU (output) REAL array, dimension (min(M,N))
+* The scalar factors of the elementary reflectors (see Further
+* Details).
+*
+* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))
+* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+* LWORK (input) INTEGER
+* The dimension of the array WORK. LWORK >= max(1,M).
+* For optimum performance LWORK >= M*NB, where NB is the
+* optimal blocksize.
+*
+* If LWORK = -1, then a workspace query is assumed; the routine
+* only calculates the optimal size of the WORK array, returns
+* this value as the first entry of the WORK array, and no error
+* message related to LWORK is issued by XERBLA.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+*
+* Further Details
+* ===============
+*
+* The matrix Q is represented as a product of elementary reflectors
+*
+* Q = H(k) . . . H(2) H(1), where k = min(m,n).
+*
+* Each H(i) has the form
+*
+* H(i) = I - tau * v * v'
+*
+* where tau is a real scalar, and v is a real vector with
+* v(1:i-1) = 0 and v(i) = 1; v(i+1:n) is stored on exit in A(i,i+1:n),
+* and tau in TAU(i).
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ LOGICAL LQUERY
+ INTEGER I, IB, IINFO, IWS, K, LDWORK, LWKOPT, NB,
+ $ NBMIN, NX
+* ..
+* .. External Subroutines ..
+ EXTERNAL SGELQ2, SLARFB, SLARFT, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN
+* ..
+* .. External Functions ..
+ INTEGER ILAENV
+ EXTERNAL ILAENV
+* ..
+* .. Executable Statements ..
+*
+* Test the input arguments
+*
+ INFO = 0
+ NB = ILAENV( 1, 'SGELQF', ' ', M, N, -1, -1 )
+ LWKOPT = M*NB
+ WORK( 1 ) = LWKOPT
+ LQUERY = ( LWORK.EQ.-1 )
+ IF( M.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+ INFO = -4
+ ELSE IF( LWORK.LT.MAX( 1, M ) .AND. .NOT.LQUERY ) THEN
+ INFO = -7
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SGELQF', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ K = MIN( M, N )
+ IF( K.EQ.0 ) THEN
+ WORK( 1 ) = 1
+ RETURN
+ END IF
+*
+ NBMIN = 2
+ NX = 0
+ IWS = M
+ IF( NB.GT.1 .AND. NB.LT.K ) THEN
+*
+* Determine when to cross over from blocked to unblocked code.
+*
+ NX = MAX( 0, ILAENV( 3, 'SGELQF', ' ', M, N, -1, -1 ) )
+ IF( NX.LT.K ) THEN
+*
+* Determine if workspace is large enough for blocked code.
+*
+ LDWORK = M
+ IWS = LDWORK*NB
+ IF( LWORK.LT.IWS ) THEN
+*
+* Not enough workspace to use optimal NB: reduce NB and
+* determine the minimum value of NB.
+*
+ NB = LWORK / LDWORK
+ NBMIN = MAX( 2, ILAENV( 2, 'SGELQF', ' ', M, N, -1,
+ $ -1 ) )
+ END IF
+ END IF
+ END IF
+*
+ IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN
+*
+* Use blocked code initially
+*
+ DO 10 I = 1, K - NX, NB
+ IB = MIN( K-I+1, NB )
+*
+* Compute the LQ factorization of the current block
+* A(i:i+ib-1,i:n)
+*
+ CALL SGELQ2( IB, N-I+1, A( I, I ), LDA, TAU( I ), WORK,
+ $ IINFO )
+ IF( I+IB.LE.M ) THEN
+*
+* Form the triangular factor of the block reflector
+* H = H(i) H(i+1) . . . H(i+ib-1)
+*
+ CALL SLARFT( 'Forward', 'Rowwise', N-I+1, IB, A( I, I ),
+ $ LDA, TAU( I ), WORK, LDWORK )
+*
+* Apply H to A(i+ib:m,i:n) from the right
+*
+ CALL SLARFB( 'Right', 'No transpose', 'Forward',
+ $ 'Rowwise', M-I-IB+1, N-I+1, IB, A( I, I ),
+ $ LDA, WORK, LDWORK, A( I+IB, I ), LDA,
+ $ WORK( IB+1 ), LDWORK )
+ END IF
+ 10 CONTINUE
+ ELSE
+ I = 1
+ END IF
+*
+* Use unblocked code to factor the last or only block.
+*
+ IF( I.LE.K )
+ $ CALL SGELQ2( M-I+1, N-I+1, A( I, I ), LDA, TAU( I ), WORK,
+ $ IINFO )
+*
+ WORK( 1 ) = IWS
+ RETURN
+*
+* End of SGELQF
+*
+ END
+ SUBROUTINE SGELS( TRANS, M, N, NRHS, A, LDA, B, LDB, WORK, LWORK,
+ $ INFO )
+*
+* -- LAPACK driver routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER TRANS
+ INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS
+* ..
+* .. Array Arguments ..
+ REAL A( LDA, * ), B( LDB, * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SGELS solves overdetermined or underdetermined real linear systems
+* involving an M-by-N matrix A, or its transpose, using a QR or LQ
+* factorization of A. It is assumed that A has full rank.
+*
+* The following options are provided:
+*
+* 1. If TRANS = 'N' and m >= n: find the least squares solution of
+* an overdetermined system, i.e., solve the least squares problem
+* minimize || B - A*X ||.
+*
+* 2. If TRANS = 'N' and m < n: find the minimum norm solution of
+* an underdetermined system A * X = B.
+*
+* 3. If TRANS = 'T' and m >= n: find the minimum norm solution of
+* an undetermined system A**T * X = B.
+*
+* 4. If TRANS = 'T' and m < n: find the least squares solution of
+* an overdetermined system, i.e., solve the least squares problem
+* minimize || B - A**T * X ||.
+*
+* Several right hand side vectors b and solution vectors x can be
+* handled in a single call; they are stored as the columns of the
+* M-by-NRHS right hand side matrix B and the N-by-NRHS solution
+* matrix X.
+*
+* Arguments
+* =========
+*
+* TRANS (input) CHARACTER*1
+* = 'N': the linear system involves A;
+* = 'T': the linear system involves A**T.
+*
+* M (input) INTEGER
+* The number of rows of the matrix A. M >= 0.
+*
+* N (input) INTEGER
+* The number of columns of the matrix A. N >= 0.
+*
+* NRHS (input) INTEGER
+* The number of right hand sides, i.e., the number of
+* columns of the matrices B and X. NRHS >=0.
+*
+* A (input/output) REAL array, dimension (LDA,N)
+* On entry, the M-by-N matrix A.
+* On exit,
+* if M >= N, A is overwritten by details of its QR
+* factorization as returned by SGEQRF;
+* if M < N, A is overwritten by details of its LQ
+* factorization as returned by SGELQF.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,M).
+*
+* B (input/output) REAL array, dimension (LDB,NRHS)
+* On entry, the matrix B of right hand side vectors, stored
+* columnwise; B is M-by-NRHS if TRANS = 'N', or N-by-NRHS
+* if TRANS = 'T'.
+* On exit, if INFO = 0, B is overwritten by the solution
+* vectors, stored columnwise:
+* if TRANS = 'N' and m >= n, rows 1 to n of B contain the least
+* squares solution vectors; the residual sum of squares for the
+* solution in each column is given by the sum of squares of
+* elements N+1 to M in that column;
+* if TRANS = 'N' and m < n, rows 1 to N of B contain the
+* minimum norm solution vectors;
+* if TRANS = 'T' and m >= n, rows 1 to M of B contain the
+* minimum norm solution vectors;
+* if TRANS = 'T' and m < n, rows 1 to M of B contain the
+* least squares solution vectors; the residual sum of squares
+* for the solution in each column is given by the sum of
+* squares of elements M+1 to N in that column.
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. LDB >= MAX(1,M,N).
+*
+* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))
+* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+* LWORK (input) INTEGER
+* The dimension of the array WORK.
+* LWORK >= max( 1, MN + max( MN, NRHS ) ).
+* For optimal performance,
+* LWORK >= max( 1, MN + max( MN, NRHS )*NB ).
+* where MN = min(M,N) and NB is the optimum block size.
+*
+* If LWORK = -1, then a workspace query is assumed; the routine
+* only calculates the optimal size of the WORK array, returns
+* this value as the first entry of the WORK array, and no error
+* message related to LWORK is issued by XERBLA.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* > 0: if INFO = i, the i-th diagonal element of the
+* triangular factor of A is zero, so that A does not have
+* full rank; the least squares solution could not be
+* computed.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO, ONE
+ PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL LQUERY, TPSD
+ INTEGER BROW, I, IASCL, IBSCL, J, MN, NB, SCLLEN, WSIZE
+ REAL ANRM, BIGNUM, BNRM, SMLNUM
+* ..
+* .. Local Arrays ..
+ REAL RWORK( 1 )
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ILAENV
+ REAL SLAMCH, SLANGE
+ EXTERNAL LSAME, ILAENV, SLAMCH, SLANGE
+* ..
+* .. External Subroutines ..
+ EXTERNAL SGELQF, SGEQRF, SLABAD, SLASCL, SLASET, SORMLQ,
+ $ SORMQR, STRTRS, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN, REAL
+* ..
+* .. Executable Statements ..
+*
+* Test the input arguments.
+*
+ INFO = 0
+ MN = MIN( M, N )
+ LQUERY = ( LWORK.EQ.-1 )
+ IF( .NOT.( LSAME( TRANS, 'N' ) .OR. LSAME( TRANS, 'T' ) ) ) THEN
+ INFO = -1
+ ELSE IF( M.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( NRHS.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+ INFO = -6
+ ELSE IF( LDB.LT.MAX( 1, M, N ) ) THEN
+ INFO = -8
+ ELSE IF( LWORK.LT.MAX( 1, MN + MAX( MN, NRHS ) ) .AND.
+ $ .NOT.LQUERY ) THEN
+ INFO = -10
+ END IF
+*
+* Figure out optimal block size
+*
+ IF( INFO.EQ.0 .OR. INFO.EQ.-10 ) THEN
+*
+ TPSD = .TRUE.
+ IF( LSAME( TRANS, 'N' ) )
+ $ TPSD = .FALSE.
+*
+ IF( M.GE.N ) THEN
+ NB = ILAENV( 1, 'SGEQRF', ' ', M, N, -1, -1 )
+ IF( TPSD ) THEN
+ NB = MAX( NB, ILAENV( 1, 'SORMQR', 'LN', M, NRHS, N,
+ $ -1 ) )
+ ELSE
+ NB = MAX( NB, ILAENV( 1, 'SORMQR', 'LT', M, NRHS, N,
+ $ -1 ) )
+ END IF
+ ELSE
+ NB = ILAENV( 1, 'SGELQF', ' ', M, N, -1, -1 )
+ IF( TPSD ) THEN
+ NB = MAX( NB, ILAENV( 1, 'SORMLQ', 'LT', N, NRHS, M,
+ $ -1 ) )
+ ELSE
+ NB = MAX( NB, ILAENV( 1, 'SORMLQ', 'LN', N, NRHS, M,
+ $ -1 ) )
+ END IF
+ END IF
+*
+ WSIZE = MAX( 1, MN + MAX( MN, NRHS )*NB )
+ WORK( 1 ) = REAL( WSIZE )
+*
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SGELS ', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( MIN( M, N, NRHS ).EQ.0 ) THEN
+ CALL SLASET( 'Full', MAX( M, N ), NRHS, ZERO, ZERO, B, LDB )
+ RETURN
+ END IF
+*
+* Get machine parameters
+*
+ SMLNUM = SLAMCH( 'S' ) / SLAMCH( 'P' )
+ BIGNUM = ONE / SMLNUM
+ CALL SLABAD( SMLNUM, BIGNUM )
+*
+* Scale A, B if max element outside range [SMLNUM,BIGNUM]
+*
+ ANRM = SLANGE( 'M', M, N, A, LDA, RWORK )
+ IASCL = 0
+ IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
+*
+* Scale matrix norm up to SMLNUM
+*
+ CALL SLASCL( 'G', 0, 0, ANRM, SMLNUM, M, N, A, LDA, INFO )
+ IASCL = 1
+ ELSE IF( ANRM.GT.BIGNUM ) THEN
+*
+* Scale matrix norm down to BIGNUM
+*
+ CALL SLASCL( 'G', 0, 0, ANRM, BIGNUM, M, N, A, LDA, INFO )
+ IASCL = 2
+ ELSE IF( ANRM.EQ.ZERO ) THEN
+*
+* Matrix all zero. Return zero solution.
+*
+ CALL SLASET( 'F', MAX( M, N ), NRHS, ZERO, ZERO, B, LDB )
+ GO TO 50
+ END IF
+*
+ BROW = M
+ IF( TPSD )
+ $ BROW = N
+ BNRM = SLANGE( 'M', BROW, NRHS, B, LDB, RWORK )
+ IBSCL = 0
+ IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN
+*
+* Scale matrix norm up to SMLNUM
+*
+ CALL SLASCL( 'G', 0, 0, BNRM, SMLNUM, BROW, NRHS, B, LDB,
+ $ INFO )
+ IBSCL = 1
+ ELSE IF( BNRM.GT.BIGNUM ) THEN
+*
+* Scale matrix norm down to BIGNUM
+*
+ CALL SLASCL( 'G', 0, 0, BNRM, BIGNUM, BROW, NRHS, B, LDB,
+ $ INFO )
+ IBSCL = 2
+ END IF
+*
+ IF( M.GE.N ) THEN
+*
+* compute QR factorization of A
+*
+ CALL SGEQRF( M, N, A, LDA, WORK( 1 ), WORK( MN+1 ), LWORK-MN,
+ $ INFO )
+*
+* workspace at least N, optimally N*NB
+*
+ IF( .NOT.TPSD ) THEN
+*
+* Least-Squares Problem min || A * X - B ||
+*
+* B(1:M,1:NRHS) := Q' * B(1:M,1:NRHS)
+*
+ CALL SORMQR( 'Left', 'Transpose', M, NRHS, N, A, LDA,
+ $ WORK( 1 ), B, LDB, WORK( MN+1 ), LWORK-MN,
+ $ INFO )
+*
+* workspace at least NRHS, optimally NRHS*NB
+*
+* B(1:N,1:NRHS) := inv(R) * B(1:N,1:NRHS)
+*
+ CALL STRTRS( 'Upper', 'No transpose', 'Non-unit', N, NRHS,
+ $ A, LDA, B, LDB, INFO )
+*
+ IF( INFO.GT.0 ) THEN
+ RETURN
+ END IF
+*
+ SCLLEN = N
+*
+ ELSE
+*
+* Overdetermined system of equations A' * X = B
+*
+* B(1:N,1:NRHS) := inv(R') * B(1:N,1:NRHS)
+*
+ CALL STRTRS( 'Upper', 'Transpose', 'Non-unit', N, NRHS,
+ $ A, LDA, B, LDB, INFO )
+*
+ IF( INFO.GT.0 ) THEN
+ RETURN
+ END IF
+*
+* B(N+1:M,1:NRHS) = ZERO
+*
+ DO 20 J = 1, NRHS
+ DO 10 I = N + 1, M
+ B( I, J ) = ZERO
+ 10 CONTINUE
+ 20 CONTINUE
+*
+* B(1:M,1:NRHS) := Q(1:N,:) * B(1:N,1:NRHS)
+*
+ CALL SORMQR( 'Left', 'No transpose', M, NRHS, N, A, LDA,
+ $ WORK( 1 ), B, LDB, WORK( MN+1 ), LWORK-MN,
+ $ INFO )
+*
+* workspace at least NRHS, optimally NRHS*NB
+*
+ SCLLEN = M
+*
+ END IF
+*
+ ELSE
+*
+* Compute LQ factorization of A
+*
+ CALL SGELQF( M, N, A, LDA, WORK( 1 ), WORK( MN+1 ), LWORK-MN,
+ $ INFO )
+*
+* workspace at least M, optimally M*NB.
+*
+ IF( .NOT.TPSD ) THEN
+*
+* underdetermined system of equations A * X = B
+*
+* B(1:M,1:NRHS) := inv(L) * B(1:M,1:NRHS)
+*
+ CALL STRTRS( 'Lower', 'No transpose', 'Non-unit', M, NRHS,
+ $ A, LDA, B, LDB, INFO )
+*
+ IF( INFO.GT.0 ) THEN
+ RETURN
+ END IF
+*
+* B(M+1:N,1:NRHS) = 0
+*
+ DO 40 J = 1, NRHS
+ DO 30 I = M + 1, N
+ B( I, J ) = ZERO
+ 30 CONTINUE
+ 40 CONTINUE
+*
+* B(1:N,1:NRHS) := Q(1:N,:)' * B(1:M,1:NRHS)
+*
+ CALL SORMLQ( 'Left', 'Transpose', N, NRHS, M, A, LDA,
+ $ WORK( 1 ), B, LDB, WORK( MN+1 ), LWORK-MN,
+ $ INFO )
+*
+* workspace at least NRHS, optimally NRHS*NB
+*
+ SCLLEN = N
+*
+ ELSE
+*
+* overdetermined system min || A' * X - B ||
+*
+* B(1:N,1:NRHS) := Q * B(1:N,1:NRHS)
+*
+ CALL SORMLQ( 'Left', 'No transpose', N, NRHS, M, A, LDA,
+ $ WORK( 1 ), B, LDB, WORK( MN+1 ), LWORK-MN,
+ $ INFO )
+*
+* workspace at least NRHS, optimally NRHS*NB
+*
+* B(1:M,1:NRHS) := inv(L') * B(1:M,1:NRHS)
+*
+ CALL STRTRS( 'Lower', 'Transpose', 'Non-unit', M, NRHS,
+ $ A, LDA, B, LDB, INFO )
+*
+ IF( INFO.GT.0 ) THEN
+ RETURN
+ END IF
+*
+ SCLLEN = M
+*
+ END IF
+*
+ END IF
+*
+* Undo scaling
+*
+ IF( IASCL.EQ.1 ) THEN
+ CALL SLASCL( 'G', 0, 0, ANRM, SMLNUM, SCLLEN, NRHS, B, LDB,
+ $ INFO )
+ ELSE IF( IASCL.EQ.2 ) THEN
+ CALL SLASCL( 'G', 0, 0, ANRM, BIGNUM, SCLLEN, NRHS, B, LDB,
+ $ INFO )
+ END IF
+ IF( IBSCL.EQ.1 ) THEN
+ CALL SLASCL( 'G', 0, 0, SMLNUM, BNRM, SCLLEN, NRHS, B, LDB,
+ $ INFO )
+ ELSE IF( IBSCL.EQ.2 ) THEN
+ CALL SLASCL( 'G', 0, 0, BIGNUM, BNRM, SCLLEN, NRHS, B, LDB,
+ $ INFO )
+ END IF
+*
+ 50 CONTINUE
+ WORK( 1 ) = REAL( WSIZE )
+*
+ RETURN
+*
+* End of SGELS
+*
+ END
+ SUBROUTINE SGELSD( M, N, NRHS, A, LDA, B, LDB, S, RCOND,
+ $ RANK, WORK, LWORK, IWORK, INFO )
+*
+* -- LAPACK driver routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS, RANK
+ REAL RCOND
+* ..
+* .. Array Arguments ..
+ INTEGER IWORK( * )
+ REAL A( LDA, * ), B( LDB, * ), S( * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SGELSD computes the minimum-norm solution to a real linear least
+* squares problem:
+* minimize 2-norm(| b - A*x |)
+* using the singular value decomposition (SVD) of A. A is an M-by-N
+* matrix which may be rank-deficient.
+*
+* Several right hand side vectors b and solution vectors x can be
+* handled in a single call; they are stored as the columns of the
+* M-by-NRHS right hand side matrix B and the N-by-NRHS solution
+* matrix X.
+*
+* The problem is solved in three steps:
+* (1) Reduce the coefficient matrix A to bidiagonal form with
+* Householder transformations, reducing the original problem
+* into a "bidiagonal least squares problem" (BLS)
+* (2) Solve the BLS using a divide and conquer approach.
+* (3) Apply back all the Householder tranformations to solve
+* the original least squares problem.
+*
+* The effective rank of A is determined by treating as zero those
+* singular values which are less than RCOND times the largest singular
+* value.
+*
+* The divide and conquer algorithm makes very mild assumptions about
+* floating point arithmetic. It will work on machines with a guard
+* digit in add/subtract, or on those binary machines without guard
+* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
+* Cray-2. It could conceivably fail on hexadecimal or decimal machines
+* without guard digits, but we know of none.
+*
+* Arguments
+* =========
+*
+* M (input) INTEGER
+* The number of rows of A. M >= 0.
+*
+* N (input) INTEGER
+* The number of columns of A. N >= 0.
+*
+* NRHS (input) INTEGER
+* The number of right hand sides, i.e., the number of columns
+* of the matrices B and X. NRHS >= 0.
+*
+* A (input) REAL array, dimension (LDA,N)
+* On entry, the M-by-N matrix A.
+* On exit, A has been destroyed.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,M).
+*
+* B (input/output) REAL array, dimension (LDB,NRHS)
+* On entry, the M-by-NRHS right hand side matrix B.
+* On exit, B is overwritten by the N-by-NRHS solution
+* matrix X. If m >= n and RANK = n, the residual
+* sum-of-squares for the solution in the i-th column is given
+* by the sum of squares of elements n+1:m in that column.
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. LDB >= max(1,max(M,N)).
+*
+* S (output) REAL array, dimension (min(M,N))
+* The singular values of A in decreasing order.
+* The condition number of A in the 2-norm = S(1)/S(min(m,n)).
+*
+* RCOND (input) REAL
+* RCOND is used to determine the effective rank of A.
+* Singular values S(i) <= RCOND*S(1) are treated as zero.
+* If RCOND < 0, machine precision is used instead.
+*
+* RANK (output) INTEGER
+* The effective rank of A, i.e., the number of singular values
+* which are greater than RCOND*S(1).
+*
+* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))
+* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+* LWORK (input) INTEGER
+* The dimension of the array WORK. LWORK must be at least 1.
+* The exact minimum amount of workspace needed depends on M,
+* N and NRHS. As long as LWORK is at least
+* 12*N + 2*N*SMLSIZ + 8*N*NLVL + N*NRHS + (SMLSIZ+1)**2,
+* if M is greater than or equal to N or
+* 12*M + 2*M*SMLSIZ + 8*M*NLVL + M*NRHS + (SMLSIZ+1)**2,
+* if M is less than N, the code will execute correctly.
+* SMLSIZ is returned by ILAENV and is equal to the maximum
+* size of the subproblems at the bottom of the computation
+* tree (usually about 25), and
+* NLVL = MAX( 0, INT( LOG_2( MIN( M,N )/(SMLSIZ+1) ) ) + 1 )
+* For good performance, LWORK should generally be larger.
+*
+* If LWORK = -1, then a workspace query is assumed; the routine
+* only calculates the optimal size of the array WORK and the
+* minimum size of the array IWORK, and returns these values as
+* the first entries of the WORK and IWORK arrays, and no error
+* message related to LWORK is issued by XERBLA.
+*
+* IWORK (workspace) INTEGER array, dimension (MAX(1,LIWORK))
+* LIWORK >= max(1, 3*MINMN*NLVL + 11*MINMN),
+* where MINMN = MIN( M,N ).
+* On exit, if INFO = 0, IWORK(1) returns the minimum LIWORK.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value.
+* > 0: the algorithm for computing the SVD failed to converge;
+* if INFO = i, i off-diagonal elements of an intermediate
+* bidiagonal form did not converge to zero.
+*
+* Further Details
+* ===============
+*
+* Based on contributions by
+* Ming Gu and Ren-Cang Li, Computer Science Division, University of
+* California at Berkeley, USA
+* Osni Marques, LBNL/NERSC, USA
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO, ONE, TWO
+ PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0, TWO = 2.0E0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL LQUERY
+ INTEGER IASCL, IBSCL, IE, IL, ITAU, ITAUP, ITAUQ,
+ $ LDWORK, LIWORK, MAXMN, MAXWRK, MINMN, MINWRK,
+ $ MM, MNTHR, NLVL, NWORK, SMLSIZ, WLALSD
+ REAL ANRM, BIGNUM, BNRM, EPS, SFMIN, SMLNUM
+* ..
+* .. External Subroutines ..
+ EXTERNAL SGEBRD, SGELQF, SGEQRF, SLABAD, SLACPY, SLALSD,
+ $ SLASCL, SLASET, SORMBR, SORMLQ, SORMQR, XERBLA
+* ..
+* .. External Functions ..
+ INTEGER ILAENV
+ REAL SLAMCH, SLANGE
+ EXTERNAL SLAMCH, SLANGE, ILAENV
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC INT, LOG, MAX, MIN, REAL
+* ..
+* .. Executable Statements ..
+*
+* Test the input arguments.
+*
+ INFO = 0
+ MINMN = MIN( M, N )
+ MAXMN = MAX( M, N )
+ LQUERY = ( LWORK.EQ.-1 )
+ IF( M.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( NRHS.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+ INFO = -5
+ ELSE IF( LDB.LT.MAX( 1, MAXMN ) ) THEN
+ INFO = -7
+ END IF
+*
+* Compute workspace.
+* (Note: Comments in the code beginning "Workspace:" describe the
+* minimal amount of workspace needed at that point in the code,
+* as well as the preferred amount for good performance.
+* NB refers to the optimal block size for the immediately
+* following subroutine, as returned by ILAENV.)
+*
+ IF( INFO.EQ.0 ) THEN
+ MINWRK = 1
+ MAXWRK = 1
+ LIWORK = 1
+ IF( MINMN.GT.0 ) THEN
+ SMLSIZ = ILAENV( 9, 'SGELSD', ' ', 0, 0, 0, 0 )
+ MNTHR = ILAENV( 6, 'SGELSD', ' ', M, N, NRHS, -1 )
+ NLVL = MAX( INT( LOG( REAL( MINMN ) / REAL( SMLSIZ + 1 ) ) /
+ $ LOG( TWO ) ) + 1, 0 )
+ LIWORK = 3*MINMN*NLVL + 11*MINMN
+ MM = M
+ IF( M.GE.N .AND. M.GE.MNTHR ) THEN
+*
+* Path 1a - overdetermined, with many more rows than
+* columns.
+*
+ MM = N
+ MAXWRK = MAX( MAXWRK, N + N*ILAENV( 1, 'SGEQRF', ' ', M,
+ $ N, -1, -1 ) )
+ MAXWRK = MAX( MAXWRK, N + NRHS*ILAENV( 1, 'SORMQR', 'LT',
+ $ M, NRHS, N, -1 ) )
+ END IF
+ IF( M.GE.N ) THEN
+*
+* Path 1 - overdetermined or exactly determined.
+*
+ MAXWRK = MAX( MAXWRK, 3*N + ( MM + N )*ILAENV( 1,
+ $ 'SGEBRD', ' ', MM, N, -1, -1 ) )
+ MAXWRK = MAX( MAXWRK, 3*N + NRHS*ILAENV( 1, 'SORMBR',
+ $ 'QLT', MM, NRHS, N, -1 ) )
+ MAXWRK = MAX( MAXWRK, 3*N + ( N - 1 )*ILAENV( 1,
+ $ 'SORMBR', 'PLN', N, NRHS, N, -1 ) )
+ WLALSD = 9*N + 2*N*SMLSIZ + 8*N*NLVL + N*NRHS +
+ $ ( SMLSIZ + 1 )**2
+ MAXWRK = MAX( MAXWRK, 3*N + WLALSD )
+ MINWRK = MAX( 3*N + MM, 3*N + NRHS, 3*N + WLALSD )
+ END IF
+ IF( N.GT.M ) THEN
+ WLALSD = 9*M + 2*M*SMLSIZ + 8*M*NLVL + M*NRHS +
+ $ ( SMLSIZ + 1 )**2
+ IF( N.GE.MNTHR ) THEN
+*
+* Path 2a - underdetermined, with many more columns
+* than rows.
+*
+ MAXWRK = M + M*ILAENV( 1, 'SGELQF', ' ', M, N, -1,
+ $ -1 )
+ MAXWRK = MAX( MAXWRK, M*M + 4*M + 2*M*ILAENV( 1,
+ $ 'SGEBRD', ' ', M, M, -1, -1 ) )
+ MAXWRK = MAX( MAXWRK, M*M + 4*M + NRHS*ILAENV( 1,
+ $ 'SORMBR', 'QLT', M, NRHS, M, -1 ) )
+ MAXWRK = MAX( MAXWRK, M*M + 4*M + ( M - 1 )*ILAENV( 1,
+ $ 'SORMBR', 'PLN', M, NRHS, M, -1 ) )
+ IF( NRHS.GT.1 ) THEN
+ MAXWRK = MAX( MAXWRK, M*M + M + M*NRHS )
+ ELSE
+ MAXWRK = MAX( MAXWRK, M*M + 2*M )
+ END IF
+ MAXWRK = MAX( MAXWRK, M + NRHS*ILAENV( 1, 'SORMLQ',
+ $ 'LT', N, NRHS, M, -1 ) )
+ MAXWRK = MAX( MAXWRK, M*M + 4*M + WLALSD )
+ ELSE
+*
+* Path 2 - remaining underdetermined cases.
+*
+ MAXWRK = 3*M + ( N + M )*ILAENV( 1, 'SGEBRD', ' ', M,
+ $ N, -1, -1 )
+ MAXWRK = MAX( MAXWRK, 3*M + NRHS*ILAENV( 1, 'SORMBR',
+ $ 'QLT', M, NRHS, N, -1 ) )
+ MAXWRK = MAX( MAXWRK, 3*M + M*ILAENV( 1, 'SORMBR',
+ $ 'PLN', N, NRHS, M, -1 ) )
+ MAXWRK = MAX( MAXWRK, 3*M + WLALSD )
+ END IF
+ MINWRK = MAX( 3*M + NRHS, 3*M + M, 3*M + WLALSD )
+ END IF
+ END IF
+ MINWRK = MIN( MINWRK, MAXWRK )
+ WORK( 1 ) = MAXWRK
+ IWORK( 1 ) = LIWORK
+*
+ IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN
+ INFO = -12
+ END IF
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SGELSD', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible.
+*
+ IF( M.EQ.0 .OR. N.EQ.0 ) THEN
+ RANK = 0
+ RETURN
+ END IF
+*
+* Get machine parameters.
+*
+ EPS = SLAMCH( 'P' )
+ SFMIN = SLAMCH( 'S' )
+ SMLNUM = SFMIN / EPS
+ BIGNUM = ONE / SMLNUM
+ CALL SLABAD( SMLNUM, BIGNUM )
+*
+* Scale A if max entry outside range [SMLNUM,BIGNUM].
+*
+ ANRM = SLANGE( 'M', M, N, A, LDA, WORK )
+ IASCL = 0
+ IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
+*
+* Scale matrix norm up to SMLNUM.
+*
+ CALL SLASCL( 'G', 0, 0, ANRM, SMLNUM, M, N, A, LDA, INFO )
+ IASCL = 1
+ ELSE IF( ANRM.GT.BIGNUM ) THEN
+*
+* Scale matrix norm down to BIGNUM.
+*
+ CALL SLASCL( 'G', 0, 0, ANRM, BIGNUM, M, N, A, LDA, INFO )
+ IASCL = 2
+ ELSE IF( ANRM.EQ.ZERO ) THEN
+*
+* Matrix all zero. Return zero solution.
+*
+ CALL SLASET( 'F', MAX( M, N ), NRHS, ZERO, ZERO, B, LDB )
+ CALL SLASET( 'F', MINMN, 1, ZERO, ZERO, S, 1 )
+ RANK = 0
+ GO TO 10
+ END IF
+*
+* Scale B if max entry outside range [SMLNUM,BIGNUM].
+*
+ BNRM = SLANGE( 'M', M, NRHS, B, LDB, WORK )
+ IBSCL = 0
+ IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN
+*
+* Scale matrix norm up to SMLNUM.
+*
+ CALL SLASCL( 'G', 0, 0, BNRM, SMLNUM, M, NRHS, B, LDB, INFO )
+ IBSCL = 1
+ ELSE IF( BNRM.GT.BIGNUM ) THEN
+*
+* Scale matrix norm down to BIGNUM.
+*
+ CALL SLASCL( 'G', 0, 0, BNRM, BIGNUM, M, NRHS, B, LDB, INFO )
+ IBSCL = 2
+ END IF
+*
+* If M < N make sure certain entries of B are zero.
+*
+ IF( M.LT.N )
+ $ CALL SLASET( 'F', N-M, NRHS, ZERO, ZERO, B( M+1, 1 ), LDB )
+*
+* Overdetermined case.
+*
+ IF( M.GE.N ) THEN
+*
+* Path 1 - overdetermined or exactly determined.
+*
+ MM = M
+ IF( M.GE.MNTHR ) THEN
+*
+* Path 1a - overdetermined, with many more rows than columns.
+*
+ MM = N
+ ITAU = 1
+ NWORK = ITAU + N
+*
+* Compute A=Q*R.
+* (Workspace: need 2*N, prefer N+N*NB)
+*
+ CALL SGEQRF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ),
+ $ LWORK-NWORK+1, INFO )
+*
+* Multiply B by transpose(Q).
+* (Workspace: need N+NRHS, prefer N+NRHS*NB)
+*
+ CALL SORMQR( 'L', 'T', M, NRHS, N, A, LDA, WORK( ITAU ), B,
+ $ LDB, WORK( NWORK ), LWORK-NWORK+1, INFO )
+*
+* Zero out below R.
+*
+ IF( N.GT.1 ) THEN
+ CALL SLASET( 'L', N-1, N-1, ZERO, ZERO, A( 2, 1 ), LDA )
+ END IF
+ END IF
+*
+ IE = 1
+ ITAUQ = IE + N
+ ITAUP = ITAUQ + N
+ NWORK = ITAUP + N
+*
+* Bidiagonalize R in A.
+* (Workspace: need 3*N+MM, prefer 3*N+(MM+N)*NB)
+*
+ CALL SGEBRD( MM, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ),
+ $ WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1,
+ $ INFO )
+*
+* Multiply B by transpose of left bidiagonalizing vectors of R.
+* (Workspace: need 3*N+NRHS, prefer 3*N+NRHS*NB)
+*
+ CALL SORMBR( 'Q', 'L', 'T', MM, NRHS, N, A, LDA, WORK( ITAUQ ),
+ $ B, LDB, WORK( NWORK ), LWORK-NWORK+1, INFO )
+*
+* Solve the bidiagonal least squares problem.
+*
+ CALL SLALSD( 'U', SMLSIZ, N, NRHS, S, WORK( IE ), B, LDB,
+ $ RCOND, RANK, WORK( NWORK ), IWORK, INFO )
+ IF( INFO.NE.0 ) THEN
+ GO TO 10
+ END IF
+*
+* Multiply B by right bidiagonalizing vectors of R.
+*
+ CALL SORMBR( 'P', 'L', 'N', N, NRHS, N, A, LDA, WORK( ITAUP ),
+ $ B, LDB, WORK( NWORK ), LWORK-NWORK+1, INFO )
+*
+ ELSE IF( N.GE.MNTHR .AND. LWORK.GE.4*M+M*M+
+ $ MAX( M, 2*M-4, NRHS, N-3*M, WLALSD ) ) THEN
+*
+* Path 2a - underdetermined, with many more columns than rows
+* and sufficient workspace for an efficient algorithm.
+*
+ LDWORK = M
+ IF( LWORK.GE.MAX( 4*M+M*LDA+MAX( M, 2*M-4, NRHS, N-3*M ),
+ $ M*LDA+M+M*NRHS, 4*M+M*LDA+WLALSD ) )LDWORK = LDA
+ ITAU = 1
+ NWORK = M + 1
+*
+* Compute A=L*Q.
+* (Workspace: need 2*M, prefer M+M*NB)
+*
+ CALL SGELQF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ),
+ $ LWORK-NWORK+1, INFO )
+ IL = NWORK
+*
+* Copy L to WORK(IL), zeroing out above its diagonal.
+*
+ CALL SLACPY( 'L', M, M, A, LDA, WORK( IL ), LDWORK )
+ CALL SLASET( 'U', M-1, M-1, ZERO, ZERO, WORK( IL+LDWORK ),
+ $ LDWORK )
+ IE = IL + LDWORK*M
+ ITAUQ = IE + M
+ ITAUP = ITAUQ + M
+ NWORK = ITAUP + M
+*
+* Bidiagonalize L in WORK(IL).
+* (Workspace: need M*M+5*M, prefer M*M+4*M+2*M*NB)
+*
+ CALL SGEBRD( M, M, WORK( IL ), LDWORK, S, WORK( IE ),
+ $ WORK( ITAUQ ), WORK( ITAUP ), WORK( NWORK ),
+ $ LWORK-NWORK+1, INFO )
+*
+* Multiply B by transpose of left bidiagonalizing vectors of L.
+* (Workspace: need M*M+4*M+NRHS, prefer M*M+4*M+NRHS*NB)
+*
+ CALL SORMBR( 'Q', 'L', 'T', M, NRHS, M, WORK( IL ), LDWORK,
+ $ WORK( ITAUQ ), B, LDB, WORK( NWORK ),
+ $ LWORK-NWORK+1, INFO )
+*
+* Solve the bidiagonal least squares problem.
+*
+ CALL SLALSD( 'U', SMLSIZ, M, NRHS, S, WORK( IE ), B, LDB,
+ $ RCOND, RANK, WORK( NWORK ), IWORK, INFO )
+ IF( INFO.NE.0 ) THEN
+ GO TO 10
+ END IF
+*
+* Multiply B by right bidiagonalizing vectors of L.
+*
+ CALL SORMBR( 'P', 'L', 'N', M, NRHS, M, WORK( IL ), LDWORK,
+ $ WORK( ITAUP ), B, LDB, WORK( NWORK ),
+ $ LWORK-NWORK+1, INFO )
+*
+* Zero out below first M rows of B.
+*
+ CALL SLASET( 'F', N-M, NRHS, ZERO, ZERO, B( M+1, 1 ), LDB )
+ NWORK = ITAU + M
+*
+* Multiply transpose(Q) by B.
+* (Workspace: need M+NRHS, prefer M+NRHS*NB)
+*
+ CALL SORMLQ( 'L', 'T', N, NRHS, M, A, LDA, WORK( ITAU ), B,
+ $ LDB, WORK( NWORK ), LWORK-NWORK+1, INFO )
+*
+ ELSE
+*
+* Path 2 - remaining underdetermined cases.
+*
+ IE = 1
+ ITAUQ = IE + M
+ ITAUP = ITAUQ + M
+ NWORK = ITAUP + M
+*
+* Bidiagonalize A.
+* (Workspace: need 3*M+N, prefer 3*M+(M+N)*NB)
+*
+ CALL SGEBRD( M, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ),
+ $ WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1,
+ $ INFO )
+*
+* Multiply B by transpose of left bidiagonalizing vectors.
+* (Workspace: need 3*M+NRHS, prefer 3*M+NRHS*NB)
+*
+ CALL SORMBR( 'Q', 'L', 'T', M, NRHS, N, A, LDA, WORK( ITAUQ ),
+ $ B, LDB, WORK( NWORK ), LWORK-NWORK+1, INFO )
+*
+* Solve the bidiagonal least squares problem.
+*
+ CALL SLALSD( 'L', SMLSIZ, M, NRHS, S, WORK( IE ), B, LDB,
+ $ RCOND, RANK, WORK( NWORK ), IWORK, INFO )
+ IF( INFO.NE.0 ) THEN
+ GO TO 10
+ END IF
+*
+* Multiply B by right bidiagonalizing vectors of A.
+*
+ CALL SORMBR( 'P', 'L', 'N', N, NRHS, M, A, LDA, WORK( ITAUP ),
+ $ B, LDB, WORK( NWORK ), LWORK-NWORK+1, INFO )
+*
+ END IF
+*
+* Undo scaling.
+*
+ IF( IASCL.EQ.1 ) THEN
+ CALL SLASCL( 'G', 0, 0, ANRM, SMLNUM, N, NRHS, B, LDB, INFO )
+ CALL SLASCL( 'G', 0, 0, SMLNUM, ANRM, MINMN, 1, S, MINMN,
+ $ INFO )
+ ELSE IF( IASCL.EQ.2 ) THEN
+ CALL SLASCL( 'G', 0, 0, ANRM, BIGNUM, N, NRHS, B, LDB, INFO )
+ CALL SLASCL( 'G', 0, 0, BIGNUM, ANRM, MINMN, 1, S, MINMN,
+ $ INFO )
+ END IF
+ IF( IBSCL.EQ.1 ) THEN
+ CALL SLASCL( 'G', 0, 0, SMLNUM, BNRM, N, NRHS, B, LDB, INFO )
+ ELSE IF( IBSCL.EQ.2 ) THEN
+ CALL SLASCL( 'G', 0, 0, BIGNUM, BNRM, N, NRHS, B, LDB, INFO )
+ END IF
+*
+ 10 CONTINUE
+ WORK( 1 ) = MAXWRK
+ IWORK( 1 ) = LIWORK
+ RETURN
+*
+* End of SGELSD
+*
+ END
+ SUBROUTINE SGELSS( M, N, NRHS, A, LDA, B, LDB, S, RCOND, RANK,
+ $ WORK, LWORK, INFO )
+*
+* -- LAPACK driver routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS, RANK
+ REAL RCOND
+* ..
+* .. Array Arguments ..
+ REAL A( LDA, * ), B( LDB, * ), S( * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SGELSS computes the minimum norm solution to a real linear least
+* squares problem:
+*
+* Minimize 2-norm(| b - A*x |).
+*
+* using the singular value decomposition (SVD) of A. A is an M-by-N
+* matrix which may be rank-deficient.
+*
+* Several right hand side vectors b and solution vectors x can be
+* handled in a single call; they are stored as the columns of the
+* M-by-NRHS right hand side matrix B and the N-by-NRHS solution matrix
+* X.
+*
+* The effective rank of A is determined by treating as zero those
+* singular values which are less than RCOND times the largest singular
+* value.
+*
+* Arguments
+* =========
+*
+* M (input) INTEGER
+* The number of rows of the matrix A. M >= 0.
+*
+* N (input) INTEGER
+* The number of columns of the matrix A. N >= 0.
+*
+* NRHS (input) INTEGER
+* The number of right hand sides, i.e., the number of columns
+* of the matrices B and X. NRHS >= 0.
+*
+* A (input/output) REAL array, dimension (LDA,N)
+* On entry, the M-by-N matrix A.
+* On exit, the first min(m,n) rows of A are overwritten with
+* its right singular vectors, stored rowwise.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,M).
+*
+* B (input/output) REAL array, dimension (LDB,NRHS)
+* On entry, the M-by-NRHS right hand side matrix B.
+* On exit, B is overwritten by the N-by-NRHS solution
+* matrix X. If m >= n and RANK = n, the residual
+* sum-of-squares for the solution in the i-th column is given
+* by the sum of squares of elements n+1:m in that column.
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. LDB >= max(1,max(M,N)).
+*
+* S (output) REAL array, dimension (min(M,N))
+* The singular values of A in decreasing order.
+* The condition number of A in the 2-norm = S(1)/S(min(m,n)).
+*
+* RCOND (input) REAL
+* RCOND is used to determine the effective rank of A.
+* Singular values S(i) <= RCOND*S(1) are treated as zero.
+* If RCOND < 0, machine precision is used instead.
+*
+* RANK (output) INTEGER
+* The effective rank of A, i.e., the number of singular values
+* which are greater than RCOND*S(1).
+*
+* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))
+* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+* LWORK (input) INTEGER
+* The dimension of the array WORK. LWORK >= 1, and also:
+* LWORK >= 3*min(M,N) + max( 2*min(M,N), max(M,N), NRHS )
+* For good performance, LWORK should generally be larger.
+*
+* If LWORK = -1, then a workspace query is assumed; the routine
+* only calculates the optimal size of the WORK array, returns
+* this value as the first entry of the WORK array, and no error
+* message related to LWORK is issued by XERBLA.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value.
+* > 0: the algorithm for computing the SVD failed to converge;
+* if INFO = i, i off-diagonal elements of an intermediate
+* bidiagonal form did not converge to zero.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO, ONE
+ PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL LQUERY
+ INTEGER BDSPAC, BL, CHUNK, I, IASCL, IBSCL, IE, IL,
+ $ ITAU, ITAUP, ITAUQ, IWORK, LDWORK, MAXMN,
+ $ MAXWRK, MINMN, MINWRK, MM, MNTHR
+ REAL ANRM, BIGNUM, BNRM, EPS, SFMIN, SMLNUM, THR
+* ..
+* .. Local Arrays ..
+ REAL VDUM( 1 )
+* ..
+* .. External Subroutines ..
+ EXTERNAL SBDSQR, SCOPY, SGEBRD, SGELQF, SGEMM, SGEMV,
+ $ SGEQRF, SLABAD, SLACPY, SLASCL, SLASET, SORGBR,
+ $ SORMBR, SORMLQ, SORMQR, SRSCL, XERBLA
+* ..
+* .. External Functions ..
+ INTEGER ILAENV
+ REAL SLAMCH, SLANGE
+ EXTERNAL ILAENV, SLAMCH, SLANGE
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+* Test the input arguments
+*
+ INFO = 0
+ MINMN = MIN( M, N )
+ MAXMN = MAX( M, N )
+ LQUERY = ( LWORK.EQ.-1 )
+ IF( M.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( NRHS.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+ INFO = -5
+ ELSE IF( LDB.LT.MAX( 1, MAXMN ) ) THEN
+ INFO = -7
+ END IF
+*
+* Compute workspace
+* (Note: Comments in the code beginning "Workspace:" describe the
+* minimal amount of workspace needed at that point in the code,
+* as well as the preferred amount for good performance.
+* NB refers to the optimal block size for the immediately
+* following subroutine, as returned by ILAENV.)
+*
+ IF( INFO.EQ.0 ) THEN
+ MINWRK = 1
+ MAXWRK = 1
+ IF( MINMN.GT.0 ) THEN
+ MM = M
+ MNTHR = ILAENV( 6, 'SGELSS', ' ', M, N, NRHS, -1 )
+ IF( M.GE.N .AND. M.GE.MNTHR ) THEN
+*
+* Path 1a - overdetermined, with many more rows than
+* columns
+*
+ MM = N
+ MAXWRK = MAX( MAXWRK, N + N*ILAENV( 1, 'SGEQRF', ' ', M,
+ $ N, -1, -1 ) )
+ MAXWRK = MAX( MAXWRK, N + NRHS*ILAENV( 1, 'SORMQR', 'LT',
+ $ M, NRHS, N, -1 ) )
+ END IF
+ IF( M.GE.N ) THEN
+*
+* Path 1 - overdetermined or exactly determined
+*
+* Compute workspace needed for SBDSQR
+*
+ BDSPAC = MAX( 1, 5*N )
+ MAXWRK = MAX( MAXWRK, 3*N + ( MM + N )*ILAENV( 1,
+ $ 'SGEBRD', ' ', MM, N, -1, -1 ) )
+ MAXWRK = MAX( MAXWRK, 3*N + NRHS*ILAENV( 1, 'SORMBR',
+ $ 'QLT', MM, NRHS, N, -1 ) )
+ MAXWRK = MAX( MAXWRK, 3*N + ( N - 1 )*ILAENV( 1,
+ $ 'SORGBR', 'P', N, N, N, -1 ) )
+ MAXWRK = MAX( MAXWRK, BDSPAC )
+ MAXWRK = MAX( MAXWRK, N*NRHS )
+ MINWRK = MAX( 3*N + MM, 3*N + NRHS, BDSPAC )
+ MAXWRK = MAX( MINWRK, MAXWRK )
+ END IF
+ IF( N.GT.M ) THEN
+*
+* Compute workspace needed for SBDSQR
+*
+ BDSPAC = MAX( 1, 5*M )
+ MINWRK = MAX( 3*M+NRHS, 3*M+N, BDSPAC )
+ IF( N.GE.MNTHR ) THEN
+*
+* Path 2a - underdetermined, with many more columns
+* than rows
+*
+ MAXWRK = M + M*ILAENV( 1, 'SGELQF', ' ', M, N, -1,
+ $ -1 )
+ MAXWRK = MAX( MAXWRK, M*M + 4*M + 2*M*ILAENV( 1,
+ $ 'SGEBRD', ' ', M, M, -1, -1 ) )
+ MAXWRK = MAX( MAXWRK, M*M + 4*M + NRHS*ILAENV( 1,
+ $ 'SORMBR', 'QLT', M, NRHS, M, -1 ) )
+ MAXWRK = MAX( MAXWRK, M*M + 4*M +
+ $ ( M - 1 )*ILAENV( 1, 'SORGBR', 'P', M,
+ $ M, M, -1 ) )
+ MAXWRK = MAX( MAXWRK, M*M + M + BDSPAC )
+ IF( NRHS.GT.1 ) THEN
+ MAXWRK = MAX( MAXWRK, M*M + M + M*NRHS )
+ ELSE
+ MAXWRK = MAX( MAXWRK, M*M + 2*M )
+ END IF
+ MAXWRK = MAX( MAXWRK, M + NRHS*ILAENV( 1, 'SORMLQ',
+ $ 'LT', N, NRHS, M, -1 ) )
+ ELSE
+*
+* Path 2 - underdetermined
+*
+ MAXWRK = 3*M + ( N + M )*ILAENV( 1, 'SGEBRD', ' ', M,
+ $ N, -1, -1 )
+ MAXWRK = MAX( MAXWRK, 3*M + NRHS*ILAENV( 1, 'SORMBR',
+ $ 'QLT', M, NRHS, M, -1 ) )
+ MAXWRK = MAX( MAXWRK, 3*M + M*ILAENV( 1, 'SORGBR',
+ $ 'P', M, N, M, -1 ) )
+ MAXWRK = MAX( MAXWRK, BDSPAC )
+ MAXWRK = MAX( MAXWRK, N*NRHS )
+ END IF
+ END IF
+ MAXWRK = MAX( MINWRK, MAXWRK )
+ END IF
+ WORK( 1 ) = MAXWRK
+*
+ IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY )
+ $ INFO = -12
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SGELSS', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( M.EQ.0 .OR. N.EQ.0 ) THEN
+ RANK = 0
+ RETURN
+ END IF
+*
+* Get machine parameters
+*
+ EPS = SLAMCH( 'P' )
+ SFMIN = SLAMCH( 'S' )
+ SMLNUM = SFMIN / EPS
+ BIGNUM = ONE / SMLNUM
+ CALL SLABAD( SMLNUM, BIGNUM )
+*
+* Scale A if max element outside range [SMLNUM,BIGNUM]
+*
+ ANRM = SLANGE( 'M', M, N, A, LDA, WORK )
+ IASCL = 0
+ IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
+*
+* Scale matrix norm up to SMLNUM
+*
+ CALL SLASCL( 'G', 0, 0, ANRM, SMLNUM, M, N, A, LDA, INFO )
+ IASCL = 1
+ ELSE IF( ANRM.GT.BIGNUM ) THEN
+*
+* Scale matrix norm down to BIGNUM
+*
+ CALL SLASCL( 'G', 0, 0, ANRM, BIGNUM, M, N, A, LDA, INFO )
+ IASCL = 2
+ ELSE IF( ANRM.EQ.ZERO ) THEN
+*
+* Matrix all zero. Return zero solution.
+*
+ CALL SLASET( 'F', MAX( M, N ), NRHS, ZERO, ZERO, B, LDB )
+ CALL SLASET( 'F', MINMN, 1, ZERO, ZERO, S, 1 )
+ RANK = 0
+ GO TO 70
+ END IF
+*
+* Scale B if max element outside range [SMLNUM,BIGNUM]
+*
+ BNRM = SLANGE( 'M', M, NRHS, B, LDB, WORK )
+ IBSCL = 0
+ IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN
+*
+* Scale matrix norm up to SMLNUM
+*
+ CALL SLASCL( 'G', 0, 0, BNRM, SMLNUM, M, NRHS, B, LDB, INFO )
+ IBSCL = 1
+ ELSE IF( BNRM.GT.BIGNUM ) THEN
+*
+* Scale matrix norm down to BIGNUM
+*
+ CALL SLASCL( 'G', 0, 0, BNRM, BIGNUM, M, NRHS, B, LDB, INFO )
+ IBSCL = 2
+ END IF
+*
+* Overdetermined case
+*
+ IF( M.GE.N ) THEN
+*
+* Path 1 - overdetermined or exactly determined
+*
+ MM = M
+ IF( M.GE.MNTHR ) THEN
+*
+* Path 1a - overdetermined, with many more rows than columns
+*
+ MM = N
+ ITAU = 1
+ IWORK = ITAU + N
+*
+* Compute A=Q*R
+* (Workspace: need 2*N, prefer N+N*NB)
+*
+ CALL SGEQRF( M, N, A, LDA, WORK( ITAU ), WORK( IWORK ),
+ $ LWORK-IWORK+1, INFO )
+*
+* Multiply B by transpose(Q)
+* (Workspace: need N+NRHS, prefer N+NRHS*NB)
+*
+ CALL SORMQR( 'L', 'T', M, NRHS, N, A, LDA, WORK( ITAU ), B,
+ $ LDB, WORK( IWORK ), LWORK-IWORK+1, INFO )
+*
+* Zero out below R
+*
+ IF( N.GT.1 )
+ $ CALL SLASET( 'L', N-1, N-1, ZERO, ZERO, A( 2, 1 ), LDA )
+ END IF
+*
+ IE = 1
+ ITAUQ = IE + N
+ ITAUP = ITAUQ + N
+ IWORK = ITAUP + N
+*
+* Bidiagonalize R in A
+* (Workspace: need 3*N+MM, prefer 3*N+(MM+N)*NB)
+*
+ CALL SGEBRD( MM, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ),
+ $ WORK( ITAUP ), WORK( IWORK ), LWORK-IWORK+1,
+ $ INFO )
+*
+* Multiply B by transpose of left bidiagonalizing vectors of R
+* (Workspace: need 3*N+NRHS, prefer 3*N+NRHS*NB)
+*
+ CALL SORMBR( 'Q', 'L', 'T', MM, NRHS, N, A, LDA, WORK( ITAUQ ),
+ $ B, LDB, WORK( IWORK ), LWORK-IWORK+1, INFO )
+*
+* Generate right bidiagonalizing vectors of R in A
+* (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB)
+*
+ CALL SORGBR( 'P', N, N, N, A, LDA, WORK( ITAUP ),
+ $ WORK( IWORK ), LWORK-IWORK+1, INFO )
+ IWORK = IE + N
+*
+* Perform bidiagonal QR iteration
+* multiply B by transpose of left singular vectors
+* compute right singular vectors in A
+* (Workspace: need BDSPAC)
+*
+ CALL SBDSQR( 'U', N, N, 0, NRHS, S, WORK( IE ), A, LDA, VDUM,
+ $ 1, B, LDB, WORK( IWORK ), INFO )
+ IF( INFO.NE.0 )
+ $ GO TO 70
+*
+* Multiply B by reciprocals of singular values
+*
+ THR = MAX( RCOND*S( 1 ), SFMIN )
+ IF( RCOND.LT.ZERO )
+ $ THR = MAX( EPS*S( 1 ), SFMIN )
+ RANK = 0
+ DO 10 I = 1, N
+ IF( S( I ).GT.THR ) THEN
+ CALL SRSCL( NRHS, S( I ), B( I, 1 ), LDB )
+ RANK = RANK + 1
+ ELSE
+ CALL SLASET( 'F', 1, NRHS, ZERO, ZERO, B( I, 1 ), LDB )
+ END IF
+ 10 CONTINUE
+*
+* Multiply B by right singular vectors
+* (Workspace: need N, prefer N*NRHS)
+*
+ IF( LWORK.GE.LDB*NRHS .AND. NRHS.GT.1 ) THEN
+ CALL SGEMM( 'T', 'N', N, NRHS, N, ONE, A, LDA, B, LDB, ZERO,
+ $ WORK, LDB )
+ CALL SLACPY( 'G', N, NRHS, WORK, LDB, B, LDB )
+ ELSE IF( NRHS.GT.1 ) THEN
+ CHUNK = LWORK / N
+ DO 20 I = 1, NRHS, CHUNK
+ BL = MIN( NRHS-I+1, CHUNK )
+ CALL SGEMM( 'T', 'N', N, BL, N, ONE, A, LDA, B( 1, I ),
+ $ LDB, ZERO, WORK, N )
+ CALL SLACPY( 'G', N, BL, WORK, N, B( 1, I ), LDB )
+ 20 CONTINUE
+ ELSE
+ CALL SGEMV( 'T', N, N, ONE, A, LDA, B, 1, ZERO, WORK, 1 )
+ CALL SCOPY( N, WORK, 1, B, 1 )
+ END IF
+*
+ ELSE IF( N.GE.MNTHR .AND. LWORK.GE.4*M+M*M+
+ $ MAX( M, 2*M-4, NRHS, N-3*M ) ) THEN
+*
+* Path 2a - underdetermined, with many more columns than rows
+* and sufficient workspace for an efficient algorithm
+*
+ LDWORK = M
+ IF( LWORK.GE.MAX( 4*M+M*LDA+MAX( M, 2*M-4, NRHS, N-3*M ),
+ $ M*LDA+M+M*NRHS ) )LDWORK = LDA
+ ITAU = 1
+ IWORK = M + 1
+*
+* Compute A=L*Q
+* (Workspace: need 2*M, prefer M+M*NB)
+*
+ CALL SGELQF( M, N, A, LDA, WORK( ITAU ), WORK( IWORK ),
+ $ LWORK-IWORK+1, INFO )
+ IL = IWORK
+*
+* Copy L to WORK(IL), zeroing out above it
+*
+ CALL SLACPY( 'L', M, M, A, LDA, WORK( IL ), LDWORK )
+ CALL SLASET( 'U', M-1, M-1, ZERO, ZERO, WORK( IL+LDWORK ),
+ $ LDWORK )
+ IE = IL + LDWORK*M
+ ITAUQ = IE + M
+ ITAUP = ITAUQ + M
+ IWORK = ITAUP + M
+*
+* Bidiagonalize L in WORK(IL)
+* (Workspace: need M*M+5*M, prefer M*M+4*M+2*M*NB)
+*
+ CALL SGEBRD( M, M, WORK( IL ), LDWORK, S, WORK( IE ),
+ $ WORK( ITAUQ ), WORK( ITAUP ), WORK( IWORK ),
+ $ LWORK-IWORK+1, INFO )
+*
+* Multiply B by transpose of left bidiagonalizing vectors of L
+* (Workspace: need M*M+4*M+NRHS, prefer M*M+4*M+NRHS*NB)
+*
+ CALL SORMBR( 'Q', 'L', 'T', M, NRHS, M, WORK( IL ), LDWORK,
+ $ WORK( ITAUQ ), B, LDB, WORK( IWORK ),
+ $ LWORK-IWORK+1, INFO )
+*
+* Generate right bidiagonalizing vectors of R in WORK(IL)
+* (Workspace: need M*M+5*M-1, prefer M*M+4*M+(M-1)*NB)
+*
+ CALL SORGBR( 'P', M, M, M, WORK( IL ), LDWORK, WORK( ITAUP ),
+ $ WORK( IWORK ), LWORK-IWORK+1, INFO )
+ IWORK = IE + M
+*
+* Perform bidiagonal QR iteration,
+* computing right singular vectors of L in WORK(IL) and
+* multiplying B by transpose of left singular vectors
+* (Workspace: need M*M+M+BDSPAC)
+*
+ CALL SBDSQR( 'U', M, M, 0, NRHS, S, WORK( IE ), WORK( IL ),
+ $ LDWORK, A, LDA, B, LDB, WORK( IWORK ), INFO )
+ IF( INFO.NE.0 )
+ $ GO TO 70
+*
+* Multiply B by reciprocals of singular values
+*
+ THR = MAX( RCOND*S( 1 ), SFMIN )
+ IF( RCOND.LT.ZERO )
+ $ THR = MAX( EPS*S( 1 ), SFMIN )
+ RANK = 0
+ DO 30 I = 1, M
+ IF( S( I ).GT.THR ) THEN
+ CALL SRSCL( NRHS, S( I ), B( I, 1 ), LDB )
+ RANK = RANK + 1
+ ELSE
+ CALL SLASET( 'F', 1, NRHS, ZERO, ZERO, B( I, 1 ), LDB )
+ END IF
+ 30 CONTINUE
+ IWORK = IE
+*
+* Multiply B by right singular vectors of L in WORK(IL)
+* (Workspace: need M*M+2*M, prefer M*M+M+M*NRHS)
+*
+ IF( LWORK.GE.LDB*NRHS+IWORK-1 .AND. NRHS.GT.1 ) THEN
+ CALL SGEMM( 'T', 'N', M, NRHS, M, ONE, WORK( IL ), LDWORK,
+ $ B, LDB, ZERO, WORK( IWORK ), LDB )
+ CALL SLACPY( 'G', M, NRHS, WORK( IWORK ), LDB, B, LDB )
+ ELSE IF( NRHS.GT.1 ) THEN
+ CHUNK = ( LWORK-IWORK+1 ) / M
+ DO 40 I = 1, NRHS, CHUNK
+ BL = MIN( NRHS-I+1, CHUNK )
+ CALL SGEMM( 'T', 'N', M, BL, M, ONE, WORK( IL ), LDWORK,
+ $ B( 1, I ), LDB, ZERO, WORK( IWORK ), M )
+ CALL SLACPY( 'G', M, BL, WORK( IWORK ), M, B( 1, I ),
+ $ LDB )
+ 40 CONTINUE
+ ELSE
+ CALL SGEMV( 'T', M, M, ONE, WORK( IL ), LDWORK, B( 1, 1 ),
+ $ 1, ZERO, WORK( IWORK ), 1 )
+ CALL SCOPY( M, WORK( IWORK ), 1, B( 1, 1 ), 1 )
+ END IF
+*
+* Zero out below first M rows of B
+*
+ CALL SLASET( 'F', N-M, NRHS, ZERO, ZERO, B( M+1, 1 ), LDB )
+ IWORK = ITAU + M
+*
+* Multiply transpose(Q) by B
+* (Workspace: need M+NRHS, prefer M+NRHS*NB)
+*
+ CALL SORMLQ( 'L', 'T', N, NRHS, M, A, LDA, WORK( ITAU ), B,
+ $ LDB, WORK( IWORK ), LWORK-IWORK+1, INFO )
+*
+ ELSE
+*
+* Path 2 - remaining underdetermined cases
+*
+ IE = 1
+ ITAUQ = IE + M
+ ITAUP = ITAUQ + M
+ IWORK = ITAUP + M
+*
+* Bidiagonalize A
+* (Workspace: need 3*M+N, prefer 3*M+(M+N)*NB)
+*
+ CALL SGEBRD( M, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ),
+ $ WORK( ITAUP ), WORK( IWORK ), LWORK-IWORK+1,
+ $ INFO )
+*
+* Multiply B by transpose of left bidiagonalizing vectors
+* (Workspace: need 3*M+NRHS, prefer 3*M+NRHS*NB)
+*
+ CALL SORMBR( 'Q', 'L', 'T', M, NRHS, N, A, LDA, WORK( ITAUQ ),
+ $ B, LDB, WORK( IWORK ), LWORK-IWORK+1, INFO )
+*
+* Generate right bidiagonalizing vectors in A
+* (Workspace: need 4*M, prefer 3*M+M*NB)
+*
+ CALL SORGBR( 'P', M, N, M, A, LDA, WORK( ITAUP ),
+ $ WORK( IWORK ), LWORK-IWORK+1, INFO )
+ IWORK = IE + M
+*
+* Perform bidiagonal QR iteration,
+* computing right singular vectors of A in A and
+* multiplying B by transpose of left singular vectors
+* (Workspace: need BDSPAC)
+*
+ CALL SBDSQR( 'L', M, N, 0, NRHS, S, WORK( IE ), A, LDA, VDUM,
+ $ 1, B, LDB, WORK( IWORK ), INFO )
+ IF( INFO.NE.0 )
+ $ GO TO 70
+*
+* Multiply B by reciprocals of singular values
+*
+ THR = MAX( RCOND*S( 1 ), SFMIN )
+ IF( RCOND.LT.ZERO )
+ $ THR = MAX( EPS*S( 1 ), SFMIN )
+ RANK = 0
+ DO 50 I = 1, M
+ IF( S( I ).GT.THR ) THEN
+ CALL SRSCL( NRHS, S( I ), B( I, 1 ), LDB )
+ RANK = RANK + 1
+ ELSE
+ CALL SLASET( 'F', 1, NRHS, ZERO, ZERO, B( I, 1 ), LDB )
+ END IF
+ 50 CONTINUE
+*
+* Multiply B by right singular vectors of A
+* (Workspace: need N, prefer N*NRHS)
+*
+ IF( LWORK.GE.LDB*NRHS .AND. NRHS.GT.1 ) THEN
+ CALL SGEMM( 'T', 'N', N, NRHS, M, ONE, A, LDA, B, LDB, ZERO,
+ $ WORK, LDB )
+ CALL SLACPY( 'F', N, NRHS, WORK, LDB, B, LDB )
+ ELSE IF( NRHS.GT.1 ) THEN
+ CHUNK = LWORK / N
+ DO 60 I = 1, NRHS, CHUNK
+ BL = MIN( NRHS-I+1, CHUNK )
+ CALL SGEMM( 'T', 'N', N, BL, M, ONE, A, LDA, B( 1, I ),
+ $ LDB, ZERO, WORK, N )
+ CALL SLACPY( 'F', N, BL, WORK, N, B( 1, I ), LDB )
+ 60 CONTINUE
+ ELSE
+ CALL SGEMV( 'T', M, N, ONE, A, LDA, B, 1, ZERO, WORK, 1 )
+ CALL SCOPY( N, WORK, 1, B, 1 )
+ END IF
+ END IF
+*
+* Undo scaling
+*
+ IF( IASCL.EQ.1 ) THEN
+ CALL SLASCL( 'G', 0, 0, ANRM, SMLNUM, N, NRHS, B, LDB, INFO )
+ CALL SLASCL( 'G', 0, 0, SMLNUM, ANRM, MINMN, 1, S, MINMN,
+ $ INFO )
+ ELSE IF( IASCL.EQ.2 ) THEN
+ CALL SLASCL( 'G', 0, 0, ANRM, BIGNUM, N, NRHS, B, LDB, INFO )
+ CALL SLASCL( 'G', 0, 0, BIGNUM, ANRM, MINMN, 1, S, MINMN,
+ $ INFO )
+ END IF
+ IF( IBSCL.EQ.1 ) THEN
+ CALL SLASCL( 'G', 0, 0, SMLNUM, BNRM, N, NRHS, B, LDB, INFO )
+ ELSE IF( IBSCL.EQ.2 ) THEN
+ CALL SLASCL( 'G', 0, 0, BIGNUM, BNRM, N, NRHS, B, LDB, INFO )
+ END IF
+*
+ 70 CONTINUE
+ WORK( 1 ) = MAXWRK
+ RETURN
+*
+* End of SGELSS
+*
+ END
+ SUBROUTINE SGELSX( M, N, NRHS, A, LDA, B, LDB, JPVT, RCOND, RANK,
+ $ WORK, INFO )
+*
+* -- LAPACK driver routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LDA, LDB, M, N, NRHS, RANK
+ REAL RCOND
+* ..
+* .. Array Arguments ..
+ INTEGER JPVT( * )
+ REAL A( LDA, * ), B( LDB, * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* This routine is deprecated and has been replaced by routine SGELSY.
+*
+* SGELSX computes the minimum-norm solution to a real linear least
+* squares problem:
+* minimize || A * X - B ||
+* using a complete orthogonal factorization of A. A is an M-by-N
+* matrix which may be rank-deficient.
+*
+* Several right hand side vectors b and solution vectors x can be
+* handled in a single call; they are stored as the columns of the
+* M-by-NRHS right hand side matrix B and the N-by-NRHS solution
+* matrix X.
+*
+* The routine first computes a QR factorization with column pivoting:
+* A * P = Q * [ R11 R12 ]
+* [ 0 R22 ]
+* with R11 defined as the largest leading submatrix whose estimated
+* condition number is less than 1/RCOND. The order of R11, RANK,
+* is the effective rank of A.
+*
+* Then, R22 is considered to be negligible, and R12 is annihilated
+* by orthogonal transformations from the right, arriving at the
+* complete orthogonal factorization:
+* A * P = Q * [ T11 0 ] * Z
+* [ 0 0 ]
+* The minimum-norm solution is then
+* X = P * Z' [ inv(T11)*Q1'*B ]
+* [ 0 ]
+* where Q1 consists of the first RANK columns of Q.
+*
+* Arguments
+* =========
+*
+* M (input) INTEGER
+* The number of rows of the matrix A. M >= 0.
+*
+* N (input) INTEGER
+* The number of columns of the matrix A. N >= 0.
+*
+* NRHS (input) INTEGER
+* The number of right hand sides, i.e., the number of
+* columns of matrices B and X. NRHS >= 0.
+*
+* A (input/output) REAL array, dimension (LDA,N)
+* On entry, the M-by-N matrix A.
+* On exit, A has been overwritten by details of its
+* complete orthogonal factorization.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,M).
+*
+* B (input/output) REAL array, dimension (LDB,NRHS)
+* On entry, the M-by-NRHS right hand side matrix B.
+* On exit, the N-by-NRHS solution matrix X.
+* If m >= n and RANK = n, the residual sum-of-squares for
+* the solution in the i-th column is given by the sum of
+* squares of elements N+1:M in that column.
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. LDB >= max(1,M,N).
+*
+* JPVT (input/output) INTEGER array, dimension (N)
+* On entry, if JPVT(i) .ne. 0, the i-th column of A is an
+* initial column, otherwise it is a free column. Before
+* the QR factorization of A, all initial columns are
+* permuted to the leading positions; only the remaining
+* free columns are moved as a result of column pivoting
+* during the factorization.
+* On exit, if JPVT(i) = k, then the i-th column of A*P
+* was the k-th column of A.
+*
+* RCOND (input) REAL
+* RCOND is used to determine the effective rank of A, which
+* is defined as the order of the largest leading triangular
+* submatrix R11 in the QR factorization with pivoting of A,
+* whose estimated condition number < 1/RCOND.
+*
+* RANK (output) INTEGER
+* The effective rank of A, i.e., the order of the submatrix
+* R11. This is the same as the order of the submatrix T11
+* in the complete orthogonal factorization of A.
+*
+* WORK (workspace) REAL array, dimension
+* (max( min(M,N)+3*N, 2*min(M,N)+NRHS )),
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+*
+* =====================================================================
+*
+* .. Parameters ..
+ INTEGER IMAX, IMIN
+ PARAMETER ( IMAX = 1, IMIN = 2 )
+ REAL ZERO, ONE, DONE, NTDONE
+ PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0, DONE = ZERO,
+ $ NTDONE = ONE )
+* ..
+* .. Local Scalars ..
+ INTEGER I, IASCL, IBSCL, ISMAX, ISMIN, J, K, MN
+ REAL ANRM, BIGNUM, BNRM, C1, C2, S1, S2, SMAX,
+ $ SMAXPR, SMIN, SMINPR, SMLNUM, T1, T2
+* ..
+* .. External Functions ..
+ REAL SLAMCH, SLANGE
+ EXTERNAL SLAMCH, SLANGE
+* ..
+* .. External Subroutines ..
+ EXTERNAL SGEQPF, SLABAD, SLAIC1, SLASCL, SLASET, SLATZM,
+ $ SORM2R, STRSM, STZRQF, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+ MN = MIN( M, N )
+ ISMIN = MN + 1
+ ISMAX = 2*MN + 1
+*
+* Test the input arguments.
+*
+ INFO = 0
+ IF( M.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( NRHS.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+ INFO = -5
+ ELSE IF( LDB.LT.MAX( 1, M, N ) ) THEN
+ INFO = -7
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SGELSX', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( MIN( M, N, NRHS ).EQ.0 ) THEN
+ RANK = 0
+ RETURN
+ END IF
+*
+* Get machine parameters
+*
+ SMLNUM = SLAMCH( 'S' ) / SLAMCH( 'P' )
+ BIGNUM = ONE / SMLNUM
+ CALL SLABAD( SMLNUM, BIGNUM )
+*
+* Scale A, B if max elements outside range [SMLNUM,BIGNUM]
+*
+ ANRM = SLANGE( 'M', M, N, A, LDA, WORK )
+ IASCL = 0
+ IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
+*
+* Scale matrix norm up to SMLNUM
+*
+ CALL SLASCL( 'G', 0, 0, ANRM, SMLNUM, M, N, A, LDA, INFO )
+ IASCL = 1
+ ELSE IF( ANRM.GT.BIGNUM ) THEN
+*
+* Scale matrix norm down to BIGNUM
+*
+ CALL SLASCL( 'G', 0, 0, ANRM, BIGNUM, M, N, A, LDA, INFO )
+ IASCL = 2
+ ELSE IF( ANRM.EQ.ZERO ) THEN
+*
+* Matrix all zero. Return zero solution.
+*
+ CALL SLASET( 'F', MAX( M, N ), NRHS, ZERO, ZERO, B, LDB )
+ RANK = 0
+ GO TO 100
+ END IF
+*
+ BNRM = SLANGE( 'M', M, NRHS, B, LDB, WORK )
+ IBSCL = 0
+ IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN
+*
+* Scale matrix norm up to SMLNUM
+*
+ CALL SLASCL( 'G', 0, 0, BNRM, SMLNUM, M, NRHS, B, LDB, INFO )
+ IBSCL = 1
+ ELSE IF( BNRM.GT.BIGNUM ) THEN
+*
+* Scale matrix norm down to BIGNUM
+*
+ CALL SLASCL( 'G', 0, 0, BNRM, BIGNUM, M, NRHS, B, LDB, INFO )
+ IBSCL = 2
+ END IF
+*
+* Compute QR factorization with column pivoting of A:
+* A * P = Q * R
+*
+ CALL SGEQPF( M, N, A, LDA, JPVT, WORK( 1 ), WORK( MN+1 ), INFO )
+*
+* workspace 3*N. Details of Householder rotations stored
+* in WORK(1:MN).
+*
+* Determine RANK using incremental condition estimation
+*
+ WORK( ISMIN ) = ONE
+ WORK( ISMAX ) = ONE
+ SMAX = ABS( A( 1, 1 ) )
+ SMIN = SMAX
+ IF( ABS( A( 1, 1 ) ).EQ.ZERO ) THEN
+ RANK = 0
+ CALL SLASET( 'F', MAX( M, N ), NRHS, ZERO, ZERO, B, LDB )
+ GO TO 100
+ ELSE
+ RANK = 1
+ END IF
+*
+ 10 CONTINUE
+ IF( RANK.LT.MN ) THEN
+ I = RANK + 1
+ CALL SLAIC1( IMIN, RANK, WORK( ISMIN ), SMIN, A( 1, I ),
+ $ A( I, I ), SMINPR, S1, C1 )
+ CALL SLAIC1( IMAX, RANK, WORK( ISMAX ), SMAX, A( 1, I ),
+ $ A( I, I ), SMAXPR, S2, C2 )
+*
+ IF( SMAXPR*RCOND.LE.SMINPR ) THEN
+ DO 20 I = 1, RANK
+ WORK( ISMIN+I-1 ) = S1*WORK( ISMIN+I-1 )
+ WORK( ISMAX+I-1 ) = S2*WORK( ISMAX+I-1 )
+ 20 CONTINUE
+ WORK( ISMIN+RANK ) = C1
+ WORK( ISMAX+RANK ) = C2
+ SMIN = SMINPR
+ SMAX = SMAXPR
+ RANK = RANK + 1
+ GO TO 10
+ END IF
+ END IF
+*
+* Logically partition R = [ R11 R12 ]
+* [ 0 R22 ]
+* where R11 = R(1:RANK,1:RANK)
+*
+* [R11,R12] = [ T11, 0 ] * Y
+*
+ IF( RANK.LT.N )
+ $ CALL STZRQF( RANK, N, A, LDA, WORK( MN+1 ), INFO )
+*
+* Details of Householder rotations stored in WORK(MN+1:2*MN)
+*
+* B(1:M,1:NRHS) := Q' * B(1:M,1:NRHS)
+*
+ CALL SORM2R( 'Left', 'Transpose', M, NRHS, MN, A, LDA, WORK( 1 ),
+ $ B, LDB, WORK( 2*MN+1 ), INFO )
+*
+* workspace NRHS
+*
+* B(1:RANK,1:NRHS) := inv(T11) * B(1:RANK,1:NRHS)
+*
+ CALL STRSM( 'Left', 'Upper', 'No transpose', 'Non-unit', RANK,
+ $ NRHS, ONE, A, LDA, B, LDB )
+*
+ DO 40 I = RANK + 1, N
+ DO 30 J = 1, NRHS
+ B( I, J ) = ZERO
+ 30 CONTINUE
+ 40 CONTINUE
+*
+* B(1:N,1:NRHS) := Y' * B(1:N,1:NRHS)
+*
+ IF( RANK.LT.N ) THEN
+ DO 50 I = 1, RANK
+ CALL SLATZM( 'Left', N-RANK+1, NRHS, A( I, RANK+1 ), LDA,
+ $ WORK( MN+I ), B( I, 1 ), B( RANK+1, 1 ), LDB,
+ $ WORK( 2*MN+1 ) )
+ 50 CONTINUE
+ END IF
+*
+* workspace NRHS
+*
+* B(1:N,1:NRHS) := P * B(1:N,1:NRHS)
+*
+ DO 90 J = 1, NRHS
+ DO 60 I = 1, N
+ WORK( 2*MN+I ) = NTDONE
+ 60 CONTINUE
+ DO 80 I = 1, N
+ IF( WORK( 2*MN+I ).EQ.NTDONE ) THEN
+ IF( JPVT( I ).NE.I ) THEN
+ K = I
+ T1 = B( K, J )
+ T2 = B( JPVT( K ), J )
+ 70 CONTINUE
+ B( JPVT( K ), J ) = T1
+ WORK( 2*MN+K ) = DONE
+ T1 = T2
+ K = JPVT( K )
+ T2 = B( JPVT( K ), J )
+ IF( JPVT( K ).NE.I )
+ $ GO TO 70
+ B( I, J ) = T1
+ WORK( 2*MN+K ) = DONE
+ END IF
+ END IF
+ 80 CONTINUE
+ 90 CONTINUE
+*
+* Undo scaling
+*
+ IF( IASCL.EQ.1 ) THEN
+ CALL SLASCL( 'G', 0, 0, ANRM, SMLNUM, N, NRHS, B, LDB, INFO )
+ CALL SLASCL( 'U', 0, 0, SMLNUM, ANRM, RANK, RANK, A, LDA,
+ $ INFO )
+ ELSE IF( IASCL.EQ.2 ) THEN
+ CALL SLASCL( 'G', 0, 0, ANRM, BIGNUM, N, NRHS, B, LDB, INFO )
+ CALL SLASCL( 'U', 0, 0, BIGNUM, ANRM, RANK, RANK, A, LDA,
+ $ INFO )
+ END IF
+ IF( IBSCL.EQ.1 ) THEN
+ CALL SLASCL( 'G', 0, 0, SMLNUM, BNRM, N, NRHS, B, LDB, INFO )
+ ELSE IF( IBSCL.EQ.2 ) THEN
+ CALL SLASCL( 'G', 0, 0, BIGNUM, BNRM, N, NRHS, B, LDB, INFO )
+ END IF
+*
+ 100 CONTINUE
+*
+ RETURN
+*
+* End of SGELSX
+*
+ END
+ SUBROUTINE SGELSY( M, N, NRHS, A, LDA, B, LDB, JPVT, RCOND, RANK,
+ $ WORK, LWORK, INFO )
+*
+* -- LAPACK driver routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LDA, LDB, LWORK, M, N, NRHS, RANK
+ REAL RCOND
+* ..
+* .. Array Arguments ..
+ INTEGER JPVT( * )
+ REAL A( LDA, * ), B( LDB, * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SGELSY computes the minimum-norm solution to a real linear least
+* squares problem:
+* minimize || A * X - B ||
+* using a complete orthogonal factorization of A. A is an M-by-N
+* matrix which may be rank-deficient.
+*
+* Several right hand side vectors b and solution vectors x can be
+* handled in a single call; they are stored as the columns of the
+* M-by-NRHS right hand side matrix B and the N-by-NRHS solution
+* matrix X.
+*
+* The routine first computes a QR factorization with column pivoting:
+* A * P = Q * [ R11 R12 ]
+* [ 0 R22 ]
+* with R11 defined as the largest leading submatrix whose estimated
+* condition number is less than 1/RCOND. The order of R11, RANK,
+* is the effective rank of A.
+*
+* Then, R22 is considered to be negligible, and R12 is annihilated
+* by orthogonal transformations from the right, arriving at the
+* complete orthogonal factorization:
+* A * P = Q * [ T11 0 ] * Z
+* [ 0 0 ]
+* The minimum-norm solution is then
+* X = P * Z' [ inv(T11)*Q1'*B ]
+* [ 0 ]
+* where Q1 consists of the first RANK columns of Q.
+*
+* This routine is basically identical to the original xGELSX except
+* three differences:
+* o The call to the subroutine xGEQPF has been substituted by the
+* the call to the subroutine xGEQP3. This subroutine is a Blas-3
+* version of the QR factorization with column pivoting.
+* o Matrix B (the right hand side) is updated with Blas-3.
+* o The permutation of matrix B (the right hand side) is faster and
+* more simple.
+*
+* Arguments
+* =========
+*
+* M (input) INTEGER
+* The number of rows of the matrix A. M >= 0.
+*
+* N (input) INTEGER
+* The number of columns of the matrix A. N >= 0.
+*
+* NRHS (input) INTEGER
+* The number of right hand sides, i.e., the number of
+* columns of matrices B and X. NRHS >= 0.
+*
+* A (input/output) REAL array, dimension (LDA,N)
+* On entry, the M-by-N matrix A.
+* On exit, A has been overwritten by details of its
+* complete orthogonal factorization.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,M).
+*
+* B (input/output) REAL array, dimension (LDB,NRHS)
+* On entry, the M-by-NRHS right hand side matrix B.
+* On exit, the N-by-NRHS solution matrix X.
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. LDB >= max(1,M,N).
+*
+* JPVT (input/output) INTEGER array, dimension (N)
+* On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted
+* to the front of AP, otherwise column i is a free column.
+* On exit, if JPVT(i) = k, then the i-th column of AP
+* was the k-th column of A.
+*
+* RCOND (input) REAL
+* RCOND is used to determine the effective rank of A, which
+* is defined as the order of the largest leading triangular
+* submatrix R11 in the QR factorization with pivoting of A,
+* whose estimated condition number < 1/RCOND.
+*
+* RANK (output) INTEGER
+* The effective rank of A, i.e., the order of the submatrix
+* R11. This is the same as the order of the submatrix T11
+* in the complete orthogonal factorization of A.
+*
+* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))
+* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+* LWORK (input) INTEGER
+* The dimension of the array WORK.
+* The unblocked strategy requires that:
+* LWORK >= MAX( MN+3*N+1, 2*MN+NRHS ),
+* where MN = min( M, N ).
+* The block algorithm requires that:
+* LWORK >= MAX( MN+2*N+NB*(N+1), 2*MN+NB*NRHS ),
+* where NB is an upper bound on the blocksize returned
+* by ILAENV for the routines SGEQP3, STZRZF, STZRQF, SORMQR,
+* and SORMRZ.
+*
+* If LWORK = -1, then a workspace query is assumed; the routine
+* only calculates the optimal size of the WORK array, returns
+* this value as the first entry of the WORK array, and no error
+* message related to LWORK is issued by XERBLA.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: If INFO = -i, the i-th argument had an illegal value.
+*
+* Further Details
+* ===============
+*
+* Based on contributions by
+* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA
+* E. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain
+* G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain
+*
+* =====================================================================
+*
+* .. Parameters ..
+ INTEGER IMAX, IMIN
+ PARAMETER ( IMAX = 1, IMIN = 2 )
+ REAL ZERO, ONE
+ PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL LQUERY
+ INTEGER I, IASCL, IBSCL, ISMAX, ISMIN, J, LWKMIN,
+ $ LWKOPT, MN, NB, NB1, NB2, NB3, NB4
+ REAL ANRM, BIGNUM, BNRM, C1, C2, S1, S2, SMAX,
+ $ SMAXPR, SMIN, SMINPR, SMLNUM, WSIZE
+* ..
+* .. External Functions ..
+ INTEGER ILAENV
+ REAL SLAMCH, SLANGE
+ EXTERNAL ILAENV, SLAMCH, SLANGE
+* ..
+* .. External Subroutines ..
+ EXTERNAL SCOPY, SGEQP3, SLABAD, SLAIC1, SLASCL, SLASET,
+ $ SORMQR, SORMRZ, STRSM, STZRZF, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+ MN = MIN( M, N )
+ ISMIN = MN + 1
+ ISMAX = 2*MN + 1
+*
+* Test the input arguments.
+*
+ INFO = 0
+ LQUERY = ( LWORK.EQ.-1 )
+ IF( M.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( NRHS.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+ INFO = -5
+ ELSE IF( LDB.LT.MAX( 1, M, N ) ) THEN
+ INFO = -7
+ END IF
+*
+* Figure out optimal block size
+*
+ IF( INFO.EQ.0 ) THEN
+ IF( MN.EQ.0 .OR. NRHS.EQ.0 ) THEN
+ LWKMIN = 1
+ LWKOPT = 1
+ ELSE
+ NB1 = ILAENV( 1, 'SGEQRF', ' ', M, N, -1, -1 )
+ NB2 = ILAENV( 1, 'SGERQF', ' ', M, N, -1, -1 )
+ NB3 = ILAENV( 1, 'SORMQR', ' ', M, N, NRHS, -1 )
+ NB4 = ILAENV( 1, 'SORMRQ', ' ', M, N, NRHS, -1 )
+ NB = MAX( NB1, NB2, NB3, NB4 )
+ LWKMIN = MN + MAX( 2*MN, N + 1, MN + NRHS )
+ LWKOPT = MAX( LWKMIN,
+ $ MN + 2*N + NB*( N + 1 ), 2*MN + NB*NRHS )
+ END IF
+ WORK( 1 ) = LWKOPT
+*
+ IF( LWORK.LT.LWKMIN .AND. .NOT.LQUERY ) THEN
+ INFO = -12
+ END IF
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SGELSY', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( MN.EQ.0 .OR. NRHS.EQ.0 ) THEN
+ RANK = 0
+ RETURN
+ END IF
+*
+* Get machine parameters
+*
+ SMLNUM = SLAMCH( 'S' ) / SLAMCH( 'P' )
+ BIGNUM = ONE / SMLNUM
+ CALL SLABAD( SMLNUM, BIGNUM )
+*
+* Scale A, B if max entries outside range [SMLNUM,BIGNUM]
+*
+ ANRM = SLANGE( 'M', M, N, A, LDA, WORK )
+ IASCL = 0
+ IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
+*
+* Scale matrix norm up to SMLNUM
+*
+ CALL SLASCL( 'G', 0, 0, ANRM, SMLNUM, M, N, A, LDA, INFO )
+ IASCL = 1
+ ELSE IF( ANRM.GT.BIGNUM ) THEN
+*
+* Scale matrix norm down to BIGNUM
+*
+ CALL SLASCL( 'G', 0, 0, ANRM, BIGNUM, M, N, A, LDA, INFO )
+ IASCL = 2
+ ELSE IF( ANRM.EQ.ZERO ) THEN
+*
+* Matrix all zero. Return zero solution.
+*
+ CALL SLASET( 'F', MAX( M, N ), NRHS, ZERO, ZERO, B, LDB )
+ RANK = 0
+ GO TO 70
+ END IF
+*
+ BNRM = SLANGE( 'M', M, NRHS, B, LDB, WORK )
+ IBSCL = 0
+ IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN
+*
+* Scale matrix norm up to SMLNUM
+*
+ CALL SLASCL( 'G', 0, 0, BNRM, SMLNUM, M, NRHS, B, LDB, INFO )
+ IBSCL = 1
+ ELSE IF( BNRM.GT.BIGNUM ) THEN
+*
+* Scale matrix norm down to BIGNUM
+*
+ CALL SLASCL( 'G', 0, 0, BNRM, BIGNUM, M, NRHS, B, LDB, INFO )
+ IBSCL = 2
+ END IF
+*
+* Compute QR factorization with column pivoting of A:
+* A * P = Q * R
+*
+ CALL SGEQP3( M, N, A, LDA, JPVT, WORK( 1 ), WORK( MN+1 ),
+ $ LWORK-MN, INFO )
+ WSIZE = MN + WORK( MN+1 )
+*
+* workspace: MN+2*N+NB*(N+1).
+* Details of Householder rotations stored in WORK(1:MN).
+*
+* Determine RANK using incremental condition estimation
+*
+ WORK( ISMIN ) = ONE
+ WORK( ISMAX ) = ONE
+ SMAX = ABS( A( 1, 1 ) )
+ SMIN = SMAX
+ IF( ABS( A( 1, 1 ) ).EQ.ZERO ) THEN
+ RANK = 0
+ CALL SLASET( 'F', MAX( M, N ), NRHS, ZERO, ZERO, B, LDB )
+ GO TO 70
+ ELSE
+ RANK = 1
+ END IF
+*
+ 10 CONTINUE
+ IF( RANK.LT.MN ) THEN
+ I = RANK + 1
+ CALL SLAIC1( IMIN, RANK, WORK( ISMIN ), SMIN, A( 1, I ),
+ $ A( I, I ), SMINPR, S1, C1 )
+ CALL SLAIC1( IMAX, RANK, WORK( ISMAX ), SMAX, A( 1, I ),
+ $ A( I, I ), SMAXPR, S2, C2 )
+*
+ IF( SMAXPR*RCOND.LE.SMINPR ) THEN
+ DO 20 I = 1, RANK
+ WORK( ISMIN+I-1 ) = S1*WORK( ISMIN+I-1 )
+ WORK( ISMAX+I-1 ) = S2*WORK( ISMAX+I-1 )
+ 20 CONTINUE
+ WORK( ISMIN+RANK ) = C1
+ WORK( ISMAX+RANK ) = C2
+ SMIN = SMINPR
+ SMAX = SMAXPR
+ RANK = RANK + 1
+ GO TO 10
+ END IF
+ END IF
+*
+* workspace: 3*MN.
+*
+* Logically partition R = [ R11 R12 ]
+* [ 0 R22 ]
+* where R11 = R(1:RANK,1:RANK)
+*
+* [R11,R12] = [ T11, 0 ] * Y
+*
+ IF( RANK.LT.N )
+ $ CALL STZRZF( RANK, N, A, LDA, WORK( MN+1 ), WORK( 2*MN+1 ),
+ $ LWORK-2*MN, INFO )
+*
+* workspace: 2*MN.
+* Details of Householder rotations stored in WORK(MN+1:2*MN)
+*
+* B(1:M,1:NRHS) := Q' * B(1:M,1:NRHS)
+*
+ CALL SORMQR( 'Left', 'Transpose', M, NRHS, MN, A, LDA, WORK( 1 ),
+ $ B, LDB, WORK( 2*MN+1 ), LWORK-2*MN, INFO )
+ WSIZE = MAX( WSIZE, 2*MN+WORK( 2*MN+1 ) )
+*
+* workspace: 2*MN+NB*NRHS.
+*
+* B(1:RANK,1:NRHS) := inv(T11) * B(1:RANK,1:NRHS)
+*
+ CALL STRSM( 'Left', 'Upper', 'No transpose', 'Non-unit', RANK,
+ $ NRHS, ONE, A, LDA, B, LDB )
+*
+ DO 40 J = 1, NRHS
+ DO 30 I = RANK + 1, N
+ B( I, J ) = ZERO
+ 30 CONTINUE
+ 40 CONTINUE
+*
+* B(1:N,1:NRHS) := Y' * B(1:N,1:NRHS)
+*
+ IF( RANK.LT.N ) THEN
+ CALL SORMRZ( 'Left', 'Transpose', N, NRHS, RANK, N-RANK, A,
+ $ LDA, WORK( MN+1 ), B, LDB, WORK( 2*MN+1 ),
+ $ LWORK-2*MN, INFO )
+ END IF
+*
+* workspace: 2*MN+NRHS.
+*
+* B(1:N,1:NRHS) := P * B(1:N,1:NRHS)
+*
+ DO 60 J = 1, NRHS
+ DO 50 I = 1, N
+ WORK( JPVT( I ) ) = B( I, J )
+ 50 CONTINUE
+ CALL SCOPY( N, WORK( 1 ), 1, B( 1, J ), 1 )
+ 60 CONTINUE
+*
+* workspace: N.
+*
+* Undo scaling
+*
+ IF( IASCL.EQ.1 ) THEN
+ CALL SLASCL( 'G', 0, 0, ANRM, SMLNUM, N, NRHS, B, LDB, INFO )
+ CALL SLASCL( 'U', 0, 0, SMLNUM, ANRM, RANK, RANK, A, LDA,
+ $ INFO )
+ ELSE IF( IASCL.EQ.2 ) THEN
+ CALL SLASCL( 'G', 0, 0, ANRM, BIGNUM, N, NRHS, B, LDB, INFO )
+ CALL SLASCL( 'U', 0, 0, BIGNUM, ANRM, RANK, RANK, A, LDA,
+ $ INFO )
+ END IF
+ IF( IBSCL.EQ.1 ) THEN
+ CALL SLASCL( 'G', 0, 0, SMLNUM, BNRM, N, NRHS, B, LDB, INFO )
+ ELSE IF( IBSCL.EQ.2 ) THEN
+ CALL SLASCL( 'G', 0, 0, BIGNUM, BNRM, N, NRHS, B, LDB, INFO )
+ END IF
+*
+ 70 CONTINUE
+ WORK( 1 ) = LWKOPT
+*
+ RETURN
+*
+* End of SGELSY
+*
+ END
+ SUBROUTINE SGEQL2( M, N, A, LDA, TAU, WORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LDA, M, N
+* ..
+* .. Array Arguments ..
+ REAL A( LDA, * ), TAU( * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SGEQL2 computes a QL factorization of a real m by n matrix A:
+* A = Q * L.
+*
+* Arguments
+* =========
+*
+* M (input) INTEGER
+* The number of rows of the matrix A. M >= 0.
+*
+* N (input) INTEGER
+* The number of columns of the matrix A. N >= 0.
+*
+* A (input/output) REAL array, dimension (LDA,N)
+* On entry, the m by n matrix A.
+* On exit, if m >= n, the lower triangle of the subarray
+* A(m-n+1:m,1:n) contains the n by n lower triangular matrix L;
+* if m <= n, the elements on and below the (n-m)-th
+* superdiagonal contain the m by n lower trapezoidal matrix L;
+* the remaining elements, with the array TAU, represent the
+* orthogonal matrix Q as a product of elementary reflectors
+* (see Further Details).
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,M).
+*
+* TAU (output) REAL array, dimension (min(M,N))
+* The scalar factors of the elementary reflectors (see Further
+* Details).
+*
+* WORK (workspace) REAL array, dimension (N)
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+*
+* Further Details
+* ===============
+*
+* The matrix Q is represented as a product of elementary reflectors
+*
+* Q = H(k) . . . H(2) H(1), where k = min(m,n).
+*
+* Each H(i) has the form
+*
+* H(i) = I - tau * v * v'
+*
+* where tau is a real scalar, and v is a real vector with
+* v(m-k+i+1:m) = 0 and v(m-k+i) = 1; v(1:m-k+i-1) is stored on exit in
+* A(1:m-k+i-1,n-k+i), and tau in TAU(i).
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ONE
+ PARAMETER ( ONE = 1.0E+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, K
+ REAL AII
+* ..
+* .. External Subroutines ..
+ EXTERNAL SLARF, SLARFG, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+* Test the input arguments
+*
+ INFO = 0
+ IF( M.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+ INFO = -4
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SGEQL2', -INFO )
+ RETURN
+ END IF
+*
+ K = MIN( M, N )
+*
+ DO 10 I = K, 1, -1
+*
+* Generate elementary reflector H(i) to annihilate
+* A(1:m-k+i-1,n-k+i)
+*
+ CALL SLARFG( M-K+I, A( M-K+I, N-K+I ), A( 1, N-K+I ), 1,
+ $ TAU( I ) )
+*
+* Apply H(i) to A(1:m-k+i,1:n-k+i-1) from the left
+*
+ AII = A( M-K+I, N-K+I )
+ A( M-K+I, N-K+I ) = ONE
+ CALL SLARF( 'Left', M-K+I, N-K+I-1, A( 1, N-K+I ), 1, TAU( I ),
+ $ A, LDA, WORK )
+ A( M-K+I, N-K+I ) = AII
+ 10 CONTINUE
+ RETURN
+*
+* End of SGEQL2
+*
+ END
+ SUBROUTINE SGEQLF( M, N, A, LDA, TAU, WORK, LWORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LDA, LWORK, M, N
+* ..
+* .. Array Arguments ..
+ REAL A( LDA, * ), TAU( * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SGEQLF computes a QL factorization of a real M-by-N matrix A:
+* A = Q * L.
+*
+* Arguments
+* =========
+*
+* M (input) INTEGER
+* The number of rows of the matrix A. M >= 0.
+*
+* N (input) INTEGER
+* The number of columns of the matrix A. N >= 0.
+*
+* A (input/output) REAL array, dimension (LDA,N)
+* On entry, the M-by-N matrix A.
+* On exit,
+* if m >= n, the lower triangle of the subarray
+* A(m-n+1:m,1:n) contains the N-by-N lower triangular matrix L;
+* if m <= n, the elements on and below the (n-m)-th
+* superdiagonal contain the M-by-N lower trapezoidal matrix L;
+* the remaining elements, with the array TAU, represent the
+* orthogonal matrix Q as a product of elementary reflectors
+* (see Further Details).
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,M).
+*
+* TAU (output) REAL array, dimension (min(M,N))
+* The scalar factors of the elementary reflectors (see Further
+* Details).
+*
+* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))
+* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+* LWORK (input) INTEGER
+* The dimension of the array WORK. LWORK >= max(1,N).
+* For optimum performance LWORK >= N*NB, where NB is the
+* optimal blocksize.
+*
+* If LWORK = -1, then a workspace query is assumed; the routine
+* only calculates the optimal size of the WORK array, returns
+* this value as the first entry of the WORK array, and no error
+* message related to LWORK is issued by XERBLA.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+*
+* Further Details
+* ===============
+*
+* The matrix Q is represented as a product of elementary reflectors
+*
+* Q = H(k) . . . H(2) H(1), where k = min(m,n).
+*
+* Each H(i) has the form
+*
+* H(i) = I - tau * v * v'
+*
+* where tau is a real scalar, and v is a real vector with
+* v(m-k+i+1:m) = 0 and v(m-k+i) = 1; v(1:m-k+i-1) is stored on exit in
+* A(1:m-k+i-1,n-k+i), and tau in TAU(i).
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ LOGICAL LQUERY
+ INTEGER I, IB, IINFO, IWS, K, KI, KK, LDWORK, LWKOPT,
+ $ MU, NB, NBMIN, NU, NX
+* ..
+* .. External Subroutines ..
+ EXTERNAL SGEQL2, SLARFB, SLARFT, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN
+* ..
+* .. External Functions ..
+ INTEGER ILAENV
+ EXTERNAL ILAENV
+* ..
+* .. Executable Statements ..
+*
+* Test the input arguments
+*
+ INFO = 0
+ LQUERY = ( LWORK.EQ.-1 )
+ IF( M.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+ INFO = -4
+ END IF
+*
+ IF( INFO.EQ.0 ) THEN
+ K = MIN( M, N )
+ IF( K.EQ.0 ) THEN
+ LWKOPT = 1
+ ELSE
+ NB = ILAENV( 1, 'SGEQLF', ' ', M, N, -1, -1 )
+ LWKOPT = N*NB
+ END IF
+ WORK( 1 ) = LWKOPT
+*
+ IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN
+ INFO = -7
+ END IF
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SGEQLF', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( K.EQ.0 ) THEN
+ RETURN
+ END IF
+*
+ NBMIN = 2
+ NX = 1
+ IWS = N
+ IF( NB.GT.1 .AND. NB.LT.K ) THEN
+*
+* Determine when to cross over from blocked to unblocked code.
+*
+ NX = MAX( 0, ILAENV( 3, 'SGEQLF', ' ', M, N, -1, -1 ) )
+ IF( NX.LT.K ) THEN
+*
+* Determine if workspace is large enough for blocked code.
+*
+ LDWORK = N
+ IWS = LDWORK*NB
+ IF( LWORK.LT.IWS ) THEN
+*
+* Not enough workspace to use optimal NB: reduce NB and
+* determine the minimum value of NB.
+*
+ NB = LWORK / LDWORK
+ NBMIN = MAX( 2, ILAENV( 2, 'SGEQLF', ' ', M, N, -1,
+ $ -1 ) )
+ END IF
+ END IF
+ END IF
+*
+ IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN
+*
+* Use blocked code initially.
+* The last kk columns are handled by the block method.
+*
+ KI = ( ( K-NX-1 ) / NB )*NB
+ KK = MIN( K, KI+NB )
+*
+ DO 10 I = K - KK + KI + 1, K - KK + 1, -NB
+ IB = MIN( K-I+1, NB )
+*
+* Compute the QL factorization of the current block
+* A(1:m-k+i+ib-1,n-k+i:n-k+i+ib-1)
+*
+ CALL SGEQL2( M-K+I+IB-1, IB, A( 1, N-K+I ), LDA, TAU( I ),
+ $ WORK, IINFO )
+ IF( N-K+I.GT.1 ) THEN
+*
+* Form the triangular factor of the block reflector
+* H = H(i+ib-1) . . . H(i+1) H(i)
+*
+ CALL SLARFT( 'Backward', 'Columnwise', M-K+I+IB-1, IB,
+ $ A( 1, N-K+I ), LDA, TAU( I ), WORK, LDWORK )
+*
+* Apply H' to A(1:m-k+i+ib-1,1:n-k+i-1) from the left
+*
+ CALL SLARFB( 'Left', 'Transpose', 'Backward',
+ $ 'Columnwise', M-K+I+IB-1, N-K+I-1, IB,
+ $ A( 1, N-K+I ), LDA, WORK, LDWORK, A, LDA,
+ $ WORK( IB+1 ), LDWORK )
+ END IF
+ 10 CONTINUE
+ MU = M - K + I + NB - 1
+ NU = N - K + I + NB - 1
+ ELSE
+ MU = M
+ NU = N
+ END IF
+*
+* Use unblocked code to factor the last or only block
+*
+ IF( MU.GT.0 .AND. NU.GT.0 )
+ $ CALL SGEQL2( MU, NU, A, LDA, TAU, WORK, IINFO )
+*
+ WORK( 1 ) = IWS
+ RETURN
+*
+* End of SGEQLF
+*
+ END
+ SUBROUTINE SGEQP3( M, N, A, LDA, JPVT, TAU, WORK, LWORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LDA, LWORK, M, N
+* ..
+* .. Array Arguments ..
+ INTEGER JPVT( * )
+ REAL A( LDA, * ), TAU( * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SGEQP3 computes a QR factorization with column pivoting of a
+* matrix A: A*P = Q*R using Level 3 BLAS.
+*
+* Arguments
+* =========
+*
+* M (input) INTEGER
+* The number of rows of the matrix A. M >= 0.
+*
+* N (input) INTEGER
+* The number of columns of the matrix A. N >= 0.
+*
+* A (input/output) REAL array, dimension (LDA,N)
+* On entry, the M-by-N matrix A.
+* On exit, the upper triangle of the array contains the
+* min(M,N)-by-N upper trapezoidal matrix R; the elements below
+* the diagonal, together with the array TAU, represent the
+* orthogonal matrix Q as a product of min(M,N) elementary
+* reflectors.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,M).
+*
+* JPVT (input/output) INTEGER array, dimension (N)
+* On entry, if JPVT(J).ne.0, the J-th column of A is permuted
+* to the front of A*P (a leading column); if JPVT(J)=0,
+* the J-th column of A is a free column.
+* On exit, if JPVT(J)=K, then the J-th column of A*P was the
+* the K-th column of A.
+*
+* TAU (output) REAL array, dimension (min(M,N))
+* The scalar factors of the elementary reflectors.
+*
+* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))
+* On exit, if INFO=0, WORK(1) returns the optimal LWORK.
+*
+* LWORK (input) INTEGER
+* The dimension of the array WORK. LWORK >= 3*N+1.
+* For optimal performance LWORK >= 2*N+( N+1 )*NB, where NB
+* is the optimal blocksize.
+*
+* If LWORK = -1, then a workspace query is assumed; the routine
+* only calculates the optimal size of the WORK array, returns
+* this value as the first entry of the WORK array, and no error
+* message related to LWORK is issued by XERBLA.
+*
+* INFO (output) INTEGER
+* = 0: successful exit.
+* < 0: if INFO = -i, the i-th argument had an illegal value.
+*
+* Further Details
+* ===============
+*
+* The matrix Q is represented as a product of elementary reflectors
+*
+* Q = H(1) H(2) . . . H(k), where k = min(m,n).
+*
+* Each H(i) has the form
+*
+* H(i) = I - tau * v * v'
+*
+* where tau is a real/complex scalar, and v is a real/complex vector
+* with v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in
+* A(i+1:m,i), and tau in TAU(i).
+*
+* Based on contributions by
+* G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain
+* X. Sun, Computer Science Dept., Duke University, USA
+*
+* =====================================================================
+*
+* .. Parameters ..
+ INTEGER INB, INBMIN, IXOVER
+ PARAMETER ( INB = 1, INBMIN = 2, IXOVER = 3 )
+* ..
+* .. Local Scalars ..
+ LOGICAL LQUERY
+ INTEGER FJB, IWS, J, JB, LWKOPT, MINMN, MINWS, NA, NB,
+ $ NBMIN, NFXD, NX, SM, SMINMN, SN, TOPBMN
+* ..
+* .. External Subroutines ..
+ EXTERNAL SGEQRF, SLAQP2, SLAQPS, SORMQR, SSWAP, XERBLA
+* ..
+* .. External Functions ..
+ INTEGER ILAENV
+ REAL SNRM2
+ EXTERNAL ILAENV, SNRM2
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC INT, MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+ INFO = 0
+ LQUERY = ( LWORK.EQ.-1 )
+ IF( M.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+ INFO = -4
+ END IF
+*
+ IF( INFO.EQ.0 ) THEN
+ MINMN = MIN( M, N )
+ IF( MINMN.EQ.0 ) THEN
+ IWS = 1
+ LWKOPT = 1
+ ELSE
+ IWS = 3*N + 1
+ NB = ILAENV( INB, 'SGEQRF', ' ', M, N, -1, -1 )
+ LWKOPT = 2*N + ( N + 1 )*NB
+ END IF
+ WORK( 1 ) = LWKOPT
+*
+ IF( ( LWORK.LT.IWS ) .AND. .NOT.LQUERY ) THEN
+ INFO = -8
+ END IF
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SGEQP3', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible.
+*
+ IF( MINMN.EQ.0 ) THEN
+ RETURN
+ END IF
+*
+* Move initial columns up front.
+*
+ NFXD = 1
+ DO 10 J = 1, N
+ IF( JPVT( J ).NE.0 ) THEN
+ IF( J.NE.NFXD ) THEN
+ CALL SSWAP( M, A( 1, J ), 1, A( 1, NFXD ), 1 )
+ JPVT( J ) = JPVT( NFXD )
+ JPVT( NFXD ) = J
+ ELSE
+ JPVT( J ) = J
+ END IF
+ NFXD = NFXD + 1
+ ELSE
+ JPVT( J ) = J
+ END IF
+ 10 CONTINUE
+ NFXD = NFXD - 1
+*
+* Factorize fixed columns
+* =======================
+*
+* Compute the QR factorization of fixed columns and update
+* remaining columns.
+*
+ IF( NFXD.GT.0 ) THEN
+ NA = MIN( M, NFXD )
+*CC CALL SGEQR2( M, NA, A, LDA, TAU, WORK, INFO )
+ CALL SGEQRF( M, NA, A, LDA, TAU, WORK, LWORK, INFO )
+ IWS = MAX( IWS, INT( WORK( 1 ) ) )
+ IF( NA.LT.N ) THEN
+*CC CALL SORM2R( 'Left', 'Transpose', M, N-NA, NA, A, LDA,
+*CC $ TAU, A( 1, NA+1 ), LDA, WORK, INFO )
+ CALL SORMQR( 'Left', 'Transpose', M, N-NA, NA, A, LDA, TAU,
+ $ A( 1, NA+1 ), LDA, WORK, LWORK, INFO )
+ IWS = MAX( IWS, INT( WORK( 1 ) ) )
+ END IF
+ END IF
+*
+* Factorize free columns
+* ======================
+*
+ IF( NFXD.LT.MINMN ) THEN
+*
+ SM = M - NFXD
+ SN = N - NFXD
+ SMINMN = MINMN - NFXD
+*
+* Determine the block size.
+*
+ NB = ILAENV( INB, 'SGEQRF', ' ', SM, SN, -1, -1 )
+ NBMIN = 2
+ NX = 0
+*
+ IF( ( NB.GT.1 ) .AND. ( NB.LT.SMINMN ) ) THEN
+*
+* Determine when to cross over from blocked to unblocked code.
+*
+ NX = MAX( 0, ILAENV( IXOVER, 'SGEQRF', ' ', SM, SN, -1,
+ $ -1 ) )
+*
+*
+ IF( NX.LT.SMINMN ) THEN
+*
+* Determine if workspace is large enough for blocked code.
+*
+ MINWS = 2*SN + ( SN+1 )*NB
+ IWS = MAX( IWS, MINWS )
+ IF( LWORK.LT.MINWS ) THEN
+*
+* Not enough workspace to use optimal NB: Reduce NB and
+* determine the minimum value of NB.
+*
+ NB = ( LWORK-2*SN ) / ( SN+1 )
+ NBMIN = MAX( 2, ILAENV( INBMIN, 'SGEQRF', ' ', SM, SN,
+ $ -1, -1 ) )
+*
+*
+ END IF
+ END IF
+ END IF
+*
+* Initialize partial column norms. The first N elements of work
+* store the exact column norms.
+*
+ DO 20 J = NFXD + 1, N
+ WORK( J ) = SNRM2( SM, A( NFXD+1, J ), 1 )
+ WORK( N+J ) = WORK( J )
+ 20 CONTINUE
+*
+ IF( ( NB.GE.NBMIN ) .AND. ( NB.LT.SMINMN ) .AND.
+ $ ( NX.LT.SMINMN ) ) THEN
+*
+* Use blocked code initially.
+*
+ J = NFXD + 1
+*
+* Compute factorization: while loop.
+*
+*
+ TOPBMN = MINMN - NX
+ 30 CONTINUE
+ IF( J.LE.TOPBMN ) THEN
+ JB = MIN( NB, TOPBMN-J+1 )
+*
+* Factorize JB columns among columns J:N.
+*
+ CALL SLAQPS( M, N-J+1, J-1, JB, FJB, A( 1, J ), LDA,
+ $ JPVT( J ), TAU( J ), WORK( J ), WORK( N+J ),
+ $ WORK( 2*N+1 ), WORK( 2*N+JB+1 ), N-J+1 )
+*
+ J = J + FJB
+ GO TO 30
+ END IF
+ ELSE
+ J = NFXD + 1
+ END IF
+*
+* Use unblocked code to factor the last or only block.
+*
+*
+ IF( J.LE.MINMN )
+ $ CALL SLAQP2( M, N-J+1, J-1, A( 1, J ), LDA, JPVT( J ),
+ $ TAU( J ), WORK( J ), WORK( N+J ),
+ $ WORK( 2*N+1 ) )
+*
+ END IF
+*
+ WORK( 1 ) = IWS
+ RETURN
+*
+* End of SGEQP3
+*
+ END
+ SUBROUTINE SGEQPF( M, N, A, LDA, JPVT, TAU, WORK, INFO )
+*
+* -- LAPACK deprecated driver routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LDA, M, N
+* ..
+* .. Array Arguments ..
+ INTEGER JPVT( * )
+ REAL A( LDA, * ), TAU( * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* This routine is deprecated and has been replaced by routine SGEQP3.
+*
+* SGEQPF computes a QR factorization with column pivoting of a
+* real M-by-N matrix A: A*P = Q*R.
+*
+* Arguments
+* =========
+*
+* M (input) INTEGER
+* The number of rows of the matrix A. M >= 0.
+*
+* N (input) INTEGER
+* The number of columns of the matrix A. N >= 0
+*
+* A (input/output) REAL array, dimension (LDA,N)
+* On entry, the M-by-N matrix A.
+* On exit, the upper triangle of the array contains the
+* min(M,N)-by-N upper triangular matrix R; the elements
+* below the diagonal, together with the array TAU,
+* represent the orthogonal matrix Q as a product of
+* min(m,n) elementary reflectors.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,M).
+*
+* JPVT (input/output) INTEGER array, dimension (N)
+* On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted
+* to the front of A*P (a leading column); if JPVT(i) = 0,
+* the i-th column of A is a free column.
+* On exit, if JPVT(i) = k, then the i-th column of A*P
+* was the k-th column of A.
+*
+* TAU (output) REAL array, dimension (min(M,N))
+* The scalar factors of the elementary reflectors.
+*
+* WORK (workspace) REAL array, dimension (3*N)
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+*
+* Further Details
+* ===============
+*
+* The matrix Q is represented as a product of elementary reflectors
+*
+* Q = H(1) H(2) . . . H(n)
+*
+* Each H(i) has the form
+*
+* H = I - tau * v * v'
+*
+* where tau is a real scalar, and v is a real vector with
+* v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i).
+*
+* The matrix P is represented in jpvt as follows: If
+* jpvt(j) = i
+* then the jth column of P is the ith canonical unit vector.
+*
+* Partial column norm updating strategy modified by
+* Z. Drmac and Z. Bujanovic, Dept. of Mathematics,
+* University of Zagreb, Croatia.
+* June 2006.
+* For more details see LAPACK Working Note 176.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO, ONE
+ PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, ITEMP, J, MA, MN, PVT
+ REAL AII, TEMP, TEMP2, TOL3Z
+* ..
+* .. External Subroutines ..
+ EXTERNAL SGEQR2, SLARF, SLARFG, SORM2R, SSWAP, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, MIN, SQRT
+* ..
+* .. External Functions ..
+ INTEGER ISAMAX
+ REAL SLAMCH, SNRM2
+ EXTERNAL ISAMAX, SLAMCH, SNRM2
+* ..
+* .. Executable Statements ..
+*
+* Test the input arguments
+*
+ INFO = 0
+ IF( M.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+ INFO = -4
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SGEQPF', -INFO )
+ RETURN
+ END IF
+*
+ MN = MIN( M, N )
+ TOL3Z = SQRT(SLAMCH('Epsilon'))
+*
+* Move initial columns up front
+*
+ ITEMP = 1
+ DO 10 I = 1, N
+ IF( JPVT( I ).NE.0 ) THEN
+ IF( I.NE.ITEMP ) THEN
+ CALL SSWAP( M, A( 1, I ), 1, A( 1, ITEMP ), 1 )
+ JPVT( I ) = JPVT( ITEMP )
+ JPVT( ITEMP ) = I
+ ELSE
+ JPVT( I ) = I
+ END IF
+ ITEMP = ITEMP + 1
+ ELSE
+ JPVT( I ) = I
+ END IF
+ 10 CONTINUE
+ ITEMP = ITEMP - 1
+*
+* Compute the QR factorization and update remaining columns
+*
+ IF( ITEMP.GT.0 ) THEN
+ MA = MIN( ITEMP, M )
+ CALL SGEQR2( M, MA, A, LDA, TAU, WORK, INFO )
+ IF( MA.LT.N ) THEN
+ CALL SORM2R( 'Left', 'Transpose', M, N-MA, MA, A, LDA, TAU,
+ $ A( 1, MA+1 ), LDA, WORK, INFO )
+ END IF
+ END IF
+*
+ IF( ITEMP.LT.MN ) THEN
+*
+* Initialize partial column norms. The first n elements of
+* work store the exact column norms.
+*
+ DO 20 I = ITEMP + 1, N
+ WORK( I ) = SNRM2( M-ITEMP, A( ITEMP+1, I ), 1 )
+ WORK( N+I ) = WORK( I )
+ 20 CONTINUE
+*
+* Compute factorization
+*
+ DO 40 I = ITEMP + 1, MN
+*
+* Determine ith pivot column and swap if necessary
+*
+ PVT = ( I-1 ) + ISAMAX( N-I+1, WORK( I ), 1 )
+*
+ IF( PVT.NE.I ) THEN
+ CALL SSWAP( M, A( 1, PVT ), 1, A( 1, I ), 1 )
+ ITEMP = JPVT( PVT )
+ JPVT( PVT ) = JPVT( I )
+ JPVT( I ) = ITEMP
+ WORK( PVT ) = WORK( I )
+ WORK( N+PVT ) = WORK( N+I )
+ END IF
+*
+* Generate elementary reflector H(i)
+*
+ IF( I.LT.M ) THEN
+ CALL SLARFG( M-I+1, A( I, I ), A( I+1, I ), 1, TAU( I ) )
+ ELSE
+ CALL SLARFG( 1, A( M, M ), A( M, M ), 1, TAU( M ) )
+ END IF
+*
+ IF( I.LT.N ) THEN
+*
+* Apply H(i) to A(i:m,i+1:n) from the left
+*
+ AII = A( I, I )
+ A( I, I ) = ONE
+ CALL SLARF( 'LEFT', M-I+1, N-I, A( I, I ), 1, TAU( I ),
+ $ A( I, I+1 ), LDA, WORK( 2*N+1 ) )
+ A( I, I ) = AII
+ END IF
+*
+* Update partial column norms
+*
+ DO 30 J = I + 1, N
+ IF( WORK( J ).NE.ZERO ) THEN
+*
+* NOTE: The following 4 lines follow from the analysis in
+* Lapack Working Note 176.
+*
+ TEMP = ABS( A( I, J ) ) / WORK( J )
+ TEMP = MAX( ZERO, ( ONE+TEMP )*( ONE-TEMP ) )
+ TEMP2 = TEMP*( WORK( J ) / WORK( N+J ) )**2
+ IF( TEMP2 .LE. TOL3Z ) THEN
+ IF( M-I.GT.0 ) THEN
+ WORK( J ) = SNRM2( M-I, A( I+1, J ), 1 )
+ WORK( N+J ) = WORK( J )
+ ELSE
+ WORK( J ) = ZERO
+ WORK( N+J ) = ZERO
+ END IF
+ ELSE
+ WORK( J ) = WORK( J )*SQRT( TEMP )
+ END IF
+ END IF
+ 30 CONTINUE
+*
+ 40 CONTINUE
+ END IF
+ RETURN
+*
+* End of SGEQPF
+*
+ END
+ SUBROUTINE SGEQR2( M, N, A, LDA, TAU, WORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LDA, M, N
+* ..
+* .. Array Arguments ..
+ REAL A( LDA, * ), TAU( * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SGEQR2 computes a QR factorization of a real m by n matrix A:
+* A = Q * R.
+*
+* Arguments
+* =========
+*
+* M (input) INTEGER
+* The number of rows of the matrix A. M >= 0.
+*
+* N (input) INTEGER
+* The number of columns of the matrix A. N >= 0.
+*
+* A (input/output) REAL array, dimension (LDA,N)
+* On entry, the m by n matrix A.
+* On exit, the elements on and above the diagonal of the array
+* contain the min(m,n) by n upper trapezoidal matrix R (R is
+* upper triangular if m >= n); the elements below the diagonal,
+* with the array TAU, represent the orthogonal matrix Q as a
+* product of elementary reflectors (see Further Details).
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,M).
+*
+* TAU (output) REAL array, dimension (min(M,N))
+* The scalar factors of the elementary reflectors (see Further
+* Details).
+*
+* WORK (workspace) REAL array, dimension (N)
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+*
+* Further Details
+* ===============
+*
+* The matrix Q is represented as a product of elementary reflectors
+*
+* Q = H(1) H(2) . . . H(k), where k = min(m,n).
+*
+* Each H(i) has the form
+*
+* H(i) = I - tau * v * v'
+*
+* where tau is a real scalar, and v is a real vector with
+* v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i),
+* and tau in TAU(i).
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ONE
+ PARAMETER ( ONE = 1.0E+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, K
+ REAL AII
+* ..
+* .. External Subroutines ..
+ EXTERNAL SLARF, SLARFG, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+* Test the input arguments
+*
+ INFO = 0
+ IF( M.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+ INFO = -4
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SGEQR2', -INFO )
+ RETURN
+ END IF
+*
+ K = MIN( M, N )
+*
+ DO 10 I = 1, K
+*
+* Generate elementary reflector H(i) to annihilate A(i+1:m,i)
+*
+ CALL SLARFG( M-I+1, A( I, I ), A( MIN( I+1, M ), I ), 1,
+ $ TAU( I ) )
+ IF( I.LT.N ) THEN
+*
+* Apply H(i) to A(i:m,i+1:n) from the left
+*
+ AII = A( I, I )
+ A( I, I ) = ONE
+ CALL SLARF( 'Left', M-I+1, N-I, A( I, I ), 1, TAU( I ),
+ $ A( I, I+1 ), LDA, WORK )
+ A( I, I ) = AII
+ END IF
+ 10 CONTINUE
+ RETURN
+*
+* End of SGEQR2
+*
+ END
+ SUBROUTINE SGEQRF( M, N, A, LDA, TAU, WORK, LWORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LDA, LWORK, M, N
+* ..
+* .. Array Arguments ..
+ REAL A( LDA, * ), TAU( * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SGEQRF computes a QR factorization of a real M-by-N matrix A:
+* A = Q * R.
+*
+* Arguments
+* =========
+*
+* M (input) INTEGER
+* The number of rows of the matrix A. M >= 0.
+*
+* N (input) INTEGER
+* The number of columns of the matrix A. N >= 0.
+*
+* A (input/output) REAL array, dimension (LDA,N)
+* On entry, the M-by-N matrix A.
+* On exit, the elements on and above the diagonal of the array
+* contain the min(M,N)-by-N upper trapezoidal matrix R (R is
+* upper triangular if m >= n); the elements below the diagonal,
+* with the array TAU, represent the orthogonal matrix Q as a
+* product of min(m,n) elementary reflectors (see Further
+* Details).
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,M).
+*
+* TAU (output) REAL array, dimension (min(M,N))
+* The scalar factors of the elementary reflectors (see Further
+* Details).
+*
+* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))
+* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+* LWORK (input) INTEGER
+* The dimension of the array WORK. LWORK >= max(1,N).
+* For optimum performance LWORK >= N*NB, where NB is
+* the optimal blocksize.
+*
+* If LWORK = -1, then a workspace query is assumed; the routine
+* only calculates the optimal size of the WORK array, returns
+* this value as the first entry of the WORK array, and no error
+* message related to LWORK is issued by XERBLA.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+*
+* Further Details
+* ===============
+*
+* The matrix Q is represented as a product of elementary reflectors
+*
+* Q = H(1) H(2) . . . H(k), where k = min(m,n).
+*
+* Each H(i) has the form
+*
+* H(i) = I - tau * v * v'
+*
+* where tau is a real scalar, and v is a real vector with
+* v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i),
+* and tau in TAU(i).
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ LOGICAL LQUERY
+ INTEGER I, IB, IINFO, IWS, K, LDWORK, LWKOPT, NB,
+ $ NBMIN, NX
+* ..
+* .. External Subroutines ..
+ EXTERNAL SGEQR2, SLARFB, SLARFT, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN
+* ..
+* .. External Functions ..
+ INTEGER ILAENV
+ EXTERNAL ILAENV
+* ..
+* .. Executable Statements ..
+*
+* Test the input arguments
+*
+ INFO = 0
+ NB = ILAENV( 1, 'SGEQRF', ' ', M, N, -1, -1 )
+ LWKOPT = N*NB
+ WORK( 1 ) = LWKOPT
+ LQUERY = ( LWORK.EQ.-1 )
+ IF( M.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+ INFO = -4
+ ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN
+ INFO = -7
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SGEQRF', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ K = MIN( M, N )
+ IF( K.EQ.0 ) THEN
+ WORK( 1 ) = 1
+ RETURN
+ END IF
+*
+ NBMIN = 2
+ NX = 0
+ IWS = N
+ IF( NB.GT.1 .AND. NB.LT.K ) THEN
+*
+* Determine when to cross over from blocked to unblocked code.
+*
+ NX = MAX( 0, ILAENV( 3, 'SGEQRF', ' ', M, N, -1, -1 ) )
+ IF( NX.LT.K ) THEN
+*
+* Determine if workspace is large enough for blocked code.
+*
+ LDWORK = N
+ IWS = LDWORK*NB
+ IF( LWORK.LT.IWS ) THEN
+*
+* Not enough workspace to use optimal NB: reduce NB and
+* determine the minimum value of NB.
+*
+ NB = LWORK / LDWORK
+ NBMIN = MAX( 2, ILAENV( 2, 'SGEQRF', ' ', M, N, -1,
+ $ -1 ) )
+ END IF
+ END IF
+ END IF
+*
+ IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN
+*
+* Use blocked code initially
+*
+ DO 10 I = 1, K - NX, NB
+ IB = MIN( K-I+1, NB )
+*
+* Compute the QR factorization of the current block
+* A(i:m,i:i+ib-1)
+*
+ CALL SGEQR2( M-I+1, IB, A( I, I ), LDA, TAU( I ), WORK,
+ $ IINFO )
+ IF( I+IB.LE.N ) THEN
+*
+* Form the triangular factor of the block reflector
+* H = H(i) H(i+1) . . . H(i+ib-1)
+*
+ CALL SLARFT( 'Forward', 'Columnwise', M-I+1, IB,
+ $ A( I, I ), LDA, TAU( I ), WORK, LDWORK )
+*
+* Apply H' to A(i:m,i+ib:n) from the left
+*
+ CALL SLARFB( 'Left', 'Transpose', 'Forward',
+ $ 'Columnwise', M-I+1, N-I-IB+1, IB,
+ $ A( I, I ), LDA, WORK, LDWORK, A( I, I+IB ),
+ $ LDA, WORK( IB+1 ), LDWORK )
+ END IF
+ 10 CONTINUE
+ ELSE
+ I = 1
+ END IF
+*
+* Use unblocked code to factor the last or only block.
+*
+ IF( I.LE.K )
+ $ CALL SGEQR2( M-I+1, N-I+1, A( I, I ), LDA, TAU( I ), WORK,
+ $ IINFO )
+*
+ WORK( 1 ) = IWS
+ RETURN
+*
+* End of SGEQRF
+*
+ END
+ SUBROUTINE SGERFS( TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB,
+ $ X, LDX, FERR, BERR, WORK, IWORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* Modified to call SLACN2 in place of SLACON, 7 Feb 03, SJH.
+*
+* .. Scalar Arguments ..
+ CHARACTER TRANS
+ INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * ), IWORK( * )
+ REAL A( LDA, * ), AF( LDAF, * ), B( LDB, * ),
+ $ BERR( * ), FERR( * ), WORK( * ), X( LDX, * )
+* ..
+*
+* Purpose
+* =======
+*
+* SGERFS improves the computed solution to a system of linear
+* equations and provides error bounds and backward error estimates for
+* the solution.
+*
+* Arguments
+* =========
+*
+* TRANS (input) CHARACTER*1
+* Specifies the form of the system of equations:
+* = 'N': A * X = B (No transpose)
+* = 'T': A**T * X = B (Transpose)
+* = 'C': A**H * X = B (Conjugate transpose = Transpose)
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* NRHS (input) INTEGER
+* The number of right hand sides, i.e., the number of columns
+* of the matrices B and X. NRHS >= 0.
+*
+* A (input) REAL array, dimension (LDA,N)
+* The original N-by-N matrix A.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,N).
+*
+* AF (input) REAL array, dimension (LDAF,N)
+* The factors L and U from the factorization A = P*L*U
+* as computed by SGETRF.
+*
+* LDAF (input) INTEGER
+* The leading dimension of the array AF. LDAF >= max(1,N).
+*
+* IPIV (input) INTEGER array, dimension (N)
+* The pivot indices from SGETRF; for 1<=i<=N, row i of the
+* matrix was interchanged with row IPIV(i).
+*
+* B (input) REAL array, dimension (LDB,NRHS)
+* The right hand side matrix B.
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. LDB >= max(1,N).
+*
+* X (input/output) REAL array, dimension (LDX,NRHS)
+* On entry, the solution matrix X, as computed by SGETRS.
+* On exit, the improved solution matrix X.
+*
+* LDX (input) INTEGER
+* The leading dimension of the array X. LDX >= max(1,N).
+*
+* FERR (output) REAL array, dimension (NRHS)
+* The estimated forward error bound for each solution vector
+* X(j) (the j-th column of the solution matrix X).
+* If XTRUE is the true solution corresponding to X(j), FERR(j)
+* is an estimated upper bound for the magnitude of the largest
+* element in (X(j) - XTRUE) divided by the magnitude of the
+* largest element in X(j). The estimate is as reliable as
+* the estimate for RCOND, and is almost always a slight
+* overestimate of the true error.
+*
+* BERR (output) REAL array, dimension (NRHS)
+* The componentwise relative backward error of each solution
+* vector X(j) (i.e., the smallest relative change in
+* any element of A or B that makes X(j) an exact solution).
+*
+* WORK (workspace) REAL array, dimension (3*N)
+*
+* IWORK (workspace) INTEGER array, dimension (N)
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+*
+* Internal Parameters
+* ===================
+*
+* ITMAX is the maximum number of steps of iterative refinement.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ INTEGER ITMAX
+ PARAMETER ( ITMAX = 5 )
+ REAL ZERO
+ PARAMETER ( ZERO = 0.0E+0 )
+ REAL ONE
+ PARAMETER ( ONE = 1.0E+0 )
+ REAL TWO
+ PARAMETER ( TWO = 2.0E+0 )
+ REAL THREE
+ PARAMETER ( THREE = 3.0E+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL NOTRAN
+ CHARACTER TRANST
+ INTEGER COUNT, I, J, K, KASE, NZ
+ REAL EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK
+* ..
+* .. Local Arrays ..
+ INTEGER ISAVE( 3 )
+* ..
+* .. External Subroutines ..
+ EXTERNAL SAXPY, SCOPY, SGEMV, SGETRS, SLACN2, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ REAL SLAMCH
+ EXTERNAL LSAME, SLAMCH
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ NOTRAN = LSAME( TRANS, 'N' )
+ IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT.
+ $ LSAME( TRANS, 'C' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( NRHS.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -5
+ ELSE IF( LDAF.LT.MAX( 1, N ) ) THEN
+ INFO = -7
+ ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -10
+ ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
+ INFO = -12
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SGERFS', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN
+ DO 10 J = 1, NRHS
+ FERR( J ) = ZERO
+ BERR( J ) = ZERO
+ 10 CONTINUE
+ RETURN
+ END IF
+*
+ IF( NOTRAN ) THEN
+ TRANST = 'T'
+ ELSE
+ TRANST = 'N'
+ END IF
+*
+* NZ = maximum number of nonzero elements in each row of A, plus 1
+*
+ NZ = N + 1
+ EPS = SLAMCH( 'Epsilon' )
+ SAFMIN = SLAMCH( 'Safe minimum' )
+ SAFE1 = NZ*SAFMIN
+ SAFE2 = SAFE1 / EPS
+*
+* Do for each right hand side
+*
+ DO 140 J = 1, NRHS
+*
+ COUNT = 1
+ LSTRES = THREE
+ 20 CONTINUE
+*
+* Loop until stopping criterion is satisfied.
+*
+* Compute residual R = B - op(A) * X,
+* where op(A) = A, A**T, or A**H, depending on TRANS.
+*
+ CALL SCOPY( N, B( 1, J ), 1, WORK( N+1 ), 1 )
+ CALL SGEMV( TRANS, N, N, -ONE, A, LDA, X( 1, J ), 1, ONE,
+ $ WORK( N+1 ), 1 )
+*
+* Compute componentwise relative backward error from formula
+*
+* max(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) )
+*
+* where abs(Z) is the componentwise absolute value of the matrix
+* or vector Z. If the i-th component of the denominator is less
+* than SAFE2, then SAFE1 is added to the i-th components of the
+* numerator and denominator before dividing.
+*
+ DO 30 I = 1, N
+ WORK( I ) = ABS( B( I, J ) )
+ 30 CONTINUE
+*
+* Compute abs(op(A))*abs(X) + abs(B).
+*
+ IF( NOTRAN ) THEN
+ DO 50 K = 1, N
+ XK = ABS( X( K, J ) )
+ DO 40 I = 1, N
+ WORK( I ) = WORK( I ) + ABS( A( I, K ) )*XK
+ 40 CONTINUE
+ 50 CONTINUE
+ ELSE
+ DO 70 K = 1, N
+ S = ZERO
+ DO 60 I = 1, N
+ S = S + ABS( A( I, K ) )*ABS( X( I, J ) )
+ 60 CONTINUE
+ WORK( K ) = WORK( K ) + S
+ 70 CONTINUE
+ END IF
+ S = ZERO
+ DO 80 I = 1, N
+ IF( WORK( I ).GT.SAFE2 ) THEN
+ S = MAX( S, ABS( WORK( N+I ) ) / WORK( I ) )
+ ELSE
+ S = MAX( S, ( ABS( WORK( N+I ) )+SAFE1 ) /
+ $ ( WORK( I )+SAFE1 ) )
+ END IF
+ 80 CONTINUE
+ BERR( J ) = S
+*
+* Test stopping criterion. Continue iterating if
+* 1) The residual BERR(J) is larger than machine epsilon, and
+* 2) BERR(J) decreased by at least a factor of 2 during the
+* last iteration, and
+* 3) At most ITMAX iterations tried.
+*
+ IF( BERR( J ).GT.EPS .AND. TWO*BERR( J ).LE.LSTRES .AND.
+ $ COUNT.LE.ITMAX ) THEN
+*
+* Update solution and try again.
+*
+ CALL SGETRS( TRANS, N, 1, AF, LDAF, IPIV, WORK( N+1 ), N,
+ $ INFO )
+ CALL SAXPY( N, ONE, WORK( N+1 ), 1, X( 1, J ), 1 )
+ LSTRES = BERR( J )
+ COUNT = COUNT + 1
+ GO TO 20
+ END IF
+*
+* Bound error from formula
+*
+* norm(X - XTRUE) / norm(X) .le. FERR =
+* norm( abs(inv(op(A)))*
+* ( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X)
+*
+* where
+* norm(Z) is the magnitude of the largest component of Z
+* inv(op(A)) is the inverse of op(A)
+* abs(Z) is the componentwise absolute value of the matrix or
+* vector Z
+* NZ is the maximum number of nonzeros in any row of A, plus 1
+* EPS is machine epsilon
+*
+* The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B))
+* is incremented by SAFE1 if the i-th component of
+* abs(op(A))*abs(X) + abs(B) is less than SAFE2.
+*
+* Use SLACN2 to estimate the infinity-norm of the matrix
+* inv(op(A)) * diag(W),
+* where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) )))
+*
+ DO 90 I = 1, N
+ IF( WORK( I ).GT.SAFE2 ) THEN
+ WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I )
+ ELSE
+ WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I ) + SAFE1
+ END IF
+ 90 CONTINUE
+*
+ KASE = 0
+ 100 CONTINUE
+ CALL SLACN2( N, WORK( 2*N+1 ), WORK( N+1 ), IWORK, FERR( J ),
+ $ KASE, ISAVE )
+ IF( KASE.NE.0 ) THEN
+ IF( KASE.EQ.1 ) THEN
+*
+* Multiply by diag(W)*inv(op(A)**T).
+*
+ CALL SGETRS( TRANST, N, 1, AF, LDAF, IPIV, WORK( N+1 ),
+ $ N, INFO )
+ DO 110 I = 1, N
+ WORK( N+I ) = WORK( I )*WORK( N+I )
+ 110 CONTINUE
+ ELSE
+*
+* Multiply by inv(op(A))*diag(W).
+*
+ DO 120 I = 1, N
+ WORK( N+I ) = WORK( I )*WORK( N+I )
+ 120 CONTINUE
+ CALL SGETRS( TRANS, N, 1, AF, LDAF, IPIV, WORK( N+1 ), N,
+ $ INFO )
+ END IF
+ GO TO 100
+ END IF
+*
+* Normalize error.
+*
+ LSTRES = ZERO
+ DO 130 I = 1, N
+ LSTRES = MAX( LSTRES, ABS( X( I, J ) ) )
+ 130 CONTINUE
+ IF( LSTRES.NE.ZERO )
+ $ FERR( J ) = FERR( J ) / LSTRES
+*
+ 140 CONTINUE
+*
+ RETURN
+*
+* End of SGERFS
+*
+ END
+ SUBROUTINE SGERQ2( M, N, A, LDA, TAU, WORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LDA, M, N
+* ..
+* .. Array Arguments ..
+ REAL A( LDA, * ), TAU( * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SGERQ2 computes an RQ factorization of a real m by n matrix A:
+* A = R * Q.
+*
+* Arguments
+* =========
+*
+* M (input) INTEGER
+* The number of rows of the matrix A. M >= 0.
+*
+* N (input) INTEGER
+* The number of columns of the matrix A. N >= 0.
+*
+* A (input/output) REAL array, dimension (LDA,N)
+* On entry, the m by n matrix A.
+* On exit, if m <= n, the upper triangle of the subarray
+* A(1:m,n-m+1:n) contains the m by m upper triangular matrix R;
+* if m >= n, the elements on and above the (m-n)-th subdiagonal
+* contain the m by n upper trapezoidal matrix R; the remaining
+* elements, with the array TAU, represent the orthogonal matrix
+* Q as a product of elementary reflectors (see Further
+* Details).
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,M).
+*
+* TAU (output) REAL array, dimension (min(M,N))
+* The scalar factors of the elementary reflectors (see Further
+* Details).
+*
+* WORK (workspace) REAL array, dimension (M)
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+*
+* Further Details
+* ===============
+*
+* The matrix Q is represented as a product of elementary reflectors
+*
+* Q = H(1) H(2) . . . H(k), where k = min(m,n).
+*
+* Each H(i) has the form
+*
+* H(i) = I - tau * v * v'
+*
+* where tau is a real scalar, and v is a real vector with
+* v(n-k+i+1:n) = 0 and v(n-k+i) = 1; v(1:n-k+i-1) is stored on exit in
+* A(m-k+i,1:n-k+i-1), and tau in TAU(i).
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ONE
+ PARAMETER ( ONE = 1.0E+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, K
+ REAL AII
+* ..
+* .. External Subroutines ..
+ EXTERNAL SLARF, SLARFG, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+* Test the input arguments
+*
+ INFO = 0
+ IF( M.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+ INFO = -4
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SGERQ2', -INFO )
+ RETURN
+ END IF
+*
+ K = MIN( M, N )
+*
+ DO 10 I = K, 1, -1
+*
+* Generate elementary reflector H(i) to annihilate
+* A(m-k+i,1:n-k+i-1)
+*
+ CALL SLARFG( N-K+I, A( M-K+I, N-K+I ), A( M-K+I, 1 ), LDA,
+ $ TAU( I ) )
+*
+* Apply H(i) to A(1:m-k+i-1,1:n-k+i) from the right
+*
+ AII = A( M-K+I, N-K+I )
+ A( M-K+I, N-K+I ) = ONE
+ CALL SLARF( 'Right', M-K+I-1, N-K+I, A( M-K+I, 1 ), LDA,
+ $ TAU( I ), A, LDA, WORK )
+ A( M-K+I, N-K+I ) = AII
+ 10 CONTINUE
+ RETURN
+*
+* End of SGERQ2
+*
+ END
+ SUBROUTINE SGERQF( M, N, A, LDA, TAU, WORK, LWORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LDA, LWORK, M, N
+* ..
+* .. Array Arguments ..
+ REAL A( LDA, * ), TAU( * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SGERQF computes an RQ factorization of a real M-by-N matrix A:
+* A = R * Q.
+*
+* Arguments
+* =========
+*
+* M (input) INTEGER
+* The number of rows of the matrix A. M >= 0.
+*
+* N (input) INTEGER
+* The number of columns of the matrix A. N >= 0.
+*
+* A (input/output) REAL array, dimension (LDA,N)
+* On entry, the M-by-N matrix A.
+* On exit,
+* if m <= n, the upper triangle of the subarray
+* A(1:m,n-m+1:n) contains the M-by-M upper triangular matrix R;
+* if m >= n, the elements on and above the (m-n)-th subdiagonal
+* contain the M-by-N upper trapezoidal matrix R;
+* the remaining elements, with the array TAU, represent the
+* orthogonal matrix Q as a product of min(m,n) elementary
+* reflectors (see Further Details).
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,M).
+*
+* TAU (output) REAL array, dimension (min(M,N))
+* The scalar factors of the elementary reflectors (see Further
+* Details).
+*
+* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))
+* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+* LWORK (input) INTEGER
+* The dimension of the array WORK. LWORK >= max(1,M).
+* For optimum performance LWORK >= M*NB, where NB is
+* the optimal blocksize.
+*
+* If LWORK = -1, then a workspace query is assumed; the routine
+* only calculates the optimal size of the WORK array, returns
+* this value as the first entry of the WORK array, and no error
+* message related to LWORK is issued by XERBLA.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+*
+* Further Details
+* ===============
+*
+* The matrix Q is represented as a product of elementary reflectors
+*
+* Q = H(1) H(2) . . . H(k), where k = min(m,n).
+*
+* Each H(i) has the form
+*
+* H(i) = I - tau * v * v'
+*
+* where tau is a real scalar, and v is a real vector with
+* v(n-k+i+1:n) = 0 and v(n-k+i) = 1; v(1:n-k+i-1) is stored on exit in
+* A(m-k+i,1:n-k+i-1), and tau in TAU(i).
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ LOGICAL LQUERY
+ INTEGER I, IB, IINFO, IWS, K, KI, KK, LDWORK, LWKOPT,
+ $ MU, NB, NBMIN, NU, NX
+* ..
+* .. External Subroutines ..
+ EXTERNAL SGERQ2, SLARFB, SLARFT, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN
+* ..
+* .. External Functions ..
+ INTEGER ILAENV
+ EXTERNAL ILAENV
+* ..
+* .. Executable Statements ..
+*
+* Test the input arguments
+*
+ INFO = 0
+ LQUERY = ( LWORK.EQ.-1 )
+ IF( M.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+ INFO = -4
+ ELSE IF( LWORK.LT.MAX( 1, M ) .AND. .NOT.LQUERY ) THEN
+ INFO = -7
+ END IF
+*
+ IF( INFO.EQ.0 ) THEN
+ K = MIN( M, N )
+ IF( K.EQ.0 ) THEN
+ LWKOPT = 1
+ ELSE
+ NB = ILAENV( 1, 'SGERQF', ' ', M, N, -1, -1 )
+ LWKOPT = M*NB
+ WORK( 1 ) = LWKOPT
+ END IF
+ WORK( 1 ) = LWKOPT
+*
+ IF( LWORK.LT.MAX( 1, M ) .AND. .NOT.LQUERY ) THEN
+ INFO = -7
+ END IF
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SGERQF', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( K.EQ.0 ) THEN
+ RETURN
+ END IF
+*
+ NBMIN = 2
+ NX = 1
+ IWS = M
+ IF( NB.GT.1 .AND. NB.LT.K ) THEN
+*
+* Determine when to cross over from blocked to unblocked code.
+*
+ NX = MAX( 0, ILAENV( 3, 'SGERQF', ' ', M, N, -1, -1 ) )
+ IF( NX.LT.K ) THEN
+*
+* Determine if workspace is large enough for blocked code.
+*
+ LDWORK = M
+ IWS = LDWORK*NB
+ IF( LWORK.LT.IWS ) THEN
+*
+* Not enough workspace to use optimal NB: reduce NB and
+* determine the minimum value of NB.
+*
+ NB = LWORK / LDWORK
+ NBMIN = MAX( 2, ILAENV( 2, 'SGERQF', ' ', M, N, -1,
+ $ -1 ) )
+ END IF
+ END IF
+ END IF
+*
+ IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN
+*
+* Use blocked code initially.
+* The last kk rows are handled by the block method.
+*
+ KI = ( ( K-NX-1 ) / NB )*NB
+ KK = MIN( K, KI+NB )
+*
+ DO 10 I = K - KK + KI + 1, K - KK + 1, -NB
+ IB = MIN( K-I+1, NB )
+*
+* Compute the RQ factorization of the current block
+* A(m-k+i:m-k+i+ib-1,1:n-k+i+ib-1)
+*
+ CALL SGERQ2( IB, N-K+I+IB-1, A( M-K+I, 1 ), LDA, TAU( I ),
+ $ WORK, IINFO )
+ IF( M-K+I.GT.1 ) THEN
+*
+* Form the triangular factor of the block reflector
+* H = H(i+ib-1) . . . H(i+1) H(i)
+*
+ CALL SLARFT( 'Backward', 'Rowwise', N-K+I+IB-1, IB,
+ $ A( M-K+I, 1 ), LDA, TAU( I ), WORK, LDWORK )
+*
+* Apply H to A(1:m-k+i-1,1:n-k+i+ib-1) from the right
+*
+ CALL SLARFB( 'Right', 'No transpose', 'Backward',
+ $ 'Rowwise', M-K+I-1, N-K+I+IB-1, IB,
+ $ A( M-K+I, 1 ), LDA, WORK, LDWORK, A, LDA,
+ $ WORK( IB+1 ), LDWORK )
+ END IF
+ 10 CONTINUE
+ MU = M - K + I + NB - 1
+ NU = N - K + I + NB - 1
+ ELSE
+ MU = M
+ NU = N
+ END IF
+*
+* Use unblocked code to factor the last or only block
+*
+ IF( MU.GT.0 .AND. NU.GT.0 )
+ $ CALL SGERQ2( MU, NU, A, LDA, TAU, WORK, IINFO )
+*
+ WORK( 1 ) = IWS
+ RETURN
+*
+* End of SGERQF
+*
+ END
+ SUBROUTINE SGESC2( N, A, LDA, RHS, IPIV, JPIV, SCALE )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER LDA, N
+ REAL SCALE
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * ), JPIV( * )
+ REAL A( LDA, * ), RHS( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SGESC2 solves a system of linear equations
+*
+* A * X = scale* RHS
+*
+* with a general N-by-N matrix A using the LU factorization with
+* complete pivoting computed by SGETC2.
+*
+* Arguments
+* =========
+*
+* N (input) INTEGER
+* The order of the matrix A.
+*
+* A (input) REAL array, dimension (LDA,N)
+* On entry, the LU part of the factorization of the n-by-n
+* matrix A computed by SGETC2: A = P * L * U * Q
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1, N).
+*
+* RHS (input/output) REAL array, dimension (N).
+* On entry, the right hand side vector b.
+* On exit, the solution vector X.
+*
+* IPIV (input) INTEGER array, dimension (N).
+* The pivot indices; for 1 <= i <= N, row i of the
+* matrix has been interchanged with row IPIV(i).
+*
+* JPIV (input) INTEGER array, dimension (N).
+* The pivot indices; for 1 <= j <= N, column j of the
+* matrix has been interchanged with column JPIV(j).
+*
+* SCALE (output) REAL
+* On exit, SCALE contains the scale factor. SCALE is chosen
+* 0 <= SCALE <= 1 to prevent owerflow in the solution.
+*
+* Further Details
+* ===============
+*
+* Based on contributions by
+* Bo Kagstrom and Peter Poromaa, Department of Computing Science,
+* Umea University, S-901 87 Umea, Sweden.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ONE, TWO
+ PARAMETER ( ONE = 1.0E+0, TWO = 2.0E+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, J
+ REAL BIGNUM, EPS, SMLNUM, TEMP
+* ..
+* .. External Subroutines ..
+ EXTERNAL SLABAD, SLASWP, SSCAL
+* ..
+* .. External Functions ..
+ INTEGER ISAMAX
+ REAL SLAMCH
+ EXTERNAL ISAMAX, SLAMCH
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS
+* ..
+* .. Executable Statements ..
+*
+* Set constant to control owerflow
+*
+ EPS = SLAMCH( 'P' )
+ SMLNUM = SLAMCH( 'S' ) / EPS
+ BIGNUM = ONE / SMLNUM
+ CALL SLABAD( SMLNUM, BIGNUM )
+*
+* Apply permutations IPIV to RHS
+*
+ CALL SLASWP( 1, RHS, LDA, 1, N-1, IPIV, 1 )
+*
+* Solve for L part
+*
+ DO 20 I = 1, N - 1
+ DO 10 J = I + 1, N
+ RHS( J ) = RHS( J ) - A( J, I )*RHS( I )
+ 10 CONTINUE
+ 20 CONTINUE
+*
+* Solve for U part
+*
+ SCALE = ONE
+*
+* Check for scaling
+*
+ I = ISAMAX( N, RHS, 1 )
+ IF( TWO*SMLNUM*ABS( RHS( I ) ).GT.ABS( A( N, N ) ) ) THEN
+ TEMP = ( ONE / TWO ) / ABS( RHS( I ) )
+ CALL SSCAL( N, TEMP, RHS( 1 ), 1 )
+ SCALE = SCALE*TEMP
+ END IF
+*
+ DO 40 I = N, 1, -1
+ TEMP = ONE / A( I, I )
+ RHS( I ) = RHS( I )*TEMP
+ DO 30 J = I + 1, N
+ RHS( I ) = RHS( I ) - RHS( J )*( A( I, J )*TEMP )
+ 30 CONTINUE
+ 40 CONTINUE
+*
+* Apply permutations JPIV to the solution (RHS)
+*
+ CALL SLASWP( 1, RHS, LDA, 1, N-1, JPIV, -1 )
+ RETURN
+*
+* End of SGESC2
+*
+ END
+ SUBROUTINE SGESDD( JOBZ, M, N, A, LDA, S, U, LDU, VT, LDVT, WORK,
+ $ LWORK, IWORK, INFO )
+*
+* -- LAPACK driver routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER JOBZ
+ INTEGER INFO, LDA, LDU, LDVT, LWORK, M, N
+* ..
+* .. Array Arguments ..
+ INTEGER IWORK( * )
+ REAL A( LDA, * ), S( * ), U( LDU, * ),
+ $ VT( LDVT, * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SGESDD computes the singular value decomposition (SVD) of a real
+* M-by-N matrix A, optionally computing the left and right singular
+* vectors. If singular vectors are desired, it uses a
+* divide-and-conquer algorithm.
+*
+* The SVD is written
+*
+* A = U * SIGMA * transpose(V)
+*
+* where SIGMA is an M-by-N matrix which is zero except for its
+* min(m,n) diagonal elements, U is an M-by-M orthogonal matrix, and
+* V is an N-by-N orthogonal matrix. The diagonal elements of SIGMA
+* are the singular values of A; they are real and non-negative, and
+* are returned in descending order. The first min(m,n) columns of
+* U and V are the left and right singular vectors of A.
+*
+* Note that the routine returns VT = V**T, not V.
+*
+* The divide and conquer algorithm makes very mild assumptions about
+* floating point arithmetic. It will work on machines with a guard
+* digit in add/subtract, or on those binary machines without guard
+* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
+* Cray-2. It could conceivably fail on hexadecimal or decimal machines
+* without guard digits, but we know of none.
+*
+* Arguments
+* =========
+*
+* JOBZ (input) CHARACTER*1
+* Specifies options for computing all or part of the matrix U:
+* = 'A': all M columns of U and all N rows of V**T are
+* returned in the arrays U and VT;
+* = 'S': the first min(M,N) columns of U and the first
+* min(M,N) rows of V**T are returned in the arrays U
+* and VT;
+* = 'O': If M >= N, the first N columns of U are overwritten
+* on the array A and all rows of V**T are returned in
+* the array VT;
+* otherwise, all columns of U are returned in the
+* array U and the first M rows of V**T are overwritten
+* in the array A;
+* = 'N': no columns of U or rows of V**T are computed.
+*
+* M (input) INTEGER
+* The number of rows of the input matrix A. M >= 0.
+*
+* N (input) INTEGER
+* The number of columns of the input matrix A. N >= 0.
+*
+* A (input/output) REAL array, dimension (LDA,N)
+* On entry, the M-by-N matrix A.
+* On exit,
+* if JOBZ = 'O', A is overwritten with the first N columns
+* of U (the left singular vectors, stored
+* columnwise) if M >= N;
+* A is overwritten with the first M rows
+* of V**T (the right singular vectors, stored
+* rowwise) otherwise.
+* if JOBZ .ne. 'O', the contents of A are destroyed.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,M).
+*
+* S (output) REAL array, dimension (min(M,N))
+* The singular values of A, sorted so that S(i) >= S(i+1).
+*
+* U (output) REAL array, dimension (LDU,UCOL)
+* UCOL = M if JOBZ = 'A' or JOBZ = 'O' and M < N;
+* UCOL = min(M,N) if JOBZ = 'S'.
+* If JOBZ = 'A' or JOBZ = 'O' and M < N, U contains the M-by-M
+* orthogonal matrix U;
+* if JOBZ = 'S', U contains the first min(M,N) columns of U
+* (the left singular vectors, stored columnwise);
+* if JOBZ = 'O' and M >= N, or JOBZ = 'N', U is not referenced.
+*
+* LDU (input) INTEGER
+* The leading dimension of the array U. LDU >= 1; if
+* JOBZ = 'S' or 'A' or JOBZ = 'O' and M < N, LDU >= M.
+*
+* VT (output) REAL array, dimension (LDVT,N)
+* If JOBZ = 'A' or JOBZ = 'O' and M >= N, VT contains the
+* N-by-N orthogonal matrix V**T;
+* if JOBZ = 'S', VT contains the first min(M,N) rows of
+* V**T (the right singular vectors, stored rowwise);
+* if JOBZ = 'O' and M < N, or JOBZ = 'N', VT is not referenced.
+*
+* LDVT (input) INTEGER
+* The leading dimension of the array VT. LDVT >= 1; if
+* JOBZ = 'A' or JOBZ = 'O' and M >= N, LDVT >= N;
+* if JOBZ = 'S', LDVT >= min(M,N).
+*
+* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))
+* On exit, if INFO = 0, WORK(1) returns the optimal LWORK;
+*
+* LWORK (input) INTEGER
+* The dimension of the array WORK. LWORK >= 1.
+* If JOBZ = 'N',
+* LWORK >= 3*min(M,N) + max(max(M,N),6*min(M,N)).
+* If JOBZ = 'O',
+* LWORK >= 3*min(M,N)*min(M,N) +
+* max(max(M,N),5*min(M,N)*min(M,N)+4*min(M,N)).
+* If JOBZ = 'S' or 'A'
+* LWORK >= 3*min(M,N)*min(M,N) +
+* max(max(M,N),4*min(M,N)*min(M,N)+4*min(M,N)).
+* For good performance, LWORK should generally be larger.
+* If LWORK = -1 but other input arguments are legal, WORK(1)
+* returns the optimal LWORK.
+*
+* IWORK (workspace) INTEGER array, dimension (8*min(M,N))
+*
+* INFO (output) INTEGER
+* = 0: successful exit.
+* < 0: if INFO = -i, the i-th argument had an illegal value.
+* > 0: SBDSDC did not converge, updating process failed.
+*
+* Further Details
+* ===============
+*
+* Based on contributions by
+* Ming Gu and Huan Ren, Computer Science Division, University of
+* California at Berkeley, USA
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO, ONE
+ PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL LQUERY, WNTQA, WNTQAS, WNTQN, WNTQO, WNTQS
+ INTEGER BDSPAC, BLK, CHUNK, I, IE, IERR, IL,
+ $ IR, ISCL, ITAU, ITAUP, ITAUQ, IU, IVT, LDWKVT,
+ $ LDWRKL, LDWRKR, LDWRKU, MAXWRK, MINMN, MINWRK,
+ $ MNTHR, NWORK, WRKBL
+ REAL ANRM, BIGNUM, EPS, SMLNUM
+* ..
+* .. Local Arrays ..
+ INTEGER IDUM( 1 )
+ REAL DUM( 1 )
+* ..
+* .. External Subroutines ..
+ EXTERNAL SBDSDC, SGEBRD, SGELQF, SGEMM, SGEQRF, SLACPY,
+ $ SLASCL, SLASET, SORGBR, SORGLQ, SORGQR, SORMBR,
+ $ XERBLA
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ILAENV
+ REAL SLAMCH, SLANGE
+ EXTERNAL ILAENV, LSAME, SLAMCH, SLANGE
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC INT, MAX, MIN, SQRT
+* ..
+* .. Executable Statements ..
+*
+* Test the input arguments
+*
+ INFO = 0
+ MINMN = MIN( M, N )
+ WNTQA = LSAME( JOBZ, 'A' )
+ WNTQS = LSAME( JOBZ, 'S' )
+ WNTQAS = WNTQA .OR. WNTQS
+ WNTQO = LSAME( JOBZ, 'O' )
+ WNTQN = LSAME( JOBZ, 'N' )
+ LQUERY = ( LWORK.EQ.-1 )
+*
+ IF( .NOT.( WNTQA .OR. WNTQS .OR. WNTQO .OR. WNTQN ) ) THEN
+ INFO = -1
+ ELSE IF( M.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+ INFO = -5
+ ELSE IF( LDU.LT.1 .OR. ( WNTQAS .AND. LDU.LT.M ) .OR.
+ $ ( WNTQO .AND. M.LT.N .AND. LDU.LT.M ) ) THEN
+ INFO = -8
+ ELSE IF( LDVT.LT.1 .OR. ( WNTQA .AND. LDVT.LT.N ) .OR.
+ $ ( WNTQS .AND. LDVT.LT.MINMN ) .OR.
+ $ ( WNTQO .AND. M.GE.N .AND. LDVT.LT.N ) ) THEN
+ INFO = -10
+ END IF
+*
+* Compute workspace
+* (Note: Comments in the code beginning "Workspace:" describe the
+* minimal amount of workspace needed at that point in the code,
+* as well as the preferred amount for good performance.
+* NB refers to the optimal block size for the immediately
+* following subroutine, as returned by ILAENV.)
+*
+ IF( INFO.EQ.0 ) THEN
+ MINWRK = 1
+ MAXWRK = 1
+ IF( M.GE.N .AND. MINMN.GT.0 ) THEN
+*
+* Compute space needed for SBDSDC
+*
+ MNTHR = INT( MINMN*11.0E0 / 6.0E0 )
+ IF( WNTQN ) THEN
+ BDSPAC = 7*N
+ ELSE
+ BDSPAC = 3*N*N + 4*N
+ END IF
+ IF( M.GE.MNTHR ) THEN
+ IF( WNTQN ) THEN
+*
+* Path 1 (M much larger than N, JOBZ='N')
+*
+ WRKBL = N + N*ILAENV( 1, 'SGEQRF', ' ', M, N, -1,
+ $ -1 )
+ WRKBL = MAX( WRKBL, 3*N+2*N*
+ $ ILAENV( 1, 'SGEBRD', ' ', N, N, -1, -1 ) )
+ MAXWRK = MAX( WRKBL, BDSPAC+N )
+ MINWRK = BDSPAC + N
+ ELSE IF( WNTQO ) THEN
+*
+* Path 2 (M much larger than N, JOBZ='O')
+*
+ WRKBL = N + N*ILAENV( 1, 'SGEQRF', ' ', M, N, -1, -1 )
+ WRKBL = MAX( WRKBL, N+N*ILAENV( 1, 'SORGQR', ' ', M,
+ $ N, N, -1 ) )
+ WRKBL = MAX( WRKBL, 3*N+2*N*
+ $ ILAENV( 1, 'SGEBRD', ' ', N, N, -1, -1 ) )
+ WRKBL = MAX( WRKBL, 3*N+N*
+ $ ILAENV( 1, 'SORMBR', 'QLN', N, N, N, -1 ) )
+ WRKBL = MAX( WRKBL, 3*N+N*
+ $ ILAENV( 1, 'SORMBR', 'PRT', N, N, N, -1 ) )
+ WRKBL = MAX( WRKBL, BDSPAC+3*N )
+ MAXWRK = WRKBL + 2*N*N
+ MINWRK = BDSPAC + 2*N*N + 3*N
+ ELSE IF( WNTQS ) THEN
+*
+* Path 3 (M much larger than N, JOBZ='S')
+*
+ WRKBL = N + N*ILAENV( 1, 'SGEQRF', ' ', M, N, -1, -1 )
+ WRKBL = MAX( WRKBL, N+N*ILAENV( 1, 'SORGQR', ' ', M,
+ $ N, N, -1 ) )
+ WRKBL = MAX( WRKBL, 3*N+2*N*
+ $ ILAENV( 1, 'SGEBRD', ' ', N, N, -1, -1 ) )
+ WRKBL = MAX( WRKBL, 3*N+N*
+ $ ILAENV( 1, 'SORMBR', 'QLN', N, N, N, -1 ) )
+ WRKBL = MAX( WRKBL, 3*N+N*
+ $ ILAENV( 1, 'SORMBR', 'PRT', N, N, N, -1 ) )
+ WRKBL = MAX( WRKBL, BDSPAC+3*N )
+ MAXWRK = WRKBL + N*N
+ MINWRK = BDSPAC + N*N + 3*N
+ ELSE IF( WNTQA ) THEN
+*
+* Path 4 (M much larger than N, JOBZ='A')
+*
+ WRKBL = N + N*ILAENV( 1, 'SGEQRF', ' ', M, N, -1, -1 )
+ WRKBL = MAX( WRKBL, N+M*ILAENV( 1, 'SORGQR', ' ', M,
+ $ M, N, -1 ) )
+ WRKBL = MAX( WRKBL, 3*N+2*N*
+ $ ILAENV( 1, 'SGEBRD', ' ', N, N, -1, -1 ) )
+ WRKBL = MAX( WRKBL, 3*N+N*
+ $ ILAENV( 1, 'SORMBR', 'QLN', N, N, N, -1 ) )
+ WRKBL = MAX( WRKBL, 3*N+N*
+ $ ILAENV( 1, 'SORMBR', 'PRT', N, N, N, -1 ) )
+ WRKBL = MAX( WRKBL, BDSPAC+3*N )
+ MAXWRK = WRKBL + N*N
+ MINWRK = BDSPAC + N*N + 3*N
+ END IF
+ ELSE
+*
+* Path 5 (M at least N, but not much larger)
+*
+ WRKBL = 3*N + ( M+N )*ILAENV( 1, 'SGEBRD', ' ', M, N, -1,
+ $ -1 )
+ IF( WNTQN ) THEN
+ MAXWRK = MAX( WRKBL, BDSPAC+3*N )
+ MINWRK = 3*N + MAX( M, BDSPAC )
+ ELSE IF( WNTQO ) THEN
+ WRKBL = MAX( WRKBL, 3*N+N*
+ $ ILAENV( 1, 'SORMBR', 'QLN', M, N, N, -1 ) )
+ WRKBL = MAX( WRKBL, 3*N+N*
+ $ ILAENV( 1, 'SORMBR', 'PRT', N, N, N, -1 ) )
+ WRKBL = MAX( WRKBL, BDSPAC+3*N )
+ MAXWRK = WRKBL + M*N
+ MINWRK = 3*N + MAX( M, N*N+BDSPAC )
+ ELSE IF( WNTQS ) THEN
+ WRKBL = MAX( WRKBL, 3*N+N*
+ $ ILAENV( 1, 'SORMBR', 'QLN', M, N, N, -1 ) )
+ WRKBL = MAX( WRKBL, 3*N+N*
+ $ ILAENV( 1, 'SORMBR', 'PRT', N, N, N, -1 ) )
+ MAXWRK = MAX( WRKBL, BDSPAC+3*N )
+ MINWRK = 3*N + MAX( M, BDSPAC )
+ ELSE IF( WNTQA ) THEN
+ WRKBL = MAX( WRKBL, 3*N+M*
+ $ ILAENV( 1, 'SORMBR', 'QLN', M, M, N, -1 ) )
+ WRKBL = MAX( WRKBL, 3*N+N*
+ $ ILAENV( 1, 'SORMBR', 'PRT', N, N, N, -1 ) )
+ MAXWRK = MAX( MAXWRK, BDSPAC+3*N )
+ MINWRK = 3*N + MAX( M, BDSPAC )
+ END IF
+ END IF
+ ELSE IF ( MINMN.GT.0 ) THEN
+*
+* Compute space needed for SBDSDC
+*
+ MNTHR = INT( MINMN*11.0E0 / 6.0E0 )
+ IF( WNTQN ) THEN
+ BDSPAC = 7*M
+ ELSE
+ BDSPAC = 3*M*M + 4*M
+ END IF
+ IF( N.GE.MNTHR ) THEN
+ IF( WNTQN ) THEN
+*
+* Path 1t (N much larger than M, JOBZ='N')
+*
+ WRKBL = M + M*ILAENV( 1, 'SGELQF', ' ', M, N, -1,
+ $ -1 )
+ WRKBL = MAX( WRKBL, 3*M+2*M*
+ $ ILAENV( 1, 'SGEBRD', ' ', M, M, -1, -1 ) )
+ MAXWRK = MAX( WRKBL, BDSPAC+M )
+ MINWRK = BDSPAC + M
+ ELSE IF( WNTQO ) THEN
+*
+* Path 2t (N much larger than M, JOBZ='O')
+*
+ WRKBL = M + M*ILAENV( 1, 'SGELQF', ' ', M, N, -1, -1 )
+ WRKBL = MAX( WRKBL, M+M*ILAENV( 1, 'SORGLQ', ' ', M,
+ $ N, M, -1 ) )
+ WRKBL = MAX( WRKBL, 3*M+2*M*
+ $ ILAENV( 1, 'SGEBRD', ' ', M, M, -1, -1 ) )
+ WRKBL = MAX( WRKBL, 3*M+M*
+ $ ILAENV( 1, 'SORMBR', 'QLN', M, M, M, -1 ) )
+ WRKBL = MAX( WRKBL, 3*M+M*
+ $ ILAENV( 1, 'SORMBR', 'PRT', M, M, M, -1 ) )
+ WRKBL = MAX( WRKBL, BDSPAC+3*M )
+ MAXWRK = WRKBL + 2*M*M
+ MINWRK = BDSPAC + 2*M*M + 3*M
+ ELSE IF( WNTQS ) THEN
+*
+* Path 3t (N much larger than M, JOBZ='S')
+*
+ WRKBL = M + M*ILAENV( 1, 'SGELQF', ' ', M, N, -1, -1 )
+ WRKBL = MAX( WRKBL, M+M*ILAENV( 1, 'SORGLQ', ' ', M,
+ $ N, M, -1 ) )
+ WRKBL = MAX( WRKBL, 3*M+2*M*
+ $ ILAENV( 1, 'SGEBRD', ' ', M, M, -1, -1 ) )
+ WRKBL = MAX( WRKBL, 3*M+M*
+ $ ILAENV( 1, 'SORMBR', 'QLN', M, M, M, -1 ) )
+ WRKBL = MAX( WRKBL, 3*M+M*
+ $ ILAENV( 1, 'SORMBR', 'PRT', M, M, M, -1 ) )
+ WRKBL = MAX( WRKBL, BDSPAC+3*M )
+ MAXWRK = WRKBL + M*M
+ MINWRK = BDSPAC + M*M + 3*M
+ ELSE IF( WNTQA ) THEN
+*
+* Path 4t (N much larger than M, JOBZ='A')
+*
+ WRKBL = M + M*ILAENV( 1, 'SGELQF', ' ', M, N, -1, -1 )
+ WRKBL = MAX( WRKBL, M+N*ILAENV( 1, 'SORGLQ', ' ', N,
+ $ N, M, -1 ) )
+ WRKBL = MAX( WRKBL, 3*M+2*M*
+ $ ILAENV( 1, 'SGEBRD', ' ', M, M, -1, -1 ) )
+ WRKBL = MAX( WRKBL, 3*M+M*
+ $ ILAENV( 1, 'SORMBR', 'QLN', M, M, M, -1 ) )
+ WRKBL = MAX( WRKBL, 3*M+M*
+ $ ILAENV( 1, 'SORMBR', 'PRT', M, M, M, -1 ) )
+ WRKBL = MAX( WRKBL, BDSPAC+3*M )
+ MAXWRK = WRKBL + M*M
+ MINWRK = BDSPAC + M*M + 3*M
+ END IF
+ ELSE
+*
+* Path 5t (N greater than M, but not much larger)
+*
+ WRKBL = 3*M + ( M+N )*ILAENV( 1, 'SGEBRD', ' ', M, N, -1,
+ $ -1 )
+ IF( WNTQN ) THEN
+ MAXWRK = MAX( WRKBL, BDSPAC+3*M )
+ MINWRK = 3*M + MAX( N, BDSPAC )
+ ELSE IF( WNTQO ) THEN
+ WRKBL = MAX( WRKBL, 3*M+M*
+ $ ILAENV( 1, 'SORMBR', 'QLN', M, M, N, -1 ) )
+ WRKBL = MAX( WRKBL, 3*M+M*
+ $ ILAENV( 1, 'SORMBR', 'PRT', M, N, M, -1 ) )
+ WRKBL = MAX( WRKBL, BDSPAC+3*M )
+ MAXWRK = WRKBL + M*N
+ MINWRK = 3*M + MAX( N, M*M+BDSPAC )
+ ELSE IF( WNTQS ) THEN
+ WRKBL = MAX( WRKBL, 3*M+M*
+ $ ILAENV( 1, 'SORMBR', 'QLN', M, M, N, -1 ) )
+ WRKBL = MAX( WRKBL, 3*M+M*
+ $ ILAENV( 1, 'SORMBR', 'PRT', M, N, M, -1 ) )
+ MAXWRK = MAX( WRKBL, BDSPAC+3*M )
+ MINWRK = 3*M + MAX( N, BDSPAC )
+ ELSE IF( WNTQA ) THEN
+ WRKBL = MAX( WRKBL, 3*M+M*
+ $ ILAENV( 1, 'SORMBR', 'QLN', M, M, N, -1 ) )
+ WRKBL = MAX( WRKBL, 3*M+M*
+ $ ILAENV( 1, 'SORMBR', 'PRT', N, N, M, -1 ) )
+ MAXWRK = MAX( WRKBL, BDSPAC+3*M )
+ MINWRK = 3*M + MAX( N, BDSPAC )
+ END IF
+ END IF
+ END IF
+ MAXWRK = MAX( MAXWRK, MINWRK )
+ WORK( 1 ) = MAXWRK
+*
+ IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN
+ INFO = -12
+ END IF
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SGESDD', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( M.EQ.0 .OR. N.EQ.0 ) THEN
+ RETURN
+ END IF
+*
+* Get machine constants
+*
+ EPS = SLAMCH( 'P' )
+ SMLNUM = SQRT( SLAMCH( 'S' ) ) / EPS
+ BIGNUM = ONE / SMLNUM
+*
+* Scale A if max element outside range [SMLNUM,BIGNUM]
+*
+ ANRM = SLANGE( 'M', M, N, A, LDA, DUM )
+ ISCL = 0
+ IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
+ ISCL = 1
+ CALL SLASCL( 'G', 0, 0, ANRM, SMLNUM, M, N, A, LDA, IERR )
+ ELSE IF( ANRM.GT.BIGNUM ) THEN
+ ISCL = 1
+ CALL SLASCL( 'G', 0, 0, ANRM, BIGNUM, M, N, A, LDA, IERR )
+ END IF
+*
+ IF( M.GE.N ) THEN
+*
+* A has at least as many rows as columns. If A has sufficiently
+* more rows than columns, first reduce using the QR
+* decomposition (if sufficient workspace available)
+*
+ IF( M.GE.MNTHR ) THEN
+*
+ IF( WNTQN ) THEN
+*
+* Path 1 (M much larger than N, JOBZ='N')
+* No singular vectors to be computed
+*
+ ITAU = 1
+ NWORK = ITAU + N
+*
+* Compute A=Q*R
+* (Workspace: need 2*N, prefer N+N*NB)
+*
+ CALL SGEQRF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ),
+ $ LWORK-NWORK+1, IERR )
+*
+* Zero out below R
+*
+ CALL SLASET( 'L', N-1, N-1, ZERO, ZERO, A( 2, 1 ), LDA )
+ IE = 1
+ ITAUQ = IE + N
+ ITAUP = ITAUQ + N
+ NWORK = ITAUP + N
+*
+* Bidiagonalize R in A
+* (Workspace: need 4*N, prefer 3*N+2*N*NB)
+*
+ CALL SGEBRD( N, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ),
+ $ WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1,
+ $ IERR )
+ NWORK = IE + N
+*
+* Perform bidiagonal SVD, computing singular values only
+* (Workspace: need N+BDSPAC)
+*
+ CALL SBDSDC( 'U', 'N', N, S, WORK( IE ), DUM, 1, DUM, 1,
+ $ DUM, IDUM, WORK( NWORK ), IWORK, INFO )
+*
+ ELSE IF( WNTQO ) THEN
+*
+* Path 2 (M much larger than N, JOBZ = 'O')
+* N left singular vectors to be overwritten on A and
+* N right singular vectors to be computed in VT
+*
+ IR = 1
+*
+* WORK(IR) is LDWRKR by N
+*
+ IF( LWORK.GE.LDA*N+N*N+3*N+BDSPAC ) THEN
+ LDWRKR = LDA
+ ELSE
+ LDWRKR = ( LWORK-N*N-3*N-BDSPAC ) / N
+ END IF
+ ITAU = IR + LDWRKR*N
+ NWORK = ITAU + N
+*
+* Compute A=Q*R
+* (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
+*
+ CALL SGEQRF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ),
+ $ LWORK-NWORK+1, IERR )
+*
+* Copy R to WORK(IR), zeroing out below it
+*
+ CALL SLACPY( 'U', N, N, A, LDA, WORK( IR ), LDWRKR )
+ CALL SLASET( 'L', N-1, N-1, ZERO, ZERO, WORK( IR+1 ),
+ $ LDWRKR )
+*
+* Generate Q in A
+* (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
+*
+ CALL SORGQR( M, N, N, A, LDA, WORK( ITAU ),
+ $ WORK( NWORK ), LWORK-NWORK+1, IERR )
+ IE = ITAU
+ ITAUQ = IE + N
+ ITAUP = ITAUQ + N
+ NWORK = ITAUP + N
+*
+* Bidiagonalize R in VT, copying result to WORK(IR)
+* (Workspace: need N*N+4*N, prefer N*N+3*N+2*N*NB)
+*
+ CALL SGEBRD( N, N, WORK( IR ), LDWRKR, S, WORK( IE ),
+ $ WORK( ITAUQ ), WORK( ITAUP ), WORK( NWORK ),
+ $ LWORK-NWORK+1, IERR )
+*
+* WORK(IU) is N by N
+*
+ IU = NWORK
+ NWORK = IU + N*N
+*
+* Perform bidiagonal SVD, computing left singular vectors
+* of bidiagonal matrix in WORK(IU) and computing right
+* singular vectors of bidiagonal matrix in VT
+* (Workspace: need N+N*N+BDSPAC)
+*
+ CALL SBDSDC( 'U', 'I', N, S, WORK( IE ), WORK( IU ), N,
+ $ VT, LDVT, DUM, IDUM, WORK( NWORK ), IWORK,
+ $ INFO )
+*
+* Overwrite WORK(IU) by left singular vectors of R
+* and VT by right singular vectors of R
+* (Workspace: need 2*N*N+3*N, prefer 2*N*N+2*N+N*NB)
+*
+ CALL SORMBR( 'Q', 'L', 'N', N, N, N, WORK( IR ), LDWRKR,
+ $ WORK( ITAUQ ), WORK( IU ), N, WORK( NWORK ),
+ $ LWORK-NWORK+1, IERR )
+ CALL SORMBR( 'P', 'R', 'T', N, N, N, WORK( IR ), LDWRKR,
+ $ WORK( ITAUP ), VT, LDVT, WORK( NWORK ),
+ $ LWORK-NWORK+1, IERR )
+*
+* Multiply Q in A by left singular vectors of R in
+* WORK(IU), storing result in WORK(IR) and copying to A
+* (Workspace: need 2*N*N, prefer N*N+M*N)
+*
+ DO 10 I = 1, M, LDWRKR
+ CHUNK = MIN( M-I+1, LDWRKR )
+ CALL SGEMM( 'N', 'N', CHUNK, N, N, ONE, A( I, 1 ),
+ $ LDA, WORK( IU ), N, ZERO, WORK( IR ),
+ $ LDWRKR )
+ CALL SLACPY( 'F', CHUNK, N, WORK( IR ), LDWRKR,
+ $ A( I, 1 ), LDA )
+ 10 CONTINUE
+*
+ ELSE IF( WNTQS ) THEN
+*
+* Path 3 (M much larger than N, JOBZ='S')
+* N left singular vectors to be computed in U and
+* N right singular vectors to be computed in VT
+*
+ IR = 1
+*
+* WORK(IR) is N by N
+*
+ LDWRKR = N
+ ITAU = IR + LDWRKR*N
+ NWORK = ITAU + N
+*
+* Compute A=Q*R
+* (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
+*
+ CALL SGEQRF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ),
+ $ LWORK-NWORK+1, IERR )
+*
+* Copy R to WORK(IR), zeroing out below it
+*
+ CALL SLACPY( 'U', N, N, A, LDA, WORK( IR ), LDWRKR )
+ CALL SLASET( 'L', N-1, N-1, ZERO, ZERO, WORK( IR+1 ),
+ $ LDWRKR )
+*
+* Generate Q in A
+* (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
+*
+ CALL SORGQR( M, N, N, A, LDA, WORK( ITAU ),
+ $ WORK( NWORK ), LWORK-NWORK+1, IERR )
+ IE = ITAU
+ ITAUQ = IE + N
+ ITAUP = ITAUQ + N
+ NWORK = ITAUP + N
+*
+* Bidiagonalize R in WORK(IR)
+* (Workspace: need N*N+4*N, prefer N*N+3*N+2*N*NB)
+*
+ CALL SGEBRD( N, N, WORK( IR ), LDWRKR, S, WORK( IE ),
+ $ WORK( ITAUQ ), WORK( ITAUP ), WORK( NWORK ),
+ $ LWORK-NWORK+1, IERR )
+*
+* Perform bidiagonal SVD, computing left singular vectors
+* of bidiagoal matrix in U and computing right singular
+* vectors of bidiagonal matrix in VT
+* (Workspace: need N+BDSPAC)
+*
+ CALL SBDSDC( 'U', 'I', N, S, WORK( IE ), U, LDU, VT,
+ $ LDVT, DUM, IDUM, WORK( NWORK ), IWORK,
+ $ INFO )
+*
+* Overwrite U by left singular vectors of R and VT
+* by right singular vectors of R
+* (Workspace: need N*N+3*N, prefer N*N+2*N+N*NB)
+*
+ CALL SORMBR( 'Q', 'L', 'N', N, N, N, WORK( IR ), LDWRKR,
+ $ WORK( ITAUQ ), U, LDU, WORK( NWORK ),
+ $ LWORK-NWORK+1, IERR )
+*
+ CALL SORMBR( 'P', 'R', 'T', N, N, N, WORK( IR ), LDWRKR,
+ $ WORK( ITAUP ), VT, LDVT, WORK( NWORK ),
+ $ LWORK-NWORK+1, IERR )
+*
+* Multiply Q in A by left singular vectors of R in
+* WORK(IR), storing result in U
+* (Workspace: need N*N)
+*
+ CALL SLACPY( 'F', N, N, U, LDU, WORK( IR ), LDWRKR )
+ CALL SGEMM( 'N', 'N', M, N, N, ONE, A, LDA, WORK( IR ),
+ $ LDWRKR, ZERO, U, LDU )
+*
+ ELSE IF( WNTQA ) THEN
+*
+* Path 4 (M much larger than N, JOBZ='A')
+* M left singular vectors to be computed in U and
+* N right singular vectors to be computed in VT
+*
+ IU = 1
+*
+* WORK(IU) is N by N
+*
+ LDWRKU = N
+ ITAU = IU + LDWRKU*N
+ NWORK = ITAU + N
+*
+* Compute A=Q*R, copying result to U
+* (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
+*
+ CALL SGEQRF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ),
+ $ LWORK-NWORK+1, IERR )
+ CALL SLACPY( 'L', M, N, A, LDA, U, LDU )
+*
+* Generate Q in U
+* (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
+ CALL SORGQR( M, M, N, U, LDU, WORK( ITAU ),
+ $ WORK( NWORK ), LWORK-NWORK+1, IERR )
+*
+* Produce R in A, zeroing out other entries
+*
+ CALL SLASET( 'L', N-1, N-1, ZERO, ZERO, A( 2, 1 ), LDA )
+ IE = ITAU
+ ITAUQ = IE + N
+ ITAUP = ITAUQ + N
+ NWORK = ITAUP + N
+*
+* Bidiagonalize R in A
+* (Workspace: need N*N+4*N, prefer N*N+3*N+2*N*NB)
+*
+ CALL SGEBRD( N, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ),
+ $ WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1,
+ $ IERR )
+*
+* Perform bidiagonal SVD, computing left singular vectors
+* of bidiagonal matrix in WORK(IU) and computing right
+* singular vectors of bidiagonal matrix in VT
+* (Workspace: need N+N*N+BDSPAC)
+*
+ CALL SBDSDC( 'U', 'I', N, S, WORK( IE ), WORK( IU ), N,
+ $ VT, LDVT, DUM, IDUM, WORK( NWORK ), IWORK,
+ $ INFO )
+*
+* Overwrite WORK(IU) by left singular vectors of R and VT
+* by right singular vectors of R
+* (Workspace: need N*N+3*N, prefer N*N+2*N+N*NB)
+*
+ CALL SORMBR( 'Q', 'L', 'N', N, N, N, A, LDA,
+ $ WORK( ITAUQ ), WORK( IU ), LDWRKU,
+ $ WORK( NWORK ), LWORK-NWORK+1, IERR )
+ CALL SORMBR( 'P', 'R', 'T', N, N, N, A, LDA,
+ $ WORK( ITAUP ), VT, LDVT, WORK( NWORK ),
+ $ LWORK-NWORK+1, IERR )
+*
+* Multiply Q in U by left singular vectors of R in
+* WORK(IU), storing result in A
+* (Workspace: need N*N)
+*
+ CALL SGEMM( 'N', 'N', M, N, N, ONE, U, LDU, WORK( IU ),
+ $ LDWRKU, ZERO, A, LDA )
+*
+* Copy left singular vectors of A from A to U
+*
+ CALL SLACPY( 'F', M, N, A, LDA, U, LDU )
+*
+ END IF
+*
+ ELSE
+*
+* M .LT. MNTHR
+*
+* Path 5 (M at least N, but not much larger)
+* Reduce to bidiagonal form without QR decomposition
+*
+ IE = 1
+ ITAUQ = IE + N
+ ITAUP = ITAUQ + N
+ NWORK = ITAUP + N
+*
+* Bidiagonalize A
+* (Workspace: need 3*N+M, prefer 3*N+(M+N)*NB)
+*
+ CALL SGEBRD( M, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ),
+ $ WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1,
+ $ IERR )
+ IF( WNTQN ) THEN
+*
+* Perform bidiagonal SVD, only computing singular values
+* (Workspace: need N+BDSPAC)
+*
+ CALL SBDSDC( 'U', 'N', N, S, WORK( IE ), DUM, 1, DUM, 1,
+ $ DUM, IDUM, WORK( NWORK ), IWORK, INFO )
+ ELSE IF( WNTQO ) THEN
+ IU = NWORK
+ IF( LWORK.GE.M*N+3*N+BDSPAC ) THEN
+*
+* WORK( IU ) is M by N
+*
+ LDWRKU = M
+ NWORK = IU + LDWRKU*N
+ CALL SLASET( 'F', M, N, ZERO, ZERO, WORK( IU ),
+ $ LDWRKU )
+ ELSE
+*
+* WORK( IU ) is N by N
+*
+ LDWRKU = N
+ NWORK = IU + LDWRKU*N
+*
+* WORK(IR) is LDWRKR by N
+*
+ IR = NWORK
+ LDWRKR = ( LWORK-N*N-3*N ) / N
+ END IF
+ NWORK = IU + LDWRKU*N
+*
+* Perform bidiagonal SVD, computing left singular vectors
+* of bidiagonal matrix in WORK(IU) and computing right
+* singular vectors of bidiagonal matrix in VT
+* (Workspace: need N+N*N+BDSPAC)
+*
+ CALL SBDSDC( 'U', 'I', N, S, WORK( IE ), WORK( IU ),
+ $ LDWRKU, VT, LDVT, DUM, IDUM, WORK( NWORK ),
+ $ IWORK, INFO )
+*
+* Overwrite VT by right singular vectors of A
+* (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
+*
+ CALL SORMBR( 'P', 'R', 'T', N, N, N, A, LDA,
+ $ WORK( ITAUP ), VT, LDVT, WORK( NWORK ),
+ $ LWORK-NWORK+1, IERR )
+*
+ IF( LWORK.GE.M*N+3*N+BDSPAC ) THEN
+*
+* Overwrite WORK(IU) by left singular vectors of A
+* (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
+*
+ CALL SORMBR( 'Q', 'L', 'N', M, N, N, A, LDA,
+ $ WORK( ITAUQ ), WORK( IU ), LDWRKU,
+ $ WORK( NWORK ), LWORK-NWORK+1, IERR )
+*
+* Copy left singular vectors of A from WORK(IU) to A
+*
+ CALL SLACPY( 'F', M, N, WORK( IU ), LDWRKU, A, LDA )
+ ELSE
+*
+* Generate Q in A
+* (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
+*
+ CALL SORGBR( 'Q', M, N, N, A, LDA, WORK( ITAUQ ),
+ $ WORK( NWORK ), LWORK-NWORK+1, IERR )
+*
+* Multiply Q in A by left singular vectors of
+* bidiagonal matrix in WORK(IU), storing result in
+* WORK(IR) and copying to A
+* (Workspace: need 2*N*N, prefer N*N+M*N)
+*
+ DO 20 I = 1, M, LDWRKR
+ CHUNK = MIN( M-I+1, LDWRKR )
+ CALL SGEMM( 'N', 'N', CHUNK, N, N, ONE, A( I, 1 ),
+ $ LDA, WORK( IU ), LDWRKU, ZERO,
+ $ WORK( IR ), LDWRKR )
+ CALL SLACPY( 'F', CHUNK, N, WORK( IR ), LDWRKR,
+ $ A( I, 1 ), LDA )
+ 20 CONTINUE
+ END IF
+*
+ ELSE IF( WNTQS ) THEN
+*
+* Perform bidiagonal SVD, computing left singular vectors
+* of bidiagonal matrix in U and computing right singular
+* vectors of bidiagonal matrix in VT
+* (Workspace: need N+BDSPAC)
+*
+ CALL SLASET( 'F', M, N, ZERO, ZERO, U, LDU )
+ CALL SBDSDC( 'U', 'I', N, S, WORK( IE ), U, LDU, VT,
+ $ LDVT, DUM, IDUM, WORK( NWORK ), IWORK,
+ $ INFO )
+*
+* Overwrite U by left singular vectors of A and VT
+* by right singular vectors of A
+* (Workspace: need 3*N, prefer 2*N+N*NB)
+*
+ CALL SORMBR( 'Q', 'L', 'N', M, N, N, A, LDA,
+ $ WORK( ITAUQ ), U, LDU, WORK( NWORK ),
+ $ LWORK-NWORK+1, IERR )
+ CALL SORMBR( 'P', 'R', 'T', N, N, N, A, LDA,
+ $ WORK( ITAUP ), VT, LDVT, WORK( NWORK ),
+ $ LWORK-NWORK+1, IERR )
+ ELSE IF( WNTQA ) THEN
+*
+* Perform bidiagonal SVD, computing left singular vectors
+* of bidiagonal matrix in U and computing right singular
+* vectors of bidiagonal matrix in VT
+* (Workspace: need N+BDSPAC)
+*
+ CALL SLASET( 'F', M, M, ZERO, ZERO, U, LDU )
+ CALL SBDSDC( 'U', 'I', N, S, WORK( IE ), U, LDU, VT,
+ $ LDVT, DUM, IDUM, WORK( NWORK ), IWORK,
+ $ INFO )
+*
+* Set the right corner of U to identity matrix
+*
+ IF( M.GT.N ) THEN
+ CALL SLASET( 'F', M-N, M-N, ZERO, ONE, U( N+1, N+1 ),
+ $ LDU )
+ END IF
+*
+* Overwrite U by left singular vectors of A and VT
+* by right singular vectors of A
+* (Workspace: need N*N+2*N+M, prefer N*N+2*N+M*NB)
+*
+ CALL SORMBR( 'Q', 'L', 'N', M, M, N, A, LDA,
+ $ WORK( ITAUQ ), U, LDU, WORK( NWORK ),
+ $ LWORK-NWORK+1, IERR )
+ CALL SORMBR( 'P', 'R', 'T', N, N, M, A, LDA,
+ $ WORK( ITAUP ), VT, LDVT, WORK( NWORK ),
+ $ LWORK-NWORK+1, IERR )
+ END IF
+*
+ END IF
+*
+ ELSE
+*
+* A has more columns than rows. If A has sufficiently more
+* columns than rows, first reduce using the LQ decomposition (if
+* sufficient workspace available)
+*
+ IF( N.GE.MNTHR ) THEN
+*
+ IF( WNTQN ) THEN
+*
+* Path 1t (N much larger than M, JOBZ='N')
+* No singular vectors to be computed
+*
+ ITAU = 1
+ NWORK = ITAU + M
+*
+* Compute A=L*Q
+* (Workspace: need 2*M, prefer M+M*NB)
+*
+ CALL SGELQF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ),
+ $ LWORK-NWORK+1, IERR )
+*
+* Zero out above L
+*
+ CALL SLASET( 'U', M-1, M-1, ZERO, ZERO, A( 1, 2 ), LDA )
+ IE = 1
+ ITAUQ = IE + M
+ ITAUP = ITAUQ + M
+ NWORK = ITAUP + M
+*
+* Bidiagonalize L in A
+* (Workspace: need 4*M, prefer 3*M+2*M*NB)
+*
+ CALL SGEBRD( M, M, A, LDA, S, WORK( IE ), WORK( ITAUQ ),
+ $ WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1,
+ $ IERR )
+ NWORK = IE + M
+*
+* Perform bidiagonal SVD, computing singular values only
+* (Workspace: need M+BDSPAC)
+*
+ CALL SBDSDC( 'U', 'N', M, S, WORK( IE ), DUM, 1, DUM, 1,
+ $ DUM, IDUM, WORK( NWORK ), IWORK, INFO )
+*
+ ELSE IF( WNTQO ) THEN
+*
+* Path 2t (N much larger than M, JOBZ='O')
+* M right singular vectors to be overwritten on A and
+* M left singular vectors to be computed in U
+*
+ IVT = 1
+*
+* IVT is M by M
+*
+ IL = IVT + M*M
+ IF( LWORK.GE.M*N+M*M+3*M+BDSPAC ) THEN
+*
+* WORK(IL) is M by N
+*
+ LDWRKL = M
+ CHUNK = N
+ ELSE
+ LDWRKL = M
+ CHUNK = ( LWORK-M*M ) / M
+ END IF
+ ITAU = IL + LDWRKL*M
+ NWORK = ITAU + M
+*
+* Compute A=L*Q
+* (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
+*
+ CALL SGELQF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ),
+ $ LWORK-NWORK+1, IERR )
+*
+* Copy L to WORK(IL), zeroing about above it
+*
+ CALL SLACPY( 'L', M, M, A, LDA, WORK( IL ), LDWRKL )
+ CALL SLASET( 'U', M-1, M-1, ZERO, ZERO,
+ $ WORK( IL+LDWRKL ), LDWRKL )
+*
+* Generate Q in A
+* (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
+*
+ CALL SORGLQ( M, N, M, A, LDA, WORK( ITAU ),
+ $ WORK( NWORK ), LWORK-NWORK+1, IERR )
+ IE = ITAU
+ ITAUQ = IE + M
+ ITAUP = ITAUQ + M
+ NWORK = ITAUP + M
+*
+* Bidiagonalize L in WORK(IL)
+* (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB)
+*
+ CALL SGEBRD( M, M, WORK( IL ), LDWRKL, S, WORK( IE ),
+ $ WORK( ITAUQ ), WORK( ITAUP ), WORK( NWORK ),
+ $ LWORK-NWORK+1, IERR )
+*
+* Perform bidiagonal SVD, computing left singular vectors
+* of bidiagonal matrix in U, and computing right singular
+* vectors of bidiagonal matrix in WORK(IVT)
+* (Workspace: need M+M*M+BDSPAC)
+*
+ CALL SBDSDC( 'U', 'I', M, S, WORK( IE ), U, LDU,
+ $ WORK( IVT ), M, DUM, IDUM, WORK( NWORK ),
+ $ IWORK, INFO )
+*
+* Overwrite U by left singular vectors of L and WORK(IVT)
+* by right singular vectors of L
+* (Workspace: need 2*M*M+3*M, prefer 2*M*M+2*M+M*NB)
+*
+ CALL SORMBR( 'Q', 'L', 'N', M, M, M, WORK( IL ), LDWRKL,
+ $ WORK( ITAUQ ), U, LDU, WORK( NWORK ),
+ $ LWORK-NWORK+1, IERR )
+ CALL SORMBR( 'P', 'R', 'T', M, M, M, WORK( IL ), LDWRKL,
+ $ WORK( ITAUP ), WORK( IVT ), M,
+ $ WORK( NWORK ), LWORK-NWORK+1, IERR )
+*
+* Multiply right singular vectors of L in WORK(IVT) by Q
+* in A, storing result in WORK(IL) and copying to A
+* (Workspace: need 2*M*M, prefer M*M+M*N)
+*
+ DO 30 I = 1, N, CHUNK
+ BLK = MIN( N-I+1, CHUNK )
+ CALL SGEMM( 'N', 'N', M, BLK, M, ONE, WORK( IVT ), M,
+ $ A( 1, I ), LDA, ZERO, WORK( IL ), LDWRKL )
+ CALL SLACPY( 'F', M, BLK, WORK( IL ), LDWRKL,
+ $ A( 1, I ), LDA )
+ 30 CONTINUE
+*
+ ELSE IF( WNTQS ) THEN
+*
+* Path 3t (N much larger than M, JOBZ='S')
+* M right singular vectors to be computed in VT and
+* M left singular vectors to be computed in U
+*
+ IL = 1
+*
+* WORK(IL) is M by M
+*
+ LDWRKL = M
+ ITAU = IL + LDWRKL*M
+ NWORK = ITAU + M
+*
+* Compute A=L*Q
+* (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
+*
+ CALL SGELQF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ),
+ $ LWORK-NWORK+1, IERR )
+*
+* Copy L to WORK(IL), zeroing out above it
+*
+ CALL SLACPY( 'L', M, M, A, LDA, WORK( IL ), LDWRKL )
+ CALL SLASET( 'U', M-1, M-1, ZERO, ZERO,
+ $ WORK( IL+LDWRKL ), LDWRKL )
+*
+* Generate Q in A
+* (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
+*
+ CALL SORGLQ( M, N, M, A, LDA, WORK( ITAU ),
+ $ WORK( NWORK ), LWORK-NWORK+1, IERR )
+ IE = ITAU
+ ITAUQ = IE + M
+ ITAUP = ITAUQ + M
+ NWORK = ITAUP + M
+*
+* Bidiagonalize L in WORK(IU), copying result to U
+* (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB)
+*
+ CALL SGEBRD( M, M, WORK( IL ), LDWRKL, S, WORK( IE ),
+ $ WORK( ITAUQ ), WORK( ITAUP ), WORK( NWORK ),
+ $ LWORK-NWORK+1, IERR )
+*
+* Perform bidiagonal SVD, computing left singular vectors
+* of bidiagonal matrix in U and computing right singular
+* vectors of bidiagonal matrix in VT
+* (Workspace: need M+BDSPAC)
+*
+ CALL SBDSDC( 'U', 'I', M, S, WORK( IE ), U, LDU, VT,
+ $ LDVT, DUM, IDUM, WORK( NWORK ), IWORK,
+ $ INFO )
+*
+* Overwrite U by left singular vectors of L and VT
+* by right singular vectors of L
+* (Workspace: need M*M+3*M, prefer M*M+2*M+M*NB)
+*
+ CALL SORMBR( 'Q', 'L', 'N', M, M, M, WORK( IL ), LDWRKL,
+ $ WORK( ITAUQ ), U, LDU, WORK( NWORK ),
+ $ LWORK-NWORK+1, IERR )
+ CALL SORMBR( 'P', 'R', 'T', M, M, M, WORK( IL ), LDWRKL,
+ $ WORK( ITAUP ), VT, LDVT, WORK( NWORK ),
+ $ LWORK-NWORK+1, IERR )
+*
+* Multiply right singular vectors of L in WORK(IL) by
+* Q in A, storing result in VT
+* (Workspace: need M*M)
+*
+ CALL SLACPY( 'F', M, M, VT, LDVT, WORK( IL ), LDWRKL )
+ CALL SGEMM( 'N', 'N', M, N, M, ONE, WORK( IL ), LDWRKL,
+ $ A, LDA, ZERO, VT, LDVT )
+*
+ ELSE IF( WNTQA ) THEN
+*
+* Path 4t (N much larger than M, JOBZ='A')
+* N right singular vectors to be computed in VT and
+* M left singular vectors to be computed in U
+*
+ IVT = 1
+*
+* WORK(IVT) is M by M
+*
+ LDWKVT = M
+ ITAU = IVT + LDWKVT*M
+ NWORK = ITAU + M
+*
+* Compute A=L*Q, copying result to VT
+* (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
+*
+ CALL SGELQF( M, N, A, LDA, WORK( ITAU ), WORK( NWORK ),
+ $ LWORK-NWORK+1, IERR )
+ CALL SLACPY( 'U', M, N, A, LDA, VT, LDVT )
+*
+* Generate Q in VT
+* (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
+*
+ CALL SORGLQ( N, N, M, VT, LDVT, WORK( ITAU ),
+ $ WORK( NWORK ), LWORK-NWORK+1, IERR )
+*
+* Produce L in A, zeroing out other entries
+*
+ CALL SLASET( 'U', M-1, M-1, ZERO, ZERO, A( 1, 2 ), LDA )
+ IE = ITAU
+ ITAUQ = IE + M
+ ITAUP = ITAUQ + M
+ NWORK = ITAUP + M
+*
+* Bidiagonalize L in A
+* (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB)
+*
+ CALL SGEBRD( M, M, A, LDA, S, WORK( IE ), WORK( ITAUQ ),
+ $ WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1,
+ $ IERR )
+*
+* Perform bidiagonal SVD, computing left singular vectors
+* of bidiagonal matrix in U and computing right singular
+* vectors of bidiagonal matrix in WORK(IVT)
+* (Workspace: need M+M*M+BDSPAC)
+*
+ CALL SBDSDC( 'U', 'I', M, S, WORK( IE ), U, LDU,
+ $ WORK( IVT ), LDWKVT, DUM, IDUM,
+ $ WORK( NWORK ), IWORK, INFO )
+*
+* Overwrite U by left singular vectors of L and WORK(IVT)
+* by right singular vectors of L
+* (Workspace: need M*M+3*M, prefer M*M+2*M+M*NB)
+*
+ CALL SORMBR( 'Q', 'L', 'N', M, M, M, A, LDA,
+ $ WORK( ITAUQ ), U, LDU, WORK( NWORK ),
+ $ LWORK-NWORK+1, IERR )
+ CALL SORMBR( 'P', 'R', 'T', M, M, M, A, LDA,
+ $ WORK( ITAUP ), WORK( IVT ), LDWKVT,
+ $ WORK( NWORK ), LWORK-NWORK+1, IERR )
+*
+* Multiply right singular vectors of L in WORK(IVT) by
+* Q in VT, storing result in A
+* (Workspace: need M*M)
+*
+ CALL SGEMM( 'N', 'N', M, N, M, ONE, WORK( IVT ), LDWKVT,
+ $ VT, LDVT, ZERO, A, LDA )
+*
+* Copy right singular vectors of A from A to VT
+*
+ CALL SLACPY( 'F', M, N, A, LDA, VT, LDVT )
+*
+ END IF
+*
+ ELSE
+*
+* N .LT. MNTHR
+*
+* Path 5t (N greater than M, but not much larger)
+* Reduce to bidiagonal form without LQ decomposition
+*
+ IE = 1
+ ITAUQ = IE + M
+ ITAUP = ITAUQ + M
+ NWORK = ITAUP + M
+*
+* Bidiagonalize A
+* (Workspace: need 3*M+N, prefer 3*M+(M+N)*NB)
+*
+ CALL SGEBRD( M, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ),
+ $ WORK( ITAUP ), WORK( NWORK ), LWORK-NWORK+1,
+ $ IERR )
+ IF( WNTQN ) THEN
+*
+* Perform bidiagonal SVD, only computing singular values
+* (Workspace: need M+BDSPAC)
+*
+ CALL SBDSDC( 'L', 'N', M, S, WORK( IE ), DUM, 1, DUM, 1,
+ $ DUM, IDUM, WORK( NWORK ), IWORK, INFO )
+ ELSE IF( WNTQO ) THEN
+ LDWKVT = M
+ IVT = NWORK
+ IF( LWORK.GE.M*N+3*M+BDSPAC ) THEN
+*
+* WORK( IVT ) is M by N
+*
+ CALL SLASET( 'F', M, N, ZERO, ZERO, WORK( IVT ),
+ $ LDWKVT )
+ NWORK = IVT + LDWKVT*N
+ ELSE
+*
+* WORK( IVT ) is M by M
+*
+ NWORK = IVT + LDWKVT*M
+ IL = NWORK
+*
+* WORK(IL) is M by CHUNK
+*
+ CHUNK = ( LWORK-M*M-3*M ) / M
+ END IF
+*
+* Perform bidiagonal SVD, computing left singular vectors
+* of bidiagonal matrix in U and computing right singular
+* vectors of bidiagonal matrix in WORK(IVT)
+* (Workspace: need M*M+BDSPAC)
+*
+ CALL SBDSDC( 'L', 'I', M, S, WORK( IE ), U, LDU,
+ $ WORK( IVT ), LDWKVT, DUM, IDUM,
+ $ WORK( NWORK ), IWORK, INFO )
+*
+* Overwrite U by left singular vectors of A
+* (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
+*
+ CALL SORMBR( 'Q', 'L', 'N', M, M, N, A, LDA,
+ $ WORK( ITAUQ ), U, LDU, WORK( NWORK ),
+ $ LWORK-NWORK+1, IERR )
+*
+ IF( LWORK.GE.M*N+3*M+BDSPAC ) THEN
+*
+* Overwrite WORK(IVT) by left singular vectors of A
+* (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
+*
+ CALL SORMBR( 'P', 'R', 'T', M, N, M, A, LDA,
+ $ WORK( ITAUP ), WORK( IVT ), LDWKVT,
+ $ WORK( NWORK ), LWORK-NWORK+1, IERR )
+*
+* Copy right singular vectors of A from WORK(IVT) to A
+*
+ CALL SLACPY( 'F', M, N, WORK( IVT ), LDWKVT, A, LDA )
+ ELSE
+*
+* Generate P**T in A
+* (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
+*
+ CALL SORGBR( 'P', M, N, M, A, LDA, WORK( ITAUP ),
+ $ WORK( NWORK ), LWORK-NWORK+1, IERR )
+*
+* Multiply Q in A by right singular vectors of
+* bidiagonal matrix in WORK(IVT), storing result in
+* WORK(IL) and copying to A
+* (Workspace: need 2*M*M, prefer M*M+M*N)
+*
+ DO 40 I = 1, N, CHUNK
+ BLK = MIN( N-I+1, CHUNK )
+ CALL SGEMM( 'N', 'N', M, BLK, M, ONE, WORK( IVT ),
+ $ LDWKVT, A( 1, I ), LDA, ZERO,
+ $ WORK( IL ), M )
+ CALL SLACPY( 'F', M, BLK, WORK( IL ), M, A( 1, I ),
+ $ LDA )
+ 40 CONTINUE
+ END IF
+ ELSE IF( WNTQS ) THEN
+*
+* Perform bidiagonal SVD, computing left singular vectors
+* of bidiagonal matrix in U and computing right singular
+* vectors of bidiagonal matrix in VT
+* (Workspace: need M+BDSPAC)
+*
+ CALL SLASET( 'F', M, N, ZERO, ZERO, VT, LDVT )
+ CALL SBDSDC( 'L', 'I', M, S, WORK( IE ), U, LDU, VT,
+ $ LDVT, DUM, IDUM, WORK( NWORK ), IWORK,
+ $ INFO )
+*
+* Overwrite U by left singular vectors of A and VT
+* by right singular vectors of A
+* (Workspace: need 3*M, prefer 2*M+M*NB)
+*
+ CALL SORMBR( 'Q', 'L', 'N', M, M, N, A, LDA,
+ $ WORK( ITAUQ ), U, LDU, WORK( NWORK ),
+ $ LWORK-NWORK+1, IERR )
+ CALL SORMBR( 'P', 'R', 'T', M, N, M, A, LDA,
+ $ WORK( ITAUP ), VT, LDVT, WORK( NWORK ),
+ $ LWORK-NWORK+1, IERR )
+ ELSE IF( WNTQA ) THEN
+*
+* Perform bidiagonal SVD, computing left singular vectors
+* of bidiagonal matrix in U and computing right singular
+* vectors of bidiagonal matrix in VT
+* (Workspace: need M+BDSPAC)
+*
+ CALL SLASET( 'F', N, N, ZERO, ZERO, VT, LDVT )
+ CALL SBDSDC( 'L', 'I', M, S, WORK( IE ), U, LDU, VT,
+ $ LDVT, DUM, IDUM, WORK( NWORK ), IWORK,
+ $ INFO )
+*
+* Set the right corner of VT to identity matrix
+*
+ IF( N.GT.M ) THEN
+ CALL SLASET( 'F', N-M, N-M, ZERO, ONE, VT( M+1, M+1 ),
+ $ LDVT )
+ END IF
+*
+* Overwrite U by left singular vectors of A and VT
+* by right singular vectors of A
+* (Workspace: need 2*M+N, prefer 2*M+N*NB)
+*
+ CALL SORMBR( 'Q', 'L', 'N', M, M, N, A, LDA,
+ $ WORK( ITAUQ ), U, LDU, WORK( NWORK ),
+ $ LWORK-NWORK+1, IERR )
+ CALL SORMBR( 'P', 'R', 'T', N, N, M, A, LDA,
+ $ WORK( ITAUP ), VT, LDVT, WORK( NWORK ),
+ $ LWORK-NWORK+1, IERR )
+ END IF
+*
+ END IF
+*
+ END IF
+*
+* Undo scaling if necessary
+*
+ IF( ISCL.EQ.1 ) THEN
+ IF( ANRM.GT.BIGNUM )
+ $ CALL SLASCL( 'G', 0, 0, BIGNUM, ANRM, MINMN, 1, S, MINMN,
+ $ IERR )
+ IF( ANRM.LT.SMLNUM )
+ $ CALL SLASCL( 'G', 0, 0, SMLNUM, ANRM, MINMN, 1, S, MINMN,
+ $ IERR )
+ END IF
+*
+* Return optimal workspace in WORK(1)
+*
+ WORK( 1 ) = MAXWRK
+*
+ RETURN
+*
+* End of SGESDD
+*
+ END
+ SUBROUTINE SGESV( N, NRHS, A, LDA, IPIV, B, LDB, INFO )
+*
+* -- LAPACK driver routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LDA, LDB, N, NRHS
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ REAL A( LDA, * ), B( LDB, * )
+* ..
+*
+* Purpose
+* =======
+*
+* SGESV computes the solution to a real system of linear equations
+* A * X = B,
+* where A is an N-by-N matrix and X and B are N-by-NRHS matrices.
+*
+* The LU decomposition with partial pivoting and row interchanges is
+* used to factor A as
+* A = P * L * U,
+* where P is a permutation matrix, L is unit lower triangular, and U is
+* upper triangular. The factored form of A is then used to solve the
+* system of equations A * X = B.
+*
+* Arguments
+* =========
+*
+* N (input) INTEGER
+* The number of linear equations, i.e., the order of the
+* matrix A. N >= 0.
+*
+* NRHS (input) INTEGER
+* The number of right hand sides, i.e., the number of columns
+* of the matrix B. NRHS >= 0.
+*
+* A (input/output) REAL array, dimension (LDA,N)
+* On entry, the N-by-N coefficient matrix A.
+* On exit, the factors L and U from the factorization
+* A = P*L*U; the unit diagonal elements of L are not stored.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,N).
+*
+* IPIV (output) INTEGER array, dimension (N)
+* The pivot indices that define the permutation matrix P;
+* row i of the matrix was interchanged with row IPIV(i).
+*
+* B (input/output) REAL array, dimension (LDB,NRHS)
+* On entry, the N-by-NRHS matrix of right hand side matrix B.
+* On exit, if INFO = 0, the N-by-NRHS solution matrix X.
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. LDB >= max(1,N).
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* > 0: if INFO = i, U(i,i) is exactly zero. The factorization
+* has been completed, but the factor U is exactly
+* singular, so the solution could not be computed.
+*
+* =====================================================================
+*
+* .. External Subroutines ..
+ EXTERNAL SGETRF, SGETRS, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ IF( N.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( NRHS.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -4
+ ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -7
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SGESV ', -INFO )
+ RETURN
+ END IF
+*
+* Compute the LU factorization of A.
+*
+ CALL SGETRF( N, N, A, LDA, IPIV, INFO )
+ IF( INFO.EQ.0 ) THEN
+*
+* Solve the system A*X = B, overwriting B with X.
+*
+ CALL SGETRS( 'No transpose', N, NRHS, A, LDA, IPIV, B, LDB,
+ $ INFO )
+ END IF
+ RETURN
+*
+* End of SGESV
+*
+ END
+ SUBROUTINE SGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU, VT, LDVT,
+ $ WORK, LWORK, INFO )
+*
+* -- LAPACK driver routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER JOBU, JOBVT
+ INTEGER INFO, LDA, LDU, LDVT, LWORK, M, N
+* ..
+* .. Array Arguments ..
+ REAL A( LDA, * ), S( * ), U( LDU, * ),
+ $ VT( LDVT, * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SGESVD computes the singular value decomposition (SVD) of a real
+* M-by-N matrix A, optionally computing the left and/or right singular
+* vectors. The SVD is written
+*
+* A = U * SIGMA * transpose(V)
+*
+* where SIGMA is an M-by-N matrix which is zero except for its
+* min(m,n) diagonal elements, U is an M-by-M orthogonal matrix, and
+* V is an N-by-N orthogonal matrix. The diagonal elements of SIGMA
+* are the singular values of A; they are real and non-negative, and
+* are returned in descending order. The first min(m,n) columns of
+* U and V are the left and right singular vectors of A.
+*
+* Note that the routine returns V**T, not V.
+*
+* Arguments
+* =========
+*
+* JOBU (input) CHARACTER*1
+* Specifies options for computing all or part of the matrix U:
+* = 'A': all M columns of U are returned in array U:
+* = 'S': the first min(m,n) columns of U (the left singular
+* vectors) are returned in the array U;
+* = 'O': the first min(m,n) columns of U (the left singular
+* vectors) are overwritten on the array A;
+* = 'N': no columns of U (no left singular vectors) are
+* computed.
+*
+* JOBVT (input) CHARACTER*1
+* Specifies options for computing all or part of the matrix
+* V**T:
+* = 'A': all N rows of V**T are returned in the array VT;
+* = 'S': the first min(m,n) rows of V**T (the right singular
+* vectors) are returned in the array VT;
+* = 'O': the first min(m,n) rows of V**T (the right singular
+* vectors) are overwritten on the array A;
+* = 'N': no rows of V**T (no right singular vectors) are
+* computed.
+*
+* JOBVT and JOBU cannot both be 'O'.
+*
+* M (input) INTEGER
+* The number of rows of the input matrix A. M >= 0.
+*
+* N (input) INTEGER
+* The number of columns of the input matrix A. N >= 0.
+*
+* A (input/output) REAL array, dimension (LDA,N)
+* On entry, the M-by-N matrix A.
+* On exit,
+* if JOBU = 'O', A is overwritten with the first min(m,n)
+* columns of U (the left singular vectors,
+* stored columnwise);
+* if JOBVT = 'O', A is overwritten with the first min(m,n)
+* rows of V**T (the right singular vectors,
+* stored rowwise);
+* if JOBU .ne. 'O' and JOBVT .ne. 'O', the contents of A
+* are destroyed.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,M).
+*
+* S (output) REAL array, dimension (min(M,N))
+* The singular values of A, sorted so that S(i) >= S(i+1).
+*
+* U (output) REAL array, dimension (LDU,UCOL)
+* (LDU,M) if JOBU = 'A' or (LDU,min(M,N)) if JOBU = 'S'.
+* If JOBU = 'A', U contains the M-by-M orthogonal matrix U;
+* if JOBU = 'S', U contains the first min(m,n) columns of U
+* (the left singular vectors, stored columnwise);
+* if JOBU = 'N' or 'O', U is not referenced.
+*
+* LDU (input) INTEGER
+* The leading dimension of the array U. LDU >= 1; if
+* JOBU = 'S' or 'A', LDU >= M.
+*
+* VT (output) REAL array, dimension (LDVT,N)
+* If JOBVT = 'A', VT contains the N-by-N orthogonal matrix
+* V**T;
+* if JOBVT = 'S', VT contains the first min(m,n) rows of
+* V**T (the right singular vectors, stored rowwise);
+* if JOBVT = 'N' or 'O', VT is not referenced.
+*
+* LDVT (input) INTEGER
+* The leading dimension of the array VT. LDVT >= 1; if
+* JOBVT = 'A', LDVT >= N; if JOBVT = 'S', LDVT >= min(M,N).
+*
+* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))
+* On exit, if INFO = 0, WORK(1) returns the optimal LWORK;
+* if INFO > 0, WORK(2:MIN(M,N)) contains the unconverged
+* superdiagonal elements of an upper bidiagonal matrix B
+* whose diagonal is in S (not necessarily sorted). B
+* satisfies A = U * B * VT, so it has the same singular values
+* as A, and singular vectors related by U and VT.
+*
+* LWORK (input) INTEGER
+* The dimension of the array WORK.
+* LWORK >= MAX(1,3*MIN(M,N)+MAX(M,N),5*MIN(M,N)).
+* For good performance, LWORK should generally be larger.
+*
+* If LWORK = -1, then a workspace query is assumed; the routine
+* only calculates the optimal size of the WORK array, returns
+* this value as the first entry of the WORK array, and no error
+* message related to LWORK is issued by XERBLA.
+*
+* INFO (output) INTEGER
+* = 0: successful exit.
+* < 0: if INFO = -i, the i-th argument had an illegal value.
+* > 0: if SBDSQR did not converge, INFO specifies how many
+* superdiagonals of an intermediate bidiagonal form B
+* did not converge to zero. See the description of WORK
+* above for details.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO, ONE
+ PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL LQUERY, WNTUA, WNTUAS, WNTUN, WNTUO, WNTUS,
+ $ WNTVA, WNTVAS, WNTVN, WNTVO, WNTVS
+ INTEGER BDSPAC, BLK, CHUNK, I, IE, IERR, IR, ISCL,
+ $ ITAU, ITAUP, ITAUQ, IU, IWORK, LDWRKR, LDWRKU,
+ $ MAXWRK, MINMN, MINWRK, MNTHR, NCU, NCVT, NRU,
+ $ NRVT, WRKBL
+ REAL ANRM, BIGNUM, EPS, SMLNUM
+* ..
+* .. Local Arrays ..
+ REAL DUM( 1 )
+* ..
+* .. External Subroutines ..
+ EXTERNAL SBDSQR, SGEBRD, SGELQF, SGEMM, SGEQRF, SLACPY,
+ $ SLASCL, SLASET, SORGBR, SORGLQ, SORGQR, SORMBR,
+ $ XERBLA
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ILAENV
+ REAL SLAMCH, SLANGE
+ EXTERNAL LSAME, ILAENV, SLAMCH, SLANGE
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN, SQRT
+* ..
+* .. Executable Statements ..
+*
+* Test the input arguments
+*
+ INFO = 0
+ MINMN = MIN( M, N )
+ WNTUA = LSAME( JOBU, 'A' )
+ WNTUS = LSAME( JOBU, 'S' )
+ WNTUAS = WNTUA .OR. WNTUS
+ WNTUO = LSAME( JOBU, 'O' )
+ WNTUN = LSAME( JOBU, 'N' )
+ WNTVA = LSAME( JOBVT, 'A' )
+ WNTVS = LSAME( JOBVT, 'S' )
+ WNTVAS = WNTVA .OR. WNTVS
+ WNTVO = LSAME( JOBVT, 'O' )
+ WNTVN = LSAME( JOBVT, 'N' )
+ LQUERY = ( LWORK.EQ.-1 )
+*
+ IF( .NOT.( WNTUA .OR. WNTUS .OR. WNTUO .OR. WNTUN ) ) THEN
+ INFO = -1
+ ELSE IF( .NOT.( WNTVA .OR. WNTVS .OR. WNTVO .OR. WNTVN ) .OR.
+ $ ( WNTVO .AND. WNTUO ) ) THEN
+ INFO = -2
+ ELSE IF( M.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+ INFO = -6
+ ELSE IF( LDU.LT.1 .OR. ( WNTUAS .AND. LDU.LT.M ) ) THEN
+ INFO = -9
+ ELSE IF( LDVT.LT.1 .OR. ( WNTVA .AND. LDVT.LT.N ) .OR.
+ $ ( WNTVS .AND. LDVT.LT.MINMN ) ) THEN
+ INFO = -11
+ END IF
+*
+* Compute workspace
+* (Note: Comments in the code beginning "Workspace:" describe the
+* minimal amount of workspace needed at that point in the code,
+* as well as the preferred amount for good performance.
+* NB refers to the optimal block size for the immediately
+* following subroutine, as returned by ILAENV.)
+*
+ IF( INFO.EQ.0 ) THEN
+ MINWRK = 1
+ MAXWRK = 1
+ IF( M.GE.N .AND. MINMN.GT.0 ) THEN
+*
+* Compute space needed for SBDSQR
+*
+ MNTHR = ILAENV( 6, 'SGESVD', JOBU // JOBVT, M, N, 0, 0 )
+ BDSPAC = 5*N
+ IF( M.GE.MNTHR ) THEN
+ IF( WNTUN ) THEN
+*
+* Path 1 (M much larger than N, JOBU='N')
+*
+ MAXWRK = N + N*ILAENV( 1, 'SGEQRF', ' ', M, N, -1,
+ $ -1 )
+ MAXWRK = MAX( MAXWRK, 3*N+2*N*
+ $ ILAENV( 1, 'SGEBRD', ' ', N, N, -1, -1 ) )
+ IF( WNTVO .OR. WNTVAS )
+ $ MAXWRK = MAX( MAXWRK, 3*N+( N-1 )*
+ $ ILAENV( 1, 'SORGBR', 'P', N, N, N, -1 ) )
+ MAXWRK = MAX( MAXWRK, BDSPAC )
+ MINWRK = MAX( 4*N, BDSPAC )
+ ELSE IF( WNTUO .AND. WNTVN ) THEN
+*
+* Path 2 (M much larger than N, JOBU='O', JOBVT='N')
+*
+ WRKBL = N + N*ILAENV( 1, 'SGEQRF', ' ', M, N, -1, -1 )
+ WRKBL = MAX( WRKBL, N+N*ILAENV( 1, 'SORGQR', ' ', M,
+ $ N, N, -1 ) )
+ WRKBL = MAX( WRKBL, 3*N+2*N*
+ $ ILAENV( 1, 'SGEBRD', ' ', N, N, -1, -1 ) )
+ WRKBL = MAX( WRKBL, 3*N+N*
+ $ ILAENV( 1, 'SORGBR', 'Q', N, N, N, -1 ) )
+ WRKBL = MAX( WRKBL, BDSPAC )
+ MAXWRK = MAX( N*N+WRKBL, N*N+M*N+N )
+ MINWRK = MAX( 3*N+M, BDSPAC )
+ ELSE IF( WNTUO .AND. WNTVAS ) THEN
+*
+* Path 3 (M much larger than N, JOBU='O', JOBVT='S' or
+* 'A')
+*
+ WRKBL = N + N*ILAENV( 1, 'SGEQRF', ' ', M, N, -1, -1 )
+ WRKBL = MAX( WRKBL, N+N*ILAENV( 1, 'SORGQR', ' ', M,
+ $ N, N, -1 ) )
+ WRKBL = MAX( WRKBL, 3*N+2*N*
+ $ ILAENV( 1, 'SGEBRD', ' ', N, N, -1, -1 ) )
+ WRKBL = MAX( WRKBL, 3*N+N*
+ $ ILAENV( 1, 'SORGBR', 'Q', N, N, N, -1 ) )
+ WRKBL = MAX( WRKBL, 3*N+( N-1 )*
+ $ ILAENV( 1, 'SORGBR', 'P', N, N, N, -1 ) )
+ WRKBL = MAX( WRKBL, BDSPAC )
+ MAXWRK = MAX( N*N+WRKBL, N*N+M*N+N )
+ MINWRK = MAX( 3*N+M, BDSPAC )
+ ELSE IF( WNTUS .AND. WNTVN ) THEN
+*
+* Path 4 (M much larger than N, JOBU='S', JOBVT='N')
+*
+ WRKBL = N + N*ILAENV( 1, 'SGEQRF', ' ', M, N, -1, -1 )
+ WRKBL = MAX( WRKBL, N+N*ILAENV( 1, 'SORGQR', ' ', M,
+ $ N, N, -1 ) )
+ WRKBL = MAX( WRKBL, 3*N+2*N*
+ $ ILAENV( 1, 'SGEBRD', ' ', N, N, -1, -1 ) )
+ WRKBL = MAX( WRKBL, 3*N+N*
+ $ ILAENV( 1, 'SORGBR', 'Q', N, N, N, -1 ) )
+ WRKBL = MAX( WRKBL, BDSPAC )
+ MAXWRK = N*N + WRKBL
+ MINWRK = MAX( 3*N+M, BDSPAC )
+ ELSE IF( WNTUS .AND. WNTVO ) THEN
+*
+* Path 5 (M much larger than N, JOBU='S', JOBVT='O')
+*
+ WRKBL = N + N*ILAENV( 1, 'SGEQRF', ' ', M, N, -1, -1 )
+ WRKBL = MAX( WRKBL, N+N*ILAENV( 1, 'SORGQR', ' ', M,
+ $ N, N, -1 ) )
+ WRKBL = MAX( WRKBL, 3*N+2*N*
+ $ ILAENV( 1, 'SGEBRD', ' ', N, N, -1, -1 ) )
+ WRKBL = MAX( WRKBL, 3*N+N*
+ $ ILAENV( 1, 'SORGBR', 'Q', N, N, N, -1 ) )
+ WRKBL = MAX( WRKBL, 3*N+( N-1 )*
+ $ ILAENV( 1, 'SORGBR', 'P', N, N, N, -1 ) )
+ WRKBL = MAX( WRKBL, BDSPAC )
+ MAXWRK = 2*N*N + WRKBL
+ MINWRK = MAX( 3*N+M, BDSPAC )
+ ELSE IF( WNTUS .AND. WNTVAS ) THEN
+*
+* Path 6 (M much larger than N, JOBU='S', JOBVT='S' or
+* 'A')
+*
+ WRKBL = N + N*ILAENV( 1, 'SGEQRF', ' ', M, N, -1, -1 )
+ WRKBL = MAX( WRKBL, N+N*ILAENV( 1, 'SORGQR', ' ', M,
+ $ N, N, -1 ) )
+ WRKBL = MAX( WRKBL, 3*N+2*N*
+ $ ILAENV( 1, 'SGEBRD', ' ', N, N, -1, -1 ) )
+ WRKBL = MAX( WRKBL, 3*N+N*
+ $ ILAENV( 1, 'SORGBR', 'Q', N, N, N, -1 ) )
+ WRKBL = MAX( WRKBL, 3*N+( N-1 )*
+ $ ILAENV( 1, 'SORGBR', 'P', N, N, N, -1 ) )
+ WRKBL = MAX( WRKBL, BDSPAC )
+ MAXWRK = N*N + WRKBL
+ MINWRK = MAX( 3*N+M, BDSPAC )
+ ELSE IF( WNTUA .AND. WNTVN ) THEN
+*
+* Path 7 (M much larger than N, JOBU='A', JOBVT='N')
+*
+ WRKBL = N + N*ILAENV( 1, 'SGEQRF', ' ', M, N, -1, -1 )
+ WRKBL = MAX( WRKBL, N+M*ILAENV( 1, 'SORGQR', ' ', M,
+ $ M, N, -1 ) )
+ WRKBL = MAX( WRKBL, 3*N+2*N*
+ $ ILAENV( 1, 'SGEBRD', ' ', N, N, -1, -1 ) )
+ WRKBL = MAX( WRKBL, 3*N+N*
+ $ ILAENV( 1, 'SORGBR', 'Q', N, N, N, -1 ) )
+ WRKBL = MAX( WRKBL, BDSPAC )
+ MAXWRK = N*N + WRKBL
+ MINWRK = MAX( 3*N+M, BDSPAC )
+ ELSE IF( WNTUA .AND. WNTVO ) THEN
+*
+* Path 8 (M much larger than N, JOBU='A', JOBVT='O')
+*
+ WRKBL = N + N*ILAENV( 1, 'SGEQRF', ' ', M, N, -1, -1 )
+ WRKBL = MAX( WRKBL, N+M*ILAENV( 1, 'SORGQR', ' ', M,
+ $ M, N, -1 ) )
+ WRKBL = MAX( WRKBL, 3*N+2*N*
+ $ ILAENV( 1, 'SGEBRD', ' ', N, N, -1, -1 ) )
+ WRKBL = MAX( WRKBL, 3*N+N*
+ $ ILAENV( 1, 'SORGBR', 'Q', N, N, N, -1 ) )
+ WRKBL = MAX( WRKBL, 3*N+( N-1 )*
+ $ ILAENV( 1, 'SORGBR', 'P', N, N, N, -1 ) )
+ WRKBL = MAX( WRKBL, BDSPAC )
+ MAXWRK = 2*N*N + WRKBL
+ MINWRK = MAX( 3*N+M, BDSPAC )
+ ELSE IF( WNTUA .AND. WNTVAS ) THEN
+*
+* Path 9 (M much larger than N, JOBU='A', JOBVT='S' or
+* 'A')
+*
+ WRKBL = N + N*ILAENV( 1, 'SGEQRF', ' ', M, N, -1, -1 )
+ WRKBL = MAX( WRKBL, N+M*ILAENV( 1, 'SORGQR', ' ', M,
+ $ M, N, -1 ) )
+ WRKBL = MAX( WRKBL, 3*N+2*N*
+ $ ILAENV( 1, 'SGEBRD', ' ', N, N, -1, -1 ) )
+ WRKBL = MAX( WRKBL, 3*N+N*
+ $ ILAENV( 1, 'SORGBR', 'Q', N, N, N, -1 ) )
+ WRKBL = MAX( WRKBL, 3*N+( N-1 )*
+ $ ILAENV( 1, 'SORGBR', 'P', N, N, N, -1 ) )
+ WRKBL = MAX( WRKBL, BDSPAC )
+ MAXWRK = N*N + WRKBL
+ MINWRK = MAX( 3*N+M, BDSPAC )
+ END IF
+ ELSE
+*
+* Path 10 (M at least N, but not much larger)
+*
+ MAXWRK = 3*N + ( M+N )*ILAENV( 1, 'SGEBRD', ' ', M, N,
+ $ -1, -1 )
+ IF( WNTUS .OR. WNTUO )
+ $ MAXWRK = MAX( MAXWRK, 3*N+N*
+ $ ILAENV( 1, 'SORGBR', 'Q', M, N, N, -1 ) )
+ IF( WNTUA )
+ $ MAXWRK = MAX( MAXWRK, 3*N+M*
+ $ ILAENV( 1, 'SORGBR', 'Q', M, M, N, -1 ) )
+ IF( .NOT.WNTVN )
+ $ MAXWRK = MAX( MAXWRK, 3*N+( N-1 )*
+ $ ILAENV( 1, 'SORGBR', 'P', N, N, N, -1 ) )
+ MAXWRK = MAX( MAXWRK, BDSPAC )
+ MINWRK = MAX( 3*N+M, BDSPAC )
+ END IF
+ ELSE IF( MINMN.GT.0 ) THEN
+*
+* Compute space needed for SBDSQR
+*
+ MNTHR = ILAENV( 6, 'SGESVD', JOBU // JOBVT, M, N, 0, 0 )
+ BDSPAC = 5*M
+ IF( N.GE.MNTHR ) THEN
+ IF( WNTVN ) THEN
+*
+* Path 1t(N much larger than M, JOBVT='N')
+*
+ MAXWRK = M + M*ILAENV( 1, 'SGELQF', ' ', M, N, -1,
+ $ -1 )
+ MAXWRK = MAX( MAXWRK, 3*M+2*M*
+ $ ILAENV( 1, 'SGEBRD', ' ', M, M, -1, -1 ) )
+ IF( WNTUO .OR. WNTUAS )
+ $ MAXWRK = MAX( MAXWRK, 3*M+M*
+ $ ILAENV( 1, 'SORGBR', 'Q', M, M, M, -1 ) )
+ MAXWRK = MAX( MAXWRK, BDSPAC )
+ MINWRK = MAX( 4*M, BDSPAC )
+ ELSE IF( WNTVO .AND. WNTUN ) THEN
+*
+* Path 2t(N much larger than M, JOBU='N', JOBVT='O')
+*
+ WRKBL = M + M*ILAENV( 1, 'SGELQF', ' ', M, N, -1, -1 )
+ WRKBL = MAX( WRKBL, M+M*ILAENV( 1, 'SORGLQ', ' ', M,
+ $ N, M, -1 ) )
+ WRKBL = MAX( WRKBL, 3*M+2*M*
+ $ ILAENV( 1, 'SGEBRD', ' ', M, M, -1, -1 ) )
+ WRKBL = MAX( WRKBL, 3*M+( M-1 )*
+ $ ILAENV( 1, 'SORGBR', 'P', M, M, M, -1 ) )
+ WRKBL = MAX( WRKBL, BDSPAC )
+ MAXWRK = MAX( M*M+WRKBL, M*M+M*N+M )
+ MINWRK = MAX( 3*M+N, BDSPAC )
+ ELSE IF( WNTVO .AND. WNTUAS ) THEN
+*
+* Path 3t(N much larger than M, JOBU='S' or 'A',
+* JOBVT='O')
+*
+ WRKBL = M + M*ILAENV( 1, 'SGELQF', ' ', M, N, -1, -1 )
+ WRKBL = MAX( WRKBL, M+M*ILAENV( 1, 'SORGLQ', ' ', M,
+ $ N, M, -1 ) )
+ WRKBL = MAX( WRKBL, 3*M+2*M*
+ $ ILAENV( 1, 'SGEBRD', ' ', M, M, -1, -1 ) )
+ WRKBL = MAX( WRKBL, 3*M+( M-1 )*
+ $ ILAENV( 1, 'SORGBR', 'P', M, M, M, -1 ) )
+ WRKBL = MAX( WRKBL, 3*M+M*
+ $ ILAENV( 1, 'SORGBR', 'Q', M, M, M, -1 ) )
+ WRKBL = MAX( WRKBL, BDSPAC )
+ MAXWRK = MAX( M*M+WRKBL, M*M+M*N+M )
+ MINWRK = MAX( 3*M+N, BDSPAC )
+ ELSE IF( WNTVS .AND. WNTUN ) THEN
+*
+* Path 4t(N much larger than M, JOBU='N', JOBVT='S')
+*
+ WRKBL = M + M*ILAENV( 1, 'SGELQF', ' ', M, N, -1, -1 )
+ WRKBL = MAX( WRKBL, M+M*ILAENV( 1, 'SORGLQ', ' ', M,
+ $ N, M, -1 ) )
+ WRKBL = MAX( WRKBL, 3*M+2*M*
+ $ ILAENV( 1, 'SGEBRD', ' ', M, M, -1, -1 ) )
+ WRKBL = MAX( WRKBL, 3*M+( M-1 )*
+ $ ILAENV( 1, 'SORGBR', 'P', M, M, M, -1 ) )
+ WRKBL = MAX( WRKBL, BDSPAC )
+ MAXWRK = M*M + WRKBL
+ MINWRK = MAX( 3*M+N, BDSPAC )
+ ELSE IF( WNTVS .AND. WNTUO ) THEN
+*
+* Path 5t(N much larger than M, JOBU='O', JOBVT='S')
+*
+ WRKBL = M + M*ILAENV( 1, 'SGELQF', ' ', M, N, -1, -1 )
+ WRKBL = MAX( WRKBL, M+M*ILAENV( 1, 'SORGLQ', ' ', M,
+ $ N, M, -1 ) )
+ WRKBL = MAX( WRKBL, 3*M+2*M*
+ $ ILAENV( 1, 'SGEBRD', ' ', M, M, -1, -1 ) )
+ WRKBL = MAX( WRKBL, 3*M+( M-1 )*
+ $ ILAENV( 1, 'SORGBR', 'P', M, M, M, -1 ) )
+ WRKBL = MAX( WRKBL, 3*M+M*
+ $ ILAENV( 1, 'SORGBR', 'Q', M, M, M, -1 ) )
+ WRKBL = MAX( WRKBL, BDSPAC )
+ MAXWRK = 2*M*M + WRKBL
+ MINWRK = MAX( 3*M+N, BDSPAC )
+ MAXWRK = MAX( MAXWRK, MINWRK )
+ ELSE IF( WNTVS .AND. WNTUAS ) THEN
+*
+* Path 6t(N much larger than M, JOBU='S' or 'A',
+* JOBVT='S')
+*
+ WRKBL = M + M*ILAENV( 1, 'SGELQF', ' ', M, N, -1, -1 )
+ WRKBL = MAX( WRKBL, M+M*ILAENV( 1, 'SORGLQ', ' ', M,
+ $ N, M, -1 ) )
+ WRKBL = MAX( WRKBL, 3*M+2*M*
+ $ ILAENV( 1, 'SGEBRD', ' ', M, M, -1, -1 ) )
+ WRKBL = MAX( WRKBL, 3*M+( M-1 )*
+ $ ILAENV( 1, 'SORGBR', 'P', M, M, M, -1 ) )
+ WRKBL = MAX( WRKBL, 3*M+M*
+ $ ILAENV( 1, 'SORGBR', 'Q', M, M, M, -1 ) )
+ WRKBL = MAX( WRKBL, BDSPAC )
+ MAXWRK = M*M + WRKBL
+ MINWRK = MAX( 3*M+N, BDSPAC )
+ ELSE IF( WNTVA .AND. WNTUN ) THEN
+*
+* Path 7t(N much larger than M, JOBU='N', JOBVT='A')
+*
+ WRKBL = M + M*ILAENV( 1, 'SGELQF', ' ', M, N, -1, -1 )
+ WRKBL = MAX( WRKBL, M+N*ILAENV( 1, 'SORGLQ', ' ', N,
+ $ N, M, -1 ) )
+ WRKBL = MAX( WRKBL, 3*M+2*M*
+ $ ILAENV( 1, 'SGEBRD', ' ', M, M, -1, -1 ) )
+ WRKBL = MAX( WRKBL, 3*M+( M-1 )*
+ $ ILAENV( 1, 'SORGBR', 'P', M, M, M, -1 ) )
+ WRKBL = MAX( WRKBL, BDSPAC )
+ MAXWRK = M*M + WRKBL
+ MINWRK = MAX( 3*M+N, BDSPAC )
+ ELSE IF( WNTVA .AND. WNTUO ) THEN
+*
+* Path 8t(N much larger than M, JOBU='O', JOBVT='A')
+*
+ WRKBL = M + M*ILAENV( 1, 'SGELQF', ' ', M, N, -1, -1 )
+ WRKBL = MAX( WRKBL, M+N*ILAENV( 1, 'SORGLQ', ' ', N,
+ $ N, M, -1 ) )
+ WRKBL = MAX( WRKBL, 3*M+2*M*
+ $ ILAENV( 1, 'SGEBRD', ' ', M, M, -1, -1 ) )
+ WRKBL = MAX( WRKBL, 3*M+( M-1 )*
+ $ ILAENV( 1, 'SORGBR', 'P', M, M, M, -1 ) )
+ WRKBL = MAX( WRKBL, 3*M+M*
+ $ ILAENV( 1, 'SORGBR', 'Q', M, M, M, -1 ) )
+ WRKBL = MAX( WRKBL, BDSPAC )
+ MAXWRK = 2*M*M + WRKBL
+ MINWRK = MAX( 3*M+N, BDSPAC )
+ ELSE IF( WNTVA .AND. WNTUAS ) THEN
+*
+* Path 9t(N much larger than M, JOBU='S' or 'A',
+* JOBVT='A')
+*
+ WRKBL = M + M*ILAENV( 1, 'SGELQF', ' ', M, N, -1, -1 )
+ WRKBL = MAX( WRKBL, M+N*ILAENV( 1, 'SORGLQ', ' ', N,
+ $ N, M, -1 ) )
+ WRKBL = MAX( WRKBL, 3*M+2*M*
+ $ ILAENV( 1, 'SGEBRD', ' ', M, M, -1, -1 ) )
+ WRKBL = MAX( WRKBL, 3*M+( M-1 )*
+ $ ILAENV( 1, 'SORGBR', 'P', M, M, M, -1 ) )
+ WRKBL = MAX( WRKBL, 3*M+M*
+ $ ILAENV( 1, 'SORGBR', 'Q', M, M, M, -1 ) )
+ WRKBL = MAX( WRKBL, BDSPAC )
+ MAXWRK = M*M + WRKBL
+ MINWRK = MAX( 3*M+N, BDSPAC )
+ END IF
+ ELSE
+*
+* Path 10t(N greater than M, but not much larger)
+*
+ MAXWRK = 3*M + ( M+N )*ILAENV( 1, 'SGEBRD', ' ', M, N,
+ $ -1, -1 )
+ IF( WNTVS .OR. WNTVO )
+ $ MAXWRK = MAX( MAXWRK, 3*M+M*
+ $ ILAENV( 1, 'SORGBR', 'P', M, N, M, -1 ) )
+ IF( WNTVA )
+ $ MAXWRK = MAX( MAXWRK, 3*M+N*
+ $ ILAENV( 1, 'SORGBR', 'P', N, N, M, -1 ) )
+ IF( .NOT.WNTUN )
+ $ MAXWRK = MAX( MAXWRK, 3*M+( M-1 )*
+ $ ILAENV( 1, 'SORGBR', 'Q', M, M, M, -1 ) )
+ MAXWRK = MAX( MAXWRK, BDSPAC )
+ MINWRK = MAX( 3*M+N, BDSPAC )
+ END IF
+ END IF
+ MAXWRK = MAX( MAXWRK, MINWRK )
+ WORK( 1 ) = MAXWRK
+*
+ IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN
+ INFO = -13
+ END IF
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SGESVD', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( M.EQ.0 .OR. N.EQ.0 ) THEN
+ RETURN
+ END IF
+*
+* Get machine constants
+*
+ EPS = SLAMCH( 'P' )
+ SMLNUM = SQRT( SLAMCH( 'S' ) ) / EPS
+ BIGNUM = ONE / SMLNUM
+*
+* Scale A if max element outside range [SMLNUM,BIGNUM]
+*
+ ANRM = SLANGE( 'M', M, N, A, LDA, DUM )
+ ISCL = 0
+ IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
+ ISCL = 1
+ CALL SLASCL( 'G', 0, 0, ANRM, SMLNUM, M, N, A, LDA, IERR )
+ ELSE IF( ANRM.GT.BIGNUM ) THEN
+ ISCL = 1
+ CALL SLASCL( 'G', 0, 0, ANRM, BIGNUM, M, N, A, LDA, IERR )
+ END IF
+*
+ IF( M.GE.N ) THEN
+*
+* A has at least as many rows as columns. If A has sufficiently
+* more rows than columns, first reduce using the QR
+* decomposition (if sufficient workspace available)
+*
+ IF( M.GE.MNTHR ) THEN
+*
+ IF( WNTUN ) THEN
+*
+* Path 1 (M much larger than N, JOBU='N')
+* No left singular vectors to be computed
+*
+ ITAU = 1
+ IWORK = ITAU + N
+*
+* Compute A=Q*R
+* (Workspace: need 2*N, prefer N+N*NB)
+*
+ CALL SGEQRF( M, N, A, LDA, WORK( ITAU ), WORK( IWORK ),
+ $ LWORK-IWORK+1, IERR )
+*
+* Zero out below R
+*
+ CALL SLASET( 'L', N-1, N-1, ZERO, ZERO, A( 2, 1 ), LDA )
+ IE = 1
+ ITAUQ = IE + N
+ ITAUP = ITAUQ + N
+ IWORK = ITAUP + N
+*
+* Bidiagonalize R in A
+* (Workspace: need 4*N, prefer 3*N+2*N*NB)
+*
+ CALL SGEBRD( N, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ),
+ $ WORK( ITAUP ), WORK( IWORK ), LWORK-IWORK+1,
+ $ IERR )
+ NCVT = 0
+ IF( WNTVO .OR. WNTVAS ) THEN
+*
+* If right singular vectors desired, generate P'.
+* (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB)
+*
+ CALL SORGBR( 'P', N, N, N, A, LDA, WORK( ITAUP ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ NCVT = N
+ END IF
+ IWORK = IE + N
+*
+* Perform bidiagonal QR iteration, computing right
+* singular vectors of A in A if desired
+* (Workspace: need BDSPAC)
+*
+ CALL SBDSQR( 'U', N, NCVT, 0, 0, S, WORK( IE ), A, LDA,
+ $ DUM, 1, DUM, 1, WORK( IWORK ), INFO )
+*
+* If right singular vectors desired in VT, copy them there
+*
+ IF( WNTVAS )
+ $ CALL SLACPY( 'F', N, N, A, LDA, VT, LDVT )
+*
+ ELSE IF( WNTUO .AND. WNTVN ) THEN
+*
+* Path 2 (M much larger than N, JOBU='O', JOBVT='N')
+* N left singular vectors to be overwritten on A and
+* no right singular vectors to be computed
+*
+ IF( LWORK.GE.N*N+MAX( 4*N, BDSPAC ) ) THEN
+*
+* Sufficient workspace for a fast algorithm
+*
+ IR = 1
+ IF( LWORK.GE.MAX( WRKBL, LDA*N+N )+LDA*N ) THEN
+*
+* WORK(IU) is LDA by N, WORK(IR) is LDA by N
+*
+ LDWRKU = LDA
+ LDWRKR = LDA
+ ELSE IF( LWORK.GE.MAX( WRKBL, LDA*N+N )+N*N ) THEN
+*
+* WORK(IU) is LDA by N, WORK(IR) is N by N
+*
+ LDWRKU = LDA
+ LDWRKR = N
+ ELSE
+*
+* WORK(IU) is LDWRKU by N, WORK(IR) is N by N
+*
+ LDWRKU = ( LWORK-N*N-N ) / N
+ LDWRKR = N
+ END IF
+ ITAU = IR + LDWRKR*N
+ IWORK = ITAU + N
+*
+* Compute A=Q*R
+* (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
+*
+ CALL SGEQRF( M, N, A, LDA, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+* Copy R to WORK(IR) and zero out below it
+*
+ CALL SLACPY( 'U', N, N, A, LDA, WORK( IR ), LDWRKR )
+ CALL SLASET( 'L', N-1, N-1, ZERO, ZERO, WORK( IR+1 ),
+ $ LDWRKR )
+*
+* Generate Q in A
+* (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
+*
+ CALL SORGQR( M, N, N, A, LDA, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ IE = ITAU
+ ITAUQ = IE + N
+ ITAUP = ITAUQ + N
+ IWORK = ITAUP + N
+*
+* Bidiagonalize R in WORK(IR)
+* (Workspace: need N*N+4*N, prefer N*N+3*N+2*N*NB)
+*
+ CALL SGEBRD( N, N, WORK( IR ), LDWRKR, S, WORK( IE ),
+ $ WORK( ITAUQ ), WORK( ITAUP ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+* Generate left vectors bidiagonalizing R
+* (Workspace: need N*N+4*N, prefer N*N+3*N+N*NB)
+*
+ CALL SORGBR( 'Q', N, N, N, WORK( IR ), LDWRKR,
+ $ WORK( ITAUQ ), WORK( IWORK ),
+ $ LWORK-IWORK+1, IERR )
+ IWORK = IE + N
+*
+* Perform bidiagonal QR iteration, computing left
+* singular vectors of R in WORK(IR)
+* (Workspace: need N*N+BDSPAC)
+*
+ CALL SBDSQR( 'U', N, 0, N, 0, S, WORK( IE ), DUM, 1,
+ $ WORK( IR ), LDWRKR, DUM, 1,
+ $ WORK( IWORK ), INFO )
+ IU = IE + N
+*
+* Multiply Q in A by left singular vectors of R in
+* WORK(IR), storing result in WORK(IU) and copying to A
+* (Workspace: need N*N+2*N, prefer N*N+M*N+N)
+*
+ DO 10 I = 1, M, LDWRKU
+ CHUNK = MIN( M-I+1, LDWRKU )
+ CALL SGEMM( 'N', 'N', CHUNK, N, N, ONE, A( I, 1 ),
+ $ LDA, WORK( IR ), LDWRKR, ZERO,
+ $ WORK( IU ), LDWRKU )
+ CALL SLACPY( 'F', CHUNK, N, WORK( IU ), LDWRKU,
+ $ A( I, 1 ), LDA )
+ 10 CONTINUE
+*
+ ELSE
+*
+* Insufficient workspace for a fast algorithm
+*
+ IE = 1
+ ITAUQ = IE + N
+ ITAUP = ITAUQ + N
+ IWORK = ITAUP + N
+*
+* Bidiagonalize A
+* (Workspace: need 3*N+M, prefer 3*N+(M+N)*NB)
+*
+ CALL SGEBRD( M, N, A, LDA, S, WORK( IE ),
+ $ WORK( ITAUQ ), WORK( ITAUP ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+* Generate left vectors bidiagonalizing A
+* (Workspace: need 4*N, prefer 3*N+N*NB)
+*
+ CALL SORGBR( 'Q', M, N, N, A, LDA, WORK( ITAUQ ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ IWORK = IE + N
+*
+* Perform bidiagonal QR iteration, computing left
+* singular vectors of A in A
+* (Workspace: need BDSPAC)
+*
+ CALL SBDSQR( 'U', N, 0, M, 0, S, WORK( IE ), DUM, 1,
+ $ A, LDA, DUM, 1, WORK( IWORK ), INFO )
+*
+ END IF
+*
+ ELSE IF( WNTUO .AND. WNTVAS ) THEN
+*
+* Path 3 (M much larger than N, JOBU='O', JOBVT='S' or 'A')
+* N left singular vectors to be overwritten on A and
+* N right singular vectors to be computed in VT
+*
+ IF( LWORK.GE.N*N+MAX( 4*N, BDSPAC ) ) THEN
+*
+* Sufficient workspace for a fast algorithm
+*
+ IR = 1
+ IF( LWORK.GE.MAX( WRKBL, LDA*N+N )+LDA*N ) THEN
+*
+* WORK(IU) is LDA by N and WORK(IR) is LDA by N
+*
+ LDWRKU = LDA
+ LDWRKR = LDA
+ ELSE IF( LWORK.GE.MAX( WRKBL, LDA*N+N )+N*N ) THEN
+*
+* WORK(IU) is LDA by N and WORK(IR) is N by N
+*
+ LDWRKU = LDA
+ LDWRKR = N
+ ELSE
+*
+* WORK(IU) is LDWRKU by N and WORK(IR) is N by N
+*
+ LDWRKU = ( LWORK-N*N-N ) / N
+ LDWRKR = N
+ END IF
+ ITAU = IR + LDWRKR*N
+ IWORK = ITAU + N
+*
+* Compute A=Q*R
+* (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
+*
+ CALL SGEQRF( M, N, A, LDA, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+* Copy R to VT, zeroing out below it
+*
+ CALL SLACPY( 'U', N, N, A, LDA, VT, LDVT )
+ IF( N.GT.1 )
+ $ CALL SLASET( 'L', N-1, N-1, ZERO, ZERO,
+ $ VT( 2, 1 ), LDVT )
+*
+* Generate Q in A
+* (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
+*
+ CALL SORGQR( M, N, N, A, LDA, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ IE = ITAU
+ ITAUQ = IE + N
+ ITAUP = ITAUQ + N
+ IWORK = ITAUP + N
+*
+* Bidiagonalize R in VT, copying result to WORK(IR)
+* (Workspace: need N*N+4*N, prefer N*N+3*N+2*N*NB)
+*
+ CALL SGEBRD( N, N, VT, LDVT, S, WORK( IE ),
+ $ WORK( ITAUQ ), WORK( ITAUP ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ CALL SLACPY( 'L', N, N, VT, LDVT, WORK( IR ), LDWRKR )
+*
+* Generate left vectors bidiagonalizing R in WORK(IR)
+* (Workspace: need N*N+4*N, prefer N*N+3*N+N*NB)
+*
+ CALL SORGBR( 'Q', N, N, N, WORK( IR ), LDWRKR,
+ $ WORK( ITAUQ ), WORK( IWORK ),
+ $ LWORK-IWORK+1, IERR )
+*
+* Generate right vectors bidiagonalizing R in VT
+* (Workspace: need N*N+4*N-1, prefer N*N+3*N+(N-1)*NB)
+*
+ CALL SORGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ IWORK = IE + N
+*
+* Perform bidiagonal QR iteration, computing left
+* singular vectors of R in WORK(IR) and computing right
+* singular vectors of R in VT
+* (Workspace: need N*N+BDSPAC)
+*
+ CALL SBDSQR( 'U', N, N, N, 0, S, WORK( IE ), VT, LDVT,
+ $ WORK( IR ), LDWRKR, DUM, 1,
+ $ WORK( IWORK ), INFO )
+ IU = IE + N
+*
+* Multiply Q in A by left singular vectors of R in
+* WORK(IR), storing result in WORK(IU) and copying to A
+* (Workspace: need N*N+2*N, prefer N*N+M*N+N)
+*
+ DO 20 I = 1, M, LDWRKU
+ CHUNK = MIN( M-I+1, LDWRKU )
+ CALL SGEMM( 'N', 'N', CHUNK, N, N, ONE, A( I, 1 ),
+ $ LDA, WORK( IR ), LDWRKR, ZERO,
+ $ WORK( IU ), LDWRKU )
+ CALL SLACPY( 'F', CHUNK, N, WORK( IU ), LDWRKU,
+ $ A( I, 1 ), LDA )
+ 20 CONTINUE
+*
+ ELSE
+*
+* Insufficient workspace for a fast algorithm
+*
+ ITAU = 1
+ IWORK = ITAU + N
+*
+* Compute A=Q*R
+* (Workspace: need 2*N, prefer N+N*NB)
+*
+ CALL SGEQRF( M, N, A, LDA, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+* Copy R to VT, zeroing out below it
+*
+ CALL SLACPY( 'U', N, N, A, LDA, VT, LDVT )
+ IF( N.GT.1 )
+ $ CALL SLASET( 'L', N-1, N-1, ZERO, ZERO,
+ $ VT( 2, 1 ), LDVT )
+*
+* Generate Q in A
+* (Workspace: need 2*N, prefer N+N*NB)
+*
+ CALL SORGQR( M, N, N, A, LDA, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ IE = ITAU
+ ITAUQ = IE + N
+ ITAUP = ITAUQ + N
+ IWORK = ITAUP + N
+*
+* Bidiagonalize R in VT
+* (Workspace: need 4*N, prefer 3*N+2*N*NB)
+*
+ CALL SGEBRD( N, N, VT, LDVT, S, WORK( IE ),
+ $ WORK( ITAUQ ), WORK( ITAUP ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+* Multiply Q in A by left vectors bidiagonalizing R
+* (Workspace: need 3*N+M, prefer 3*N+M*NB)
+*
+ CALL SORMBR( 'Q', 'R', 'N', M, N, N, VT, LDVT,
+ $ WORK( ITAUQ ), A, LDA, WORK( IWORK ),
+ $ LWORK-IWORK+1, IERR )
+*
+* Generate right vectors bidiagonalizing R in VT
+* (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB)
+*
+ CALL SORGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ IWORK = IE + N
+*
+* Perform bidiagonal QR iteration, computing left
+* singular vectors of A in A and computing right
+* singular vectors of A in VT
+* (Workspace: need BDSPAC)
+*
+ CALL SBDSQR( 'U', N, N, M, 0, S, WORK( IE ), VT, LDVT,
+ $ A, LDA, DUM, 1, WORK( IWORK ), INFO )
+*
+ END IF
+*
+ ELSE IF( WNTUS ) THEN
+*
+ IF( WNTVN ) THEN
+*
+* Path 4 (M much larger than N, JOBU='S', JOBVT='N')
+* N left singular vectors to be computed in U and
+* no right singular vectors to be computed
+*
+ IF( LWORK.GE.N*N+MAX( 4*N, BDSPAC ) ) THEN
+*
+* Sufficient workspace for a fast algorithm
+*
+ IR = 1
+ IF( LWORK.GE.WRKBL+LDA*N ) THEN
+*
+* WORK(IR) is LDA by N
+*
+ LDWRKR = LDA
+ ELSE
+*
+* WORK(IR) is N by N
+*
+ LDWRKR = N
+ END IF
+ ITAU = IR + LDWRKR*N
+ IWORK = ITAU + N
+*
+* Compute A=Q*R
+* (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
+*
+ CALL SGEQRF( M, N, A, LDA, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+* Copy R to WORK(IR), zeroing out below it
+*
+ CALL SLACPY( 'U', N, N, A, LDA, WORK( IR ),
+ $ LDWRKR )
+ CALL SLASET( 'L', N-1, N-1, ZERO, ZERO,
+ $ WORK( IR+1 ), LDWRKR )
+*
+* Generate Q in A
+* (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
+*
+ CALL SORGQR( M, N, N, A, LDA, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ IE = ITAU
+ ITAUQ = IE + N
+ ITAUP = ITAUQ + N
+ IWORK = ITAUP + N
+*
+* Bidiagonalize R in WORK(IR)
+* (Workspace: need N*N+4*N, prefer N*N+3*N+2*N*NB)
+*
+ CALL SGEBRD( N, N, WORK( IR ), LDWRKR, S,
+ $ WORK( IE ), WORK( ITAUQ ),
+ $ WORK( ITAUP ), WORK( IWORK ),
+ $ LWORK-IWORK+1, IERR )
+*
+* Generate left vectors bidiagonalizing R in WORK(IR)
+* (Workspace: need N*N+4*N, prefer N*N+3*N+N*NB)
+*
+ CALL SORGBR( 'Q', N, N, N, WORK( IR ), LDWRKR,
+ $ WORK( ITAUQ ), WORK( IWORK ),
+ $ LWORK-IWORK+1, IERR )
+ IWORK = IE + N
+*
+* Perform bidiagonal QR iteration, computing left
+* singular vectors of R in WORK(IR)
+* (Workspace: need N*N+BDSPAC)
+*
+ CALL SBDSQR( 'U', N, 0, N, 0, S, WORK( IE ), DUM,
+ $ 1, WORK( IR ), LDWRKR, DUM, 1,
+ $ WORK( IWORK ), INFO )
+*
+* Multiply Q in A by left singular vectors of R in
+* WORK(IR), storing result in U
+* (Workspace: need N*N)
+*
+ CALL SGEMM( 'N', 'N', M, N, N, ONE, A, LDA,
+ $ WORK( IR ), LDWRKR, ZERO, U, LDU )
+*
+ ELSE
+*
+* Insufficient workspace for a fast algorithm
+*
+ ITAU = 1
+ IWORK = ITAU + N
+*
+* Compute A=Q*R, copying result to U
+* (Workspace: need 2*N, prefer N+N*NB)
+*
+ CALL SGEQRF( M, N, A, LDA, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ CALL SLACPY( 'L', M, N, A, LDA, U, LDU )
+*
+* Generate Q in U
+* (Workspace: need 2*N, prefer N+N*NB)
+*
+ CALL SORGQR( M, N, N, U, LDU, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ IE = ITAU
+ ITAUQ = IE + N
+ ITAUP = ITAUQ + N
+ IWORK = ITAUP + N
+*
+* Zero out below R in A
+*
+ CALL SLASET( 'L', N-1, N-1, ZERO, ZERO, A( 2, 1 ),
+ $ LDA )
+*
+* Bidiagonalize R in A
+* (Workspace: need 4*N, prefer 3*N+2*N*NB)
+*
+ CALL SGEBRD( N, N, A, LDA, S, WORK( IE ),
+ $ WORK( ITAUQ ), WORK( ITAUP ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+* Multiply Q in U by left vectors bidiagonalizing R
+* (Workspace: need 3*N+M, prefer 3*N+M*NB)
+*
+ CALL SORMBR( 'Q', 'R', 'N', M, N, N, A, LDA,
+ $ WORK( ITAUQ ), U, LDU, WORK( IWORK ),
+ $ LWORK-IWORK+1, IERR )
+ IWORK = IE + N
+*
+* Perform bidiagonal QR iteration, computing left
+* singular vectors of A in U
+* (Workspace: need BDSPAC)
+*
+ CALL SBDSQR( 'U', N, 0, M, 0, S, WORK( IE ), DUM,
+ $ 1, U, LDU, DUM, 1, WORK( IWORK ),
+ $ INFO )
+*
+ END IF
+*
+ ELSE IF( WNTVO ) THEN
+*
+* Path 5 (M much larger than N, JOBU='S', JOBVT='O')
+* N left singular vectors to be computed in U and
+* N right singular vectors to be overwritten on A
+*
+ IF( LWORK.GE.2*N*N+MAX( 4*N, BDSPAC ) ) THEN
+*
+* Sufficient workspace for a fast algorithm
+*
+ IU = 1
+ IF( LWORK.GE.WRKBL+2*LDA*N ) THEN
+*
+* WORK(IU) is LDA by N and WORK(IR) is LDA by N
+*
+ LDWRKU = LDA
+ IR = IU + LDWRKU*N
+ LDWRKR = LDA
+ ELSE IF( LWORK.GE.WRKBL+( LDA+N )*N ) THEN
+*
+* WORK(IU) is LDA by N and WORK(IR) is N by N
+*
+ LDWRKU = LDA
+ IR = IU + LDWRKU*N
+ LDWRKR = N
+ ELSE
+*
+* WORK(IU) is N by N and WORK(IR) is N by N
+*
+ LDWRKU = N
+ IR = IU + LDWRKU*N
+ LDWRKR = N
+ END IF
+ ITAU = IR + LDWRKR*N
+ IWORK = ITAU + N
+*
+* Compute A=Q*R
+* (Workspace: need 2*N*N+2*N, prefer 2*N*N+N+N*NB)
+*
+ CALL SGEQRF( M, N, A, LDA, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+* Copy R to WORK(IU), zeroing out below it
+*
+ CALL SLACPY( 'U', N, N, A, LDA, WORK( IU ),
+ $ LDWRKU )
+ CALL SLASET( 'L', N-1, N-1, ZERO, ZERO,
+ $ WORK( IU+1 ), LDWRKU )
+*
+* Generate Q in A
+* (Workspace: need 2*N*N+2*N, prefer 2*N*N+N+N*NB)
+*
+ CALL SORGQR( M, N, N, A, LDA, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ IE = ITAU
+ ITAUQ = IE + N
+ ITAUP = ITAUQ + N
+ IWORK = ITAUP + N
+*
+* Bidiagonalize R in WORK(IU), copying result to
+* WORK(IR)
+* (Workspace: need 2*N*N+4*N,
+* prefer 2*N*N+3*N+2*N*NB)
+*
+ CALL SGEBRD( N, N, WORK( IU ), LDWRKU, S,
+ $ WORK( IE ), WORK( ITAUQ ),
+ $ WORK( ITAUP ), WORK( IWORK ),
+ $ LWORK-IWORK+1, IERR )
+ CALL SLACPY( 'U', N, N, WORK( IU ), LDWRKU,
+ $ WORK( IR ), LDWRKR )
+*
+* Generate left bidiagonalizing vectors in WORK(IU)
+* (Workspace: need 2*N*N+4*N, prefer 2*N*N+3*N+N*NB)
+*
+ CALL SORGBR( 'Q', N, N, N, WORK( IU ), LDWRKU,
+ $ WORK( ITAUQ ), WORK( IWORK ),
+ $ LWORK-IWORK+1, IERR )
+*
+* Generate right bidiagonalizing vectors in WORK(IR)
+* (Workspace: need 2*N*N+4*N-1,
+* prefer 2*N*N+3*N+(N-1)*NB)
+*
+ CALL SORGBR( 'P', N, N, N, WORK( IR ), LDWRKR,
+ $ WORK( ITAUP ), WORK( IWORK ),
+ $ LWORK-IWORK+1, IERR )
+ IWORK = IE + N
+*
+* Perform bidiagonal QR iteration, computing left
+* singular vectors of R in WORK(IU) and computing
+* right singular vectors of R in WORK(IR)
+* (Workspace: need 2*N*N+BDSPAC)
+*
+ CALL SBDSQR( 'U', N, N, N, 0, S, WORK( IE ),
+ $ WORK( IR ), LDWRKR, WORK( IU ),
+ $ LDWRKU, DUM, 1, WORK( IWORK ), INFO )
+*
+* Multiply Q in A by left singular vectors of R in
+* WORK(IU), storing result in U
+* (Workspace: need N*N)
+*
+ CALL SGEMM( 'N', 'N', M, N, N, ONE, A, LDA,
+ $ WORK( IU ), LDWRKU, ZERO, U, LDU )
+*
+* Copy right singular vectors of R to A
+* (Workspace: need N*N)
+*
+ CALL SLACPY( 'F', N, N, WORK( IR ), LDWRKR, A,
+ $ LDA )
+*
+ ELSE
+*
+* Insufficient workspace for a fast algorithm
+*
+ ITAU = 1
+ IWORK = ITAU + N
+*
+* Compute A=Q*R, copying result to U
+* (Workspace: need 2*N, prefer N+N*NB)
+*
+ CALL SGEQRF( M, N, A, LDA, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ CALL SLACPY( 'L', M, N, A, LDA, U, LDU )
+*
+* Generate Q in U
+* (Workspace: need 2*N, prefer N+N*NB)
+*
+ CALL SORGQR( M, N, N, U, LDU, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ IE = ITAU
+ ITAUQ = IE + N
+ ITAUP = ITAUQ + N
+ IWORK = ITAUP + N
+*
+* Zero out below R in A
+*
+ CALL SLASET( 'L', N-1, N-1, ZERO, ZERO, A( 2, 1 ),
+ $ LDA )
+*
+* Bidiagonalize R in A
+* (Workspace: need 4*N, prefer 3*N+2*N*NB)
+*
+ CALL SGEBRD( N, N, A, LDA, S, WORK( IE ),
+ $ WORK( ITAUQ ), WORK( ITAUP ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+* Multiply Q in U by left vectors bidiagonalizing R
+* (Workspace: need 3*N+M, prefer 3*N+M*NB)
+*
+ CALL SORMBR( 'Q', 'R', 'N', M, N, N, A, LDA,
+ $ WORK( ITAUQ ), U, LDU, WORK( IWORK ),
+ $ LWORK-IWORK+1, IERR )
+*
+* Generate right vectors bidiagonalizing R in A
+* (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB)
+*
+ CALL SORGBR( 'P', N, N, N, A, LDA, WORK( ITAUP ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ IWORK = IE + N
+*
+* Perform bidiagonal QR iteration, computing left
+* singular vectors of A in U and computing right
+* singular vectors of A in A
+* (Workspace: need BDSPAC)
+*
+ CALL SBDSQR( 'U', N, N, M, 0, S, WORK( IE ), A,
+ $ LDA, U, LDU, DUM, 1, WORK( IWORK ),
+ $ INFO )
+*
+ END IF
+*
+ ELSE IF( WNTVAS ) THEN
+*
+* Path 6 (M much larger than N, JOBU='S', JOBVT='S'
+* or 'A')
+* N left singular vectors to be computed in U and
+* N right singular vectors to be computed in VT
+*
+ IF( LWORK.GE.N*N+MAX( 4*N, BDSPAC ) ) THEN
+*
+* Sufficient workspace for a fast algorithm
+*
+ IU = 1
+ IF( LWORK.GE.WRKBL+LDA*N ) THEN
+*
+* WORK(IU) is LDA by N
+*
+ LDWRKU = LDA
+ ELSE
+*
+* WORK(IU) is N by N
+*
+ LDWRKU = N
+ END IF
+ ITAU = IU + LDWRKU*N
+ IWORK = ITAU + N
+*
+* Compute A=Q*R
+* (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
+*
+ CALL SGEQRF( M, N, A, LDA, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+* Copy R to WORK(IU), zeroing out below it
+*
+ CALL SLACPY( 'U', N, N, A, LDA, WORK( IU ),
+ $ LDWRKU )
+ CALL SLASET( 'L', N-1, N-1, ZERO, ZERO,
+ $ WORK( IU+1 ), LDWRKU )
+*
+* Generate Q in A
+* (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
+*
+ CALL SORGQR( M, N, N, A, LDA, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ IE = ITAU
+ ITAUQ = IE + N
+ ITAUP = ITAUQ + N
+ IWORK = ITAUP + N
+*
+* Bidiagonalize R in WORK(IU), copying result to VT
+* (Workspace: need N*N+4*N, prefer N*N+3*N+2*N*NB)
+*
+ CALL SGEBRD( N, N, WORK( IU ), LDWRKU, S,
+ $ WORK( IE ), WORK( ITAUQ ),
+ $ WORK( ITAUP ), WORK( IWORK ),
+ $ LWORK-IWORK+1, IERR )
+ CALL SLACPY( 'U', N, N, WORK( IU ), LDWRKU, VT,
+ $ LDVT )
+*
+* Generate left bidiagonalizing vectors in WORK(IU)
+* (Workspace: need N*N+4*N, prefer N*N+3*N+N*NB)
+*
+ CALL SORGBR( 'Q', N, N, N, WORK( IU ), LDWRKU,
+ $ WORK( ITAUQ ), WORK( IWORK ),
+ $ LWORK-IWORK+1, IERR )
+*
+* Generate right bidiagonalizing vectors in VT
+* (Workspace: need N*N+4*N-1,
+* prefer N*N+3*N+(N-1)*NB)
+*
+ CALL SORGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ IWORK = IE + N
+*
+* Perform bidiagonal QR iteration, computing left
+* singular vectors of R in WORK(IU) and computing
+* right singular vectors of R in VT
+* (Workspace: need N*N+BDSPAC)
+*
+ CALL SBDSQR( 'U', N, N, N, 0, S, WORK( IE ), VT,
+ $ LDVT, WORK( IU ), LDWRKU, DUM, 1,
+ $ WORK( IWORK ), INFO )
+*
+* Multiply Q in A by left singular vectors of R in
+* WORK(IU), storing result in U
+* (Workspace: need N*N)
+*
+ CALL SGEMM( 'N', 'N', M, N, N, ONE, A, LDA,
+ $ WORK( IU ), LDWRKU, ZERO, U, LDU )
+*
+ ELSE
+*
+* Insufficient workspace for a fast algorithm
+*
+ ITAU = 1
+ IWORK = ITAU + N
+*
+* Compute A=Q*R, copying result to U
+* (Workspace: need 2*N, prefer N+N*NB)
+*
+ CALL SGEQRF( M, N, A, LDA, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ CALL SLACPY( 'L', M, N, A, LDA, U, LDU )
+*
+* Generate Q in U
+* (Workspace: need 2*N, prefer N+N*NB)
+*
+ CALL SORGQR( M, N, N, U, LDU, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+* Copy R to VT, zeroing out below it
+*
+ CALL SLACPY( 'U', N, N, A, LDA, VT, LDVT )
+ IF( N.GT.1 )
+ $ CALL SLASET( 'L', N-1, N-1, ZERO, ZERO,
+ $ VT( 2, 1 ), LDVT )
+ IE = ITAU
+ ITAUQ = IE + N
+ ITAUP = ITAUQ + N
+ IWORK = ITAUP + N
+*
+* Bidiagonalize R in VT
+* (Workspace: need 4*N, prefer 3*N+2*N*NB)
+*
+ CALL SGEBRD( N, N, VT, LDVT, S, WORK( IE ),
+ $ WORK( ITAUQ ), WORK( ITAUP ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+* Multiply Q in U by left bidiagonalizing vectors
+* in VT
+* (Workspace: need 3*N+M, prefer 3*N+M*NB)
+*
+ CALL SORMBR( 'Q', 'R', 'N', M, N, N, VT, LDVT,
+ $ WORK( ITAUQ ), U, LDU, WORK( IWORK ),
+ $ LWORK-IWORK+1, IERR )
+*
+* Generate right bidiagonalizing vectors in VT
+* (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB)
+*
+ CALL SORGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ IWORK = IE + N
+*
+* Perform bidiagonal QR iteration, computing left
+* singular vectors of A in U and computing right
+* singular vectors of A in VT
+* (Workspace: need BDSPAC)
+*
+ CALL SBDSQR( 'U', N, N, M, 0, S, WORK( IE ), VT,
+ $ LDVT, U, LDU, DUM, 1, WORK( IWORK ),
+ $ INFO )
+*
+ END IF
+*
+ END IF
+*
+ ELSE IF( WNTUA ) THEN
+*
+ IF( WNTVN ) THEN
+*
+* Path 7 (M much larger than N, JOBU='A', JOBVT='N')
+* M left singular vectors to be computed in U and
+* no right singular vectors to be computed
+*
+ IF( LWORK.GE.N*N+MAX( N+M, 4*N, BDSPAC ) ) THEN
+*
+* Sufficient workspace for a fast algorithm
+*
+ IR = 1
+ IF( LWORK.GE.WRKBL+LDA*N ) THEN
+*
+* WORK(IR) is LDA by N
+*
+ LDWRKR = LDA
+ ELSE
+*
+* WORK(IR) is N by N
+*
+ LDWRKR = N
+ END IF
+ ITAU = IR + LDWRKR*N
+ IWORK = ITAU + N
+*
+* Compute A=Q*R, copying result to U
+* (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
+*
+ CALL SGEQRF( M, N, A, LDA, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ CALL SLACPY( 'L', M, N, A, LDA, U, LDU )
+*
+* Copy R to WORK(IR), zeroing out below it
+*
+ CALL SLACPY( 'U', N, N, A, LDA, WORK( IR ),
+ $ LDWRKR )
+ CALL SLASET( 'L', N-1, N-1, ZERO, ZERO,
+ $ WORK( IR+1 ), LDWRKR )
+*
+* Generate Q in U
+* (Workspace: need N*N+N+M, prefer N*N+N+M*NB)
+*
+ CALL SORGQR( M, M, N, U, LDU, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ IE = ITAU
+ ITAUQ = IE + N
+ ITAUP = ITAUQ + N
+ IWORK = ITAUP + N
+*
+* Bidiagonalize R in WORK(IR)
+* (Workspace: need N*N+4*N, prefer N*N+3*N+2*N*NB)
+*
+ CALL SGEBRD( N, N, WORK( IR ), LDWRKR, S,
+ $ WORK( IE ), WORK( ITAUQ ),
+ $ WORK( ITAUP ), WORK( IWORK ),
+ $ LWORK-IWORK+1, IERR )
+*
+* Generate left bidiagonalizing vectors in WORK(IR)
+* (Workspace: need N*N+4*N, prefer N*N+3*N+N*NB)
+*
+ CALL SORGBR( 'Q', N, N, N, WORK( IR ), LDWRKR,
+ $ WORK( ITAUQ ), WORK( IWORK ),
+ $ LWORK-IWORK+1, IERR )
+ IWORK = IE + N
+*
+* Perform bidiagonal QR iteration, computing left
+* singular vectors of R in WORK(IR)
+* (Workspace: need N*N+BDSPAC)
+*
+ CALL SBDSQR( 'U', N, 0, N, 0, S, WORK( IE ), DUM,
+ $ 1, WORK( IR ), LDWRKR, DUM, 1,
+ $ WORK( IWORK ), INFO )
+*
+* Multiply Q in U by left singular vectors of R in
+* WORK(IR), storing result in A
+* (Workspace: need N*N)
+*
+ CALL SGEMM( 'N', 'N', M, N, N, ONE, U, LDU,
+ $ WORK( IR ), LDWRKR, ZERO, A, LDA )
+*
+* Copy left singular vectors of A from A to U
+*
+ CALL SLACPY( 'F', M, N, A, LDA, U, LDU )
+*
+ ELSE
+*
+* Insufficient workspace for a fast algorithm
+*
+ ITAU = 1
+ IWORK = ITAU + N
+*
+* Compute A=Q*R, copying result to U
+* (Workspace: need 2*N, prefer N+N*NB)
+*
+ CALL SGEQRF( M, N, A, LDA, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ CALL SLACPY( 'L', M, N, A, LDA, U, LDU )
+*
+* Generate Q in U
+* (Workspace: need N+M, prefer N+M*NB)
+*
+ CALL SORGQR( M, M, N, U, LDU, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ IE = ITAU
+ ITAUQ = IE + N
+ ITAUP = ITAUQ + N
+ IWORK = ITAUP + N
+*
+* Zero out below R in A
+*
+ CALL SLASET( 'L', N-1, N-1, ZERO, ZERO, A( 2, 1 ),
+ $ LDA )
+*
+* Bidiagonalize R in A
+* (Workspace: need 4*N, prefer 3*N+2*N*NB)
+*
+ CALL SGEBRD( N, N, A, LDA, S, WORK( IE ),
+ $ WORK( ITAUQ ), WORK( ITAUP ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+* Multiply Q in U by left bidiagonalizing vectors
+* in A
+* (Workspace: need 3*N+M, prefer 3*N+M*NB)
+*
+ CALL SORMBR( 'Q', 'R', 'N', M, N, N, A, LDA,
+ $ WORK( ITAUQ ), U, LDU, WORK( IWORK ),
+ $ LWORK-IWORK+1, IERR )
+ IWORK = IE + N
+*
+* Perform bidiagonal QR iteration, computing left
+* singular vectors of A in U
+* (Workspace: need BDSPAC)
+*
+ CALL SBDSQR( 'U', N, 0, M, 0, S, WORK( IE ), DUM,
+ $ 1, U, LDU, DUM, 1, WORK( IWORK ),
+ $ INFO )
+*
+ END IF
+*
+ ELSE IF( WNTVO ) THEN
+*
+* Path 8 (M much larger than N, JOBU='A', JOBVT='O')
+* M left singular vectors to be computed in U and
+* N right singular vectors to be overwritten on A
+*
+ IF( LWORK.GE.2*N*N+MAX( N+M, 4*N, BDSPAC ) ) THEN
+*
+* Sufficient workspace for a fast algorithm
+*
+ IU = 1
+ IF( LWORK.GE.WRKBL+2*LDA*N ) THEN
+*
+* WORK(IU) is LDA by N and WORK(IR) is LDA by N
+*
+ LDWRKU = LDA
+ IR = IU + LDWRKU*N
+ LDWRKR = LDA
+ ELSE IF( LWORK.GE.WRKBL+( LDA+N )*N ) THEN
+*
+* WORK(IU) is LDA by N and WORK(IR) is N by N
+*
+ LDWRKU = LDA
+ IR = IU + LDWRKU*N
+ LDWRKR = N
+ ELSE
+*
+* WORK(IU) is N by N and WORK(IR) is N by N
+*
+ LDWRKU = N
+ IR = IU + LDWRKU*N
+ LDWRKR = N
+ END IF
+ ITAU = IR + LDWRKR*N
+ IWORK = ITAU + N
+*
+* Compute A=Q*R, copying result to U
+* (Workspace: need 2*N*N+2*N, prefer 2*N*N+N+N*NB)
+*
+ CALL SGEQRF( M, N, A, LDA, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ CALL SLACPY( 'L', M, N, A, LDA, U, LDU )
+*
+* Generate Q in U
+* (Workspace: need 2*N*N+N+M, prefer 2*N*N+N+M*NB)
+*
+ CALL SORGQR( M, M, N, U, LDU, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+* Copy R to WORK(IU), zeroing out below it
+*
+ CALL SLACPY( 'U', N, N, A, LDA, WORK( IU ),
+ $ LDWRKU )
+ CALL SLASET( 'L', N-1, N-1, ZERO, ZERO,
+ $ WORK( IU+1 ), LDWRKU )
+ IE = ITAU
+ ITAUQ = IE + N
+ ITAUP = ITAUQ + N
+ IWORK = ITAUP + N
+*
+* Bidiagonalize R in WORK(IU), copying result to
+* WORK(IR)
+* (Workspace: need 2*N*N+4*N,
+* prefer 2*N*N+3*N+2*N*NB)
+*
+ CALL SGEBRD( N, N, WORK( IU ), LDWRKU, S,
+ $ WORK( IE ), WORK( ITAUQ ),
+ $ WORK( ITAUP ), WORK( IWORK ),
+ $ LWORK-IWORK+1, IERR )
+ CALL SLACPY( 'U', N, N, WORK( IU ), LDWRKU,
+ $ WORK( IR ), LDWRKR )
+*
+* Generate left bidiagonalizing vectors in WORK(IU)
+* (Workspace: need 2*N*N+4*N, prefer 2*N*N+3*N+N*NB)
+*
+ CALL SORGBR( 'Q', N, N, N, WORK( IU ), LDWRKU,
+ $ WORK( ITAUQ ), WORK( IWORK ),
+ $ LWORK-IWORK+1, IERR )
+*
+* Generate right bidiagonalizing vectors in WORK(IR)
+* (Workspace: need 2*N*N+4*N-1,
+* prefer 2*N*N+3*N+(N-1)*NB)
+*
+ CALL SORGBR( 'P', N, N, N, WORK( IR ), LDWRKR,
+ $ WORK( ITAUP ), WORK( IWORK ),
+ $ LWORK-IWORK+1, IERR )
+ IWORK = IE + N
+*
+* Perform bidiagonal QR iteration, computing left
+* singular vectors of R in WORK(IU) and computing
+* right singular vectors of R in WORK(IR)
+* (Workspace: need 2*N*N+BDSPAC)
+*
+ CALL SBDSQR( 'U', N, N, N, 0, S, WORK( IE ),
+ $ WORK( IR ), LDWRKR, WORK( IU ),
+ $ LDWRKU, DUM, 1, WORK( IWORK ), INFO )
+*
+* Multiply Q in U by left singular vectors of R in
+* WORK(IU), storing result in A
+* (Workspace: need N*N)
+*
+ CALL SGEMM( 'N', 'N', M, N, N, ONE, U, LDU,
+ $ WORK( IU ), LDWRKU, ZERO, A, LDA )
+*
+* Copy left singular vectors of A from A to U
+*
+ CALL SLACPY( 'F', M, N, A, LDA, U, LDU )
+*
+* Copy right singular vectors of R from WORK(IR) to A
+*
+ CALL SLACPY( 'F', N, N, WORK( IR ), LDWRKR, A,
+ $ LDA )
+*
+ ELSE
+*
+* Insufficient workspace for a fast algorithm
+*
+ ITAU = 1
+ IWORK = ITAU + N
+*
+* Compute A=Q*R, copying result to U
+* (Workspace: need 2*N, prefer N+N*NB)
+*
+ CALL SGEQRF( M, N, A, LDA, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ CALL SLACPY( 'L', M, N, A, LDA, U, LDU )
+*
+* Generate Q in U
+* (Workspace: need N+M, prefer N+M*NB)
+*
+ CALL SORGQR( M, M, N, U, LDU, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ IE = ITAU
+ ITAUQ = IE + N
+ ITAUP = ITAUQ + N
+ IWORK = ITAUP + N
+*
+* Zero out below R in A
+*
+ CALL SLASET( 'L', N-1, N-1, ZERO, ZERO, A( 2, 1 ),
+ $ LDA )
+*
+* Bidiagonalize R in A
+* (Workspace: need 4*N, prefer 3*N+2*N*NB)
+*
+ CALL SGEBRD( N, N, A, LDA, S, WORK( IE ),
+ $ WORK( ITAUQ ), WORK( ITAUP ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+* Multiply Q in U by left bidiagonalizing vectors
+* in A
+* (Workspace: need 3*N+M, prefer 3*N+M*NB)
+*
+ CALL SORMBR( 'Q', 'R', 'N', M, N, N, A, LDA,
+ $ WORK( ITAUQ ), U, LDU, WORK( IWORK ),
+ $ LWORK-IWORK+1, IERR )
+*
+* Generate right bidiagonalizing vectors in A
+* (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB)
+*
+ CALL SORGBR( 'P', N, N, N, A, LDA, WORK( ITAUP ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ IWORK = IE + N
+*
+* Perform bidiagonal QR iteration, computing left
+* singular vectors of A in U and computing right
+* singular vectors of A in A
+* (Workspace: need BDSPAC)
+*
+ CALL SBDSQR( 'U', N, N, M, 0, S, WORK( IE ), A,
+ $ LDA, U, LDU, DUM, 1, WORK( IWORK ),
+ $ INFO )
+*
+ END IF
+*
+ ELSE IF( WNTVAS ) THEN
+*
+* Path 9 (M much larger than N, JOBU='A', JOBVT='S'
+* or 'A')
+* M left singular vectors to be computed in U and
+* N right singular vectors to be computed in VT
+*
+ IF( LWORK.GE.N*N+MAX( N+M, 4*N, BDSPAC ) ) THEN
+*
+* Sufficient workspace for a fast algorithm
+*
+ IU = 1
+ IF( LWORK.GE.WRKBL+LDA*N ) THEN
+*
+* WORK(IU) is LDA by N
+*
+ LDWRKU = LDA
+ ELSE
+*
+* WORK(IU) is N by N
+*
+ LDWRKU = N
+ END IF
+ ITAU = IU + LDWRKU*N
+ IWORK = ITAU + N
+*
+* Compute A=Q*R, copying result to U
+* (Workspace: need N*N+2*N, prefer N*N+N+N*NB)
+*
+ CALL SGEQRF( M, N, A, LDA, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ CALL SLACPY( 'L', M, N, A, LDA, U, LDU )
+*
+* Generate Q in U
+* (Workspace: need N*N+N+M, prefer N*N+N+M*NB)
+*
+ CALL SORGQR( M, M, N, U, LDU, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+* Copy R to WORK(IU), zeroing out below it
+*
+ CALL SLACPY( 'U', N, N, A, LDA, WORK( IU ),
+ $ LDWRKU )
+ CALL SLASET( 'L', N-1, N-1, ZERO, ZERO,
+ $ WORK( IU+1 ), LDWRKU )
+ IE = ITAU
+ ITAUQ = IE + N
+ ITAUP = ITAUQ + N
+ IWORK = ITAUP + N
+*
+* Bidiagonalize R in WORK(IU), copying result to VT
+* (Workspace: need N*N+4*N, prefer N*N+3*N+2*N*NB)
+*
+ CALL SGEBRD( N, N, WORK( IU ), LDWRKU, S,
+ $ WORK( IE ), WORK( ITAUQ ),
+ $ WORK( ITAUP ), WORK( IWORK ),
+ $ LWORK-IWORK+1, IERR )
+ CALL SLACPY( 'U', N, N, WORK( IU ), LDWRKU, VT,
+ $ LDVT )
+*
+* Generate left bidiagonalizing vectors in WORK(IU)
+* (Workspace: need N*N+4*N, prefer N*N+3*N+N*NB)
+*
+ CALL SORGBR( 'Q', N, N, N, WORK( IU ), LDWRKU,
+ $ WORK( ITAUQ ), WORK( IWORK ),
+ $ LWORK-IWORK+1, IERR )
+*
+* Generate right bidiagonalizing vectors in VT
+* (Workspace: need N*N+4*N-1,
+* prefer N*N+3*N+(N-1)*NB)
+*
+ CALL SORGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ IWORK = IE + N
+*
+* Perform bidiagonal QR iteration, computing left
+* singular vectors of R in WORK(IU) and computing
+* right singular vectors of R in VT
+* (Workspace: need N*N+BDSPAC)
+*
+ CALL SBDSQR( 'U', N, N, N, 0, S, WORK( IE ), VT,
+ $ LDVT, WORK( IU ), LDWRKU, DUM, 1,
+ $ WORK( IWORK ), INFO )
+*
+* Multiply Q in U by left singular vectors of R in
+* WORK(IU), storing result in A
+* (Workspace: need N*N)
+*
+ CALL SGEMM( 'N', 'N', M, N, N, ONE, U, LDU,
+ $ WORK( IU ), LDWRKU, ZERO, A, LDA )
+*
+* Copy left singular vectors of A from A to U
+*
+ CALL SLACPY( 'F', M, N, A, LDA, U, LDU )
+*
+ ELSE
+*
+* Insufficient workspace for a fast algorithm
+*
+ ITAU = 1
+ IWORK = ITAU + N
+*
+* Compute A=Q*R, copying result to U
+* (Workspace: need 2*N, prefer N+N*NB)
+*
+ CALL SGEQRF( M, N, A, LDA, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ CALL SLACPY( 'L', M, N, A, LDA, U, LDU )
+*
+* Generate Q in U
+* (Workspace: need N+M, prefer N+M*NB)
+*
+ CALL SORGQR( M, M, N, U, LDU, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+* Copy R from A to VT, zeroing out below it
+*
+ CALL SLACPY( 'U', N, N, A, LDA, VT, LDVT )
+ IF( N.GT.1 )
+ $ CALL SLASET( 'L', N-1, N-1, ZERO, ZERO,
+ $ VT( 2, 1 ), LDVT )
+ IE = ITAU
+ ITAUQ = IE + N
+ ITAUP = ITAUQ + N
+ IWORK = ITAUP + N
+*
+* Bidiagonalize R in VT
+* (Workspace: need 4*N, prefer 3*N+2*N*NB)
+*
+ CALL SGEBRD( N, N, VT, LDVT, S, WORK( IE ),
+ $ WORK( ITAUQ ), WORK( ITAUP ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+* Multiply Q in U by left bidiagonalizing vectors
+* in VT
+* (Workspace: need 3*N+M, prefer 3*N+M*NB)
+*
+ CALL SORMBR( 'Q', 'R', 'N', M, N, N, VT, LDVT,
+ $ WORK( ITAUQ ), U, LDU, WORK( IWORK ),
+ $ LWORK-IWORK+1, IERR )
+*
+* Generate right bidiagonalizing vectors in VT
+* (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB)
+*
+ CALL SORGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ IWORK = IE + N
+*
+* Perform bidiagonal QR iteration, computing left
+* singular vectors of A in U and computing right
+* singular vectors of A in VT
+* (Workspace: need BDSPAC)
+*
+ CALL SBDSQR( 'U', N, N, M, 0, S, WORK( IE ), VT,
+ $ LDVT, U, LDU, DUM, 1, WORK( IWORK ),
+ $ INFO )
+*
+ END IF
+*
+ END IF
+*
+ END IF
+*
+ ELSE
+*
+* M .LT. MNTHR
+*
+* Path 10 (M at least N, but not much larger)
+* Reduce to bidiagonal form without QR decomposition
+*
+ IE = 1
+ ITAUQ = IE + N
+ ITAUP = ITAUQ + N
+ IWORK = ITAUP + N
+*
+* Bidiagonalize A
+* (Workspace: need 3*N+M, prefer 3*N+(M+N)*NB)
+*
+ CALL SGEBRD( M, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ),
+ $ WORK( ITAUP ), WORK( IWORK ), LWORK-IWORK+1,
+ $ IERR )
+ IF( WNTUAS ) THEN
+*
+* If left singular vectors desired in U, copy result to U
+* and generate left bidiagonalizing vectors in U
+* (Workspace: need 3*N+NCU, prefer 3*N+NCU*NB)
+*
+ CALL SLACPY( 'L', M, N, A, LDA, U, LDU )
+ IF( WNTUS )
+ $ NCU = N
+ IF( WNTUA )
+ $ NCU = M
+ CALL SORGBR( 'Q', M, NCU, N, U, LDU, WORK( ITAUQ ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ END IF
+ IF( WNTVAS ) THEN
+*
+* If right singular vectors desired in VT, copy result to
+* VT and generate right bidiagonalizing vectors in VT
+* (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB)
+*
+ CALL SLACPY( 'U', N, N, A, LDA, VT, LDVT )
+ CALL SORGBR( 'P', N, N, N, VT, LDVT, WORK( ITAUP ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ END IF
+ IF( WNTUO ) THEN
+*
+* If left singular vectors desired in A, generate left
+* bidiagonalizing vectors in A
+* (Workspace: need 4*N, prefer 3*N+N*NB)
+*
+ CALL SORGBR( 'Q', M, N, N, A, LDA, WORK( ITAUQ ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ END IF
+ IF( WNTVO ) THEN
+*
+* If right singular vectors desired in A, generate right
+* bidiagonalizing vectors in A
+* (Workspace: need 4*N-1, prefer 3*N+(N-1)*NB)
+*
+ CALL SORGBR( 'P', N, N, N, A, LDA, WORK( ITAUP ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ END IF
+ IWORK = IE + N
+ IF( WNTUAS .OR. WNTUO )
+ $ NRU = M
+ IF( WNTUN )
+ $ NRU = 0
+ IF( WNTVAS .OR. WNTVO )
+ $ NCVT = N
+ IF( WNTVN )
+ $ NCVT = 0
+ IF( ( .NOT.WNTUO ) .AND. ( .NOT.WNTVO ) ) THEN
+*
+* Perform bidiagonal QR iteration, if desired, computing
+* left singular vectors in U and computing right singular
+* vectors in VT
+* (Workspace: need BDSPAC)
+*
+ CALL SBDSQR( 'U', N, NCVT, NRU, 0, S, WORK( IE ), VT,
+ $ LDVT, U, LDU, DUM, 1, WORK( IWORK ), INFO )
+ ELSE IF( ( .NOT.WNTUO ) .AND. WNTVO ) THEN
+*
+* Perform bidiagonal QR iteration, if desired, computing
+* left singular vectors in U and computing right singular
+* vectors in A
+* (Workspace: need BDSPAC)
+*
+ CALL SBDSQR( 'U', N, NCVT, NRU, 0, S, WORK( IE ), A, LDA,
+ $ U, LDU, DUM, 1, WORK( IWORK ), INFO )
+ ELSE
+*
+* Perform bidiagonal QR iteration, if desired, computing
+* left singular vectors in A and computing right singular
+* vectors in VT
+* (Workspace: need BDSPAC)
+*
+ CALL SBDSQR( 'U', N, NCVT, NRU, 0, S, WORK( IE ), VT,
+ $ LDVT, A, LDA, DUM, 1, WORK( IWORK ), INFO )
+ END IF
+*
+ END IF
+*
+ ELSE
+*
+* A has more columns than rows. If A has sufficiently more
+* columns than rows, first reduce using the LQ decomposition (if
+* sufficient workspace available)
+*
+ IF( N.GE.MNTHR ) THEN
+*
+ IF( WNTVN ) THEN
+*
+* Path 1t(N much larger than M, JOBVT='N')
+* No right singular vectors to be computed
+*
+ ITAU = 1
+ IWORK = ITAU + M
+*
+* Compute A=L*Q
+* (Workspace: need 2*M, prefer M+M*NB)
+*
+ CALL SGELQF( M, N, A, LDA, WORK( ITAU ), WORK( IWORK ),
+ $ LWORK-IWORK+1, IERR )
+*
+* Zero out above L
+*
+ CALL SLASET( 'U', M-1, M-1, ZERO, ZERO, A( 1, 2 ), LDA )
+ IE = 1
+ ITAUQ = IE + M
+ ITAUP = ITAUQ + M
+ IWORK = ITAUP + M
+*
+* Bidiagonalize L in A
+* (Workspace: need 4*M, prefer 3*M+2*M*NB)
+*
+ CALL SGEBRD( M, M, A, LDA, S, WORK( IE ), WORK( ITAUQ ),
+ $ WORK( ITAUP ), WORK( IWORK ), LWORK-IWORK+1,
+ $ IERR )
+ IF( WNTUO .OR. WNTUAS ) THEN
+*
+* If left singular vectors desired, generate Q
+* (Workspace: need 4*M, prefer 3*M+M*NB)
+*
+ CALL SORGBR( 'Q', M, M, M, A, LDA, WORK( ITAUQ ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ END IF
+ IWORK = IE + M
+ NRU = 0
+ IF( WNTUO .OR. WNTUAS )
+ $ NRU = M
+*
+* Perform bidiagonal QR iteration, computing left singular
+* vectors of A in A if desired
+* (Workspace: need BDSPAC)
+*
+ CALL SBDSQR( 'U', M, 0, NRU, 0, S, WORK( IE ), DUM, 1, A,
+ $ LDA, DUM, 1, WORK( IWORK ), INFO )
+*
+* If left singular vectors desired in U, copy them there
+*
+ IF( WNTUAS )
+ $ CALL SLACPY( 'F', M, M, A, LDA, U, LDU )
+*
+ ELSE IF( WNTVO .AND. WNTUN ) THEN
+*
+* Path 2t(N much larger than M, JOBU='N', JOBVT='O')
+* M right singular vectors to be overwritten on A and
+* no left singular vectors to be computed
+*
+ IF( LWORK.GE.M*M+MAX( 4*M, BDSPAC ) ) THEN
+*
+* Sufficient workspace for a fast algorithm
+*
+ IR = 1
+ IF( LWORK.GE.MAX( WRKBL, LDA*N+M )+LDA*M ) THEN
+*
+* WORK(IU) is LDA by N and WORK(IR) is LDA by M
+*
+ LDWRKU = LDA
+ CHUNK = N
+ LDWRKR = LDA
+ ELSE IF( LWORK.GE.MAX( WRKBL, LDA*N+M )+M*M ) THEN
+*
+* WORK(IU) is LDA by N and WORK(IR) is M by M
+*
+ LDWRKU = LDA
+ CHUNK = N
+ LDWRKR = M
+ ELSE
+*
+* WORK(IU) is M by CHUNK and WORK(IR) is M by M
+*
+ LDWRKU = M
+ CHUNK = ( LWORK-M*M-M ) / M
+ LDWRKR = M
+ END IF
+ ITAU = IR + LDWRKR*M
+ IWORK = ITAU + M
+*
+* Compute A=L*Q
+* (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
+*
+ CALL SGELQF( M, N, A, LDA, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+* Copy L to WORK(IR) and zero out above it
+*
+ CALL SLACPY( 'L', M, M, A, LDA, WORK( IR ), LDWRKR )
+ CALL SLASET( 'U', M-1, M-1, ZERO, ZERO,
+ $ WORK( IR+LDWRKR ), LDWRKR )
+*
+* Generate Q in A
+* (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
+*
+ CALL SORGLQ( M, N, M, A, LDA, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ IE = ITAU
+ ITAUQ = IE + M
+ ITAUP = ITAUQ + M
+ IWORK = ITAUP + M
+*
+* Bidiagonalize L in WORK(IR)
+* (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB)
+*
+ CALL SGEBRD( M, M, WORK( IR ), LDWRKR, S, WORK( IE ),
+ $ WORK( ITAUQ ), WORK( ITAUP ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+* Generate right vectors bidiagonalizing L
+* (Workspace: need M*M+4*M-1, prefer M*M+3*M+(M-1)*NB)
+*
+ CALL SORGBR( 'P', M, M, M, WORK( IR ), LDWRKR,
+ $ WORK( ITAUP ), WORK( IWORK ),
+ $ LWORK-IWORK+1, IERR )
+ IWORK = IE + M
+*
+* Perform bidiagonal QR iteration, computing right
+* singular vectors of L in WORK(IR)
+* (Workspace: need M*M+BDSPAC)
+*
+ CALL SBDSQR( 'U', M, M, 0, 0, S, WORK( IE ),
+ $ WORK( IR ), LDWRKR, DUM, 1, DUM, 1,
+ $ WORK( IWORK ), INFO )
+ IU = IE + M
+*
+* Multiply right singular vectors of L in WORK(IR) by Q
+* in A, storing result in WORK(IU) and copying to A
+* (Workspace: need M*M+2*M, prefer M*M+M*N+M)
+*
+ DO 30 I = 1, N, CHUNK
+ BLK = MIN( N-I+1, CHUNK )
+ CALL SGEMM( 'N', 'N', M, BLK, M, ONE, WORK( IR ),
+ $ LDWRKR, A( 1, I ), LDA, ZERO,
+ $ WORK( IU ), LDWRKU )
+ CALL SLACPY( 'F', M, BLK, WORK( IU ), LDWRKU,
+ $ A( 1, I ), LDA )
+ 30 CONTINUE
+*
+ ELSE
+*
+* Insufficient workspace for a fast algorithm
+*
+ IE = 1
+ ITAUQ = IE + M
+ ITAUP = ITAUQ + M
+ IWORK = ITAUP + M
+*
+* Bidiagonalize A
+* (Workspace: need 3*M+N, prefer 3*M+(M+N)*NB)
+*
+ CALL SGEBRD( M, N, A, LDA, S, WORK( IE ),
+ $ WORK( ITAUQ ), WORK( ITAUP ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+* Generate right vectors bidiagonalizing A
+* (Workspace: need 4*M, prefer 3*M+M*NB)
+*
+ CALL SORGBR( 'P', M, N, M, A, LDA, WORK( ITAUP ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ IWORK = IE + M
+*
+* Perform bidiagonal QR iteration, computing right
+* singular vectors of A in A
+* (Workspace: need BDSPAC)
+*
+ CALL SBDSQR( 'L', M, N, 0, 0, S, WORK( IE ), A, LDA,
+ $ DUM, 1, DUM, 1, WORK( IWORK ), INFO )
+*
+ END IF
+*
+ ELSE IF( WNTVO .AND. WNTUAS ) THEN
+*
+* Path 3t(N much larger than M, JOBU='S' or 'A', JOBVT='O')
+* M right singular vectors to be overwritten on A and
+* M left singular vectors to be computed in U
+*
+ IF( LWORK.GE.M*M+MAX( 4*M, BDSPAC ) ) THEN
+*
+* Sufficient workspace for a fast algorithm
+*
+ IR = 1
+ IF( LWORK.GE.MAX( WRKBL, LDA*N+M )+LDA*M ) THEN
+*
+* WORK(IU) is LDA by N and WORK(IR) is LDA by M
+*
+ LDWRKU = LDA
+ CHUNK = N
+ LDWRKR = LDA
+ ELSE IF( LWORK.GE.MAX( WRKBL, LDA*N+M )+M*M ) THEN
+*
+* WORK(IU) is LDA by N and WORK(IR) is M by M
+*
+ LDWRKU = LDA
+ CHUNK = N
+ LDWRKR = M
+ ELSE
+*
+* WORK(IU) is M by CHUNK and WORK(IR) is M by M
+*
+ LDWRKU = M
+ CHUNK = ( LWORK-M*M-M ) / M
+ LDWRKR = M
+ END IF
+ ITAU = IR + LDWRKR*M
+ IWORK = ITAU + M
+*
+* Compute A=L*Q
+* (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
+*
+ CALL SGELQF( M, N, A, LDA, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+* Copy L to U, zeroing about above it
+*
+ CALL SLACPY( 'L', M, M, A, LDA, U, LDU )
+ CALL SLASET( 'U', M-1, M-1, ZERO, ZERO, U( 1, 2 ),
+ $ LDU )
+*
+* Generate Q in A
+* (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
+*
+ CALL SORGLQ( M, N, M, A, LDA, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ IE = ITAU
+ ITAUQ = IE + M
+ ITAUP = ITAUQ + M
+ IWORK = ITAUP + M
+*
+* Bidiagonalize L in U, copying result to WORK(IR)
+* (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB)
+*
+ CALL SGEBRD( M, M, U, LDU, S, WORK( IE ),
+ $ WORK( ITAUQ ), WORK( ITAUP ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ CALL SLACPY( 'U', M, M, U, LDU, WORK( IR ), LDWRKR )
+*
+* Generate right vectors bidiagonalizing L in WORK(IR)
+* (Workspace: need M*M+4*M-1, prefer M*M+3*M+(M-1)*NB)
+*
+ CALL SORGBR( 'P', M, M, M, WORK( IR ), LDWRKR,
+ $ WORK( ITAUP ), WORK( IWORK ),
+ $ LWORK-IWORK+1, IERR )
+*
+* Generate left vectors bidiagonalizing L in U
+* (Workspace: need M*M+4*M, prefer M*M+3*M+M*NB)
+*
+ CALL SORGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ IWORK = IE + M
+*
+* Perform bidiagonal QR iteration, computing left
+* singular vectors of L in U, and computing right
+* singular vectors of L in WORK(IR)
+* (Workspace: need M*M+BDSPAC)
+*
+ CALL SBDSQR( 'U', M, M, M, 0, S, WORK( IE ),
+ $ WORK( IR ), LDWRKR, U, LDU, DUM, 1,
+ $ WORK( IWORK ), INFO )
+ IU = IE + M
+*
+* Multiply right singular vectors of L in WORK(IR) by Q
+* in A, storing result in WORK(IU) and copying to A
+* (Workspace: need M*M+2*M, prefer M*M+M*N+M))
+*
+ DO 40 I = 1, N, CHUNK
+ BLK = MIN( N-I+1, CHUNK )
+ CALL SGEMM( 'N', 'N', M, BLK, M, ONE, WORK( IR ),
+ $ LDWRKR, A( 1, I ), LDA, ZERO,
+ $ WORK( IU ), LDWRKU )
+ CALL SLACPY( 'F', M, BLK, WORK( IU ), LDWRKU,
+ $ A( 1, I ), LDA )
+ 40 CONTINUE
+*
+ ELSE
+*
+* Insufficient workspace for a fast algorithm
+*
+ ITAU = 1
+ IWORK = ITAU + M
+*
+* Compute A=L*Q
+* (Workspace: need 2*M, prefer M+M*NB)
+*
+ CALL SGELQF( M, N, A, LDA, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+* Copy L to U, zeroing out above it
+*
+ CALL SLACPY( 'L', M, M, A, LDA, U, LDU )
+ CALL SLASET( 'U', M-1, M-1, ZERO, ZERO, U( 1, 2 ),
+ $ LDU )
+*
+* Generate Q in A
+* (Workspace: need 2*M, prefer M+M*NB)
+*
+ CALL SORGLQ( M, N, M, A, LDA, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ IE = ITAU
+ ITAUQ = IE + M
+ ITAUP = ITAUQ + M
+ IWORK = ITAUP + M
+*
+* Bidiagonalize L in U
+* (Workspace: need 4*M, prefer 3*M+2*M*NB)
+*
+ CALL SGEBRD( M, M, U, LDU, S, WORK( IE ),
+ $ WORK( ITAUQ ), WORK( ITAUP ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+* Multiply right vectors bidiagonalizing L by Q in A
+* (Workspace: need 3*M+N, prefer 3*M+N*NB)
+*
+ CALL SORMBR( 'P', 'L', 'T', M, N, M, U, LDU,
+ $ WORK( ITAUP ), A, LDA, WORK( IWORK ),
+ $ LWORK-IWORK+1, IERR )
+*
+* Generate left vectors bidiagonalizing L in U
+* (Workspace: need 4*M, prefer 3*M+M*NB)
+*
+ CALL SORGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ IWORK = IE + M
+*
+* Perform bidiagonal QR iteration, computing left
+* singular vectors of A in U and computing right
+* singular vectors of A in A
+* (Workspace: need BDSPAC)
+*
+ CALL SBDSQR( 'U', M, N, M, 0, S, WORK( IE ), A, LDA,
+ $ U, LDU, DUM, 1, WORK( IWORK ), INFO )
+*
+ END IF
+*
+ ELSE IF( WNTVS ) THEN
+*
+ IF( WNTUN ) THEN
+*
+* Path 4t(N much larger than M, JOBU='N', JOBVT='S')
+* M right singular vectors to be computed in VT and
+* no left singular vectors to be computed
+*
+ IF( LWORK.GE.M*M+MAX( 4*M, BDSPAC ) ) THEN
+*
+* Sufficient workspace for a fast algorithm
+*
+ IR = 1
+ IF( LWORK.GE.WRKBL+LDA*M ) THEN
+*
+* WORK(IR) is LDA by M
+*
+ LDWRKR = LDA
+ ELSE
+*
+* WORK(IR) is M by M
+*
+ LDWRKR = M
+ END IF
+ ITAU = IR + LDWRKR*M
+ IWORK = ITAU + M
+*
+* Compute A=L*Q
+* (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
+*
+ CALL SGELQF( M, N, A, LDA, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+* Copy L to WORK(IR), zeroing out above it
+*
+ CALL SLACPY( 'L', M, M, A, LDA, WORK( IR ),
+ $ LDWRKR )
+ CALL SLASET( 'U', M-1, M-1, ZERO, ZERO,
+ $ WORK( IR+LDWRKR ), LDWRKR )
+*
+* Generate Q in A
+* (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
+*
+ CALL SORGLQ( M, N, M, A, LDA, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ IE = ITAU
+ ITAUQ = IE + M
+ ITAUP = ITAUQ + M
+ IWORK = ITAUP + M
+*
+* Bidiagonalize L in WORK(IR)
+* (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB)
+*
+ CALL SGEBRD( M, M, WORK( IR ), LDWRKR, S,
+ $ WORK( IE ), WORK( ITAUQ ),
+ $ WORK( ITAUP ), WORK( IWORK ),
+ $ LWORK-IWORK+1, IERR )
+*
+* Generate right vectors bidiagonalizing L in
+* WORK(IR)
+* (Workspace: need M*M+4*M, prefer M*M+3*M+(M-1)*NB)
+*
+ CALL SORGBR( 'P', M, M, M, WORK( IR ), LDWRKR,
+ $ WORK( ITAUP ), WORK( IWORK ),
+ $ LWORK-IWORK+1, IERR )
+ IWORK = IE + M
+*
+* Perform bidiagonal QR iteration, computing right
+* singular vectors of L in WORK(IR)
+* (Workspace: need M*M+BDSPAC)
+*
+ CALL SBDSQR( 'U', M, M, 0, 0, S, WORK( IE ),
+ $ WORK( IR ), LDWRKR, DUM, 1, DUM, 1,
+ $ WORK( IWORK ), INFO )
+*
+* Multiply right singular vectors of L in WORK(IR) by
+* Q in A, storing result in VT
+* (Workspace: need M*M)
+*
+ CALL SGEMM( 'N', 'N', M, N, M, ONE, WORK( IR ),
+ $ LDWRKR, A, LDA, ZERO, VT, LDVT )
+*
+ ELSE
+*
+* Insufficient workspace for a fast algorithm
+*
+ ITAU = 1
+ IWORK = ITAU + M
+*
+* Compute A=L*Q
+* (Workspace: need 2*M, prefer M+M*NB)
+*
+ CALL SGELQF( M, N, A, LDA, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+* Copy result to VT
+*
+ CALL SLACPY( 'U', M, N, A, LDA, VT, LDVT )
+*
+* Generate Q in VT
+* (Workspace: need 2*M, prefer M+M*NB)
+*
+ CALL SORGLQ( M, N, M, VT, LDVT, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ IE = ITAU
+ ITAUQ = IE + M
+ ITAUP = ITAUQ + M
+ IWORK = ITAUP + M
+*
+* Zero out above L in A
+*
+ CALL SLASET( 'U', M-1, M-1, ZERO, ZERO, A( 1, 2 ),
+ $ LDA )
+*
+* Bidiagonalize L in A
+* (Workspace: need 4*M, prefer 3*M+2*M*NB)
+*
+ CALL SGEBRD( M, M, A, LDA, S, WORK( IE ),
+ $ WORK( ITAUQ ), WORK( ITAUP ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+* Multiply right vectors bidiagonalizing L by Q in VT
+* (Workspace: need 3*M+N, prefer 3*M+N*NB)
+*
+ CALL SORMBR( 'P', 'L', 'T', M, N, M, A, LDA,
+ $ WORK( ITAUP ), VT, LDVT,
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ IWORK = IE + M
+*
+* Perform bidiagonal QR iteration, computing right
+* singular vectors of A in VT
+* (Workspace: need BDSPAC)
+*
+ CALL SBDSQR( 'U', M, N, 0, 0, S, WORK( IE ), VT,
+ $ LDVT, DUM, 1, DUM, 1, WORK( IWORK ),
+ $ INFO )
+*
+ END IF
+*
+ ELSE IF( WNTUO ) THEN
+*
+* Path 5t(N much larger than M, JOBU='O', JOBVT='S')
+* M right singular vectors to be computed in VT and
+* M left singular vectors to be overwritten on A
+*
+ IF( LWORK.GE.2*M*M+MAX( 4*M, BDSPAC ) ) THEN
+*
+* Sufficient workspace for a fast algorithm
+*
+ IU = 1
+ IF( LWORK.GE.WRKBL+2*LDA*M ) THEN
+*
+* WORK(IU) is LDA by M and WORK(IR) is LDA by M
+*
+ LDWRKU = LDA
+ IR = IU + LDWRKU*M
+ LDWRKR = LDA
+ ELSE IF( LWORK.GE.WRKBL+( LDA+M )*M ) THEN
+*
+* WORK(IU) is LDA by M and WORK(IR) is M by M
+*
+ LDWRKU = LDA
+ IR = IU + LDWRKU*M
+ LDWRKR = M
+ ELSE
+*
+* WORK(IU) is M by M and WORK(IR) is M by M
+*
+ LDWRKU = M
+ IR = IU + LDWRKU*M
+ LDWRKR = M
+ END IF
+ ITAU = IR + LDWRKR*M
+ IWORK = ITAU + M
+*
+* Compute A=L*Q
+* (Workspace: need 2*M*M+2*M, prefer 2*M*M+M+M*NB)
+*
+ CALL SGELQF( M, N, A, LDA, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+* Copy L to WORK(IU), zeroing out below it
+*
+ CALL SLACPY( 'L', M, M, A, LDA, WORK( IU ),
+ $ LDWRKU )
+ CALL SLASET( 'U', M-1, M-1, ZERO, ZERO,
+ $ WORK( IU+LDWRKU ), LDWRKU )
+*
+* Generate Q in A
+* (Workspace: need 2*M*M+2*M, prefer 2*M*M+M+M*NB)
+*
+ CALL SORGLQ( M, N, M, A, LDA, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ IE = ITAU
+ ITAUQ = IE + M
+ ITAUP = ITAUQ + M
+ IWORK = ITAUP + M
+*
+* Bidiagonalize L in WORK(IU), copying result to
+* WORK(IR)
+* (Workspace: need 2*M*M+4*M,
+* prefer 2*M*M+3*M+2*M*NB)
+*
+ CALL SGEBRD( M, M, WORK( IU ), LDWRKU, S,
+ $ WORK( IE ), WORK( ITAUQ ),
+ $ WORK( ITAUP ), WORK( IWORK ),
+ $ LWORK-IWORK+1, IERR )
+ CALL SLACPY( 'L', M, M, WORK( IU ), LDWRKU,
+ $ WORK( IR ), LDWRKR )
+*
+* Generate right bidiagonalizing vectors in WORK(IU)
+* (Workspace: need 2*M*M+4*M-1,
+* prefer 2*M*M+3*M+(M-1)*NB)
+*
+ CALL SORGBR( 'P', M, M, M, WORK( IU ), LDWRKU,
+ $ WORK( ITAUP ), WORK( IWORK ),
+ $ LWORK-IWORK+1, IERR )
+*
+* Generate left bidiagonalizing vectors in WORK(IR)
+* (Workspace: need 2*M*M+4*M, prefer 2*M*M+3*M+M*NB)
+*
+ CALL SORGBR( 'Q', M, M, M, WORK( IR ), LDWRKR,
+ $ WORK( ITAUQ ), WORK( IWORK ),
+ $ LWORK-IWORK+1, IERR )
+ IWORK = IE + M
+*
+* Perform bidiagonal QR iteration, computing left
+* singular vectors of L in WORK(IR) and computing
+* right singular vectors of L in WORK(IU)
+* (Workspace: need 2*M*M+BDSPAC)
+*
+ CALL SBDSQR( 'U', M, M, M, 0, S, WORK( IE ),
+ $ WORK( IU ), LDWRKU, WORK( IR ),
+ $ LDWRKR, DUM, 1, WORK( IWORK ), INFO )
+*
+* Multiply right singular vectors of L in WORK(IU) by
+* Q in A, storing result in VT
+* (Workspace: need M*M)
+*
+ CALL SGEMM( 'N', 'N', M, N, M, ONE, WORK( IU ),
+ $ LDWRKU, A, LDA, ZERO, VT, LDVT )
+*
+* Copy left singular vectors of L to A
+* (Workspace: need M*M)
+*
+ CALL SLACPY( 'F', M, M, WORK( IR ), LDWRKR, A,
+ $ LDA )
+*
+ ELSE
+*
+* Insufficient workspace for a fast algorithm
+*
+ ITAU = 1
+ IWORK = ITAU + M
+*
+* Compute A=L*Q, copying result to VT
+* (Workspace: need 2*M, prefer M+M*NB)
+*
+ CALL SGELQF( M, N, A, LDA, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ CALL SLACPY( 'U', M, N, A, LDA, VT, LDVT )
+*
+* Generate Q in VT
+* (Workspace: need 2*M, prefer M+M*NB)
+*
+ CALL SORGLQ( M, N, M, VT, LDVT, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ IE = ITAU
+ ITAUQ = IE + M
+ ITAUP = ITAUQ + M
+ IWORK = ITAUP + M
+*
+* Zero out above L in A
+*
+ CALL SLASET( 'U', M-1, M-1, ZERO, ZERO, A( 1, 2 ),
+ $ LDA )
+*
+* Bidiagonalize L in A
+* (Workspace: need 4*M, prefer 3*M+2*M*NB)
+*
+ CALL SGEBRD( M, M, A, LDA, S, WORK( IE ),
+ $ WORK( ITAUQ ), WORK( ITAUP ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+* Multiply right vectors bidiagonalizing L by Q in VT
+* (Workspace: need 3*M+N, prefer 3*M+N*NB)
+*
+ CALL SORMBR( 'P', 'L', 'T', M, N, M, A, LDA,
+ $ WORK( ITAUP ), VT, LDVT,
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+* Generate left bidiagonalizing vectors of L in A
+* (Workspace: need 4*M, prefer 3*M+M*NB)
+*
+ CALL SORGBR( 'Q', M, M, M, A, LDA, WORK( ITAUQ ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ IWORK = IE + M
+*
+* Perform bidiagonal QR iteration, compute left
+* singular vectors of A in A and compute right
+* singular vectors of A in VT
+* (Workspace: need BDSPAC)
+*
+ CALL SBDSQR( 'U', M, N, M, 0, S, WORK( IE ), VT,
+ $ LDVT, A, LDA, DUM, 1, WORK( IWORK ),
+ $ INFO )
+*
+ END IF
+*
+ ELSE IF( WNTUAS ) THEN
+*
+* Path 6t(N much larger than M, JOBU='S' or 'A',
+* JOBVT='S')
+* M right singular vectors to be computed in VT and
+* M left singular vectors to be computed in U
+*
+ IF( LWORK.GE.M*M+MAX( 4*M, BDSPAC ) ) THEN
+*
+* Sufficient workspace for a fast algorithm
+*
+ IU = 1
+ IF( LWORK.GE.WRKBL+LDA*M ) THEN
+*
+* WORK(IU) is LDA by N
+*
+ LDWRKU = LDA
+ ELSE
+*
+* WORK(IU) is LDA by M
+*
+ LDWRKU = M
+ END IF
+ ITAU = IU + LDWRKU*M
+ IWORK = ITAU + M
+*
+* Compute A=L*Q
+* (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
+*
+ CALL SGELQF( M, N, A, LDA, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+* Copy L to WORK(IU), zeroing out above it
+*
+ CALL SLACPY( 'L', M, M, A, LDA, WORK( IU ),
+ $ LDWRKU )
+ CALL SLASET( 'U', M-1, M-1, ZERO, ZERO,
+ $ WORK( IU+LDWRKU ), LDWRKU )
+*
+* Generate Q in A
+* (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
+*
+ CALL SORGLQ( M, N, M, A, LDA, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ IE = ITAU
+ ITAUQ = IE + M
+ ITAUP = ITAUQ + M
+ IWORK = ITAUP + M
+*
+* Bidiagonalize L in WORK(IU), copying result to U
+* (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB)
+*
+ CALL SGEBRD( M, M, WORK( IU ), LDWRKU, S,
+ $ WORK( IE ), WORK( ITAUQ ),
+ $ WORK( ITAUP ), WORK( IWORK ),
+ $ LWORK-IWORK+1, IERR )
+ CALL SLACPY( 'L', M, M, WORK( IU ), LDWRKU, U,
+ $ LDU )
+*
+* Generate right bidiagonalizing vectors in WORK(IU)
+* (Workspace: need M*M+4*M-1,
+* prefer M*M+3*M+(M-1)*NB)
+*
+ CALL SORGBR( 'P', M, M, M, WORK( IU ), LDWRKU,
+ $ WORK( ITAUP ), WORK( IWORK ),
+ $ LWORK-IWORK+1, IERR )
+*
+* Generate left bidiagonalizing vectors in U
+* (Workspace: need M*M+4*M, prefer M*M+3*M+M*NB)
+*
+ CALL SORGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ IWORK = IE + M
+*
+* Perform bidiagonal QR iteration, computing left
+* singular vectors of L in U and computing right
+* singular vectors of L in WORK(IU)
+* (Workspace: need M*M+BDSPAC)
+*
+ CALL SBDSQR( 'U', M, M, M, 0, S, WORK( IE ),
+ $ WORK( IU ), LDWRKU, U, LDU, DUM, 1,
+ $ WORK( IWORK ), INFO )
+*
+* Multiply right singular vectors of L in WORK(IU) by
+* Q in A, storing result in VT
+* (Workspace: need M*M)
+*
+ CALL SGEMM( 'N', 'N', M, N, M, ONE, WORK( IU ),
+ $ LDWRKU, A, LDA, ZERO, VT, LDVT )
+*
+ ELSE
+*
+* Insufficient workspace for a fast algorithm
+*
+ ITAU = 1
+ IWORK = ITAU + M
+*
+* Compute A=L*Q, copying result to VT
+* (Workspace: need 2*M, prefer M+M*NB)
+*
+ CALL SGELQF( M, N, A, LDA, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ CALL SLACPY( 'U', M, N, A, LDA, VT, LDVT )
+*
+* Generate Q in VT
+* (Workspace: need 2*M, prefer M+M*NB)
+*
+ CALL SORGLQ( M, N, M, VT, LDVT, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+* Copy L to U, zeroing out above it
+*
+ CALL SLACPY( 'L', M, M, A, LDA, U, LDU )
+ CALL SLASET( 'U', M-1, M-1, ZERO, ZERO, U( 1, 2 ),
+ $ LDU )
+ IE = ITAU
+ ITAUQ = IE + M
+ ITAUP = ITAUQ + M
+ IWORK = ITAUP + M
+*
+* Bidiagonalize L in U
+* (Workspace: need 4*M, prefer 3*M+2*M*NB)
+*
+ CALL SGEBRD( M, M, U, LDU, S, WORK( IE ),
+ $ WORK( ITAUQ ), WORK( ITAUP ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+* Multiply right bidiagonalizing vectors in U by Q
+* in VT
+* (Workspace: need 3*M+N, prefer 3*M+N*NB)
+*
+ CALL SORMBR( 'P', 'L', 'T', M, N, M, U, LDU,
+ $ WORK( ITAUP ), VT, LDVT,
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+* Generate left bidiagonalizing vectors in U
+* (Workspace: need 4*M, prefer 3*M+M*NB)
+*
+ CALL SORGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ IWORK = IE + M
+*
+* Perform bidiagonal QR iteration, computing left
+* singular vectors of A in U and computing right
+* singular vectors of A in VT
+* (Workspace: need BDSPAC)
+*
+ CALL SBDSQR( 'U', M, N, M, 0, S, WORK( IE ), VT,
+ $ LDVT, U, LDU, DUM, 1, WORK( IWORK ),
+ $ INFO )
+*
+ END IF
+*
+ END IF
+*
+ ELSE IF( WNTVA ) THEN
+*
+ IF( WNTUN ) THEN
+*
+* Path 7t(N much larger than M, JOBU='N', JOBVT='A')
+* N right singular vectors to be computed in VT and
+* no left singular vectors to be computed
+*
+ IF( LWORK.GE.M*M+MAX( N+M, 4*M, BDSPAC ) ) THEN
+*
+* Sufficient workspace for a fast algorithm
+*
+ IR = 1
+ IF( LWORK.GE.WRKBL+LDA*M ) THEN
+*
+* WORK(IR) is LDA by M
+*
+ LDWRKR = LDA
+ ELSE
+*
+* WORK(IR) is M by M
+*
+ LDWRKR = M
+ END IF
+ ITAU = IR + LDWRKR*M
+ IWORK = ITAU + M
+*
+* Compute A=L*Q, copying result to VT
+* (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
+*
+ CALL SGELQF( M, N, A, LDA, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ CALL SLACPY( 'U', M, N, A, LDA, VT, LDVT )
+*
+* Copy L to WORK(IR), zeroing out above it
+*
+ CALL SLACPY( 'L', M, M, A, LDA, WORK( IR ),
+ $ LDWRKR )
+ CALL SLASET( 'U', M-1, M-1, ZERO, ZERO,
+ $ WORK( IR+LDWRKR ), LDWRKR )
+*
+* Generate Q in VT
+* (Workspace: need M*M+M+N, prefer M*M+M+N*NB)
+*
+ CALL SORGLQ( N, N, M, VT, LDVT, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ IE = ITAU
+ ITAUQ = IE + M
+ ITAUP = ITAUQ + M
+ IWORK = ITAUP + M
+*
+* Bidiagonalize L in WORK(IR)
+* (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB)
+*
+ CALL SGEBRD( M, M, WORK( IR ), LDWRKR, S,
+ $ WORK( IE ), WORK( ITAUQ ),
+ $ WORK( ITAUP ), WORK( IWORK ),
+ $ LWORK-IWORK+1, IERR )
+*
+* Generate right bidiagonalizing vectors in WORK(IR)
+* (Workspace: need M*M+4*M-1,
+* prefer M*M+3*M+(M-1)*NB)
+*
+ CALL SORGBR( 'P', M, M, M, WORK( IR ), LDWRKR,
+ $ WORK( ITAUP ), WORK( IWORK ),
+ $ LWORK-IWORK+1, IERR )
+ IWORK = IE + M
+*
+* Perform bidiagonal QR iteration, computing right
+* singular vectors of L in WORK(IR)
+* (Workspace: need M*M+BDSPAC)
+*
+ CALL SBDSQR( 'U', M, M, 0, 0, S, WORK( IE ),
+ $ WORK( IR ), LDWRKR, DUM, 1, DUM, 1,
+ $ WORK( IWORK ), INFO )
+*
+* Multiply right singular vectors of L in WORK(IR) by
+* Q in VT, storing result in A
+* (Workspace: need M*M)
+*
+ CALL SGEMM( 'N', 'N', M, N, M, ONE, WORK( IR ),
+ $ LDWRKR, VT, LDVT, ZERO, A, LDA )
+*
+* Copy right singular vectors of A from A to VT
+*
+ CALL SLACPY( 'F', M, N, A, LDA, VT, LDVT )
+*
+ ELSE
+*
+* Insufficient workspace for a fast algorithm
+*
+ ITAU = 1
+ IWORK = ITAU + M
+*
+* Compute A=L*Q, copying result to VT
+* (Workspace: need 2*M, prefer M+M*NB)
+*
+ CALL SGELQF( M, N, A, LDA, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ CALL SLACPY( 'U', M, N, A, LDA, VT, LDVT )
+*
+* Generate Q in VT
+* (Workspace: need M+N, prefer M+N*NB)
+*
+ CALL SORGLQ( N, N, M, VT, LDVT, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ IE = ITAU
+ ITAUQ = IE + M
+ ITAUP = ITAUQ + M
+ IWORK = ITAUP + M
+*
+* Zero out above L in A
+*
+ CALL SLASET( 'U', M-1, M-1, ZERO, ZERO, A( 1, 2 ),
+ $ LDA )
+*
+* Bidiagonalize L in A
+* (Workspace: need 4*M, prefer 3*M+2*M*NB)
+*
+ CALL SGEBRD( M, M, A, LDA, S, WORK( IE ),
+ $ WORK( ITAUQ ), WORK( ITAUP ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+* Multiply right bidiagonalizing vectors in A by Q
+* in VT
+* (Workspace: need 3*M+N, prefer 3*M+N*NB)
+*
+ CALL SORMBR( 'P', 'L', 'T', M, N, M, A, LDA,
+ $ WORK( ITAUP ), VT, LDVT,
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ IWORK = IE + M
+*
+* Perform bidiagonal QR iteration, computing right
+* singular vectors of A in VT
+* (Workspace: need BDSPAC)
+*
+ CALL SBDSQR( 'U', M, N, 0, 0, S, WORK( IE ), VT,
+ $ LDVT, DUM, 1, DUM, 1, WORK( IWORK ),
+ $ INFO )
+*
+ END IF
+*
+ ELSE IF( WNTUO ) THEN
+*
+* Path 8t(N much larger than M, JOBU='O', JOBVT='A')
+* N right singular vectors to be computed in VT and
+* M left singular vectors to be overwritten on A
+*
+ IF( LWORK.GE.2*M*M+MAX( N+M, 4*M, BDSPAC ) ) THEN
+*
+* Sufficient workspace for a fast algorithm
+*
+ IU = 1
+ IF( LWORK.GE.WRKBL+2*LDA*M ) THEN
+*
+* WORK(IU) is LDA by M and WORK(IR) is LDA by M
+*
+ LDWRKU = LDA
+ IR = IU + LDWRKU*M
+ LDWRKR = LDA
+ ELSE IF( LWORK.GE.WRKBL+( LDA+M )*M ) THEN
+*
+* WORK(IU) is LDA by M and WORK(IR) is M by M
+*
+ LDWRKU = LDA
+ IR = IU + LDWRKU*M
+ LDWRKR = M
+ ELSE
+*
+* WORK(IU) is M by M and WORK(IR) is M by M
+*
+ LDWRKU = M
+ IR = IU + LDWRKU*M
+ LDWRKR = M
+ END IF
+ ITAU = IR + LDWRKR*M
+ IWORK = ITAU + M
+*
+* Compute A=L*Q, copying result to VT
+* (Workspace: need 2*M*M+2*M, prefer 2*M*M+M+M*NB)
+*
+ CALL SGELQF( M, N, A, LDA, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ CALL SLACPY( 'U', M, N, A, LDA, VT, LDVT )
+*
+* Generate Q in VT
+* (Workspace: need 2*M*M+M+N, prefer 2*M*M+M+N*NB)
+*
+ CALL SORGLQ( N, N, M, VT, LDVT, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+* Copy L to WORK(IU), zeroing out above it
+*
+ CALL SLACPY( 'L', M, M, A, LDA, WORK( IU ),
+ $ LDWRKU )
+ CALL SLASET( 'U', M-1, M-1, ZERO, ZERO,
+ $ WORK( IU+LDWRKU ), LDWRKU )
+ IE = ITAU
+ ITAUQ = IE + M
+ ITAUP = ITAUQ + M
+ IWORK = ITAUP + M
+*
+* Bidiagonalize L in WORK(IU), copying result to
+* WORK(IR)
+* (Workspace: need 2*M*M+4*M,
+* prefer 2*M*M+3*M+2*M*NB)
+*
+ CALL SGEBRD( M, M, WORK( IU ), LDWRKU, S,
+ $ WORK( IE ), WORK( ITAUQ ),
+ $ WORK( ITAUP ), WORK( IWORK ),
+ $ LWORK-IWORK+1, IERR )
+ CALL SLACPY( 'L', M, M, WORK( IU ), LDWRKU,
+ $ WORK( IR ), LDWRKR )
+*
+* Generate right bidiagonalizing vectors in WORK(IU)
+* (Workspace: need 2*M*M+4*M-1,
+* prefer 2*M*M+3*M+(M-1)*NB)
+*
+ CALL SORGBR( 'P', M, M, M, WORK( IU ), LDWRKU,
+ $ WORK( ITAUP ), WORK( IWORK ),
+ $ LWORK-IWORK+1, IERR )
+*
+* Generate left bidiagonalizing vectors in WORK(IR)
+* (Workspace: need 2*M*M+4*M, prefer 2*M*M+3*M+M*NB)
+*
+ CALL SORGBR( 'Q', M, M, M, WORK( IR ), LDWRKR,
+ $ WORK( ITAUQ ), WORK( IWORK ),
+ $ LWORK-IWORK+1, IERR )
+ IWORK = IE + M
+*
+* Perform bidiagonal QR iteration, computing left
+* singular vectors of L in WORK(IR) and computing
+* right singular vectors of L in WORK(IU)
+* (Workspace: need 2*M*M+BDSPAC)
+*
+ CALL SBDSQR( 'U', M, M, M, 0, S, WORK( IE ),
+ $ WORK( IU ), LDWRKU, WORK( IR ),
+ $ LDWRKR, DUM, 1, WORK( IWORK ), INFO )
+*
+* Multiply right singular vectors of L in WORK(IU) by
+* Q in VT, storing result in A
+* (Workspace: need M*M)
+*
+ CALL SGEMM( 'N', 'N', M, N, M, ONE, WORK( IU ),
+ $ LDWRKU, VT, LDVT, ZERO, A, LDA )
+*
+* Copy right singular vectors of A from A to VT
+*
+ CALL SLACPY( 'F', M, N, A, LDA, VT, LDVT )
+*
+* Copy left singular vectors of A from WORK(IR) to A
+*
+ CALL SLACPY( 'F', M, M, WORK( IR ), LDWRKR, A,
+ $ LDA )
+*
+ ELSE
+*
+* Insufficient workspace for a fast algorithm
+*
+ ITAU = 1
+ IWORK = ITAU + M
+*
+* Compute A=L*Q, copying result to VT
+* (Workspace: need 2*M, prefer M+M*NB)
+*
+ CALL SGELQF( M, N, A, LDA, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ CALL SLACPY( 'U', M, N, A, LDA, VT, LDVT )
+*
+* Generate Q in VT
+* (Workspace: need M+N, prefer M+N*NB)
+*
+ CALL SORGLQ( N, N, M, VT, LDVT, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ IE = ITAU
+ ITAUQ = IE + M
+ ITAUP = ITAUQ + M
+ IWORK = ITAUP + M
+*
+* Zero out above L in A
+*
+ CALL SLASET( 'U', M-1, M-1, ZERO, ZERO, A( 1, 2 ),
+ $ LDA )
+*
+* Bidiagonalize L in A
+* (Workspace: need 4*M, prefer 3*M+2*M*NB)
+*
+ CALL SGEBRD( M, M, A, LDA, S, WORK( IE ),
+ $ WORK( ITAUQ ), WORK( ITAUP ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+* Multiply right bidiagonalizing vectors in A by Q
+* in VT
+* (Workspace: need 3*M+N, prefer 3*M+N*NB)
+*
+ CALL SORMBR( 'P', 'L', 'T', M, N, M, A, LDA,
+ $ WORK( ITAUP ), VT, LDVT,
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+* Generate left bidiagonalizing vectors in A
+* (Workspace: need 4*M, prefer 3*M+M*NB)
+*
+ CALL SORGBR( 'Q', M, M, M, A, LDA, WORK( ITAUQ ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ IWORK = IE + M
+*
+* Perform bidiagonal QR iteration, computing left
+* singular vectors of A in A and computing right
+* singular vectors of A in VT
+* (Workspace: need BDSPAC)
+*
+ CALL SBDSQR( 'U', M, N, M, 0, S, WORK( IE ), VT,
+ $ LDVT, A, LDA, DUM, 1, WORK( IWORK ),
+ $ INFO )
+*
+ END IF
+*
+ ELSE IF( WNTUAS ) THEN
+*
+* Path 9t(N much larger than M, JOBU='S' or 'A',
+* JOBVT='A')
+* N right singular vectors to be computed in VT and
+* M left singular vectors to be computed in U
+*
+ IF( LWORK.GE.M*M+MAX( N+M, 4*M, BDSPAC ) ) THEN
+*
+* Sufficient workspace for a fast algorithm
+*
+ IU = 1
+ IF( LWORK.GE.WRKBL+LDA*M ) THEN
+*
+* WORK(IU) is LDA by M
+*
+ LDWRKU = LDA
+ ELSE
+*
+* WORK(IU) is M by M
+*
+ LDWRKU = M
+ END IF
+ ITAU = IU + LDWRKU*M
+ IWORK = ITAU + M
+*
+* Compute A=L*Q, copying result to VT
+* (Workspace: need M*M+2*M, prefer M*M+M+M*NB)
+*
+ CALL SGELQF( M, N, A, LDA, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ CALL SLACPY( 'U', M, N, A, LDA, VT, LDVT )
+*
+* Generate Q in VT
+* (Workspace: need M*M+M+N, prefer M*M+M+N*NB)
+*
+ CALL SORGLQ( N, N, M, VT, LDVT, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+* Copy L to WORK(IU), zeroing out above it
+*
+ CALL SLACPY( 'L', M, M, A, LDA, WORK( IU ),
+ $ LDWRKU )
+ CALL SLASET( 'U', M-1, M-1, ZERO, ZERO,
+ $ WORK( IU+LDWRKU ), LDWRKU )
+ IE = ITAU
+ ITAUQ = IE + M
+ ITAUP = ITAUQ + M
+ IWORK = ITAUP + M
+*
+* Bidiagonalize L in WORK(IU), copying result to U
+* (Workspace: need M*M+4*M, prefer M*M+3*M+2*M*NB)
+*
+ CALL SGEBRD( M, M, WORK( IU ), LDWRKU, S,
+ $ WORK( IE ), WORK( ITAUQ ),
+ $ WORK( ITAUP ), WORK( IWORK ),
+ $ LWORK-IWORK+1, IERR )
+ CALL SLACPY( 'L', M, M, WORK( IU ), LDWRKU, U,
+ $ LDU )
+*
+* Generate right bidiagonalizing vectors in WORK(IU)
+* (Workspace: need M*M+4*M, prefer M*M+3*M+(M-1)*NB)
+*
+ CALL SORGBR( 'P', M, M, M, WORK( IU ), LDWRKU,
+ $ WORK( ITAUP ), WORK( IWORK ),
+ $ LWORK-IWORK+1, IERR )
+*
+* Generate left bidiagonalizing vectors in U
+* (Workspace: need M*M+4*M, prefer M*M+3*M+M*NB)
+*
+ CALL SORGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ IWORK = IE + M
+*
+* Perform bidiagonal QR iteration, computing left
+* singular vectors of L in U and computing right
+* singular vectors of L in WORK(IU)
+* (Workspace: need M*M+BDSPAC)
+*
+ CALL SBDSQR( 'U', M, M, M, 0, S, WORK( IE ),
+ $ WORK( IU ), LDWRKU, U, LDU, DUM, 1,
+ $ WORK( IWORK ), INFO )
+*
+* Multiply right singular vectors of L in WORK(IU) by
+* Q in VT, storing result in A
+* (Workspace: need M*M)
+*
+ CALL SGEMM( 'N', 'N', M, N, M, ONE, WORK( IU ),
+ $ LDWRKU, VT, LDVT, ZERO, A, LDA )
+*
+* Copy right singular vectors of A from A to VT
+*
+ CALL SLACPY( 'F', M, N, A, LDA, VT, LDVT )
+*
+ ELSE
+*
+* Insufficient workspace for a fast algorithm
+*
+ ITAU = 1
+ IWORK = ITAU + M
+*
+* Compute A=L*Q, copying result to VT
+* (Workspace: need 2*M, prefer M+M*NB)
+*
+ CALL SGELQF( M, N, A, LDA, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ CALL SLACPY( 'U', M, N, A, LDA, VT, LDVT )
+*
+* Generate Q in VT
+* (Workspace: need M+N, prefer M+N*NB)
+*
+ CALL SORGLQ( N, N, M, VT, LDVT, WORK( ITAU ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+* Copy L to U, zeroing out above it
+*
+ CALL SLACPY( 'L', M, M, A, LDA, U, LDU )
+ CALL SLASET( 'U', M-1, M-1, ZERO, ZERO, U( 1, 2 ),
+ $ LDU )
+ IE = ITAU
+ ITAUQ = IE + M
+ ITAUP = ITAUQ + M
+ IWORK = ITAUP + M
+*
+* Bidiagonalize L in U
+* (Workspace: need 4*M, prefer 3*M+2*M*NB)
+*
+ CALL SGEBRD( M, M, U, LDU, S, WORK( IE ),
+ $ WORK( ITAUQ ), WORK( ITAUP ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+* Multiply right bidiagonalizing vectors in U by Q
+* in VT
+* (Workspace: need 3*M+N, prefer 3*M+N*NB)
+*
+ CALL SORMBR( 'P', 'L', 'T', M, N, M, U, LDU,
+ $ WORK( ITAUP ), VT, LDVT,
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+*
+* Generate left bidiagonalizing vectors in U
+* (Workspace: need 4*M, prefer 3*M+M*NB)
+*
+ CALL SORGBR( 'Q', M, M, M, U, LDU, WORK( ITAUQ ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ IWORK = IE + M
+*
+* Perform bidiagonal QR iteration, computing left
+* singular vectors of A in U and computing right
+* singular vectors of A in VT
+* (Workspace: need BDSPAC)
+*
+ CALL SBDSQR( 'U', M, N, M, 0, S, WORK( IE ), VT,
+ $ LDVT, U, LDU, DUM, 1, WORK( IWORK ),
+ $ INFO )
+*
+ END IF
+*
+ END IF
+*
+ END IF
+*
+ ELSE
+*
+* N .LT. MNTHR
+*
+* Path 10t(N greater than M, but not much larger)
+* Reduce to bidiagonal form without LQ decomposition
+*
+ IE = 1
+ ITAUQ = IE + M
+ ITAUP = ITAUQ + M
+ IWORK = ITAUP + M
+*
+* Bidiagonalize A
+* (Workspace: need 3*M+N, prefer 3*M+(M+N)*NB)
+*
+ CALL SGEBRD( M, N, A, LDA, S, WORK( IE ), WORK( ITAUQ ),
+ $ WORK( ITAUP ), WORK( IWORK ), LWORK-IWORK+1,
+ $ IERR )
+ IF( WNTUAS ) THEN
+*
+* If left singular vectors desired in U, copy result to U
+* and generate left bidiagonalizing vectors in U
+* (Workspace: need 4*M-1, prefer 3*M+(M-1)*NB)
+*
+ CALL SLACPY( 'L', M, M, A, LDA, U, LDU )
+ CALL SORGBR( 'Q', M, M, N, U, LDU, WORK( ITAUQ ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ END IF
+ IF( WNTVAS ) THEN
+*
+* If right singular vectors desired in VT, copy result to
+* VT and generate right bidiagonalizing vectors in VT
+* (Workspace: need 3*M+NRVT, prefer 3*M+NRVT*NB)
+*
+ CALL SLACPY( 'U', M, N, A, LDA, VT, LDVT )
+ IF( WNTVA )
+ $ NRVT = N
+ IF( WNTVS )
+ $ NRVT = M
+ CALL SORGBR( 'P', NRVT, N, M, VT, LDVT, WORK( ITAUP ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ END IF
+ IF( WNTUO ) THEN
+*
+* If left singular vectors desired in A, generate left
+* bidiagonalizing vectors in A
+* (Workspace: need 4*M-1, prefer 3*M+(M-1)*NB)
+*
+ CALL SORGBR( 'Q', M, M, N, A, LDA, WORK( ITAUQ ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ END IF
+ IF( WNTVO ) THEN
+*
+* If right singular vectors desired in A, generate right
+* bidiagonalizing vectors in A
+* (Workspace: need 4*M, prefer 3*M+M*NB)
+*
+ CALL SORGBR( 'P', M, N, M, A, LDA, WORK( ITAUP ),
+ $ WORK( IWORK ), LWORK-IWORK+1, IERR )
+ END IF
+ IWORK = IE + M
+ IF( WNTUAS .OR. WNTUO )
+ $ NRU = M
+ IF( WNTUN )
+ $ NRU = 0
+ IF( WNTVAS .OR. WNTVO )
+ $ NCVT = N
+ IF( WNTVN )
+ $ NCVT = 0
+ IF( ( .NOT.WNTUO ) .AND. ( .NOT.WNTVO ) ) THEN
+*
+* Perform bidiagonal QR iteration, if desired, computing
+* left singular vectors in U and computing right singular
+* vectors in VT
+* (Workspace: need BDSPAC)
+*
+ CALL SBDSQR( 'L', M, NCVT, NRU, 0, S, WORK( IE ), VT,
+ $ LDVT, U, LDU, DUM, 1, WORK( IWORK ), INFO )
+ ELSE IF( ( .NOT.WNTUO ) .AND. WNTVO ) THEN
+*
+* Perform bidiagonal QR iteration, if desired, computing
+* left singular vectors in U and computing right singular
+* vectors in A
+* (Workspace: need BDSPAC)
+*
+ CALL SBDSQR( 'L', M, NCVT, NRU, 0, S, WORK( IE ), A, LDA,
+ $ U, LDU, DUM, 1, WORK( IWORK ), INFO )
+ ELSE
+*
+* Perform bidiagonal QR iteration, if desired, computing
+* left singular vectors in A and computing right singular
+* vectors in VT
+* (Workspace: need BDSPAC)
+*
+ CALL SBDSQR( 'L', M, NCVT, NRU, 0, S, WORK( IE ), VT,
+ $ LDVT, A, LDA, DUM, 1, WORK( IWORK ), INFO )
+ END IF
+*
+ END IF
+*
+ END IF
+*
+* If SBDSQR failed to converge, copy unconverged superdiagonals
+* to WORK( 2:MINMN )
+*
+ IF( INFO.NE.0 ) THEN
+ IF( IE.GT.2 ) THEN
+ DO 50 I = 1, MINMN - 1
+ WORK( I+1 ) = WORK( I+IE-1 )
+ 50 CONTINUE
+ END IF
+ IF( IE.LT.2 ) THEN
+ DO 60 I = MINMN - 1, 1, -1
+ WORK( I+1 ) = WORK( I+IE-1 )
+ 60 CONTINUE
+ END IF
+ END IF
+*
+* Undo scaling if necessary
+*
+ IF( ISCL.EQ.1 ) THEN
+ IF( ANRM.GT.BIGNUM )
+ $ CALL SLASCL( 'G', 0, 0, BIGNUM, ANRM, MINMN, 1, S, MINMN,
+ $ IERR )
+ IF( INFO.NE.0 .AND. ANRM.GT.BIGNUM )
+ $ CALL SLASCL( 'G', 0, 0, BIGNUM, ANRM, MINMN-1, 1, WORK( 2 ),
+ $ MINMN, IERR )
+ IF( ANRM.LT.SMLNUM )
+ $ CALL SLASCL( 'G', 0, 0, SMLNUM, ANRM, MINMN, 1, S, MINMN,
+ $ IERR )
+ IF( INFO.NE.0 .AND. ANRM.LT.SMLNUM )
+ $ CALL SLASCL( 'G', 0, 0, SMLNUM, ANRM, MINMN-1, 1, WORK( 2 ),
+ $ MINMN, IERR )
+ END IF
+*
+* Return optimal workspace in WORK(1)
+*
+ WORK( 1 ) = MAXWRK
+*
+ RETURN
+*
+* End of SGESVD
+*
+ END
+ SUBROUTINE SGESVX( FACT, TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV,
+ $ EQUED, R, C, B, LDB, X, LDX, RCOND, FERR, BERR,
+ $ WORK, IWORK, INFO )
+*
+* -- LAPACK driver routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER EQUED, FACT, TRANS
+ INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS
+ REAL RCOND
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * ), IWORK( * )
+ REAL A( LDA, * ), AF( LDAF, * ), B( LDB, * ),
+ $ BERR( * ), C( * ), FERR( * ), R( * ),
+ $ WORK( * ), X( LDX, * )
+* ..
+*
+* Purpose
+* =======
+*
+* SGESVX uses the LU factorization to compute the solution to a real
+* system of linear equations
+* A * X = B,
+* where A is an N-by-N matrix and X and B are N-by-NRHS matrices.
+*
+* Error bounds on the solution and a condition estimate are also
+* provided.
+*
+* Description
+* ===========
+*
+* The following steps are performed:
+*
+* 1. If FACT = 'E', real scaling factors are computed to equilibrate
+* the system:
+* TRANS = 'N': diag(R)*A*diag(C) *inv(diag(C))*X = diag(R)*B
+* TRANS = 'T': (diag(R)*A*diag(C))**T *inv(diag(R))*X = diag(C)*B
+* TRANS = 'C': (diag(R)*A*diag(C))**H *inv(diag(R))*X = diag(C)*B
+* Whether or not the system will be equilibrated depends on the
+* scaling of the matrix A, but if equilibration is used, A is
+* overwritten by diag(R)*A*diag(C) and B by diag(R)*B (if TRANS='N')
+* or diag(C)*B (if TRANS = 'T' or 'C').
+*
+* 2. If FACT = 'N' or 'E', the LU decomposition is used to factor the
+* matrix A (after equilibration if FACT = 'E') as
+* A = P * L * U,
+* where P is a permutation matrix, L is a unit lower triangular
+* matrix, and U is upper triangular.
+*
+* 3. If some U(i,i)=0, so that U is exactly singular, then the routine
+* returns with INFO = i. Otherwise, the factored form of A is used
+* to estimate the condition number of the matrix A. If the
+* reciprocal of the condition number is less than machine precision,
+* INFO = N+1 is returned as a warning, but the routine still goes on
+* to solve for X and compute error bounds as described below.
+*
+* 4. The system of equations is solved for X using the factored form
+* of A.
+*
+* 5. Iterative refinement is applied to improve the computed solution
+* matrix and calculate error bounds and backward error estimates
+* for it.
+*
+* 6. If equilibration was used, the matrix X is premultiplied by
+* diag(C) (if TRANS = 'N') or diag(R) (if TRANS = 'T' or 'C') so
+* that it solves the original system before equilibration.
+*
+* Arguments
+* =========
+*
+* FACT (input) CHARACTER*1
+* Specifies whether or not the factored form of the matrix A is
+* supplied on entry, and if not, whether the matrix A should be
+* equilibrated before it is factored.
+* = 'F': On entry, AF and IPIV contain the factored form of A.
+* If EQUED is not 'N', the matrix A has been
+* equilibrated with scaling factors given by R and C.
+* A, AF, and IPIV are not modified.
+* = 'N': The matrix A will be copied to AF and factored.
+* = 'E': The matrix A will be equilibrated if necessary, then
+* copied to AF and factored.
+*
+* TRANS (input) CHARACTER*1
+* Specifies the form of the system of equations:
+* = 'N': A * X = B (No transpose)
+* = 'T': A**T * X = B (Transpose)
+* = 'C': A**H * X = B (Transpose)
+*
+* N (input) INTEGER
+* The number of linear equations, i.e., the order of the
+* matrix A. N >= 0.
+*
+* NRHS (input) INTEGER
+* The number of right hand sides, i.e., the number of columns
+* of the matrices B and X. NRHS >= 0.
+*
+* A (input/output) REAL array, dimension (LDA,N)
+* On entry, the N-by-N matrix A. If FACT = 'F' and EQUED is
+* not 'N', then A must have been equilibrated by the scaling
+* factors in R and/or C. A is not modified if FACT = 'F' or
+* 'N', or if FACT = 'E' and EQUED = 'N' on exit.
+*
+* On exit, if EQUED .ne. 'N', A is scaled as follows:
+* EQUED = 'R': A := diag(R) * A
+* EQUED = 'C': A := A * diag(C)
+* EQUED = 'B': A := diag(R) * A * diag(C).
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,N).
+*
+* AF (input or output) REAL array, dimension (LDAF,N)
+* If FACT = 'F', then AF is an input argument and on entry
+* contains the factors L and U from the factorization
+* A = P*L*U as computed by SGETRF. If EQUED .ne. 'N', then
+* AF is the factored form of the equilibrated matrix A.
+*
+* If FACT = 'N', then AF is an output argument and on exit
+* returns the factors L and U from the factorization A = P*L*U
+* of the original matrix A.
+*
+* If FACT = 'E', then AF is an output argument and on exit
+* returns the factors L and U from the factorization A = P*L*U
+* of the equilibrated matrix A (see the description of A for
+* the form of the equilibrated matrix).
+*
+* LDAF (input) INTEGER
+* The leading dimension of the array AF. LDAF >= max(1,N).
+*
+* IPIV (input or output) INTEGER array, dimension (N)
+* If FACT = 'F', then IPIV is an input argument and on entry
+* contains the pivot indices from the factorization A = P*L*U
+* as computed by SGETRF; row i of the matrix was interchanged
+* with row IPIV(i).
+*
+* If FACT = 'N', then IPIV is an output argument and on exit
+* contains the pivot indices from the factorization A = P*L*U
+* of the original matrix A.
+*
+* If FACT = 'E', then IPIV is an output argument and on exit
+* contains the pivot indices from the factorization A = P*L*U
+* of the equilibrated matrix A.
+*
+* EQUED (input or output) CHARACTER*1
+* Specifies the form of equilibration that was done.
+* = 'N': No equilibration (always true if FACT = 'N').
+* = 'R': Row equilibration, i.e., A has been premultiplied by
+* diag(R).
+* = 'C': Column equilibration, i.e., A has been postmultiplied
+* by diag(C).
+* = 'B': Both row and column equilibration, i.e., A has been
+* replaced by diag(R) * A * diag(C).
+* EQUED is an input argument if FACT = 'F'; otherwise, it is an
+* output argument.
+*
+* R (input or output) REAL array, dimension (N)
+* The row scale factors for A. If EQUED = 'R' or 'B', A is
+* multiplied on the left by diag(R); if EQUED = 'N' or 'C', R
+* is not accessed. R is an input argument if FACT = 'F';
+* otherwise, R is an output argument. If FACT = 'F' and
+* EQUED = 'R' or 'B', each element of R must be positive.
+*
+* C (input or output) REAL array, dimension (N)
+* The column scale factors for A. If EQUED = 'C' or 'B', A is
+* multiplied on the right by diag(C); if EQUED = 'N' or 'R', C
+* is not accessed. C is an input argument if FACT = 'F';
+* otherwise, C is an output argument. If FACT = 'F' and
+* EQUED = 'C' or 'B', each element of C must be positive.
+*
+* B (input/output) REAL array, dimension (LDB,NRHS)
+* On entry, the N-by-NRHS right hand side matrix B.
+* On exit,
+* if EQUED = 'N', B is not modified;
+* if TRANS = 'N' and EQUED = 'R' or 'B', B is overwritten by
+* diag(R)*B;
+* if TRANS = 'T' or 'C' and EQUED = 'C' or 'B', B is
+* overwritten by diag(C)*B.
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. LDB >= max(1,N).
+*
+* X (output) REAL array, dimension (LDX,NRHS)
+* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X
+* to the original system of equations. Note that A and B are
+* modified on exit if EQUED .ne. 'N', and the solution to the
+* equilibrated system is inv(diag(C))*X if TRANS = 'N' and
+* EQUED = 'C' or 'B', or inv(diag(R))*X if TRANS = 'T' or 'C'
+* and EQUED = 'R' or 'B'.
+*
+* LDX (input) INTEGER
+* The leading dimension of the array X. LDX >= max(1,N).
+*
+* RCOND (output) REAL
+* The estimate of the reciprocal condition number of the matrix
+* A after equilibration (if done). If RCOND is less than the
+* machine precision (in particular, if RCOND = 0), the matrix
+* is singular to working precision. This condition is
+* indicated by a return code of INFO > 0.
+*
+* FERR (output) REAL array, dimension (NRHS)
+* The estimated forward error bound for each solution vector
+* X(j) (the j-th column of the solution matrix X).
+* If XTRUE is the true solution corresponding to X(j), FERR(j)
+* is an estimated upper bound for the magnitude of the largest
+* element in (X(j) - XTRUE) divided by the magnitude of the
+* largest element in X(j). The estimate is as reliable as
+* the estimate for RCOND, and is almost always a slight
+* overestimate of the true error.
+*
+* BERR (output) REAL array, dimension (NRHS)
+* The componentwise relative backward error of each solution
+* vector X(j) (i.e., the smallest relative change in
+* any element of A or B that makes X(j) an exact solution).
+*
+* WORK (workspace/output) REAL array, dimension (4*N)
+* On exit, WORK(1) contains the reciprocal pivot growth
+* factor norm(A)/norm(U). The "max absolute element" norm is
+* used. If WORK(1) is much less than 1, then the stability
+* of the LU factorization of the (equilibrated) matrix A
+* could be poor. This also means that the solution X, condition
+* estimator RCOND, and forward error bound FERR could be
+* unreliable. If factorization fails with 0<INFO<=N, then
+* WORK(1) contains the reciprocal pivot growth factor for the
+* leading INFO columns of A.
+*
+* IWORK (workspace) INTEGER array, dimension (N)
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* > 0: if INFO = i, and i is
+* <= N: U(i,i) is exactly zero. The factorization has
+* been completed, but the factor U is exactly
+* singular, so the solution and error bounds
+* could not be computed. RCOND = 0 is returned.
+* = N+1: U is nonsingular, but RCOND is less than machine
+* precision, meaning that the matrix is singular
+* to working precision. Nevertheless, the
+* solution and error bounds are computed because
+* there are a number of situations where the
+* computed solution can be more accurate than the
+* value of RCOND would suggest.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO, ONE
+ PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL COLEQU, EQUIL, NOFACT, NOTRAN, ROWEQU
+ CHARACTER NORM
+ INTEGER I, INFEQU, J
+ REAL AMAX, ANORM, BIGNUM, COLCND, RCMAX, RCMIN,
+ $ ROWCND, RPVGRW, SMLNUM
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ REAL SLAMCH, SLANGE, SLANTR
+ EXTERNAL LSAME, SLAMCH, SLANGE, SLANTR
+* ..
+* .. External Subroutines ..
+ EXTERNAL SGECON, SGEEQU, SGERFS, SGETRF, SGETRS, SLACPY,
+ $ SLAQGE, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+ INFO = 0
+ NOFACT = LSAME( FACT, 'N' )
+ EQUIL = LSAME( FACT, 'E' )
+ NOTRAN = LSAME( TRANS, 'N' )
+ IF( NOFACT .OR. EQUIL ) THEN
+ EQUED = 'N'
+ ROWEQU = .FALSE.
+ COLEQU = .FALSE.
+ ELSE
+ ROWEQU = LSAME( EQUED, 'R' ) .OR. LSAME( EQUED, 'B' )
+ COLEQU = LSAME( EQUED, 'C' ) .OR. LSAME( EQUED, 'B' )
+ SMLNUM = SLAMCH( 'Safe minimum' )
+ BIGNUM = ONE / SMLNUM
+ END IF
+*
+* Test the input parameters.
+*
+ IF( .NOT.NOFACT .AND. .NOT.EQUIL .AND. .NOT.LSAME( FACT, 'F' ) )
+ $ THEN
+ INFO = -1
+ ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT.
+ $ LSAME( TRANS, 'C' ) ) THEN
+ INFO = -2
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( NRHS.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -6
+ ELSE IF( LDAF.LT.MAX( 1, N ) ) THEN
+ INFO = -8
+ ELSE IF( LSAME( FACT, 'F' ) .AND. .NOT.
+ $ ( ROWEQU .OR. COLEQU .OR. LSAME( EQUED, 'N' ) ) ) THEN
+ INFO = -10
+ ELSE
+ IF( ROWEQU ) THEN
+ RCMIN = BIGNUM
+ RCMAX = ZERO
+ DO 10 J = 1, N
+ RCMIN = MIN( RCMIN, R( J ) )
+ RCMAX = MAX( RCMAX, R( J ) )
+ 10 CONTINUE
+ IF( RCMIN.LE.ZERO ) THEN
+ INFO = -11
+ ELSE IF( N.GT.0 ) THEN
+ ROWCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM )
+ ELSE
+ ROWCND = ONE
+ END IF
+ END IF
+ IF( COLEQU .AND. INFO.EQ.0 ) THEN
+ RCMIN = BIGNUM
+ RCMAX = ZERO
+ DO 20 J = 1, N
+ RCMIN = MIN( RCMIN, C( J ) )
+ RCMAX = MAX( RCMAX, C( J ) )
+ 20 CONTINUE
+ IF( RCMIN.LE.ZERO ) THEN
+ INFO = -12
+ ELSE IF( N.GT.0 ) THEN
+ COLCND = MAX( RCMIN, SMLNUM ) / MIN( RCMAX, BIGNUM )
+ ELSE
+ COLCND = ONE
+ END IF
+ END IF
+ IF( INFO.EQ.0 ) THEN
+ IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -14
+ ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
+ INFO = -16
+ END IF
+ END IF
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SGESVX', -INFO )
+ RETURN
+ END IF
+*
+ IF( EQUIL ) THEN
+*
+* Compute row and column scalings to equilibrate the matrix A.
+*
+ CALL SGEEQU( N, N, A, LDA, R, C, ROWCND, COLCND, AMAX, INFEQU )
+ IF( INFEQU.EQ.0 ) THEN
+*
+* Equilibrate the matrix.
+*
+ CALL SLAQGE( N, N, A, LDA, R, C, ROWCND, COLCND, AMAX,
+ $ EQUED )
+ ROWEQU = LSAME( EQUED, 'R' ) .OR. LSAME( EQUED, 'B' )
+ COLEQU = LSAME( EQUED, 'C' ) .OR. LSAME( EQUED, 'B' )
+ END IF
+ END IF
+*
+* Scale the right hand side.
+*
+ IF( NOTRAN ) THEN
+ IF( ROWEQU ) THEN
+ DO 40 J = 1, NRHS
+ DO 30 I = 1, N
+ B( I, J ) = R( I )*B( I, J )
+ 30 CONTINUE
+ 40 CONTINUE
+ END IF
+ ELSE IF( COLEQU ) THEN
+ DO 60 J = 1, NRHS
+ DO 50 I = 1, N
+ B( I, J ) = C( I )*B( I, J )
+ 50 CONTINUE
+ 60 CONTINUE
+ END IF
+*
+ IF( NOFACT .OR. EQUIL ) THEN
+*
+* Compute the LU factorization of A.
+*
+ CALL SLACPY( 'Full', N, N, A, LDA, AF, LDAF )
+ CALL SGETRF( N, N, AF, LDAF, IPIV, INFO )
+*
+* Return if INFO is non-zero.
+*
+ IF( INFO.GT.0 ) THEN
+*
+* Compute the reciprocal pivot growth factor of the
+* leading rank-deficient INFO columns of A.
+*
+ RPVGRW = SLANTR( 'M', 'U', 'N', INFO, INFO, AF, LDAF,
+ $ WORK )
+ IF( RPVGRW.EQ.ZERO ) THEN
+ RPVGRW = ONE
+ ELSE
+ RPVGRW = SLANGE( 'M', N, INFO, A, LDA, WORK ) / RPVGRW
+ END IF
+ WORK( 1 ) = RPVGRW
+ RCOND = ZERO
+ RETURN
+ END IF
+ END IF
+*
+* Compute the norm of the matrix A and the
+* reciprocal pivot growth factor RPVGRW.
+*
+ IF( NOTRAN ) THEN
+ NORM = '1'
+ ELSE
+ NORM = 'I'
+ END IF
+ ANORM = SLANGE( NORM, N, N, A, LDA, WORK )
+ RPVGRW = SLANTR( 'M', 'U', 'N', N, N, AF, LDAF, WORK )
+ IF( RPVGRW.EQ.ZERO ) THEN
+ RPVGRW = ONE
+ ELSE
+ RPVGRW = SLANGE( 'M', N, N, A, LDA, WORK ) / RPVGRW
+ END IF
+*
+* Compute the reciprocal of the condition number of A.
+*
+ CALL SGECON( NORM, N, AF, LDAF, ANORM, RCOND, WORK, IWORK, INFO )
+*
+* Compute the solution matrix X.
+*
+ CALL SLACPY( 'Full', N, NRHS, B, LDB, X, LDX )
+ CALL SGETRS( TRANS, N, NRHS, AF, LDAF, IPIV, X, LDX, INFO )
+*
+* Use iterative refinement to improve the computed solution and
+* compute error bounds and backward error estimates for it.
+*
+ CALL SGERFS( TRANS, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, X,
+ $ LDX, FERR, BERR, WORK, IWORK, INFO )
+*
+* Transform the solution matrix X to a solution of the original
+* system.
+*
+ IF( NOTRAN ) THEN
+ IF( COLEQU ) THEN
+ DO 80 J = 1, NRHS
+ DO 70 I = 1, N
+ X( I, J ) = C( I )*X( I, J )
+ 70 CONTINUE
+ 80 CONTINUE
+ DO 90 J = 1, NRHS
+ FERR( J ) = FERR( J ) / COLCND
+ 90 CONTINUE
+ END IF
+ ELSE IF( ROWEQU ) THEN
+ DO 110 J = 1, NRHS
+ DO 100 I = 1, N
+ X( I, J ) = R( I )*X( I, J )
+ 100 CONTINUE
+ 110 CONTINUE
+ DO 120 J = 1, NRHS
+ FERR( J ) = FERR( J ) / ROWCND
+ 120 CONTINUE
+ END IF
+*
+* Set INFO = N+1 if the matrix is singular to working precision.
+*
+ IF( RCOND.LT.SLAMCH( 'Epsilon' ) )
+ $ INFO = N + 1
+*
+ WORK( 1 ) = RPVGRW
+ RETURN
+*
+* End of SGESVX
+*
+ END
+ SUBROUTINE SGETC2( N, A, LDA, IPIV, JPIV, INFO )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LDA, N
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * ), JPIV( * )
+ REAL A( LDA, * )
+* ..
+*
+* Purpose
+* =======
+*
+* SGETC2 computes an LU factorization with complete pivoting of the
+* n-by-n matrix A. The factorization has the form A = P * L * U * Q,
+* where P and Q are permutation matrices, L is lower triangular with
+* unit diagonal elements and U is upper triangular.
+*
+* This is the Level 2 BLAS algorithm.
+*
+* Arguments
+* =========
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* A (input/output) REAL array, dimension (LDA, N)
+* On entry, the n-by-n matrix A to be factored.
+* On exit, the factors L and U from the factorization
+* A = P*L*U*Q; the unit diagonal elements of L are not stored.
+* If U(k, k) appears to be less than SMIN, U(k, k) is given the
+* value of SMIN, i.e., giving a nonsingular perturbed system.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,N).
+*
+* IPIV (output) INTEGER array, dimension(N).
+* The pivot indices; for 1 <= i <= N, row i of the
+* matrix has been interchanged with row IPIV(i).
+*
+* JPIV (output) INTEGER array, dimension(N).
+* The pivot indices; for 1 <= j <= N, column j of the
+* matrix has been interchanged with column JPIV(j).
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* > 0: if INFO = k, U(k, k) is likely to produce owerflow if
+* we try to solve for x in Ax = b. So U is perturbed to
+* avoid the overflow.
+*
+* Further Details
+* ===============
+*
+* Based on contributions by
+* Bo Kagstrom and Peter Poromaa, Department of Computing Science,
+* Umea University, S-901 87 Umea, Sweden.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO, ONE
+ PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, IP, IPV, J, JP, JPV
+ REAL BIGNUM, EPS, SMIN, SMLNUM, XMAX
+* ..
+* .. External Subroutines ..
+ EXTERNAL SGER, SLABAD, SSWAP
+* ..
+* .. External Functions ..
+ REAL SLAMCH
+ EXTERNAL SLAMCH
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX
+* ..
+* .. Executable Statements ..
+*
+* Set constants to control overflow
+*
+ INFO = 0
+ EPS = SLAMCH( 'P' )
+ SMLNUM = SLAMCH( 'S' ) / EPS
+ BIGNUM = ONE / SMLNUM
+ CALL SLABAD( SMLNUM, BIGNUM )
+*
+* Factorize A using complete pivoting.
+* Set pivots less than SMIN to SMIN.
+*
+ DO 40 I = 1, N - 1
+*
+* Find max element in matrix A
+*
+ XMAX = ZERO
+ DO 20 IP = I, N
+ DO 10 JP = I, N
+ IF( ABS( A( IP, JP ) ).GE.XMAX ) THEN
+ XMAX = ABS( A( IP, JP ) )
+ IPV = IP
+ JPV = JP
+ END IF
+ 10 CONTINUE
+ 20 CONTINUE
+ IF( I.EQ.1 )
+ $ SMIN = MAX( EPS*XMAX, SMLNUM )
+*
+* Swap rows
+*
+ IF( IPV.NE.I )
+ $ CALL SSWAP( N, A( IPV, 1 ), LDA, A( I, 1 ), LDA )
+ IPIV( I ) = IPV
+*
+* Swap columns
+*
+ IF( JPV.NE.I )
+ $ CALL SSWAP( N, A( 1, JPV ), 1, A( 1, I ), 1 )
+ JPIV( I ) = JPV
+*
+* Check for singularity
+*
+ IF( ABS( A( I, I ) ).LT.SMIN ) THEN
+ INFO = I
+ A( I, I ) = SMIN
+ END IF
+ DO 30 J = I + 1, N
+ A( J, I ) = A( J, I ) / A( I, I )
+ 30 CONTINUE
+ CALL SGER( N-I, N-I, -ONE, A( I+1, I ), 1, A( I, I+1 ), LDA,
+ $ A( I+1, I+1 ), LDA )
+ 40 CONTINUE
+*
+ IF( ABS( A( N, N ) ).LT.SMIN ) THEN
+ INFO = N
+ A( N, N ) = SMIN
+ END IF
+*
+ RETURN
+*
+* End of SGETC2
+*
+ END
+ SUBROUTINE SGETF2( M, N, A, LDA, IPIV, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LDA, M, N
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ REAL A( LDA, * )
+* ..
+*
+* Purpose
+* =======
+*
+* SGETF2 computes an LU factorization of a general m-by-n matrix A
+* using partial pivoting with row interchanges.
+*
+* The factorization has the form
+* A = P * L * U
+* where P is a permutation matrix, L is lower triangular with unit
+* diagonal elements (lower trapezoidal if m > n), and U is upper
+* triangular (upper trapezoidal if m < n).
+*
+* This is the right-looking Level 2 BLAS version of the algorithm.
+*
+* Arguments
+* =========
+*
+* M (input) INTEGER
+* The number of rows of the matrix A. M >= 0.
+*
+* N (input) INTEGER
+* The number of columns of the matrix A. N >= 0.
+*
+* A (input/output) REAL array, dimension (LDA,N)
+* On entry, the m by n matrix to be factored.
+* On exit, the factors L and U from the factorization
+* A = P*L*U; the unit diagonal elements of L are not stored.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,M).
+*
+* IPIV (output) INTEGER array, dimension (min(M,N))
+* The pivot indices; for 1 <= i <= min(M,N), row i of the
+* matrix was interchanged with row IPIV(i).
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -k, the k-th argument had an illegal value
+* > 0: if INFO = k, U(k,k) is exactly zero. The factorization
+* has been completed, but the factor U is exactly
+* singular, and division by zero will occur if it is used
+* to solve a system of equations.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ONE, ZERO
+ PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+* ..
+* .. Local Scalars ..
+ REAL SFMIN
+ INTEGER I, J, JP
+* ..
+* .. External Functions ..
+ REAL SLAMCH
+ INTEGER ISAMAX
+ EXTERNAL SLAMCH, ISAMAX
+* ..
+* .. External Subroutines ..
+ EXTERNAL SGER, SSCAL, SSWAP, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ IF( M.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+ INFO = -4
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SGETF2', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( M.EQ.0 .OR. N.EQ.0 )
+ $ RETURN
+*
+* Compute machine safe minimum
+*
+ SFMIN = SLAMCH('S')
+*
+ DO 10 J = 1, MIN( M, N )
+*
+* Find pivot and test for singularity.
+*
+ JP = J - 1 + ISAMAX( M-J+1, A( J, J ), 1 )
+ IPIV( J ) = JP
+ IF( A( JP, J ).NE.ZERO ) THEN
+*
+* Apply the interchange to columns 1:N.
+*
+ IF( JP.NE.J )
+ $ CALL SSWAP( N, A( J, 1 ), LDA, A( JP, 1 ), LDA )
+*
+* Compute elements J+1:M of J-th column.
+*
+ IF( J.LT.M ) THEN
+ IF( ABS(A( J, J )) .GE. SFMIN ) THEN
+ CALL SSCAL( M-J, ONE / A( J, J ), A( J+1, J ), 1 )
+ ELSE
+ DO 20 I = 1, M-J
+ A( J+I, J ) = A( J+I, J ) / A( J, J )
+ 20 CONTINUE
+ END IF
+ END IF
+*
+ ELSE IF( INFO.EQ.0 ) THEN
+*
+ INFO = J
+ END IF
+*
+ IF( J.LT.MIN( M, N ) ) THEN
+*
+* Update trailing submatrix.
+*
+ CALL SGER( M-J, N-J, -ONE, A( J+1, J ), 1, A( J, J+1 ), LDA,
+ $ A( J+1, J+1 ), LDA )
+ END IF
+ 10 CONTINUE
+ RETURN
+*
+* End of SGETF2
+*
+ END
+ SUBROUTINE SGETRF( M, N, A, LDA, IPIV, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LDA, M, N
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ REAL A( LDA, * )
+* ..
+*
+* Purpose
+* =======
+*
+* SGETRF computes an LU factorization of a general M-by-N matrix A
+* using partial pivoting with row interchanges.
+*
+* The factorization has the form
+* A = P * L * U
+* where P is a permutation matrix, L is lower triangular with unit
+* diagonal elements (lower trapezoidal if m > n), and U is upper
+* triangular (upper trapezoidal if m < n).
+*
+* This is the right-looking Level 3 BLAS version of the algorithm.
+*
+* Arguments
+* =========
+*
+* M (input) INTEGER
+* The number of rows of the matrix A. M >= 0.
+*
+* N (input) INTEGER
+* The number of columns of the matrix A. N >= 0.
+*
+* A (input/output) REAL array, dimension (LDA,N)
+* On entry, the M-by-N matrix to be factored.
+* On exit, the factors L and U from the factorization
+* A = P*L*U; the unit diagonal elements of L are not stored.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,M).
+*
+* IPIV (output) INTEGER array, dimension (min(M,N))
+* The pivot indices; for 1 <= i <= min(M,N), row i of the
+* matrix was interchanged with row IPIV(i).
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* > 0: if INFO = i, U(i,i) is exactly zero. The factorization
+* has been completed, but the factor U is exactly
+* singular, and division by zero will occur if it is used
+* to solve a system of equations.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ONE
+ PARAMETER ( ONE = 1.0E+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, IINFO, J, JB, NB
+* ..
+* .. External Subroutines ..
+ EXTERNAL SGEMM, SGETF2, SLASWP, STRSM, XERBLA
+* ..
+* .. External Functions ..
+ INTEGER ILAENV
+ EXTERNAL ILAENV
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ IF( M.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+ INFO = -4
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SGETRF', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( M.EQ.0 .OR. N.EQ.0 )
+ $ RETURN
+*
+* Determine the block size for this environment.
+*
+ NB = ILAENV( 1, 'SGETRF', ' ', M, N, -1, -1 )
+ IF( NB.LE.1 .OR. NB.GE.MIN( M, N ) ) THEN
+*
+* Use unblocked code.
+*
+ CALL SGETF2( M, N, A, LDA, IPIV, INFO )
+ ELSE
+*
+* Use blocked code.
+*
+ DO 20 J = 1, MIN( M, N ), NB
+ JB = MIN( MIN( M, N )-J+1, NB )
+*
+* Factor diagonal and subdiagonal blocks and test for exact
+* singularity.
+*
+ CALL SGETF2( M-J+1, JB, A( J, J ), LDA, IPIV( J ), IINFO )
+*
+* Adjust INFO and the pivot indices.
+*
+ IF( INFO.EQ.0 .AND. IINFO.GT.0 )
+ $ INFO = IINFO + J - 1
+ DO 10 I = J, MIN( M, J+JB-1 )
+ IPIV( I ) = J - 1 + IPIV( I )
+ 10 CONTINUE
+*
+* Apply interchanges to columns 1:J-1.
+*
+ CALL SLASWP( J-1, A, LDA, J, J+JB-1, IPIV, 1 )
+*
+ IF( J+JB.LE.N ) THEN
+*
+* Apply interchanges to columns J+JB:N.
+*
+ CALL SLASWP( N-J-JB+1, A( 1, J+JB ), LDA, J, J+JB-1,
+ $ IPIV, 1 )
+*
+* Compute block row of U.
+*
+ CALL STRSM( 'Left', 'Lower', 'No transpose', 'Unit', JB,
+ $ N-J-JB+1, ONE, A( J, J ), LDA, A( J, J+JB ),
+ $ LDA )
+ IF( J+JB.LE.M ) THEN
+*
+* Update trailing submatrix.
+*
+ CALL SGEMM( 'No transpose', 'No transpose', M-J-JB+1,
+ $ N-J-JB+1, JB, -ONE, A( J+JB, J ), LDA,
+ $ A( J, J+JB ), LDA, ONE, A( J+JB, J+JB ),
+ $ LDA )
+ END IF
+ END IF
+ 20 CONTINUE
+ END IF
+ RETURN
+*
+* End of SGETRF
+*
+ END
+ SUBROUTINE SGETRI( N, A, LDA, IPIV, WORK, LWORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LDA, LWORK, N
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ REAL A( LDA, * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SGETRI computes the inverse of a matrix using the LU factorization
+* computed by SGETRF.
+*
+* This method inverts U and then computes inv(A) by solving the system
+* inv(A)*L = inv(U) for inv(A).
+*
+* Arguments
+* =========
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* A (input/output) REAL array, dimension (LDA,N)
+* On entry, the factors L and U from the factorization
+* A = P*L*U as computed by SGETRF.
+* On exit, if INFO = 0, the inverse of the original matrix A.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,N).
+*
+* IPIV (input) INTEGER array, dimension (N)
+* The pivot indices from SGETRF; for 1<=i<=N, row i of the
+* matrix was interchanged with row IPIV(i).
+*
+* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))
+* On exit, if INFO=0, then WORK(1) returns the optimal LWORK.
+*
+* LWORK (input) INTEGER
+* The dimension of the array WORK. LWORK >= max(1,N).
+* For optimal performance LWORK >= N*NB, where NB is
+* the optimal blocksize returned by ILAENV.
+*
+* If LWORK = -1, then a workspace query is assumed; the routine
+* only calculates the optimal size of the WORK array, returns
+* this value as the first entry of the WORK array, and no error
+* message related to LWORK is issued by XERBLA.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* > 0: if INFO = i, U(i,i) is exactly zero; the matrix is
+* singular and its inverse could not be computed.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO, ONE
+ PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL LQUERY
+ INTEGER I, IWS, J, JB, JJ, JP, LDWORK, LWKOPT, NB,
+ $ NBMIN, NN
+* ..
+* .. External Functions ..
+ INTEGER ILAENV
+ EXTERNAL ILAENV
+* ..
+* .. External Subroutines ..
+ EXTERNAL SGEMM, SGEMV, SSWAP, STRSM, STRTRI, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ NB = ILAENV( 1, 'SGETRI', ' ', N, -1, -1, -1 )
+ LWKOPT = N*NB
+ WORK( 1 ) = LWKOPT
+ LQUERY = ( LWORK.EQ.-1 )
+ IF( N.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -3
+ ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN
+ INFO = -6
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SGETRI', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+* Form inv(U). If INFO > 0 from STRTRI, then U is singular,
+* and the inverse is not computed.
+*
+ CALL STRTRI( 'Upper', 'Non-unit', N, A, LDA, INFO )
+ IF( INFO.GT.0 )
+ $ RETURN
+*
+ NBMIN = 2
+ LDWORK = N
+ IF( NB.GT.1 .AND. NB.LT.N ) THEN
+ IWS = MAX( LDWORK*NB, 1 )
+ IF( LWORK.LT.IWS ) THEN
+ NB = LWORK / LDWORK
+ NBMIN = MAX( 2, ILAENV( 2, 'SGETRI', ' ', N, -1, -1, -1 ) )
+ END IF
+ ELSE
+ IWS = N
+ END IF
+*
+* Solve the equation inv(A)*L = inv(U) for inv(A).
+*
+ IF( NB.LT.NBMIN .OR. NB.GE.N ) THEN
+*
+* Use unblocked code.
+*
+ DO 20 J = N, 1, -1
+*
+* Copy current column of L to WORK and replace with zeros.
+*
+ DO 10 I = J + 1, N
+ WORK( I ) = A( I, J )
+ A( I, J ) = ZERO
+ 10 CONTINUE
+*
+* Compute current column of inv(A).
+*
+ IF( J.LT.N )
+ $ CALL SGEMV( 'No transpose', N, N-J, -ONE, A( 1, J+1 ),
+ $ LDA, WORK( J+1 ), 1, ONE, A( 1, J ), 1 )
+ 20 CONTINUE
+ ELSE
+*
+* Use blocked code.
+*
+ NN = ( ( N-1 ) / NB )*NB + 1
+ DO 50 J = NN, 1, -NB
+ JB = MIN( NB, N-J+1 )
+*
+* Copy current block column of L to WORK and replace with
+* zeros.
+*
+ DO 40 JJ = J, J + JB - 1
+ DO 30 I = JJ + 1, N
+ WORK( I+( JJ-J )*LDWORK ) = A( I, JJ )
+ A( I, JJ ) = ZERO
+ 30 CONTINUE
+ 40 CONTINUE
+*
+* Compute current block column of inv(A).
+*
+ IF( J+JB.LE.N )
+ $ CALL SGEMM( 'No transpose', 'No transpose', N, JB,
+ $ N-J-JB+1, -ONE, A( 1, J+JB ), LDA,
+ $ WORK( J+JB ), LDWORK, ONE, A( 1, J ), LDA )
+ CALL STRSM( 'Right', 'Lower', 'No transpose', 'Unit', N, JB,
+ $ ONE, WORK( J ), LDWORK, A( 1, J ), LDA )
+ 50 CONTINUE
+ END IF
+*
+* Apply column interchanges.
+*
+ DO 60 J = N - 1, 1, -1
+ JP = IPIV( J )
+ IF( JP.NE.J )
+ $ CALL SSWAP( N, A( 1, J ), 1, A( 1, JP ), 1 )
+ 60 CONTINUE
+*
+ WORK( 1 ) = IWS
+ RETURN
+*
+* End of SGETRI
+*
+ END
+ SUBROUTINE SGETRS( TRANS, N, NRHS, A, LDA, IPIV, B, LDB, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER TRANS
+ INTEGER INFO, LDA, LDB, N, NRHS
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ REAL A( LDA, * ), B( LDB, * )
+* ..
+*
+* Purpose
+* =======
+*
+* SGETRS solves a system of linear equations
+* A * X = B or A' * X = B
+* with a general N-by-N matrix A using the LU factorization computed
+* by SGETRF.
+*
+* Arguments
+* =========
+*
+* TRANS (input) CHARACTER*1
+* Specifies the form of the system of equations:
+* = 'N': A * X = B (No transpose)
+* = 'T': A'* X = B (Transpose)
+* = 'C': A'* X = B (Conjugate transpose = Transpose)
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* NRHS (input) INTEGER
+* The number of right hand sides, i.e., the number of columns
+* of the matrix B. NRHS >= 0.
+*
+* A (input) REAL array, dimension (LDA,N)
+* The factors L and U from the factorization A = P*L*U
+* as computed by SGETRF.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,N).
+*
+* IPIV (input) INTEGER array, dimension (N)
+* The pivot indices from SGETRF; for 1<=i<=N, row i of the
+* matrix was interchanged with row IPIV(i).
+*
+* B (input/output) REAL array, dimension (LDB,NRHS)
+* On entry, the right hand side matrix B.
+* On exit, the solution matrix X.
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. LDB >= max(1,N).
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ONE
+ PARAMETER ( ONE = 1.0E+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL NOTRAN
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL SLASWP, STRSM, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ NOTRAN = LSAME( TRANS, 'N' )
+ IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT.
+ $ LSAME( TRANS, 'C' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( NRHS.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -5
+ ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -8
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SGETRS', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 .OR. NRHS.EQ.0 )
+ $ RETURN
+*
+ IF( NOTRAN ) THEN
+*
+* Solve A * X = B.
+*
+* Apply row interchanges to the right hand sides.
+*
+ CALL SLASWP( NRHS, B, LDB, 1, N, IPIV, 1 )
+*
+* Solve L*X = B, overwriting B with X.
+*
+ CALL STRSM( 'Left', 'Lower', 'No transpose', 'Unit', N, NRHS,
+ $ ONE, A, LDA, B, LDB )
+*
+* Solve U*X = B, overwriting B with X.
+*
+ CALL STRSM( 'Left', 'Upper', 'No transpose', 'Non-unit', N,
+ $ NRHS, ONE, A, LDA, B, LDB )
+ ELSE
+*
+* Solve A' * X = B.
+*
+* Solve U'*X = B, overwriting B with X.
+*
+ CALL STRSM( 'Left', 'Upper', 'Transpose', 'Non-unit', N, NRHS,
+ $ ONE, A, LDA, B, LDB )
+*
+* Solve L'*X = B, overwriting B with X.
+*
+ CALL STRSM( 'Left', 'Lower', 'Transpose', 'Unit', N, NRHS, ONE,
+ $ A, LDA, B, LDB )
+*
+* Apply row interchanges to the solution vectors.
+*
+ CALL SLASWP( NRHS, B, LDB, 1, N, IPIV, -1 )
+ END IF
+*
+ RETURN
+*
+* End of SGETRS
+*
+ END
+ SUBROUTINE SGGBAK( JOB, SIDE, N, ILO, IHI, LSCALE, RSCALE, M, V,
+ $ LDV, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER JOB, SIDE
+ INTEGER IHI, ILO, INFO, LDV, M, N
+* ..
+* .. Array Arguments ..
+ REAL LSCALE( * ), RSCALE( * ), V( LDV, * )
+* ..
+*
+* Purpose
+* =======
+*
+* SGGBAK forms the right or left eigenvectors of a real generalized
+* eigenvalue problem A*x = lambda*B*x, by backward transformation on
+* the computed eigenvectors of the balanced pair of matrices output by
+* SGGBAL.
+*
+* Arguments
+* =========
+*
+* JOB (input) CHARACTER*1
+* Specifies the type of backward transformation required:
+* = 'N': do nothing, return immediately;
+* = 'P': do backward transformation for permutation only;
+* = 'S': do backward transformation for scaling only;
+* = 'B': do backward transformations for both permutation and
+* scaling.
+* JOB must be the same as the argument JOB supplied to SGGBAL.
+*
+* SIDE (input) CHARACTER*1
+* = 'R': V contains right eigenvectors;
+* = 'L': V contains left eigenvectors.
+*
+* N (input) INTEGER
+* The number of rows of the matrix V. N >= 0.
+*
+* ILO (input) INTEGER
+* IHI (input) INTEGER
+* The integers ILO and IHI determined by SGGBAL.
+* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.
+*
+* LSCALE (input) REAL array, dimension (N)
+* Details of the permutations and/or scaling factors applied
+* to the left side of A and B, as returned by SGGBAL.
+*
+* RSCALE (input) REAL array, dimension (N)
+* Details of the permutations and/or scaling factors applied
+* to the right side of A and B, as returned by SGGBAL.
+*
+* M (input) INTEGER
+* The number of columns of the matrix V. M >= 0.
+*
+* V (input/output) REAL array, dimension (LDV,M)
+* On entry, the matrix of right or left eigenvectors to be
+* transformed, as returned by STGEVC.
+* On exit, V is overwritten by the transformed eigenvectors.
+*
+* LDV (input) INTEGER
+* The leading dimension of the matrix V. LDV >= max(1,N).
+*
+* INFO (output) INTEGER
+* = 0: successful exit.
+* < 0: if INFO = -i, the i-th argument had an illegal value.
+*
+* Further Details
+* ===============
+*
+* See R.C. Ward, Balancing the generalized eigenvalue problem,
+* SIAM J. Sci. Stat. Comp. 2 (1981), 141-152.
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ LOGICAL LEFTV, RIGHTV
+ INTEGER I, K
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL SSCAL, SSWAP, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters
+*
+ RIGHTV = LSAME( SIDE, 'R' )
+ LEFTV = LSAME( SIDE, 'L' )
+*
+ INFO = 0
+ IF( .NOT.LSAME( JOB, 'N' ) .AND. .NOT.LSAME( JOB, 'P' ) .AND.
+ $ .NOT.LSAME( JOB, 'S' ) .AND. .NOT.LSAME( JOB, 'B' ) ) THEN
+ INFO = -1
+ ELSE IF( .NOT.RIGHTV .AND. .NOT.LEFTV ) THEN
+ INFO = -2
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( ILO.LT.1 ) THEN
+ INFO = -4
+ ELSE IF( N.EQ.0 .AND. IHI.EQ.0 .AND. ILO.NE.1 ) THEN
+ INFO = -4
+ ELSE IF( N.GT.0 .AND. ( IHI.LT.ILO .OR. IHI.GT.MAX( 1, N ) ) )
+ $ THEN
+ INFO = -5
+ ELSE IF( N.EQ.0 .AND. ILO.EQ.1 .AND. IHI.NE.0 ) THEN
+ INFO = -5
+ ELSE IF( M.LT.0 ) THEN
+ INFO = -8
+ ELSE IF( LDV.LT.MAX( 1, N ) ) THEN
+ INFO = -10
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SGGBAK', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 )
+ $ RETURN
+ IF( M.EQ.0 )
+ $ RETURN
+ IF( LSAME( JOB, 'N' ) )
+ $ RETURN
+*
+ IF( ILO.EQ.IHI )
+ $ GO TO 30
+*
+* Backward balance
+*
+ IF( LSAME( JOB, 'S' ) .OR. LSAME( JOB, 'B' ) ) THEN
+*
+* Backward transformation on right eigenvectors
+*
+ IF( RIGHTV ) THEN
+ DO 10 I = ILO, IHI
+ CALL SSCAL( M, RSCALE( I ), V( I, 1 ), LDV )
+ 10 CONTINUE
+ END IF
+*
+* Backward transformation on left eigenvectors
+*
+ IF( LEFTV ) THEN
+ DO 20 I = ILO, IHI
+ CALL SSCAL( M, LSCALE( I ), V( I, 1 ), LDV )
+ 20 CONTINUE
+ END IF
+ END IF
+*
+* Backward permutation
+*
+ 30 CONTINUE
+ IF( LSAME( JOB, 'P' ) .OR. LSAME( JOB, 'B' ) ) THEN
+*
+* Backward permutation on right eigenvectors
+*
+ IF( RIGHTV ) THEN
+ IF( ILO.EQ.1 )
+ $ GO TO 50
+*
+ DO 40 I = ILO - 1, 1, -1
+ K = RSCALE( I )
+ IF( K.EQ.I )
+ $ GO TO 40
+ CALL SSWAP( M, V( I, 1 ), LDV, V( K, 1 ), LDV )
+ 40 CONTINUE
+*
+ 50 CONTINUE
+ IF( IHI.EQ.N )
+ $ GO TO 70
+ DO 60 I = IHI + 1, N
+ K = RSCALE( I )
+ IF( K.EQ.I )
+ $ GO TO 60
+ CALL SSWAP( M, V( I, 1 ), LDV, V( K, 1 ), LDV )
+ 60 CONTINUE
+ END IF
+*
+* Backward permutation on left eigenvectors
+*
+ 70 CONTINUE
+ IF( LEFTV ) THEN
+ IF( ILO.EQ.1 )
+ $ GO TO 90
+ DO 80 I = ILO - 1, 1, -1
+ K = LSCALE( I )
+ IF( K.EQ.I )
+ $ GO TO 80
+ CALL SSWAP( M, V( I, 1 ), LDV, V( K, 1 ), LDV )
+ 80 CONTINUE
+*
+ 90 CONTINUE
+ IF( IHI.EQ.N )
+ $ GO TO 110
+ DO 100 I = IHI + 1, N
+ K = LSCALE( I )
+ IF( K.EQ.I )
+ $ GO TO 100
+ CALL SSWAP( M, V( I, 1 ), LDV, V( K, 1 ), LDV )
+ 100 CONTINUE
+ END IF
+ END IF
+*
+ 110 CONTINUE
+*
+ RETURN
+*
+* End of SGGBAK
+*
+ END
+ SUBROUTINE SGGBAL( JOB, N, A, LDA, B, LDB, ILO, IHI, LSCALE,
+ $ RSCALE, WORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER JOB
+ INTEGER IHI, ILO, INFO, LDA, LDB, N
+* ..
+* .. Array Arguments ..
+ REAL A( LDA, * ), B( LDB, * ), LSCALE( * ),
+ $ RSCALE( * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SGGBAL balances a pair of general real matrices (A,B). This
+* involves, first, permuting A and B by similarity transformations to
+* isolate eigenvalues in the first 1 to ILO$-$1 and last IHI+1 to N
+* elements on the diagonal; and second, applying a diagonal similarity
+* transformation to rows and columns ILO to IHI to make the rows
+* and columns as close in norm as possible. Both steps are optional.
+*
+* Balancing may reduce the 1-norm of the matrices, and improve the
+* accuracy of the computed eigenvalues and/or eigenvectors in the
+* generalized eigenvalue problem A*x = lambda*B*x.
+*
+* Arguments
+* =========
+*
+* JOB (input) CHARACTER*1
+* Specifies the operations to be performed on A and B:
+* = 'N': none: simply set ILO = 1, IHI = N, LSCALE(I) = 1.0
+* and RSCALE(I) = 1.0 for i = 1,...,N.
+* = 'P': permute only;
+* = 'S': scale only;
+* = 'B': both permute and scale.
+*
+* N (input) INTEGER
+* The order of the matrices A and B. N >= 0.
+*
+* A (input/output) REAL array, dimension (LDA,N)
+* On entry, the input matrix A.
+* On exit, A is overwritten by the balanced matrix.
+* If JOB = 'N', A is not referenced.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,N).
+*
+* B (input/output) REAL array, dimension (LDB,N)
+* On entry, the input matrix B.
+* On exit, B is overwritten by the balanced matrix.
+* If JOB = 'N', B is not referenced.
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. LDB >= max(1,N).
+*
+* ILO (output) INTEGER
+* IHI (output) INTEGER
+* ILO and IHI are set to integers such that on exit
+* A(i,j) = 0 and B(i,j) = 0 if i > j and
+* j = 1,...,ILO-1 or i = IHI+1,...,N.
+* If JOB = 'N' or 'S', ILO = 1 and IHI = N.
+*
+* LSCALE (output) REAL array, dimension (N)
+* Details of the permutations and scaling factors applied
+* to the left side of A and B. If P(j) is the index of the
+* row interchanged with row j, and D(j)
+* is the scaling factor applied to row j, then
+* LSCALE(j) = P(j) for J = 1,...,ILO-1
+* = D(j) for J = ILO,...,IHI
+* = P(j) for J = IHI+1,...,N.
+* The order in which the interchanges are made is N to IHI+1,
+* then 1 to ILO-1.
+*
+* RSCALE (output) REAL array, dimension (N)
+* Details of the permutations and scaling factors applied
+* to the right side of A and B. If P(j) is the index of the
+* column interchanged with column j, and D(j)
+* is the scaling factor applied to column j, then
+* LSCALE(j) = P(j) for J = 1,...,ILO-1
+* = D(j) for J = ILO,...,IHI
+* = P(j) for J = IHI+1,...,N.
+* The order in which the interchanges are made is N to IHI+1,
+* then 1 to ILO-1.
+*
+* WORK (workspace) REAL array, dimension (lwork)
+* lwork must be at least max(1,6*N) when JOB = 'S' or 'B', and
+* at least 1 when JOB = 'N' or 'P'.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value.
+*
+* Further Details
+* ===============
+*
+* See R.C. WARD, Balancing the generalized eigenvalue problem,
+* SIAM J. Sci. Stat. Comp. 2 (1981), 141-152.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO, HALF, ONE
+ PARAMETER ( ZERO = 0.0E+0, HALF = 0.5E+0, ONE = 1.0E+0 )
+ REAL THREE, SCLFAC
+ PARAMETER ( THREE = 3.0E+0, SCLFAC = 1.0E+1 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, ICAB, IFLOW, IP1, IR, IRAB, IT, J, JC, JP1,
+ $ K, KOUNT, L, LCAB, LM1, LRAB, LSFMAX, LSFMIN,
+ $ M, NR, NRP2
+ REAL ALPHA, BASL, BETA, CAB, CMAX, COEF, COEF2,
+ $ COEF5, COR, EW, EWC, GAMMA, PGAMMA, RAB, SFMAX,
+ $ SFMIN, SUM, T, TA, TB, TC
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ISAMAX
+ REAL SDOT, SLAMCH
+ EXTERNAL LSAME, ISAMAX, SDOT, SLAMCH
+* ..
+* .. External Subroutines ..
+ EXTERNAL SAXPY, SSCAL, SSWAP, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, INT, LOG10, MAX, MIN, REAL, SIGN
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters
+*
+ INFO = 0
+ IF( .NOT.LSAME( JOB, 'N' ) .AND. .NOT.LSAME( JOB, 'P' ) .AND.
+ $ .NOT.LSAME( JOB, 'S' ) .AND. .NOT.LSAME( JOB, 'B' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -4
+ ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -6
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SGGBAL', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 ) THEN
+ ILO = 1
+ IHI = N
+ RETURN
+ END IF
+*
+ IF( N.EQ.1 ) THEN
+ ILO = 1
+ IHI = N
+ LSCALE( 1 ) = ONE
+ RSCALE( 1 ) = ONE
+ RETURN
+ END IF
+*
+ IF( LSAME( JOB, 'N' ) ) THEN
+ ILO = 1
+ IHI = N
+ DO 10 I = 1, N
+ LSCALE( I ) = ONE
+ RSCALE( I ) = ONE
+ 10 CONTINUE
+ RETURN
+ END IF
+*
+ K = 1
+ L = N
+ IF( LSAME( JOB, 'S' ) )
+ $ GO TO 190
+*
+ GO TO 30
+*
+* Permute the matrices A and B to isolate the eigenvalues.
+*
+* Find row with one nonzero in columns 1 through L
+*
+ 20 CONTINUE
+ L = LM1
+ IF( L.NE.1 )
+ $ GO TO 30
+*
+ RSCALE( 1 ) = ONE
+ LSCALE( 1 ) = ONE
+ GO TO 190
+*
+ 30 CONTINUE
+ LM1 = L - 1
+ DO 80 I = L, 1, -1
+ DO 40 J = 1, LM1
+ JP1 = J + 1
+ IF( A( I, J ).NE.ZERO .OR. B( I, J ).NE.ZERO )
+ $ GO TO 50
+ 40 CONTINUE
+ J = L
+ GO TO 70
+*
+ 50 CONTINUE
+ DO 60 J = JP1, L
+ IF( A( I, J ).NE.ZERO .OR. B( I, J ).NE.ZERO )
+ $ GO TO 80
+ 60 CONTINUE
+ J = JP1 - 1
+*
+ 70 CONTINUE
+ M = L
+ IFLOW = 1
+ GO TO 160
+ 80 CONTINUE
+ GO TO 100
+*
+* Find column with one nonzero in rows K through N
+*
+ 90 CONTINUE
+ K = K + 1
+*
+ 100 CONTINUE
+ DO 150 J = K, L
+ DO 110 I = K, LM1
+ IP1 = I + 1
+ IF( A( I, J ).NE.ZERO .OR. B( I, J ).NE.ZERO )
+ $ GO TO 120
+ 110 CONTINUE
+ I = L
+ GO TO 140
+ 120 CONTINUE
+ DO 130 I = IP1, L
+ IF( A( I, J ).NE.ZERO .OR. B( I, J ).NE.ZERO )
+ $ GO TO 150
+ 130 CONTINUE
+ I = IP1 - 1
+ 140 CONTINUE
+ M = K
+ IFLOW = 2
+ GO TO 160
+ 150 CONTINUE
+ GO TO 190
+*
+* Permute rows M and I
+*
+ 160 CONTINUE
+ LSCALE( M ) = I
+ IF( I.EQ.M )
+ $ GO TO 170
+ CALL SSWAP( N-K+1, A( I, K ), LDA, A( M, K ), LDA )
+ CALL SSWAP( N-K+1, B( I, K ), LDB, B( M, K ), LDB )
+*
+* Permute columns M and J
+*
+ 170 CONTINUE
+ RSCALE( M ) = J
+ IF( J.EQ.M )
+ $ GO TO 180
+ CALL SSWAP( L, A( 1, J ), 1, A( 1, M ), 1 )
+ CALL SSWAP( L, B( 1, J ), 1, B( 1, M ), 1 )
+*
+ 180 CONTINUE
+ GO TO ( 20, 90 )IFLOW
+*
+ 190 CONTINUE
+ ILO = K
+ IHI = L
+*
+ IF( LSAME( JOB, 'P' ) ) THEN
+ DO 195 I = ILO, IHI
+ LSCALE( I ) = ONE
+ RSCALE( I ) = ONE
+ 195 CONTINUE
+ RETURN
+ END IF
+*
+ IF( ILO.EQ.IHI )
+ $ RETURN
+*
+* Balance the submatrix in rows ILO to IHI.
+*
+ NR = IHI - ILO + 1
+ DO 200 I = ILO, IHI
+ RSCALE( I ) = ZERO
+ LSCALE( I ) = ZERO
+*
+ WORK( I ) = ZERO
+ WORK( I+N ) = ZERO
+ WORK( I+2*N ) = ZERO
+ WORK( I+3*N ) = ZERO
+ WORK( I+4*N ) = ZERO
+ WORK( I+5*N ) = ZERO
+ 200 CONTINUE
+*
+* Compute right side vector in resulting linear equations
+*
+ BASL = LOG10( SCLFAC )
+ DO 240 I = ILO, IHI
+ DO 230 J = ILO, IHI
+ TB = B( I, J )
+ TA = A( I, J )
+ IF( TA.EQ.ZERO )
+ $ GO TO 210
+ TA = LOG10( ABS( TA ) ) / BASL
+ 210 CONTINUE
+ IF( TB.EQ.ZERO )
+ $ GO TO 220
+ TB = LOG10( ABS( TB ) ) / BASL
+ 220 CONTINUE
+ WORK( I+4*N ) = WORK( I+4*N ) - TA - TB
+ WORK( J+5*N ) = WORK( J+5*N ) - TA - TB
+ 230 CONTINUE
+ 240 CONTINUE
+*
+ COEF = ONE / REAL( 2*NR )
+ COEF2 = COEF*COEF
+ COEF5 = HALF*COEF2
+ NRP2 = NR + 2
+ BETA = ZERO
+ IT = 1
+*
+* Start generalized conjugate gradient iteration
+*
+ 250 CONTINUE
+*
+ GAMMA = SDOT( NR, WORK( ILO+4*N ), 1, WORK( ILO+4*N ), 1 ) +
+ $ SDOT( NR, WORK( ILO+5*N ), 1, WORK( ILO+5*N ), 1 )
+*
+ EW = ZERO
+ EWC = ZERO
+ DO 260 I = ILO, IHI
+ EW = EW + WORK( I+4*N )
+ EWC = EWC + WORK( I+5*N )
+ 260 CONTINUE
+*
+ GAMMA = COEF*GAMMA - COEF2*( EW**2+EWC**2 ) - COEF5*( EW-EWC )**2
+ IF( GAMMA.EQ.ZERO )
+ $ GO TO 350
+ IF( IT.NE.1 )
+ $ BETA = GAMMA / PGAMMA
+ T = COEF5*( EWC-THREE*EW )
+ TC = COEF5*( EW-THREE*EWC )
+*
+ CALL SSCAL( NR, BETA, WORK( ILO ), 1 )
+ CALL SSCAL( NR, BETA, WORK( ILO+N ), 1 )
+*
+ CALL SAXPY( NR, COEF, WORK( ILO+4*N ), 1, WORK( ILO+N ), 1 )
+ CALL SAXPY( NR, COEF, WORK( ILO+5*N ), 1, WORK( ILO ), 1 )
+*
+ DO 270 I = ILO, IHI
+ WORK( I ) = WORK( I ) + TC
+ WORK( I+N ) = WORK( I+N ) + T
+ 270 CONTINUE
+*
+* Apply matrix to vector
+*
+ DO 300 I = ILO, IHI
+ KOUNT = 0
+ SUM = ZERO
+ DO 290 J = ILO, IHI
+ IF( A( I, J ).EQ.ZERO )
+ $ GO TO 280
+ KOUNT = KOUNT + 1
+ SUM = SUM + WORK( J )
+ 280 CONTINUE
+ IF( B( I, J ).EQ.ZERO )
+ $ GO TO 290
+ KOUNT = KOUNT + 1
+ SUM = SUM + WORK( J )
+ 290 CONTINUE
+ WORK( I+2*N ) = REAL( KOUNT )*WORK( I+N ) + SUM
+ 300 CONTINUE
+*
+ DO 330 J = ILO, IHI
+ KOUNT = 0
+ SUM = ZERO
+ DO 320 I = ILO, IHI
+ IF( A( I, J ).EQ.ZERO )
+ $ GO TO 310
+ KOUNT = KOUNT + 1
+ SUM = SUM + WORK( I+N )
+ 310 CONTINUE
+ IF( B( I, J ).EQ.ZERO )
+ $ GO TO 320
+ KOUNT = KOUNT + 1
+ SUM = SUM + WORK( I+N )
+ 320 CONTINUE
+ WORK( J+3*N ) = REAL( KOUNT )*WORK( J ) + SUM
+ 330 CONTINUE
+*
+ SUM = SDOT( NR, WORK( ILO+N ), 1, WORK( ILO+2*N ), 1 ) +
+ $ SDOT( NR, WORK( ILO ), 1, WORK( ILO+3*N ), 1 )
+ ALPHA = GAMMA / SUM
+*
+* Determine correction to current iteration
+*
+ CMAX = ZERO
+ DO 340 I = ILO, IHI
+ COR = ALPHA*WORK( I+N )
+ IF( ABS( COR ).GT.CMAX )
+ $ CMAX = ABS( COR )
+ LSCALE( I ) = LSCALE( I ) + COR
+ COR = ALPHA*WORK( I )
+ IF( ABS( COR ).GT.CMAX )
+ $ CMAX = ABS( COR )
+ RSCALE( I ) = RSCALE( I ) + COR
+ 340 CONTINUE
+ IF( CMAX.LT.HALF )
+ $ GO TO 350
+*
+ CALL SAXPY( NR, -ALPHA, WORK( ILO+2*N ), 1, WORK( ILO+4*N ), 1 )
+ CALL SAXPY( NR, -ALPHA, WORK( ILO+3*N ), 1, WORK( ILO+5*N ), 1 )
+*
+ PGAMMA = GAMMA
+ IT = IT + 1
+ IF( IT.LE.NRP2 )
+ $ GO TO 250
+*
+* End generalized conjugate gradient iteration
+*
+ 350 CONTINUE
+ SFMIN = SLAMCH( 'S' )
+ SFMAX = ONE / SFMIN
+ LSFMIN = INT( LOG10( SFMIN ) / BASL+ONE )
+ LSFMAX = INT( LOG10( SFMAX ) / BASL )
+ DO 360 I = ILO, IHI
+ IRAB = ISAMAX( N-ILO+1, A( I, ILO ), LDA )
+ RAB = ABS( A( I, IRAB+ILO-1 ) )
+ IRAB = ISAMAX( N-ILO+1, B( I, ILO ), LDB )
+ RAB = MAX( RAB, ABS( B( I, IRAB+ILO-1 ) ) )
+ LRAB = INT( LOG10( RAB+SFMIN ) / BASL+ONE )
+ IR = LSCALE( I ) + SIGN( HALF, LSCALE( I ) )
+ IR = MIN( MAX( IR, LSFMIN ), LSFMAX, LSFMAX-LRAB )
+ LSCALE( I ) = SCLFAC**IR
+ ICAB = ISAMAX( IHI, A( 1, I ), 1 )
+ CAB = ABS( A( ICAB, I ) )
+ ICAB = ISAMAX( IHI, B( 1, I ), 1 )
+ CAB = MAX( CAB, ABS( B( ICAB, I ) ) )
+ LCAB = INT( LOG10( CAB+SFMIN ) / BASL+ONE )
+ JC = RSCALE( I ) + SIGN( HALF, RSCALE( I ) )
+ JC = MIN( MAX( JC, LSFMIN ), LSFMAX, LSFMAX-LCAB )
+ RSCALE( I ) = SCLFAC**JC
+ 360 CONTINUE
+*
+* Row scaling of matrices A and B
+*
+ DO 370 I = ILO, IHI
+ CALL SSCAL( N-ILO+1, LSCALE( I ), A( I, ILO ), LDA )
+ CALL SSCAL( N-ILO+1, LSCALE( I ), B( I, ILO ), LDB )
+ 370 CONTINUE
+*
+* Column scaling of matrices A and B
+*
+ DO 380 J = ILO, IHI
+ CALL SSCAL( IHI, RSCALE( J ), A( 1, J ), 1 )
+ CALL SSCAL( IHI, RSCALE( J ), B( 1, J ), 1 )
+ 380 CONTINUE
+*
+ RETURN
+*
+* End of SGGBAL
+*
+ END
+ SUBROUTINE SGGES( JOBVSL, JOBVSR, SORT, SELCTG, N, A, LDA, B, LDB,
+ $ SDIM, ALPHAR, ALPHAI, BETA, VSL, LDVSL, VSR,
+ $ LDVSR, WORK, LWORK, BWORK, INFO )
+*
+* -- LAPACK driver routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER JOBVSL, JOBVSR, SORT
+ INTEGER INFO, LDA, LDB, LDVSL, LDVSR, LWORK, N, SDIM
+* ..
+* .. Array Arguments ..
+ LOGICAL BWORK( * )
+ REAL A( LDA, * ), ALPHAI( * ), ALPHAR( * ),
+ $ B( LDB, * ), BETA( * ), VSL( LDVSL, * ),
+ $ VSR( LDVSR, * ), WORK( * )
+* ..
+* .. Function Arguments ..
+ LOGICAL SELCTG
+ EXTERNAL SELCTG
+* ..
+*
+* Purpose
+* =======
+*
+* SGGES computes for a pair of N-by-N real nonsymmetric matrices (A,B),
+* the generalized eigenvalues, the generalized real Schur form (S,T),
+* optionally, the left and/or right matrices of Schur vectors (VSL and
+* VSR). This gives the generalized Schur factorization
+*
+* (A,B) = ( (VSL)*S*(VSR)**T, (VSL)*T*(VSR)**T )
+*
+* Optionally, it also orders the eigenvalues so that a selected cluster
+* of eigenvalues appears in the leading diagonal blocks of the upper
+* quasi-triangular matrix S and the upper triangular matrix T.The
+* leading columns of VSL and VSR then form an orthonormal basis for the
+* corresponding left and right eigenspaces (deflating subspaces).
+*
+* (If only the generalized eigenvalues are needed, use the driver
+* SGGEV instead, which is faster.)
+*
+* A generalized eigenvalue for a pair of matrices (A,B) is a scalar w
+* or a ratio alpha/beta = w, such that A - w*B is singular. It is
+* usually represented as the pair (alpha,beta), as there is a
+* reasonable interpretation for beta=0 or both being zero.
+*
+* A pair of matrices (S,T) is in generalized real Schur form if T is
+* upper triangular with non-negative diagonal and S is block upper
+* triangular with 1-by-1 and 2-by-2 blocks. 1-by-1 blocks correspond
+* to real generalized eigenvalues, while 2-by-2 blocks of S will be
+* "standardized" by making the corresponding elements of T have the
+* form:
+* [ a 0 ]
+* [ 0 b ]
+*
+* and the pair of corresponding 2-by-2 blocks in S and T will have a
+* complex conjugate pair of generalized eigenvalues.
+*
+*
+* Arguments
+* =========
+*
+* JOBVSL (input) CHARACTER*1
+* = 'N': do not compute the left Schur vectors;
+* = 'V': compute the left Schur vectors.
+*
+* JOBVSR (input) CHARACTER*1
+* = 'N': do not compute the right Schur vectors;
+* = 'V': compute the right Schur vectors.
+*
+* SORT (input) CHARACTER*1
+* Specifies whether or not to order the eigenvalues on the
+* diagonal of the generalized Schur form.
+* = 'N': Eigenvalues are not ordered;
+* = 'S': Eigenvalues are ordered (see SELCTG);
+*
+* SELCTG (external procedure) LOGICAL FUNCTION of three REAL arguments
+* SELCTG must be declared EXTERNAL in the calling subroutine.
+* If SORT = 'N', SELCTG is not referenced.
+* If SORT = 'S', SELCTG is used to select eigenvalues to sort
+* to the top left of the Schur form.
+* An eigenvalue (ALPHAR(j)+ALPHAI(j))/BETA(j) is selected if
+* SELCTG(ALPHAR(j),ALPHAI(j),BETA(j)) is true; i.e. if either
+* one of a complex conjugate pair of eigenvalues is selected,
+* then both complex eigenvalues are selected.
+*
+* Note that in the ill-conditioned case, a selected complex
+* eigenvalue may no longer satisfy SELCTG(ALPHAR(j),ALPHAI(j),
+* BETA(j)) = .TRUE. after ordering. INFO is to be set to N+2
+* in this case.
+*
+* N (input) INTEGER
+* The order of the matrices A, B, VSL, and VSR. N >= 0.
+*
+* A (input/output) REAL array, dimension (LDA, N)
+* On entry, the first of the pair of matrices.
+* On exit, A has been overwritten by its generalized Schur
+* form S.
+*
+* LDA (input) INTEGER
+* The leading dimension of A. LDA >= max(1,N).
+*
+* B (input/output) REAL array, dimension (LDB, N)
+* On entry, the second of the pair of matrices.
+* On exit, B has been overwritten by its generalized Schur
+* form T.
+*
+* LDB (input) INTEGER
+* The leading dimension of B. LDB >= max(1,N).
+*
+* SDIM (output) INTEGER
+* If SORT = 'N', SDIM = 0.
+* If SORT = 'S', SDIM = number of eigenvalues (after sorting)
+* for which SELCTG is true. (Complex conjugate pairs for which
+* SELCTG is true for either eigenvalue count as 2.)
+*
+* ALPHAR (output) REAL array, dimension (N)
+* ALPHAI (output) REAL array, dimension (N)
+* BETA (output) REAL array, dimension (N)
+* On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, will
+* be the generalized eigenvalues. ALPHAR(j) + ALPHAI(j)*i,
+* and BETA(j),j=1,...,N are the diagonals of the complex Schur
+* form (S,T) that would result if the 2-by-2 diagonal blocks of
+* the real Schur form of (A,B) were further reduced to
+* triangular form using 2-by-2 complex unitary transformations.
+* If ALPHAI(j) is zero, then the j-th eigenvalue is real; if
+* positive, then the j-th and (j+1)-st eigenvalues are a
+* complex conjugate pair, with ALPHAI(j+1) negative.
+*
+* Note: the quotients ALPHAR(j)/BETA(j) and ALPHAI(j)/BETA(j)
+* may easily over- or underflow, and BETA(j) may even be zero.
+* Thus, the user should avoid naively computing the ratio.
+* However, ALPHAR and ALPHAI will be always less than and
+* usually comparable with norm(A) in magnitude, and BETA always
+* less than and usually comparable with norm(B).
+*
+* VSL (output) REAL array, dimension (LDVSL,N)
+* If JOBVSL = 'V', VSL will contain the left Schur vectors.
+* Not referenced if JOBVSL = 'N'.
+*
+* LDVSL (input) INTEGER
+* The leading dimension of the matrix VSL. LDVSL >=1, and
+* if JOBVSL = 'V', LDVSL >= N.
+*
+* VSR (output) REAL array, dimension (LDVSR,N)
+* If JOBVSR = 'V', VSR will contain the right Schur vectors.
+* Not referenced if JOBVSR = 'N'.
+*
+* LDVSR (input) INTEGER
+* The leading dimension of the matrix VSR. LDVSR >= 1, and
+* if JOBVSR = 'V', LDVSR >= N.
+*
+* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))
+* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+* LWORK (input) INTEGER
+* The dimension of the array WORK.
+* If N = 0, LWORK >= 1, else LWORK >= max(8*N,6*N+16).
+* For good performance , LWORK must generally be larger.
+*
+* If LWORK = -1, then a workspace query is assumed; the routine
+* only calculates the optimal size of the WORK array, returns
+* this value as the first entry of the WORK array, and no error
+* message related to LWORK is issued by XERBLA.
+*
+* BWORK (workspace) LOGICAL array, dimension (N)
+* Not referenced if SORT = 'N'.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value.
+* = 1,...,N:
+* The QZ iteration failed. (A,B) are not in Schur
+* form, but ALPHAR(j), ALPHAI(j), and BETA(j) should
+* be correct for j=INFO+1,...,N.
+* > N: =N+1: other than QZ iteration failed in SHGEQZ.
+* =N+2: after reordering, roundoff changed values of
+* some complex eigenvalues so that leading
+* eigenvalues in the Generalized Schur form no
+* longer satisfy SELCTG=.TRUE. This could also
+* be caused due to scaling.
+* =N+3: reordering failed in STGSEN.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO, ONE
+ PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL CURSL, ILASCL, ILBSCL, ILVSL, ILVSR, LASTSL,
+ $ LQUERY, LST2SL, WANTST
+ INTEGER I, ICOLS, IERR, IHI, IJOBVL, IJOBVR, ILEFT,
+ $ ILO, IP, IRIGHT, IROWS, ITAU, IWRK, MAXWRK,
+ $ MINWRK
+ REAL ANRM, ANRMTO, BIGNUM, BNRM, BNRMTO, EPS, PVSL,
+ $ PVSR, SAFMAX, SAFMIN, SMLNUM
+* ..
+* .. Local Arrays ..
+ INTEGER IDUM( 1 )
+ REAL DIF( 2 )
+* ..
+* .. External Subroutines ..
+ EXTERNAL SGEQRF, SGGBAK, SGGBAL, SGGHRD, SHGEQZ, SLABAD,
+ $ SLACPY, SLASCL, SLASET, SORGQR, SORMQR, STGSEN,
+ $ XERBLA
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ILAENV
+ REAL SLAMCH, SLANGE
+ EXTERNAL LSAME, ILAENV, SLAMCH, SLANGE
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, SQRT
+* ..
+* .. Executable Statements ..
+*
+* Decode the input arguments
+*
+ IF( LSAME( JOBVSL, 'N' ) ) THEN
+ IJOBVL = 1
+ ILVSL = .FALSE.
+ ELSE IF( LSAME( JOBVSL, 'V' ) ) THEN
+ IJOBVL = 2
+ ILVSL = .TRUE.
+ ELSE
+ IJOBVL = -1
+ ILVSL = .FALSE.
+ END IF
+*
+ IF( LSAME( JOBVSR, 'N' ) ) THEN
+ IJOBVR = 1
+ ILVSR = .FALSE.
+ ELSE IF( LSAME( JOBVSR, 'V' ) ) THEN
+ IJOBVR = 2
+ ILVSR = .TRUE.
+ ELSE
+ IJOBVR = -1
+ ILVSR = .FALSE.
+ END IF
+*
+ WANTST = LSAME( SORT, 'S' )
+*
+* Test the input arguments
+*
+ INFO = 0
+ LQUERY = ( LWORK.EQ.-1 )
+ IF( IJOBVL.LE.0 ) THEN
+ INFO = -1
+ ELSE IF( IJOBVR.LE.0 ) THEN
+ INFO = -2
+ ELSE IF( ( .NOT.WANTST ) .AND. ( .NOT.LSAME( SORT, 'N' ) ) ) THEN
+ INFO = -3
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -5
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -7
+ ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -9
+ ELSE IF( LDVSL.LT.1 .OR. ( ILVSL .AND. LDVSL.LT.N ) ) THEN
+ INFO = -15
+ ELSE IF( LDVSR.LT.1 .OR. ( ILVSR .AND. LDVSR.LT.N ) ) THEN
+ INFO = -17
+ END IF
+*
+* Compute workspace
+* (Note: Comments in the code beginning "Workspace:" describe the
+* minimal amount of workspace needed at that point in the code,
+* as well as the preferred amount for good performance.
+* NB refers to the optimal block size for the immediately
+* following subroutine, as returned by ILAENV.)
+*
+ IF( INFO.EQ.0 ) THEN
+ IF( N.GT.0 )THEN
+ MINWRK = MAX( 8*N, 6*N + 16 )
+ MAXWRK = MINWRK - N +
+ $ N*ILAENV( 1, 'SGEQRF', ' ', N, 1, N, 0 )
+ MAXWRK = MAX( MAXWRK, MINWRK - N +
+ $ N*ILAENV( 1, 'SORMQR', ' ', N, 1, N, -1 ) )
+ IF( ILVSL ) THEN
+ MAXWRK = MAX( MAXWRK, MINWRK - N +
+ $ N*ILAENV( 1, 'SORGQR', ' ', N, 1, N, -1 ) )
+ END IF
+ ELSE
+ MINWRK = 1
+ MAXWRK = 1
+ END IF
+ WORK( 1 ) = MAXWRK
+*
+ IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY )
+ $ INFO = -19
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SGGES ', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 ) THEN
+ SDIM = 0
+ RETURN
+ END IF
+*
+* Get machine constants
+*
+ EPS = SLAMCH( 'P' )
+ SAFMIN = SLAMCH( 'S' )
+ SAFMAX = ONE / SAFMIN
+ CALL SLABAD( SAFMIN, SAFMAX )
+ SMLNUM = SQRT( SAFMIN ) / EPS
+ BIGNUM = ONE / SMLNUM
+*
+* Scale A if max element outside range [SMLNUM,BIGNUM]
+*
+ ANRM = SLANGE( 'M', N, N, A, LDA, WORK )
+ ILASCL = .FALSE.
+ IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
+ ANRMTO = SMLNUM
+ ILASCL = .TRUE.
+ ELSE IF( ANRM.GT.BIGNUM ) THEN
+ ANRMTO = BIGNUM
+ ILASCL = .TRUE.
+ END IF
+ IF( ILASCL )
+ $ CALL SLASCL( 'G', 0, 0, ANRM, ANRMTO, N, N, A, LDA, IERR )
+*
+* Scale B if max element outside range [SMLNUM,BIGNUM]
+*
+ BNRM = SLANGE( 'M', N, N, B, LDB, WORK )
+ ILBSCL = .FALSE.
+ IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN
+ BNRMTO = SMLNUM
+ ILBSCL = .TRUE.
+ ELSE IF( BNRM.GT.BIGNUM ) THEN
+ BNRMTO = BIGNUM
+ ILBSCL = .TRUE.
+ END IF
+ IF( ILBSCL )
+ $ CALL SLASCL( 'G', 0, 0, BNRM, BNRMTO, N, N, B, LDB, IERR )
+*
+* Permute the matrix to make it more nearly triangular
+* (Workspace: need 6*N + 2*N space for storing balancing factors)
+*
+ ILEFT = 1
+ IRIGHT = N + 1
+ IWRK = IRIGHT + N
+ CALL SGGBAL( 'P', N, A, LDA, B, LDB, ILO, IHI, WORK( ILEFT ),
+ $ WORK( IRIGHT ), WORK( IWRK ), IERR )
+*
+* Reduce B to triangular form (QR decomposition of B)
+* (Workspace: need N, prefer N*NB)
+*
+ IROWS = IHI + 1 - ILO
+ ICOLS = N + 1 - ILO
+ ITAU = IWRK
+ IWRK = ITAU + IROWS
+ CALL SGEQRF( IROWS, ICOLS, B( ILO, ILO ), LDB, WORK( ITAU ),
+ $ WORK( IWRK ), LWORK+1-IWRK, IERR )
+*
+* Apply the orthogonal transformation to matrix A
+* (Workspace: need N, prefer N*NB)
+*
+ CALL SORMQR( 'L', 'T', IROWS, ICOLS, IROWS, B( ILO, ILO ), LDB,
+ $ WORK( ITAU ), A( ILO, ILO ), LDA, WORK( IWRK ),
+ $ LWORK+1-IWRK, IERR )
+*
+* Initialize VSL
+* (Workspace: need N, prefer N*NB)
+*
+ IF( ILVSL ) THEN
+ CALL SLASET( 'Full', N, N, ZERO, ONE, VSL, LDVSL )
+ IF( IROWS.GT.1 ) THEN
+ CALL SLACPY( 'L', IROWS-1, IROWS-1, B( ILO+1, ILO ), LDB,
+ $ VSL( ILO+1, ILO ), LDVSL )
+ END IF
+ CALL SORGQR( IROWS, IROWS, IROWS, VSL( ILO, ILO ), LDVSL,
+ $ WORK( ITAU ), WORK( IWRK ), LWORK+1-IWRK, IERR )
+ END IF
+*
+* Initialize VSR
+*
+ IF( ILVSR )
+ $ CALL SLASET( 'Full', N, N, ZERO, ONE, VSR, LDVSR )
+*
+* Reduce to generalized Hessenberg form
+* (Workspace: none needed)
+*
+ CALL SGGHRD( JOBVSL, JOBVSR, N, ILO, IHI, A, LDA, B, LDB, VSL,
+ $ LDVSL, VSR, LDVSR, IERR )
+*
+* Perform QZ algorithm, computing Schur vectors if desired
+* (Workspace: need N)
+*
+ IWRK = ITAU
+ CALL SHGEQZ( 'S', JOBVSL, JOBVSR, N, ILO, IHI, A, LDA, B, LDB,
+ $ ALPHAR, ALPHAI, BETA, VSL, LDVSL, VSR, LDVSR,
+ $ WORK( IWRK ), LWORK+1-IWRK, IERR )
+ IF( IERR.NE.0 ) THEN
+ IF( IERR.GT.0 .AND. IERR.LE.N ) THEN
+ INFO = IERR
+ ELSE IF( IERR.GT.N .AND. IERR.LE.2*N ) THEN
+ INFO = IERR - N
+ ELSE
+ INFO = N + 1
+ END IF
+ GO TO 40
+ END IF
+*
+* Sort eigenvalues ALPHA/BETA if desired
+* (Workspace: need 4*N+16 )
+*
+ SDIM = 0
+ IF( WANTST ) THEN
+*
+* Undo scaling on eigenvalues before SELCTGing
+*
+ IF( ILASCL ) THEN
+ CALL SLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHAR, N,
+ $ IERR )
+ CALL SLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHAI, N,
+ $ IERR )
+ END IF
+ IF( ILBSCL )
+ $ CALL SLASCL( 'G', 0, 0, BNRMTO, BNRM, N, 1, BETA, N, IERR )
+*
+* Select eigenvalues
+*
+ DO 10 I = 1, N
+ BWORK( I ) = SELCTG( ALPHAR( I ), ALPHAI( I ), BETA( I ) )
+ 10 CONTINUE
+*
+ CALL STGSEN( 0, ILVSL, ILVSR, BWORK, N, A, LDA, B, LDB, ALPHAR,
+ $ ALPHAI, BETA, VSL, LDVSL, VSR, LDVSR, SDIM, PVSL,
+ $ PVSR, DIF, WORK( IWRK ), LWORK-IWRK+1, IDUM, 1,
+ $ IERR )
+ IF( IERR.EQ.1 )
+ $ INFO = N + 3
+*
+ END IF
+*
+* Apply back-permutation to VSL and VSR
+* (Workspace: none needed)
+*
+ IF( ILVSL )
+ $ CALL SGGBAK( 'P', 'L', N, ILO, IHI, WORK( ILEFT ),
+ $ WORK( IRIGHT ), N, VSL, LDVSL, IERR )
+*
+ IF( ILVSR )
+ $ CALL SGGBAK( 'P', 'R', N, ILO, IHI, WORK( ILEFT ),
+ $ WORK( IRIGHT ), N, VSR, LDVSR, IERR )
+*
+* Check if unscaling would cause over/underflow, if so, rescale
+* (ALPHAR(I),ALPHAI(I),BETA(I)) so BETA(I) is on the order of
+* B(I,I) and ALPHAR(I) and ALPHAI(I) are on the order of A(I,I)
+*
+ IF( ILASCL )THEN
+ DO 50 I = 1, N
+ IF( ALPHAI( I ).NE.ZERO ) THEN
+ IF( ( ALPHAR( I )/SAFMAX ).GT.( ANRMTO/ANRM ) .OR.
+ $ ( SAFMIN/ALPHAR( I ) ).GT.( ANRM/ANRMTO ) ) THEN
+ WORK( 1 ) = ABS( A( I, I )/ALPHAR( I ) )
+ BETA( I ) = BETA( I )*WORK( 1 )
+ ALPHAR( I ) = ALPHAR( I )*WORK( 1 )
+ ALPHAI( I ) = ALPHAI( I )*WORK( 1 )
+ ELSE IF( ( ALPHAI( I )/SAFMAX ).GT.( ANRMTO/ANRM ) .OR.
+ $ ( SAFMIN/ALPHAI( I ) ).GT.( ANRM/ANRMTO ) ) THEN
+ WORK( 1 ) = ABS( A( I, I+1 )/ALPHAI( I ) )
+ BETA( I ) = BETA( I )*WORK( 1 )
+ ALPHAR( I ) = ALPHAR( I )*WORK( 1 )
+ ALPHAI( I ) = ALPHAI( I )*WORK( 1 )
+ END IF
+ END IF
+ 50 CONTINUE
+ END IF
+*
+ IF( ILBSCL )THEN
+ DO 60 I = 1, N
+ IF( ALPHAI( I ).NE.ZERO ) THEN
+ IF( ( BETA( I )/SAFMAX ).GT.( BNRMTO/BNRM ) .OR.
+ $ ( SAFMIN/BETA( I ) ).GT.( BNRM/BNRMTO ) ) THEN
+ WORK( 1 ) = ABS(B( I, I )/BETA( I ))
+ BETA( I ) = BETA( I )*WORK( 1 )
+ ALPHAR( I ) = ALPHAR( I )*WORK( 1 )
+ ALPHAI( I ) = ALPHAI( I )*WORK( 1 )
+ END IF
+ END IF
+ 60 CONTINUE
+ END IF
+*
+* Undo scaling
+*
+ IF( ILASCL ) THEN
+ CALL SLASCL( 'H', 0, 0, ANRMTO, ANRM, N, N, A, LDA, IERR )
+ CALL SLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHAR, N, IERR )
+ CALL SLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHAI, N, IERR )
+ END IF
+*
+ IF( ILBSCL ) THEN
+ CALL SLASCL( 'U', 0, 0, BNRMTO, BNRM, N, N, B, LDB, IERR )
+ CALL SLASCL( 'G', 0, 0, BNRMTO, BNRM, N, 1, BETA, N, IERR )
+ END IF
+*
+ IF( WANTST ) THEN
+*
+* Check if reordering is correct
+*
+ LASTSL = .TRUE.
+ LST2SL = .TRUE.
+ SDIM = 0
+ IP = 0
+ DO 30 I = 1, N
+ CURSL = SELCTG( ALPHAR( I ), ALPHAI( I ), BETA( I ) )
+ IF( ALPHAI( I ).EQ.ZERO ) THEN
+ IF( CURSL )
+ $ SDIM = SDIM + 1
+ IP = 0
+ IF( CURSL .AND. .NOT.LASTSL )
+ $ INFO = N + 2
+ ELSE
+ IF( IP.EQ.1 ) THEN
+*
+* Last eigenvalue of conjugate pair
+*
+ CURSL = CURSL .OR. LASTSL
+ LASTSL = CURSL
+ IF( CURSL )
+ $ SDIM = SDIM + 2
+ IP = -1
+ IF( CURSL .AND. .NOT.LST2SL )
+ $ INFO = N + 2
+ ELSE
+*
+* First eigenvalue of conjugate pair
+*
+ IP = 1
+ END IF
+ END IF
+ LST2SL = LASTSL
+ LASTSL = CURSL
+ 30 CONTINUE
+*
+ END IF
+*
+ 40 CONTINUE
+*
+ WORK( 1 ) = MAXWRK
+*
+ RETURN
+*
+* End of SGGES
+*
+ END
+ 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 )
+*
+* -- LAPACK driver routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER JOBVSL, JOBVSR, SENSE, SORT
+ INTEGER INFO, LDA, LDB, LDVSL, LDVSR, LIWORK, LWORK, N,
+ $ SDIM
+* ..
+* .. Array Arguments ..
+ LOGICAL BWORK( * )
+ INTEGER IWORK( * )
+ REAL A( LDA, * ), ALPHAI( * ), ALPHAR( * ),
+ $ B( LDB, * ), BETA( * ), RCONDE( 2 ),
+ $ RCONDV( 2 ), VSL( LDVSL, * ), VSR( LDVSR, * ),
+ $ WORK( * )
+* ..
+* .. Function Arguments ..
+ LOGICAL SELCTG
+ EXTERNAL SELCTG
+* ..
+*
+* Purpose
+* =======
+*
+* SGGESX computes for a pair of N-by-N real nonsymmetric matrices
+* (A,B), the generalized eigenvalues, the real Schur form (S,T), and,
+* optionally, the left and/or right matrices of Schur vectors (VSL and
+* VSR). This gives the generalized Schur factorization
+*
+* (A,B) = ( (VSL) S (VSR)**T, (VSL) T (VSR)**T )
+*
+* Optionally, it also orders the eigenvalues so that a selected cluster
+* of eigenvalues appears in the leading diagonal blocks of the upper
+* quasi-triangular matrix S and the upper triangular matrix T; computes
+* a reciprocal condition number for the average of the selected
+* eigenvalues (RCONDE); and computes a reciprocal condition number for
+* the right and left deflating subspaces corresponding to the selected
+* eigenvalues (RCONDV). The leading columns of VSL and VSR then form
+* an orthonormal basis for the corresponding left and right eigenspaces
+* (deflating subspaces).
+*
+* A generalized eigenvalue for a pair of matrices (A,B) is a scalar w
+* or a ratio alpha/beta = w, such that A - w*B is singular. It is
+* usually represented as the pair (alpha,beta), as there is a
+* reasonable interpretation for beta=0 or for both being zero.
+*
+* A pair of matrices (S,T) is in generalized real Schur form if T is
+* upper triangular with non-negative diagonal and S is block upper
+* triangular with 1-by-1 and 2-by-2 blocks. 1-by-1 blocks correspond
+* to real generalized eigenvalues, while 2-by-2 blocks of S will be
+* "standardized" by making the corresponding elements of T have the
+* form:
+* [ a 0 ]
+* [ 0 b ]
+*
+* and the pair of corresponding 2-by-2 blocks in S and T will have a
+* complex conjugate pair of generalized eigenvalues.
+*
+*
+* Arguments
+* =========
+*
+* JOBVSL (input) CHARACTER*1
+* = 'N': do not compute the left Schur vectors;
+* = 'V': compute the left Schur vectors.
+*
+* JOBVSR (input) CHARACTER*1
+* = 'N': do not compute the right Schur vectors;
+* = 'V': compute the right Schur vectors.
+*
+* SORT (input) CHARACTER*1
+* Specifies whether or not to order the eigenvalues on the
+* diagonal of the generalized Schur form.
+* = 'N': Eigenvalues are not ordered;
+* = 'S': Eigenvalues are ordered (see SELCTG).
+*
+* SELCTG (external procedure) LOGICAL FUNCTION of three REAL arguments
+* SELCTG must be declared EXTERNAL in the calling subroutine.
+* If SORT = 'N', SELCTG is not referenced.
+* If SORT = 'S', SELCTG is used to select eigenvalues to sort
+* to the top left of the Schur form.
+* An eigenvalue (ALPHAR(j)+ALPHAI(j))/BETA(j) is selected if
+* SELCTG(ALPHAR(j),ALPHAI(j),BETA(j)) is true; i.e. if either
+* one of a complex conjugate pair of eigenvalues is selected,
+* then both complex eigenvalues are selected.
+* Note that a selected complex eigenvalue may no longer satisfy
+* SELCTG(ALPHAR(j),ALPHAI(j),BETA(j)) = .TRUE. after ordering,
+* since ordering may change the value of complex eigenvalues
+* (especially if the eigenvalue is ill-conditioned), in this
+* case INFO is set to N+3.
+*
+* SENSE (input) CHARACTER*1
+* Determines which reciprocal condition numbers are computed.
+* = 'N' : None are computed;
+* = 'E' : Computed for average of selected eigenvalues only;
+* = 'V' : Computed for selected deflating subspaces only;
+* = 'B' : Computed for both.
+* If SENSE = 'E', 'V', or 'B', SORT must equal 'S'.
+*
+* N (input) INTEGER
+* The order of the matrices A, B, VSL, and VSR. N >= 0.
+*
+* A (input/output) REAL array, dimension (LDA, N)
+* On entry, the first of the pair of matrices.
+* On exit, A has been overwritten by its generalized Schur
+* form S.
+*
+* LDA (input) INTEGER
+* The leading dimension of A. LDA >= max(1,N).
+*
+* B (input/output) REAL array, dimension (LDB, N)
+* On entry, the second of the pair of matrices.
+* On exit, B has been overwritten by its generalized Schur
+* form T.
+*
+* LDB (input) INTEGER
+* The leading dimension of B. LDB >= max(1,N).
+*
+* SDIM (output) INTEGER
+* If SORT = 'N', SDIM = 0.
+* If SORT = 'S', SDIM = number of eigenvalues (after sorting)
+* for which SELCTG is true. (Complex conjugate pairs for which
+* SELCTG is true for either eigenvalue count as 2.)
+*
+* ALPHAR (output) REAL array, dimension (N)
+* ALPHAI (output) REAL array, dimension (N)
+* BETA (output) REAL array, dimension (N)
+* On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, will
+* be the generalized eigenvalues. ALPHAR(j) + ALPHAI(j)*i
+* and BETA(j),j=1,...,N are the diagonals of the complex Schur
+* form (S,T) that would result if the 2-by-2 diagonal blocks of
+* the real Schur form of (A,B) were further reduced to
+* triangular form using 2-by-2 complex unitary transformations.
+* If ALPHAI(j) is zero, then the j-th eigenvalue is real; if
+* positive, then the j-th and (j+1)-st eigenvalues are a
+* complex conjugate pair, with ALPHAI(j+1) negative.
+*
+* Note: the quotients ALPHAR(j)/BETA(j) and ALPHAI(j)/BETA(j)
+* may easily over- or underflow, and BETA(j) may even be zero.
+* Thus, the user should avoid naively computing the ratio.
+* However, ALPHAR and ALPHAI will be always less than and
+* usually comparable with norm(A) in magnitude, and BETA always
+* less than and usually comparable with norm(B).
+*
+* VSL (output) REAL array, dimension (LDVSL,N)
+* If JOBVSL = 'V', VSL will contain the left Schur vectors.
+* Not referenced if JOBVSL = 'N'.
+*
+* LDVSL (input) INTEGER
+* The leading dimension of the matrix VSL. LDVSL >=1, and
+* if JOBVSL = 'V', LDVSL >= N.
+*
+* VSR (output) REAL array, dimension (LDVSR,N)
+* If JOBVSR = 'V', VSR will contain the right Schur vectors.
+* Not referenced if JOBVSR = 'N'.
+*
+* LDVSR (input) INTEGER
+* The leading dimension of the matrix VSR. LDVSR >= 1, and
+* if JOBVSR = 'V', LDVSR >= N.
+*
+* RCONDE (output) REAL array, dimension ( 2 )
+* If SENSE = 'E' or 'B', RCONDE(1) and RCONDE(2) contain the
+* reciprocal condition numbers for the average of the selected
+* eigenvalues.
+* Not referenced if SENSE = 'N' or 'V'.
+*
+* RCONDV (output) REAL array, dimension ( 2 )
+* If SENSE = 'V' or 'B', RCONDV(1) and RCONDV(2) contain the
+* reciprocal condition numbers for the selected deflating
+* subspaces.
+* Not referenced if SENSE = 'N' or 'E'.
+*
+* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))
+* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+* LWORK (input) INTEGER
+* The dimension of the array WORK.
+* If N = 0, LWORK >= 1, else if SENSE = 'E', 'V', or 'B',
+* LWORK >= max( 8*N, 6*N+16, 2*SDIM*(N-SDIM) ), else
+* LWORK >= max( 8*N, 6*N+16 ).
+* Note that 2*SDIM*(N-SDIM) <= N*N/2.
+* Note also that an error is only returned if
+* LWORK < max( 8*N, 6*N+16), but if SENSE = 'E' or 'V' or 'B'
+* this may not be large enough.
+*
+* If LWORK = -1, then a workspace query is assumed; the routine
+* only calculates the bound on the optimal size of the WORK
+* array and the minimum size of the IWORK array, returns these
+* values as the first entries of the WORK and IWORK arrays, and
+* no error message related to LWORK or LIWORK is issued by
+* XERBLA.
+*
+* IWORK (workspace) INTEGER array, dimension (MAX(1,LIWORK))
+* On exit, if INFO = 0, IWORK(1) returns the minimum LIWORK.
+*
+* LIWORK (input) INTEGER
+* The dimension of the array IWORK.
+* If SENSE = 'N' or N = 0, LIWORK >= 1, otherwise
+* LIWORK >= N+6.
+*
+* If LIWORK = -1, then a workspace query is assumed; the
+* routine only calculates the bound on the optimal size of the
+* WORK array and the minimum size of the IWORK array, returns
+* these values as the first entries of the WORK and IWORK
+* arrays, and no error message related to LWORK or LIWORK is
+* issued by XERBLA.
+*
+* BWORK (workspace) LOGICAL array, dimension (N)
+* Not referenced if SORT = 'N'.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value.
+* = 1,...,N:
+* The QZ iteration failed. (A,B) are not in Schur
+* form, but ALPHAR(j), ALPHAI(j), and BETA(j) should
+* be correct for j=INFO+1,...,N.
+* > N: =N+1: other than QZ iteration failed in SHGEQZ
+* =N+2: after reordering, roundoff changed values of
+* some complex eigenvalues so that leading
+* eigenvalues in the Generalized Schur form no
+* longer satisfy SELCTG=.TRUE. This could also
+* be caused due to scaling.
+* =N+3: reordering failed in STGSEN.
+*
+* Further details
+* ===============
+*
+* An approximate (asymptotic) bound on the average absolute error of
+* the selected eigenvalues is
+*
+* EPS * norm((A, B)) / RCONDE( 1 ).
+*
+* An approximate (asymptotic) bound on the maximum angular error in
+* the computed deflating subspaces is
+*
+* EPS * norm((A, B)) / RCONDV( 2 ).
+*
+* See LAPACK User's Guide, section 4.11 for more information.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO, ONE
+ PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL CURSL, ILASCL, ILBSCL, ILVSL, ILVSR, LASTSL,
+ $ LQUERY, LST2SL, WANTSB, WANTSE, WANTSN, WANTST,
+ $ WANTSV
+ INTEGER I, ICOLS, IERR, IHI, IJOB, IJOBVL, IJOBVR,
+ $ ILEFT, ILO, IP, IRIGHT, IROWS, ITAU, IWRK,
+ $ LIWMIN, LWRK, MAXWRK, MINWRK
+ REAL ANRM, ANRMTO, BIGNUM, BNRM, BNRMTO, EPS, PL,
+ $ PR, SAFMAX, SAFMIN, SMLNUM
+* ..
+* .. Local Arrays ..
+ REAL DIF( 2 )
+* ..
+* .. External Subroutines ..
+ EXTERNAL SGEQRF, SGGBAK, SGGBAL, SGGHRD, SHGEQZ, SLABAD,
+ $ SLACPY, SLASCL, SLASET, SORGQR, SORMQR, STGSEN,
+ $ XERBLA
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ILAENV
+ REAL SLAMCH, SLANGE
+ EXTERNAL LSAME, ILAENV, SLAMCH, SLANGE
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, SQRT
+* ..
+* .. Executable Statements ..
+*
+* Decode the input arguments
+*
+ IF( LSAME( JOBVSL, 'N' ) ) THEN
+ IJOBVL = 1
+ ILVSL = .FALSE.
+ ELSE IF( LSAME( JOBVSL, 'V' ) ) THEN
+ IJOBVL = 2
+ ILVSL = .TRUE.
+ ELSE
+ IJOBVL = -1
+ ILVSL = .FALSE.
+ END IF
+*
+ IF( LSAME( JOBVSR, 'N' ) ) THEN
+ IJOBVR = 1
+ ILVSR = .FALSE.
+ ELSE IF( LSAME( JOBVSR, 'V' ) ) THEN
+ IJOBVR = 2
+ ILVSR = .TRUE.
+ ELSE
+ IJOBVR = -1
+ ILVSR = .FALSE.
+ END IF
+*
+ WANTST = LSAME( SORT, 'S' )
+ WANTSN = LSAME( SENSE, 'N' )
+ WANTSE = LSAME( SENSE, 'E' )
+ WANTSV = LSAME( SENSE, 'V' )
+ WANTSB = LSAME( SENSE, 'B' )
+ LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 )
+ IF( WANTSN ) THEN
+ IJOB = 0
+ ELSE IF( WANTSE ) THEN
+ IJOB = 1
+ ELSE IF( WANTSV ) THEN
+ IJOB = 2
+ ELSE IF( WANTSB ) THEN
+ IJOB = 4
+ END IF
+*
+* Test the input arguments
+*
+ INFO = 0
+ IF( IJOBVL.LE.0 ) THEN
+ INFO = -1
+ ELSE IF( IJOBVR.LE.0 ) THEN
+ INFO = -2
+ ELSE IF( ( .NOT.WANTST ) .AND. ( .NOT.LSAME( SORT, 'N' ) ) ) THEN
+ INFO = -3
+ ELSE IF( .NOT.( WANTSN .OR. WANTSE .OR. WANTSV .OR. WANTSB ) .OR.
+ $ ( .NOT.WANTST .AND. .NOT.WANTSN ) ) THEN
+ INFO = -5
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -6
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -8
+ ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -10
+ ELSE IF( LDVSL.LT.1 .OR. ( ILVSL .AND. LDVSL.LT.N ) ) THEN
+ INFO = -16
+ ELSE IF( LDVSR.LT.1 .OR. ( ILVSR .AND. LDVSR.LT.N ) ) THEN
+ INFO = -18
+ END IF
+*
+* Compute workspace
+* (Note: Comments in the code beginning "Workspace:" describe the
+* minimal amount of workspace needed at that point in the code,
+* as well as the preferred amount for good performance.
+* NB refers to the optimal block size for the immediately
+* following subroutine, as returned by ILAENV.)
+*
+ IF( INFO.EQ.0 ) THEN
+ IF( N.GT.0) THEN
+ MINWRK = MAX( 8*N, 6*N + 16 )
+ MAXWRK = MINWRK - N +
+ $ N*ILAENV( 1, 'SGEQRF', ' ', N, 1, N, 0 )
+ MAXWRK = MAX( MAXWRK, MINWRK - N +
+ $ N*ILAENV( 1, 'SORMQR', ' ', N, 1, N, -1 ) )
+ IF( ILVSL ) THEN
+ MAXWRK = MAX( MAXWRK, MINWRK - N +
+ $ N*ILAENV( 1, 'SORGQR', ' ', N, 1, N, -1 ) )
+ END IF
+ LWRK = MAXWRK
+ IF( IJOB.GE.1 )
+ $ LWRK = MAX( LWRK, N*N/2 )
+ ELSE
+ MINWRK = 1
+ MAXWRK = 1
+ LWRK = 1
+ END IF
+ WORK( 1 ) = LWRK
+ IF( WANTSN .OR. N.EQ.0 ) THEN
+ LIWMIN = 1
+ ELSE
+ LIWMIN = N + 6
+ END IF
+ IWORK( 1 ) = LIWMIN
+*
+ IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN
+ INFO = -22
+ ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN
+ INFO = -24
+ END IF
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SGGESX', -INFO )
+ RETURN
+ ELSE IF (LQUERY) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 ) THEN
+ SDIM = 0
+ RETURN
+ END IF
+*
+* Get machine constants
+*
+ EPS = SLAMCH( 'P' )
+ SAFMIN = SLAMCH( 'S' )
+ SAFMAX = ONE / SAFMIN
+ CALL SLABAD( SAFMIN, SAFMAX )
+ SMLNUM = SQRT( SAFMIN ) / EPS
+ BIGNUM = ONE / SMLNUM
+*
+* Scale A if max element outside range [SMLNUM,BIGNUM]
+*
+ ANRM = SLANGE( 'M', N, N, A, LDA, WORK )
+ ILASCL = .FALSE.
+ IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
+ ANRMTO = SMLNUM
+ ILASCL = .TRUE.
+ ELSE IF( ANRM.GT.BIGNUM ) THEN
+ ANRMTO = BIGNUM
+ ILASCL = .TRUE.
+ END IF
+ IF( ILASCL )
+ $ CALL SLASCL( 'G', 0, 0, ANRM, ANRMTO, N, N, A, LDA, IERR )
+*
+* Scale B if max element outside range [SMLNUM,BIGNUM]
+*
+ BNRM = SLANGE( 'M', N, N, B, LDB, WORK )
+ ILBSCL = .FALSE.
+ IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN
+ BNRMTO = SMLNUM
+ ILBSCL = .TRUE.
+ ELSE IF( BNRM.GT.BIGNUM ) THEN
+ BNRMTO = BIGNUM
+ ILBSCL = .TRUE.
+ END IF
+ IF( ILBSCL )
+ $ CALL SLASCL( 'G', 0, 0, BNRM, BNRMTO, N, N, B, LDB, IERR )
+*
+* Permute the matrix to make it more nearly triangular
+* (Workspace: need 6*N + 2*N for permutation parameters)
+*
+ ILEFT = 1
+ IRIGHT = N + 1
+ IWRK = IRIGHT + N
+ CALL SGGBAL( 'P', N, A, LDA, B, LDB, ILO, IHI, WORK( ILEFT ),
+ $ WORK( IRIGHT ), WORK( IWRK ), IERR )
+*
+* Reduce B to triangular form (QR decomposition of B)
+* (Workspace: need N, prefer N*NB)
+*
+ IROWS = IHI + 1 - ILO
+ ICOLS = N + 1 - ILO
+ ITAU = IWRK
+ IWRK = ITAU + IROWS
+ CALL SGEQRF( IROWS, ICOLS, B( ILO, ILO ), LDB, WORK( ITAU ),
+ $ WORK( IWRK ), LWORK+1-IWRK, IERR )
+*
+* Apply the orthogonal transformation to matrix A
+* (Workspace: need N, prefer N*NB)
+*
+ CALL SORMQR( 'L', 'T', IROWS, ICOLS, IROWS, B( ILO, ILO ), LDB,
+ $ WORK( ITAU ), A( ILO, ILO ), LDA, WORK( IWRK ),
+ $ LWORK+1-IWRK, IERR )
+*
+* Initialize VSL
+* (Workspace: need N, prefer N*NB)
+*
+ IF( ILVSL ) THEN
+ CALL SLASET( 'Full', N, N, ZERO, ONE, VSL, LDVSL )
+ IF( IROWS.GT.1 ) THEN
+ CALL SLACPY( 'L', IROWS-1, IROWS-1, B( ILO+1, ILO ), LDB,
+ $ VSL( ILO+1, ILO ), LDVSL )
+ END IF
+ CALL SORGQR( IROWS, IROWS, IROWS, VSL( ILO, ILO ), LDVSL,
+ $ WORK( ITAU ), WORK( IWRK ), LWORK+1-IWRK, IERR )
+ END IF
+*
+* Initialize VSR
+*
+ IF( ILVSR )
+ $ CALL SLASET( 'Full', N, N, ZERO, ONE, VSR, LDVSR )
+*
+* Reduce to generalized Hessenberg form
+* (Workspace: none needed)
+*
+ CALL SGGHRD( JOBVSL, JOBVSR, N, ILO, IHI, A, LDA, B, LDB, VSL,
+ $ LDVSL, VSR, LDVSR, IERR )
+*
+ SDIM = 0
+*
+* Perform QZ algorithm, computing Schur vectors if desired
+* (Workspace: need N)
+*
+ IWRK = ITAU
+ CALL SHGEQZ( 'S', JOBVSL, JOBVSR, N, ILO, IHI, A, LDA, B, LDB,
+ $ ALPHAR, ALPHAI, BETA, VSL, LDVSL, VSR, LDVSR,
+ $ WORK( IWRK ), LWORK+1-IWRK, IERR )
+ IF( IERR.NE.0 ) THEN
+ IF( IERR.GT.0 .AND. IERR.LE.N ) THEN
+ INFO = IERR
+ ELSE IF( IERR.GT.N .AND. IERR.LE.2*N ) THEN
+ INFO = IERR - N
+ ELSE
+ INFO = N + 1
+ END IF
+ GO TO 50
+ END IF
+*
+* Sort eigenvalues ALPHA/BETA and compute the reciprocal of
+* condition number(s)
+* (Workspace: If IJOB >= 1, need MAX( 8*(N+1), 2*SDIM*(N-SDIM) )
+* otherwise, need 8*(N+1) )
+*
+ IF( WANTST ) THEN
+*
+* Undo scaling on eigenvalues before SELCTGing
+*
+ IF( ILASCL ) THEN
+ CALL SLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHAR, N,
+ $ IERR )
+ CALL SLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHAI, N,
+ $ IERR )
+ END IF
+ IF( ILBSCL )
+ $ CALL SLASCL( 'G', 0, 0, BNRMTO, BNRM, N, 1, BETA, N, IERR )
+*
+* Select eigenvalues
+*
+ DO 10 I = 1, N
+ BWORK( I ) = SELCTG( ALPHAR( I ), ALPHAI( I ), BETA( I ) )
+ 10 CONTINUE
+*
+* Reorder eigenvalues, transform Generalized Schur vectors, and
+* compute reciprocal condition numbers
+*
+ CALL STGSEN( IJOB, ILVSL, ILVSR, BWORK, N, A, LDA, B, LDB,
+ $ ALPHAR, ALPHAI, BETA, VSL, LDVSL, VSR, LDVSR,
+ $ SDIM, PL, PR, DIF, WORK( IWRK ), LWORK-IWRK+1,
+ $ IWORK, LIWORK, IERR )
+*
+ IF( IJOB.GE.1 )
+ $ MAXWRK = MAX( MAXWRK, 2*SDIM*( N-SDIM ) )
+ IF( IERR.EQ.-22 ) THEN
+*
+* not enough real workspace
+*
+ INFO = -22
+ ELSE
+ IF( IJOB.EQ.1 .OR. IJOB.EQ.4 ) THEN
+ RCONDE( 1 ) = PL
+ RCONDE( 2 ) = PR
+ END IF
+ IF( IJOB.EQ.2 .OR. IJOB.EQ.4 ) THEN
+ RCONDV( 1 ) = DIF( 1 )
+ RCONDV( 2 ) = DIF( 2 )
+ END IF
+ IF( IERR.EQ.1 )
+ $ INFO = N + 3
+ END IF
+*
+ END IF
+*
+* Apply permutation to VSL and VSR
+* (Workspace: none needed)
+*
+ IF( ILVSL )
+ $ CALL SGGBAK( 'P', 'L', N, ILO, IHI, WORK( ILEFT ),
+ $ WORK( IRIGHT ), N, VSL, LDVSL, IERR )
+*
+ IF( ILVSR )
+ $ CALL SGGBAK( 'P', 'R', N, ILO, IHI, WORK( ILEFT ),
+ $ WORK( IRIGHT ), N, VSR, LDVSR, IERR )
+*
+* Check if unscaling would cause over/underflow, if so, rescale
+* (ALPHAR(I),ALPHAI(I),BETA(I)) so BETA(I) is on the order of
+* B(I,I) and ALPHAR(I) and ALPHAI(I) are on the order of A(I,I)
+*
+ IF( ILASCL ) THEN
+ DO 20 I = 1, N
+ IF( ALPHAI( I ).NE.ZERO ) THEN
+ IF( ( ALPHAR( I ) / SAFMAX ).GT.( ANRMTO / ANRM ) .OR.
+ $ ( SAFMIN / ALPHAR( I ) ).GT.( ANRM / ANRMTO ) )
+ $ THEN
+ WORK( 1 ) = ABS( A( I, I ) / ALPHAR( I ) )
+ BETA( I ) = BETA( I )*WORK( 1 )
+ ALPHAR( I ) = ALPHAR( I )*WORK( 1 )
+ ALPHAI( I ) = ALPHAI( I )*WORK( 1 )
+ ELSE IF( ( ALPHAI( I ) / SAFMAX ).GT.( ANRMTO / ANRM )
+ $ .OR. ( SAFMIN / ALPHAI( I ) ).GT.( ANRM / ANRMTO ) )
+ $ THEN
+ WORK( 1 ) = ABS( A( I, I+1 ) / ALPHAI( I ) )
+ BETA( I ) = BETA( I )*WORK( 1 )
+ ALPHAR( I ) = ALPHAR( I )*WORK( 1 )
+ ALPHAI( I ) = ALPHAI( I )*WORK( 1 )
+ END IF
+ END IF
+ 20 CONTINUE
+ END IF
+*
+ IF( ILBSCL ) THEN
+ DO 25 I = 1, N
+ IF( ALPHAI( I ).NE.ZERO ) THEN
+ IF( ( BETA( I ) / SAFMAX ).GT.( BNRMTO / BNRM ) .OR.
+ $ ( SAFMIN / BETA( I ) ).GT.( BNRM / BNRMTO ) ) THEN
+ WORK( 1 ) = ABS( B( I, I ) / BETA( I ) )
+ BETA( I ) = BETA( I )*WORK( 1 )
+ ALPHAR( I ) = ALPHAR( I )*WORK( 1 )
+ ALPHAI( I ) = ALPHAI( I )*WORK( 1 )
+ END IF
+ END IF
+ 25 CONTINUE
+ END IF
+*
+* Undo scaling
+*
+ IF( ILASCL ) THEN
+ CALL SLASCL( 'H', 0, 0, ANRMTO, ANRM, N, N, A, LDA, IERR )
+ CALL SLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHAR, N, IERR )
+ CALL SLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHAI, N, IERR )
+ END IF
+*
+ IF( ILBSCL ) THEN
+ CALL SLASCL( 'U', 0, 0, BNRMTO, BNRM, N, N, B, LDB, IERR )
+ CALL SLASCL( 'G', 0, 0, BNRMTO, BNRM, N, 1, BETA, N, IERR )
+ END IF
+*
+ IF( WANTST ) THEN
+*
+* Check if reordering is correct
+*
+ LASTSL = .TRUE.
+ LST2SL = .TRUE.
+ SDIM = 0
+ IP = 0
+ DO 40 I = 1, N
+ CURSL = SELCTG( ALPHAR( I ), ALPHAI( I ), BETA( I ) )
+ IF( ALPHAI( I ).EQ.ZERO ) THEN
+ IF( CURSL )
+ $ SDIM = SDIM + 1
+ IP = 0
+ IF( CURSL .AND. .NOT.LASTSL )
+ $ INFO = N + 2
+ ELSE
+ IF( IP.EQ.1 ) THEN
+*
+* Last eigenvalue of conjugate pair
+*
+ CURSL = CURSL .OR. LASTSL
+ LASTSL = CURSL
+ IF( CURSL )
+ $ SDIM = SDIM + 2
+ IP = -1
+ IF( CURSL .AND. .NOT.LST2SL )
+ $ INFO = N + 2
+ ELSE
+*
+* First eigenvalue of conjugate pair
+*
+ IP = 1
+ END IF
+ END IF
+ LST2SL = LASTSL
+ LASTSL = CURSL
+ 40 CONTINUE
+*
+ END IF
+*
+ 50 CONTINUE
+*
+ WORK( 1 ) = MAXWRK
+ IWORK( 1 ) = LIWMIN
+*
+ RETURN
+*
+* End of SGGESX
+*
+ END
+ SUBROUTINE SGGEV( JOBVL, JOBVR, N, A, LDA, B, LDB, ALPHAR, ALPHAI,
+ $ BETA, VL, LDVL, VR, LDVR, WORK, LWORK, INFO )
+*
+* -- LAPACK driver routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER JOBVL, JOBVR
+ INTEGER INFO, LDA, LDB, LDVL, LDVR, LWORK, N
+* ..
+* .. Array Arguments ..
+ REAL A( LDA, * ), ALPHAI( * ), ALPHAR( * ),
+ $ B( LDB, * ), BETA( * ), VL( LDVL, * ),
+ $ VR( LDVR, * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SGGEV computes for a pair of N-by-N real nonsymmetric matrices (A,B)
+* the generalized eigenvalues, and optionally, the left and/or right
+* generalized eigenvectors.
+*
+* A generalized eigenvalue for a pair of matrices (A,B) is a scalar
+* lambda or a ratio alpha/beta = lambda, such that A - lambda*B is
+* singular. It is usually represented as the pair (alpha,beta), as
+* there is a reasonable interpretation for beta=0, and even for both
+* being zero.
+*
+* The right eigenvector v(j) corresponding to the eigenvalue lambda(j)
+* of (A,B) satisfies
+*
+* A * v(j) = lambda(j) * B * v(j).
+*
+* The left eigenvector u(j) corresponding to the eigenvalue lambda(j)
+* of (A,B) satisfies
+*
+* u(j)**H * A = lambda(j) * u(j)**H * B .
+*
+* where u(j)**H is the conjugate-transpose of u(j).
+*
+*
+* Arguments
+* =========
+*
+* JOBVL (input) CHARACTER*1
+* = 'N': do not compute the left generalized eigenvectors;
+* = 'V': compute the left generalized eigenvectors.
+*
+* JOBVR (input) CHARACTER*1
+* = 'N': do not compute the right generalized eigenvectors;
+* = 'V': compute the right generalized eigenvectors.
+*
+* N (input) INTEGER
+* The order of the matrices A, B, VL, and VR. N >= 0.
+*
+* A (input/output) REAL array, dimension (LDA, N)
+* On entry, the matrix A in the pair (A,B).
+* On exit, A has been overwritten.
+*
+* LDA (input) INTEGER
+* The leading dimension of A. LDA >= max(1,N).
+*
+* B (input/output) REAL array, dimension (LDB, N)
+* On entry, the matrix B in the pair (A,B).
+* On exit, B has been overwritten.
+*
+* LDB (input) INTEGER
+* The leading dimension of B. LDB >= max(1,N).
+*
+* ALPHAR (output) REAL array, dimension (N)
+* ALPHAI (output) REAL array, dimension (N)
+* BETA (output) REAL array, dimension (N)
+* On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, will
+* be the generalized eigenvalues. If ALPHAI(j) is zero, then
+* the j-th eigenvalue is real; if positive, then the j-th and
+* (j+1)-st eigenvalues are a complex conjugate pair, with
+* ALPHAI(j+1) negative.
+*
+* Note: the quotients ALPHAR(j)/BETA(j) and ALPHAI(j)/BETA(j)
+* may easily over- or underflow, and BETA(j) may even be zero.
+* Thus, the user should avoid naively computing the ratio
+* alpha/beta. However, ALPHAR and ALPHAI will be always less
+* than and usually comparable with norm(A) in magnitude, and
+* BETA always less than and usually comparable with norm(B).
+*
+* VL (output) REAL array, dimension (LDVL,N)
+* If JOBVL = 'V', the left eigenvectors u(j) are stored one
+* after another in the columns of VL, in the same order as
+* their eigenvalues. If the j-th eigenvalue is real, then
+* u(j) = VL(:,j), the j-th column of VL. If the j-th and
+* (j+1)-th eigenvalues form a complex conjugate pair, then
+* u(j) = VL(:,j)+i*VL(:,j+1) and u(j+1) = VL(:,j)-i*VL(:,j+1).
+* Each eigenvector is scaled so the largest component has
+* abs(real part)+abs(imag. part)=1.
+* Not referenced if JOBVL = 'N'.
+*
+* LDVL (input) INTEGER
+* The leading dimension of the matrix VL. LDVL >= 1, and
+* if JOBVL = 'V', LDVL >= N.
+*
+* VR (output) REAL array, dimension (LDVR,N)
+* If JOBVR = 'V', the right eigenvectors v(j) are stored one
+* after another in the columns of VR, in the same order as
+* their eigenvalues. If the j-th eigenvalue is real, then
+* v(j) = VR(:,j), the j-th column of VR. If the j-th and
+* (j+1)-th eigenvalues form a complex conjugate pair, then
+* v(j) = VR(:,j)+i*VR(:,j+1) and v(j+1) = VR(:,j)-i*VR(:,j+1).
+* Each eigenvector is scaled so the largest component has
+* abs(real part)+abs(imag. part)=1.
+* Not referenced if JOBVR = 'N'.
+*
+* LDVR (input) INTEGER
+* The leading dimension of the matrix VR. LDVR >= 1, and
+* if JOBVR = 'V', LDVR >= N.
+*
+* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))
+* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+* LWORK (input) INTEGER
+* The dimension of the array WORK. LWORK >= max(1,8*N).
+* For good performance, LWORK must generally be larger.
+*
+* If LWORK = -1, then a workspace query is assumed; the routine
+* only calculates the optimal size of the WORK array, returns
+* this value as the first entry of the WORK array, and no error
+* message related to LWORK is issued by XERBLA.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value.
+* = 1,...,N:
+* The QZ iteration failed. No eigenvectors have been
+* calculated, but ALPHAR(j), ALPHAI(j), and BETA(j)
+* should be correct for j=INFO+1,...,N.
+* > N: =N+1: other than QZ iteration failed in SHGEQZ.
+* =N+2: error return from STGEVC.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO, ONE
+ PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL ILASCL, ILBSCL, ILV, ILVL, ILVR, LQUERY
+ CHARACTER CHTEMP
+ INTEGER ICOLS, IERR, IHI, IJOBVL, IJOBVR, ILEFT, ILO,
+ $ IN, IRIGHT, IROWS, ITAU, IWRK, JC, JR, MAXWRK,
+ $ MINWRK
+ REAL ANRM, ANRMTO, BIGNUM, BNRM, BNRMTO, EPS,
+ $ SMLNUM, TEMP
+* ..
+* .. Local Arrays ..
+ LOGICAL LDUMMA( 1 )
+* ..
+* .. External Subroutines ..
+ EXTERNAL SGEQRF, SGGBAK, SGGBAL, SGGHRD, SHGEQZ, SLABAD,
+ $ SLACPY, SLASCL, SLASET, SORGQR, SORMQR, STGEVC,
+ $ XERBLA
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ILAENV
+ REAL SLAMCH, SLANGE
+ EXTERNAL LSAME, ILAENV, SLAMCH, SLANGE
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, SQRT
+* ..
+* .. Executable Statements ..
+*
+* Decode the input arguments
+*
+ IF( LSAME( JOBVL, 'N' ) ) THEN
+ IJOBVL = 1
+ ILVL = .FALSE.
+ ELSE IF( LSAME( JOBVL, 'V' ) ) THEN
+ IJOBVL = 2
+ ILVL = .TRUE.
+ ELSE
+ IJOBVL = -1
+ ILVL = .FALSE.
+ END IF
+*
+ IF( LSAME( JOBVR, 'N' ) ) THEN
+ IJOBVR = 1
+ ILVR = .FALSE.
+ ELSE IF( LSAME( JOBVR, 'V' ) ) THEN
+ IJOBVR = 2
+ ILVR = .TRUE.
+ ELSE
+ IJOBVR = -1
+ ILVR = .FALSE.
+ END IF
+ ILV = ILVL .OR. ILVR
+*
+* Test the input arguments
+*
+ INFO = 0
+ LQUERY = ( LWORK.EQ.-1 )
+ IF( IJOBVL.LE.0 ) THEN
+ INFO = -1
+ ELSE IF( IJOBVR.LE.0 ) THEN
+ INFO = -2
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -5
+ ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -7
+ ELSE IF( LDVL.LT.1 .OR. ( ILVL .AND. LDVL.LT.N ) ) THEN
+ INFO = -12
+ ELSE IF( LDVR.LT.1 .OR. ( ILVR .AND. LDVR.LT.N ) ) THEN
+ INFO = -14
+ END IF
+*
+* Compute workspace
+* (Note: Comments in the code beginning "Workspace:" describe the
+* minimal amount of workspace needed at that point in the code,
+* as well as the preferred amount for good performance.
+* NB refers to the optimal block size for the immediately
+* following subroutine, as returned by ILAENV. The workspace is
+* computed assuming ILO = 1 and IHI = N, the worst case.)
+*
+ IF( INFO.EQ.0 ) THEN
+ MINWRK = MAX( 1, 8*N )
+ MAXWRK = MAX( 1, N*( 7 +
+ $ ILAENV( 1, 'SGEQRF', ' ', N, 1, N, 0 ) ) )
+ MAXWRK = MAX( MAXWRK, N*( 7 +
+ $ ILAENV( 1, 'SORMQR', ' ', N, 1, N, 0 ) ) )
+ IF( ILVL ) THEN
+ MAXWRK = MAX( MAXWRK, N*( 7 +
+ $ ILAENV( 1, 'SORGQR', ' ', N, 1, N, -1 ) ) )
+ END IF
+ WORK( 1 ) = MAXWRK
+*
+ IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY )
+ $ INFO = -16
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SGGEV ', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+* Get machine constants
+*
+ EPS = SLAMCH( 'P' )
+ SMLNUM = SLAMCH( 'S' )
+ BIGNUM = ONE / SMLNUM
+ CALL SLABAD( SMLNUM, BIGNUM )
+ SMLNUM = SQRT( SMLNUM ) / EPS
+ BIGNUM = ONE / SMLNUM
+*
+* Scale A if max element outside range [SMLNUM,BIGNUM]
+*
+ ANRM = SLANGE( 'M', N, N, A, LDA, WORK )
+ ILASCL = .FALSE.
+ IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
+ ANRMTO = SMLNUM
+ ILASCL = .TRUE.
+ ELSE IF( ANRM.GT.BIGNUM ) THEN
+ ANRMTO = BIGNUM
+ ILASCL = .TRUE.
+ END IF
+ IF( ILASCL )
+ $ CALL SLASCL( 'G', 0, 0, ANRM, ANRMTO, N, N, A, LDA, IERR )
+*
+* Scale B if max element outside range [SMLNUM,BIGNUM]
+*
+ BNRM = SLANGE( 'M', N, N, B, LDB, WORK )
+ ILBSCL = .FALSE.
+ IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN
+ BNRMTO = SMLNUM
+ ILBSCL = .TRUE.
+ ELSE IF( BNRM.GT.BIGNUM ) THEN
+ BNRMTO = BIGNUM
+ ILBSCL = .TRUE.
+ END IF
+ IF( ILBSCL )
+ $ CALL SLASCL( 'G', 0, 0, BNRM, BNRMTO, N, N, B, LDB, IERR )
+*
+* Permute the matrices A, B to isolate eigenvalues if possible
+* (Workspace: need 6*N)
+*
+ ILEFT = 1
+ IRIGHT = N + 1
+ IWRK = IRIGHT + N
+ CALL SGGBAL( 'P', N, A, LDA, B, LDB, ILO, IHI, WORK( ILEFT ),
+ $ WORK( IRIGHT ), WORK( IWRK ), IERR )
+*
+* Reduce B to triangular form (QR decomposition of B)
+* (Workspace: need N, prefer N*NB)
+*
+ IROWS = IHI + 1 - ILO
+ IF( ILV ) THEN
+ ICOLS = N + 1 - ILO
+ ELSE
+ ICOLS = IROWS
+ END IF
+ ITAU = IWRK
+ IWRK = ITAU + IROWS
+ CALL SGEQRF( IROWS, ICOLS, B( ILO, ILO ), LDB, WORK( ITAU ),
+ $ WORK( IWRK ), LWORK+1-IWRK, IERR )
+*
+* Apply the orthogonal transformation to matrix A
+* (Workspace: need N, prefer N*NB)
+*
+ CALL SORMQR( 'L', 'T', IROWS, ICOLS, IROWS, B( ILO, ILO ), LDB,
+ $ WORK( ITAU ), A( ILO, ILO ), LDA, WORK( IWRK ),
+ $ LWORK+1-IWRK, IERR )
+*
+* Initialize VL
+* (Workspace: need N, prefer N*NB)
+*
+ IF( ILVL ) THEN
+ CALL SLASET( 'Full', N, N, ZERO, ONE, VL, LDVL )
+ IF( IROWS.GT.1 ) THEN
+ CALL SLACPY( 'L', IROWS-1, IROWS-1, B( ILO+1, ILO ), LDB,
+ $ VL( ILO+1, ILO ), LDVL )
+ END IF
+ CALL SORGQR( IROWS, IROWS, IROWS, VL( ILO, ILO ), LDVL,
+ $ WORK( ITAU ), WORK( IWRK ), LWORK+1-IWRK, IERR )
+ END IF
+*
+* Initialize VR
+*
+ IF( ILVR )
+ $ CALL SLASET( 'Full', N, N, ZERO, ONE, VR, LDVR )
+*
+* Reduce to generalized Hessenberg form
+* (Workspace: none needed)
+*
+ IF( ILV ) THEN
+*
+* Eigenvectors requested -- work on whole matrix.
+*
+ CALL SGGHRD( JOBVL, JOBVR, N, ILO, IHI, A, LDA, B, LDB, VL,
+ $ LDVL, VR, LDVR, IERR )
+ ELSE
+ CALL SGGHRD( 'N', 'N', IROWS, 1, IROWS, A( ILO, ILO ), LDA,
+ $ B( ILO, ILO ), LDB, VL, LDVL, VR, LDVR, IERR )
+ END IF
+*
+* Perform QZ algorithm (Compute eigenvalues, and optionally, the
+* Schur forms and Schur vectors)
+* (Workspace: need N)
+*
+ IWRK = ITAU
+ IF( ILV ) THEN
+ CHTEMP = 'S'
+ ELSE
+ CHTEMP = 'E'
+ END IF
+ CALL SHGEQZ( CHTEMP, JOBVL, JOBVR, N, ILO, IHI, A, LDA, B, LDB,
+ $ ALPHAR, ALPHAI, BETA, VL, LDVL, VR, LDVR,
+ $ WORK( IWRK ), LWORK+1-IWRK, IERR )
+ IF( IERR.NE.0 ) THEN
+ IF( IERR.GT.0 .AND. IERR.LE.N ) THEN
+ INFO = IERR
+ ELSE IF( IERR.GT.N .AND. IERR.LE.2*N ) THEN
+ INFO = IERR - N
+ ELSE
+ INFO = N + 1
+ END IF
+ GO TO 110
+ END IF
+*
+* Compute Eigenvectors
+* (Workspace: need 6*N)
+*
+ IF( ILV ) THEN
+ IF( ILVL ) THEN
+ IF( ILVR ) THEN
+ CHTEMP = 'B'
+ ELSE
+ CHTEMP = 'L'
+ END IF
+ ELSE
+ CHTEMP = 'R'
+ END IF
+ CALL STGEVC( CHTEMP, 'B', LDUMMA, N, A, LDA, B, LDB, VL, LDVL,
+ $ VR, LDVR, N, IN, WORK( IWRK ), IERR )
+ IF( IERR.NE.0 ) THEN
+ INFO = N + 2
+ GO TO 110
+ END IF
+*
+* Undo balancing on VL and VR and normalization
+* (Workspace: none needed)
+*
+ IF( ILVL ) THEN
+ CALL SGGBAK( 'P', 'L', N, ILO, IHI, WORK( ILEFT ),
+ $ WORK( IRIGHT ), N, VL, LDVL, IERR )
+ DO 50 JC = 1, N
+ IF( ALPHAI( JC ).LT.ZERO )
+ $ GO TO 50
+ TEMP = ZERO
+ IF( ALPHAI( JC ).EQ.ZERO ) THEN
+ DO 10 JR = 1, N
+ TEMP = MAX( TEMP, ABS( VL( JR, JC ) ) )
+ 10 CONTINUE
+ ELSE
+ DO 20 JR = 1, N
+ TEMP = MAX( TEMP, ABS( VL( JR, JC ) )+
+ $ ABS( VL( JR, JC+1 ) ) )
+ 20 CONTINUE
+ END IF
+ IF( TEMP.LT.SMLNUM )
+ $ GO TO 50
+ TEMP = ONE / TEMP
+ IF( ALPHAI( JC ).EQ.ZERO ) THEN
+ DO 30 JR = 1, N
+ VL( JR, JC ) = VL( JR, JC )*TEMP
+ 30 CONTINUE
+ ELSE
+ DO 40 JR = 1, N
+ VL( JR, JC ) = VL( JR, JC )*TEMP
+ VL( JR, JC+1 ) = VL( JR, JC+1 )*TEMP
+ 40 CONTINUE
+ END IF
+ 50 CONTINUE
+ END IF
+ IF( ILVR ) THEN
+ CALL SGGBAK( 'P', 'R', N, ILO, IHI, WORK( ILEFT ),
+ $ WORK( IRIGHT ), N, VR, LDVR, IERR )
+ DO 100 JC = 1, N
+ IF( ALPHAI( JC ).LT.ZERO )
+ $ GO TO 100
+ TEMP = ZERO
+ IF( ALPHAI( JC ).EQ.ZERO ) THEN
+ DO 60 JR = 1, N
+ TEMP = MAX( TEMP, ABS( VR( JR, JC ) ) )
+ 60 CONTINUE
+ ELSE
+ DO 70 JR = 1, N
+ TEMP = MAX( TEMP, ABS( VR( JR, JC ) )+
+ $ ABS( VR( JR, JC+1 ) ) )
+ 70 CONTINUE
+ END IF
+ IF( TEMP.LT.SMLNUM )
+ $ GO TO 100
+ TEMP = ONE / TEMP
+ IF( ALPHAI( JC ).EQ.ZERO ) THEN
+ DO 80 JR = 1, N
+ VR( JR, JC ) = VR( JR, JC )*TEMP
+ 80 CONTINUE
+ ELSE
+ DO 90 JR = 1, N
+ VR( JR, JC ) = VR( JR, JC )*TEMP
+ VR( JR, JC+1 ) = VR( JR, JC+1 )*TEMP
+ 90 CONTINUE
+ END IF
+ 100 CONTINUE
+ END IF
+*
+* End of eigenvector calculation
+*
+ END IF
+*
+* Undo scaling if necessary
+*
+ IF( ILASCL ) THEN
+ CALL SLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHAR, N, IERR )
+ CALL SLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHAI, N, IERR )
+ END IF
+*
+ IF( ILBSCL ) THEN
+ CALL SLASCL( 'G', 0, 0, BNRMTO, BNRM, N, 1, BETA, N, IERR )
+ END IF
+*
+ 110 CONTINUE
+*
+ WORK( 1 ) = MAXWRK
+*
+ RETURN
+*
+* End of SGGEV
+*
+ END
+ 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 )
+*
+* -- LAPACK driver routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER BALANC, JOBVL, JOBVR, SENSE
+ INTEGER IHI, ILO, INFO, LDA, LDB, LDVL, LDVR, LWORK, N
+ REAL ABNRM, BBNRM
+* ..
+* .. Array Arguments ..
+ LOGICAL BWORK( * )
+ INTEGER IWORK( * )
+ REAL A( LDA, * ), ALPHAI( * ), ALPHAR( * ),
+ $ B( LDB, * ), BETA( * ), LSCALE( * ),
+ $ RCONDE( * ), RCONDV( * ), RSCALE( * ),
+ $ VL( LDVL, * ), VR( LDVR, * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SGGEVX computes for a pair of N-by-N real nonsymmetric matrices (A,B)
+* the generalized eigenvalues, and optionally, the left and/or right
+* generalized eigenvectors.
+*
+* Optionally also, it computes a balancing transformation to improve
+* the conditioning of the eigenvalues and eigenvectors (ILO, IHI,
+* LSCALE, RSCALE, ABNRM, and BBNRM), reciprocal condition numbers for
+* the eigenvalues (RCONDE), and reciprocal condition numbers for the
+* right eigenvectors (RCONDV).
+*
+* A generalized eigenvalue for a pair of matrices (A,B) is a scalar
+* lambda or a ratio alpha/beta = lambda, such that A - lambda*B is
+* singular. It is usually represented as the pair (alpha,beta), as
+* there is a reasonable interpretation for beta=0, and even for both
+* being zero.
+*
+* The right eigenvector v(j) corresponding to the eigenvalue lambda(j)
+* of (A,B) satisfies
+*
+* A * v(j) = lambda(j) * B * v(j) .
+*
+* The left eigenvector u(j) corresponding to the eigenvalue lambda(j)
+* of (A,B) satisfies
+*
+* u(j)**H * A = lambda(j) * u(j)**H * B.
+*
+* where u(j)**H is the conjugate-transpose of u(j).
+*
+*
+* Arguments
+* =========
+*
+* BALANC (input) CHARACTER*1
+* Specifies the balance option to be performed.
+* = 'N': do not diagonally scale or permute;
+* = 'P': permute only;
+* = 'S': scale only;
+* = 'B': both permute and scale.
+* Computed reciprocal condition numbers will be for the
+* matrices after permuting and/or balancing. Permuting does
+* not change condition numbers (in exact arithmetic), but
+* balancing does.
+*
+* JOBVL (input) CHARACTER*1
+* = 'N': do not compute the left generalized eigenvectors;
+* = 'V': compute the left generalized eigenvectors.
+*
+* JOBVR (input) CHARACTER*1
+* = 'N': do not compute the right generalized eigenvectors;
+* = 'V': compute the right generalized eigenvectors.
+*
+* SENSE (input) CHARACTER*1
+* Determines which reciprocal condition numbers are computed.
+* = 'N': none are computed;
+* = 'E': computed for eigenvalues only;
+* = 'V': computed for eigenvectors only;
+* = 'B': computed for eigenvalues and eigenvectors.
+*
+* N (input) INTEGER
+* The order of the matrices A, B, VL, and VR. N >= 0.
+*
+* A (input/output) REAL array, dimension (LDA, N)
+* On entry, the matrix A in the pair (A,B).
+* On exit, A has been overwritten. If JOBVL='V' or JOBVR='V'
+* or both, then A contains the first part of the real Schur
+* form of the "balanced" versions of the input A and B.
+*
+* LDA (input) INTEGER
+* The leading dimension of A. LDA >= max(1,N).
+*
+* B (input/output) REAL array, dimension (LDB, N)
+* On entry, the matrix B in the pair (A,B).
+* On exit, B has been overwritten. If JOBVL='V' or JOBVR='V'
+* or both, then B contains the second part of the real Schur
+* form of the "balanced" versions of the input A and B.
+*
+* LDB (input) INTEGER
+* The leading dimension of B. LDB >= max(1,N).
+*
+* ALPHAR (output) REAL array, dimension (N)
+* ALPHAI (output) REAL array, dimension (N)
+* BETA (output) REAL array, dimension (N)
+* On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, will
+* be the generalized eigenvalues. If ALPHAI(j) is zero, then
+* the j-th eigenvalue is real; if positive, then the j-th and
+* (j+1)-st eigenvalues are a complex conjugate pair, with
+* ALPHAI(j+1) negative.
+*
+* Note: the quotients ALPHAR(j)/BETA(j) and ALPHAI(j)/BETA(j)
+* may easily over- or underflow, and BETA(j) may even be zero.
+* Thus, the user should avoid naively computing the ratio
+* ALPHA/BETA. However, ALPHAR and ALPHAI will be always less
+* than and usually comparable with norm(A) in magnitude, and
+* BETA always less than and usually comparable with norm(B).
+*
+* VL (output) REAL array, dimension (LDVL,N)
+* If JOBVL = 'V', the left eigenvectors u(j) are stored one
+* after another in the columns of VL, in the same order as
+* their eigenvalues. If the j-th eigenvalue is real, then
+* u(j) = VL(:,j), the j-th column of VL. If the j-th and
+* (j+1)-th eigenvalues form a complex conjugate pair, then
+* u(j) = VL(:,j)+i*VL(:,j+1) and u(j+1) = VL(:,j)-i*VL(:,j+1).
+* Each eigenvector will be scaled so the largest component have
+* abs(real part) + abs(imag. part) = 1.
+* Not referenced if JOBVL = 'N'.
+*
+* LDVL (input) INTEGER
+* The leading dimension of the matrix VL. LDVL >= 1, and
+* if JOBVL = 'V', LDVL >= N.
+*
+* VR (output) REAL array, dimension (LDVR,N)
+* If JOBVR = 'V', the right eigenvectors v(j) are stored one
+* after another in the columns of VR, in the same order as
+* their eigenvalues. If the j-th eigenvalue is real, then
+* v(j) = VR(:,j), the j-th column of VR. If the j-th and
+* (j+1)-th eigenvalues form a complex conjugate pair, then
+* v(j) = VR(:,j)+i*VR(:,j+1) and v(j+1) = VR(:,j)-i*VR(:,j+1).
+* Each eigenvector will be scaled so the largest component have
+* abs(real part) + abs(imag. part) = 1.
+* Not referenced if JOBVR = 'N'.
+*
+* LDVR (input) INTEGER
+* The leading dimension of the matrix VR. LDVR >= 1, and
+* if JOBVR = 'V', LDVR >= N.
+*
+* ILO (output) INTEGER
+* IHI (output) INTEGER
+* ILO and IHI are integer values such that on exit
+* A(i,j) = 0 and B(i,j) = 0 if i > j and
+* j = 1,...,ILO-1 or i = IHI+1,...,N.
+* If BALANC = 'N' or 'S', ILO = 1 and IHI = N.
+*
+* LSCALE (output) REAL array, dimension (N)
+* Details of the permutations and scaling factors applied
+* to the left side of A and B. If PL(j) is the index of the
+* row interchanged with row j, and DL(j) is the scaling
+* factor applied to row j, then
+* LSCALE(j) = PL(j) for j = 1,...,ILO-1
+* = DL(j) for j = ILO,...,IHI
+* = PL(j) for j = IHI+1,...,N.
+* The order in which the interchanges are made is N to IHI+1,
+* then 1 to ILO-1.
+*
+* RSCALE (output) REAL array, dimension (N)
+* Details of the permutations and scaling factors applied
+* to the right side of A and B. If PR(j) is the index of the
+* column interchanged with column j, and DR(j) is the scaling
+* factor applied to column j, then
+* RSCALE(j) = PR(j) for j = 1,...,ILO-1
+* = DR(j) for j = ILO,...,IHI
+* = PR(j) for j = IHI+1,...,N
+* The order in which the interchanges are made is N to IHI+1,
+* then 1 to ILO-1.
+*
+* ABNRM (output) REAL
+* The one-norm of the balanced matrix A.
+*
+* BBNRM (output) REAL
+* The one-norm of the balanced matrix B.
+*
+* RCONDE (output) REAL array, dimension (N)
+* If SENSE = 'E' or 'B', the reciprocal condition numbers of
+* the eigenvalues, stored in consecutive elements of the array.
+* For a complex conjugate pair of eigenvalues two consecutive
+* elements of RCONDE are set to the same value. Thus RCONDE(j),
+* RCONDV(j), and the j-th columns of VL and VR all correspond
+* to the j-th eigenpair.
+* If SENSE = 'N' or 'V', RCONDE is not referenced.
+*
+* RCONDV (output) REAL array, dimension (N)
+* If SENSE = 'V' or 'B', the estimated reciprocal condition
+* numbers of the eigenvectors, stored in consecutive elements
+* of the array. For a complex eigenvector two consecutive
+* elements of RCONDV are set to the same value. If the
+* eigenvalues cannot be reordered to compute RCONDV(j),
+* RCONDV(j) is set to 0; this can only occur when the true
+* value would be very small anyway.
+* If SENSE = 'N' or 'E', RCONDV is not referenced.
+*
+* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))
+* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+* LWORK (input) INTEGER
+* The dimension of the array WORK. LWORK >= max(1,2*N).
+* If BALANC = 'S' or 'B', or JOBVL = 'V', or JOBVR = 'V',
+* LWORK >= max(1,6*N).
+* If SENSE = 'E', LWORK >= max(1,10*N).
+* If SENSE = 'V' or 'B', LWORK >= 2*N*N+8*N+16.
+*
+* If LWORK = -1, then a workspace query is assumed; the routine
+* only calculates the optimal size of the WORK array, returns
+* this value as the first entry of the WORK array, and no error
+* message related to LWORK is issued by XERBLA.
+*
+* IWORK (workspace) INTEGER array, dimension (N+6)
+* If SENSE = 'E', IWORK is not referenced.
+*
+* BWORK (workspace) LOGICAL array, dimension (N)
+* If SENSE = 'N', BWORK is not referenced.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value.
+* = 1,...,N:
+* The QZ iteration failed. No eigenvectors have been
+* calculated, but ALPHAR(j), ALPHAI(j), and BETA(j)
+* should be correct for j=INFO+1,...,N.
+* > N: =N+1: other than QZ iteration failed in SHGEQZ.
+* =N+2: error return from STGEVC.
+*
+* Further Details
+* ===============
+*
+* Balancing a matrix pair (A,B) includes, first, permuting rows and
+* columns to isolate eigenvalues, second, applying diagonal similarity
+* transformation to the rows and columns to make the rows and columns
+* as close in norm as possible. The computed reciprocal condition
+* numbers correspond to the balanced matrix. Permuting rows and columns
+* will not change the condition numbers (in exact arithmetic) but
+* diagonal scaling will. For further explanation of balancing, see
+* section 4.11.1.2 of LAPACK Users' Guide.
+*
+* An approximate error bound on the chordal distance between the i-th
+* computed generalized eigenvalue w and the corresponding exact
+* eigenvalue lambda is
+*
+* chord(w, lambda) <= EPS * norm(ABNRM, BBNRM) / RCONDE(I)
+*
+* An approximate error bound for the angle between the i-th computed
+* eigenvector VL(i) or VR(i) is given by
+*
+* EPS * norm(ABNRM, BBNRM) / DIF(i).
+*
+* For further explanation of the reciprocal condition numbers RCONDE
+* and RCONDV, see section 4.11 of LAPACK User's Guide.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO, ONE
+ PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL ILASCL, ILBSCL, ILV, ILVL, ILVR, LQUERY, NOSCL,
+ $ PAIR, WANTSB, WANTSE, WANTSN, WANTSV
+ CHARACTER CHTEMP
+ INTEGER I, ICOLS, IERR, IJOBVL, IJOBVR, IN, IROWS,
+ $ ITAU, IWRK, IWRK1, J, JC, JR, M, MAXWRK,
+ $ MINWRK, MM
+ REAL ANRM, ANRMTO, BIGNUM, BNRM, BNRMTO, EPS,
+ $ SMLNUM, TEMP
+* ..
+* .. Local Arrays ..
+ LOGICAL LDUMMA( 1 )
+* ..
+* .. External Subroutines ..
+ EXTERNAL SGEQRF, SGGBAK, SGGBAL, SGGHRD, SHGEQZ, SLABAD,
+ $ SLACPY, SLASCL, SLASET, SORGQR, SORMQR, STGEVC,
+ $ STGSNA, XERBLA
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ILAENV
+ REAL SLAMCH, SLANGE
+ EXTERNAL LSAME, ILAENV, SLAMCH, SLANGE
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, SQRT
+* ..
+* .. Executable Statements ..
+*
+* Decode the input arguments
+*
+ IF( LSAME( JOBVL, 'N' ) ) THEN
+ IJOBVL = 1
+ ILVL = .FALSE.
+ ELSE IF( LSAME( JOBVL, 'V' ) ) THEN
+ IJOBVL = 2
+ ILVL = .TRUE.
+ ELSE
+ IJOBVL = -1
+ ILVL = .FALSE.
+ END IF
+*
+ IF( LSAME( JOBVR, 'N' ) ) THEN
+ IJOBVR = 1
+ ILVR = .FALSE.
+ ELSE IF( LSAME( JOBVR, 'V' ) ) THEN
+ IJOBVR = 2
+ ILVR = .TRUE.
+ ELSE
+ IJOBVR = -1
+ ILVR = .FALSE.
+ END IF
+ ILV = ILVL .OR. ILVR
+*
+ NOSCL = LSAME( BALANC, 'N' ) .OR. LSAME( BALANC, 'P' )
+ WANTSN = LSAME( SENSE, 'N' )
+ WANTSE = LSAME( SENSE, 'E' )
+ WANTSV = LSAME( SENSE, 'V' )
+ WANTSB = LSAME( SENSE, 'B' )
+*
+* Test the input arguments
+*
+ INFO = 0
+ LQUERY = ( LWORK.EQ.-1 )
+ IF( .NOT.( NOSCL .OR. LSAME( BALANC, 'S' ) .OR.
+ $ LSAME( BALANC, 'B' ) ) ) THEN
+ INFO = -1
+ ELSE IF( IJOBVL.LE.0 ) THEN
+ INFO = -2
+ ELSE IF( IJOBVR.LE.0 ) THEN
+ INFO = -3
+ ELSE IF( .NOT.( WANTSN .OR. WANTSE .OR. WANTSB .OR. WANTSV ) )
+ $ THEN
+ INFO = -4
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -5
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -7
+ ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -9
+ ELSE IF( LDVL.LT.1 .OR. ( ILVL .AND. LDVL.LT.N ) ) THEN
+ INFO = -14
+ ELSE IF( LDVR.LT.1 .OR. ( ILVR .AND. LDVR.LT.N ) ) THEN
+ INFO = -16
+ END IF
+*
+* Compute workspace
+* (Note: Comments in the code beginning "Workspace:" describe the
+* minimal amount of workspace needed at that point in the code,
+* as well as the preferred amount for good performance.
+* NB refers to the optimal block size for the immediately
+* following subroutine, as returned by ILAENV. The workspace is
+* computed assuming ILO = 1 and IHI = N, the worst case.)
+*
+ IF( INFO.EQ.0 ) THEN
+ IF( N.EQ.0 ) THEN
+ MINWRK = 1
+ MAXWRK = 1
+ ELSE
+ IF( NOSCL .AND. .NOT.ILV ) THEN
+ MINWRK = 2*N
+ ELSE
+ MINWRK = 6*N
+ END IF
+ IF( WANTSE ) THEN
+ MINWRK = 10*N
+ ELSE IF( WANTSV .OR. WANTSB ) THEN
+ MINWRK = 2*N*( N + 4 ) + 16
+ END IF
+ MAXWRK = MINWRK
+ MAXWRK = MAX( MAXWRK,
+ $ N + N*ILAENV( 1, 'SGEQRF', ' ', N, 1, N, 0 ) )
+ MAXWRK = MAX( MAXWRK,
+ $ N + N*ILAENV( 1, 'SORMQR', ' ', N, 1, N, 0 ) )
+ IF( ILVL ) THEN
+ MAXWRK = MAX( MAXWRK, N +
+ $ N*ILAENV( 1, 'SORGQR', ' ', N, 1, N, 0 ) )
+ END IF
+ END IF
+ WORK( 1 ) = MAXWRK
+*
+ IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN
+ INFO = -26
+ END IF
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SGGEVX', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+*
+* Get machine constants
+*
+ EPS = SLAMCH( 'P' )
+ SMLNUM = SLAMCH( 'S' )
+ BIGNUM = ONE / SMLNUM
+ CALL SLABAD( SMLNUM, BIGNUM )
+ SMLNUM = SQRT( SMLNUM ) / EPS
+ BIGNUM = ONE / SMLNUM
+*
+* Scale A if max element outside range [SMLNUM,BIGNUM]
+*
+ ANRM = SLANGE( 'M', N, N, A, LDA, WORK )
+ ILASCL = .FALSE.
+ IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
+ ANRMTO = SMLNUM
+ ILASCL = .TRUE.
+ ELSE IF( ANRM.GT.BIGNUM ) THEN
+ ANRMTO = BIGNUM
+ ILASCL = .TRUE.
+ END IF
+ IF( ILASCL )
+ $ CALL SLASCL( 'G', 0, 0, ANRM, ANRMTO, N, N, A, LDA, IERR )
+*
+* Scale B if max element outside range [SMLNUM,BIGNUM]
+*
+ BNRM = SLANGE( 'M', N, N, B, LDB, WORK )
+ ILBSCL = .FALSE.
+ IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN
+ BNRMTO = SMLNUM
+ ILBSCL = .TRUE.
+ ELSE IF( BNRM.GT.BIGNUM ) THEN
+ BNRMTO = BIGNUM
+ ILBSCL = .TRUE.
+ END IF
+ IF( ILBSCL )
+ $ CALL SLASCL( 'G', 0, 0, BNRM, BNRMTO, N, N, B, LDB, IERR )
+*
+* Permute and/or balance the matrix pair (A,B)
+* (Workspace: need 6*N if BALANC = 'S' or 'B', 1 otherwise)
+*
+ CALL SGGBAL( BALANC, N, A, LDA, B, LDB, ILO, IHI, LSCALE, RSCALE,
+ $ WORK, IERR )
+*
+* Compute ABNRM and BBNRM
+*
+ ABNRM = SLANGE( '1', N, N, A, LDA, WORK( 1 ) )
+ IF( ILASCL ) THEN
+ WORK( 1 ) = ABNRM
+ CALL SLASCL( 'G', 0, 0, ANRMTO, ANRM, 1, 1, WORK( 1 ), 1,
+ $ IERR )
+ ABNRM = WORK( 1 )
+ END IF
+*
+ BBNRM = SLANGE( '1', N, N, B, LDB, WORK( 1 ) )
+ IF( ILBSCL ) THEN
+ WORK( 1 ) = BBNRM
+ CALL SLASCL( 'G', 0, 0, BNRMTO, BNRM, 1, 1, WORK( 1 ), 1,
+ $ IERR )
+ BBNRM = WORK( 1 )
+ END IF
+*
+* Reduce B to triangular form (QR decomposition of B)
+* (Workspace: need N, prefer N*NB )
+*
+ IROWS = IHI + 1 - ILO
+ IF( ILV .OR. .NOT.WANTSN ) THEN
+ ICOLS = N + 1 - ILO
+ ELSE
+ ICOLS = IROWS
+ END IF
+ ITAU = 1
+ IWRK = ITAU + IROWS
+ CALL SGEQRF( IROWS, ICOLS, B( ILO, ILO ), LDB, WORK( ITAU ),
+ $ WORK( IWRK ), LWORK+1-IWRK, IERR )
+*
+* Apply the orthogonal transformation to A
+* (Workspace: need N, prefer N*NB)
+*
+ CALL SORMQR( 'L', 'T', IROWS, ICOLS, IROWS, B( ILO, ILO ), LDB,
+ $ WORK( ITAU ), A( ILO, ILO ), LDA, WORK( IWRK ),
+ $ LWORK+1-IWRK, IERR )
+*
+* Initialize VL and/or VR
+* (Workspace: need N, prefer N*NB)
+*
+ IF( ILVL ) THEN
+ CALL SLASET( 'Full', N, N, ZERO, ONE, VL, LDVL )
+ IF( IROWS.GT.1 ) THEN
+ CALL SLACPY( 'L', IROWS-1, IROWS-1, B( ILO+1, ILO ), LDB,
+ $ VL( ILO+1, ILO ), LDVL )
+ END IF
+ CALL SORGQR( IROWS, IROWS, IROWS, VL( ILO, ILO ), LDVL,
+ $ WORK( ITAU ), WORK( IWRK ), LWORK+1-IWRK, IERR )
+ END IF
+*
+ IF( ILVR )
+ $ CALL SLASET( 'Full', N, N, ZERO, ONE, VR, LDVR )
+*
+* Reduce to generalized Hessenberg form
+* (Workspace: none needed)
+*
+ IF( ILV .OR. .NOT.WANTSN ) THEN
+*
+* Eigenvectors requested -- work on whole matrix.
+*
+ CALL SGGHRD( JOBVL, JOBVR, N, ILO, IHI, A, LDA, B, LDB, VL,
+ $ LDVL, VR, LDVR, IERR )
+ ELSE
+ CALL SGGHRD( 'N', 'N', IROWS, 1, IROWS, A( ILO, ILO ), LDA,
+ $ B( ILO, ILO ), LDB, VL, LDVL, VR, LDVR, IERR )
+ END IF
+*
+* Perform QZ algorithm (Compute eigenvalues, and optionally, the
+* Schur forms and Schur vectors)
+* (Workspace: need N)
+*
+ IF( ILV .OR. .NOT.WANTSN ) THEN
+ CHTEMP = 'S'
+ ELSE
+ CHTEMP = 'E'
+ END IF
+*
+ CALL SHGEQZ( CHTEMP, JOBVL, JOBVR, N, ILO, IHI, A, LDA, B, LDB,
+ $ ALPHAR, ALPHAI, BETA, VL, LDVL, VR, LDVR, WORK,
+ $ LWORK, IERR )
+ IF( IERR.NE.0 ) THEN
+ IF( IERR.GT.0 .AND. IERR.LE.N ) THEN
+ INFO = IERR
+ ELSE IF( IERR.GT.N .AND. IERR.LE.2*N ) THEN
+ INFO = IERR - N
+ ELSE
+ INFO = N + 1
+ END IF
+ GO TO 130
+ END IF
+*
+* Compute Eigenvectors and estimate condition numbers if desired
+* (Workspace: STGEVC: need 6*N
+* STGSNA: need 2*N*(N+2)+16 if SENSE = 'V' or 'B',
+* need N otherwise )
+*
+ IF( ILV .OR. .NOT.WANTSN ) THEN
+ IF( ILV ) THEN
+ IF( ILVL ) THEN
+ IF( ILVR ) THEN
+ CHTEMP = 'B'
+ ELSE
+ CHTEMP = 'L'
+ END IF
+ ELSE
+ CHTEMP = 'R'
+ END IF
+*
+ CALL STGEVC( CHTEMP, 'B', LDUMMA, N, A, LDA, B, LDB, VL,
+ $ LDVL, VR, LDVR, N, IN, WORK, IERR )
+ IF( IERR.NE.0 ) THEN
+ INFO = N + 2
+ GO TO 130
+ END IF
+ END IF
+*
+ IF( .NOT.WANTSN ) THEN
+*
+* compute eigenvectors (STGEVC) and estimate condition
+* numbers (STGSNA). Note that the definition of the condition
+* number is not invariant under transformation (u,v) to
+* (Q*u, Z*v), where (u,v) are eigenvectors of the generalized
+* Schur form (S,T), Q and Z are orthogonal matrices. In order
+* to avoid using extra 2*N*N workspace, we have to recalculate
+* eigenvectors and estimate one condition numbers at a time.
+*
+ PAIR = .FALSE.
+ DO 20 I = 1, N
+*
+ IF( PAIR ) THEN
+ PAIR = .FALSE.
+ GO TO 20
+ END IF
+ MM = 1
+ IF( I.LT.N ) THEN
+ IF( A( I+1, I ).NE.ZERO ) THEN
+ PAIR = .TRUE.
+ MM = 2
+ END IF
+ END IF
+*
+ DO 10 J = 1, N
+ BWORK( J ) = .FALSE.
+ 10 CONTINUE
+ IF( MM.EQ.1 ) THEN
+ BWORK( I ) = .TRUE.
+ ELSE IF( MM.EQ.2 ) THEN
+ BWORK( I ) = .TRUE.
+ BWORK( I+1 ) = .TRUE.
+ END IF
+*
+ IWRK = MM*N + 1
+ IWRK1 = IWRK + MM*N
+*
+* Compute a pair of left and right eigenvectors.
+* (compute workspace: need up to 4*N + 6*N)
+*
+ IF( WANTSE .OR. WANTSB ) THEN
+ CALL STGEVC( 'B', 'S', BWORK, N, A, LDA, B, LDB,
+ $ WORK( 1 ), N, WORK( IWRK ), N, MM, M,
+ $ WORK( IWRK1 ), IERR )
+ IF( IERR.NE.0 ) THEN
+ INFO = N + 2
+ GO TO 130
+ END IF
+ END IF
+*
+ CALL STGSNA( SENSE, 'S', BWORK, N, A, LDA, B, LDB,
+ $ WORK( 1 ), N, WORK( IWRK ), N, RCONDE( I ),
+ $ RCONDV( I ), MM, M, WORK( IWRK1 ),
+ $ LWORK-IWRK1+1, IWORK, IERR )
+*
+ 20 CONTINUE
+ END IF
+ END IF
+*
+* Undo balancing on VL and VR and normalization
+* (Workspace: none needed)
+*
+ IF( ILVL ) THEN
+ CALL SGGBAK( BALANC, 'L', N, ILO, IHI, LSCALE, RSCALE, N, VL,
+ $ LDVL, IERR )
+*
+ DO 70 JC = 1, N
+ IF( ALPHAI( JC ).LT.ZERO )
+ $ GO TO 70
+ TEMP = ZERO
+ IF( ALPHAI( JC ).EQ.ZERO ) THEN
+ DO 30 JR = 1, N
+ TEMP = MAX( TEMP, ABS( VL( JR, JC ) ) )
+ 30 CONTINUE
+ ELSE
+ DO 40 JR = 1, N
+ TEMP = MAX( TEMP, ABS( VL( JR, JC ) )+
+ $ ABS( VL( JR, JC+1 ) ) )
+ 40 CONTINUE
+ END IF
+ IF( TEMP.LT.SMLNUM )
+ $ GO TO 70
+ TEMP = ONE / TEMP
+ IF( ALPHAI( JC ).EQ.ZERO ) THEN
+ DO 50 JR = 1, N
+ VL( JR, JC ) = VL( JR, JC )*TEMP
+ 50 CONTINUE
+ ELSE
+ DO 60 JR = 1, N
+ VL( JR, JC ) = VL( JR, JC )*TEMP
+ VL( JR, JC+1 ) = VL( JR, JC+1 )*TEMP
+ 60 CONTINUE
+ END IF
+ 70 CONTINUE
+ END IF
+ IF( ILVR ) THEN
+ CALL SGGBAK( BALANC, 'R', N, ILO, IHI, LSCALE, RSCALE, N, VR,
+ $ LDVR, IERR )
+ DO 120 JC = 1, N
+ IF( ALPHAI( JC ).LT.ZERO )
+ $ GO TO 120
+ TEMP = ZERO
+ IF( ALPHAI( JC ).EQ.ZERO ) THEN
+ DO 80 JR = 1, N
+ TEMP = MAX( TEMP, ABS( VR( JR, JC ) ) )
+ 80 CONTINUE
+ ELSE
+ DO 90 JR = 1, N
+ TEMP = MAX( TEMP, ABS( VR( JR, JC ) )+
+ $ ABS( VR( JR, JC+1 ) ) )
+ 90 CONTINUE
+ END IF
+ IF( TEMP.LT.SMLNUM )
+ $ GO TO 120
+ TEMP = ONE / TEMP
+ IF( ALPHAI( JC ).EQ.ZERO ) THEN
+ DO 100 JR = 1, N
+ VR( JR, JC ) = VR( JR, JC )*TEMP
+ 100 CONTINUE
+ ELSE
+ DO 110 JR = 1, N
+ VR( JR, JC ) = VR( JR, JC )*TEMP
+ VR( JR, JC+1 ) = VR( JR, JC+1 )*TEMP
+ 110 CONTINUE
+ END IF
+ 120 CONTINUE
+ END IF
+*
+* Undo scaling if necessary
+*
+ IF( ILASCL ) THEN
+ CALL SLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHAR, N, IERR )
+ CALL SLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHAI, N, IERR )
+ END IF
+*
+ IF( ILBSCL ) THEN
+ CALL SLASCL( 'G', 0, 0, BNRMTO, BNRM, N, 1, BETA, N, IERR )
+ END IF
+*
+ 130 CONTINUE
+ WORK( 1 ) = MAXWRK
+*
+ RETURN
+*
+* End of SGGEVX
+*
+ END
+ SUBROUTINE SGGGLM( N, M, P, A, LDA, B, LDB, D, X, Y, WORK, LWORK,
+ $ INFO )
+*
+* -- LAPACK driver routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LDA, LDB, LWORK, M, N, P
+* ..
+* .. Array Arguments ..
+ REAL A( LDA, * ), B( LDB, * ), D( * ), WORK( * ),
+ $ X( * ), Y( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SGGGLM solves a general Gauss-Markov linear model (GLM) problem:
+*
+* minimize || y ||_2 subject to d = A*x + B*y
+* x
+*
+* where A is an N-by-M matrix, B is an N-by-P matrix, and d is a
+* given N-vector. It is assumed that M <= N <= M+P, and
+*
+* rank(A) = M and rank( A B ) = N.
+*
+* Under these assumptions, the constrained equation is always
+* consistent, and there is a unique solution x and a minimal 2-norm
+* solution y, which is obtained using a generalized QR factorization
+* of the matrices (A, B) given by
+*
+* A = Q*(R), B = Q*T*Z.
+* (0)
+*
+* In particular, if matrix B is square nonsingular, then the problem
+* GLM is equivalent to the following weighted linear least squares
+* problem
+*
+* minimize || inv(B)*(d-A*x) ||_2
+* x
+*
+* where inv(B) denotes the inverse of B.
+*
+* Arguments
+* =========
+*
+* N (input) INTEGER
+* The number of rows of the matrices A and B. N >= 0.
+*
+* M (input) INTEGER
+* The number of columns of the matrix A. 0 <= M <= N.
+*
+* P (input) INTEGER
+* The number of columns of the matrix B. P >= N-M.
+*
+* A (input/output) REAL array, dimension (LDA,M)
+* On entry, the N-by-M matrix A.
+* On exit, the upper triangular part of the array A contains
+* the M-by-M upper triangular matrix R.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,N).
+*
+* B (input/output) REAL array, dimension (LDB,P)
+* On entry, the N-by-P matrix B.
+* On exit, if N <= P, the upper triangle of the subarray
+* B(1:N,P-N+1:P) contains the N-by-N upper triangular matrix T;
+* if N > P, the elements on and above the (N-P)th subdiagonal
+* contain the N-by-P upper trapezoidal matrix T.
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. LDB >= max(1,N).
+*
+* D (input/output) REAL array, dimension (N)
+* On entry, D is the left hand side of the GLM equation.
+* On exit, D is destroyed.
+*
+* X (output) REAL array, dimension (M)
+* Y (output) REAL array, dimension (P)
+* On exit, X and Y are the solutions of the GLM problem.
+*
+* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))
+* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+* LWORK (input) INTEGER
+* The dimension of the array WORK. LWORK >= max(1,N+M+P).
+* For optimum performance, LWORK >= M+min(N,P)+max(N,P)*NB,
+* where NB is an upper bound for the optimal blocksizes for
+* SGEQRF, SGERQF, SORMQR and SORMRQ.
+*
+* If LWORK = -1, then a workspace query is assumed; the routine
+* only calculates the optimal size of the WORK array, returns
+* this value as the first entry of the WORK array, and no error
+* message related to LWORK is issued by XERBLA.
+*
+* INFO (output) INTEGER
+* = 0: successful exit.
+* < 0: if INFO = -i, the i-th argument had an illegal value.
+* = 1: the upper triangular factor R associated with A in the
+* generalized QR factorization of the pair (A, B) is
+* singular, so that rank(A) < M; the least squares
+* solution could not be computed.
+* = 2: the bottom (N-M) by (N-M) part of the upper trapezoidal
+* factor T associated with B in the generalized QR
+* factorization of the pair (A, B) is singular, so that
+* rank( A B ) < N; the least squares solution could not
+* be computed.
+*
+* ===================================================================
+*
+* .. Parameters ..
+ REAL ZERO, ONE
+ PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL LQUERY
+ INTEGER I, LOPT, LWKMIN, LWKOPT, NB, NB1, NB2, NB3,
+ $ NB4, NP
+* ..
+* .. External Subroutines ..
+ EXTERNAL SCOPY, SGEMV, SGGQRF, SORMQR, SORMRQ, STRTRS,
+ $ XERBLA
+* ..
+* .. External Functions ..
+ INTEGER ILAENV
+ EXTERNAL ILAENV
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC INT, MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters
+*
+ INFO = 0
+ NP = MIN( N, P )
+ LQUERY = ( LWORK.EQ.-1 )
+ IF( N.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( M.LT.0 .OR. M.GT.N ) THEN
+ INFO = -2
+ ELSE IF( P.LT.0 .OR. P.LT.N-M ) THEN
+ INFO = -3
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -5
+ ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -7
+ END IF
+*
+* Calculate workspace
+*
+ IF( INFO.EQ.0) THEN
+ IF( N.EQ.0 ) THEN
+ LWKMIN = 1
+ LWKOPT = 1
+ ELSE
+ NB1 = ILAENV( 1, 'SGEQRF', ' ', N, M, -1, -1 )
+ NB2 = ILAENV( 1, 'SGERQF', ' ', N, M, -1, -1 )
+ NB3 = ILAENV( 1, 'SORMQR', ' ', N, M, P, -1 )
+ NB4 = ILAENV( 1, 'SORMRQ', ' ', N, M, P, -1 )
+ NB = MAX( NB1, NB2, NB3, NB4 )
+ LWKMIN = M + N + P
+ LWKOPT = M + NP + MAX( N, P )*NB
+ END IF
+ WORK( 1 ) = LWKOPT
+*
+ IF( LWORK.LT.LWKMIN .AND. .NOT.LQUERY ) THEN
+ INFO = -12
+ END IF
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SGGGLM', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+* Compute the GQR factorization of matrices A and B:
+*
+* Q'*A = ( R11 ) M, Q'*B*Z' = ( T11 T12 ) M
+* ( 0 ) N-M ( 0 T22 ) N-M
+* M M+P-N N-M
+*
+* where R11 and T22 are upper triangular, and Q and Z are
+* orthogonal.
+*
+ CALL SGGQRF( N, M, P, A, LDA, WORK, B, LDB, WORK( M+1 ),
+ $ WORK( M+NP+1 ), LWORK-M-NP, INFO )
+ LOPT = WORK( M+NP+1 )
+*
+* Update left-hand-side vector d = Q'*d = ( d1 ) M
+* ( d2 ) N-M
+*
+ CALL SORMQR( 'Left', 'Transpose', N, 1, M, A, LDA, WORK, D,
+ $ MAX( 1, N ), WORK( M+NP+1 ), LWORK-M-NP, INFO )
+ LOPT = MAX( LOPT, INT( WORK( M+NP+1 ) ) )
+*
+* Solve T22*y2 = d2 for y2
+*
+ IF( N.GT.M ) THEN
+ CALL STRTRS( 'Upper', 'No transpose', 'Non unit', N-M, 1,
+ $ B( M+1, M+P-N+1 ), LDB, D( M+1 ), N-M, INFO )
+*
+ IF( INFO.GT.0 ) THEN
+ INFO = 1
+ RETURN
+ END IF
+*
+ CALL SCOPY( N-M, D( M+1 ), 1, Y( M+P-N+1 ), 1 )
+ END IF
+*
+* Set y1 = 0
+*
+ DO 10 I = 1, M + P - N
+ Y( I ) = ZERO
+ 10 CONTINUE
+*
+* Update d1 = d1 - T12*y2
+*
+ CALL SGEMV( 'No transpose', M, N-M, -ONE, B( 1, M+P-N+1 ), LDB,
+ $ Y( M+P-N+1 ), 1, ONE, D, 1 )
+*
+* Solve triangular system: R11*x = d1
+*
+ IF( M.GT.0 ) THEN
+ CALL STRTRS( 'Upper', 'No Transpose', 'Non unit', M, 1, A, LDA,
+ $ D, M, INFO )
+*
+ IF( INFO.GT.0 ) THEN
+ INFO = 2
+ RETURN
+ END IF
+*
+* Copy D to X
+*
+ CALL SCOPY( M, D, 1, X, 1 )
+ END IF
+*
+* Backward transformation y = Z'*y
+*
+ CALL SORMRQ( 'Left', 'Transpose', P, 1, NP,
+ $ B( MAX( 1, N-P+1 ), 1 ), LDB, WORK( M+1 ), Y,
+ $ MAX( 1, P ), WORK( M+NP+1 ), LWORK-M-NP, INFO )
+ WORK( 1 ) = M + NP + MAX( LOPT, INT( WORK( M+NP+1 ) ) )
+*
+ RETURN
+*
+* End of SGGGLM
+*
+ END
+ SUBROUTINE SGGHRD( COMPQ, COMPZ, N, ILO, IHI, A, LDA, B, LDB, Q,
+ $ LDQ, Z, LDZ, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER COMPQ, COMPZ
+ INTEGER IHI, ILO, INFO, LDA, LDB, LDQ, LDZ, N
+* ..
+* .. Array Arguments ..
+ REAL A( LDA, * ), B( LDB, * ), Q( LDQ, * ),
+ $ Z( LDZ, * )
+* ..
+*
+* Purpose
+* =======
+*
+* SGGHRD reduces a pair of real matrices (A,B) to generalized upper
+* Hessenberg form using orthogonal transformations, where A is a
+* general matrix and B is upper triangular. The form of the
+* generalized eigenvalue problem is
+* A*x = lambda*B*x,
+* and B is typically made upper triangular by computing its QR
+* factorization and moving the orthogonal matrix Q to the left side
+* of the equation.
+*
+* This subroutine simultaneously reduces A to a Hessenberg matrix H:
+* Q**T*A*Z = H
+* and transforms B to another upper triangular matrix T:
+* Q**T*B*Z = T
+* in order to reduce the problem to its standard form
+* H*y = lambda*T*y
+* where y = Z**T*x.
+*
+* The orthogonal matrices Q and Z are determined as products of Givens
+* rotations. They may either be formed explicitly, or they may be
+* postmultiplied into input matrices Q1 and Z1, so that
+*
+* Q1 * A * Z1**T = (Q1*Q) * H * (Z1*Z)**T
+*
+* Q1 * B * Z1**T = (Q1*Q) * T * (Z1*Z)**T
+*
+* If Q1 is the orthogonal matrix from the QR factorization of B in the
+* original equation A*x = lambda*B*x, then SGGHRD reduces the original
+* problem to generalized Hessenberg form.
+*
+* Arguments
+* =========
+*
+* COMPQ (input) CHARACTER*1
+* = 'N': do not compute Q;
+* = 'I': Q is initialized to the unit matrix, and the
+* orthogonal matrix Q is returned;
+* = 'V': Q must contain an orthogonal matrix Q1 on entry,
+* and the product Q1*Q is returned.
+*
+* COMPZ (input) CHARACTER*1
+* = 'N': do not compute Z;
+* = 'I': Z is initialized to the unit matrix, and the
+* orthogonal matrix Z is returned;
+* = 'V': Z must contain an orthogonal matrix Z1 on entry,
+* and the product Z1*Z is returned.
+*
+* N (input) INTEGER
+* The order of the matrices A and B. N >= 0.
+*
+* ILO (input) INTEGER
+* IHI (input) INTEGER
+* ILO and IHI mark the rows and columns of A which are to be
+* reduced. It is assumed that A is already upper triangular
+* in rows and columns 1:ILO-1 and IHI+1:N. ILO and IHI are
+* normally set by a previous call to SGGBAL; otherwise they
+* should be set to 1 and N respectively.
+* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.
+*
+* A (input/output) REAL array, dimension (LDA, N)
+* On entry, the N-by-N general matrix to be reduced.
+* On exit, the upper triangle and the first subdiagonal of A
+* are overwritten with the upper Hessenberg matrix H, and the
+* rest is set to zero.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,N).
+*
+* B (input/output) REAL array, dimension (LDB, N)
+* On entry, the N-by-N upper triangular matrix B.
+* On exit, the upper triangular matrix T = Q**T B Z. The
+* elements below the diagonal are set to zero.
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. LDB >= max(1,N).
+*
+* Q (input/output) REAL array, dimension (LDQ, N)
+* On entry, if COMPQ = 'V', the orthogonal matrix Q1,
+* typically from the QR factorization of B.
+* On exit, if COMPQ='I', the orthogonal matrix Q, and if
+* COMPQ = 'V', the product Q1*Q.
+* Not referenced if COMPQ='N'.
+*
+* LDQ (input) INTEGER
+* The leading dimension of the array Q.
+* LDQ >= N if COMPQ='V' or 'I'; LDQ >= 1 otherwise.
+*
+* Z (input/output) REAL array, dimension (LDZ, N)
+* On entry, if COMPZ = 'V', the orthogonal matrix Z1.
+* On exit, if COMPZ='I', the orthogonal matrix Z, and if
+* COMPZ = 'V', the product Z1*Z.
+* Not referenced if COMPZ='N'.
+*
+* LDZ (input) INTEGER
+* The leading dimension of the array Z.
+* LDZ >= N if COMPZ='V' or 'I'; LDZ >= 1 otherwise.
+*
+* INFO (output) INTEGER
+* = 0: successful exit.
+* < 0: if INFO = -i, the i-th argument had an illegal value.
+*
+* Further Details
+* ===============
+*
+* This routine reduces A to Hessenberg and B to triangular form by
+* an unblocked reduction, as described in _Matrix_Computations_,
+* by Golub and Van Loan (Johns Hopkins Press.)
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ONE, ZERO
+ PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL ILQ, ILZ
+ INTEGER ICOMPQ, ICOMPZ, JCOL, JROW
+ REAL C, S, TEMP
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL SLARTG, SLASET, SROT, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+* Decode COMPQ
+*
+ IF( LSAME( COMPQ, 'N' ) ) THEN
+ ILQ = .FALSE.
+ ICOMPQ = 1
+ ELSE IF( LSAME( COMPQ, 'V' ) ) THEN
+ ILQ = .TRUE.
+ ICOMPQ = 2
+ ELSE IF( LSAME( COMPQ, 'I' ) ) THEN
+ ILQ = .TRUE.
+ ICOMPQ = 3
+ ELSE
+ ICOMPQ = 0
+ END IF
+*
+* Decode COMPZ
+*
+ IF( LSAME( COMPZ, 'N' ) ) THEN
+ ILZ = .FALSE.
+ ICOMPZ = 1
+ ELSE IF( LSAME( COMPZ, 'V' ) ) THEN
+ ILZ = .TRUE.
+ ICOMPZ = 2
+ ELSE IF( LSAME( COMPZ, 'I' ) ) THEN
+ ILZ = .TRUE.
+ ICOMPZ = 3
+ ELSE
+ ICOMPZ = 0
+ END IF
+*
+* Test the input parameters.
+*
+ INFO = 0
+ IF( ICOMPQ.LE.0 ) THEN
+ INFO = -1
+ ELSE IF( ICOMPZ.LE.0 ) THEN
+ INFO = -2
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( ILO.LT.1 ) THEN
+ INFO = -4
+ ELSE IF( IHI.GT.N .OR. IHI.LT.ILO-1 ) THEN
+ INFO = -5
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -7
+ ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -9
+ ELSE IF( ( ILQ .AND. LDQ.LT.N ) .OR. LDQ.LT.1 ) THEN
+ INFO = -11
+ ELSE IF( ( ILZ .AND. LDZ.LT.N ) .OR. LDZ.LT.1 ) THEN
+ INFO = -13
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SGGHRD', -INFO )
+ RETURN
+ END IF
+*
+* Initialize Q and Z if desired.
+*
+ IF( ICOMPQ.EQ.3 )
+ $ CALL SLASET( 'Full', N, N, ZERO, ONE, Q, LDQ )
+ IF( ICOMPZ.EQ.3 )
+ $ CALL SLASET( 'Full', N, N, ZERO, ONE, Z, LDZ )
+*
+* Quick return if possible
+*
+ IF( N.LE.1 )
+ $ RETURN
+*
+* Zero out lower triangle of B
+*
+ DO 20 JCOL = 1, N - 1
+ DO 10 JROW = JCOL + 1, N
+ B( JROW, JCOL ) = ZERO
+ 10 CONTINUE
+ 20 CONTINUE
+*
+* Reduce A and B
+*
+ DO 40 JCOL = ILO, IHI - 2
+*
+ DO 30 JROW = IHI, JCOL + 2, -1
+*
+* Step 1: rotate rows JROW-1, JROW to kill A(JROW,JCOL)
+*
+ TEMP = A( JROW-1, JCOL )
+ CALL SLARTG( TEMP, A( JROW, JCOL ), C, S,
+ $ A( JROW-1, JCOL ) )
+ A( JROW, JCOL ) = ZERO
+ CALL SROT( N-JCOL, A( JROW-1, JCOL+1 ), LDA,
+ $ A( JROW, JCOL+1 ), LDA, C, S )
+ CALL SROT( N+2-JROW, B( JROW-1, JROW-1 ), LDB,
+ $ B( JROW, JROW-1 ), LDB, C, S )
+ IF( ILQ )
+ $ CALL SROT( N, Q( 1, JROW-1 ), 1, Q( 1, JROW ), 1, C, S )
+*
+* Step 2: rotate columns JROW, JROW-1 to kill B(JROW,JROW-1)
+*
+ TEMP = B( JROW, JROW )
+ CALL SLARTG( TEMP, B( JROW, JROW-1 ), C, S,
+ $ B( JROW, JROW ) )
+ B( JROW, JROW-1 ) = ZERO
+ CALL SROT( IHI, A( 1, JROW ), 1, A( 1, JROW-1 ), 1, C, S )
+ CALL SROT( JROW-1, B( 1, JROW ), 1, B( 1, JROW-1 ), 1, C,
+ $ S )
+ IF( ILZ )
+ $ CALL SROT( N, Z( 1, JROW ), 1, Z( 1, JROW-1 ), 1, C, S )
+ 30 CONTINUE
+ 40 CONTINUE
+*
+ RETURN
+*
+* End of SGGHRD
+*
+ END
+ SUBROUTINE SGGLSE( M, N, P, A, LDA, B, LDB, C, D, X, WORK, LWORK,
+ $ INFO )
+*
+* -- LAPACK driver routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LDA, LDB, LWORK, M, N, P
+* ..
+* .. Array Arguments ..
+ REAL A( LDA, * ), B( LDB, * ), C( * ), D( * ),
+ $ WORK( * ), X( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SGGLSE solves the linear equality-constrained least squares (LSE)
+* problem:
+*
+* minimize || c - A*x ||_2 subject to B*x = d
+*
+* where A is an M-by-N matrix, B is a P-by-N matrix, c is a given
+* M-vector, and d is a given P-vector. It is assumed that
+* P <= N <= M+P, and
+*
+* rank(B) = P and rank( (A) ) = N.
+* ( (B) )
+*
+* These conditions ensure that the LSE problem has a unique solution,
+* which is obtained using a generalized RQ factorization of the
+* matrices (B, A) given by
+*
+* B = (0 R)*Q, A = Z*T*Q.
+*
+* Arguments
+* =========
+*
+* M (input) INTEGER
+* The number of rows of the matrix A. M >= 0.
+*
+* N (input) INTEGER
+* The number of columns of the matrices A and B. N >= 0.
+*
+* P (input) INTEGER
+* The number of rows of the matrix B. 0 <= P <= N <= M+P.
+*
+* A (input/output) REAL array, dimension (LDA,N)
+* On entry, the M-by-N matrix A.
+* On exit, the elements on and above the diagonal of the array
+* contain the min(M,N)-by-N upper trapezoidal matrix T.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,M).
+*
+* B (input/output) REAL array, dimension (LDB,N)
+* On entry, the P-by-N matrix B.
+* On exit, the upper triangle of the subarray B(1:P,N-P+1:N)
+* contains the P-by-P upper triangular matrix R.
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. LDB >= max(1,P).
+*
+* C (input/output) REAL array, dimension (M)
+* On entry, C contains the right hand side vector for the
+* least squares part of the LSE problem.
+* On exit, the residual sum of squares for the solution
+* is given by the sum of squares of elements N-P+1 to M of
+* vector C.
+*
+* D (input/output) REAL array, dimension (P)
+* On entry, D contains the right hand side vector for the
+* constrained equation.
+* On exit, D is destroyed.
+*
+* X (output) REAL array, dimension (N)
+* On exit, X is the solution of the LSE problem.
+*
+* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))
+* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+* LWORK (input) INTEGER
+* The dimension of the array WORK. LWORK >= max(1,M+N+P).
+* For optimum performance LWORK >= P+min(M,N)+max(M,N)*NB,
+* where NB is an upper bound for the optimal blocksizes for
+* SGEQRF, SGERQF, SORMQR and SORMRQ.
+*
+* If LWORK = -1, then a workspace query is assumed; the routine
+* only calculates the optimal size of the WORK array, returns
+* this value as the first entry of the WORK array, and no error
+* message related to LWORK is issued by XERBLA.
+*
+* INFO (output) INTEGER
+* = 0: successful exit.
+* < 0: if INFO = -i, the i-th argument had an illegal value.
+* = 1: the upper triangular factor R associated with B in the
+* generalized RQ factorization of the pair (B, A) is
+* singular, so that rank(B) < P; the least squares
+* solution could not be computed.
+* = 2: the (N-P) by (N-P) part of the upper trapezoidal factor
+* T associated with A in the generalized RQ factorization
+* of the pair (B, A) is singular, so that
+* rank( (A) ) < N; the least squares solution could not
+* ( (B) )
+* be computed.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ONE
+ PARAMETER ( ONE = 1.0E+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL LQUERY
+ INTEGER LOPT, LWKMIN, LWKOPT, MN, NB, NB1, NB2, NB3,
+ $ NB4, NR
+* ..
+* .. External Subroutines ..
+ EXTERNAL SAXPY, SCOPY, SGEMV, SGGRQF, SORMQR, SORMRQ,
+ $ STRMV, STRTRS, XERBLA
+* ..
+* .. External Functions ..
+ INTEGER ILAENV
+ EXTERNAL ILAENV
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC INT, MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters
+*
+ INFO = 0
+ MN = MIN( M, N )
+ LQUERY = ( LWORK.EQ.-1 )
+ IF( M.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( P.LT.0 .OR. P.GT.N .OR. P.LT.N-M ) THEN
+ INFO = -3
+ ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+ INFO = -5
+ ELSE IF( LDB.LT.MAX( 1, P ) ) THEN
+ INFO = -7
+ END IF
+*
+* Calculate workspace
+*
+ IF( INFO.EQ.0) THEN
+ IF( N.EQ.0 ) THEN
+ LWKMIN = 1
+ LWKOPT = 1
+ ELSE
+ NB1 = ILAENV( 1, 'SGEQRF', ' ', M, N, -1, -1 )
+ NB2 = ILAENV( 1, 'SGERQF', ' ', M, N, -1, -1 )
+ NB3 = ILAENV( 1, 'SORMQR', ' ', M, N, P, -1 )
+ NB4 = ILAENV( 1, 'SORMRQ', ' ', M, N, P, -1 )
+ NB = MAX( NB1, NB2, NB3, NB4 )
+ LWKMIN = M + N + P
+ LWKOPT = P + MN + MAX( M, N )*NB
+ END IF
+ WORK( 1 ) = LWKOPT
+*
+ IF( LWORK.LT.LWKMIN .AND. .NOT.LQUERY ) THEN
+ INFO = -12
+ END IF
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SGGLSE', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+* Compute the GRQ factorization of matrices B and A:
+*
+* B*Q' = ( 0 T12 ) P Z'*A*Q' = ( R11 R12 ) N-P
+* N-P P ( 0 R22 ) M+P-N
+* N-P P
+*
+* where T12 and R11 are upper triangular, and Q and Z are
+* orthogonal.
+*
+ CALL SGGRQF( P, M, N, B, LDB, WORK, A, LDA, WORK( P+1 ),
+ $ WORK( P+MN+1 ), LWORK-P-MN, INFO )
+ LOPT = WORK( P+MN+1 )
+*
+* Update c = Z'*c = ( c1 ) N-P
+* ( c2 ) M+P-N
+*
+ CALL SORMQR( 'Left', 'Transpose', M, 1, MN, A, LDA, WORK( P+1 ),
+ $ C, MAX( 1, M ), WORK( P+MN+1 ), LWORK-P-MN, INFO )
+ LOPT = MAX( LOPT, INT( WORK( P+MN+1 ) ) )
+*
+* Solve T12*x2 = d for x2
+*
+ IF( P.GT.0 ) THEN
+ CALL STRTRS( 'Upper', 'No transpose', 'Non-unit', P, 1,
+ $ B( 1, N-P+1 ), LDB, D, P, INFO )
+*
+ IF( INFO.GT.0 ) THEN
+ INFO = 1
+ RETURN
+ END IF
+*
+* Put the solution in X
+*
+ CALL SCOPY( P, D, 1, X( N-P+1 ), 1 )
+*
+* Update c1
+*
+ CALL SGEMV( 'No transpose', N-P, P, -ONE, A( 1, N-P+1 ), LDA,
+ $ D, 1, ONE, C, 1 )
+ END IF
+*
+* Solve R11*x1 = c1 for x1
+*
+ IF( N.GT.P ) THEN
+ CALL STRTRS( 'Upper', 'No transpose', 'Non-unit', N-P, 1,
+ $ A, LDA, C, N-P, INFO )
+*
+ IF( INFO.GT.0 ) THEN
+ INFO = 2
+ RETURN
+ END IF
+*
+* Put the solution in X
+*
+ CALL SCOPY( N-P, C, 1, X, 1 )
+ END IF
+*
+* Compute the residual vector:
+*
+ IF( M.LT.N ) THEN
+ NR = M + P - N
+ IF( NR.GT.0 )
+ $ CALL SGEMV( 'No transpose', NR, N-M, -ONE, A( N-P+1, M+1 ),
+ $ LDA, D( NR+1 ), 1, ONE, C( N-P+1 ), 1 )
+ ELSE
+ NR = P
+ END IF
+ IF( NR.GT.0 ) THEN
+ CALL STRMV( 'Upper', 'No transpose', 'Non unit', NR,
+ $ A( N-P+1, N-P+1 ), LDA, D, 1 )
+ CALL SAXPY( NR, -ONE, D, 1, C( N-P+1 ), 1 )
+ END IF
+*
+* Backward transformation x = Q'*x
+*
+ CALL SORMRQ( 'Left', 'Transpose', N, 1, P, B, LDB, WORK( 1 ), X,
+ $ N, WORK( P+MN+1 ), LWORK-P-MN, INFO )
+ WORK( 1 ) = P + MN + MAX( LOPT, INT( WORK( P+MN+1 ) ) )
+*
+ RETURN
+*
+* End of SGGLSE
+*
+ END
+ SUBROUTINE SGGQRF( N, M, P, A, LDA, TAUA, B, LDB, TAUB, WORK,
+ $ LWORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LDA, LDB, LWORK, M, N, P
+* ..
+* .. Array Arguments ..
+ REAL A( LDA, * ), B( LDB, * ), TAUA( * ), TAUB( * ),
+ $ WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SGGQRF computes a generalized QR factorization of an N-by-M matrix A
+* and an N-by-P matrix B:
+*
+* A = Q*R, B = Q*T*Z,
+*
+* where Q is an N-by-N orthogonal matrix, Z is a P-by-P orthogonal
+* matrix, and R and T assume one of the forms:
+*
+* if N >= M, R = ( R11 ) M , or if N < M, R = ( R11 R12 ) N,
+* ( 0 ) N-M N M-N
+* M
+*
+* where R11 is upper triangular, and
+*
+* if N <= P, T = ( 0 T12 ) N, or if N > P, T = ( T11 ) N-P,
+* P-N N ( T21 ) P
+* P
+*
+* where T12 or T21 is upper triangular.
+*
+* In particular, if B is square and nonsingular, the GQR factorization
+* of A and B implicitly gives the QR factorization of inv(B)*A:
+*
+* inv(B)*A = Z'*(inv(T)*R)
+*
+* where inv(B) denotes the inverse of the matrix B, and Z' denotes the
+* transpose of the matrix Z.
+*
+* Arguments
+* =========
+*
+* N (input) INTEGER
+* The number of rows of the matrices A and B. N >= 0.
+*
+* M (input) INTEGER
+* The number of columns of the matrix A. M >= 0.
+*
+* P (input) INTEGER
+* The number of columns of the matrix B. P >= 0.
+*
+* A (input/output) REAL array, dimension (LDA,M)
+* On entry, the N-by-M matrix A.
+* On exit, the elements on and above the diagonal of the array
+* contain the min(N,M)-by-M upper trapezoidal matrix R (R is
+* upper triangular if N >= M); the elements below the diagonal,
+* with the array TAUA, represent the orthogonal matrix Q as a
+* product of min(N,M) elementary reflectors (see Further
+* Details).
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,N).
+*
+* TAUA (output) REAL array, dimension (min(N,M))
+* The scalar factors of the elementary reflectors which
+* represent the orthogonal matrix Q (see Further Details).
+*
+* B (input/output) REAL array, dimension (LDB,P)
+* On entry, the N-by-P matrix B.
+* On exit, if N <= P, the upper triangle of the subarray
+* B(1:N,P-N+1:P) contains the N-by-N upper triangular matrix T;
+* if N > P, the elements on and above the (N-P)-th subdiagonal
+* contain the N-by-P upper trapezoidal matrix T; the remaining
+* elements, with the array TAUB, represent the orthogonal
+* matrix Z as a product of elementary reflectors (see Further
+* Details).
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. LDB >= max(1,N).
+*
+* TAUB (output) REAL array, dimension (min(N,P))
+* The scalar factors of the elementary reflectors which
+* represent the orthogonal matrix Z (see Further Details).
+*
+* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))
+* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+* LWORK (input) INTEGER
+* The dimension of the array WORK. LWORK >= max(1,N,M,P).
+* For optimum performance LWORK >= max(N,M,P)*max(NB1,NB2,NB3),
+* where NB1 is the optimal blocksize for the QR factorization
+* of an N-by-M matrix, NB2 is the optimal blocksize for the
+* RQ factorization of an N-by-P matrix, and NB3 is the optimal
+* blocksize for a call of SORMQR.
+*
+* If LWORK = -1, then a workspace query is assumed; the routine
+* only calculates the optimal size of the WORK array, returns
+* this value as the first entry of the WORK array, and no error
+* message related to LWORK is issued by XERBLA.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value.
+*
+* Further Details
+* ===============
+*
+* The matrix Q is represented as a product of elementary reflectors
+*
+* Q = H(1) H(2) . . . H(k), where k = min(n,m).
+*
+* Each H(i) has the form
+*
+* H(i) = I - taua * v * v'
+*
+* where taua is a real scalar, and v is a real vector with
+* v(1:i-1) = 0 and v(i) = 1; v(i+1:n) is stored on exit in A(i+1:n,i),
+* and taua in TAUA(i).
+* To form Q explicitly, use LAPACK subroutine SORGQR.
+* To use Q to update another matrix, use LAPACK subroutine SORMQR.
+*
+* The matrix Z is represented as a product of elementary reflectors
+*
+* Z = H(1) H(2) . . . H(k), where k = min(n,p).
+*
+* Each H(i) has the form
+*
+* H(i) = I - taub * v * v'
+*
+* where taub is a real scalar, and v is a real vector with
+* v(p-k+i+1:p) = 0 and v(p-k+i) = 1; v(1:p-k+i-1) is stored on exit in
+* B(n-k+i,1:p-k+i-1), and taub in TAUB(i).
+* To form Z explicitly, use LAPACK subroutine SORGRQ.
+* To use Z to update another matrix, use LAPACK subroutine SORMRQ.
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ LOGICAL LQUERY
+ INTEGER LOPT, LWKOPT, NB, NB1, NB2, NB3
+* ..
+* .. External Subroutines ..
+ EXTERNAL SGEQRF, SGERQF, SORMQR, XERBLA
+* ..
+* .. External Functions ..
+ INTEGER ILAENV
+ EXTERNAL ILAENV
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC INT, MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters
+*
+ INFO = 0
+ NB1 = ILAENV( 1, 'SGEQRF', ' ', N, M, -1, -1 )
+ NB2 = ILAENV( 1, 'SGERQF', ' ', N, P, -1, -1 )
+ NB3 = ILAENV( 1, 'SORMQR', ' ', N, M, P, -1 )
+ NB = MAX( NB1, NB2, NB3 )
+ LWKOPT = MAX( N, M, P )*NB
+ WORK( 1 ) = LWKOPT
+ LQUERY = ( LWORK.EQ.-1 )
+ IF( N.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( M.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( P.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -5
+ ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -8
+ ELSE IF( LWORK.LT.MAX( 1, N, M, P ) .AND. .NOT.LQUERY ) THEN
+ INFO = -11
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SGGQRF', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* QR factorization of N-by-M matrix A: A = Q*R
+*
+ CALL SGEQRF( N, M, A, LDA, TAUA, WORK, LWORK, INFO )
+ LOPT = WORK( 1 )
+*
+* Update B := Q'*B.
+*
+ CALL SORMQR( 'Left', 'Transpose', N, P, MIN( N, M ), A, LDA, TAUA,
+ $ B, LDB, WORK, LWORK, INFO )
+ LOPT = MAX( LOPT, INT( WORK( 1 ) ) )
+*
+* RQ factorization of N-by-P matrix B: B = T*Z.
+*
+ CALL SGERQF( N, P, B, LDB, TAUB, WORK, LWORK, INFO )
+ WORK( 1 ) = MAX( LOPT, INT( WORK( 1 ) ) )
+*
+ RETURN
+*
+* End of SGGQRF
+*
+ END
+ SUBROUTINE SGGRQF( M, P, N, A, LDA, TAUA, B, LDB, TAUB, WORK,
+ $ LWORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LDA, LDB, LWORK, M, N, P
+* ..
+* .. Array Arguments ..
+ REAL A( LDA, * ), B( LDB, * ), TAUA( * ), TAUB( * ),
+ $ WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SGGRQF computes a generalized RQ factorization of an M-by-N matrix A
+* and a P-by-N matrix B:
+*
+* A = R*Q, B = Z*T*Q,
+*
+* where Q is an N-by-N orthogonal matrix, Z is a P-by-P orthogonal
+* matrix, and R and T assume one of the forms:
+*
+* if M <= N, R = ( 0 R12 ) M, or if M > N, R = ( R11 ) M-N,
+* N-M M ( R21 ) N
+* N
+*
+* where R12 or R21 is upper triangular, and
+*
+* if P >= N, T = ( T11 ) N , or if P < N, T = ( T11 T12 ) P,
+* ( 0 ) P-N P N-P
+* N
+*
+* where T11 is upper triangular.
+*
+* In particular, if B is square and nonsingular, the GRQ factorization
+* of A and B implicitly gives the RQ factorization of A*inv(B):
+*
+* A*inv(B) = (R*inv(T))*Z'
+*
+* where inv(B) denotes the inverse of the matrix B, and Z' denotes the
+* transpose of the matrix Z.
+*
+* Arguments
+* =========
+*
+* M (input) INTEGER
+* The number of rows of the matrix A. M >= 0.
+*
+* P (input) INTEGER
+* The number of rows of the matrix B. P >= 0.
+*
+* N (input) INTEGER
+* The number of columns of the matrices A and B. N >= 0.
+*
+* A (input/output) REAL array, dimension (LDA,N)
+* On entry, the M-by-N matrix A.
+* On exit, if M <= N, the upper triangle of the subarray
+* A(1:M,N-M+1:N) contains the M-by-M upper triangular matrix R;
+* if M > N, the elements on and above the (M-N)-th subdiagonal
+* contain the M-by-N upper trapezoidal matrix R; the remaining
+* elements, with the array TAUA, represent the orthogonal
+* matrix Q as a product of elementary reflectors (see Further
+* Details).
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,M).
+*
+* TAUA (output) REAL array, dimension (min(M,N))
+* The scalar factors of the elementary reflectors which
+* represent the orthogonal matrix Q (see Further Details).
+*
+* B (input/output) REAL array, dimension (LDB,N)
+* On entry, the P-by-N matrix B.
+* On exit, the elements on and above the diagonal of the array
+* contain the min(P,N)-by-N upper trapezoidal matrix T (T is
+* upper triangular if P >= N); the elements below the diagonal,
+* with the array TAUB, represent the orthogonal matrix Z as a
+* product of elementary reflectors (see Further Details).
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. LDB >= max(1,P).
+*
+* TAUB (output) REAL array, dimension (min(P,N))
+* The scalar factors of the elementary reflectors which
+* represent the orthogonal matrix Z (see Further Details).
+*
+* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))
+* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+* LWORK (input) INTEGER
+* The dimension of the array WORK. LWORK >= max(1,N,M,P).
+* For optimum performance LWORK >= max(N,M,P)*max(NB1,NB2,NB3),
+* where NB1 is the optimal blocksize for the RQ factorization
+* of an M-by-N matrix, NB2 is the optimal blocksize for the
+* QR factorization of a P-by-N matrix, and NB3 is the optimal
+* blocksize for a call of SORMRQ.
+*
+* If LWORK = -1, then a workspace query is assumed; the routine
+* only calculates the optimal size of the WORK array, returns
+* this value as the first entry of the WORK array, and no error
+* message related to LWORK is issued by XERBLA.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INF0= -i, the i-th argument had an illegal value.
+*
+* Further Details
+* ===============
+*
+* The matrix Q is represented as a product of elementary reflectors
+*
+* Q = H(1) H(2) . . . H(k), where k = min(m,n).
+*
+* Each H(i) has the form
+*
+* H(i) = I - taua * v * v'
+*
+* where taua is a real scalar, and v is a real vector with
+* v(n-k+i+1:n) = 0 and v(n-k+i) = 1; v(1:n-k+i-1) is stored on exit in
+* A(m-k+i,1:n-k+i-1), and taua in TAUA(i).
+* To form Q explicitly, use LAPACK subroutine SORGRQ.
+* To use Q to update another matrix, use LAPACK subroutine SORMRQ.
+*
+* The matrix Z is represented as a product of elementary reflectors
+*
+* Z = H(1) H(2) . . . H(k), where k = min(p,n).
+*
+* Each H(i) has the form
+*
+* H(i) = I - taub * v * v'
+*
+* where taub is a real scalar, and v is a real vector with
+* v(1:i-1) = 0 and v(i) = 1; v(i+1:p) is stored on exit in B(i+1:p,i),
+* and taub in TAUB(i).
+* To form Z explicitly, use LAPACK subroutine SORGQR.
+* To use Z to update another matrix, use LAPACK subroutine SORMQR.
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ LOGICAL LQUERY
+ INTEGER LOPT, LWKOPT, NB, NB1, NB2, NB3
+* ..
+* .. External Subroutines ..
+ EXTERNAL SGEQRF, SGERQF, SORMRQ, XERBLA
+* ..
+* .. External Functions ..
+ INTEGER ILAENV
+ EXTERNAL ILAENV
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC INT, MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters
+*
+ INFO = 0
+ NB1 = ILAENV( 1, 'SGERQF', ' ', M, N, -1, -1 )
+ NB2 = ILAENV( 1, 'SGEQRF', ' ', P, N, -1, -1 )
+ NB3 = ILAENV( 1, 'SORMRQ', ' ', M, N, P, -1 )
+ NB = MAX( NB1, NB2, NB3 )
+ LWKOPT = MAX( N, M, P)*NB
+ WORK( 1 ) = LWKOPT
+ LQUERY = ( LWORK.EQ.-1 )
+ IF( M.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( P.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+ INFO = -5
+ ELSE IF( LDB.LT.MAX( 1, P ) ) THEN
+ INFO = -8
+ ELSE IF( LWORK.LT.MAX( 1, M, P, N ) .AND. .NOT.LQUERY ) THEN
+ INFO = -11
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SGGRQF', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* RQ factorization of M-by-N matrix A: A = R*Q
+*
+ CALL SGERQF( M, N, A, LDA, TAUA, WORK, LWORK, INFO )
+ LOPT = WORK( 1 )
+*
+* Update B := B*Q'
+*
+ CALL SORMRQ( 'Right', 'Transpose', P, N, MIN( M, N ),
+ $ A( MAX( 1, M-N+1 ), 1 ), LDA, TAUA, B, LDB, WORK,
+ $ LWORK, INFO )
+ LOPT = MAX( LOPT, INT( WORK( 1 ) ) )
+*
+* QR factorization of P-by-N matrix B: B = Z*T
+*
+ CALL SGEQRF( P, N, B, LDB, TAUB, WORK, LWORK, INFO )
+ WORK( 1 ) = MAX( LOPT, INT( WORK( 1 ) ) )
+*
+ RETURN
+*
+* End of SGGRQF
+*
+ END
+ 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 )
+*
+* -- LAPACK driver routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER JOBQ, JOBU, JOBV
+ INTEGER INFO, K, L, LDA, LDB, LDQ, LDU, LDV, M, N, P
+* ..
+* .. Array Arguments ..
+ INTEGER IWORK( * )
+ REAL A( LDA, * ), ALPHA( * ), B( LDB, * ),
+ $ BETA( * ), Q( LDQ, * ), U( LDU, * ),
+ $ V( LDV, * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SGGSVD computes the generalized singular value decomposition (GSVD)
+* of an M-by-N real matrix A and P-by-N real matrix B:
+*
+* U'*A*Q = D1*( 0 R ), V'*B*Q = D2*( 0 R )
+*
+* where U, V and Q are orthogonal matrices, and Z' is the transpose
+* of Z. Let K+L = the effective numerical rank of the matrix (A',B')',
+* then R is a K+L-by-K+L nonsingular upper triangular matrix, D1 and
+* D2 are M-by-(K+L) and P-by-(K+L) "diagonal" matrices and of the
+* following structures, respectively:
+*
+* If M-K-L >= 0,
+*
+* K L
+* D1 = K ( I 0 )
+* L ( 0 C )
+* M-K-L ( 0 0 )
+*
+* K L
+* D2 = L ( 0 S )
+* P-L ( 0 0 )
+*
+* N-K-L K L
+* ( 0 R ) = K ( 0 R11 R12 )
+* L ( 0 0 R22 )
+*
+* where
+*
+* C = diag( ALPHA(K+1), ... , ALPHA(K+L) ),
+* S = diag( BETA(K+1), ... , BETA(K+L) ),
+* C**2 + S**2 = I.
+*
+* R is stored in A(1:K+L,N-K-L+1:N) on exit.
+*
+* If M-K-L < 0,
+*
+* K M-K K+L-M
+* D1 = K ( I 0 0 )
+* M-K ( 0 C 0 )
+*
+* K M-K K+L-M
+* D2 = M-K ( 0 S 0 )
+* K+L-M ( 0 0 I )
+* P-L ( 0 0 0 )
+*
+* N-K-L K M-K K+L-M
+* ( 0 R ) = K ( 0 R11 R12 R13 )
+* M-K ( 0 0 R22 R23 )
+* K+L-M ( 0 0 0 R33 )
+*
+* where
+*
+* C = diag( ALPHA(K+1), ... , ALPHA(M) ),
+* S = diag( BETA(K+1), ... , BETA(M) ),
+* C**2 + S**2 = I.
+*
+* (R11 R12 R13 ) is stored in A(1:M, N-K-L+1:N), and R33 is stored
+* ( 0 R22 R23 )
+* in B(M-K+1:L,N+M-K-L+1:N) on exit.
+*
+* The routine computes C, S, R, and optionally the orthogonal
+* transformation matrices U, V and Q.
+*
+* In particular, if B is an N-by-N nonsingular matrix, then the GSVD of
+* A and B implicitly gives the SVD of A*inv(B):
+* A*inv(B) = U*(D1*inv(D2))*V'.
+* If ( A',B')' has orthonormal columns, then the GSVD of A and B is
+* also equal to the CS decomposition of A and B. Furthermore, the GSVD
+* can be used to derive the solution of the eigenvalue problem:
+* A'*A x = lambda* B'*B x.
+* In some literature, the GSVD of A and B is presented in the form
+* U'*A*X = ( 0 D1 ), V'*B*X = ( 0 D2 )
+* where U and V are orthogonal and X is nonsingular, D1 and D2 are
+* ``diagonal''. The former GSVD form can be converted to the latter
+* form by taking the nonsingular matrix X as
+*
+* X = Q*( I 0 )
+* ( 0 inv(R) ).
+*
+* Arguments
+* =========
+*
+* JOBU (input) CHARACTER*1
+* = 'U': Orthogonal matrix U is computed;
+* = 'N': U is not computed.
+*
+* JOBV (input) CHARACTER*1
+* = 'V': Orthogonal matrix V is computed;
+* = 'N': V is not computed.
+*
+* JOBQ (input) CHARACTER*1
+* = 'Q': Orthogonal matrix Q is computed;
+* = 'N': Q is not computed.
+*
+* M (input) INTEGER
+* The number of rows of the matrix A. M >= 0.
+*
+* N (input) INTEGER
+* The number of columns of the matrices A and B. N >= 0.
+*
+* P (input) INTEGER
+* The number of rows of the matrix B. P >= 0.
+*
+* K (output) INTEGER
+* L (output) INTEGER
+* On exit, K and L specify the dimension of the subblocks
+* described in the Purpose section.
+* K + L = effective numerical rank of (A',B')'.
+*
+* A (input/output) REAL array, dimension (LDA,N)
+* On entry, the M-by-N matrix A.
+* On exit, A contains the triangular matrix R, or part of R.
+* See Purpose for details.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,M).
+*
+* B (input/output) REAL array, dimension (LDB,N)
+* On entry, the P-by-N matrix B.
+* On exit, B contains the triangular matrix R if M-K-L < 0.
+* See Purpose for details.
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. LDB >= max(1,P).
+*
+* ALPHA (output) REAL array, dimension (N)
+* BETA (output) REAL array, dimension (N)
+* On exit, ALPHA and BETA contain the generalized singular
+* value pairs of A and B;
+* ALPHA(1:K) = 1,
+* BETA(1:K) = 0,
+* and if M-K-L >= 0,
+* ALPHA(K+1:K+L) = C,
+* BETA(K+1:K+L) = S,
+* or if M-K-L < 0,
+* ALPHA(K+1:M)=C, ALPHA(M+1:K+L)=0
+* BETA(K+1:M) =S, BETA(M+1:K+L) =1
+* and
+* ALPHA(K+L+1:N) = 0
+* BETA(K+L+1:N) = 0
+*
+* U (output) REAL array, dimension (LDU,M)
+* If JOBU = 'U', U contains the M-by-M orthogonal matrix U.
+* If JOBU = 'N', U is not referenced.
+*
+* LDU (input) INTEGER
+* The leading dimension of the array U. LDU >= max(1,M) if
+* JOBU = 'U'; LDU >= 1 otherwise.
+*
+* V (output) REAL array, dimension (LDV,P)
+* If JOBV = 'V', V contains the P-by-P orthogonal matrix V.
+* If JOBV = 'N', V is not referenced.
+*
+* LDV (input) INTEGER
+* The leading dimension of the array V. LDV >= max(1,P) if
+* JOBV = 'V'; LDV >= 1 otherwise.
+*
+* Q (output) REAL array, dimension (LDQ,N)
+* If JOBQ = 'Q', Q contains the N-by-N orthogonal matrix Q.
+* If JOBQ = 'N', Q is not referenced.
+*
+* LDQ (input) INTEGER
+* The leading dimension of the array Q. LDQ >= max(1,N) if
+* JOBQ = 'Q'; LDQ >= 1 otherwise.
+*
+* WORK (workspace) REAL array,
+* dimension (max(3*N,M,P)+N)
+*
+* IWORK (workspace/output) INTEGER array, dimension (N)
+* On exit, IWORK stores the sorting information. More
+* precisely, the following loop will sort ALPHA
+* for I = K+1, min(M,K+L)
+* swap ALPHA(I) and ALPHA(IWORK(I))
+* endfor
+* such that ALPHA(1) >= ALPHA(2) >= ... >= ALPHA(N).
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value.
+* > 0: if INFO = 1, the Jacobi-type procedure failed to
+* converge. For further details, see subroutine STGSJA.
+*
+* Internal Parameters
+* ===================
+*
+* TOLA REAL
+* TOLB REAL
+* TOLA and TOLB are the thresholds to determine the effective
+* rank of (A',B')'. Generally, they are set to
+* TOLA = MAX(M,N)*norm(A)*MACHEPS,
+* TOLB = MAX(P,N)*norm(B)*MACHEPS.
+* The size of TOLA and TOLB may affect the size of backward
+* errors of the decomposition.
+*
+* Further Details
+* ===============
+*
+* 2-96 Based on modifications by
+* Ming Gu and Huan Ren, Computer Science Division, University of
+* California at Berkeley, USA
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ LOGICAL WANTQ, WANTU, WANTV
+ INTEGER I, IBND, ISUB, J, NCYCLE
+ REAL ANORM, BNORM, SMAX, TEMP, TOLA, TOLB, ULP, UNFL
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ REAL SLAMCH, SLANGE
+ EXTERNAL LSAME, SLAMCH, SLANGE
+* ..
+* .. External Subroutines ..
+ EXTERNAL SCOPY, SGGSVP, STGSJA, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters
+*
+ WANTU = LSAME( JOBU, 'U' )
+ WANTV = LSAME( JOBV, 'V' )
+ WANTQ = LSAME( JOBQ, 'Q' )
+*
+ INFO = 0
+ IF( .NOT.( WANTU .OR. LSAME( JOBU, 'N' ) ) ) THEN
+ INFO = -1
+ ELSE IF( .NOT.( WANTV .OR. LSAME( JOBV, 'N' ) ) ) THEN
+ INFO = -2
+ ELSE IF( .NOT.( WANTQ .OR. LSAME( JOBQ, 'N' ) ) ) THEN
+ INFO = -3
+ ELSE IF( M.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -5
+ ELSE IF( P.LT.0 ) THEN
+ INFO = -6
+ ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+ INFO = -10
+ ELSE IF( LDB.LT.MAX( 1, P ) ) THEN
+ INFO = -12
+ ELSE IF( LDU.LT.1 .OR. ( WANTU .AND. LDU.LT.M ) ) THEN
+ INFO = -16
+ ELSE IF( LDV.LT.1 .OR. ( WANTV .AND. LDV.LT.P ) ) THEN
+ INFO = -18
+ ELSE IF( LDQ.LT.1 .OR. ( WANTQ .AND. LDQ.LT.N ) ) THEN
+ INFO = -20
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SGGSVD', -INFO )
+ RETURN
+ END IF
+*
+* Compute the Frobenius norm of matrices A and B
+*
+ ANORM = SLANGE( '1', M, N, A, LDA, WORK )
+ BNORM = SLANGE( '1', P, N, B, LDB, WORK )
+*
+* Get machine precision and set up threshold for determining
+* the effective numerical rank of the matrices A and B.
+*
+ ULP = SLAMCH( 'Precision' )
+ UNFL = SLAMCH( 'Safe Minimum' )
+ TOLA = MAX( M, N )*MAX( ANORM, UNFL )*ULP
+ TOLB = MAX( P, N )*MAX( BNORM, UNFL )*ULP
+*
+* Preprocessing
+*
+ CALL SGGSVP( JOBU, JOBV, JOBQ, M, P, N, A, LDA, B, LDB, TOLA,
+ $ TOLB, K, L, U, LDU, V, LDV, Q, LDQ, IWORK, WORK,
+ $ WORK( N+1 ), INFO )
+*
+* Compute the GSVD of two upper "triangular" matrices
+*
+ CALL 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 )
+*
+* Sort the singular values and store the pivot indices in IWORK
+* Copy ALPHA to WORK, then sort ALPHA in WORK
+*
+ CALL SCOPY( N, ALPHA, 1, WORK, 1 )
+ IBND = MIN( L, M-K )
+ DO 20 I = 1, IBND
+*
+* Scan for largest ALPHA(K+I)
+*
+ ISUB = I
+ SMAX = WORK( K+I )
+ DO 10 J = I + 1, IBND
+ TEMP = WORK( K+J )
+ IF( TEMP.GT.SMAX ) THEN
+ ISUB = J
+ SMAX = TEMP
+ END IF
+ 10 CONTINUE
+ IF( ISUB.NE.I ) THEN
+ WORK( K+ISUB ) = WORK( K+I )
+ WORK( K+I ) = SMAX
+ IWORK( K+I ) = K + ISUB
+ ELSE
+ IWORK( K+I ) = K + I
+ END IF
+ 20 CONTINUE
+*
+ RETURN
+*
+* End of SGGSVD
+*
+ END
+ 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 )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER JOBQ, JOBU, JOBV
+ INTEGER INFO, K, L, LDA, LDB, LDQ, LDU, LDV, M, N, P
+ REAL TOLA, TOLB
+* ..
+* .. Array Arguments ..
+ INTEGER IWORK( * )
+ REAL A( LDA, * ), B( LDB, * ), Q( LDQ, * ),
+ $ TAU( * ), U( LDU, * ), V( LDV, * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SGGSVP computes orthogonal matrices U, V and Q such that
+*
+* N-K-L K L
+* U'*A*Q = K ( 0 A12 A13 ) if M-K-L >= 0;
+* L ( 0 0 A23 )
+* M-K-L ( 0 0 0 )
+*
+* N-K-L K L
+* = K ( 0 A12 A13 ) if M-K-L < 0;
+* M-K ( 0 0 A23 )
+*
+* N-K-L K L
+* V'*B*Q = L ( 0 0 B13 )
+* P-L ( 0 0 0 )
+*
+* where the K-by-K matrix A12 and L-by-L matrix B13 are nonsingular
+* upper triangular; A23 is L-by-L upper triangular if M-K-L >= 0,
+* otherwise A23 is (M-K)-by-L upper trapezoidal. K+L = the effective
+* numerical rank of the (M+P)-by-N matrix (A',B')'. Z' denotes the
+* transpose of Z.
+*
+* This decomposition is the preprocessing step for computing the
+* Generalized Singular Value Decomposition (GSVD), see subroutine
+* SGGSVD.
+*
+* Arguments
+* =========
+*
+* JOBU (input) CHARACTER*1
+* = 'U': Orthogonal matrix U is computed;
+* = 'N': U is not computed.
+*
+* JOBV (input) CHARACTER*1
+* = 'V': Orthogonal matrix V is computed;
+* = 'N': V is not computed.
+*
+* JOBQ (input) CHARACTER*1
+* = 'Q': Orthogonal matrix Q is computed;
+* = 'N': Q is not computed.
+*
+* M (input) INTEGER
+* The number of rows of the matrix A. M >= 0.
+*
+* P (input) INTEGER
+* The number of rows of the matrix B. P >= 0.
+*
+* N (input) INTEGER
+* The number of columns of the matrices A and B. N >= 0.
+*
+* A (input/output) REAL array, dimension (LDA,N)
+* On entry, the M-by-N matrix A.
+* On exit, A contains the triangular (or trapezoidal) matrix
+* described in the Purpose section.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,M).
+*
+* B (input/output) REAL array, dimension (LDB,N)
+* On entry, the P-by-N matrix B.
+* On exit, B contains the triangular matrix described in
+* the Purpose section.
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. LDB >= max(1,P).
+*
+* TOLA (input) REAL
+* TOLB (input) REAL
+* TOLA and TOLB are the thresholds to determine the effective
+* numerical rank of matrix B and a subblock of A. Generally,
+* they are set to
+* TOLA = MAX(M,N)*norm(A)*MACHEPS,
+* TOLB = MAX(P,N)*norm(B)*MACHEPS.
+* The size of TOLA and TOLB may affect the size of backward
+* errors of the decomposition.
+*
+* K (output) INTEGER
+* L (output) INTEGER
+* On exit, K and L specify the dimension of the subblocks
+* described in Purpose.
+* K + L = effective numerical rank of (A',B')'.
+*
+* U (output) REAL array, dimension (LDU,M)
+* If JOBU = 'U', U contains the orthogonal matrix U.
+* If JOBU = 'N', U is not referenced.
+*
+* LDU (input) INTEGER
+* The leading dimension of the array U. LDU >= max(1,M) if
+* JOBU = 'U'; LDU >= 1 otherwise.
+*
+* V (output) REAL array, dimension (LDV,M)
+* If JOBV = 'V', V contains the orthogonal matrix V.
+* If JOBV = 'N', V is not referenced.
+*
+* LDV (input) INTEGER
+* The leading dimension of the array V. LDV >= max(1,P) if
+* JOBV = 'V'; LDV >= 1 otherwise.
+*
+* Q (output) REAL array, dimension (LDQ,N)
+* If JOBQ = 'Q', Q contains the orthogonal matrix Q.
+* If JOBQ = 'N', Q is not referenced.
+*
+* LDQ (input) INTEGER
+* The leading dimension of the array Q. LDQ >= max(1,N) if
+* JOBQ = 'Q'; LDQ >= 1 otherwise.
+*
+* IWORK (workspace) INTEGER array, dimension (N)
+*
+* TAU (workspace) REAL array, dimension (N)
+*
+* WORK (workspace) REAL array, dimension (max(3*N,M,P))
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value.
+*
+*
+* Further Details
+* ===============
+*
+* The subroutine uses LAPACK subroutine SGEQPF for the QR factorization
+* with column pivoting to detect the effective numerical rank of the
+* a matrix. It may be replaced by a better rank determination strategy.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO, ONE
+ PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL FORWRD, WANTQ, WANTU, WANTV
+ INTEGER I, J
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL SGEQPF, SGEQR2, SGERQ2, SLACPY, SLAPMT, SLASET,
+ $ SORG2R, SORM2R, SORMR2, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters
+*
+ WANTU = LSAME( JOBU, 'U' )
+ WANTV = LSAME( JOBV, 'V' )
+ WANTQ = LSAME( JOBQ, 'Q' )
+ FORWRD = .TRUE.
+*
+ INFO = 0
+ IF( .NOT.( WANTU .OR. LSAME( JOBU, 'N' ) ) ) THEN
+ INFO = -1
+ ELSE IF( .NOT.( WANTV .OR. LSAME( JOBV, 'N' ) ) ) THEN
+ INFO = -2
+ ELSE IF( .NOT.( WANTQ .OR. LSAME( JOBQ, 'N' ) ) ) THEN
+ INFO = -3
+ ELSE IF( M.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( P.LT.0 ) THEN
+ INFO = -5
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -6
+ ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+ INFO = -8
+ ELSE IF( LDB.LT.MAX( 1, P ) ) THEN
+ INFO = -10
+ ELSE IF( LDU.LT.1 .OR. ( WANTU .AND. LDU.LT.M ) ) THEN
+ INFO = -16
+ ELSE IF( LDV.LT.1 .OR. ( WANTV .AND. LDV.LT.P ) ) THEN
+ INFO = -18
+ ELSE IF( LDQ.LT.1 .OR. ( WANTQ .AND. LDQ.LT.N ) ) THEN
+ INFO = -20
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SGGSVP', -INFO )
+ RETURN
+ END IF
+*
+* QR with column pivoting of B: B*P = V*( S11 S12 )
+* ( 0 0 )
+*
+ DO 10 I = 1, N
+ IWORK( I ) = 0
+ 10 CONTINUE
+ CALL SGEQPF( P, N, B, LDB, IWORK, TAU, WORK, INFO )
+*
+* Update A := A*P
+*
+ CALL SLAPMT( FORWRD, M, N, A, LDA, IWORK )
+*
+* Determine the effective rank of matrix B.
+*
+ L = 0
+ DO 20 I = 1, MIN( P, N )
+ IF( ABS( B( I, I ) ).GT.TOLB )
+ $ L = L + 1
+ 20 CONTINUE
+*
+ IF( WANTV ) THEN
+*
+* Copy the details of V, and form V.
+*
+ CALL SLASET( 'Full', P, P, ZERO, ZERO, V, LDV )
+ IF( P.GT.1 )
+ $ CALL SLACPY( 'Lower', P-1, N, B( 2, 1 ), LDB, V( 2, 1 ),
+ $ LDV )
+ CALL SORG2R( P, P, MIN( P, N ), V, LDV, TAU, WORK, INFO )
+ END IF
+*
+* Clean up B
+*
+ DO 40 J = 1, L - 1
+ DO 30 I = J + 1, L
+ B( I, J ) = ZERO
+ 30 CONTINUE
+ 40 CONTINUE
+ IF( P.GT.L )
+ $ CALL SLASET( 'Full', P-L, N, ZERO, ZERO, B( L+1, 1 ), LDB )
+*
+ IF( WANTQ ) THEN
+*
+* Set Q = I and Update Q := Q*P
+*
+ CALL SLASET( 'Full', N, N, ZERO, ONE, Q, LDQ )
+ CALL SLAPMT( FORWRD, N, N, Q, LDQ, IWORK )
+ END IF
+*
+ IF( P.GE.L .AND. N.NE.L ) THEN
+*
+* RQ factorization of (S11 S12): ( S11 S12 ) = ( 0 S12 )*Z
+*
+ CALL SGERQ2( L, N, B, LDB, TAU, WORK, INFO )
+*
+* Update A := A*Z'
+*
+ CALL SORMR2( 'Right', 'Transpose', M, N, L, B, LDB, TAU, A,
+ $ LDA, WORK, INFO )
+*
+ IF( WANTQ ) THEN
+*
+* Update Q := Q*Z'
+*
+ CALL SORMR2( 'Right', 'Transpose', N, N, L, B, LDB, TAU, Q,
+ $ LDQ, WORK, INFO )
+ END IF
+*
+* Clean up B
+*
+ CALL SLASET( 'Full', L, N-L, ZERO, ZERO, B, LDB )
+ DO 60 J = N - L + 1, N
+ DO 50 I = J - N + L + 1, L
+ B( I, J ) = ZERO
+ 50 CONTINUE
+ 60 CONTINUE
+*
+ END IF
+*
+* Let N-L L
+* A = ( A11 A12 ) M,
+*
+* then the following does the complete QR decomposition of A11:
+*
+* A11 = U*( 0 T12 )*P1'
+* ( 0 0 )
+*
+ DO 70 I = 1, N - L
+ IWORK( I ) = 0
+ 70 CONTINUE
+ CALL SGEQPF( M, N-L, A, LDA, IWORK, TAU, WORK, INFO )
+*
+* Determine the effective rank of A11
+*
+ K = 0
+ DO 80 I = 1, MIN( M, N-L )
+ IF( ABS( A( I, I ) ).GT.TOLA )
+ $ K = K + 1
+ 80 CONTINUE
+*
+* Update A12 := U'*A12, where A12 = A( 1:M, N-L+1:N )
+*
+ CALL SORM2R( 'Left', 'Transpose', M, L, MIN( M, N-L ), A, LDA,
+ $ TAU, A( 1, N-L+1 ), LDA, WORK, INFO )
+*
+ IF( WANTU ) THEN
+*
+* Copy the details of U, and form U
+*
+ CALL SLASET( 'Full', M, M, ZERO, ZERO, U, LDU )
+ IF( M.GT.1 )
+ $ CALL SLACPY( 'Lower', M-1, N-L, A( 2, 1 ), LDA, U( 2, 1 ),
+ $ LDU )
+ CALL SORG2R( M, M, MIN( M, N-L ), U, LDU, TAU, WORK, INFO )
+ END IF
+*
+ IF( WANTQ ) THEN
+*
+* Update Q( 1:N, 1:N-L ) = Q( 1:N, 1:N-L )*P1
+*
+ CALL SLAPMT( FORWRD, N, N-L, Q, LDQ, IWORK )
+ END IF
+*
+* Clean up A: set the strictly lower triangular part of
+* A(1:K, 1:K) = 0, and A( K+1:M, 1:N-L ) = 0.
+*
+ DO 100 J = 1, K - 1
+ DO 90 I = J + 1, K
+ A( I, J ) = ZERO
+ 90 CONTINUE
+ 100 CONTINUE
+ IF( M.GT.K )
+ $ CALL SLASET( 'Full', M-K, N-L, ZERO, ZERO, A( K+1, 1 ), LDA )
+*
+ IF( N-L.GT.K ) THEN
+*
+* RQ factorization of ( T11 T12 ) = ( 0 T12 )*Z1
+*
+ CALL SGERQ2( K, N-L, A, LDA, TAU, WORK, INFO )
+*
+ IF( WANTQ ) THEN
+*
+* Update Q( 1:N,1:N-L ) = Q( 1:N,1:N-L )*Z1'
+*
+ CALL SORMR2( 'Right', 'Transpose', N, N-L, K, A, LDA, TAU,
+ $ Q, LDQ, WORK, INFO )
+ END IF
+*
+* Clean up A
+*
+ CALL SLASET( 'Full', K, N-L-K, ZERO, ZERO, A, LDA )
+ DO 120 J = N - L - K + 1, N - L
+ DO 110 I = J - N + L + K + 1, K
+ A( I, J ) = ZERO
+ 110 CONTINUE
+ 120 CONTINUE
+*
+ END IF
+*
+ IF( M.GT.K ) THEN
+*
+* QR factorization of A( K+1:M,N-L+1:N )
+*
+ CALL SGEQR2( M-K, L, A( K+1, N-L+1 ), LDA, TAU, WORK, INFO )
+*
+ IF( WANTU ) THEN
+*
+* Update U(:,K+1:M) := U(:,K+1:M)*U1
+*
+ CALL SORM2R( 'Right', 'No transpose', M, M-K, MIN( M-K, L ),
+ $ A( K+1, N-L+1 ), LDA, TAU, U( 1, K+1 ), LDU,
+ $ WORK, INFO )
+ END IF
+*
+* Clean up
+*
+ DO 140 J = N - L + 1, N
+ DO 130 I = J - N + K + L + 1, M
+ A( I, J ) = ZERO
+ 130 CONTINUE
+ 140 CONTINUE
+*
+ END IF
+*
+ RETURN
+*
+* End of SGGSVP
+*
+ END
+ SUBROUTINE SGTCON( NORM, N, DL, D, DU, DU2, IPIV, ANORM, RCOND,
+ $ WORK, IWORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* Modified to call SLACN2 in place of SLACON, 7 Feb 03, SJH.
+*
+* .. Scalar Arguments ..
+ CHARACTER NORM
+ INTEGER INFO, N
+ REAL ANORM, RCOND
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * ), IWORK( * )
+ REAL D( * ), DL( * ), DU( * ), DU2( * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SGTCON estimates the reciprocal of the condition number of a real
+* tridiagonal matrix A using the LU factorization as computed by
+* SGTTRF.
+*
+* An estimate is obtained for norm(inv(A)), and the reciprocal of the
+* condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).
+*
+* Arguments
+* =========
+*
+* NORM (input) CHARACTER*1
+* Specifies whether the 1-norm condition number or the
+* infinity-norm condition number is required:
+* = '1' or 'O': 1-norm;
+* = 'I': Infinity-norm.
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* DL (input) REAL array, dimension (N-1)
+* The (n-1) multipliers that define the matrix L from the
+* LU factorization of A as computed by SGTTRF.
+*
+* D (input) REAL array, dimension (N)
+* The n diagonal elements of the upper triangular matrix U from
+* the LU factorization of A.
+*
+* DU (input) REAL array, dimension (N-1)
+* The (n-1) elements of the first superdiagonal of U.
+*
+* DU2 (input) REAL array, dimension (N-2)
+* The (n-2) elements of the second superdiagonal of U.
+*
+* IPIV (input) INTEGER array, dimension (N)
+* The pivot indices; for 1 <= i <= n, row i of the matrix was
+* interchanged with row IPIV(i). IPIV(i) will always be either
+* i or i+1; IPIV(i) = i indicates a row interchange was not
+* required.
+*
+* ANORM (input) REAL
+* If NORM = '1' or 'O', the 1-norm of the original matrix A.
+* If NORM = 'I', the infinity-norm of the original matrix A.
+*
+* RCOND (output) REAL
+* The reciprocal of the condition number of the matrix A,
+* computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an
+* estimate of the 1-norm of inv(A) computed in this routine.
+*
+* WORK (workspace) REAL array, dimension (2*N)
+*
+* IWORK (workspace) INTEGER array, dimension (N)
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ONE, ZERO
+ PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL ONENRM
+ INTEGER I, KASE, KASE1
+ REAL AINVNM
+* ..
+* .. Local Arrays ..
+ INTEGER ISAVE( 3 )
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL SGTTRS, SLACN2, XERBLA
+* ..
+* .. Executable Statements ..
+*
+* Test the input arguments.
+*
+ INFO = 0
+ ONENRM = NORM.EQ.'1' .OR. LSAME( NORM, 'O' )
+ IF( .NOT.ONENRM .AND. .NOT.LSAME( NORM, 'I' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( ANORM.LT.ZERO ) THEN
+ INFO = -8
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SGTCON', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ RCOND = ZERO
+ IF( N.EQ.0 ) THEN
+ RCOND = ONE
+ RETURN
+ ELSE IF( ANORM.EQ.ZERO ) THEN
+ RETURN
+ END IF
+*
+* Check that D(1:N) is non-zero.
+*
+ DO 10 I = 1, N
+ IF( D( I ).EQ.ZERO )
+ $ RETURN
+ 10 CONTINUE
+*
+ AINVNM = ZERO
+ IF( ONENRM ) THEN
+ KASE1 = 1
+ ELSE
+ KASE1 = 2
+ END IF
+ KASE = 0
+ 20 CONTINUE
+ CALL SLACN2( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE, ISAVE )
+ IF( KASE.NE.0 ) THEN
+ IF( KASE.EQ.KASE1 ) THEN
+*
+* Multiply by inv(U)*inv(L).
+*
+ CALL SGTTRS( 'No transpose', N, 1, DL, D, DU, DU2, IPIV,
+ $ WORK, N, INFO )
+ ELSE
+*
+* Multiply by inv(L')*inv(U').
+*
+ CALL SGTTRS( 'Transpose', N, 1, DL, D, DU, DU2, IPIV, WORK,
+ $ N, INFO )
+ END IF
+ GO TO 20
+ END IF
+*
+* Compute the estimate of the reciprocal condition number.
+*
+ IF( AINVNM.NE.ZERO )
+ $ RCOND = ( ONE / AINVNM ) / ANORM
+*
+ RETURN
+*
+* End of SGTCON
+*
+ END
+ SUBROUTINE SGTRFS( TRANS, N, NRHS, DL, D, DU, DLF, DF, DUF, DU2,
+ $ IPIV, B, LDB, X, LDX, FERR, BERR, WORK, IWORK,
+ $ INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* Modified to call SLACN2 in place of SLACON, 7 Feb 03, SJH.
+*
+* .. Scalar Arguments ..
+ CHARACTER TRANS
+ INTEGER INFO, LDB, LDX, N, NRHS
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * ), IWORK( * )
+ REAL B( LDB, * ), BERR( * ), D( * ), DF( * ),
+ $ DL( * ), DLF( * ), DU( * ), DU2( * ), DUF( * ),
+ $ FERR( * ), WORK( * ), X( LDX, * )
+* ..
+*
+* Purpose
+* =======
+*
+* SGTRFS improves the computed solution to a system of linear
+* equations when the coefficient matrix is tridiagonal, and provides
+* error bounds and backward error estimates for the solution.
+*
+* Arguments
+* =========
+*
+* TRANS (input) CHARACTER*1
+* Specifies the form of the system of equations:
+* = 'N': A * X = B (No transpose)
+* = 'T': A**T * X = B (Transpose)
+* = 'C': A**H * X = B (Conjugate transpose = Transpose)
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* NRHS (input) INTEGER
+* The number of right hand sides, i.e., the number of columns
+* of the matrix B. NRHS >= 0.
+*
+* DL (input) REAL array, dimension (N-1)
+* The (n-1) subdiagonal elements of A.
+*
+* D (input) REAL array, dimension (N)
+* The diagonal elements of A.
+*
+* DU (input) REAL array, dimension (N-1)
+* The (n-1) superdiagonal elements of A.
+*
+* DLF (input) REAL array, dimension (N-1)
+* The (n-1) multipliers that define the matrix L from the
+* LU factorization of A as computed by SGTTRF.
+*
+* DF (input) REAL array, dimension (N)
+* The n diagonal elements of the upper triangular matrix U from
+* the LU factorization of A.
+*
+* DUF (input) REAL array, dimension (N-1)
+* The (n-1) elements of the first superdiagonal of U.
+*
+* DU2 (input) REAL array, dimension (N-2)
+* The (n-2) elements of the second superdiagonal of U.
+*
+* IPIV (input) INTEGER array, dimension (N)
+* The pivot indices; for 1 <= i <= n, row i of the matrix was
+* interchanged with row IPIV(i). IPIV(i) will always be either
+* i or i+1; IPIV(i) = i indicates a row interchange was not
+* required.
+*
+* B (input) REAL array, dimension (LDB,NRHS)
+* The right hand side matrix B.
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. LDB >= max(1,N).
+*
+* X (input/output) REAL array, dimension (LDX,NRHS)
+* On entry, the solution matrix X, as computed by SGTTRS.
+* On exit, the improved solution matrix X.
+*
+* LDX (input) INTEGER
+* The leading dimension of the array X. LDX >= max(1,N).
+*
+* FERR (output) REAL array, dimension (NRHS)
+* The estimated forward error bound for each solution vector
+* X(j) (the j-th column of the solution matrix X).
+* If XTRUE is the true solution corresponding to X(j), FERR(j)
+* is an estimated upper bound for the magnitude of the largest
+* element in (X(j) - XTRUE) divided by the magnitude of the
+* largest element in X(j). The estimate is as reliable as
+* the estimate for RCOND, and is almost always a slight
+* overestimate of the true error.
+*
+* BERR (output) REAL array, dimension (NRHS)
+* The componentwise relative backward error of each solution
+* vector X(j) (i.e., the smallest relative change in
+* any element of A or B that makes X(j) an exact solution).
+*
+* WORK (workspace) REAL array, dimension (3*N)
+*
+* IWORK (workspace) INTEGER array, dimension (N)
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+*
+* Internal Parameters
+* ===================
+*
+* ITMAX is the maximum number of steps of iterative refinement.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ INTEGER ITMAX
+ PARAMETER ( ITMAX = 5 )
+ REAL ZERO, ONE
+ PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+ REAL TWO
+ PARAMETER ( TWO = 2.0E+0 )
+ REAL THREE
+ PARAMETER ( THREE = 3.0E+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL NOTRAN
+ CHARACTER TRANSN, TRANST
+ INTEGER COUNT, I, J, KASE, NZ
+ REAL EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN
+* ..
+* .. Local Arrays ..
+ INTEGER ISAVE( 3 )
+* ..
+* .. External Subroutines ..
+ EXTERNAL SAXPY, SCOPY, SGTTRS, SLACN2, SLAGTM, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ REAL SLAMCH
+ EXTERNAL LSAME, SLAMCH
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ NOTRAN = LSAME( TRANS, 'N' )
+ IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT.
+ $ LSAME( TRANS, 'C' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( NRHS.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -13
+ ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
+ INFO = -15
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SGTRFS', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN
+ DO 10 J = 1, NRHS
+ FERR( J ) = ZERO
+ BERR( J ) = ZERO
+ 10 CONTINUE
+ RETURN
+ END IF
+*
+ IF( NOTRAN ) THEN
+ TRANSN = 'N'
+ TRANST = 'T'
+ ELSE
+ TRANSN = 'T'
+ TRANST = 'N'
+ END IF
+*
+* NZ = maximum number of nonzero elements in each row of A, plus 1
+*
+ NZ = 4
+ EPS = SLAMCH( 'Epsilon' )
+ SAFMIN = SLAMCH( 'Safe minimum' )
+ SAFE1 = NZ*SAFMIN
+ SAFE2 = SAFE1 / EPS
+*
+* Do for each right hand side
+*
+ DO 110 J = 1, NRHS
+*
+ COUNT = 1
+ LSTRES = THREE
+ 20 CONTINUE
+*
+* Loop until stopping criterion is satisfied.
+*
+* Compute residual R = B - op(A) * X,
+* where op(A) = A, A**T, or A**H, depending on TRANS.
+*
+ CALL SCOPY( N, B( 1, J ), 1, WORK( N+1 ), 1 )
+ CALL SLAGTM( TRANS, N, 1, -ONE, DL, D, DU, X( 1, J ), LDX, ONE,
+ $ WORK( N+1 ), N )
+*
+* Compute abs(op(A))*abs(x) + abs(b) for use in the backward
+* error bound.
+*
+ IF( NOTRAN ) THEN
+ IF( N.EQ.1 ) THEN
+ WORK( 1 ) = ABS( B( 1, J ) ) + ABS( D( 1 )*X( 1, J ) )
+ ELSE
+ WORK( 1 ) = ABS( B( 1, J ) ) + ABS( D( 1 )*X( 1, J ) ) +
+ $ ABS( DU( 1 )*X( 2, J ) )
+ DO 30 I = 2, N - 1
+ WORK( I ) = ABS( B( I, J ) ) +
+ $ ABS( DL( I-1 )*X( I-1, J ) ) +
+ $ ABS( D( I )*X( I, J ) ) +
+ $ ABS( DU( I )*X( I+1, J ) )
+ 30 CONTINUE
+ WORK( N ) = ABS( B( N, J ) ) +
+ $ ABS( DL( N-1 )*X( N-1, J ) ) +
+ $ ABS( D( N )*X( N, J ) )
+ END IF
+ ELSE
+ IF( N.EQ.1 ) THEN
+ WORK( 1 ) = ABS( B( 1, J ) ) + ABS( D( 1 )*X( 1, J ) )
+ ELSE
+ WORK( 1 ) = ABS( B( 1, J ) ) + ABS( D( 1 )*X( 1, J ) ) +
+ $ ABS( DL( 1 )*X( 2, J ) )
+ DO 40 I = 2, N - 1
+ WORK( I ) = ABS( B( I, J ) ) +
+ $ ABS( DU( I-1 )*X( I-1, J ) ) +
+ $ ABS( D( I )*X( I, J ) ) +
+ $ ABS( DL( I )*X( I+1, J ) )
+ 40 CONTINUE
+ WORK( N ) = ABS( B( N, J ) ) +
+ $ ABS( DU( N-1 )*X( N-1, J ) ) +
+ $ ABS( D( N )*X( N, J ) )
+ END IF
+ END IF
+*
+* Compute componentwise relative backward error from formula
+*
+* max(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) )
+*
+* where abs(Z) is the componentwise absolute value of the matrix
+* or vector Z. If the i-th component of the denominator is less
+* than SAFE2, then SAFE1 is added to the i-th components of the
+* numerator and denominator before dividing.
+*
+ S = ZERO
+ DO 50 I = 1, N
+ IF( WORK( I ).GT.SAFE2 ) THEN
+ S = MAX( S, ABS( WORK( N+I ) ) / WORK( I ) )
+ ELSE
+ S = MAX( S, ( ABS( WORK( N+I ) )+SAFE1 ) /
+ $ ( WORK( I )+SAFE1 ) )
+ END IF
+ 50 CONTINUE
+ BERR( J ) = S
+*
+* Test stopping criterion. Continue iterating if
+* 1) The residual BERR(J) is larger than machine epsilon, and
+* 2) BERR(J) decreased by at least a factor of 2 during the
+* last iteration, and
+* 3) At most ITMAX iterations tried.
+*
+ IF( BERR( J ).GT.EPS .AND. TWO*BERR( J ).LE.LSTRES .AND.
+ $ COUNT.LE.ITMAX ) THEN
+*
+* Update solution and try again.
+*
+ CALL SGTTRS( TRANS, N, 1, DLF, DF, DUF, DU2, IPIV,
+ $ WORK( N+1 ), N, INFO )
+ CALL SAXPY( N, ONE, WORK( N+1 ), 1, X( 1, J ), 1 )
+ LSTRES = BERR( J )
+ COUNT = COUNT + 1
+ GO TO 20
+ END IF
+*
+* Bound error from formula
+*
+* norm(X - XTRUE) / norm(X) .le. FERR =
+* norm( abs(inv(op(A)))*
+* ( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X)
+*
+* where
+* norm(Z) is the magnitude of the largest component of Z
+* inv(op(A)) is the inverse of op(A)
+* abs(Z) is the componentwise absolute value of the matrix or
+* vector Z
+* NZ is the maximum number of nonzeros in any row of A, plus 1
+* EPS is machine epsilon
+*
+* The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B))
+* is incremented by SAFE1 if the i-th component of
+* abs(op(A))*abs(X) + abs(B) is less than SAFE2.
+*
+* Use SLACN2 to estimate the infinity-norm of the matrix
+* inv(op(A)) * diag(W),
+* where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) )))
+*
+ DO 60 I = 1, N
+ IF( WORK( I ).GT.SAFE2 ) THEN
+ WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I )
+ ELSE
+ WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I ) + SAFE1
+ END IF
+ 60 CONTINUE
+*
+ KASE = 0
+ 70 CONTINUE
+ CALL SLACN2( N, WORK( 2*N+1 ), WORK( N+1 ), IWORK, FERR( J ),
+ $ KASE, ISAVE )
+ IF( KASE.NE.0 ) THEN
+ IF( KASE.EQ.1 ) THEN
+*
+* Multiply by diag(W)*inv(op(A)**T).
+*
+ CALL SGTTRS( TRANST, N, 1, DLF, DF, DUF, DU2, IPIV,
+ $ WORK( N+1 ), N, INFO )
+ DO 80 I = 1, N
+ WORK( N+I ) = WORK( I )*WORK( N+I )
+ 80 CONTINUE
+ ELSE
+*
+* Multiply by inv(op(A))*diag(W).
+*
+ DO 90 I = 1, N
+ WORK( N+I ) = WORK( I )*WORK( N+I )
+ 90 CONTINUE
+ CALL SGTTRS( TRANSN, N, 1, DLF, DF, DUF, DU2, IPIV,
+ $ WORK( N+1 ), N, INFO )
+ END IF
+ GO TO 70
+ END IF
+*
+* Normalize error.
+*
+ LSTRES = ZERO
+ DO 100 I = 1, N
+ LSTRES = MAX( LSTRES, ABS( X( I, J ) ) )
+ 100 CONTINUE
+ IF( LSTRES.NE.ZERO )
+ $ FERR( J ) = FERR( J ) / LSTRES
+*
+ 110 CONTINUE
+*
+ RETURN
+*
+* End of SGTRFS
+*
+ END
+ SUBROUTINE SGTSV( N, NRHS, DL, D, DU, B, LDB, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LDB, N, NRHS
+* ..
+* .. Array Arguments ..
+ REAL B( LDB, * ), D( * ), DL( * ), DU( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SGTSV solves the equation
+*
+* A*X = B,
+*
+* where A is an n by n tridiagonal matrix, by Gaussian elimination with
+* partial pivoting.
+*
+* Note that the equation A'*X = B may be solved by interchanging the
+* order of the arguments DU and DL.
+*
+* Arguments
+* =========
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* NRHS (input) INTEGER
+* The number of right hand sides, i.e., the number of columns
+* of the matrix B. NRHS >= 0.
+*
+* DL (input/output) REAL array, dimension (N-1)
+* On entry, DL must contain the (n-1) sub-diagonal elements of
+* A.
+*
+* On exit, DL is overwritten by the (n-2) elements of the
+* second super-diagonal of the upper triangular matrix U from
+* the LU factorization of A, in DL(1), ..., DL(n-2).
+*
+* D (input/output) REAL array, dimension (N)
+* On entry, D must contain the diagonal elements of A.
+*
+* On exit, D is overwritten by the n diagonal elements of U.
+*
+* DU (input/output) REAL array, dimension (N-1)
+* On entry, DU must contain the (n-1) super-diagonal elements
+* of A.
+*
+* On exit, DU is overwritten by the (n-1) elements of the first
+* super-diagonal of U.
+*
+* B (input/output) REAL array, dimension (LDB,NRHS)
+* On entry, the N by NRHS matrix of right hand side matrix B.
+* On exit, if INFO = 0, the N by NRHS solution matrix X.
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. LDB >= max(1,N).
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* > 0: if INFO = i, U(i,i) is exactly zero, and the solution
+* has not been computed. The factorization has not been
+* completed unless i = N.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO
+ PARAMETER ( ZERO = 0.0E+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, J
+ REAL FACT, TEMP
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX
+* ..
+* .. External Subroutines ..
+ EXTERNAL XERBLA
+* ..
+* .. Executable Statements ..
+*
+ INFO = 0
+ IF( N.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( NRHS.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -7
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SGTSV ', -INFO )
+ RETURN
+ END IF
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+ IF( NRHS.EQ.1 ) THEN
+ DO 10 I = 1, N - 2
+ IF( ABS( D( I ) ).GE.ABS( DL( I ) ) ) THEN
+*
+* No row interchange required
+*
+ IF( D( I ).NE.ZERO ) THEN
+ FACT = DL( I ) / D( I )
+ D( I+1 ) = D( I+1 ) - FACT*DU( I )
+ B( I+1, 1 ) = B( I+1, 1 ) - FACT*B( I, 1 )
+ ELSE
+ INFO = I
+ RETURN
+ END IF
+ DL( I ) = ZERO
+ ELSE
+*
+* Interchange rows I and I+1
+*
+ FACT = D( I ) / DL( I )
+ D( I ) = DL( I )
+ TEMP = D( I+1 )
+ D( I+1 ) = DU( I ) - FACT*TEMP
+ DL( I ) = DU( I+1 )
+ DU( I+1 ) = -FACT*DL( I )
+ DU( I ) = TEMP
+ TEMP = B( I, 1 )
+ B( I, 1 ) = B( I+1, 1 )
+ B( I+1, 1 ) = TEMP - FACT*B( I+1, 1 )
+ END IF
+ 10 CONTINUE
+ IF( N.GT.1 ) THEN
+ I = N - 1
+ IF( ABS( D( I ) ).GE.ABS( DL( I ) ) ) THEN
+ IF( D( I ).NE.ZERO ) THEN
+ FACT = DL( I ) / D( I )
+ D( I+1 ) = D( I+1 ) - FACT*DU( I )
+ B( I+1, 1 ) = B( I+1, 1 ) - FACT*B( I, 1 )
+ ELSE
+ INFO = I
+ RETURN
+ END IF
+ ELSE
+ FACT = D( I ) / DL( I )
+ D( I ) = DL( I )
+ TEMP = D( I+1 )
+ D( I+1 ) = DU( I ) - FACT*TEMP
+ DU( I ) = TEMP
+ TEMP = B( I, 1 )
+ B( I, 1 ) = B( I+1, 1 )
+ B( I+1, 1 ) = TEMP - FACT*B( I+1, 1 )
+ END IF
+ END IF
+ IF( D( N ).EQ.ZERO ) THEN
+ INFO = N
+ RETURN
+ END IF
+ ELSE
+ DO 40 I = 1, N - 2
+ IF( ABS( D( I ) ).GE.ABS( DL( I ) ) ) THEN
+*
+* No row interchange required
+*
+ IF( D( I ).NE.ZERO ) THEN
+ FACT = DL( I ) / D( I )
+ D( I+1 ) = D( I+1 ) - FACT*DU( I )
+ DO 20 J = 1, NRHS
+ B( I+1, J ) = B( I+1, J ) - FACT*B( I, J )
+ 20 CONTINUE
+ ELSE
+ INFO = I
+ RETURN
+ END IF
+ DL( I ) = ZERO
+ ELSE
+*
+* Interchange rows I and I+1
+*
+ FACT = D( I ) / DL( I )
+ D( I ) = DL( I )
+ TEMP = D( I+1 )
+ D( I+1 ) = DU( I ) - FACT*TEMP
+ DL( I ) = DU( I+1 )
+ DU( I+1 ) = -FACT*DL( I )
+ DU( I ) = TEMP
+ DO 30 J = 1, NRHS
+ TEMP = B( I, J )
+ B( I, J ) = B( I+1, J )
+ B( I+1, J ) = TEMP - FACT*B( I+1, J )
+ 30 CONTINUE
+ END IF
+ 40 CONTINUE
+ IF( N.GT.1 ) THEN
+ I = N - 1
+ IF( ABS( D( I ) ).GE.ABS( DL( I ) ) ) THEN
+ IF( D( I ).NE.ZERO ) THEN
+ FACT = DL( I ) / D( I )
+ D( I+1 ) = D( I+1 ) - FACT*DU( I )
+ DO 50 J = 1, NRHS
+ B( I+1, J ) = B( I+1, J ) - FACT*B( I, J )
+ 50 CONTINUE
+ ELSE
+ INFO = I
+ RETURN
+ END IF
+ ELSE
+ FACT = D( I ) / DL( I )
+ D( I ) = DL( I )
+ TEMP = D( I+1 )
+ D( I+1 ) = DU( I ) - FACT*TEMP
+ DU( I ) = TEMP
+ DO 60 J = 1, NRHS
+ TEMP = B( I, J )
+ B( I, J ) = B( I+1, J )
+ B( I+1, J ) = TEMP - FACT*B( I+1, J )
+ 60 CONTINUE
+ END IF
+ END IF
+ IF( D( N ).EQ.ZERO ) THEN
+ INFO = N
+ RETURN
+ END IF
+ END IF
+*
+* Back solve with the matrix U from the factorization.
+*
+ IF( NRHS.LE.2 ) THEN
+ J = 1
+ 70 CONTINUE
+ B( N, J ) = B( N, J ) / D( N )
+ IF( N.GT.1 )
+ $ B( N-1, J ) = ( B( N-1, J )-DU( N-1 )*B( N, J ) ) / D( N-1 )
+ DO 80 I = N - 2, 1, -1
+ B( I, J ) = ( B( I, J )-DU( I )*B( I+1, J )-DL( I )*
+ $ B( I+2, J ) ) / D( I )
+ 80 CONTINUE
+ IF( J.LT.NRHS ) THEN
+ J = J + 1
+ GO TO 70
+ END IF
+ ELSE
+ DO 100 J = 1, NRHS
+ B( N, J ) = B( N, J ) / D( N )
+ IF( N.GT.1 )
+ $ B( N-1, J ) = ( B( N-1, J )-DU( N-1 )*B( N, J ) ) /
+ $ D( N-1 )
+ DO 90 I = N - 2, 1, -1
+ B( I, J ) = ( B( I, J )-DU( I )*B( I+1, J )-DL( I )*
+ $ B( I+2, J ) ) / D( I )
+ 90 CONTINUE
+ 100 CONTINUE
+ END IF
+*
+ RETURN
+*
+* End of SGTSV
+*
+ END
+ SUBROUTINE SGTSVX( FACT, TRANS, N, NRHS, DL, D, DU, DLF, DF, DUF,
+ $ DU2, IPIV, B, LDB, X, LDX, RCOND, FERR, BERR,
+ $ WORK, IWORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER FACT, TRANS
+ INTEGER INFO, LDB, LDX, N, NRHS
+ REAL RCOND
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * ), IWORK( * )
+ REAL B( LDB, * ), BERR( * ), D( * ), DF( * ),
+ $ DL( * ), DLF( * ), DU( * ), DU2( * ), DUF( * ),
+ $ FERR( * ), WORK( * ), X( LDX, * )
+* ..
+*
+* Purpose
+* =======
+*
+* SGTSVX uses the LU factorization to compute the solution to a real
+* system of linear equations A * X = B or A**T * X = B,
+* where A is a tridiagonal matrix of order N and X and B are N-by-NRHS
+* matrices.
+*
+* Error bounds on the solution and a condition estimate are also
+* provided.
+*
+* Description
+* ===========
+*
+* The following steps are performed:
+*
+* 1. If FACT = 'N', the LU decomposition is used to factor the matrix A
+* as A = L * U, where L is a product of permutation and unit lower
+* bidiagonal matrices and U is upper triangular with nonzeros in
+* only the main diagonal and first two superdiagonals.
+*
+* 2. If some U(i,i)=0, so that U is exactly singular, then the routine
+* returns with INFO = i. Otherwise, the factored form of A is used
+* to estimate the condition number of the matrix A. If the
+* reciprocal of the condition number is less than machine precision,
+* INFO = N+1 is returned as a warning, but the routine still goes on
+* to solve for X and compute error bounds as described below.
+*
+* 3. The system of equations is solved for X using the factored form
+* of A.
+*
+* 4. Iterative refinement is applied to improve the computed solution
+* matrix and calculate error bounds and backward error estimates
+* for it.
+*
+* Arguments
+* =========
+*
+* FACT (input) CHARACTER*1
+* Specifies whether or not the factored form of A has been
+* supplied on entry.
+* = 'F': DLF, DF, DUF, DU2, and IPIV contain the factored
+* form of A; DL, D, DU, DLF, DF, DUF, DU2 and IPIV
+* will not be modified.
+* = 'N': The matrix will be copied to DLF, DF, and DUF
+* and factored.
+*
+* TRANS (input) CHARACTER*1
+* Specifies the form of the system of equations:
+* = 'N': A * X = B (No transpose)
+* = 'T': A**T * X = B (Transpose)
+* = 'C': A**H * X = B (Conjugate transpose = Transpose)
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* NRHS (input) INTEGER
+* The number of right hand sides, i.e., the number of columns
+* of the matrix B. NRHS >= 0.
+*
+* DL (input) REAL array, dimension (N-1)
+* The (n-1) subdiagonal elements of A.
+*
+* D (input) REAL array, dimension (N)
+* The n diagonal elements of A.
+*
+* DU (input) REAL array, dimension (N-1)
+* The (n-1) superdiagonal elements of A.
+*
+* DLF (input or output) REAL array, dimension (N-1)
+* If FACT = 'F', then DLF is an input argument and on entry
+* contains the (n-1) multipliers that define the matrix L from
+* the LU factorization of A as computed by SGTTRF.
+*
+* If FACT = 'N', then DLF is an output argument and on exit
+* contains the (n-1) multipliers that define the matrix L from
+* the LU factorization of A.
+*
+* DF (input or output) REAL array, dimension (N)
+* If FACT = 'F', then DF is an input argument and on entry
+* contains the n diagonal elements of the upper triangular
+* matrix U from the LU factorization of A.
+*
+* If FACT = 'N', then DF is an output argument and on exit
+* contains the n diagonal elements of the upper triangular
+* matrix U from the LU factorization of A.
+*
+* DUF (input or output) REAL array, dimension (N-1)
+* If FACT = 'F', then DUF is an input argument and on entry
+* contains the (n-1) elements of the first superdiagonal of U.
+*
+* If FACT = 'N', then DUF is an output argument and on exit
+* contains the (n-1) elements of the first superdiagonal of U.
+*
+* DU2 (input or output) REAL array, dimension (N-2)
+* If FACT = 'F', then DU2 is an input argument and on entry
+* contains the (n-2) elements of the second superdiagonal of
+* U.
+*
+* If FACT = 'N', then DU2 is an output argument and on exit
+* contains the (n-2) elements of the second superdiagonal of
+* U.
+*
+* IPIV (input or output) INTEGER array, dimension (N)
+* If FACT = 'F', then IPIV is an input argument and on entry
+* contains the pivot indices from the LU factorization of A as
+* computed by SGTTRF.
+*
+* If FACT = 'N', then IPIV is an output argument and on exit
+* contains the pivot indices from the LU factorization of A;
+* row i of the matrix was interchanged with row IPIV(i).
+* IPIV(i) will always be either i or i+1; IPIV(i) = i indicates
+* a row interchange was not required.
+*
+* B (input) REAL array, dimension (LDB,NRHS)
+* The N-by-NRHS right hand side matrix B.
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. LDB >= max(1,N).
+*
+* X (output) REAL array, dimension (LDX,NRHS)
+* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X.
+*
+* LDX (input) INTEGER
+* The leading dimension of the array X. LDX >= max(1,N).
+*
+* RCOND (output) REAL
+* The estimate of the reciprocal condition number of the matrix
+* A. If RCOND is less than the machine precision (in
+* particular, if RCOND = 0), the matrix is singular to working
+* precision. This condition is indicated by a return code of
+* INFO > 0.
+*
+* FERR (output) REAL array, dimension (NRHS)
+* The estimated forward error bound for each solution vector
+* X(j) (the j-th column of the solution matrix X).
+* If XTRUE is the true solution corresponding to X(j), FERR(j)
+* is an estimated upper bound for the magnitude of the largest
+* element in (X(j) - XTRUE) divided by the magnitude of the
+* largest element in X(j). The estimate is as reliable as
+* the estimate for RCOND, and is almost always a slight
+* overestimate of the true error.
+*
+* BERR (output) REAL array, dimension (NRHS)
+* The componentwise relative backward error of each solution
+* vector X(j) (i.e., the smallest relative change in
+* any element of A or B that makes X(j) an exact solution).
+*
+* WORK (workspace) REAL array, dimension (3*N)
+*
+* IWORK (workspace) INTEGER array, dimension (N)
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* > 0: if INFO = i, and i is
+* <= N: U(i,i) is exactly zero. The factorization
+* has not been completed unless i = N, but the
+* factor U is exactly singular, so the solution
+* and error bounds could not be computed.
+* RCOND = 0 is returned.
+* = N+1: U is nonsingular, but RCOND is less than machine
+* precision, meaning that the matrix is singular
+* to working precision. Nevertheless, the
+* solution and error bounds are computed because
+* there are a number of situations where the
+* computed solution can be more accurate than the
+* value of RCOND would suggest.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO
+ PARAMETER ( ZERO = 0.0E+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL NOFACT, NOTRAN
+ CHARACTER NORM
+ REAL ANORM
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ REAL SLAMCH, SLANGT
+ EXTERNAL LSAME, SLAMCH, SLANGT
+* ..
+* .. External Subroutines ..
+ EXTERNAL SCOPY, SGTCON, SGTRFS, SGTTRF, SGTTRS, SLACPY,
+ $ XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+ INFO = 0
+ NOFACT = LSAME( FACT, 'N' )
+ NOTRAN = LSAME( TRANS, 'N' )
+ IF( .NOT.NOFACT .AND. .NOT.LSAME( FACT, 'F' ) ) THEN
+ INFO = -1
+ ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT.
+ $ LSAME( TRANS, 'C' ) ) THEN
+ INFO = -2
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( NRHS.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -14
+ ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
+ INFO = -16
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SGTSVX', -INFO )
+ RETURN
+ END IF
+*
+ IF( NOFACT ) THEN
+*
+* Compute the LU factorization of A.
+*
+ CALL SCOPY( N, D, 1, DF, 1 )
+ IF( N.GT.1 ) THEN
+ CALL SCOPY( N-1, DL, 1, DLF, 1 )
+ CALL SCOPY( N-1, DU, 1, DUF, 1 )
+ END IF
+ CALL SGTTRF( N, DLF, DF, DUF, DU2, IPIV, INFO )
+*
+* Return if INFO is non-zero.
+*
+ IF( INFO.GT.0 )THEN
+ RCOND = ZERO
+ RETURN
+ END IF
+ END IF
+*
+* Compute the norm of the matrix A.
+*
+ IF( NOTRAN ) THEN
+ NORM = '1'
+ ELSE
+ NORM = 'I'
+ END IF
+ ANORM = SLANGT( NORM, N, DL, D, DU )
+*
+* Compute the reciprocal of the condition number of A.
+*
+ CALL SGTCON( NORM, N, DLF, DF, DUF, DU2, IPIV, ANORM, RCOND, WORK,
+ $ IWORK, INFO )
+*
+* Compute the solution vectors X.
+*
+ CALL SLACPY( 'Full', N, NRHS, B, LDB, X, LDX )
+ CALL SGTTRS( TRANS, N, NRHS, DLF, DF, DUF, DU2, IPIV, X, LDX,
+ $ INFO )
+*
+* Use iterative refinement to improve the computed solutions and
+* compute error bounds and backward error estimates for them.
+*
+ CALL SGTRFS( TRANS, N, NRHS, DL, D, DU, DLF, DF, DUF, DU2, IPIV,
+ $ B, LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO )
+*
+* Set INFO = N+1 if the matrix is singular to working precision.
+*
+ IF( RCOND.LT.SLAMCH( 'Epsilon' ) )
+ $ INFO = N + 1
+*
+ RETURN
+*
+* End of SGTSVX
+*
+ END
+ SUBROUTINE SGTTRF( N, DL, D, DU, DU2, IPIV, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, N
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ REAL D( * ), DL( * ), DU( * ), DU2( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SGTTRF computes an LU factorization of a real tridiagonal matrix A
+* using elimination with partial pivoting and row interchanges.
+*
+* The factorization has the form
+* A = L * U
+* where L is a product of permutation and unit lower bidiagonal
+* matrices and U is upper triangular with nonzeros in only the main
+* diagonal and first two superdiagonals.
+*
+* Arguments
+* =========
+*
+* N (input) INTEGER
+* The order of the matrix A.
+*
+* DL (input/output) REAL array, dimension (N-1)
+* On entry, DL must contain the (n-1) sub-diagonal elements of
+* A.
+*
+* On exit, DL is overwritten by the (n-1) multipliers that
+* define the matrix L from the LU factorization of A.
+*
+* D (input/output) REAL array, dimension (N)
+* On entry, D must contain the diagonal elements of A.
+*
+* On exit, D is overwritten by the n diagonal elements of the
+* upper triangular matrix U from the LU factorization of A.
+*
+* DU (input/output) REAL array, dimension (N-1)
+* On entry, DU must contain the (n-1) super-diagonal elements
+* of A.
+*
+* On exit, DU is overwritten by the (n-1) elements of the first
+* super-diagonal of U.
+*
+* DU2 (output) REAL array, dimension (N-2)
+* On exit, DU2 is overwritten by the (n-2) elements of the
+* second super-diagonal of U.
+*
+* IPIV (output) INTEGER array, dimension (N)
+* The pivot indices; for 1 <= i <= n, row i of the matrix was
+* interchanged with row IPIV(i). IPIV(i) will always be either
+* i or i+1; IPIV(i) = i indicates a row interchange was not
+* required.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -k, the k-th argument had an illegal value
+* > 0: if INFO = k, U(k,k) is exactly zero. The factorization
+* has been completed, but the factor U is exactly
+* singular, and division by zero will occur if it is used
+* to solve a system of equations.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO
+ PARAMETER ( ZERO = 0.0E+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I
+ REAL FACT, TEMP
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS
+* ..
+* .. External Subroutines ..
+ EXTERNAL XERBLA
+* ..
+* .. Executable Statements ..
+*
+ INFO = 0
+ IF( N.LT.0 ) THEN
+ INFO = -1
+ CALL XERBLA( 'SGTTRF', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+* Initialize IPIV(i) = i and DU2(I) = 0
+*
+ DO 10 I = 1, N
+ IPIV( I ) = I
+ 10 CONTINUE
+ DO 20 I = 1, N - 2
+ DU2( I ) = ZERO
+ 20 CONTINUE
+*
+ DO 30 I = 1, N - 2
+ IF( ABS( D( I ) ).GE.ABS( DL( I ) ) ) THEN
+*
+* No row interchange required, eliminate DL(I)
+*
+ IF( D( I ).NE.ZERO ) THEN
+ FACT = DL( I ) / D( I )
+ DL( I ) = FACT
+ D( I+1 ) = D( I+1 ) - FACT*DU( I )
+ END IF
+ ELSE
+*
+* Interchange rows I and I+1, eliminate DL(I)
+*
+ FACT = D( I ) / DL( I )
+ D( I ) = DL( I )
+ DL( I ) = FACT
+ TEMP = DU( I )
+ DU( I ) = D( I+1 )
+ D( I+1 ) = TEMP - FACT*D( I+1 )
+ DU2( I ) = DU( I+1 )
+ DU( I+1 ) = -FACT*DU( I+1 )
+ IPIV( I ) = I + 1
+ END IF
+ 30 CONTINUE
+ IF( N.GT.1 ) THEN
+ I = N - 1
+ IF( ABS( D( I ) ).GE.ABS( DL( I ) ) ) THEN
+ IF( D( I ).NE.ZERO ) THEN
+ FACT = DL( I ) / D( I )
+ DL( I ) = FACT
+ D( I+1 ) = D( I+1 ) - FACT*DU( I )
+ END IF
+ ELSE
+ FACT = D( I ) / DL( I )
+ D( I ) = DL( I )
+ DL( I ) = FACT
+ TEMP = DU( I )
+ DU( I ) = D( I+1 )
+ D( I+1 ) = TEMP - FACT*D( I+1 )
+ IPIV( I ) = I + 1
+ END IF
+ END IF
+*
+* Check for a zero on the diagonal of U.
+*
+ DO 40 I = 1, N
+ IF( D( I ).EQ.ZERO ) THEN
+ INFO = I
+ GO TO 50
+ END IF
+ 40 CONTINUE
+ 50 CONTINUE
+*
+ RETURN
+*
+* End of SGTTRF
+*
+ END
+ SUBROUTINE SGTTRS( TRANS, N, NRHS, DL, D, DU, DU2, IPIV, B, LDB,
+ $ INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER TRANS
+ INTEGER INFO, LDB, N, NRHS
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ REAL B( LDB, * ), D( * ), DL( * ), DU( * ), DU2( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SGTTRS solves one of the systems of equations
+* A*X = B or A'*X = B,
+* with a tridiagonal matrix A using the LU factorization computed
+* by SGTTRF.
+*
+* Arguments
+* =========
+*
+* TRANS (input) CHARACTER*1
+* Specifies the form of the system of equations.
+* = 'N': A * X = B (No transpose)
+* = 'T': A'* X = B (Transpose)
+* = 'C': A'* X = B (Conjugate transpose = Transpose)
+*
+* N (input) INTEGER
+* The order of the matrix A.
+*
+* NRHS (input) INTEGER
+* The number of right hand sides, i.e., the number of columns
+* of the matrix B. NRHS >= 0.
+*
+* DL (input) REAL array, dimension (N-1)
+* The (n-1) multipliers that define the matrix L from the
+* LU factorization of A.
+*
+* D (input) REAL array, dimension (N)
+* The n diagonal elements of the upper triangular matrix U from
+* the LU factorization of A.
+*
+* DU (input) REAL array, dimension (N-1)
+* The (n-1) elements of the first super-diagonal of U.
+*
+* DU2 (input) REAL array, dimension (N-2)
+* The (n-2) elements of the second super-diagonal of U.
+*
+* IPIV (input) INTEGER array, dimension (N)
+* The pivot indices; for 1 <= i <= n, row i of the matrix was
+* interchanged with row IPIV(i). IPIV(i) will always be either
+* i or i+1; IPIV(i) = i indicates a row interchange was not
+* required.
+*
+* B (input/output) REAL array, dimension (LDB,NRHS)
+* On entry, the matrix of right hand side vectors B.
+* On exit, B is overwritten by the solution vectors X.
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. LDB >= max(1,N).
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ LOGICAL NOTRAN
+ INTEGER ITRANS, J, JB, NB
+* ..
+* .. External Functions ..
+ INTEGER ILAENV
+ EXTERNAL ILAENV
+* ..
+* .. External Subroutines ..
+ EXTERNAL SGTTS2, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+ INFO = 0
+ NOTRAN = ( TRANS.EQ.'N' .OR. TRANS.EQ.'n' )
+ IF( .NOT.NOTRAN .AND. .NOT.( TRANS.EQ.'T' .OR. TRANS.EQ.
+ $ 't' ) .AND. .NOT.( TRANS.EQ.'C' .OR. TRANS.EQ.'c' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( NRHS.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( LDB.LT.MAX( N, 1 ) ) THEN
+ INFO = -10
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SGTTRS', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 .OR. NRHS.EQ.0 )
+ $ RETURN
+*
+* Decode TRANS
+*
+ IF( NOTRAN ) THEN
+ ITRANS = 0
+ ELSE
+ ITRANS = 1
+ END IF
+*
+* Determine the number of right-hand sides to solve at a time.
+*
+ IF( NRHS.EQ.1 ) THEN
+ NB = 1
+ ELSE
+ NB = MAX( 1, ILAENV( 1, 'SGTTRS', TRANS, N, NRHS, -1, -1 ) )
+ END IF
+*
+ IF( NB.GE.NRHS ) THEN
+ CALL SGTTS2( ITRANS, N, NRHS, DL, D, DU, DU2, IPIV, B, LDB )
+ ELSE
+ DO 10 J = 1, NRHS, NB
+ JB = MIN( NRHS-J+1, NB )
+ CALL SGTTS2( ITRANS, N, JB, DL, D, DU, DU2, IPIV, B( 1, J ),
+ $ LDB )
+ 10 CONTINUE
+ END IF
+*
+* End of SGTTRS
+*
+ END
+ SUBROUTINE SGTTS2( ITRANS, N, NRHS, DL, D, DU, DU2, IPIV, B, LDB )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER ITRANS, LDB, N, NRHS
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ REAL B( LDB, * ), D( * ), DL( * ), DU( * ), DU2( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SGTTS2 solves one of the systems of equations
+* A*X = B or A'*X = B,
+* with a tridiagonal matrix A using the LU factorization computed
+* by SGTTRF.
+*
+* Arguments
+* =========
+*
+* ITRANS (input) INTEGER
+* Specifies the form of the system of equations.
+* = 0: A * X = B (No transpose)
+* = 1: A'* X = B (Transpose)
+* = 2: A'* X = B (Conjugate transpose = Transpose)
+*
+* N (input) INTEGER
+* The order of the matrix A.
+*
+* NRHS (input) INTEGER
+* The number of right hand sides, i.e., the number of columns
+* of the matrix B. NRHS >= 0.
+*
+* DL (input) REAL array, dimension (N-1)
+* The (n-1) multipliers that define the matrix L from the
+* LU factorization of A.
+*
+* D (input) REAL array, dimension (N)
+* The n diagonal elements of the upper triangular matrix U from
+* the LU factorization of A.
+*
+* DU (input) REAL array, dimension (N-1)
+* The (n-1) elements of the first super-diagonal of U.
+*
+* DU2 (input) REAL array, dimension (N-2)
+* The (n-2) elements of the second super-diagonal of U.
+*
+* IPIV (input) INTEGER array, dimension (N)
+* The pivot indices; for 1 <= i <= n, row i of the matrix was
+* interchanged with row IPIV(i). IPIV(i) will always be either
+* i or i+1; IPIV(i) = i indicates a row interchange was not
+* required.
+*
+* B (input/output) REAL array, dimension (LDB,NRHS)
+* On entry, the matrix of right hand side vectors B.
+* On exit, B is overwritten by the solution vectors X.
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. LDB >= max(1,N).
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ INTEGER I, IP, J
+ REAL TEMP
+* ..
+* .. Executable Statements ..
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 .OR. NRHS.EQ.0 )
+ $ RETURN
+*
+ IF( ITRANS.EQ.0 ) THEN
+*
+* Solve A*X = B using the LU factorization of A,
+* overwriting each right hand side vector with its solution.
+*
+ IF( NRHS.LE.1 ) THEN
+ J = 1
+ 10 CONTINUE
+*
+* Solve L*x = b.
+*
+ DO 20 I = 1, N - 1
+ IP = IPIV( I )
+ TEMP = B( I+1-IP+I, J ) - DL( I )*B( IP, J )
+ B( I, J ) = B( IP, J )
+ B( I+1, J ) = TEMP
+ 20 CONTINUE
+*
+* Solve U*x = b.
+*
+ B( N, J ) = B( N, J ) / D( N )
+ IF( N.GT.1 )
+ $ B( N-1, J ) = ( B( N-1, J )-DU( N-1 )*B( N, J ) ) /
+ $ D( N-1 )
+ DO 30 I = N - 2, 1, -1
+ B( I, J ) = ( B( I, J )-DU( I )*B( I+1, J )-DU2( I )*
+ $ B( I+2, J ) ) / D( I )
+ 30 CONTINUE
+ IF( J.LT.NRHS ) THEN
+ J = J + 1
+ GO TO 10
+ END IF
+ ELSE
+ DO 60 J = 1, NRHS
+*
+* Solve L*x = b.
+*
+ DO 40 I = 1, N - 1
+ IF( IPIV( I ).EQ.I ) THEN
+ B( I+1, J ) = B( I+1, J ) - DL( I )*B( I, J )
+ ELSE
+ TEMP = B( I, J )
+ B( I, J ) = B( I+1, J )
+ B( I+1, J ) = TEMP - DL( I )*B( I, J )
+ END IF
+ 40 CONTINUE
+*
+* Solve U*x = b.
+*
+ B( N, J ) = B( N, J ) / D( N )
+ IF( N.GT.1 )
+ $ B( N-1, J ) = ( B( N-1, J )-DU( N-1 )*B( N, J ) ) /
+ $ D( N-1 )
+ DO 50 I = N - 2, 1, -1
+ B( I, J ) = ( B( I, J )-DU( I )*B( I+1, J )-DU2( I )*
+ $ B( I+2, J ) ) / D( I )
+ 50 CONTINUE
+ 60 CONTINUE
+ END IF
+ ELSE
+*
+* Solve A' * X = B.
+*
+ IF( NRHS.LE.1 ) THEN
+*
+* Solve U'*x = b.
+*
+ J = 1
+ 70 CONTINUE
+ B( 1, J ) = B( 1, J ) / D( 1 )
+ IF( N.GT.1 )
+ $ B( 2, J ) = ( B( 2, J )-DU( 1 )*B( 1, J ) ) / D( 2 )
+ DO 80 I = 3, N
+ B( I, J ) = ( B( I, J )-DU( I-1 )*B( I-1, J )-DU2( I-2 )*
+ $ B( I-2, J ) ) / D( I )
+ 80 CONTINUE
+*
+* Solve L'*x = b.
+*
+ DO 90 I = N - 1, 1, -1
+ IP = IPIV( I )
+ TEMP = B( I, J ) - DL( I )*B( I+1, J )
+ B( I, J ) = B( IP, J )
+ B( IP, J ) = TEMP
+ 90 CONTINUE
+ IF( J.LT.NRHS ) THEN
+ J = J + 1
+ GO TO 70
+ END IF
+*
+ ELSE
+ DO 120 J = 1, NRHS
+*
+* Solve U'*x = b.
+*
+ B( 1, J ) = B( 1, J ) / D( 1 )
+ IF( N.GT.1 )
+ $ B( 2, J ) = ( B( 2, J )-DU( 1 )*B( 1, J ) ) / D( 2 )
+ DO 100 I = 3, N
+ B( I, J ) = ( B( I, J )-DU( I-1 )*B( I-1, J )-
+ $ DU2( I-2 )*B( I-2, J ) ) / D( I )
+ 100 CONTINUE
+ DO 110 I = N - 1, 1, -1
+ IF( IPIV( I ).EQ.I ) THEN
+ B( I, J ) = B( I, J ) - DL( I )*B( I+1, J )
+ ELSE
+ TEMP = B( I+1, J )
+ B( I+1, J ) = B( I, J ) - DL( I )*TEMP
+ B( I, J ) = TEMP
+ END IF
+ 110 CONTINUE
+ 120 CONTINUE
+ END IF
+ END IF
+*
+* End of SGTTS2
+*
+ END
+ SUBROUTINE SHGEQZ( JOB, COMPQ, COMPZ, N, ILO, IHI, H, LDH, T, LDT,
+ $ ALPHAR, ALPHAI, BETA, Q, LDQ, Z, LDZ, WORK,
+ $ LWORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER COMPQ, COMPZ, JOB
+ INTEGER IHI, ILO, INFO, LDH, LDQ, LDT, LDZ, LWORK, N
+* ..
+* .. Array Arguments ..
+ REAL ALPHAI( * ), ALPHAR( * ), BETA( * ),
+ $ H( LDH, * ), Q( LDQ, * ), T( LDT, * ),
+ $ WORK( * ), Z( LDZ, * )
+* ..
+*
+* Purpose
+* =======
+*
+* SHGEQZ computes the eigenvalues of a real matrix pair (H,T),
+* where H is an upper Hessenberg matrix and T is upper triangular,
+* using the double-shift QZ method.
+* Matrix pairs of this type are produced by the reduction to
+* generalized upper Hessenberg form of a real matrix pair (A,B):
+*
+* A = Q1*H*Z1**T, B = Q1*T*Z1**T,
+*
+* as computed by SGGHRD.
+*
+* If JOB='S', then the Hessenberg-triangular pair (H,T) is
+* also reduced to generalized Schur form,
+*
+* H = Q*S*Z**T, T = Q*P*Z**T,
+*
+* where Q and Z are orthogonal matrices, P is an upper triangular
+* matrix, and S is a quasi-triangular matrix with 1-by-1 and 2-by-2
+* diagonal blocks.
+*
+* The 1-by-1 blocks correspond to real eigenvalues of the matrix pair
+* (H,T) and the 2-by-2 blocks correspond to complex conjugate pairs of
+* eigenvalues.
+*
+* Additionally, the 2-by-2 upper triangular diagonal blocks of P
+* corresponding to 2-by-2 blocks of S are reduced to positive diagonal
+* form, i.e., if S(j+1,j) is non-zero, then P(j+1,j) = P(j,j+1) = 0,
+* P(j,j) > 0, and P(j+1,j+1) > 0.
+*
+* Optionally, the orthogonal matrix Q from the generalized Schur
+* factorization may be postmultiplied into an input matrix Q1, and the
+* orthogonal matrix Z may be postmultiplied into an input matrix Z1.
+* If Q1 and Z1 are the orthogonal matrices from SGGHRD that reduced
+* the matrix pair (A,B) to generalized upper Hessenberg form, then the
+* output matrices Q1*Q and Z1*Z are the orthogonal factors from the
+* generalized Schur factorization of (A,B):
+*
+* A = (Q1*Q)*S*(Z1*Z)**T, B = (Q1*Q)*P*(Z1*Z)**T.
+*
+* To avoid overflow, eigenvalues of the matrix pair (H,T) (equivalently,
+* of (A,B)) are computed as a pair of values (alpha,beta), where alpha is
+* complex and beta real.
+* If beta is nonzero, lambda = alpha / beta is an eigenvalue of the
+* generalized nonsymmetric eigenvalue problem (GNEP)
+* A*x = lambda*B*x
+* and if alpha is nonzero, mu = beta / alpha is an eigenvalue of the
+* alternate form of the GNEP
+* mu*A*y = B*y.
+* Real eigenvalues can be read directly from the generalized Schur
+* form:
+* alpha = S(i,i), beta = P(i,i).
+*
+* Ref: C.B. Moler & G.W. Stewart, "An Algorithm for Generalized Matrix
+* Eigenvalue Problems", SIAM J. Numer. Anal., 10(1973),
+* pp. 241--256.
+*
+* Arguments
+* =========
+*
+* JOB (input) CHARACTER*1
+* = 'E': Compute eigenvalues only;
+* = 'S': Compute eigenvalues and the Schur form.
+*
+* COMPQ (input) CHARACTER*1
+* = 'N': Left Schur vectors (Q) are not computed;
+* = 'I': Q is initialized to the unit matrix and the matrix Q
+* of left Schur vectors of (H,T) is returned;
+* = 'V': Q must contain an orthogonal matrix Q1 on entry and
+* the product Q1*Q is returned.
+*
+* COMPZ (input) CHARACTER*1
+* = 'N': Right Schur vectors (Z) are not computed;
+* = 'I': Z is initialized to the unit matrix and the matrix Z
+* of right Schur vectors of (H,T) is returned;
+* = 'V': Z must contain an orthogonal matrix Z1 on entry and
+* the product Z1*Z is returned.
+*
+* N (input) INTEGER
+* The order of the matrices H, T, Q, and Z. N >= 0.
+*
+* ILO (input) INTEGER
+* IHI (input) INTEGER
+* ILO and IHI mark the rows and columns of H which are in
+* Hessenberg form. It is assumed that A is already upper
+* triangular in rows and columns 1:ILO-1 and IHI+1:N.
+* If N > 0, 1 <= ILO <= IHI <= N; if N = 0, ILO=1 and IHI=0.
+*
+* H (input/output) REAL array, dimension (LDH, N)
+* On entry, the N-by-N upper Hessenberg matrix H.
+* On exit, if JOB = 'S', H contains the upper quasi-triangular
+* matrix S from the generalized Schur factorization;
+* 2-by-2 diagonal blocks (corresponding to complex conjugate
+* pairs of eigenvalues) are returned in standard form, with
+* H(i,i) = H(i+1,i+1) and H(i+1,i)*H(i,i+1) < 0.
+* If JOB = 'E', the diagonal blocks of H match those of S, but
+* the rest of H is unspecified.
+*
+* LDH (input) INTEGER
+* The leading dimension of the array H. LDH >= max( 1, N ).
+*
+* T (input/output) REAL array, dimension (LDT, N)
+* On entry, the N-by-N upper triangular matrix T.
+* On exit, if JOB = 'S', T contains the upper triangular
+* matrix P from the generalized Schur factorization;
+* 2-by-2 diagonal blocks of P corresponding to 2-by-2 blocks of S
+* are reduced to positive diagonal form, i.e., if H(j+1,j) is
+* non-zero, then T(j+1,j) = T(j,j+1) = 0, T(j,j) > 0, and
+* T(j+1,j+1) > 0.
+* If JOB = 'E', the diagonal blocks of T match those of P, but
+* the rest of T is unspecified.
+*
+* LDT (input) INTEGER
+* The leading dimension of the array T. LDT >= max( 1, N ).
+*
+* ALPHAR (output) REAL array, dimension (N)
+* The real parts of each scalar alpha defining an eigenvalue
+* of GNEP.
+*
+* ALPHAI (output) REAL array, dimension (N)
+* The imaginary parts of each scalar alpha defining an
+* eigenvalue of GNEP.
+* If ALPHAI(j) is zero, then the j-th eigenvalue is real; if
+* positive, then the j-th and (j+1)-st eigenvalues are a
+* complex conjugate pair, with ALPHAI(j+1) = -ALPHAI(j).
+*
+* BETA (output) REAL array, dimension (N)
+* The scalars beta that define the eigenvalues of GNEP.
+* Together, the quantities alpha = (ALPHAR(j),ALPHAI(j)) and
+* beta = BETA(j) represent the j-th eigenvalue of the matrix
+* pair (A,B), in one of the forms lambda = alpha/beta or
+* mu = beta/alpha. Since either lambda or mu may overflow,
+* they should not, in general, be computed.
+*
+* Q (input/output) REAL array, dimension (LDQ, N)
+* On entry, if COMPZ = 'V', the orthogonal matrix Q1 used in
+* the reduction of (A,B) to generalized Hessenberg form.
+* On exit, if COMPZ = 'I', the orthogonal matrix of left Schur
+* vectors of (H,T), and if COMPZ = 'V', the orthogonal matrix
+* of left Schur vectors of (A,B).
+* Not referenced if COMPZ = 'N'.
+*
+* LDQ (input) INTEGER
+* The leading dimension of the array Q. LDQ >= 1.
+* If COMPQ='V' or 'I', then LDQ >= N.
+*
+* Z (input/output) REAL array, dimension (LDZ, N)
+* On entry, if COMPZ = 'V', the orthogonal matrix Z1 used in
+* the reduction of (A,B) to generalized Hessenberg form.
+* On exit, if COMPZ = 'I', the orthogonal matrix of
+* right Schur vectors of (H,T), and if COMPZ = 'V', the
+* orthogonal matrix of right Schur vectors of (A,B).
+* Not referenced if COMPZ = 'N'.
+*
+* LDZ (input) INTEGER
+* The leading dimension of the array Z. LDZ >= 1.
+* If COMPZ='V' or 'I', then LDZ >= N.
+*
+* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))
+* On exit, if INFO >= 0, WORK(1) returns the optimal LWORK.
+*
+* LWORK (input) INTEGER
+* The dimension of the array WORK. LWORK >= max(1,N).
+*
+* If LWORK = -1, then a workspace query is assumed; the routine
+* only calculates the optimal size of the WORK array, returns
+* this value as the first entry of the WORK array, and no error
+* message related to LWORK is issued by XERBLA.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* = 1,...,N: the QZ iteration did not converge. (H,T) is not
+* in Schur form, but ALPHAR(i), ALPHAI(i), and
+* BETA(i), i=INFO+1,...,N should be correct.
+* = N+1,...,2*N: the shift calculation failed. (H,T) is not
+* in Schur form, but ALPHAR(i), ALPHAI(i), and
+* BETA(i), i=INFO-N+1,...,N should be correct.
+*
+* Further Details
+* ===============
+*
+* Iteration counters:
+*
+* JITER -- counts iterations.
+* IITER -- counts iterations run since ILAST was last
+* changed. This is therefore reset only when a 1-by-1 or
+* 2-by-2 block deflates off the bottom.
+*
+* =====================================================================
+*
+* .. Parameters ..
+* $ SAFETY = 1.0E+0 )
+ REAL HALF, ZERO, ONE, SAFETY
+ PARAMETER ( HALF = 0.5E+0, ZERO = 0.0E+0, ONE = 1.0E+0,
+ $ SAFETY = 1.0E+2 )
+* ..
+* .. Local Scalars ..
+ LOGICAL ILAZR2, ILAZRO, ILPIVT, ILQ, ILSCHR, ILZ,
+ $ LQUERY
+ INTEGER ICOMPQ, ICOMPZ, IFIRST, IFRSTM, IITER, ILAST,
+ $ ILASTM, IN, ISCHUR, ISTART, J, JC, JCH, JITER,
+ $ JR, MAXIT
+ REAL A11, A12, A1I, A1R, A21, A22, A2I, A2R, AD11,
+ $ AD11L, AD12, AD12L, AD21, AD21L, AD22, AD22L,
+ $ AD32L, AN, ANORM, ASCALE, ATOL, B11, B1A, B1I,
+ $ B1R, B22, B2A, B2I, B2R, BN, BNORM, BSCALE,
+ $ BTOL, C, C11I, C11R, C12, C21, C22I, C22R, CL,
+ $ CQ, CR, CZ, ESHIFT, S, S1, S1INV, S2, SAFMAX,
+ $ SAFMIN, SCALE, SL, SQI, SQR, SR, SZI, SZR, T1,
+ $ TAU, TEMP, TEMP2, TEMPI, TEMPR, U1, U12, U12L,
+ $ U2, ULP, VS, W11, W12, W21, W22, WABS, WI, WR,
+ $ WR2
+* ..
+* .. Local Arrays ..
+ REAL V( 3 )
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ REAL SLAMCH, SLANHS, SLAPY2, SLAPY3
+ EXTERNAL LSAME, SLAMCH, SLANHS, SLAPY2, SLAPY3
+* ..
+* .. External Subroutines ..
+ EXTERNAL SLAG2, SLARFG, SLARTG, SLASET, SLASV2, SROT,
+ $ XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, MIN, REAL, SQRT
+* ..
+* .. Executable Statements ..
+*
+* Decode JOB, COMPQ, COMPZ
+*
+ IF( LSAME( JOB, 'E' ) ) THEN
+ ILSCHR = .FALSE.
+ ISCHUR = 1
+ ELSE IF( LSAME( JOB, 'S' ) ) THEN
+ ILSCHR = .TRUE.
+ ISCHUR = 2
+ ELSE
+ ISCHUR = 0
+ END IF
+*
+ IF( LSAME( COMPQ, 'N' ) ) THEN
+ ILQ = .FALSE.
+ ICOMPQ = 1
+ ELSE IF( LSAME( COMPQ, 'V' ) ) THEN
+ ILQ = .TRUE.
+ ICOMPQ = 2
+ ELSE IF( LSAME( COMPQ, 'I' ) ) THEN
+ ILQ = .TRUE.
+ ICOMPQ = 3
+ ELSE
+ ICOMPQ = 0
+ END IF
+*
+ IF( LSAME( COMPZ, 'N' ) ) THEN
+ ILZ = .FALSE.
+ ICOMPZ = 1
+ ELSE IF( LSAME( COMPZ, 'V' ) ) THEN
+ ILZ = .TRUE.
+ ICOMPZ = 2
+ ELSE IF( LSAME( COMPZ, 'I' ) ) THEN
+ ILZ = .TRUE.
+ ICOMPZ = 3
+ ELSE
+ ICOMPZ = 0
+ END IF
+*
+* Check Argument Values
+*
+ INFO = 0
+ WORK( 1 ) = MAX( 1, N )
+ LQUERY = ( LWORK.EQ.-1 )
+ IF( ISCHUR.EQ.0 ) THEN
+ INFO = -1
+ ELSE IF( ICOMPQ.EQ.0 ) THEN
+ INFO = -2
+ ELSE IF( ICOMPZ.EQ.0 ) THEN
+ INFO = -3
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( ILO.LT.1 ) THEN
+ INFO = -5
+ ELSE IF( IHI.GT.N .OR. IHI.LT.ILO-1 ) THEN
+ INFO = -6
+ ELSE IF( LDH.LT.N ) THEN
+ INFO = -8
+ ELSE IF( LDT.LT.N ) THEN
+ INFO = -10
+ ELSE IF( LDQ.LT.1 .OR. ( ILQ .AND. LDQ.LT.N ) ) THEN
+ INFO = -15
+ ELSE IF( LDZ.LT.1 .OR. ( ILZ .AND. LDZ.LT.N ) ) THEN
+ INFO = -17
+ ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN
+ INFO = -19
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SHGEQZ', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.LE.0 ) THEN
+ WORK( 1 ) = REAL( 1 )
+ RETURN
+ END IF
+*
+* Initialize Q and Z
+*
+ IF( ICOMPQ.EQ.3 )
+ $ CALL SLASET( 'Full', N, N, ZERO, ONE, Q, LDQ )
+ IF( ICOMPZ.EQ.3 )
+ $ CALL SLASET( 'Full', N, N, ZERO, ONE, Z, LDZ )
+*
+* Machine Constants
+*
+ IN = IHI + 1 - ILO
+ SAFMIN = SLAMCH( 'S' )
+ SAFMAX = ONE / SAFMIN
+ ULP = SLAMCH( 'E' )*SLAMCH( 'B' )
+ ANORM = SLANHS( 'F', IN, H( ILO, ILO ), LDH, WORK )
+ BNORM = SLANHS( 'F', IN, T( ILO, ILO ), LDT, WORK )
+ ATOL = MAX( SAFMIN, ULP*ANORM )
+ BTOL = MAX( SAFMIN, ULP*BNORM )
+ ASCALE = ONE / MAX( SAFMIN, ANORM )
+ BSCALE = ONE / MAX( SAFMIN, BNORM )
+*
+* Set Eigenvalues IHI+1:N
+*
+ DO 30 J = IHI + 1, N
+ IF( T( J, J ).LT.ZERO ) THEN
+ IF( ILSCHR ) THEN
+ DO 10 JR = 1, J
+ H( JR, J ) = -H( JR, J )
+ T( JR, J ) = -T( JR, J )
+ 10 CONTINUE
+ ELSE
+ H( J, J ) = -H( J, J )
+ T( J, J ) = -T( J, J )
+ END IF
+ IF( ILZ ) THEN
+ DO 20 JR = 1, N
+ Z( JR, J ) = -Z( JR, J )
+ 20 CONTINUE
+ END IF
+ END IF
+ ALPHAR( J ) = H( J, J )
+ ALPHAI( J ) = ZERO
+ BETA( J ) = T( J, J )
+ 30 CONTINUE
+*
+* If IHI < ILO, skip QZ steps
+*
+ IF( IHI.LT.ILO )
+ $ GO TO 380
+*
+* MAIN QZ ITERATION LOOP
+*
+* Initialize dynamic indices
+*
+* Eigenvalues ILAST+1:N have been found.
+* Column operations modify rows IFRSTM:whatever.
+* Row operations modify columns whatever:ILASTM.
+*
+* If only eigenvalues are being computed, then
+* IFRSTM is the row of the last splitting row above row ILAST;
+* this is always at least ILO.
+* IITER counts iterations since the last eigenvalue was found,
+* to tell when to use an extraordinary shift.
+* MAXIT is the maximum number of QZ sweeps allowed.
+*
+ ILAST = IHI
+ IF( ILSCHR ) THEN
+ IFRSTM = 1
+ ILASTM = N
+ ELSE
+ IFRSTM = ILO
+ ILASTM = IHI
+ END IF
+ IITER = 0
+ ESHIFT = ZERO
+ MAXIT = 30*( IHI-ILO+1 )
+*
+ DO 360 JITER = 1, MAXIT
+*
+* Split the matrix if possible.
+*
+* Two tests:
+* 1: H(j,j-1)=0 or j=ILO
+* 2: T(j,j)=0
+*
+ IF( ILAST.EQ.ILO ) THEN
+*
+* Special case: j=ILAST
+*
+ GO TO 80
+ ELSE
+ IF( ABS( H( ILAST, ILAST-1 ) ).LE.ATOL ) THEN
+ H( ILAST, ILAST-1 ) = ZERO
+ GO TO 80
+ END IF
+ END IF
+*
+ IF( ABS( T( ILAST, ILAST ) ).LE.BTOL ) THEN
+ T( ILAST, ILAST ) = ZERO
+ GO TO 70
+ END IF
+*
+* General case: j<ILAST
+*
+ DO 60 J = ILAST - 1, ILO, -1
+*
+* Test 1: for H(j,j-1)=0 or j=ILO
+*
+ IF( J.EQ.ILO ) THEN
+ ILAZRO = .TRUE.
+ ELSE
+ IF( ABS( H( J, J-1 ) ).LE.ATOL ) THEN
+ H( J, J-1 ) = ZERO
+ ILAZRO = .TRUE.
+ ELSE
+ ILAZRO = .FALSE.
+ END IF
+ END IF
+*
+* Test 2: for T(j,j)=0
+*
+ IF( ABS( T( J, J ) ).LT.BTOL ) THEN
+ T( J, J ) = ZERO
+*
+* Test 1a: Check for 2 consecutive small subdiagonals in A
+*
+ ILAZR2 = .FALSE.
+ IF( .NOT.ILAZRO ) THEN
+ TEMP = ABS( H( J, J-1 ) )
+ TEMP2 = ABS( H( J, J ) )
+ TEMPR = MAX( TEMP, TEMP2 )
+ IF( TEMPR.LT.ONE .AND. TEMPR.NE.ZERO ) THEN
+ TEMP = TEMP / TEMPR
+ TEMP2 = TEMP2 / TEMPR
+ END IF
+ IF( TEMP*( ASCALE*ABS( H( J+1, J ) ) ).LE.TEMP2*
+ $ ( ASCALE*ATOL ) )ILAZR2 = .TRUE.
+ END IF
+*
+* If both tests pass (1 & 2), i.e., the leading diagonal
+* element of B in the block is zero, split a 1x1 block off
+* at the top. (I.e., at the J-th row/column) The leading
+* diagonal element of the remainder can also be zero, so
+* this may have to be done repeatedly.
+*
+ IF( ILAZRO .OR. ILAZR2 ) THEN
+ DO 40 JCH = J, ILAST - 1
+ TEMP = H( JCH, JCH )
+ CALL SLARTG( TEMP, H( JCH+1, JCH ), C, S,
+ $ H( JCH, JCH ) )
+ H( JCH+1, JCH ) = ZERO
+ CALL SROT( ILASTM-JCH, H( JCH, JCH+1 ), LDH,
+ $ H( JCH+1, JCH+1 ), LDH, C, S )
+ CALL SROT( ILASTM-JCH, T( JCH, JCH+1 ), LDT,
+ $ T( JCH+1, JCH+1 ), LDT, C, S )
+ IF( ILQ )
+ $ CALL SROT( N, Q( 1, JCH ), 1, Q( 1, JCH+1 ), 1,
+ $ C, S )
+ IF( ILAZR2 )
+ $ H( JCH, JCH-1 ) = H( JCH, JCH-1 )*C
+ ILAZR2 = .FALSE.
+ IF( ABS( T( JCH+1, JCH+1 ) ).GE.BTOL ) THEN
+ IF( JCH+1.GE.ILAST ) THEN
+ GO TO 80
+ ELSE
+ IFIRST = JCH + 1
+ GO TO 110
+ END IF
+ END IF
+ T( JCH+1, JCH+1 ) = ZERO
+ 40 CONTINUE
+ GO TO 70
+ ELSE
+*
+* Only test 2 passed -- chase the zero to T(ILAST,ILAST)
+* Then process as in the case T(ILAST,ILAST)=0
+*
+ DO 50 JCH = J, ILAST - 1
+ TEMP = T( JCH, JCH+1 )
+ CALL SLARTG( TEMP, T( JCH+1, JCH+1 ), C, S,
+ $ T( JCH, JCH+1 ) )
+ T( JCH+1, JCH+1 ) = ZERO
+ IF( JCH.LT.ILASTM-1 )
+ $ CALL SROT( ILASTM-JCH-1, T( JCH, JCH+2 ), LDT,
+ $ T( JCH+1, JCH+2 ), LDT, C, S )
+ CALL SROT( ILASTM-JCH+2, H( JCH, JCH-1 ), LDH,
+ $ H( JCH+1, JCH-1 ), LDH, C, S )
+ IF( ILQ )
+ $ CALL SROT( N, Q( 1, JCH ), 1, Q( 1, JCH+1 ), 1,
+ $ C, S )
+ TEMP = H( JCH+1, JCH )
+ CALL SLARTG( TEMP, H( JCH+1, JCH-1 ), C, S,
+ $ H( JCH+1, JCH ) )
+ H( JCH+1, JCH-1 ) = ZERO
+ CALL SROT( JCH+1-IFRSTM, H( IFRSTM, JCH ), 1,
+ $ H( IFRSTM, JCH-1 ), 1, C, S )
+ CALL SROT( JCH-IFRSTM, T( IFRSTM, JCH ), 1,
+ $ T( IFRSTM, JCH-1 ), 1, C, S )
+ IF( ILZ )
+ $ CALL SROT( N, Z( 1, JCH ), 1, Z( 1, JCH-1 ), 1,
+ $ C, S )
+ 50 CONTINUE
+ GO TO 70
+ END IF
+ ELSE IF( ILAZRO ) THEN
+*
+* Only test 1 passed -- work on J:ILAST
+*
+ IFIRST = J
+ GO TO 110
+ END IF
+*
+* Neither test passed -- try next J
+*
+ 60 CONTINUE
+*
+* (Drop-through is "impossible")
+*
+ INFO = N + 1
+ GO TO 420
+*
+* T(ILAST,ILAST)=0 -- clear H(ILAST,ILAST-1) to split off a
+* 1x1 block.
+*
+ 70 CONTINUE
+ TEMP = H( ILAST, ILAST )
+ CALL SLARTG( TEMP, H( ILAST, ILAST-1 ), C, S,
+ $ H( ILAST, ILAST ) )
+ H( ILAST, ILAST-1 ) = ZERO
+ CALL SROT( ILAST-IFRSTM, H( IFRSTM, ILAST ), 1,
+ $ H( IFRSTM, ILAST-1 ), 1, C, S )
+ CALL SROT( ILAST-IFRSTM, T( IFRSTM, ILAST ), 1,
+ $ T( IFRSTM, ILAST-1 ), 1, C, S )
+ IF( ILZ )
+ $ CALL SROT( N, Z( 1, ILAST ), 1, Z( 1, ILAST-1 ), 1, C, S )
+*
+* H(ILAST,ILAST-1)=0 -- Standardize B, set ALPHAR, ALPHAI,
+* and BETA
+*
+ 80 CONTINUE
+ IF( T( ILAST, ILAST ).LT.ZERO ) THEN
+ IF( ILSCHR ) THEN
+ DO 90 J = IFRSTM, ILAST
+ H( J, ILAST ) = -H( J, ILAST )
+ T( J, ILAST ) = -T( J, ILAST )
+ 90 CONTINUE
+ ELSE
+ H( ILAST, ILAST ) = -H( ILAST, ILAST )
+ T( ILAST, ILAST ) = -T( ILAST, ILAST )
+ END IF
+ IF( ILZ ) THEN
+ DO 100 J = 1, N
+ Z( J, ILAST ) = -Z( J, ILAST )
+ 100 CONTINUE
+ END IF
+ END IF
+ ALPHAR( ILAST ) = H( ILAST, ILAST )
+ ALPHAI( ILAST ) = ZERO
+ BETA( ILAST ) = T( ILAST, ILAST )
+*
+* Go to next block -- exit if finished.
+*
+ ILAST = ILAST - 1
+ IF( ILAST.LT.ILO )
+ $ GO TO 380
+*
+* Reset counters
+*
+ IITER = 0
+ ESHIFT = ZERO
+ IF( .NOT.ILSCHR ) THEN
+ ILASTM = ILAST
+ IF( IFRSTM.GT.ILAST )
+ $ IFRSTM = ILO
+ END IF
+ GO TO 350
+*
+* QZ step
+*
+* This iteration only involves rows/columns IFIRST:ILAST. We
+* assume IFIRST < ILAST, and that the diagonal of B is non-zero.
+*
+ 110 CONTINUE
+ IITER = IITER + 1
+ IF( .NOT.ILSCHR ) THEN
+ IFRSTM = IFIRST
+ END IF
+*
+* Compute single shifts.
+*
+* At this point, IFIRST < ILAST, and the diagonal elements of
+* T(IFIRST:ILAST,IFIRST,ILAST) are larger than BTOL (in
+* magnitude)
+*
+ IF( ( IITER / 10 )*10.EQ.IITER ) THEN
+*
+* Exceptional shift. Chosen for no particularly good reason.
+* (Single shift only.)
+*
+ IF( ( REAL( MAXIT )*SAFMIN )*ABS( H( ILAST-1, ILAST ) ).LT.
+ $ ABS( T( ILAST-1, ILAST-1 ) ) ) THEN
+ ESHIFT = ESHIFT + H( ILAST-1, ILAST ) /
+ $ T( ILAST-1, ILAST-1 )
+ ELSE
+ ESHIFT = ESHIFT + ONE / ( SAFMIN*REAL( MAXIT ) )
+ END IF
+ S1 = ONE
+ WR = ESHIFT
+*
+ ELSE
+*
+* Shifts based on the generalized eigenvalues of the
+* bottom-right 2x2 block of A and B. The first eigenvalue
+* returned by SLAG2 is the Wilkinson shift (AEP p.512),
+*
+ CALL SLAG2( H( ILAST-1, ILAST-1 ), LDH,
+ $ T( ILAST-1, ILAST-1 ), LDT, SAFMIN*SAFETY, S1,
+ $ S2, WR, WR2, WI )
+*
+ TEMP = MAX( S1, SAFMIN*MAX( ONE, ABS( WR ), ABS( WI ) ) )
+ IF( WI.NE.ZERO )
+ $ GO TO 200
+ END IF
+*
+* Fiddle with shift to avoid overflow
+*
+ TEMP = MIN( ASCALE, ONE )*( HALF*SAFMAX )
+ IF( S1.GT.TEMP ) THEN
+ SCALE = TEMP / S1
+ ELSE
+ SCALE = ONE
+ END IF
+*
+ TEMP = MIN( BSCALE, ONE )*( HALF*SAFMAX )
+ IF( ABS( WR ).GT.TEMP )
+ $ SCALE = MIN( SCALE, TEMP / ABS( WR ) )
+ S1 = SCALE*S1
+ WR = SCALE*WR
+*
+* Now check for two consecutive small subdiagonals.
+*
+ DO 120 J = ILAST - 1, IFIRST + 1, -1
+ ISTART = J
+ TEMP = ABS( S1*H( J, J-1 ) )
+ TEMP2 = ABS( S1*H( J, J )-WR*T( J, J ) )
+ TEMPR = MAX( TEMP, TEMP2 )
+ IF( TEMPR.LT.ONE .AND. TEMPR.NE.ZERO ) THEN
+ TEMP = TEMP / TEMPR
+ TEMP2 = TEMP2 / TEMPR
+ END IF
+ IF( ABS( ( ASCALE*H( J+1, J ) )*TEMP ).LE.( ASCALE*ATOL )*
+ $ TEMP2 )GO TO 130
+ 120 CONTINUE
+*
+ ISTART = IFIRST
+ 130 CONTINUE
+*
+* Do an implicit single-shift QZ sweep.
+*
+* Initial Q
+*
+ TEMP = S1*H( ISTART, ISTART ) - WR*T( ISTART, ISTART )
+ TEMP2 = S1*H( ISTART+1, ISTART )
+ CALL SLARTG( TEMP, TEMP2, C, S, TEMPR )
+*
+* Sweep
+*
+ DO 190 J = ISTART, ILAST - 1
+ IF( J.GT.ISTART ) THEN
+ TEMP = H( J, J-1 )
+ CALL SLARTG( TEMP, H( J+1, J-1 ), C, S, H( J, J-1 ) )
+ H( J+1, J-1 ) = ZERO
+ END IF
+*
+ DO 140 JC = J, ILASTM
+ TEMP = C*H( J, JC ) + S*H( J+1, JC )
+ H( J+1, JC ) = -S*H( J, JC ) + C*H( J+1, JC )
+ H( J, JC ) = TEMP
+ TEMP2 = C*T( J, JC ) + S*T( J+1, JC )
+ T( J+1, JC ) = -S*T( J, JC ) + C*T( J+1, JC )
+ T( J, JC ) = TEMP2
+ 140 CONTINUE
+ IF( ILQ ) THEN
+ DO 150 JR = 1, N
+ TEMP = C*Q( JR, J ) + S*Q( JR, J+1 )
+ Q( JR, J+1 ) = -S*Q( JR, J ) + C*Q( JR, J+1 )
+ Q( JR, J ) = TEMP
+ 150 CONTINUE
+ END IF
+*
+ TEMP = T( J+1, J+1 )
+ CALL SLARTG( TEMP, T( J+1, J ), C, S, T( J+1, J+1 ) )
+ T( J+1, J ) = ZERO
+*
+ DO 160 JR = IFRSTM, MIN( J+2, ILAST )
+ TEMP = C*H( JR, J+1 ) + S*H( JR, J )
+ H( JR, J ) = -S*H( JR, J+1 ) + C*H( JR, J )
+ H( JR, J+1 ) = TEMP
+ 160 CONTINUE
+ DO 170 JR = IFRSTM, J
+ TEMP = C*T( JR, J+1 ) + S*T( JR, J )
+ T( JR, J ) = -S*T( JR, J+1 ) + C*T( JR, J )
+ T( JR, J+1 ) = TEMP
+ 170 CONTINUE
+ IF( ILZ ) THEN
+ DO 180 JR = 1, N
+ TEMP = C*Z( JR, J+1 ) + S*Z( JR, J )
+ Z( JR, J ) = -S*Z( JR, J+1 ) + C*Z( JR, J )
+ Z( JR, J+1 ) = TEMP
+ 180 CONTINUE
+ END IF
+ 190 CONTINUE
+*
+ GO TO 350
+*
+* Use Francis double-shift
+*
+* Note: the Francis double-shift should work with real shifts,
+* but only if the block is at least 3x3.
+* This code may break if this point is reached with
+* a 2x2 block with real eigenvalues.
+*
+ 200 CONTINUE
+ IF( IFIRST+1.EQ.ILAST ) THEN
+*
+* Special case -- 2x2 block with complex eigenvectors
+*
+* Step 1: Standardize, that is, rotate so that
+*
+* ( B11 0 )
+* B = ( ) with B11 non-negative.
+* ( 0 B22 )
+*
+ CALL SLASV2( T( ILAST-1, ILAST-1 ), T( ILAST-1, ILAST ),
+ $ T( ILAST, ILAST ), B22, B11, SR, CR, SL, CL )
+*
+ IF( B11.LT.ZERO ) THEN
+ CR = -CR
+ SR = -SR
+ B11 = -B11
+ B22 = -B22
+ END IF
+*
+ CALL SROT( ILASTM+1-IFIRST, H( ILAST-1, ILAST-1 ), LDH,
+ $ H( ILAST, ILAST-1 ), LDH, CL, SL )
+ CALL SROT( ILAST+1-IFRSTM, H( IFRSTM, ILAST-1 ), 1,
+ $ H( IFRSTM, ILAST ), 1, CR, SR )
+*
+ IF( ILAST.LT.ILASTM )
+ $ CALL SROT( ILASTM-ILAST, T( ILAST-1, ILAST+1 ), LDT,
+ $ T( ILAST, ILAST+1 ), LDH, CL, SL )
+ IF( IFRSTM.LT.ILAST-1 )
+ $ CALL SROT( IFIRST-IFRSTM, T( IFRSTM, ILAST-1 ), 1,
+ $ T( IFRSTM, ILAST ), 1, CR, SR )
+*
+ IF( ILQ )
+ $ CALL SROT( N, Q( 1, ILAST-1 ), 1, Q( 1, ILAST ), 1, CL,
+ $ SL )
+ IF( ILZ )
+ $ CALL SROT( N, Z( 1, ILAST-1 ), 1, Z( 1, ILAST ), 1, CR,
+ $ SR )
+*
+ T( ILAST-1, ILAST-1 ) = B11
+ T( ILAST-1, ILAST ) = ZERO
+ T( ILAST, ILAST-1 ) = ZERO
+ T( ILAST, ILAST ) = B22
+*
+* If B22 is negative, negate column ILAST
+*
+ IF( B22.LT.ZERO ) THEN
+ DO 210 J = IFRSTM, ILAST
+ H( J, ILAST ) = -H( J, ILAST )
+ T( J, ILAST ) = -T( J, ILAST )
+ 210 CONTINUE
+*
+ IF( ILZ ) THEN
+ DO 220 J = 1, N
+ Z( J, ILAST ) = -Z( J, ILAST )
+ 220 CONTINUE
+ END IF
+ END IF
+*
+* Step 2: Compute ALPHAR, ALPHAI, and BETA (see refs.)
+*
+* Recompute shift
+*
+ CALL SLAG2( H( ILAST-1, ILAST-1 ), LDH,
+ $ T( ILAST-1, ILAST-1 ), LDT, SAFMIN*SAFETY, S1,
+ $ TEMP, WR, TEMP2, WI )
+*
+* If standardization has perturbed the shift onto real line,
+* do another (real single-shift) QR step.
+*
+ IF( WI.EQ.ZERO )
+ $ GO TO 350
+ S1INV = ONE / S1
+*
+* Do EISPACK (QZVAL) computation of alpha and beta
+*
+ A11 = H( ILAST-1, ILAST-1 )
+ A21 = H( ILAST, ILAST-1 )
+ A12 = H( ILAST-1, ILAST )
+ A22 = H( ILAST, ILAST )
+*
+* Compute complex Givens rotation on right
+* (Assume some element of C = (sA - wB) > unfl )
+* __
+* (sA - wB) ( CZ -SZ )
+* ( SZ CZ )
+*
+ C11R = S1*A11 - WR*B11
+ C11I = -WI*B11
+ C12 = S1*A12
+ C21 = S1*A21
+ C22R = S1*A22 - WR*B22
+ C22I = -WI*B22
+*
+ IF( ABS( C11R )+ABS( C11I )+ABS( C12 ).GT.ABS( C21 )+
+ $ ABS( C22R )+ABS( C22I ) ) THEN
+ T1 = SLAPY3( C12, C11R, C11I )
+ CZ = C12 / T1
+ SZR = -C11R / T1
+ SZI = -C11I / T1
+ ELSE
+ CZ = SLAPY2( C22R, C22I )
+ IF( CZ.LE.SAFMIN ) THEN
+ CZ = ZERO
+ SZR = ONE
+ SZI = ZERO
+ ELSE
+ TEMPR = C22R / CZ
+ TEMPI = C22I / CZ
+ T1 = SLAPY2( CZ, C21 )
+ CZ = CZ / T1
+ SZR = -C21*TEMPR / T1
+ SZI = C21*TEMPI / T1
+ END IF
+ END IF
+*
+* Compute Givens rotation on left
+*
+* ( CQ SQ )
+* ( __ ) A or B
+* ( -SQ CQ )
+*
+ AN = ABS( A11 ) + ABS( A12 ) + ABS( A21 ) + ABS( A22 )
+ BN = ABS( B11 ) + ABS( B22 )
+ WABS = ABS( WR ) + ABS( WI )
+ IF( S1*AN.GT.WABS*BN ) THEN
+ CQ = CZ*B11
+ SQR = SZR*B22
+ SQI = -SZI*B22
+ ELSE
+ A1R = CZ*A11 + SZR*A12
+ A1I = SZI*A12
+ A2R = CZ*A21 + SZR*A22
+ A2I = SZI*A22
+ CQ = SLAPY2( A1R, A1I )
+ IF( CQ.LE.SAFMIN ) THEN
+ CQ = ZERO
+ SQR = ONE
+ SQI = ZERO
+ ELSE
+ TEMPR = A1R / CQ
+ TEMPI = A1I / CQ
+ SQR = TEMPR*A2R + TEMPI*A2I
+ SQI = TEMPI*A2R - TEMPR*A2I
+ END IF
+ END IF
+ T1 = SLAPY3( CQ, SQR, SQI )
+ CQ = CQ / T1
+ SQR = SQR / T1
+ SQI = SQI / T1
+*
+* Compute diagonal elements of QBZ
+*
+ TEMPR = SQR*SZR - SQI*SZI
+ TEMPI = SQR*SZI + SQI*SZR
+ B1R = CQ*CZ*B11 + TEMPR*B22
+ B1I = TEMPI*B22
+ B1A = SLAPY2( B1R, B1I )
+ B2R = CQ*CZ*B22 + TEMPR*B11
+ B2I = -TEMPI*B11
+ B2A = SLAPY2( B2R, B2I )
+*
+* Normalize so beta > 0, and Im( alpha1 ) > 0
+*
+ BETA( ILAST-1 ) = B1A
+ BETA( ILAST ) = B2A
+ ALPHAR( ILAST-1 ) = ( WR*B1A )*S1INV
+ ALPHAI( ILAST-1 ) = ( WI*B1A )*S1INV
+ ALPHAR( ILAST ) = ( WR*B2A )*S1INV
+ ALPHAI( ILAST ) = -( WI*B2A )*S1INV
+*
+* Step 3: Go to next block -- exit if finished.
+*
+ ILAST = IFIRST - 1
+ IF( ILAST.LT.ILO )
+ $ GO TO 380
+*
+* Reset counters
+*
+ IITER = 0
+ ESHIFT = ZERO
+ IF( .NOT.ILSCHR ) THEN
+ ILASTM = ILAST
+ IF( IFRSTM.GT.ILAST )
+ $ IFRSTM = ILO
+ END IF
+ GO TO 350
+ ELSE
+*
+* Usual case: 3x3 or larger block, using Francis implicit
+* double-shift
+*
+* 2
+* Eigenvalue equation is w - c w + d = 0,
+*
+* -1 2 -1
+* so compute 1st column of (A B ) - c A B + d
+* using the formula in QZIT (from EISPACK)
+*
+* We assume that the block is at least 3x3
+*
+ AD11 = ( ASCALE*H( ILAST-1, ILAST-1 ) ) /
+ $ ( BSCALE*T( ILAST-1, ILAST-1 ) )
+ AD21 = ( ASCALE*H( ILAST, ILAST-1 ) ) /
+ $ ( BSCALE*T( ILAST-1, ILAST-1 ) )
+ AD12 = ( ASCALE*H( ILAST-1, ILAST ) ) /
+ $ ( BSCALE*T( ILAST, ILAST ) )
+ AD22 = ( ASCALE*H( ILAST, ILAST ) ) /
+ $ ( BSCALE*T( ILAST, ILAST ) )
+ U12 = T( ILAST-1, ILAST ) / T( ILAST, ILAST )
+ AD11L = ( ASCALE*H( IFIRST, IFIRST ) ) /
+ $ ( BSCALE*T( IFIRST, IFIRST ) )
+ AD21L = ( ASCALE*H( IFIRST+1, IFIRST ) ) /
+ $ ( BSCALE*T( IFIRST, IFIRST ) )
+ AD12L = ( ASCALE*H( IFIRST, IFIRST+1 ) ) /
+ $ ( BSCALE*T( IFIRST+1, IFIRST+1 ) )
+ AD22L = ( ASCALE*H( IFIRST+1, IFIRST+1 ) ) /
+ $ ( BSCALE*T( IFIRST+1, IFIRST+1 ) )
+ AD32L = ( ASCALE*H( IFIRST+2, IFIRST+1 ) ) /
+ $ ( BSCALE*T( IFIRST+1, IFIRST+1 ) )
+ U12L = T( IFIRST, IFIRST+1 ) / T( IFIRST+1, IFIRST+1 )
+*
+ V( 1 ) = ( AD11-AD11L )*( AD22-AD11L ) - AD12*AD21 +
+ $ AD21*U12*AD11L + ( AD12L-AD11L*U12L )*AD21L
+ V( 2 ) = ( ( AD22L-AD11L )-AD21L*U12L-( AD11-AD11L )-
+ $ ( AD22-AD11L )+AD21*U12 )*AD21L
+ V( 3 ) = AD32L*AD21L
+*
+ ISTART = IFIRST
+*
+ CALL SLARFG( 3, V( 1 ), V( 2 ), 1, TAU )
+ V( 1 ) = ONE
+*
+* Sweep
+*
+ DO 290 J = ISTART, ILAST - 2
+*
+* All but last elements: use 3x3 Householder transforms.
+*
+* Zero (j-1)st column of A
+*
+ IF( J.GT.ISTART ) THEN
+ V( 1 ) = H( J, J-1 )
+ V( 2 ) = H( J+1, J-1 )
+ V( 3 ) = H( J+2, J-1 )
+*
+ CALL SLARFG( 3, H( J, J-1 ), V( 2 ), 1, TAU )
+ V( 1 ) = ONE
+ H( J+1, J-1 ) = ZERO
+ H( J+2, J-1 ) = ZERO
+ END IF
+*
+ DO 230 JC = J, ILASTM
+ TEMP = TAU*( H( J, JC )+V( 2 )*H( J+1, JC )+V( 3 )*
+ $ H( J+2, JC ) )
+ H( J, JC ) = H( J, JC ) - TEMP
+ H( J+1, JC ) = H( J+1, JC ) - TEMP*V( 2 )
+ H( J+2, JC ) = H( J+2, JC ) - TEMP*V( 3 )
+ TEMP2 = TAU*( T( J, JC )+V( 2 )*T( J+1, JC )+V( 3 )*
+ $ T( J+2, JC ) )
+ T( J, JC ) = T( J, JC ) - TEMP2
+ T( J+1, JC ) = T( J+1, JC ) - TEMP2*V( 2 )
+ T( J+2, JC ) = T( J+2, JC ) - TEMP2*V( 3 )
+ 230 CONTINUE
+ IF( ILQ ) THEN
+ DO 240 JR = 1, N
+ TEMP = TAU*( Q( JR, J )+V( 2 )*Q( JR, J+1 )+V( 3 )*
+ $ Q( JR, J+2 ) )
+ Q( JR, J ) = Q( JR, J ) - TEMP
+ Q( JR, J+1 ) = Q( JR, J+1 ) - TEMP*V( 2 )
+ Q( JR, J+2 ) = Q( JR, J+2 ) - TEMP*V( 3 )
+ 240 CONTINUE
+ END IF
+*
+* Zero j-th column of B (see SLAGBC for details)
+*
+* Swap rows to pivot
+*
+ ILPIVT = .FALSE.
+ TEMP = MAX( ABS( T( J+1, J+1 ) ), ABS( T( J+1, J+2 ) ) )
+ TEMP2 = MAX( ABS( T( J+2, J+1 ) ), ABS( T( J+2, J+2 ) ) )
+ IF( MAX( TEMP, TEMP2 ).LT.SAFMIN ) THEN
+ SCALE = ZERO
+ U1 = ONE
+ U2 = ZERO
+ GO TO 250
+ ELSE IF( TEMP.GE.TEMP2 ) THEN
+ W11 = T( J+1, J+1 )
+ W21 = T( J+2, J+1 )
+ W12 = T( J+1, J+2 )
+ W22 = T( J+2, J+2 )
+ U1 = T( J+1, J )
+ U2 = T( J+2, J )
+ ELSE
+ W21 = T( J+1, J+1 )
+ W11 = T( J+2, J+1 )
+ W22 = T( J+1, J+2 )
+ W12 = T( J+2, J+2 )
+ U2 = T( J+1, J )
+ U1 = T( J+2, J )
+ END IF
+*
+* Swap columns if nec.
+*
+ IF( ABS( W12 ).GT.ABS( W11 ) ) THEN
+ ILPIVT = .TRUE.
+ TEMP = W12
+ TEMP2 = W22
+ W12 = W11
+ W22 = W21
+ W11 = TEMP
+ W21 = TEMP2
+ END IF
+*
+* LU-factor
+*
+ TEMP = W21 / W11
+ U2 = U2 - TEMP*U1
+ W22 = W22 - TEMP*W12
+ W21 = ZERO
+*
+* Compute SCALE
+*
+ SCALE = ONE
+ IF( ABS( W22 ).LT.SAFMIN ) THEN
+ SCALE = ZERO
+ U2 = ONE
+ U1 = -W12 / W11
+ GO TO 250
+ END IF
+ IF( ABS( W22 ).LT.ABS( U2 ) )
+ $ SCALE = ABS( W22 / U2 )
+ IF( ABS( W11 ).LT.ABS( U1 ) )
+ $ SCALE = MIN( SCALE, ABS( W11 / U1 ) )
+*
+* Solve
+*
+ U2 = ( SCALE*U2 ) / W22
+ U1 = ( SCALE*U1-W12*U2 ) / W11
+*
+ 250 CONTINUE
+ IF( ILPIVT ) THEN
+ TEMP = U2
+ U2 = U1
+ U1 = TEMP
+ END IF
+*
+* Compute Householder Vector
+*
+ T1 = SQRT( SCALE**2+U1**2+U2**2 )
+ TAU = ONE + SCALE / T1
+ VS = -ONE / ( SCALE+T1 )
+ V( 1 ) = ONE
+ V( 2 ) = VS*U1
+ V( 3 ) = VS*U2
+*
+* Apply transformations from the right.
+*
+ DO 260 JR = IFRSTM, MIN( J+3, ILAST )
+ TEMP = TAU*( H( JR, J )+V( 2 )*H( JR, J+1 )+V( 3 )*
+ $ H( JR, J+2 ) )
+ H( JR, J ) = H( JR, J ) - TEMP
+ H( JR, J+1 ) = H( JR, J+1 ) - TEMP*V( 2 )
+ H( JR, J+2 ) = H( JR, J+2 ) - TEMP*V( 3 )
+ 260 CONTINUE
+ DO 270 JR = IFRSTM, J + 2
+ TEMP = TAU*( T( JR, J )+V( 2 )*T( JR, J+1 )+V( 3 )*
+ $ T( JR, J+2 ) )
+ T( JR, J ) = T( JR, J ) - TEMP
+ T( JR, J+1 ) = T( JR, J+1 ) - TEMP*V( 2 )
+ T( JR, J+2 ) = T( JR, J+2 ) - TEMP*V( 3 )
+ 270 CONTINUE
+ IF( ILZ ) THEN
+ DO 280 JR = 1, N
+ TEMP = TAU*( Z( JR, J )+V( 2 )*Z( JR, J+1 )+V( 3 )*
+ $ Z( JR, J+2 ) )
+ Z( JR, J ) = Z( JR, J ) - TEMP
+ Z( JR, J+1 ) = Z( JR, J+1 ) - TEMP*V( 2 )
+ Z( JR, J+2 ) = Z( JR, J+2 ) - TEMP*V( 3 )
+ 280 CONTINUE
+ END IF
+ T( J+1, J ) = ZERO
+ T( J+2, J ) = ZERO
+ 290 CONTINUE
+*
+* Last elements: Use Givens rotations
+*
+* Rotations from the left
+*
+ J = ILAST - 1
+ TEMP = H( J, J-1 )
+ CALL SLARTG( TEMP, H( J+1, J-1 ), C, S, H( J, J-1 ) )
+ H( J+1, J-1 ) = ZERO
+*
+ DO 300 JC = J, ILASTM
+ TEMP = C*H( J, JC ) + S*H( J+1, JC )
+ H( J+1, JC ) = -S*H( J, JC ) + C*H( J+1, JC )
+ H( J, JC ) = TEMP
+ TEMP2 = C*T( J, JC ) + S*T( J+1, JC )
+ T( J+1, JC ) = -S*T( J, JC ) + C*T( J+1, JC )
+ T( J, JC ) = TEMP2
+ 300 CONTINUE
+ IF( ILQ ) THEN
+ DO 310 JR = 1, N
+ TEMP = C*Q( JR, J ) + S*Q( JR, J+1 )
+ Q( JR, J+1 ) = -S*Q( JR, J ) + C*Q( JR, J+1 )
+ Q( JR, J ) = TEMP
+ 310 CONTINUE
+ END IF
+*
+* Rotations from the right.
+*
+ TEMP = T( J+1, J+1 )
+ CALL SLARTG( TEMP, T( J+1, J ), C, S, T( J+1, J+1 ) )
+ T( J+1, J ) = ZERO
+*
+ DO 320 JR = IFRSTM, ILAST
+ TEMP = C*H( JR, J+1 ) + S*H( JR, J )
+ H( JR, J ) = -S*H( JR, J+1 ) + C*H( JR, J )
+ H( JR, J+1 ) = TEMP
+ 320 CONTINUE
+ DO 330 JR = IFRSTM, ILAST - 1
+ TEMP = C*T( JR, J+1 ) + S*T( JR, J )
+ T( JR, J ) = -S*T( JR, J+1 ) + C*T( JR, J )
+ T( JR, J+1 ) = TEMP
+ 330 CONTINUE
+ IF( ILZ ) THEN
+ DO 340 JR = 1, N
+ TEMP = C*Z( JR, J+1 ) + S*Z( JR, J )
+ Z( JR, J ) = -S*Z( JR, J+1 ) + C*Z( JR, J )
+ Z( JR, J+1 ) = TEMP
+ 340 CONTINUE
+ END IF
+*
+* End of Double-Shift code
+*
+ END IF
+*
+ GO TO 350
+*
+* End of iteration loop
+*
+ 350 CONTINUE
+ 360 CONTINUE
+*
+* Drop-through = non-convergence
+*
+ INFO = ILAST
+ GO TO 420
+*
+* Successful completion of all QZ steps
+*
+ 380 CONTINUE
+*
+* Set Eigenvalues 1:ILO-1
+*
+ DO 410 J = 1, ILO - 1
+ IF( T( J, J ).LT.ZERO ) THEN
+ IF( ILSCHR ) THEN
+ DO 390 JR = 1, J
+ H( JR, J ) = -H( JR, J )
+ T( JR, J ) = -T( JR, J )
+ 390 CONTINUE
+ ELSE
+ H( J, J ) = -H( J, J )
+ T( J, J ) = -T( J, J )
+ END IF
+ IF( ILZ ) THEN
+ DO 400 JR = 1, N
+ Z( JR, J ) = -Z( JR, J )
+ 400 CONTINUE
+ END IF
+ END IF
+ ALPHAR( J ) = H( J, J )
+ ALPHAI( J ) = ZERO
+ BETA( J ) = T( J, J )
+ 410 CONTINUE
+*
+* Normal Termination
+*
+ INFO = 0
+*
+* Exit (other than argument error) -- return optimal workspace size
+*
+ 420 CONTINUE
+ WORK( 1 ) = REAL( N )
+ RETURN
+*
+* End of SHGEQZ
+*
+ END
+ SUBROUTINE SHSEIN( SIDE, EIGSRC, INITV, SELECT, N, H, LDH, WR, WI,
+ $ VL, LDVL, VR, LDVR, MM, M, WORK, IFAILL,
+ $ IFAILR, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER EIGSRC, INITV, SIDE
+ INTEGER INFO, LDH, LDVL, LDVR, M, MM, N
+* ..
+* .. Array Arguments ..
+ LOGICAL SELECT( * )
+ INTEGER IFAILL( * ), IFAILR( * )
+ REAL H( LDH, * ), VL( LDVL, * ), VR( LDVR, * ),
+ $ WI( * ), WORK( * ), WR( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SHSEIN uses inverse iteration to find specified right and/or left
+* eigenvectors of a real upper Hessenberg matrix H.
+*
+* The right eigenvector x and the left eigenvector y of the matrix H
+* corresponding to an eigenvalue w are defined by:
+*
+* H * x = w * x, y**h * H = w * y**h
+*
+* where y**h denotes the conjugate transpose of the vector y.
+*
+* Arguments
+* =========
+*
+* SIDE (input) CHARACTER*1
+* = 'R': compute right eigenvectors only;
+* = 'L': compute left eigenvectors only;
+* = 'B': compute both right and left eigenvectors.
+*
+* EIGSRC (input) CHARACTER*1
+* Specifies the source of eigenvalues supplied in (WR,WI):
+* = 'Q': the eigenvalues were found using SHSEQR; thus, if
+* H has zero subdiagonal elements, and so is
+* block-triangular, then the j-th eigenvalue can be
+* assumed to be an eigenvalue of the block containing
+* the j-th row/column. This property allows SHSEIN to
+* perform inverse iteration on just one diagonal block.
+* = 'N': no assumptions are made on the correspondence
+* between eigenvalues and diagonal blocks. In this
+* case, SHSEIN must always perform inverse iteration
+* using the whole matrix H.
+*
+* INITV (input) CHARACTER*1
+* = 'N': no initial vectors are supplied;
+* = 'U': user-supplied initial vectors are stored in the arrays
+* VL and/or VR.
+*
+* SELECT (input/output) LOGICAL array, dimension (N)
+* Specifies the eigenvectors to be computed. To select the
+* real eigenvector corresponding to a real eigenvalue WR(j),
+* SELECT(j) must be set to .TRUE.. To select the complex
+* eigenvector corresponding to a complex eigenvalue
+* (WR(j),WI(j)), with complex conjugate (WR(j+1),WI(j+1)),
+* either SELECT(j) or SELECT(j+1) or both must be set to
+* .TRUE.; then on exit SELECT(j) is .TRUE. and SELECT(j+1) is
+* .FALSE..
+*
+* N (input) INTEGER
+* The order of the matrix H. N >= 0.
+*
+* H (input) REAL array, dimension (LDH,N)
+* The upper Hessenberg matrix H.
+*
+* LDH (input) INTEGER
+* The leading dimension of the array H. LDH >= max(1,N).
+*
+* WR (input/output) REAL array, dimension (N)
+* WI (input) REAL array, dimension (N)
+* On entry, the real and imaginary parts of the eigenvalues of
+* H; a complex conjugate pair of eigenvalues must be stored in
+* consecutive elements of WR and WI.
+* On exit, WR may have been altered since close eigenvalues
+* are perturbed slightly in searching for independent
+* eigenvectors.
+*
+* VL (input/output) REAL array, dimension (LDVL,MM)
+* On entry, if INITV = 'U' and SIDE = 'L' or 'B', VL must
+* contain starting vectors for the inverse iteration for the
+* left eigenvectors; the starting vector for each eigenvector
+* must be in the same column(s) in which the eigenvector will
+* be stored.
+* On exit, if SIDE = 'L' or 'B', the left eigenvectors
+* specified by SELECT will be stored consecutively in the
+* columns of VL, in the same order as their eigenvalues. A
+* complex eigenvector corresponding to a complex eigenvalue is
+* stored in two consecutive columns, the first holding the real
+* part and the second the imaginary part.
+* If SIDE = 'R', VL is not referenced.
+*
+* LDVL (input) INTEGER
+* The leading dimension of the array VL.
+* LDVL >= max(1,N) if SIDE = 'L' or 'B'; LDVL >= 1 otherwise.
+*
+* VR (input/output) REAL array, dimension (LDVR,MM)
+* On entry, if INITV = 'U' and SIDE = 'R' or 'B', VR must
+* contain starting vectors for the inverse iteration for the
+* right eigenvectors; the starting vector for each eigenvector
+* must be in the same column(s) in which the eigenvector will
+* be stored.
+* On exit, if SIDE = 'R' or 'B', the right eigenvectors
+* specified by SELECT will be stored consecutively in the
+* columns of VR, in the same order as their eigenvalues. A
+* complex eigenvector corresponding to a complex eigenvalue is
+* stored in two consecutive columns, the first holding the real
+* part and the second the imaginary part.
+* If SIDE = 'L', VR is not referenced.
+*
+* LDVR (input) INTEGER
+* The leading dimension of the array VR.
+* LDVR >= max(1,N) if SIDE = 'R' or 'B'; LDVR >= 1 otherwise.
+*
+* MM (input) INTEGER
+* The number of columns in the arrays VL and/or VR. MM >= M.
+*
+* M (output) INTEGER
+* The number of columns in the arrays VL and/or VR required to
+* store the eigenvectors; each selected real eigenvector
+* occupies one column and each selected complex eigenvector
+* occupies two columns.
+*
+* WORK (workspace) REAL array, dimension ((N+2)*N)
+*
+* IFAILL (output) INTEGER array, dimension (MM)
+* If SIDE = 'L' or 'B', IFAILL(i) = j > 0 if the left
+* eigenvector in the i-th column of VL (corresponding to the
+* eigenvalue w(j)) failed to converge; IFAILL(i) = 0 if the
+* eigenvector converged satisfactorily. If the i-th and (i+1)th
+* columns of VL hold a complex eigenvector, then IFAILL(i) and
+* IFAILL(i+1) are set to the same value.
+* If SIDE = 'R', IFAILL is not referenced.
+*
+* IFAILR (output) INTEGER array, dimension (MM)
+* If SIDE = 'R' or 'B', IFAILR(i) = j > 0 if the right
+* eigenvector in the i-th column of VR (corresponding to the
+* eigenvalue w(j)) failed to converge; IFAILR(i) = 0 if the
+* eigenvector converged satisfactorily. If the i-th and (i+1)th
+* columns of VR hold a complex eigenvector, then IFAILR(i) and
+* IFAILR(i+1) are set to the same value.
+* If SIDE = 'L', IFAILR is not referenced.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* > 0: if INFO = i, i is the number of eigenvectors which
+* failed to converge; see IFAILL and IFAILR for further
+* details.
+*
+* Further Details
+* ===============
+*
+* Each eigenvector is normalized so that the element of largest
+* magnitude has magnitude 1; here the magnitude of a complex number
+* (x,y) is taken to be |x|+|y|.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO, ONE
+ PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL BOTHV, FROMQR, LEFTV, NOINIT, PAIR, RIGHTV
+ INTEGER I, IINFO, K, KL, KLN, KR, KSI, KSR, LDWORK
+ REAL BIGNUM, EPS3, HNORM, SMLNUM, ULP, UNFL, WKI,
+ $ WKR
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ REAL SLAMCH, SLANHS
+ EXTERNAL LSAME, SLAMCH, SLANHS
+* ..
+* .. External Subroutines ..
+ EXTERNAL SLAEIN, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX
+* ..
+* .. Executable Statements ..
+*
+* Decode and test the input parameters.
+*
+ BOTHV = LSAME( SIDE, 'B' )
+ RIGHTV = LSAME( SIDE, 'R' ) .OR. BOTHV
+ LEFTV = LSAME( SIDE, 'L' ) .OR. BOTHV
+*
+ FROMQR = LSAME( EIGSRC, 'Q' )
+*
+ NOINIT = LSAME( INITV, 'N' )
+*
+* Set M to the number of columns required to store the selected
+* eigenvectors, and standardize the array SELECT.
+*
+ M = 0
+ PAIR = .FALSE.
+ DO 10 K = 1, N
+ IF( PAIR ) THEN
+ PAIR = .FALSE.
+ SELECT( K ) = .FALSE.
+ ELSE
+ IF( WI( K ).EQ.ZERO ) THEN
+ IF( SELECT( K ) )
+ $ M = M + 1
+ ELSE
+ PAIR = .TRUE.
+ IF( SELECT( K ) .OR. SELECT( K+1 ) ) THEN
+ SELECT( K ) = .TRUE.
+ M = M + 2
+ END IF
+ END IF
+ END IF
+ 10 CONTINUE
+*
+ INFO = 0
+ IF( .NOT.RIGHTV .AND. .NOT.LEFTV ) THEN
+ INFO = -1
+ ELSE IF( .NOT.FROMQR .AND. .NOT.LSAME( EIGSRC, 'N' ) ) THEN
+ INFO = -2
+ ELSE IF( .NOT.NOINIT .AND. .NOT.LSAME( INITV, 'U' ) ) THEN
+ INFO = -3
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -5
+ ELSE IF( LDH.LT.MAX( 1, N ) ) THEN
+ INFO = -7
+ ELSE IF( LDVL.LT.1 .OR. ( LEFTV .AND. LDVL.LT.N ) ) THEN
+ INFO = -11
+ ELSE IF( LDVR.LT.1 .OR. ( RIGHTV .AND. LDVR.LT.N ) ) THEN
+ INFO = -13
+ ELSE IF( MM.LT.M ) THEN
+ INFO = -14
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SHSEIN', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible.
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+* Set machine-dependent constants.
+*
+ UNFL = SLAMCH( 'Safe minimum' )
+ ULP = SLAMCH( 'Precision' )
+ SMLNUM = UNFL*( N / ULP )
+ BIGNUM = ( ONE-ULP ) / SMLNUM
+*
+ LDWORK = N + 1
+*
+ KL = 1
+ KLN = 0
+ IF( FROMQR ) THEN
+ KR = 0
+ ELSE
+ KR = N
+ END IF
+ KSR = 1
+*
+ DO 120 K = 1, N
+ IF( SELECT( K ) ) THEN
+*
+* Compute eigenvector(s) corresponding to W(K).
+*
+ IF( FROMQR ) THEN
+*
+* If affiliation of eigenvalues is known, check whether
+* the matrix splits.
+*
+* Determine KL and KR such that 1 <= KL <= K <= KR <= N
+* and H(KL,KL-1) and H(KR+1,KR) are zero (or KL = 1 or
+* KR = N).
+*
+* Then inverse iteration can be performed with the
+* submatrix H(KL:N,KL:N) for a left eigenvector, and with
+* the submatrix H(1:KR,1:KR) for a right eigenvector.
+*
+ DO 20 I = K, KL + 1, -1
+ IF( H( I, I-1 ).EQ.ZERO )
+ $ GO TO 30
+ 20 CONTINUE
+ 30 CONTINUE
+ KL = I
+ IF( K.GT.KR ) THEN
+ DO 40 I = K, N - 1
+ IF( H( I+1, I ).EQ.ZERO )
+ $ GO TO 50
+ 40 CONTINUE
+ 50 CONTINUE
+ KR = I
+ END IF
+ END IF
+*
+ IF( KL.NE.KLN ) THEN
+ KLN = KL
+*
+* Compute infinity-norm of submatrix H(KL:KR,KL:KR) if it
+* has not ben computed before.
+*
+ HNORM = SLANHS( 'I', KR-KL+1, H( KL, KL ), LDH, WORK )
+ IF( HNORM.GT.ZERO ) THEN
+ EPS3 = HNORM*ULP
+ ELSE
+ EPS3 = SMLNUM
+ END IF
+ END IF
+*
+* Perturb eigenvalue if it is close to any previous
+* selected eigenvalues affiliated to the submatrix
+* H(KL:KR,KL:KR). Close roots are modified by EPS3.
+*
+ WKR = WR( K )
+ WKI = WI( K )
+ 60 CONTINUE
+ DO 70 I = K - 1, KL, -1
+ IF( SELECT( I ) .AND. ABS( WR( I )-WKR )+
+ $ ABS( WI( I )-WKI ).LT.EPS3 ) THEN
+ WKR = WKR + EPS3
+ GO TO 60
+ END IF
+ 70 CONTINUE
+ WR( K ) = WKR
+*
+ PAIR = WKI.NE.ZERO
+ IF( PAIR ) THEN
+ KSI = KSR + 1
+ ELSE
+ KSI = KSR
+ END IF
+ IF( LEFTV ) THEN
+*
+* Compute left eigenvector.
+*
+ CALL SLAEIN( .FALSE., NOINIT, N-KL+1, H( KL, KL ), LDH,
+ $ WKR, WKI, VL( KL, KSR ), VL( KL, KSI ),
+ $ WORK, LDWORK, WORK( N*N+N+1 ), EPS3, SMLNUM,
+ $ BIGNUM, IINFO )
+ IF( IINFO.GT.0 ) THEN
+ IF( PAIR ) THEN
+ INFO = INFO + 2
+ ELSE
+ INFO = INFO + 1
+ END IF
+ IFAILL( KSR ) = K
+ IFAILL( KSI ) = K
+ ELSE
+ IFAILL( KSR ) = 0
+ IFAILL( KSI ) = 0
+ END IF
+ DO 80 I = 1, KL - 1
+ VL( I, KSR ) = ZERO
+ 80 CONTINUE
+ IF( PAIR ) THEN
+ DO 90 I = 1, KL - 1
+ VL( I, KSI ) = ZERO
+ 90 CONTINUE
+ END IF
+ END IF
+ IF( RIGHTV ) THEN
+*
+* Compute right eigenvector.
+*
+ CALL SLAEIN( .TRUE., NOINIT, KR, H, LDH, WKR, WKI,
+ $ VR( 1, KSR ), VR( 1, KSI ), WORK, LDWORK,
+ $ WORK( N*N+N+1 ), EPS3, SMLNUM, BIGNUM,
+ $ IINFO )
+ IF( IINFO.GT.0 ) THEN
+ IF( PAIR ) THEN
+ INFO = INFO + 2
+ ELSE
+ INFO = INFO + 1
+ END IF
+ IFAILR( KSR ) = K
+ IFAILR( KSI ) = K
+ ELSE
+ IFAILR( KSR ) = 0
+ IFAILR( KSI ) = 0
+ END IF
+ DO 100 I = KR + 1, N
+ VR( I, KSR ) = ZERO
+ 100 CONTINUE
+ IF( PAIR ) THEN
+ DO 110 I = KR + 1, N
+ VR( I, KSI ) = ZERO
+ 110 CONTINUE
+ END IF
+ END IF
+*
+ IF( PAIR ) THEN
+ KSR = KSR + 2
+ ELSE
+ KSR = KSR + 1
+ END IF
+ END IF
+ 120 CONTINUE
+*
+ RETURN
+*
+* End of SHSEIN
+*
+ END
+ SUBROUTINE SHSEQR( JOB, COMPZ, N, ILO, IHI, H, LDH, WR, WI, Z,
+ $ LDZ, WORK, LWORK, INFO )
+*
+* -- LAPACK driver routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER IHI, ILO, INFO, LDH, LDZ, LWORK, N
+ CHARACTER COMPZ, JOB
+* ..
+* .. Array Arguments ..
+ REAL H( LDH, * ), WI( * ), WORK( * ), WR( * ),
+ $ Z( LDZ, * )
+* ..
+* Purpose
+* =======
+*
+* SHSEQR computes the eigenvalues of a Hessenberg matrix H
+* and, optionally, the matrices T and Z from the Schur decomposition
+* H = Z T Z**T, where T is an upper quasi-triangular matrix (the
+* Schur form), and Z is the orthogonal matrix of Schur vectors.
+*
+* Optionally Z may be postmultiplied into an input orthogonal
+* matrix Q so that this routine can give the Schur factorization
+* of a matrix A which has been reduced to the Hessenberg form H
+* by the orthogonal matrix Q: A = Q*H*Q**T = (QZ)*T*(QZ)**T.
+*
+* Arguments
+* =========
+*
+* JOB (input) CHARACTER*1
+* = 'E': compute eigenvalues only;
+* = 'S': compute eigenvalues and the Schur form T.
+*
+* COMPZ (input) CHARACTER*1
+* = 'N': no Schur vectors are computed;
+* = 'I': Z is initialized to the unit matrix and the matrix Z
+* of Schur vectors of H is returned;
+* = 'V': Z must contain an orthogonal matrix Q on entry, and
+* the product Q*Z is returned.
+*
+* N (input) INTEGER
+* The order of the matrix H. N .GE. 0.
+*
+* ILO (input) INTEGER
+* IHI (input) INTEGER
+* It is assumed that H is already upper triangular in rows
+* and columns 1:ILO-1 and IHI+1:N. ILO and IHI are normally
+* set by a previous call to SGEBAL, and then passed to SGEHRD
+* when the matrix output by SGEBAL is reduced to Hessenberg
+* form. Otherwise ILO and IHI should be set to 1 and N
+* respectively. If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N.
+* If N = 0, then ILO = 1 and IHI = 0.
+*
+* H (input/output) REAL array, dimension (LDH,N)
+* On entry, the upper Hessenberg matrix H.
+* On exit, if INFO = 0 and JOB = 'S', then H contains the
+* upper quasi-triangular matrix T from the Schur decomposition
+* (the Schur form); 2-by-2 diagonal blocks (corresponding to
+* complex conjugate pairs of eigenvalues) are returned in
+* standard form, with H(i,i) = H(i+1,i+1) and
+* H(i+1,i)*H(i,i+1).LT.0. If INFO = 0 and JOB = 'E', the
+* contents of H are unspecified on exit. (The output value of
+* H when INFO.GT.0 is given under the description of INFO
+* below.)
+*
+* Unlike earlier versions of SHSEQR, this subroutine may
+* explicitly H(i,j) = 0 for i.GT.j and j = 1, 2, ... ILO-1
+* or j = IHI+1, IHI+2, ... N.
+*
+* LDH (input) INTEGER
+* The leading dimension of the array H. LDH .GE. max(1,N).
+*
+* WR (output) REAL array, dimension (N)
+* WI (output) REAL array, dimension (N)
+* The real and imaginary parts, respectively, of the computed
+* eigenvalues. If two eigenvalues are computed as a complex
+* conjugate pair, they are stored in consecutive elements of
+* WR and WI, say the i-th and (i+1)th, with WI(i) .GT. 0 and
+* WI(i+1) .LT. 0. If JOB = 'S', the eigenvalues are stored in
+* the same order as on the diagonal of the Schur form returned
+* in H, with WR(i) = H(i,i) and, if H(i:i+1,i:i+1) is a 2-by-2
+* diagonal block, WI(i) = sqrt(-H(i+1,i)*H(i,i+1)) and
+* WI(i+1) = -WI(i).
+*
+* Z (input/output) REAL array, dimension (LDZ,N)
+* If COMPZ = 'N', Z is not referenced.
+* If COMPZ = 'I', on entry Z need not be set and on exit,
+* if INFO = 0, Z contains the orthogonal matrix Z of the Schur
+* vectors of H. If COMPZ = 'V', on entry Z must contain an
+* N-by-N matrix Q, which is assumed to be equal to the unit
+* matrix except for the submatrix Z(ILO:IHI,ILO:IHI). On exit,
+* if INFO = 0, Z contains Q*Z.
+* Normally Q is the orthogonal matrix generated by SORGHR
+* after the call to SGEHRD which formed the Hessenberg matrix
+* H. (The output value of Z when INFO.GT.0 is given under
+* the description of INFO below.)
+*
+* LDZ (input) INTEGER
+* The leading dimension of the array Z. if COMPZ = 'I' or
+* COMPZ = 'V', then LDZ.GE.MAX(1,N). Otherwize, LDZ.GE.1.
+*
+* WORK (workspace/output) REAL array, dimension (LWORK)
+* On exit, if INFO = 0, WORK(1) returns an estimate of
+* the optimal value for LWORK.
+*
+* LWORK (input) INTEGER
+* The dimension of the array WORK. LWORK .GE. max(1,N)
+* is sufficient, but LWORK typically as large as 6*N may
+* be required for optimal performance. A workspace query
+* to determine the optimal workspace size is recommended.
+*
+* If LWORK = -1, then SHSEQR does a workspace query.
+* In this case, SHSEQR checks the input parameters and
+* estimates the optimal workspace size for the given
+* values of N, ILO and IHI. The estimate is returned
+* in WORK(1). No error message related to LWORK is
+* issued by XERBLA. Neither H nor Z are accessed.
+*
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* .LT. 0: if INFO = -i, the i-th argument had an illegal
+* value
+* .GT. 0: if INFO = i, SHSEQR failed to compute all of
+* the eigenvalues. Elements 1:ilo-1 and i+1:n of WR
+* and WI contain those eigenvalues which have been
+* successfully computed. (Failures are rare.)
+*
+* If INFO .GT. 0 and JOB = 'E', then on exit, the
+* remaining unconverged eigenvalues are the eigen-
+* values of the upper Hessenberg matrix rows and
+* columns ILO through INFO of the final, output
+* value of H.
+*
+* If INFO .GT. 0 and JOB = 'S', then on exit
+*
+* (*) (initial value of H)*U = U*(final value of H)
+*
+* where U is an orthogonal matrix. The final
+* value of H is upper Hessenberg and quasi-triangular
+* in rows and columns INFO+1 through IHI.
+*
+* If INFO .GT. 0 and COMPZ = 'V', then on exit
+*
+* (final value of Z) = (initial value of Z)*U
+*
+* where U is the orthogonal matrix in (*) (regard-
+* less of the value of JOB.)
+*
+* If INFO .GT. 0 and COMPZ = 'I', then on exit
+* (final value of Z) = U
+* where U is the orthogonal matrix in (*) (regard-
+* less of the value of JOB.)
+*
+* If INFO .GT. 0 and COMPZ = 'N', then Z is not
+* accessed.
+*
+* ================================================================
+* Default values supplied by
+* ILAENV(ISPEC,'SHSEQR',JOB(:1)//COMPZ(:1),N,ILO,IHI,LWORK).
+* It is suggested that these defaults be adjusted in order
+* to attain best performance in each particular
+* computational environment.
+*
+* ISPEC=1: The SLAHQR vs SLAQR0 crossover point.
+* Default: 75. (Must be at least 11.)
+*
+* ISPEC=2: Recommended deflation window size.
+* This depends on ILO, IHI and NS. NS is the
+* number of simultaneous shifts returned
+* by ILAENV(ISPEC=4). (See ISPEC=4 below.)
+* The default for (IHI-ILO+1).LE.500 is NS.
+* The default for (IHI-ILO+1).GT.500 is 3*NS/2.
+*
+* ISPEC=3: Nibble crossover point. (See ILAENV for
+* details.) Default: 14% of deflation window
+* size.
+*
+* ISPEC=4: Number of simultaneous shifts, NS, in
+* a multi-shift QR iteration.
+*
+* If IHI-ILO+1 is ...
+*
+* greater than ...but less ... the
+* or equal to ... than default is
+*
+* 1 30 NS - 2(+)
+* 30 60 NS - 4(+)
+* 60 150 NS = 10(+)
+* 150 590 NS = **
+* 590 3000 NS = 64
+* 3000 6000 NS = 128
+* 6000 infinity NS = 256
+*
+* (+) By default some or all matrices of this order
+* are passed to the implicit double shift routine
+* SLAHQR and NS is ignored. See ISPEC=1 above
+* and comments in IPARM for details.
+*
+* The asterisks (**) indicate an ad-hoc
+* function of N increasing from 10 to 64.
+*
+* ISPEC=5: Select structured matrix multiply.
+* (See ILAENV for details.) Default: 3.
+*
+* ================================================================
+* Based on contributions by
+* Karen Braman and Ralph Byers, Department of Mathematics,
+* University of Kansas, USA
+*
+* ================================================================
+* References:
+* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR
+* Algorithm Part I: Maintaining Well Focused Shifts, and Level 3
+* Performance, SIAM Journal of Matrix Analysis, volume 23, pages
+* 929--947, 2002.
+*
+* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR
+* Algorithm Part II: Aggressive Early Deflation, SIAM Journal
+* of Matrix Analysis, volume 23, pages 948--973, 2002.
+*
+* ================================================================
+* .. Parameters ..
+*
+* ==== Matrices of order NTINY or smaller must be processed by
+* . SLAHQR because of insufficient subdiagonal scratch space.
+* . (This is a hard limit.) ====
+*
+* ==== NL allocates some local workspace to help small matrices
+* . through a rare SLAHQR failure. NL .GT. NTINY = 11 is
+* . required and NL .LE. NMIN = ILAENV(ISPEC=1,...) is recom-
+* . mended. (The default value of NMIN is 75.) Using NL = 49
+* . allows up to six simultaneous shifts and a 16-by-16
+* . deflation window. ====
+*
+ INTEGER NTINY
+ PARAMETER ( NTINY = 11 )
+ INTEGER NL
+ PARAMETER ( NL = 49 )
+ REAL ZERO, ONE
+ PARAMETER ( ZERO = 0.0e0, ONE = 1.0e0 )
+* ..
+* .. Local Arrays ..
+ REAL HL( NL, NL ), WORKL( NL )
+* ..
+* .. Local Scalars ..
+ INTEGER I, KBOT, NMIN
+ LOGICAL INITZ, LQUERY, WANTT, WANTZ
+* ..
+* .. External Functions ..
+ INTEGER ILAENV
+ LOGICAL LSAME
+ EXTERNAL ILAENV, LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL SLACPY, SLAHQR, SLAQR0, SLASET, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN, REAL
+* ..
+* .. Executable Statements ..
+*
+* ==== Decode and check the input parameters. ====
+*
+ WANTT = LSAME( JOB, 'S' )
+ INITZ = LSAME( COMPZ, 'I' )
+ WANTZ = INITZ .OR. LSAME( COMPZ, 'V' )
+ WORK( 1 ) = REAL( MAX( 1, N ) )
+ LQUERY = LWORK.EQ.-1
+*
+ INFO = 0
+ IF( .NOT.LSAME( JOB, 'E' ) .AND. .NOT.WANTT ) THEN
+ INFO = -1
+ ELSE IF( .NOT.LSAME( COMPZ, 'N' ) .AND. .NOT.WANTZ ) THEN
+ INFO = -2
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN
+ INFO = -4
+ ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN
+ INFO = -5
+ ELSE IF( LDH.LT.MAX( 1, N ) ) THEN
+ INFO = -7
+ ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.MAX( 1, N ) ) ) THEN
+ INFO = -11
+ ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN
+ INFO = -13
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+*
+* ==== Quick return in case of invalid argument. ====
+*
+ CALL XERBLA( 'SHSEQR', -INFO )
+ RETURN
+*
+ ELSE IF( N.EQ.0 ) THEN
+*
+* ==== Quick return in case N = 0; nothing to do. ====
+*
+ RETURN
+*
+ ELSE IF( LQUERY ) THEN
+*
+* ==== Quick return in case of a workspace query ====
+*
+ CALL SLAQR0( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, ILO,
+ $ IHI, Z, LDZ, WORK, LWORK, INFO )
+* ==== Ensure reported workspace size is backward-compatible with
+* . previous LAPACK versions. ====
+ WORK( 1 ) = MAX( REAL( MAX( 1, N ) ), WORK( 1 ) )
+ RETURN
+*
+ ELSE
+*
+* ==== copy eigenvalues isolated by SGEBAL ====
+*
+ DO 10 I = 1, ILO - 1
+ WR( I ) = H( I, I )
+ WI( I ) = ZERO
+ 10 CONTINUE
+ DO 20 I = IHI + 1, N
+ WR( I ) = H( I, I )
+ WI( I ) = ZERO
+ 20 CONTINUE
+*
+* ==== Initialize Z, if requested ====
+*
+ IF( INITZ )
+ $ CALL SLASET( 'A', N, N, ZERO, ONE, Z, LDZ )
+*
+* ==== Quick return if possible ====
+*
+ IF( ILO.EQ.IHI ) THEN
+ WR( ILO ) = H( ILO, ILO )
+ WI( ILO ) = ZERO
+ RETURN
+ END IF
+*
+* ==== SLAHQR/SLAQR0 crossover point ====
+*
+ NMIN = ILAENV( 1, 'SHSEQR', JOB( : 1 ) // COMPZ( : 1 ), N, ILO,
+ $ IHI, LWORK )
+ NMIN = MAX( NTINY, NMIN )
+*
+* ==== SLAQR0 for big matrices; SLAHQR for small ones ====
+*
+ IF( N.GT.NMIN ) THEN
+ CALL SLAQR0( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, ILO,
+ $ IHI, Z, LDZ, WORK, LWORK, INFO )
+ ELSE
+*
+* ==== Small matrix ====
+*
+ CALL SLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI, ILO,
+ $ IHI, Z, LDZ, INFO )
+*
+ IF( INFO.GT.0 ) THEN
+*
+* ==== A rare SLAHQR failure! SLAQR0 sometimes succeeds
+* . when SLAHQR fails. ====
+*
+ KBOT = INFO
+*
+ IF( N.GE.NL ) THEN
+*
+* ==== Larger matrices have enough subdiagonal scratch
+* . space to call SLAQR0 directly. ====
+*
+ CALL SLAQR0( WANTT, WANTZ, N, ILO, KBOT, H, LDH, WR,
+ $ WI, ILO, IHI, Z, LDZ, WORK, LWORK, INFO )
+*
+ ELSE
+*
+* ==== Tiny matrices don't have enough subdiagonal
+* . scratch space to benefit from SLAQR0. Hence,
+* . tiny matrices must be copied into a larger
+* . array before calling SLAQR0. ====
+*
+ CALL SLACPY( 'A', N, N, H, LDH, HL, NL )
+ HL( N+1, N ) = ZERO
+ CALL SLASET( 'A', NL, NL-N, ZERO, ZERO, HL( 1, N+1 ),
+ $ NL )
+ CALL SLAQR0( WANTT, WANTZ, NL, ILO, KBOT, HL, NL, WR,
+ $ WI, ILO, IHI, Z, LDZ, WORKL, NL, INFO )
+ IF( WANTT .OR. INFO.NE.0 )
+ $ CALL SLACPY( 'A', N, N, HL, NL, H, LDH )
+ END IF
+ END IF
+ END IF
+*
+* ==== Clear out the trash, if necessary. ====
+*
+ IF( ( WANTT .OR. INFO.NE.0 ) .AND. N.GT.2 )
+ $ CALL SLASET( 'L', N-2, N-2, ZERO, ZERO, H( 3, 1 ), LDH )
+*
+* ==== Ensure reported workspace size is backward-compatible with
+* . previous LAPACK versions. ====
+*
+ WORK( 1 ) = MAX( REAL( MAX( 1, N ) ), WORK( 1 ) )
+ END IF
+*
+* ==== End of SHSEQR ====
+*
+ END
+ LOGICAL FUNCTION SISNAN(SIN)
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ REAL SIN
+* ..
+*
+* Purpose
+* =======
+*
+* SISNAN returns .TRUE. if its argument is NaN, and .FALSE.
+* otherwise. To be replaced by the Fortran 2003 intrinsic in the
+* future.
+*
+* Arguments
+* =========
+*
+* SIN (input) REAL
+* Input to test for NaN.
+*
+* =====================================================================
+*
+* .. External Functions ..
+ LOGICAL SLAISNAN
+ EXTERNAL SLAISNAN
+* ..
+* .. Executable Statements ..
+ SISNAN = SLAISNAN(SIN,SIN)
+ RETURN
+ END
+ SUBROUTINE SLABAD( SMALL, LARGE )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ REAL LARGE, SMALL
+* ..
+*
+* Purpose
+* =======
+*
+* SLABAD takes as input the values computed by SLAMCH for underflow and
+* overflow, and returns the square root of each of these values if the
+* log of LARGE is sufficiently large. This subroutine is intended to
+* identify machines with a large exponent range, such as the Crays, and
+* redefine the underflow and overflow limits to be the square roots of
+* the values computed by SLAMCH. This subroutine is needed because
+* SLAMCH does not compensate for poor arithmetic in the upper half of
+* the exponent range, as is found on a Cray.
+*
+* Arguments
+* =========
+*
+* SMALL (input/output) REAL
+* On entry, the underflow threshold as computed by SLAMCH.
+* On exit, if LOG10(LARGE) is sufficiently large, the square
+* root of SMALL, otherwise unchanged.
+*
+* LARGE (input/output) REAL
+* On entry, the overflow threshold as computed by SLAMCH.
+* On exit, if LOG10(LARGE) is sufficiently large, the square
+* root of LARGE, otherwise unchanged.
+*
+* =====================================================================
+*
+* .. Intrinsic Functions ..
+ INTRINSIC LOG10, SQRT
+* ..
+* .. Executable Statements ..
+*
+* If it looks like we're on a Cray, take the square root of
+* SMALL and LARGE to avoid overflow and underflow problems.
+*
+ IF( LOG10( LARGE ).GT.2000. ) THEN
+ SMALL = SQRT( SMALL )
+ LARGE = SQRT( LARGE )
+ END IF
+*
+ RETURN
+*
+* End of SLABAD
+*
+ END
+ SUBROUTINE SLABRD( M, N, NB, A, LDA, D, E, TAUQ, TAUP, X, LDX, Y,
+ $ LDY )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER LDA, LDX, LDY, M, N, NB
+* ..
+* .. Array Arguments ..
+ REAL A( LDA, * ), D( * ), E( * ), TAUP( * ),
+ $ TAUQ( * ), X( LDX, * ), Y( LDY, * )
+* ..
+*
+* Purpose
+* =======
+*
+* SLABRD reduces the first NB rows and columns of a real general
+* m by n matrix A to upper or lower bidiagonal form by an orthogonal
+* transformation Q' * A * P, and returns the matrices X and Y which
+* are needed to apply the transformation to the unreduced part of A.
+*
+* If m >= n, A is reduced to upper bidiagonal form; if m < n, to lower
+* bidiagonal form.
+*
+* This is an auxiliary routine called by SGEBRD
+*
+* Arguments
+* =========
+*
+* M (input) INTEGER
+* The number of rows in the matrix A.
+*
+* N (input) INTEGER
+* The number of columns in the matrix A.
+*
+* NB (input) INTEGER
+* The number of leading rows and columns of A to be reduced.
+*
+* A (input/output) REAL array, dimension (LDA,N)
+* On entry, the m by n general matrix to be reduced.
+* On exit, the first NB rows and columns of the matrix are
+* overwritten; the rest of the array is unchanged.
+* If m >= n, elements on and below the diagonal in the first NB
+* columns, with the array TAUQ, represent the orthogonal
+* matrix Q as a product of elementary reflectors; and
+* elements above the diagonal in the first NB rows, with the
+* array TAUP, represent the orthogonal matrix P as a product
+* of elementary reflectors.
+* If m < n, elements below the diagonal in the first NB
+* columns, with the array TAUQ, represent the orthogonal
+* matrix Q as a product of elementary reflectors, and
+* elements on and above the diagonal in the first NB rows,
+* with the array TAUP, represent the orthogonal matrix P as
+* a product of elementary reflectors.
+* See Further Details.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,M).
+*
+* D (output) REAL array, dimension (NB)
+* The diagonal elements of the first NB rows and columns of
+* the reduced matrix. D(i) = A(i,i).
+*
+* E (output) REAL array, dimension (NB)
+* The off-diagonal elements of the first NB rows and columns of
+* the reduced matrix.
+*
+* TAUQ (output) REAL array dimension (NB)
+* The scalar factors of the elementary reflectors which
+* represent the orthogonal matrix Q. See Further Details.
+*
+* TAUP (output) REAL array, dimension (NB)
+* The scalar factors of the elementary reflectors which
+* represent the orthogonal matrix P. See Further Details.
+*
+* X (output) REAL array, dimension (LDX,NB)
+* The m-by-nb matrix X required to update the unreduced part
+* of A.
+*
+* LDX (input) INTEGER
+* The leading dimension of the array X. LDX >= M.
+*
+* Y (output) REAL array, dimension (LDY,NB)
+* The n-by-nb matrix Y required to update the unreduced part
+* of A.
+*
+* LDY (input) INTEGER
+* The leading dimension of the array Y. LDY >= N.
+*
+* Further Details
+* ===============
+*
+* The matrices Q and P are represented as products of elementary
+* reflectors:
+*
+* Q = H(1) H(2) . . . H(nb) and P = G(1) G(2) . . . G(nb)
+*
+* Each H(i) and G(i) has the form:
+*
+* H(i) = I - tauq * v * v' and G(i) = I - taup * u * u'
+*
+* where tauq and taup are real scalars, and v and u are real vectors.
+*
+* If m >= n, v(1:i-1) = 0, v(i) = 1, and v(i:m) is stored on exit in
+* A(i:m,i); u(1:i) = 0, u(i+1) = 1, and u(i+1:n) is stored on exit in
+* A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i).
+*
+* If m < n, v(1:i) = 0, v(i+1) = 1, and v(i+1:m) is stored on exit in
+* A(i+2:m,i); u(1:i-1) = 0, u(i) = 1, and u(i:n) is stored on exit in
+* A(i,i+1:n); tauq is stored in TAUQ(i) and taup in TAUP(i).
+*
+* The elements of the vectors v and u together form the m-by-nb matrix
+* V and the nb-by-n matrix U' which are needed, with X and Y, to apply
+* the transformation to the unreduced part of the matrix, using a block
+* update of the form: A := A - V*Y' - X*U'.
+*
+* The contents of A on exit are illustrated by the following examples
+* with nb = 2:
+*
+* m = 6 and n = 5 (m > n): m = 5 and n = 6 (m < n):
+*
+* ( 1 1 u1 u1 u1 ) ( 1 u1 u1 u1 u1 u1 )
+* ( v1 1 1 u2 u2 ) ( 1 1 u2 u2 u2 u2 )
+* ( v1 v2 a a a ) ( v1 1 a a a a )
+* ( v1 v2 a a a ) ( v1 v2 a a a a )
+* ( v1 v2 a a a ) ( v1 v2 a a a a )
+* ( v1 v2 a a a )
+*
+* where a denotes an element of the original matrix which is unchanged,
+* vi denotes an element of the vector defining H(i), and ui an element
+* of the vector defining G(i).
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO, ONE
+ PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I
+* ..
+* .. External Subroutines ..
+ EXTERNAL SGEMV, SLARFG, SSCAL
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MIN
+* ..
+* .. Executable Statements ..
+*
+* Quick return if possible
+*
+ IF( M.LE.0 .OR. N.LE.0 )
+ $ RETURN
+*
+ IF( M.GE.N ) THEN
+*
+* Reduce to upper bidiagonal form
+*
+ DO 10 I = 1, NB
+*
+* Update A(i:m,i)
+*
+ CALL SGEMV( 'No transpose', M-I+1, I-1, -ONE, A( I, 1 ),
+ $ LDA, Y( I, 1 ), LDY, ONE, A( I, I ), 1 )
+ CALL SGEMV( 'No transpose', M-I+1, I-1, -ONE, X( I, 1 ),
+ $ LDX, A( 1, I ), 1, ONE, A( I, I ), 1 )
+*
+* Generate reflection Q(i) to annihilate A(i+1:m,i)
+*
+ CALL SLARFG( M-I+1, A( I, I ), A( MIN( I+1, M ), I ), 1,
+ $ TAUQ( I ) )
+ D( I ) = A( I, I )
+ IF( I.LT.N ) THEN
+ A( I, I ) = ONE
+*
+* Compute Y(i+1:n,i)
+*
+ CALL SGEMV( 'Transpose', M-I+1, N-I, ONE, A( I, I+1 ),
+ $ LDA, A( I, I ), 1, ZERO, Y( I+1, I ), 1 )
+ CALL SGEMV( 'Transpose', M-I+1, I-1, ONE, A( I, 1 ), LDA,
+ $ A( I, I ), 1, ZERO, Y( 1, I ), 1 )
+ CALL SGEMV( 'No transpose', N-I, I-1, -ONE, Y( I+1, 1 ),
+ $ LDY, Y( 1, I ), 1, ONE, Y( I+1, I ), 1 )
+ CALL SGEMV( 'Transpose', M-I+1, I-1, ONE, X( I, 1 ), LDX,
+ $ A( I, I ), 1, ZERO, Y( 1, I ), 1 )
+ CALL SGEMV( 'Transpose', I-1, N-I, -ONE, A( 1, I+1 ),
+ $ LDA, Y( 1, I ), 1, ONE, Y( I+1, I ), 1 )
+ CALL SSCAL( N-I, TAUQ( I ), Y( I+1, I ), 1 )
+*
+* Update A(i,i+1:n)
+*
+ CALL SGEMV( 'No transpose', N-I, I, -ONE, Y( I+1, 1 ),
+ $ LDY, A( I, 1 ), LDA, ONE, A( I, I+1 ), LDA )
+ CALL SGEMV( 'Transpose', I-1, N-I, -ONE, A( 1, I+1 ),
+ $ LDA, X( I, 1 ), LDX, ONE, A( I, I+1 ), LDA )
+*
+* Generate reflection P(i) to annihilate A(i,i+2:n)
+*
+ CALL SLARFG( N-I, A( I, I+1 ), A( I, MIN( I+2, N ) ),
+ $ LDA, TAUP( I ) )
+ E( I ) = A( I, I+1 )
+ A( I, I+1 ) = ONE
+*
+* Compute X(i+1:m,i)
+*
+ CALL SGEMV( 'No transpose', M-I, N-I, ONE, A( I+1, I+1 ),
+ $ LDA, A( I, I+1 ), LDA, ZERO, X( I+1, I ), 1 )
+ CALL SGEMV( 'Transpose', N-I, I, ONE, Y( I+1, 1 ), LDY,
+ $ A( I, I+1 ), LDA, ZERO, X( 1, I ), 1 )
+ CALL SGEMV( 'No transpose', M-I, I, -ONE, A( I+1, 1 ),
+ $ LDA, X( 1, I ), 1, ONE, X( I+1, I ), 1 )
+ CALL SGEMV( 'No transpose', I-1, N-I, ONE, A( 1, I+1 ),
+ $ LDA, A( I, I+1 ), LDA, ZERO, X( 1, I ), 1 )
+ CALL SGEMV( 'No transpose', M-I, I-1, -ONE, X( I+1, 1 ),
+ $ LDX, X( 1, I ), 1, ONE, X( I+1, I ), 1 )
+ CALL SSCAL( M-I, TAUP( I ), X( I+1, I ), 1 )
+ END IF
+ 10 CONTINUE
+ ELSE
+*
+* Reduce to lower bidiagonal form
+*
+ DO 20 I = 1, NB
+*
+* Update A(i,i:n)
+*
+ CALL SGEMV( 'No transpose', N-I+1, I-1, -ONE, Y( I, 1 ),
+ $ LDY, A( I, 1 ), LDA, ONE, A( I, I ), LDA )
+ CALL SGEMV( 'Transpose', I-1, N-I+1, -ONE, A( 1, I ), LDA,
+ $ X( I, 1 ), LDX, ONE, A( I, I ), LDA )
+*
+* Generate reflection P(i) to annihilate A(i,i+1:n)
+*
+ CALL SLARFG( N-I+1, A( I, I ), A( I, MIN( I+1, N ) ), LDA,
+ $ TAUP( I ) )
+ D( I ) = A( I, I )
+ IF( I.LT.M ) THEN
+ A( I, I ) = ONE
+*
+* Compute X(i+1:m,i)
+*
+ CALL SGEMV( 'No transpose', M-I, N-I+1, ONE, A( I+1, I ),
+ $ LDA, A( I, I ), LDA, ZERO, X( I+1, I ), 1 )
+ CALL SGEMV( 'Transpose', N-I+1, I-1, ONE, Y( I, 1 ), LDY,
+ $ A( I, I ), LDA, ZERO, X( 1, I ), 1 )
+ CALL SGEMV( 'No transpose', M-I, I-1, -ONE, A( I+1, 1 ),
+ $ LDA, X( 1, I ), 1, ONE, X( I+1, I ), 1 )
+ CALL SGEMV( 'No transpose', I-1, N-I+1, ONE, A( 1, I ),
+ $ LDA, A( I, I ), LDA, ZERO, X( 1, I ), 1 )
+ CALL SGEMV( 'No transpose', M-I, I-1, -ONE, X( I+1, 1 ),
+ $ LDX, X( 1, I ), 1, ONE, X( I+1, I ), 1 )
+ CALL SSCAL( M-I, TAUP( I ), X( I+1, I ), 1 )
+*
+* Update A(i+1:m,i)
+*
+ CALL SGEMV( 'No transpose', M-I, I-1, -ONE, A( I+1, 1 ),
+ $ LDA, Y( I, 1 ), LDY, ONE, A( I+1, I ), 1 )
+ CALL SGEMV( 'No transpose', M-I, I, -ONE, X( I+1, 1 ),
+ $ LDX, A( 1, I ), 1, ONE, A( I+1, I ), 1 )
+*
+* Generate reflection Q(i) to annihilate A(i+2:m,i)
+*
+ CALL SLARFG( M-I, A( I+1, I ), A( MIN( I+2, M ), I ), 1,
+ $ TAUQ( I ) )
+ E( I ) = A( I+1, I )
+ A( I+1, I ) = ONE
+*
+* Compute Y(i+1:n,i)
+*
+ CALL SGEMV( 'Transpose', M-I, N-I, ONE, A( I+1, I+1 ),
+ $ LDA, A( I+1, I ), 1, ZERO, Y( I+1, I ), 1 )
+ CALL SGEMV( 'Transpose', M-I, I-1, ONE, A( I+1, 1 ), LDA,
+ $ A( I+1, I ), 1, ZERO, Y( 1, I ), 1 )
+ CALL SGEMV( 'No transpose', N-I, I-1, -ONE, Y( I+1, 1 ),
+ $ LDY, Y( 1, I ), 1, ONE, Y( I+1, I ), 1 )
+ CALL SGEMV( 'Transpose', M-I, I, ONE, X( I+1, 1 ), LDX,
+ $ A( I+1, I ), 1, ZERO, Y( 1, I ), 1 )
+ CALL SGEMV( 'Transpose', I, N-I, -ONE, A( 1, I+1 ), LDA,
+ $ Y( 1, I ), 1, ONE, Y( I+1, I ), 1 )
+ CALL SSCAL( N-I, TAUQ( I ), Y( I+1, I ), 1 )
+ END IF
+ 20 CONTINUE
+ END IF
+ RETURN
+*
+* End of SLABRD
+*
+ END
+ SUBROUTINE SLACN2( N, V, X, ISGN, EST, KASE, ISAVE )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER KASE, N
+ REAL EST
+* ..
+* .. Array Arguments ..
+ INTEGER ISGN( * ), ISAVE( 3 )
+ REAL V( * ), X( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SLACN2 estimates the 1-norm of a square, real matrix A.
+* Reverse communication is used for evaluating matrix-vector products.
+*
+* Arguments
+* =========
+*
+* N (input) INTEGER
+* The order of the matrix. N >= 1.
+*
+* V (workspace) REAL array, dimension (N)
+* On the final return, V = A*W, where EST = norm(V)/norm(W)
+* (W is not returned).
+*
+* X (input/output) REAL array, dimension (N)
+* On an intermediate return, X should be overwritten by
+* A * X, if KASE=1,
+* A' * X, if KASE=2,
+* and SLACN2 must be re-called with all the other parameters
+* unchanged.
+*
+* ISGN (workspace) INTEGER array, dimension (N)
+*
+* EST (input/output) REAL
+* On entry with KASE = 1 or 2 and ISAVE(1) = 3, EST should be
+* unchanged from the previous call to SLACN2.
+* On exit, EST is an estimate (a lower bound) for norm(A).
+*
+* KASE (input/output) INTEGER
+* On the initial call to SLACN2, KASE should be 0.
+* On an intermediate return, KASE will be 1 or 2, indicating
+* whether X should be overwritten by A * X or A' * X.
+* On the final return from SLACN2, KASE will again be 0.
+*
+* ISAVE (input/output) INTEGER array, dimension (3)
+* ISAVE is used to save variables between calls to SLACN2
+*
+* Further Details
+* ======= =======
+*
+* Contributed by Nick Higham, University of Manchester.
+* Originally named SONEST, dated March 16, 1988.
+*
+* Reference: N.J. Higham, "FORTRAN codes for estimating the one-norm of
+* a real or complex matrix, with applications to condition estimation",
+* ACM Trans. Math. Soft., vol. 14, no. 4, pp. 381-396, December 1988.
+*
+* This is a thread safe version of SLACON, which uses the array ISAVE
+* in place of a SAVE statement, as follows:
+*
+* SLACON SLACN2
+* JUMP ISAVE(1)
+* J ISAVE(2)
+* ITER ISAVE(3)
+*
+* =====================================================================
+*
+* .. Parameters ..
+ INTEGER ITMAX
+ PARAMETER ( ITMAX = 5 )
+ REAL ZERO, ONE, TWO
+ PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0, TWO = 2.0E+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, JLAST
+ REAL ALTSGN, ESTOLD, TEMP
+* ..
+* .. External Functions ..
+ INTEGER ISAMAX
+ REAL SASUM
+ EXTERNAL ISAMAX, SASUM
+* ..
+* .. External Subroutines ..
+ EXTERNAL SCOPY
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, NINT, REAL, SIGN
+* ..
+* .. Executable Statements ..
+*
+ IF( KASE.EQ.0 ) THEN
+ DO 10 I = 1, N
+ X( I ) = ONE / REAL( N )
+ 10 CONTINUE
+ KASE = 1
+ ISAVE( 1 ) = 1
+ RETURN
+ END IF
+*
+ GO TO ( 20, 40, 70, 110, 140 )ISAVE( 1 )
+*
+* ................ ENTRY (ISAVE( 1 ) = 1)
+* FIRST ITERATION. X HAS BEEN OVERWRITTEN BY A*X.
+*
+ 20 CONTINUE
+ IF( N.EQ.1 ) THEN
+ V( 1 ) = X( 1 )
+ EST = ABS( V( 1 ) )
+* ... QUIT
+ GO TO 150
+ END IF
+ EST = SASUM( N, X, 1 )
+*
+ DO 30 I = 1, N
+ X( I ) = SIGN( ONE, X( I ) )
+ ISGN( I ) = NINT( X( I ) )
+ 30 CONTINUE
+ KASE = 2
+ ISAVE( 1 ) = 2
+ RETURN
+*
+* ................ ENTRY (ISAVE( 1 ) = 2)
+* FIRST ITERATION. X HAS BEEN OVERWRITTEN BY TRANSPOSE(A)*X.
+*
+ 40 CONTINUE
+ ISAVE( 2 ) = ISAMAX( N, X, 1 )
+ ISAVE( 3 ) = 2
+*
+* MAIN LOOP - ITERATIONS 2,3,...,ITMAX.
+*
+ 50 CONTINUE
+ DO 60 I = 1, N
+ X( I ) = ZERO
+ 60 CONTINUE
+ X( ISAVE( 2 ) ) = ONE
+ KASE = 1
+ ISAVE( 1 ) = 3
+ RETURN
+*
+* ................ ENTRY (ISAVE( 1 ) = 3)
+* X HAS BEEN OVERWRITTEN BY A*X.
+*
+ 70 CONTINUE
+ CALL SCOPY( N, X, 1, V, 1 )
+ ESTOLD = EST
+ EST = SASUM( N, V, 1 )
+ DO 80 I = 1, N
+ IF( NINT( SIGN( ONE, X( I ) ) ).NE.ISGN( I ) )
+ $ GO TO 90
+ 80 CONTINUE
+* REPEATED SIGN VECTOR DETECTED, HENCE ALGORITHM HAS CONVERGED.
+ GO TO 120
+*
+ 90 CONTINUE
+* TEST FOR CYCLING.
+ IF( EST.LE.ESTOLD )
+ $ GO TO 120
+*
+ DO 100 I = 1, N
+ X( I ) = SIGN( ONE, X( I ) )
+ ISGN( I ) = NINT( X( I ) )
+ 100 CONTINUE
+ KASE = 2
+ ISAVE( 1 ) = 4
+ RETURN
+*
+* ................ ENTRY (ISAVE( 1 ) = 4)
+* X HAS BEEN OVERWRITTEN BY TRANSPOSE(A)*X.
+*
+ 110 CONTINUE
+ JLAST = ISAVE( 2 )
+ ISAVE( 2 ) = ISAMAX( N, X, 1 )
+ IF( ( X( JLAST ).NE.ABS( X( ISAVE( 2 ) ) ) ) .AND.
+ $ ( ISAVE( 3 ).LT.ITMAX ) ) THEN
+ ISAVE( 3 ) = ISAVE( 3 ) + 1
+ GO TO 50
+ END IF
+*
+* ITERATION COMPLETE. FINAL STAGE.
+*
+ 120 CONTINUE
+ ALTSGN = ONE
+ DO 130 I = 1, N
+ X( I ) = ALTSGN*( ONE+REAL( I-1 ) / REAL( N-1 ) )
+ ALTSGN = -ALTSGN
+ 130 CONTINUE
+ KASE = 1
+ ISAVE( 1 ) = 5
+ RETURN
+*
+* ................ ENTRY (ISAVE( 1 ) = 5)
+* X HAS BEEN OVERWRITTEN BY A*X.
+*
+ 140 CONTINUE
+ TEMP = TWO*( SASUM( N, X, 1 ) / REAL( 3*N ) )
+ IF( TEMP.GT.EST ) THEN
+ CALL SCOPY( N, X, 1, V, 1 )
+ EST = TEMP
+ END IF
+*
+ 150 CONTINUE
+ KASE = 0
+ RETURN
+*
+* End of SLACN2
+*
+ END
+ SUBROUTINE SLACON( N, V, X, ISGN, EST, KASE )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER KASE, N
+ REAL EST
+* ..
+* .. Array Arguments ..
+ INTEGER ISGN( * )
+ REAL V( * ), X( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SLACON estimates the 1-norm of a square, real matrix A.
+* Reverse communication is used for evaluating matrix-vector products.
+*
+* Arguments
+* =========
+*
+* N (input) INTEGER
+* The order of the matrix. N >= 1.
+*
+* V (workspace) REAL array, dimension (N)
+* On the final return, V = A*W, where EST = norm(V)/norm(W)
+* (W is not returned).
+*
+* X (input/output) REAL array, dimension (N)
+* On an intermediate return, X should be overwritten by
+* A * X, if KASE=1,
+* A' * X, if KASE=2,
+* and SLACON must be re-called with all the other parameters
+* unchanged.
+*
+* ISGN (workspace) INTEGER array, dimension (N)
+*
+* EST (input/output) REAL
+* On entry with KASE = 1 or 2 and JUMP = 3, EST should be
+* unchanged from the previous call to SLACON.
+* On exit, EST is an estimate (a lower bound) for norm(A).
+*
+* KASE (input/output) INTEGER
+* On the initial call to SLACON, KASE should be 0.
+* On an intermediate return, KASE will be 1 or 2, indicating
+* whether X should be overwritten by A * X or A' * X.
+* On the final return from SLACON, KASE will again be 0.
+*
+* Further Details
+* ======= =======
+*
+* Contributed by Nick Higham, University of Manchester.
+* Originally named SONEST, dated March 16, 1988.
+*
+* Reference: N.J. Higham, "FORTRAN codes for estimating the one-norm of
+* a real or complex matrix, with applications to condition estimation",
+* ACM Trans. Math. Soft., vol. 14, no. 4, pp. 381-396, December 1988.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ INTEGER ITMAX
+ PARAMETER ( ITMAX = 5 )
+ REAL ZERO, ONE, TWO
+ PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0, TWO = 2.0E+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, ITER, J, JLAST, JUMP
+ REAL ALTSGN, ESTOLD, TEMP
+* ..
+* .. External Functions ..
+ INTEGER ISAMAX
+ REAL SASUM
+ EXTERNAL ISAMAX, SASUM
+* ..
+* .. External Subroutines ..
+ EXTERNAL SCOPY
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, NINT, REAL, SIGN
+* ..
+* .. Save statement ..
+ SAVE
+* ..
+* .. Executable Statements ..
+*
+ IF( KASE.EQ.0 ) THEN
+ DO 10 I = 1, N
+ X( I ) = ONE / REAL( N )
+ 10 CONTINUE
+ KASE = 1
+ JUMP = 1
+ RETURN
+ END IF
+*
+ GO TO ( 20, 40, 70, 110, 140 )JUMP
+*
+* ................ ENTRY (JUMP = 1)
+* FIRST ITERATION. X HAS BEEN OVERWRITTEN BY A*X.
+*
+ 20 CONTINUE
+ IF( N.EQ.1 ) THEN
+ V( 1 ) = X( 1 )
+ EST = ABS( V( 1 ) )
+* ... QUIT
+ GO TO 150
+ END IF
+ EST = SASUM( N, X, 1 )
+*
+ DO 30 I = 1, N
+ X( I ) = SIGN( ONE, X( I ) )
+ ISGN( I ) = NINT( X( I ) )
+ 30 CONTINUE
+ KASE = 2
+ JUMP = 2
+ RETURN
+*
+* ................ ENTRY (JUMP = 2)
+* FIRST ITERATION. X HAS BEEN OVERWRITTEN BY TRANSPOSE(A)*X.
+*
+ 40 CONTINUE
+ J = ISAMAX( N, X, 1 )
+ ITER = 2
+*
+* MAIN LOOP - ITERATIONS 2,3,...,ITMAX.
+*
+ 50 CONTINUE
+ DO 60 I = 1, N
+ X( I ) = ZERO
+ 60 CONTINUE
+ X( J ) = ONE
+ KASE = 1
+ JUMP = 3
+ RETURN
+*
+* ................ ENTRY (JUMP = 3)
+* X HAS BEEN OVERWRITTEN BY A*X.
+*
+ 70 CONTINUE
+ CALL SCOPY( N, X, 1, V, 1 )
+ ESTOLD = EST
+ EST = SASUM( N, V, 1 )
+ DO 80 I = 1, N
+ IF( NINT( SIGN( ONE, X( I ) ) ).NE.ISGN( I ) )
+ $ GO TO 90
+ 80 CONTINUE
+* REPEATED SIGN VECTOR DETECTED, HENCE ALGORITHM HAS CONVERGED.
+ GO TO 120
+*
+ 90 CONTINUE
+* TEST FOR CYCLING.
+ IF( EST.LE.ESTOLD )
+ $ GO TO 120
+*
+ DO 100 I = 1, N
+ X( I ) = SIGN( ONE, X( I ) )
+ ISGN( I ) = NINT( X( I ) )
+ 100 CONTINUE
+ KASE = 2
+ JUMP = 4
+ RETURN
+*
+* ................ ENTRY (JUMP = 4)
+* X HAS BEEN OVERWRITTEN BY TRANSPOSE(A)*X.
+*
+ 110 CONTINUE
+ JLAST = J
+ J = ISAMAX( N, X, 1 )
+ IF( ( X( JLAST ).NE.ABS( X( J ) ) ) .AND. ( ITER.LT.ITMAX ) ) THEN
+ ITER = ITER + 1
+ GO TO 50
+ END IF
+*
+* ITERATION COMPLETE. FINAL STAGE.
+*
+ 120 CONTINUE
+ ALTSGN = ONE
+ DO 130 I = 1, N
+ X( I ) = ALTSGN*( ONE+REAL( I-1 ) / REAL( N-1 ) )
+ ALTSGN = -ALTSGN
+ 130 CONTINUE
+ KASE = 1
+ JUMP = 5
+ RETURN
+*
+* ................ ENTRY (JUMP = 5)
+* X HAS BEEN OVERWRITTEN BY A*X.
+*
+ 140 CONTINUE
+ TEMP = TWO*( SASUM( N, X, 1 ) / REAL( 3*N ) )
+ IF( TEMP.GT.EST ) THEN
+ CALL SCOPY( N, X, 1, V, 1 )
+ EST = TEMP
+ END IF
+*
+ 150 CONTINUE
+ KASE = 0
+ RETURN
+*
+* End of SLACON
+*
+ END
+ SUBROUTINE SLACPY( UPLO, M, N, A, LDA, B, LDB )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER LDA, LDB, M, N
+* ..
+* .. Array Arguments ..
+ REAL A( LDA, * ), B( LDB, * )
+* ..
+*
+* Purpose
+* =======
+*
+* SLACPY copies all or part of a two-dimensional matrix A to another
+* matrix B.
+*
+* Arguments
+* =========
+*
+* UPLO (input) CHARACTER*1
+* Specifies the part of the matrix A to be copied to B.
+* = 'U': Upper triangular part
+* = 'L': Lower triangular part
+* Otherwise: All of the matrix A
+*
+* M (input) INTEGER
+* The number of rows of the matrix A. M >= 0.
+*
+* N (input) INTEGER
+* The number of columns of the matrix A. N >= 0.
+*
+* A (input) REAL array, dimension (LDA,N)
+* The m by n matrix A. If UPLO = 'U', only the upper triangle
+* or trapezoid is accessed; if UPLO = 'L', only the lower
+* triangle or trapezoid is accessed.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,M).
+*
+* B (output) REAL array, dimension (LDB,N)
+* On exit, B = A in the locations specified by UPLO.
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. LDB >= max(1,M).
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ INTEGER I, J
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MIN
+* ..
+* .. Executable Statements ..
+*
+ IF( LSAME( UPLO, 'U' ) ) THEN
+ DO 20 J = 1, N
+ DO 10 I = 1, MIN( J, M )
+ B( I, J ) = A( I, J )
+ 10 CONTINUE
+ 20 CONTINUE
+ ELSE IF( LSAME( UPLO, 'L' ) ) THEN
+ DO 40 J = 1, N
+ DO 30 I = J, M
+ B( I, J ) = A( I, J )
+ 30 CONTINUE
+ 40 CONTINUE
+ ELSE
+ DO 60 J = 1, N
+ DO 50 I = 1, M
+ B( I, J ) = A( I, J )
+ 50 CONTINUE
+ 60 CONTINUE
+ END IF
+ RETURN
+*
+* End of SLACPY
+*
+ END
+ SUBROUTINE SLADIV( A, B, C, D, P, Q )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ REAL A, B, C, D, P, Q
+* ..
+*
+* Purpose
+* =======
+*
+* SLADIV performs complex division in real arithmetic
+*
+* a + i*b
+* p + i*q = ---------
+* c + i*d
+*
+* The algorithm is due to Robert L. Smith and can be found
+* in D. Knuth, The art of Computer Programming, Vol.2, p.195
+*
+* Arguments
+* =========
+*
+* A (input) REAL
+* B (input) REAL
+* C (input) REAL
+* D (input) REAL
+* The scalars a, b, c, and d in the above expression.
+*
+* P (output) REAL
+* Q (output) REAL
+* The scalars p and q in the above expression.
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ REAL E, F
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS
+* ..
+* .. Executable Statements ..
+*
+ IF( ABS( D ).LT.ABS( C ) ) THEN
+ E = D / C
+ F = C + D*E
+ P = ( A+B*E ) / F
+ Q = ( B-A*E ) / F
+ ELSE
+ E = C / D
+ F = D + C*E
+ P = ( B+A*E ) / F
+ Q = ( -A+B*E ) / F
+ END IF
+*
+ RETURN
+*
+* End of SLADIV
+*
+ END
+ SUBROUTINE SLAE2( A, B, C, RT1, RT2 )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ REAL A, B, C, RT1, RT2
+* ..
+*
+* Purpose
+* =======
+*
+* SLAE2 computes the eigenvalues of a 2-by-2 symmetric matrix
+* [ A B ]
+* [ B C ].
+* On return, RT1 is the eigenvalue of larger absolute value, and RT2
+* is the eigenvalue of smaller absolute value.
+*
+* Arguments
+* =========
+*
+* A (input) REAL
+* The (1,1) element of the 2-by-2 matrix.
+*
+* B (input) REAL
+* The (1,2) and (2,1) elements of the 2-by-2 matrix.
+*
+* C (input) REAL
+* The (2,2) element of the 2-by-2 matrix.
+*
+* RT1 (output) REAL
+* The eigenvalue of larger absolute value.
+*
+* RT2 (output) REAL
+* The eigenvalue of smaller absolute value.
+*
+* Further Details
+* ===============
+*
+* RT1 is accurate to a few ulps barring over/underflow.
+*
+* RT2 may be inaccurate if there is massive cancellation in the
+* determinant A*C-B*B; higher precision or correctly rounded or
+* correctly truncated arithmetic would be needed to compute RT2
+* accurately in all cases.
+*
+* Overflow is possible only if RT1 is within a factor of 5 of overflow.
+* Underflow is harmless if the input data is 0 or exceeds
+* underflow_threshold / macheps.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ONE
+ PARAMETER ( ONE = 1.0E0 )
+ REAL TWO
+ PARAMETER ( TWO = 2.0E0 )
+ REAL ZERO
+ PARAMETER ( ZERO = 0.0E0 )
+ REAL HALF
+ PARAMETER ( HALF = 0.5E0 )
+* ..
+* .. Local Scalars ..
+ REAL AB, ACMN, ACMX, ADF, DF, RT, SM, TB
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, SQRT
+* ..
+* .. Executable Statements ..
+*
+* Compute the eigenvalues
+*
+ SM = A + C
+ DF = A - C
+ ADF = ABS( DF )
+ TB = B + B
+ AB = ABS( TB )
+ IF( ABS( A ).GT.ABS( C ) ) THEN
+ ACMX = A
+ ACMN = C
+ ELSE
+ ACMX = C
+ ACMN = A
+ END IF
+ IF( ADF.GT.AB ) THEN
+ RT = ADF*SQRT( ONE+( AB / ADF )**2 )
+ ELSE IF( ADF.LT.AB ) THEN
+ RT = AB*SQRT( ONE+( ADF / AB )**2 )
+ ELSE
+*
+* Includes case AB=ADF=0
+*
+ RT = AB*SQRT( TWO )
+ END IF
+ IF( SM.LT.ZERO ) THEN
+ RT1 = HALF*( SM-RT )
+*
+* Order of execution important.
+* To get fully accurate smaller eigenvalue,
+* next line needs to be executed in higher precision.
+*
+ RT2 = ( ACMX / RT1 )*ACMN - ( B / RT1 )*B
+ ELSE IF( SM.GT.ZERO ) THEN
+ RT1 = HALF*( SM+RT )
+*
+* Order of execution important.
+* To get fully accurate smaller eigenvalue,
+* next line needs to be executed in higher precision.
+*
+ RT2 = ( ACMX / RT1 )*ACMN - ( B / RT1 )*B
+ ELSE
+*
+* Includes case RT1 = RT2 = 0
+*
+ RT1 = HALF*RT
+ RT2 = -HALF*RT
+ END IF
+ RETURN
+*
+* End of SLAE2
+*
+ END
+ SUBROUTINE SLAEBZ( IJOB, NITMAX, N, MMAX, MINP, NBMIN, ABSTOL,
+ $ RELTOL, PIVMIN, D, E, E2, NVAL, AB, C, MOUT,
+ $ NAB, WORK, IWORK, INFO )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER IJOB, INFO, MINP, MMAX, MOUT, N, NBMIN, NITMAX
+ REAL ABSTOL, PIVMIN, RELTOL
+* ..
+* .. Array Arguments ..
+ INTEGER IWORK( * ), NAB( MMAX, * ), NVAL( * )
+ REAL AB( MMAX, * ), C( * ), D( * ), E( * ), E2( * ),
+ $ WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SLAEBZ contains the iteration loops which compute and use the
+* function N(w), which is the count of eigenvalues of a symmetric
+* tridiagonal matrix T less than or equal to its argument w. It
+* performs a choice of two types of loops:
+*
+* IJOB=1, followed by
+* IJOB=2: It takes as input a list of intervals and returns a list of
+* sufficiently small intervals whose union contains the same
+* eigenvalues as the union of the original intervals.
+* The input intervals are (AB(j,1),AB(j,2)], j=1,...,MINP.
+* The output interval (AB(j,1),AB(j,2)] will contain
+* eigenvalues NAB(j,1)+1,...,NAB(j,2), where 1 <= j <= MOUT.
+*
+* IJOB=3: It performs a binary search in each input interval
+* (AB(j,1),AB(j,2)] for a point w(j) such that
+* N(w(j))=NVAL(j), and uses C(j) as the starting point of
+* the search. If such a w(j) is found, then on output
+* AB(j,1)=AB(j,2)=w. If no such w(j) is found, then on output
+* (AB(j,1),AB(j,2)] will be a small interval containing the
+* point where N(w) jumps through NVAL(j), unless that point
+* lies outside the initial interval.
+*
+* Note that the intervals are in all cases half-open intervals,
+* i.e., of the form (a,b] , which includes b but not a .
+*
+* To avoid underflow, the matrix should be scaled so that its largest
+* element is no greater than overflow**(1/2) * underflow**(1/4)
+* in absolute value. To assure the most accurate computation
+* of small eigenvalues, the matrix should be scaled to be
+* not much smaller than that, either.
+*
+* See W. Kahan "Accurate Eigenvalues of a Symmetric Tridiagonal
+* Matrix", Report CS41, Computer Science Dept., Stanford
+* University, July 21, 1966
+*
+* Note: the arguments are, in general, *not* checked for unreasonable
+* values.
+*
+* Arguments
+* =========
+*
+* IJOB (input) INTEGER
+* Specifies what is to be done:
+* = 1: Compute NAB for the initial intervals.
+* = 2: Perform bisection iteration to find eigenvalues of T.
+* = 3: Perform bisection iteration to invert N(w), i.e.,
+* to find a point which has a specified number of
+* eigenvalues of T to its left.
+* Other values will cause SLAEBZ to return with INFO=-1.
+*
+* NITMAX (input) INTEGER
+* The maximum number of "levels" of bisection to be
+* performed, i.e., an interval of width W will not be made
+* smaller than 2^(-NITMAX) * W. If not all intervals
+* have converged after NITMAX iterations, then INFO is set
+* to the number of non-converged intervals.
+*
+* N (input) INTEGER
+* The dimension n of the tridiagonal matrix T. It must be at
+* least 1.
+*
+* MMAX (input) INTEGER
+* The maximum number of intervals. If more than MMAX intervals
+* are generated, then SLAEBZ will quit with INFO=MMAX+1.
+*
+* MINP (input) INTEGER
+* The initial number of intervals. It may not be greater than
+* MMAX.
+*
+* NBMIN (input) INTEGER
+* The smallest number of intervals that should be processed
+* using a vector loop. If zero, then only the scalar loop
+* will be used.
+*
+* ABSTOL (input) REAL
+* The minimum (absolute) width of an interval. When an
+* interval is narrower than ABSTOL, or than RELTOL times the
+* larger (in magnitude) endpoint, then it is considered to be
+* sufficiently small, i.e., converged. This must be at least
+* zero.
+*
+* RELTOL (input) REAL
+* The minimum relative width of an interval. When an interval
+* is narrower than ABSTOL, or than RELTOL times the larger (in
+* magnitude) endpoint, then it is considered to be
+* sufficiently small, i.e., converged. Note: this should
+* always be at least radix*machine epsilon.
+*
+* PIVMIN (input) REAL
+* The minimum absolute value of a "pivot" in the Sturm
+* sequence loop. This *must* be at least max |e(j)**2| *
+* safe_min and at least safe_min, where safe_min is at least
+* the smallest number that can divide one without overflow.
+*
+* D (input) REAL array, dimension (N)
+* The diagonal elements of the tridiagonal matrix T.
+*
+* E (input) REAL array, dimension (N)
+* The offdiagonal elements of the tridiagonal matrix T in
+* positions 1 through N-1. E(N) is arbitrary.
+*
+* E2 (input) REAL array, dimension (N)
+* The squares of the offdiagonal elements of the tridiagonal
+* matrix T. E2(N) is ignored.
+*
+* NVAL (input/output) INTEGER array, dimension (MINP)
+* If IJOB=1 or 2, not referenced.
+* If IJOB=3, the desired values of N(w). The elements of NVAL
+* will be reordered to correspond with the intervals in AB.
+* Thus, NVAL(j) on output will not, in general be the same as
+* NVAL(j) on input, but it will correspond with the interval
+* (AB(j,1),AB(j,2)] on output.
+*
+* AB (input/output) REAL array, dimension (MMAX,2)
+* The endpoints of the intervals. AB(j,1) is a(j), the left
+* endpoint of the j-th interval, and AB(j,2) is b(j), the
+* right endpoint of the j-th interval. The input intervals
+* will, in general, be modified, split, and reordered by the
+* calculation.
+*
+* C (input/output) REAL array, dimension (MMAX)
+* If IJOB=1, ignored.
+* If IJOB=2, workspace.
+* If IJOB=3, then on input C(j) should be initialized to the
+* first search point in the binary search.
+*
+* MOUT (output) INTEGER
+* If IJOB=1, the number of eigenvalues in the intervals.
+* If IJOB=2 or 3, the number of intervals output.
+* If IJOB=3, MOUT will equal MINP.
+*
+* NAB (input/output) INTEGER array, dimension (MMAX,2)
+* If IJOB=1, then on output NAB(i,j) will be set to N(AB(i,j)).
+* If IJOB=2, then on input, NAB(i,j) should be set. It must
+* satisfy the condition:
+* N(AB(i,1)) <= NAB(i,1) <= NAB(i,2) <= N(AB(i,2)),
+* which means that in interval i only eigenvalues
+* NAB(i,1)+1,...,NAB(i,2) will be considered. Usually,
+* NAB(i,j)=N(AB(i,j)), from a previous call to SLAEBZ with
+* IJOB=1.
+* On output, NAB(i,j) will contain
+* max(na(k),min(nb(k),N(AB(i,j)))), where k is the index of
+* the input interval that the output interval
+* (AB(j,1),AB(j,2)] came from, and na(k) and nb(k) are the
+* the input values of NAB(k,1) and NAB(k,2).
+* If IJOB=3, then on output, NAB(i,j) contains N(AB(i,j)),
+* unless N(w) > NVAL(i) for all search points w , in which
+* case NAB(i,1) will not be modified, i.e., the output
+* value will be the same as the input value (modulo
+* reorderings -- see NVAL and AB), or unless N(w) < NVAL(i)
+* for all search points w , in which case NAB(i,2) will
+* not be modified. Normally, NAB should be set to some
+* distinctive value(s) before SLAEBZ is called.
+*
+* WORK (workspace) REAL array, dimension (MMAX)
+* Workspace.
+*
+* IWORK (workspace) INTEGER array, dimension (MMAX)
+* Workspace.
+*
+* INFO (output) INTEGER
+* = 0: All intervals converged.
+* = 1--MMAX: The last INFO intervals did not converge.
+* = MMAX+1: More than MMAX intervals were generated.
+*
+* Further Details
+* ===============
+*
+* This routine is intended to be called only by other LAPACK
+* routines, thus the interface is less user-friendly. It is intended
+* for two purposes:
+*
+* (a) finding eigenvalues. In this case, SLAEBZ should have one or
+* more initial intervals set up in AB, and SLAEBZ should be called
+* with IJOB=1. This sets up NAB, and also counts the eigenvalues.
+* Intervals with no eigenvalues would usually be thrown out at
+* this point. Also, if not all the eigenvalues in an interval i
+* are desired, NAB(i,1) can be increased or NAB(i,2) decreased.
+* For example, set NAB(i,1)=NAB(i,2)-1 to get the largest
+* eigenvalue. SLAEBZ is then called with IJOB=2 and MMAX
+* no smaller than the value of MOUT returned by the call with
+* IJOB=1. After this (IJOB=2) call, eigenvalues NAB(i,1)+1
+* through NAB(i,2) are approximately AB(i,1) (or AB(i,2)) to the
+* tolerance specified by ABSTOL and RELTOL.
+*
+* (b) finding an interval (a',b'] containing eigenvalues w(f),...,w(l).
+* In this case, start with a Gershgorin interval (a,b). Set up
+* AB to contain 2 search intervals, both initially (a,b). One
+* NVAL element should contain f-1 and the other should contain l
+* , while C should contain a and b, resp. NAB(i,1) should be -1
+* and NAB(i,2) should be N+1, to flag an error if the desired
+* interval does not lie in (a,b). SLAEBZ is then called with
+* IJOB=3. On exit, if w(f-1) < w(f), then one of the intervals --
+* j -- will have AB(j,1)=AB(j,2) and NAB(j,1)=NAB(j,2)=f-1, while
+* if, to the specified tolerance, w(f-k)=...=w(f+r), k > 0 and r
+* >= 0, then the interval will have N(AB(j,1))=NAB(j,1)=f-k and
+* N(AB(j,2))=NAB(j,2)=f+r. The cases w(l) < w(l+1) and
+* w(l-r)=...=w(l+k) are handled similarly.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO, TWO, HALF
+ PARAMETER ( ZERO = 0.0E0, TWO = 2.0E0,
+ $ HALF = 1.0E0 / TWO )
+* ..
+* .. Local Scalars ..
+ INTEGER ITMP1, ITMP2, J, JI, JIT, JP, KF, KFNEW, KL,
+ $ KLNEW
+ REAL TMP1, TMP2
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+* Check for Errors
+*
+ INFO = 0
+ IF( IJOB.LT.1 .OR. IJOB.GT.3 ) THEN
+ INFO = -1
+ RETURN
+ END IF
+*
+* Initialize NAB
+*
+ IF( IJOB.EQ.1 ) THEN
+*
+* Compute the number of eigenvalues in the initial intervals.
+*
+ MOUT = 0
+CDIR$ NOVECTOR
+ DO 30 JI = 1, MINP
+ DO 20 JP = 1, 2
+ TMP1 = D( 1 ) - AB( JI, JP )
+ IF( ABS( TMP1 ).LT.PIVMIN )
+ $ TMP1 = -PIVMIN
+ NAB( JI, JP ) = 0
+ IF( TMP1.LE.ZERO )
+ $ NAB( JI, JP ) = 1
+*
+ DO 10 J = 2, N
+ TMP1 = D( J ) - E2( J-1 ) / TMP1 - AB( JI, JP )
+ IF( ABS( TMP1 ).LT.PIVMIN )
+ $ TMP1 = -PIVMIN
+ IF( TMP1.LE.ZERO )
+ $ NAB( JI, JP ) = NAB( JI, JP ) + 1
+ 10 CONTINUE
+ 20 CONTINUE
+ MOUT = MOUT + NAB( JI, 2 ) - NAB( JI, 1 )
+ 30 CONTINUE
+ RETURN
+ END IF
+*
+* Initialize for loop
+*
+* KF and KL have the following meaning:
+* Intervals 1,...,KF-1 have converged.
+* Intervals KF,...,KL still need to be refined.
+*
+ KF = 1
+ KL = MINP
+*
+* If IJOB=2, initialize C.
+* If IJOB=3, use the user-supplied starting point.
+*
+ IF( IJOB.EQ.2 ) THEN
+ DO 40 JI = 1, MINP
+ C( JI ) = HALF*( AB( JI, 1 )+AB( JI, 2 ) )
+ 40 CONTINUE
+ END IF
+*
+* Iteration loop
+*
+ DO 130 JIT = 1, NITMAX
+*
+* Loop over intervals
+*
+ IF( KL-KF+1.GE.NBMIN .AND. NBMIN.GT.0 ) THEN
+*
+* Begin of Parallel Version of the loop
+*
+ DO 60 JI = KF, KL
+*
+* Compute N(c), the number of eigenvalues less than c
+*
+ WORK( JI ) = D( 1 ) - C( JI )
+ IWORK( JI ) = 0
+ IF( WORK( JI ).LE.PIVMIN ) THEN
+ IWORK( JI ) = 1
+ WORK( JI ) = MIN( WORK( JI ), -PIVMIN )
+ END IF
+*
+ DO 50 J = 2, N
+ WORK( JI ) = D( J ) - E2( J-1 ) / WORK( JI ) - C( JI )
+ IF( WORK( JI ).LE.PIVMIN ) THEN
+ IWORK( JI ) = IWORK( JI ) + 1
+ WORK( JI ) = MIN( WORK( JI ), -PIVMIN )
+ END IF
+ 50 CONTINUE
+ 60 CONTINUE
+*
+ IF( IJOB.LE.2 ) THEN
+*
+* IJOB=2: Choose all intervals containing eigenvalues.
+*
+ KLNEW = KL
+ DO 70 JI = KF, KL
+*
+* Insure that N(w) is monotone
+*
+ IWORK( JI ) = MIN( NAB( JI, 2 ),
+ $ MAX( NAB( JI, 1 ), IWORK( JI ) ) )
+*
+* Update the Queue -- add intervals if both halves
+* contain eigenvalues.
+*
+ IF( IWORK( JI ).EQ.NAB( JI, 2 ) ) THEN
+*
+* No eigenvalue in the upper interval:
+* just use the lower interval.
+*
+ AB( JI, 2 ) = C( JI )
+*
+ ELSE IF( IWORK( JI ).EQ.NAB( JI, 1 ) ) THEN
+*
+* No eigenvalue in the lower interval:
+* just use the upper interval.
+*
+ AB( JI, 1 ) = C( JI )
+ ELSE
+ KLNEW = KLNEW + 1
+ IF( KLNEW.LE.MMAX ) THEN
+*
+* Eigenvalue in both intervals -- add upper to
+* queue.
+*
+ AB( KLNEW, 2 ) = AB( JI, 2 )
+ NAB( KLNEW, 2 ) = NAB( JI, 2 )
+ AB( KLNEW, 1 ) = C( JI )
+ NAB( KLNEW, 1 ) = IWORK( JI )
+ AB( JI, 2 ) = C( JI )
+ NAB( JI, 2 ) = IWORK( JI )
+ ELSE
+ INFO = MMAX + 1
+ END IF
+ END IF
+ 70 CONTINUE
+ IF( INFO.NE.0 )
+ $ RETURN
+ KL = KLNEW
+ ELSE
+*
+* IJOB=3: Binary search. Keep only the interval containing
+* w s.t. N(w) = NVAL
+*
+ DO 80 JI = KF, KL
+ IF( IWORK( JI ).LE.NVAL( JI ) ) THEN
+ AB( JI, 1 ) = C( JI )
+ NAB( JI, 1 ) = IWORK( JI )
+ END IF
+ IF( IWORK( JI ).GE.NVAL( JI ) ) THEN
+ AB( JI, 2 ) = C( JI )
+ NAB( JI, 2 ) = IWORK( JI )
+ END IF
+ 80 CONTINUE
+ END IF
+*
+ ELSE
+*
+* End of Parallel Version of the loop
+*
+* Begin of Serial Version of the loop
+*
+ KLNEW = KL
+ DO 100 JI = KF, KL
+*
+* Compute N(w), the number of eigenvalues less than w
+*
+ TMP1 = C( JI )
+ TMP2 = D( 1 ) - TMP1
+ ITMP1 = 0
+ IF( TMP2.LE.PIVMIN ) THEN
+ ITMP1 = 1
+ TMP2 = MIN( TMP2, -PIVMIN )
+ END IF
+*
+* A series of compiler directives to defeat vectorization
+* for the next loop
+*
+*$PL$ CMCHAR=' '
+CDIR$ NEXTSCALAR
+C$DIR SCALAR
+CDIR$ NEXT SCALAR
+CVD$L NOVECTOR
+CDEC$ NOVECTOR
+CVD$ NOVECTOR
+*VDIR NOVECTOR
+*VOCL LOOP,SCALAR
+CIBM PREFER SCALAR
+*$PL$ CMCHAR='*'
+*
+ DO 90 J = 2, N
+ TMP2 = D( J ) - E2( J-1 ) / TMP2 - TMP1
+ IF( TMP2.LE.PIVMIN ) THEN
+ ITMP1 = ITMP1 + 1
+ TMP2 = MIN( TMP2, -PIVMIN )
+ END IF
+ 90 CONTINUE
+*
+ IF( IJOB.LE.2 ) THEN
+*
+* IJOB=2: Choose all intervals containing eigenvalues.
+*
+* Insure that N(w) is monotone
+*
+ ITMP1 = MIN( NAB( JI, 2 ),
+ $ MAX( NAB( JI, 1 ), ITMP1 ) )
+*
+* Update the Queue -- add intervals if both halves
+* contain eigenvalues.
+*
+ IF( ITMP1.EQ.NAB( JI, 2 ) ) THEN
+*
+* No eigenvalue in the upper interval:
+* just use the lower interval.
+*
+ AB( JI, 2 ) = TMP1
+*
+ ELSE IF( ITMP1.EQ.NAB( JI, 1 ) ) THEN
+*
+* No eigenvalue in the lower interval:
+* just use the upper interval.
+*
+ AB( JI, 1 ) = TMP1
+ ELSE IF( KLNEW.LT.MMAX ) THEN
+*
+* Eigenvalue in both intervals -- add upper to queue.
+*
+ KLNEW = KLNEW + 1
+ AB( KLNEW, 2 ) = AB( JI, 2 )
+ NAB( KLNEW, 2 ) = NAB( JI, 2 )
+ AB( KLNEW, 1 ) = TMP1
+ NAB( KLNEW, 1 ) = ITMP1
+ AB( JI, 2 ) = TMP1
+ NAB( JI, 2 ) = ITMP1
+ ELSE
+ INFO = MMAX + 1
+ RETURN
+ END IF
+ ELSE
+*
+* IJOB=3: Binary search. Keep only the interval
+* containing w s.t. N(w) = NVAL
+*
+ IF( ITMP1.LE.NVAL( JI ) ) THEN
+ AB( JI, 1 ) = TMP1
+ NAB( JI, 1 ) = ITMP1
+ END IF
+ IF( ITMP1.GE.NVAL( JI ) ) THEN
+ AB( JI, 2 ) = TMP1
+ NAB( JI, 2 ) = ITMP1
+ END IF
+ END IF
+ 100 CONTINUE
+ KL = KLNEW
+*
+* End of Serial Version of the loop
+*
+ END IF
+*
+* Check for convergence
+*
+ KFNEW = KF
+ DO 110 JI = KF, KL
+ TMP1 = ABS( AB( JI, 2 )-AB( JI, 1 ) )
+ TMP2 = MAX( ABS( AB( JI, 2 ) ), ABS( AB( JI, 1 ) ) )
+ IF( TMP1.LT.MAX( ABSTOL, PIVMIN, RELTOL*TMP2 ) .OR.
+ $ NAB( JI, 1 ).GE.NAB( JI, 2 ) ) THEN
+*
+* Converged -- Swap with position KFNEW,
+* then increment KFNEW
+*
+ IF( JI.GT.KFNEW ) THEN
+ TMP1 = AB( JI, 1 )
+ TMP2 = AB( JI, 2 )
+ ITMP1 = NAB( JI, 1 )
+ ITMP2 = NAB( JI, 2 )
+ AB( JI, 1 ) = AB( KFNEW, 1 )
+ AB( JI, 2 ) = AB( KFNEW, 2 )
+ NAB( JI, 1 ) = NAB( KFNEW, 1 )
+ NAB( JI, 2 ) = NAB( KFNEW, 2 )
+ AB( KFNEW, 1 ) = TMP1
+ AB( KFNEW, 2 ) = TMP2
+ NAB( KFNEW, 1 ) = ITMP1
+ NAB( KFNEW, 2 ) = ITMP2
+ IF( IJOB.EQ.3 ) THEN
+ ITMP1 = NVAL( JI )
+ NVAL( JI ) = NVAL( KFNEW )
+ NVAL( KFNEW ) = ITMP1
+ END IF
+ END IF
+ KFNEW = KFNEW + 1
+ END IF
+ 110 CONTINUE
+ KF = KFNEW
+*
+* Choose Midpoints
+*
+ DO 120 JI = KF, KL
+ C( JI ) = HALF*( AB( JI, 1 )+AB( JI, 2 ) )
+ 120 CONTINUE
+*
+* If no more intervals to refine, quit.
+*
+ IF( KF.GT.KL )
+ $ GO TO 140
+ 130 CONTINUE
+*
+* Converged
+*
+ 140 CONTINUE
+ INFO = MAX( KL+1-KF, 0 )
+ MOUT = KL
+*
+ RETURN
+*
+* End of SLAEBZ
+*
+ END
+ SUBROUTINE SLAED0( ICOMPQ, QSIZ, N, D, E, Q, LDQ, QSTORE, LDQS,
+ $ WORK, IWORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER ICOMPQ, INFO, LDQ, LDQS, N, QSIZ
+* ..
+* .. Array Arguments ..
+ INTEGER IWORK( * )
+ REAL D( * ), E( * ), Q( LDQ, * ), QSTORE( LDQS, * ),
+ $ WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SLAED0 computes all eigenvalues and corresponding eigenvectors of a
+* symmetric tridiagonal matrix using the divide and conquer method.
+*
+* Arguments
+* =========
+*
+* ICOMPQ (input) INTEGER
+* = 0: Compute eigenvalues only.
+* = 1: Compute eigenvectors of original dense symmetric matrix
+* also. On entry, Q contains the orthogonal matrix used
+* to reduce the original matrix to tridiagonal form.
+* = 2: Compute eigenvalues and eigenvectors of tridiagonal
+* matrix.
+*
+* QSIZ (input) INTEGER
+* The dimension of the orthogonal matrix used to reduce
+* the full matrix to tridiagonal form. QSIZ >= N if ICOMPQ = 1.
+*
+* N (input) INTEGER
+* The dimension of the symmetric tridiagonal matrix. N >= 0.
+*
+* D (input/output) REAL array, dimension (N)
+* On entry, the main diagonal of the tridiagonal matrix.
+* On exit, its eigenvalues.
+*
+* E (input) REAL array, dimension (N-1)
+* The off-diagonal elements of the tridiagonal matrix.
+* On exit, E has been destroyed.
+*
+* Q (input/output) REAL array, dimension (LDQ, N)
+* On entry, Q must contain an N-by-N orthogonal matrix.
+* If ICOMPQ = 0 Q is not referenced.
+* If ICOMPQ = 1 On entry, Q is a subset of the columns of the
+* orthogonal matrix used to reduce the full
+* matrix to tridiagonal form corresponding to
+* the subset of the full matrix which is being
+* decomposed at this time.
+* If ICOMPQ = 2 On entry, Q will be the identity matrix.
+* On exit, Q contains the eigenvectors of the
+* tridiagonal matrix.
+*
+* LDQ (input) INTEGER
+* The leading dimension of the array Q. If eigenvectors are
+* desired, then LDQ >= max(1,N). In any case, LDQ >= 1.
+*
+* QSTORE (workspace) REAL array, dimension (LDQS, N)
+* Referenced only when ICOMPQ = 1. Used to store parts of
+* the eigenvector matrix when the updating matrix multiplies
+* take place.
+*
+* LDQS (input) INTEGER
+* The leading dimension of the array QSTORE. If ICOMPQ = 1,
+* then LDQS >= max(1,N). In any case, LDQS >= 1.
+*
+* WORK (workspace) REAL array,
+* If ICOMPQ = 0 or 1, the dimension of WORK must be at least
+* 1 + 3*N + 2*N*lg N + 2*N**2
+* ( lg( N ) = smallest integer k
+* such that 2^k >= N )
+* If ICOMPQ = 2, the dimension of WORK must be at least
+* 4*N + N**2.
+*
+* IWORK (workspace) INTEGER array,
+* If ICOMPQ = 0 or 1, the dimension of IWORK must be at least
+* 6 + 6*N + 5*N*lg N.
+* ( lg( N ) = smallest integer k
+* such that 2^k >= N )
+* If ICOMPQ = 2, the dimension of IWORK must be at least
+* 3 + 5*N.
+*
+* INFO (output) INTEGER
+* = 0: successful exit.
+* < 0: if INFO = -i, the i-th argument had an illegal value.
+* > 0: The algorithm failed to compute an eigenvalue while
+* working on the submatrix lying in rows and columns
+* INFO/(N+1) through mod(INFO,N+1).
+*
+* Further Details
+* ===============
+*
+* Based on contributions by
+* Jeff Rutter, Computer Science Division, University of California
+* at Berkeley, USA
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO, ONE, TWO
+ PARAMETER ( ZERO = 0.E0, ONE = 1.E0, TWO = 2.E0 )
+* ..
+* .. Local Scalars ..
+ INTEGER CURLVL, CURPRB, CURR, I, IGIVCL, IGIVNM,
+ $ IGIVPT, INDXQ, IPERM, IPRMPT, IQ, IQPTR, IWREM,
+ $ J, K, LGN, MATSIZ, MSD2, SMLSIZ, SMM1, SPM1,
+ $ SPM2, SUBMAT, SUBPBS, TLVLS
+ REAL TEMP
+* ..
+* .. External Subroutines ..
+ EXTERNAL SCOPY, SGEMM, SLACPY, SLAED1, SLAED7, SSTEQR,
+ $ XERBLA
+* ..
+* .. External Functions ..
+ INTEGER ILAENV
+ EXTERNAL ILAENV
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, INT, LOG, MAX, REAL
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+*
+ IF( ICOMPQ.LT.0 .OR. ICOMPQ.GT.2 ) THEN
+ INFO = -1
+ ELSE IF( ( ICOMPQ.EQ.1 ) .AND. ( QSIZ.LT.MAX( 0, N ) ) ) THEN
+ INFO = -2
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN
+ INFO = -7
+ ELSE IF( LDQS.LT.MAX( 1, N ) ) THEN
+ INFO = -9
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SLAED0', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+ SMLSIZ = ILAENV( 9, 'SLAED0', ' ', 0, 0, 0, 0 )
+*
+* Determine the size and placement of the submatrices, and save in
+* the leading elements of IWORK.
+*
+ IWORK( 1 ) = N
+ SUBPBS = 1
+ TLVLS = 0
+ 10 CONTINUE
+ IF( IWORK( SUBPBS ).GT.SMLSIZ ) THEN
+ DO 20 J = SUBPBS, 1, -1
+ IWORK( 2*J ) = ( IWORK( J )+1 ) / 2
+ IWORK( 2*J-1 ) = IWORK( J ) / 2
+ 20 CONTINUE
+ TLVLS = TLVLS + 1
+ SUBPBS = 2*SUBPBS
+ GO TO 10
+ END IF
+ DO 30 J = 2, SUBPBS
+ IWORK( J ) = IWORK( J ) + IWORK( J-1 )
+ 30 CONTINUE
+*
+* Divide the matrix into SUBPBS submatrices of size at most SMLSIZ+1
+* using rank-1 modifications (cuts).
+*
+ SPM1 = SUBPBS - 1
+ DO 40 I = 1, SPM1
+ SUBMAT = IWORK( I ) + 1
+ SMM1 = SUBMAT - 1
+ D( SMM1 ) = D( SMM1 ) - ABS( E( SMM1 ) )
+ D( SUBMAT ) = D( SUBMAT ) - ABS( E( SMM1 ) )
+ 40 CONTINUE
+*
+ INDXQ = 4*N + 3
+ IF( ICOMPQ.NE.2 ) THEN
+*
+* Set up workspaces for eigenvalues only/accumulate new vectors
+* routine
+*
+ TEMP = LOG( REAL( N ) ) / LOG( TWO )
+ LGN = INT( TEMP )
+ IF( 2**LGN.LT.N )
+ $ LGN = LGN + 1
+ IF( 2**LGN.LT.N )
+ $ LGN = LGN + 1
+ IPRMPT = INDXQ + N + 1
+ IPERM = IPRMPT + N*LGN
+ IQPTR = IPERM + N*LGN
+ IGIVPT = IQPTR + N + 2
+ IGIVCL = IGIVPT + N*LGN
+*
+ IGIVNM = 1
+ IQ = IGIVNM + 2*N*LGN
+ IWREM = IQ + N**2 + 1
+*
+* Initialize pointers
+*
+ DO 50 I = 0, SUBPBS
+ IWORK( IPRMPT+I ) = 1
+ IWORK( IGIVPT+I ) = 1
+ 50 CONTINUE
+ IWORK( IQPTR ) = 1
+ END IF
+*
+* Solve each submatrix eigenproblem at the bottom of the divide and
+* conquer tree.
+*
+ CURR = 0
+ DO 70 I = 0, SPM1
+ IF( I.EQ.0 ) THEN
+ SUBMAT = 1
+ MATSIZ = IWORK( 1 )
+ ELSE
+ SUBMAT = IWORK( I ) + 1
+ MATSIZ = IWORK( I+1 ) - IWORK( I )
+ END IF
+ IF( ICOMPQ.EQ.2 ) THEN
+ CALL SSTEQR( 'I', MATSIZ, D( SUBMAT ), E( SUBMAT ),
+ $ Q( SUBMAT, SUBMAT ), LDQ, WORK, INFO )
+ IF( INFO.NE.0 )
+ $ GO TO 130
+ ELSE
+ CALL SSTEQR( 'I', MATSIZ, D( SUBMAT ), E( SUBMAT ),
+ $ WORK( IQ-1+IWORK( IQPTR+CURR ) ), MATSIZ, WORK,
+ $ INFO )
+ IF( INFO.NE.0 )
+ $ GO TO 130
+ IF( ICOMPQ.EQ.1 ) THEN
+ CALL SGEMM( 'N', 'N', QSIZ, MATSIZ, MATSIZ, ONE,
+ $ Q( 1, SUBMAT ), LDQ, WORK( IQ-1+IWORK( IQPTR+
+ $ CURR ) ), MATSIZ, ZERO, QSTORE( 1, SUBMAT ),
+ $ LDQS )
+ END IF
+ IWORK( IQPTR+CURR+1 ) = IWORK( IQPTR+CURR ) + MATSIZ**2
+ CURR = CURR + 1
+ END IF
+ K = 1
+ DO 60 J = SUBMAT, IWORK( I+1 )
+ IWORK( INDXQ+J ) = K
+ K = K + 1
+ 60 CONTINUE
+ 70 CONTINUE
+*
+* Successively merge eigensystems of adjacent submatrices
+* into eigensystem for the corresponding larger matrix.
+*
+* while ( SUBPBS > 1 )
+*
+ CURLVL = 1
+ 80 CONTINUE
+ IF( SUBPBS.GT.1 ) THEN
+ SPM2 = SUBPBS - 2
+ DO 90 I = 0, SPM2, 2
+ IF( I.EQ.0 ) THEN
+ SUBMAT = 1
+ MATSIZ = IWORK( 2 )
+ MSD2 = IWORK( 1 )
+ CURPRB = 0
+ ELSE
+ SUBMAT = IWORK( I ) + 1
+ MATSIZ = IWORK( I+2 ) - IWORK( I )
+ MSD2 = MATSIZ / 2
+ CURPRB = CURPRB + 1
+ END IF
+*
+* Merge lower order eigensystems (of size MSD2 and MATSIZ - MSD2)
+* into an eigensystem of size MATSIZ.
+* SLAED1 is used only for the full eigensystem of a tridiagonal
+* matrix.
+* SLAED7 handles the cases in which eigenvalues only or eigenvalues
+* and eigenvectors of a full symmetric matrix (which was reduced to
+* tridiagonal form) are desired.
+*
+ IF( ICOMPQ.EQ.2 ) THEN
+ CALL SLAED1( MATSIZ, D( SUBMAT ), Q( SUBMAT, SUBMAT ),
+ $ LDQ, IWORK( INDXQ+SUBMAT ),
+ $ E( SUBMAT+MSD2-1 ), MSD2, WORK,
+ $ IWORK( SUBPBS+1 ), INFO )
+ ELSE
+ CALL SLAED7( ICOMPQ, MATSIZ, QSIZ, TLVLS, CURLVL, CURPRB,
+ $ D( SUBMAT ), QSTORE( 1, SUBMAT ), LDQS,
+ $ IWORK( INDXQ+SUBMAT ), E( SUBMAT+MSD2-1 ),
+ $ MSD2, WORK( IQ ), IWORK( IQPTR ),
+ $ IWORK( IPRMPT ), IWORK( IPERM ),
+ $ IWORK( IGIVPT ), IWORK( IGIVCL ),
+ $ WORK( IGIVNM ), WORK( IWREM ),
+ $ IWORK( SUBPBS+1 ), INFO )
+ END IF
+ IF( INFO.NE.0 )
+ $ GO TO 130
+ IWORK( I / 2+1 ) = IWORK( I+2 )
+ 90 CONTINUE
+ SUBPBS = SUBPBS / 2
+ CURLVL = CURLVL + 1
+ GO TO 80
+ END IF
+*
+* end while
+*
+* Re-merge the eigenvalues/vectors which were deflated at the final
+* merge step.
+*
+ IF( ICOMPQ.EQ.1 ) THEN
+ DO 100 I = 1, N
+ J = IWORK( INDXQ+I )
+ WORK( I ) = D( J )
+ CALL SCOPY( QSIZ, QSTORE( 1, J ), 1, Q( 1, I ), 1 )
+ 100 CONTINUE
+ CALL SCOPY( N, WORK, 1, D, 1 )
+ ELSE IF( ICOMPQ.EQ.2 ) THEN
+ DO 110 I = 1, N
+ J = IWORK( INDXQ+I )
+ WORK( I ) = D( J )
+ CALL SCOPY( N, Q( 1, J ), 1, WORK( N*I+1 ), 1 )
+ 110 CONTINUE
+ CALL SCOPY( N, WORK, 1, D, 1 )
+ CALL SLACPY( 'A', N, N, WORK( N+1 ), N, Q, LDQ )
+ ELSE
+ DO 120 I = 1, N
+ J = IWORK( INDXQ+I )
+ WORK( I ) = D( J )
+ 120 CONTINUE
+ CALL SCOPY( N, WORK, 1, D, 1 )
+ END IF
+ GO TO 140
+*
+ 130 CONTINUE
+ INFO = SUBMAT*( N+1 ) + SUBMAT + MATSIZ - 1
+*
+ 140 CONTINUE
+ RETURN
+*
+* End of SLAED0
+*
+ END
+ SUBROUTINE SLAED1( N, D, Q, LDQ, INDXQ, RHO, CUTPNT, WORK, IWORK,
+ $ INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER CUTPNT, INFO, LDQ, N
+ REAL RHO
+* ..
+* .. Array Arguments ..
+ INTEGER INDXQ( * ), IWORK( * )
+ REAL D( * ), Q( LDQ, * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SLAED1 computes the updated eigensystem of a diagonal
+* matrix after modification by a rank-one symmetric matrix. This
+* routine is used only for the eigenproblem which requires all
+* eigenvalues and eigenvectors of a tridiagonal matrix. SLAED7 handles
+* the case in which eigenvalues only or eigenvalues and eigenvectors
+* of a full symmetric matrix (which was reduced to tridiagonal form)
+* are desired.
+*
+* T = Q(in) ( D(in) + RHO * Z*Z' ) Q'(in) = Q(out) * D(out) * Q'(out)
+*
+* where Z = Q'u, u is a vector of length N with ones in the
+* CUTPNT and CUTPNT + 1 th elements and zeros elsewhere.
+*
+* The eigenvectors of the original matrix are stored in Q, and the
+* eigenvalues are in D. The algorithm consists of three stages:
+*
+* The first stage consists of deflating the size of the problem
+* when there are multiple eigenvalues or if there is a zero in
+* the Z vector. For each such occurence the dimension of the
+* secular equation problem is reduced by one. This stage is
+* performed by the routine SLAED2.
+*
+* The second stage consists of calculating the updated
+* eigenvalues. This is done by finding the roots of the secular
+* equation via the routine SLAED4 (as called by SLAED3).
+* This routine also calculates the eigenvectors of the current
+* problem.
+*
+* The final stage consists of computing the updated eigenvectors
+* directly using the updated eigenvalues. The eigenvectors for
+* the current problem are multiplied with the eigenvectors from
+* the overall problem.
+*
+* Arguments
+* =========
+*
+* N (input) INTEGER
+* The dimension of the symmetric tridiagonal matrix. N >= 0.
+*
+* D (input/output) REAL array, dimension (N)
+* On entry, the eigenvalues of the rank-1-perturbed matrix.
+* On exit, the eigenvalues of the repaired matrix.
+*
+* Q (input/output) REAL array, dimension (LDQ,N)
+* On entry, the eigenvectors of the rank-1-perturbed matrix.
+* On exit, the eigenvectors of the repaired tridiagonal matrix.
+*
+* LDQ (input) INTEGER
+* The leading dimension of the array Q. LDQ >= max(1,N).
+*
+* INDXQ (input/output) INTEGER array, dimension (N)
+* On entry, the permutation which separately sorts the two
+* subproblems in D into ascending order.
+* On exit, the permutation which will reintegrate the
+* subproblems back into sorted order,
+* i.e. D( INDXQ( I = 1, N ) ) will be in ascending order.
+*
+* RHO (input) REAL
+* The subdiagonal entry used to create the rank-1 modification.
+*
+* CUTPNT (input) INTEGER
+* The location of the last eigenvalue in the leading sub-matrix.
+* min(1,N) <= CUTPNT <= N/2.
+*
+* WORK (workspace) REAL array, dimension (4*N + N**2)
+*
+* IWORK (workspace) INTEGER array, dimension (4*N)
+*
+* INFO (output) INTEGER
+* = 0: successful exit.
+* < 0: if INFO = -i, the i-th argument had an illegal value.
+* > 0: if INFO = 1, an eigenvalue did not converge
+*
+* Further Details
+* ===============
+*
+* Based on contributions by
+* Jeff Rutter, Computer Science Division, University of California
+* at Berkeley, USA
+* Modified by Francoise Tisseur, University of Tennessee.
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ INTEGER COLTYP, CPP1, I, IDLMDA, INDX, INDXC, INDXP,
+ $ IQ2, IS, IW, IZ, K, N1, N2
+* ..
+* .. External Subroutines ..
+ EXTERNAL SCOPY, SLAED2, SLAED3, SLAMRG, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+*
+ IF( N.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN
+ INFO = -4
+ ELSE IF( MIN( 1, N / 2 ).GT.CUTPNT .OR. ( N / 2 ).LT.CUTPNT ) THEN
+ INFO = -7
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SLAED1', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+* The following values are integer pointers which indicate
+* the portion of the workspace
+* used by a particular array in SLAED2 and SLAED3.
+*
+ IZ = 1
+ IDLMDA = IZ + N
+ IW = IDLMDA + N
+ IQ2 = IW + N
+*
+ INDX = 1
+ INDXC = INDX + N
+ COLTYP = INDXC + N
+ INDXP = COLTYP + N
+*
+*
+* Form the z-vector which consists of the last row of Q_1 and the
+* first row of Q_2.
+*
+ CALL SCOPY( CUTPNT, Q( CUTPNT, 1 ), LDQ, WORK( IZ ), 1 )
+ CPP1 = CUTPNT + 1
+ CALL SCOPY( N-CUTPNT, Q( CPP1, CPP1 ), LDQ, WORK( IZ+CUTPNT ), 1 )
+*
+* Deflate eigenvalues.
+*
+ CALL SLAED2( K, N, CUTPNT, D, Q, LDQ, INDXQ, RHO, WORK( IZ ),
+ $ WORK( IDLMDA ), WORK( IW ), WORK( IQ2 ),
+ $ IWORK( INDX ), IWORK( INDXC ), IWORK( INDXP ),
+ $ IWORK( COLTYP ), INFO )
+*
+ IF( INFO.NE.0 )
+ $ GO TO 20
+*
+* Solve Secular Equation.
+*
+ IF( K.NE.0 ) THEN
+ IS = ( IWORK( COLTYP )+IWORK( COLTYP+1 ) )*CUTPNT +
+ $ ( IWORK( COLTYP+1 )+IWORK( COLTYP+2 ) )*( N-CUTPNT ) + IQ2
+ CALL SLAED3( K, N, CUTPNT, D, Q, LDQ, RHO, WORK( IDLMDA ),
+ $ WORK( IQ2 ), IWORK( INDXC ), IWORK( COLTYP ),
+ $ WORK( IW ), WORK( IS ), INFO )
+ IF( INFO.NE.0 )
+ $ GO TO 20
+*
+* Prepare the INDXQ sorting permutation.
+*
+ N1 = K
+ N2 = N - K
+ CALL SLAMRG( N1, N2, D, 1, -1, INDXQ )
+ ELSE
+ DO 10 I = 1, N
+ INDXQ( I ) = I
+ 10 CONTINUE
+ END IF
+*
+ 20 CONTINUE
+ RETURN
+*
+* End of SLAED1
+*
+ END
+ SUBROUTINE SLAED2( K, N, N1, D, Q, LDQ, INDXQ, RHO, Z, DLAMDA, W,
+ $ Q2, INDX, INDXC, INDXP, COLTYP, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, K, LDQ, N, N1
+ REAL RHO
+* ..
+* .. Array Arguments ..
+ INTEGER COLTYP( * ), INDX( * ), INDXC( * ), INDXP( * ),
+ $ INDXQ( * )
+ REAL D( * ), DLAMDA( * ), Q( LDQ, * ), Q2( * ),
+ $ W( * ), Z( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SLAED2 merges the two sets of eigenvalues together into a single
+* sorted set. Then it tries to deflate the size of the problem.
+* There are two ways in which deflation can occur: when two or more
+* eigenvalues are close together or if there is a tiny entry in the
+* Z vector. For each such occurrence the order of the related secular
+* equation problem is reduced by one.
+*
+* Arguments
+* =========
+*
+* K (output) INTEGER
+* The number of non-deflated eigenvalues, and the order of the
+* related secular equation. 0 <= K <=N.
+*
+* N (input) INTEGER
+* The dimension of the symmetric tridiagonal matrix. N >= 0.
+*
+* N1 (input) INTEGER
+* The location of the last eigenvalue in the leading sub-matrix.
+* min(1,N) <= N1 <= N/2.
+*
+* D (input/output) REAL array, dimension (N)
+* On entry, D contains the eigenvalues of the two submatrices to
+* be combined.
+* On exit, D contains the trailing (N-K) updated eigenvalues
+* (those which were deflated) sorted into increasing order.
+*
+* Q (input/output) REAL array, dimension (LDQ, N)
+* On entry, Q contains the eigenvectors of two submatrices in
+* the two square blocks with corners at (1,1), (N1,N1)
+* and (N1+1, N1+1), (N,N).
+* On exit, Q contains the trailing (N-K) updated eigenvectors
+* (those which were deflated) in its last N-K columns.
+*
+* LDQ (input) INTEGER
+* The leading dimension of the array Q. LDQ >= max(1,N).
+*
+* INDXQ (input/output) INTEGER array, dimension (N)
+* The permutation which separately sorts the two sub-problems
+* in D into ascending order. Note that elements in the second
+* half of this permutation must first have N1 added to their
+* values. Destroyed on exit.
+*
+* RHO (input/output) REAL
+* On entry, the off-diagonal element associated with the rank-1
+* cut which originally split the two submatrices which are now
+* being recombined.
+* On exit, RHO has been modified to the value required by
+* SLAED3.
+*
+* Z (input) REAL array, dimension (N)
+* On entry, Z contains the updating vector (the last
+* row of the first sub-eigenvector matrix and the first row of
+* the second sub-eigenvector matrix).
+* On exit, the contents of Z have been destroyed by the updating
+* process.
+*
+* DLAMDA (output) REAL array, dimension (N)
+* A copy of the first K eigenvalues which will be used by
+* SLAED3 to form the secular equation.
+*
+* W (output) REAL array, dimension (N)
+* The first k values of the final deflation-altered z-vector
+* which will be passed to SLAED3.
+*
+* Q2 (output) REAL array, dimension (N1**2+(N-N1)**2)
+* A copy of the first K eigenvectors which will be used by
+* SLAED3 in a matrix multiply (SGEMM) to solve for the new
+* eigenvectors.
+*
+* INDX (workspace) INTEGER array, dimension (N)
+* The permutation used to sort the contents of DLAMDA into
+* ascending order.
+*
+* INDXC (output) INTEGER array, dimension (N)
+* The permutation used to arrange the columns of the deflated
+* Q matrix into three groups: the first group contains non-zero
+* elements only at and above N1, the second contains
+* non-zero elements only below N1, and the third is dense.
+*
+* INDXP (workspace) INTEGER array, dimension (N)
+* The permutation used to place deflated values of D at the end
+* of the array. INDXP(1:K) points to the nondeflated D-values
+* and INDXP(K+1:N) points to the deflated eigenvalues.
+*
+* COLTYP (workspace/output) INTEGER array, dimension (N)
+* During execution, a label which will indicate which of the
+* following types a column in the Q2 matrix is:
+* 1 : non-zero in the upper half only;
+* 2 : dense;
+* 3 : non-zero in the lower half only;
+* 4 : deflated.
+* On exit, COLTYP(i) is the number of columns of type i,
+* for i=1 to 4 only.
+*
+* INFO (output) INTEGER
+* = 0: successful exit.
+* < 0: if INFO = -i, the i-th argument had an illegal value.
+*
+* Further Details
+* ===============
+*
+* Based on contributions by
+* Jeff Rutter, Computer Science Division, University of California
+* at Berkeley, USA
+* Modified by Francoise Tisseur, University of Tennessee.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL MONE, ZERO, ONE, TWO, EIGHT
+ PARAMETER ( MONE = -1.0E0, ZERO = 0.0E0, ONE = 1.0E0,
+ $ TWO = 2.0E0, EIGHT = 8.0E0 )
+* ..
+* .. Local Arrays ..
+ INTEGER CTOT( 4 ), PSM( 4 )
+* ..
+* .. Local Scalars ..
+ INTEGER CT, I, IMAX, IQ1, IQ2, J, JMAX, JS, K2, N1P1,
+ $ N2, NJ, PJ
+ REAL C, EPS, S, T, TAU, TOL
+* ..
+* .. External Functions ..
+ INTEGER ISAMAX
+ REAL SLAMCH, SLAPY2
+ EXTERNAL ISAMAX, SLAMCH, SLAPY2
+* ..
+* .. External Subroutines ..
+ EXTERNAL SCOPY, SLACPY, SLAMRG, SROT, SSCAL, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, MIN, SQRT
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+*
+ IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN
+ INFO = -6
+ ELSE IF( MIN( 1, ( N / 2 ) ).GT.N1 .OR. ( N / 2 ).LT.N1 ) THEN
+ INFO = -3
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SLAED2', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+ N2 = N - N1
+ N1P1 = N1 + 1
+*
+ IF( RHO.LT.ZERO ) THEN
+ CALL SSCAL( N2, MONE, Z( N1P1 ), 1 )
+ END IF
+*
+* Normalize z so that norm(z) = 1. Since z is the concatenation of
+* two normalized vectors, norm2(z) = sqrt(2).
+*
+ T = ONE / SQRT( TWO )
+ CALL SSCAL( N, T, Z, 1 )
+*
+* RHO = ABS( norm(z)**2 * RHO )
+*
+ RHO = ABS( TWO*RHO )
+*
+* Sort the eigenvalues into increasing order
+*
+ DO 10 I = N1P1, N
+ INDXQ( I ) = INDXQ( I ) + N1
+ 10 CONTINUE
+*
+* re-integrate the deflated parts from the last pass
+*
+ DO 20 I = 1, N
+ DLAMDA( I ) = D( INDXQ( I ) )
+ 20 CONTINUE
+ CALL SLAMRG( N1, N2, DLAMDA, 1, 1, INDXC )
+ DO 30 I = 1, N
+ INDX( I ) = INDXQ( INDXC( I ) )
+ 30 CONTINUE
+*
+* Calculate the allowable deflation tolerance
+*
+ IMAX = ISAMAX( N, Z, 1 )
+ JMAX = ISAMAX( N, D, 1 )
+ EPS = SLAMCH( 'Epsilon' )
+ TOL = EIGHT*EPS*MAX( ABS( D( JMAX ) ), ABS( Z( IMAX ) ) )
+*
+* If the rank-1 modifier is small enough, no more needs to be done
+* except to reorganize Q so that its columns correspond with the
+* elements in D.
+*
+ IF( RHO*ABS( Z( IMAX ) ).LE.TOL ) THEN
+ K = 0
+ IQ2 = 1
+ DO 40 J = 1, N
+ I = INDX( J )
+ CALL SCOPY( N, Q( 1, I ), 1, Q2( IQ2 ), 1 )
+ DLAMDA( J ) = D( I )
+ IQ2 = IQ2 + N
+ 40 CONTINUE
+ CALL SLACPY( 'A', N, N, Q2, N, Q, LDQ )
+ CALL SCOPY( N, DLAMDA, 1, D, 1 )
+ GO TO 190
+ END IF
+*
+* If there are multiple eigenvalues then the problem deflates. Here
+* the number of equal eigenvalues are found. As each equal
+* eigenvalue is found, an elementary reflector is computed to rotate
+* the corresponding eigensubspace so that the corresponding
+* components of Z are zero in this new basis.
+*
+ DO 50 I = 1, N1
+ COLTYP( I ) = 1
+ 50 CONTINUE
+ DO 60 I = N1P1, N
+ COLTYP( I ) = 3
+ 60 CONTINUE
+*
+*
+ K = 0
+ K2 = N + 1
+ DO 70 J = 1, N
+ NJ = INDX( J )
+ IF( RHO*ABS( Z( NJ ) ).LE.TOL ) THEN
+*
+* Deflate due to small z component.
+*
+ K2 = K2 - 1
+ COLTYP( NJ ) = 4
+ INDXP( K2 ) = NJ
+ IF( J.EQ.N )
+ $ GO TO 100
+ ELSE
+ PJ = NJ
+ GO TO 80
+ END IF
+ 70 CONTINUE
+ 80 CONTINUE
+ J = J + 1
+ NJ = INDX( J )
+ IF( J.GT.N )
+ $ GO TO 100
+ IF( RHO*ABS( Z( NJ ) ).LE.TOL ) THEN
+*
+* Deflate due to small z component.
+*
+ K2 = K2 - 1
+ COLTYP( NJ ) = 4
+ INDXP( K2 ) = NJ
+ ELSE
+*
+* Check if eigenvalues are close enough to allow deflation.
+*
+ S = Z( PJ )
+ C = Z( NJ )
+*
+* Find sqrt(a**2+b**2) without overflow or
+* destructive underflow.
+*
+ TAU = SLAPY2( C, S )
+ T = D( NJ ) - D( PJ )
+ C = C / TAU
+ S = -S / TAU
+ IF( ABS( T*C*S ).LE.TOL ) THEN
+*
+* Deflation is possible.
+*
+ Z( NJ ) = TAU
+ Z( PJ ) = ZERO
+ IF( COLTYP( NJ ).NE.COLTYP( PJ ) )
+ $ COLTYP( NJ ) = 2
+ COLTYP( PJ ) = 4
+ CALL SROT( N, Q( 1, PJ ), 1, Q( 1, NJ ), 1, C, S )
+ T = D( PJ )*C**2 + D( NJ )*S**2
+ D( NJ ) = D( PJ )*S**2 + D( NJ )*C**2
+ D( PJ ) = T
+ K2 = K2 - 1
+ I = 1
+ 90 CONTINUE
+ IF( K2+I.LE.N ) THEN
+ IF( D( PJ ).LT.D( INDXP( K2+I ) ) ) THEN
+ INDXP( K2+I-1 ) = INDXP( K2+I )
+ INDXP( K2+I ) = PJ
+ I = I + 1
+ GO TO 90
+ ELSE
+ INDXP( K2+I-1 ) = PJ
+ END IF
+ ELSE
+ INDXP( K2+I-1 ) = PJ
+ END IF
+ PJ = NJ
+ ELSE
+ K = K + 1
+ DLAMDA( K ) = D( PJ )
+ W( K ) = Z( PJ )
+ INDXP( K ) = PJ
+ PJ = NJ
+ END IF
+ END IF
+ GO TO 80
+ 100 CONTINUE
+*
+* Record the last eigenvalue.
+*
+ K = K + 1
+ DLAMDA( K ) = D( PJ )
+ W( K ) = Z( PJ )
+ INDXP( K ) = PJ
+*
+* Count up the total number of the various types of columns, then
+* form a permutation which positions the four column types into
+* four uniform groups (although one or more of these groups may be
+* empty).
+*
+ DO 110 J = 1, 4
+ CTOT( J ) = 0
+ 110 CONTINUE
+ DO 120 J = 1, N
+ CT = COLTYP( J )
+ CTOT( CT ) = CTOT( CT ) + 1
+ 120 CONTINUE
+*
+* PSM(*) = Position in SubMatrix (of types 1 through 4)
+*
+ PSM( 1 ) = 1
+ PSM( 2 ) = 1 + CTOT( 1 )
+ PSM( 3 ) = PSM( 2 ) + CTOT( 2 )
+ PSM( 4 ) = PSM( 3 ) + CTOT( 3 )
+ K = N - CTOT( 4 )
+*
+* Fill out the INDXC array so that the permutation which it induces
+* will place all type-1 columns first, all type-2 columns next,
+* then all type-3's, and finally all type-4's.
+*
+ DO 130 J = 1, N
+ JS = INDXP( J )
+ CT = COLTYP( JS )
+ INDX( PSM( CT ) ) = JS
+ INDXC( PSM( CT ) ) = J
+ PSM( CT ) = PSM( CT ) + 1
+ 130 CONTINUE
+*
+* Sort the eigenvalues and corresponding eigenvectors into DLAMDA
+* and Q2 respectively. The eigenvalues/vectors which were not
+* deflated go into the first K slots of DLAMDA and Q2 respectively,
+* while those which were deflated go into the last N - K slots.
+*
+ I = 1
+ IQ1 = 1
+ IQ2 = 1 + ( CTOT( 1 )+CTOT( 2 ) )*N1
+ DO 140 J = 1, CTOT( 1 )
+ JS = INDX( I )
+ CALL SCOPY( N1, Q( 1, JS ), 1, Q2( IQ1 ), 1 )
+ Z( I ) = D( JS )
+ I = I + 1
+ IQ1 = IQ1 + N1
+ 140 CONTINUE
+*
+ DO 150 J = 1, CTOT( 2 )
+ JS = INDX( I )
+ CALL SCOPY( N1, Q( 1, JS ), 1, Q2( IQ1 ), 1 )
+ CALL SCOPY( N2, Q( N1+1, JS ), 1, Q2( IQ2 ), 1 )
+ Z( I ) = D( JS )
+ I = I + 1
+ IQ1 = IQ1 + N1
+ IQ2 = IQ2 + N2
+ 150 CONTINUE
+*
+ DO 160 J = 1, CTOT( 3 )
+ JS = INDX( I )
+ CALL SCOPY( N2, Q( N1+1, JS ), 1, Q2( IQ2 ), 1 )
+ Z( I ) = D( JS )
+ I = I + 1
+ IQ2 = IQ2 + N2
+ 160 CONTINUE
+*
+ IQ1 = IQ2
+ DO 170 J = 1, CTOT( 4 )
+ JS = INDX( I )
+ CALL SCOPY( N, Q( 1, JS ), 1, Q2( IQ2 ), 1 )
+ IQ2 = IQ2 + N
+ Z( I ) = D( JS )
+ I = I + 1
+ 170 CONTINUE
+*
+* The deflated eigenvalues and their corresponding vectors go back
+* into the last N - K slots of D and Q respectively.
+*
+ CALL SLACPY( 'A', N, CTOT( 4 ), Q2( IQ1 ), N, Q( 1, K+1 ), LDQ )
+ CALL SCOPY( N-K, Z( K+1 ), 1, D( K+1 ), 1 )
+*
+* Copy CTOT into COLTYP for referencing in SLAED3.
+*
+ DO 180 J = 1, 4
+ COLTYP( J ) = CTOT( J )
+ 180 CONTINUE
+*
+ 190 CONTINUE
+ RETURN
+*
+* End of SLAED2
+*
+ END
+ SUBROUTINE SLAED3( K, N, N1, D, Q, LDQ, RHO, DLAMDA, Q2, INDX,
+ $ CTOT, W, S, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, K, LDQ, N, N1
+ REAL RHO
+* ..
+* .. Array Arguments ..
+ INTEGER CTOT( * ), INDX( * )
+ REAL D( * ), DLAMDA( * ), Q( LDQ, * ), Q2( * ),
+ $ S( * ), W( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SLAED3 finds the roots of the secular equation, as defined by the
+* values in D, W, and RHO, between 1 and K. It makes the
+* appropriate calls to SLAED4 and then updates the eigenvectors by
+* multiplying the matrix of eigenvectors of the pair of eigensystems
+* being combined by the matrix of eigenvectors of the K-by-K system
+* which is solved here.
+*
+* This code makes very mild assumptions about floating point
+* arithmetic. It will work on machines with a guard digit in
+* add/subtract, or on those binary machines without guard digits
+* which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2.
+* It could conceivably fail on hexadecimal or decimal machines
+* without guard digits, but we know of none.
+*
+* Arguments
+* =========
+*
+* K (input) INTEGER
+* The number of terms in the rational function to be solved by
+* SLAED4. K >= 0.
+*
+* N (input) INTEGER
+* The number of rows and columns in the Q matrix.
+* N >= K (deflation may result in N>K).
+*
+* N1 (input) INTEGER
+* The location of the last eigenvalue in the leading submatrix.
+* min(1,N) <= N1 <= N/2.
+*
+* D (output) REAL array, dimension (N)
+* D(I) contains the updated eigenvalues for
+* 1 <= I <= K.
+*
+* Q (output) REAL array, dimension (LDQ,N)
+* Initially the first K columns are used as workspace.
+* On output the columns 1 to K contain
+* the updated eigenvectors.
+*
+* LDQ (input) INTEGER
+* The leading dimension of the array Q. LDQ >= max(1,N).
+*
+* RHO (input) REAL
+* The value of the parameter in the rank one update equation.
+* RHO >= 0 required.
+*
+* DLAMDA (input/output) REAL array, dimension (K)
+* The first K elements of this array contain the old roots
+* of the deflated updating problem. These are the poles
+* of the secular equation. May be changed on output by
+* having lowest order bit set to zero on Cray X-MP, Cray Y-MP,
+* Cray-2, or Cray C-90, as described above.
+*
+* Q2 (input) REAL array, dimension (LDQ2, N)
+* The first K columns of this matrix contain the non-deflated
+* eigenvectors for the split problem.
+*
+* INDX (input) INTEGER array, dimension (N)
+* The permutation used to arrange the columns of the deflated
+* Q matrix into three groups (see SLAED2).
+* The rows of the eigenvectors found by SLAED4 must be likewise
+* permuted before the matrix multiply can take place.
+*
+* CTOT (input) INTEGER array, dimension (4)
+* A count of the total number of the various types of columns
+* in Q, as described in INDX. The fourth column type is any
+* column which has been deflated.
+*
+* W (input/output) REAL array, dimension (K)
+* The first K elements of this array contain the components
+* of the deflation-adjusted updating vector. Destroyed on
+* output.
+*
+* S (workspace) REAL array, dimension (N1 + 1)*K
+* Will contain the eigenvectors of the repaired matrix which
+* will be multiplied by the previously accumulated eigenvectors
+* to update the system.
+*
+* LDS (input) INTEGER
+* The leading dimension of S. LDS >= max(1,K).
+*
+* INFO (output) INTEGER
+* = 0: successful exit.
+* < 0: if INFO = -i, the i-th argument had an illegal value.
+* > 0: if INFO = 1, an eigenvalue did not converge
+*
+* Further Details
+* ===============
+*
+* Based on contributions by
+* Jeff Rutter, Computer Science Division, University of California
+* at Berkeley, USA
+* Modified by Francoise Tisseur, University of Tennessee.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ONE, ZERO
+ PARAMETER ( ONE = 1.0E0, ZERO = 0.0E0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, II, IQ2, J, N12, N2, N23
+ REAL TEMP
+* ..
+* .. External Functions ..
+ REAL SLAMC3, SNRM2
+ EXTERNAL SLAMC3, SNRM2
+* ..
+* .. External Subroutines ..
+ EXTERNAL SCOPY, SGEMM, SLACPY, SLAED4, SLASET, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, SIGN, SQRT
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+*
+ IF( K.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( N.LT.K ) THEN
+ INFO = -2
+ ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN
+ INFO = -6
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SLAED3', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( K.EQ.0 )
+ $ RETURN
+*
+* Modify values DLAMDA(i) to make sure all DLAMDA(i)-DLAMDA(j) can
+* be computed with high relative accuracy (barring over/underflow).
+* This is a problem on machines without a guard digit in
+* add/subtract (Cray XMP, Cray YMP, Cray C 90 and Cray 2).
+* The following code replaces DLAMDA(I) by 2*DLAMDA(I)-DLAMDA(I),
+* which on any of these machines zeros out the bottommost
+* bit of DLAMDA(I) if it is 1; this makes the subsequent
+* subtractions DLAMDA(I)-DLAMDA(J) unproblematic when cancellation
+* occurs. On binary machines with a guard digit (almost all
+* machines) it does not change DLAMDA(I) at all. On hexadecimal
+* and decimal machines with a guard digit, it slightly
+* changes the bottommost bits of DLAMDA(I). It does not account
+* for hexadecimal or decimal machines without guard digits
+* (we know of none). We use a subroutine call to compute
+* 2*DLAMBDA(I) to prevent optimizing compilers from eliminating
+* this code.
+*
+ DO 10 I = 1, K
+ DLAMDA( I ) = SLAMC3( DLAMDA( I ), DLAMDA( I ) ) - DLAMDA( I )
+ 10 CONTINUE
+*
+ DO 20 J = 1, K
+ CALL SLAED4( K, J, DLAMDA, W, Q( 1, J ), RHO, D( J ), INFO )
+*
+* If the zero finder fails, the computation is terminated.
+*
+ IF( INFO.NE.0 )
+ $ GO TO 120
+ 20 CONTINUE
+*
+ IF( K.EQ.1 )
+ $ GO TO 110
+ IF( K.EQ.2 ) THEN
+ DO 30 J = 1, K
+ W( 1 ) = Q( 1, J )
+ W( 2 ) = Q( 2, J )
+ II = INDX( 1 )
+ Q( 1, J ) = W( II )
+ II = INDX( 2 )
+ Q( 2, J ) = W( II )
+ 30 CONTINUE
+ GO TO 110
+ END IF
+*
+* Compute updated W.
+*
+ CALL SCOPY( K, W, 1, S, 1 )
+*
+* Initialize W(I) = Q(I,I)
+*
+ CALL SCOPY( K, Q, LDQ+1, W, 1 )
+ DO 60 J = 1, K
+ DO 40 I = 1, J - 1
+ W( I ) = W( I )*( Q( I, J ) / ( DLAMDA( I )-DLAMDA( J ) ) )
+ 40 CONTINUE
+ DO 50 I = J + 1, K
+ W( I ) = W( I )*( Q( I, J ) / ( DLAMDA( I )-DLAMDA( J ) ) )
+ 50 CONTINUE
+ 60 CONTINUE
+ DO 70 I = 1, K
+ W( I ) = SIGN( SQRT( -W( I ) ), S( I ) )
+ 70 CONTINUE
+*
+* Compute eigenvectors of the modified rank-1 modification.
+*
+ DO 100 J = 1, K
+ DO 80 I = 1, K
+ S( I ) = W( I ) / Q( I, J )
+ 80 CONTINUE
+ TEMP = SNRM2( K, S, 1 )
+ DO 90 I = 1, K
+ II = INDX( I )
+ Q( I, J ) = S( II ) / TEMP
+ 90 CONTINUE
+ 100 CONTINUE
+*
+* Compute the updated eigenvectors.
+*
+ 110 CONTINUE
+*
+ N2 = N - N1
+ N12 = CTOT( 1 ) + CTOT( 2 )
+ N23 = CTOT( 2 ) + CTOT( 3 )
+*
+ CALL SLACPY( 'A', N23, K, Q( CTOT( 1 )+1, 1 ), LDQ, S, N23 )
+ IQ2 = N1*N12 + 1
+ IF( N23.NE.0 ) THEN
+ CALL SGEMM( 'N', 'N', N2, K, N23, ONE, Q2( IQ2 ), N2, S, N23,
+ $ ZERO, Q( N1+1, 1 ), LDQ )
+ ELSE
+ CALL SLASET( 'A', N2, K, ZERO, ZERO, Q( N1+1, 1 ), LDQ )
+ END IF
+*
+ CALL SLACPY( 'A', N12, K, Q, LDQ, S, N12 )
+ IF( N12.NE.0 ) THEN
+ CALL SGEMM( 'N', 'N', N1, K, N12, ONE, Q2, N1, S, N12, ZERO, Q,
+ $ LDQ )
+ ELSE
+ CALL SLASET( 'A', N1, K, ZERO, ZERO, Q( 1, 1 ), LDQ )
+ END IF
+*
+*
+ 120 CONTINUE
+ RETURN
+*
+* End of SLAED3
+*
+ END
+ SUBROUTINE SLAED4( N, I, D, Z, DELTA, RHO, DLAM, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER I, INFO, N
+ REAL DLAM, RHO
+* ..
+* .. Array Arguments ..
+ REAL D( * ), DELTA( * ), Z( * )
+* ..
+*
+* Purpose
+* =======
+*
+* This subroutine computes the I-th updated eigenvalue of a symmetric
+* rank-one modification to a diagonal matrix whose elements are
+* given in the array d, and that
+*
+* D(i) < D(j) for i < j
+*
+* and that RHO > 0. This is arranged by the calling routine, and is
+* no loss in generality. The rank-one modified system is thus
+*
+* diag( D ) + RHO * Z * Z_transpose.
+*
+* where we assume the Euclidean norm of Z is 1.
+*
+* The method consists of approximating the rational functions in the
+* secular equation by simpler interpolating rational functions.
+*
+* Arguments
+* =========
+*
+* N (input) INTEGER
+* The length of all arrays.
+*
+* I (input) INTEGER
+* The index of the eigenvalue to be computed. 1 <= I <= N.
+*
+* D (input) REAL array, dimension (N)
+* The original eigenvalues. It is assumed that they are in
+* order, D(I) < D(J) for I < J.
+*
+* Z (input) REAL array, dimension (N)
+* The components of the updating vector.
+*
+* DELTA (output) REAL array, dimension (N)
+* If N .GT. 2, DELTA contains (D(j) - lambda_I) in its j-th
+* component. If N = 1, then DELTA(1) = 1. If N = 2, see SLAED5
+* for detail. The vector DELTA contains the information necessary
+* to construct the eigenvectors by SLAED3 and SLAED9.
+*
+* RHO (input) REAL
+* The scalar in the symmetric updating formula.
+*
+* DLAM (output) REAL
+* The computed lambda_I, the I-th updated eigenvalue.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* > 0: if INFO = 1, the updating process failed.
+*
+* Internal Parameters
+* ===================
+*
+* Logical variable ORGATI (origin-at-i?) is used for distinguishing
+* whether D(i) or D(i+1) is treated as the origin.
+*
+* ORGATI = .true. origin at i
+* ORGATI = .false. origin at i+1
+*
+* Logical variable SWTCH3 (switch-for-3-poles?) is for noting
+* if we are working with THREE poles!
+*
+* MAXIT is the maximum number of iterations allowed for each
+* eigenvalue.
+*
+* Further Details
+* ===============
+*
+* Based on contributions by
+* Ren-Cang Li, Computer Science Division, University of California
+* at Berkeley, USA
+*
+* =====================================================================
+*
+* .. Parameters ..
+ INTEGER MAXIT
+ PARAMETER ( MAXIT = 30 )
+ REAL ZERO, ONE, TWO, THREE, FOUR, EIGHT, TEN
+ PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0, TWO = 2.0E0,
+ $ THREE = 3.0E0, FOUR = 4.0E0, EIGHT = 8.0E0,
+ $ TEN = 10.0E0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL ORGATI, SWTCH, SWTCH3
+ INTEGER II, IIM1, IIP1, IP1, ITER, J, NITER
+ REAL A, B, C, DEL, DLTLB, DLTUB, DPHI, DPSI, DW,
+ $ EPS, ERRETM, ETA, MIDPT, PHI, PREW, PSI,
+ $ RHOINV, TAU, TEMP, TEMP1, W
+* ..
+* .. Local Arrays ..
+ REAL ZZ( 3 )
+* ..
+* .. External Functions ..
+ REAL SLAMCH
+ EXTERNAL SLAMCH
+* ..
+* .. External Subroutines ..
+ EXTERNAL SLAED5, SLAED6
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, MIN, SQRT
+* ..
+* .. Executable Statements ..
+*
+* Since this routine is called in an inner loop, we do no argument
+* checking.
+*
+* Quick return for N=1 and 2.
+*
+ INFO = 0
+ IF( N.EQ.1 ) THEN
+*
+* Presumably, I=1 upon entry
+*
+ DLAM = D( 1 ) + RHO*Z( 1 )*Z( 1 )
+ DELTA( 1 ) = ONE
+ RETURN
+ END IF
+ IF( N.EQ.2 ) THEN
+ CALL SLAED5( I, D, Z, DELTA, RHO, DLAM )
+ RETURN
+ END IF
+*
+* Compute machine epsilon
+*
+ EPS = SLAMCH( 'Epsilon' )
+ RHOINV = ONE / RHO
+*
+* The case I = N
+*
+ IF( I.EQ.N ) THEN
+*
+* Initialize some basic variables
+*
+ II = N - 1
+ NITER = 1
+*
+* Calculate initial guess
+*
+ MIDPT = RHO / TWO
+*
+* If ||Z||_2 is not one, then TEMP should be set to
+* RHO * ||Z||_2^2 / TWO
+*
+ DO 10 J = 1, N
+ DELTA( J ) = ( D( J )-D( I ) ) - MIDPT
+ 10 CONTINUE
+*
+ PSI = ZERO
+ DO 20 J = 1, N - 2
+ PSI = PSI + Z( J )*Z( J ) / DELTA( J )
+ 20 CONTINUE
+*
+ C = RHOINV + PSI
+ W = C + Z( II )*Z( II ) / DELTA( II ) +
+ $ Z( N )*Z( N ) / DELTA( N )
+*
+ IF( W.LE.ZERO ) THEN
+ TEMP = Z( N-1 )*Z( N-1 ) / ( D( N )-D( N-1 )+RHO ) +
+ $ Z( N )*Z( N ) / RHO
+ IF( C.LE.TEMP ) THEN
+ TAU = RHO
+ ELSE
+ DEL = D( N ) - D( N-1 )
+ A = -C*DEL + Z( N-1 )*Z( N-1 ) + Z( N )*Z( N )
+ B = Z( N )*Z( N )*DEL
+ IF( A.LT.ZERO ) THEN
+ TAU = TWO*B / ( SQRT( A*A+FOUR*B*C )-A )
+ ELSE
+ TAU = ( A+SQRT( A*A+FOUR*B*C ) ) / ( TWO*C )
+ END IF
+ END IF
+*
+* It can be proved that
+* D(N)+RHO/2 <= LAMBDA(N) < D(N)+TAU <= D(N)+RHO
+*
+ DLTLB = MIDPT
+ DLTUB = RHO
+ ELSE
+ DEL = D( N ) - D( N-1 )
+ A = -C*DEL + Z( N-1 )*Z( N-1 ) + Z( N )*Z( N )
+ B = Z( N )*Z( N )*DEL
+ IF( A.LT.ZERO ) THEN
+ TAU = TWO*B / ( SQRT( A*A+FOUR*B*C )-A )
+ ELSE
+ TAU = ( A+SQRT( A*A+FOUR*B*C ) ) / ( TWO*C )
+ END IF
+*
+* It can be proved that
+* D(N) < D(N)+TAU < LAMBDA(N) < D(N)+RHO/2
+*
+ DLTLB = ZERO
+ DLTUB = MIDPT
+ END IF
+*
+ DO 30 J = 1, N
+ DELTA( J ) = ( D( J )-D( I ) ) - TAU
+ 30 CONTINUE
+*
+* Evaluate PSI and the derivative DPSI
+*
+ DPSI = ZERO
+ PSI = ZERO
+ ERRETM = ZERO
+ DO 40 J = 1, II
+ TEMP = Z( J ) / DELTA( J )
+ PSI = PSI + Z( J )*TEMP
+ DPSI = DPSI + TEMP*TEMP
+ ERRETM = ERRETM + PSI
+ 40 CONTINUE
+ ERRETM = ABS( ERRETM )
+*
+* Evaluate PHI and the derivative DPHI
+*
+ TEMP = Z( N ) / DELTA( N )
+ PHI = Z( N )*TEMP
+ DPHI = TEMP*TEMP
+ ERRETM = EIGHT*( -PHI-PSI ) + ERRETM - PHI + RHOINV +
+ $ ABS( TAU )*( DPSI+DPHI )
+*
+ W = RHOINV + PHI + PSI
+*
+* Test for convergence
+*
+ IF( ABS( W ).LE.EPS*ERRETM ) THEN
+ DLAM = D( I ) + TAU
+ GO TO 250
+ END IF
+*
+ IF( W.LE.ZERO ) THEN
+ DLTLB = MAX( DLTLB, TAU )
+ ELSE
+ DLTUB = MIN( DLTUB, TAU )
+ END IF
+*
+* Calculate the new step
+*
+ NITER = NITER + 1
+ C = W - DELTA( N-1 )*DPSI - DELTA( N )*DPHI
+ A = ( DELTA( N-1 )+DELTA( N ) )*W -
+ $ DELTA( N-1 )*DELTA( N )*( DPSI+DPHI )
+ B = DELTA( N-1 )*DELTA( N )*W
+ IF( C.LT.ZERO )
+ $ C = ABS( C )
+ IF( C.EQ.ZERO ) THEN
+* ETA = B/A
+* ETA = RHO - TAU
+ ETA = DLTUB - TAU
+ ELSE IF( A.GE.ZERO ) THEN
+ ETA = ( A+SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C )
+ ELSE
+ ETA = TWO*B / ( A-SQRT( ABS( A*A-FOUR*B*C ) ) )
+ END IF
+*
+* Note, eta should be positive if w is negative, and
+* eta should be negative otherwise. However,
+* if for some reason caused by roundoff, eta*w > 0,
+* we simply use one Newton step instead. This way
+* will guarantee eta*w < 0.
+*
+ IF( W*ETA.GT.ZERO )
+ $ ETA = -W / ( DPSI+DPHI )
+ TEMP = TAU + ETA
+ IF( TEMP.GT.DLTUB .OR. TEMP.LT.DLTLB ) THEN
+ IF( W.LT.ZERO ) THEN
+ ETA = ( DLTUB-TAU ) / TWO
+ ELSE
+ ETA = ( DLTLB-TAU ) / TWO
+ END IF
+ END IF
+ DO 50 J = 1, N
+ DELTA( J ) = DELTA( J ) - ETA
+ 50 CONTINUE
+*
+ TAU = TAU + ETA
+*
+* Evaluate PSI and the derivative DPSI
+*
+ DPSI = ZERO
+ PSI = ZERO
+ ERRETM = ZERO
+ DO 60 J = 1, II
+ TEMP = Z( J ) / DELTA( J )
+ PSI = PSI + Z( J )*TEMP
+ DPSI = DPSI + TEMP*TEMP
+ ERRETM = ERRETM + PSI
+ 60 CONTINUE
+ ERRETM = ABS( ERRETM )
+*
+* Evaluate PHI and the derivative DPHI
+*
+ TEMP = Z( N ) / DELTA( N )
+ PHI = Z( N )*TEMP
+ DPHI = TEMP*TEMP
+ ERRETM = EIGHT*( -PHI-PSI ) + ERRETM - PHI + RHOINV +
+ $ ABS( TAU )*( DPSI+DPHI )
+*
+ W = RHOINV + PHI + PSI
+*
+* Main loop to update the values of the array DELTA
+*
+ ITER = NITER + 1
+*
+ DO 90 NITER = ITER, MAXIT
+*
+* Test for convergence
+*
+ IF( ABS( W ).LE.EPS*ERRETM ) THEN
+ DLAM = D( I ) + TAU
+ GO TO 250
+ END IF
+*
+ IF( W.LE.ZERO ) THEN
+ DLTLB = MAX( DLTLB, TAU )
+ ELSE
+ DLTUB = MIN( DLTUB, TAU )
+ END IF
+*
+* Calculate the new step
+*
+ C = W - DELTA( N-1 )*DPSI - DELTA( N )*DPHI
+ A = ( DELTA( N-1 )+DELTA( N ) )*W -
+ $ DELTA( N-1 )*DELTA( N )*( DPSI+DPHI )
+ B = DELTA( N-1 )*DELTA( N )*W
+ IF( A.GE.ZERO ) THEN
+ ETA = ( A+SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C )
+ ELSE
+ ETA = TWO*B / ( A-SQRT( ABS( A*A-FOUR*B*C ) ) )
+ END IF
+*
+* Note, eta should be positive if w is negative, and
+* eta should be negative otherwise. However,
+* if for some reason caused by roundoff, eta*w > 0,
+* we simply use one Newton step instead. This way
+* will guarantee eta*w < 0.
+*
+ IF( W*ETA.GT.ZERO )
+ $ ETA = -W / ( DPSI+DPHI )
+ TEMP = TAU + ETA
+ IF( TEMP.GT.DLTUB .OR. TEMP.LT.DLTLB ) THEN
+ IF( W.LT.ZERO ) THEN
+ ETA = ( DLTUB-TAU ) / TWO
+ ELSE
+ ETA = ( DLTLB-TAU ) / TWO
+ END IF
+ END IF
+ DO 70 J = 1, N
+ DELTA( J ) = DELTA( J ) - ETA
+ 70 CONTINUE
+*
+ TAU = TAU + ETA
+*
+* Evaluate PSI and the derivative DPSI
+*
+ DPSI = ZERO
+ PSI = ZERO
+ ERRETM = ZERO
+ DO 80 J = 1, II
+ TEMP = Z( J ) / DELTA( J )
+ PSI = PSI + Z( J )*TEMP
+ DPSI = DPSI + TEMP*TEMP
+ ERRETM = ERRETM + PSI
+ 80 CONTINUE
+ ERRETM = ABS( ERRETM )
+*
+* Evaluate PHI and the derivative DPHI
+*
+ TEMP = Z( N ) / DELTA( N )
+ PHI = Z( N )*TEMP
+ DPHI = TEMP*TEMP
+ ERRETM = EIGHT*( -PHI-PSI ) + ERRETM - PHI + RHOINV +
+ $ ABS( TAU )*( DPSI+DPHI )
+*
+ W = RHOINV + PHI + PSI
+ 90 CONTINUE
+*
+* Return with INFO = 1, NITER = MAXIT and not converged
+*
+ INFO = 1
+ DLAM = D( I ) + TAU
+ GO TO 250
+*
+* End for the case I = N
+*
+ ELSE
+*
+* The case for I < N
+*
+ NITER = 1
+ IP1 = I + 1
+*
+* Calculate initial guess
+*
+ DEL = D( IP1 ) - D( I )
+ MIDPT = DEL / TWO
+ DO 100 J = 1, N
+ DELTA( J ) = ( D( J )-D( I ) ) - MIDPT
+ 100 CONTINUE
+*
+ PSI = ZERO
+ DO 110 J = 1, I - 1
+ PSI = PSI + Z( J )*Z( J ) / DELTA( J )
+ 110 CONTINUE
+*
+ PHI = ZERO
+ DO 120 J = N, I + 2, -1
+ PHI = PHI + Z( J )*Z( J ) / DELTA( J )
+ 120 CONTINUE
+ C = RHOINV + PSI + PHI
+ W = C + Z( I )*Z( I ) / DELTA( I ) +
+ $ Z( IP1 )*Z( IP1 ) / DELTA( IP1 )
+*
+ IF( W.GT.ZERO ) THEN
+*
+* d(i)< the ith eigenvalue < (d(i)+d(i+1))/2
+*
+* We choose d(i) as origin.
+*
+ ORGATI = .TRUE.
+ A = C*DEL + Z( I )*Z( I ) + Z( IP1 )*Z( IP1 )
+ B = Z( I )*Z( I )*DEL
+ IF( A.GT.ZERO ) THEN
+ TAU = TWO*B / ( A+SQRT( ABS( A*A-FOUR*B*C ) ) )
+ ELSE
+ TAU = ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C )
+ END IF
+ DLTLB = ZERO
+ DLTUB = MIDPT
+ ELSE
+*
+* (d(i)+d(i+1))/2 <= the ith eigenvalue < d(i+1)
+*
+* We choose d(i+1) as origin.
+*
+ ORGATI = .FALSE.
+ A = C*DEL - Z( I )*Z( I ) - Z( IP1 )*Z( IP1 )
+ B = Z( IP1 )*Z( IP1 )*DEL
+ IF( A.LT.ZERO ) THEN
+ TAU = TWO*B / ( A-SQRT( ABS( A*A+FOUR*B*C ) ) )
+ ELSE
+ TAU = -( A+SQRT( ABS( A*A+FOUR*B*C ) ) ) / ( TWO*C )
+ END IF
+ DLTLB = -MIDPT
+ DLTUB = ZERO
+ END IF
+*
+ IF( ORGATI ) THEN
+ DO 130 J = 1, N
+ DELTA( J ) = ( D( J )-D( I ) ) - TAU
+ 130 CONTINUE
+ ELSE
+ DO 140 J = 1, N
+ DELTA( J ) = ( D( J )-D( IP1 ) ) - TAU
+ 140 CONTINUE
+ END IF
+ IF( ORGATI ) THEN
+ II = I
+ ELSE
+ II = I + 1
+ END IF
+ IIM1 = II - 1
+ IIP1 = II + 1
+*
+* Evaluate PSI and the derivative DPSI
+*
+ DPSI = ZERO
+ PSI = ZERO
+ ERRETM = ZERO
+ DO 150 J = 1, IIM1
+ TEMP = Z( J ) / DELTA( J )
+ PSI = PSI + Z( J )*TEMP
+ DPSI = DPSI + TEMP*TEMP
+ ERRETM = ERRETM + PSI
+ 150 CONTINUE
+ ERRETM = ABS( ERRETM )
+*
+* Evaluate PHI and the derivative DPHI
+*
+ DPHI = ZERO
+ PHI = ZERO
+ DO 160 J = N, IIP1, -1
+ TEMP = Z( J ) / DELTA( J )
+ PHI = PHI + Z( J )*TEMP
+ DPHI = DPHI + TEMP*TEMP
+ ERRETM = ERRETM + PHI
+ 160 CONTINUE
+*
+ W = RHOINV + PHI + PSI
+*
+* W is the value of the secular function with
+* its ii-th element removed.
+*
+ SWTCH3 = .FALSE.
+ IF( ORGATI ) THEN
+ IF( W.LT.ZERO )
+ $ SWTCH3 = .TRUE.
+ ELSE
+ IF( W.GT.ZERO )
+ $ SWTCH3 = .TRUE.
+ END IF
+ IF( II.EQ.1 .OR. II.EQ.N )
+ $ SWTCH3 = .FALSE.
+*
+ TEMP = Z( II ) / DELTA( II )
+ DW = DPSI + DPHI + TEMP*TEMP
+ TEMP = Z( II )*TEMP
+ W = W + TEMP
+ ERRETM = EIGHT*( PHI-PSI ) + ERRETM + TWO*RHOINV +
+ $ THREE*ABS( TEMP ) + ABS( TAU )*DW
+*
+* Test for convergence
+*
+ IF( ABS( W ).LE.EPS*ERRETM ) THEN
+ IF( ORGATI ) THEN
+ DLAM = D( I ) + TAU
+ ELSE
+ DLAM = D( IP1 ) + TAU
+ END IF
+ GO TO 250
+ END IF
+*
+ IF( W.LE.ZERO ) THEN
+ DLTLB = MAX( DLTLB, TAU )
+ ELSE
+ DLTUB = MIN( DLTUB, TAU )
+ END IF
+*
+* Calculate the new step
+*
+ NITER = NITER + 1
+ IF( .NOT.SWTCH3 ) THEN
+ IF( ORGATI ) THEN
+ C = W - DELTA( IP1 )*DW - ( D( I )-D( IP1 ) )*
+ $ ( Z( I ) / DELTA( I ) )**2
+ ELSE
+ C = W - DELTA( I )*DW - ( D( IP1 )-D( I ) )*
+ $ ( Z( IP1 ) / DELTA( IP1 ) )**2
+ END IF
+ A = ( DELTA( I )+DELTA( IP1 ) )*W -
+ $ DELTA( I )*DELTA( IP1 )*DW
+ B = DELTA( I )*DELTA( IP1 )*W
+ IF( C.EQ.ZERO ) THEN
+ IF( A.EQ.ZERO ) THEN
+ IF( ORGATI ) THEN
+ A = Z( I )*Z( I ) + DELTA( IP1 )*DELTA( IP1 )*
+ $ ( DPSI+DPHI )
+ ELSE
+ A = Z( IP1 )*Z( IP1 ) + DELTA( I )*DELTA( I )*
+ $ ( DPSI+DPHI )
+ END IF
+ END IF
+ ETA = B / A
+ ELSE IF( A.LE.ZERO ) THEN
+ ETA = ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C )
+ ELSE
+ ETA = TWO*B / ( A+SQRT( ABS( A*A-FOUR*B*C ) ) )
+ END IF
+ ELSE
+*
+* Interpolation using THREE most relevant poles
+*
+ TEMP = RHOINV + PSI + PHI
+ IF( ORGATI ) THEN
+ TEMP1 = Z( IIM1 ) / DELTA( IIM1 )
+ TEMP1 = TEMP1*TEMP1
+ C = TEMP - DELTA( IIP1 )*( DPSI+DPHI ) -
+ $ ( D( IIM1 )-D( IIP1 ) )*TEMP1
+ ZZ( 1 ) = Z( IIM1 )*Z( IIM1 )
+ ZZ( 3 ) = DELTA( IIP1 )*DELTA( IIP1 )*
+ $ ( ( DPSI-TEMP1 )+DPHI )
+ ELSE
+ TEMP1 = Z( IIP1 ) / DELTA( IIP1 )
+ TEMP1 = TEMP1*TEMP1
+ C = TEMP - DELTA( IIM1 )*( DPSI+DPHI ) -
+ $ ( D( IIP1 )-D( IIM1 ) )*TEMP1
+ ZZ( 1 ) = DELTA( IIM1 )*DELTA( IIM1 )*
+ $ ( DPSI+( DPHI-TEMP1 ) )
+ ZZ( 3 ) = Z( IIP1 )*Z( IIP1 )
+ END IF
+ ZZ( 2 ) = Z( II )*Z( II )
+ CALL SLAED6( NITER, ORGATI, C, DELTA( IIM1 ), ZZ, W, ETA,
+ $ INFO )
+ IF( INFO.NE.0 )
+ $ GO TO 250
+ END IF
+*
+* Note, eta should be positive if w is negative, and
+* eta should be negative otherwise. However,
+* if for some reason caused by roundoff, eta*w > 0,
+* we simply use one Newton step instead. This way
+* will guarantee eta*w < 0.
+*
+ IF( W*ETA.GE.ZERO )
+ $ ETA = -W / DW
+ TEMP = TAU + ETA
+ IF( TEMP.GT.DLTUB .OR. TEMP.LT.DLTLB ) THEN
+ IF( W.LT.ZERO ) THEN
+ ETA = ( DLTUB-TAU ) / TWO
+ ELSE
+ ETA = ( DLTLB-TAU ) / TWO
+ END IF
+ END IF
+*
+ PREW = W
+*
+ DO 180 J = 1, N
+ DELTA( J ) = DELTA( J ) - ETA
+ 180 CONTINUE
+*
+* Evaluate PSI and the derivative DPSI
+*
+ DPSI = ZERO
+ PSI = ZERO
+ ERRETM = ZERO
+ DO 190 J = 1, IIM1
+ TEMP = Z( J ) / DELTA( J )
+ PSI = PSI + Z( J )*TEMP
+ DPSI = DPSI + TEMP*TEMP
+ ERRETM = ERRETM + PSI
+ 190 CONTINUE
+ ERRETM = ABS( ERRETM )
+*
+* Evaluate PHI and the derivative DPHI
+*
+ DPHI = ZERO
+ PHI = ZERO
+ DO 200 J = N, IIP1, -1
+ TEMP = Z( J ) / DELTA( J )
+ PHI = PHI + Z( J )*TEMP
+ DPHI = DPHI + TEMP*TEMP
+ ERRETM = ERRETM + PHI
+ 200 CONTINUE
+*
+ TEMP = Z( II ) / DELTA( II )
+ DW = DPSI + DPHI + TEMP*TEMP
+ TEMP = Z( II )*TEMP
+ W = RHOINV + PHI + PSI + TEMP
+ ERRETM = EIGHT*( PHI-PSI ) + ERRETM + TWO*RHOINV +
+ $ THREE*ABS( TEMP ) + ABS( TAU+ETA )*DW
+*
+ SWTCH = .FALSE.
+ IF( ORGATI ) THEN
+ IF( -W.GT.ABS( PREW ) / TEN )
+ $ SWTCH = .TRUE.
+ ELSE
+ IF( W.GT.ABS( PREW ) / TEN )
+ $ SWTCH = .TRUE.
+ END IF
+*
+ TAU = TAU + ETA
+*
+* Main loop to update the values of the array DELTA
+*
+ ITER = NITER + 1
+*
+ DO 240 NITER = ITER, MAXIT
+*
+* Test for convergence
+*
+ IF( ABS( W ).LE.EPS*ERRETM ) THEN
+ IF( ORGATI ) THEN
+ DLAM = D( I ) + TAU
+ ELSE
+ DLAM = D( IP1 ) + TAU
+ END IF
+ GO TO 250
+ END IF
+*
+ IF( W.LE.ZERO ) THEN
+ DLTLB = MAX( DLTLB, TAU )
+ ELSE
+ DLTUB = MIN( DLTUB, TAU )
+ END IF
+*
+* Calculate the new step
+*
+ IF( .NOT.SWTCH3 ) THEN
+ IF( .NOT.SWTCH ) THEN
+ IF( ORGATI ) THEN
+ C = W - DELTA( IP1 )*DW -
+ $ ( D( I )-D( IP1 ) )*( Z( I ) / DELTA( I ) )**2
+ ELSE
+ C = W - DELTA( I )*DW - ( D( IP1 )-D( I ) )*
+ $ ( Z( IP1 ) / DELTA( IP1 ) )**2
+ END IF
+ ELSE
+ TEMP = Z( II ) / DELTA( II )
+ IF( ORGATI ) THEN
+ DPSI = DPSI + TEMP*TEMP
+ ELSE
+ DPHI = DPHI + TEMP*TEMP
+ END IF
+ C = W - DELTA( I )*DPSI - DELTA( IP1 )*DPHI
+ END IF
+ A = ( DELTA( I )+DELTA( IP1 ) )*W -
+ $ DELTA( I )*DELTA( IP1 )*DW
+ B = DELTA( I )*DELTA( IP1 )*W
+ IF( C.EQ.ZERO ) THEN
+ IF( A.EQ.ZERO ) THEN
+ IF( .NOT.SWTCH ) THEN
+ IF( ORGATI ) THEN
+ A = Z( I )*Z( I ) + DELTA( IP1 )*
+ $ DELTA( IP1 )*( DPSI+DPHI )
+ ELSE
+ A = Z( IP1 )*Z( IP1 ) +
+ $ DELTA( I )*DELTA( I )*( DPSI+DPHI )
+ END IF
+ ELSE
+ A = DELTA( I )*DELTA( I )*DPSI +
+ $ DELTA( IP1 )*DELTA( IP1 )*DPHI
+ END IF
+ END IF
+ ETA = B / A
+ ELSE IF( A.LE.ZERO ) THEN
+ ETA = ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C )
+ ELSE
+ ETA = TWO*B / ( A+SQRT( ABS( A*A-FOUR*B*C ) ) )
+ END IF
+ ELSE
+*
+* Interpolation using THREE most relevant poles
+*
+ TEMP = RHOINV + PSI + PHI
+ IF( SWTCH ) THEN
+ C = TEMP - DELTA( IIM1 )*DPSI - DELTA( IIP1 )*DPHI
+ ZZ( 1 ) = DELTA( IIM1 )*DELTA( IIM1 )*DPSI
+ ZZ( 3 ) = DELTA( IIP1 )*DELTA( IIP1 )*DPHI
+ ELSE
+ IF( ORGATI ) THEN
+ TEMP1 = Z( IIM1 ) / DELTA( IIM1 )
+ TEMP1 = TEMP1*TEMP1
+ C = TEMP - DELTA( IIP1 )*( DPSI+DPHI ) -
+ $ ( D( IIM1 )-D( IIP1 ) )*TEMP1
+ ZZ( 1 ) = Z( IIM1 )*Z( IIM1 )
+ ZZ( 3 ) = DELTA( IIP1 )*DELTA( IIP1 )*
+ $ ( ( DPSI-TEMP1 )+DPHI )
+ ELSE
+ TEMP1 = Z( IIP1 ) / DELTA( IIP1 )
+ TEMP1 = TEMP1*TEMP1
+ C = TEMP - DELTA( IIM1 )*( DPSI+DPHI ) -
+ $ ( D( IIP1 )-D( IIM1 ) )*TEMP1
+ ZZ( 1 ) = DELTA( IIM1 )*DELTA( IIM1 )*
+ $ ( DPSI+( DPHI-TEMP1 ) )
+ ZZ( 3 ) = Z( IIP1 )*Z( IIP1 )
+ END IF
+ END IF
+ CALL SLAED6( NITER, ORGATI, C, DELTA( IIM1 ), ZZ, W, ETA,
+ $ INFO )
+ IF( INFO.NE.0 )
+ $ GO TO 250
+ END IF
+*
+* Note, eta should be positive if w is negative, and
+* eta should be negative otherwise. However,
+* if for some reason caused by roundoff, eta*w > 0,
+* we simply use one Newton step instead. This way
+* will guarantee eta*w < 0.
+*
+ IF( W*ETA.GE.ZERO )
+ $ ETA = -W / DW
+ TEMP = TAU + ETA
+ IF( TEMP.GT.DLTUB .OR. TEMP.LT.DLTLB ) THEN
+ IF( W.LT.ZERO ) THEN
+ ETA = ( DLTUB-TAU ) / TWO
+ ELSE
+ ETA = ( DLTLB-TAU ) / TWO
+ END IF
+ END IF
+*
+ DO 210 J = 1, N
+ DELTA( J ) = DELTA( J ) - ETA
+ 210 CONTINUE
+*
+ TAU = TAU + ETA
+ PREW = W
+*
+* Evaluate PSI and the derivative DPSI
+*
+ DPSI = ZERO
+ PSI = ZERO
+ ERRETM = ZERO
+ DO 220 J = 1, IIM1
+ TEMP = Z( J ) / DELTA( J )
+ PSI = PSI + Z( J )*TEMP
+ DPSI = DPSI + TEMP*TEMP
+ ERRETM = ERRETM + PSI
+ 220 CONTINUE
+ ERRETM = ABS( ERRETM )
+*
+* Evaluate PHI and the derivative DPHI
+*
+ DPHI = ZERO
+ PHI = ZERO
+ DO 230 J = N, IIP1, -1
+ TEMP = Z( J ) / DELTA( J )
+ PHI = PHI + Z( J )*TEMP
+ DPHI = DPHI + TEMP*TEMP
+ ERRETM = ERRETM + PHI
+ 230 CONTINUE
+*
+ TEMP = Z( II ) / DELTA( II )
+ DW = DPSI + DPHI + TEMP*TEMP
+ TEMP = Z( II )*TEMP
+ W = RHOINV + PHI + PSI + TEMP
+ ERRETM = EIGHT*( PHI-PSI ) + ERRETM + TWO*RHOINV +
+ $ THREE*ABS( TEMP ) + ABS( TAU )*DW
+ IF( W*PREW.GT.ZERO .AND. ABS( W ).GT.ABS( PREW ) / TEN )
+ $ SWTCH = .NOT.SWTCH
+*
+ 240 CONTINUE
+*
+* Return with INFO = 1, NITER = MAXIT and not converged
+*
+ INFO = 1
+ IF( ORGATI ) THEN
+ DLAM = D( I ) + TAU
+ ELSE
+ DLAM = D( IP1 ) + TAU
+ END IF
+*
+ END IF
+*
+ 250 CONTINUE
+*
+ RETURN
+*
+* End of SLAED4
+*
+ END
+ SUBROUTINE SLAED5( I, D, Z, DELTA, RHO, DLAM )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER I
+ REAL DLAM, RHO
+* ..
+* .. Array Arguments ..
+ REAL D( 2 ), DELTA( 2 ), Z( 2 )
+* ..
+*
+* Purpose
+* =======
+*
+* This subroutine computes the I-th eigenvalue of a symmetric rank-one
+* modification of a 2-by-2 diagonal matrix
+*
+* diag( D ) + RHO * Z * transpose(Z) .
+*
+* The diagonal elements in the array D are assumed to satisfy
+*
+* D(i) < D(j) for i < j .
+*
+* We also assume RHO > 0 and that the Euclidean norm of the vector
+* Z is one.
+*
+* Arguments
+* =========
+*
+* I (input) INTEGER
+* The index of the eigenvalue to be computed. I = 1 or I = 2.
+*
+* D (input) REAL array, dimension (2)
+* The original eigenvalues. We assume D(1) < D(2).
+*
+* Z (input) REAL array, dimension (2)
+* The components of the updating vector.
+*
+* DELTA (output) REAL array, dimension (2)
+* The vector DELTA contains the information necessary
+* to construct the eigenvectors.
+*
+* RHO (input) REAL
+* The scalar in the symmetric updating formula.
+*
+* DLAM (output) REAL
+* The computed lambda_I, the I-th updated eigenvalue.
+*
+* Further Details
+* ===============
+*
+* Based on contributions by
+* Ren-Cang Li, Computer Science Division, University of California
+* at Berkeley, USA
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO, ONE, TWO, FOUR
+ PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0, TWO = 2.0E0,
+ $ FOUR = 4.0E0 )
+* ..
+* .. Local Scalars ..
+ REAL B, C, DEL, TAU, TEMP, W
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, SQRT
+* ..
+* .. Executable Statements ..
+*
+ DEL = D( 2 ) - D( 1 )
+ IF( I.EQ.1 ) THEN
+ W = ONE + TWO*RHO*( Z( 2 )*Z( 2 )-Z( 1 )*Z( 1 ) ) / DEL
+ IF( W.GT.ZERO ) THEN
+ B = DEL + RHO*( Z( 1 )*Z( 1 )+Z( 2 )*Z( 2 ) )
+ C = RHO*Z( 1 )*Z( 1 )*DEL
+*
+* B > ZERO, always
+*
+ TAU = TWO*C / ( B+SQRT( ABS( B*B-FOUR*C ) ) )
+ DLAM = D( 1 ) + TAU
+ DELTA( 1 ) = -Z( 1 ) / TAU
+ DELTA( 2 ) = Z( 2 ) / ( DEL-TAU )
+ ELSE
+ B = -DEL + RHO*( Z( 1 )*Z( 1 )+Z( 2 )*Z( 2 ) )
+ C = RHO*Z( 2 )*Z( 2 )*DEL
+ IF( B.GT.ZERO ) THEN
+ TAU = -TWO*C / ( B+SQRT( B*B+FOUR*C ) )
+ ELSE
+ TAU = ( B-SQRT( B*B+FOUR*C ) ) / TWO
+ END IF
+ DLAM = D( 2 ) + TAU
+ DELTA( 1 ) = -Z( 1 ) / ( DEL+TAU )
+ DELTA( 2 ) = -Z( 2 ) / TAU
+ END IF
+ TEMP = SQRT( DELTA( 1 )*DELTA( 1 )+DELTA( 2 )*DELTA( 2 ) )
+ DELTA( 1 ) = DELTA( 1 ) / TEMP
+ DELTA( 2 ) = DELTA( 2 ) / TEMP
+ ELSE
+*
+* Now I=2
+*
+ B = -DEL + RHO*( Z( 1 )*Z( 1 )+Z( 2 )*Z( 2 ) )
+ C = RHO*Z( 2 )*Z( 2 )*DEL
+ IF( B.GT.ZERO ) THEN
+ TAU = ( B+SQRT( B*B+FOUR*C ) ) / TWO
+ ELSE
+ TAU = TWO*C / ( -B+SQRT( B*B+FOUR*C ) )
+ END IF
+ DLAM = D( 2 ) + TAU
+ DELTA( 1 ) = -Z( 1 ) / ( DEL+TAU )
+ DELTA( 2 ) = -Z( 2 ) / TAU
+ TEMP = SQRT( DELTA( 1 )*DELTA( 1 )+DELTA( 2 )*DELTA( 2 ) )
+ DELTA( 1 ) = DELTA( 1 ) / TEMP
+ DELTA( 2 ) = DELTA( 2 ) / TEMP
+ END IF
+ RETURN
+*
+* End OF SLAED5
+*
+ END
+ SUBROUTINE SLAED6( KNITER, ORGATI, RHO, D, Z, FINIT, TAU, INFO )
+*
+* -- LAPACK routine (version 3.1.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* February 2007
+*
+* .. Scalar Arguments ..
+ LOGICAL ORGATI
+ INTEGER INFO, KNITER
+ REAL FINIT, RHO, TAU
+* ..
+* .. Array Arguments ..
+ REAL D( 3 ), Z( 3 )
+* ..
+*
+* Purpose
+* =======
+*
+* SLAED6 computes the positive or negative root (closest to the origin)
+* of
+* z(1) z(2) z(3)
+* f(x) = rho + --------- + ---------- + ---------
+* d(1)-x d(2)-x d(3)-x
+*
+* It is assumed that
+*
+* if ORGATI = .true. the root is between d(2) and d(3);
+* otherwise it is between d(1) and d(2)
+*
+* This routine will be called by SLAED4 when necessary. In most cases,
+* the root sought is the smallest in magnitude, though it might not be
+* in some extremely rare situations.
+*
+* Arguments
+* =========
+*
+* KNITER (input) INTEGER
+* Refer to SLAED4 for its significance.
+*
+* ORGATI (input) LOGICAL
+* If ORGATI is true, the needed root is between d(2) and
+* d(3); otherwise it is between d(1) and d(2). See
+* SLAED4 for further details.
+*
+* RHO (input) REAL
+* Refer to the equation f(x) above.
+*
+* D (input) REAL array, dimension (3)
+* D satisfies d(1) < d(2) < d(3).
+*
+* Z (input) REAL array, dimension (3)
+* Each of the elements in z must be positive.
+*
+* FINIT (input) REAL
+* The value of f at 0. It is more accurate than the one
+* evaluated inside this routine (if someone wants to do
+* so).
+*
+* TAU (output) REAL
+* The root of the equation f(x).
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* > 0: if INFO = 1, failure to converge
+*
+* Further Details
+* ===============
+*
+* 30/06/99: Based on contributions by
+* Ren-Cang Li, Computer Science Division, University of California
+* at Berkeley, USA
+*
+* 10/02/03: This version has a few statements commented out for thread safety
+* (machine parameters are computed on each entry). SJH.
+*
+* 05/10/06: Modified from a new version of Ren-Cang Li, use
+* Gragg-Thornton-Warner cubic convergent scheme for better stability.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ INTEGER MAXIT
+ PARAMETER ( MAXIT = 40 )
+ REAL ZERO, ONE, TWO, THREE, FOUR, EIGHT
+ PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0, TWO = 2.0E0,
+ $ THREE = 3.0E0, FOUR = 4.0E0, EIGHT = 8.0E0 )
+* ..
+* .. External Functions ..
+ REAL SLAMCH
+ EXTERNAL SLAMCH
+* ..
+* .. Local Arrays ..
+ REAL DSCALE( 3 ), ZSCALE( 3 )
+* ..
+* .. Local Scalars ..
+ LOGICAL SCALE
+ INTEGER I, ITER, NITER
+ REAL A, B, BASE, C, DDF, DF, EPS, ERRETM, ETA, F,
+ $ FC, SCLFAC, SCLINV, SMALL1, SMALL2, SMINV1,
+ $ SMINV2, TEMP, TEMP1, TEMP2, TEMP3, TEMP4,
+ $ LBD, UBD
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, INT, LOG, MAX, MIN, SQRT
+* ..
+* .. Executable Statements ..
+*
+ INFO = 0
+*
+ IF( ORGATI ) THEN
+ LBD = D(2)
+ UBD = D(3)
+ ELSE
+ LBD = D(1)
+ UBD = D(2)
+ END IF
+ IF( FINIT .LT. ZERO )THEN
+ LBD = ZERO
+ ELSE
+ UBD = ZERO
+ END IF
+*
+ NITER = 1
+ TAU = ZERO
+ IF( KNITER.EQ.2 ) THEN
+ IF( ORGATI ) THEN
+ TEMP = ( D( 3 )-D( 2 ) ) / TWO
+ C = RHO + Z( 1 ) / ( ( D( 1 )-D( 2 ) )-TEMP )
+ A = C*( D( 2 )+D( 3 ) ) + Z( 2 ) + Z( 3 )
+ B = C*D( 2 )*D( 3 ) + Z( 2 )*D( 3 ) + Z( 3 )*D( 2 )
+ ELSE
+ TEMP = ( D( 1 )-D( 2 ) ) / TWO
+ C = RHO + Z( 3 ) / ( ( D( 3 )-D( 2 ) )-TEMP )
+ A = C*( D( 1 )+D( 2 ) ) + Z( 1 ) + Z( 2 )
+ B = C*D( 1 )*D( 2 ) + Z( 1 )*D( 2 ) + Z( 2 )*D( 1 )
+ END IF
+ TEMP = MAX( ABS( A ), ABS( B ), ABS( C ) )
+ A = A / TEMP
+ B = B / TEMP
+ C = C / TEMP
+ IF( C.EQ.ZERO ) THEN
+ TAU = B / A
+ ELSE IF( A.LE.ZERO ) THEN
+ TAU = ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C )
+ ELSE
+ TAU = TWO*B / ( A+SQRT( ABS( A*A-FOUR*B*C ) ) )
+ END IF
+ IF( TAU .LT. LBD .OR. TAU .GT. UBD )
+ $ TAU = ( LBD+UBD )/TWO
+ IF( D(1).EQ.TAU .OR. D(2).EQ.TAU .OR. D(3).EQ.TAU ) THEN
+ TAU = ZERO
+ ELSE
+ TEMP = FINIT + TAU*Z(1)/( D(1)*( D( 1 )-TAU ) ) +
+ $ TAU*Z(2)/( D(2)*( D( 2 )-TAU ) ) +
+ $ TAU*Z(3)/( D(3)*( D( 3 )-TAU ) )
+ IF( TEMP .LE. ZERO )THEN
+ LBD = TAU
+ ELSE
+ UBD = TAU
+ END IF
+ IF( ABS( FINIT ).LE.ABS( TEMP ) )
+ $ TAU = ZERO
+ END IF
+ END IF
+*
+* get machine parameters for possible scaling to avoid overflow
+*
+* modified by Sven: parameters SMALL1, SMINV1, SMALL2,
+* SMINV2, EPS are not SAVEd anymore between one call to the
+* others but recomputed at each call
+*
+ EPS = SLAMCH( 'Epsilon' )
+ BASE = SLAMCH( 'Base' )
+ SMALL1 = BASE**( INT( LOG( SLAMCH( 'SafMin' ) ) / LOG( BASE ) /
+ $ THREE ) )
+ SMINV1 = ONE / SMALL1
+ SMALL2 = SMALL1*SMALL1
+ SMINV2 = SMINV1*SMINV1
+*
+* Determine if scaling of inputs necessary to avoid overflow
+* when computing 1/TEMP**3
+*
+ IF( ORGATI ) THEN
+ TEMP = MIN( ABS( D( 2 )-TAU ), ABS( D( 3 )-TAU ) )
+ ELSE
+ TEMP = MIN( ABS( D( 1 )-TAU ), ABS( D( 2 )-TAU ) )
+ END IF
+ SCALE = .FALSE.
+ IF( TEMP.LE.SMALL1 ) THEN
+ SCALE = .TRUE.
+ IF( TEMP.LE.SMALL2 ) THEN
+*
+* Scale up by power of radix nearest 1/SAFMIN**(2/3)
+*
+ SCLFAC = SMINV2
+ SCLINV = SMALL2
+ ELSE
+*
+* Scale up by power of radix nearest 1/SAFMIN**(1/3)
+*
+ SCLFAC = SMINV1
+ SCLINV = SMALL1
+ END IF
+*
+* Scaling up safe because D, Z, TAU scaled elsewhere to be O(1)
+*
+ DO 10 I = 1, 3
+ DSCALE( I ) = D( I )*SCLFAC
+ ZSCALE( I ) = Z( I )*SCLFAC
+ 10 CONTINUE
+ TAU = TAU*SCLFAC
+ LBD = LBD*SCLFAC
+ UBD = UBD*SCLFAC
+ ELSE
+*
+* Copy D and Z to DSCALE and ZSCALE
+*
+ DO 20 I = 1, 3
+ DSCALE( I ) = D( I )
+ ZSCALE( I ) = Z( I )
+ 20 CONTINUE
+ END IF
+*
+ FC = ZERO
+ DF = ZERO
+ DDF = ZERO
+ DO 30 I = 1, 3
+ TEMP = ONE / ( DSCALE( I )-TAU )
+ TEMP1 = ZSCALE( I )*TEMP
+ TEMP2 = TEMP1*TEMP
+ TEMP3 = TEMP2*TEMP
+ FC = FC + TEMP1 / DSCALE( I )
+ DF = DF + TEMP2
+ DDF = DDF + TEMP3
+ 30 CONTINUE
+ F = FINIT + TAU*FC
+*
+ IF( ABS( F ).LE.ZERO )
+ $ GO TO 60
+ IF( F .LE. ZERO )THEN
+ LBD = TAU
+ ELSE
+ UBD = TAU
+ END IF
+*
+* Iteration begins -- Use Gragg-Thornton-Warner cubic convergent
+* scheme
+*
+* It is not hard to see that
+*
+* 1) Iterations will go up monotonically
+* if FINIT < 0;
+*
+* 2) Iterations will go down monotonically
+* if FINIT > 0.
+*
+ ITER = NITER + 1
+*
+ DO 50 NITER = ITER, MAXIT
+*
+ IF( ORGATI ) THEN
+ TEMP1 = DSCALE( 2 ) - TAU
+ TEMP2 = DSCALE( 3 ) - TAU
+ ELSE
+ TEMP1 = DSCALE( 1 ) - TAU
+ TEMP2 = DSCALE( 2 ) - TAU
+ END IF
+ A = ( TEMP1+TEMP2 )*F - TEMP1*TEMP2*DF
+ B = TEMP1*TEMP2*F
+ C = F - ( TEMP1+TEMP2 )*DF + TEMP1*TEMP2*DDF
+ TEMP = MAX( ABS( A ), ABS( B ), ABS( C ) )
+ A = A / TEMP
+ B = B / TEMP
+ C = C / TEMP
+ IF( C.EQ.ZERO ) THEN
+ ETA = B / A
+ ELSE IF( A.LE.ZERO ) THEN
+ ETA = ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C )
+ ELSE
+ ETA = TWO*B / ( A+SQRT( ABS( A*A-FOUR*B*C ) ) )
+ END IF
+ IF( F*ETA.GE.ZERO ) THEN
+ ETA = -F / DF
+ END IF
+*
+ TAU = TAU + ETA
+ IF( TAU .LT. LBD .OR. TAU .GT. UBD )
+ $ TAU = ( LBD + UBD )/TWO
+*
+ FC = ZERO
+ ERRETM = ZERO
+ DF = ZERO
+ DDF = ZERO
+ DO 40 I = 1, 3
+ TEMP = ONE / ( DSCALE( I )-TAU )
+ TEMP1 = ZSCALE( I )*TEMP
+ TEMP2 = TEMP1*TEMP
+ TEMP3 = TEMP2*TEMP
+ TEMP4 = TEMP1 / DSCALE( I )
+ FC = FC + TEMP4
+ ERRETM = ERRETM + ABS( TEMP4 )
+ DF = DF + TEMP2
+ DDF = DDF + TEMP3
+ 40 CONTINUE
+ F = FINIT + TAU*FC
+ ERRETM = EIGHT*( ABS( FINIT )+ABS( TAU )*ERRETM ) +
+ $ ABS( TAU )*DF
+ IF( ABS( F ).LE.EPS*ERRETM )
+ $ GO TO 60
+ IF( F .LE. ZERO )THEN
+ LBD = TAU
+ ELSE
+ UBD = TAU
+ END IF
+ 50 CONTINUE
+ INFO = 1
+ 60 CONTINUE
+*
+* Undo scaling
+*
+ IF( SCALE )
+ $ TAU = TAU*SCLINV
+ RETURN
+*
+* End of SLAED6
+*
+ END
+ SUBROUTINE SLAED7( ICOMPQ, N, QSIZ, TLVLS, CURLVL, CURPBM, D, Q,
+ $ LDQ, INDXQ, RHO, CUTPNT, QSTORE, QPTR, PRMPTR,
+ $ PERM, GIVPTR, GIVCOL, GIVNUM, WORK, IWORK,
+ $ INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER CURLVL, CURPBM, CUTPNT, ICOMPQ, INFO, LDQ, N,
+ $ QSIZ, TLVLS
+ REAL RHO
+* ..
+* .. Array Arguments ..
+ INTEGER GIVCOL( 2, * ), GIVPTR( * ), INDXQ( * ),
+ $ IWORK( * ), PERM( * ), PRMPTR( * ), QPTR( * )
+ REAL D( * ), GIVNUM( 2, * ), Q( LDQ, * ),
+ $ QSTORE( * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SLAED7 computes the updated eigensystem of a diagonal
+* matrix after modification by a rank-one symmetric matrix. This
+* routine is used only for the eigenproblem which requires all
+* eigenvalues and optionally eigenvectors of a dense symmetric matrix
+* that has been reduced to tridiagonal form. SLAED1 handles
+* the case in which all eigenvalues and eigenvectors of a symmetric
+* tridiagonal matrix are desired.
+*
+* T = Q(in) ( D(in) + RHO * Z*Z' ) Q'(in) = Q(out) * D(out) * Q'(out)
+*
+* where Z = Q'u, u is a vector of length N with ones in the
+* CUTPNT and CUTPNT + 1 th elements and zeros elsewhere.
+*
+* The eigenvectors of the original matrix are stored in Q, and the
+* eigenvalues are in D. The algorithm consists of three stages:
+*
+* The first stage consists of deflating the size of the problem
+* when there are multiple eigenvalues or if there is a zero in
+* the Z vector. For each such occurence the dimension of the
+* secular equation problem is reduced by one. This stage is
+* performed by the routine SLAED8.
+*
+* The second stage consists of calculating the updated
+* eigenvalues. This is done by finding the roots of the secular
+* equation via the routine SLAED4 (as called by SLAED9).
+* This routine also calculates the eigenvectors of the current
+* problem.
+*
+* The final stage consists of computing the updated eigenvectors
+* directly using the updated eigenvalues. The eigenvectors for
+* the current problem are multiplied with the eigenvectors from
+* the overall problem.
+*
+* Arguments
+* =========
+*
+* ICOMPQ (input) INTEGER
+* = 0: Compute eigenvalues only.
+* = 1: Compute eigenvectors of original dense symmetric matrix
+* also. On entry, Q contains the orthogonal matrix used
+* to reduce the original matrix to tridiagonal form.
+*
+* N (input) INTEGER
+* The dimension of the symmetric tridiagonal matrix. N >= 0.
+*
+* QSIZ (input) INTEGER
+* The dimension of the orthogonal matrix used to reduce
+* the full matrix to tridiagonal form. QSIZ >= N if ICOMPQ = 1.
+*
+* TLVLS (input) INTEGER
+* The total number of merging levels in the overall divide and
+* conquer tree.
+*
+* CURLVL (input) INTEGER
+* The current level in the overall merge routine,
+* 0 <= CURLVL <= TLVLS.
+*
+* CURPBM (input) INTEGER
+* The current problem in the current level in the overall
+* merge routine (counting from upper left to lower right).
+*
+* D (input/output) REAL array, dimension (N)
+* On entry, the eigenvalues of the rank-1-perturbed matrix.
+* On exit, the eigenvalues of the repaired matrix.
+*
+* Q (input/output) REAL array, dimension (LDQ, N)
+* On entry, the eigenvectors of the rank-1-perturbed matrix.
+* On exit, the eigenvectors of the repaired tridiagonal matrix.
+*
+* LDQ (input) INTEGER
+* The leading dimension of the array Q. LDQ >= max(1,N).
+*
+* INDXQ (output) INTEGER array, dimension (N)
+* The permutation which will reintegrate the subproblem just
+* solved back into sorted order, i.e., D( INDXQ( I = 1, N ) )
+* will be in ascending order.
+*
+* RHO (input) REAL
+* The subdiagonal element used to create the rank-1
+* modification.
+*
+* CUTPNT (input) INTEGER
+* Contains the location of the last eigenvalue in the leading
+* sub-matrix. min(1,N) <= CUTPNT <= N.
+*
+* QSTORE (input/output) REAL array, dimension (N**2+1)
+* Stores eigenvectors of submatrices encountered during
+* divide and conquer, packed together. QPTR points to
+* beginning of the submatrices.
+*
+* QPTR (input/output) INTEGER array, dimension (N+2)
+* List of indices pointing to beginning of submatrices stored
+* in QSTORE. The submatrices are numbered starting at the
+* bottom left of the divide and conquer tree, from left to
+* right and bottom to top.
+*
+* PRMPTR (input) INTEGER array, dimension (N lg N)
+* Contains a list of pointers which indicate where in PERM a
+* level's permutation is stored. PRMPTR(i+1) - PRMPTR(i)
+* indicates the size of the permutation and also the size of
+* the full, non-deflated problem.
+*
+* PERM (input) INTEGER array, dimension (N lg N)
+* Contains the permutations (from deflation and sorting) to be
+* applied to each eigenblock.
+*
+* GIVPTR (input) INTEGER array, dimension (N lg N)
+* Contains a list of pointers which indicate where in GIVCOL a
+* level's Givens rotations are stored. GIVPTR(i+1) - GIVPTR(i)
+* indicates the number of Givens rotations.
+*
+* GIVCOL (input) INTEGER array, dimension (2, N lg N)
+* Each pair of numbers indicates a pair of columns to take place
+* in a Givens rotation.
+*
+* GIVNUM (input) REAL array, dimension (2, N lg N)
+* Each number indicates the S value to be used in the
+* corresponding Givens rotation.
+*
+* WORK (workspace) REAL array, dimension (3*N+QSIZ*N)
+*
+* IWORK (workspace) INTEGER array, dimension (4*N)
+*
+* INFO (output) INTEGER
+* = 0: successful exit.
+* < 0: if INFO = -i, the i-th argument had an illegal value.
+* > 0: if INFO = 1, an eigenvalue did not converge
+*
+* Further Details
+* ===============
+*
+* Based on contributions by
+* Jeff Rutter, Computer Science Division, University of California
+* at Berkeley, USA
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ONE, ZERO
+ PARAMETER ( ONE = 1.0E0, ZERO = 0.0E0 )
+* ..
+* .. Local Scalars ..
+ INTEGER COLTYP, CURR, I, IDLMDA, INDX, INDXC, INDXP,
+ $ IQ2, IS, IW, IZ, K, LDQ2, N1, N2, PTR
+* ..
+* .. External Subroutines ..
+ EXTERNAL SGEMM, SLAED8, SLAED9, SLAEDA, SLAMRG, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+*
+ IF( ICOMPQ.LT.0 .OR. ICOMPQ.GT.1 ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( ICOMPQ.EQ.1 .AND. QSIZ.LT.N ) THEN
+ INFO = -4
+ ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN
+ INFO = -9
+ ELSE IF( MIN( 1, N ).GT.CUTPNT .OR. N.LT.CUTPNT ) THEN
+ INFO = -12
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SLAED7', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+* The following values are for bookkeeping purposes only. They are
+* integer pointers which indicate the portion of the workspace
+* used by a particular array in SLAED8 and SLAED9.
+*
+ IF( ICOMPQ.EQ.1 ) THEN
+ LDQ2 = QSIZ
+ ELSE
+ LDQ2 = N
+ END IF
+*
+ IZ = 1
+ IDLMDA = IZ + N
+ IW = IDLMDA + N
+ IQ2 = IW + N
+ IS = IQ2 + N*LDQ2
+*
+ INDX = 1
+ INDXC = INDX + N
+ COLTYP = INDXC + N
+ INDXP = COLTYP + N
+*
+* Form the z-vector which consists of the last row of Q_1 and the
+* first row of Q_2.
+*
+ PTR = 1 + 2**TLVLS
+ DO 10 I = 1, CURLVL - 1
+ PTR = PTR + 2**( TLVLS-I )
+ 10 CONTINUE
+ CURR = PTR + CURPBM
+ CALL SLAEDA( N, TLVLS, CURLVL, CURPBM, PRMPTR, PERM, GIVPTR,
+ $ GIVCOL, GIVNUM, QSTORE, QPTR, WORK( IZ ),
+ $ WORK( IZ+N ), INFO )
+*
+* When solving the final problem, we no longer need the stored data,
+* so we will overwrite the data from this level onto the previously
+* used storage space.
+*
+ IF( CURLVL.EQ.TLVLS ) THEN
+ QPTR( CURR ) = 1
+ PRMPTR( CURR ) = 1
+ GIVPTR( CURR ) = 1
+ END IF
+*
+* Sort and Deflate eigenvalues.
+*
+ CALL SLAED8( ICOMPQ, K, N, QSIZ, D, Q, LDQ, INDXQ, RHO, CUTPNT,
+ $ WORK( IZ ), WORK( IDLMDA ), WORK( IQ2 ), LDQ2,
+ $ WORK( IW ), PERM( PRMPTR( CURR ) ), GIVPTR( CURR+1 ),
+ $ GIVCOL( 1, GIVPTR( CURR ) ),
+ $ GIVNUM( 1, GIVPTR( CURR ) ), IWORK( INDXP ),
+ $ IWORK( INDX ), INFO )
+ PRMPTR( CURR+1 ) = PRMPTR( CURR ) + N
+ GIVPTR( CURR+1 ) = GIVPTR( CURR+1 ) + GIVPTR( CURR )
+*
+* Solve Secular Equation.
+*
+ IF( K.NE.0 ) THEN
+ CALL SLAED9( K, 1, K, N, D, WORK( IS ), K, RHO, WORK( IDLMDA ),
+ $ WORK( IW ), QSTORE( QPTR( CURR ) ), K, INFO )
+ IF( INFO.NE.0 )
+ $ GO TO 30
+ IF( ICOMPQ.EQ.1 ) THEN
+ CALL SGEMM( 'N', 'N', QSIZ, K, K, ONE, WORK( IQ2 ), LDQ2,
+ $ QSTORE( QPTR( CURR ) ), K, ZERO, Q, LDQ )
+ END IF
+ QPTR( CURR+1 ) = QPTR( CURR ) + K**2
+*
+* Prepare the INDXQ sorting permutation.
+*
+ N1 = K
+ N2 = N - K
+ CALL SLAMRG( N1, N2, D, 1, -1, INDXQ )
+ ELSE
+ QPTR( CURR+1 ) = QPTR( CURR )
+ DO 20 I = 1, N
+ INDXQ( I ) = I
+ 20 CONTINUE
+ END IF
+*
+ 30 CONTINUE
+ RETURN
+*
+* End of SLAED7
+*
+ END
+ SUBROUTINE SLAED8( ICOMPQ, K, N, QSIZ, D, Q, LDQ, INDXQ, RHO,
+ $ CUTPNT, Z, DLAMDA, Q2, LDQ2, W, PERM, GIVPTR,
+ $ GIVCOL, GIVNUM, INDXP, INDX, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER CUTPNT, GIVPTR, ICOMPQ, INFO, K, LDQ, LDQ2, N,
+ $ QSIZ
+ REAL RHO
+* ..
+* .. Array Arguments ..
+ INTEGER GIVCOL( 2, * ), INDX( * ), INDXP( * ),
+ $ INDXQ( * ), PERM( * )
+ REAL D( * ), DLAMDA( * ), GIVNUM( 2, * ),
+ $ Q( LDQ, * ), Q2( LDQ2, * ), W( * ), Z( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SLAED8 merges the two sets of eigenvalues together into a single
+* sorted set. Then it tries to deflate the size of the problem.
+* There are two ways in which deflation can occur: when two or more
+* eigenvalues are close together or if there is a tiny element in the
+* Z vector. For each such occurrence the order of the related secular
+* equation problem is reduced by one.
+*
+* Arguments
+* =========
+*
+* ICOMPQ (input) INTEGER
+* = 0: Compute eigenvalues only.
+* = 1: Compute eigenvectors of original dense symmetric matrix
+* also. On entry, Q contains the orthogonal matrix used
+* to reduce the original matrix to tridiagonal form.
+*
+* K (output) INTEGER
+* The number of non-deflated eigenvalues, and the order of the
+* related secular equation.
+*
+* N (input) INTEGER
+* The dimension of the symmetric tridiagonal matrix. N >= 0.
+*
+* QSIZ (input) INTEGER
+* The dimension of the orthogonal matrix used to reduce
+* the full matrix to tridiagonal form. QSIZ >= N if ICOMPQ = 1.
+*
+* D (input/output) REAL array, dimension (N)
+* On entry, the eigenvalues of the two submatrices to be
+* combined. On exit, the trailing (N-K) updated eigenvalues
+* (those which were deflated) sorted into increasing order.
+*
+* Q (input/output) REAL array, dimension (LDQ,N)
+* If ICOMPQ = 0, Q is not referenced. Otherwise,
+* on entry, Q contains the eigenvectors of the partially solved
+* system which has been previously updated in matrix
+* multiplies with other partially solved eigensystems.
+* On exit, Q contains the trailing (N-K) updated eigenvectors
+* (those which were deflated) in its last N-K columns.
+*
+* LDQ (input) INTEGER
+* The leading dimension of the array Q. LDQ >= max(1,N).
+*
+* INDXQ (input) INTEGER array, dimension (N)
+* The permutation which separately sorts the two sub-problems
+* in D into ascending order. Note that elements in the second
+* half of this permutation must first have CUTPNT added to
+* their values in order to be accurate.
+*
+* RHO (input/output) REAL
+* On entry, the off-diagonal element associated with the rank-1
+* cut which originally split the two submatrices which are now
+* being recombined.
+* On exit, RHO has been modified to the value required by
+* SLAED3.
+*
+* CUTPNT (input) INTEGER
+* The location of the last eigenvalue in the leading
+* sub-matrix. min(1,N) <= CUTPNT <= N.
+*
+* Z (input) REAL array, dimension (N)
+* On entry, Z contains the updating vector (the last row of
+* the first sub-eigenvector matrix and the first row of the
+* second sub-eigenvector matrix).
+* On exit, the contents of Z are destroyed by the updating
+* process.
+*
+* DLAMDA (output) REAL array, dimension (N)
+* A copy of the first K eigenvalues which will be used by
+* SLAED3 to form the secular equation.
+*
+* Q2 (output) REAL array, dimension (LDQ2,N)
+* If ICOMPQ = 0, Q2 is not referenced. Otherwise,
+* a copy of the first K eigenvectors which will be used by
+* SLAED7 in a matrix multiply (SGEMM) to update the new
+* eigenvectors.
+*
+* LDQ2 (input) INTEGER
+* The leading dimension of the array Q2. LDQ2 >= max(1,N).
+*
+* W (output) REAL array, dimension (N)
+* The first k values of the final deflation-altered z-vector and
+* will be passed to SLAED3.
+*
+* PERM (output) INTEGER array, dimension (N)
+* The permutations (from deflation and sorting) to be applied
+* to each eigenblock.
+*
+* GIVPTR (output) INTEGER
+* The number of Givens rotations which took place in this
+* subproblem.
+*
+* GIVCOL (output) INTEGER array, dimension (2, N)
+* Each pair of numbers indicates a pair of columns to take place
+* in a Givens rotation.
+*
+* GIVNUM (output) REAL array, dimension (2, N)
+* Each number indicates the S value to be used in the
+* corresponding Givens rotation.
+*
+* INDXP (workspace) INTEGER array, dimension (N)
+* The permutation used to place deflated values of D at the end
+* of the array. INDXP(1:K) points to the nondeflated D-values
+* and INDXP(K+1:N) points to the deflated eigenvalues.
+*
+* INDX (workspace) INTEGER array, dimension (N)
+* The permutation used to sort the contents of D into ascending
+* order.
+*
+* INFO (output) INTEGER
+* = 0: successful exit.
+* < 0: if INFO = -i, the i-th argument had an illegal value.
+*
+* Further Details
+* ===============
+*
+* Based on contributions by
+* Jeff Rutter, Computer Science Division, University of California
+* at Berkeley, USA
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL MONE, ZERO, ONE, TWO, EIGHT
+ PARAMETER ( MONE = -1.0E0, ZERO = 0.0E0, ONE = 1.0E0,
+ $ TWO = 2.0E0, EIGHT = 8.0E0 )
+* ..
+* .. Local Scalars ..
+*
+ INTEGER I, IMAX, J, JLAM, JMAX, JP, K2, N1, N1P1, N2
+ REAL C, EPS, S, T, TAU, TOL
+* ..
+* .. External Functions ..
+ INTEGER ISAMAX
+ REAL SLAMCH, SLAPY2
+ EXTERNAL ISAMAX, SLAMCH, SLAPY2
+* ..
+* .. External Subroutines ..
+ EXTERNAL SCOPY, SLACPY, SLAMRG, SROT, SSCAL, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, MIN, SQRT
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+*
+ IF( ICOMPQ.LT.0 .OR. ICOMPQ.GT.1 ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( ICOMPQ.EQ.1 .AND. QSIZ.LT.N ) THEN
+ INFO = -4
+ ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN
+ INFO = -7
+ ELSE IF( CUTPNT.LT.MIN( 1, N ) .OR. CUTPNT.GT.N ) THEN
+ INFO = -10
+ ELSE IF( LDQ2.LT.MAX( 1, N ) ) THEN
+ INFO = -14
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SLAED8', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+ N1 = CUTPNT
+ N2 = N - N1
+ N1P1 = N1 + 1
+*
+ IF( RHO.LT.ZERO ) THEN
+ CALL SSCAL( N2, MONE, Z( N1P1 ), 1 )
+ END IF
+*
+* Normalize z so that norm(z) = 1
+*
+ T = ONE / SQRT( TWO )
+ DO 10 J = 1, N
+ INDX( J ) = J
+ 10 CONTINUE
+ CALL SSCAL( N, T, Z, 1 )
+ RHO = ABS( TWO*RHO )
+*
+* Sort the eigenvalues into increasing order
+*
+ DO 20 I = CUTPNT + 1, N
+ INDXQ( I ) = INDXQ( I ) + CUTPNT
+ 20 CONTINUE
+ DO 30 I = 1, N
+ DLAMDA( I ) = D( INDXQ( I ) )
+ W( I ) = Z( INDXQ( I ) )
+ 30 CONTINUE
+ I = 1
+ J = CUTPNT + 1
+ CALL SLAMRG( N1, N2, DLAMDA, 1, 1, INDX )
+ DO 40 I = 1, N
+ D( I ) = DLAMDA( INDX( I ) )
+ Z( I ) = W( INDX( I ) )
+ 40 CONTINUE
+*
+* Calculate the allowable deflation tolerence
+*
+ IMAX = ISAMAX( N, Z, 1 )
+ JMAX = ISAMAX( N, D, 1 )
+ EPS = SLAMCH( 'Epsilon' )
+ TOL = EIGHT*EPS*ABS( D( JMAX ) )
+*
+* If the rank-1 modifier is small enough, no more needs to be done
+* except to reorganize Q so that its columns correspond with the
+* elements in D.
+*
+ IF( RHO*ABS( Z( IMAX ) ).LE.TOL ) THEN
+ K = 0
+ IF( ICOMPQ.EQ.0 ) THEN
+ DO 50 J = 1, N
+ PERM( J ) = INDXQ( INDX( J ) )
+ 50 CONTINUE
+ ELSE
+ DO 60 J = 1, N
+ PERM( J ) = INDXQ( INDX( J ) )
+ CALL SCOPY( QSIZ, Q( 1, PERM( J ) ), 1, Q2( 1, J ), 1 )
+ 60 CONTINUE
+ CALL SLACPY( 'A', QSIZ, N, Q2( 1, 1 ), LDQ2, Q( 1, 1 ),
+ $ LDQ )
+ END IF
+ RETURN
+ END IF
+*
+* If there are multiple eigenvalues then the problem deflates. Here
+* the number of equal eigenvalues are found. As each equal
+* eigenvalue is found, an elementary reflector is computed to rotate
+* the corresponding eigensubspace so that the corresponding
+* components of Z are zero in this new basis.
+*
+ K = 0
+ GIVPTR = 0
+ K2 = N + 1
+ DO 70 J = 1, N
+ IF( RHO*ABS( Z( J ) ).LE.TOL ) THEN
+*
+* Deflate due to small z component.
+*
+ K2 = K2 - 1
+ INDXP( K2 ) = J
+ IF( J.EQ.N )
+ $ GO TO 110
+ ELSE
+ JLAM = J
+ GO TO 80
+ END IF
+ 70 CONTINUE
+ 80 CONTINUE
+ J = J + 1
+ IF( J.GT.N )
+ $ GO TO 100
+ IF( RHO*ABS( Z( J ) ).LE.TOL ) THEN
+*
+* Deflate due to small z component.
+*
+ K2 = K2 - 1
+ INDXP( K2 ) = J
+ ELSE
+*
+* Check if eigenvalues are close enough to allow deflation.
+*
+ S = Z( JLAM )
+ C = Z( J )
+*
+* Find sqrt(a**2+b**2) without overflow or
+* destructive underflow.
+*
+ TAU = SLAPY2( C, S )
+ T = D( J ) - D( JLAM )
+ C = C / TAU
+ S = -S / TAU
+ IF( ABS( T*C*S ).LE.TOL ) THEN
+*
+* Deflation is possible.
+*
+ Z( J ) = TAU
+ Z( JLAM ) = ZERO
+*
+* Record the appropriate Givens rotation
+*
+ GIVPTR = GIVPTR + 1
+ GIVCOL( 1, GIVPTR ) = INDXQ( INDX( JLAM ) )
+ GIVCOL( 2, GIVPTR ) = INDXQ( INDX( J ) )
+ GIVNUM( 1, GIVPTR ) = C
+ GIVNUM( 2, GIVPTR ) = S
+ IF( ICOMPQ.EQ.1 ) THEN
+ CALL SROT( QSIZ, Q( 1, INDXQ( INDX( JLAM ) ) ), 1,
+ $ Q( 1, INDXQ( INDX( J ) ) ), 1, C, S )
+ END IF
+ T = D( JLAM )*C*C + D( J )*S*S
+ D( J ) = D( JLAM )*S*S + D( J )*C*C
+ D( JLAM ) = T
+ K2 = K2 - 1
+ I = 1
+ 90 CONTINUE
+ IF( K2+I.LE.N ) THEN
+ IF( D( JLAM ).LT.D( INDXP( K2+I ) ) ) THEN
+ INDXP( K2+I-1 ) = INDXP( K2+I )
+ INDXP( K2+I ) = JLAM
+ I = I + 1
+ GO TO 90
+ ELSE
+ INDXP( K2+I-1 ) = JLAM
+ END IF
+ ELSE
+ INDXP( K2+I-1 ) = JLAM
+ END IF
+ JLAM = J
+ ELSE
+ K = K + 1
+ W( K ) = Z( JLAM )
+ DLAMDA( K ) = D( JLAM )
+ INDXP( K ) = JLAM
+ JLAM = J
+ END IF
+ END IF
+ GO TO 80
+ 100 CONTINUE
+*
+* Record the last eigenvalue.
+*
+ K = K + 1
+ W( K ) = Z( JLAM )
+ DLAMDA( K ) = D( JLAM )
+ INDXP( K ) = JLAM
+*
+ 110 CONTINUE
+*
+* Sort the eigenvalues and corresponding eigenvectors into DLAMDA
+* and Q2 respectively. The eigenvalues/vectors which were not
+* deflated go into the first K slots of DLAMDA and Q2 respectively,
+* while those which were deflated go into the last N - K slots.
+*
+ IF( ICOMPQ.EQ.0 ) THEN
+ DO 120 J = 1, N
+ JP = INDXP( J )
+ DLAMDA( J ) = D( JP )
+ PERM( J ) = INDXQ( INDX( JP ) )
+ 120 CONTINUE
+ ELSE
+ DO 130 J = 1, N
+ JP = INDXP( J )
+ DLAMDA( J ) = D( JP )
+ PERM( J ) = INDXQ( INDX( JP ) )
+ CALL SCOPY( QSIZ, Q( 1, PERM( J ) ), 1, Q2( 1, J ), 1 )
+ 130 CONTINUE
+ END IF
+*
+* The deflated eigenvalues and their corresponding vectors go back
+* into the last N - K slots of D and Q respectively.
+*
+ IF( K.LT.N ) THEN
+ IF( ICOMPQ.EQ.0 ) THEN
+ CALL SCOPY( N-K, DLAMDA( K+1 ), 1, D( K+1 ), 1 )
+ ELSE
+ CALL SCOPY( N-K, DLAMDA( K+1 ), 1, D( K+1 ), 1 )
+ CALL SLACPY( 'A', QSIZ, N-K, Q2( 1, K+1 ), LDQ2,
+ $ Q( 1, K+1 ), LDQ )
+ END IF
+ END IF
+*
+ RETURN
+*
+* End of SLAED8
+*
+ END
+ SUBROUTINE SLAED9( K, KSTART, KSTOP, N, D, Q, LDQ, RHO, DLAMDA, W,
+ $ S, LDS, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, K, KSTART, KSTOP, LDQ, LDS, N
+ REAL RHO
+* ..
+* .. Array Arguments ..
+ REAL D( * ), DLAMDA( * ), Q( LDQ, * ), S( LDS, * ),
+ $ W( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SLAED9 finds the roots of the secular equation, as defined by the
+* values in D, Z, and RHO, between KSTART and KSTOP. It makes the
+* appropriate calls to SLAED4 and then stores the new matrix of
+* eigenvectors for use in calculating the next level of Z vectors.
+*
+* Arguments
+* =========
+*
+* K (input) INTEGER
+* The number of terms in the rational function to be solved by
+* SLAED4. K >= 0.
+*
+* KSTART (input) INTEGER
+* KSTOP (input) INTEGER
+* The updated eigenvalues Lambda(I), KSTART <= I <= KSTOP
+* are to be computed. 1 <= KSTART <= KSTOP <= K.
+*
+* N (input) INTEGER
+* The number of rows and columns in the Q matrix.
+* N >= K (delation may result in N > K).
+*
+* D (output) REAL array, dimension (N)
+* D(I) contains the updated eigenvalues
+* for KSTART <= I <= KSTOP.
+*
+* Q (workspace) REAL array, dimension (LDQ,N)
+*
+* LDQ (input) INTEGER
+* The leading dimension of the array Q. LDQ >= max( 1, N ).
+*
+* RHO (input) REAL
+* The value of the parameter in the rank one update equation.
+* RHO >= 0 required.
+*
+* DLAMDA (input) REAL array, dimension (K)
+* The first K elements of this array contain the old roots
+* of the deflated updating problem. These are the poles
+* of the secular equation.
+*
+* W (input) REAL array, dimension (K)
+* The first K elements of this array contain the components
+* of the deflation-adjusted updating vector.
+*
+* S (output) REAL array, dimension (LDS, K)
+* Will contain the eigenvectors of the repaired matrix which
+* will be stored for subsequent Z vector calculation and
+* multiplied by the previously accumulated eigenvectors
+* to update the system.
+*
+* LDS (input) INTEGER
+* The leading dimension of S. LDS >= max( 1, K ).
+*
+* INFO (output) INTEGER
+* = 0: successful exit.
+* < 0: if INFO = -i, the i-th argument had an illegal value.
+* > 0: if INFO = 1, an eigenvalue did not converge
+*
+* Further Details
+* ===============
+*
+* Based on contributions by
+* Jeff Rutter, Computer Science Division, University of California
+* at Berkeley, USA
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ INTEGER I, J
+ REAL TEMP
+* ..
+* .. External Functions ..
+ REAL SLAMC3, SNRM2
+ EXTERNAL SLAMC3, SNRM2
+* ..
+* .. External Subroutines ..
+ EXTERNAL SCOPY, SLAED4, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, SIGN, SQRT
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+*
+ IF( K.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( KSTART.LT.1 .OR. KSTART.GT.MAX( 1, K ) ) THEN
+ INFO = -2
+ ELSE IF( MAX( 1, KSTOP ).LT.KSTART .OR. KSTOP.GT.MAX( 1, K ) )
+ $ THEN
+ INFO = -3
+ ELSE IF( N.LT.K ) THEN
+ INFO = -4
+ ELSE IF( LDQ.LT.MAX( 1, K ) ) THEN
+ INFO = -7
+ ELSE IF( LDS.LT.MAX( 1, K ) ) THEN
+ INFO = -12
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SLAED9', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( K.EQ.0 )
+ $ RETURN
+*
+* Modify values DLAMDA(i) to make sure all DLAMDA(i)-DLAMDA(j) can
+* be computed with high relative accuracy (barring over/underflow).
+* This is a problem on machines without a guard digit in
+* add/subtract (Cray XMP, Cray YMP, Cray C 90 and Cray 2).
+* The following code replaces DLAMDA(I) by 2*DLAMDA(I)-DLAMDA(I),
+* which on any of these machines zeros out the bottommost
+* bit of DLAMDA(I) if it is 1; this makes the subsequent
+* subtractions DLAMDA(I)-DLAMDA(J) unproblematic when cancellation
+* occurs. On binary machines with a guard digit (almost all
+* machines) it does not change DLAMDA(I) at all. On hexadecimal
+* and decimal machines with a guard digit, it slightly
+* changes the bottommost bits of DLAMDA(I). It does not account
+* for hexadecimal or decimal machines without guard digits
+* (we know of none). We use a subroutine call to compute
+* 2*DLAMBDA(I) to prevent optimizing compilers from eliminating
+* this code.
+*
+ DO 10 I = 1, N
+ DLAMDA( I ) = SLAMC3( DLAMDA( I ), DLAMDA( I ) ) - DLAMDA( I )
+ 10 CONTINUE
+*
+ DO 20 J = KSTART, KSTOP
+ CALL SLAED4( K, J, DLAMDA, W, Q( 1, J ), RHO, D( J ), INFO )
+*
+* If the zero finder fails, the computation is terminated.
+*
+ IF( INFO.NE.0 )
+ $ GO TO 120
+ 20 CONTINUE
+*
+ IF( K.EQ.1 .OR. K.EQ.2 ) THEN
+ DO 40 I = 1, K
+ DO 30 J = 1, K
+ S( J, I ) = Q( J, I )
+ 30 CONTINUE
+ 40 CONTINUE
+ GO TO 120
+ END IF
+*
+* Compute updated W.
+*
+ CALL SCOPY( K, W, 1, S, 1 )
+*
+* Initialize W(I) = Q(I,I)
+*
+ CALL SCOPY( K, Q, LDQ+1, W, 1 )
+ DO 70 J = 1, K
+ DO 50 I = 1, J - 1
+ W( I ) = W( I )*( Q( I, J ) / ( DLAMDA( I )-DLAMDA( J ) ) )
+ 50 CONTINUE
+ DO 60 I = J + 1, K
+ W( I ) = W( I )*( Q( I, J ) / ( DLAMDA( I )-DLAMDA( J ) ) )
+ 60 CONTINUE
+ 70 CONTINUE
+ DO 80 I = 1, K
+ W( I ) = SIGN( SQRT( -W( I ) ), S( I, 1 ) )
+ 80 CONTINUE
+*
+* Compute eigenvectors of the modified rank-1 modification.
+*
+ DO 110 J = 1, K
+ DO 90 I = 1, K
+ Q( I, J ) = W( I ) / Q( I, J )
+ 90 CONTINUE
+ TEMP = SNRM2( K, Q( 1, J ), 1 )
+ DO 100 I = 1, K
+ S( I, J ) = Q( I, J ) / TEMP
+ 100 CONTINUE
+ 110 CONTINUE
+*
+ 120 CONTINUE
+ RETURN
+*
+* End of SLAED9
+*
+ END
+ SUBROUTINE SLAEDA( N, TLVLS, CURLVL, CURPBM, PRMPTR, PERM, GIVPTR,
+ $ GIVCOL, GIVNUM, Q, QPTR, Z, ZTEMP, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER CURLVL, CURPBM, INFO, N, TLVLS
+* ..
+* .. Array Arguments ..
+ INTEGER GIVCOL( 2, * ), GIVPTR( * ), PERM( * ),
+ $ PRMPTR( * ), QPTR( * )
+ REAL GIVNUM( 2, * ), Q( * ), Z( * ), ZTEMP( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SLAEDA computes the Z vector corresponding to the merge step in the
+* CURLVLth step of the merge process with TLVLS steps for the CURPBMth
+* problem.
+*
+* Arguments
+* =========
+*
+* N (input) INTEGER
+* The dimension of the symmetric tridiagonal matrix. N >= 0.
+*
+* TLVLS (input) INTEGER
+* The total number of merging levels in the overall divide and
+* conquer tree.
+*
+* CURLVL (input) INTEGER
+* The current level in the overall merge routine,
+* 0 <= curlvl <= tlvls.
+*
+* CURPBM (input) INTEGER
+* The current problem in the current level in the overall
+* merge routine (counting from upper left to lower right).
+*
+* PRMPTR (input) INTEGER array, dimension (N lg N)
+* Contains a list of pointers which indicate where in PERM a
+* level's permutation is stored. PRMPTR(i+1) - PRMPTR(i)
+* indicates the size of the permutation and incidentally the
+* size of the full, non-deflated problem.
+*
+* PERM (input) INTEGER array, dimension (N lg N)
+* Contains the permutations (from deflation and sorting) to be
+* applied to each eigenblock.
+*
+* GIVPTR (input) INTEGER array, dimension (N lg N)
+* Contains a list of pointers which indicate where in GIVCOL a
+* level's Givens rotations are stored. GIVPTR(i+1) - GIVPTR(i)
+* indicates the number of Givens rotations.
+*
+* GIVCOL (input) INTEGER array, dimension (2, N lg N)
+* Each pair of numbers indicates a pair of columns to take place
+* in a Givens rotation.
+*
+* GIVNUM (input) REAL array, dimension (2, N lg N)
+* Each number indicates the S value to be used in the
+* corresponding Givens rotation.
+*
+* Q (input) REAL array, dimension (N**2)
+* Contains the square eigenblocks from previous levels, the
+* starting positions for blocks are given by QPTR.
+*
+* QPTR (input) INTEGER array, dimension (N+2)
+* Contains a list of pointers which indicate where in Q an
+* eigenblock is stored. SQRT( QPTR(i+1) - QPTR(i) ) indicates
+* the size of the block.
+*
+* Z (output) REAL array, dimension (N)
+* On output this vector contains the updating vector (the last
+* row of the first sub-eigenvector matrix and the first row of
+* the second sub-eigenvector matrix).
+*
+* ZTEMP (workspace) REAL array, dimension (N)
+*
+* INFO (output) INTEGER
+* = 0: successful exit.
+* < 0: if INFO = -i, the i-th argument had an illegal value.
+*
+* Further Details
+* ===============
+*
+* Based on contributions by
+* Jeff Rutter, Computer Science Division, University of California
+* at Berkeley, USA
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO, HALF, ONE
+ PARAMETER ( ZERO = 0.0E0, HALF = 0.5E0, ONE = 1.0E0 )
+* ..
+* .. Local Scalars ..
+ INTEGER BSIZ1, BSIZ2, CURR, I, K, MID, PSIZ1, PSIZ2,
+ $ PTR, ZPTR1
+* ..
+* .. External Subroutines ..
+ EXTERNAL SCOPY, SGEMV, SROT, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC INT, REAL, SQRT
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+*
+ IF( N.LT.0 ) THEN
+ INFO = -1
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SLAEDA', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+* Determine location of first number in second half.
+*
+ MID = N / 2 + 1
+*
+* Gather last/first rows of appropriate eigenblocks into center of Z
+*
+ PTR = 1
+*
+* Determine location of lowest level subproblem in the full storage
+* scheme
+*
+ CURR = PTR + CURPBM*2**CURLVL + 2**( CURLVL-1 ) - 1
+*
+* Determine size of these matrices. We add HALF to the value of
+* the SQRT in case the machine underestimates one of these square
+* roots.
+*
+ BSIZ1 = INT( HALF+SQRT( REAL( QPTR( CURR+1 )-QPTR( CURR ) ) ) )
+ BSIZ2 = INT( HALF+SQRT( REAL( QPTR( CURR+2 )-QPTR( CURR+1 ) ) ) )
+ DO 10 K = 1, MID - BSIZ1 - 1
+ Z( K ) = ZERO
+ 10 CONTINUE
+ CALL SCOPY( BSIZ1, Q( QPTR( CURR )+BSIZ1-1 ), BSIZ1,
+ $ Z( MID-BSIZ1 ), 1 )
+ CALL SCOPY( BSIZ2, Q( QPTR( CURR+1 ) ), BSIZ2, Z( MID ), 1 )
+ DO 20 K = MID + BSIZ2, N
+ Z( K ) = ZERO
+ 20 CONTINUE
+*
+* Loop thru remaining levels 1 -> CURLVL applying the Givens
+* rotations and permutation and then multiplying the center matrices
+* against the current Z.
+*
+ PTR = 2**TLVLS + 1
+ DO 70 K = 1, CURLVL - 1
+ CURR = PTR + CURPBM*2**( CURLVL-K ) + 2**( CURLVL-K-1 ) - 1
+ PSIZ1 = PRMPTR( CURR+1 ) - PRMPTR( CURR )
+ PSIZ2 = PRMPTR( CURR+2 ) - PRMPTR( CURR+1 )
+ ZPTR1 = MID - PSIZ1
+*
+* Apply Givens at CURR and CURR+1
+*
+ DO 30 I = GIVPTR( CURR ), GIVPTR( CURR+1 ) - 1
+ CALL SROT( 1, Z( ZPTR1+GIVCOL( 1, I )-1 ), 1,
+ $ Z( ZPTR1+GIVCOL( 2, I )-1 ), 1, GIVNUM( 1, I ),
+ $ GIVNUM( 2, I ) )
+ 30 CONTINUE
+ DO 40 I = GIVPTR( CURR+1 ), GIVPTR( CURR+2 ) - 1
+ CALL SROT( 1, Z( MID-1+GIVCOL( 1, I ) ), 1,
+ $ Z( MID-1+GIVCOL( 2, I ) ), 1, GIVNUM( 1, I ),
+ $ GIVNUM( 2, I ) )
+ 40 CONTINUE
+ PSIZ1 = PRMPTR( CURR+1 ) - PRMPTR( CURR )
+ PSIZ2 = PRMPTR( CURR+2 ) - PRMPTR( CURR+1 )
+ DO 50 I = 0, PSIZ1 - 1
+ ZTEMP( I+1 ) = Z( ZPTR1+PERM( PRMPTR( CURR )+I )-1 )
+ 50 CONTINUE
+ DO 60 I = 0, PSIZ2 - 1
+ ZTEMP( PSIZ1+I+1 ) = Z( MID+PERM( PRMPTR( CURR+1 )+I )-1 )
+ 60 CONTINUE
+*
+* Multiply Blocks at CURR and CURR+1
+*
+* Determine size of these matrices. We add HALF to the value of
+* the SQRT in case the machine underestimates one of these
+* square roots.
+*
+ BSIZ1 = INT( HALF+SQRT( REAL( QPTR( CURR+1 )-QPTR( CURR ) ) ) )
+ BSIZ2 = INT( HALF+SQRT( REAL( QPTR( CURR+2 )-QPTR( CURR+
+ $ 1 ) ) ) )
+ IF( BSIZ1.GT.0 ) THEN
+ CALL SGEMV( 'T', BSIZ1, BSIZ1, ONE, Q( QPTR( CURR ) ),
+ $ BSIZ1, ZTEMP( 1 ), 1, ZERO, Z( ZPTR1 ), 1 )
+ END IF
+ CALL SCOPY( PSIZ1-BSIZ1, ZTEMP( BSIZ1+1 ), 1, Z( ZPTR1+BSIZ1 ),
+ $ 1 )
+ IF( BSIZ2.GT.0 ) THEN
+ CALL SGEMV( 'T', BSIZ2, BSIZ2, ONE, Q( QPTR( CURR+1 ) ),
+ $ BSIZ2, ZTEMP( PSIZ1+1 ), 1, ZERO, Z( MID ), 1 )
+ END IF
+ CALL SCOPY( PSIZ2-BSIZ2, ZTEMP( PSIZ1+BSIZ2+1 ), 1,
+ $ Z( MID+BSIZ2 ), 1 )
+*
+ PTR = PTR + 2**( TLVLS-K )
+ 70 CONTINUE
+*
+ RETURN
+*
+* End of SLAEDA
+*
+ END
+ SUBROUTINE SLAEIN( RIGHTV, NOINIT, N, H, LDH, WR, WI, VR, VI, B,
+ $ LDB, WORK, EPS3, SMLNUM, BIGNUM, INFO )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ LOGICAL NOINIT, RIGHTV
+ INTEGER INFO, LDB, LDH, N
+ REAL BIGNUM, EPS3, SMLNUM, WI, WR
+* ..
+* .. Array Arguments ..
+ REAL B( LDB, * ), H( LDH, * ), VI( * ), VR( * ),
+ $ WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SLAEIN uses inverse iteration to find a right or left eigenvector
+* corresponding to the eigenvalue (WR,WI) of a real upper Hessenberg
+* matrix H.
+*
+* Arguments
+* =========
+*
+* RIGHTV (input) LOGICAL
+* = .TRUE. : compute right eigenvector;
+* = .FALSE.: compute left eigenvector.
+*
+* NOINIT (input) LOGICAL
+* = .TRUE. : no initial vector supplied in (VR,VI).
+* = .FALSE.: initial vector supplied in (VR,VI).
+*
+* N (input) INTEGER
+* The order of the matrix H. N >= 0.
+*
+* H (input) REAL array, dimension (LDH,N)
+* The upper Hessenberg matrix H.
+*
+* LDH (input) INTEGER
+* The leading dimension of the array H. LDH >= max(1,N).
+*
+* WR (input) REAL
+* WI (input) REAL
+* The real and imaginary parts of the eigenvalue of H whose
+* corresponding right or left eigenvector is to be computed.
+*
+* VR (input/output) REAL array, dimension (N)
+* VI (input/output) REAL array, dimension (N)
+* On entry, if NOINIT = .FALSE. and WI = 0.0, VR must contain
+* a real starting vector for inverse iteration using the real
+* eigenvalue WR; if NOINIT = .FALSE. and WI.ne.0.0, VR and VI
+* must contain the real and imaginary parts of a complex
+* starting vector for inverse iteration using the complex
+* eigenvalue (WR,WI); otherwise VR and VI need not be set.
+* On exit, if WI = 0.0 (real eigenvalue), VR contains the
+* computed real eigenvector; if WI.ne.0.0 (complex eigenvalue),
+* VR and VI contain the real and imaginary parts of the
+* computed complex eigenvector. The eigenvector is normalized
+* so that the component of largest magnitude has magnitude 1;
+* here the magnitude of a complex number (x,y) is taken to be
+* |x| + |y|.
+* VI is not referenced if WI = 0.0.
+*
+* B (workspace) REAL array, dimension (LDB,N)
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. LDB >= N+1.
+*
+* WORK (workspace) REAL array, dimension (N)
+*
+* EPS3 (input) REAL
+* A small machine-dependent value which is used to perturb
+* close eigenvalues, and to replace zero pivots.
+*
+* SMLNUM (input) REAL
+* A machine-dependent value close to the underflow threshold.
+*
+* BIGNUM (input) REAL
+* A machine-dependent value close to the overflow threshold.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* = 1: inverse iteration did not converge; VR is set to the
+* last iterate, and so is VI if WI.ne.0.0.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO, ONE, TENTH
+ PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0, TENTH = 1.0E-1 )
+* ..
+* .. Local Scalars ..
+ CHARACTER NORMIN, TRANS
+ INTEGER I, I1, I2, I3, IERR, ITS, J
+ REAL ABSBII, ABSBJJ, EI, EJ, GROWTO, NORM, NRMSML,
+ $ REC, ROOTN, SCALE, TEMP, VCRIT, VMAX, VNORM, W,
+ $ W1, X, XI, XR, Y
+* ..
+* .. External Functions ..
+ INTEGER ISAMAX
+ REAL SASUM, SLAPY2, SNRM2
+ EXTERNAL ISAMAX, SASUM, SLAPY2, SNRM2
+* ..
+* .. External Subroutines ..
+ EXTERNAL SLADIV, SLATRS, SSCAL
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, REAL, SQRT
+* ..
+* .. Executable Statements ..
+*
+ INFO = 0
+*
+* GROWTO is the threshold used in the acceptance test for an
+* eigenvector.
+*
+ ROOTN = SQRT( REAL( N ) )
+ GROWTO = TENTH / ROOTN
+ NRMSML = MAX( ONE, EPS3*ROOTN )*SMLNUM
+*
+* Form B = H - (WR,WI)*I (except that the subdiagonal elements and
+* the imaginary parts of the diagonal elements are not stored).
+*
+ DO 20 J = 1, N
+ DO 10 I = 1, J - 1
+ B( I, J ) = H( I, J )
+ 10 CONTINUE
+ B( J, J ) = H( J, J ) - WR
+ 20 CONTINUE
+*
+ IF( WI.EQ.ZERO ) THEN
+*
+* Real eigenvalue.
+*
+ IF( NOINIT ) THEN
+*
+* Set initial vector.
+*
+ DO 30 I = 1, N
+ VR( I ) = EPS3
+ 30 CONTINUE
+ ELSE
+*
+* Scale supplied initial vector.
+*
+ VNORM = SNRM2( N, VR, 1 )
+ CALL SSCAL( N, ( EPS3*ROOTN ) / MAX( VNORM, NRMSML ), VR,
+ $ 1 )
+ END IF
+*
+ IF( RIGHTV ) THEN
+*
+* LU decomposition with partial pivoting of B, replacing zero
+* pivots by EPS3.
+*
+ DO 60 I = 1, N - 1
+ EI = H( I+1, I )
+ IF( ABS( B( I, I ) ).LT.ABS( EI ) ) THEN
+*
+* Interchange rows and eliminate.
+*
+ X = B( I, I ) / EI
+ B( I, I ) = EI
+ DO 40 J = I + 1, N
+ TEMP = B( I+1, J )
+ B( I+1, J ) = B( I, J ) - X*TEMP
+ B( I, J ) = TEMP
+ 40 CONTINUE
+ ELSE
+*
+* Eliminate without interchange.
+*
+ IF( B( I, I ).EQ.ZERO )
+ $ B( I, I ) = EPS3
+ X = EI / B( I, I )
+ IF( X.NE.ZERO ) THEN
+ DO 50 J = I + 1, N
+ B( I+1, J ) = B( I+1, J ) - X*B( I, J )
+ 50 CONTINUE
+ END IF
+ END IF
+ 60 CONTINUE
+ IF( B( N, N ).EQ.ZERO )
+ $ B( N, N ) = EPS3
+*
+ TRANS = 'N'
+*
+ ELSE
+*
+* UL decomposition with partial pivoting of B, replacing zero
+* pivots by EPS3.
+*
+ DO 90 J = N, 2, -1
+ EJ = H( J, J-1 )
+ IF( ABS( B( J, J ) ).LT.ABS( EJ ) ) THEN
+*
+* Interchange columns and eliminate.
+*
+ X = B( J, J ) / EJ
+ B( J, J ) = EJ
+ DO 70 I = 1, J - 1
+ TEMP = B( I, J-1 )
+ B( I, J-1 ) = B( I, J ) - X*TEMP
+ B( I, J ) = TEMP
+ 70 CONTINUE
+ ELSE
+*
+* Eliminate without interchange.
+*
+ IF( B( J, J ).EQ.ZERO )
+ $ B( J, J ) = EPS3
+ X = EJ / B( J, J )
+ IF( X.NE.ZERO ) THEN
+ DO 80 I = 1, J - 1
+ B( I, J-1 ) = B( I, J-1 ) - X*B( I, J )
+ 80 CONTINUE
+ END IF
+ END IF
+ 90 CONTINUE
+ IF( B( 1, 1 ).EQ.ZERO )
+ $ B( 1, 1 ) = EPS3
+*
+ TRANS = 'T'
+*
+ END IF
+*
+ NORMIN = 'N'
+ DO 110 ITS = 1, N
+*
+* Solve U*x = scale*v for a right eigenvector
+* or U'*x = scale*v for a left eigenvector,
+* overwriting x on v.
+*
+ CALL SLATRS( 'Upper', TRANS, 'Nonunit', NORMIN, N, B, LDB,
+ $ VR, SCALE, WORK, IERR )
+ NORMIN = 'Y'
+*
+* Test for sufficient growth in the norm of v.
+*
+ VNORM = SASUM( N, VR, 1 )
+ IF( VNORM.GE.GROWTO*SCALE )
+ $ GO TO 120
+*
+* Choose new orthogonal starting vector and try again.
+*
+ TEMP = EPS3 / ( ROOTN+ONE )
+ VR( 1 ) = EPS3
+ DO 100 I = 2, N
+ VR( I ) = TEMP
+ 100 CONTINUE
+ VR( N-ITS+1 ) = VR( N-ITS+1 ) - EPS3*ROOTN
+ 110 CONTINUE
+*
+* Failure to find eigenvector in N iterations.
+*
+ INFO = 1
+*
+ 120 CONTINUE
+*
+* Normalize eigenvector.
+*
+ I = ISAMAX( N, VR, 1 )
+ CALL SSCAL( N, ONE / ABS( VR( I ) ), VR, 1 )
+ ELSE
+*
+* Complex eigenvalue.
+*
+ IF( NOINIT ) THEN
+*
+* Set initial vector.
+*
+ DO 130 I = 1, N
+ VR( I ) = EPS3
+ VI( I ) = ZERO
+ 130 CONTINUE
+ ELSE
+*
+* Scale supplied initial vector.
+*
+ NORM = SLAPY2( SNRM2( N, VR, 1 ), SNRM2( N, VI, 1 ) )
+ REC = ( EPS3*ROOTN ) / MAX( NORM, NRMSML )
+ CALL SSCAL( N, REC, VR, 1 )
+ CALL SSCAL( N, REC, VI, 1 )
+ END IF
+*
+ IF( RIGHTV ) THEN
+*
+* LU decomposition with partial pivoting of B, replacing zero
+* pivots by EPS3.
+*
+* The imaginary part of the (i,j)-th element of U is stored in
+* B(j+1,i).
+*
+ B( 2, 1 ) = -WI
+ DO 140 I = 2, N
+ B( I+1, 1 ) = ZERO
+ 140 CONTINUE
+*
+ DO 170 I = 1, N - 1
+ ABSBII = SLAPY2( B( I, I ), B( I+1, I ) )
+ EI = H( I+1, I )
+ IF( ABSBII.LT.ABS( EI ) ) THEN
+*
+* Interchange rows and eliminate.
+*
+ XR = B( I, I ) / EI
+ XI = B( I+1, I ) / EI
+ B( I, I ) = EI
+ B( I+1, I ) = ZERO
+ DO 150 J = I + 1, N
+ TEMP = B( I+1, J )
+ B( I+1, J ) = B( I, J ) - XR*TEMP
+ B( J+1, I+1 ) = B( J+1, I ) - XI*TEMP
+ B( I, J ) = TEMP
+ B( J+1, I ) = ZERO
+ 150 CONTINUE
+ B( I+2, I ) = -WI
+ B( I+1, I+1 ) = B( I+1, I+1 ) - XI*WI
+ B( I+2, I+1 ) = B( I+2, I+1 ) + XR*WI
+ ELSE
+*
+* Eliminate without interchanging rows.
+*
+ IF( ABSBII.EQ.ZERO ) THEN
+ B( I, I ) = EPS3
+ B( I+1, I ) = ZERO
+ ABSBII = EPS3
+ END IF
+ EI = ( EI / ABSBII ) / ABSBII
+ XR = B( I, I )*EI
+ XI = -B( I+1, I )*EI
+ DO 160 J = I + 1, N
+ B( I+1, J ) = B( I+1, J ) - XR*B( I, J ) +
+ $ XI*B( J+1, I )
+ B( J+1, I+1 ) = -XR*B( J+1, I ) - XI*B( I, J )
+ 160 CONTINUE
+ B( I+2, I+1 ) = B( I+2, I+1 ) - WI
+ END IF
+*
+* Compute 1-norm of offdiagonal elements of i-th row.
+*
+ WORK( I ) = SASUM( N-I, B( I, I+1 ), LDB ) +
+ $ SASUM( N-I, B( I+2, I ), 1 )
+ 170 CONTINUE
+ IF( B( N, N ).EQ.ZERO .AND. B( N+1, N ).EQ.ZERO )
+ $ B( N, N ) = EPS3
+ WORK( N ) = ZERO
+*
+ I1 = N
+ I2 = 1
+ I3 = -1
+ ELSE
+*
+* UL decomposition with partial pivoting of conjg(B),
+* replacing zero pivots by EPS3.
+*
+* The imaginary part of the (i,j)-th element of U is stored in
+* B(j+1,i).
+*
+ B( N+1, N ) = WI
+ DO 180 J = 1, N - 1
+ B( N+1, J ) = ZERO
+ 180 CONTINUE
+*
+ DO 210 J = N, 2, -1
+ EJ = H( J, J-1 )
+ ABSBJJ = SLAPY2( B( J, J ), B( J+1, J ) )
+ IF( ABSBJJ.LT.ABS( EJ ) ) THEN
+*
+* Interchange columns and eliminate
+*
+ XR = B( J, J ) / EJ
+ XI = B( J+1, J ) / EJ
+ B( J, J ) = EJ
+ B( J+1, J ) = ZERO
+ DO 190 I = 1, J - 1
+ TEMP = B( I, J-1 )
+ B( I, J-1 ) = B( I, J ) - XR*TEMP
+ B( J, I ) = B( J+1, I ) - XI*TEMP
+ B( I, J ) = TEMP
+ B( J+1, I ) = ZERO
+ 190 CONTINUE
+ B( J+1, J-1 ) = WI
+ B( J-1, J-1 ) = B( J-1, J-1 ) + XI*WI
+ B( J, J-1 ) = B( J, J-1 ) - XR*WI
+ ELSE
+*
+* Eliminate without interchange.
+*
+ IF( ABSBJJ.EQ.ZERO ) THEN
+ B( J, J ) = EPS3
+ B( J+1, J ) = ZERO
+ ABSBJJ = EPS3
+ END IF
+ EJ = ( EJ / ABSBJJ ) / ABSBJJ
+ XR = B( J, J )*EJ
+ XI = -B( J+1, J )*EJ
+ DO 200 I = 1, J - 1
+ B( I, J-1 ) = B( I, J-1 ) - XR*B( I, J ) +
+ $ XI*B( J+1, I )
+ B( J, I ) = -XR*B( J+1, I ) - XI*B( I, J )
+ 200 CONTINUE
+ B( J, J-1 ) = B( J, J-1 ) + WI
+ END IF
+*
+* Compute 1-norm of offdiagonal elements of j-th column.
+*
+ WORK( J ) = SASUM( J-1, B( 1, J ), 1 ) +
+ $ SASUM( J-1, B( J+1, 1 ), LDB )
+ 210 CONTINUE
+ IF( B( 1, 1 ).EQ.ZERO .AND. B( 2, 1 ).EQ.ZERO )
+ $ B( 1, 1 ) = EPS3
+ WORK( 1 ) = ZERO
+*
+ I1 = 1
+ I2 = N
+ I3 = 1
+ END IF
+*
+ DO 270 ITS = 1, N
+ SCALE = ONE
+ VMAX = ONE
+ VCRIT = BIGNUM
+*
+* Solve U*(xr,xi) = scale*(vr,vi) for a right eigenvector,
+* or U'*(xr,xi) = scale*(vr,vi) for a left eigenvector,
+* overwriting (xr,xi) on (vr,vi).
+*
+ DO 250 I = I1, I2, I3
+*
+ IF( WORK( I ).GT.VCRIT ) THEN
+ REC = ONE / VMAX
+ CALL SSCAL( N, REC, VR, 1 )
+ CALL SSCAL( N, REC, VI, 1 )
+ SCALE = SCALE*REC
+ VMAX = ONE
+ VCRIT = BIGNUM
+ END IF
+*
+ XR = VR( I )
+ XI = VI( I )
+ IF( RIGHTV ) THEN
+ DO 220 J = I + 1, N
+ XR = XR - B( I, J )*VR( J ) + B( J+1, I )*VI( J )
+ XI = XI - B( I, J )*VI( J ) - B( J+1, I )*VR( J )
+ 220 CONTINUE
+ ELSE
+ DO 230 J = 1, I - 1
+ XR = XR - B( J, I )*VR( J ) + B( I+1, J )*VI( J )
+ XI = XI - B( J, I )*VI( J ) - B( I+1, J )*VR( J )
+ 230 CONTINUE
+ END IF
+*
+ W = ABS( B( I, I ) ) + ABS( B( I+1, I ) )
+ IF( W.GT.SMLNUM ) THEN
+ IF( W.LT.ONE ) THEN
+ W1 = ABS( XR ) + ABS( XI )
+ IF( W1.GT.W*BIGNUM ) THEN
+ REC = ONE / W1
+ CALL SSCAL( N, REC, VR, 1 )
+ CALL SSCAL( N, REC, VI, 1 )
+ XR = VR( I )
+ XI = VI( I )
+ SCALE = SCALE*REC
+ VMAX = VMAX*REC
+ END IF
+ END IF
+*
+* Divide by diagonal element of B.
+*
+ CALL SLADIV( XR, XI, B( I, I ), B( I+1, I ), VR( I ),
+ $ VI( I ) )
+ VMAX = MAX( ABS( VR( I ) )+ABS( VI( I ) ), VMAX )
+ VCRIT = BIGNUM / VMAX
+ ELSE
+ DO 240 J = 1, N
+ VR( J ) = ZERO
+ VI( J ) = ZERO
+ 240 CONTINUE
+ VR( I ) = ONE
+ VI( I ) = ONE
+ SCALE = ZERO
+ VMAX = ONE
+ VCRIT = BIGNUM
+ END IF
+ 250 CONTINUE
+*
+* Test for sufficient growth in the norm of (VR,VI).
+*
+ VNORM = SASUM( N, VR, 1 ) + SASUM( N, VI, 1 )
+ IF( VNORM.GE.GROWTO*SCALE )
+ $ GO TO 280
+*
+* Choose a new orthogonal starting vector and try again.
+*
+ Y = EPS3 / ( ROOTN+ONE )
+ VR( 1 ) = EPS3
+ VI( 1 ) = ZERO
+*
+ DO 260 I = 2, N
+ VR( I ) = Y
+ VI( I ) = ZERO
+ 260 CONTINUE
+ VR( N-ITS+1 ) = VR( N-ITS+1 ) - EPS3*ROOTN
+ 270 CONTINUE
+*
+* Failure to find eigenvector in N iterations
+*
+ INFO = 1
+*
+ 280 CONTINUE
+*
+* Normalize eigenvector.
+*
+ VNORM = ZERO
+ DO 290 I = 1, N
+ VNORM = MAX( VNORM, ABS( VR( I ) )+ABS( VI( I ) ) )
+ 290 CONTINUE
+ CALL SSCAL( N, ONE / VNORM, VR, 1 )
+ CALL SSCAL( N, ONE / VNORM, VI, 1 )
+*
+ END IF
+*
+ RETURN
+*
+* End of SLAEIN
+*
+ END
+ SUBROUTINE SLAEV2( A, B, C, RT1, RT2, CS1, SN1 )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ REAL A, B, C, CS1, RT1, RT2, SN1
+* ..
+*
+* Purpose
+* =======
+*
+* SLAEV2 computes the eigendecomposition of a 2-by-2 symmetric matrix
+* [ A B ]
+* [ B C ].
+* On return, RT1 is the eigenvalue of larger absolute value, RT2 is the
+* eigenvalue of smaller absolute value, and (CS1,SN1) is the unit right
+* eigenvector for RT1, giving the decomposition
+*
+* [ CS1 SN1 ] [ A B ] [ CS1 -SN1 ] = [ RT1 0 ]
+* [-SN1 CS1 ] [ B C ] [ SN1 CS1 ] [ 0 RT2 ].
+*
+* Arguments
+* =========
+*
+* A (input) REAL
+* The (1,1) element of the 2-by-2 matrix.
+*
+* B (input) REAL
+* The (1,2) element and the conjugate of the (2,1) element of
+* the 2-by-2 matrix.
+*
+* C (input) REAL
+* The (2,2) element of the 2-by-2 matrix.
+*
+* RT1 (output) REAL
+* The eigenvalue of larger absolute value.
+*
+* RT2 (output) REAL
+* The eigenvalue of smaller absolute value.
+*
+* CS1 (output) REAL
+* SN1 (output) REAL
+* The vector (CS1, SN1) is a unit right eigenvector for RT1.
+*
+* Further Details
+* ===============
+*
+* RT1 is accurate to a few ulps barring over/underflow.
+*
+* RT2 may be inaccurate if there is massive cancellation in the
+* determinant A*C-B*B; higher precision or correctly rounded or
+* correctly truncated arithmetic would be needed to compute RT2
+* accurately in all cases.
+*
+* CS1 and SN1 are accurate to a few ulps barring over/underflow.
+*
+* Overflow is possible only if RT1 is within a factor of 5 of overflow.
+* Underflow is harmless if the input data is 0 or exceeds
+* underflow_threshold / macheps.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ONE
+ PARAMETER ( ONE = 1.0E0 )
+ REAL TWO
+ PARAMETER ( TWO = 2.0E0 )
+ REAL ZERO
+ PARAMETER ( ZERO = 0.0E0 )
+ REAL HALF
+ PARAMETER ( HALF = 0.5E0 )
+* ..
+* .. Local Scalars ..
+ INTEGER SGN1, SGN2
+ REAL AB, ACMN, ACMX, ACS, ADF, CS, CT, DF, RT, SM,
+ $ TB, TN
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, SQRT
+* ..
+* .. Executable Statements ..
+*
+* Compute the eigenvalues
+*
+ SM = A + C
+ DF = A - C
+ ADF = ABS( DF )
+ TB = B + B
+ AB = ABS( TB )
+ IF( ABS( A ).GT.ABS( C ) ) THEN
+ ACMX = A
+ ACMN = C
+ ELSE
+ ACMX = C
+ ACMN = A
+ END IF
+ IF( ADF.GT.AB ) THEN
+ RT = ADF*SQRT( ONE+( AB / ADF )**2 )
+ ELSE IF( ADF.LT.AB ) THEN
+ RT = AB*SQRT( ONE+( ADF / AB )**2 )
+ ELSE
+*
+* Includes case AB=ADF=0
+*
+ RT = AB*SQRT( TWO )
+ END IF
+ IF( SM.LT.ZERO ) THEN
+ RT1 = HALF*( SM-RT )
+ SGN1 = -1
+*
+* Order of execution important.
+* To get fully accurate smaller eigenvalue,
+* next line needs to be executed in higher precision.
+*
+ RT2 = ( ACMX / RT1 )*ACMN - ( B / RT1 )*B
+ ELSE IF( SM.GT.ZERO ) THEN
+ RT1 = HALF*( SM+RT )
+ SGN1 = 1
+*
+* Order of execution important.
+* To get fully accurate smaller eigenvalue,
+* next line needs to be executed in higher precision.
+*
+ RT2 = ( ACMX / RT1 )*ACMN - ( B / RT1 )*B
+ ELSE
+*
+* Includes case RT1 = RT2 = 0
+*
+ RT1 = HALF*RT
+ RT2 = -HALF*RT
+ SGN1 = 1
+ END IF
+*
+* Compute the eigenvector
+*
+ IF( DF.GE.ZERO ) THEN
+ CS = DF + RT
+ SGN2 = 1
+ ELSE
+ CS = DF - RT
+ SGN2 = -1
+ END IF
+ ACS = ABS( CS )
+ IF( ACS.GT.AB ) THEN
+ CT = -TB / CS
+ SN1 = ONE / SQRT( ONE+CT*CT )
+ CS1 = CT*SN1
+ ELSE
+ IF( AB.EQ.ZERO ) THEN
+ CS1 = ONE
+ SN1 = ZERO
+ ELSE
+ TN = -CS / TB
+ CS1 = ONE / SQRT( ONE+TN*TN )
+ SN1 = TN*CS1
+ END IF
+ END IF
+ IF( SGN1.EQ.SGN2 ) THEN
+ TN = CS1
+ CS1 = -SN1
+ SN1 = TN
+ END IF
+ RETURN
+*
+* End of SLAEV2
+*
+ END
+ SUBROUTINE SLAEXC( WANTQ, N, T, LDT, Q, LDQ, J1, N1, N2, WORK,
+ $ INFO )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ LOGICAL WANTQ
+ INTEGER INFO, J1, LDQ, LDT, N, N1, N2
+* ..
+* .. Array Arguments ..
+ REAL Q( LDQ, * ), T( LDT, * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SLAEXC swaps adjacent diagonal blocks T11 and T22 of order 1 or 2 in
+* an upper quasi-triangular matrix T by an orthogonal similarity
+* transformation.
+*
+* T must be in Schur canonical form, that is, block upper triangular
+* with 1-by-1 and 2-by-2 diagonal blocks; each 2-by-2 diagonal block
+* has its diagonal elemnts equal and its off-diagonal elements of
+* opposite sign.
+*
+* Arguments
+* =========
+*
+* WANTQ (input) LOGICAL
+* = .TRUE. : accumulate the transformation in the matrix Q;
+* = .FALSE.: do not accumulate the transformation.
+*
+* N (input) INTEGER
+* The order of the matrix T. N >= 0.
+*
+* T (input/output) REAL array, dimension (LDT,N)
+* On entry, the upper quasi-triangular matrix T, in Schur
+* canonical form.
+* On exit, the updated matrix T, again in Schur canonical form.
+*
+* LDT (input) INTEGER
+* The leading dimension of the array T. LDT >= max(1,N).
+*
+* Q (input/output) REAL array, dimension (LDQ,N)
+* On entry, if WANTQ is .TRUE., the orthogonal matrix Q.
+* On exit, if WANTQ is .TRUE., the updated matrix Q.
+* If WANTQ is .FALSE., Q is not referenced.
+*
+* LDQ (input) INTEGER
+* The leading dimension of the array Q.
+* LDQ >= 1; and if WANTQ is .TRUE., LDQ >= N.
+*
+* J1 (input) INTEGER
+* The index of the first row of the first block T11.
+*
+* N1 (input) INTEGER
+* The order of the first block T11. N1 = 0, 1 or 2.
+*
+* N2 (input) INTEGER
+* The order of the second block T22. N2 = 0, 1 or 2.
+*
+* WORK (workspace) REAL array, dimension (N)
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* = 1: the transformed matrix T would be too far from Schur
+* form; the blocks are not swapped and T and Q are
+* unchanged.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO, ONE
+ PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+ REAL TEN
+ PARAMETER ( TEN = 1.0E+1 )
+ INTEGER LDD, LDX
+ PARAMETER ( LDD = 4, LDX = 2 )
+* ..
+* .. Local Scalars ..
+ INTEGER IERR, J2, J3, J4, K, ND
+ REAL CS, DNORM, EPS, SCALE, SMLNUM, SN, T11, T22,
+ $ T33, TAU, TAU1, TAU2, TEMP, THRESH, WI1, WI2,
+ $ WR1, WR2, XNORM
+* ..
+* .. Local Arrays ..
+ REAL D( LDD, 4 ), U( 3 ), U1( 3 ), U2( 3 ),
+ $ X( LDX, 2 )
+* ..
+* .. External Functions ..
+ REAL SLAMCH, SLANGE
+ EXTERNAL SLAMCH, SLANGE
+* ..
+* .. External Subroutines ..
+ EXTERNAL SLACPY, SLANV2, SLARFG, SLARFX, SLARTG, SLASY2,
+ $ SROT
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX
+* ..
+* .. Executable Statements ..
+*
+ INFO = 0
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 .OR. N1.EQ.0 .OR. N2.EQ.0 )
+ $ RETURN
+ IF( J1+N1.GT.N )
+ $ RETURN
+*
+ J2 = J1 + 1
+ J3 = J1 + 2
+ J4 = J1 + 3
+*
+ IF( N1.EQ.1 .AND. N2.EQ.1 ) THEN
+*
+* Swap two 1-by-1 blocks.
+*
+ T11 = T( J1, J1 )
+ T22 = T( J2, J2 )
+*
+* Determine the transformation to perform the interchange.
+*
+ CALL SLARTG( T( J1, J2 ), T22-T11, CS, SN, TEMP )
+*
+* Apply transformation to the matrix T.
+*
+ IF( J3.LE.N )
+ $ CALL SROT( N-J1-1, T( J1, J3 ), LDT, T( J2, J3 ), LDT, CS,
+ $ SN )
+ CALL SROT( J1-1, T( 1, J1 ), 1, T( 1, J2 ), 1, CS, SN )
+*
+ T( J1, J1 ) = T22
+ T( J2, J2 ) = T11
+*
+ IF( WANTQ ) THEN
+*
+* Accumulate transformation in the matrix Q.
+*
+ CALL SROT( N, Q( 1, J1 ), 1, Q( 1, J2 ), 1, CS, SN )
+ END IF
+*
+ ELSE
+*
+* Swapping involves at least one 2-by-2 block.
+*
+* Copy the diagonal block of order N1+N2 to the local array D
+* and compute its norm.
+*
+ ND = N1 + N2
+ CALL SLACPY( 'Full', ND, ND, T( J1, J1 ), LDT, D, LDD )
+ DNORM = SLANGE( 'Max', ND, ND, D, LDD, WORK )
+*
+* Compute machine-dependent threshold for test for accepting
+* swap.
+*
+ EPS = SLAMCH( 'P' )
+ SMLNUM = SLAMCH( 'S' ) / EPS
+ THRESH = MAX( TEN*EPS*DNORM, SMLNUM )
+*
+* Solve T11*X - X*T22 = scale*T12 for X.
+*
+ CALL SLASY2( .FALSE., .FALSE., -1, N1, N2, D, LDD,
+ $ D( N1+1, N1+1 ), LDD, D( 1, N1+1 ), LDD, SCALE, X,
+ $ LDX, XNORM, IERR )
+*
+* Swap the adjacent diagonal blocks.
+*
+ K = N1 + N1 + N2 - 3
+ GO TO ( 10, 20, 30 )K
+*
+ 10 CONTINUE
+*
+* N1 = 1, N2 = 2: generate elementary reflector H so that:
+*
+* ( scale, X11, X12 ) H = ( 0, 0, * )
+*
+ U( 1 ) = SCALE
+ U( 2 ) = X( 1, 1 )
+ U( 3 ) = X( 1, 2 )
+ CALL SLARFG( 3, U( 3 ), U, 1, TAU )
+ U( 3 ) = ONE
+ T11 = T( J1, J1 )
+*
+* Perform swap provisionally on diagonal block in D.
+*
+ CALL SLARFX( 'L', 3, 3, U, TAU, D, LDD, WORK )
+ CALL SLARFX( 'R', 3, 3, U, TAU, D, LDD, WORK )
+*
+* Test whether to reject swap.
+*
+ IF( MAX( ABS( D( 3, 1 ) ), ABS( D( 3, 2 ) ), ABS( D( 3,
+ $ 3 )-T11 ) ).GT.THRESH )GO TO 50
+*
+* Accept swap: apply transformation to the entire matrix T.
+*
+ CALL SLARFX( 'L', 3, N-J1+1, U, TAU, T( J1, J1 ), LDT, WORK )
+ CALL SLARFX( 'R', J2, 3, U, TAU, T( 1, J1 ), LDT, WORK )
+*
+ T( J3, J1 ) = ZERO
+ T( J3, J2 ) = ZERO
+ T( J3, J3 ) = T11
+*
+ IF( WANTQ ) THEN
+*
+* Accumulate transformation in the matrix Q.
+*
+ CALL SLARFX( 'R', N, 3, U, TAU, Q( 1, J1 ), LDQ, WORK )
+ END IF
+ GO TO 40
+*
+ 20 CONTINUE
+*
+* N1 = 2, N2 = 1: generate elementary reflector H so that:
+*
+* H ( -X11 ) = ( * )
+* ( -X21 ) = ( 0 )
+* ( scale ) = ( 0 )
+*
+ U( 1 ) = -X( 1, 1 )
+ U( 2 ) = -X( 2, 1 )
+ U( 3 ) = SCALE
+ CALL SLARFG( 3, U( 1 ), U( 2 ), 1, TAU )
+ U( 1 ) = ONE
+ T33 = T( J3, J3 )
+*
+* Perform swap provisionally on diagonal block in D.
+*
+ CALL SLARFX( 'L', 3, 3, U, TAU, D, LDD, WORK )
+ CALL SLARFX( 'R', 3, 3, U, TAU, D, LDD, WORK )
+*
+* Test whether to reject swap.
+*
+ IF( MAX( ABS( D( 2, 1 ) ), ABS( D( 3, 1 ) ), ABS( D( 1,
+ $ 1 )-T33 ) ).GT.THRESH )GO TO 50
+*
+* Accept swap: apply transformation to the entire matrix T.
+*
+ CALL SLARFX( 'R', J3, 3, U, TAU, T( 1, J1 ), LDT, WORK )
+ CALL SLARFX( 'L', 3, N-J1, U, TAU, T( J1, J2 ), LDT, WORK )
+*
+ T( J1, J1 ) = T33
+ T( J2, J1 ) = ZERO
+ T( J3, J1 ) = ZERO
+*
+ IF( WANTQ ) THEN
+*
+* Accumulate transformation in the matrix Q.
+*
+ CALL SLARFX( 'R', N, 3, U, TAU, Q( 1, J1 ), LDQ, WORK )
+ END IF
+ GO TO 40
+*
+ 30 CONTINUE
+*
+* N1 = 2, N2 = 2: generate elementary reflectors H(1) and H(2) so
+* that:
+*
+* H(2) H(1) ( -X11 -X12 ) = ( * * )
+* ( -X21 -X22 ) ( 0 * )
+* ( scale 0 ) ( 0 0 )
+* ( 0 scale ) ( 0 0 )
+*
+ U1( 1 ) = -X( 1, 1 )
+ U1( 2 ) = -X( 2, 1 )
+ U1( 3 ) = SCALE
+ CALL SLARFG( 3, U1( 1 ), U1( 2 ), 1, TAU1 )
+ U1( 1 ) = ONE
+*
+ TEMP = -TAU1*( X( 1, 2 )+U1( 2 )*X( 2, 2 ) )
+ U2( 1 ) = -TEMP*U1( 2 ) - X( 2, 2 )
+ U2( 2 ) = -TEMP*U1( 3 )
+ U2( 3 ) = SCALE
+ CALL SLARFG( 3, U2( 1 ), U2( 2 ), 1, TAU2 )
+ U2( 1 ) = ONE
+*
+* Perform swap provisionally on diagonal block in D.
+*
+ CALL SLARFX( 'L', 3, 4, U1, TAU1, D, LDD, WORK )
+ CALL SLARFX( 'R', 4, 3, U1, TAU1, D, LDD, WORK )
+ CALL SLARFX( 'L', 3, 4, U2, TAU2, D( 2, 1 ), LDD, WORK )
+ CALL SLARFX( 'R', 4, 3, U2, TAU2, D( 1, 2 ), LDD, WORK )
+*
+* Test whether to reject swap.
+*
+ IF( MAX( ABS( D( 3, 1 ) ), ABS( D( 3, 2 ) ), ABS( D( 4, 1 ) ),
+ $ ABS( D( 4, 2 ) ) ).GT.THRESH )GO TO 50
+*
+* Accept swap: apply transformation to the entire matrix T.
+*
+ CALL SLARFX( 'L', 3, N-J1+1, U1, TAU1, T( J1, J1 ), LDT, WORK )
+ CALL SLARFX( 'R', J4, 3, U1, TAU1, T( 1, J1 ), LDT, WORK )
+ CALL SLARFX( 'L', 3, N-J1+1, U2, TAU2, T( J2, J1 ), LDT, WORK )
+ CALL SLARFX( 'R', J4, 3, U2, TAU2, T( 1, J2 ), LDT, WORK )
+*
+ T( J3, J1 ) = ZERO
+ T( J3, J2 ) = ZERO
+ T( J4, J1 ) = ZERO
+ T( J4, J2 ) = ZERO
+*
+ IF( WANTQ ) THEN
+*
+* Accumulate transformation in the matrix Q.
+*
+ CALL SLARFX( 'R', N, 3, U1, TAU1, Q( 1, J1 ), LDQ, WORK )
+ CALL SLARFX( 'R', N, 3, U2, TAU2, Q( 1, J2 ), LDQ, WORK )
+ END IF
+*
+ 40 CONTINUE
+*
+ IF( N2.EQ.2 ) THEN
+*
+* Standardize new 2-by-2 block T11
+*
+ CALL SLANV2( T( J1, J1 ), T( J1, J2 ), T( J2, J1 ),
+ $ T( J2, J2 ), WR1, WI1, WR2, WI2, CS, SN )
+ CALL SROT( N-J1-1, T( J1, J1+2 ), LDT, T( J2, J1+2 ), LDT,
+ $ CS, SN )
+ CALL SROT( J1-1, T( 1, J1 ), 1, T( 1, J2 ), 1, CS, SN )
+ IF( WANTQ )
+ $ CALL SROT( N, Q( 1, J1 ), 1, Q( 1, J2 ), 1, CS, SN )
+ END IF
+*
+ IF( N1.EQ.2 ) THEN
+*
+* Standardize new 2-by-2 block T22
+*
+ J3 = J1 + N2
+ J4 = J3 + 1
+ CALL SLANV2( T( J3, J3 ), T( J3, J4 ), T( J4, J3 ),
+ $ T( J4, J4 ), WR1, WI1, WR2, WI2, CS, SN )
+ IF( J3+2.LE.N )
+ $ CALL SROT( N-J3-1, T( J3, J3+2 ), LDT, T( J4, J3+2 ),
+ $ LDT, CS, SN )
+ CALL SROT( J3-1, T( 1, J3 ), 1, T( 1, J4 ), 1, CS, SN )
+ IF( WANTQ )
+ $ CALL SROT( N, Q( 1, J3 ), 1, Q( 1, J4 ), 1, CS, SN )
+ END IF
+*
+ END IF
+ RETURN
+*
+* Exit with INFO = 1 if swap was rejected.
+*
+ 50 INFO = 1
+ RETURN
+*
+* End of SLAEXC
+*
+ END
+ SUBROUTINE SLAG2( A, LDA, B, LDB, SAFMIN, SCALE1, SCALE2, WR1,
+ $ WR2, WI )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER LDA, LDB
+ REAL SAFMIN, SCALE1, SCALE2, WI, WR1, WR2
+* ..
+* .. Array Arguments ..
+ REAL A( LDA, * ), B( LDB, * )
+* ..
+*
+* Purpose
+* =======
+*
+* SLAG2 computes the eigenvalues of a 2 x 2 generalized eigenvalue
+* problem A - w B, with scaling as necessary to avoid over-/underflow.
+*
+* The scaling factor "s" results in a modified eigenvalue equation
+*
+* s A - w B
+*
+* where s is a non-negative scaling factor chosen so that w, w B,
+* and s A do not overflow and, if possible, do not underflow, either.
+*
+* Arguments
+* =========
+*
+* A (input) REAL array, dimension (LDA, 2)
+* On entry, the 2 x 2 matrix A. It is assumed that its 1-norm
+* is less than 1/SAFMIN. Entries less than
+* sqrt(SAFMIN)*norm(A) are subject to being treated as zero.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= 2.
+*
+* B (input) REAL array, dimension (LDB, 2)
+* On entry, the 2 x 2 upper triangular matrix B. It is
+* assumed that the one-norm of B is less than 1/SAFMIN. The
+* diagonals should be at least sqrt(SAFMIN) times the largest
+* element of B (in absolute value); if a diagonal is smaller
+* than that, then +/- sqrt(SAFMIN) will be used instead of
+* that diagonal.
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. LDB >= 2.
+*
+* SAFMIN (input) REAL
+* The smallest positive number s.t. 1/SAFMIN does not
+* overflow. (This should always be SLAMCH('S') -- it is an
+* argument in order to avoid having to call SLAMCH frequently.)
+*
+* SCALE1 (output) REAL
+* A scaling factor used to avoid over-/underflow in the
+* eigenvalue equation which defines the first eigenvalue. If
+* the eigenvalues are complex, then the eigenvalues are
+* ( WR1 +/- WI i ) / SCALE1 (which may lie outside the
+* exponent range of the machine), SCALE1=SCALE2, and SCALE1
+* will always be positive. If the eigenvalues are real, then
+* the first (real) eigenvalue is WR1 / SCALE1 , but this may
+* overflow or underflow, and in fact, SCALE1 may be zero or
+* less than the underflow threshhold if the exact eigenvalue
+* is sufficiently large.
+*
+* SCALE2 (output) REAL
+* A scaling factor used to avoid over-/underflow in the
+* eigenvalue equation which defines the second eigenvalue. If
+* the eigenvalues are complex, then SCALE2=SCALE1. If the
+* eigenvalues are real, then the second (real) eigenvalue is
+* WR2 / SCALE2 , but this may overflow or underflow, and in
+* fact, SCALE2 may be zero or less than the underflow
+* threshhold if the exact eigenvalue is sufficiently large.
+*
+* WR1 (output) REAL
+* If the eigenvalue is real, then WR1 is SCALE1 times the
+* eigenvalue closest to the (2,2) element of A B**(-1). If the
+* eigenvalue is complex, then WR1=WR2 is SCALE1 times the real
+* part of the eigenvalues.
+*
+* WR2 (output) REAL
+* If the eigenvalue is real, then WR2 is SCALE2 times the
+* other eigenvalue. If the eigenvalue is complex, then
+* WR1=WR2 is SCALE1 times the real part of the eigenvalues.
+*
+* WI (output) REAL
+* If the eigenvalue is real, then WI is zero. If the
+* eigenvalue is complex, then WI is SCALE1 times the imaginary
+* part of the eigenvalues. WI will always be non-negative.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO, ONE, TWO
+ PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0, TWO = 2.0E+0 )
+ REAL HALF
+ PARAMETER ( HALF = ONE / TWO )
+ REAL FUZZY1
+ PARAMETER ( FUZZY1 = ONE+1.0E-5 )
+* ..
+* .. Local Scalars ..
+ REAL A11, A12, A21, A22, ABI22, ANORM, AS11, AS12,
+ $ AS22, ASCALE, B11, B12, B22, BINV11, BINV22,
+ $ BMIN, BNORM, BSCALE, BSIZE, C1, C2, C3, C4, C5,
+ $ DIFF, DISCR, PP, QQ, R, RTMAX, RTMIN, S1, S2,
+ $ SAFMAX, SHIFT, SS, SUM, WABS, WBIG, WDET,
+ $ WSCALE, WSIZE, WSMALL
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, MIN, SIGN, SQRT
+* ..
+* .. Executable Statements ..
+*
+ RTMIN = SQRT( SAFMIN )
+ RTMAX = ONE / RTMIN
+ SAFMAX = ONE / SAFMIN
+*
+* Scale A
+*
+ ANORM = MAX( ABS( A( 1, 1 ) )+ABS( A( 2, 1 ) ),
+ $ ABS( A( 1, 2 ) )+ABS( A( 2, 2 ) ), SAFMIN )
+ ASCALE = ONE / ANORM
+ A11 = ASCALE*A( 1, 1 )
+ A21 = ASCALE*A( 2, 1 )
+ A12 = ASCALE*A( 1, 2 )
+ A22 = ASCALE*A( 2, 2 )
+*
+* Perturb B if necessary to insure non-singularity
+*
+ B11 = B( 1, 1 )
+ B12 = B( 1, 2 )
+ B22 = B( 2, 2 )
+ BMIN = RTMIN*MAX( ABS( B11 ), ABS( B12 ), ABS( B22 ), RTMIN )
+ IF( ABS( B11 ).LT.BMIN )
+ $ B11 = SIGN( BMIN, B11 )
+ IF( ABS( B22 ).LT.BMIN )
+ $ B22 = SIGN( BMIN, B22 )
+*
+* Scale B
+*
+ BNORM = MAX( ABS( B11 ), ABS( B12 )+ABS( B22 ), SAFMIN )
+ BSIZE = MAX( ABS( B11 ), ABS( B22 ) )
+ BSCALE = ONE / BSIZE
+ B11 = B11*BSCALE
+ B12 = B12*BSCALE
+ B22 = B22*BSCALE
+*
+* Compute larger eigenvalue by method described by C. van Loan
+*
+* ( AS is A shifted by -SHIFT*B )
+*
+ BINV11 = ONE / B11
+ BINV22 = ONE / B22
+ S1 = A11*BINV11
+ S2 = A22*BINV22
+ IF( ABS( S1 ).LE.ABS( S2 ) ) THEN
+ AS12 = A12 - S1*B12
+ AS22 = A22 - S1*B22
+ SS = A21*( BINV11*BINV22 )
+ ABI22 = AS22*BINV22 - SS*B12
+ PP = HALF*ABI22
+ SHIFT = S1
+ ELSE
+ AS12 = A12 - S2*B12
+ AS11 = A11 - S2*B11
+ SS = A21*( BINV11*BINV22 )
+ ABI22 = -SS*B12
+ PP = HALF*( AS11*BINV11+ABI22 )
+ SHIFT = S2
+ END IF
+ QQ = SS*AS12
+ IF( ABS( PP*RTMIN ).GE.ONE ) THEN
+ DISCR = ( RTMIN*PP )**2 + QQ*SAFMIN
+ R = SQRT( ABS( DISCR ) )*RTMAX
+ ELSE
+ IF( PP**2+ABS( QQ ).LE.SAFMIN ) THEN
+ DISCR = ( RTMAX*PP )**2 + QQ*SAFMAX
+ R = SQRT( ABS( DISCR ) )*RTMIN
+ ELSE
+ DISCR = PP**2 + QQ
+ R = SQRT( ABS( DISCR ) )
+ END IF
+ END IF
+*
+* Note: the test of R in the following IF is to cover the case when
+* DISCR is small and negative and is flushed to zero during
+* the calculation of R. On machines which have a consistent
+* flush-to-zero threshhold and handle numbers above that
+* threshhold correctly, it would not be necessary.
+*
+ IF( DISCR.GE.ZERO .OR. R.EQ.ZERO ) THEN
+ SUM = PP + SIGN( R, PP )
+ DIFF = PP - SIGN( R, PP )
+ WBIG = SHIFT + SUM
+*
+* Compute smaller eigenvalue
+*
+ WSMALL = SHIFT + DIFF
+ IF( HALF*ABS( WBIG ).GT.MAX( ABS( WSMALL ), SAFMIN ) ) THEN
+ WDET = ( A11*A22-A12*A21 )*( BINV11*BINV22 )
+ WSMALL = WDET / WBIG
+ END IF
+*
+* Choose (real) eigenvalue closest to 2,2 element of A*B**(-1)
+* for WR1.
+*
+ IF( PP.GT.ABI22 ) THEN
+ WR1 = MIN( WBIG, WSMALL )
+ WR2 = MAX( WBIG, WSMALL )
+ ELSE
+ WR1 = MAX( WBIG, WSMALL )
+ WR2 = MIN( WBIG, WSMALL )
+ END IF
+ WI = ZERO
+ ELSE
+*
+* Complex eigenvalues
+*
+ WR1 = SHIFT + PP
+ WR2 = WR1
+ WI = R
+ END IF
+*
+* Further scaling to avoid underflow and overflow in computing
+* SCALE1 and overflow in computing w*B.
+*
+* This scale factor (WSCALE) is bounded from above using C1 and C2,
+* and from below using C3 and C4.
+* C1 implements the condition s A must never overflow.
+* C2 implements the condition w B must never overflow.
+* C3, with C2,
+* implement the condition that s A - w B must never overflow.
+* C4 implements the condition s should not underflow.
+* C5 implements the condition max(s,|w|) should be at least 2.
+*
+ C1 = BSIZE*( SAFMIN*MAX( ONE, ASCALE ) )
+ C2 = SAFMIN*MAX( ONE, BNORM )
+ C3 = BSIZE*SAFMIN
+ IF( ASCALE.LE.ONE .AND. BSIZE.LE.ONE ) THEN
+ C4 = MIN( ONE, ( ASCALE / SAFMIN )*BSIZE )
+ ELSE
+ C4 = ONE
+ END IF
+ IF( ASCALE.LE.ONE .OR. BSIZE.LE.ONE ) THEN
+ C5 = MIN( ONE, ASCALE*BSIZE )
+ ELSE
+ C5 = ONE
+ END IF
+*
+* Scale first eigenvalue
+*
+ WABS = ABS( WR1 ) + ABS( WI )
+ WSIZE = MAX( SAFMIN, C1, FUZZY1*( WABS*C2+C3 ),
+ $ MIN( C4, HALF*MAX( WABS, C5 ) ) )
+ IF( WSIZE.NE.ONE ) THEN
+ WSCALE = ONE / WSIZE
+ IF( WSIZE.GT.ONE ) THEN
+ SCALE1 = ( MAX( ASCALE, BSIZE )*WSCALE )*
+ $ MIN( ASCALE, BSIZE )
+ ELSE
+ SCALE1 = ( MIN( ASCALE, BSIZE )*WSCALE )*
+ $ MAX( ASCALE, BSIZE )
+ END IF
+ WR1 = WR1*WSCALE
+ IF( WI.NE.ZERO ) THEN
+ WI = WI*WSCALE
+ WR2 = WR1
+ SCALE2 = SCALE1
+ END IF
+ ELSE
+ SCALE1 = ASCALE*BSIZE
+ SCALE2 = SCALE1
+ END IF
+*
+* Scale second eigenvalue (if real)
+*
+ IF( WI.EQ.ZERO ) THEN
+ WSIZE = MAX( SAFMIN, C1, FUZZY1*( ABS( WR2 )*C2+C3 ),
+ $ MIN( C4, HALF*MAX( ABS( WR2 ), C5 ) ) )
+ IF( WSIZE.NE.ONE ) THEN
+ WSCALE = ONE / WSIZE
+ IF( WSIZE.GT.ONE ) THEN
+ SCALE2 = ( MAX( ASCALE, BSIZE )*WSCALE )*
+ $ MIN( ASCALE, BSIZE )
+ ELSE
+ SCALE2 = ( MIN( ASCALE, BSIZE )*WSCALE )*
+ $ MAX( ASCALE, BSIZE )
+ END IF
+ WR2 = WR2*WSCALE
+ ELSE
+ SCALE2 = ASCALE*BSIZE
+ END IF
+ END IF
+*
+* End of SLAG2
+*
+ RETURN
+ END
+ SUBROUTINE SLAG2D( M, N, SA, LDSA, A, LDA, INFO)
+*
+* -- LAPACK PROTOTYPE auxiliary routine (version 3.1.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* January 2007
+*
+* ..
+* .. WARNING: PROTOTYPE ..
+* This is an LAPACK PROTOTYPE routine which means that the
+* interface of this routine is likely to be changed in the future
+* based on community feedback.
+*
+* .. Scalar Arguments ..
+ INTEGER INFO,LDA,LDSA,M,N
+* ..
+* .. Array Arguments ..
+ REAL SA(LDSA,*)
+ DOUBLE PRECISION A(LDA,*)
+* ..
+*
+* Purpose
+* =======
+*
+* SLAG2D converts a SINGLE PRECISION matrix, SA, to a DOUBLE
+* PRECISION matrix, A.
+*
+* Note that while it is possible to overflow while converting
+* from double to single, it is not possible to overflow when
+* converting from single to double.
+*
+* This is a helper routine so there is no argument checking.
+*
+* Arguments
+* =========
+*
+* M (input) INTEGER
+* The number of lines of the matrix A. M >= 0.
+*
+* N (input) INTEGER
+* The number of columns of the matrix A. N >= 0.
+*
+* SA (output) REAL array, dimension (LDSA,N)
+* On exit, the M-by-N coefficient matrix SA.
+*
+* LDSA (input) INTEGER
+* The leading dimension of the array SA. LDSA >= max(1,M).
+*
+* A (input) DOUBLE PRECISION array, dimension (LDA,N)
+* On entry, the M-by-N coefficient matrix A.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,M).
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* =========
+*
+* .. Local Scalars ..
+ INTEGER I,J
+* ..
+* .. Executable Statements ..
+*
+ INFO = 0
+ DO 20 J = 1,N
+ DO 30 I = 1,M
+ A(I,J) = SA(I,J)
+ 30 CONTINUE
+ 20 CONTINUE
+ RETURN
+*
+* End of SLAG2D
+*
+ END
+ SUBROUTINE SLAGS2( UPPER, A1, A2, A3, B1, B2, B3, CSU, SNU, CSV,
+ $ SNV, CSQ, SNQ )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ LOGICAL UPPER
+ REAL A1, A2, A3, B1, B2, B3, CSQ, CSU, CSV, SNQ,
+ $ SNU, SNV
+* ..
+*
+* Purpose
+* =======
+*
+* SLAGS2 computes 2-by-2 orthogonal matrices U, V and Q, such
+* that if ( UPPER ) then
+*
+* U'*A*Q = U'*( A1 A2 )*Q = ( x 0 )
+* ( 0 A3 ) ( x x )
+* and
+* V'*B*Q = V'*( B1 B2 )*Q = ( x 0 )
+* ( 0 B3 ) ( x x )
+*
+* or if ( .NOT.UPPER ) then
+*
+* U'*A*Q = U'*( A1 0 )*Q = ( x x )
+* ( A2 A3 ) ( 0 x )
+* and
+* V'*B*Q = V'*( B1 0 )*Q = ( x x )
+* ( B2 B3 ) ( 0 x )
+*
+* The rows of the transformed A and B are parallel, where
+*
+* U = ( CSU SNU ), V = ( CSV SNV ), Q = ( CSQ SNQ )
+* ( -SNU CSU ) ( -SNV CSV ) ( -SNQ CSQ )
+*
+* Z' denotes the transpose of Z.
+*
+*
+* Arguments
+* =========
+*
+* UPPER (input) LOGICAL
+* = .TRUE.: the input matrices A and B are upper triangular.
+* = .FALSE.: the input matrices A and B are lower triangular.
+*
+* A1 (input) REAL
+* A2 (input) REAL
+* A3 (input) REAL
+* On entry, A1, A2 and A3 are elements of the input 2-by-2
+* upper (lower) triangular matrix A.
+*
+* B1 (input) REAL
+* B2 (input) REAL
+* B3 (input) REAL
+* On entry, B1, B2 and B3 are elements of the input 2-by-2
+* upper (lower) triangular matrix B.
+*
+* CSU (output) REAL
+* SNU (output) REAL
+* The desired orthogonal matrix U.
+*
+* CSV (output) REAL
+* SNV (output) REAL
+* The desired orthogonal matrix V.
+*
+* CSQ (output) REAL
+* SNQ (output) REAL
+* The desired orthogonal matrix Q.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO
+ PARAMETER ( ZERO = 0.0E+0 )
+* ..
+* .. Local Scalars ..
+ REAL A, AUA11, AUA12, AUA21, AUA22, AVB11, AVB12,
+ $ AVB21, AVB22, CSL, CSR, D, S1, S2, SNL,
+ $ SNR, UA11R, UA22R, VB11R, VB22R, B, C, R, UA11,
+ $ UA12, UA21, UA22, VB11, VB12, VB21, VB22
+* ..
+* .. External Subroutines ..
+ EXTERNAL SLARTG, SLASV2
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS
+* ..
+* .. Executable Statements ..
+*
+ IF( UPPER ) THEN
+*
+* Input matrices A and B are upper triangular matrices
+*
+* Form matrix C = A*adj(B) = ( a b )
+* ( 0 d )
+*
+ A = A1*B3
+ D = A3*B1
+ B = A2*B1 - A1*B2
+*
+* The SVD of real 2-by-2 triangular C
+*
+* ( CSL -SNL )*( A B )*( CSR SNR ) = ( R 0 )
+* ( SNL CSL ) ( 0 D ) ( -SNR CSR ) ( 0 T )
+*
+ CALL SLASV2( A, B, D, S1, S2, SNR, CSR, SNL, CSL )
+*
+ IF( ABS( CSL ).GE.ABS( SNL ) .OR. ABS( CSR ).GE.ABS( SNR ) )
+ $ THEN
+*
+* Compute the (1,1) and (1,2) elements of U'*A and V'*B,
+* and (1,2) element of |U|'*|A| and |V|'*|B|.
+*
+ UA11R = CSL*A1
+ UA12 = CSL*A2 + SNL*A3
+*
+ VB11R = CSR*B1
+ VB12 = CSR*B2 + SNR*B3
+*
+ AUA12 = ABS( CSL )*ABS( A2 ) + ABS( SNL )*ABS( A3 )
+ AVB12 = ABS( CSR )*ABS( B2 ) + ABS( SNR )*ABS( B3 )
+*
+* zero (1,2) elements of U'*A and V'*B
+*
+ IF( ( ABS( UA11R )+ABS( UA12 ) ).NE.ZERO ) THEN
+ IF( AUA12 / ( ABS( UA11R )+ABS( UA12 ) ).LE.AVB12 /
+ $ ( ABS( VB11R )+ABS( VB12 ) ) ) THEN
+ CALL SLARTG( -UA11R, UA12, CSQ, SNQ, R )
+ ELSE
+ CALL SLARTG( -VB11R, VB12, CSQ, SNQ, R )
+ END IF
+ ELSE
+ CALL SLARTG( -VB11R, VB12, CSQ, SNQ, R )
+ END IF
+*
+ CSU = CSL
+ SNU = -SNL
+ CSV = CSR
+ SNV = -SNR
+*
+ ELSE
+*
+* Compute the (2,1) and (2,2) elements of U'*A and V'*B,
+* and (2,2) element of |U|'*|A| and |V|'*|B|.
+*
+ UA21 = -SNL*A1
+ UA22 = -SNL*A2 + CSL*A3
+*
+ VB21 = -SNR*B1
+ VB22 = -SNR*B2 + CSR*B3
+*
+ AUA22 = ABS( SNL )*ABS( A2 ) + ABS( CSL )*ABS( A3 )
+ AVB22 = ABS( SNR )*ABS( B2 ) + ABS( CSR )*ABS( B3 )
+*
+* zero (2,2) elements of U'*A and V'*B, and then swap.
+*
+ IF( ( ABS( UA21 )+ABS( UA22 ) ).NE.ZERO ) THEN
+ IF( AUA22 / ( ABS( UA21 )+ABS( UA22 ) ).LE.AVB22 /
+ $ ( ABS( VB21 )+ABS( VB22 ) ) ) THEN
+ CALL SLARTG( -UA21, UA22, CSQ, SNQ, R )
+ ELSE
+ CALL SLARTG( -VB21, VB22, CSQ, SNQ, R )
+ END IF
+ ELSE
+ CALL SLARTG( -VB21, VB22, CSQ, SNQ, R )
+ END IF
+*
+ CSU = SNL
+ SNU = CSL
+ CSV = SNR
+ SNV = CSR
+*
+ END IF
+*
+ ELSE
+*
+* Input matrices A and B are lower triangular matrices
+*
+* Form matrix C = A*adj(B) = ( a 0 )
+* ( c d )
+*
+ A = A1*B3
+ D = A3*B1
+ C = A2*B3 - A3*B2
+*
+* The SVD of real 2-by-2 triangular C
+*
+* ( CSL -SNL )*( A 0 )*( CSR SNR ) = ( R 0 )
+* ( SNL CSL ) ( C D ) ( -SNR CSR ) ( 0 T )
+*
+ CALL SLASV2( A, C, D, S1, S2, SNR, CSR, SNL, CSL )
+*
+ IF( ABS( CSR ).GE.ABS( SNR ) .OR. ABS( CSL ).GE.ABS( SNL ) )
+ $ THEN
+*
+* Compute the (2,1) and (2,2) elements of U'*A and V'*B,
+* and (2,1) element of |U|'*|A| and |V|'*|B|.
+*
+ UA21 = -SNR*A1 + CSR*A2
+ UA22R = CSR*A3
+*
+ VB21 = -SNL*B1 + CSL*B2
+ VB22R = CSL*B3
+*
+ AUA21 = ABS( SNR )*ABS( A1 ) + ABS( CSR )*ABS( A2 )
+ AVB21 = ABS( SNL )*ABS( B1 ) + ABS( CSL )*ABS( B2 )
+*
+* zero (2,1) elements of U'*A and V'*B.
+*
+ IF( ( ABS( UA21 )+ABS( UA22R ) ).NE.ZERO ) THEN
+ IF( AUA21 / ( ABS( UA21 )+ABS( UA22R ) ).LE.AVB21 /
+ $ ( ABS( VB21 )+ABS( VB22R ) ) ) THEN
+ CALL SLARTG( UA22R, UA21, CSQ, SNQ, R )
+ ELSE
+ CALL SLARTG( VB22R, VB21, CSQ, SNQ, R )
+ END IF
+ ELSE
+ CALL SLARTG( VB22R, VB21, CSQ, SNQ, R )
+ END IF
+*
+ CSU = CSR
+ SNU = -SNR
+ CSV = CSL
+ SNV = -SNL
+*
+ ELSE
+*
+* Compute the (1,1) and (1,2) elements of U'*A and V'*B,
+* and (1,1) element of |U|'*|A| and |V|'*|B|.
+*
+ UA11 = CSR*A1 + SNR*A2
+ UA12 = SNR*A3
+*
+ VB11 = CSL*B1 + SNL*B2
+ VB12 = SNL*B3
+*
+ AUA11 = ABS( CSR )*ABS( A1 ) + ABS( SNR )*ABS( A2 )
+ AVB11 = ABS( CSL )*ABS( B1 ) + ABS( SNL )*ABS( B2 )
+*
+* zero (1,1) elements of U'*A and V'*B, and then swap.
+*
+ IF( ( ABS( UA11 )+ABS( UA12 ) ).NE.ZERO ) THEN
+ IF( AUA11 / ( ABS( UA11 )+ABS( UA12 ) ).LE.AVB11 /
+ $ ( ABS( VB11 )+ABS( VB12 ) ) ) THEN
+ CALL SLARTG( UA12, UA11, CSQ, SNQ, R )
+ ELSE
+ CALL SLARTG( VB12, VB11, CSQ, SNQ, R )
+ END IF
+ ELSE
+ CALL SLARTG( VB12, VB11, CSQ, SNQ, R )
+ END IF
+*
+ CSU = SNR
+ SNU = CSR
+ CSV = SNL
+ SNV = CSL
+*
+ END IF
+*
+ END IF
+*
+ RETURN
+*
+* End of SLAGS2
+*
+ END
+ SUBROUTINE SLAGTF( N, A, LAMBDA, B, C, TOL, D, IN, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, N
+ REAL LAMBDA, TOL
+* ..
+* .. Array Arguments ..
+ INTEGER IN( * )
+ REAL A( * ), B( * ), C( * ), D( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SLAGTF factorizes the matrix (T - lambda*I), where T is an n by n
+* tridiagonal matrix and lambda is a scalar, as
+*
+* T - lambda*I = PLU,
+*
+* where P is a permutation matrix, L is a unit lower tridiagonal matrix
+* with at most one non-zero sub-diagonal elements per column and U is
+* an upper triangular matrix with at most two non-zero super-diagonal
+* elements per column.
+*
+* The factorization is obtained by Gaussian elimination with partial
+* pivoting and implicit row scaling.
+*
+* The parameter LAMBDA is included in the routine so that SLAGTF may
+* be used, in conjunction with SLAGTS, to obtain eigenvectors of T by
+* inverse iteration.
+*
+* Arguments
+* =========
+*
+* N (input) INTEGER
+* The order of the matrix T.
+*
+* A (input/output) REAL array, dimension (N)
+* On entry, A must contain the diagonal elements of T.
+*
+* On exit, A is overwritten by the n diagonal elements of the
+* upper triangular matrix U of the factorization of T.
+*
+* LAMBDA (input) REAL
+* On entry, the scalar lambda.
+*
+* B (input/output) REAL array, dimension (N-1)
+* On entry, B must contain the (n-1) super-diagonal elements of
+* T.
+*
+* On exit, B is overwritten by the (n-1) super-diagonal
+* elements of the matrix U of the factorization of T.
+*
+* C (input/output) REAL array, dimension (N-1)
+* On entry, C must contain the (n-1) sub-diagonal elements of
+* T.
+*
+* On exit, C is overwritten by the (n-1) sub-diagonal elements
+* of the matrix L of the factorization of T.
+*
+* TOL (input) REAL
+* On entry, a relative tolerance used to indicate whether or
+* not the matrix (T - lambda*I) is nearly singular. TOL should
+* normally be chose as approximately the largest relative error
+* in the elements of T. For example, if the elements of T are
+* correct to about 4 significant figures, then TOL should be
+* set to about 5*10**(-4). If TOL is supplied as less than eps,
+* where eps is the relative machine precision, then the value
+* eps is used in place of TOL.
+*
+* D (output) REAL array, dimension (N-2)
+* On exit, D is overwritten by the (n-2) second super-diagonal
+* elements of the matrix U of the factorization of T.
+*
+* IN (output) INTEGER array, dimension (N)
+* On exit, IN contains details of the permutation matrix P. If
+* an interchange occurred at the kth step of the elimination,
+* then IN(k) = 1, otherwise IN(k) = 0. The element IN(n)
+* returns the smallest positive integer j such that
+*
+* abs( u(j,j) ).le. norm( (T - lambda*I)(j) )*TOL,
+*
+* where norm( A(j) ) denotes the sum of the absolute values of
+* the jth row of the matrix A. If no such j exists then IN(n)
+* is returned as zero. If IN(n) is returned as positive, then a
+* diagonal element of U is small, indicating that
+* (T - lambda*I) is singular or nearly singular,
+*
+* INFO (output) INTEGER
+* = 0 : successful exit
+* .lt. 0: if INFO = -k, the kth argument had an illegal value
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO
+ PARAMETER ( ZERO = 0.0E+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER K
+ REAL EPS, MULT, PIV1, PIV2, SCALE1, SCALE2, TEMP, TL
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX
+* ..
+* .. External Functions ..
+ REAL SLAMCH
+ EXTERNAL SLAMCH
+* ..
+* .. External Subroutines ..
+ EXTERNAL XERBLA
+* ..
+* .. Executable Statements ..
+*
+ INFO = 0
+ IF( N.LT.0 ) THEN
+ INFO = -1
+ CALL XERBLA( 'SLAGTF', -INFO )
+ RETURN
+ END IF
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+ A( 1 ) = A( 1 ) - LAMBDA
+ IN( N ) = 0
+ IF( N.EQ.1 ) THEN
+ IF( A( 1 ).EQ.ZERO )
+ $ IN( 1 ) = 1
+ RETURN
+ END IF
+*
+ EPS = SLAMCH( 'Epsilon' )
+*
+ TL = MAX( TOL, EPS )
+ SCALE1 = ABS( A( 1 ) ) + ABS( B( 1 ) )
+ DO 10 K = 1, N - 1
+ A( K+1 ) = A( K+1 ) - LAMBDA
+ SCALE2 = ABS( C( K ) ) + ABS( A( K+1 ) )
+ IF( K.LT.( N-1 ) )
+ $ SCALE2 = SCALE2 + ABS( B( K+1 ) )
+ IF( A( K ).EQ.ZERO ) THEN
+ PIV1 = ZERO
+ ELSE
+ PIV1 = ABS( A( K ) ) / SCALE1
+ END IF
+ IF( C( K ).EQ.ZERO ) THEN
+ IN( K ) = 0
+ PIV2 = ZERO
+ SCALE1 = SCALE2
+ IF( K.LT.( N-1 ) )
+ $ D( K ) = ZERO
+ ELSE
+ PIV2 = ABS( C( K ) ) / SCALE2
+ IF( PIV2.LE.PIV1 ) THEN
+ IN( K ) = 0
+ SCALE1 = SCALE2
+ C( K ) = C( K ) / A( K )
+ A( K+1 ) = A( K+1 ) - C( K )*B( K )
+ IF( K.LT.( N-1 ) )
+ $ D( K ) = ZERO
+ ELSE
+ IN( K ) = 1
+ MULT = A( K ) / C( K )
+ A( K ) = C( K )
+ TEMP = A( K+1 )
+ A( K+1 ) = B( K ) - MULT*TEMP
+ IF( K.LT.( N-1 ) ) THEN
+ D( K ) = B( K+1 )
+ B( K+1 ) = -MULT*D( K )
+ END IF
+ B( K ) = TEMP
+ C( K ) = MULT
+ END IF
+ END IF
+ IF( ( MAX( PIV1, PIV2 ).LE.TL ) .AND. ( IN( N ).EQ.0 ) )
+ $ IN( N ) = K
+ 10 CONTINUE
+ IF( ( ABS( A( N ) ).LE.SCALE1*TL ) .AND. ( IN( N ).EQ.0 ) )
+ $ IN( N ) = N
+*
+ RETURN
+*
+* End of SLAGTF
+*
+ END
+ SUBROUTINE SLAGTM( TRANS, N, NRHS, ALPHA, DL, D, DU, X, LDX, BETA,
+ $ B, LDB )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER TRANS
+ INTEGER LDB, LDX, N, NRHS
+ REAL ALPHA, BETA
+* ..
+* .. Array Arguments ..
+ REAL B( LDB, * ), D( * ), DL( * ), DU( * ),
+ $ X( LDX, * )
+* ..
+*
+* Purpose
+* =======
+*
+* SLAGTM performs a matrix-vector product of the form
+*
+* B := alpha * A * X + beta * B
+*
+* where A is a tridiagonal matrix of order N, B and X are N by NRHS
+* matrices, and alpha and beta are real scalars, each of which may be
+* 0., 1., or -1.
+*
+* Arguments
+* =========
+*
+* TRANS (input) CHARACTER*1
+* Specifies the operation applied to A.
+* = 'N': No transpose, B := alpha * A * X + beta * B
+* = 'T': Transpose, B := alpha * A'* X + beta * B
+* = 'C': Conjugate transpose = Transpose
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* NRHS (input) INTEGER
+* The number of right hand sides, i.e., the number of columns
+* of the matrices X and B.
+*
+* ALPHA (input) REAL
+* The scalar alpha. ALPHA must be 0., 1., or -1.; otherwise,
+* it is assumed to be 0.
+*
+* DL (input) REAL array, dimension (N-1)
+* The (n-1) sub-diagonal elements of T.
+*
+* D (input) REAL array, dimension (N)
+* The diagonal elements of T.
+*
+* DU (input) REAL array, dimension (N-1)
+* The (n-1) super-diagonal elements of T.
+*
+* X (input) REAL array, dimension (LDX,NRHS)
+* The N by NRHS matrix X.
+* LDX (input) INTEGER
+* The leading dimension of the array X. LDX >= max(N,1).
+*
+* BETA (input) REAL
+* The scalar beta. BETA must be 0., 1., or -1.; otherwise,
+* it is assumed to be 1.
+*
+* B (input/output) REAL array, dimension (LDB,NRHS)
+* On entry, the N by NRHS matrix B.
+* On exit, B is overwritten by the matrix expression
+* B := alpha * A * X + beta * B.
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. LDB >= max(N,1).
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ONE, ZERO
+ PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, J
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. Executable Statements ..
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+* Multiply B by BETA if BETA.NE.1.
+*
+ IF( BETA.EQ.ZERO ) THEN
+ DO 20 J = 1, NRHS
+ DO 10 I = 1, N
+ B( I, J ) = ZERO
+ 10 CONTINUE
+ 20 CONTINUE
+ ELSE IF( BETA.EQ.-ONE ) THEN
+ DO 40 J = 1, NRHS
+ DO 30 I = 1, N
+ B( I, J ) = -B( I, J )
+ 30 CONTINUE
+ 40 CONTINUE
+ END IF
+*
+ IF( ALPHA.EQ.ONE ) THEN
+ IF( LSAME( TRANS, 'N' ) ) THEN
+*
+* Compute B := B + A*X
+*
+ DO 60 J = 1, NRHS
+ IF( N.EQ.1 ) THEN
+ B( 1, J ) = B( 1, J ) + D( 1 )*X( 1, J )
+ ELSE
+ B( 1, J ) = B( 1, J ) + D( 1 )*X( 1, J ) +
+ $ DU( 1 )*X( 2, J )
+ B( N, J ) = B( N, J ) + DL( N-1 )*X( N-1, J ) +
+ $ D( N )*X( N, J )
+ DO 50 I = 2, N - 1
+ B( I, J ) = B( I, J ) + DL( I-1 )*X( I-1, J ) +
+ $ D( I )*X( I, J ) + DU( I )*X( I+1, J )
+ 50 CONTINUE
+ END IF
+ 60 CONTINUE
+ ELSE
+*
+* Compute B := B + A'*X
+*
+ DO 80 J = 1, NRHS
+ IF( N.EQ.1 ) THEN
+ B( 1, J ) = B( 1, J ) + D( 1 )*X( 1, J )
+ ELSE
+ B( 1, J ) = B( 1, J ) + D( 1 )*X( 1, J ) +
+ $ DL( 1 )*X( 2, J )
+ B( N, J ) = B( N, J ) + DU( N-1 )*X( N-1, J ) +
+ $ D( N )*X( N, J )
+ DO 70 I = 2, N - 1
+ B( I, J ) = B( I, J ) + DU( I-1 )*X( I-1, J ) +
+ $ D( I )*X( I, J ) + DL( I )*X( I+1, J )
+ 70 CONTINUE
+ END IF
+ 80 CONTINUE
+ END IF
+ ELSE IF( ALPHA.EQ.-ONE ) THEN
+ IF( LSAME( TRANS, 'N' ) ) THEN
+*
+* Compute B := B - A*X
+*
+ DO 100 J = 1, NRHS
+ IF( N.EQ.1 ) THEN
+ B( 1, J ) = B( 1, J ) - D( 1 )*X( 1, J )
+ ELSE
+ B( 1, J ) = B( 1, J ) - D( 1 )*X( 1, J ) -
+ $ DU( 1 )*X( 2, J )
+ B( N, J ) = B( N, J ) - DL( N-1 )*X( N-1, J ) -
+ $ D( N )*X( N, J )
+ DO 90 I = 2, N - 1
+ B( I, J ) = B( I, J ) - DL( I-1 )*X( I-1, J ) -
+ $ D( I )*X( I, J ) - DU( I )*X( I+1, J )
+ 90 CONTINUE
+ END IF
+ 100 CONTINUE
+ ELSE
+*
+* Compute B := B - A'*X
+*
+ DO 120 J = 1, NRHS
+ IF( N.EQ.1 ) THEN
+ B( 1, J ) = B( 1, J ) - D( 1 )*X( 1, J )
+ ELSE
+ B( 1, J ) = B( 1, J ) - D( 1 )*X( 1, J ) -
+ $ DL( 1 )*X( 2, J )
+ B( N, J ) = B( N, J ) - DU( N-1 )*X( N-1, J ) -
+ $ D( N )*X( N, J )
+ DO 110 I = 2, N - 1
+ B( I, J ) = B( I, J ) - DU( I-1 )*X( I-1, J ) -
+ $ D( I )*X( I, J ) - DL( I )*X( I+1, J )
+ 110 CONTINUE
+ END IF
+ 120 CONTINUE
+ END IF
+ END IF
+ RETURN
+*
+* End of SLAGTM
+*
+ END
+ SUBROUTINE SLAGTS( JOB, N, A, B, C, D, IN, Y, TOL, INFO )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, JOB, N
+ REAL TOL
+* ..
+* .. Array Arguments ..
+ INTEGER IN( * )
+ REAL A( * ), B( * ), C( * ), D( * ), Y( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SLAGTS may be used to solve one of the systems of equations
+*
+* (T - lambda*I)*x = y or (T - lambda*I)'*x = y,
+*
+* where T is an n by n tridiagonal matrix, for x, following the
+* factorization of (T - lambda*I) as
+*
+* (T - lambda*I) = P*L*U ,
+*
+* by routine SLAGTF. The choice of equation to be solved is
+* controlled by the argument JOB, and in each case there is an option
+* to perturb zero or very small diagonal elements of U, this option
+* being intended for use in applications such as inverse iteration.
+*
+* Arguments
+* =========
+*
+* JOB (input) INTEGER
+* Specifies the job to be performed by SLAGTS as follows:
+* = 1: The equations (T - lambda*I)x = y are to be solved,
+* but diagonal elements of U are not to be perturbed.
+* = -1: The equations (T - lambda*I)x = y are to be solved
+* and, if overflow would otherwise occur, the diagonal
+* elements of U are to be perturbed. See argument TOL
+* below.
+* = 2: The equations (T - lambda*I)'x = y are to be solved,
+* but diagonal elements of U are not to be perturbed.
+* = -2: The equations (T - lambda*I)'x = y are to be solved
+* and, if overflow would otherwise occur, the diagonal
+* elements of U are to be perturbed. See argument TOL
+* below.
+*
+* N (input) INTEGER
+* The order of the matrix T.
+*
+* A (input) REAL array, dimension (N)
+* On entry, A must contain the diagonal elements of U as
+* returned from SLAGTF.
+*
+* B (input) REAL array, dimension (N-1)
+* On entry, B must contain the first super-diagonal elements of
+* U as returned from SLAGTF.
+*
+* C (input) REAL array, dimension (N-1)
+* On entry, C must contain the sub-diagonal elements of L as
+* returned from SLAGTF.
+*
+* D (input) REAL array, dimension (N-2)
+* On entry, D must contain the second super-diagonal elements
+* of U as returned from SLAGTF.
+*
+* IN (input) INTEGER array, dimension (N)
+* On entry, IN must contain details of the matrix P as returned
+* from SLAGTF.
+*
+* Y (input/output) REAL array, dimension (N)
+* On entry, the right hand side vector y.
+* On exit, Y is overwritten by the solution vector x.
+*
+* TOL (input/output) REAL
+* On entry, with JOB .lt. 0, TOL should be the minimum
+* perturbation to be made to very small diagonal elements of U.
+* TOL should normally be chosen as about eps*norm(U), where eps
+* is the relative machine precision, but if TOL is supplied as
+* non-positive, then it is reset to eps*max( abs( u(i,j) ) ).
+* If JOB .gt. 0 then TOL is not referenced.
+*
+* On exit, TOL is changed as described above, only if TOL is
+* non-positive on entry. Otherwise TOL is unchanged.
+*
+* INFO (output) INTEGER
+* = 0 : successful exit
+* .lt. 0: if INFO = -i, the i-th argument had an illegal value
+* .gt. 0: overflow would occur when computing the INFO(th)
+* element of the solution vector x. This can only occur
+* when JOB is supplied as positive and either means
+* that a diagonal element of U is very small, or that
+* the elements of the right-hand side vector y are very
+* large.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ONE, ZERO
+ PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER K
+ REAL ABSAK, AK, BIGNUM, EPS, PERT, SFMIN, TEMP
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, SIGN
+* ..
+* .. External Functions ..
+ REAL SLAMCH
+ EXTERNAL SLAMCH
+* ..
+* .. External Subroutines ..
+ EXTERNAL XERBLA
+* ..
+* .. Executable Statements ..
+*
+ INFO = 0
+ IF( ( ABS( JOB ).GT.2 ) .OR. ( JOB.EQ.0 ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SLAGTS', -INFO )
+ RETURN
+ END IF
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+ EPS = SLAMCH( 'Epsilon' )
+ SFMIN = SLAMCH( 'Safe minimum' )
+ BIGNUM = ONE / SFMIN
+*
+ IF( JOB.LT.0 ) THEN
+ IF( TOL.LE.ZERO ) THEN
+ TOL = ABS( A( 1 ) )
+ IF( N.GT.1 )
+ $ TOL = MAX( TOL, ABS( A( 2 ) ), ABS( B( 1 ) ) )
+ DO 10 K = 3, N
+ TOL = MAX( TOL, ABS( A( K ) ), ABS( B( K-1 ) ),
+ $ ABS( D( K-2 ) ) )
+ 10 CONTINUE
+ TOL = TOL*EPS
+ IF( TOL.EQ.ZERO )
+ $ TOL = EPS
+ END IF
+ END IF
+*
+ IF( ABS( JOB ).EQ.1 ) THEN
+ DO 20 K = 2, N
+ IF( IN( K-1 ).EQ.0 ) THEN
+ Y( K ) = Y( K ) - C( K-1 )*Y( K-1 )
+ ELSE
+ TEMP = Y( K-1 )
+ Y( K-1 ) = Y( K )
+ Y( K ) = TEMP - C( K-1 )*Y( K )
+ END IF
+ 20 CONTINUE
+ IF( JOB.EQ.1 ) THEN
+ DO 30 K = N, 1, -1
+ IF( K.LE.N-2 ) THEN
+ TEMP = Y( K ) - B( K )*Y( K+1 ) - D( K )*Y( K+2 )
+ ELSE IF( K.EQ.N-1 ) THEN
+ TEMP = Y( K ) - B( K )*Y( K+1 )
+ ELSE
+ TEMP = Y( K )
+ END IF
+ AK = A( K )
+ ABSAK = ABS( AK )
+ IF( ABSAK.LT.ONE ) THEN
+ IF( ABSAK.LT.SFMIN ) THEN
+ IF( ABSAK.EQ.ZERO .OR. ABS( TEMP )*SFMIN.GT.ABSAK )
+ $ THEN
+ INFO = K
+ RETURN
+ ELSE
+ TEMP = TEMP*BIGNUM
+ AK = AK*BIGNUM
+ END IF
+ ELSE IF( ABS( TEMP ).GT.ABSAK*BIGNUM ) THEN
+ INFO = K
+ RETURN
+ END IF
+ END IF
+ Y( K ) = TEMP / AK
+ 30 CONTINUE
+ ELSE
+ DO 50 K = N, 1, -1
+ IF( K.LE.N-2 ) THEN
+ TEMP = Y( K ) - B( K )*Y( K+1 ) - D( K )*Y( K+2 )
+ ELSE IF( K.EQ.N-1 ) THEN
+ TEMP = Y( K ) - B( K )*Y( K+1 )
+ ELSE
+ TEMP = Y( K )
+ END IF
+ AK = A( K )
+ PERT = SIGN( TOL, AK )
+ 40 CONTINUE
+ ABSAK = ABS( AK )
+ IF( ABSAK.LT.ONE ) THEN
+ IF( ABSAK.LT.SFMIN ) THEN
+ IF( ABSAK.EQ.ZERO .OR. ABS( TEMP )*SFMIN.GT.ABSAK )
+ $ THEN
+ AK = AK + PERT
+ PERT = 2*PERT
+ GO TO 40
+ ELSE
+ TEMP = TEMP*BIGNUM
+ AK = AK*BIGNUM
+ END IF
+ ELSE IF( ABS( TEMP ).GT.ABSAK*BIGNUM ) THEN
+ AK = AK + PERT
+ PERT = 2*PERT
+ GO TO 40
+ END IF
+ END IF
+ Y( K ) = TEMP / AK
+ 50 CONTINUE
+ END IF
+ ELSE
+*
+* Come to here if JOB = 2 or -2
+*
+ IF( JOB.EQ.2 ) THEN
+ DO 60 K = 1, N
+ IF( K.GE.3 ) THEN
+ TEMP = Y( K ) - B( K-1 )*Y( K-1 ) - D( K-2 )*Y( K-2 )
+ ELSE IF( K.EQ.2 ) THEN
+ TEMP = Y( K ) - B( K-1 )*Y( K-1 )
+ ELSE
+ TEMP = Y( K )
+ END IF
+ AK = A( K )
+ ABSAK = ABS( AK )
+ IF( ABSAK.LT.ONE ) THEN
+ IF( ABSAK.LT.SFMIN ) THEN
+ IF( ABSAK.EQ.ZERO .OR. ABS( TEMP )*SFMIN.GT.ABSAK )
+ $ THEN
+ INFO = K
+ RETURN
+ ELSE
+ TEMP = TEMP*BIGNUM
+ AK = AK*BIGNUM
+ END IF
+ ELSE IF( ABS( TEMP ).GT.ABSAK*BIGNUM ) THEN
+ INFO = K
+ RETURN
+ END IF
+ END IF
+ Y( K ) = TEMP / AK
+ 60 CONTINUE
+ ELSE
+ DO 80 K = 1, N
+ IF( K.GE.3 ) THEN
+ TEMP = Y( K ) - B( K-1 )*Y( K-1 ) - D( K-2 )*Y( K-2 )
+ ELSE IF( K.EQ.2 ) THEN
+ TEMP = Y( K ) - B( K-1 )*Y( K-1 )
+ ELSE
+ TEMP = Y( K )
+ END IF
+ AK = A( K )
+ PERT = SIGN( TOL, AK )
+ 70 CONTINUE
+ ABSAK = ABS( AK )
+ IF( ABSAK.LT.ONE ) THEN
+ IF( ABSAK.LT.SFMIN ) THEN
+ IF( ABSAK.EQ.ZERO .OR. ABS( TEMP )*SFMIN.GT.ABSAK )
+ $ THEN
+ AK = AK + PERT
+ PERT = 2*PERT
+ GO TO 70
+ ELSE
+ TEMP = TEMP*BIGNUM
+ AK = AK*BIGNUM
+ END IF
+ ELSE IF( ABS( TEMP ).GT.ABSAK*BIGNUM ) THEN
+ AK = AK + PERT
+ PERT = 2*PERT
+ GO TO 70
+ END IF
+ END IF
+ Y( K ) = TEMP / AK
+ 80 CONTINUE
+ END IF
+*
+ DO 90 K = N, 2, -1
+ IF( IN( K-1 ).EQ.0 ) THEN
+ Y( K-1 ) = Y( K-1 ) - C( K-1 )*Y( K )
+ ELSE
+ TEMP = Y( K-1 )
+ Y( K-1 ) = Y( K )
+ Y( K ) = TEMP - C( K-1 )*Y( K )
+ END IF
+ 90 CONTINUE
+ END IF
+*
+* End of SLAGTS
+*
+ END
+ SUBROUTINE SLAGV2( A, LDA, B, LDB, ALPHAR, ALPHAI, BETA, CSL, SNL,
+ $ CSR, SNR )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER LDA, LDB
+ REAL CSL, CSR, SNL, SNR
+* ..
+* .. Array Arguments ..
+ REAL A( LDA, * ), ALPHAI( 2 ), ALPHAR( 2 ),
+ $ B( LDB, * ), BETA( 2 )
+* ..
+*
+* Purpose
+* =======
+*
+* SLAGV2 computes the Generalized Schur factorization of a real 2-by-2
+* matrix pencil (A,B) where B is upper triangular. This routine
+* computes orthogonal (rotation) matrices given by CSL, SNL and CSR,
+* SNR such that
+*
+* 1) if the pencil (A,B) has two real eigenvalues (include 0/0 or 1/0
+* types), then
+*
+* [ a11 a12 ] := [ CSL SNL ] [ a11 a12 ] [ CSR -SNR ]
+* [ 0 a22 ] [ -SNL CSL ] [ a21 a22 ] [ SNR CSR ]
+*
+* [ b11 b12 ] := [ CSL SNL ] [ b11 b12 ] [ CSR -SNR ]
+* [ 0 b22 ] [ -SNL CSL ] [ 0 b22 ] [ SNR CSR ],
+*
+* 2) if the pencil (A,B) has a pair of complex conjugate eigenvalues,
+* then
+*
+* [ a11 a12 ] := [ CSL SNL ] [ a11 a12 ] [ CSR -SNR ]
+* [ a21 a22 ] [ -SNL CSL ] [ a21 a22 ] [ SNR CSR ]
+*
+* [ b11 0 ] := [ CSL SNL ] [ b11 b12 ] [ CSR -SNR ]
+* [ 0 b22 ] [ -SNL CSL ] [ 0 b22 ] [ SNR CSR ]
+*
+* where b11 >= b22 > 0.
+*
+*
+* Arguments
+* =========
+*
+* A (input/output) REAL array, dimension (LDA, 2)
+* On entry, the 2 x 2 matrix A.
+* On exit, A is overwritten by the ``A-part'' of the
+* generalized Schur form.
+*
+* LDA (input) INTEGER
+* THe leading dimension of the array A. LDA >= 2.
+*
+* B (input/output) REAL array, dimension (LDB, 2)
+* On entry, the upper triangular 2 x 2 matrix B.
+* On exit, B is overwritten by the ``B-part'' of the
+* generalized Schur form.
+*
+* LDB (input) INTEGER
+* THe leading dimension of the array B. LDB >= 2.
+*
+* ALPHAR (output) REAL array, dimension (2)
+* ALPHAI (output) REAL array, dimension (2)
+* BETA (output) REAL array, dimension (2)
+* (ALPHAR(k)+i*ALPHAI(k))/BETA(k) are the eigenvalues of the
+* pencil (A,B), k=1,2, i = sqrt(-1). Note that BETA(k) may
+* be zero.
+*
+* CSL (output) REAL
+* The cosine of the left rotation matrix.
+*
+* SNL (output) REAL
+* The sine of the left rotation matrix.
+*
+* CSR (output) REAL
+* The cosine of the right rotation matrix.
+*
+* SNR (output) REAL
+* The sine of the right rotation matrix.
+*
+* Further Details
+* ===============
+*
+* Based on contributions by
+* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO, ONE
+ PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+* ..
+* .. Local Scalars ..
+ REAL ANORM, ASCALE, BNORM, BSCALE, H1, H2, H3, QQ,
+ $ R, RR, SAFMIN, SCALE1, SCALE2, T, ULP, WI, WR1,
+ $ WR2
+* ..
+* .. External Subroutines ..
+ EXTERNAL SLAG2, SLARTG, SLASV2, SROT
+* ..
+* .. External Functions ..
+ REAL SLAMCH, SLAPY2
+ EXTERNAL SLAMCH, SLAPY2
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX
+* ..
+* .. Executable Statements ..
+*
+ SAFMIN = SLAMCH( 'S' )
+ ULP = SLAMCH( 'P' )
+*
+* Scale A
+*
+ ANORM = MAX( ABS( A( 1, 1 ) )+ABS( A( 2, 1 ) ),
+ $ ABS( A( 1, 2 ) )+ABS( A( 2, 2 ) ), SAFMIN )
+ ASCALE = ONE / ANORM
+ A( 1, 1 ) = ASCALE*A( 1, 1 )
+ A( 1, 2 ) = ASCALE*A( 1, 2 )
+ A( 2, 1 ) = ASCALE*A( 2, 1 )
+ A( 2, 2 ) = ASCALE*A( 2, 2 )
+*
+* Scale B
+*
+ BNORM = MAX( ABS( B( 1, 1 ) ), ABS( B( 1, 2 ) )+ABS( B( 2, 2 ) ),
+ $ SAFMIN )
+ BSCALE = ONE / BNORM
+ B( 1, 1 ) = BSCALE*B( 1, 1 )
+ B( 1, 2 ) = BSCALE*B( 1, 2 )
+ B( 2, 2 ) = BSCALE*B( 2, 2 )
+*
+* Check if A can be deflated
+*
+ IF( ABS( A( 2, 1 ) ).LE.ULP ) THEN
+ CSL = ONE
+ SNL = ZERO
+ CSR = ONE
+ SNR = ZERO
+ A( 2, 1 ) = ZERO
+ B( 2, 1 ) = ZERO
+*
+* Check if B is singular
+*
+ ELSE IF( ABS( B( 1, 1 ) ).LE.ULP ) THEN
+ CALL SLARTG( A( 1, 1 ), A( 2, 1 ), CSL, SNL, R )
+ CSR = ONE
+ SNR = ZERO
+ CALL SROT( 2, A( 1, 1 ), LDA, A( 2, 1 ), LDA, CSL, SNL )
+ CALL SROT( 2, B( 1, 1 ), LDB, B( 2, 1 ), LDB, CSL, SNL )
+ A( 2, 1 ) = ZERO
+ B( 1, 1 ) = ZERO
+ B( 2, 1 ) = ZERO
+*
+ ELSE IF( ABS( B( 2, 2 ) ).LE.ULP ) THEN
+ CALL SLARTG( A( 2, 2 ), A( 2, 1 ), CSR, SNR, T )
+ SNR = -SNR
+ CALL SROT( 2, A( 1, 1 ), 1, A( 1, 2 ), 1, CSR, SNR )
+ CALL SROT( 2, B( 1, 1 ), 1, B( 1, 2 ), 1, CSR, SNR )
+ CSL = ONE
+ SNL = ZERO
+ A( 2, 1 ) = ZERO
+ B( 2, 1 ) = ZERO
+ B( 2, 2 ) = ZERO
+*
+ ELSE
+*
+* B is nonsingular, first compute the eigenvalues of (A,B)
+*
+ CALL SLAG2( A, LDA, B, LDB, SAFMIN, SCALE1, SCALE2, WR1, WR2,
+ $ WI )
+*
+ IF( WI.EQ.ZERO ) THEN
+*
+* two real eigenvalues, compute s*A-w*B
+*
+ H1 = SCALE1*A( 1, 1 ) - WR1*B( 1, 1 )
+ H2 = SCALE1*A( 1, 2 ) - WR1*B( 1, 2 )
+ H3 = SCALE1*A( 2, 2 ) - WR1*B( 2, 2 )
+*
+ RR = SLAPY2( H1, H2 )
+ QQ = SLAPY2( SCALE1*A( 2, 1 ), H3 )
+*
+ IF( RR.GT.QQ ) THEN
+*
+* find right rotation matrix to zero 1,1 element of
+* (sA - wB)
+*
+ CALL SLARTG( H2, H1, CSR, SNR, T )
+*
+ ELSE
+*
+* find right rotation matrix to zero 2,1 element of
+* (sA - wB)
+*
+ CALL SLARTG( H3, SCALE1*A( 2, 1 ), CSR, SNR, T )
+*
+ END IF
+*
+ SNR = -SNR
+ CALL SROT( 2, A( 1, 1 ), 1, A( 1, 2 ), 1, CSR, SNR )
+ CALL SROT( 2, B( 1, 1 ), 1, B( 1, 2 ), 1, CSR, SNR )
+*
+* compute inf norms of A and B
+*
+ H1 = MAX( ABS( A( 1, 1 ) )+ABS( A( 1, 2 ) ),
+ $ ABS( A( 2, 1 ) )+ABS( A( 2, 2 ) ) )
+ H2 = MAX( ABS( B( 1, 1 ) )+ABS( B( 1, 2 ) ),
+ $ ABS( B( 2, 1 ) )+ABS( B( 2, 2 ) ) )
+*
+ IF( ( SCALE1*H1 ).GE.ABS( WR1 )*H2 ) THEN
+*
+* find left rotation matrix Q to zero out B(2,1)
+*
+ CALL SLARTG( B( 1, 1 ), B( 2, 1 ), CSL, SNL, R )
+*
+ ELSE
+*
+* find left rotation matrix Q to zero out A(2,1)
+*
+ CALL SLARTG( A( 1, 1 ), A( 2, 1 ), CSL, SNL, R )
+*
+ END IF
+*
+ CALL SROT( 2, A( 1, 1 ), LDA, A( 2, 1 ), LDA, CSL, SNL )
+ CALL SROT( 2, B( 1, 1 ), LDB, B( 2, 1 ), LDB, CSL, SNL )
+*
+ A( 2, 1 ) = ZERO
+ B( 2, 1 ) = ZERO
+*
+ ELSE
+*
+* a pair of complex conjugate eigenvalues
+* first compute the SVD of the matrix B
+*
+ CALL SLASV2( B( 1, 1 ), B( 1, 2 ), B( 2, 2 ), R, T, SNR,
+ $ CSR, SNL, CSL )
+*
+* Form (A,B) := Q(A,B)Z' where Q is left rotation matrix and
+* Z is right rotation matrix computed from SLASV2
+*
+ CALL SROT( 2, A( 1, 1 ), LDA, A( 2, 1 ), LDA, CSL, SNL )
+ CALL SROT( 2, B( 1, 1 ), LDB, B( 2, 1 ), LDB, CSL, SNL )
+ CALL SROT( 2, A( 1, 1 ), 1, A( 1, 2 ), 1, CSR, SNR )
+ CALL SROT( 2, B( 1, 1 ), 1, B( 1, 2 ), 1, CSR, SNR )
+*
+ B( 2, 1 ) = ZERO
+ B( 1, 2 ) = ZERO
+*
+ END IF
+*
+ END IF
+*
+* Unscaling
+*
+ A( 1, 1 ) = ANORM*A( 1, 1 )
+ A( 2, 1 ) = ANORM*A( 2, 1 )
+ A( 1, 2 ) = ANORM*A( 1, 2 )
+ A( 2, 2 ) = ANORM*A( 2, 2 )
+ B( 1, 1 ) = BNORM*B( 1, 1 )
+ B( 2, 1 ) = BNORM*B( 2, 1 )
+ B( 1, 2 ) = BNORM*B( 1, 2 )
+ B( 2, 2 ) = BNORM*B( 2, 2 )
+*
+ IF( WI.EQ.ZERO ) THEN
+ ALPHAR( 1 ) = A( 1, 1 )
+ ALPHAR( 2 ) = A( 2, 2 )
+ ALPHAI( 1 ) = ZERO
+ ALPHAI( 2 ) = ZERO
+ BETA( 1 ) = B( 1, 1 )
+ BETA( 2 ) = B( 2, 2 )
+ ELSE
+ ALPHAR( 1 ) = ANORM*WR1 / SCALE1 / BNORM
+ ALPHAI( 1 ) = ANORM*WI / SCALE1 / BNORM
+ ALPHAR( 2 ) = ALPHAR( 1 )
+ ALPHAI( 2 ) = -ALPHAI( 1 )
+ BETA( 1 ) = ONE
+ BETA( 2 ) = ONE
+ END IF
+*
+ RETURN
+*
+* End of SLAGV2
+*
+ END
+ SUBROUTINE SLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI,
+ $ ILOZ, IHIZ, Z, LDZ, INFO )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, N
+ LOGICAL WANTT, WANTZ
+* ..
+* .. Array Arguments ..
+ REAL H( LDH, * ), WI( * ), WR( * ), Z( LDZ, * )
+* ..
+*
+* Purpose
+* =======
+*
+* SLAHQR is an auxiliary routine called by SHSEQR to update the
+* eigenvalues and Schur decomposition already computed by SHSEQR, by
+* dealing with the Hessenberg submatrix in rows and columns ILO to
+* IHI.
+*
+* Arguments
+* =========
+*
+* WANTT (input) LOGICAL
+* = .TRUE. : the full Schur form T is required;
+* = .FALSE.: only eigenvalues are required.
+*
+* WANTZ (input) LOGICAL
+* = .TRUE. : the matrix of Schur vectors Z is required;
+* = .FALSE.: Schur vectors are not required.
+*
+* N (input) INTEGER
+* The order of the matrix H. N >= 0.
+*
+* ILO (input) INTEGER
+* IHI (input) INTEGER
+* It is assumed that H is already upper quasi-triangular in
+* rows and columns IHI+1:N, and that H(ILO,ILO-1) = 0 (unless
+* ILO = 1). SLAHQR works primarily with the Hessenberg
+* submatrix in rows and columns ILO to IHI, but applies
+* transformations to all of H if WANTT is .TRUE..
+* 1 <= ILO <= max(1,IHI); IHI <= N.
+*
+* H (input/output) REAL array, dimension (LDH,N)
+* On entry, the upper Hessenberg matrix H.
+* On exit, if INFO is zero and if WANTT is .TRUE., H is upper
+* quasi-triangular in rows and columns ILO:IHI, with any
+* 2-by-2 diagonal blocks in standard form. If INFO is zero
+* and WANTT is .FALSE., the contents of H are unspecified on
+* exit. The output state of H if INFO is nonzero is given
+* below under the description of INFO.
+*
+* LDH (input) INTEGER
+* The leading dimension of the array H. LDH >= max(1,N).
+*
+* WR (output) REAL array, dimension (N)
+* WI (output) REAL array, dimension (N)
+* The real and imaginary parts, respectively, of the computed
+* eigenvalues ILO to IHI are stored in the corresponding
+* elements of WR and WI. If two eigenvalues are computed as a
+* complex conjugate pair, they are stored in consecutive
+* elements of WR and WI, say the i-th and (i+1)th, with
+* WI(i) > 0 and WI(i+1) < 0. If WANTT is .TRUE., the
+* eigenvalues are stored in the same order as on the diagonal
+* of the Schur form returned in H, with WR(i) = H(i,i), and, if
+* H(i:i+1,i:i+1) is a 2-by-2 diagonal block,
+* WI(i) = sqrt(H(i+1,i)*H(i,i+1)) and WI(i+1) = -WI(i).
+*
+* ILOZ (input) INTEGER
+* IHIZ (input) INTEGER
+* Specify the rows of Z to which transformations must be
+* applied if WANTZ is .TRUE..
+* 1 <= ILOZ <= ILO; IHI <= IHIZ <= N.
+*
+* Z (input/output) REAL array, dimension (LDZ,N)
+* If WANTZ is .TRUE., on entry Z must contain the current
+* matrix Z of transformations accumulated by SHSEQR, and on
+* exit Z has been updated; transformations are applied only to
+* the submatrix Z(ILOZ:IHIZ,ILO:IHI).
+* If WANTZ is .FALSE., Z is not referenced.
+*
+* LDZ (input) INTEGER
+* The leading dimension of the array Z. LDZ >= max(1,N).
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* .GT. 0: If INFO = i, SLAHQR failed to compute all the
+* eigenvalues ILO to IHI in a total of 30 iterations
+* per eigenvalue; elements i+1:ihi of WR and WI
+* contain those eigenvalues which have been
+* successfully computed.
+*
+* If INFO .GT. 0 and WANTT is .FALSE., then on exit,
+* the remaining unconverged eigenvalues are the
+* eigenvalues of the upper Hessenberg matrix rows
+* and columns ILO thorugh INFO of the final, output
+* value of H.
+*
+* If INFO .GT. 0 and WANTT is .TRUE., then on exit
+* (*) (initial value of H)*U = U*(final value of H)
+* where U is an orthognal matrix. The final
+* value of H is upper Hessenberg and triangular in
+* rows and columns INFO+1 through IHI.
+*
+* If INFO .GT. 0 and WANTZ is .TRUE., then on exit
+* (final value of Z) = (initial value of Z)*U
+* where U is the orthogonal matrix in (*)
+* (regardless of the value of WANTT.)
+*
+* Further Details
+* ===============
+*
+* 02-96 Based on modifications by
+* David Day, Sandia National Laboratory, USA
+*
+* 12-04 Further modifications by
+* Ralph Byers, University of Kansas, USA
+*
+* This is a modified version of SLAHQR from LAPACK version 3.0.
+* It is (1) more robust against overflow and underflow and
+* (2) adopts the more conservative Ahues & Tisseur stopping
+* criterion (LAWN 122, 1997).
+*
+* =========================================================
+*
+* .. Parameters ..
+ INTEGER ITMAX
+ PARAMETER ( ITMAX = 30 )
+ REAL ZERO, ONE, TWO
+ PARAMETER ( ZERO = 0.0e0, ONE = 1.0e0, TWO = 2.0e0 )
+ REAL DAT1, DAT2
+ PARAMETER ( DAT1 = 3.0e0 / 4.0e0, DAT2 = -0.4375e0 )
+* ..
+* .. Local Scalars ..
+ REAL AA, AB, BA, BB, CS, DET, H11, H12, H21, H21S,
+ $ H22, RT1I, RT1R, RT2I, RT2R, RTDISC, S, SAFMAX,
+ $ SAFMIN, SMLNUM, SN, SUM, T1, T2, T3, TR, TST,
+ $ ULP, V2, V3
+ INTEGER I, I1, I2, ITS, J, K, L, M, NH, NR, NZ
+* ..
+* .. Local Arrays ..
+ REAL V( 3 )
+* ..
+* .. External Functions ..
+ REAL SLAMCH
+ EXTERNAL SLAMCH
+* ..
+* .. External Subroutines ..
+ EXTERNAL SCOPY, SLABAD, SLANV2, SLARFG, SROT
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, MIN, REAL, SQRT
+* ..
+* .. Executable Statements ..
+*
+ INFO = 0
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 )
+ $ RETURN
+ IF( ILO.EQ.IHI ) THEN
+ WR( ILO ) = H( ILO, ILO )
+ WI( ILO ) = ZERO
+ RETURN
+ END IF
+*
+* ==== clear out the trash ====
+ DO 10 J = ILO, IHI - 3
+ H( J+2, J ) = ZERO
+ H( J+3, J ) = ZERO
+ 10 CONTINUE
+ IF( ILO.LE.IHI-2 )
+ $ H( IHI, IHI-2 ) = ZERO
+*
+ NH = IHI - ILO + 1
+ NZ = IHIZ - ILOZ + 1
+*
+* Set machine-dependent constants for the stopping criterion.
+*
+ SAFMIN = SLAMCH( 'SAFE MINIMUM' )
+ SAFMAX = ONE / SAFMIN
+ CALL SLABAD( SAFMIN, SAFMAX )
+ ULP = SLAMCH( 'PRECISION' )
+ SMLNUM = SAFMIN*( REAL( NH ) / ULP )
+*
+* I1 and I2 are the indices of the first row and last column of H
+* to which transformations must be applied. If eigenvalues only are
+* being computed, I1 and I2 are set inside the main loop.
+*
+ IF( WANTT ) THEN
+ I1 = 1
+ I2 = N
+ END IF
+*
+* The main loop begins here. I is the loop index and decreases from
+* IHI to ILO in steps of 1 or 2. Each iteration of the loop works
+* with the active submatrix in rows and columns L to I.
+* Eigenvalues I+1 to IHI have already converged. Either L = ILO or
+* H(L,L-1) is negligible so that the matrix splits.
+*
+ I = IHI
+ 20 CONTINUE
+ L = ILO
+ IF( I.LT.ILO )
+ $ GO TO 160
+*
+* Perform QR iterations on rows and columns ILO to I until a
+* submatrix of order 1 or 2 splits off at the bottom because a
+* subdiagonal element has become negligible.
+*
+ DO 140 ITS = 0, ITMAX
+*
+* Look for a single small subdiagonal element.
+*
+ DO 30 K = I, L + 1, -1
+ IF( ABS( H( K, K-1 ) ).LE.SMLNUM )
+ $ GO TO 40
+ TST = ABS( H( K-1, K-1 ) ) + ABS( H( K, K ) )
+ IF( TST.EQ.ZERO ) THEN
+ IF( K-2.GE.ILO )
+ $ TST = TST + ABS( H( K-1, K-2 ) )
+ IF( K+1.LE.IHI )
+ $ TST = TST + ABS( H( K+1, K ) )
+ END IF
+* ==== The following is a conservative small subdiagonal
+* . deflation criterion due to Ahues & Tisseur (LAWN 122,
+* . 1997). It has better mathematical foundation and
+* . improves accuracy in some cases. ====
+ IF( ABS( H( K, K-1 ) ).LE.ULP*TST ) THEN
+ AB = MAX( ABS( H( K, K-1 ) ), ABS( H( K-1, K ) ) )
+ BA = MIN( ABS( H( K, K-1 ) ), ABS( H( K-1, K ) ) )
+ AA = MAX( ABS( H( K, K ) ),
+ $ ABS( H( K-1, K-1 )-H( K, K ) ) )
+ BB = MIN( ABS( H( K, K ) ),
+ $ ABS( H( K-1, K-1 )-H( K, K ) ) )
+ S = AA + AB
+ IF( BA*( AB / S ).LE.MAX( SMLNUM,
+ $ ULP*( BB*( AA / S ) ) ) )GO TO 40
+ END IF
+ 30 CONTINUE
+ 40 CONTINUE
+ L = K
+ IF( L.GT.ILO ) THEN
+*
+* H(L,L-1) is negligible
+*
+ H( L, L-1 ) = ZERO
+ END IF
+*
+* Exit from loop if a submatrix of order 1 or 2 has split off.
+*
+ IF( L.GE.I-1 )
+ $ GO TO 150
+*
+* Now the active submatrix is in rows and columns L to I. If
+* eigenvalues only are being computed, only the active submatrix
+* need be transformed.
+*
+ IF( .NOT.WANTT ) THEN
+ I1 = L
+ I2 = I
+ END IF
+*
+ IF( ITS.EQ.10 .OR. ITS.EQ.20 ) THEN
+*
+* Exceptional shift.
+*
+ H11 = DAT1*S + H( I, I )
+ H12 = DAT2*S
+ H21 = S
+ H22 = H11
+ ELSE
+*
+* Prepare to use Francis' double shift
+* (i.e. 2nd degree generalized Rayleigh quotient)
+*
+ H11 = H( I-1, I-1 )
+ H21 = H( I, I-1 )
+ H12 = H( I-1, I )
+ H22 = H( I, I )
+ END IF
+ S = ABS( H11 ) + ABS( H12 ) + ABS( H21 ) + ABS( H22 )
+ IF( S.EQ.ZERO ) THEN
+ RT1R = ZERO
+ RT1I = ZERO
+ RT2R = ZERO
+ RT2I = ZERO
+ ELSE
+ H11 = H11 / S
+ H21 = H21 / S
+ H12 = H12 / S
+ H22 = H22 / S
+ TR = ( H11+H22 ) / TWO
+ DET = ( H11-TR )*( H22-TR ) - H12*H21
+ RTDISC = SQRT( ABS( DET ) )
+ IF( DET.GE.ZERO ) THEN
+*
+* ==== complex conjugate shifts ====
+*
+ RT1R = TR*S
+ RT2R = RT1R
+ RT1I = RTDISC*S
+ RT2I = -RT1I
+ ELSE
+*
+* ==== real shifts (use only one of them) ====
+*
+ RT1R = TR + RTDISC
+ RT2R = TR - RTDISC
+ IF( ABS( RT1R-H22 ).LE.ABS( RT2R-H22 ) ) THEN
+ RT1R = RT1R*S
+ RT2R = RT1R
+ ELSE
+ RT2R = RT2R*S
+ RT1R = RT2R
+ END IF
+ RT1I = ZERO
+ RT2I = ZERO
+ END IF
+ END IF
+*
+* Look for two consecutive small subdiagonal elements.
+*
+ DO 50 M = I - 2, L, -1
+* Determine the effect of starting the double-shift QR
+* iteration at row M, and see if this would make H(M,M-1)
+* negligible. (The following uses scaling to avoid
+* overflows and most underflows.)
+*
+ H21S = H( M+1, M )
+ S = ABS( H( M, M )-RT2R ) + ABS( RT2I ) + ABS( H21S )
+ H21S = H( M+1, M ) / S
+ V( 1 ) = H21S*H( M, M+1 ) + ( H( M, M )-RT1R )*
+ $ ( ( H( M, M )-RT2R ) / S ) - RT1I*( RT2I / S )
+ V( 2 ) = H21S*( H( M, M )+H( M+1, M+1 )-RT1R-RT2R )
+ V( 3 ) = H21S*H( M+2, M+1 )
+ S = ABS( V( 1 ) ) + ABS( V( 2 ) ) + ABS( V( 3 ) )
+ V( 1 ) = V( 1 ) / S
+ V( 2 ) = V( 2 ) / S
+ V( 3 ) = V( 3 ) / S
+ IF( M.EQ.L )
+ $ GO TO 60
+ IF( ABS( H( M, M-1 ) )*( ABS( V( 2 ) )+ABS( V( 3 ) ) ).LE.
+ $ ULP*ABS( V( 1 ) )*( ABS( H( M-1, M-1 ) )+ABS( H( M,
+ $ M ) )+ABS( H( M+1, M+1 ) ) ) )GO TO 60
+ 50 CONTINUE
+ 60 CONTINUE
+*
+* Double-shift QR step
+*
+ DO 130 K = M, I - 1
+*
+* The first iteration of this loop determines a reflection G
+* from the vector V and applies it from left and right to H,
+* thus creating a nonzero bulge below the subdiagonal.
+*
+* Each subsequent iteration determines a reflection G to
+* restore the Hessenberg form in the (K-1)th column, and thus
+* chases the bulge one step toward the bottom of the active
+* submatrix. NR is the order of G.
+*
+ NR = MIN( 3, I-K+1 )
+ IF( K.GT.M )
+ $ CALL SCOPY( NR, H( K, K-1 ), 1, V, 1 )
+ CALL SLARFG( NR, V( 1 ), V( 2 ), 1, T1 )
+ IF( K.GT.M ) THEN
+ H( K, K-1 ) = V( 1 )
+ H( K+1, K-1 ) = ZERO
+ IF( K.LT.I-1 )
+ $ H( K+2, K-1 ) = ZERO
+ ELSE IF( M.GT.L ) THEN
+ H( K, K-1 ) = -H( K, K-1 )
+ END IF
+ V2 = V( 2 )
+ T2 = T1*V2
+ IF( NR.EQ.3 ) THEN
+ V3 = V( 3 )
+ T3 = T1*V3
+*
+* Apply G from the left to transform the rows of the matrix
+* in columns K to I2.
+*
+ DO 70 J = K, I2
+ SUM = H( K, J ) + V2*H( K+1, J ) + V3*H( K+2, J )
+ H( K, J ) = H( K, J ) - SUM*T1
+ H( K+1, J ) = H( K+1, J ) - SUM*T2
+ H( K+2, J ) = H( K+2, J ) - SUM*T3
+ 70 CONTINUE
+*
+* Apply G from the right to transform the columns of the
+* matrix in rows I1 to min(K+3,I).
+*
+ DO 80 J = I1, MIN( K+3, I )
+ SUM = H( J, K ) + V2*H( J, K+1 ) + V3*H( J, K+2 )
+ H( J, K ) = H( J, K ) - SUM*T1
+ H( J, K+1 ) = H( J, K+1 ) - SUM*T2
+ H( J, K+2 ) = H( J, K+2 ) - SUM*T3
+ 80 CONTINUE
+*
+ IF( WANTZ ) THEN
+*
+* Accumulate transformations in the matrix Z
+*
+ DO 90 J = ILOZ, IHIZ
+ SUM = Z( J, K ) + V2*Z( J, K+1 ) + V3*Z( J, K+2 )
+ Z( J, K ) = Z( J, K ) - SUM*T1
+ Z( J, K+1 ) = Z( J, K+1 ) - SUM*T2
+ Z( J, K+2 ) = Z( J, K+2 ) - SUM*T3
+ 90 CONTINUE
+ END IF
+ ELSE IF( NR.EQ.2 ) THEN
+*
+* Apply G from the left to transform the rows of the matrix
+* in columns K to I2.
+*
+ DO 100 J = K, I2
+ SUM = H( K, J ) + V2*H( K+1, J )
+ H( K, J ) = H( K, J ) - SUM*T1
+ H( K+1, J ) = H( K+1, J ) - SUM*T2
+ 100 CONTINUE
+*
+* Apply G from the right to transform the columns of the
+* matrix in rows I1 to min(K+3,I).
+*
+ DO 110 J = I1, I
+ SUM = H( J, K ) + V2*H( J, K+1 )
+ H( J, K ) = H( J, K ) - SUM*T1
+ H( J, K+1 ) = H( J, K+1 ) - SUM*T2
+ 110 CONTINUE
+*
+ IF( WANTZ ) THEN
+*
+* Accumulate transformations in the matrix Z
+*
+ DO 120 J = ILOZ, IHIZ
+ SUM = Z( J, K ) + V2*Z( J, K+1 )
+ Z( J, K ) = Z( J, K ) - SUM*T1
+ Z( J, K+1 ) = Z( J, K+1 ) - SUM*T2
+ 120 CONTINUE
+ END IF
+ END IF
+ 130 CONTINUE
+*
+ 140 CONTINUE
+*
+* Failure to converge in remaining number of iterations
+*
+ INFO = I
+ RETURN
+*
+ 150 CONTINUE
+*
+ IF( L.EQ.I ) THEN
+*
+* H(I,I-1) is negligible: one eigenvalue has converged.
+*
+ WR( I ) = H( I, I )
+ WI( I ) = ZERO
+ ELSE IF( L.EQ.I-1 ) THEN
+*
+* H(I-1,I-2) is negligible: a pair of eigenvalues have converged.
+*
+* Transform the 2-by-2 submatrix to standard Schur form,
+* and compute and store the eigenvalues.
+*
+ CALL SLANV2( H( I-1, I-1 ), H( I-1, I ), H( I, I-1 ),
+ $ H( I, I ), WR( I-1 ), WI( I-1 ), WR( I ), WI( I ),
+ $ CS, SN )
+*
+ IF( WANTT ) THEN
+*
+* Apply the transformation to the rest of H.
+*
+ IF( I2.GT.I )
+ $ CALL SROT( I2-I, H( I-1, I+1 ), LDH, H( I, I+1 ), LDH,
+ $ CS, SN )
+ CALL SROT( I-I1-1, H( I1, I-1 ), 1, H( I1, I ), 1, CS, SN )
+ END IF
+ IF( WANTZ ) THEN
+*
+* Apply the transformation to Z.
+*
+ CALL SROT( NZ, Z( ILOZ, I-1 ), 1, Z( ILOZ, I ), 1, CS, SN )
+ END IF
+ END IF
+*
+* return to start of the main loop with new value of I.
+*
+ I = L - 1
+ GO TO 20
+*
+ 160 CONTINUE
+ RETURN
+*
+* End of SLAHQR
+*
+ END
+ SUBROUTINE SLAHR2( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER K, LDA, LDT, LDY, N, NB
+* ..
+* .. Array Arguments ..
+ REAL A( LDA, * ), T( LDT, NB ), TAU( NB ),
+ $ Y( LDY, NB )
+* ..
+*
+* Purpose
+* =======
+*
+* SLAHR2 reduces the first NB columns of A real general n-BY-(n-k+1)
+* matrix A so that elements below the k-th subdiagonal are zero. The
+* reduction is performed by an orthogonal similarity transformation
+* Q' * A * Q. The routine returns the matrices V and T which determine
+* Q as a block reflector I - V*T*V', and also the matrix Y = A * V * T.
+*
+* This is an auxiliary routine called by SGEHRD.
+*
+* Arguments
+* =========
+*
+* N (input) INTEGER
+* The order of the matrix A.
+*
+* K (input) INTEGER
+* The offset for the reduction. Elements below the k-th
+* subdiagonal in the first NB columns are reduced to zero.
+* K < N.
+*
+* NB (input) INTEGER
+* The number of columns to be reduced.
+*
+* A (input/output) REAL array, dimension (LDA,N-K+1)
+* On entry, the n-by-(n-k+1) general matrix A.
+* On exit, the elements on and above the k-th subdiagonal in
+* the first NB columns are overwritten with the corresponding
+* elements of the reduced matrix; the elements below the k-th
+* subdiagonal, with the array TAU, represent the matrix Q as a
+* product of elementary reflectors. The other columns of A are
+* unchanged. See Further Details.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,N).
+*
+* TAU (output) REAL array, dimension (NB)
+* The scalar factors of the elementary reflectors. See Further
+* Details.
+*
+* T (output) REAL array, dimension (LDT,NB)
+* The upper triangular matrix T.
+*
+* LDT (input) INTEGER
+* The leading dimension of the array T. LDT >= NB.
+*
+* Y (output) REAL array, dimension (LDY,NB)
+* The n-by-nb matrix Y.
+*
+* LDY (input) INTEGER
+* The leading dimension of the array Y. LDY >= N.
+*
+* Further Details
+* ===============
+*
+* The matrix Q is represented as a product of nb elementary reflectors
+*
+* Q = H(1) H(2) . . . H(nb).
+*
+* Each H(i) has the form
+*
+* H(i) = I - tau * v * v'
+*
+* where tau is a real scalar, and v is a real vector with
+* v(1:i+k-1) = 0, v(i+k) = 1; v(i+k+1:n) is stored on exit in
+* A(i+k+1:n,i), and tau in TAU(i).
+*
+* The elements of the vectors v together form the (n-k+1)-by-nb matrix
+* V which is needed, with T and Y, to apply the transformation to the
+* unreduced part of the matrix, using an update of the form:
+* A := (I - V*T*V') * (A - Y*V').
+*
+* The contents of A on exit are illustrated by the following example
+* with n = 7, k = 3 and nb = 2:
+*
+* ( a a a a a )
+* ( a a a a a )
+* ( a a a a a )
+* ( h h a a a )
+* ( v1 h a a a )
+* ( v1 v2 a a a )
+* ( v1 v2 a a a )
+*
+* where a denotes an element of the original matrix A, h denotes a
+* modified element of the upper Hessenberg matrix H, and vi denotes an
+* element of the vector defining H(i).
+*
+* This file is a slight modification of LAPACK-3.0's SLAHRD
+* incorporating improvements proposed by Quintana-Orti and Van de
+* Gejin. Note that the entries of A(1:K,2:NB) differ from those
+* returned by the original LAPACK routine. This function is
+* not backward compatible with LAPACK3.0.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO, ONE
+ PARAMETER ( ZERO = 0.0E+0,
+ $ ONE = 1.0E+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I
+ REAL EI
+* ..
+* .. External Subroutines ..
+ EXTERNAL SAXPY, SCOPY, SGEMM, SGEMV, SLACPY,
+ $ SLARFG, SSCAL, STRMM, STRMV
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MIN
+* ..
+* .. Executable Statements ..
+*
+* Quick return if possible
+*
+ IF( N.LE.1 )
+ $ RETURN
+*
+ DO 10 I = 1, NB
+ IF( I.GT.1 ) THEN
+*
+* Update A(K+1:N,I)
+*
+* Update I-th column of A - Y * V'
+*
+ CALL SGEMV( 'NO TRANSPOSE', N-K, I-1, -ONE, Y(K+1,1), LDY,
+ $ A( K+I-1, 1 ), LDA, ONE, A( K+1, I ), 1 )
+*
+* Apply I - V * T' * V' to this column (call it b) from the
+* left, using the last column of T as workspace
+*
+* Let V = ( V1 ) and b = ( b1 ) (first I-1 rows)
+* ( V2 ) ( b2 )
+*
+* where V1 is unit lower triangular
+*
+* w := V1' * b1
+*
+ CALL SCOPY( I-1, A( K+1, I ), 1, T( 1, NB ), 1 )
+ CALL STRMV( 'Lower', 'Transpose', 'UNIT',
+ $ I-1, A( K+1, 1 ),
+ $ LDA, T( 1, NB ), 1 )
+*
+* w := w + V2'*b2
+*
+ CALL SGEMV( 'Transpose', N-K-I+1, I-1,
+ $ ONE, A( K+I, 1 ),
+ $ LDA, A( K+I, I ), 1, ONE, T( 1, NB ), 1 )
+*
+* w := T'*w
+*
+ CALL STRMV( 'Upper', 'Transpose', 'NON-UNIT',
+ $ I-1, T, LDT,
+ $ T( 1, NB ), 1 )
+*
+* b2 := b2 - V2*w
+*
+ CALL SGEMV( 'NO TRANSPOSE', N-K-I+1, I-1, -ONE,
+ $ A( K+I, 1 ),
+ $ LDA, T( 1, NB ), 1, ONE, A( K+I, I ), 1 )
+*
+* b1 := b1 - V1*w
+*
+ CALL STRMV( 'Lower', 'NO TRANSPOSE',
+ $ 'UNIT', I-1,
+ $ A( K+1, 1 ), LDA, T( 1, NB ), 1 )
+ CALL SAXPY( I-1, -ONE, T( 1, NB ), 1, A( K+1, I ), 1 )
+*
+ A( K+I-1, I-1 ) = EI
+ END IF
+*
+* Generate the elementary reflector H(I) to annihilate
+* A(K+I+1:N,I)
+*
+ CALL SLARFG( N-K-I+1, A( K+I, I ), A( MIN( K+I+1, N ), I ), 1,
+ $ TAU( I ) )
+ EI = A( K+I, I )
+ A( K+I, I ) = ONE
+*
+* Compute Y(K+1:N,I)
+*
+ CALL SGEMV( 'NO TRANSPOSE', N-K, N-K-I+1,
+ $ ONE, A( K+1, I+1 ),
+ $ LDA, A( K+I, I ), 1, ZERO, Y( K+1, I ), 1 )
+ CALL SGEMV( 'Transpose', N-K-I+1, I-1,
+ $ ONE, A( K+I, 1 ), LDA,
+ $ A( K+I, I ), 1, ZERO, T( 1, I ), 1 )
+ CALL SGEMV( 'NO TRANSPOSE', N-K, I-1, -ONE,
+ $ Y( K+1, 1 ), LDY,
+ $ T( 1, I ), 1, ONE, Y( K+1, I ), 1 )
+ CALL SSCAL( N-K, TAU( I ), Y( K+1, I ), 1 )
+*
+* Compute T(1:I,I)
+*
+ CALL SSCAL( I-1, -TAU( I ), T( 1, I ), 1 )
+ CALL STRMV( 'Upper', 'No Transpose', 'NON-UNIT',
+ $ I-1, T, LDT,
+ $ T( 1, I ), 1 )
+ T( I, I ) = TAU( I )
+*
+ 10 CONTINUE
+ A( K+NB, NB ) = EI
+*
+* Compute Y(1:K,1:NB)
+*
+ CALL SLACPY( 'ALL', K, NB, A( 1, 2 ), LDA, Y, LDY )
+ CALL STRMM( 'RIGHT', 'Lower', 'NO TRANSPOSE',
+ $ 'UNIT', K, NB,
+ $ ONE, A( K+1, 1 ), LDA, Y, LDY )
+ IF( N.GT.K+NB )
+ $ CALL SGEMM( 'NO TRANSPOSE', 'NO TRANSPOSE', K,
+ $ NB, N-K-NB, ONE,
+ $ A( 1, 2+NB ), LDA, A( K+1+NB, 1 ), LDA, ONE, Y,
+ $ LDY )
+ CALL STRMM( 'RIGHT', 'Upper', 'NO TRANSPOSE',
+ $ 'NON-UNIT', K, NB,
+ $ ONE, T, LDT, Y, LDY )
+*
+ RETURN
+*
+* End of SLAHR2
+*
+ END
+ SUBROUTINE SLAHRD( N, K, NB, A, LDA, TAU, T, LDT, Y, LDY )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER K, LDA, LDT, LDY, N, NB
+* ..
+* .. Array Arguments ..
+ REAL A( LDA, * ), T( LDT, NB ), TAU( NB ),
+ $ Y( LDY, NB )
+* ..
+*
+* Purpose
+* =======
+*
+* SLAHRD reduces the first NB columns of a real general n-by-(n-k+1)
+* matrix A so that elements below the k-th subdiagonal are zero. The
+* reduction is performed by an orthogonal similarity transformation
+* Q' * A * Q. The routine returns the matrices V and T which determine
+* Q as a block reflector I - V*T*V', and also the matrix Y = A * V * T.
+*
+* This is an OBSOLETE auxiliary routine.
+* This routine will be 'deprecated' in a future release.
+* Please use the new routine SLAHR2 instead.
+*
+* Arguments
+* =========
+*
+* N (input) INTEGER
+* The order of the matrix A.
+*
+* K (input) INTEGER
+* The offset for the reduction. Elements below the k-th
+* subdiagonal in the first NB columns are reduced to zero.
+*
+* NB (input) INTEGER
+* The number of columns to be reduced.
+*
+* A (input/output) REAL array, dimension (LDA,N-K+1)
+* On entry, the n-by-(n-k+1) general matrix A.
+* On exit, the elements on and above the k-th subdiagonal in
+* the first NB columns are overwritten with the corresponding
+* elements of the reduced matrix; the elements below the k-th
+* subdiagonal, with the array TAU, represent the matrix Q as a
+* product of elementary reflectors. The other columns of A are
+* unchanged. See Further Details.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,N).
+*
+* TAU (output) REAL array, dimension (NB)
+* The scalar factors of the elementary reflectors. See Further
+* Details.
+*
+* T (output) REAL array, dimension (LDT,NB)
+* The upper triangular matrix T.
+*
+* LDT (input) INTEGER
+* The leading dimension of the array T. LDT >= NB.
+*
+* Y (output) REAL array, dimension (LDY,NB)
+* The n-by-nb matrix Y.
+*
+* LDY (input) INTEGER
+* The leading dimension of the array Y. LDY >= N.
+*
+* Further Details
+* ===============
+*
+* The matrix Q is represented as a product of nb elementary reflectors
+*
+* Q = H(1) H(2) . . . H(nb).
+*
+* Each H(i) has the form
+*
+* H(i) = I - tau * v * v'
+*
+* where tau is a real scalar, and v is a real vector with
+* v(1:i+k-1) = 0, v(i+k) = 1; v(i+k+1:n) is stored on exit in
+* A(i+k+1:n,i), and tau in TAU(i).
+*
+* The elements of the vectors v together form the (n-k+1)-by-nb matrix
+* V which is needed, with T and Y, to apply the transformation to the
+* unreduced part of the matrix, using an update of the form:
+* A := (I - V*T*V') * (A - Y*V').
+*
+* The contents of A on exit are illustrated by the following example
+* with n = 7, k = 3 and nb = 2:
+*
+* ( a h a a a )
+* ( a h a a a )
+* ( a h a a a )
+* ( h h a a a )
+* ( v1 h a a a )
+* ( v1 v2 a a a )
+* ( v1 v2 a a a )
+*
+* where a denotes an element of the original matrix A, h denotes a
+* modified element of the upper Hessenberg matrix H, and vi denotes an
+* element of the vector defining H(i).
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO, ONE
+ PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I
+ REAL EI
+* ..
+* .. External Subroutines ..
+ EXTERNAL SAXPY, SCOPY, SGEMV, SLARFG, SSCAL, STRMV
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MIN
+* ..
+* .. Executable Statements ..
+*
+* Quick return if possible
+*
+ IF( N.LE.1 )
+ $ RETURN
+*
+ DO 10 I = 1, NB
+ IF( I.GT.1 ) THEN
+*
+* Update A(1:n,i)
+*
+* Compute i-th column of A - Y * V'
+*
+ CALL SGEMV( 'No transpose', N, I-1, -ONE, Y, LDY,
+ $ A( K+I-1, 1 ), LDA, ONE, A( 1, I ), 1 )
+*
+* Apply I - V * T' * V' to this column (call it b) from the
+* left, using the last column of T as workspace
+*
+* Let V = ( V1 ) and b = ( b1 ) (first I-1 rows)
+* ( V2 ) ( b2 )
+*
+* where V1 is unit lower triangular
+*
+* w := V1' * b1
+*
+ CALL SCOPY( I-1, A( K+1, I ), 1, T( 1, NB ), 1 )
+ CALL STRMV( 'Lower', 'Transpose', 'Unit', I-1, A( K+1, 1 ),
+ $ LDA, T( 1, NB ), 1 )
+*
+* w := w + V2'*b2
+*
+ CALL SGEMV( 'Transpose', N-K-I+1, I-1, ONE, A( K+I, 1 ),
+ $ LDA, A( K+I, I ), 1, ONE, T( 1, NB ), 1 )
+*
+* w := T'*w
+*
+ CALL STRMV( 'Upper', 'Transpose', 'Non-unit', I-1, T, LDT,
+ $ T( 1, NB ), 1 )
+*
+* b2 := b2 - V2*w
+*
+ CALL SGEMV( 'No transpose', N-K-I+1, I-1, -ONE, A( K+I, 1 ),
+ $ LDA, T( 1, NB ), 1, ONE, A( K+I, I ), 1 )
+*
+* b1 := b1 - V1*w
+*
+ CALL STRMV( 'Lower', 'No transpose', 'Unit', I-1,
+ $ A( K+1, 1 ), LDA, T( 1, NB ), 1 )
+ CALL SAXPY( I-1, -ONE, T( 1, NB ), 1, A( K+1, I ), 1 )
+*
+ A( K+I-1, I-1 ) = EI
+ END IF
+*
+* Generate the elementary reflector H(i) to annihilate
+* A(k+i+1:n,i)
+*
+ CALL SLARFG( N-K-I+1, A( K+I, I ), A( MIN( K+I+1, N ), I ), 1,
+ $ TAU( I ) )
+ EI = A( K+I, I )
+ A( K+I, I ) = ONE
+*
+* Compute Y(1:n,i)
+*
+ CALL SGEMV( 'No transpose', N, N-K-I+1, ONE, A( 1, I+1 ), LDA,
+ $ A( K+I, I ), 1, ZERO, Y( 1, I ), 1 )
+ CALL SGEMV( 'Transpose', N-K-I+1, I-1, ONE, A( K+I, 1 ), LDA,
+ $ A( K+I, I ), 1, ZERO, T( 1, I ), 1 )
+ CALL SGEMV( 'No transpose', N, I-1, -ONE, Y, LDY, T( 1, I ), 1,
+ $ ONE, Y( 1, I ), 1 )
+ CALL SSCAL( N, TAU( I ), Y( 1, I ), 1 )
+*
+* Compute T(1:i,i)
+*
+ CALL SSCAL( I-1, -TAU( I ), T( 1, I ), 1 )
+ CALL STRMV( 'Upper', 'No transpose', 'Non-unit', I-1, T, LDT,
+ $ T( 1, I ), 1 )
+ T( I, I ) = TAU( I )
+*
+ 10 CONTINUE
+ A( K+NB, NB ) = EI
+*
+ RETURN
+*
+* End of SLAHRD
+*
+ END
+ SUBROUTINE SLAIC1( JOB, J, X, SEST, W, GAMMA, SESTPR, S, C )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER J, JOB
+ REAL C, GAMMA, S, SEST, SESTPR
+* ..
+* .. Array Arguments ..
+ REAL W( J ), X( J )
+* ..
+*
+* Purpose
+* =======
+*
+* SLAIC1 applies one step of incremental condition estimation in
+* its simplest version:
+*
+* Let x, twonorm(x) = 1, be an approximate singular vector of an j-by-j
+* lower triangular matrix L, such that
+* twonorm(L*x) = sest
+* Then SLAIC1 computes sestpr, s, c such that
+* the vector
+* [ s*x ]
+* xhat = [ c ]
+* is an approximate singular vector of
+* [ L 0 ]
+* Lhat = [ w' gamma ]
+* in the sense that
+* twonorm(Lhat*xhat) = sestpr.
+*
+* Depending on JOB, an estimate for the largest or smallest singular
+* value is computed.
+*
+* Note that [s c]' and sestpr**2 is an eigenpair of the system
+*
+* diag(sest*sest, 0) + [alpha gamma] * [ alpha ]
+* [ gamma ]
+*
+* where alpha = x'*w.
+*
+* Arguments
+* =========
+*
+* JOB (input) INTEGER
+* = 1: an estimate for the largest singular value is computed.
+* = 2: an estimate for the smallest singular value is computed.
+*
+* J (input) INTEGER
+* Length of X and W
+*
+* X (input) REAL array, dimension (J)
+* The j-vector x.
+*
+* SEST (input) REAL
+* Estimated singular value of j by j matrix L
+*
+* W (input) REAL array, dimension (J)
+* The j-vector w.
+*
+* GAMMA (input) REAL
+* The diagonal element gamma.
+*
+* SESTPR (output) REAL
+* Estimated singular value of (j+1) by (j+1) matrix Lhat.
+*
+* S (output) REAL
+* Sine needed in forming xhat.
+*
+* C (output) REAL
+* Cosine needed in forming xhat.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO, ONE, TWO
+ PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0, TWO = 2.0E0 )
+ REAL HALF, FOUR
+ PARAMETER ( HALF = 0.5E0, FOUR = 4.0E0 )
+* ..
+* .. Local Scalars ..
+ REAL ABSALP, ABSEST, ABSGAM, ALPHA, B, COSINE, EPS,
+ $ NORMA, S1, S2, SINE, T, TEST, TMP, ZETA1, ZETA2
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, SIGN, SQRT
+* ..
+* .. External Functions ..
+ REAL SDOT, SLAMCH
+ EXTERNAL SDOT, SLAMCH
+* ..
+* .. Executable Statements ..
+*
+ EPS = SLAMCH( 'Epsilon' )
+ ALPHA = SDOT( J, X, 1, W, 1 )
+*
+ ABSALP = ABS( ALPHA )
+ ABSGAM = ABS( GAMMA )
+ ABSEST = ABS( SEST )
+*
+ IF( JOB.EQ.1 ) THEN
+*
+* Estimating largest singular value
+*
+* special cases
+*
+ IF( SEST.EQ.ZERO ) THEN
+ S1 = MAX( ABSGAM, ABSALP )
+ IF( S1.EQ.ZERO ) THEN
+ S = ZERO
+ C = ONE
+ SESTPR = ZERO
+ ELSE
+ S = ALPHA / S1
+ C = GAMMA / S1
+ TMP = SQRT( S*S+C*C )
+ S = S / TMP
+ C = C / TMP
+ SESTPR = S1*TMP
+ END IF
+ RETURN
+ ELSE IF( ABSGAM.LE.EPS*ABSEST ) THEN
+ S = ONE
+ C = ZERO
+ TMP = MAX( ABSEST, ABSALP )
+ S1 = ABSEST / TMP
+ S2 = ABSALP / TMP
+ SESTPR = TMP*SQRT( S1*S1+S2*S2 )
+ RETURN
+ ELSE IF( ABSALP.LE.EPS*ABSEST ) THEN
+ S1 = ABSGAM
+ S2 = ABSEST
+ IF( S1.LE.S2 ) THEN
+ S = ONE
+ C = ZERO
+ SESTPR = S2
+ ELSE
+ S = ZERO
+ C = ONE
+ SESTPR = S1
+ END IF
+ RETURN
+ ELSE IF( ABSEST.LE.EPS*ABSALP .OR. ABSEST.LE.EPS*ABSGAM ) THEN
+ S1 = ABSGAM
+ S2 = ABSALP
+ IF( S1.LE.S2 ) THEN
+ TMP = S1 / S2
+ S = SQRT( ONE+TMP*TMP )
+ SESTPR = S2*S
+ C = ( GAMMA / S2 ) / S
+ S = SIGN( ONE, ALPHA ) / S
+ ELSE
+ TMP = S2 / S1
+ C = SQRT( ONE+TMP*TMP )
+ SESTPR = S1*C
+ S = ( ALPHA / S1 ) / C
+ C = SIGN( ONE, GAMMA ) / C
+ END IF
+ RETURN
+ ELSE
+*
+* normal case
+*
+ ZETA1 = ALPHA / ABSEST
+ ZETA2 = GAMMA / ABSEST
+*
+ B = ( ONE-ZETA1*ZETA1-ZETA2*ZETA2 )*HALF
+ C = ZETA1*ZETA1
+ IF( B.GT.ZERO ) THEN
+ T = C / ( B+SQRT( B*B+C ) )
+ ELSE
+ T = SQRT( B*B+C ) - B
+ END IF
+*
+ SINE = -ZETA1 / T
+ COSINE = -ZETA2 / ( ONE+T )
+ TMP = SQRT( SINE*SINE+COSINE*COSINE )
+ S = SINE / TMP
+ C = COSINE / TMP
+ SESTPR = SQRT( T+ONE )*ABSEST
+ RETURN
+ END IF
+*
+ ELSE IF( JOB.EQ.2 ) THEN
+*
+* Estimating smallest singular value
+*
+* special cases
+*
+ IF( SEST.EQ.ZERO ) THEN
+ SESTPR = ZERO
+ IF( MAX( ABSGAM, ABSALP ).EQ.ZERO ) THEN
+ SINE = ONE
+ COSINE = ZERO
+ ELSE
+ SINE = -GAMMA
+ COSINE = ALPHA
+ END IF
+ S1 = MAX( ABS( SINE ), ABS( COSINE ) )
+ S = SINE / S1
+ C = COSINE / S1
+ TMP = SQRT( S*S+C*C )
+ S = S / TMP
+ C = C / TMP
+ RETURN
+ ELSE IF( ABSGAM.LE.EPS*ABSEST ) THEN
+ S = ZERO
+ C = ONE
+ SESTPR = ABSGAM
+ RETURN
+ ELSE IF( ABSALP.LE.EPS*ABSEST ) THEN
+ S1 = ABSGAM
+ S2 = ABSEST
+ IF( S1.LE.S2 ) THEN
+ S = ZERO
+ C = ONE
+ SESTPR = S1
+ ELSE
+ S = ONE
+ C = ZERO
+ SESTPR = S2
+ END IF
+ RETURN
+ ELSE IF( ABSEST.LE.EPS*ABSALP .OR. ABSEST.LE.EPS*ABSGAM ) THEN
+ S1 = ABSGAM
+ S2 = ABSALP
+ IF( S1.LE.S2 ) THEN
+ TMP = S1 / S2
+ C = SQRT( ONE+TMP*TMP )
+ SESTPR = ABSEST*( TMP / C )
+ S = -( GAMMA / S2 ) / C
+ C = SIGN( ONE, ALPHA ) / C
+ ELSE
+ TMP = S2 / S1
+ S = SQRT( ONE+TMP*TMP )
+ SESTPR = ABSEST / S
+ C = ( ALPHA / S1 ) / S
+ S = -SIGN( ONE, GAMMA ) / S
+ END IF
+ RETURN
+ ELSE
+*
+* normal case
+*
+ ZETA1 = ALPHA / ABSEST
+ ZETA2 = GAMMA / ABSEST
+*
+ NORMA = MAX( ONE+ZETA1*ZETA1+ABS( ZETA1*ZETA2 ),
+ $ ABS( ZETA1*ZETA2 )+ZETA2*ZETA2 )
+*
+* See if root is closer to zero or to ONE
+*
+ TEST = ONE + TWO*( ZETA1-ZETA2 )*( ZETA1+ZETA2 )
+ IF( TEST.GE.ZERO ) THEN
+*
+* root is close to zero, compute directly
+*
+ B = ( ZETA1*ZETA1+ZETA2*ZETA2+ONE )*HALF
+ C = ZETA2*ZETA2
+ T = C / ( B+SQRT( ABS( B*B-C ) ) )
+ SINE = ZETA1 / ( ONE-T )
+ COSINE = -ZETA2 / T
+ SESTPR = SQRT( T+FOUR*EPS*EPS*NORMA )*ABSEST
+ ELSE
+*
+* root is closer to ONE, shift by that amount
+*
+ B = ( ZETA2*ZETA2+ZETA1*ZETA1-ONE )*HALF
+ C = ZETA1*ZETA1
+ IF( B.GE.ZERO ) THEN
+ T = -C / ( B+SQRT( B*B+C ) )
+ ELSE
+ T = B - SQRT( B*B+C )
+ END IF
+ SINE = -ZETA1 / T
+ COSINE = -ZETA2 / ( ONE+T )
+ SESTPR = SQRT( ONE+T+FOUR*EPS*EPS*NORMA )*ABSEST
+ END IF
+ TMP = SQRT( SINE*SINE+COSINE*COSINE )
+ S = SINE / TMP
+ C = COSINE / TMP
+ RETURN
+*
+ END IF
+ END IF
+ RETURN
+*
+* End of SLAIC1
+*
+ END
+ LOGICAL FUNCTION SLAISNAN(SIN1,SIN2)
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ REAL SIN1,SIN2
+* ..
+*
+* Purpose
+* =======
+*
+* This routine is not for general use. It exists solely to avoid
+* over-optimization in SISNAN.
+*
+* SLAISNAN checks for NaNs by comparing its two arguments for
+* inequality. NaN is the only floating-point value where NaN != NaN
+* returns .TRUE. To check for NaNs, pass the same variable as both
+* arguments.
+*
+* Strictly speaking, Fortran does not allow aliasing of function
+* arguments. So a compiler must assume that the two arguments are
+* not the same variable, and the test will not be optimized away.
+* Interprocedural or whole-program optimization may delete this
+* test. The ISNAN functions will be replaced by the correct
+* Fortran 03 intrinsic once the intrinsic is widely available.
+*
+* Arguments
+* =========
+*
+* SIN1 (input) REAL
+* SIN2 (input) REAL
+* Two numbers to compare for inequality.
+*
+* =====================================================================
+*
+* .. Executable Statements ..
+ SLAISNAN = (SIN1.NE.SIN2)
+ RETURN
+ END
+ SUBROUTINE SLALN2( LTRANS, NA, NW, SMIN, CA, A, LDA, D1, D2, B,
+ $ LDB, WR, WI, X, LDX, SCALE, XNORM, INFO )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ LOGICAL LTRANS
+ INTEGER INFO, LDA, LDB, LDX, NA, NW
+ REAL CA, D1, D2, SCALE, SMIN, WI, WR, XNORM
+* ..
+* .. Array Arguments ..
+ REAL A( LDA, * ), B( LDB, * ), X( LDX, * )
+* ..
+*
+* Purpose
+* =======
+*
+* SLALN2 solves a system of the form (ca A - w D ) X = s B
+* or (ca A' - w D) X = s B with possible scaling ("s") and
+* perturbation of A. (A' means A-transpose.)
+*
+* A is an NA x NA real matrix, ca is a real scalar, D is an NA x NA
+* real diagonal matrix, w is a real or complex value, and X and B are
+* NA x 1 matrices -- real if w is real, complex if w is complex. NA
+* may be 1 or 2.
+*
+* If w is complex, X and B are represented as NA x 2 matrices,
+* the first column of each being the real part and the second
+* being the imaginary part.
+*
+* "s" is a scaling factor (.LE. 1), computed by SLALN2, which is
+* so chosen that X can be computed without overflow. X is further
+* scaled if necessary to assure that norm(ca A - w D)*norm(X) is less
+* than overflow.
+*
+* If both singular values of (ca A - w D) are less than SMIN,
+* SMIN*identity will be used instead of (ca A - w D). If only one
+* singular value is less than SMIN, one element of (ca A - w D) will be
+* perturbed enough to make the smallest singular value roughly SMIN.
+* If both singular values are at least SMIN, (ca A - w D) will not be
+* perturbed. In any case, the perturbation will be at most some small
+* multiple of max( SMIN, ulp*norm(ca A - w D) ). The singular values
+* are computed by infinity-norm approximations, and thus will only be
+* correct to a factor of 2 or so.
+*
+* Note: all input quantities are assumed to be smaller than overflow
+* by a reasonable factor. (See BIGNUM.)
+*
+* Arguments
+* ==========
+*
+* LTRANS (input) LOGICAL
+* =.TRUE.: A-transpose will be used.
+* =.FALSE.: A will be used (not transposed.)
+*
+* NA (input) INTEGER
+* The size of the matrix A. It may (only) be 1 or 2.
+*
+* NW (input) INTEGER
+* 1 if "w" is real, 2 if "w" is complex. It may only be 1
+* or 2.
+*
+* SMIN (input) REAL
+* The desired lower bound on the singular values of A. This
+* should be a safe distance away from underflow or overflow,
+* say, between (underflow/machine precision) and (machine
+* precision * overflow ). (See BIGNUM and ULP.)
+*
+* CA (input) REAL
+* The coefficient c, which A is multiplied by.
+*
+* A (input) REAL array, dimension (LDA,NA)
+* The NA x NA matrix A.
+*
+* LDA (input) INTEGER
+* The leading dimension of A. It must be at least NA.
+*
+* D1 (input) REAL
+* The 1,1 element in the diagonal matrix D.
+*
+* D2 (input) REAL
+* The 2,2 element in the diagonal matrix D. Not used if NW=1.
+*
+* B (input) REAL array, dimension (LDB,NW)
+* The NA x NW matrix B (right-hand side). If NW=2 ("w" is
+* complex), column 1 contains the real part of B and column 2
+* contains the imaginary part.
+*
+* LDB (input) INTEGER
+* The leading dimension of B. It must be at least NA.
+*
+* WR (input) REAL
+* The real part of the scalar "w".
+*
+* WI (input) REAL
+* The imaginary part of the scalar "w". Not used if NW=1.
+*
+* X (output) REAL array, dimension (LDX,NW)
+* The NA x NW matrix X (unknowns), as computed by SLALN2.
+* If NW=2 ("w" is complex), on exit, column 1 will contain
+* the real part of X and column 2 will contain the imaginary
+* part.
+*
+* LDX (input) INTEGER
+* The leading dimension of X. It must be at least NA.
+*
+* SCALE (output) REAL
+* The scale factor that B must be multiplied by to insure
+* that overflow does not occur when computing X. Thus,
+* (ca A - w D) X will be SCALE*B, not B (ignoring
+* perturbations of A.) It will be at most 1.
+*
+* XNORM (output) REAL
+* The infinity-norm of X, when X is regarded as an NA x NW
+* real matrix.
+*
+* INFO (output) INTEGER
+* An error flag. It will be set to zero if no error occurs,
+* a negative number if an argument is in error, or a positive
+* number if ca A - w D had to be perturbed.
+* The possible values are:
+* = 0: No error occurred, and (ca A - w D) did not have to be
+* perturbed.
+* = 1: (ca A - w D) had to be perturbed to make its smallest
+* (or only) singular value greater than SMIN.
+* NOTE: In the interests of speed, this routine does not
+* check the inputs for errors.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO, ONE
+ PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 )
+ REAL TWO
+ PARAMETER ( TWO = 2.0E0 )
+* ..
+* .. Local Scalars ..
+ INTEGER ICMAX, J
+ REAL BBND, BI1, BI2, BIGNUM, BNORM, BR1, BR2, CI21,
+ $ CI22, CMAX, CNORM, CR21, CR22, CSI, CSR, LI21,
+ $ LR21, SMINI, SMLNUM, TEMP, U22ABS, UI11, UI11R,
+ $ UI12, UI12S, UI22, UR11, UR11R, UR12, UR12S,
+ $ UR22, XI1, XI2, XR1, XR2
+* ..
+* .. Local Arrays ..
+ LOGICAL CSWAP( 4 ), RSWAP( 4 )
+ INTEGER IPIVOT( 4, 4 )
+ REAL CI( 2, 2 ), CIV( 4 ), CR( 2, 2 ), CRV( 4 )
+* ..
+* .. External Functions ..
+ REAL SLAMCH
+ EXTERNAL SLAMCH
+* ..
+* .. External Subroutines ..
+ EXTERNAL SLADIV
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX
+* ..
+* .. Equivalences ..
+ EQUIVALENCE ( CI( 1, 1 ), CIV( 1 ) ),
+ $ ( CR( 1, 1 ), CRV( 1 ) )
+* ..
+* .. Data statements ..
+ DATA CSWAP / .FALSE., .FALSE., .TRUE., .TRUE. /
+ DATA RSWAP / .FALSE., .TRUE., .FALSE., .TRUE. /
+ DATA IPIVOT / 1, 2, 3, 4, 2, 1, 4, 3, 3, 4, 1, 2, 4,
+ $ 3, 2, 1 /
+* ..
+* .. Executable Statements ..
+*
+* Compute BIGNUM
+*
+ SMLNUM = TWO*SLAMCH( 'Safe minimum' )
+ BIGNUM = ONE / SMLNUM
+ SMINI = MAX( SMIN, SMLNUM )
+*
+* Don't check for input errors
+*
+ INFO = 0
+*
+* Standard Initializations
+*
+ SCALE = ONE
+*
+ IF( NA.EQ.1 ) THEN
+*
+* 1 x 1 (i.e., scalar) system C X = B
+*
+ IF( NW.EQ.1 ) THEN
+*
+* Real 1x1 system.
+*
+* C = ca A - w D
+*
+ CSR = CA*A( 1, 1 ) - WR*D1
+ CNORM = ABS( CSR )
+*
+* If | C | < SMINI, use C = SMINI
+*
+ IF( CNORM.LT.SMINI ) THEN
+ CSR = SMINI
+ CNORM = SMINI
+ INFO = 1
+ END IF
+*
+* Check scaling for X = B / C
+*
+ BNORM = ABS( B( 1, 1 ) )
+ IF( CNORM.LT.ONE .AND. BNORM.GT.ONE ) THEN
+ IF( BNORM.GT.BIGNUM*CNORM )
+ $ SCALE = ONE / BNORM
+ END IF
+*
+* Compute X
+*
+ X( 1, 1 ) = ( B( 1, 1 )*SCALE ) / CSR
+ XNORM = ABS( X( 1, 1 ) )
+ ELSE
+*
+* Complex 1x1 system (w is complex)
+*
+* C = ca A - w D
+*
+ CSR = CA*A( 1, 1 ) - WR*D1
+ CSI = -WI*D1
+ CNORM = ABS( CSR ) + ABS( CSI )
+*
+* If | C | < SMINI, use C = SMINI
+*
+ IF( CNORM.LT.SMINI ) THEN
+ CSR = SMINI
+ CSI = ZERO
+ CNORM = SMINI
+ INFO = 1
+ END IF
+*
+* Check scaling for X = B / C
+*
+ BNORM = ABS( B( 1, 1 ) ) + ABS( B( 1, 2 ) )
+ IF( CNORM.LT.ONE .AND. BNORM.GT.ONE ) THEN
+ IF( BNORM.GT.BIGNUM*CNORM )
+ $ SCALE = ONE / BNORM
+ END IF
+*
+* Compute X
+*
+ CALL SLADIV( SCALE*B( 1, 1 ), SCALE*B( 1, 2 ), CSR, CSI,
+ $ X( 1, 1 ), X( 1, 2 ) )
+ XNORM = ABS( X( 1, 1 ) ) + ABS( X( 1, 2 ) )
+ END IF
+*
+ ELSE
+*
+* 2x2 System
+*
+* Compute the real part of C = ca A - w D (or ca A' - w D )
+*
+ CR( 1, 1 ) = CA*A( 1, 1 ) - WR*D1
+ CR( 2, 2 ) = CA*A( 2, 2 ) - WR*D2
+ IF( LTRANS ) THEN
+ CR( 1, 2 ) = CA*A( 2, 1 )
+ CR( 2, 1 ) = CA*A( 1, 2 )
+ ELSE
+ CR( 2, 1 ) = CA*A( 2, 1 )
+ CR( 1, 2 ) = CA*A( 1, 2 )
+ END IF
+*
+ IF( NW.EQ.1 ) THEN
+*
+* Real 2x2 system (w is real)
+*
+* Find the largest element in C
+*
+ CMAX = ZERO
+ ICMAX = 0
+*
+ DO 10 J = 1, 4
+ IF( ABS( CRV( J ) ).GT.CMAX ) THEN
+ CMAX = ABS( CRV( J ) )
+ ICMAX = J
+ END IF
+ 10 CONTINUE
+*
+* If norm(C) < SMINI, use SMINI*identity.
+*
+ IF( CMAX.LT.SMINI ) THEN
+ BNORM = MAX( ABS( B( 1, 1 ) ), ABS( B( 2, 1 ) ) )
+ IF( SMINI.LT.ONE .AND. BNORM.GT.ONE ) THEN
+ IF( BNORM.GT.BIGNUM*SMINI )
+ $ SCALE = ONE / BNORM
+ END IF
+ TEMP = SCALE / SMINI
+ X( 1, 1 ) = TEMP*B( 1, 1 )
+ X( 2, 1 ) = TEMP*B( 2, 1 )
+ XNORM = TEMP*BNORM
+ INFO = 1
+ RETURN
+ END IF
+*
+* Gaussian elimination with complete pivoting.
+*
+ UR11 = CRV( ICMAX )
+ CR21 = CRV( IPIVOT( 2, ICMAX ) )
+ UR12 = CRV( IPIVOT( 3, ICMAX ) )
+ CR22 = CRV( IPIVOT( 4, ICMAX ) )
+ UR11R = ONE / UR11
+ LR21 = UR11R*CR21
+ UR22 = CR22 - UR12*LR21
+*
+* If smaller pivot < SMINI, use SMINI
+*
+ IF( ABS( UR22 ).LT.SMINI ) THEN
+ UR22 = SMINI
+ INFO = 1
+ END IF
+ IF( RSWAP( ICMAX ) ) THEN
+ BR1 = B( 2, 1 )
+ BR2 = B( 1, 1 )
+ ELSE
+ BR1 = B( 1, 1 )
+ BR2 = B( 2, 1 )
+ END IF
+ BR2 = BR2 - LR21*BR1
+ BBND = MAX( ABS( BR1*( UR22*UR11R ) ), ABS( BR2 ) )
+ IF( BBND.GT.ONE .AND. ABS( UR22 ).LT.ONE ) THEN
+ IF( BBND.GE.BIGNUM*ABS( UR22 ) )
+ $ SCALE = ONE / BBND
+ END IF
+*
+ XR2 = ( BR2*SCALE ) / UR22
+ XR1 = ( SCALE*BR1 )*UR11R - XR2*( UR11R*UR12 )
+ IF( CSWAP( ICMAX ) ) THEN
+ X( 1, 1 ) = XR2
+ X( 2, 1 ) = XR1
+ ELSE
+ X( 1, 1 ) = XR1
+ X( 2, 1 ) = XR2
+ END IF
+ XNORM = MAX( ABS( XR1 ), ABS( XR2 ) )
+*
+* Further scaling if norm(A) norm(X) > overflow
+*
+ IF( XNORM.GT.ONE .AND. CMAX.GT.ONE ) THEN
+ IF( XNORM.GT.BIGNUM / CMAX ) THEN
+ TEMP = CMAX / BIGNUM
+ X( 1, 1 ) = TEMP*X( 1, 1 )
+ X( 2, 1 ) = TEMP*X( 2, 1 )
+ XNORM = TEMP*XNORM
+ SCALE = TEMP*SCALE
+ END IF
+ END IF
+ ELSE
+*
+* Complex 2x2 system (w is complex)
+*
+* Find the largest element in C
+*
+ CI( 1, 1 ) = -WI*D1
+ CI( 2, 1 ) = ZERO
+ CI( 1, 2 ) = ZERO
+ CI( 2, 2 ) = -WI*D2
+ CMAX = ZERO
+ ICMAX = 0
+*
+ DO 20 J = 1, 4
+ IF( ABS( CRV( J ) )+ABS( CIV( J ) ).GT.CMAX ) THEN
+ CMAX = ABS( CRV( J ) ) + ABS( CIV( J ) )
+ ICMAX = J
+ END IF
+ 20 CONTINUE
+*
+* If norm(C) < SMINI, use SMINI*identity.
+*
+ IF( CMAX.LT.SMINI ) THEN
+ BNORM = MAX( ABS( B( 1, 1 ) )+ABS( B( 1, 2 ) ),
+ $ ABS( B( 2, 1 ) )+ABS( B( 2, 2 ) ) )
+ IF( SMINI.LT.ONE .AND. BNORM.GT.ONE ) THEN
+ IF( BNORM.GT.BIGNUM*SMINI )
+ $ SCALE = ONE / BNORM
+ END IF
+ TEMP = SCALE / SMINI
+ X( 1, 1 ) = TEMP*B( 1, 1 )
+ X( 2, 1 ) = TEMP*B( 2, 1 )
+ X( 1, 2 ) = TEMP*B( 1, 2 )
+ X( 2, 2 ) = TEMP*B( 2, 2 )
+ XNORM = TEMP*BNORM
+ INFO = 1
+ RETURN
+ END IF
+*
+* Gaussian elimination with complete pivoting.
+*
+ UR11 = CRV( ICMAX )
+ UI11 = CIV( ICMAX )
+ CR21 = CRV( IPIVOT( 2, ICMAX ) )
+ CI21 = CIV( IPIVOT( 2, ICMAX ) )
+ UR12 = CRV( IPIVOT( 3, ICMAX ) )
+ UI12 = CIV( IPIVOT( 3, ICMAX ) )
+ CR22 = CRV( IPIVOT( 4, ICMAX ) )
+ CI22 = CIV( IPIVOT( 4, ICMAX ) )
+ IF( ICMAX.EQ.1 .OR. ICMAX.EQ.4 ) THEN
+*
+* Code when off-diagonals of pivoted C are real
+*
+ IF( ABS( UR11 ).GT.ABS( UI11 ) ) THEN
+ TEMP = UI11 / UR11
+ UR11R = ONE / ( UR11*( ONE+TEMP**2 ) )
+ UI11R = -TEMP*UR11R
+ ELSE
+ TEMP = UR11 / UI11
+ UI11R = -ONE / ( UI11*( ONE+TEMP**2 ) )
+ UR11R = -TEMP*UI11R
+ END IF
+ LR21 = CR21*UR11R
+ LI21 = CR21*UI11R
+ UR12S = UR12*UR11R
+ UI12S = UR12*UI11R
+ UR22 = CR22 - UR12*LR21
+ UI22 = CI22 - UR12*LI21
+ ELSE
+*
+* Code when diagonals of pivoted C are real
+*
+ UR11R = ONE / UR11
+ UI11R = ZERO
+ LR21 = CR21*UR11R
+ LI21 = CI21*UR11R
+ UR12S = UR12*UR11R
+ UI12S = UI12*UR11R
+ UR22 = CR22 - UR12*LR21 + UI12*LI21
+ UI22 = -UR12*LI21 - UI12*LR21
+ END IF
+ U22ABS = ABS( UR22 ) + ABS( UI22 )
+*
+* If smaller pivot < SMINI, use SMINI
+*
+ IF( U22ABS.LT.SMINI ) THEN
+ UR22 = SMINI
+ UI22 = ZERO
+ INFO = 1
+ END IF
+ IF( RSWAP( ICMAX ) ) THEN
+ BR2 = B( 1, 1 )
+ BR1 = B( 2, 1 )
+ BI2 = B( 1, 2 )
+ BI1 = B( 2, 2 )
+ ELSE
+ BR1 = B( 1, 1 )
+ BR2 = B( 2, 1 )
+ BI1 = B( 1, 2 )
+ BI2 = B( 2, 2 )
+ END IF
+ BR2 = BR2 - LR21*BR1 + LI21*BI1
+ BI2 = BI2 - LI21*BR1 - LR21*BI1
+ BBND = MAX( ( ABS( BR1 )+ABS( BI1 ) )*
+ $ ( U22ABS*( ABS( UR11R )+ABS( UI11R ) ) ),
+ $ ABS( BR2 )+ABS( BI2 ) )
+ IF( BBND.GT.ONE .AND. U22ABS.LT.ONE ) THEN
+ IF( BBND.GE.BIGNUM*U22ABS ) THEN
+ SCALE = ONE / BBND
+ BR1 = SCALE*BR1
+ BI1 = SCALE*BI1
+ BR2 = SCALE*BR2
+ BI2 = SCALE*BI2
+ END IF
+ END IF
+*
+ CALL SLADIV( BR2, BI2, UR22, UI22, XR2, XI2 )
+ XR1 = UR11R*BR1 - UI11R*BI1 - UR12S*XR2 + UI12S*XI2
+ XI1 = UI11R*BR1 + UR11R*BI1 - UI12S*XR2 - UR12S*XI2
+ IF( CSWAP( ICMAX ) ) THEN
+ X( 1, 1 ) = XR2
+ X( 2, 1 ) = XR1
+ X( 1, 2 ) = XI2
+ X( 2, 2 ) = XI1
+ ELSE
+ X( 1, 1 ) = XR1
+ X( 2, 1 ) = XR2
+ X( 1, 2 ) = XI1
+ X( 2, 2 ) = XI2
+ END IF
+ XNORM = MAX( ABS( XR1 )+ABS( XI1 ), ABS( XR2 )+ABS( XI2 ) )
+*
+* Further scaling if norm(A) norm(X) > overflow
+*
+ IF( XNORM.GT.ONE .AND. CMAX.GT.ONE ) THEN
+ IF( XNORM.GT.BIGNUM / CMAX ) THEN
+ TEMP = CMAX / BIGNUM
+ X( 1, 1 ) = TEMP*X( 1, 1 )
+ X( 2, 1 ) = TEMP*X( 2, 1 )
+ X( 1, 2 ) = TEMP*X( 1, 2 )
+ X( 2, 2 ) = TEMP*X( 2, 2 )
+ XNORM = TEMP*XNORM
+ SCALE = TEMP*SCALE
+ END IF
+ END IF
+ END IF
+ END IF
+*
+ RETURN
+*
+* End of SLALN2
+*
+ END
+ 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 )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER GIVPTR, ICOMPQ, INFO, K, LDB, LDBX, LDGCOL,
+ $ LDGNUM, NL, NR, NRHS, SQRE
+ REAL C, S
+* ..
+* .. Array Arguments ..
+ INTEGER GIVCOL( LDGCOL, * ), PERM( * )
+ REAL B( LDB, * ), BX( LDBX, * ), DIFL( * ),
+ $ DIFR( LDGNUM, * ), GIVNUM( LDGNUM, * ),
+ $ POLES( LDGNUM, * ), WORK( * ), Z( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SLALS0 applies back the multiplying factors of either the left or the
+* right singular vector matrix of a diagonal matrix appended by a row
+* to the right hand side matrix B in solving the least squares problem
+* using the divide-and-conquer SVD approach.
+*
+* For the left singular vector matrix, three types of orthogonal
+* matrices are involved:
+*
+* (1L) Givens rotations: the number of such rotations is GIVPTR; the
+* pairs of columns/rows they were applied to are stored in GIVCOL;
+* and the C- and S-values of these rotations are stored in GIVNUM.
+*
+* (2L) Permutation. The (NL+1)-st row of B is to be moved to the first
+* row, and for J=2:N, PERM(J)-th row of B is to be moved to the
+* J-th row.
+*
+* (3L) The left singular vector matrix of the remaining matrix.
+*
+* For the right singular vector matrix, four types of orthogonal
+* matrices are involved:
+*
+* (1R) The right singular vector matrix of the remaining matrix.
+*
+* (2R) If SQRE = 1, one extra Givens rotation to generate the right
+* null space.
+*
+* (3R) The inverse transformation of (2L).
+*
+* (4R) The inverse transformation of (1L).
+*
+* Arguments
+* =========
+*
+* ICOMPQ (input) INTEGER
+* Specifies whether singular vectors are to be computed in
+* factored form:
+* = 0: Left singular vector matrix.
+* = 1: Right singular vector matrix.
+*
+* NL (input) INTEGER
+* The row dimension of the upper block. NL >= 1.
+*
+* NR (input) INTEGER
+* The row dimension of the lower block. NR >= 1.
+*
+* SQRE (input) INTEGER
+* = 0: the lower block is an NR-by-NR square matrix.
+* = 1: the lower block is an NR-by-(NR+1) rectangular matrix.
+*
+* The bidiagonal matrix has row dimension N = NL + NR + 1,
+* and column dimension M = N + SQRE.
+*
+* NRHS (input) INTEGER
+* The number of columns of B and BX. NRHS must be at least 1.
+*
+* B (input/output) REAL array, dimension ( LDB, NRHS )
+* On input, B contains the right hand sides of the least
+* squares problem in rows 1 through M. On output, B contains
+* the solution X in rows 1 through N.
+*
+* LDB (input) INTEGER
+* The leading dimension of B. LDB must be at least
+* max(1,MAX( M, N ) ).
+*
+* BX (workspace) REAL array, dimension ( LDBX, NRHS )
+*
+* LDBX (input) INTEGER
+* The leading dimension of BX.
+*
+* PERM (input) INTEGER array, dimension ( N )
+* The permutations (from deflation and sorting) applied
+* to the two blocks.
+*
+* GIVPTR (input) INTEGER
+* The number of Givens rotations which took place in this
+* subproblem.
+*
+* GIVCOL (input) INTEGER array, dimension ( LDGCOL, 2 )
+* Each pair of numbers indicates a pair of rows/columns
+* involved in a Givens rotation.
+*
+* LDGCOL (input) INTEGER
+* The leading dimension of GIVCOL, must be at least N.
+*
+* GIVNUM (input) REAL array, dimension ( LDGNUM, 2 )
+* Each number indicates the C or S value used in the
+* corresponding Givens rotation.
+*
+* LDGNUM (input) INTEGER
+* The leading dimension of arrays DIFR, POLES and
+* GIVNUM, must be at least K.
+*
+* POLES (input) REAL array, dimension ( LDGNUM, 2 )
+* On entry, POLES(1:K, 1) contains the new singular
+* values obtained from solving the secular equation, and
+* POLES(1:K, 2) is an array containing the poles in the secular
+* equation.
+*
+* DIFL (input) REAL array, dimension ( K ).
+* On entry, DIFL(I) is the distance between I-th updated
+* (undeflated) singular value and the I-th (undeflated) old
+* singular value.
+*
+* DIFR (input) REAL array, dimension ( LDGNUM, 2 ).
+* On entry, DIFR(I, 1) contains the distances between I-th
+* updated (undeflated) singular value and the I+1-th
+* (undeflated) old singular value. And DIFR(I, 2) is the
+* normalizing factor for the I-th right singular vector.
+*
+* Z (input) REAL array, dimension ( K )
+* Contain the components of the deflation-adjusted updating row
+* vector.
+*
+* K (input) INTEGER
+* Contains the dimension of the non-deflated matrix,
+* This is the order of the related secular equation. 1 <= K <=N.
+*
+* C (input) REAL
+* C contains garbage if SQRE =0 and the C-value of a Givens
+* rotation related to the right null space if SQRE = 1.
+*
+* S (input) REAL
+* S contains garbage if SQRE =0 and the S-value of a Givens
+* rotation related to the right null space if SQRE = 1.
+*
+* WORK (workspace) REAL array, dimension ( K )
+*
+* INFO (output) INTEGER
+* = 0: successful exit.
+* < 0: if INFO = -i, the i-th argument had an illegal value.
+*
+* Further Details
+* ===============
+*
+* Based on contributions by
+* Ming Gu and Ren-Cang Li, Computer Science Division, University of
+* California at Berkeley, USA
+* Osni Marques, LBNL/NERSC, USA
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ONE, ZERO, NEGONE
+ PARAMETER ( ONE = 1.0E0, ZERO = 0.0E0, NEGONE = -1.0E0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, J, M, N, NLP1
+ REAL DIFLJ, DIFRJ, DJ, DSIGJ, DSIGJP, TEMP
+* ..
+* .. External Subroutines ..
+ EXTERNAL SCOPY, SGEMV, SLACPY, SLASCL, SROT, SSCAL,
+ $ XERBLA
+* ..
+* .. External Functions ..
+ REAL SLAMC3, SNRM2
+ EXTERNAL SLAMC3, SNRM2
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+*
+ IF( ( ICOMPQ.LT.0 ) .OR. ( ICOMPQ.GT.1 ) ) THEN
+ INFO = -1
+ ELSE IF( NL.LT.1 ) THEN
+ INFO = -2
+ ELSE IF( NR.LT.1 ) THEN
+ INFO = -3
+ ELSE IF( ( SQRE.LT.0 ) .OR. ( SQRE.GT.1 ) ) THEN
+ INFO = -4
+ END IF
+*
+ N = NL + NR + 1
+*
+ IF( NRHS.LT.1 ) THEN
+ INFO = -5
+ ELSE IF( LDB.LT.N ) THEN
+ INFO = -7
+ ELSE IF( LDBX.LT.N ) THEN
+ INFO = -9
+ ELSE IF( GIVPTR.LT.0 ) THEN
+ INFO = -11
+ ELSE IF( LDGCOL.LT.N ) THEN
+ INFO = -13
+ ELSE IF( LDGNUM.LT.N ) THEN
+ INFO = -15
+ ELSE IF( K.LT.1 ) THEN
+ INFO = -20
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SLALS0', -INFO )
+ RETURN
+ END IF
+*
+ M = N + SQRE
+ NLP1 = NL + 1
+*
+ IF( ICOMPQ.EQ.0 ) THEN
+*
+* Apply back orthogonal transformations from the left.
+*
+* Step (1L): apply back the Givens rotations performed.
+*
+ DO 10 I = 1, GIVPTR
+ CALL SROT( NRHS, B( GIVCOL( I, 2 ), 1 ), LDB,
+ $ B( GIVCOL( I, 1 ), 1 ), LDB, GIVNUM( I, 2 ),
+ $ GIVNUM( I, 1 ) )
+ 10 CONTINUE
+*
+* Step (2L): permute rows of B.
+*
+ CALL SCOPY( NRHS, B( NLP1, 1 ), LDB, BX( 1, 1 ), LDBX )
+ DO 20 I = 2, N
+ CALL SCOPY( NRHS, B( PERM( I ), 1 ), LDB, BX( I, 1 ), LDBX )
+ 20 CONTINUE
+*
+* Step (3L): apply the inverse of the left singular vector
+* matrix to BX.
+*
+ IF( K.EQ.1 ) THEN
+ CALL SCOPY( NRHS, BX, LDBX, B, LDB )
+ IF( Z( 1 ).LT.ZERO ) THEN
+ CALL SSCAL( NRHS, NEGONE, B, LDB )
+ END IF
+ ELSE
+ DO 50 J = 1, K
+ DIFLJ = DIFL( J )
+ DJ = POLES( J, 1 )
+ DSIGJ = -POLES( J, 2 )
+ IF( J.LT.K ) THEN
+ DIFRJ = -DIFR( J, 1 )
+ DSIGJP = -POLES( J+1, 2 )
+ END IF
+ IF( ( Z( J ).EQ.ZERO ) .OR. ( POLES( J, 2 ).EQ.ZERO ) )
+ $ THEN
+ WORK( J ) = ZERO
+ ELSE
+ WORK( J ) = -POLES( J, 2 )*Z( J ) / DIFLJ /
+ $ ( POLES( J, 2 )+DJ )
+ END IF
+ DO 30 I = 1, J - 1
+ IF( ( Z( I ).EQ.ZERO ) .OR.
+ $ ( POLES( I, 2 ).EQ.ZERO ) ) THEN
+ WORK( I ) = ZERO
+ ELSE
+ WORK( I ) = POLES( I, 2 )*Z( I ) /
+ $ ( SLAMC3( POLES( I, 2 ), DSIGJ )-
+ $ DIFLJ ) / ( POLES( I, 2 )+DJ )
+ END IF
+ 30 CONTINUE
+ DO 40 I = J + 1, K
+ IF( ( Z( I ).EQ.ZERO ) .OR.
+ $ ( POLES( I, 2 ).EQ.ZERO ) ) THEN
+ WORK( I ) = ZERO
+ ELSE
+ WORK( I ) = POLES( I, 2 )*Z( I ) /
+ $ ( SLAMC3( POLES( I, 2 ), DSIGJP )+
+ $ DIFRJ ) / ( POLES( I, 2 )+DJ )
+ END IF
+ 40 CONTINUE
+ WORK( 1 ) = NEGONE
+ TEMP = SNRM2( K, WORK, 1 )
+ CALL SGEMV( 'T', K, NRHS, ONE, BX, LDBX, WORK, 1, ZERO,
+ $ B( J, 1 ), LDB )
+ CALL SLASCL( 'G', 0, 0, TEMP, ONE, 1, NRHS, B( J, 1 ),
+ $ LDB, INFO )
+ 50 CONTINUE
+ END IF
+*
+* Move the deflated rows of BX to B also.
+*
+ IF( K.LT.MAX( M, N ) )
+ $ CALL SLACPY( 'A', N-K, NRHS, BX( K+1, 1 ), LDBX,
+ $ B( K+1, 1 ), LDB )
+ ELSE
+*
+* Apply back the right orthogonal transformations.
+*
+* Step (1R): apply back the new right singular vector matrix
+* to B.
+*
+ IF( K.EQ.1 ) THEN
+ CALL SCOPY( NRHS, B, LDB, BX, LDBX )
+ ELSE
+ DO 80 J = 1, K
+ DSIGJ = POLES( J, 2 )
+ IF( Z( J ).EQ.ZERO ) THEN
+ WORK( J ) = ZERO
+ ELSE
+ WORK( J ) = -Z( J ) / DIFL( J ) /
+ $ ( DSIGJ+POLES( J, 1 ) ) / DIFR( J, 2 )
+ END IF
+ DO 60 I = 1, J - 1
+ IF( Z( J ).EQ.ZERO ) THEN
+ WORK( I ) = ZERO
+ ELSE
+ WORK( I ) = Z( J ) / ( SLAMC3( DSIGJ, -POLES( I+1,
+ $ 2 ) )-DIFR( I, 1 ) ) /
+ $ ( DSIGJ+POLES( I, 1 ) ) / DIFR( I, 2 )
+ END IF
+ 60 CONTINUE
+ DO 70 I = J + 1, K
+ IF( Z( J ).EQ.ZERO ) THEN
+ WORK( I ) = ZERO
+ ELSE
+ WORK( I ) = Z( J ) / ( SLAMC3( DSIGJ, -POLES( I,
+ $ 2 ) )-DIFL( I ) ) /
+ $ ( DSIGJ+POLES( I, 1 ) ) / DIFR( I, 2 )
+ END IF
+ 70 CONTINUE
+ CALL SGEMV( 'T', K, NRHS, ONE, B, LDB, WORK, 1, ZERO,
+ $ BX( J, 1 ), LDBX )
+ 80 CONTINUE
+ END IF
+*
+* Step (2R): if SQRE = 1, apply back the rotation that is
+* related to the right null space of the subproblem.
+*
+ IF( SQRE.EQ.1 ) THEN
+ CALL SCOPY( NRHS, B( M, 1 ), LDB, BX( M, 1 ), LDBX )
+ CALL SROT( NRHS, BX( 1, 1 ), LDBX, BX( M, 1 ), LDBX, C, S )
+ END IF
+ IF( K.LT.MAX( M, N ) )
+ $ CALL SLACPY( 'A', N-K, NRHS, B( K+1, 1 ), LDB, BX( K+1, 1 ),
+ $ LDBX )
+*
+* Step (3R): permute rows of B.
+*
+ CALL SCOPY( NRHS, BX( 1, 1 ), LDBX, B( NLP1, 1 ), LDB )
+ IF( SQRE.EQ.1 ) THEN
+ CALL SCOPY( NRHS, BX( M, 1 ), LDBX, B( M, 1 ), LDB )
+ END IF
+ DO 90 I = 2, N
+ CALL SCOPY( NRHS, BX( I, 1 ), LDBX, B( PERM( I ), 1 ), LDB )
+ 90 CONTINUE
+*
+* Step (4R): apply back the Givens rotations performed.
+*
+ DO 100 I = GIVPTR, 1, -1
+ CALL SROT( NRHS, B( GIVCOL( I, 2 ), 1 ), LDB,
+ $ B( GIVCOL( I, 1 ), 1 ), LDB, GIVNUM( I, 2 ),
+ $ -GIVNUM( I, 1 ) )
+ 100 CONTINUE
+ END IF
+*
+ RETURN
+*
+* End of SLALS0
+*
+ END
+ 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 )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER ICOMPQ, INFO, LDB, LDBX, LDGCOL, LDU, N, NRHS,
+ $ SMLSIZ
+* ..
+* .. Array Arguments ..
+ INTEGER GIVCOL( LDGCOL, * ), GIVPTR( * ), IWORK( * ),
+ $ K( * ), PERM( LDGCOL, * )
+ REAL B( LDB, * ), BX( LDBX, * ), C( * ),
+ $ DIFL( LDU, * ), DIFR( LDU, * ),
+ $ GIVNUM( LDU, * ), POLES( LDU, * ), S( * ),
+ $ U( LDU, * ), VT( LDU, * ), WORK( * ),
+ $ Z( LDU, * )
+* ..
+*
+* Purpose
+* =======
+*
+* SLALSA is an itermediate step in solving the least squares problem
+* by computing the SVD of the coefficient matrix in compact form (The
+* singular vectors are computed as products of simple orthorgonal
+* matrices.).
+*
+* If ICOMPQ = 0, SLALSA applies the inverse of the left singular vector
+* matrix of an upper bidiagonal matrix to the right hand side; and if
+* ICOMPQ = 1, SLALSA applies the right singular vector matrix to the
+* right hand side. The singular vector matrices were generated in
+* compact form by SLALSA.
+*
+* Arguments
+* =========
+*
+*
+* ICOMPQ (input) INTEGER
+* Specifies whether the left or the right singular vector
+* matrix is involved.
+* = 0: Left singular vector matrix
+* = 1: Right singular vector matrix
+*
+* SMLSIZ (input) INTEGER
+* The maximum size of the subproblems at the bottom of the
+* computation tree.
+*
+* N (input) INTEGER
+* The row and column dimensions of the upper bidiagonal matrix.
+*
+* NRHS (input) INTEGER
+* The number of columns of B and BX. NRHS must be at least 1.
+*
+* B (input/output) REAL array, dimension ( LDB, NRHS )
+* On input, B contains the right hand sides of the least
+* squares problem in rows 1 through M.
+* On output, B contains the solution X in rows 1 through N.
+*
+* LDB (input) INTEGER
+* The leading dimension of B in the calling subprogram.
+* LDB must be at least max(1,MAX( M, N ) ).
+*
+* BX (output) REAL array, dimension ( LDBX, NRHS )
+* On exit, the result of applying the left or right singular
+* vector matrix to B.
+*
+* LDBX (input) INTEGER
+* The leading dimension of BX.
+*
+* U (input) REAL array, dimension ( LDU, SMLSIZ ).
+* On entry, U contains the left singular vector matrices of all
+* subproblems at the bottom level.
+*
+* LDU (input) INTEGER, LDU = > N.
+* The leading dimension of arrays U, VT, DIFL, DIFR,
+* POLES, GIVNUM, and Z.
+*
+* VT (input) REAL array, dimension ( LDU, SMLSIZ+1 ).
+* On entry, VT' contains the right singular vector matrices of
+* all subproblems at the bottom level.
+*
+* K (input) INTEGER array, dimension ( N ).
+*
+* DIFL (input) REAL array, dimension ( LDU, NLVL ).
+* where NLVL = INT(log_2 (N/(SMLSIZ+1))) + 1.
+*
+* DIFR (input) REAL array, dimension ( LDU, 2 * NLVL ).
+* On entry, DIFL(*, I) and DIFR(*, 2 * I -1) record
+* distances between singular values on the I-th level and
+* singular values on the (I -1)-th level, and DIFR(*, 2 * I)
+* record the normalizing factors of the right singular vectors
+* matrices of subproblems on I-th level.
+*
+* Z (input) REAL array, dimension ( LDU, NLVL ).
+* On entry, Z(1, I) contains the components of the deflation-
+* adjusted updating row vector for subproblems on the I-th
+* level.
+*
+* POLES (input) REAL array, dimension ( LDU, 2 * NLVL ).
+* On entry, POLES(*, 2 * I -1: 2 * I) contains the new and old
+* singular values involved in the secular equations on the I-th
+* level.
+*
+* GIVPTR (input) INTEGER array, dimension ( N ).
+* On entry, GIVPTR( I ) records the number of Givens
+* rotations performed on the I-th problem on the computation
+* tree.
+*
+* GIVCOL (input) INTEGER array, dimension ( LDGCOL, 2 * NLVL ).
+* On entry, for each I, GIVCOL(*, 2 * I - 1: 2 * I) records the
+* locations of Givens rotations performed on the I-th level on
+* the computation tree.
+*
+* LDGCOL (input) INTEGER, LDGCOL = > N.
+* The leading dimension of arrays GIVCOL and PERM.
+*
+* PERM (input) INTEGER array, dimension ( LDGCOL, NLVL ).
+* On entry, PERM(*, I) records permutations done on the I-th
+* level of the computation tree.
+*
+* GIVNUM (input) REAL array, dimension ( LDU, 2 * NLVL ).
+* On entry, GIVNUM(*, 2 *I -1 : 2 * I) records the C- and S-
+* values of Givens rotations performed on the I-th level on the
+* computation tree.
+*
+* C (input) REAL array, dimension ( N ).
+* On entry, if the I-th subproblem is not square,
+* C( I ) contains the C-value of a Givens rotation related to
+* the right null space of the I-th subproblem.
+*
+* S (input) REAL array, dimension ( N ).
+* On entry, if the I-th subproblem is not square,
+* S( I ) contains the S-value of a Givens rotation related to
+* the right null space of the I-th subproblem.
+*
+* WORK (workspace) REAL array.
+* The dimension must be at least N.
+*
+* IWORK (workspace) INTEGER array.
+* The dimension must be at least 3 * N
+*
+* INFO (output) INTEGER
+* = 0: successful exit.
+* < 0: if INFO = -i, the i-th argument had an illegal value.
+*
+* Further Details
+* ===============
+*
+* Based on contributions by
+* Ming Gu and Ren-Cang Li, Computer Science Division, University of
+* California at Berkeley, USA
+* Osni Marques, LBNL/NERSC, USA
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO, ONE
+ PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, I1, IC, IM1, INODE, J, LF, LL, LVL, LVL2,
+ $ ND, NDB1, NDIML, NDIMR, NL, NLF, NLP1, NLVL,
+ $ NR, NRF, NRP1, SQRE
+* ..
+* .. External Subroutines ..
+ EXTERNAL SCOPY, SGEMM, SLALS0, SLASDT, XERBLA
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+*
+ IF( ( ICOMPQ.LT.0 ) .OR. ( ICOMPQ.GT.1 ) ) THEN
+ INFO = -1
+ ELSE IF( SMLSIZ.LT.3 ) THEN
+ INFO = -2
+ ELSE IF( N.LT.SMLSIZ ) THEN
+ INFO = -3
+ ELSE IF( NRHS.LT.1 ) THEN
+ INFO = -4
+ ELSE IF( LDB.LT.N ) THEN
+ INFO = -6
+ ELSE IF( LDBX.LT.N ) THEN
+ INFO = -8
+ ELSE IF( LDU.LT.N ) THEN
+ INFO = -10
+ ELSE IF( LDGCOL.LT.N ) THEN
+ INFO = -19
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SLALSA', -INFO )
+ RETURN
+ END IF
+*
+* Book-keeping and setting up the computation tree.
+*
+ INODE = 1
+ NDIML = INODE + N
+ NDIMR = NDIML + N
+*
+ CALL SLASDT( N, NLVL, ND, IWORK( INODE ), IWORK( NDIML ),
+ $ IWORK( NDIMR ), SMLSIZ )
+*
+* The following code applies back the left singular vector factors.
+* For applying back the right singular vector factors, go to 50.
+*
+ IF( ICOMPQ.EQ.1 ) THEN
+ GO TO 50
+ END IF
+*
+* The nodes on the bottom level of the tree were solved
+* by SLASDQ. The corresponding left and right singular vector
+* matrices are in explicit form. First apply back the left
+* singular vector matrices.
+*
+ NDB1 = ( ND+1 ) / 2
+ DO 10 I = NDB1, ND
+*
+* IC : center row of each node
+* NL : number of rows of left subproblem
+* NR : number of rows of right subproblem
+* NLF: starting row of the left subproblem
+* NRF: starting row of the right subproblem
+*
+ I1 = I - 1
+ IC = IWORK( INODE+I1 )
+ NL = IWORK( NDIML+I1 )
+ NR = IWORK( NDIMR+I1 )
+ NLF = IC - NL
+ NRF = IC + 1
+ CALL SGEMM( 'T', 'N', NL, NRHS, NL, ONE, U( NLF, 1 ), LDU,
+ $ B( NLF, 1 ), LDB, ZERO, BX( NLF, 1 ), LDBX )
+ CALL SGEMM( 'T', 'N', NR, NRHS, NR, ONE, U( NRF, 1 ), LDU,
+ $ B( NRF, 1 ), LDB, ZERO, BX( NRF, 1 ), LDBX )
+ 10 CONTINUE
+*
+* Next copy the rows of B that correspond to unchanged rows
+* in the bidiagonal matrix to BX.
+*
+ DO 20 I = 1, ND
+ IC = IWORK( INODE+I-1 )
+ CALL SCOPY( NRHS, B( IC, 1 ), LDB, BX( IC, 1 ), LDBX )
+ 20 CONTINUE
+*
+* Finally go through the left singular vector matrices of all
+* the other subproblems bottom-up on the tree.
+*
+ J = 2**NLVL
+ SQRE = 0
+*
+ DO 40 LVL = NLVL, 1, -1
+ LVL2 = 2*LVL - 1
+*
+* find the first node LF and last node LL on
+* the current level LVL
+*
+ IF( LVL.EQ.1 ) THEN
+ LF = 1
+ LL = 1
+ ELSE
+ LF = 2**( LVL-1 )
+ LL = 2*LF - 1
+ END IF
+ DO 30 I = LF, LL
+ IM1 = I - 1
+ IC = IWORK( INODE+IM1 )
+ NL = IWORK( NDIML+IM1 )
+ NR = IWORK( NDIMR+IM1 )
+ NLF = IC - NL
+ NRF = IC + 1
+ J = J - 1
+ CALL SLALS0( ICOMPQ, NL, NR, SQRE, NRHS, BX( NLF, 1 ), LDBX,
+ $ B( NLF, 1 ), LDB, PERM( NLF, LVL ),
+ $ GIVPTR( J ), GIVCOL( NLF, LVL2 ), LDGCOL,
+ $ GIVNUM( NLF, LVL2 ), LDU, POLES( NLF, LVL2 ),
+ $ DIFL( NLF, LVL ), DIFR( NLF, LVL2 ),
+ $ Z( NLF, LVL ), K( J ), C( J ), S( J ), WORK,
+ $ INFO )
+ 30 CONTINUE
+ 40 CONTINUE
+ GO TO 90
+*
+* ICOMPQ = 1: applying back the right singular vector factors.
+*
+ 50 CONTINUE
+*
+* First now go through the right singular vector matrices of all
+* the tree nodes top-down.
+*
+ J = 0
+ DO 70 LVL = 1, NLVL
+ LVL2 = 2*LVL - 1
+*
+* Find the first node LF and last node LL on
+* the current level LVL.
+*
+ IF( LVL.EQ.1 ) THEN
+ LF = 1
+ LL = 1
+ ELSE
+ LF = 2**( LVL-1 )
+ LL = 2*LF - 1
+ END IF
+ DO 60 I = LL, LF, -1
+ IM1 = I - 1
+ IC = IWORK( INODE+IM1 )
+ NL = IWORK( NDIML+IM1 )
+ NR = IWORK( NDIMR+IM1 )
+ NLF = IC - NL
+ NRF = IC + 1
+ IF( I.EQ.LL ) THEN
+ SQRE = 0
+ ELSE
+ SQRE = 1
+ END IF
+ J = J + 1
+ CALL SLALS0( ICOMPQ, NL, NR, SQRE, NRHS, B( NLF, 1 ), LDB,
+ $ BX( NLF, 1 ), LDBX, PERM( NLF, LVL ),
+ $ GIVPTR( J ), GIVCOL( NLF, LVL2 ), LDGCOL,
+ $ GIVNUM( NLF, LVL2 ), LDU, POLES( NLF, LVL2 ),
+ $ DIFL( NLF, LVL ), DIFR( NLF, LVL2 ),
+ $ Z( NLF, LVL ), K( J ), C( J ), S( J ), WORK,
+ $ INFO )
+ 60 CONTINUE
+ 70 CONTINUE
+*
+* The nodes on the bottom level of the tree were solved
+* by SLASDQ. The corresponding right singular vector
+* matrices are in explicit form. Apply them back.
+*
+ NDB1 = ( ND+1 ) / 2
+ DO 80 I = NDB1, ND
+ I1 = I - 1
+ IC = IWORK( INODE+I1 )
+ NL = IWORK( NDIML+I1 )
+ NR = IWORK( NDIMR+I1 )
+ NLP1 = NL + 1
+ IF( I.EQ.ND ) THEN
+ NRP1 = NR
+ ELSE
+ NRP1 = NR + 1
+ END IF
+ NLF = IC - NL
+ NRF = IC + 1
+ CALL SGEMM( 'T', 'N', NLP1, NRHS, NLP1, ONE, VT( NLF, 1 ), LDU,
+ $ B( NLF, 1 ), LDB, ZERO, BX( NLF, 1 ), LDBX )
+ CALL SGEMM( 'T', 'N', NRP1, NRHS, NRP1, ONE, VT( NRF, 1 ), LDU,
+ $ B( NRF, 1 ), LDB, ZERO, BX( NRF, 1 ), LDBX )
+ 80 CONTINUE
+*
+ 90 CONTINUE
+*
+ RETURN
+*
+* End of SLALSA
+*
+ END
+ SUBROUTINE SLALSD( UPLO, SMLSIZ, N, NRHS, D, E, B, LDB, RCOND,
+ $ RANK, WORK, IWORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, LDB, N, NRHS, RANK, SMLSIZ
+ REAL RCOND
+* ..
+* .. Array Arguments ..
+ INTEGER IWORK( * )
+ REAL B( LDB, * ), D( * ), E( * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SLALSD uses the singular value decomposition of A to solve the least
+* squares problem of finding X to minimize the Euclidean norm of each
+* column of A*X-B, where A is N-by-N upper bidiagonal, and X and B
+* are N-by-NRHS. The solution X overwrites B.
+*
+* The singular values of A smaller than RCOND times the largest
+* singular value are treated as zero in solving the least squares
+* problem; in this case a minimum norm solution is returned.
+* The actual singular values are returned in D in ascending order.
+*
+* This code makes very mild assumptions about floating point
+* arithmetic. It will work on machines with a guard digit in
+* add/subtract, or on those binary machines without guard digits
+* which subtract like the Cray XMP, Cray YMP, Cray C 90, or Cray 2.
+* It could conceivably fail on hexadecimal or decimal machines
+* without guard digits, but we know of none.
+*
+* Arguments
+* =========
+*
+* UPLO (input) CHARACTER*1
+* = 'U': D and E define an upper bidiagonal matrix.
+* = 'L': D and E define a lower bidiagonal matrix.
+*
+* SMLSIZ (input) INTEGER
+* The maximum size of the subproblems at the bottom of the
+* computation tree.
+*
+* N (input) INTEGER
+* The dimension of the bidiagonal matrix. N >= 0.
+*
+* NRHS (input) INTEGER
+* The number of columns of B. NRHS must be at least 1.
+*
+* D (input/output) REAL array, dimension (N)
+* On entry D contains the main diagonal of the bidiagonal
+* matrix. On exit, if INFO = 0, D contains its singular values.
+*
+* E (input/output) REAL array, dimension (N-1)
+* Contains the super-diagonal entries of the bidiagonal matrix.
+* On exit, E has been destroyed.
+*
+* B (input/output) REAL array, dimension (LDB,NRHS)
+* On input, B contains the right hand sides of the least
+* squares problem. On output, B contains the solution X.
+*
+* LDB (input) INTEGER
+* The leading dimension of B in the calling subprogram.
+* LDB must be at least max(1,N).
+*
+* RCOND (input) REAL
+* The singular values of A less than or equal to RCOND times
+* the largest singular value are treated as zero in solving
+* the least squares problem. If RCOND is negative,
+* machine precision is used instead.
+* For example, if diag(S)*X=B were the least squares problem,
+* where diag(S) is a diagonal matrix of singular values, the
+* solution would be X(i) = B(i) / S(i) if S(i) is greater than
+* RCOND*max(S), and X(i) = 0 if S(i) is less than or equal to
+* RCOND*max(S).
+*
+* RANK (output) INTEGER
+* The number of singular values of A greater than RCOND times
+* the largest singular value.
+*
+* WORK (workspace) REAL array, dimension at least
+* (9*N + 2*N*SMLSIZ + 8*N*NLVL + N*NRHS + (SMLSIZ+1)**2),
+* where NLVL = max(0, INT(log_2 (N/(SMLSIZ+1))) + 1).
+*
+* IWORK (workspace) INTEGER array, dimension at least
+* (3*N*NLVL + 11*N)
+*
+* INFO (output) INTEGER
+* = 0: successful exit.
+* < 0: if INFO = -i, the i-th argument had an illegal value.
+* > 0: The algorithm failed to compute an singular value while
+* working on the submatrix lying in rows and columns
+* INFO/(N+1) through MOD(INFO,N+1).
+*
+* Further Details
+* ===============
+*
+* Based on contributions by
+* Ming Gu and Ren-Cang Li, Computer Science Division, University of
+* California at Berkeley, USA
+* Osni Marques, LBNL/NERSC, USA
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO, ONE, TWO
+ PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0, TWO = 2.0E0 )
+* ..
+* .. Local Scalars ..
+ INTEGER BX, BXST, C, DIFL, DIFR, GIVCOL, GIVNUM,
+ $ GIVPTR, I, ICMPQ1, ICMPQ2, IWK, J, K, NLVL,
+ $ NM1, NSIZE, NSUB, NWORK, PERM, POLES, S, SIZEI,
+ $ SMLSZP, SQRE, ST, ST1, U, VT, Z
+ REAL CS, EPS, ORGNRM, R, RCND, SN, TOL
+* ..
+* .. External Functions ..
+ INTEGER ISAMAX
+ REAL SLAMCH, SLANST
+ EXTERNAL ISAMAX, SLAMCH, SLANST
+* ..
+* .. External Subroutines ..
+ EXTERNAL SCOPY, SGEMM, SLACPY, SLALSA, SLARTG, SLASCL,
+ $ SLASDA, SLASDQ, SLASET, SLASRT, SROT, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, INT, LOG, REAL, SIGN
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+*
+ IF( N.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( NRHS.LT.1 ) THEN
+ INFO = -4
+ ELSE IF( ( LDB.LT.1 ) .OR. ( LDB.LT.N ) ) THEN
+ INFO = -8
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SLALSD', -INFO )
+ RETURN
+ END IF
+*
+ EPS = SLAMCH( 'Epsilon' )
+*
+* Set up the tolerance.
+*
+ IF( ( RCOND.LE.ZERO ) .OR. ( RCOND.GE.ONE ) ) THEN
+ RCND = EPS
+ ELSE
+ RCND = RCOND
+ END IF
+*
+ RANK = 0
+*
+* Quick return if possible.
+*
+ IF( N.EQ.0 ) THEN
+ RETURN
+ ELSE IF( N.EQ.1 ) THEN
+ IF( D( 1 ).EQ.ZERO ) THEN
+ CALL SLASET( 'A', 1, NRHS, ZERO, ZERO, B, LDB )
+ ELSE
+ RANK = 1
+ CALL SLASCL( 'G', 0, 0, D( 1 ), ONE, 1, NRHS, B, LDB, INFO )
+ D( 1 ) = ABS( D( 1 ) )
+ END IF
+ RETURN
+ END IF
+*
+* Rotate the matrix if it is lower bidiagonal.
+*
+ IF( UPLO.EQ.'L' ) THEN
+ DO 10 I = 1, N - 1
+ CALL SLARTG( D( I ), E( I ), CS, SN, R )
+ D( I ) = R
+ E( I ) = SN*D( I+1 )
+ D( I+1 ) = CS*D( I+1 )
+ IF( NRHS.EQ.1 ) THEN
+ CALL SROT( 1, B( I, 1 ), 1, B( I+1, 1 ), 1, CS, SN )
+ ELSE
+ WORK( I*2-1 ) = CS
+ WORK( I*2 ) = SN
+ END IF
+ 10 CONTINUE
+ IF( NRHS.GT.1 ) THEN
+ DO 30 I = 1, NRHS
+ DO 20 J = 1, N - 1
+ CS = WORK( J*2-1 )
+ SN = WORK( J*2 )
+ CALL SROT( 1, B( J, I ), 1, B( J+1, I ), 1, CS, SN )
+ 20 CONTINUE
+ 30 CONTINUE
+ END IF
+ END IF
+*
+* Scale.
+*
+ NM1 = N - 1
+ ORGNRM = SLANST( 'M', N, D, E )
+ IF( ORGNRM.EQ.ZERO ) THEN
+ CALL SLASET( 'A', N, NRHS, ZERO, ZERO, B, LDB )
+ RETURN
+ END IF
+*
+ CALL SLASCL( 'G', 0, 0, ORGNRM, ONE, N, 1, D, N, INFO )
+ CALL SLASCL( 'G', 0, 0, ORGNRM, ONE, NM1, 1, E, NM1, INFO )
+*
+* If N is smaller than the minimum divide size SMLSIZ, then solve
+* the problem with another solver.
+*
+ IF( N.LE.SMLSIZ ) THEN
+ NWORK = 1 + N*N
+ CALL SLASET( 'A', N, N, ZERO, ONE, WORK, N )
+ CALL SLASDQ( 'U', 0, N, N, 0, NRHS, D, E, WORK, N, WORK, N, B,
+ $ LDB, WORK( NWORK ), INFO )
+ IF( INFO.NE.0 ) THEN
+ RETURN
+ END IF
+ TOL = RCND*ABS( D( ISAMAX( N, D, 1 ) ) )
+ DO 40 I = 1, N
+ IF( D( I ).LE.TOL ) THEN
+ CALL SLASET( 'A', 1, NRHS, ZERO, ZERO, B( I, 1 ), LDB )
+ ELSE
+ CALL SLASCL( 'G', 0, 0, D( I ), ONE, 1, NRHS, B( I, 1 ),
+ $ LDB, INFO )
+ RANK = RANK + 1
+ END IF
+ 40 CONTINUE
+ CALL SGEMM( 'T', 'N', N, NRHS, N, ONE, WORK, N, B, LDB, ZERO,
+ $ WORK( NWORK ), N )
+ CALL SLACPY( 'A', N, NRHS, WORK( NWORK ), N, B, LDB )
+*
+* Unscale.
+*
+ CALL SLASCL( 'G', 0, 0, ONE, ORGNRM, N, 1, D, N, INFO )
+ CALL SLASRT( 'D', N, D, INFO )
+ CALL SLASCL( 'G', 0, 0, ORGNRM, ONE, N, NRHS, B, LDB, INFO )
+*
+ RETURN
+ END IF
+*
+* Book-keeping and setting up some constants.
+*
+ NLVL = INT( LOG( REAL( N ) / REAL( SMLSIZ+1 ) ) / LOG( TWO ) ) + 1
+*
+ SMLSZP = SMLSIZ + 1
+*
+ U = 1
+ VT = 1 + SMLSIZ*N
+ DIFL = VT + SMLSZP*N
+ DIFR = DIFL + NLVL*N
+ Z = DIFR + NLVL*N*2
+ C = Z + NLVL*N
+ S = C + N
+ POLES = S + N
+ GIVNUM = POLES + 2*NLVL*N
+ BX = GIVNUM + 2*NLVL*N
+ NWORK = BX + N*NRHS
+*
+ SIZEI = 1 + N
+ K = SIZEI + N
+ GIVPTR = K + N
+ PERM = GIVPTR + N
+ GIVCOL = PERM + NLVL*N
+ IWK = GIVCOL + NLVL*N*2
+*
+ ST = 1
+ SQRE = 0
+ ICMPQ1 = 1
+ ICMPQ2 = 0
+ NSUB = 0
+*
+ DO 50 I = 1, N
+ IF( ABS( D( I ) ).LT.EPS ) THEN
+ D( I ) = SIGN( EPS, D( I ) )
+ END IF
+ 50 CONTINUE
+*
+ DO 60 I = 1, NM1
+ IF( ( ABS( E( I ) ).LT.EPS ) .OR. ( I.EQ.NM1 ) ) THEN
+ NSUB = NSUB + 1
+ IWORK( NSUB ) = ST
+*
+* Subproblem found. First determine its size and then
+* apply divide and conquer on it.
+*
+ IF( I.LT.NM1 ) THEN
+*
+* A subproblem with E(I) small for I < NM1.
+*
+ NSIZE = I - ST + 1
+ IWORK( SIZEI+NSUB-1 ) = NSIZE
+ ELSE IF( ABS( E( I ) ).GE.EPS ) THEN
+*
+* A subproblem with E(NM1) not too small but I = NM1.
+*
+ NSIZE = N - ST + 1
+ IWORK( SIZEI+NSUB-1 ) = NSIZE
+ ELSE
+*
+* A subproblem with E(NM1) small. This implies an
+* 1-by-1 subproblem at D(N), which is not solved
+* explicitly.
+*
+ NSIZE = I - ST + 1
+ IWORK( SIZEI+NSUB-1 ) = NSIZE
+ NSUB = NSUB + 1
+ IWORK( NSUB ) = N
+ IWORK( SIZEI+NSUB-1 ) = 1
+ CALL SCOPY( NRHS, B( N, 1 ), LDB, WORK( BX+NM1 ), N )
+ END IF
+ ST1 = ST - 1
+ IF( NSIZE.EQ.1 ) THEN
+*
+* This is a 1-by-1 subproblem and is not solved
+* explicitly.
+*
+ CALL SCOPY( NRHS, B( ST, 1 ), LDB, WORK( BX+ST1 ), N )
+ ELSE IF( NSIZE.LE.SMLSIZ ) THEN
+*
+* This is a small subproblem and is solved by SLASDQ.
+*
+ CALL SLASET( 'A', NSIZE, NSIZE, ZERO, ONE,
+ $ WORK( VT+ST1 ), N )
+ CALL SLASDQ( 'U', 0, NSIZE, NSIZE, 0, NRHS, D( ST ),
+ $ E( ST ), WORK( VT+ST1 ), N, WORK( NWORK ),
+ $ N, B( ST, 1 ), LDB, WORK( NWORK ), INFO )
+ IF( INFO.NE.0 ) THEN
+ RETURN
+ END IF
+ CALL SLACPY( 'A', NSIZE, NRHS, B( ST, 1 ), LDB,
+ $ WORK( BX+ST1 ), N )
+ ELSE
+*
+* A large problem. Solve it using divide and conquer.
+*
+ CALL SLASDA( ICMPQ1, SMLSIZ, NSIZE, SQRE, D( ST ),
+ $ E( ST ), WORK( U+ST1 ), N, WORK( VT+ST1 ),
+ $ IWORK( K+ST1 ), WORK( DIFL+ST1 ),
+ $ WORK( DIFR+ST1 ), WORK( Z+ST1 ),
+ $ WORK( POLES+ST1 ), IWORK( GIVPTR+ST1 ),
+ $ IWORK( GIVCOL+ST1 ), N, IWORK( PERM+ST1 ),
+ $ WORK( GIVNUM+ST1 ), WORK( C+ST1 ),
+ $ WORK( S+ST1 ), WORK( NWORK ), IWORK( IWK ),
+ $ INFO )
+ IF( INFO.NE.0 ) THEN
+ RETURN
+ END IF
+ BXST = BX + ST1
+ CALL SLALSA( ICMPQ2, SMLSIZ, NSIZE, NRHS, B( ST, 1 ),
+ $ LDB, WORK( BXST ), N, WORK( U+ST1 ), N,
+ $ WORK( VT+ST1 ), IWORK( K+ST1 ),
+ $ WORK( DIFL+ST1 ), WORK( DIFR+ST1 ),
+ $ WORK( Z+ST1 ), WORK( POLES+ST1 ),
+ $ IWORK( GIVPTR+ST1 ), IWORK( GIVCOL+ST1 ), N,
+ $ IWORK( PERM+ST1 ), WORK( GIVNUM+ST1 ),
+ $ WORK( C+ST1 ), WORK( S+ST1 ), WORK( NWORK ),
+ $ IWORK( IWK ), INFO )
+ IF( INFO.NE.0 ) THEN
+ RETURN
+ END IF
+ END IF
+ ST = I + 1
+ END IF
+ 60 CONTINUE
+*
+* Apply the singular values and treat the tiny ones as zero.
+*
+ TOL = RCND*ABS( D( ISAMAX( N, D, 1 ) ) )
+*
+ DO 70 I = 1, N
+*
+* Some of the elements in D can be negative because 1-by-1
+* subproblems were not solved explicitly.
+*
+ IF( ABS( D( I ) ).LE.TOL ) THEN
+ CALL SLASET( 'A', 1, NRHS, ZERO, ZERO, WORK( BX+I-1 ), N )
+ ELSE
+ RANK = RANK + 1
+ CALL SLASCL( 'G', 0, 0, D( I ), ONE, 1, NRHS,
+ $ WORK( BX+I-1 ), N, INFO )
+ END IF
+ D( I ) = ABS( D( I ) )
+ 70 CONTINUE
+*
+* Now apply back the right singular vectors.
+*
+ ICMPQ2 = 1
+ DO 80 I = 1, NSUB
+ ST = IWORK( I )
+ ST1 = ST - 1
+ NSIZE = IWORK( SIZEI+I-1 )
+ BXST = BX + ST1
+ IF( NSIZE.EQ.1 ) THEN
+ CALL SCOPY( NRHS, WORK( BXST ), N, B( ST, 1 ), LDB )
+ ELSE IF( NSIZE.LE.SMLSIZ ) THEN
+ CALL SGEMM( 'T', 'N', NSIZE, NRHS, NSIZE, ONE,
+ $ WORK( VT+ST1 ), N, WORK( BXST ), N, ZERO,
+ $ B( ST, 1 ), LDB )
+ ELSE
+ CALL SLALSA( ICMPQ2, SMLSIZ, NSIZE, NRHS, WORK( BXST ), N,
+ $ B( ST, 1 ), LDB, WORK( U+ST1 ), N,
+ $ WORK( VT+ST1 ), IWORK( K+ST1 ),
+ $ WORK( DIFL+ST1 ), WORK( DIFR+ST1 ),
+ $ WORK( Z+ST1 ), WORK( POLES+ST1 ),
+ $ IWORK( GIVPTR+ST1 ), IWORK( GIVCOL+ST1 ), N,
+ $ IWORK( PERM+ST1 ), WORK( GIVNUM+ST1 ),
+ $ WORK( C+ST1 ), WORK( S+ST1 ), WORK( NWORK ),
+ $ IWORK( IWK ), INFO )
+ IF( INFO.NE.0 ) THEN
+ RETURN
+ END IF
+ END IF
+ 80 CONTINUE
+*
+* Unscale and sort the singular values.
+*
+ CALL SLASCL( 'G', 0, 0, ONE, ORGNRM, N, 1, D, N, INFO )
+ CALL SLASRT( 'D', N, D, INFO )
+ CALL SLASCL( 'G', 0, 0, ORGNRM, ONE, N, NRHS, B, LDB, INFO )
+*
+ RETURN
+*
+* End of SLALSD
+*
+ END
+ SUBROUTINE SLAMRG( N1, N2, A, STRD1, STRD2, INDEX )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER N1, N2, STRD1, STRD2
+* ..
+* .. Array Arguments ..
+ INTEGER INDEX( * )
+ REAL A( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SLAMRG will create a permutation list which will merge the elements
+* of A (which is composed of two independently sorted sets) into a
+* single set which is sorted in ascending order.
+*
+* Arguments
+* =========
+*
+* N1 (input) INTEGER
+* N2 (input) INTEGER
+* These arguements contain the respective lengths of the two
+* sorted lists to be merged.
+*
+* A (input) REAL array, dimension (N1+N2)
+* The first N1 elements of A contain a list of numbers which
+* are sorted in either ascending or descending order. Likewise
+* for the final N2 elements.
+*
+* STRD1 (input) INTEGER
+* STRD2 (input) INTEGER
+* These are the strides to be taken through the array A.
+* Allowable strides are 1 and -1. They indicate whether a
+* subset of A is sorted in ascending (STRDx = 1) or descending
+* (STRDx = -1) order.
+*
+* INDEX (output) INTEGER array, dimension (N1+N2)
+* On exit this array will contain a permutation such that
+* if B( I ) = A( INDEX( I ) ) for I=1,N1+N2, then B will be
+* sorted in ascending order.
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ INTEGER I, IND1, IND2, N1SV, N2SV
+* ..
+* .. Executable Statements ..
+*
+ N1SV = N1
+ N2SV = N2
+ IF( STRD1.GT.0 ) THEN
+ IND1 = 1
+ ELSE
+ IND1 = N1
+ END IF
+ IF( STRD2.GT.0 ) THEN
+ IND2 = 1 + N1
+ ELSE
+ IND2 = N1 + N2
+ END IF
+ I = 1
+* while ( (N1SV > 0) & (N2SV > 0) )
+ 10 CONTINUE
+ IF( N1SV.GT.0 .AND. N2SV.GT.0 ) THEN
+ IF( A( IND1 ).LE.A( IND2 ) ) THEN
+ INDEX( I ) = IND1
+ I = I + 1
+ IND1 = IND1 + STRD1
+ N1SV = N1SV - 1
+ ELSE
+ INDEX( I ) = IND2
+ I = I + 1
+ IND2 = IND2 + STRD2
+ N2SV = N2SV - 1
+ END IF
+ GO TO 10
+ END IF
+* end while
+ IF( N1SV.EQ.0 ) THEN
+ DO 20 N1SV = 1, N2SV
+ INDEX( I ) = IND2
+ I = I + 1
+ IND2 = IND2 + STRD2
+ 20 CONTINUE
+ ELSE
+* N2SV .EQ. 0
+ DO 30 N2SV = 1, N1SV
+ INDEX( I ) = IND1
+ I = I + 1
+ IND1 = IND1 + STRD1
+ 30 CONTINUE
+ END IF
+*
+ RETURN
+*
+* End of SLAMRG
+*
+ END
+ FUNCTION SLANEG( N, D, LLD, SIGMA, PIVMIN, R )
+ IMPLICIT NONE
+ INTEGER SLANEG
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER N, R
+ REAL PIVMIN, SIGMA
+* ..
+* .. Array Arguments ..
+ REAL D( * ), LLD( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SLANEG computes the Sturm count, the number of negative pivots
+* encountered while factoring tridiagonal T - sigma I = L D L^T.
+* This implementation works directly on the factors without forming
+* the tridiagonal matrix T. The Sturm count is also the number of
+* eigenvalues of T less than sigma.
+*
+* This routine is called from SLARRB.
+*
+* The current routine does not use the PIVMIN parameter but rather
+* requires IEEE-754 propagation of Infinities and NaNs. This
+* routine also has no input range restrictions but does require
+* default exception handling such that x/0 produces Inf when x is
+* non-zero, and Inf/Inf produces NaN. For more information, see:
+*
+* Marques, Riedy, and Voemel, "Benefits of IEEE-754 Features in
+* Modern Symmetric Tridiagonal Eigensolvers," SIAM Journal on
+* Scientific Computing, v28, n5, 2006. DOI 10.1137/050641624
+* (Tech report version in LAWN 172 with the same title.)
+*
+* Arguments
+* =========
+*
+* N (input) INTEGER
+* The order of the matrix.
+*
+* D (input) REAL array, dimension (N)
+* The N diagonal elements of the diagonal matrix D.
+*
+* LLD (input) REAL array, dimension (N-1)
+* The (N-1) elements L(i)*L(i)*D(i).
+*
+* SIGMA (input) REAL
+* Shift amount in T - sigma I = L D L^T.
+*
+* PIVMIN (input) REAL
+* The minimum pivot in the Sturm sequence. May be used
+* when zero pivots are encountered on non-IEEE-754
+* architectures.
+*
+* R (input) INTEGER
+* The twist index for the twisted factorization that is used
+* for the negcount.
+*
+* Further Details
+* ===============
+*
+* Based on contributions by
+* Osni Marques, LBNL/NERSC, USA
+* Christof Voemel, University of California, Berkeley, USA
+* Jason Riedy, University of California, Berkeley, USA
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO, ONE
+ PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 )
+* Some architectures propagate Infinities and NaNs very slowly, so
+* the code computes counts in BLKLEN chunks. Then a NaN can
+* propagate at most BLKLEN columns before being detected. This is
+* not a general tuning parameter; it needs only to be just large
+* enough that the overhead is tiny in common cases.
+ INTEGER BLKLEN
+ PARAMETER ( BLKLEN = 128 )
+* ..
+* .. Local Scalars ..
+ INTEGER BJ, J, NEG1, NEG2, NEGCNT
+ REAL BSAV, DMINUS, DPLUS, GAMMA, P, T, TMP
+ LOGICAL SAWNAN
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MIN, MAX
+* ..
+* .. External Functions ..
+ LOGICAL SISNAN
+ EXTERNAL SISNAN
+* ..
+* .. Executable Statements ..
+
+ NEGCNT = 0
+
+* I) upper part: L D L^T - SIGMA I = L+ D+ L+^T
+ T = -SIGMA
+ DO 210 BJ = 1, R-1, BLKLEN
+ NEG1 = 0
+ BSAV = T
+ DO 21 J = BJ, MIN(BJ+BLKLEN-1, R-1)
+ DPLUS = D( J ) + T
+ IF( DPLUS.LT.ZERO ) NEG1 = NEG1 + 1
+ TMP = T / DPLUS
+ T = TMP * LLD( J ) - SIGMA
+ 21 CONTINUE
+ SAWNAN = SISNAN( T )
+* Run a slower version of the above loop if a NaN is detected.
+* A NaN should occur only with a zero pivot after an infinite
+* pivot. In that case, substituting 1 for T/DPLUS is the
+* correct limit.
+ IF( SAWNAN ) THEN
+ NEG1 = 0
+ T = BSAV
+ DO 22 J = BJ, MIN(BJ+BLKLEN-1, R-1)
+ DPLUS = D( J ) + T
+ IF( DPLUS.LT.ZERO ) NEG1 = NEG1 + 1
+ TMP = T / DPLUS
+ IF (SISNAN(TMP)) TMP = ONE
+ T = TMP * LLD(J) - SIGMA
+ 22 CONTINUE
+ END IF
+ NEGCNT = NEGCNT + NEG1
+ 210 CONTINUE
+*
+* II) lower part: L D L^T - SIGMA I = U- D- U-^T
+ P = D( N ) - SIGMA
+ DO 230 BJ = N-1, R, -BLKLEN
+ NEG2 = 0
+ BSAV = P
+ DO 23 J = BJ, MAX(BJ-BLKLEN+1, R), -1
+ DMINUS = LLD( J ) + P
+ IF( DMINUS.LT.ZERO ) NEG2 = NEG2 + 1
+ TMP = P / DMINUS
+ P = TMP * D( J ) - SIGMA
+ 23 CONTINUE
+ SAWNAN = SISNAN( P )
+* As above, run a slower version that substitutes 1 for Inf/Inf.
+*
+ IF( SAWNAN ) THEN
+ NEG2 = 0
+ P = BSAV
+ DO 24 J = BJ, MAX(BJ-BLKLEN+1, R), -1
+ DMINUS = LLD( J ) + P
+ IF( DMINUS.LT.ZERO ) NEG2 = NEG2 + 1
+ TMP = P / DMINUS
+ IF (SISNAN(TMP)) TMP = ONE
+ P = TMP * D(J) - SIGMA
+ 24 CONTINUE
+ END IF
+ NEGCNT = NEGCNT + NEG2
+ 230 CONTINUE
+*
+* III) Twist index
+* T was shifted by SIGMA initially.
+ GAMMA = (T + SIGMA) + P
+ IF( GAMMA.LT.ZERO ) NEGCNT = NEGCNT+1
+
+ SLANEG = NEGCNT
+ END
+ REAL FUNCTION SLANGB( NORM, N, KL, KU, AB, LDAB,
+ $ WORK )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER NORM
+ INTEGER KL, KU, LDAB, N
+* ..
+* .. Array Arguments ..
+ REAL AB( LDAB, * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SLANGB returns the value of the one norm, or the Frobenius norm, or
+* the infinity norm, or the element of largest absolute value of an
+* n by n band matrix A, with kl sub-diagonals and ku super-diagonals.
+*
+* Description
+* ===========
+*
+* SLANGB returns the value
+*
+* SLANGB = ( max(abs(A(i,j))), NORM = 'M' or 'm'
+* (
+* ( norm1(A), NORM = '1', 'O' or 'o'
+* (
+* ( normI(A), NORM = 'I' or 'i'
+* (
+* ( normF(A), NORM = 'F', 'f', 'E' or 'e'
+*
+* where norm1 denotes the one norm of a matrix (maximum column sum),
+* normI denotes the infinity norm of a matrix (maximum row sum) and
+* normF denotes the Frobenius norm of a matrix (square root of sum of
+* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.
+*
+* Arguments
+* =========
+*
+* NORM (input) CHARACTER*1
+* Specifies the value to be returned in SLANGB as described
+* above.
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0. When N = 0, SLANGB is
+* set to zero.
+*
+* KL (input) INTEGER
+* The number of sub-diagonals of the matrix A. KL >= 0.
+*
+* KU (input) INTEGER
+* The number of super-diagonals of the matrix A. KU >= 0.
+*
+* AB (input) REAL array, dimension (LDAB,N)
+* The band matrix A, stored in rows 1 to KL+KU+1. The j-th
+* column of A is stored in the j-th column of the array AB as
+* follows:
+* AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(n,j+kl).
+*
+* LDAB (input) INTEGER
+* The leading dimension of the array AB. LDAB >= KL+KU+1.
+*
+* WORK (workspace) REAL array, dimension (MAX(1,LWORK)),
+* where LWORK >= N when NORM = 'I'; otherwise, WORK is not
+* referenced.
+*
+* =====================================================================
+*
+*
+* .. Parameters ..
+ REAL ONE, ZERO
+ PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, J, K, L
+ REAL SCALE, SUM, VALUE
+* ..
+* .. External Subroutines ..
+ EXTERNAL SLASSQ
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, MIN, SQRT
+* ..
+* .. Executable Statements ..
+*
+ IF( N.EQ.0 ) THEN
+ VALUE = ZERO
+ ELSE IF( LSAME( NORM, 'M' ) ) THEN
+*
+* Find max(abs(A(i,j))).
+*
+ VALUE = ZERO
+ DO 20 J = 1, N
+ DO 10 I = MAX( KU+2-J, 1 ), MIN( N+KU+1-J, KL+KU+1 )
+ VALUE = MAX( VALUE, ABS( AB( I, J ) ) )
+ 10 CONTINUE
+ 20 CONTINUE
+ ELSE IF( ( LSAME( NORM, 'O' ) ) .OR. ( NORM.EQ.'1' ) ) THEN
+*
+* Find norm1(A).
+*
+ VALUE = ZERO
+ DO 40 J = 1, N
+ SUM = ZERO
+ DO 30 I = MAX( KU+2-J, 1 ), MIN( N+KU+1-J, KL+KU+1 )
+ SUM = SUM + ABS( AB( I, J ) )
+ 30 CONTINUE
+ VALUE = MAX( VALUE, SUM )
+ 40 CONTINUE
+ ELSE IF( LSAME( NORM, 'I' ) ) THEN
+*
+* Find normI(A).
+*
+ DO 50 I = 1, N
+ WORK( I ) = ZERO
+ 50 CONTINUE
+ DO 70 J = 1, N
+ K = KU + 1 - J
+ DO 60 I = MAX( 1, J-KU ), MIN( N, J+KL )
+ WORK( I ) = WORK( I ) + ABS( AB( K+I, J ) )
+ 60 CONTINUE
+ 70 CONTINUE
+ VALUE = ZERO
+ DO 80 I = 1, N
+ VALUE = MAX( VALUE, WORK( I ) )
+ 80 CONTINUE
+ ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN
+*
+* Find normF(A).
+*
+ SCALE = ZERO
+ SUM = ONE
+ DO 90 J = 1, N
+ L = MAX( 1, J-KU )
+ K = KU + 1 - J + L
+ CALL SLASSQ( MIN( N, J+KL )-L+1, AB( K, J ), 1, SCALE, SUM )
+ 90 CONTINUE
+ VALUE = SCALE*SQRT( SUM )
+ END IF
+*
+ SLANGB = VALUE
+ RETURN
+*
+* End of SLANGB
+*
+ END
+ REAL FUNCTION SLANGE( NORM, M, N, A, LDA, WORK )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER NORM
+ INTEGER LDA, M, N
+* ..
+* .. Array Arguments ..
+ REAL A( LDA, * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SLANGE returns the value of the one norm, or the Frobenius norm, or
+* the infinity norm, or the element of largest absolute value of a
+* real matrix A.
+*
+* Description
+* ===========
+*
+* SLANGE returns the value
+*
+* SLANGE = ( max(abs(A(i,j))), NORM = 'M' or 'm'
+* (
+* ( norm1(A), NORM = '1', 'O' or 'o'
+* (
+* ( normI(A), NORM = 'I' or 'i'
+* (
+* ( normF(A), NORM = 'F', 'f', 'E' or 'e'
+*
+* where norm1 denotes the one norm of a matrix (maximum column sum),
+* normI denotes the infinity norm of a matrix (maximum row sum) and
+* normF denotes the Frobenius norm of a matrix (square root of sum of
+* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.
+*
+* Arguments
+* =========
+*
+* NORM (input) CHARACTER*1
+* Specifies the value to be returned in SLANGE as described
+* above.
+*
+* M (input) INTEGER
+* The number of rows of the matrix A. M >= 0. When M = 0,
+* SLANGE is set to zero.
+*
+* N (input) INTEGER
+* The number of columns of the matrix A. N >= 0. When N = 0,
+* SLANGE is set to zero.
+*
+* A (input) REAL array, dimension (LDA,N)
+* The m by n matrix A.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(M,1).
+*
+* WORK (workspace) REAL array, dimension (MAX(1,LWORK)),
+* where LWORK >= M when NORM = 'I'; otherwise, WORK is not
+* referenced.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ONE, ZERO
+ PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, J
+ REAL SCALE, SUM, VALUE
+* ..
+* .. External Subroutines ..
+ EXTERNAL SLASSQ
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, MIN, SQRT
+* ..
+* .. Executable Statements ..
+*
+ IF( MIN( M, N ).EQ.0 ) THEN
+ VALUE = ZERO
+ ELSE IF( LSAME( NORM, 'M' ) ) THEN
+*
+* Find max(abs(A(i,j))).
+*
+ VALUE = ZERO
+ DO 20 J = 1, N
+ DO 10 I = 1, M
+ VALUE = MAX( VALUE, ABS( A( I, J ) ) )
+ 10 CONTINUE
+ 20 CONTINUE
+ ELSE IF( ( LSAME( NORM, 'O' ) ) .OR. ( NORM.EQ.'1' ) ) THEN
+*
+* Find norm1(A).
+*
+ VALUE = ZERO
+ DO 40 J = 1, N
+ SUM = ZERO
+ DO 30 I = 1, M
+ SUM = SUM + ABS( A( I, J ) )
+ 30 CONTINUE
+ VALUE = MAX( VALUE, SUM )
+ 40 CONTINUE
+ ELSE IF( LSAME( NORM, 'I' ) ) THEN
+*
+* Find normI(A).
+*
+ DO 50 I = 1, M
+ WORK( I ) = ZERO
+ 50 CONTINUE
+ DO 70 J = 1, N
+ DO 60 I = 1, M
+ WORK( I ) = WORK( I ) + ABS( A( I, J ) )
+ 60 CONTINUE
+ 70 CONTINUE
+ VALUE = ZERO
+ DO 80 I = 1, M
+ VALUE = MAX( VALUE, WORK( I ) )
+ 80 CONTINUE
+ ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN
+*
+* Find normF(A).
+*
+ SCALE = ZERO
+ SUM = ONE
+ DO 90 J = 1, N
+ CALL SLASSQ( M, A( 1, J ), 1, SCALE, SUM )
+ 90 CONTINUE
+ VALUE = SCALE*SQRT( SUM )
+ END IF
+*
+ SLANGE = VALUE
+ RETURN
+*
+* End of SLANGE
+*
+ END
+ REAL FUNCTION SLANGT( NORM, N, DL, D, DU )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER NORM
+ INTEGER N
+* ..
+* .. Array Arguments ..
+ REAL D( * ), DL( * ), DU( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SLANGT returns the value of the one norm, or the Frobenius norm, or
+* the infinity norm, or the element of largest absolute value of a
+* real tridiagonal matrix A.
+*
+* Description
+* ===========
+*
+* SLANGT returns the value
+*
+* SLANGT = ( max(abs(A(i,j))), NORM = 'M' or 'm'
+* (
+* ( norm1(A), NORM = '1', 'O' or 'o'
+* (
+* ( normI(A), NORM = 'I' or 'i'
+* (
+* ( normF(A), NORM = 'F', 'f', 'E' or 'e'
+*
+* where norm1 denotes the one norm of a matrix (maximum column sum),
+* normI denotes the infinity norm of a matrix (maximum row sum) and
+* normF denotes the Frobenius norm of a matrix (square root of sum of
+* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.
+*
+* Arguments
+* =========
+*
+* NORM (input) CHARACTER*1
+* Specifies the value to be returned in SLANGT as described
+* above.
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0. When N = 0, SLANGT is
+* set to zero.
+*
+* DL (input) REAL array, dimension (N-1)
+* The (n-1) sub-diagonal elements of A.
+*
+* D (input) REAL array, dimension (N)
+* The diagonal elements of A.
+*
+* DU (input) REAL array, dimension (N-1)
+* The (n-1) super-diagonal elements of A.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ONE, ZERO
+ PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I
+ REAL ANORM, SCALE, SUM
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL SLASSQ
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, SQRT
+* ..
+* .. Executable Statements ..
+*
+ IF( N.LE.0 ) THEN
+ ANORM = ZERO
+ ELSE IF( LSAME( NORM, 'M' ) ) THEN
+*
+* Find max(abs(A(i,j))).
+*
+ ANORM = ABS( D( N ) )
+ DO 10 I = 1, N - 1
+ ANORM = MAX( ANORM, ABS( DL( I ) ) )
+ ANORM = MAX( ANORM, ABS( D( I ) ) )
+ ANORM = MAX( ANORM, ABS( DU( I ) ) )
+ 10 CONTINUE
+ ELSE IF( LSAME( NORM, 'O' ) .OR. NORM.EQ.'1' ) THEN
+*
+* Find norm1(A).
+*
+ IF( N.EQ.1 ) THEN
+ ANORM = ABS( D( 1 ) )
+ ELSE
+ ANORM = MAX( ABS( D( 1 ) )+ABS( DL( 1 ) ),
+ $ ABS( D( N ) )+ABS( DU( N-1 ) ) )
+ DO 20 I = 2, N - 1
+ ANORM = MAX( ANORM, ABS( D( I ) )+ABS( DL( I ) )+
+ $ ABS( DU( I-1 ) ) )
+ 20 CONTINUE
+ END IF
+ ELSE IF( LSAME( NORM, 'I' ) ) THEN
+*
+* Find normI(A).
+*
+ IF( N.EQ.1 ) THEN
+ ANORM = ABS( D( 1 ) )
+ ELSE
+ ANORM = MAX( ABS( D( 1 ) )+ABS( DU( 1 ) ),
+ $ ABS( D( N ) )+ABS( DL( N-1 ) ) )
+ DO 30 I = 2, N - 1
+ ANORM = MAX( ANORM, ABS( D( I ) )+ABS( DU( I ) )+
+ $ ABS( DL( I-1 ) ) )
+ 30 CONTINUE
+ END IF
+ ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN
+*
+* Find normF(A).
+*
+ SCALE = ZERO
+ SUM = ONE
+ CALL SLASSQ( N, D, 1, SCALE, SUM )
+ IF( N.GT.1 ) THEN
+ CALL SLASSQ( N-1, DL, 1, SCALE, SUM )
+ CALL SLASSQ( N-1, DU, 1, SCALE, SUM )
+ END IF
+ ANORM = SCALE*SQRT( SUM )
+ END IF
+*
+ SLANGT = ANORM
+ RETURN
+*
+* End of SLANGT
+*
+ END
+ REAL FUNCTION SLANHS( NORM, N, A, LDA, WORK )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER NORM
+ INTEGER LDA, N
+* ..
+* .. Array Arguments ..
+ REAL A( LDA, * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SLANHS returns the value of the one norm, or the Frobenius norm, or
+* the infinity norm, or the element of largest absolute value of a
+* Hessenberg matrix A.
+*
+* Description
+* ===========
+*
+* SLANHS returns the value
+*
+* SLANHS = ( max(abs(A(i,j))), NORM = 'M' or 'm'
+* (
+* ( norm1(A), NORM = '1', 'O' or 'o'
+* (
+* ( normI(A), NORM = 'I' or 'i'
+* (
+* ( normF(A), NORM = 'F', 'f', 'E' or 'e'
+*
+* where norm1 denotes the one norm of a matrix (maximum column sum),
+* normI denotes the infinity norm of a matrix (maximum row sum) and
+* normF denotes the Frobenius norm of a matrix (square root of sum of
+* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.
+*
+* Arguments
+* =========
+*
+* NORM (input) CHARACTER*1
+* Specifies the value to be returned in SLANHS as described
+* above.
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0. When N = 0, SLANHS is
+* set to zero.
+*
+* A (input) REAL array, dimension (LDA,N)
+* The n by n upper Hessenberg matrix A; the part of A below the
+* first sub-diagonal is not referenced.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(N,1).
+*
+* WORK (workspace) REAL array, dimension (MAX(1,LWORK)),
+* where LWORK >= N when NORM = 'I'; otherwise, WORK is not
+* referenced.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ONE, ZERO
+ PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, J
+ REAL SCALE, SUM, VALUE
+* ..
+* .. External Subroutines ..
+ EXTERNAL SLASSQ
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, MIN, SQRT
+* ..
+* .. Executable Statements ..
+*
+ IF( N.EQ.0 ) THEN
+ VALUE = ZERO
+ ELSE IF( LSAME( NORM, 'M' ) ) THEN
+*
+* Find max(abs(A(i,j))).
+*
+ VALUE = ZERO
+ DO 20 J = 1, N
+ DO 10 I = 1, MIN( N, J+1 )
+ VALUE = MAX( VALUE, ABS( A( I, J ) ) )
+ 10 CONTINUE
+ 20 CONTINUE
+ ELSE IF( ( LSAME( NORM, 'O' ) ) .OR. ( NORM.EQ.'1' ) ) THEN
+*
+* Find norm1(A).
+*
+ VALUE = ZERO
+ DO 40 J = 1, N
+ SUM = ZERO
+ DO 30 I = 1, MIN( N, J+1 )
+ SUM = SUM + ABS( A( I, J ) )
+ 30 CONTINUE
+ VALUE = MAX( VALUE, SUM )
+ 40 CONTINUE
+ ELSE IF( LSAME( NORM, 'I' ) ) THEN
+*
+* Find normI(A).
+*
+ DO 50 I = 1, N
+ WORK( I ) = ZERO
+ 50 CONTINUE
+ DO 70 J = 1, N
+ DO 60 I = 1, MIN( N, J+1 )
+ WORK( I ) = WORK( I ) + ABS( A( I, J ) )
+ 60 CONTINUE
+ 70 CONTINUE
+ VALUE = ZERO
+ DO 80 I = 1, N
+ VALUE = MAX( VALUE, WORK( I ) )
+ 80 CONTINUE
+ ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN
+*
+* Find normF(A).
+*
+ SCALE = ZERO
+ SUM = ONE
+ DO 90 J = 1, N
+ CALL SLASSQ( MIN( N, J+1 ), A( 1, J ), 1, SCALE, SUM )
+ 90 CONTINUE
+ VALUE = SCALE*SQRT( SUM )
+ END IF
+*
+ SLANHS = VALUE
+ RETURN
+*
+* End of SLANHS
+*
+ END
+ REAL FUNCTION SLANSB( NORM, UPLO, N, K, AB, LDAB,
+ $ WORK )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER NORM, UPLO
+ INTEGER K, LDAB, N
+* ..
+* .. Array Arguments ..
+ REAL AB( LDAB, * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SLANSB returns the value of the one norm, or the Frobenius norm, or
+* the infinity norm, or the element of largest absolute value of an
+* n by n symmetric band matrix A, with k super-diagonals.
+*
+* Description
+* ===========
+*
+* SLANSB returns the value
+*
+* SLANSB = ( max(abs(A(i,j))), NORM = 'M' or 'm'
+* (
+* ( norm1(A), NORM = '1', 'O' or 'o'
+* (
+* ( normI(A), NORM = 'I' or 'i'
+* (
+* ( normF(A), NORM = 'F', 'f', 'E' or 'e'
+*
+* where norm1 denotes the one norm of a matrix (maximum column sum),
+* normI denotes the infinity norm of a matrix (maximum row sum) and
+* normF denotes the Frobenius norm of a matrix (square root of sum of
+* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.
+*
+* Arguments
+* =========
+*
+* NORM (input) CHARACTER*1
+* Specifies the value to be returned in SLANSB as described
+* above.
+*
+* UPLO (input) CHARACTER*1
+* Specifies whether the upper or lower triangular part of the
+* band matrix A is supplied.
+* = 'U': Upper triangular part is supplied
+* = 'L': Lower triangular part is supplied
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0. When N = 0, SLANSB is
+* set to zero.
+*
+* K (input) INTEGER
+* The number of super-diagonals or sub-diagonals of the
+* band matrix A. K >= 0.
+*
+* AB (input) REAL array, dimension (LDAB,N)
+* The upper or lower triangle of the symmetric band matrix A,
+* stored in the first K+1 rows of AB. The j-th column of A is
+* stored in the j-th column of the array AB as follows:
+* if UPLO = 'U', AB(k+1+i-j,j) = A(i,j) for max(1,j-k)<=i<=j;
+* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+k).
+*
+* LDAB (input) INTEGER
+* The leading dimension of the array AB. LDAB >= K+1.
+*
+* WORK (workspace) REAL array, dimension (MAX(1,LWORK)),
+* where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,
+* WORK is not referenced.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ONE, ZERO
+ PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, J, L
+ REAL ABSA, SCALE, SUM, VALUE
+* ..
+* .. External Subroutines ..
+ EXTERNAL SLASSQ
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, MIN, SQRT
+* ..
+* .. Executable Statements ..
+*
+ IF( N.EQ.0 ) THEN
+ VALUE = ZERO
+ ELSE IF( LSAME( NORM, 'M' ) ) THEN
+*
+* Find max(abs(A(i,j))).
+*
+ VALUE = ZERO
+ IF( LSAME( UPLO, 'U' ) ) THEN
+ DO 20 J = 1, N
+ DO 10 I = MAX( K+2-J, 1 ), K + 1
+ VALUE = MAX( VALUE, ABS( AB( I, J ) ) )
+ 10 CONTINUE
+ 20 CONTINUE
+ ELSE
+ DO 40 J = 1, N
+ DO 30 I = 1, MIN( N+1-J, K+1 )
+ VALUE = MAX( VALUE, ABS( AB( I, J ) ) )
+ 30 CONTINUE
+ 40 CONTINUE
+ END IF
+ ELSE IF( ( LSAME( NORM, 'I' ) ) .OR. ( LSAME( NORM, 'O' ) ) .OR.
+ $ ( NORM.EQ.'1' ) ) THEN
+*
+* Find normI(A) ( = norm1(A), since A is symmetric).
+*
+ VALUE = ZERO
+ IF( LSAME( UPLO, 'U' ) ) THEN
+ DO 60 J = 1, N
+ SUM = ZERO
+ L = K + 1 - J
+ DO 50 I = MAX( 1, J-K ), J - 1
+ ABSA = ABS( AB( L+I, J ) )
+ SUM = SUM + ABSA
+ WORK( I ) = WORK( I ) + ABSA
+ 50 CONTINUE
+ WORK( J ) = SUM + ABS( AB( K+1, J ) )
+ 60 CONTINUE
+ DO 70 I = 1, N
+ VALUE = MAX( VALUE, WORK( I ) )
+ 70 CONTINUE
+ ELSE
+ DO 80 I = 1, N
+ WORK( I ) = ZERO
+ 80 CONTINUE
+ DO 100 J = 1, N
+ SUM = WORK( J ) + ABS( AB( 1, J ) )
+ L = 1 - J
+ DO 90 I = J + 1, MIN( N, J+K )
+ ABSA = ABS( AB( L+I, J ) )
+ SUM = SUM + ABSA
+ WORK( I ) = WORK( I ) + ABSA
+ 90 CONTINUE
+ VALUE = MAX( VALUE, SUM )
+ 100 CONTINUE
+ END IF
+ ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN
+*
+* Find normF(A).
+*
+ SCALE = ZERO
+ SUM = ONE
+ IF( K.GT.0 ) THEN
+ IF( LSAME( UPLO, 'U' ) ) THEN
+ DO 110 J = 2, N
+ CALL SLASSQ( MIN( J-1, K ), AB( MAX( K+2-J, 1 ), J ),
+ $ 1, SCALE, SUM )
+ 110 CONTINUE
+ L = K + 1
+ ELSE
+ DO 120 J = 1, N - 1
+ CALL SLASSQ( MIN( N-J, K ), AB( 2, J ), 1, SCALE,
+ $ SUM )
+ 120 CONTINUE
+ L = 1
+ END IF
+ SUM = 2*SUM
+ ELSE
+ L = 1
+ END IF
+ CALL SLASSQ( N, AB( L, 1 ), LDAB, SCALE, SUM )
+ VALUE = SCALE*SQRT( SUM )
+ END IF
+*
+ SLANSB = VALUE
+ RETURN
+*
+* End of SLANSB
+*
+ END
+ REAL FUNCTION SLANSP( NORM, UPLO, N, AP, WORK )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER NORM, UPLO
+ INTEGER N
+* ..
+* .. Array Arguments ..
+ REAL AP( * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SLANSP returns the value of the one norm, or the Frobenius norm, or
+* the infinity norm, or the element of largest absolute value of a
+* real symmetric matrix A, supplied in packed form.
+*
+* Description
+* ===========
+*
+* SLANSP returns the value
+*
+* SLANSP = ( max(abs(A(i,j))), NORM = 'M' or 'm'
+* (
+* ( norm1(A), NORM = '1', 'O' or 'o'
+* (
+* ( normI(A), NORM = 'I' or 'i'
+* (
+* ( normF(A), NORM = 'F', 'f', 'E' or 'e'
+*
+* where norm1 denotes the one norm of a matrix (maximum column sum),
+* normI denotes the infinity norm of a matrix (maximum row sum) and
+* normF denotes the Frobenius norm of a matrix (square root of sum of
+* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.
+*
+* Arguments
+* =========
+*
+* NORM (input) CHARACTER*1
+* Specifies the value to be returned in SLANSP as described
+* above.
+*
+* UPLO (input) CHARACTER*1
+* Specifies whether the upper or lower triangular part of the
+* symmetric matrix A is supplied.
+* = 'U': Upper triangular part of A is supplied
+* = 'L': Lower triangular part of A is supplied
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0. When N = 0, SLANSP is
+* set to zero.
+*
+* AP (input) REAL array, dimension (N*(N+1)/2)
+* The upper or lower triangle of the symmetric matrix A, packed
+* columnwise in a linear array. The j-th column of A is stored
+* in the array AP as follows:
+* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
+* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
+*
+* WORK (workspace) REAL array, dimension (MAX(1,LWORK)),
+* where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,
+* WORK is not referenced.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ONE, ZERO
+ PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, J, K
+ REAL ABSA, SCALE, SUM, VALUE
+* ..
+* .. External Subroutines ..
+ EXTERNAL SLASSQ
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, SQRT
+* ..
+* .. Executable Statements ..
+*
+ IF( N.EQ.0 ) THEN
+ VALUE = ZERO
+ ELSE IF( LSAME( NORM, 'M' ) ) THEN
+*
+* Find max(abs(A(i,j))).
+*
+ VALUE = ZERO
+ IF( LSAME( UPLO, 'U' ) ) THEN
+ K = 1
+ DO 20 J = 1, N
+ DO 10 I = K, K + J - 1
+ VALUE = MAX( VALUE, ABS( AP( I ) ) )
+ 10 CONTINUE
+ K = K + J
+ 20 CONTINUE
+ ELSE
+ K = 1
+ DO 40 J = 1, N
+ DO 30 I = K, K + N - J
+ VALUE = MAX( VALUE, ABS( AP( I ) ) )
+ 30 CONTINUE
+ K = K + N - J + 1
+ 40 CONTINUE
+ END IF
+ ELSE IF( ( LSAME( NORM, 'I' ) ) .OR. ( LSAME( NORM, 'O' ) ) .OR.
+ $ ( NORM.EQ.'1' ) ) THEN
+*
+* Find normI(A) ( = norm1(A), since A is symmetric).
+*
+ VALUE = ZERO
+ K = 1
+ IF( LSAME( UPLO, 'U' ) ) THEN
+ DO 60 J = 1, N
+ SUM = ZERO
+ DO 50 I = 1, J - 1
+ ABSA = ABS( AP( K ) )
+ SUM = SUM + ABSA
+ WORK( I ) = WORK( I ) + ABSA
+ K = K + 1
+ 50 CONTINUE
+ WORK( J ) = SUM + ABS( AP( K ) )
+ K = K + 1
+ 60 CONTINUE
+ DO 70 I = 1, N
+ VALUE = MAX( VALUE, WORK( I ) )
+ 70 CONTINUE
+ ELSE
+ DO 80 I = 1, N
+ WORK( I ) = ZERO
+ 80 CONTINUE
+ DO 100 J = 1, N
+ SUM = WORK( J ) + ABS( AP( K ) )
+ K = K + 1
+ DO 90 I = J + 1, N
+ ABSA = ABS( AP( K ) )
+ SUM = SUM + ABSA
+ WORK( I ) = WORK( I ) + ABSA
+ K = K + 1
+ 90 CONTINUE
+ VALUE = MAX( VALUE, SUM )
+ 100 CONTINUE
+ END IF
+ ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN
+*
+* Find normF(A).
+*
+ SCALE = ZERO
+ SUM = ONE
+ K = 2
+ IF( LSAME( UPLO, 'U' ) ) THEN
+ DO 110 J = 2, N
+ CALL SLASSQ( J-1, AP( K ), 1, SCALE, SUM )
+ K = K + J
+ 110 CONTINUE
+ ELSE
+ DO 120 J = 1, N - 1
+ CALL SLASSQ( N-J, AP( K ), 1, SCALE, SUM )
+ K = K + N - J + 1
+ 120 CONTINUE
+ END IF
+ SUM = 2*SUM
+ K = 1
+ DO 130 I = 1, N
+ IF( AP( K ).NE.ZERO ) THEN
+ ABSA = ABS( AP( K ) )
+ IF( SCALE.LT.ABSA ) THEN
+ SUM = ONE + SUM*( SCALE / ABSA )**2
+ SCALE = ABSA
+ ELSE
+ SUM = SUM + ( ABSA / SCALE )**2
+ END IF
+ END IF
+ IF( LSAME( UPLO, 'U' ) ) THEN
+ K = K + I + 1
+ ELSE
+ K = K + N - I + 1
+ END IF
+ 130 CONTINUE
+ VALUE = SCALE*SQRT( SUM )
+ END IF
+*
+ SLANSP = VALUE
+ RETURN
+*
+* End of SLANSP
+*
+ END
+ REAL FUNCTION SLANST( NORM, N, D, E )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER NORM
+ INTEGER N
+* ..
+* .. Array Arguments ..
+ REAL D( * ), E( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SLANST returns the value of the one norm, or the Frobenius norm, or
+* the infinity norm, or the element of largest absolute value of a
+* real symmetric tridiagonal matrix A.
+*
+* Description
+* ===========
+*
+* SLANST returns the value
+*
+* SLANST = ( max(abs(A(i,j))), NORM = 'M' or 'm'
+* (
+* ( norm1(A), NORM = '1', 'O' or 'o'
+* (
+* ( normI(A), NORM = 'I' or 'i'
+* (
+* ( normF(A), NORM = 'F', 'f', 'E' or 'e'
+*
+* where norm1 denotes the one norm of a matrix (maximum column sum),
+* normI denotes the infinity norm of a matrix (maximum row sum) and
+* normF denotes the Frobenius norm of a matrix (square root of sum of
+* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.
+*
+* Arguments
+* =========
+*
+* NORM (input) CHARACTER*1
+* Specifies the value to be returned in SLANST as described
+* above.
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0. When N = 0, SLANST is
+* set to zero.
+*
+* D (input) REAL array, dimension (N)
+* The diagonal elements of A.
+*
+* E (input) REAL array, dimension (N-1)
+* The (n-1) sub-diagonal or super-diagonal elements of A.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ONE, ZERO
+ PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I
+ REAL ANORM, SCALE, SUM
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL SLASSQ
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, SQRT
+* ..
+* .. Executable Statements ..
+*
+ IF( N.LE.0 ) THEN
+ ANORM = ZERO
+ ELSE IF( LSAME( NORM, 'M' ) ) THEN
+*
+* Find max(abs(A(i,j))).
+*
+ ANORM = ABS( D( N ) )
+ DO 10 I = 1, N - 1
+ ANORM = MAX( ANORM, ABS( D( I ) ) )
+ ANORM = MAX( ANORM, ABS( E( I ) ) )
+ 10 CONTINUE
+ ELSE IF( LSAME( NORM, 'O' ) .OR. NORM.EQ.'1' .OR.
+ $ LSAME( NORM, 'I' ) ) THEN
+*
+* Find norm1(A).
+*
+ IF( N.EQ.1 ) THEN
+ ANORM = ABS( D( 1 ) )
+ ELSE
+ ANORM = MAX( ABS( D( 1 ) )+ABS( E( 1 ) ),
+ $ ABS( E( N-1 ) )+ABS( D( N ) ) )
+ DO 20 I = 2, N - 1
+ ANORM = MAX( ANORM, ABS( D( I ) )+ABS( E( I ) )+
+ $ ABS( E( I-1 ) ) )
+ 20 CONTINUE
+ END IF
+ ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN
+*
+* Find normF(A).
+*
+ SCALE = ZERO
+ SUM = ONE
+ IF( N.GT.1 ) THEN
+ CALL SLASSQ( N-1, E, 1, SCALE, SUM )
+ SUM = 2*SUM
+ END IF
+ CALL SLASSQ( N, D, 1, SCALE, SUM )
+ ANORM = SCALE*SQRT( SUM )
+ END IF
+*
+ SLANST = ANORM
+ RETURN
+*
+* End of SLANST
+*
+ END
+ REAL FUNCTION SLANSY( NORM, UPLO, N, A, LDA, WORK )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER NORM, UPLO
+ INTEGER LDA, N
+* ..
+* .. Array Arguments ..
+ REAL A( LDA, * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SLANSY returns the value of the one norm, or the Frobenius norm, or
+* the infinity norm, or the element of largest absolute value of a
+* real symmetric matrix A.
+*
+* Description
+* ===========
+*
+* SLANSY returns the value
+*
+* SLANSY = ( max(abs(A(i,j))), NORM = 'M' or 'm'
+* (
+* ( norm1(A), NORM = '1', 'O' or 'o'
+* (
+* ( normI(A), NORM = 'I' or 'i'
+* (
+* ( normF(A), NORM = 'F', 'f', 'E' or 'e'
+*
+* where norm1 denotes the one norm of a matrix (maximum column sum),
+* normI denotes the infinity norm of a matrix (maximum row sum) and
+* normF denotes the Frobenius norm of a matrix (square root of sum of
+* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.
+*
+* Arguments
+* =========
+*
+* NORM (input) CHARACTER*1
+* Specifies the value to be returned in SLANSY as described
+* above.
+*
+* UPLO (input) CHARACTER*1
+* Specifies whether the upper or lower triangular part of the
+* symmetric matrix A is to be referenced.
+* = 'U': Upper triangular part of A is referenced
+* = 'L': Lower triangular part of A is referenced
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0. When N = 0, SLANSY is
+* set to zero.
+*
+* A (input) REAL array, dimension (LDA,N)
+* The symmetric matrix A. If UPLO = 'U', the leading n by n
+* upper triangular part of A contains the upper triangular part
+* of the matrix A, and the strictly lower triangular part of A
+* is not referenced. If UPLO = 'L', the leading n by n lower
+* triangular part of A contains the lower triangular part of
+* the matrix A, and the strictly upper triangular part of A is
+* not referenced.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(N,1).
+*
+* WORK (workspace) REAL array, dimension (MAX(1,LWORK)),
+* where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,
+* WORK is not referenced.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ONE, ZERO
+ PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, J
+ REAL ABSA, SCALE, SUM, VALUE
+* ..
+* .. External Subroutines ..
+ EXTERNAL SLASSQ
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, SQRT
+* ..
+* .. Executable Statements ..
+*
+ IF( N.EQ.0 ) THEN
+ VALUE = ZERO
+ ELSE IF( LSAME( NORM, 'M' ) ) THEN
+*
+* Find max(abs(A(i,j))).
+*
+ VALUE = ZERO
+ IF( LSAME( UPLO, 'U' ) ) THEN
+ DO 20 J = 1, N
+ DO 10 I = 1, J
+ VALUE = MAX( VALUE, ABS( A( I, J ) ) )
+ 10 CONTINUE
+ 20 CONTINUE
+ ELSE
+ DO 40 J = 1, N
+ DO 30 I = J, N
+ VALUE = MAX( VALUE, ABS( A( I, J ) ) )
+ 30 CONTINUE
+ 40 CONTINUE
+ END IF
+ ELSE IF( ( LSAME( NORM, 'I' ) ) .OR. ( LSAME( NORM, 'O' ) ) .OR.
+ $ ( NORM.EQ.'1' ) ) THEN
+*
+* Find normI(A) ( = norm1(A), since A is symmetric).
+*
+ VALUE = ZERO
+ IF( LSAME( UPLO, 'U' ) ) THEN
+ DO 60 J = 1, N
+ SUM = ZERO
+ DO 50 I = 1, J - 1
+ ABSA = ABS( A( I, J ) )
+ SUM = SUM + ABSA
+ WORK( I ) = WORK( I ) + ABSA
+ 50 CONTINUE
+ WORK( J ) = SUM + ABS( A( J, J ) )
+ 60 CONTINUE
+ DO 70 I = 1, N
+ VALUE = MAX( VALUE, WORK( I ) )
+ 70 CONTINUE
+ ELSE
+ DO 80 I = 1, N
+ WORK( I ) = ZERO
+ 80 CONTINUE
+ DO 100 J = 1, N
+ SUM = WORK( J ) + ABS( A( J, J ) )
+ DO 90 I = J + 1, N
+ ABSA = ABS( A( I, J ) )
+ SUM = SUM + ABSA
+ WORK( I ) = WORK( I ) + ABSA
+ 90 CONTINUE
+ VALUE = MAX( VALUE, SUM )
+ 100 CONTINUE
+ END IF
+ ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN
+*
+* Find normF(A).
+*
+ SCALE = ZERO
+ SUM = ONE
+ IF( LSAME( UPLO, 'U' ) ) THEN
+ DO 110 J = 2, N
+ CALL SLASSQ( J-1, A( 1, J ), 1, SCALE, SUM )
+ 110 CONTINUE
+ ELSE
+ DO 120 J = 1, N - 1
+ CALL SLASSQ( N-J, A( J+1, J ), 1, SCALE, SUM )
+ 120 CONTINUE
+ END IF
+ SUM = 2*SUM
+ CALL SLASSQ( N, A, LDA+1, SCALE, SUM )
+ VALUE = SCALE*SQRT( SUM )
+ END IF
+*
+ SLANSY = VALUE
+ RETURN
+*
+* End of SLANSY
+*
+ END
+ REAL FUNCTION SLANTB( NORM, UPLO, DIAG, N, K, AB,
+ $ LDAB, WORK )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER DIAG, NORM, UPLO
+ INTEGER K, LDAB, N
+* ..
+* .. Array Arguments ..
+ REAL AB( LDAB, * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SLANTB returns the value of the one norm, or the Frobenius norm, or
+* the infinity norm, or the element of largest absolute value of an
+* n by n triangular band matrix A, with ( k + 1 ) diagonals.
+*
+* Description
+* ===========
+*
+* SLANTB returns the value
+*
+* SLANTB = ( max(abs(A(i,j))), NORM = 'M' or 'm'
+* (
+* ( norm1(A), NORM = '1', 'O' or 'o'
+* (
+* ( normI(A), NORM = 'I' or 'i'
+* (
+* ( normF(A), NORM = 'F', 'f', 'E' or 'e'
+*
+* where norm1 denotes the one norm of a matrix (maximum column sum),
+* normI denotes the infinity norm of a matrix (maximum row sum) and
+* normF denotes the Frobenius norm of a matrix (square root of sum of
+* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.
+*
+* Arguments
+* =========
+*
+* NORM (input) CHARACTER*1
+* Specifies the value to be returned in SLANTB as described
+* above.
+*
+* UPLO (input) CHARACTER*1
+* Specifies whether the matrix A is upper or lower triangular.
+* = 'U': Upper triangular
+* = 'L': Lower triangular
+*
+* DIAG (input) CHARACTER*1
+* Specifies whether or not the matrix A is unit triangular.
+* = 'N': Non-unit triangular
+* = 'U': Unit triangular
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0. When N = 0, SLANTB is
+* set to zero.
+*
+* K (input) INTEGER
+* The number of super-diagonals of the matrix A if UPLO = 'U',
+* or the number of sub-diagonals of the matrix A if UPLO = 'L'.
+* K >= 0.
+*
+* AB (input) REAL array, dimension (LDAB,N)
+* The upper or lower triangular band matrix A, stored in the
+* first k+1 rows of AB. The j-th column of A is stored
+* in the j-th column of the array AB as follows:
+* if UPLO = 'U', AB(k+1+i-j,j) = A(i,j) for max(1,j-k)<=i<=j;
+* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+k).
+* Note that when DIAG = 'U', the elements of the array AB
+* corresponding to the diagonal elements of the matrix A are
+* not referenced, but are assumed to be one.
+*
+* LDAB (input) INTEGER
+* The leading dimension of the array AB. LDAB >= K+1.
+*
+* WORK (workspace) REAL array, dimension (MAX(1,LWORK)),
+* where LWORK >= N when NORM = 'I'; otherwise, WORK is not
+* referenced.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ONE, ZERO
+ PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL UDIAG
+ INTEGER I, J, L
+ REAL SCALE, SUM, VALUE
+* ..
+* .. External Subroutines ..
+ EXTERNAL SLASSQ
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, MIN, SQRT
+* ..
+* .. Executable Statements ..
+*
+ IF( N.EQ.0 ) THEN
+ VALUE = ZERO
+ ELSE IF( LSAME( NORM, 'M' ) ) THEN
+*
+* Find max(abs(A(i,j))).
+*
+ IF( LSAME( DIAG, 'U' ) ) THEN
+ VALUE = ONE
+ IF( LSAME( UPLO, 'U' ) ) THEN
+ DO 20 J = 1, N
+ DO 10 I = MAX( K+2-J, 1 ), K
+ VALUE = MAX( VALUE, ABS( AB( I, J ) ) )
+ 10 CONTINUE
+ 20 CONTINUE
+ ELSE
+ DO 40 J = 1, N
+ DO 30 I = 2, MIN( N+1-J, K+1 )
+ VALUE = MAX( VALUE, ABS( AB( I, J ) ) )
+ 30 CONTINUE
+ 40 CONTINUE
+ END IF
+ ELSE
+ VALUE = ZERO
+ IF( LSAME( UPLO, 'U' ) ) THEN
+ DO 60 J = 1, N
+ DO 50 I = MAX( K+2-J, 1 ), K + 1
+ VALUE = MAX( VALUE, ABS( AB( I, J ) ) )
+ 50 CONTINUE
+ 60 CONTINUE
+ ELSE
+ DO 80 J = 1, N
+ DO 70 I = 1, MIN( N+1-J, K+1 )
+ VALUE = MAX( VALUE, ABS( AB( I, J ) ) )
+ 70 CONTINUE
+ 80 CONTINUE
+ END IF
+ END IF
+ ELSE IF( ( LSAME( NORM, 'O' ) ) .OR. ( NORM.EQ.'1' ) ) THEN
+*
+* Find norm1(A).
+*
+ VALUE = ZERO
+ UDIAG = LSAME( DIAG, 'U' )
+ IF( LSAME( UPLO, 'U' ) ) THEN
+ DO 110 J = 1, N
+ IF( UDIAG ) THEN
+ SUM = ONE
+ DO 90 I = MAX( K+2-J, 1 ), K
+ SUM = SUM + ABS( AB( I, J ) )
+ 90 CONTINUE
+ ELSE
+ SUM = ZERO
+ DO 100 I = MAX( K+2-J, 1 ), K + 1
+ SUM = SUM + ABS( AB( I, J ) )
+ 100 CONTINUE
+ END IF
+ VALUE = MAX( VALUE, SUM )
+ 110 CONTINUE
+ ELSE
+ DO 140 J = 1, N
+ IF( UDIAG ) THEN
+ SUM = ONE
+ DO 120 I = 2, MIN( N+1-J, K+1 )
+ SUM = SUM + ABS( AB( I, J ) )
+ 120 CONTINUE
+ ELSE
+ SUM = ZERO
+ DO 130 I = 1, MIN( N+1-J, K+1 )
+ SUM = SUM + ABS( AB( I, J ) )
+ 130 CONTINUE
+ END IF
+ VALUE = MAX( VALUE, SUM )
+ 140 CONTINUE
+ END IF
+ ELSE IF( LSAME( NORM, 'I' ) ) THEN
+*
+* Find normI(A).
+*
+ VALUE = ZERO
+ IF( LSAME( UPLO, 'U' ) ) THEN
+ IF( LSAME( DIAG, 'U' ) ) THEN
+ DO 150 I = 1, N
+ WORK( I ) = ONE
+ 150 CONTINUE
+ DO 170 J = 1, N
+ L = K + 1 - J
+ DO 160 I = MAX( 1, J-K ), J - 1
+ WORK( I ) = WORK( I ) + ABS( AB( L+I, J ) )
+ 160 CONTINUE
+ 170 CONTINUE
+ ELSE
+ DO 180 I = 1, N
+ WORK( I ) = ZERO
+ 180 CONTINUE
+ DO 200 J = 1, N
+ L = K + 1 - J
+ DO 190 I = MAX( 1, J-K ), J
+ WORK( I ) = WORK( I ) + ABS( AB( L+I, J ) )
+ 190 CONTINUE
+ 200 CONTINUE
+ END IF
+ ELSE
+ IF( LSAME( DIAG, 'U' ) ) THEN
+ DO 210 I = 1, N
+ WORK( I ) = ONE
+ 210 CONTINUE
+ DO 230 J = 1, N
+ L = 1 - J
+ DO 220 I = J + 1, MIN( N, J+K )
+ WORK( I ) = WORK( I ) + ABS( AB( L+I, J ) )
+ 220 CONTINUE
+ 230 CONTINUE
+ ELSE
+ DO 240 I = 1, N
+ WORK( I ) = ZERO
+ 240 CONTINUE
+ DO 260 J = 1, N
+ L = 1 - J
+ DO 250 I = J, MIN( N, J+K )
+ WORK( I ) = WORK( I ) + ABS( AB( L+I, J ) )
+ 250 CONTINUE
+ 260 CONTINUE
+ END IF
+ END IF
+ DO 270 I = 1, N
+ VALUE = MAX( VALUE, WORK( I ) )
+ 270 CONTINUE
+ ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN
+*
+* Find normF(A).
+*
+ IF( LSAME( UPLO, 'U' ) ) THEN
+ IF( LSAME( DIAG, 'U' ) ) THEN
+ SCALE = ONE
+ SUM = N
+ IF( K.GT.0 ) THEN
+ DO 280 J = 2, N
+ CALL SLASSQ( MIN( J-1, K ),
+ $ AB( MAX( K+2-J, 1 ), J ), 1, SCALE,
+ $ SUM )
+ 280 CONTINUE
+ END IF
+ ELSE
+ SCALE = ZERO
+ SUM = ONE
+ DO 290 J = 1, N
+ CALL SLASSQ( MIN( J, K+1 ), AB( MAX( K+2-J, 1 ), J ),
+ $ 1, SCALE, SUM )
+ 290 CONTINUE
+ END IF
+ ELSE
+ IF( LSAME( DIAG, 'U' ) ) THEN
+ SCALE = ONE
+ SUM = N
+ IF( K.GT.0 ) THEN
+ DO 300 J = 1, N - 1
+ CALL SLASSQ( MIN( N-J, K ), AB( 2, J ), 1, SCALE,
+ $ SUM )
+ 300 CONTINUE
+ END IF
+ ELSE
+ SCALE = ZERO
+ SUM = ONE
+ DO 310 J = 1, N
+ CALL SLASSQ( MIN( N-J+1, K+1 ), AB( 1, J ), 1, SCALE,
+ $ SUM )
+ 310 CONTINUE
+ END IF
+ END IF
+ VALUE = SCALE*SQRT( SUM )
+ END IF
+*
+ SLANTB = VALUE
+ RETURN
+*
+* End of SLANTB
+*
+ END
+ REAL FUNCTION SLANTP( NORM, UPLO, DIAG, N, AP, WORK )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER DIAG, NORM, UPLO
+ INTEGER N
+* ..
+* .. Array Arguments ..
+ REAL AP( * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SLANTP returns the value of the one norm, or the Frobenius norm, or
+* the infinity norm, or the element of largest absolute value of a
+* triangular matrix A, supplied in packed form.
+*
+* Description
+* ===========
+*
+* SLANTP returns the value
+*
+* SLANTP = ( max(abs(A(i,j))), NORM = 'M' or 'm'
+* (
+* ( norm1(A), NORM = '1', 'O' or 'o'
+* (
+* ( normI(A), NORM = 'I' or 'i'
+* (
+* ( normF(A), NORM = 'F', 'f', 'E' or 'e'
+*
+* where norm1 denotes the one norm of a matrix (maximum column sum),
+* normI denotes the infinity norm of a matrix (maximum row sum) and
+* normF denotes the Frobenius norm of a matrix (square root of sum of
+* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.
+*
+* Arguments
+* =========
+*
+* NORM (input) CHARACTER*1
+* Specifies the value to be returned in SLANTP as described
+* above.
+*
+* UPLO (input) CHARACTER*1
+* Specifies whether the matrix A is upper or lower triangular.
+* = 'U': Upper triangular
+* = 'L': Lower triangular
+*
+* DIAG (input) CHARACTER*1
+* Specifies whether or not the matrix A is unit triangular.
+* = 'N': Non-unit triangular
+* = 'U': Unit triangular
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0. When N = 0, SLANTP is
+* set to zero.
+*
+* AP (input) REAL array, dimension (N*(N+1)/2)
+* The upper or lower triangular matrix A, packed columnwise in
+* a linear array. The j-th column of A is stored in the array
+* AP as follows:
+* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
+* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
+* Note that when DIAG = 'U', the elements of the array AP
+* corresponding to the diagonal elements of the matrix A are
+* not referenced, but are assumed to be one.
+*
+* WORK (workspace) REAL array, dimension (MAX(1,LWORK)),
+* where LWORK >= N when NORM = 'I'; otherwise, WORK is not
+* referenced.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ONE, ZERO
+ PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL UDIAG
+ INTEGER I, J, K
+ REAL SCALE, SUM, VALUE
+* ..
+* .. External Subroutines ..
+ EXTERNAL SLASSQ
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, SQRT
+* ..
+* .. Executable Statements ..
+*
+ IF( N.EQ.0 ) THEN
+ VALUE = ZERO
+ ELSE IF( LSAME( NORM, 'M' ) ) THEN
+*
+* Find max(abs(A(i,j))).
+*
+ K = 1
+ IF( LSAME( DIAG, 'U' ) ) THEN
+ VALUE = ONE
+ IF( LSAME( UPLO, 'U' ) ) THEN
+ DO 20 J = 1, N
+ DO 10 I = K, K + J - 2
+ VALUE = MAX( VALUE, ABS( AP( I ) ) )
+ 10 CONTINUE
+ K = K + J
+ 20 CONTINUE
+ ELSE
+ DO 40 J = 1, N
+ DO 30 I = K + 1, K + N - J
+ VALUE = MAX( VALUE, ABS( AP( I ) ) )
+ 30 CONTINUE
+ K = K + N - J + 1
+ 40 CONTINUE
+ END IF
+ ELSE
+ VALUE = ZERO
+ IF( LSAME( UPLO, 'U' ) ) THEN
+ DO 60 J = 1, N
+ DO 50 I = K, K + J - 1
+ VALUE = MAX( VALUE, ABS( AP( I ) ) )
+ 50 CONTINUE
+ K = K + J
+ 60 CONTINUE
+ ELSE
+ DO 80 J = 1, N
+ DO 70 I = K, K + N - J
+ VALUE = MAX( VALUE, ABS( AP( I ) ) )
+ 70 CONTINUE
+ K = K + N - J + 1
+ 80 CONTINUE
+ END IF
+ END IF
+ ELSE IF( ( LSAME( NORM, 'O' ) ) .OR. ( NORM.EQ.'1' ) ) THEN
+*
+* Find norm1(A).
+*
+ VALUE = ZERO
+ K = 1
+ UDIAG = LSAME( DIAG, 'U' )
+ IF( LSAME( UPLO, 'U' ) ) THEN
+ DO 110 J = 1, N
+ IF( UDIAG ) THEN
+ SUM = ONE
+ DO 90 I = K, K + J - 2
+ SUM = SUM + ABS( AP( I ) )
+ 90 CONTINUE
+ ELSE
+ SUM = ZERO
+ DO 100 I = K, K + J - 1
+ SUM = SUM + ABS( AP( I ) )
+ 100 CONTINUE
+ END IF
+ K = K + J
+ VALUE = MAX( VALUE, SUM )
+ 110 CONTINUE
+ ELSE
+ DO 140 J = 1, N
+ IF( UDIAG ) THEN
+ SUM = ONE
+ DO 120 I = K + 1, K + N - J
+ SUM = SUM + ABS( AP( I ) )
+ 120 CONTINUE
+ ELSE
+ SUM = ZERO
+ DO 130 I = K, K + N - J
+ SUM = SUM + ABS( AP( I ) )
+ 130 CONTINUE
+ END IF
+ K = K + N - J + 1
+ VALUE = MAX( VALUE, SUM )
+ 140 CONTINUE
+ END IF
+ ELSE IF( LSAME( NORM, 'I' ) ) THEN
+*
+* Find normI(A).
+*
+ K = 1
+ IF( LSAME( UPLO, 'U' ) ) THEN
+ IF( LSAME( DIAG, 'U' ) ) THEN
+ DO 150 I = 1, N
+ WORK( I ) = ONE
+ 150 CONTINUE
+ DO 170 J = 1, N
+ DO 160 I = 1, J - 1
+ WORK( I ) = WORK( I ) + ABS( AP( K ) )
+ K = K + 1
+ 160 CONTINUE
+ K = K + 1
+ 170 CONTINUE
+ ELSE
+ DO 180 I = 1, N
+ WORK( I ) = ZERO
+ 180 CONTINUE
+ DO 200 J = 1, N
+ DO 190 I = 1, J
+ WORK( I ) = WORK( I ) + ABS( AP( K ) )
+ K = K + 1
+ 190 CONTINUE
+ 200 CONTINUE
+ END IF
+ ELSE
+ IF( LSAME( DIAG, 'U' ) ) THEN
+ DO 210 I = 1, N
+ WORK( I ) = ONE
+ 210 CONTINUE
+ DO 230 J = 1, N
+ K = K + 1
+ DO 220 I = J + 1, N
+ WORK( I ) = WORK( I ) + ABS( AP( K ) )
+ K = K + 1
+ 220 CONTINUE
+ 230 CONTINUE
+ ELSE
+ DO 240 I = 1, N
+ WORK( I ) = ZERO
+ 240 CONTINUE
+ DO 260 J = 1, N
+ DO 250 I = J, N
+ WORK( I ) = WORK( I ) + ABS( AP( K ) )
+ K = K + 1
+ 250 CONTINUE
+ 260 CONTINUE
+ END IF
+ END IF
+ VALUE = ZERO
+ DO 270 I = 1, N
+ VALUE = MAX( VALUE, WORK( I ) )
+ 270 CONTINUE
+ ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN
+*
+* Find normF(A).
+*
+ IF( LSAME( UPLO, 'U' ) ) THEN
+ IF( LSAME( DIAG, 'U' ) ) THEN
+ SCALE = ONE
+ SUM = N
+ K = 2
+ DO 280 J = 2, N
+ CALL SLASSQ( J-1, AP( K ), 1, SCALE, SUM )
+ K = K + J
+ 280 CONTINUE
+ ELSE
+ SCALE = ZERO
+ SUM = ONE
+ K = 1
+ DO 290 J = 1, N
+ CALL SLASSQ( J, AP( K ), 1, SCALE, SUM )
+ K = K + J
+ 290 CONTINUE
+ END IF
+ ELSE
+ IF( LSAME( DIAG, 'U' ) ) THEN
+ SCALE = ONE
+ SUM = N
+ K = 2
+ DO 300 J = 1, N - 1
+ CALL SLASSQ( N-J, AP( K ), 1, SCALE, SUM )
+ K = K + N - J + 1
+ 300 CONTINUE
+ ELSE
+ SCALE = ZERO
+ SUM = ONE
+ K = 1
+ DO 310 J = 1, N
+ CALL SLASSQ( N-J+1, AP( K ), 1, SCALE, SUM )
+ K = K + N - J + 1
+ 310 CONTINUE
+ END IF
+ END IF
+ VALUE = SCALE*SQRT( SUM )
+ END IF
+*
+ SLANTP = VALUE
+ RETURN
+*
+* End of SLANTP
+*
+ END
+ REAL FUNCTION SLANTR( NORM, UPLO, DIAG, M, N, A, LDA,
+ $ WORK )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER DIAG, NORM, UPLO
+ INTEGER LDA, M, N
+* ..
+* .. Array Arguments ..
+ REAL A( LDA, * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SLANTR returns the value of the one norm, or the Frobenius norm, or
+* the infinity norm, or the element of largest absolute value of a
+* trapezoidal or triangular matrix A.
+*
+* Description
+* ===========
+*
+* SLANTR returns the value
+*
+* SLANTR = ( max(abs(A(i,j))), NORM = 'M' or 'm'
+* (
+* ( norm1(A), NORM = '1', 'O' or 'o'
+* (
+* ( normI(A), NORM = 'I' or 'i'
+* (
+* ( normF(A), NORM = 'F', 'f', 'E' or 'e'
+*
+* where norm1 denotes the one norm of a matrix (maximum column sum),
+* normI denotes the infinity norm of a matrix (maximum row sum) and
+* normF denotes the Frobenius norm of a matrix (square root of sum of
+* squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.
+*
+* Arguments
+* =========
+*
+* NORM (input) CHARACTER*1
+* Specifies the value to be returned in SLANTR as described
+* above.
+*
+* UPLO (input) CHARACTER*1
+* Specifies whether the matrix A is upper or lower trapezoidal.
+* = 'U': Upper trapezoidal
+* = 'L': Lower trapezoidal
+* Note that A is triangular instead of trapezoidal if M = N.
+*
+* DIAG (input) CHARACTER*1
+* Specifies whether or not the matrix A has unit diagonal.
+* = 'N': Non-unit diagonal
+* = 'U': Unit diagonal
+*
+* M (input) INTEGER
+* The number of rows of the matrix A. M >= 0, and if
+* UPLO = 'U', M <= N. When M = 0, SLANTR is set to zero.
+*
+* N (input) INTEGER
+* The number of columns of the matrix A. N >= 0, and if
+* UPLO = 'L', N <= M. When N = 0, SLANTR is set to zero.
+*
+* A (input) REAL array, dimension (LDA,N)
+* The trapezoidal matrix A (A is triangular if M = N).
+* If UPLO = 'U', the leading m by n upper trapezoidal part of
+* the array A contains the upper trapezoidal matrix, and the
+* strictly lower triangular part of A is not referenced.
+* If UPLO = 'L', the leading m by n lower trapezoidal part of
+* the array A contains the lower trapezoidal matrix, and the
+* strictly upper triangular part of A is not referenced. Note
+* that when DIAG = 'U', the diagonal elements of A are not
+* referenced and are assumed to be one.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(M,1).
+*
+* WORK (workspace) REAL array, dimension (MAX(1,LWORK)),
+* where LWORK >= M when NORM = 'I'; otherwise, WORK is not
+* referenced.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ONE, ZERO
+ PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL UDIAG
+ INTEGER I, J
+ REAL SCALE, SUM, VALUE
+* ..
+* .. External Subroutines ..
+ EXTERNAL SLASSQ
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, MIN, SQRT
+* ..
+* .. Executable Statements ..
+*
+ IF( MIN( M, N ).EQ.0 ) THEN
+ VALUE = ZERO
+ ELSE IF( LSAME( NORM, 'M' ) ) THEN
+*
+* Find max(abs(A(i,j))).
+*
+ IF( LSAME( DIAG, 'U' ) ) THEN
+ VALUE = ONE
+ IF( LSAME( UPLO, 'U' ) ) THEN
+ DO 20 J = 1, N
+ DO 10 I = 1, MIN( M, J-1 )
+ VALUE = MAX( VALUE, ABS( A( I, J ) ) )
+ 10 CONTINUE
+ 20 CONTINUE
+ ELSE
+ DO 40 J = 1, N
+ DO 30 I = J + 1, M
+ VALUE = MAX( VALUE, ABS( A( I, J ) ) )
+ 30 CONTINUE
+ 40 CONTINUE
+ END IF
+ ELSE
+ VALUE = ZERO
+ IF( LSAME( UPLO, 'U' ) ) THEN
+ DO 60 J = 1, N
+ DO 50 I = 1, MIN( M, J )
+ VALUE = MAX( VALUE, ABS( A( I, J ) ) )
+ 50 CONTINUE
+ 60 CONTINUE
+ ELSE
+ DO 80 J = 1, N
+ DO 70 I = J, M
+ VALUE = MAX( VALUE, ABS( A( I, J ) ) )
+ 70 CONTINUE
+ 80 CONTINUE
+ END IF
+ END IF
+ ELSE IF( ( LSAME( NORM, 'O' ) ) .OR. ( NORM.EQ.'1' ) ) THEN
+*
+* Find norm1(A).
+*
+ VALUE = ZERO
+ UDIAG = LSAME( DIAG, 'U' )
+ IF( LSAME( UPLO, 'U' ) ) THEN
+ DO 110 J = 1, N
+ IF( ( UDIAG ) .AND. ( J.LE.M ) ) THEN
+ SUM = ONE
+ DO 90 I = 1, J - 1
+ SUM = SUM + ABS( A( I, J ) )
+ 90 CONTINUE
+ ELSE
+ SUM = ZERO
+ DO 100 I = 1, MIN( M, J )
+ SUM = SUM + ABS( A( I, J ) )
+ 100 CONTINUE
+ END IF
+ VALUE = MAX( VALUE, SUM )
+ 110 CONTINUE
+ ELSE
+ DO 140 J = 1, N
+ IF( UDIAG ) THEN
+ SUM = ONE
+ DO 120 I = J + 1, M
+ SUM = SUM + ABS( A( I, J ) )
+ 120 CONTINUE
+ ELSE
+ SUM = ZERO
+ DO 130 I = J, M
+ SUM = SUM + ABS( A( I, J ) )
+ 130 CONTINUE
+ END IF
+ VALUE = MAX( VALUE, SUM )
+ 140 CONTINUE
+ END IF
+ ELSE IF( LSAME( NORM, 'I' ) ) THEN
+*
+* Find normI(A).
+*
+ IF( LSAME( UPLO, 'U' ) ) THEN
+ IF( LSAME( DIAG, 'U' ) ) THEN
+ DO 150 I = 1, M
+ WORK( I ) = ONE
+ 150 CONTINUE
+ DO 170 J = 1, N
+ DO 160 I = 1, MIN( M, J-1 )
+ WORK( I ) = WORK( I ) + ABS( A( I, J ) )
+ 160 CONTINUE
+ 170 CONTINUE
+ ELSE
+ DO 180 I = 1, M
+ WORK( I ) = ZERO
+ 180 CONTINUE
+ DO 200 J = 1, N
+ DO 190 I = 1, MIN( M, J )
+ WORK( I ) = WORK( I ) + ABS( A( I, J ) )
+ 190 CONTINUE
+ 200 CONTINUE
+ END IF
+ ELSE
+ IF( LSAME( DIAG, 'U' ) ) THEN
+ DO 210 I = 1, N
+ WORK( I ) = ONE
+ 210 CONTINUE
+ DO 220 I = N + 1, M
+ WORK( I ) = ZERO
+ 220 CONTINUE
+ DO 240 J = 1, N
+ DO 230 I = J + 1, M
+ WORK( I ) = WORK( I ) + ABS( A( I, J ) )
+ 230 CONTINUE
+ 240 CONTINUE
+ ELSE
+ DO 250 I = 1, M
+ WORK( I ) = ZERO
+ 250 CONTINUE
+ DO 270 J = 1, N
+ DO 260 I = J, M
+ WORK( I ) = WORK( I ) + ABS( A( I, J ) )
+ 260 CONTINUE
+ 270 CONTINUE
+ END IF
+ END IF
+ VALUE = ZERO
+ DO 280 I = 1, M
+ VALUE = MAX( VALUE, WORK( I ) )
+ 280 CONTINUE
+ ELSE IF( ( LSAME( NORM, 'F' ) ) .OR. ( LSAME( NORM, 'E' ) ) ) THEN
+*
+* Find normF(A).
+*
+ IF( LSAME( UPLO, 'U' ) ) THEN
+ IF( LSAME( DIAG, 'U' ) ) THEN
+ SCALE = ONE
+ SUM = MIN( M, N )
+ DO 290 J = 2, N
+ CALL SLASSQ( MIN( M, J-1 ), A( 1, J ), 1, SCALE, SUM )
+ 290 CONTINUE
+ ELSE
+ SCALE = ZERO
+ SUM = ONE
+ DO 300 J = 1, N
+ CALL SLASSQ( MIN( M, J ), A( 1, J ), 1, SCALE, SUM )
+ 300 CONTINUE
+ END IF
+ ELSE
+ IF( LSAME( DIAG, 'U' ) ) THEN
+ SCALE = ONE
+ SUM = MIN( M, N )
+ DO 310 J = 1, N
+ CALL SLASSQ( M-J, A( MIN( M, J+1 ), J ), 1, SCALE,
+ $ SUM )
+ 310 CONTINUE
+ ELSE
+ SCALE = ZERO
+ SUM = ONE
+ DO 320 J = 1, N
+ CALL SLASSQ( M-J+1, A( J, J ), 1, SCALE, SUM )
+ 320 CONTINUE
+ END IF
+ END IF
+ VALUE = SCALE*SQRT( SUM )
+ END IF
+*
+ SLANTR = VALUE
+ RETURN
+*
+* End of SLANTR
+*
+ END
+ SUBROUTINE SLANV2( A, B, C, D, RT1R, RT1I, RT2R, RT2I, CS, SN )
+*
+* -- LAPACK driver routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ REAL A, B, C, CS, D, RT1I, RT1R, RT2I, RT2R, SN
+* ..
+*
+* Purpose
+* =======
+*
+* SLANV2 computes the Schur factorization of a real 2-by-2 nonsymmetric
+* matrix in standard form:
+*
+* [ A B ] = [ CS -SN ] [ AA BB ] [ CS SN ]
+* [ C D ] [ SN CS ] [ CC DD ] [-SN CS ]
+*
+* where either
+* 1) CC = 0 so that AA and DD are real eigenvalues of the matrix, or
+* 2) AA = DD and BB*CC < 0, so that AA + or - sqrt(BB*CC) are complex
+* conjugate eigenvalues.
+*
+* Arguments
+* =========
+*
+* A (input/output) REAL
+* B (input/output) REAL
+* C (input/output) REAL
+* D (input/output) REAL
+* On entry, the elements of the input matrix.
+* On exit, they are overwritten by the elements of the
+* standardised Schur form.
+*
+* RT1R (output) REAL
+* RT1I (output) REAL
+* RT2R (output) REAL
+* RT2I (output) REAL
+* The real and imaginary parts of the eigenvalues. If the
+* eigenvalues are a complex conjugate pair, RT1I > 0.
+*
+* CS (output) REAL
+* SN (output) REAL
+* Parameters of the rotation matrix.
+*
+* Further Details
+* ===============
+*
+* Modified by V. Sima, Research Institute for Informatics, Bucharest,
+* Romania, to reduce the risk of cancellation errors,
+* when computing real eigenvalues, and to ensure, if possible, that
+* abs(RT1R) >= abs(RT2R).
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO, HALF, ONE
+ PARAMETER ( ZERO = 0.0E+0, HALF = 0.5E+0, ONE = 1.0E+0 )
+ REAL MULTPL
+ PARAMETER ( MULTPL = 4.0E+0 )
+* ..
+* .. Local Scalars ..
+ REAL AA, BB, BCMAX, BCMIS, CC, CS1, DD, EPS, P, SAB,
+ $ SAC, SCALE, SIGMA, SN1, TAU, TEMP, Z
+* ..
+* .. External Functions ..
+ REAL SLAMCH, SLAPY2
+ EXTERNAL SLAMCH, SLAPY2
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, MIN, SIGN, SQRT
+* ..
+* .. Executable Statements ..
+*
+ EPS = SLAMCH( 'P' )
+ IF( C.EQ.ZERO ) THEN
+ CS = ONE
+ SN = ZERO
+ GO TO 10
+*
+ ELSE IF( B.EQ.ZERO ) THEN
+*
+* Swap rows and columns
+*
+ CS = ZERO
+ SN = ONE
+ TEMP = D
+ D = A
+ A = TEMP
+ B = -C
+ C = ZERO
+ GO TO 10
+ ELSE IF( (A-D).EQ.ZERO .AND. SIGN( ONE, B ).NE.
+ $ SIGN( ONE, C ) ) THEN
+ CS = ONE
+ SN = ZERO
+ GO TO 10
+ ELSE
+*
+ TEMP = A - D
+ P = HALF*TEMP
+ BCMAX = MAX( ABS( B ), ABS( C ) )
+ BCMIS = MIN( ABS( B ), ABS( C ) )*SIGN( ONE, B )*SIGN( ONE, C )
+ SCALE = MAX( ABS( P ), BCMAX )
+ Z = ( P / SCALE )*P + ( BCMAX / SCALE )*BCMIS
+*
+* If Z is of the order of the machine accuracy, postpone the
+* decision on the nature of eigenvalues
+*
+ IF( Z.GE.MULTPL*EPS ) THEN
+*
+* Real eigenvalues. Compute A and D.
+*
+ Z = P + SIGN( SQRT( SCALE )*SQRT( Z ), P )
+ A = D + Z
+ D = D - ( BCMAX / Z )*BCMIS
+*
+* Compute B and the rotation matrix
+*
+ TAU = SLAPY2( C, Z )
+ CS = Z / TAU
+ SN = C / TAU
+ B = B - C
+ C = ZERO
+ ELSE
+*
+* Complex eigenvalues, or real (almost) equal eigenvalues.
+* Make diagonal elements equal.
+*
+ SIGMA = B + C
+ TAU = SLAPY2( SIGMA, TEMP )
+ CS = SQRT( HALF*( ONE+ABS( SIGMA ) / TAU ) )
+ SN = -( P / ( TAU*CS ) )*SIGN( ONE, SIGMA )
+*
+* Compute [ AA BB ] = [ A B ] [ CS -SN ]
+* [ CC DD ] [ C D ] [ SN CS ]
+*
+ AA = A*CS + B*SN
+ BB = -A*SN + B*CS
+ CC = C*CS + D*SN
+ DD = -C*SN + D*CS
+*
+* Compute [ A B ] = [ CS SN ] [ AA BB ]
+* [ C D ] [-SN CS ] [ CC DD ]
+*
+ A = AA*CS + CC*SN
+ B = BB*CS + DD*SN
+ C = -AA*SN + CC*CS
+ D = -BB*SN + DD*CS
+*
+ TEMP = HALF*( A+D )
+ A = TEMP
+ D = TEMP
+*
+ IF( C.NE.ZERO ) THEN
+ IF( B.NE.ZERO ) THEN
+ IF( SIGN( ONE, B ).EQ.SIGN( ONE, C ) ) THEN
+*
+* Real eigenvalues: reduce to upper triangular form
+*
+ SAB = SQRT( ABS( B ) )
+ SAC = SQRT( ABS( C ) )
+ P = SIGN( SAB*SAC, C )
+ TAU = ONE / SQRT( ABS( B+C ) )
+ A = TEMP + P
+ D = TEMP - P
+ B = B - C
+ C = ZERO
+ CS1 = SAB*TAU
+ SN1 = SAC*TAU
+ TEMP = CS*CS1 - SN*SN1
+ SN = CS*SN1 + SN*CS1
+ CS = TEMP
+ END IF
+ ELSE
+ B = -C
+ C = ZERO
+ TEMP = CS
+ CS = -SN
+ SN = TEMP
+ END IF
+ END IF
+ END IF
+*
+ END IF
+*
+ 10 CONTINUE
+*
+* Store eigenvalues in (RT1R,RT1I) and (RT2R,RT2I).
+*
+ RT1R = A
+ RT2R = D
+ IF( C.EQ.ZERO ) THEN
+ RT1I = ZERO
+ RT2I = ZERO
+ ELSE
+ RT1I = SQRT( ABS( B ) )*SQRT( ABS( C ) )
+ RT2I = -RT1I
+ END IF
+ RETURN
+*
+* End of SLANV2
+*
+ END
+ SUBROUTINE SLAPLL( N, X, INCX, Y, INCY, SSMIN )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INCX, INCY, N
+ REAL SSMIN
+* ..
+* .. Array Arguments ..
+ REAL X( * ), Y( * )
+* ..
+*
+* Purpose
+* =======
+*
+* Given two column vectors X and Y, let
+*
+* A = ( X Y ).
+*
+* The subroutine first computes the QR factorization of A = Q*R,
+* and then computes the SVD of the 2-by-2 upper triangular matrix R.
+* The smaller singular value of R is returned in SSMIN, which is used
+* as the measurement of the linear dependency of the vectors X and Y.
+*
+* Arguments
+* =========
+*
+* N (input) INTEGER
+* The length of the vectors X and Y.
+*
+* X (input/output) REAL array,
+* dimension (1+(N-1)*INCX)
+* On entry, X contains the N-vector X.
+* On exit, X is overwritten.
+*
+* INCX (input) INTEGER
+* The increment between successive elements of X. INCX > 0.
+*
+* Y (input/output) REAL array,
+* dimension (1+(N-1)*INCY)
+* On entry, Y contains the N-vector Y.
+* On exit, Y is overwritten.
+*
+* INCY (input) INTEGER
+* The increment between successive elements of Y. INCY > 0.
+*
+* SSMIN (output) REAL
+* The smallest singular value of the N-by-2 matrix A = ( X Y ).
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO, ONE
+ PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+* ..
+* .. Local Scalars ..
+ REAL A11, A12, A22, C, SSMAX, TAU
+* ..
+* .. External Functions ..
+ REAL SDOT
+ EXTERNAL SDOT
+* ..
+* .. External Subroutines ..
+ EXTERNAL SAXPY, SLARFG, SLAS2
+* ..
+* .. Executable Statements ..
+*
+* Quick return if possible
+*
+ IF( N.LE.1 ) THEN
+ SSMIN = ZERO
+ RETURN
+ END IF
+*
+* Compute the QR factorization of the N-by-2 matrix ( X Y )
+*
+ CALL SLARFG( N, X( 1 ), X( 1+INCX ), INCX, TAU )
+ A11 = X( 1 )
+ X( 1 ) = ONE
+*
+ C = -TAU*SDOT( N, X, INCX, Y, INCY )
+ CALL SAXPY( N, C, X, INCX, Y, INCY )
+*
+ CALL SLARFG( N-1, Y( 1+INCY ), Y( 1+2*INCY ), INCY, TAU )
+*
+ A12 = Y( 1 )
+ A22 = Y( 1+INCY )
+*
+* Compute the SVD of 2-by-2 Upper triangular matrix.
+*
+ CALL SLAS2( A11, A12, A22, SSMIN, SSMAX )
+*
+ RETURN
+*
+* End of SLAPLL
+*
+ END
+ SUBROUTINE SLAPMT( FORWRD, M, N, X, LDX, K )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ LOGICAL FORWRD
+ INTEGER LDX, M, N
+* ..
+* .. Array Arguments ..
+ INTEGER K( * )
+ REAL X( LDX, * )
+* ..
+*
+* Purpose
+* =======
+*
+* SLAPMT rearranges the columns of the M by N matrix X as specified
+* by the permutation K(1),K(2),...,K(N) of the integers 1,...,N.
+* If FORWRD = .TRUE., forward permutation:
+*
+* X(*,K(J)) is moved X(*,J) for J = 1,2,...,N.
+*
+* If FORWRD = .FALSE., backward permutation:
+*
+* X(*,J) is moved to X(*,K(J)) for J = 1,2,...,N.
+*
+* Arguments
+* =========
+*
+* FORWRD (input) LOGICAL
+* = .TRUE., forward permutation
+* = .FALSE., backward permutation
+*
+* M (input) INTEGER
+* The number of rows of the matrix X. M >= 0.
+*
+* N (input) INTEGER
+* The number of columns of the matrix X. N >= 0.
+*
+* X (input/output) REAL array, dimension (LDX,N)
+* On entry, the M by N matrix X.
+* On exit, X contains the permuted matrix X.
+*
+* LDX (input) INTEGER
+* The leading dimension of the array X, LDX >= MAX(1,M).
+*
+* K (input/output) INTEGER array, dimension (N)
+* On entry, K contains the permutation vector. K is used as
+* internal workspace, but reset to its original value on
+* output.
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ INTEGER I, II, J, IN
+ REAL TEMP
+* ..
+* .. Executable Statements ..
+*
+ IF( N.LE.1 )
+ $ RETURN
+*
+ DO 10 I = 1, N
+ K( I ) = -K( I )
+ 10 CONTINUE
+*
+ IF( FORWRD ) THEN
+*
+* Forward permutation
+*
+ DO 60 I = 1, N
+*
+ IF( K( I ).GT.0 )
+ $ GO TO 40
+*
+ J = I
+ K( J ) = -K( J )
+ IN = K( J )
+*
+ 20 CONTINUE
+ IF( K( IN ).GT.0 )
+ $ GO TO 40
+*
+ DO 30 II = 1, M
+ TEMP = X( II, J )
+ X( II, J ) = X( II, IN )
+ X( II, IN ) = TEMP
+ 30 CONTINUE
+*
+ K( IN ) = -K( IN )
+ J = IN
+ IN = K( IN )
+ GO TO 20
+*
+ 40 CONTINUE
+*
+ 60 CONTINUE
+*
+ ELSE
+*
+* Backward permutation
+*
+ DO 110 I = 1, N
+*
+ IF( K( I ).GT.0 )
+ $ GO TO 100
+*
+ K( I ) = -K( I )
+ J = K( I )
+ 80 CONTINUE
+ IF( J.EQ.I )
+ $ GO TO 100
+*
+ DO 90 II = 1, M
+ TEMP = X( II, I )
+ X( II, I ) = X( II, J )
+ X( II, J ) = TEMP
+ 90 CONTINUE
+*
+ K( J ) = -K( J )
+ J = K( J )
+ GO TO 80
+*
+ 100 CONTINUE
+
+ 110 CONTINUE
+*
+ END IF
+*
+ RETURN
+*
+* End of SLAPMT
+*
+ END
+ REAL FUNCTION SLAPY2( X, Y )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ REAL X, Y
+* ..
+*
+* Purpose
+* =======
+*
+* SLAPY2 returns sqrt(x**2+y**2), taking care not to cause unnecessary
+* overflow.
+*
+* Arguments
+* =========
+*
+* X (input) REAL
+* Y (input) REAL
+* X and Y specify the values x and y.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO
+ PARAMETER ( ZERO = 0.0E0 )
+ REAL ONE
+ PARAMETER ( ONE = 1.0E0 )
+* ..
+* .. Local Scalars ..
+ REAL W, XABS, YABS, Z
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, MIN, SQRT
+* ..
+* .. Executable Statements ..
+*
+ XABS = ABS( X )
+ YABS = ABS( Y )
+ W = MAX( XABS, YABS )
+ Z = MIN( XABS, YABS )
+ IF( Z.EQ.ZERO ) THEN
+ SLAPY2 = W
+ ELSE
+ SLAPY2 = W*SQRT( ONE+( Z / W )**2 )
+ END IF
+ RETURN
+*
+* End of SLAPY2
+*
+ END
+ REAL FUNCTION SLAPY3( X, Y, Z )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ REAL X, Y, Z
+* ..
+*
+* Purpose
+* =======
+*
+* SLAPY3 returns sqrt(x**2+y**2+z**2), taking care not to cause
+* unnecessary overflow.
+*
+* Arguments
+* =========
+*
+* X (input) REAL
+* Y (input) REAL
+* Z (input) REAL
+* X, Y and Z specify the values x, y and z.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO
+ PARAMETER ( ZERO = 0.0E0 )
+* ..
+* .. Local Scalars ..
+ REAL W, XABS, YABS, ZABS
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, SQRT
+* ..
+* .. Executable Statements ..
+*
+ XABS = ABS( X )
+ YABS = ABS( Y )
+ ZABS = ABS( Z )
+ W = MAX( XABS, YABS, ZABS )
+ IF( W.EQ.ZERO ) THEN
+* W can be zero for max(0,nan,0)
+* adding all three entries together will make sure
+* NaN will not disappear.
+ SLAPY3 = XABS + YABS + ZABS
+ ELSE
+ SLAPY3 = W*SQRT( ( XABS / W )**2+( YABS / W )**2+
+ $ ( ZABS / W )**2 )
+ END IF
+ RETURN
+*
+* End of SLAPY3
+*
+ END
+ SUBROUTINE SLAQGB( M, N, KL, KU, AB, LDAB, R, C, ROWCND, COLCND,
+ $ AMAX, EQUED )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER EQUED
+ INTEGER KL, KU, LDAB, M, N
+ REAL AMAX, COLCND, ROWCND
+* ..
+* .. Array Arguments ..
+ REAL AB( LDAB, * ), C( * ), R( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SLAQGB equilibrates a general M by N band matrix A with KL
+* subdiagonals and KU superdiagonals using the row and scaling factors
+* in the vectors R and C.
+*
+* Arguments
+* =========
+*
+* M (input) INTEGER
+* The number of rows of the matrix A. M >= 0.
+*
+* N (input) INTEGER
+* The number of columns of the matrix A. N >= 0.
+*
+* KL (input) INTEGER
+* The number of subdiagonals within the band of A. KL >= 0.
+*
+* KU (input) INTEGER
+* The number of superdiagonals within the band of A. KU >= 0.
+*
+* AB (input/output) REAL array, dimension (LDAB,N)
+* On entry, the matrix A in band storage, in rows 1 to KL+KU+1.
+* The j-th column of A is stored in the j-th column of the
+* array AB as follows:
+* AB(ku+1+i-j,j) = A(i,j) for max(1,j-ku)<=i<=min(m,j+kl)
+*
+* On exit, the equilibrated matrix, in the same storage format
+* as A. See EQUED for the form of the equilibrated matrix.
+*
+* LDAB (input) INTEGER
+* The leading dimension of the array AB. LDA >= KL+KU+1.
+*
+* R (input) REAL array, dimension (M)
+* The row scale factors for A.
+*
+* C (input) REAL array, dimension (N)
+* The column scale factors for A.
+*
+* ROWCND (input) REAL
+* Ratio of the smallest R(i) to the largest R(i).
+*
+* COLCND (input) REAL
+* Ratio of the smallest C(i) to the largest C(i).
+*
+* AMAX (input) REAL
+* Absolute value of largest matrix entry.
+*
+* EQUED (output) CHARACTER*1
+* Specifies the form of equilibration that was done.
+* = 'N': No equilibration
+* = 'R': Row equilibration, i.e., A has been premultiplied by
+* diag(R).
+* = 'C': Column equilibration, i.e., A has been postmultiplied
+* by diag(C).
+* = 'B': Both row and column equilibration, i.e., A has been
+* replaced by diag(R) * A * diag(C).
+*
+* Internal Parameters
+* ===================
+*
+* THRESH is a threshold value used to decide if row or column scaling
+* should be done based on the ratio of the row or column scaling
+* factors. If ROWCND < THRESH, row scaling is done, and if
+* COLCND < THRESH, column scaling is done.
+*
+* LARGE and SMALL are threshold values used to decide if row scaling
+* should be done based on the absolute size of the largest matrix
+* element. If AMAX > LARGE or AMAX < SMALL, row scaling is done.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ONE, THRESH
+ PARAMETER ( ONE = 1.0E+0, THRESH = 0.1E+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, J
+ REAL CJ, LARGE, SMALL
+* ..
+* .. External Functions ..
+ REAL SLAMCH
+ EXTERNAL SLAMCH
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+* Quick return if possible
+*
+ IF( M.LE.0 .OR. N.LE.0 ) THEN
+ EQUED = 'N'
+ RETURN
+ END IF
+*
+* Initialize LARGE and SMALL.
+*
+ SMALL = SLAMCH( 'Safe minimum' ) / SLAMCH( 'Precision' )
+ LARGE = ONE / SMALL
+*
+ IF( ROWCND.GE.THRESH .AND. AMAX.GE.SMALL .AND. AMAX.LE.LARGE )
+ $ THEN
+*
+* No row scaling
+*
+ IF( COLCND.GE.THRESH ) THEN
+*
+* No column scaling
+*
+ EQUED = 'N'
+ ELSE
+*
+* Column scaling
+*
+ DO 20 J = 1, N
+ CJ = C( J )
+ DO 10 I = MAX( 1, J-KU ), MIN( M, J+KL )
+ AB( KU+1+I-J, J ) = CJ*AB( KU+1+I-J, J )
+ 10 CONTINUE
+ 20 CONTINUE
+ EQUED = 'C'
+ END IF
+ ELSE IF( COLCND.GE.THRESH ) THEN
+*
+* Row scaling, no column scaling
+*
+ DO 40 J = 1, N
+ DO 30 I = MAX( 1, J-KU ), MIN( M, J+KL )
+ AB( KU+1+I-J, J ) = R( I )*AB( KU+1+I-J, J )
+ 30 CONTINUE
+ 40 CONTINUE
+ EQUED = 'R'
+ ELSE
+*
+* Row and column scaling
+*
+ DO 60 J = 1, N
+ CJ = C( J )
+ DO 50 I = MAX( 1, J-KU ), MIN( M, J+KL )
+ AB( KU+1+I-J, J ) = CJ*R( I )*AB( KU+1+I-J, J )
+ 50 CONTINUE
+ 60 CONTINUE
+ EQUED = 'B'
+ END IF
+*
+ RETURN
+*
+* End of SLAQGB
+*
+ END
+ SUBROUTINE SLAQGE( M, N, A, LDA, R, C, ROWCND, COLCND, AMAX,
+ $ EQUED )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER EQUED
+ INTEGER LDA, M, N
+ REAL AMAX, COLCND, ROWCND
+* ..
+* .. Array Arguments ..
+ REAL A( LDA, * ), C( * ), R( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SLAQGE equilibrates a general M by N matrix A using the row and
+* column scaling factors in the vectors R and C.
+*
+* Arguments
+* =========
+*
+* M (input) INTEGER
+* The number of rows of the matrix A. M >= 0.
+*
+* N (input) INTEGER
+* The number of columns of the matrix A. N >= 0.
+*
+* A (input/output) REAL array, dimension (LDA,N)
+* On entry, the M by N matrix A.
+* On exit, the equilibrated matrix. See EQUED for the form of
+* the equilibrated matrix.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(M,1).
+*
+* R (input) REAL array, dimension (M)
+* The row scale factors for A.
+*
+* C (input) REAL array, dimension (N)
+* The column scale factors for A.
+*
+* ROWCND (input) REAL
+* Ratio of the smallest R(i) to the largest R(i).
+*
+* COLCND (input) REAL
+* Ratio of the smallest C(i) to the largest C(i).
+*
+* AMAX (input) REAL
+* Absolute value of largest matrix entry.
+*
+* EQUED (output) CHARACTER*1
+* Specifies the form of equilibration that was done.
+* = 'N': No equilibration
+* = 'R': Row equilibration, i.e., A has been premultiplied by
+* diag(R).
+* = 'C': Column equilibration, i.e., A has been postmultiplied
+* by diag(C).
+* = 'B': Both row and column equilibration, i.e., A has been
+* replaced by diag(R) * A * diag(C).
+*
+* Internal Parameters
+* ===================
+*
+* THRESH is a threshold value used to decide if row or column scaling
+* should be done based on the ratio of the row or column scaling
+* factors. If ROWCND < THRESH, row scaling is done, and if
+* COLCND < THRESH, column scaling is done.
+*
+* LARGE and SMALL are threshold values used to decide if row scaling
+* should be done based on the absolute size of the largest matrix
+* element. If AMAX > LARGE or AMAX < SMALL, row scaling is done.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ONE, THRESH
+ PARAMETER ( ONE = 1.0E+0, THRESH = 0.1E+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, J
+ REAL CJ, LARGE, SMALL
+* ..
+* .. External Functions ..
+ REAL SLAMCH
+ EXTERNAL SLAMCH
+* ..
+* .. Executable Statements ..
+*
+* Quick return if possible
+*
+ IF( M.LE.0 .OR. N.LE.0 ) THEN
+ EQUED = 'N'
+ RETURN
+ END IF
+*
+* Initialize LARGE and SMALL.
+*
+ SMALL = SLAMCH( 'Safe minimum' ) / SLAMCH( 'Precision' )
+ LARGE = ONE / SMALL
+*
+ IF( ROWCND.GE.THRESH .AND. AMAX.GE.SMALL .AND. AMAX.LE.LARGE )
+ $ THEN
+*
+* No row scaling
+*
+ IF( COLCND.GE.THRESH ) THEN
+*
+* No column scaling
+*
+ EQUED = 'N'
+ ELSE
+*
+* Column scaling
+*
+ DO 20 J = 1, N
+ CJ = C( J )
+ DO 10 I = 1, M
+ A( I, J ) = CJ*A( I, J )
+ 10 CONTINUE
+ 20 CONTINUE
+ EQUED = 'C'
+ END IF
+ ELSE IF( COLCND.GE.THRESH ) THEN
+*
+* Row scaling, no column scaling
+*
+ DO 40 J = 1, N
+ DO 30 I = 1, M
+ A( I, J ) = R( I )*A( I, J )
+ 30 CONTINUE
+ 40 CONTINUE
+ EQUED = 'R'
+ ELSE
+*
+* Row and column scaling
+*
+ DO 60 J = 1, N
+ CJ = C( J )
+ DO 50 I = 1, M
+ A( I, J ) = CJ*R( I )*A( I, J )
+ 50 CONTINUE
+ 60 CONTINUE
+ EQUED = 'B'
+ END IF
+*
+ RETURN
+*
+* End of SLAQGE
+*
+ END
+ SUBROUTINE SLAQP2( M, N, OFFSET, A, LDA, JPVT, TAU, VN1, VN2,
+ $ WORK )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER LDA, M, N, OFFSET
+* ..
+* .. Array Arguments ..
+ INTEGER JPVT( * )
+ REAL A( LDA, * ), TAU( * ), VN1( * ), VN2( * ),
+ $ WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SLAQP2 computes a QR factorization with column pivoting of
+* the block A(OFFSET+1:M,1:N).
+* The block A(1:OFFSET,1:N) is accordingly pivoted, but not factorized.
+*
+* Arguments
+* =========
+*
+* M (input) INTEGER
+* The number of rows of the matrix A. M >= 0.
+*
+* N (input) INTEGER
+* The number of columns of the matrix A. N >= 0.
+*
+* OFFSET (input) INTEGER
+* The number of rows of the matrix A that must be pivoted
+* but no factorized. OFFSET >= 0.
+*
+* A (input/output) REAL array, dimension (LDA,N)
+* On entry, the M-by-N matrix A.
+* On exit, the upper triangle of block A(OFFSET+1:M,1:N) is
+* the triangular factor obtained; the elements in block
+* A(OFFSET+1:M,1:N) below the diagonal, together with the
+* array TAU, represent the orthogonal matrix Q as a product of
+* elementary reflectors. Block A(1:OFFSET,1:N) has been
+* accordingly pivoted, but no factorized.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,M).
+*
+* JPVT (input/output) INTEGER array, dimension (N)
+* On entry, if JPVT(i) .ne. 0, the i-th column of A is permuted
+* to the front of A*P (a leading column); if JPVT(i) = 0,
+* the i-th column of A is a free column.
+* On exit, if JPVT(i) = k, then the i-th column of A*P
+* was the k-th column of A.
+*
+* TAU (output) REAL array, dimension (min(M,N))
+* The scalar factors of the elementary reflectors.
+*
+* VN1 (input/output) REAL array, dimension (N)
+* The vector with the partial column norms.
+*
+* VN2 (input/output) REAL array, dimension (N)
+* The vector with the exact column norms.
+*
+* WORK (workspace) REAL array, dimension (N)
+*
+* Further Details
+* ===============
+*
+* Based on contributions by
+* G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain
+* X. Sun, Computer Science Dept., Duke University, USA
+*
+* Partial column norm updating strategy modified by
+* Z. Drmac and Z. Bujanovic, Dept. of Mathematics,
+* University of Zagreb, Croatia.
+* June 2006.
+* For more details see LAPACK Working Note 176.
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO, ONE
+ PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, ITEMP, J, MN, OFFPI, PVT
+ REAL AII, TEMP, TEMP2, TOL3Z
+* ..
+* .. External Subroutines ..
+ EXTERNAL SLARF, SLARFG, SSWAP
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, MIN, SQRT
+* ..
+* .. External Functions ..
+ INTEGER ISAMAX
+ REAL SLAMCH, SNRM2
+ EXTERNAL ISAMAX, SLAMCH, SNRM2
+* ..
+* .. Executable Statements ..
+*
+ MN = MIN( M-OFFSET, N )
+ TOL3Z = SQRT(SLAMCH('Epsilon'))
+*
+* Compute factorization.
+*
+ DO 20 I = 1, MN
+*
+ OFFPI = OFFSET + I
+*
+* Determine ith pivot column and swap if necessary.
+*
+ PVT = ( I-1 ) + ISAMAX( N-I+1, VN1( I ), 1 )
+*
+ IF( PVT.NE.I ) THEN
+ CALL SSWAP( M, A( 1, PVT ), 1, A( 1, I ), 1 )
+ ITEMP = JPVT( PVT )
+ JPVT( PVT ) = JPVT( I )
+ JPVT( I ) = ITEMP
+ VN1( PVT ) = VN1( I )
+ VN2( PVT ) = VN2( I )
+ END IF
+*
+* Generate elementary reflector H(i).
+*
+ IF( OFFPI.LT.M ) THEN
+ CALL SLARFG( M-OFFPI+1, A( OFFPI, I ), A( OFFPI+1, I ), 1,
+ $ TAU( I ) )
+ ELSE
+ CALL SLARFG( 1, A( M, I ), A( M, I ), 1, TAU( I ) )
+ END IF
+*
+ IF( I.LT.N ) THEN
+*
+* Apply H(i)' to A(offset+i:m,i+1:n) from the left.
+*
+ AII = A( OFFPI, I )
+ A( OFFPI, I ) = ONE
+ CALL SLARF( 'Left', M-OFFPI+1, N-I, A( OFFPI, I ), 1,
+ $ TAU( I ), A( OFFPI, I+1 ), LDA, WORK( 1 ) )
+ A( OFFPI, I ) = AII
+ END IF
+*
+* Update partial column norms.
+*
+ DO 10 J = I + 1, N
+ IF( VN1( J ).NE.ZERO ) THEN
+*
+* NOTE: The following 4 lines follow from the analysis in
+* Lapack Working Note 176.
+*
+ TEMP = ONE - ( ABS( A( OFFPI, J ) ) / VN1( J ) )**2
+ TEMP = MAX( TEMP, ZERO )
+ TEMP2 = TEMP*( VN1( J ) / VN2( J ) )**2
+ IF( TEMP2 .LE. TOL3Z ) THEN
+ IF( OFFPI.LT.M ) THEN
+ VN1( J ) = SNRM2( M-OFFPI, A( OFFPI+1, J ), 1 )
+ VN2( J ) = VN1( J )
+ ELSE
+ VN1( J ) = ZERO
+ VN2( J ) = ZERO
+ END IF
+ ELSE
+ VN1( J ) = VN1( J )*SQRT( TEMP )
+ END IF
+ END IF
+ 10 CONTINUE
+*
+ 20 CONTINUE
+*
+ RETURN
+*
+* End of SLAQP2
+*
+ END
+ SUBROUTINE SLAQPS( M, N, OFFSET, NB, KB, A, LDA, JPVT, TAU, VN1,
+ $ VN2, AUXV, F, LDF )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER KB, LDA, LDF, M, N, NB, OFFSET
+* ..
+* .. Array Arguments ..
+ INTEGER JPVT( * )
+ REAL A( LDA, * ), AUXV( * ), F( LDF, * ), TAU( * ),
+ $ VN1( * ), VN2( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SLAQPS computes a step of QR factorization with column pivoting
+* of a real M-by-N matrix A by using Blas-3. It tries to factorize
+* NB columns from A starting from the row OFFSET+1, and updates all
+* of the matrix with Blas-3 xGEMM.
+*
+* In some cases, due to catastrophic cancellations, it cannot
+* factorize NB columns. Hence, the actual number of factorized
+* columns is returned in KB.
+*
+* Block A(1:OFFSET,1:N) is accordingly pivoted, but not factorized.
+*
+* Arguments
+* =========
+*
+* M (input) INTEGER
+* The number of rows of the matrix A. M >= 0.
+*
+* N (input) INTEGER
+* The number of columns of the matrix A. N >= 0
+*
+* OFFSET (input) INTEGER
+* The number of rows of A that have been factorized in
+* previous steps.
+*
+* NB (input) INTEGER
+* The number of columns to factorize.
+*
+* KB (output) INTEGER
+* The number of columns actually factorized.
+*
+* A (input/output) REAL array, dimension (LDA,N)
+* On entry, the M-by-N matrix A.
+* On exit, block A(OFFSET+1:M,1:KB) is the triangular
+* factor obtained and block A(1:OFFSET,1:N) has been
+* accordingly pivoted, but no factorized.
+* The rest of the matrix, block A(OFFSET+1:M,KB+1:N) has
+* been updated.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,M).
+*
+* JPVT (input/output) INTEGER array, dimension (N)
+* JPVT(I) = K <==> Column K of the full matrix A has been
+* permuted into position I in AP.
+*
+* TAU (output) REAL array, dimension (KB)
+* The scalar factors of the elementary reflectors.
+*
+* VN1 (input/output) REAL array, dimension (N)
+* The vector with the partial column norms.
+*
+* VN2 (input/output) REAL array, dimension (N)
+* The vector with the exact column norms.
+*
+* AUXV (input/output) REAL array, dimension (NB)
+* Auxiliar vector.
+*
+* F (input/output) REAL array, dimension (LDF,NB)
+* Matrix F' = L*Y'*A.
+*
+* LDF (input) INTEGER
+* The leading dimension of the array F. LDF >= max(1,N).
+*
+* Further Details
+* ===============
+*
+* Based on contributions by
+* G. Quintana-Orti, Depto. de Informatica, Universidad Jaime I, Spain
+* X. Sun, Computer Science Dept., Duke University, USA
+*
+* Partial column norm updating strategy modified by
+* Z. Drmac and Z. Bujanovic, Dept. of Mathematics,
+* University of Zagreb, Croatia.
+* June 2006.
+* For more details see LAPACK Working Note 176.
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO, ONE
+ PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER ITEMP, J, K, LASTRK, LSTICC, PVT, RK
+ REAL AKK, TEMP, TEMP2, TOL3Z
+* ..
+* .. External Subroutines ..
+ EXTERNAL SGEMM, SGEMV, SLARFG, SSWAP
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, MIN, NINT, REAL, SQRT
+* ..
+* .. External Functions ..
+ INTEGER ISAMAX
+ REAL SLAMCH, SNRM2
+ EXTERNAL ISAMAX, SLAMCH, SNRM2
+* ..
+* .. Executable Statements ..
+*
+ LASTRK = MIN( M, N+OFFSET )
+ LSTICC = 0
+ K = 0
+ TOL3Z = SQRT(SLAMCH('Epsilon'))
+*
+* Beginning of while loop.
+*
+ 10 CONTINUE
+ IF( ( K.LT.NB ) .AND. ( LSTICC.EQ.0 ) ) THEN
+ K = K + 1
+ RK = OFFSET + K
+*
+* Determine ith pivot column and swap if necessary
+*
+ PVT = ( K-1 ) + ISAMAX( N-K+1, VN1( K ), 1 )
+ IF( PVT.NE.K ) THEN
+ CALL SSWAP( M, A( 1, PVT ), 1, A( 1, K ), 1 )
+ CALL SSWAP( K-1, F( PVT, 1 ), LDF, F( K, 1 ), LDF )
+ ITEMP = JPVT( PVT )
+ JPVT( PVT ) = JPVT( K )
+ JPVT( K ) = ITEMP
+ VN1( PVT ) = VN1( K )
+ VN2( PVT ) = VN2( K )
+ END IF
+*
+* Apply previous Householder reflectors to column K:
+* A(RK:M,K) := A(RK:M,K) - A(RK:M,1:K-1)*F(K,1:K-1)'.
+*
+ IF( K.GT.1 ) THEN
+ CALL SGEMV( 'No transpose', M-RK+1, K-1, -ONE, A( RK, 1 ),
+ $ LDA, F( K, 1 ), LDF, ONE, A( RK, K ), 1 )
+ END IF
+*
+* Generate elementary reflector H(k).
+*
+ IF( RK.LT.M ) THEN
+ CALL SLARFG( M-RK+1, A( RK, K ), A( RK+1, K ), 1, TAU( K ) )
+ ELSE
+ CALL SLARFG( 1, A( RK, K ), A( RK, K ), 1, TAU( K ) )
+ END IF
+*
+ AKK = A( RK, K )
+ A( RK, K ) = ONE
+*
+* Compute Kth column of F:
+*
+* Compute F(K+1:N,K) := tau(K)*A(RK:M,K+1:N)'*A(RK:M,K).
+*
+ IF( K.LT.N ) THEN
+ CALL SGEMV( 'Transpose', M-RK+1, N-K, TAU( K ),
+ $ A( RK, K+1 ), LDA, A( RK, K ), 1, ZERO,
+ $ F( K+1, K ), 1 )
+ END IF
+*
+* Padding F(1:K,K) with zeros.
+*
+ DO 20 J = 1, K
+ F( J, K ) = ZERO
+ 20 CONTINUE
+*
+* Incremental updating of F:
+* F(1:N,K) := F(1:N,K) - tau(K)*F(1:N,1:K-1)*A(RK:M,1:K-1)'
+* *A(RK:M,K).
+*
+ IF( K.GT.1 ) THEN
+ CALL SGEMV( 'Transpose', M-RK+1, K-1, -TAU( K ), A( RK, 1 ),
+ $ LDA, A( RK, K ), 1, ZERO, AUXV( 1 ), 1 )
+*
+ CALL SGEMV( 'No transpose', N, K-1, ONE, F( 1, 1 ), LDF,
+ $ AUXV( 1 ), 1, ONE, F( 1, K ), 1 )
+ END IF
+*
+* Update the current row of A:
+* A(RK,K+1:N) := A(RK,K+1:N) - A(RK,1:K)*F(K+1:N,1:K)'.
+*
+ IF( K.LT.N ) THEN
+ CALL SGEMV( 'No transpose', N-K, K, -ONE, F( K+1, 1 ), LDF,
+ $ A( RK, 1 ), LDA, ONE, A( RK, K+1 ), LDA )
+ END IF
+*
+* Update partial column norms.
+*
+ IF( RK.LT.LASTRK ) THEN
+ DO 30 J = K + 1, N
+ IF( VN1( J ).NE.ZERO ) THEN
+*
+* NOTE: The following 4 lines follow from the analysis in
+* Lapack Working Note 176.
+*
+ TEMP = ABS( A( RK, J ) ) / VN1( J )
+ TEMP = MAX( ZERO, ( ONE+TEMP )*( ONE-TEMP ) )
+ TEMP2 = TEMP*( VN1( J ) / VN2( J ) )**2
+ IF( TEMP2 .LE. TOL3Z ) THEN
+ VN2( J ) = REAL( LSTICC )
+ LSTICC = J
+ ELSE
+ VN1( J ) = VN1( J )*SQRT( TEMP )
+ END IF
+ END IF
+ 30 CONTINUE
+ END IF
+*
+ A( RK, K ) = AKK
+*
+* End of while loop.
+*
+ GO TO 10
+ END IF
+ KB = K
+ RK = OFFSET + KB
+*
+* Apply the block reflector to the rest of the matrix:
+* A(OFFSET+KB+1:M,KB+1:N) := A(OFFSET+KB+1:M,KB+1:N) -
+* A(OFFSET+KB+1:M,1:KB)*F(KB+1:N,1:KB)'.
+*
+ IF( KB.LT.MIN( N, M-OFFSET ) ) THEN
+ CALL SGEMM( 'No transpose', 'Transpose', M-RK, N-KB, KB, -ONE,
+ $ A( RK+1, 1 ), LDA, F( KB+1, 1 ), LDF, ONE,
+ $ A( RK+1, KB+1 ), LDA )
+ END IF
+*
+* Recomputation of difficult columns.
+*
+ 40 CONTINUE
+ IF( LSTICC.GT.0 ) THEN
+ ITEMP = NINT( VN2( LSTICC ) )
+ VN1( LSTICC ) = SNRM2( M-RK, A( RK+1, LSTICC ), 1 )
+*
+* NOTE: The computation of VN1( LSTICC ) relies on the fact that
+* SNRM2 does not fail on vectors with norm below the value of
+* SQRT(DLAMCH('S'))
+*
+ VN2( LSTICC ) = VN1( LSTICC )
+ LSTICC = ITEMP
+ GO TO 40
+ END IF
+*
+ RETURN
+*
+* End of SLAQPS
+*
+ END
+ SUBROUTINE SLAQR0( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI,
+ $ ILOZ, IHIZ, Z, LDZ, WORK, LWORK, INFO )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, LWORK, N
+ LOGICAL WANTT, WANTZ
+* ..
+* .. Array Arguments ..
+ REAL H( LDH, * ), WI( * ), WORK( * ), WR( * ),
+ $ Z( LDZ, * )
+* ..
+*
+* Purpose
+* =======
+*
+* SLAQR0 computes the eigenvalues of a Hessenberg matrix H
+* and, optionally, the matrices T and Z from the Schur decomposition
+* H = Z T Z**T, where T is an upper quasi-triangular matrix (the
+* Schur form), and Z is the orthogonal matrix of Schur vectors.
+*
+* Optionally Z may be postmultiplied into an input orthogonal
+* matrix Q so that this routine can give the Schur factorization
+* of a matrix A which has been reduced to the Hessenberg form H
+* by the orthogonal matrix Q: A = Q*H*Q**T = (QZ)*T*(QZ)**T.
+*
+* Arguments
+* =========
+*
+* WANTT (input) LOGICAL
+* = .TRUE. : the full Schur form T is required;
+* = .FALSE.: only eigenvalues are required.
+*
+* WANTZ (input) LOGICAL
+* = .TRUE. : the matrix of Schur vectors Z is required;
+* = .FALSE.: Schur vectors are not required.
+*
+* N (input) INTEGER
+* The order of the matrix H. N .GE. 0.
+*
+* ILO (input) INTEGER
+* IHI (input) INTEGER
+* It is assumed that H is already upper triangular in rows
+* and columns 1:ILO-1 and IHI+1:N and, if ILO.GT.1,
+* H(ILO,ILO-1) is zero. ILO and IHI are normally set by a
+* previous call to SGEBAL, and then passed to SGEHRD when the
+* matrix output by SGEBAL is reduced to Hessenberg form.
+* Otherwise, ILO and IHI should be set to 1 and N,
+* respectively. If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N.
+* If N = 0, then ILO = 1 and IHI = 0.
+*
+* H (input/output) REAL array, dimension (LDH,N)
+* On entry, the upper Hessenberg matrix H.
+* On exit, if INFO = 0 and WANTT is .TRUE., then H contains
+* the upper quasi-triangular matrix T from the Schur
+* decomposition (the Schur form); 2-by-2 diagonal blocks
+* (corresponding to complex conjugate pairs of eigenvalues)
+* are returned in standard form, with H(i,i) = H(i+1,i+1)
+* and H(i+1,i)*H(i,i+1).LT.0. If INFO = 0 and WANTT is
+* .FALSE., then the contents of H are unspecified on exit.
+* (The output value of H when INFO.GT.0 is given under the
+* description of INFO below.)
+*
+* This subroutine may explicitly set H(i,j) = 0 for i.GT.j and
+* j = 1, 2, ... ILO-1 or j = IHI+1, IHI+2, ... N.
+*
+* LDH (input) INTEGER
+* The leading dimension of the array H. LDH .GE. max(1,N).
+*
+* WR (output) REAL array, dimension (IHI)
+* WI (output) REAL array, dimension (IHI)
+* The real and imaginary parts, respectively, of the computed
+* eigenvalues of H(ILO:IHI,ILO:IHI) are stored WR(ILO:IHI)
+* and WI(ILO:IHI). If two eigenvalues are computed as a
+* complex conjugate pair, they are stored in consecutive
+* elements of WR and WI, say the i-th and (i+1)th, with
+* WI(i) .GT. 0 and WI(i+1) .LT. 0. If WANTT is .TRUE., then
+* the eigenvalues are stored in the same order as on the
+* diagonal of the Schur form returned in H, with
+* WR(i) = H(i,i) and, if H(i:i+1,i:i+1) is a 2-by-2 diagonal
+* block, WI(i) = sqrt(-H(i+1,i)*H(i,i+1)) and
+* WI(i+1) = -WI(i).
+*
+* ILOZ (input) INTEGER
+* IHIZ (input) INTEGER
+* Specify the rows of Z to which transformations must be
+* applied if WANTZ is .TRUE..
+* 1 .LE. ILOZ .LE. ILO; IHI .LE. IHIZ .LE. N.
+*
+* Z (input/output) REAL array, dimension (LDZ,IHI)
+* If WANTZ is .FALSE., then Z is not referenced.
+* If WANTZ is .TRUE., then Z(ILO:IHI,ILOZ:IHIZ) is
+* replaced by Z(ILO:IHI,ILOZ:IHIZ)*U where U is the
+* orthogonal Schur factor of H(ILO:IHI,ILO:IHI).
+* (The output value of Z when INFO.GT.0 is given under
+* the description of INFO below.)
+*
+* LDZ (input) INTEGER
+* The leading dimension of the array Z. if WANTZ is .TRUE.
+* then LDZ.GE.MAX(1,IHIZ). Otherwize, LDZ.GE.1.
+*
+* WORK (workspace/output) REAL array, dimension LWORK
+* On exit, if LWORK = -1, WORK(1) returns an estimate of
+* the optimal value for LWORK.
+*
+* LWORK (input) INTEGER
+* The dimension of the array WORK. LWORK .GE. max(1,N)
+* is sufficient, but LWORK typically as large as 6*N may
+* be required for optimal performance. A workspace query
+* to determine the optimal workspace size is recommended.
+*
+* If LWORK = -1, then SLAQR0 does a workspace query.
+* In this case, SLAQR0 checks the input parameters and
+* estimates the optimal workspace size for the given
+* values of N, ILO and IHI. The estimate is returned
+* in WORK(1). No error message related to LWORK is
+* issued by XERBLA. Neither H nor Z are accessed.
+*
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* .GT. 0: if INFO = i, SLAQR0 failed to compute all of
+* the eigenvalues. Elements 1:ilo-1 and i+1:n of WR
+* and WI contain those eigenvalues which have been
+* successfully computed. (Failures are rare.)
+*
+* If INFO .GT. 0 and WANT is .FALSE., then on exit,
+* the remaining unconverged eigenvalues are the eigen-
+* values of the upper Hessenberg matrix rows and
+* columns ILO through INFO of the final, output
+* value of H.
+*
+* If INFO .GT. 0 and WANTT is .TRUE., then on exit
+*
+* (*) (initial value of H)*U = U*(final value of H)
+*
+* where U is an orthogonal matrix. The final
+* value of H is upper Hessenberg and quasi-triangular
+* in rows and columns INFO+1 through IHI.
+*
+* If INFO .GT. 0 and WANTZ is .TRUE., then on exit
+*
+* (final value of Z(ILO:IHI,ILOZ:IHIZ)
+* = (initial value of Z(ILO:IHI,ILOZ:IHIZ)*U
+*
+* where U is the orthogonal matrix in (*) (regard-
+* less of the value of WANTT.)
+*
+* If INFO .GT. 0 and WANTZ is .FALSE., then Z is not
+* accessed.
+*
+* ================================================================
+* Based on contributions by
+* Karen Braman and Ralph Byers, Department of Mathematics,
+* University of Kansas, USA
+*
+* ================================================================
+* References:
+* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR
+* Algorithm Part I: Maintaining Well Focused Shifts, and Level 3
+* Performance, SIAM Journal of Matrix Analysis, volume 23, pages
+* 929--947, 2002.
+*
+* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR
+* Algorithm Part II: Aggressive Early Deflation, SIAM Journal
+* of Matrix Analysis, volume 23, pages 948--973, 2002.
+*
+* ================================================================
+* .. Parameters ..
+*
+* ==== Matrices of order NTINY or smaller must be processed by
+* . SLAHQR because of insufficient subdiagonal scratch space.
+* . (This is a hard limit.) ====
+*
+* ==== Exceptional deflation windows: try to cure rare
+* . slow convergence by increasing the size of the
+* . deflation window after KEXNW iterations. =====
+*
+* ==== Exceptional shifts: try to cure rare slow convergence
+* . with ad-hoc exceptional shifts every KEXSH iterations.
+* . The constants WILK1 and WILK2 are used to form the
+* . exceptional shifts. ====
+*
+ INTEGER NTINY
+ PARAMETER ( NTINY = 11 )
+ INTEGER KEXNW, KEXSH
+ PARAMETER ( KEXNW = 5, KEXSH = 6 )
+ REAL WILK1, WILK2
+ PARAMETER ( WILK1 = 0.75e0, WILK2 = -0.4375e0 )
+ REAL ZERO, ONE
+ PARAMETER ( ZERO = 0.0e0, ONE = 1.0e0 )
+* ..
+* .. Local Scalars ..
+ REAL AA, BB, CC, CS, DD, SN, SS, SWAP
+ INTEGER I, INF, IT, ITMAX, K, KACC22, KBOT, KDU, KS,
+ $ KT, KTOP, KU, KV, KWH, KWTOP, KWV, LD, LS,
+ $ LWKOPT, NDFL, NH, NHO, NIBBLE, NMIN, NS, NSMAX,
+ $ NSR, NVE, NW, NWMAX, NWR
+ LOGICAL NWINC, SORTED
+ CHARACTER JBCMPZ*2
+* ..
+* .. External Functions ..
+ INTEGER ILAENV
+ EXTERNAL ILAENV
+* ..
+* .. Local Arrays ..
+ REAL ZDUM( 1, 1 )
+* ..
+* .. External Subroutines ..
+ EXTERNAL SLACPY, SLAHQR, SLANV2, SLAQR3, SLAQR4, SLAQR5
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, INT, MAX, MIN, MOD, REAL
+* ..
+* .. Executable Statements ..
+ INFO = 0
+*
+* ==== Quick return for N = 0: nothing to do. ====
+*
+ IF( N.EQ.0 ) THEN
+ WORK( 1 ) = ONE
+ RETURN
+ END IF
+*
+* ==== Set up job flags for ILAENV. ====
+*
+ IF( WANTT ) THEN
+ JBCMPZ( 1: 1 ) = 'S'
+ ELSE
+ JBCMPZ( 1: 1 ) = 'E'
+ END IF
+ IF( WANTZ ) THEN
+ JBCMPZ( 2: 2 ) = 'V'
+ ELSE
+ JBCMPZ( 2: 2 ) = 'N'
+ END IF
+*
+* ==== Tiny matrices must use SLAHQR. ====
+*
+ IF( N.LE.NTINY ) THEN
+*
+* ==== Estimate optimal workspace. ====
+*
+ LWKOPT = 1
+ IF( LWORK.NE.-1 )
+ $ CALL SLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI,
+ $ ILOZ, IHIZ, Z, LDZ, INFO )
+ ELSE
+*
+* ==== Use small bulge multi-shift QR with aggressive early
+* . deflation on larger-than-tiny matrices. ====
+*
+* ==== Hope for the best. ====
+*
+ INFO = 0
+*
+* ==== NWR = recommended deflation window size. At this
+* . point, N .GT. NTINY = 11, so there is enough
+* . subdiagonal workspace for NWR.GE.2 as required.
+* . (In fact, there is enough subdiagonal space for
+* . NWR.GE.3.) ====
+*
+ NWR = ILAENV( 13, 'SLAQR0', JBCMPZ, N, ILO, IHI, LWORK )
+ NWR = MAX( 2, NWR )
+ NWR = MIN( IHI-ILO+1, ( N-1 ) / 3, NWR )
+ NW = NWR
+*
+* ==== NSR = recommended number of simultaneous shifts.
+* . At this point N .GT. NTINY = 11, so there is at
+* . enough subdiagonal workspace for NSR to be even
+* . and greater than or equal to two as required. ====
+*
+ NSR = ILAENV( 15, 'SLAQR0', JBCMPZ, N, ILO, IHI, LWORK )
+ NSR = MIN( NSR, ( N+6 ) / 9, IHI-ILO )
+ NSR = MAX( 2, NSR-MOD( NSR, 2 ) )
+*
+* ==== Estimate optimal workspace ====
+*
+* ==== Workspace query call to SLAQR3 ====
+*
+ CALL SLAQR3( WANTT, WANTZ, N, ILO, IHI, NWR+1, H, LDH, ILOZ,
+ $ IHIZ, Z, LDZ, LS, LD, WR, WI, H, LDH, N, H, LDH,
+ $ N, H, LDH, WORK, -1 )
+*
+* ==== Optimal workspace = MAX(SLAQR5, SLAQR3) ====
+*
+ LWKOPT = MAX( 3*NSR / 2, INT( WORK( 1 ) ) )
+*
+* ==== Quick return in case of workspace query. ====
+*
+ IF( LWORK.EQ.-1 ) THEN
+ WORK( 1 ) = REAL( LWKOPT )
+ RETURN
+ END IF
+*
+* ==== SLAHQR/SLAQR0 crossover point ====
+*
+ NMIN = ILAENV( 12, 'SLAQR0', JBCMPZ, N, ILO, IHI, LWORK )
+ NMIN = MAX( NTINY, NMIN )
+*
+* ==== Nibble crossover point ====
+*
+ NIBBLE = ILAENV( 14, 'SLAQR0', JBCMPZ, N, ILO, IHI, LWORK )
+ NIBBLE = MAX( 0, NIBBLE )
+*
+* ==== Accumulate reflections during ttswp? Use block
+* . 2-by-2 structure during matrix-matrix multiply? ====
+*
+ KACC22 = ILAENV( 16, 'SLAQR0', JBCMPZ, N, ILO, IHI, LWORK )
+ KACC22 = MAX( 0, KACC22 )
+ KACC22 = MIN( 2, KACC22 )
+*
+* ==== NWMAX = the largest possible deflation window for
+* . which there is sufficient workspace. ====
+*
+ NWMAX = MIN( ( N-1 ) / 3, LWORK / 2 )
+*
+* ==== NSMAX = the Largest number of simultaneous shifts
+* . for which there is sufficient workspace. ====
+*
+ NSMAX = MIN( ( N+6 ) / 9, 2*LWORK / 3 )
+ NSMAX = NSMAX - MOD( NSMAX, 2 )
+*
+* ==== NDFL: an iteration count restarted at deflation. ====
+*
+ NDFL = 1
+*
+* ==== ITMAX = iteration limit ====
+*
+ ITMAX = MAX( 30, 2*KEXSH )*MAX( 10, ( IHI-ILO+1 ) )
+*
+* ==== Last row and column in the active block ====
+*
+ KBOT = IHI
+*
+* ==== Main Loop ====
+*
+ DO 80 IT = 1, ITMAX
+*
+* ==== Done when KBOT falls below ILO ====
+*
+ IF( KBOT.LT.ILO )
+ $ GO TO 90
+*
+* ==== Locate active block ====
+*
+ DO 10 K = KBOT, ILO + 1, -1
+ IF( H( K, K-1 ).EQ.ZERO )
+ $ GO TO 20
+ 10 CONTINUE
+ K = ILO
+ 20 CONTINUE
+ KTOP = K
+*
+* ==== Select deflation window size ====
+*
+ NH = KBOT - KTOP + 1
+ IF( NDFL.LT.KEXNW .OR. NH.LT.NW ) THEN
+*
+* ==== Typical deflation window. If possible and
+* . advisable, nibble the entire active block.
+* . If not, use size NWR or NWR+1 depending upon
+* . which has the smaller corresponding subdiagonal
+* . entry (a heuristic). ====
+*
+ NWINC = .TRUE.
+ IF( NH.LE.MIN( NMIN, NWMAX ) ) THEN
+ NW = NH
+ ELSE
+ NW = MIN( NWR, NH, NWMAX )
+ IF( NW.LT.NWMAX ) THEN
+ IF( NW.GE.NH-1 ) THEN
+ NW = NH
+ ELSE
+ KWTOP = KBOT - NW + 1
+ IF( ABS( H( KWTOP, KWTOP-1 ) ).GT.
+ $ ABS( H( KWTOP-1, KWTOP-2 ) ) )NW = NW + 1
+ END IF
+ END IF
+ END IF
+ ELSE
+*
+* ==== Exceptional deflation window. If there have
+* . been no deflations in KEXNW or more iterations,
+* . then vary the deflation window size. At first,
+* . because, larger windows are, in general, more
+* . powerful than smaller ones, rapidly increase the
+* . window up to the maximum reasonable and possible.
+* . Then maybe try a slightly smaller window. ====
+*
+ IF( NWINC .AND. NW.LT.MIN( NWMAX, NH ) ) THEN
+ NW = MIN( NWMAX, NH, 2*NW )
+ ELSE
+ NWINC = .FALSE.
+ IF( NW.EQ.NH .AND. NH.GT.2 )
+ $ NW = NH - 1
+ END IF
+ END IF
+*
+* ==== Aggressive early deflation:
+* . split workspace under the subdiagonal into
+* . - an nw-by-nw work array V in the lower
+* . left-hand-corner,
+* . - an NW-by-at-least-NW-but-more-is-better
+* . (NW-by-NHO) horizontal work array along
+* . the bottom edge,
+* . - an at-least-NW-but-more-is-better (NHV-by-NW)
+* . vertical work array along the left-hand-edge.
+* . ====
+*
+ KV = N - NW + 1
+ KT = NW + 1
+ NHO = ( N-NW-1 ) - KT + 1
+ KWV = NW + 2
+ NVE = ( N-NW ) - KWV + 1
+*
+* ==== Aggressive early deflation ====
+*
+ CALL SLAQR3( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ,
+ $ IHIZ, Z, LDZ, LS, LD, WR, WI, H( KV, 1 ), LDH,
+ $ NHO, H( KV, KT ), LDH, NVE, H( KWV, 1 ), LDH,
+ $ WORK, LWORK )
+*
+* ==== Adjust KBOT accounting for new deflations. ====
+*
+ KBOT = KBOT - LD
+*
+* ==== KS points to the shifts. ====
+*
+ KS = KBOT - LS + 1
+*
+* ==== Skip an expensive QR sweep if there is a (partly
+* . heuristic) reason to expect that many eigenvalues
+* . will deflate without it. Here, the QR sweep is
+* . skipped if many eigenvalues have just been deflated
+* . or if the remaining active block is small.
+*
+ IF( ( LD.EQ.0 ) .OR. ( ( 100*LD.LE.NW*NIBBLE ) .AND. ( KBOT-
+ $ KTOP+1.GT.MIN( NMIN, NWMAX ) ) ) ) THEN
+*
+* ==== NS = nominal number of simultaneous shifts.
+* . This may be lowered (slightly) if SLAQR3
+* . did not provide that many shifts. ====
+*
+ NS = MIN( NSMAX, NSR, MAX( 2, KBOT-KTOP ) )
+ NS = NS - MOD( NS, 2 )
+*
+* ==== If there have been no deflations
+* . in a multiple of KEXSH iterations,
+* . then try exceptional shifts.
+* . Otherwise use shifts provided by
+* . SLAQR3 above or from the eigenvalues
+* . of a trailing principal submatrix. ====
+*
+ IF( MOD( NDFL, KEXSH ).EQ.0 ) THEN
+ KS = KBOT - NS + 1
+ DO 30 I = KBOT, MAX( KS+1, KTOP+2 ), -2
+ SS = ABS( H( I, I-1 ) ) + ABS( H( I-1, I-2 ) )
+ AA = WILK1*SS + H( I, I )
+ BB = SS
+ CC = WILK2*SS
+ DD = AA
+ CALL SLANV2( AA, BB, CC, DD, WR( I-1 ), WI( I-1 ),
+ $ WR( I ), WI( I ), CS, SN )
+ 30 CONTINUE
+ IF( KS.EQ.KTOP ) THEN
+ WR( KS+1 ) = H( KS+1, KS+1 )
+ WI( KS+1 ) = ZERO
+ WR( KS ) = WR( KS+1 )
+ WI( KS ) = WI( KS+1 )
+ END IF
+ ELSE
+*
+* ==== Got NS/2 or fewer shifts? Use SLAQR4 or
+* . SLAHQR on a trailing principal submatrix to
+* . get more. (Since NS.LE.NSMAX.LE.(N+6)/9,
+* . there is enough space below the subdiagonal
+* . to fit an NS-by-NS scratch array.) ====
+*
+ IF( KBOT-KS+1.LE.NS / 2 ) THEN
+ KS = KBOT - NS + 1
+ KT = N - NS + 1
+ CALL SLACPY( 'A', NS, NS, H( KS, KS ), LDH,
+ $ H( KT, 1 ), LDH )
+ IF( NS.GT.NMIN ) THEN
+ CALL SLAQR4( .false., .false., NS, 1, NS,
+ $ H( KT, 1 ), LDH, WR( KS ),
+ $ WI( KS ), 1, 1, ZDUM, 1, WORK,
+ $ LWORK, INF )
+ ELSE
+ CALL SLAHQR( .false., .false., NS, 1, NS,
+ $ H( KT, 1 ), LDH, WR( KS ),
+ $ WI( KS ), 1, 1, ZDUM, 1, INF )
+ END IF
+ KS = KS + INF
+*
+* ==== In case of a rare QR failure use
+* . eigenvalues of the trailing 2-by-2
+* . principal submatrix. ====
+*
+ IF( KS.GE.KBOT ) THEN
+ AA = H( KBOT-1, KBOT-1 )
+ CC = H( KBOT, KBOT-1 )
+ BB = H( KBOT-1, KBOT )
+ DD = H( KBOT, KBOT )
+ CALL SLANV2( AA, BB, CC, DD, WR( KBOT-1 ),
+ $ WI( KBOT-1 ), WR( KBOT ),
+ $ WI( KBOT ), CS, SN )
+ KS = KBOT - 1
+ END IF
+ END IF
+*
+ IF( KBOT-KS+1.GT.NS ) THEN
+*
+* ==== Sort the shifts (Helps a little)
+* . Bubble sort keeps complex conjugate
+* . pairs together. ====
+*
+ SORTED = .false.
+ DO 50 K = KBOT, KS + 1, -1
+ IF( SORTED )
+ $ GO TO 60
+ SORTED = .true.
+ DO 40 I = KS, K - 1
+ IF( ABS( WR( I ) )+ABS( WI( I ) ).LT.
+ $ ABS( WR( I+1 ) )+ABS( WI( I+1 ) ) ) THEN
+ SORTED = .false.
+*
+ SWAP = WR( I )
+ WR( I ) = WR( I+1 )
+ WR( I+1 ) = SWAP
+*
+ SWAP = WI( I )
+ WI( I ) = WI( I+1 )
+ WI( I+1 ) = SWAP
+ END IF
+ 40 CONTINUE
+ 50 CONTINUE
+ 60 CONTINUE
+ END IF
+*
+* ==== Shuffle shifts into pairs of real shifts
+* . and pairs of complex conjugate shifts
+* . assuming complex conjugate shifts are
+* . already adjacent to one another. (Yes,
+* . they are.) ====
+*
+ DO 70 I = KBOT, KS + 2, -2
+ IF( WI( I ).NE.-WI( I-1 ) ) THEN
+*
+ SWAP = WR( I )
+ WR( I ) = WR( I-1 )
+ WR( I-1 ) = WR( I-2 )
+ WR( I-2 ) = SWAP
+*
+ SWAP = WI( I )
+ WI( I ) = WI( I-1 )
+ WI( I-1 ) = WI( I-2 )
+ WI( I-2 ) = SWAP
+ END IF
+ 70 CONTINUE
+ END IF
+*
+* ==== If there are only two shifts and both are
+* . real, then use only one. ====
+*
+ IF( KBOT-KS+1.EQ.2 ) THEN
+ IF( WI( KBOT ).EQ.ZERO ) THEN
+ IF( ABS( WR( KBOT )-H( KBOT, KBOT ) ).LT.
+ $ ABS( WR( KBOT-1 )-H( KBOT, KBOT ) ) ) THEN
+ WR( KBOT-1 ) = WR( KBOT )
+ ELSE
+ WR( KBOT ) = WR( KBOT-1 )
+ END IF
+ END IF
+ END IF
+*
+* ==== Use up to NS of the the smallest magnatiude
+* . shifts. If there aren't NS shifts available,
+* . then use them all, possibly dropping one to
+* . make the number of shifts even. ====
+*
+ NS = MIN( NS, KBOT-KS+1 )
+ NS = NS - MOD( NS, 2 )
+ KS = KBOT - NS + 1
+*
+* ==== Small-bulge multi-shift QR sweep:
+* . split workspace under the subdiagonal into
+* . - a KDU-by-KDU work array U in the lower
+* . left-hand-corner,
+* . - a KDU-by-at-least-KDU-but-more-is-better
+* . (KDU-by-NHo) horizontal work array WH along
+* . the bottom edge,
+* . - and an at-least-KDU-but-more-is-better-by-KDU
+* . (NVE-by-KDU) vertical work WV arrow along
+* . the left-hand-edge. ====
+*
+ KDU = 3*NS - 3
+ KU = N - KDU + 1
+ KWH = KDU + 1
+ NHO = ( N-KDU+1-4 ) - ( KDU+1 ) + 1
+ KWV = KDU + 4
+ NVE = N - KDU - KWV + 1
+*
+* ==== Small-bulge multi-shift QR sweep ====
+*
+ CALL SLAQR5( WANTT, WANTZ, KACC22, N, KTOP, KBOT, NS,
+ $ WR( KS ), WI( KS ), H, LDH, ILOZ, IHIZ, Z,
+ $ LDZ, WORK, 3, H( KU, 1 ), LDH, NVE,
+ $ H( KWV, 1 ), LDH, NHO, H( KU, KWH ), LDH )
+ END IF
+*
+* ==== Note progress (or the lack of it). ====
+*
+ IF( LD.GT.0 ) THEN
+ NDFL = 1
+ ELSE
+ NDFL = NDFL + 1
+ END IF
+*
+* ==== End of main loop ====
+ 80 CONTINUE
+*
+* ==== Iteration limit exceeded. Set INFO to show where
+* . the problem occurred and exit. ====
+*
+ INFO = KBOT
+ 90 CONTINUE
+ END IF
+*
+* ==== Return the optimal value of LWORK. ====
+*
+ WORK( 1 ) = REAL( LWKOPT )
+*
+* ==== End of SLAQR0 ====
+*
+ END
+ SUBROUTINE SLAQR1( N, H, LDH, SR1, SI1, SR2, SI2, V )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ REAL SI1, SI2, SR1, SR2
+ INTEGER LDH, N
+* ..
+* .. Array Arguments ..
+ REAL H( LDH, * ), V( * )
+* ..
+*
+* Given a 2-by-2 or 3-by-3 matrix H, SLAQR1 sets v to a
+* scalar multiple of the first column of the product
+*
+* (*) K = (H - (sr1 + i*si1)*I)*(H - (sr2 + i*si2)*I)
+*
+* scaling to avoid overflows and most underflows. It
+* is assumed that either
+*
+* 1) sr1 = sr2 and si1 = -si2
+* or
+* 2) si1 = si2 = 0.
+*
+* This is useful for starting double implicit shift bulges
+* in the QR algorithm.
+*
+*
+* N (input) integer
+* Order of the matrix H. N must be either 2 or 3.
+*
+* H (input) REAL array of dimension (LDH,N)
+* The 2-by-2 or 3-by-3 matrix H in (*).
+*
+* LDH (input) integer
+* The leading dimension of H as declared in
+* the calling procedure. LDH.GE.N
+*
+* SR1 (input) REAL
+* SI1 The shifts in (*).
+* SR2
+* SI2
+*
+* V (output) REAL array of dimension N
+* A scalar multiple of the first column of the
+* matrix K in (*).
+*
+* ================================================================
+* Based on contributions by
+* Karen Braman and Ralph Byers, Department of Mathematics,
+* University of Kansas, USA
+*
+* ================================================================
+*
+* .. Parameters ..
+ REAL ZERO
+ PARAMETER ( ZERO = 0.0e0 )
+* ..
+* .. Local Scalars ..
+ REAL H21S, H31S, S
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS
+* ..
+* .. Executable Statements ..
+ IF( N.EQ.2 ) THEN
+ S = ABS( H( 1, 1 )-SR2 ) + ABS( SI2 ) + ABS( H( 2, 1 ) )
+ IF( S.EQ.ZERO ) THEN
+ V( 1 ) = ZERO
+ V( 2 ) = ZERO
+ ELSE
+ H21S = H( 2, 1 ) / S
+ V( 1 ) = H21S*H( 1, 2 ) + ( H( 1, 1 )-SR1 )*
+ $ ( ( H( 1, 1 )-SR2 ) / S ) - SI1*( SI2 / S )
+ V( 2 ) = H21S*( H( 1, 1 )+H( 2, 2 )-SR1-SR2 )
+ END IF
+ ELSE
+ S = ABS( H( 1, 1 )-SR2 ) + ABS( SI2 ) + ABS( H( 2, 1 ) ) +
+ $ ABS( H( 3, 1 ) )
+ IF( S.EQ.ZERO ) THEN
+ V( 1 ) = ZERO
+ V( 2 ) = ZERO
+ V( 3 ) = ZERO
+ ELSE
+ H21S = H( 2, 1 ) / S
+ H31S = H( 3, 1 ) / S
+ V( 1 ) = ( H( 1, 1 )-SR1 )*( ( H( 1, 1 )-SR2 ) / S ) -
+ $ SI1*( SI2 / S ) + H( 1, 2 )*H21S + H( 1, 3 )*H31S
+ V( 2 ) = H21S*( H( 1, 1 )+H( 2, 2 )-SR1-SR2 ) +
+ $ H( 2, 3 )*H31S
+ V( 3 ) = H31S*( H( 1, 1 )+H( 3, 3 )-SR1-SR2 ) +
+ $ H21S*H( 3, 2 )
+ END IF
+ END IF
+ END
+ 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 )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER IHIZ, ILOZ, KBOT, KTOP, LDH, LDT, LDV, LDWV,
+ $ LDZ, LWORK, N, ND, NH, NS, NV, NW
+ LOGICAL WANTT, WANTZ
+* ..
+* .. Array Arguments ..
+ REAL H( LDH, * ), SI( * ), SR( * ), T( LDT, * ),
+ $ V( LDV, * ), WORK( * ), WV( LDWV, * ),
+ $ Z( LDZ, * )
+* ..
+*
+* This subroutine is identical to SLAQR3 except that it avoids
+* recursion by calling SLAHQR instead of SLAQR4.
+*
+*
+* ******************************************************************
+* Aggressive early deflation:
+*
+* This subroutine accepts as input an upper Hessenberg matrix
+* H and performs an orthogonal similarity transformation
+* designed to detect and deflate fully converged eigenvalues from
+* a trailing principal submatrix. On output H has been over-
+* written by a new Hessenberg matrix that is a perturbation of
+* an orthogonal similarity transformation of H. It is to be
+* hoped that the final version of H has many zero subdiagonal
+* entries.
+*
+* ******************************************************************
+* WANTT (input) LOGICAL
+* If .TRUE., then the Hessenberg matrix H is fully updated
+* so that the quasi-triangular Schur factor may be
+* computed (in cooperation with the calling subroutine).
+* If .FALSE., then only enough of H is updated to preserve
+* the eigenvalues.
+*
+* WANTZ (input) LOGICAL
+* If .TRUE., then the orthogonal matrix Z is updated so
+* so that the orthogonal Schur factor may be computed
+* (in cooperation with the calling subroutine).
+* If .FALSE., then Z is not referenced.
+*
+* N (input) INTEGER
+* The order of the matrix H and (if WANTZ is .TRUE.) the
+* order of the orthogonal matrix Z.
+*
+* KTOP (input) INTEGER
+* It is assumed that either KTOP = 1 or H(KTOP,KTOP-1)=0.
+* KBOT and KTOP together determine an isolated block
+* along the diagonal of the Hessenberg matrix.
+*
+* KBOT (input) INTEGER
+* It is assumed without a check that either
+* KBOT = N or H(KBOT+1,KBOT)=0. KBOT and KTOP together
+* determine an isolated block along the diagonal of the
+* Hessenberg matrix.
+*
+* NW (input) INTEGER
+* Deflation window size. 1 .LE. NW .LE. (KBOT-KTOP+1).
+*
+* H (input/output) REAL array, dimension (LDH,N)
+* On input the initial N-by-N section of H stores the
+* Hessenberg matrix undergoing aggressive early deflation.
+* On output H has been transformed by an orthogonal
+* similarity transformation, perturbed, and the returned
+* to Hessenberg form that (it is to be hoped) has some
+* zero subdiagonal entries.
+*
+* LDH (input) integer
+* Leading dimension of H just as declared in the calling
+* subroutine. N .LE. LDH
+*
+* ILOZ (input) INTEGER
+* IHIZ (input) INTEGER
+* Specify the rows of Z to which transformations must be
+* applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N.
+*
+* Z (input/output) REAL array, dimension (LDZ,IHI)
+* IF WANTZ is .TRUE., then on output, the orthogonal
+* similarity transformation mentioned above has been
+* accumulated into Z(ILOZ:IHIZ,ILO:IHI) from the right.
+* If WANTZ is .FALSE., then Z is unreferenced.
+*
+* LDZ (input) integer
+* The leading dimension of Z just as declared in the
+* calling subroutine. 1 .LE. LDZ.
+*
+* NS (output) integer
+* The number of unconverged (ie approximate) eigenvalues
+* returned in SR and SI that may be used as shifts by the
+* calling subroutine.
+*
+* ND (output) integer
+* The number of converged eigenvalues uncovered by this
+* subroutine.
+*
+* SR (output) REAL array, dimension KBOT
+* SI (output) REAL array, dimension KBOT
+* On output, the real and imaginary parts of approximate
+* eigenvalues that may be used for shifts are stored in
+* SR(KBOT-ND-NS+1) through SR(KBOT-ND) and
+* SI(KBOT-ND-NS+1) through SI(KBOT-ND), respectively.
+* The real and imaginary parts of converged eigenvalues
+* are stored in SR(KBOT-ND+1) through SR(KBOT) and
+* SI(KBOT-ND+1) through SI(KBOT), respectively.
+*
+* V (workspace) REAL array, dimension (LDV,NW)
+* An NW-by-NW work array.
+*
+* LDV (input) integer scalar
+* The leading dimension of V just as declared in the
+* calling subroutine. NW .LE. LDV
+*
+* NH (input) integer scalar
+* The number of columns of T. NH.GE.NW.
+*
+* T (workspace) REAL array, dimension (LDT,NW)
+*
+* LDT (input) integer
+* The leading dimension of T just as declared in the
+* calling subroutine. NW .LE. LDT
+*
+* NV (input) integer
+* The number of rows of work array WV available for
+* workspace. NV.GE.NW.
+*
+* WV (workspace) REAL array, dimension (LDWV,NW)
+*
+* LDWV (input) integer
+* The leading dimension of W just as declared in the
+* calling subroutine. NW .LE. LDV
+*
+* WORK (workspace) REAL array, dimension LWORK.
+* On exit, WORK(1) is set to an estimate of the optimal value
+* of LWORK for the given values of N, NW, KTOP and KBOT.
+*
+* LWORK (input) integer
+* The dimension of the work array WORK. LWORK = 2*NW
+* suffices, but greater efficiency may result from larger
+* values of LWORK.
+*
+* If LWORK = -1, then a workspace query is assumed; SLAQR2
+* only estimates the optimal workspace size for the given
+* values of N, NW, KTOP and KBOT. The estimate is returned
+* in WORK(1). No error message related to LWORK is issued
+* by XERBLA. Neither H nor Z are accessed.
+*
+* ================================================================
+* Based on contributions by
+* Karen Braman and Ralph Byers, Department of Mathematics,
+* University of Kansas, USA
+*
+* ==================================================================
+* .. Parameters ..
+ REAL ZERO, ONE
+ PARAMETER ( ZERO = 0.0e0, ONE = 1.0e0 )
+* ..
+* .. Local Scalars ..
+ REAL AA, BB, BETA, CC, CS, DD, EVI, EVK, FOO, S,
+ $ SAFMAX, SAFMIN, SMLNUM, SN, TAU, ULP
+ INTEGER I, IFST, ILST, INFO, INFQR, J, JW, K, KCOL,
+ $ KEND, KLN, KROW, KWTOP, LTOP, LWK1, LWK2,
+ $ LWKOPT
+ LOGICAL BULGE, SORTED
+* ..
+* .. External Functions ..
+ REAL SLAMCH
+ EXTERNAL SLAMCH
+* ..
+* .. External Subroutines ..
+ EXTERNAL SCOPY, SGEHRD, SGEMM, SLABAD, SLACPY, SLAHQR,
+ $ SLANV2, SLARF, SLARFG, SLASET, SORGHR, STREXC
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, INT, MAX, MIN, REAL, SQRT
+* ..
+* .. Executable Statements ..
+*
+* ==== Estimate optimal workspace. ====
+*
+ JW = MIN( NW, KBOT-KTOP+1 )
+ IF( JW.LE.2 ) THEN
+ LWKOPT = 1
+ ELSE
+*
+* ==== Workspace query call to SGEHRD ====
+*
+ CALL SGEHRD( JW, 1, JW-1, T, LDT, WORK, WORK, -1, INFO )
+ LWK1 = INT( WORK( 1 ) )
+*
+* ==== Workspace query call to SORGHR ====
+*
+ CALL SORGHR( JW, 1, JW-1, T, LDT, WORK, WORK, -1, INFO )
+ LWK2 = INT( WORK( 1 ) )
+*
+* ==== Optimal workspace ====
+*
+ LWKOPT = JW + MAX( LWK1, LWK2 )
+ END IF
+*
+* ==== Quick return in case of workspace query. ====
+*
+ IF( LWORK.EQ.-1 ) THEN
+ WORK( 1 ) = REAL( LWKOPT )
+ RETURN
+ END IF
+*
+* ==== Nothing to do ...
+* ... for an empty active block ... ====
+ NS = 0
+ ND = 0
+ IF( KTOP.GT.KBOT )
+ $ RETURN
+* ... nor for an empty deflation window. ====
+ IF( NW.LT.1 )
+ $ RETURN
+*
+* ==== Machine constants ====
+*
+ SAFMIN = SLAMCH( 'SAFE MINIMUM' )
+ SAFMAX = ONE / SAFMIN
+ CALL SLABAD( SAFMIN, SAFMAX )
+ ULP = SLAMCH( 'PRECISION' )
+ SMLNUM = SAFMIN*( REAL( N ) / ULP )
+*
+* ==== Setup deflation window ====
+*
+ JW = MIN( NW, KBOT-KTOP+1 )
+ KWTOP = KBOT - JW + 1
+ IF( KWTOP.EQ.KTOP ) THEN
+ S = ZERO
+ ELSE
+ S = H( KWTOP, KWTOP-1 )
+ END IF
+*
+ IF( KBOT.EQ.KWTOP ) THEN
+*
+* ==== 1-by-1 deflation window: not much to do ====
+*
+ SR( KWTOP ) = H( KWTOP, KWTOP )
+ SI( KWTOP ) = ZERO
+ NS = 1
+ ND = 0
+ IF( ABS( S ).LE.MAX( SMLNUM, ULP*ABS( H( KWTOP, KWTOP ) ) ) )
+ $ THEN
+ NS = 0
+ ND = 1
+ IF( KWTOP.GT.KTOP )
+ $ H( KWTOP, KWTOP-1 ) = ZERO
+ END IF
+ RETURN
+ END IF
+*
+* ==== Convert to spike-triangular form. (In case of a
+* . rare QR failure, this routine continues to do
+* . aggressive early deflation using that part of
+* . the deflation window that converged using INFQR
+* . here and there to keep track.) ====
+*
+ CALL SLACPY( 'U', JW, JW, H( KWTOP, KWTOP ), LDH, T, LDT )
+ CALL SCOPY( JW-1, H( KWTOP+1, KWTOP ), LDH+1, T( 2, 1 ), LDT+1 )
+*
+ CALL SLASET( 'A', JW, JW, ZERO, ONE, V, LDV )
+ CALL SLAHQR( .true., .true., JW, 1, JW, T, LDT, SR( KWTOP ),
+ $ SI( KWTOP ), 1, JW, V, LDV, INFQR )
+*
+* ==== STREXC needs a clean margin near the diagonal ====
+*
+ DO 10 J = 1, JW - 3
+ T( J+2, J ) = ZERO
+ T( J+3, J ) = ZERO
+ 10 CONTINUE
+ IF( JW.GT.2 )
+ $ T( JW, JW-2 ) = ZERO
+*
+* ==== Deflation detection loop ====
+*
+ NS = JW
+ ILST = INFQR + 1
+ 20 CONTINUE
+ IF( ILST.LE.NS ) THEN
+ IF( NS.EQ.1 ) THEN
+ BULGE = .FALSE.
+ ELSE
+ BULGE = T( NS, NS-1 ).NE.ZERO
+ END IF
+*
+* ==== Small spike tip test for deflation ====
+*
+ IF( .NOT.BULGE ) THEN
+*
+* ==== Real eigenvalue ====
+*
+ FOO = ABS( T( NS, NS ) )
+ IF( FOO.EQ.ZERO )
+ $ FOO = ABS( S )
+ IF( ABS( S*V( 1, NS ) ).LE.MAX( SMLNUM, ULP*FOO ) ) THEN
+*
+* ==== Deflatable ====
+*
+ NS = NS - 1
+ ELSE
+*
+* ==== Undeflatable. Move it up out of the way.
+* . (STREXC can not fail in this case.) ====
+*
+ IFST = NS
+ CALL STREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, WORK,
+ $ INFO )
+ ILST = ILST + 1
+ END IF
+ ELSE
+*
+* ==== Complex conjugate pair ====
+*
+ FOO = ABS( T( NS, NS ) ) + SQRT( ABS( T( NS, NS-1 ) ) )*
+ $ SQRT( ABS( T( NS-1, NS ) ) )
+ IF( FOO.EQ.ZERO )
+ $ FOO = ABS( S )
+ IF( MAX( ABS( S*V( 1, NS ) ), ABS( S*V( 1, NS-1 ) ) ).LE.
+ $ MAX( SMLNUM, ULP*FOO ) ) THEN
+*
+* ==== Deflatable ====
+*
+ NS = NS - 2
+ ELSE
+*
+* ==== Undflatable. Move them up out of the way.
+* . Fortunately, STREXC does the right thing with
+* . ILST in case of a rare exchange failure. ====
+*
+ IFST = NS
+ CALL STREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, WORK,
+ $ INFO )
+ ILST = ILST + 2
+ END IF
+ END IF
+*
+* ==== End deflation detection loop ====
+*
+ GO TO 20
+ END IF
+*
+* ==== Return to Hessenberg form ====
+*
+ IF( NS.EQ.0 )
+ $ S = ZERO
+*
+ IF( NS.LT.JW ) THEN
+*
+* ==== sorting diagonal blocks of T improves accuracy for
+* . graded matrices. Bubble sort deals well with
+* . exchange failures. ====
+*
+ SORTED = .false.
+ I = NS + 1
+ 30 CONTINUE
+ IF( SORTED )
+ $ GO TO 50
+ SORTED = .true.
+*
+ KEND = I - 1
+ I = INFQR + 1
+ IF( I.EQ.NS ) THEN
+ K = I + 1
+ ELSE IF( T( I+1, I ).EQ.ZERO ) THEN
+ K = I + 1
+ ELSE
+ K = I + 2
+ END IF
+ 40 CONTINUE
+ IF( K.LE.KEND ) THEN
+ IF( K.EQ.I+1 ) THEN
+ EVI = ABS( T( I, I ) )
+ ELSE
+ EVI = ABS( T( I, I ) ) + SQRT( ABS( T( I+1, I ) ) )*
+ $ SQRT( ABS( T( I, I+1 ) ) )
+ END IF
+*
+ IF( K.EQ.KEND ) THEN
+ EVK = ABS( T( K, K ) )
+ ELSE IF( T( K+1, K ).EQ.ZERO ) THEN
+ EVK = ABS( T( K, K ) )
+ ELSE
+ EVK = ABS( T( K, K ) ) + SQRT( ABS( T( K+1, K ) ) )*
+ $ SQRT( ABS( T( K, K+1 ) ) )
+ END IF
+*
+ IF( EVI.GE.EVK ) THEN
+ I = K
+ ELSE
+ SORTED = .false.
+ IFST = I
+ ILST = K
+ CALL STREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, WORK,
+ $ INFO )
+ IF( INFO.EQ.0 ) THEN
+ I = ILST
+ ELSE
+ I = K
+ END IF
+ END IF
+ IF( I.EQ.KEND ) THEN
+ K = I + 1
+ ELSE IF( T( I+1, I ).EQ.ZERO ) THEN
+ K = I + 1
+ ELSE
+ K = I + 2
+ END IF
+ GO TO 40
+ END IF
+ GO TO 30
+ 50 CONTINUE
+ END IF
+*
+* ==== Restore shift/eigenvalue array from T ====
+*
+ I = JW
+ 60 CONTINUE
+ IF( I.GE.INFQR+1 ) THEN
+ IF( I.EQ.INFQR+1 ) THEN
+ SR( KWTOP+I-1 ) = T( I, I )
+ SI( KWTOP+I-1 ) = ZERO
+ I = I - 1
+ ELSE IF( T( I, I-1 ).EQ.ZERO ) THEN
+ SR( KWTOP+I-1 ) = T( I, I )
+ SI( KWTOP+I-1 ) = ZERO
+ I = I - 1
+ ELSE
+ AA = T( I-1, I-1 )
+ CC = T( I, I-1 )
+ BB = T( I-1, I )
+ DD = T( I, I )
+ CALL SLANV2( AA, BB, CC, DD, SR( KWTOP+I-2 ),
+ $ SI( KWTOP+I-2 ), SR( KWTOP+I-1 ),
+ $ SI( KWTOP+I-1 ), CS, SN )
+ I = I - 2
+ END IF
+ GO TO 60
+ END IF
+*
+ IF( NS.LT.JW .OR. S.EQ.ZERO ) THEN
+ IF( NS.GT.1 .AND. S.NE.ZERO ) THEN
+*
+* ==== Reflect spike back into lower triangle ====
+*
+ CALL SCOPY( NS, V, LDV, WORK, 1 )
+ BETA = WORK( 1 )
+ CALL SLARFG( NS, BETA, WORK( 2 ), 1, TAU )
+ WORK( 1 ) = ONE
+*
+ CALL SLASET( 'L', JW-2, JW-2, ZERO, ZERO, T( 3, 1 ), LDT )
+*
+ CALL SLARF( 'L', NS, JW, WORK, 1, TAU, T, LDT,
+ $ WORK( JW+1 ) )
+ CALL SLARF( 'R', NS, NS, WORK, 1, TAU, T, LDT,
+ $ WORK( JW+1 ) )
+ CALL SLARF( 'R', JW, NS, WORK, 1, TAU, V, LDV,
+ $ WORK( JW+1 ) )
+*
+ CALL SGEHRD( JW, 1, NS, T, LDT, WORK, WORK( JW+1 ),
+ $ LWORK-JW, INFO )
+ END IF
+*
+* ==== Copy updated reduced window into place ====
+*
+ IF( KWTOP.GT.1 )
+ $ H( KWTOP, KWTOP-1 ) = S*V( 1, 1 )
+ CALL SLACPY( 'U', JW, JW, T, LDT, H( KWTOP, KWTOP ), LDH )
+ CALL SCOPY( JW-1, T( 2, 1 ), LDT+1, H( KWTOP+1, KWTOP ),
+ $ LDH+1 )
+*
+* ==== Accumulate orthogonal matrix in order update
+* . H and Z, if requested. (A modified version
+* . of SORGHR that accumulates block Householder
+* . transformations into V directly might be
+* . marginally more efficient than the following.) ====
+*
+ IF( NS.GT.1 .AND. S.NE.ZERO ) THEN
+ CALL SORGHR( JW, 1, NS, T, LDT, WORK, WORK( JW+1 ),
+ $ LWORK-JW, INFO )
+ CALL SGEMM( 'N', 'N', JW, NS, NS, ONE, V, LDV, T, LDT, ZERO,
+ $ WV, LDWV )
+ CALL SLACPY( 'A', JW, NS, WV, LDWV, V, LDV )
+ END IF
+*
+* ==== Update vertical slab in H ====
+*
+ IF( WANTT ) THEN
+ LTOP = 1
+ ELSE
+ LTOP = KTOP
+ END IF
+ DO 70 KROW = LTOP, KWTOP - 1, NV
+ KLN = MIN( NV, KWTOP-KROW )
+ CALL SGEMM( 'N', 'N', KLN, JW, JW, ONE, H( KROW, KWTOP ),
+ $ LDH, V, LDV, ZERO, WV, LDWV )
+ CALL SLACPY( 'A', KLN, JW, WV, LDWV, H( KROW, KWTOP ), LDH )
+ 70 CONTINUE
+*
+* ==== Update horizontal slab in H ====
+*
+ IF( WANTT ) THEN
+ DO 80 KCOL = KBOT + 1, N, NH
+ KLN = MIN( NH, N-KCOL+1 )
+ CALL SGEMM( 'C', 'N', JW, KLN, JW, ONE, V, LDV,
+ $ H( KWTOP, KCOL ), LDH, ZERO, T, LDT )
+ CALL SLACPY( 'A', JW, KLN, T, LDT, H( KWTOP, KCOL ),
+ $ LDH )
+ 80 CONTINUE
+ END IF
+*
+* ==== Update vertical slab in Z ====
+*
+ IF( WANTZ ) THEN
+ DO 90 KROW = ILOZ, IHIZ, NV
+ KLN = MIN( NV, IHIZ-KROW+1 )
+ CALL SGEMM( 'N', 'N', KLN, JW, JW, ONE, Z( KROW, KWTOP ),
+ $ LDZ, V, LDV, ZERO, WV, LDWV )
+ CALL SLACPY( 'A', KLN, JW, WV, LDWV, Z( KROW, KWTOP ),
+ $ LDZ )
+ 90 CONTINUE
+ END IF
+ END IF
+*
+* ==== Return the number of deflations ... ====
+*
+ ND = JW - NS
+*
+* ==== ... and the number of shifts. (Subtracting
+* . INFQR from the spike length takes care
+* . of the case of a rare QR failure while
+* . calculating eigenvalues of the deflation
+* . window.) ====
+*
+ NS = NS - INFQR
+*
+* ==== Return optimal workspace. ====
+*
+ WORK( 1 ) = REAL( LWKOPT )
+*
+* ==== End of SLAQR2 ====
+*
+ END
+ 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 )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER IHIZ, ILOZ, KBOT, KTOP, LDH, LDT, LDV, LDWV,
+ $ LDZ, LWORK, N, ND, NH, NS, NV, NW
+ LOGICAL WANTT, WANTZ
+* ..
+* .. Array Arguments ..
+ REAL H( LDH, * ), SI( * ), SR( * ), T( LDT, * ),
+ $ V( LDV, * ), WORK( * ), WV( LDWV, * ),
+ $ Z( LDZ, * )
+* ..
+*
+* ******************************************************************
+* Aggressive early deflation:
+*
+* This subroutine accepts as input an upper Hessenberg matrix
+* H and performs an orthogonal similarity transformation
+* designed to detect and deflate fully converged eigenvalues from
+* a trailing principal submatrix. On output H has been over-
+* written by a new Hessenberg matrix that is a perturbation of
+* an orthogonal similarity transformation of H. It is to be
+* hoped that the final version of H has many zero subdiagonal
+* entries.
+*
+* ******************************************************************
+* WANTT (input) LOGICAL
+* If .TRUE., then the Hessenberg matrix H is fully updated
+* so that the quasi-triangular Schur factor may be
+* computed (in cooperation with the calling subroutine).
+* If .FALSE., then only enough of H is updated to preserve
+* the eigenvalues.
+*
+* WANTZ (input) LOGICAL
+* If .TRUE., then the orthogonal matrix Z is updated so
+* so that the orthogonal Schur factor may be computed
+* (in cooperation with the calling subroutine).
+* If .FALSE., then Z is not referenced.
+*
+* N (input) INTEGER
+* The order of the matrix H and (if WANTZ is .TRUE.) the
+* order of the orthogonal matrix Z.
+*
+* KTOP (input) INTEGER
+* It is assumed that either KTOP = 1 or H(KTOP,KTOP-1)=0.
+* KBOT and KTOP together determine an isolated block
+* along the diagonal of the Hessenberg matrix.
+*
+* KBOT (input) INTEGER
+* It is assumed without a check that either
+* KBOT = N or H(KBOT+1,KBOT)=0. KBOT and KTOP together
+* determine an isolated block along the diagonal of the
+* Hessenberg matrix.
+*
+* NW (input) INTEGER
+* Deflation window size. 1 .LE. NW .LE. (KBOT-KTOP+1).
+*
+* H (input/output) REAL array, dimension (LDH,N)
+* On input the initial N-by-N section of H stores the
+* Hessenberg matrix undergoing aggressive early deflation.
+* On output H has been transformed by an orthogonal
+* similarity transformation, perturbed, and the returned
+* to Hessenberg form that (it is to be hoped) has some
+* zero subdiagonal entries.
+*
+* LDH (input) integer
+* Leading dimension of H just as declared in the calling
+* subroutine. N .LE. LDH
+*
+* ILOZ (input) INTEGER
+* IHIZ (input) INTEGER
+* Specify the rows of Z to which transformations must be
+* applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N.
+*
+* Z (input/output) REAL array, dimension (LDZ,IHI)
+* IF WANTZ is .TRUE., then on output, the orthogonal
+* similarity transformation mentioned above has been
+* accumulated into Z(ILOZ:IHIZ,ILO:IHI) from the right.
+* If WANTZ is .FALSE., then Z is unreferenced.
+*
+* LDZ (input) integer
+* The leading dimension of Z just as declared in the
+* calling subroutine. 1 .LE. LDZ.
+*
+* NS (output) integer
+* The number of unconverged (ie approximate) eigenvalues
+* returned in SR and SI that may be used as shifts by the
+* calling subroutine.
+*
+* ND (output) integer
+* The number of converged eigenvalues uncovered by this
+* subroutine.
+*
+* SR (output) REAL array, dimension KBOT
+* SI (output) REAL array, dimension KBOT
+* On output, the real and imaginary parts of approximate
+* eigenvalues that may be used for shifts are stored in
+* SR(KBOT-ND-NS+1) through SR(KBOT-ND) and
+* SI(KBOT-ND-NS+1) through SI(KBOT-ND), respectively.
+* The real and imaginary parts of converged eigenvalues
+* are stored in SR(KBOT-ND+1) through SR(KBOT) and
+* SI(KBOT-ND+1) through SI(KBOT), respectively.
+*
+* V (workspace) REAL array, dimension (LDV,NW)
+* An NW-by-NW work array.
+*
+* LDV (input) integer scalar
+* The leading dimension of V just as declared in the
+* calling subroutine. NW .LE. LDV
+*
+* NH (input) integer scalar
+* The number of columns of T. NH.GE.NW.
+*
+* T (workspace) REAL array, dimension (LDT,NW)
+*
+* LDT (input) integer
+* The leading dimension of T just as declared in the
+* calling subroutine. NW .LE. LDT
+*
+* NV (input) integer
+* The number of rows of work array WV available for
+* workspace. NV.GE.NW.
+*
+* WV (workspace) REAL array, dimension (LDWV,NW)
+*
+* LDWV (input) integer
+* The leading dimension of W just as declared in the
+* calling subroutine. NW .LE. LDV
+*
+* WORK (workspace) REAL array, dimension LWORK.
+* On exit, WORK(1) is set to an estimate of the optimal value
+* of LWORK for the given values of N, NW, KTOP and KBOT.
+*
+* LWORK (input) integer
+* The dimension of the work array WORK. LWORK = 2*NW
+* suffices, but greater efficiency may result from larger
+* values of LWORK.
+*
+* If LWORK = -1, then a workspace query is assumed; SLAQR3
+* only estimates the optimal workspace size for the given
+* values of N, NW, KTOP and KBOT. The estimate is returned
+* in WORK(1). No error message related to LWORK is issued
+* by XERBLA. Neither H nor Z are accessed.
+*
+* ================================================================
+* Based on contributions by
+* Karen Braman and Ralph Byers, Department of Mathematics,
+* University of Kansas, USA
+*
+* ==================================================================
+* .. Parameters ..
+ REAL ZERO, ONE
+ PARAMETER ( ZERO = 0.0e0, ONE = 1.0e0 )
+* ..
+* .. Local Scalars ..
+ REAL AA, BB, BETA, CC, CS, DD, EVI, EVK, FOO, S,
+ $ SAFMAX, SAFMIN, SMLNUM, SN, TAU, ULP
+ INTEGER I, IFST, ILST, INFO, INFQR, J, JW, K, KCOL,
+ $ KEND, KLN, KROW, KWTOP, LTOP, LWK1, LWK2, LWK3,
+ $ LWKOPT, NMIN
+ LOGICAL BULGE, SORTED
+* ..
+* .. External Functions ..
+ REAL SLAMCH
+ INTEGER ILAENV
+ EXTERNAL SLAMCH, ILAENV
+* ..
+* .. External Subroutines ..
+ EXTERNAL SCOPY, SGEHRD, SGEMM, SLABAD, SLACPY, SLAHQR,
+ $ SLANV2, SLAQR4, SLARF, SLARFG, SLASET, SORGHR,
+ $ STREXC
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, INT, MAX, MIN, REAL, SQRT
+* ..
+* .. Executable Statements ..
+*
+* ==== Estimate optimal workspace. ====
+*
+ JW = MIN( NW, KBOT-KTOP+1 )
+ IF( JW.LE.2 ) THEN
+ LWKOPT = 1
+ ELSE
+*
+* ==== Workspace query call to SGEHRD ====
+*
+ CALL SGEHRD( JW, 1, JW-1, T, LDT, WORK, WORK, -1, INFO )
+ LWK1 = INT( WORK( 1 ) )
+*
+* ==== Workspace query call to SORGHR ====
+*
+ CALL SORGHR( JW, 1, JW-1, T, LDT, WORK, WORK, -1, INFO )
+ LWK2 = INT( WORK( 1 ) )
+*
+* ==== Workspace query call to SLAQR4 ====
+*
+ CALL SLAQR4( .true., .true., JW, 1, JW, T, LDT, SR, SI, 1, JW,
+ $ V, LDV, WORK, -1, INFQR )
+ LWK3 = INT( WORK( 1 ) )
+*
+* ==== Optimal workspace ====
+*
+ LWKOPT = MAX( JW+MAX( LWK1, LWK2 ), LWK3 )
+ END IF
+*
+* ==== Quick return in case of workspace query. ====
+*
+ IF( LWORK.EQ.-1 ) THEN
+ WORK( 1 ) = REAL( LWKOPT )
+ RETURN
+ END IF
+*
+* ==== Nothing to do ...
+* ... for an empty active block ... ====
+ NS = 0
+ ND = 0
+ IF( KTOP.GT.KBOT )
+ $ RETURN
+* ... nor for an empty deflation window. ====
+ IF( NW.LT.1 )
+ $ RETURN
+*
+* ==== Machine constants ====
+*
+ SAFMIN = SLAMCH( 'SAFE MINIMUM' )
+ SAFMAX = ONE / SAFMIN
+ CALL SLABAD( SAFMIN, SAFMAX )
+ ULP = SLAMCH( 'PRECISION' )
+ SMLNUM = SAFMIN*( REAL( N ) / ULP )
+*
+* ==== Setup deflation window ====
+*
+ JW = MIN( NW, KBOT-KTOP+1 )
+ KWTOP = KBOT - JW + 1
+ IF( KWTOP.EQ.KTOP ) THEN
+ S = ZERO
+ ELSE
+ S = H( KWTOP, KWTOP-1 )
+ END IF
+*
+ IF( KBOT.EQ.KWTOP ) THEN
+*
+* ==== 1-by-1 deflation window: not much to do ====
+*
+ SR( KWTOP ) = H( KWTOP, KWTOP )
+ SI( KWTOP ) = ZERO
+ NS = 1
+ ND = 0
+ IF( ABS( S ).LE.MAX( SMLNUM, ULP*ABS( H( KWTOP, KWTOP ) ) ) )
+ $ THEN
+ NS = 0
+ ND = 1
+ IF( KWTOP.GT.KTOP )
+ $ H( KWTOP, KWTOP-1 ) = ZERO
+ END IF
+ RETURN
+ END IF
+*
+* ==== Convert to spike-triangular form. (In case of a
+* . rare QR failure, this routine continues to do
+* . aggressive early deflation using that part of
+* . the deflation window that converged using INFQR
+* . here and there to keep track.) ====
+*
+ CALL SLACPY( 'U', JW, JW, H( KWTOP, KWTOP ), LDH, T, LDT )
+ CALL SCOPY( JW-1, H( KWTOP+1, KWTOP ), LDH+1, T( 2, 1 ), LDT+1 )
+*
+ CALL SLASET( 'A', JW, JW, ZERO, ONE, V, LDV )
+ NMIN = ILAENV( 12, 'SLAQR3', 'SV', JW, 1, JW, LWORK )
+ IF( JW.GT.NMIN ) THEN
+ CALL SLAQR4( .true., .true., JW, 1, JW, T, LDT, SR( KWTOP ),
+ $ SI( KWTOP ), 1, JW, V, LDV, WORK, LWORK, INFQR )
+ ELSE
+ CALL SLAHQR( .true., .true., JW, 1, JW, T, LDT, SR( KWTOP ),
+ $ SI( KWTOP ), 1, JW, V, LDV, INFQR )
+ END IF
+*
+* ==== STREXC needs a clean margin near the diagonal ====
+*
+ DO 10 J = 1, JW - 3
+ T( J+2, J ) = ZERO
+ T( J+3, J ) = ZERO
+ 10 CONTINUE
+ IF( JW.GT.2 )
+ $ T( JW, JW-2 ) = ZERO
+*
+* ==== Deflation detection loop ====
+*
+ NS = JW
+ ILST = INFQR + 1
+ 20 CONTINUE
+ IF( ILST.LE.NS ) THEN
+ IF( NS.EQ.1 ) THEN
+ BULGE = .FALSE.
+ ELSE
+ BULGE = T( NS, NS-1 ).NE.ZERO
+ END IF
+*
+* ==== Small spike tip test for deflation ====
+*
+ IF( .NOT.BULGE ) THEN
+*
+* ==== Real eigenvalue ====
+*
+ FOO = ABS( T( NS, NS ) )
+ IF( FOO.EQ.ZERO )
+ $ FOO = ABS( S )
+ IF( ABS( S*V( 1, NS ) ).LE.MAX( SMLNUM, ULP*FOO ) ) THEN
+*
+* ==== Deflatable ====
+*
+ NS = NS - 1
+ ELSE
+*
+* ==== Undeflatable. Move it up out of the way.
+* . (STREXC can not fail in this case.) ====
+*
+ IFST = NS
+ CALL STREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, WORK,
+ $ INFO )
+ ILST = ILST + 1
+ END IF
+ ELSE
+*
+* ==== Complex conjugate pair ====
+*
+ FOO = ABS( T( NS, NS ) ) + SQRT( ABS( T( NS, NS-1 ) ) )*
+ $ SQRT( ABS( T( NS-1, NS ) ) )
+ IF( FOO.EQ.ZERO )
+ $ FOO = ABS( S )
+ IF( MAX( ABS( S*V( 1, NS ) ), ABS( S*V( 1, NS-1 ) ) ).LE.
+ $ MAX( SMLNUM, ULP*FOO ) ) THEN
+*
+* ==== Deflatable ====
+*
+ NS = NS - 2
+ ELSE
+*
+* ==== Undflatable. Move them up out of the way.
+* . Fortunately, STREXC does the right thing with
+* . ILST in case of a rare exchange failure. ====
+*
+ IFST = NS
+ CALL STREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, WORK,
+ $ INFO )
+ ILST = ILST + 2
+ END IF
+ END IF
+*
+* ==== End deflation detection loop ====
+*
+ GO TO 20
+ END IF
+*
+* ==== Return to Hessenberg form ====
+*
+ IF( NS.EQ.0 )
+ $ S = ZERO
+*
+ IF( NS.LT.JW ) THEN
+*
+* ==== sorting diagonal blocks of T improves accuracy for
+* . graded matrices. Bubble sort deals well with
+* . exchange failures. ====
+*
+ SORTED = .false.
+ I = NS + 1
+ 30 CONTINUE
+ IF( SORTED )
+ $ GO TO 50
+ SORTED = .true.
+*
+ KEND = I - 1
+ I = INFQR + 1
+ IF( I.EQ.NS ) THEN
+ K = I + 1
+ ELSE IF( T( I+1, I ).EQ.ZERO ) THEN
+ K = I + 1
+ ELSE
+ K = I + 2
+ END IF
+ 40 CONTINUE
+ IF( K.LE.KEND ) THEN
+ IF( K.EQ.I+1 ) THEN
+ EVI = ABS( T( I, I ) )
+ ELSE
+ EVI = ABS( T( I, I ) ) + SQRT( ABS( T( I+1, I ) ) )*
+ $ SQRT( ABS( T( I, I+1 ) ) )
+ END IF
+*
+ IF( K.EQ.KEND ) THEN
+ EVK = ABS( T( K, K ) )
+ ELSE IF( T( K+1, K ).EQ.ZERO ) THEN
+ EVK = ABS( T( K, K ) )
+ ELSE
+ EVK = ABS( T( K, K ) ) + SQRT( ABS( T( K+1, K ) ) )*
+ $ SQRT( ABS( T( K, K+1 ) ) )
+ END IF
+*
+ IF( EVI.GE.EVK ) THEN
+ I = K
+ ELSE
+ SORTED = .false.
+ IFST = I
+ ILST = K
+ CALL STREXC( 'V', JW, T, LDT, V, LDV, IFST, ILST, WORK,
+ $ INFO )
+ IF( INFO.EQ.0 ) THEN
+ I = ILST
+ ELSE
+ I = K
+ END IF
+ END IF
+ IF( I.EQ.KEND ) THEN
+ K = I + 1
+ ELSE IF( T( I+1, I ).EQ.ZERO ) THEN
+ K = I + 1
+ ELSE
+ K = I + 2
+ END IF
+ GO TO 40
+ END IF
+ GO TO 30
+ 50 CONTINUE
+ END IF
+*
+* ==== Restore shift/eigenvalue array from T ====
+*
+ I = JW
+ 60 CONTINUE
+ IF( I.GE.INFQR+1 ) THEN
+ IF( I.EQ.INFQR+1 ) THEN
+ SR( KWTOP+I-1 ) = T( I, I )
+ SI( KWTOP+I-1 ) = ZERO
+ I = I - 1
+ ELSE IF( T( I, I-1 ).EQ.ZERO ) THEN
+ SR( KWTOP+I-1 ) = T( I, I )
+ SI( KWTOP+I-1 ) = ZERO
+ I = I - 1
+ ELSE
+ AA = T( I-1, I-1 )
+ CC = T( I, I-1 )
+ BB = T( I-1, I )
+ DD = T( I, I )
+ CALL SLANV2( AA, BB, CC, DD, SR( KWTOP+I-2 ),
+ $ SI( KWTOP+I-2 ), SR( KWTOP+I-1 ),
+ $ SI( KWTOP+I-1 ), CS, SN )
+ I = I - 2
+ END IF
+ GO TO 60
+ END IF
+*
+ IF( NS.LT.JW .OR. S.EQ.ZERO ) THEN
+ IF( NS.GT.1 .AND. S.NE.ZERO ) THEN
+*
+* ==== Reflect spike back into lower triangle ====
+*
+ CALL SCOPY( NS, V, LDV, WORK, 1 )
+ BETA = WORK( 1 )
+ CALL SLARFG( NS, BETA, WORK( 2 ), 1, TAU )
+ WORK( 1 ) = ONE
+*
+ CALL SLASET( 'L', JW-2, JW-2, ZERO, ZERO, T( 3, 1 ), LDT )
+*
+ CALL SLARF( 'L', NS, JW, WORK, 1, TAU, T, LDT,
+ $ WORK( JW+1 ) )
+ CALL SLARF( 'R', NS, NS, WORK, 1, TAU, T, LDT,
+ $ WORK( JW+1 ) )
+ CALL SLARF( 'R', JW, NS, WORK, 1, TAU, V, LDV,
+ $ WORK( JW+1 ) )
+*
+ CALL SGEHRD( JW, 1, NS, T, LDT, WORK, WORK( JW+1 ),
+ $ LWORK-JW, INFO )
+ END IF
+*
+* ==== Copy updated reduced window into place ====
+*
+ IF( KWTOP.GT.1 )
+ $ H( KWTOP, KWTOP-1 ) = S*V( 1, 1 )
+ CALL SLACPY( 'U', JW, JW, T, LDT, H( KWTOP, KWTOP ), LDH )
+ CALL SCOPY( JW-1, T( 2, 1 ), LDT+1, H( KWTOP+1, KWTOP ),
+ $ LDH+1 )
+*
+* ==== Accumulate orthogonal matrix in order update
+* . H and Z, if requested. (A modified version
+* . of SORGHR that accumulates block Householder
+* . transformations into V directly might be
+* . marginally more efficient than the following.) ====
+*
+ IF( NS.GT.1 .AND. S.NE.ZERO ) THEN
+ CALL SORGHR( JW, 1, NS, T, LDT, WORK, WORK( JW+1 ),
+ $ LWORK-JW, INFO )
+ CALL SGEMM( 'N', 'N', JW, NS, NS, ONE, V, LDV, T, LDT, ZERO,
+ $ WV, LDWV )
+ CALL SLACPY( 'A', JW, NS, WV, LDWV, V, LDV )
+ END IF
+*
+* ==== Update vertical slab in H ====
+*
+ IF( WANTT ) THEN
+ LTOP = 1
+ ELSE
+ LTOP = KTOP
+ END IF
+ DO 70 KROW = LTOP, KWTOP - 1, NV
+ KLN = MIN( NV, KWTOP-KROW )
+ CALL SGEMM( 'N', 'N', KLN, JW, JW, ONE, H( KROW, KWTOP ),
+ $ LDH, V, LDV, ZERO, WV, LDWV )
+ CALL SLACPY( 'A', KLN, JW, WV, LDWV, H( KROW, KWTOP ), LDH )
+ 70 CONTINUE
+*
+* ==== Update horizontal slab in H ====
+*
+ IF( WANTT ) THEN
+ DO 80 KCOL = KBOT + 1, N, NH
+ KLN = MIN( NH, N-KCOL+1 )
+ CALL SGEMM( 'C', 'N', JW, KLN, JW, ONE, V, LDV,
+ $ H( KWTOP, KCOL ), LDH, ZERO, T, LDT )
+ CALL SLACPY( 'A', JW, KLN, T, LDT, H( KWTOP, KCOL ),
+ $ LDH )
+ 80 CONTINUE
+ END IF
+*
+* ==== Update vertical slab in Z ====
+*
+ IF( WANTZ ) THEN
+ DO 90 KROW = ILOZ, IHIZ, NV
+ KLN = MIN( NV, IHIZ-KROW+1 )
+ CALL SGEMM( 'N', 'N', KLN, JW, JW, ONE, Z( KROW, KWTOP ),
+ $ LDZ, V, LDV, ZERO, WV, LDWV )
+ CALL SLACPY( 'A', KLN, JW, WV, LDWV, Z( KROW, KWTOP ),
+ $ LDZ )
+ 90 CONTINUE
+ END IF
+ END IF
+*
+* ==== Return the number of deflations ... ====
+*
+ ND = JW - NS
+*
+* ==== ... and the number of shifts. (Subtracting
+* . INFQR from the spike length takes care
+* . of the case of a rare QR failure while
+* . calculating eigenvalues of the deflation
+* . window.) ====
+*
+ NS = NS - INFQR
+*
+* ==== Return optimal workspace. ====
+*
+ WORK( 1 ) = REAL( LWKOPT )
+*
+* ==== End of SLAQR3 ====
+*
+ END
+ SUBROUTINE SLAQR4( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI,
+ $ ILOZ, IHIZ, Z, LDZ, WORK, LWORK, INFO )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER IHI, IHIZ, ILO, ILOZ, INFO, LDH, LDZ, LWORK, N
+ LOGICAL WANTT, WANTZ
+* ..
+* .. Array Arguments ..
+ REAL H( LDH, * ), WI( * ), WORK( * ), WR( * ),
+ $ Z( LDZ, * )
+* ..
+*
+* This subroutine implements one level of recursion for SLAQR0.
+* It is a complete implementation of the small bulge multi-shift
+* QR algorithm. It may be called by SLAQR0 and, for large enough
+* deflation window size, it may be called by SLAQR3. This
+* subroutine is identical to SLAQR0 except that it calls SLAQR2
+* instead of SLAQR3.
+*
+* Purpose
+* =======
+*
+* SLAQR4 computes the eigenvalues of a Hessenberg matrix H
+* and, optionally, the matrices T and Z from the Schur decomposition
+* H = Z T Z**T, where T is an upper quasi-triangular matrix (the
+* Schur form), and Z is the orthogonal matrix of Schur vectors.
+*
+* Optionally Z may be postmultiplied into an input orthogonal
+* matrix Q so that this routine can give the Schur factorization
+* of a matrix A which has been reduced to the Hessenberg form H
+* by the orthogonal matrix Q: A = Q*H*Q**T = (QZ)*T*(QZ)**T.
+*
+* Arguments
+* =========
+*
+* WANTT (input) LOGICAL
+* = .TRUE. : the full Schur form T is required;
+* = .FALSE.: only eigenvalues are required.
+*
+* WANTZ (input) LOGICAL
+* = .TRUE. : the matrix of Schur vectors Z is required;
+* = .FALSE.: Schur vectors are not required.
+*
+* N (input) INTEGER
+* The order of the matrix H. N .GE. 0.
+*
+* ILO (input) INTEGER
+* IHI (input) INTEGER
+* It is assumed that H is already upper triangular in rows
+* and columns 1:ILO-1 and IHI+1:N and, if ILO.GT.1,
+* H(ILO,ILO-1) is zero. ILO and IHI are normally set by a
+* previous call to SGEBAL, and then passed to SGEHRD when the
+* matrix output by SGEBAL is reduced to Hessenberg form.
+* Otherwise, ILO and IHI should be set to 1 and N,
+* respectively. If N.GT.0, then 1.LE.ILO.LE.IHI.LE.N.
+* If N = 0, then ILO = 1 and IHI = 0.
+*
+* H (input/output) REAL array, dimension (LDH,N)
+* On entry, the upper Hessenberg matrix H.
+* On exit, if INFO = 0 and WANTT is .TRUE., then H contains
+* the upper quasi-triangular matrix T from the Schur
+* decomposition (the Schur form); 2-by-2 diagonal blocks
+* (corresponding to complex conjugate pairs of eigenvalues)
+* are returned in standard form, with H(i,i) = H(i+1,i+1)
+* and H(i+1,i)*H(i,i+1).LT.0. If INFO = 0 and WANTT is
+* .FALSE., then the contents of H are unspecified on exit.
+* (The output value of H when INFO.GT.0 is given under the
+* description of INFO below.)
+*
+* This subroutine may explicitly set H(i,j) = 0 for i.GT.j and
+* j = 1, 2, ... ILO-1 or j = IHI+1, IHI+2, ... N.
+*
+* LDH (input) INTEGER
+* The leading dimension of the array H. LDH .GE. max(1,N).
+*
+* WR (output) REAL array, dimension (IHI)
+* WI (output) REAL array, dimension (IHI)
+* The real and imaginary parts, respectively, of the computed
+* eigenvalues of H(ILO:IHI,ILO:IHI) are stored WR(ILO:IHI)
+* and WI(ILO:IHI). If two eigenvalues are computed as a
+* complex conjugate pair, they are stored in consecutive
+* elements of WR and WI, say the i-th and (i+1)th, with
+* WI(i) .GT. 0 and WI(i+1) .LT. 0. If WANTT is .TRUE., then
+* the eigenvalues are stored in the same order as on the
+* diagonal of the Schur form returned in H, with
+* WR(i) = H(i,i) and, if H(i:i+1,i:i+1) is a 2-by-2 diagonal
+* block, WI(i) = sqrt(-H(i+1,i)*H(i,i+1)) and
+* WI(i+1) = -WI(i).
+*
+* ILOZ (input) INTEGER
+* IHIZ (input) INTEGER
+* Specify the rows of Z to which transformations must be
+* applied if WANTZ is .TRUE..
+* 1 .LE. ILOZ .LE. ILO; IHI .LE. IHIZ .LE. N.
+*
+* Z (input/output) REAL array, dimension (LDZ,IHI)
+* If WANTZ is .FALSE., then Z is not referenced.
+* If WANTZ is .TRUE., then Z(ILO:IHI,ILOZ:IHIZ) is
+* replaced by Z(ILO:IHI,ILOZ:IHIZ)*U where U is the
+* orthogonal Schur factor of H(ILO:IHI,ILO:IHI).
+* (The output value of Z when INFO.GT.0 is given under
+* the description of INFO below.)
+*
+* LDZ (input) INTEGER
+* The leading dimension of the array Z. if WANTZ is .TRUE.
+* then LDZ.GE.MAX(1,IHIZ). Otherwize, LDZ.GE.1.
+*
+* WORK (workspace/output) REAL array, dimension LWORK
+* On exit, if LWORK = -1, WORK(1) returns an estimate of
+* the optimal value for LWORK.
+*
+* LWORK (input) INTEGER
+* The dimension of the array WORK. LWORK .GE. max(1,N)
+* is sufficient, but LWORK typically as large as 6*N may
+* be required for optimal performance. A workspace query
+* to determine the optimal workspace size is recommended.
+*
+* If LWORK = -1, then SLAQR4 does a workspace query.
+* In this case, SLAQR4 checks the input parameters and
+* estimates the optimal workspace size for the given
+* values of N, ILO and IHI. The estimate is returned
+* in WORK(1). No error message related to LWORK is
+* issued by XERBLA. Neither H nor Z are accessed.
+*
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* .GT. 0: if INFO = i, SLAQR4 failed to compute all of
+* the eigenvalues. Elements 1:ilo-1 and i+1:n of WR
+* and WI contain those eigenvalues which have been
+* successfully computed. (Failures are rare.)
+*
+* If INFO .GT. 0 and WANT is .FALSE., then on exit,
+* the remaining unconverged eigenvalues are the eigen-
+* values of the upper Hessenberg matrix rows and
+* columns ILO through INFO of the final, output
+* value of H.
+*
+* If INFO .GT. 0 and WANTT is .TRUE., then on exit
+*
+* (*) (initial value of H)*U = U*(final value of H)
+*
+* where U is an orthogonal matrix. The final
+* value of H is upper Hessenberg and quasi-triangular
+* in rows and columns INFO+1 through IHI.
+*
+* If INFO .GT. 0 and WANTZ is .TRUE., then on exit
+*
+* (final value of Z(ILO:IHI,ILOZ:IHIZ)
+* = (initial value of Z(ILO:IHI,ILOZ:IHIZ)*U
+*
+* where U is the orthogonal matrix in (*) (regard-
+* less of the value of WANTT.)
+*
+* If INFO .GT. 0 and WANTZ is .FALSE., then Z is not
+* accessed.
+*
+* ================================================================
+* Based on contributions by
+* Karen Braman and Ralph Byers, Department of Mathematics,
+* University of Kansas, USA
+*
+* ================================================================
+* References:
+* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR
+* Algorithm Part I: Maintaining Well Focused Shifts, and Level 3
+* Performance, SIAM Journal of Matrix Analysis, volume 23, pages
+* 929--947, 2002.
+*
+* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR
+* Algorithm Part II: Aggressive Early Deflation, SIAM Journal
+* of Matrix Analysis, volume 23, pages 948--973, 2002.
+*
+* ================================================================
+* .. Parameters ..
+*
+* ==== Matrices of order NTINY or smaller must be processed by
+* . SLAHQR because of insufficient subdiagonal scratch space.
+* . (This is a hard limit.) ====
+*
+* ==== Exceptional deflation windows: try to cure rare
+* . slow convergence by increasing the size of the
+* . deflation window after KEXNW iterations. =====
+*
+* ==== Exceptional shifts: try to cure rare slow convergence
+* . with ad-hoc exceptional shifts every KEXSH iterations.
+* . The constants WILK1 and WILK2 are used to form the
+* . exceptional shifts. ====
+*
+ INTEGER NTINY
+ PARAMETER ( NTINY = 11 )
+ INTEGER KEXNW, KEXSH
+ PARAMETER ( KEXNW = 5, KEXSH = 6 )
+ REAL WILK1, WILK2
+ PARAMETER ( WILK1 = 0.75e0, WILK2 = -0.4375e0 )
+ REAL ZERO, ONE
+ PARAMETER ( ZERO = 0.0e0, ONE = 1.0e0 )
+* ..
+* .. Local Scalars ..
+ REAL AA, BB, CC, CS, DD, SN, SS, SWAP
+ INTEGER I, INF, IT, ITMAX, K, KACC22, KBOT, KDU, KS,
+ $ KT, KTOP, KU, KV, KWH, KWTOP, KWV, LD, LS,
+ $ LWKOPT, NDFL, NH, NHO, NIBBLE, NMIN, NS, NSMAX,
+ $ NSR, NVE, NW, NWMAX, NWR
+ LOGICAL NWINC, SORTED
+ CHARACTER JBCMPZ*2
+* ..
+* .. External Functions ..
+ INTEGER ILAENV
+ EXTERNAL ILAENV
+* ..
+* .. Local Arrays ..
+ REAL ZDUM( 1, 1 )
+* ..
+* .. External Subroutines ..
+ EXTERNAL SLACPY, SLAHQR, SLANV2, SLAQR2, SLAQR5
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, INT, MAX, MIN, MOD, REAL
+* ..
+* .. Executable Statements ..
+ INFO = 0
+*
+* ==== Quick return for N = 0: nothing to do. ====
+*
+ IF( N.EQ.0 ) THEN
+ WORK( 1 ) = ONE
+ RETURN
+ END IF
+*
+* ==== Set up job flags for ILAENV. ====
+*
+ IF( WANTT ) THEN
+ JBCMPZ( 1: 1 ) = 'S'
+ ELSE
+ JBCMPZ( 1: 1 ) = 'E'
+ END IF
+ IF( WANTZ ) THEN
+ JBCMPZ( 2: 2 ) = 'V'
+ ELSE
+ JBCMPZ( 2: 2 ) = 'N'
+ END IF
+*
+* ==== Tiny matrices must use SLAHQR. ====
+*
+ IF( N.LE.NTINY ) THEN
+*
+* ==== Estimate optimal workspace. ====
+*
+ LWKOPT = 1
+ IF( LWORK.NE.-1 )
+ $ CALL SLAHQR( WANTT, WANTZ, N, ILO, IHI, H, LDH, WR, WI,
+ $ ILOZ, IHIZ, Z, LDZ, INFO )
+ ELSE
+*
+* ==== Use small bulge multi-shift QR with aggressive early
+* . deflation on larger-than-tiny matrices. ====
+*
+* ==== Hope for the best. ====
+*
+ INFO = 0
+*
+* ==== NWR = recommended deflation window size. At this
+* . point, N .GT. NTINY = 11, so there is enough
+* . subdiagonal workspace for NWR.GE.2 as required.
+* . (In fact, there is enough subdiagonal space for
+* . NWR.GE.3.) ====
+*
+ NWR = ILAENV( 13, 'SLAQR4', JBCMPZ, N, ILO, IHI, LWORK )
+ NWR = MAX( 2, NWR )
+ NWR = MIN( IHI-ILO+1, ( N-1 ) / 3, NWR )
+ NW = NWR
+*
+* ==== NSR = recommended number of simultaneous shifts.
+* . At this point N .GT. NTINY = 11, so there is at
+* . enough subdiagonal workspace for NSR to be even
+* . and greater than or equal to two as required. ====
+*
+ NSR = ILAENV( 15, 'SLAQR4', JBCMPZ, N, ILO, IHI, LWORK )
+ NSR = MIN( NSR, ( N+6 ) / 9, IHI-ILO )
+ NSR = MAX( 2, NSR-MOD( NSR, 2 ) )
+*
+* ==== Estimate optimal workspace ====
+*
+* ==== Workspace query call to SLAQR2 ====
+*
+ CALL SLAQR2( WANTT, WANTZ, N, ILO, IHI, NWR+1, H, LDH, ILOZ,
+ $ IHIZ, Z, LDZ, LS, LD, WR, WI, H, LDH, N, H, LDH,
+ $ N, H, LDH, WORK, -1 )
+*
+* ==== Optimal workspace = MAX(SLAQR5, SLAQR2) ====
+*
+ LWKOPT = MAX( 3*NSR / 2, INT( WORK( 1 ) ) )
+*
+* ==== Quick return in case of workspace query. ====
+*
+ IF( LWORK.EQ.-1 ) THEN
+ WORK( 1 ) = REAL( LWKOPT )
+ RETURN
+ END IF
+*
+* ==== SLAHQR/SLAQR0 crossover point ====
+*
+ NMIN = ILAENV( 12, 'SLAQR4', JBCMPZ, N, ILO, IHI, LWORK )
+ NMIN = MAX( NTINY, NMIN )
+*
+* ==== Nibble crossover point ====
+*
+ NIBBLE = ILAENV( 14, 'SLAQR4', JBCMPZ, N, ILO, IHI, LWORK )
+ NIBBLE = MAX( 0, NIBBLE )
+*
+* ==== Accumulate reflections during ttswp? Use block
+* . 2-by-2 structure during matrix-matrix multiply? ====
+*
+ KACC22 = ILAENV( 16, 'SLAQR4', JBCMPZ, N, ILO, IHI, LWORK )
+ KACC22 = MAX( 0, KACC22 )
+ KACC22 = MIN( 2, KACC22 )
+*
+* ==== NWMAX = the largest possible deflation window for
+* . which there is sufficient workspace. ====
+*
+ NWMAX = MIN( ( N-1 ) / 3, LWORK / 2 )
+*
+* ==== NSMAX = the Largest number of simultaneous shifts
+* . for which there is sufficient workspace. ====
+*
+ NSMAX = MIN( ( N+6 ) / 9, 2*LWORK / 3 )
+ NSMAX = NSMAX - MOD( NSMAX, 2 )
+*
+* ==== NDFL: an iteration count restarted at deflation. ====
+*
+ NDFL = 1
+*
+* ==== ITMAX = iteration limit ====
+*
+ ITMAX = MAX( 30, 2*KEXSH )*MAX( 10, ( IHI-ILO+1 ) )
+*
+* ==== Last row and column in the active block ====
+*
+ KBOT = IHI
+*
+* ==== Main Loop ====
+*
+ DO 80 IT = 1, ITMAX
+*
+* ==== Done when KBOT falls below ILO ====
+*
+ IF( KBOT.LT.ILO )
+ $ GO TO 90
+*
+* ==== Locate active block ====
+*
+ DO 10 K = KBOT, ILO + 1, -1
+ IF( H( K, K-1 ).EQ.ZERO )
+ $ GO TO 20
+ 10 CONTINUE
+ K = ILO
+ 20 CONTINUE
+ KTOP = K
+*
+* ==== Select deflation window size ====
+*
+ NH = KBOT - KTOP + 1
+ IF( NDFL.LT.KEXNW .OR. NH.LT.NW ) THEN
+*
+* ==== Typical deflation window. If possible and
+* . advisable, nibble the entire active block.
+* . If not, use size NWR or NWR+1 depending upon
+* . which has the smaller corresponding subdiagonal
+* . entry (a heuristic). ====
+*
+ NWINC = .TRUE.
+ IF( NH.LE.MIN( NMIN, NWMAX ) ) THEN
+ NW = NH
+ ELSE
+ NW = MIN( NWR, NH, NWMAX )
+ IF( NW.LT.NWMAX ) THEN
+ IF( NW.GE.NH-1 ) THEN
+ NW = NH
+ ELSE
+ KWTOP = KBOT - NW + 1
+ IF( ABS( H( KWTOP, KWTOP-1 ) ).GT.
+ $ ABS( H( KWTOP-1, KWTOP-2 ) ) )NW = NW + 1
+ END IF
+ END IF
+ END IF
+ ELSE
+*
+* ==== Exceptional deflation window. If there have
+* . been no deflations in KEXNW or more iterations,
+* . then vary the deflation window size. At first,
+* . because, larger windows are, in general, more
+* . powerful than smaller ones, rapidly increase the
+* . window up to the maximum reasonable and possible.
+* . Then maybe try a slightly smaller window. ====
+*
+ IF( NWINC .AND. NW.LT.MIN( NWMAX, NH ) ) THEN
+ NW = MIN( NWMAX, NH, 2*NW )
+ ELSE
+ NWINC = .FALSE.
+ IF( NW.EQ.NH .AND. NH.GT.2 )
+ $ NW = NH - 1
+ END IF
+ END IF
+*
+* ==== Aggressive early deflation:
+* . split workspace under the subdiagonal into
+* . - an nw-by-nw work array V in the lower
+* . left-hand-corner,
+* . - an NW-by-at-least-NW-but-more-is-better
+* . (NW-by-NHO) horizontal work array along
+* . the bottom edge,
+* . - an at-least-NW-but-more-is-better (NHV-by-NW)
+* . vertical work array along the left-hand-edge.
+* . ====
+*
+ KV = N - NW + 1
+ KT = NW + 1
+ NHO = ( N-NW-1 ) - KT + 1
+ KWV = NW + 2
+ NVE = ( N-NW ) - KWV + 1
+*
+* ==== Aggressive early deflation ====
+*
+ CALL SLAQR2( WANTT, WANTZ, N, KTOP, KBOT, NW, H, LDH, ILOZ,
+ $ IHIZ, Z, LDZ, LS, LD, WR, WI, H( KV, 1 ), LDH,
+ $ NHO, H( KV, KT ), LDH, NVE, H( KWV, 1 ), LDH,
+ $ WORK, LWORK )
+*
+* ==== Adjust KBOT accounting for new deflations. ====
+*
+ KBOT = KBOT - LD
+*
+* ==== KS points to the shifts. ====
+*
+ KS = KBOT - LS + 1
+*
+* ==== Skip an expensive QR sweep if there is a (partly
+* . heuristic) reason to expect that many eigenvalues
+* . will deflate without it. Here, the QR sweep is
+* . skipped if many eigenvalues have just been deflated
+* . or if the remaining active block is small.
+*
+ IF( ( LD.EQ.0 ) .OR. ( ( 100*LD.LE.NW*NIBBLE ) .AND. ( KBOT-
+ $ KTOP+1.GT.MIN( NMIN, NWMAX ) ) ) ) THEN
+*
+* ==== NS = nominal number of simultaneous shifts.
+* . This may be lowered (slightly) if SLAQR2
+* . did not provide that many shifts. ====
+*
+ NS = MIN( NSMAX, NSR, MAX( 2, KBOT-KTOP ) )
+ NS = NS - MOD( NS, 2 )
+*
+* ==== If there have been no deflations
+* . in a multiple of KEXSH iterations,
+* . then try exceptional shifts.
+* . Otherwise use shifts provided by
+* . SLAQR2 above or from the eigenvalues
+* . of a trailing principal submatrix. ====
+*
+ IF( MOD( NDFL, KEXSH ).EQ.0 ) THEN
+ KS = KBOT - NS + 1
+ DO 30 I = KBOT, MAX( KS+1, KTOP+2 ), -2
+ SS = ABS( H( I, I-1 ) ) + ABS( H( I-1, I-2 ) )
+ AA = WILK1*SS + H( I, I )
+ BB = SS
+ CC = WILK2*SS
+ DD = AA
+ CALL SLANV2( AA, BB, CC, DD, WR( I-1 ), WI( I-1 ),
+ $ WR( I ), WI( I ), CS, SN )
+ 30 CONTINUE
+ IF( KS.EQ.KTOP ) THEN
+ WR( KS+1 ) = H( KS+1, KS+1 )
+ WI( KS+1 ) = ZERO
+ WR( KS ) = WR( KS+1 )
+ WI( KS ) = WI( KS+1 )
+ END IF
+ ELSE
+*
+* ==== Got NS/2 or fewer shifts? Use SLAHQR
+* . on a trailing principal submatrix to
+* . get more. (Since NS.LE.NSMAX.LE.(N+6)/9,
+* . there is enough space below the subdiagonal
+* . to fit an NS-by-NS scratch array.) ====
+*
+ IF( KBOT-KS+1.LE.NS / 2 ) THEN
+ KS = KBOT - NS + 1
+ KT = N - NS + 1
+ CALL SLACPY( 'A', NS, NS, H( KS, KS ), LDH,
+ $ H( KT, 1 ), LDH )
+ CALL SLAHQR( .false., .false., NS, 1, NS,
+ $ H( KT, 1 ), LDH, WR( KS ), WI( KS ),
+ $ 1, 1, ZDUM, 1, INF )
+ KS = KS + INF
+*
+* ==== In case of a rare QR failure use
+* . eigenvalues of the trailing 2-by-2
+* . principal submatrix. ====
+*
+ IF( KS.GE.KBOT ) THEN
+ AA = H( KBOT-1, KBOT-1 )
+ CC = H( KBOT, KBOT-1 )
+ BB = H( KBOT-1, KBOT )
+ DD = H( KBOT, KBOT )
+ CALL SLANV2( AA, BB, CC, DD, WR( KBOT-1 ),
+ $ WI( KBOT-1 ), WR( KBOT ),
+ $ WI( KBOT ), CS, SN )
+ KS = KBOT - 1
+ END IF
+ END IF
+*
+ IF( KBOT-KS+1.GT.NS ) THEN
+*
+* ==== Sort the shifts (Helps a little)
+* . Bubble sort keeps complex conjugate
+* . pairs together. ====
+*
+ SORTED = .false.
+ DO 50 K = KBOT, KS + 1, -1
+ IF( SORTED )
+ $ GO TO 60
+ SORTED = .true.
+ DO 40 I = KS, K - 1
+ IF( ABS( WR( I ) )+ABS( WI( I ) ).LT.
+ $ ABS( WR( I+1 ) )+ABS( WI( I+1 ) ) ) THEN
+ SORTED = .false.
+*
+ SWAP = WR( I )
+ WR( I ) = WR( I+1 )
+ WR( I+1 ) = SWAP
+*
+ SWAP = WI( I )
+ WI( I ) = WI( I+1 )
+ WI( I+1 ) = SWAP
+ END IF
+ 40 CONTINUE
+ 50 CONTINUE
+ 60 CONTINUE
+ END IF
+*
+* ==== Shuffle shifts into pairs of real shifts
+* . and pairs of complex conjugate shifts
+* . assuming complex conjugate shifts are
+* . already adjacent to one another. (Yes,
+* . they are.) ====
+*
+ DO 70 I = KBOT, KS + 2, -2
+ IF( WI( I ).NE.-WI( I-1 ) ) THEN
+*
+ SWAP = WR( I )
+ WR( I ) = WR( I-1 )
+ WR( I-1 ) = WR( I-2 )
+ WR( I-2 ) = SWAP
+*
+ SWAP = WI( I )
+ WI( I ) = WI( I-1 )
+ WI( I-1 ) = WI( I-2 )
+ WI( I-2 ) = SWAP
+ END IF
+ 70 CONTINUE
+ END IF
+*
+* ==== If there are only two shifts and both are
+* . real, then use only one. ====
+*
+ IF( KBOT-KS+1.EQ.2 ) THEN
+ IF( WI( KBOT ).EQ.ZERO ) THEN
+ IF( ABS( WR( KBOT )-H( KBOT, KBOT ) ).LT.
+ $ ABS( WR( KBOT-1 )-H( KBOT, KBOT ) ) ) THEN
+ WR( KBOT-1 ) = WR( KBOT )
+ ELSE
+ WR( KBOT ) = WR( KBOT-1 )
+ END IF
+ END IF
+ END IF
+*
+* ==== Use up to NS of the the smallest magnatiude
+* . shifts. If there aren't NS shifts available,
+* . then use them all, possibly dropping one to
+* . make the number of shifts even. ====
+*
+ NS = MIN( NS, KBOT-KS+1 )
+ NS = NS - MOD( NS, 2 )
+ KS = KBOT - NS + 1
+*
+* ==== Small-bulge multi-shift QR sweep:
+* . split workspace under the subdiagonal into
+* . - a KDU-by-KDU work array U in the lower
+* . left-hand-corner,
+* . - a KDU-by-at-least-KDU-but-more-is-better
+* . (KDU-by-NHo) horizontal work array WH along
+* . the bottom edge,
+* . - and an at-least-KDU-but-more-is-better-by-KDU
+* . (NVE-by-KDU) vertical work WV arrow along
+* . the left-hand-edge. ====
+*
+ KDU = 3*NS - 3
+ KU = N - KDU + 1
+ KWH = KDU + 1
+ NHO = ( N-KDU+1-4 ) - ( KDU+1 ) + 1
+ KWV = KDU + 4
+ NVE = N - KDU - KWV + 1
+*
+* ==== Small-bulge multi-shift QR sweep ====
+*
+ CALL SLAQR5( WANTT, WANTZ, KACC22, N, KTOP, KBOT, NS,
+ $ WR( KS ), WI( KS ), H, LDH, ILOZ, IHIZ, Z,
+ $ LDZ, WORK, 3, H( KU, 1 ), LDH, NVE,
+ $ H( KWV, 1 ), LDH, NHO, H( KU, KWH ), LDH )
+ END IF
+*
+* ==== Note progress (or the lack of it). ====
+*
+ IF( LD.GT.0 ) THEN
+ NDFL = 1
+ ELSE
+ NDFL = NDFL + 1
+ END IF
+*
+* ==== End of main loop ====
+ 80 CONTINUE
+*
+* ==== Iteration limit exceeded. Set INFO to show where
+* . the problem occurred and exit. ====
+*
+ INFO = KBOT
+ 90 CONTINUE
+ END IF
+*
+* ==== Return the optimal value of LWORK. ====
+*
+ WORK( 1 ) = REAL( LWKOPT )
+*
+* ==== End of SLAQR4 ====
+*
+ END
+ 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 )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER IHIZ, ILOZ, KACC22, KBOT, KTOP, LDH, LDU, LDV,
+ $ LDWH, LDWV, LDZ, N, NH, NSHFTS, NV
+ LOGICAL WANTT, WANTZ
+* ..
+* .. Array Arguments ..
+ REAL H( LDH, * ), SI( * ), SR( * ), U( LDU, * ),
+ $ V( LDV, * ), WH( LDWH, * ), WV( LDWV, * ),
+ $ Z( LDZ, * )
+* ..
+*
+* This auxiliary subroutine called by SLAQR0 performs a
+* single small-bulge multi-shift QR sweep.
+*
+* WANTT (input) logical scalar
+* WANTT = .true. if the quasi-triangular Schur factor
+* is being computed. WANTT is set to .false. otherwise.
+*
+* WANTZ (input) logical scalar
+* WANTZ = .true. if the orthogonal Schur factor is being
+* computed. WANTZ is set to .false. otherwise.
+*
+* KACC22 (input) integer with value 0, 1, or 2.
+* Specifies the computation mode of far-from-diagonal
+* orthogonal updates.
+* = 0: SLAQR5 does not accumulate reflections and does not
+* use matrix-matrix multiply to update far-from-diagonal
+* matrix entries.
+* = 1: SLAQR5 accumulates reflections and uses matrix-matrix
+* multiply to update the far-from-diagonal matrix entries.
+* = 2: SLAQR5 accumulates reflections, uses matrix-matrix
+* multiply to update the far-from-diagonal matrix entries,
+* and takes advantage of 2-by-2 block structure during
+* matrix multiplies.
+*
+* N (input) integer scalar
+* N is the order of the Hessenberg matrix H upon which this
+* subroutine operates.
+*
+* KTOP (input) integer scalar
+* KBOT (input) integer scalar
+* These are the first and last rows and columns of an
+* isolated diagonal block upon which the QR sweep is to be
+* applied. It is assumed without a check that
+* either KTOP = 1 or H(KTOP,KTOP-1) = 0
+* and
+* either KBOT = N or H(KBOT+1,KBOT) = 0.
+*
+* NSHFTS (input) integer scalar
+* NSHFTS gives the number of simultaneous shifts. NSHFTS
+* must be positive and even.
+*
+* SR (input) REAL array of size (NSHFTS)
+* SI (input) REAL array of size (NSHFTS)
+* SR contains the real parts and SI contains the imaginary
+* parts of the NSHFTS shifts of origin that define the
+* multi-shift QR sweep.
+*
+* H (input/output) REAL array of size (LDH,N)
+* On input H contains a Hessenberg matrix. On output a
+* multi-shift QR sweep with shifts SR(J)+i*SI(J) is applied
+* to the isolated diagonal block in rows and columns KTOP
+* through KBOT.
+*
+* LDH (input) integer scalar
+* LDH is the leading dimension of H just as declared in the
+* calling procedure. LDH.GE.MAX(1,N).
+*
+* ILOZ (input) INTEGER
+* IHIZ (input) INTEGER
+* Specify the rows of Z to which transformations must be
+* applied if WANTZ is .TRUE.. 1 .LE. ILOZ .LE. IHIZ .LE. N
+*
+* Z (input/output) REAL array of size (LDZ,IHI)
+* If WANTZ = .TRUE., then the QR Sweep orthogonal
+* similarity transformation is accumulated into
+* Z(ILOZ:IHIZ,ILO:IHI) from the right.
+* If WANTZ = .FALSE., then Z is unreferenced.
+*
+* LDZ (input) integer scalar
+* LDA is the leading dimension of Z just as declared in
+* the calling procedure. LDZ.GE.N.
+*
+* V (workspace) REAL array of size (LDV,NSHFTS/2)
+*
+* LDV (input) integer scalar
+* LDV is the leading dimension of V as declared in the
+* calling procedure. LDV.GE.3.
+*
+* U (workspace) REAL array of size
+* (LDU,3*NSHFTS-3)
+*
+* LDU (input) integer scalar
+* LDU is the leading dimension of U just as declared in the
+* in the calling subroutine. LDU.GE.3*NSHFTS-3.
+*
+* NH (input) integer scalar
+* NH is the number of columns in array WH available for
+* workspace. NH.GE.1.
+*
+* WH (workspace) REAL array of size (LDWH,NH)
+*
+* LDWH (input) integer scalar
+* Leading dimension of WH just as declared in the
+* calling procedure. LDWH.GE.3*NSHFTS-3.
+*
+* NV (input) integer scalar
+* NV is the number of rows in WV agailable for workspace.
+* NV.GE.1.
+*
+* WV (workspace) REAL array of size
+* (LDWV,3*NSHFTS-3)
+*
+* LDWV (input) integer scalar
+* LDWV is the leading dimension of WV as declared in the
+* in the calling subroutine. LDWV.GE.NV.
+*
+*
+* ================================================================
+* Based on contributions by
+* Karen Braman and Ralph Byers, Department of Mathematics,
+* University of Kansas, USA
+*
+* ============================================================
+* Reference:
+*
+* K. Braman, R. Byers and R. Mathias, The Multi-Shift QR
+* Algorithm Part I: Maintaining Well Focused Shifts, and
+* Level 3 Performance, SIAM Journal of Matrix Analysis,
+* volume 23, pages 929--947, 2002.
+*
+* ============================================================
+* .. Parameters ..
+ REAL ZERO, ONE
+ PARAMETER ( ZERO = 0.0e0, ONE = 1.0e0 )
+* ..
+* .. Local Scalars ..
+ REAL ALPHA, BETA, H11, H12, H21, H22, REFSUM,
+ $ SAFMAX, SAFMIN, SCL, SMLNUM, SWAP, TST1, TST2,
+ $ ULP
+ INTEGER I, I2, I4, INCOL, J, J2, J4, JBOT, JCOL, JLEN,
+ $ JROW, JTOP, K, K1, KDU, KMS, KNZ, KRCOL, KZS,
+ $ M, M22, MBOT, MEND, MSTART, MTOP, NBMPS, NDCOL,
+ $ NS, NU
+ LOGICAL ACCUM, BLK22, BMP22
+* ..
+* .. External Functions ..
+ REAL SLAMCH
+ EXTERNAL SLAMCH
+* ..
+* .. Intrinsic Functions ..
+*
+ INTRINSIC ABS, MAX, MIN, MOD, REAL
+* ..
+* .. Local Arrays ..
+ REAL VT( 3 )
+* ..
+* .. External Subroutines ..
+ EXTERNAL SGEMM, SLABAD, SLACPY, SLAQR1, SLARFG, SLASET,
+ $ STRMM
+* ..
+* .. Executable Statements ..
+*
+* ==== If there are no shifts, then there is nothing to do. ====
+*
+ IF( NSHFTS.LT.2 )
+ $ RETURN
+*
+* ==== If the active block is empty or 1-by-1, then there
+* . is nothing to do. ====
+*
+ IF( KTOP.GE.KBOT )
+ $ RETURN
+*
+* ==== Shuffle shifts into pairs of real shifts and pairs
+* . of complex conjugate shifts assuming complex
+* . conjugate shifts are already adjacent to one
+* . another. ====
+*
+ DO 10 I = 1, NSHFTS - 2, 2
+ IF( SI( I ).NE.-SI( I+1 ) ) THEN
+*
+ SWAP = SR( I )
+ SR( I ) = SR( I+1 )
+ SR( I+1 ) = SR( I+2 )
+ SR( I+2 ) = SWAP
+*
+ SWAP = SI( I )
+ SI( I ) = SI( I+1 )
+ SI( I+1 ) = SI( I+2 )
+ SI( I+2 ) = SWAP
+ END IF
+ 10 CONTINUE
+*
+* ==== NSHFTS is supposed to be even, but if is odd,
+* . then simply reduce it by one. The shuffle above
+* . ensures that the dropped shift is real and that
+* . the remaining shifts are paired. ====
+*
+ NS = NSHFTS - MOD( NSHFTS, 2 )
+*
+* ==== Machine constants for deflation ====
+*
+ SAFMIN = SLAMCH( 'SAFE MINIMUM' )
+ SAFMAX = ONE / SAFMIN
+ CALL SLABAD( SAFMIN, SAFMAX )
+ ULP = SLAMCH( 'PRECISION' )
+ SMLNUM = SAFMIN*( REAL( N ) / ULP )
+*
+* ==== Use accumulated reflections to update far-from-diagonal
+* . entries ? ====
+*
+ ACCUM = ( KACC22.EQ.1 ) .OR. ( KACC22.EQ.2 )
+*
+* ==== If so, exploit the 2-by-2 block structure? ====
+*
+ BLK22 = ( NS.GT.2 ) .AND. ( KACC22.EQ.2 )
+*
+* ==== clear trash ====
+*
+ IF( KTOP+2.LE.KBOT )
+ $ H( KTOP+2, KTOP ) = ZERO
+*
+* ==== NBMPS = number of 2-shift bulges in the chain ====
+*
+ NBMPS = NS / 2
+*
+* ==== KDU = width of slab ====
+*
+ KDU = 6*NBMPS - 3
+*
+* ==== Create and chase chains of NBMPS bulges ====
+*
+ DO 220 INCOL = 3*( 1-NBMPS ) + KTOP - 1, KBOT - 2, 3*NBMPS - 2
+ NDCOL = INCOL + KDU
+ IF( ACCUM )
+ $ CALL SLASET( 'ALL', KDU, KDU, ZERO, ONE, U, LDU )
+*
+* ==== Near-the-diagonal bulge chase. The following loop
+* . performs the near-the-diagonal part of a small bulge
+* . multi-shift QR sweep. Each 6*NBMPS-2 column diagonal
+* . chunk extends from column INCOL to column NDCOL
+* . (including both column INCOL and column NDCOL). The
+* . following loop chases a 3*NBMPS column long chain of
+* . NBMPS bulges 3*NBMPS-2 columns to the right. (INCOL
+* . may be less than KTOP and and NDCOL may be greater than
+* . KBOT indicating phantom columns from which to chase
+* . bulges before they are actually introduced or to which
+* . to chase bulges beyond column KBOT.) ====
+*
+ DO 150 KRCOL = INCOL, MIN( INCOL+3*NBMPS-3, KBOT-2 )
+*
+* ==== Bulges number MTOP to MBOT are active double implicit
+* . shift bulges. There may or may not also be small
+* . 2-by-2 bulge, if there is room. The inactive bulges
+* . (if any) must wait until the active bulges have moved
+* . down the diagonal to make room. The phantom matrix
+* . paradigm described above helps keep track. ====
+*
+ MTOP = MAX( 1, ( ( KTOP-1 )-KRCOL+2 ) / 3+1 )
+ MBOT = MIN( NBMPS, ( KBOT-KRCOL ) / 3 )
+ M22 = MBOT + 1
+ BMP22 = ( MBOT.LT.NBMPS ) .AND. ( KRCOL+3*( M22-1 ) ).EQ.
+ $ ( KBOT-2 )
+*
+* ==== Generate reflections to chase the chain right
+* . one column. (The minimum value of K is KTOP-1.) ====
+*
+ DO 20 M = MTOP, MBOT
+ K = KRCOL + 3*( M-1 )
+ IF( K.EQ.KTOP-1 ) THEN
+ CALL SLAQR1( 3, H( KTOP, KTOP ), LDH, SR( 2*M-1 ),
+ $ SI( 2*M-1 ), SR( 2*M ), SI( 2*M ),
+ $ V( 1, M ) )
+ ALPHA = V( 1, M )
+ CALL SLARFG( 3, ALPHA, V( 2, M ), 1, V( 1, M ) )
+ ELSE
+ BETA = H( K+1, K )
+ V( 2, M ) = H( K+2, K )
+ V( 3, M ) = H( K+3, K )
+ CALL SLARFG( 3, BETA, V( 2, M ), 1, V( 1, M ) )
+*
+* ==== A Bulge may collapse because of vigilant
+* . deflation or destructive underflow. (The
+* . initial bulge is always collapsed.) Use
+* . the two-small-subdiagonals trick to try
+* . to get it started again. If V(2,M).NE.0 and
+* . V(3,M) = H(K+3,K+1) = H(K+3,K+2) = 0, then
+* . this bulge is collapsing into a zero
+* . subdiagonal. It will be restarted next
+* . trip through the loop.)
+*
+ IF( V( 1, M ).NE.ZERO .AND.
+ $ ( V( 3, M ).NE.ZERO .OR. ( H( K+3,
+ $ K+1 ).EQ.ZERO .AND. H( K+3, K+2 ).EQ.ZERO ) ) )
+ $ THEN
+*
+* ==== Typical case: not collapsed (yet). ====
+*
+ H( K+1, K ) = BETA
+ H( K+2, K ) = ZERO
+ H( K+3, K ) = ZERO
+ ELSE
+*
+* ==== Atypical case: collapsed. Attempt to
+* . reintroduce ignoring H(K+1,K). If the
+* . fill resulting from the new reflector
+* . is too large, then abandon it.
+* . Otherwise, use the new one. ====
+*
+ CALL SLAQR1( 3, H( K+1, K+1 ), LDH, SR( 2*M-1 ),
+ $ SI( 2*M-1 ), SR( 2*M ), SI( 2*M ),
+ $ VT )
+ SCL = ABS( VT( 1 ) ) + ABS( VT( 2 ) ) +
+ $ ABS( VT( 3 ) )
+ IF( SCL.NE.ZERO ) THEN
+ VT( 1 ) = VT( 1 ) / SCL
+ VT( 2 ) = VT( 2 ) / SCL
+ VT( 3 ) = VT( 3 ) / SCL
+ END IF
+*
+* ==== The following is the traditional and
+* . conservative two-small-subdiagonals
+* . test. ====
+* .
+ IF( ABS( H( K+1, K ) )*( ABS( VT( 2 ) )+
+ $ ABS( VT( 3 ) ) ).GT.ULP*ABS( VT( 1 ) )*
+ $ ( ABS( H( K, K ) )+ABS( H( K+1,
+ $ K+1 ) )+ABS( H( K+2, K+2 ) ) ) ) THEN
+*
+* ==== Starting a new bulge here would
+* . create non-negligible fill. If
+* . the old reflector is diagonal (only
+* . possible with underflows), then
+* . change it to I. Otherwise, use
+* . it with trepidation. ====
+*
+ IF( V( 2, M ).EQ.ZERO .AND. V( 3, M ).EQ.ZERO )
+ $ THEN
+ V( 1, M ) = ZERO
+ ELSE
+ H( K+1, K ) = BETA
+ H( K+2, K ) = ZERO
+ H( K+3, K ) = ZERO
+ END IF
+ ELSE
+*
+* ==== Stating a new bulge here would
+* . create only negligible fill.
+* . Replace the old reflector with
+* . the new one. ====
+*
+ ALPHA = VT( 1 )
+ CALL SLARFG( 3, ALPHA, VT( 2 ), 1, VT( 1 ) )
+ REFSUM = H( K+1, K ) + H( K+2, K )*VT( 2 ) +
+ $ H( K+3, K )*VT( 3 )
+ H( K+1, K ) = H( K+1, K ) - VT( 1 )*REFSUM
+ H( K+2, K ) = ZERO
+ H( K+3, K ) = ZERO
+ V( 1, M ) = VT( 1 )
+ V( 2, M ) = VT( 2 )
+ V( 3, M ) = VT( 3 )
+ END IF
+ END IF
+ END IF
+ 20 CONTINUE
+*
+* ==== Generate a 2-by-2 reflection, if needed. ====
+*
+ K = KRCOL + 3*( M22-1 )
+ IF( BMP22 ) THEN
+ IF( K.EQ.KTOP-1 ) THEN
+ CALL SLAQR1( 2, H( K+1, K+1 ), LDH, SR( 2*M22-1 ),
+ $ SI( 2*M22-1 ), SR( 2*M22 ), SI( 2*M22 ),
+ $ V( 1, M22 ) )
+ BETA = V( 1, M22 )
+ CALL SLARFG( 2, BETA, V( 2, M22 ), 1, V( 1, M22 ) )
+ ELSE
+ BETA = H( K+1, K )
+ V( 2, M22 ) = H( K+2, K )
+ CALL SLARFG( 2, BETA, V( 2, M22 ), 1, V( 1, M22 ) )
+ H( K+1, K ) = BETA
+ H( K+2, K ) = ZERO
+ END IF
+ ELSE
+*
+* ==== Initialize V(1,M22) here to avoid possible undefined
+* . variable problems later. ====
+*
+ V( 1, M22 ) = ZERO
+ END IF
+*
+* ==== Multiply H by reflections from the left ====
+*
+ IF( ACCUM ) THEN
+ JBOT = MIN( NDCOL, KBOT )
+ ELSE IF( WANTT ) THEN
+ JBOT = N
+ ELSE
+ JBOT = KBOT
+ END IF
+ DO 40 J = MAX( KTOP, KRCOL ), JBOT
+ MEND = MIN( MBOT, ( J-KRCOL+2 ) / 3 )
+ DO 30 M = MTOP, MEND
+ K = KRCOL + 3*( M-1 )
+ REFSUM = V( 1, M )*( H( K+1, J )+V( 2, M )*
+ $ H( K+2, J )+V( 3, M )*H( K+3, J ) )
+ H( K+1, J ) = H( K+1, J ) - REFSUM
+ H( K+2, J ) = H( K+2, J ) - REFSUM*V( 2, M )
+ H( K+3, J ) = H( K+3, J ) - REFSUM*V( 3, M )
+ 30 CONTINUE
+ 40 CONTINUE
+ IF( BMP22 ) THEN
+ K = KRCOL + 3*( M22-1 )
+ DO 50 J = MAX( K+1, KTOP ), JBOT
+ REFSUM = V( 1, M22 )*( H( K+1, J )+V( 2, M22 )*
+ $ H( K+2, J ) )
+ H( K+1, J ) = H( K+1, J ) - REFSUM
+ H( K+2, J ) = H( K+2, J ) - REFSUM*V( 2, M22 )
+ 50 CONTINUE
+ END IF
+*
+* ==== Multiply H by reflections from the right.
+* . Delay filling in the last row until the
+* . vigilant deflation check is complete. ====
+*
+ IF( ACCUM ) THEN
+ JTOP = MAX( KTOP, INCOL )
+ ELSE IF( WANTT ) THEN
+ JTOP = 1
+ ELSE
+ JTOP = KTOP
+ END IF
+ DO 90 M = MTOP, MBOT
+ IF( V( 1, M ).NE.ZERO ) THEN
+ K = KRCOL + 3*( M-1 )
+ DO 60 J = JTOP, MIN( KBOT, K+3 )
+ REFSUM = V( 1, M )*( H( J, K+1 )+V( 2, M )*
+ $ H( J, K+2 )+V( 3, M )*H( J, K+3 ) )
+ H( J, K+1 ) = H( J, K+1 ) - REFSUM
+ H( J, K+2 ) = H( J, K+2 ) - REFSUM*V( 2, M )
+ H( J, K+3 ) = H( J, K+3 ) - REFSUM*V( 3, M )
+ 60 CONTINUE
+*
+ IF( ACCUM ) THEN
+*
+* ==== Accumulate U. (If necessary, update Z later
+* . with with an efficient matrix-matrix
+* . multiply.) ====
+*
+ KMS = K - INCOL
+ DO 70 J = MAX( 1, KTOP-INCOL ), KDU
+ REFSUM = V( 1, M )*( U( J, KMS+1 )+V( 2, M )*
+ $ U( J, KMS+2 )+V( 3, M )*U( J, KMS+3 ) )
+ U( J, KMS+1 ) = U( J, KMS+1 ) - REFSUM
+ U( J, KMS+2 ) = U( J, KMS+2 ) - REFSUM*V( 2, M )
+ U( J, KMS+3 ) = U( J, KMS+3 ) - REFSUM*V( 3, M )
+ 70 CONTINUE
+ ELSE IF( WANTZ ) THEN
+*
+* ==== U is not accumulated, so update Z
+* . now by multiplying by reflections
+* . from the right. ====
+*
+ DO 80 J = ILOZ, IHIZ
+ REFSUM = V( 1, M )*( Z( J, K+1 )+V( 2, M )*
+ $ Z( J, K+2 )+V( 3, M )*Z( J, K+3 ) )
+ Z( J, K+1 ) = Z( J, K+1 ) - REFSUM
+ Z( J, K+2 ) = Z( J, K+2 ) - REFSUM*V( 2, M )
+ Z( J, K+3 ) = Z( J, K+3 ) - REFSUM*V( 3, M )
+ 80 CONTINUE
+ END IF
+ END IF
+ 90 CONTINUE
+*
+* ==== Special case: 2-by-2 reflection (if needed) ====
+*
+ K = KRCOL + 3*( M22-1 )
+ IF( BMP22 .AND. ( V( 1, M22 ).NE.ZERO ) ) THEN
+ DO 100 J = JTOP, MIN( KBOT, K+3 )
+ REFSUM = V( 1, M22 )*( H( J, K+1 )+V( 2, M22 )*
+ $ H( J, K+2 ) )
+ H( J, K+1 ) = H( J, K+1 ) - REFSUM
+ H( J, K+2 ) = H( J, K+2 ) - REFSUM*V( 2, M22 )
+ 100 CONTINUE
+*
+ IF( ACCUM ) THEN
+ KMS = K - INCOL
+ DO 110 J = MAX( 1, KTOP-INCOL ), KDU
+ REFSUM = V( 1, M22 )*( U( J, KMS+1 )+V( 2, M22 )*
+ $ U( J, KMS+2 ) )
+ U( J, KMS+1 ) = U( J, KMS+1 ) - REFSUM
+ U( J, KMS+2 ) = U( J, KMS+2 ) - REFSUM*V( 2, M22 )
+ 110 CONTINUE
+ ELSE IF( WANTZ ) THEN
+ DO 120 J = ILOZ, IHIZ
+ REFSUM = V( 1, M22 )*( Z( J, K+1 )+V( 2, M22 )*
+ $ Z( J, K+2 ) )
+ Z( J, K+1 ) = Z( J, K+1 ) - REFSUM
+ Z( J, K+2 ) = Z( J, K+2 ) - REFSUM*V( 2, M22 )
+ 120 CONTINUE
+ END IF
+ END IF
+*
+* ==== Vigilant deflation check ====
+*
+ MSTART = MTOP
+ IF( KRCOL+3*( MSTART-1 ).LT.KTOP )
+ $ MSTART = MSTART + 1
+ MEND = MBOT
+ IF( BMP22 )
+ $ MEND = MEND + 1
+ IF( KRCOL.EQ.KBOT-2 )
+ $ MEND = MEND + 1
+ DO 130 M = MSTART, MEND
+ K = MIN( KBOT-1, KRCOL+3*( M-1 ) )
+*
+* ==== The following convergence test requires that
+* . the tradition small-compared-to-nearby-diagonals
+* . criterion and the Ahues & Tisseur (LAWN 122, 1997)
+* . criteria both be satisfied. The latter improves
+* . accuracy in some examples. Falling back on an
+* . alternate convergence criterion when TST1 or TST2
+* . is zero (as done here) is traditional but probably
+* . unnecessary. ====
+*
+ IF( H( K+1, K ).NE.ZERO ) THEN
+ TST1 = ABS( H( K, K ) ) + ABS( H( K+1, K+1 ) )
+ IF( TST1.EQ.ZERO ) THEN
+ IF( K.GE.KTOP+1 )
+ $ TST1 = TST1 + ABS( H( K, K-1 ) )
+ IF( K.GE.KTOP+2 )
+ $ TST1 = TST1 + ABS( H( K, K-2 ) )
+ IF( K.GE.KTOP+3 )
+ $ TST1 = TST1 + ABS( H( K, K-3 ) )
+ IF( K.LE.KBOT-2 )
+ $ TST1 = TST1 + ABS( H( K+2, K+1 ) )
+ IF( K.LE.KBOT-3 )
+ $ TST1 = TST1 + ABS( H( K+3, K+1 ) )
+ IF( K.LE.KBOT-4 )
+ $ TST1 = TST1 + ABS( H( K+4, K+1 ) )
+ END IF
+ IF( ABS( H( K+1, K ) ).LE.MAX( SMLNUM, ULP*TST1 ) )
+ $ THEN
+ H12 = MAX( ABS( H( K+1, K ) ), ABS( H( K, K+1 ) ) )
+ H21 = MIN( ABS( H( K+1, K ) ), ABS( H( K, K+1 ) ) )
+ H11 = MAX( ABS( H( K+1, K+1 ) ),
+ $ ABS( H( K, K )-H( K+1, K+1 ) ) )
+ H22 = MIN( ABS( H( K+1, K+1 ) ),
+ $ ABS( H( K, K )-H( K+1, K+1 ) ) )
+ SCL = H11 + H12
+ TST2 = H22*( H11 / SCL )
+*
+ IF( TST2.EQ.ZERO .OR. H21*( H12 / SCL ).LE.
+ $ MAX( SMLNUM, ULP*TST2 ) )H( K+1, K ) = ZERO
+ END IF
+ END IF
+ 130 CONTINUE
+*
+* ==== Fill in the last row of each bulge. ====
+*
+ MEND = MIN( NBMPS, ( KBOT-KRCOL-1 ) / 3 )
+ DO 140 M = MTOP, MEND
+ K = KRCOL + 3*( M-1 )
+ REFSUM = V( 1, M )*V( 3, M )*H( K+4, K+3 )
+ H( K+4, K+1 ) = -REFSUM
+ H( K+4, K+2 ) = -REFSUM*V( 2, M )
+ H( K+4, K+3 ) = H( K+4, K+3 ) - REFSUM*V( 3, M )
+ 140 CONTINUE
+*
+* ==== End of near-the-diagonal bulge chase. ====
+*
+ 150 CONTINUE
+*
+* ==== Use U (if accumulated) to update far-from-diagonal
+* . entries in H. If required, use U to update Z as
+* . well. ====
+*
+ IF( ACCUM ) THEN
+ IF( WANTT ) THEN
+ JTOP = 1
+ JBOT = N
+ ELSE
+ JTOP = KTOP
+ JBOT = KBOT
+ END IF
+ IF( ( .NOT.BLK22 ) .OR. ( INCOL.LT.KTOP ) .OR.
+ $ ( NDCOL.GT.KBOT ) .OR. ( NS.LE.2 ) ) THEN
+*
+* ==== Updates not exploiting the 2-by-2 block
+* . structure of U. K1 and NU keep track of
+* . the location and size of U in the special
+* . cases of introducing bulges and chasing
+* . bulges off the bottom. In these special
+* . cases and in case the number of shifts
+* . is NS = 2, there is no 2-by-2 block
+* . structure to exploit. ====
+*
+ K1 = MAX( 1, KTOP-INCOL )
+ NU = ( KDU-MAX( 0, NDCOL-KBOT ) ) - K1 + 1
+*
+* ==== Horizontal Multiply ====
+*
+ DO 160 JCOL = MIN( NDCOL, KBOT ) + 1, JBOT, NH
+ JLEN = MIN( NH, JBOT-JCOL+1 )
+ CALL SGEMM( 'C', 'N', NU, JLEN, NU, ONE, U( K1, K1 ),
+ $ LDU, H( INCOL+K1, JCOL ), LDH, ZERO, WH,
+ $ LDWH )
+ CALL SLACPY( 'ALL', NU, JLEN, WH, LDWH,
+ $ H( INCOL+K1, JCOL ), LDH )
+ 160 CONTINUE
+*
+* ==== Vertical multiply ====
+*
+ DO 170 JROW = JTOP, MAX( KTOP, INCOL ) - 1, NV
+ JLEN = MIN( NV, MAX( KTOP, INCOL )-JROW )
+ CALL SGEMM( 'N', 'N', JLEN, NU, NU, ONE,
+ $ H( JROW, INCOL+K1 ), LDH, U( K1, K1 ),
+ $ LDU, ZERO, WV, LDWV )
+ CALL SLACPY( 'ALL', JLEN, NU, WV, LDWV,
+ $ H( JROW, INCOL+K1 ), LDH )
+ 170 CONTINUE
+*
+* ==== Z multiply (also vertical) ====
+*
+ IF( WANTZ ) THEN
+ DO 180 JROW = ILOZ, IHIZ, NV
+ JLEN = MIN( NV, IHIZ-JROW+1 )
+ CALL SGEMM( 'N', 'N', JLEN, NU, NU, ONE,
+ $ Z( JROW, INCOL+K1 ), LDZ, U( K1, K1 ),
+ $ LDU, ZERO, WV, LDWV )
+ CALL SLACPY( 'ALL', JLEN, NU, WV, LDWV,
+ $ Z( JROW, INCOL+K1 ), LDZ )
+ 180 CONTINUE
+ END IF
+ ELSE
+*
+* ==== Updates exploiting U's 2-by-2 block structure.
+* . (I2, I4, J2, J4 are the last rows and columns
+* . of the blocks.) ====
+*
+ I2 = ( KDU+1 ) / 2
+ I4 = KDU
+ J2 = I4 - I2
+ J4 = KDU
+*
+* ==== KZS and KNZ deal with the band of zeros
+* . along the diagonal of one of the triangular
+* . blocks. ====
+*
+ KZS = ( J4-J2 ) - ( NS+1 )
+ KNZ = NS + 1
+*
+* ==== Horizontal multiply ====
+*
+ DO 190 JCOL = MIN( NDCOL, KBOT ) + 1, JBOT, NH
+ JLEN = MIN( NH, JBOT-JCOL+1 )
+*
+* ==== Copy bottom of H to top+KZS of scratch ====
+* (The first KZS rows get multiplied by zero.) ====
+*
+ CALL SLACPY( 'ALL', KNZ, JLEN, H( INCOL+1+J2, JCOL ),
+ $ LDH, WH( KZS+1, 1 ), LDWH )
+*
+* ==== Multiply by U21' ====
+*
+ CALL SLASET( 'ALL', KZS, JLEN, ZERO, ZERO, WH, LDWH )
+ CALL STRMM( 'L', 'U', 'C', 'N', KNZ, JLEN, ONE,
+ $ U( J2+1, 1+KZS ), LDU, WH( KZS+1, 1 ),
+ $ LDWH )
+*
+* ==== Multiply top of H by U11' ====
+*
+ CALL SGEMM( 'C', 'N', I2, JLEN, J2, ONE, U, LDU,
+ $ H( INCOL+1, JCOL ), LDH, ONE, WH, LDWH )
+*
+* ==== Copy top of H bottom of WH ====
+*
+ CALL SLACPY( 'ALL', J2, JLEN, H( INCOL+1, JCOL ), LDH,
+ $ WH( I2+1, 1 ), LDWH )
+*
+* ==== Multiply by U21' ====
+*
+ CALL STRMM( 'L', 'L', 'C', 'N', J2, JLEN, ONE,
+ $ U( 1, I2+1 ), LDU, WH( I2+1, 1 ), LDWH )
+*
+* ==== Multiply by U22 ====
+*
+ CALL SGEMM( 'C', 'N', I4-I2, JLEN, J4-J2, ONE,
+ $ U( J2+1, I2+1 ), LDU,
+ $ H( INCOL+1+J2, JCOL ), LDH, ONE,
+ $ WH( I2+1, 1 ), LDWH )
+*
+* ==== Copy it back ====
+*
+ CALL SLACPY( 'ALL', KDU, JLEN, WH, LDWH,
+ $ H( INCOL+1, JCOL ), LDH )
+ 190 CONTINUE
+*
+* ==== Vertical multiply ====
+*
+ DO 200 JROW = JTOP, MAX( INCOL, KTOP ) - 1, NV
+ JLEN = MIN( NV, MAX( INCOL, KTOP )-JROW )
+*
+* ==== Copy right of H to scratch (the first KZS
+* . columns get multiplied by zero) ====
+*
+ CALL SLACPY( 'ALL', JLEN, KNZ, H( JROW, INCOL+1+J2 ),
+ $ LDH, WV( 1, 1+KZS ), LDWV )
+*
+* ==== Multiply by U21 ====
+*
+ CALL SLASET( 'ALL', JLEN, KZS, ZERO, ZERO, WV, LDWV )
+ CALL STRMM( 'R', 'U', 'N', 'N', JLEN, KNZ, ONE,
+ $ U( J2+1, 1+KZS ), LDU, WV( 1, 1+KZS ),
+ $ LDWV )
+*
+* ==== Multiply by U11 ====
+*
+ CALL SGEMM( 'N', 'N', JLEN, I2, J2, ONE,
+ $ H( JROW, INCOL+1 ), LDH, U, LDU, ONE, WV,
+ $ LDWV )
+*
+* ==== Copy left of H to right of scratch ====
+*
+ CALL SLACPY( 'ALL', JLEN, J2, H( JROW, INCOL+1 ), LDH,
+ $ WV( 1, 1+I2 ), LDWV )
+*
+* ==== Multiply by U21 ====
+*
+ CALL STRMM( 'R', 'L', 'N', 'N', JLEN, I4-I2, ONE,
+ $ U( 1, I2+1 ), LDU, WV( 1, 1+I2 ), LDWV )
+*
+* ==== Multiply by U22 ====
+*
+ CALL SGEMM( 'N', 'N', JLEN, I4-I2, J4-J2, ONE,
+ $ H( JROW, INCOL+1+J2 ), LDH,
+ $ U( J2+1, I2+1 ), LDU, ONE, WV( 1, 1+I2 ),
+ $ LDWV )
+*
+* ==== Copy it back ====
+*
+ CALL SLACPY( 'ALL', JLEN, KDU, WV, LDWV,
+ $ H( JROW, INCOL+1 ), LDH )
+ 200 CONTINUE
+*
+* ==== Multiply Z (also vertical) ====
+*
+ IF( WANTZ ) THEN
+ DO 210 JROW = ILOZ, IHIZ, NV
+ JLEN = MIN( NV, IHIZ-JROW+1 )
+*
+* ==== Copy right of Z to left of scratch (first
+* . KZS columns get multiplied by zero) ====
+*
+ CALL SLACPY( 'ALL', JLEN, KNZ,
+ $ Z( JROW, INCOL+1+J2 ), LDZ,
+ $ WV( 1, 1+KZS ), LDWV )
+*
+* ==== Multiply by U12 ====
+*
+ CALL SLASET( 'ALL', JLEN, KZS, ZERO, ZERO, WV,
+ $ LDWV )
+ CALL STRMM( 'R', 'U', 'N', 'N', JLEN, KNZ, ONE,
+ $ U( J2+1, 1+KZS ), LDU, WV( 1, 1+KZS ),
+ $ LDWV )
+*
+* ==== Multiply by U11 ====
+*
+ CALL SGEMM( 'N', 'N', JLEN, I2, J2, ONE,
+ $ Z( JROW, INCOL+1 ), LDZ, U, LDU, ONE,
+ $ WV, LDWV )
+*
+* ==== Copy left of Z to right of scratch ====
+*
+ CALL SLACPY( 'ALL', JLEN, J2, Z( JROW, INCOL+1 ),
+ $ LDZ, WV( 1, 1+I2 ), LDWV )
+*
+* ==== Multiply by U21 ====
+*
+ CALL STRMM( 'R', 'L', 'N', 'N', JLEN, I4-I2, ONE,
+ $ U( 1, I2+1 ), LDU, WV( 1, 1+I2 ),
+ $ LDWV )
+*
+* ==== Multiply by U22 ====
+*
+ CALL SGEMM( 'N', 'N', JLEN, I4-I2, J4-J2, ONE,
+ $ Z( JROW, INCOL+1+J2 ), LDZ,
+ $ U( J2+1, I2+1 ), LDU, ONE,
+ $ WV( 1, 1+I2 ), LDWV )
+*
+* ==== Copy the result back to Z ====
+*
+ CALL SLACPY( 'ALL', JLEN, KDU, WV, LDWV,
+ $ Z( JROW, INCOL+1 ), LDZ )
+ 210 CONTINUE
+ END IF
+ END IF
+ END IF
+ 220 CONTINUE
+*
+* ==== End of SLAQR5 ====
+*
+ END
+ SUBROUTINE SLAQSB( UPLO, N, KD, AB, LDAB, S, SCOND, AMAX, EQUED )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER EQUED, UPLO
+ INTEGER KD, LDAB, N
+ REAL AMAX, SCOND
+* ..
+* .. Array Arguments ..
+ REAL AB( LDAB, * ), S( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SLAQSB equilibrates a symmetric band matrix A using the scaling
+* factors in the vector S.
+*
+* Arguments
+* =========
+*
+* UPLO (input) CHARACTER*1
+* Specifies whether the upper or lower triangular part of the
+* symmetric matrix A is stored.
+* = 'U': Upper triangular
+* = 'L': Lower triangular
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* KD (input) INTEGER
+* The number of super-diagonals of the matrix A if UPLO = 'U',
+* or the number of sub-diagonals if UPLO = 'L'. KD >= 0.
+*
+* AB (input/output) REAL array, dimension (LDAB,N)
+* On entry, the upper or lower triangle of the symmetric band
+* matrix A, stored in the first KD+1 rows of the array. The
+* j-th column of A is stored in the j-th column of the array AB
+* as follows:
+* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
+* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).
+*
+* On exit, if INFO = 0, the triangular factor U or L from the
+* Cholesky factorization A = U'*U or A = L*L' of the band
+* matrix A, in the same storage format as A.
+*
+* LDAB (input) INTEGER
+* The leading dimension of the array AB. LDAB >= KD+1.
+*
+* S (input) REAL array, dimension (N)
+* The scale factors for A.
+*
+* SCOND (input) REAL
+* Ratio of the smallest S(i) to the largest S(i).
+*
+* AMAX (input) REAL
+* Absolute value of largest matrix entry.
+*
+* EQUED (output) CHARACTER*1
+* Specifies whether or not equilibration was done.
+* = 'N': No equilibration.
+* = 'Y': Equilibration was done, i.e., A has been replaced by
+* diag(S) * A * diag(S).
+*
+* Internal Parameters
+* ===================
+*
+* THRESH is a threshold value used to decide if scaling should be done
+* based on the ratio of the scaling factors. If SCOND < THRESH,
+* scaling is done.
+*
+* LARGE and SMALL are threshold values used to decide if scaling should
+* be done based on the absolute size of the largest matrix element.
+* If AMAX > LARGE or AMAX < SMALL, scaling is done.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ONE, THRESH
+ PARAMETER ( ONE = 1.0E+0, THRESH = 0.1E+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, J
+ REAL CJ, LARGE, SMALL
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ REAL SLAMCH
+ EXTERNAL LSAME, SLAMCH
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+* Quick return if possible
+*
+ IF( N.LE.0 ) THEN
+ EQUED = 'N'
+ RETURN
+ END IF
+*
+* Initialize LARGE and SMALL.
+*
+ SMALL = SLAMCH( 'Safe minimum' ) / SLAMCH( 'Precision' )
+ LARGE = ONE / SMALL
+*
+ IF( SCOND.GE.THRESH .AND. AMAX.GE.SMALL .AND. AMAX.LE.LARGE ) THEN
+*
+* No equilibration
+*
+ EQUED = 'N'
+ ELSE
+*
+* Replace A by diag(S) * A * diag(S).
+*
+ IF( LSAME( UPLO, 'U' ) ) THEN
+*
+* Upper triangle of A is stored in band format.
+*
+ DO 20 J = 1, N
+ CJ = S( J )
+ DO 10 I = MAX( 1, J-KD ), J
+ AB( KD+1+I-J, J ) = CJ*S( I )*AB( KD+1+I-J, J )
+ 10 CONTINUE
+ 20 CONTINUE
+ ELSE
+*
+* Lower triangle of A is stored.
+*
+ DO 40 J = 1, N
+ CJ = S( J )
+ DO 30 I = J, MIN( N, J+KD )
+ AB( 1+I-J, J ) = CJ*S( I )*AB( 1+I-J, J )
+ 30 CONTINUE
+ 40 CONTINUE
+ END IF
+ EQUED = 'Y'
+ END IF
+*
+ RETURN
+*
+* End of SLAQSB
+*
+ END
+ SUBROUTINE SLAQSP( UPLO, N, AP, S, SCOND, AMAX, EQUED )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER EQUED, UPLO
+ INTEGER N
+ REAL AMAX, SCOND
+* ..
+* .. Array Arguments ..
+ REAL AP( * ), S( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SLAQSP equilibrates a symmetric matrix A using the scaling factors
+* in the vector S.
+*
+* Arguments
+* =========
+*
+* UPLO (input) CHARACTER*1
+* Specifies whether the upper or lower triangular part of the
+* symmetric matrix A is stored.
+* = 'U': Upper triangular
+* = 'L': Lower triangular
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* AP (input/output) REAL array, dimension (N*(N+1)/2)
+* On entry, the upper or lower triangle of the symmetric matrix
+* A, packed columnwise in a linear array. The j-th column of A
+* is stored in the array AP as follows:
+* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
+* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
+*
+* On exit, the equilibrated matrix: diag(S) * A * diag(S), in
+* the same storage format as A.
+*
+* S (input) REAL array, dimension (N)
+* The scale factors for A.
+*
+* SCOND (input) REAL
+* Ratio of the smallest S(i) to the largest S(i).
+*
+* AMAX (input) REAL
+* Absolute value of largest matrix entry.
+*
+* EQUED (output) CHARACTER*1
+* Specifies whether or not equilibration was done.
+* = 'N': No equilibration.
+* = 'Y': Equilibration was done, i.e., A has been replaced by
+* diag(S) * A * diag(S).
+*
+* Internal Parameters
+* ===================
+*
+* THRESH is a threshold value used to decide if scaling should be done
+* based on the ratio of the scaling factors. If SCOND < THRESH,
+* scaling is done.
+*
+* LARGE and SMALL are threshold values used to decide if scaling should
+* be done based on the absolute size of the largest matrix element.
+* If AMAX > LARGE or AMAX < SMALL, scaling is done.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ONE, THRESH
+ PARAMETER ( ONE = 1.0E+0, THRESH = 0.1E+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, J, JC
+ REAL CJ, LARGE, SMALL
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ REAL SLAMCH
+ EXTERNAL LSAME, SLAMCH
+* ..
+* .. Executable Statements ..
+*
+* Quick return if possible
+*
+ IF( N.LE.0 ) THEN
+ EQUED = 'N'
+ RETURN
+ END IF
+*
+* Initialize LARGE and SMALL.
+*
+ SMALL = SLAMCH( 'Safe minimum' ) / SLAMCH( 'Precision' )
+ LARGE = ONE / SMALL
+*
+ IF( SCOND.GE.THRESH .AND. AMAX.GE.SMALL .AND. AMAX.LE.LARGE ) THEN
+*
+* No equilibration
+*
+ EQUED = 'N'
+ ELSE
+*
+* Replace A by diag(S) * A * diag(S).
+*
+ IF( LSAME( UPLO, 'U' ) ) THEN
+*
+* Upper triangle of A is stored.
+*
+ JC = 1
+ DO 20 J = 1, N
+ CJ = S( J )
+ DO 10 I = 1, J
+ AP( JC+I-1 ) = CJ*S( I )*AP( JC+I-1 )
+ 10 CONTINUE
+ JC = JC + J
+ 20 CONTINUE
+ ELSE
+*
+* Lower triangle of A is stored.
+*
+ JC = 1
+ DO 40 J = 1, N
+ CJ = S( J )
+ DO 30 I = J, N
+ AP( JC+I-J ) = CJ*S( I )*AP( JC+I-J )
+ 30 CONTINUE
+ JC = JC + N - J + 1
+ 40 CONTINUE
+ END IF
+ EQUED = 'Y'
+ END IF
+*
+ RETURN
+*
+* End of SLAQSP
+*
+ END
+ SUBROUTINE SLAQSY( UPLO, N, A, LDA, S, SCOND, AMAX, EQUED )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER EQUED, UPLO
+ INTEGER LDA, N
+ REAL AMAX, SCOND
+* ..
+* .. Array Arguments ..
+ REAL A( LDA, * ), S( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SLAQSY equilibrates a symmetric matrix A using the scaling factors
+* in the vector S.
+*
+* Arguments
+* =========
+*
+* UPLO (input) CHARACTER*1
+* Specifies whether the upper or lower triangular part of the
+* symmetric matrix A is stored.
+* = 'U': Upper triangular
+* = 'L': Lower triangular
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* A (input/output) REAL array, dimension (LDA,N)
+* On entry, the symmetric matrix A. If UPLO = 'U', the leading
+* n by n upper triangular part of A contains the upper
+* triangular part of the matrix A, and the strictly lower
+* triangular part of A is not referenced. If UPLO = 'L', the
+* leading n by n lower triangular part of A contains the lower
+* triangular part of the matrix A, and the strictly upper
+* triangular part of A is not referenced.
+*
+* On exit, if EQUED = 'Y', the equilibrated matrix:
+* diag(S) * A * diag(S).
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(N,1).
+*
+* S (input) REAL array, dimension (N)
+* The scale factors for A.
+*
+* SCOND (input) REAL
+* Ratio of the smallest S(i) to the largest S(i).
+*
+* AMAX (input) REAL
+* Absolute value of largest matrix entry.
+*
+* EQUED (output) CHARACTER*1
+* Specifies whether or not equilibration was done.
+* = 'N': No equilibration.
+* = 'Y': Equilibration was done, i.e., A has been replaced by
+* diag(S) * A * diag(S).
+*
+* Internal Parameters
+* ===================
+*
+* THRESH is a threshold value used to decide if scaling should be done
+* based on the ratio of the scaling factors. If SCOND < THRESH,
+* scaling is done.
+*
+* LARGE and SMALL are threshold values used to decide if scaling should
+* be done based on the absolute size of the largest matrix element.
+* If AMAX > LARGE or AMAX < SMALL, scaling is done.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ONE, THRESH
+ PARAMETER ( ONE = 1.0E+0, THRESH = 0.1E+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, J
+ REAL CJ, LARGE, SMALL
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ REAL SLAMCH
+ EXTERNAL LSAME, SLAMCH
+* ..
+* .. Executable Statements ..
+*
+* Quick return if possible
+*
+ IF( N.LE.0 ) THEN
+ EQUED = 'N'
+ RETURN
+ END IF
+*
+* Initialize LARGE and SMALL.
+*
+ SMALL = SLAMCH( 'Safe minimum' ) / SLAMCH( 'Precision' )
+ LARGE = ONE / SMALL
+*
+ IF( SCOND.GE.THRESH .AND. AMAX.GE.SMALL .AND. AMAX.LE.LARGE ) THEN
+*
+* No equilibration
+*
+ EQUED = 'N'
+ ELSE
+*
+* Replace A by diag(S) * A * diag(S).
+*
+ IF( LSAME( UPLO, 'U' ) ) THEN
+*
+* Upper triangle of A is stored.
+*
+ DO 20 J = 1, N
+ CJ = S( J )
+ DO 10 I = 1, J
+ A( I, J ) = CJ*S( I )*A( I, J )
+ 10 CONTINUE
+ 20 CONTINUE
+ ELSE
+*
+* Lower triangle of A is stored.
+*
+ DO 40 J = 1, N
+ CJ = S( J )
+ DO 30 I = J, N
+ A( I, J ) = CJ*S( I )*A( I, J )
+ 30 CONTINUE
+ 40 CONTINUE
+ END IF
+ EQUED = 'Y'
+ END IF
+*
+ RETURN
+*
+* End of SLAQSY
+*
+ END
+ SUBROUTINE SLAQTR( LTRAN, LREAL, N, T, LDT, B, W, SCALE, X, WORK,
+ $ INFO )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ LOGICAL LREAL, LTRAN
+ INTEGER INFO, LDT, N
+ REAL SCALE, W
+* ..
+* .. Array Arguments ..
+ REAL B( * ), T( LDT, * ), WORK( * ), X( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SLAQTR solves the real quasi-triangular system
+*
+* op(T)*p = scale*c, if LREAL = .TRUE.
+*
+* or the complex quasi-triangular systems
+*
+* op(T + iB)*(p+iq) = scale*(c+id), if LREAL = .FALSE.
+*
+* in real arithmetic, where T is upper quasi-triangular.
+* If LREAL = .FALSE., then the first diagonal block of T must be
+* 1 by 1, B is the specially structured matrix
+*
+* B = [ b(1) b(2) ... b(n) ]
+* [ w ]
+* [ w ]
+* [ . ]
+* [ w ]
+*
+* op(A) = A or A', A' denotes the conjugate transpose of
+* matrix A.
+*
+* On input, X = [ c ]. On output, X = [ p ].
+* [ d ] [ q ]
+*
+* This subroutine is designed for the condition number estimation
+* in routine STRSNA.
+*
+* Arguments
+* =========
+*
+* LTRAN (input) LOGICAL
+* On entry, LTRAN specifies the option of conjugate transpose:
+* = .FALSE., op(T+i*B) = T+i*B,
+* = .TRUE., op(T+i*B) = (T+i*B)'.
+*
+* LREAL (input) LOGICAL
+* On entry, LREAL specifies the input matrix structure:
+* = .FALSE., the input is complex
+* = .TRUE., the input is real
+*
+* N (input) INTEGER
+* On entry, N specifies the order of T+i*B. N >= 0.
+*
+* T (input) REAL array, dimension (LDT,N)
+* On entry, T contains a matrix in Schur canonical form.
+* If LREAL = .FALSE., then the first diagonal block of T must
+* be 1 by 1.
+*
+* LDT (input) INTEGER
+* The leading dimension of the matrix T. LDT >= max(1,N).
+*
+* B (input) REAL array, dimension (N)
+* On entry, B contains the elements to form the matrix
+* B as described above.
+* If LREAL = .TRUE., B is not referenced.
+*
+* W (input) REAL
+* On entry, W is the diagonal element of the matrix B.
+* If LREAL = .TRUE., W is not referenced.
+*
+* SCALE (output) REAL
+* On exit, SCALE is the scale factor.
+*
+* X (input/output) REAL array, dimension (2*N)
+* On entry, X contains the right hand side of the system.
+* On exit, X is overwritten by the solution.
+*
+* WORK (workspace) REAL array, dimension (N)
+*
+* INFO (output) INTEGER
+* On exit, INFO is set to
+* 0: successful exit.
+* 1: the some diagonal 1 by 1 block has been perturbed by
+* a small number SMIN to keep nonsingularity.
+* 2: the some diagonal 2 by 2 block has been perturbed by
+* a small number in SLALN2 to keep nonsingularity.
+* NOTE: In the interests of speed, this routine does not
+* check the inputs for errors.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO, ONE
+ PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL NOTRAN
+ INTEGER I, IERR, J, J1, J2, JNEXT, K, N1, N2
+ REAL BIGNUM, EPS, REC, SCALOC, SI, SMIN, SMINW,
+ $ SMLNUM, SR, TJJ, TMP, XJ, XMAX, XNORM, Z
+* ..
+* .. Local Arrays ..
+ REAL D( 2, 2 ), V( 2, 2 )
+* ..
+* .. External Functions ..
+ INTEGER ISAMAX
+ REAL SASUM, SDOT, SLAMCH, SLANGE
+ EXTERNAL ISAMAX, SASUM, SDOT, SLAMCH, SLANGE
+* ..
+* .. External Subroutines ..
+ EXTERNAL SAXPY, SLADIV, SLALN2, SSCAL
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX
+* ..
+* .. Executable Statements ..
+*
+* Do not test the input parameters for errors
+*
+ NOTRAN = .NOT.LTRAN
+ INFO = 0
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+* Set constants to control overflow
+*
+ EPS = SLAMCH( 'P' )
+ SMLNUM = SLAMCH( 'S' ) / EPS
+ BIGNUM = ONE / SMLNUM
+*
+ XNORM = SLANGE( 'M', N, N, T, LDT, D )
+ IF( .NOT.LREAL )
+ $ XNORM = MAX( XNORM, ABS( W ), SLANGE( 'M', N, 1, B, N, D ) )
+ SMIN = MAX( SMLNUM, EPS*XNORM )
+*
+* Compute 1-norm of each column of strictly upper triangular
+* part of T to control overflow in triangular solver.
+*
+ WORK( 1 ) = ZERO
+ DO 10 J = 2, N
+ WORK( J ) = SASUM( J-1, T( 1, J ), 1 )
+ 10 CONTINUE
+*
+ IF( .NOT.LREAL ) THEN
+ DO 20 I = 2, N
+ WORK( I ) = WORK( I ) + ABS( B( I ) )
+ 20 CONTINUE
+ END IF
+*
+ N2 = 2*N
+ N1 = N
+ IF( .NOT.LREAL )
+ $ N1 = N2
+ K = ISAMAX( N1, X, 1 )
+ XMAX = ABS( X( K ) )
+ SCALE = ONE
+*
+ IF( XMAX.GT.BIGNUM ) THEN
+ SCALE = BIGNUM / XMAX
+ CALL SSCAL( N1, SCALE, X, 1 )
+ XMAX = BIGNUM
+ END IF
+*
+ IF( LREAL ) THEN
+*
+ IF( NOTRAN ) THEN
+*
+* Solve T*p = scale*c
+*
+ JNEXT = N
+ DO 30 J = N, 1, -1
+ IF( J.GT.JNEXT )
+ $ GO TO 30
+ J1 = J
+ J2 = J
+ JNEXT = J - 1
+ IF( J.GT.1 ) THEN
+ IF( T( J, J-1 ).NE.ZERO ) THEN
+ J1 = J - 1
+ JNEXT = J - 2
+ END IF
+ END IF
+*
+ IF( J1.EQ.J2 ) THEN
+*
+* Meet 1 by 1 diagonal block
+*
+* Scale to avoid overflow when computing
+* x(j) = b(j)/T(j,j)
+*
+ XJ = ABS( X( J1 ) )
+ TJJ = ABS( T( J1, J1 ) )
+ TMP = T( J1, J1 )
+ IF( TJJ.LT.SMIN ) THEN
+ TMP = SMIN
+ TJJ = SMIN
+ INFO = 1
+ END IF
+*
+ IF( XJ.EQ.ZERO )
+ $ GO TO 30
+*
+ IF( TJJ.LT.ONE ) THEN
+ IF( XJ.GT.BIGNUM*TJJ ) THEN
+ REC = ONE / XJ
+ CALL SSCAL( N, REC, X, 1 )
+ SCALE = SCALE*REC
+ XMAX = XMAX*REC
+ END IF
+ END IF
+ X( J1 ) = X( J1 ) / TMP
+ XJ = ABS( X( J1 ) )
+*
+* Scale x if necessary to avoid overflow when adding a
+* multiple of column j1 of T.
+*
+ IF( XJ.GT.ONE ) THEN
+ REC = ONE / XJ
+ IF( WORK( J1 ).GT.( BIGNUM-XMAX )*REC ) THEN
+ CALL SSCAL( N, REC, X, 1 )
+ SCALE = SCALE*REC
+ END IF
+ END IF
+ IF( J1.GT.1 ) THEN
+ CALL SAXPY( J1-1, -X( J1 ), T( 1, J1 ), 1, X, 1 )
+ K = ISAMAX( J1-1, X, 1 )
+ XMAX = ABS( X( K ) )
+ END IF
+*
+ ELSE
+*
+* Meet 2 by 2 diagonal block
+*
+* Call 2 by 2 linear system solve, to take
+* care of possible overflow by scaling factor.
+*
+ D( 1, 1 ) = X( J1 )
+ D( 2, 1 ) = X( J2 )
+ CALL SLALN2( .FALSE., 2, 1, SMIN, ONE, T( J1, J1 ),
+ $ LDT, ONE, ONE, D, 2, ZERO, ZERO, V, 2,
+ $ SCALOC, XNORM, IERR )
+ IF( IERR.NE.0 )
+ $ INFO = 2
+*
+ IF( SCALOC.NE.ONE ) THEN
+ CALL SSCAL( N, SCALOC, X, 1 )
+ SCALE = SCALE*SCALOC
+ END IF
+ X( J1 ) = V( 1, 1 )
+ X( J2 ) = V( 2, 1 )
+*
+* Scale V(1,1) (= X(J1)) and/or V(2,1) (=X(J2))
+* to avoid overflow in updating right-hand side.
+*
+ XJ = MAX( ABS( V( 1, 1 ) ), ABS( V( 2, 1 ) ) )
+ IF( XJ.GT.ONE ) THEN
+ REC = ONE / XJ
+ IF( MAX( WORK( J1 ), WORK( J2 ) ).GT.
+ $ ( BIGNUM-XMAX )*REC ) THEN
+ CALL SSCAL( N, REC, X, 1 )
+ SCALE = SCALE*REC
+ END IF
+ END IF
+*
+* Update right-hand side
+*
+ IF( J1.GT.1 ) THEN
+ CALL SAXPY( J1-1, -X( J1 ), T( 1, J1 ), 1, X, 1 )
+ CALL SAXPY( J1-1, -X( J2 ), T( 1, J2 ), 1, X, 1 )
+ K = ISAMAX( J1-1, X, 1 )
+ XMAX = ABS( X( K ) )
+ END IF
+*
+ END IF
+*
+ 30 CONTINUE
+*
+ ELSE
+*
+* Solve T'*p = scale*c
+*
+ JNEXT = 1
+ DO 40 J = 1, N
+ IF( J.LT.JNEXT )
+ $ GO TO 40
+ J1 = J
+ J2 = J
+ JNEXT = J + 1
+ IF( J.LT.N ) THEN
+ IF( T( J+1, J ).NE.ZERO ) THEN
+ J2 = J + 1
+ JNEXT = J + 2
+ END IF
+ END IF
+*
+ IF( J1.EQ.J2 ) THEN
+*
+* 1 by 1 diagonal block
+*
+* Scale if necessary to avoid overflow in forming the
+* right-hand side element by inner product.
+*
+ XJ = ABS( X( J1 ) )
+ IF( XMAX.GT.ONE ) THEN
+ REC = ONE / XMAX
+ IF( WORK( J1 ).GT.( BIGNUM-XJ )*REC ) THEN
+ CALL SSCAL( N, REC, X, 1 )
+ SCALE = SCALE*REC
+ XMAX = XMAX*REC
+ END IF
+ END IF
+*
+ X( J1 ) = X( J1 ) - SDOT( J1-1, T( 1, J1 ), 1, X, 1 )
+*
+ XJ = ABS( X( J1 ) )
+ TJJ = ABS( T( J1, J1 ) )
+ TMP = T( J1, J1 )
+ IF( TJJ.LT.SMIN ) THEN
+ TMP = SMIN
+ TJJ = SMIN
+ INFO = 1
+ END IF
+*
+ IF( TJJ.LT.ONE ) THEN
+ IF( XJ.GT.BIGNUM*TJJ ) THEN
+ REC = ONE / XJ
+ CALL SSCAL( N, REC, X, 1 )
+ SCALE = SCALE*REC
+ XMAX = XMAX*REC
+ END IF
+ END IF
+ X( J1 ) = X( J1 ) / TMP
+ XMAX = MAX( XMAX, ABS( X( J1 ) ) )
+*
+ ELSE
+*
+* 2 by 2 diagonal block
+*
+* Scale if necessary to avoid overflow in forming the
+* right-hand side elements by inner product.
+*
+ XJ = MAX( ABS( X( J1 ) ), ABS( X( J2 ) ) )
+ IF( XMAX.GT.ONE ) THEN
+ REC = ONE / XMAX
+ IF( MAX( WORK( J2 ), WORK( J1 ) ).GT.( BIGNUM-XJ )*
+ $ REC ) THEN
+ CALL SSCAL( N, REC, X, 1 )
+ SCALE = SCALE*REC
+ XMAX = XMAX*REC
+ END IF
+ END IF
+*
+ D( 1, 1 ) = X( J1 ) - SDOT( J1-1, T( 1, J1 ), 1, X,
+ $ 1 )
+ D( 2, 1 ) = X( J2 ) - SDOT( J1-1, T( 1, J2 ), 1, X,
+ $ 1 )
+*
+ CALL SLALN2( .TRUE., 2, 1, SMIN, ONE, T( J1, J1 ),
+ $ LDT, ONE, ONE, D, 2, ZERO, ZERO, V, 2,
+ $ SCALOC, XNORM, IERR )
+ IF( IERR.NE.0 )
+ $ INFO = 2
+*
+ IF( SCALOC.NE.ONE ) THEN
+ CALL SSCAL( N, SCALOC, X, 1 )
+ SCALE = SCALE*SCALOC
+ END IF
+ X( J1 ) = V( 1, 1 )
+ X( J2 ) = V( 2, 1 )
+ XMAX = MAX( ABS( X( J1 ) ), ABS( X( J2 ) ), XMAX )
+*
+ END IF
+ 40 CONTINUE
+ END IF
+*
+ ELSE
+*
+ SMINW = MAX( EPS*ABS( W ), SMIN )
+ IF( NOTRAN ) THEN
+*
+* Solve (T + iB)*(p+iq) = c+id
+*
+ JNEXT = N
+ DO 70 J = N, 1, -1
+ IF( J.GT.JNEXT )
+ $ GO TO 70
+ J1 = J
+ J2 = J
+ JNEXT = J - 1
+ IF( J.GT.1 ) THEN
+ IF( T( J, J-1 ).NE.ZERO ) THEN
+ J1 = J - 1
+ JNEXT = J - 2
+ END IF
+ END IF
+*
+ IF( J1.EQ.J2 ) THEN
+*
+* 1 by 1 diagonal block
+*
+* Scale if necessary to avoid overflow in division
+*
+ Z = W
+ IF( J1.EQ.1 )
+ $ Z = B( 1 )
+ XJ = ABS( X( J1 ) ) + ABS( X( N+J1 ) )
+ TJJ = ABS( T( J1, J1 ) ) + ABS( Z )
+ TMP = T( J1, J1 )
+ IF( TJJ.LT.SMINW ) THEN
+ TMP = SMINW
+ TJJ = SMINW
+ INFO = 1
+ END IF
+*
+ IF( XJ.EQ.ZERO )
+ $ GO TO 70
+*
+ IF( TJJ.LT.ONE ) THEN
+ IF( XJ.GT.BIGNUM*TJJ ) THEN
+ REC = ONE / XJ
+ CALL SSCAL( N2, REC, X, 1 )
+ SCALE = SCALE*REC
+ XMAX = XMAX*REC
+ END IF
+ END IF
+ CALL SLADIV( X( J1 ), X( N+J1 ), TMP, Z, SR, SI )
+ X( J1 ) = SR
+ X( N+J1 ) = SI
+ XJ = ABS( X( J1 ) ) + ABS( X( N+J1 ) )
+*
+* Scale x if necessary to avoid overflow when adding a
+* multiple of column j1 of T.
+*
+ IF( XJ.GT.ONE ) THEN
+ REC = ONE / XJ
+ IF( WORK( J1 ).GT.( BIGNUM-XMAX )*REC ) THEN
+ CALL SSCAL( N2, REC, X, 1 )
+ SCALE = SCALE*REC
+ END IF
+ END IF
+*
+ IF( J1.GT.1 ) THEN
+ CALL SAXPY( J1-1, -X( J1 ), T( 1, J1 ), 1, X, 1 )
+ CALL SAXPY( J1-1, -X( N+J1 ), T( 1, J1 ), 1,
+ $ X( N+1 ), 1 )
+*
+ X( 1 ) = X( 1 ) + B( J1 )*X( N+J1 )
+ X( N+1 ) = X( N+1 ) - B( J1 )*X( J1 )
+*
+ XMAX = ZERO
+ DO 50 K = 1, J1 - 1
+ XMAX = MAX( XMAX, ABS( X( K ) )+
+ $ ABS( X( K+N ) ) )
+ 50 CONTINUE
+ END IF
+*
+ ELSE
+*
+* Meet 2 by 2 diagonal block
+*
+ D( 1, 1 ) = X( J1 )
+ D( 2, 1 ) = X( J2 )
+ D( 1, 2 ) = X( N+J1 )
+ D( 2, 2 ) = X( N+J2 )
+ CALL SLALN2( .FALSE., 2, 2, SMINW, ONE, T( J1, J1 ),
+ $ LDT, ONE, ONE, D, 2, ZERO, -W, V, 2,
+ $ SCALOC, XNORM, IERR )
+ IF( IERR.NE.0 )
+ $ INFO = 2
+*
+ IF( SCALOC.NE.ONE ) THEN
+ CALL SSCAL( 2*N, SCALOC, X, 1 )
+ SCALE = SCALOC*SCALE
+ END IF
+ X( J1 ) = V( 1, 1 )
+ X( J2 ) = V( 2, 1 )
+ X( N+J1 ) = V( 1, 2 )
+ X( N+J2 ) = V( 2, 2 )
+*
+* Scale X(J1), .... to avoid overflow in
+* updating right hand side.
+*
+ XJ = MAX( ABS( V( 1, 1 ) )+ABS( V( 1, 2 ) ),
+ $ ABS( V( 2, 1 ) )+ABS( V( 2, 2 ) ) )
+ IF( XJ.GT.ONE ) THEN
+ REC = ONE / XJ
+ IF( MAX( WORK( J1 ), WORK( J2 ) ).GT.
+ $ ( BIGNUM-XMAX )*REC ) THEN
+ CALL SSCAL( N2, REC, X, 1 )
+ SCALE = SCALE*REC
+ END IF
+ END IF
+*
+* Update the right-hand side.
+*
+ IF( J1.GT.1 ) THEN
+ CALL SAXPY( J1-1, -X( J1 ), T( 1, J1 ), 1, X, 1 )
+ CALL SAXPY( J1-1, -X( J2 ), T( 1, J2 ), 1, X, 1 )
+*
+ CALL SAXPY( J1-1, -X( N+J1 ), T( 1, J1 ), 1,
+ $ X( N+1 ), 1 )
+ CALL SAXPY( J1-1, -X( N+J2 ), T( 1, J2 ), 1,
+ $ X( N+1 ), 1 )
+*
+ X( 1 ) = X( 1 ) + B( J1 )*X( N+J1 ) +
+ $ B( J2 )*X( N+J2 )
+ X( N+1 ) = X( N+1 ) - B( J1 )*X( J1 ) -
+ $ B( J2 )*X( J2 )
+*
+ XMAX = ZERO
+ DO 60 K = 1, J1 - 1
+ XMAX = MAX( ABS( X( K ) )+ABS( X( K+N ) ),
+ $ XMAX )
+ 60 CONTINUE
+ END IF
+*
+ END IF
+ 70 CONTINUE
+*
+ ELSE
+*
+* Solve (T + iB)'*(p+iq) = c+id
+*
+ JNEXT = 1
+ DO 80 J = 1, N
+ IF( J.LT.JNEXT )
+ $ GO TO 80
+ J1 = J
+ J2 = J
+ JNEXT = J + 1
+ IF( J.LT.N ) THEN
+ IF( T( J+1, J ).NE.ZERO ) THEN
+ J2 = J + 1
+ JNEXT = J + 2
+ END IF
+ END IF
+*
+ IF( J1.EQ.J2 ) THEN
+*
+* 1 by 1 diagonal block
+*
+* Scale if necessary to avoid overflow in forming the
+* right-hand side element by inner product.
+*
+ XJ = ABS( X( J1 ) ) + ABS( X( J1+N ) )
+ IF( XMAX.GT.ONE ) THEN
+ REC = ONE / XMAX
+ IF( WORK( J1 ).GT.( BIGNUM-XJ )*REC ) THEN
+ CALL SSCAL( N2, REC, X, 1 )
+ SCALE = SCALE*REC
+ XMAX = XMAX*REC
+ END IF
+ END IF
+*
+ X( J1 ) = X( J1 ) - SDOT( J1-1, T( 1, J1 ), 1, X, 1 )
+ X( N+J1 ) = X( N+J1 ) - SDOT( J1-1, T( 1, J1 ), 1,
+ $ X( N+1 ), 1 )
+ IF( J1.GT.1 ) THEN
+ X( J1 ) = X( J1 ) - B( J1 )*X( N+1 )
+ X( N+J1 ) = X( N+J1 ) + B( J1 )*X( 1 )
+ END IF
+ XJ = ABS( X( J1 ) ) + ABS( X( J1+N ) )
+*
+ Z = W
+ IF( J1.EQ.1 )
+ $ Z = B( 1 )
+*
+* Scale if necessary to avoid overflow in
+* complex division
+*
+ TJJ = ABS( T( J1, J1 ) ) + ABS( Z )
+ TMP = T( J1, J1 )
+ IF( TJJ.LT.SMINW ) THEN
+ TMP = SMINW
+ TJJ = SMINW
+ INFO = 1
+ END IF
+*
+ IF( TJJ.LT.ONE ) THEN
+ IF( XJ.GT.BIGNUM*TJJ ) THEN
+ REC = ONE / XJ
+ CALL SSCAL( N2, REC, X, 1 )
+ SCALE = SCALE*REC
+ XMAX = XMAX*REC
+ END IF
+ END IF
+ CALL SLADIV( X( J1 ), X( N+J1 ), TMP, -Z, SR, SI )
+ X( J1 ) = SR
+ X( J1+N ) = SI
+ XMAX = MAX( ABS( X( J1 ) )+ABS( X( J1+N ) ), XMAX )
+*
+ ELSE
+*
+* 2 by 2 diagonal block
+*
+* Scale if necessary to avoid overflow in forming the
+* right-hand side element by inner product.
+*
+ XJ = MAX( ABS( X( J1 ) )+ABS( X( N+J1 ) ),
+ $ ABS( X( J2 ) )+ABS( X( N+J2 ) ) )
+ IF( XMAX.GT.ONE ) THEN
+ REC = ONE / XMAX
+ IF( MAX( WORK( J1 ), WORK( J2 ) ).GT.
+ $ ( BIGNUM-XJ ) / XMAX ) THEN
+ CALL SSCAL( N2, REC, X, 1 )
+ SCALE = SCALE*REC
+ XMAX = XMAX*REC
+ END IF
+ END IF
+*
+ D( 1, 1 ) = X( J1 ) - SDOT( J1-1, T( 1, J1 ), 1, X,
+ $ 1 )
+ D( 2, 1 ) = X( J2 ) - SDOT( J1-1, T( 1, J2 ), 1, X,
+ $ 1 )
+ D( 1, 2 ) = X( N+J1 ) - SDOT( J1-1, T( 1, J1 ), 1,
+ $ X( N+1 ), 1 )
+ D( 2, 2 ) = X( N+J2 ) - SDOT( J1-1, T( 1, J2 ), 1,
+ $ X( N+1 ), 1 )
+ D( 1, 1 ) = D( 1, 1 ) - B( J1 )*X( N+1 )
+ D( 2, 1 ) = D( 2, 1 ) - B( J2 )*X( N+1 )
+ D( 1, 2 ) = D( 1, 2 ) + B( J1 )*X( 1 )
+ D( 2, 2 ) = D( 2, 2 ) + B( J2 )*X( 1 )
+*
+ CALL SLALN2( .TRUE., 2, 2, SMINW, ONE, T( J1, J1 ),
+ $ LDT, ONE, ONE, D, 2, ZERO, W, V, 2,
+ $ SCALOC, XNORM, IERR )
+ IF( IERR.NE.0 )
+ $ INFO = 2
+*
+ IF( SCALOC.NE.ONE ) THEN
+ CALL SSCAL( N2, SCALOC, X, 1 )
+ SCALE = SCALOC*SCALE
+ END IF
+ X( J1 ) = V( 1, 1 )
+ X( J2 ) = V( 2, 1 )
+ X( N+J1 ) = V( 1, 2 )
+ X( N+J2 ) = V( 2, 2 )
+ XMAX = MAX( ABS( X( J1 ) )+ABS( X( N+J1 ) ),
+ $ ABS( X( J2 ) )+ABS( X( N+J2 ) ), XMAX )
+*
+ END IF
+*
+ 80 CONTINUE
+*
+ END IF
+*
+ END IF
+*
+ RETURN
+*
+* End of SLAQTR
+*
+ END
+ SUBROUTINE SLAR1V( N, B1, BN, LAMBDA, D, L, LD, LLD,
+ $ PIVMIN, GAPTOL, Z, WANTNC, NEGCNT, ZTZ, MINGMA,
+ $ R, ISUPPZ, NRMINV, RESID, RQCORR, WORK )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ LOGICAL WANTNC
+ INTEGER B1, BN, N, NEGCNT, R
+ REAL GAPTOL, LAMBDA, MINGMA, NRMINV, PIVMIN, RESID,
+ $ RQCORR, ZTZ
+* ..
+* .. Array Arguments ..
+ INTEGER ISUPPZ( * )
+ REAL D( * ), L( * ), LD( * ), LLD( * ),
+ $ WORK( * )
+ REAL Z( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SLAR1V computes the (scaled) r-th column of the inverse of
+* the sumbmatrix in rows B1 through BN of the tridiagonal matrix
+* L D L^T - sigma I. When sigma is close to an eigenvalue, the
+* computed vector is an accurate eigenvector. Usually, r corresponds
+* to the index where the eigenvector is largest in magnitude.
+* The following steps accomplish this computation :
+* (a) Stationary qd transform, L D L^T - sigma I = L(+) D(+) L(+)^T,
+* (b) Progressive qd transform, L D L^T - sigma I = U(-) D(-) U(-)^T,
+* (c) Computation of the diagonal elements of the inverse of
+* L D L^T - sigma I by combining the above transforms, and choosing
+* r as the index where the diagonal of the inverse is (one of the)
+* largest in magnitude.
+* (d) Computation of the (scaled) r-th column of the inverse using the
+* twisted factorization obtained by combining the top part of the
+* the stationary and the bottom part of the progressive transform.
+*
+* Arguments
+* =========
+*
+* N (input) INTEGER
+* The order of the matrix L D L^T.
+*
+* B1 (input) INTEGER
+* First index of the submatrix of L D L^T.
+*
+* BN (input) INTEGER
+* Last index of the submatrix of L D L^T.
+*
+* LAMBDA (input) REAL
+* The shift. In order to compute an accurate eigenvector,
+* LAMBDA should be a good approximation to an eigenvalue
+* of L D L^T.
+*
+* L (input) REAL array, dimension (N-1)
+* The (n-1) subdiagonal elements of the unit bidiagonal matrix
+* L, in elements 1 to N-1.
+*
+* D (input) REAL array, dimension (N)
+* The n diagonal elements of the diagonal matrix D.
+*
+* LD (input) REAL array, dimension (N-1)
+* The n-1 elements L(i)*D(i).
+*
+* LLD (input) REAL array, dimension (N-1)
+* The n-1 elements L(i)*L(i)*D(i).
+*
+* PIVMIN (input) REAL
+* The minimum pivot in the Sturm sequence.
+*
+* GAPTOL (input) REAL
+* Tolerance that indicates when eigenvector entries are negligible
+* w.r.t. their contribution to the residual.
+*
+* Z (input/output) REAL array, dimension (N)
+* On input, all entries of Z must be set to 0.
+* On output, Z contains the (scaled) r-th column of the
+* inverse. The scaling is such that Z(R) equals 1.
+*
+* WANTNC (input) LOGICAL
+* Specifies whether NEGCNT has to be computed.
+*
+* NEGCNT (output) INTEGER
+* If WANTNC is .TRUE. then NEGCNT = the number of pivots < pivmin
+* in the matrix factorization L D L^T, and NEGCNT = -1 otherwise.
+*
+* ZTZ (output) REAL
+* The square of the 2-norm of Z.
+*
+* MINGMA (output) REAL
+* The reciprocal of the largest (in magnitude) diagonal
+* element of the inverse of L D L^T - sigma I.
+*
+* R (input/output) INTEGER
+* The twist index for the twisted factorization used to
+* compute Z.
+* On input, 0 <= R <= N. If R is input as 0, R is set to
+* the index where (L D L^T - sigma I)^{-1} is largest
+* in magnitude. If 1 <= R <= N, R is unchanged.
+* On output, R contains the twist index used to compute Z.
+* Ideally, R designates the position of the maximum entry in the
+* eigenvector.
+*
+* ISUPPZ (output) INTEGER array, dimension (2)
+* The support of the vector in Z, i.e., the vector Z is
+* nonzero only in elements ISUPPZ(1) through ISUPPZ( 2 ).
+*
+* NRMINV (output) REAL
+* NRMINV = 1/SQRT( ZTZ )
+*
+* RESID (output) REAL
+* The residual of the FP vector.
+* RESID = ABS( MINGMA )/SQRT( ZTZ )
+*
+* RQCORR (output) REAL
+* The Rayleigh Quotient correction to LAMBDA.
+* RQCORR = MINGMA*TMP
+*
+* WORK (workspace) REAL array, dimension (4*N)
+*
+* Further Details
+* ===============
+*
+* Based on contributions by
+* Beresford Parlett, University of California, Berkeley, USA
+* Jim Demmel, University of California, Berkeley, USA
+* Inderjit Dhillon, University of Texas, Austin, USA
+* Osni Marques, LBNL/NERSC, USA
+* Christof Voemel, University of California, Berkeley, USA
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO, ONE
+ PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 )
+
+* ..
+* .. Local Scalars ..
+ LOGICAL SAWNAN1, SAWNAN2
+ INTEGER I, INDLPL, INDP, INDS, INDUMN, NEG1, NEG2, R1,
+ $ R2
+ REAL DMINUS, DPLUS, EPS, S, TMP
+* ..
+* .. External Functions ..
+ LOGICAL SISNAN
+ REAL SLAMCH
+ EXTERNAL SISNAN, SLAMCH
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS
+* ..
+* .. Executable Statements ..
+*
+ EPS = SLAMCH( 'Precision' )
+
+
+ IF( R.EQ.0 ) THEN
+ R1 = B1
+ R2 = BN
+ ELSE
+ R1 = R
+ R2 = R
+ END IF
+
+* Storage for LPLUS
+ INDLPL = 0
+* Storage for UMINUS
+ INDUMN = N
+ INDS = 2*N + 1
+ INDP = 3*N + 1
+
+ IF( B1.EQ.1 ) THEN
+ WORK( INDS ) = ZERO
+ ELSE
+ WORK( INDS+B1-1 ) = LLD( B1-1 )
+ END IF
+
+*
+* Compute the stationary transform (using the differential form)
+* until the index R2.
+*
+ SAWNAN1 = .FALSE.
+ NEG1 = 0
+ S = WORK( INDS+B1-1 ) - LAMBDA
+ DO 50 I = B1, R1 - 1
+ DPLUS = D( I ) + S
+ WORK( INDLPL+I ) = LD( I ) / DPLUS
+ IF(DPLUS.LT.ZERO) NEG1 = NEG1 + 1
+ WORK( INDS+I ) = S*WORK( INDLPL+I )*L( I )
+ S = WORK( INDS+I ) - LAMBDA
+ 50 CONTINUE
+ SAWNAN1 = SISNAN( S )
+ IF( SAWNAN1 ) GOTO 60
+ DO 51 I = R1, R2 - 1
+ DPLUS = D( I ) + S
+ WORK( INDLPL+I ) = LD( I ) / DPLUS
+ WORK( INDS+I ) = S*WORK( INDLPL+I )*L( I )
+ S = WORK( INDS+I ) - LAMBDA
+ 51 CONTINUE
+ SAWNAN1 = SISNAN( S )
+*
+ 60 CONTINUE
+ IF( SAWNAN1 ) THEN
+* Runs a slower version of the above loop if a NaN is detected
+ NEG1 = 0
+ S = WORK( INDS+B1-1 ) - LAMBDA
+ DO 70 I = B1, R1 - 1
+ DPLUS = D( I ) + S
+ IF(ABS(DPLUS).LT.PIVMIN) DPLUS = -PIVMIN
+ WORK( INDLPL+I ) = LD( I ) / DPLUS
+ IF(DPLUS.LT.ZERO) NEG1 = NEG1 + 1
+ WORK( INDS+I ) = S*WORK( INDLPL+I )*L( I )
+ IF( WORK( INDLPL+I ).EQ.ZERO )
+ $ WORK( INDS+I ) = LLD( I )
+ S = WORK( INDS+I ) - LAMBDA
+ 70 CONTINUE
+ DO 71 I = R1, R2 - 1
+ DPLUS = D( I ) + S
+ IF(ABS(DPLUS).LT.PIVMIN) DPLUS = -PIVMIN
+ WORK( INDLPL+I ) = LD( I ) / DPLUS
+ WORK( INDS+I ) = S*WORK( INDLPL+I )*L( I )
+ IF( WORK( INDLPL+I ).EQ.ZERO )
+ $ WORK( INDS+I ) = LLD( I )
+ S = WORK( INDS+I ) - LAMBDA
+ 71 CONTINUE
+ END IF
+*
+* Compute the progressive transform (using the differential form)
+* until the index R1
+*
+ SAWNAN2 = .FALSE.
+ NEG2 = 0
+ WORK( INDP+BN-1 ) = D( BN ) - LAMBDA
+ DO 80 I = BN - 1, R1, -1
+ DMINUS = LLD( I ) + WORK( INDP+I )
+ TMP = D( I ) / DMINUS
+ IF(DMINUS.LT.ZERO) NEG2 = NEG2 + 1
+ WORK( INDUMN+I ) = L( I )*TMP
+ WORK( INDP+I-1 ) = WORK( INDP+I )*TMP - LAMBDA
+ 80 CONTINUE
+ TMP = WORK( INDP+R1-1 )
+ SAWNAN2 = SISNAN( TMP )
+
+ IF( SAWNAN2 ) THEN
+* Runs a slower version of the above loop if a NaN is detected
+ NEG2 = 0
+ DO 100 I = BN-1, R1, -1
+ DMINUS = LLD( I ) + WORK( INDP+I )
+ IF(ABS(DMINUS).LT.PIVMIN) DMINUS = -PIVMIN
+ TMP = D( I ) / DMINUS
+ IF(DMINUS.LT.ZERO) NEG2 = NEG2 + 1
+ WORK( INDUMN+I ) = L( I )*TMP
+ WORK( INDP+I-1 ) = WORK( INDP+I )*TMP - LAMBDA
+ IF( TMP.EQ.ZERO )
+ $ WORK( INDP+I-1 ) = D( I ) - LAMBDA
+ 100 CONTINUE
+ END IF
+*
+* Find the index (from R1 to R2) of the largest (in magnitude)
+* diagonal element of the inverse
+*
+ MINGMA = WORK( INDS+R1-1 ) + WORK( INDP+R1-1 )
+ IF( MINGMA.LT.ZERO ) NEG1 = NEG1 + 1
+ IF( WANTNC ) THEN
+ NEGCNT = NEG1 + NEG2
+ ELSE
+ NEGCNT = -1
+ ENDIF
+ IF( ABS(MINGMA).EQ.ZERO )
+ $ MINGMA = EPS*WORK( INDS+R1-1 )
+ R = R1
+ DO 110 I = R1, R2 - 1
+ TMP = WORK( INDS+I ) + WORK( INDP+I )
+ IF( TMP.EQ.ZERO )
+ $ TMP = EPS*WORK( INDS+I )
+ IF( ABS( TMP ).LE.ABS( MINGMA ) ) THEN
+ MINGMA = TMP
+ R = I + 1
+ END IF
+ 110 CONTINUE
+*
+* Compute the FP vector: solve N^T v = e_r
+*
+ ISUPPZ( 1 ) = B1
+ ISUPPZ( 2 ) = BN
+ Z( R ) = ONE
+ ZTZ = ONE
+*
+* Compute the FP vector upwards from R
+*
+ IF( .NOT.SAWNAN1 .AND. .NOT.SAWNAN2 ) THEN
+ DO 210 I = R-1, B1, -1
+ Z( I ) = -( WORK( INDLPL+I )*Z( I+1 ) )
+ IF( (ABS(Z(I))+ABS(Z(I+1)))* ABS(LD(I)).LT.GAPTOL )
+ $ THEN
+ Z( I ) = ZERO
+ ISUPPZ( 1 ) = I + 1
+ GOTO 220
+ ENDIF
+ ZTZ = ZTZ + Z( I )*Z( I )
+ 210 CONTINUE
+ 220 CONTINUE
+ ELSE
+* Run slower loop if NaN occurred.
+ DO 230 I = R - 1, B1, -1
+ IF( Z( I+1 ).EQ.ZERO ) THEN
+ Z( I ) = -( LD( I+1 ) / LD( I ) )*Z( I+2 )
+ ELSE
+ Z( I ) = -( WORK( INDLPL+I )*Z( I+1 ) )
+ END IF
+ IF( (ABS(Z(I))+ABS(Z(I+1)))* ABS(LD(I)).LT.GAPTOL )
+ $ THEN
+ Z( I ) = ZERO
+ ISUPPZ( 1 ) = I + 1
+ GO TO 240
+ END IF
+ ZTZ = ZTZ + Z( I )*Z( I )
+ 230 CONTINUE
+ 240 CONTINUE
+ ENDIF
+
+* Compute the FP vector downwards from R in blocks of size BLKSIZ
+ IF( .NOT.SAWNAN1 .AND. .NOT.SAWNAN2 ) THEN
+ DO 250 I = R, BN-1
+ Z( I+1 ) = -( WORK( INDUMN+I )*Z( I ) )
+ IF( (ABS(Z(I))+ABS(Z(I+1)))* ABS(LD(I)).LT.GAPTOL )
+ $ THEN
+ Z( I+1 ) = ZERO
+ ISUPPZ( 2 ) = I
+ GO TO 260
+ END IF
+ ZTZ = ZTZ + Z( I+1 )*Z( I+1 )
+ 250 CONTINUE
+ 260 CONTINUE
+ ELSE
+* Run slower loop if NaN occurred.
+ DO 270 I = R, BN - 1
+ IF( Z( I ).EQ.ZERO ) THEN
+ Z( I+1 ) = -( LD( I-1 ) / LD( I ) )*Z( I-1 )
+ ELSE
+ Z( I+1 ) = -( WORK( INDUMN+I )*Z( I ) )
+ END IF
+ IF( (ABS(Z(I))+ABS(Z(I+1)))* ABS(LD(I)).LT.GAPTOL )
+ $ THEN
+ Z( I+1 ) = ZERO
+ ISUPPZ( 2 ) = I
+ GO TO 280
+ END IF
+ ZTZ = ZTZ + Z( I+1 )*Z( I+1 )
+ 270 CONTINUE
+ 280 CONTINUE
+ END IF
+*
+* Compute quantities for convergence test
+*
+ TMP = ONE / ZTZ
+ NRMINV = SQRT( TMP )
+ RESID = ABS( MINGMA )*NRMINV
+ RQCORR = MINGMA*TMP
+*
+*
+ RETURN
+*
+* End of SLAR1V
+*
+ END
+ SUBROUTINE SLAR2V( N, X, Y, Z, INCX, C, S, INCC )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INCC, INCX, N
+* ..
+* .. Array Arguments ..
+ REAL C( * ), S( * ), X( * ), Y( * ), Z( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SLAR2V applies a vector of real plane rotations from both sides to
+* a sequence of 2-by-2 real symmetric matrices, defined by the elements
+* of the vectors x, y and z. For i = 1,2,...,n
+*
+* ( x(i) z(i) ) := ( c(i) s(i) ) ( x(i) z(i) ) ( c(i) -s(i) )
+* ( z(i) y(i) ) ( -s(i) c(i) ) ( z(i) y(i) ) ( s(i) c(i) )
+*
+* Arguments
+* =========
+*
+* N (input) INTEGER
+* The number of plane rotations to be applied.
+*
+* X (input/output) REAL array,
+* dimension (1+(N-1)*INCX)
+* The vector x.
+*
+* Y (input/output) REAL array,
+* dimension (1+(N-1)*INCX)
+* The vector y.
+*
+* Z (input/output) REAL array,
+* dimension (1+(N-1)*INCX)
+* The vector z.
+*
+* INCX (input) INTEGER
+* The increment between elements of X, Y and Z. INCX > 0.
+*
+* C (input) REAL array, dimension (1+(N-1)*INCC)
+* The cosines of the plane rotations.
+*
+* S (input) REAL array, dimension (1+(N-1)*INCC)
+* The sines of the plane rotations.
+*
+* INCC (input) INTEGER
+* The increment between elements of C and S. INCC > 0.
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ INTEGER I, IC, IX
+ REAL CI, SI, T1, T2, T3, T4, T5, T6, XI, YI, ZI
+* ..
+* .. Executable Statements ..
+*
+ IX = 1
+ IC = 1
+ DO 10 I = 1, N
+ XI = X( IX )
+ YI = Y( IX )
+ ZI = Z( IX )
+ CI = C( IC )
+ SI = S( IC )
+ T1 = SI*ZI
+ T2 = CI*ZI
+ T3 = T2 - SI*XI
+ T4 = T2 + SI*YI
+ T5 = CI*XI + T1
+ T6 = CI*YI - T1
+ X( IX ) = CI*T5 + SI*T4
+ Y( IX ) = CI*T6 - SI*T3
+ Z( IX ) = CI*T4 - SI*T5
+ IX = IX + INCX
+ IC = IC + INCC
+ 10 CONTINUE
+*
+* End of SLAR2V
+*
+ RETURN
+ END
+ SUBROUTINE SLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER SIDE
+ INTEGER INCV, LDC, M, N
+ REAL TAU
+* ..
+* .. Array Arguments ..
+ REAL C( LDC, * ), V( * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SLARF applies a real elementary reflector H to a real m by n matrix
+* C, from either the left or the right. H is represented in the form
+*
+* H = I - tau * v * v'
+*
+* where tau is a real scalar and v is a real vector.
+*
+* If tau = 0, then H is taken to be the unit matrix.
+*
+* Arguments
+* =========
+*
+* SIDE (input) CHARACTER*1
+* = 'L': form H * C
+* = 'R': form C * H
+*
+* M (input) INTEGER
+* The number of rows of the matrix C.
+*
+* N (input) INTEGER
+* The number of columns of the matrix C.
+*
+* V (input) REAL array, dimension
+* (1 + (M-1)*abs(INCV)) if SIDE = 'L'
+* or (1 + (N-1)*abs(INCV)) if SIDE = 'R'
+* The vector v in the representation of H. V is not used if
+* TAU = 0.
+*
+* INCV (input) INTEGER
+* The increment between elements of v. INCV <> 0.
+*
+* TAU (input) REAL
+* The value tau in the representation of H.
+*
+* C (input/output) REAL array, dimension (LDC,N)
+* On entry, the m by n matrix C.
+* On exit, C is overwritten by the matrix H * C if SIDE = 'L',
+* or C * H if SIDE = 'R'.
+*
+* LDC (input) INTEGER
+* The leading dimension of the array C. LDC >= max(1,M).
+*
+* WORK (workspace) REAL array, dimension
+* (N) if SIDE = 'L'
+* or (M) if SIDE = 'R'
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ONE, ZERO
+ PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+* ..
+* .. External Subroutines ..
+ EXTERNAL SGEMV, SGER
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. Executable Statements ..
+*
+ IF( LSAME( SIDE, 'L' ) ) THEN
+*
+* Form H * C
+*
+ IF( TAU.NE.ZERO ) THEN
+*
+* w := C' * v
+*
+ CALL SGEMV( 'Transpose', M, N, ONE, C, LDC, V, INCV, ZERO,
+ $ WORK, 1 )
+*
+* C := C - v * w'
+*
+ CALL SGER( M, N, -TAU, V, INCV, WORK, 1, C, LDC )
+ END IF
+ ELSE
+*
+* Form C * H
+*
+ IF( TAU.NE.ZERO ) THEN
+*
+* w := C * v
+*
+ CALL SGEMV( 'No transpose', M, N, ONE, C, LDC, V, INCV,
+ $ ZERO, WORK, 1 )
+*
+* C := C - w * v'
+*
+ CALL SGER( M, N, -TAU, WORK, 1, V, INCV, C, LDC )
+ END IF
+ END IF
+ RETURN
+*
+* End of SLARF
+*
+ END
+ SUBROUTINE SLARFB( SIDE, TRANS, DIRECT, STOREV, M, N, K, V, LDV,
+ $ T, LDT, C, LDC, WORK, LDWORK )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER DIRECT, SIDE, STOREV, TRANS
+ INTEGER K, LDC, LDT, LDV, LDWORK, M, N
+* ..
+* .. Array Arguments ..
+ REAL C( LDC, * ), T( LDT, * ), V( LDV, * ),
+ $ WORK( LDWORK, * )
+* ..
+*
+* Purpose
+* =======
+*
+* SLARFB applies a real block reflector H or its transpose H' to a
+* real m by n matrix C, from either the left or the right.
+*
+* Arguments
+* =========
+*
+* SIDE (input) CHARACTER*1
+* = 'L': apply H or H' from the Left
+* = 'R': apply H or H' from the Right
+*
+* TRANS (input) CHARACTER*1
+* = 'N': apply H (No transpose)
+* = 'T': apply H' (Transpose)
+*
+* DIRECT (input) CHARACTER*1
+* Indicates how H is formed from a product of elementary
+* reflectors
+* = 'F': H = H(1) H(2) . . . H(k) (Forward)
+* = 'B': H = H(k) . . . H(2) H(1) (Backward)
+*
+* STOREV (input) CHARACTER*1
+* Indicates how the vectors which define the elementary
+* reflectors are stored:
+* = 'C': Columnwise
+* = 'R': Rowwise
+*
+* M (input) INTEGER
+* The number of rows of the matrix C.
+*
+* N (input) INTEGER
+* The number of columns of the matrix C.
+*
+* K (input) INTEGER
+* The order of the matrix T (= the number of elementary
+* reflectors whose product defines the block reflector).
+*
+* V (input) REAL array, dimension
+* (LDV,K) if STOREV = 'C'
+* (LDV,M) if STOREV = 'R' and SIDE = 'L'
+* (LDV,N) if STOREV = 'R' and SIDE = 'R'
+* The matrix V. See further details.
+*
+* LDV (input) INTEGER
+* The leading dimension of the array V.
+* If STOREV = 'C' and SIDE = 'L', LDV >= max(1,M);
+* if STOREV = 'C' and SIDE = 'R', LDV >= max(1,N);
+* if STOREV = 'R', LDV >= K.
+*
+* T (input) REAL array, dimension (LDT,K)
+* The triangular k by k matrix T in the representation of the
+* block reflector.
+*
+* LDT (input) INTEGER
+* The leading dimension of the array T. LDT >= K.
+*
+* C (input/output) REAL array, dimension (LDC,N)
+* On entry, the m by n matrix C.
+* On exit, C is overwritten by H*C or H'*C or C*H or C*H'.
+*
+* LDC (input) INTEGER
+* The leading dimension of the array C. LDA >= max(1,M).
+*
+* WORK (workspace) REAL array, dimension (LDWORK,K)
+*
+* LDWORK (input) INTEGER
+* The leading dimension of the array WORK.
+* If SIDE = 'L', LDWORK >= max(1,N);
+* if SIDE = 'R', LDWORK >= max(1,M).
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ONE
+ PARAMETER ( ONE = 1.0E+0 )
+* ..
+* .. Local Scalars ..
+ CHARACTER TRANST
+ INTEGER I, J
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL SCOPY, SGEMM, STRMM
+* ..
+* .. Executable Statements ..
+*
+* Quick return if possible
+*
+ IF( M.LE.0 .OR. N.LE.0 )
+ $ RETURN
+*
+ IF( LSAME( TRANS, 'N' ) ) THEN
+ TRANST = 'T'
+ ELSE
+ TRANST = 'N'
+ END IF
+*
+ IF( LSAME( STOREV, 'C' ) ) THEN
+*
+ IF( LSAME( DIRECT, 'F' ) ) THEN
+*
+* Let V = ( V1 ) (first K rows)
+* ( V2 )
+* where V1 is unit lower triangular.
+*
+ IF( LSAME( SIDE, 'L' ) ) THEN
+*
+* Form H * C or H' * C where C = ( C1 )
+* ( C2 )
+*
+* W := C' * V = (C1'*V1 + C2'*V2) (stored in WORK)
+*
+* W := C1'
+*
+ DO 10 J = 1, K
+ CALL SCOPY( N, C( J, 1 ), LDC, WORK( 1, J ), 1 )
+ 10 CONTINUE
+*
+* W := W * V1
+*
+ CALL STRMM( 'Right', 'Lower', 'No transpose', 'Unit', N,
+ $ K, ONE, V, LDV, WORK, LDWORK )
+ IF( M.GT.K ) THEN
+*
+* W := W + C2'*V2
+*
+ CALL SGEMM( 'Transpose', 'No transpose', N, K, M-K,
+ $ ONE, C( K+1, 1 ), LDC, V( K+1, 1 ), LDV,
+ $ ONE, WORK, LDWORK )
+ END IF
+*
+* W := W * T' or W * T
+*
+ CALL STRMM( 'Right', 'Upper', TRANST, 'Non-unit', N, K,
+ $ ONE, T, LDT, WORK, LDWORK )
+*
+* C := C - V * W'
+*
+ IF( M.GT.K ) THEN
+*
+* C2 := C2 - V2 * W'
+*
+ CALL SGEMM( 'No transpose', 'Transpose', M-K, N, K,
+ $ -ONE, V( K+1, 1 ), LDV, WORK, LDWORK, ONE,
+ $ C( K+1, 1 ), LDC )
+ END IF
+*
+* W := W * V1'
+*
+ CALL STRMM( 'Right', 'Lower', 'Transpose', 'Unit', N, K,
+ $ ONE, V, LDV, WORK, LDWORK )
+*
+* C1 := C1 - W'
+*
+ DO 30 J = 1, K
+ DO 20 I = 1, N
+ C( J, I ) = C( J, I ) - WORK( I, J )
+ 20 CONTINUE
+ 30 CONTINUE
+*
+ ELSE IF( LSAME( SIDE, 'R' ) ) THEN
+*
+* Form C * H or C * H' where C = ( C1 C2 )
+*
+* W := C * V = (C1*V1 + C2*V2) (stored in WORK)
+*
+* W := C1
+*
+ DO 40 J = 1, K
+ CALL SCOPY( M, C( 1, J ), 1, WORK( 1, J ), 1 )
+ 40 CONTINUE
+*
+* W := W * V1
+*
+ CALL STRMM( 'Right', 'Lower', 'No transpose', 'Unit', M,
+ $ K, ONE, V, LDV, WORK, LDWORK )
+ IF( N.GT.K ) THEN
+*
+* W := W + C2 * V2
+*
+ CALL SGEMM( 'No transpose', 'No transpose', M, K, N-K,
+ $ ONE, C( 1, K+1 ), LDC, V( K+1, 1 ), LDV,
+ $ ONE, WORK, LDWORK )
+ END IF
+*
+* W := W * T or W * T'
+*
+ CALL STRMM( 'Right', 'Upper', TRANS, 'Non-unit', M, K,
+ $ ONE, T, LDT, WORK, LDWORK )
+*
+* C := C - W * V'
+*
+ IF( N.GT.K ) THEN
+*
+* C2 := C2 - W * V2'
+*
+ CALL SGEMM( 'No transpose', 'Transpose', M, N-K, K,
+ $ -ONE, WORK, LDWORK, V( K+1, 1 ), LDV, ONE,
+ $ C( 1, K+1 ), LDC )
+ END IF
+*
+* W := W * V1'
+*
+ CALL STRMM( 'Right', 'Lower', 'Transpose', 'Unit', M, K,
+ $ ONE, V, LDV, WORK, LDWORK )
+*
+* C1 := C1 - W
+*
+ DO 60 J = 1, K
+ DO 50 I = 1, M
+ C( I, J ) = C( I, J ) - WORK( I, J )
+ 50 CONTINUE
+ 60 CONTINUE
+ END IF
+*
+ ELSE
+*
+* Let V = ( V1 )
+* ( V2 ) (last K rows)
+* where V2 is unit upper triangular.
+*
+ IF( LSAME( SIDE, 'L' ) ) THEN
+*
+* Form H * C or H' * C where C = ( C1 )
+* ( C2 )
+*
+* W := C' * V = (C1'*V1 + C2'*V2) (stored in WORK)
+*
+* W := C2'
+*
+ DO 70 J = 1, K
+ CALL SCOPY( N, C( M-K+J, 1 ), LDC, WORK( 1, J ), 1 )
+ 70 CONTINUE
+*
+* W := W * V2
+*
+ CALL STRMM( 'Right', 'Upper', 'No transpose', 'Unit', N,
+ $ K, ONE, V( M-K+1, 1 ), LDV, WORK, LDWORK )
+ IF( M.GT.K ) THEN
+*
+* W := W + C1'*V1
+*
+ CALL SGEMM( 'Transpose', 'No transpose', N, K, M-K,
+ $ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK )
+ END IF
+*
+* W := W * T' or W * T
+*
+ CALL STRMM( 'Right', 'Lower', TRANST, 'Non-unit', N, K,
+ $ ONE, T, LDT, WORK, LDWORK )
+*
+* C := C - V * W'
+*
+ IF( M.GT.K ) THEN
+*
+* C1 := C1 - V1 * W'
+*
+ CALL SGEMM( 'No transpose', 'Transpose', M-K, N, K,
+ $ -ONE, V, LDV, WORK, LDWORK, ONE, C, LDC )
+ END IF
+*
+* W := W * V2'
+*
+ CALL STRMM( 'Right', 'Upper', 'Transpose', 'Unit', N, K,
+ $ ONE, V( M-K+1, 1 ), LDV, WORK, LDWORK )
+*
+* C2 := C2 - W'
+*
+ DO 90 J = 1, K
+ DO 80 I = 1, N
+ C( M-K+J, I ) = C( M-K+J, I ) - WORK( I, J )
+ 80 CONTINUE
+ 90 CONTINUE
+*
+ ELSE IF( LSAME( SIDE, 'R' ) ) THEN
+*
+* Form C * H or C * H' where C = ( C1 C2 )
+*
+* W := C * V = (C1*V1 + C2*V2) (stored in WORK)
+*
+* W := C2
+*
+ DO 100 J = 1, K
+ CALL SCOPY( M, C( 1, N-K+J ), 1, WORK( 1, J ), 1 )
+ 100 CONTINUE
+*
+* W := W * V2
+*
+ CALL STRMM( 'Right', 'Upper', 'No transpose', 'Unit', M,
+ $ K, ONE, V( N-K+1, 1 ), LDV, WORK, LDWORK )
+ IF( N.GT.K ) THEN
+*
+* W := W + C1 * V1
+*
+ CALL SGEMM( 'No transpose', 'No transpose', M, K, N-K,
+ $ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK )
+ END IF
+*
+* W := W * T or W * T'
+*
+ CALL STRMM( 'Right', 'Lower', TRANS, 'Non-unit', M, K,
+ $ ONE, T, LDT, WORK, LDWORK )
+*
+* C := C - W * V'
+*
+ IF( N.GT.K ) THEN
+*
+* C1 := C1 - W * V1'
+*
+ CALL SGEMM( 'No transpose', 'Transpose', M, N-K, K,
+ $ -ONE, WORK, LDWORK, V, LDV, ONE, C, LDC )
+ END IF
+*
+* W := W * V2'
+*
+ CALL STRMM( 'Right', 'Upper', 'Transpose', 'Unit', M, K,
+ $ ONE, V( N-K+1, 1 ), LDV, WORK, LDWORK )
+*
+* C2 := C2 - W
+*
+ DO 120 J = 1, K
+ DO 110 I = 1, M
+ C( I, N-K+J ) = C( I, N-K+J ) - WORK( I, J )
+ 110 CONTINUE
+ 120 CONTINUE
+ END IF
+ END IF
+*
+ ELSE IF( LSAME( STOREV, 'R' ) ) THEN
+*
+ IF( LSAME( DIRECT, 'F' ) ) THEN
+*
+* Let V = ( V1 V2 ) (V1: first K columns)
+* where V1 is unit upper triangular.
+*
+ IF( LSAME( SIDE, 'L' ) ) THEN
+*
+* Form H * C or H' * C where C = ( C1 )
+* ( C2 )
+*
+* W := C' * V' = (C1'*V1' + C2'*V2') (stored in WORK)
+*
+* W := C1'
+*
+ DO 130 J = 1, K
+ CALL SCOPY( N, C( J, 1 ), LDC, WORK( 1, J ), 1 )
+ 130 CONTINUE
+*
+* W := W * V1'
+*
+ CALL STRMM( 'Right', 'Upper', 'Transpose', 'Unit', N, K,
+ $ ONE, V, LDV, WORK, LDWORK )
+ IF( M.GT.K ) THEN
+*
+* W := W + C2'*V2'
+*
+ CALL SGEMM( 'Transpose', 'Transpose', N, K, M-K, ONE,
+ $ C( K+1, 1 ), LDC, V( 1, K+1 ), LDV, ONE,
+ $ WORK, LDWORK )
+ END IF
+*
+* W := W * T' or W * T
+*
+ CALL STRMM( 'Right', 'Upper', TRANST, 'Non-unit', N, K,
+ $ ONE, T, LDT, WORK, LDWORK )
+*
+* C := C - V' * W'
+*
+ IF( M.GT.K ) THEN
+*
+* C2 := C2 - V2' * W'
+*
+ CALL SGEMM( 'Transpose', 'Transpose', M-K, N, K, -ONE,
+ $ V( 1, K+1 ), LDV, WORK, LDWORK, ONE,
+ $ C( K+1, 1 ), LDC )
+ END IF
+*
+* W := W * V1
+*
+ CALL STRMM( 'Right', 'Upper', 'No transpose', 'Unit', N,
+ $ K, ONE, V, LDV, WORK, LDWORK )
+*
+* C1 := C1 - W'
+*
+ DO 150 J = 1, K
+ DO 140 I = 1, N
+ C( J, I ) = C( J, I ) - WORK( I, J )
+ 140 CONTINUE
+ 150 CONTINUE
+*
+ ELSE IF( LSAME( SIDE, 'R' ) ) THEN
+*
+* Form C * H or C * H' where C = ( C1 C2 )
+*
+* W := C * V' = (C1*V1' + C2*V2') (stored in WORK)
+*
+* W := C1
+*
+ DO 160 J = 1, K
+ CALL SCOPY( M, C( 1, J ), 1, WORK( 1, J ), 1 )
+ 160 CONTINUE
+*
+* W := W * V1'
+*
+ CALL STRMM( 'Right', 'Upper', 'Transpose', 'Unit', M, K,
+ $ ONE, V, LDV, WORK, LDWORK )
+ IF( N.GT.K ) THEN
+*
+* W := W + C2 * V2'
+*
+ CALL SGEMM( 'No transpose', 'Transpose', M, K, N-K,
+ $ ONE, C( 1, K+1 ), LDC, V( 1, K+1 ), LDV,
+ $ ONE, WORK, LDWORK )
+ END IF
+*
+* W := W * T or W * T'
+*
+ CALL STRMM( 'Right', 'Upper', TRANS, 'Non-unit', M, K,
+ $ ONE, T, LDT, WORK, LDWORK )
+*
+* C := C - W * V
+*
+ IF( N.GT.K ) THEN
+*
+* C2 := C2 - W * V2
+*
+ CALL SGEMM( 'No transpose', 'No transpose', M, N-K, K,
+ $ -ONE, WORK, LDWORK, V( 1, K+1 ), LDV, ONE,
+ $ C( 1, K+1 ), LDC )
+ END IF
+*
+* W := W * V1
+*
+ CALL STRMM( 'Right', 'Upper', 'No transpose', 'Unit', M,
+ $ K, ONE, V, LDV, WORK, LDWORK )
+*
+* C1 := C1 - W
+*
+ DO 180 J = 1, K
+ DO 170 I = 1, M
+ C( I, J ) = C( I, J ) - WORK( I, J )
+ 170 CONTINUE
+ 180 CONTINUE
+*
+ END IF
+*
+ ELSE
+*
+* Let V = ( V1 V2 ) (V2: last K columns)
+* where V2 is unit lower triangular.
+*
+ IF( LSAME( SIDE, 'L' ) ) THEN
+*
+* Form H * C or H' * C where C = ( C1 )
+* ( C2 )
+*
+* W := C' * V' = (C1'*V1' + C2'*V2') (stored in WORK)
+*
+* W := C2'
+*
+ DO 190 J = 1, K
+ CALL SCOPY( N, C( M-K+J, 1 ), LDC, WORK( 1, J ), 1 )
+ 190 CONTINUE
+*
+* W := W * V2'
+*
+ CALL STRMM( 'Right', 'Lower', 'Transpose', 'Unit', N, K,
+ $ ONE, V( 1, M-K+1 ), LDV, WORK, LDWORK )
+ IF( M.GT.K ) THEN
+*
+* W := W + C1'*V1'
+*
+ CALL SGEMM( 'Transpose', 'Transpose', N, K, M-K, ONE,
+ $ C, LDC, V, LDV, ONE, WORK, LDWORK )
+ END IF
+*
+* W := W * T' or W * T
+*
+ CALL STRMM( 'Right', 'Lower', TRANST, 'Non-unit', N, K,
+ $ ONE, T, LDT, WORK, LDWORK )
+*
+* C := C - V' * W'
+*
+ IF( M.GT.K ) THEN
+*
+* C1 := C1 - V1' * W'
+*
+ CALL SGEMM( 'Transpose', 'Transpose', M-K, N, K, -ONE,
+ $ V, LDV, WORK, LDWORK, ONE, C, LDC )
+ END IF
+*
+* W := W * V2
+*
+ CALL STRMM( 'Right', 'Lower', 'No transpose', 'Unit', N,
+ $ K, ONE, V( 1, M-K+1 ), LDV, WORK, LDWORK )
+*
+* C2 := C2 - W'
+*
+ DO 210 J = 1, K
+ DO 200 I = 1, N
+ C( M-K+J, I ) = C( M-K+J, I ) - WORK( I, J )
+ 200 CONTINUE
+ 210 CONTINUE
+*
+ ELSE IF( LSAME( SIDE, 'R' ) ) THEN
+*
+* Form C * H or C * H' where C = ( C1 C2 )
+*
+* W := C * V' = (C1*V1' + C2*V2') (stored in WORK)
+*
+* W := C2
+*
+ DO 220 J = 1, K
+ CALL SCOPY( M, C( 1, N-K+J ), 1, WORK( 1, J ), 1 )
+ 220 CONTINUE
+*
+* W := W * V2'
+*
+ CALL STRMM( 'Right', 'Lower', 'Transpose', 'Unit', M, K,
+ $ ONE, V( 1, N-K+1 ), LDV, WORK, LDWORK )
+ IF( N.GT.K ) THEN
+*
+* W := W + C1 * V1'
+*
+ CALL SGEMM( 'No transpose', 'Transpose', M, K, N-K,
+ $ ONE, C, LDC, V, LDV, ONE, WORK, LDWORK )
+ END IF
+*
+* W := W * T or W * T'
+*
+ CALL STRMM( 'Right', 'Lower', TRANS, 'Non-unit', M, K,
+ $ ONE, T, LDT, WORK, LDWORK )
+*
+* C := C - W * V
+*
+ IF( N.GT.K ) THEN
+*
+* C1 := C1 - W * V1
+*
+ CALL SGEMM( 'No transpose', 'No transpose', M, N-K, K,
+ $ -ONE, WORK, LDWORK, V, LDV, ONE, C, LDC )
+ END IF
+*
+* W := W * V2
+*
+ CALL STRMM( 'Right', 'Lower', 'No transpose', 'Unit', M,
+ $ K, ONE, V( 1, N-K+1 ), LDV, WORK, LDWORK )
+*
+* C1 := C1 - W
+*
+ DO 240 J = 1, K
+ DO 230 I = 1, M
+ C( I, N-K+J ) = C( I, N-K+J ) - WORK( I, J )
+ 230 CONTINUE
+ 240 CONTINUE
+*
+ END IF
+*
+ END IF
+ END IF
+*
+ RETURN
+*
+* End of SLARFB
+*
+ END
+ SUBROUTINE SLARFG( N, ALPHA, X, INCX, TAU )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INCX, N
+ REAL ALPHA, TAU
+* ..
+* .. Array Arguments ..
+ REAL X( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SLARFG generates a real elementary reflector H of order n, such
+* that
+*
+* H * ( alpha ) = ( beta ), H' * H = I.
+* ( x ) ( 0 )
+*
+* where alpha and beta are scalars, and x is an (n-1)-element real
+* vector. H is represented in the form
+*
+* H = I - tau * ( 1 ) * ( 1 v' ) ,
+* ( v )
+*
+* where tau is a real scalar and v is a real (n-1)-element
+* vector.
+*
+* If the elements of x are all zero, then tau = 0 and H is taken to be
+* the unit matrix.
+*
+* Otherwise 1 <= tau <= 2.
+*
+* Arguments
+* =========
+*
+* N (input) INTEGER
+* The order of the elementary reflector.
+*
+* ALPHA (input/output) REAL
+* On entry, the value alpha.
+* On exit, it is overwritten with the value beta.
+*
+* X (input/output) REAL array, dimension
+* (1+(N-2)*abs(INCX))
+* On entry, the vector x.
+* On exit, it is overwritten with the vector v.
+*
+* INCX (input) INTEGER
+* The increment between elements of X. INCX > 0.
+*
+* TAU (output) REAL
+* The value tau.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ONE, ZERO
+ PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER J, KNT
+ REAL BETA, RSAFMN, SAFMIN, XNORM
+* ..
+* .. External Functions ..
+ REAL SLAMCH, SLAPY2, SNRM2
+ EXTERNAL SLAMCH, SLAPY2, SNRM2
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, SIGN
+* ..
+* .. External Subroutines ..
+ EXTERNAL SSCAL
+* ..
+* .. Executable Statements ..
+*
+ IF( N.LE.1 ) THEN
+ TAU = ZERO
+ RETURN
+ END IF
+*
+ XNORM = SNRM2( N-1, X, INCX )
+*
+ IF( XNORM.EQ.ZERO ) THEN
+*
+* H = I
+*
+ TAU = ZERO
+ ELSE
+*
+* general case
+*
+ BETA = -SIGN( SLAPY2( ALPHA, XNORM ), ALPHA )
+ SAFMIN = SLAMCH( 'S' ) / SLAMCH( 'E' )
+ IF( ABS( BETA ).LT.SAFMIN ) THEN
+*
+* XNORM, BETA may be inaccurate; scale X and recompute them
+*
+ RSAFMN = ONE / SAFMIN
+ KNT = 0
+ 10 CONTINUE
+ KNT = KNT + 1
+ CALL SSCAL( N-1, RSAFMN, X, INCX )
+ BETA = BETA*RSAFMN
+ ALPHA = ALPHA*RSAFMN
+ IF( ABS( BETA ).LT.SAFMIN )
+ $ GO TO 10
+*
+* New BETA is at most 1, at least SAFMIN
+*
+ XNORM = SNRM2( N-1, X, INCX )
+ BETA = -SIGN( SLAPY2( ALPHA, XNORM ), ALPHA )
+ TAU = ( BETA-ALPHA ) / BETA
+ CALL SSCAL( N-1, ONE / ( ALPHA-BETA ), X, INCX )
+*
+* If ALPHA is subnormal, it may lose relative accuracy
+*
+ ALPHA = BETA
+ DO 20 J = 1, KNT
+ ALPHA = ALPHA*SAFMIN
+ 20 CONTINUE
+ ELSE
+ TAU = ( BETA-ALPHA ) / BETA
+ CALL SSCAL( N-1, ONE / ( ALPHA-BETA ), X, INCX )
+ ALPHA = BETA
+ END IF
+ END IF
+*
+ RETURN
+*
+* End of SLARFG
+*
+ END
+ SUBROUTINE SLARFT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER DIRECT, STOREV
+ INTEGER K, LDT, LDV, N
+* ..
+* .. Array Arguments ..
+ REAL T( LDT, * ), TAU( * ), V( LDV, * )
+* ..
+*
+* Purpose
+* =======
+*
+* SLARFT forms the triangular factor T of a real block reflector H
+* of order n, which is defined as a product of k elementary reflectors.
+*
+* If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular;
+*
+* If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular.
+*
+* If STOREV = 'C', the vector which defines the elementary reflector
+* H(i) is stored in the i-th column of the array V, and
+*
+* H = I - V * T * V'
+*
+* If STOREV = 'R', the vector which defines the elementary reflector
+* H(i) is stored in the i-th row of the array V, and
+*
+* H = I - V' * T * V
+*
+* Arguments
+* =========
+*
+* DIRECT (input) CHARACTER*1
+* Specifies the order in which the elementary reflectors are
+* multiplied to form the block reflector:
+* = 'F': H = H(1) H(2) . . . H(k) (Forward)
+* = 'B': H = H(k) . . . H(2) H(1) (Backward)
+*
+* STOREV (input) CHARACTER*1
+* Specifies how the vectors which define the elementary
+* reflectors are stored (see also Further Details):
+* = 'C': columnwise
+* = 'R': rowwise
+*
+* N (input) INTEGER
+* The order of the block reflector H. N >= 0.
+*
+* K (input) INTEGER
+* The order of the triangular factor T (= the number of
+* elementary reflectors). K >= 1.
+*
+* V (input/output) REAL array, dimension
+* (LDV,K) if STOREV = 'C'
+* (LDV,N) if STOREV = 'R'
+* The matrix V. See further details.
+*
+* LDV (input) INTEGER
+* The leading dimension of the array V.
+* If STOREV = 'C', LDV >= max(1,N); if STOREV = 'R', LDV >= K.
+*
+* TAU (input) REAL array, dimension (K)
+* TAU(i) must contain the scalar factor of the elementary
+* reflector H(i).
+*
+* T (output) REAL array, dimension (LDT,K)
+* The k by k triangular factor T of the block reflector.
+* If DIRECT = 'F', T is upper triangular; if DIRECT = 'B', T is
+* lower triangular. The rest of the array is not used.
+*
+* LDT (input) INTEGER
+* The leading dimension of the array T. LDT >= K.
+*
+* Further Details
+* ===============
+*
+* The shape of the matrix V and the storage of the vectors which define
+* the H(i) is best illustrated by the following example with n = 5 and
+* k = 3. The elements equal to 1 are not stored; the corresponding
+* array elements are modified but restored on exit. The rest of the
+* array is not used.
+*
+* DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R':
+*
+* V = ( 1 ) V = ( 1 v1 v1 v1 v1 )
+* ( v1 1 ) ( 1 v2 v2 v2 )
+* ( v1 v2 1 ) ( 1 v3 v3 )
+* ( v1 v2 v3 )
+* ( v1 v2 v3 )
+*
+* DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R':
+*
+* V = ( v1 v2 v3 ) V = ( v1 v1 1 )
+* ( v1 v2 v3 ) ( v2 v2 v2 1 )
+* ( 1 v2 v3 ) ( v3 v3 v3 v3 1 )
+* ( 1 v3 )
+* ( 1 )
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ONE, ZERO
+ PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, J
+ REAL VII
+* ..
+* .. External Subroutines ..
+ EXTERNAL SGEMV, STRMV
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. Executable Statements ..
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+ IF( LSAME( DIRECT, 'F' ) ) THEN
+ DO 20 I = 1, K
+ IF( TAU( I ).EQ.ZERO ) THEN
+*
+* H(i) = I
+*
+ DO 10 J = 1, I
+ T( J, I ) = ZERO
+ 10 CONTINUE
+ ELSE
+*
+* general case
+*
+ VII = V( I, I )
+ V( I, I ) = ONE
+ IF( LSAME( STOREV, 'C' ) ) THEN
+*
+* T(1:i-1,i) := - tau(i) * V(i:n,1:i-1)' * V(i:n,i)
+*
+ CALL SGEMV( 'Transpose', N-I+1, I-1, -TAU( I ),
+ $ V( I, 1 ), LDV, V( I, I ), 1, ZERO,
+ $ T( 1, I ), 1 )
+ ELSE
+*
+* T(1:i-1,i) := - tau(i) * V(1:i-1,i:n) * V(i,i:n)'
+*
+ CALL SGEMV( 'No transpose', I-1, N-I+1, -TAU( I ),
+ $ V( 1, I ), LDV, V( I, I ), LDV, ZERO,
+ $ T( 1, I ), 1 )
+ END IF
+ V( I, I ) = VII
+*
+* T(1:i-1,i) := T(1:i-1,1:i-1) * T(1:i-1,i)
+*
+ CALL STRMV( 'Upper', 'No transpose', 'Non-unit', I-1, T,
+ $ LDT, T( 1, I ), 1 )
+ T( I, I ) = TAU( I )
+ END IF
+ 20 CONTINUE
+ ELSE
+ DO 40 I = K, 1, -1
+ IF( TAU( I ).EQ.ZERO ) THEN
+*
+* H(i) = I
+*
+ DO 30 J = I, K
+ T( J, I ) = ZERO
+ 30 CONTINUE
+ ELSE
+*
+* general case
+*
+ IF( I.LT.K ) THEN
+ IF( LSAME( STOREV, 'C' ) ) THEN
+ VII = V( N-K+I, I )
+ V( N-K+I, I ) = ONE
+*
+* T(i+1:k,i) :=
+* - tau(i) * V(1:n-k+i,i+1:k)' * V(1:n-k+i,i)
+*
+ CALL SGEMV( 'Transpose', N-K+I, K-I, -TAU( I ),
+ $ V( 1, I+1 ), LDV, V( 1, I ), 1, ZERO,
+ $ T( I+1, I ), 1 )
+ V( N-K+I, I ) = VII
+ ELSE
+ VII = V( I, N-K+I )
+ V( I, N-K+I ) = ONE
+*
+* T(i+1:k,i) :=
+* - tau(i) * V(i+1:k,1:n-k+i) * V(i,1:n-k+i)'
+*
+ CALL SGEMV( 'No transpose', K-I, N-K+I, -TAU( I ),
+ $ V( I+1, 1 ), LDV, V( I, 1 ), LDV, ZERO,
+ $ T( I+1, I ), 1 )
+ V( I, N-K+I ) = VII
+ END IF
+*
+* T(i+1:k,i) := T(i+1:k,i+1:k) * T(i+1:k,i)
+*
+ CALL STRMV( 'Lower', 'No transpose', 'Non-unit', K-I,
+ $ T( I+1, I+1 ), LDT, T( I+1, I ), 1 )
+ END IF
+ T( I, I ) = TAU( I )
+ END IF
+ 40 CONTINUE
+ END IF
+ RETURN
+*
+* End of SLARFT
+*
+ END
+ SUBROUTINE SLARFX( SIDE, M, N, V, TAU, C, LDC, WORK )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER SIDE
+ INTEGER LDC, M, N
+ REAL TAU
+* ..
+* .. Array Arguments ..
+ REAL C( LDC, * ), V( * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SLARFX applies a real elementary reflector H to a real m by n
+* matrix C, from either the left or the right. H is represented in the
+* form
+*
+* H = I - tau * v * v'
+*
+* where tau is a real scalar and v is a real vector.
+*
+* If tau = 0, then H is taken to be the unit matrix
+*
+* This version uses inline code if H has order < 11.
+*
+* Arguments
+* =========
+*
+* SIDE (input) CHARACTER*1
+* = 'L': form H * C
+* = 'R': form C * H
+*
+* M (input) INTEGER
+* The number of rows of the matrix C.
+*
+* N (input) INTEGER
+* The number of columns of the matrix C.
+*
+* V (input) REAL array, dimension (M) if SIDE = 'L'
+* or (N) if SIDE = 'R'
+* The vector v in the representation of H.
+*
+* TAU (input) REAL
+* The value tau in the representation of H.
+*
+* C (input/output) REAL array, dimension (LDC,N)
+* On entry, the m by n matrix C.
+* On exit, C is overwritten by the matrix H * C if SIDE = 'L',
+* or C * H if SIDE = 'R'.
+*
+* LDC (input) INTEGER
+* The leading dimension of the array C. LDA >= (1,M).
+*
+* WORK (workspace) REAL array, dimension
+* (N) if SIDE = 'L'
+* or (M) if SIDE = 'R'
+* WORK is not referenced if H has order < 11.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO, ONE
+ PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER J
+ REAL SUM, T1, T10, T2, T3, T4, T5, T6, T7, T8, T9,
+ $ V1, V10, V2, V3, V4, V5, V6, V7, V8, V9
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL SGEMV, SGER
+* ..
+* .. Executable Statements ..
+*
+ IF( TAU.EQ.ZERO )
+ $ RETURN
+ IF( LSAME( SIDE, 'L' ) ) THEN
+*
+* Form H * C, where H has order m.
+*
+ GO TO ( 10, 30, 50, 70, 90, 110, 130, 150,
+ $ 170, 190 )M
+*
+* Code for general M
+*
+* w := C'*v
+*
+ CALL SGEMV( 'Transpose', M, N, ONE, C, LDC, V, 1, ZERO, WORK,
+ $ 1 )
+*
+* C := C - tau * v * w'
+*
+ CALL SGER( M, N, -TAU, V, 1, WORK, 1, C, LDC )
+ GO TO 410
+ 10 CONTINUE
+*
+* Special code for 1 x 1 Householder
+*
+ T1 = ONE - TAU*V( 1 )*V( 1 )
+ DO 20 J = 1, N
+ C( 1, J ) = T1*C( 1, J )
+ 20 CONTINUE
+ GO TO 410
+ 30 CONTINUE
+*
+* Special code for 2 x 2 Householder
+*
+ V1 = V( 1 )
+ T1 = TAU*V1
+ V2 = V( 2 )
+ T2 = TAU*V2
+ DO 40 J = 1, N
+ SUM = V1*C( 1, J ) + V2*C( 2, J )
+ C( 1, J ) = C( 1, J ) - SUM*T1
+ C( 2, J ) = C( 2, J ) - SUM*T2
+ 40 CONTINUE
+ GO TO 410
+ 50 CONTINUE
+*
+* Special code for 3 x 3 Householder
+*
+ V1 = V( 1 )
+ T1 = TAU*V1
+ V2 = V( 2 )
+ T2 = TAU*V2
+ V3 = V( 3 )
+ T3 = TAU*V3
+ DO 60 J = 1, N
+ SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J )
+ C( 1, J ) = C( 1, J ) - SUM*T1
+ C( 2, J ) = C( 2, J ) - SUM*T2
+ C( 3, J ) = C( 3, J ) - SUM*T3
+ 60 CONTINUE
+ GO TO 410
+ 70 CONTINUE
+*
+* Special code for 4 x 4 Householder
+*
+ V1 = V( 1 )
+ T1 = TAU*V1
+ V2 = V( 2 )
+ T2 = TAU*V2
+ V3 = V( 3 )
+ T3 = TAU*V3
+ V4 = V( 4 )
+ T4 = TAU*V4
+ DO 80 J = 1, N
+ SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) +
+ $ V4*C( 4, J )
+ C( 1, J ) = C( 1, J ) - SUM*T1
+ C( 2, J ) = C( 2, J ) - SUM*T2
+ C( 3, J ) = C( 3, J ) - SUM*T3
+ C( 4, J ) = C( 4, J ) - SUM*T4
+ 80 CONTINUE
+ GO TO 410
+ 90 CONTINUE
+*
+* Special code for 5 x 5 Householder
+*
+ V1 = V( 1 )
+ T1 = TAU*V1
+ V2 = V( 2 )
+ T2 = TAU*V2
+ V3 = V( 3 )
+ T3 = TAU*V3
+ V4 = V( 4 )
+ T4 = TAU*V4
+ V5 = V( 5 )
+ T5 = TAU*V5
+ DO 100 J = 1, N
+ SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) +
+ $ V4*C( 4, J ) + V5*C( 5, J )
+ C( 1, J ) = C( 1, J ) - SUM*T1
+ C( 2, J ) = C( 2, J ) - SUM*T2
+ C( 3, J ) = C( 3, J ) - SUM*T3
+ C( 4, J ) = C( 4, J ) - SUM*T4
+ C( 5, J ) = C( 5, J ) - SUM*T5
+ 100 CONTINUE
+ GO TO 410
+ 110 CONTINUE
+*
+* Special code for 6 x 6 Householder
+*
+ V1 = V( 1 )
+ T1 = TAU*V1
+ V2 = V( 2 )
+ T2 = TAU*V2
+ V3 = V( 3 )
+ T3 = TAU*V3
+ V4 = V( 4 )
+ T4 = TAU*V4
+ V5 = V( 5 )
+ T5 = TAU*V5
+ V6 = V( 6 )
+ T6 = TAU*V6
+ DO 120 J = 1, N
+ SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) +
+ $ V4*C( 4, J ) + V5*C( 5, J ) + V6*C( 6, J )
+ C( 1, J ) = C( 1, J ) - SUM*T1
+ C( 2, J ) = C( 2, J ) - SUM*T2
+ C( 3, J ) = C( 3, J ) - SUM*T3
+ C( 4, J ) = C( 4, J ) - SUM*T4
+ C( 5, J ) = C( 5, J ) - SUM*T5
+ C( 6, J ) = C( 6, J ) - SUM*T6
+ 120 CONTINUE
+ GO TO 410
+ 130 CONTINUE
+*
+* Special code for 7 x 7 Householder
+*
+ V1 = V( 1 )
+ T1 = TAU*V1
+ V2 = V( 2 )
+ T2 = TAU*V2
+ V3 = V( 3 )
+ T3 = TAU*V3
+ V4 = V( 4 )
+ T4 = TAU*V4
+ V5 = V( 5 )
+ T5 = TAU*V5
+ V6 = V( 6 )
+ T6 = TAU*V6
+ V7 = V( 7 )
+ T7 = TAU*V7
+ DO 140 J = 1, N
+ SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) +
+ $ V4*C( 4, J ) + V5*C( 5, J ) + V6*C( 6, J ) +
+ $ V7*C( 7, J )
+ C( 1, J ) = C( 1, J ) - SUM*T1
+ C( 2, J ) = C( 2, J ) - SUM*T2
+ C( 3, J ) = C( 3, J ) - SUM*T3
+ C( 4, J ) = C( 4, J ) - SUM*T4
+ C( 5, J ) = C( 5, J ) - SUM*T5
+ C( 6, J ) = C( 6, J ) - SUM*T6
+ C( 7, J ) = C( 7, J ) - SUM*T7
+ 140 CONTINUE
+ GO TO 410
+ 150 CONTINUE
+*
+* Special code for 8 x 8 Householder
+*
+ V1 = V( 1 )
+ T1 = TAU*V1
+ V2 = V( 2 )
+ T2 = TAU*V2
+ V3 = V( 3 )
+ T3 = TAU*V3
+ V4 = V( 4 )
+ T4 = TAU*V4
+ V5 = V( 5 )
+ T5 = TAU*V5
+ V6 = V( 6 )
+ T6 = TAU*V6
+ V7 = V( 7 )
+ T7 = TAU*V7
+ V8 = V( 8 )
+ T8 = TAU*V8
+ DO 160 J = 1, N
+ SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) +
+ $ V4*C( 4, J ) + V5*C( 5, J ) + V6*C( 6, J ) +
+ $ V7*C( 7, J ) + V8*C( 8, J )
+ C( 1, J ) = C( 1, J ) - SUM*T1
+ C( 2, J ) = C( 2, J ) - SUM*T2
+ C( 3, J ) = C( 3, J ) - SUM*T3
+ C( 4, J ) = C( 4, J ) - SUM*T4
+ C( 5, J ) = C( 5, J ) - SUM*T5
+ C( 6, J ) = C( 6, J ) - SUM*T6
+ C( 7, J ) = C( 7, J ) - SUM*T7
+ C( 8, J ) = C( 8, J ) - SUM*T8
+ 160 CONTINUE
+ GO TO 410
+ 170 CONTINUE
+*
+* Special code for 9 x 9 Householder
+*
+ V1 = V( 1 )
+ T1 = TAU*V1
+ V2 = V( 2 )
+ T2 = TAU*V2
+ V3 = V( 3 )
+ T3 = TAU*V3
+ V4 = V( 4 )
+ T4 = TAU*V4
+ V5 = V( 5 )
+ T5 = TAU*V5
+ V6 = V( 6 )
+ T6 = TAU*V6
+ V7 = V( 7 )
+ T7 = TAU*V7
+ V8 = V( 8 )
+ T8 = TAU*V8
+ V9 = V( 9 )
+ T9 = TAU*V9
+ DO 180 J = 1, N
+ SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) +
+ $ V4*C( 4, J ) + V5*C( 5, J ) + V6*C( 6, J ) +
+ $ V7*C( 7, J ) + V8*C( 8, J ) + V9*C( 9, J )
+ C( 1, J ) = C( 1, J ) - SUM*T1
+ C( 2, J ) = C( 2, J ) - SUM*T2
+ C( 3, J ) = C( 3, J ) - SUM*T3
+ C( 4, J ) = C( 4, J ) - SUM*T4
+ C( 5, J ) = C( 5, J ) - SUM*T5
+ C( 6, J ) = C( 6, J ) - SUM*T6
+ C( 7, J ) = C( 7, J ) - SUM*T7
+ C( 8, J ) = C( 8, J ) - SUM*T8
+ C( 9, J ) = C( 9, J ) - SUM*T9
+ 180 CONTINUE
+ GO TO 410
+ 190 CONTINUE
+*
+* Special code for 10 x 10 Householder
+*
+ V1 = V( 1 )
+ T1 = TAU*V1
+ V2 = V( 2 )
+ T2 = TAU*V2
+ V3 = V( 3 )
+ T3 = TAU*V3
+ V4 = V( 4 )
+ T4 = TAU*V4
+ V5 = V( 5 )
+ T5 = TAU*V5
+ V6 = V( 6 )
+ T6 = TAU*V6
+ V7 = V( 7 )
+ T7 = TAU*V7
+ V8 = V( 8 )
+ T8 = TAU*V8
+ V9 = V( 9 )
+ T9 = TAU*V9
+ V10 = V( 10 )
+ T10 = TAU*V10
+ DO 200 J = 1, N
+ SUM = V1*C( 1, J ) + V2*C( 2, J ) + V3*C( 3, J ) +
+ $ V4*C( 4, J ) + V5*C( 5, J ) + V6*C( 6, J ) +
+ $ V7*C( 7, J ) + V8*C( 8, J ) + V9*C( 9, J ) +
+ $ V10*C( 10, J )
+ C( 1, J ) = C( 1, J ) - SUM*T1
+ C( 2, J ) = C( 2, J ) - SUM*T2
+ C( 3, J ) = C( 3, J ) - SUM*T3
+ C( 4, J ) = C( 4, J ) - SUM*T4
+ C( 5, J ) = C( 5, J ) - SUM*T5
+ C( 6, J ) = C( 6, J ) - SUM*T6
+ C( 7, J ) = C( 7, J ) - SUM*T7
+ C( 8, J ) = C( 8, J ) - SUM*T8
+ C( 9, J ) = C( 9, J ) - SUM*T9
+ C( 10, J ) = C( 10, J ) - SUM*T10
+ 200 CONTINUE
+ GO TO 410
+ ELSE
+*
+* Form C * H, where H has order n.
+*
+ GO TO ( 210, 230, 250, 270, 290, 310, 330, 350,
+ $ 370, 390 )N
+*
+* Code for general N
+*
+* w := C * v
+*
+ CALL SGEMV( 'No transpose', M, N, ONE, C, LDC, V, 1, ZERO,
+ $ WORK, 1 )
+*
+* C := C - tau * w * v'
+*
+ CALL SGER( M, N, -TAU, WORK, 1, V, 1, C, LDC )
+ GO TO 410
+ 210 CONTINUE
+*
+* Special code for 1 x 1 Householder
+*
+ T1 = ONE - TAU*V( 1 )*V( 1 )
+ DO 220 J = 1, M
+ C( J, 1 ) = T1*C( J, 1 )
+ 220 CONTINUE
+ GO TO 410
+ 230 CONTINUE
+*
+* Special code for 2 x 2 Householder
+*
+ V1 = V( 1 )
+ T1 = TAU*V1
+ V2 = V( 2 )
+ T2 = TAU*V2
+ DO 240 J = 1, M
+ SUM = V1*C( J, 1 ) + V2*C( J, 2 )
+ C( J, 1 ) = C( J, 1 ) - SUM*T1
+ C( J, 2 ) = C( J, 2 ) - SUM*T2
+ 240 CONTINUE
+ GO TO 410
+ 250 CONTINUE
+*
+* Special code for 3 x 3 Householder
+*
+ V1 = V( 1 )
+ T1 = TAU*V1
+ V2 = V( 2 )
+ T2 = TAU*V2
+ V3 = V( 3 )
+ T3 = TAU*V3
+ DO 260 J = 1, M
+ SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 )
+ C( J, 1 ) = C( J, 1 ) - SUM*T1
+ C( J, 2 ) = C( J, 2 ) - SUM*T2
+ C( J, 3 ) = C( J, 3 ) - SUM*T3
+ 260 CONTINUE
+ GO TO 410
+ 270 CONTINUE
+*
+* Special code for 4 x 4 Householder
+*
+ V1 = V( 1 )
+ T1 = TAU*V1
+ V2 = V( 2 )
+ T2 = TAU*V2
+ V3 = V( 3 )
+ T3 = TAU*V3
+ V4 = V( 4 )
+ T4 = TAU*V4
+ DO 280 J = 1, M
+ SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) +
+ $ V4*C( J, 4 )
+ C( J, 1 ) = C( J, 1 ) - SUM*T1
+ C( J, 2 ) = C( J, 2 ) - SUM*T2
+ C( J, 3 ) = C( J, 3 ) - SUM*T3
+ C( J, 4 ) = C( J, 4 ) - SUM*T4
+ 280 CONTINUE
+ GO TO 410
+ 290 CONTINUE
+*
+* Special code for 5 x 5 Householder
+*
+ V1 = V( 1 )
+ T1 = TAU*V1
+ V2 = V( 2 )
+ T2 = TAU*V2
+ V3 = V( 3 )
+ T3 = TAU*V3
+ V4 = V( 4 )
+ T4 = TAU*V4
+ V5 = V( 5 )
+ T5 = TAU*V5
+ DO 300 J = 1, M
+ SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) +
+ $ V4*C( J, 4 ) + V5*C( J, 5 )
+ C( J, 1 ) = C( J, 1 ) - SUM*T1
+ C( J, 2 ) = C( J, 2 ) - SUM*T2
+ C( J, 3 ) = C( J, 3 ) - SUM*T3
+ C( J, 4 ) = C( J, 4 ) - SUM*T4
+ C( J, 5 ) = C( J, 5 ) - SUM*T5
+ 300 CONTINUE
+ GO TO 410
+ 310 CONTINUE
+*
+* Special code for 6 x 6 Householder
+*
+ V1 = V( 1 )
+ T1 = TAU*V1
+ V2 = V( 2 )
+ T2 = TAU*V2
+ V3 = V( 3 )
+ T3 = TAU*V3
+ V4 = V( 4 )
+ T4 = TAU*V4
+ V5 = V( 5 )
+ T5 = TAU*V5
+ V6 = V( 6 )
+ T6 = TAU*V6
+ DO 320 J = 1, M
+ SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) +
+ $ V4*C( J, 4 ) + V5*C( J, 5 ) + V6*C( J, 6 )
+ C( J, 1 ) = C( J, 1 ) - SUM*T1
+ C( J, 2 ) = C( J, 2 ) - SUM*T2
+ C( J, 3 ) = C( J, 3 ) - SUM*T3
+ C( J, 4 ) = C( J, 4 ) - SUM*T4
+ C( J, 5 ) = C( J, 5 ) - SUM*T5
+ C( J, 6 ) = C( J, 6 ) - SUM*T6
+ 320 CONTINUE
+ GO TO 410
+ 330 CONTINUE
+*
+* Special code for 7 x 7 Householder
+*
+ V1 = V( 1 )
+ T1 = TAU*V1
+ V2 = V( 2 )
+ T2 = TAU*V2
+ V3 = V( 3 )
+ T3 = TAU*V3
+ V4 = V( 4 )
+ T4 = TAU*V4
+ V5 = V( 5 )
+ T5 = TAU*V5
+ V6 = V( 6 )
+ T6 = TAU*V6
+ V7 = V( 7 )
+ T7 = TAU*V7
+ DO 340 J = 1, M
+ SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) +
+ $ V4*C( J, 4 ) + V5*C( J, 5 ) + V6*C( J, 6 ) +
+ $ V7*C( J, 7 )
+ C( J, 1 ) = C( J, 1 ) - SUM*T1
+ C( J, 2 ) = C( J, 2 ) - SUM*T2
+ C( J, 3 ) = C( J, 3 ) - SUM*T3
+ C( J, 4 ) = C( J, 4 ) - SUM*T4
+ C( J, 5 ) = C( J, 5 ) - SUM*T5
+ C( J, 6 ) = C( J, 6 ) - SUM*T6
+ C( J, 7 ) = C( J, 7 ) - SUM*T7
+ 340 CONTINUE
+ GO TO 410
+ 350 CONTINUE
+*
+* Special code for 8 x 8 Householder
+*
+ V1 = V( 1 )
+ T1 = TAU*V1
+ V2 = V( 2 )
+ T2 = TAU*V2
+ V3 = V( 3 )
+ T3 = TAU*V3
+ V4 = V( 4 )
+ T4 = TAU*V4
+ V5 = V( 5 )
+ T5 = TAU*V5
+ V6 = V( 6 )
+ T6 = TAU*V6
+ V7 = V( 7 )
+ T7 = TAU*V7
+ V8 = V( 8 )
+ T8 = TAU*V8
+ DO 360 J = 1, M
+ SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) +
+ $ V4*C( J, 4 ) + V5*C( J, 5 ) + V6*C( J, 6 ) +
+ $ V7*C( J, 7 ) + V8*C( J, 8 )
+ C( J, 1 ) = C( J, 1 ) - SUM*T1
+ C( J, 2 ) = C( J, 2 ) - SUM*T2
+ C( J, 3 ) = C( J, 3 ) - SUM*T3
+ C( J, 4 ) = C( J, 4 ) - SUM*T4
+ C( J, 5 ) = C( J, 5 ) - SUM*T5
+ C( J, 6 ) = C( J, 6 ) - SUM*T6
+ C( J, 7 ) = C( J, 7 ) - SUM*T7
+ C( J, 8 ) = C( J, 8 ) - SUM*T8
+ 360 CONTINUE
+ GO TO 410
+ 370 CONTINUE
+*
+* Special code for 9 x 9 Householder
+*
+ V1 = V( 1 )
+ T1 = TAU*V1
+ V2 = V( 2 )
+ T2 = TAU*V2
+ V3 = V( 3 )
+ T3 = TAU*V3
+ V4 = V( 4 )
+ T4 = TAU*V4
+ V5 = V( 5 )
+ T5 = TAU*V5
+ V6 = V( 6 )
+ T6 = TAU*V6
+ V7 = V( 7 )
+ T7 = TAU*V7
+ V8 = V( 8 )
+ T8 = TAU*V8
+ V9 = V( 9 )
+ T9 = TAU*V9
+ DO 380 J = 1, M
+ SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) +
+ $ V4*C( J, 4 ) + V5*C( J, 5 ) + V6*C( J, 6 ) +
+ $ V7*C( J, 7 ) + V8*C( J, 8 ) + V9*C( J, 9 )
+ C( J, 1 ) = C( J, 1 ) - SUM*T1
+ C( J, 2 ) = C( J, 2 ) - SUM*T2
+ C( J, 3 ) = C( J, 3 ) - SUM*T3
+ C( J, 4 ) = C( J, 4 ) - SUM*T4
+ C( J, 5 ) = C( J, 5 ) - SUM*T5
+ C( J, 6 ) = C( J, 6 ) - SUM*T6
+ C( J, 7 ) = C( J, 7 ) - SUM*T7
+ C( J, 8 ) = C( J, 8 ) - SUM*T8
+ C( J, 9 ) = C( J, 9 ) - SUM*T9
+ 380 CONTINUE
+ GO TO 410
+ 390 CONTINUE
+*
+* Special code for 10 x 10 Householder
+*
+ V1 = V( 1 )
+ T1 = TAU*V1
+ V2 = V( 2 )
+ T2 = TAU*V2
+ V3 = V( 3 )
+ T3 = TAU*V3
+ V4 = V( 4 )
+ T4 = TAU*V4
+ V5 = V( 5 )
+ T5 = TAU*V5
+ V6 = V( 6 )
+ T6 = TAU*V6
+ V7 = V( 7 )
+ T7 = TAU*V7
+ V8 = V( 8 )
+ T8 = TAU*V8
+ V9 = V( 9 )
+ T9 = TAU*V9
+ V10 = V( 10 )
+ T10 = TAU*V10
+ DO 400 J = 1, M
+ SUM = V1*C( J, 1 ) + V2*C( J, 2 ) + V3*C( J, 3 ) +
+ $ V4*C( J, 4 ) + V5*C( J, 5 ) + V6*C( J, 6 ) +
+ $ V7*C( J, 7 ) + V8*C( J, 8 ) + V9*C( J, 9 ) +
+ $ V10*C( J, 10 )
+ C( J, 1 ) = C( J, 1 ) - SUM*T1
+ C( J, 2 ) = C( J, 2 ) - SUM*T2
+ C( J, 3 ) = C( J, 3 ) - SUM*T3
+ C( J, 4 ) = C( J, 4 ) - SUM*T4
+ C( J, 5 ) = C( J, 5 ) - SUM*T5
+ C( J, 6 ) = C( J, 6 ) - SUM*T6
+ C( J, 7 ) = C( J, 7 ) - SUM*T7
+ C( J, 8 ) = C( J, 8 ) - SUM*T8
+ C( J, 9 ) = C( J, 9 ) - SUM*T9
+ C( J, 10 ) = C( J, 10 ) - SUM*T10
+ 400 CONTINUE
+ GO TO 410
+ END IF
+ 410 RETURN
+*
+* End of SLARFX
+*
+ END
+ SUBROUTINE SLARGV( N, X, INCX, Y, INCY, C, INCC )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INCC, INCX, INCY, N
+* ..
+* .. Array Arguments ..
+ REAL C( * ), X( * ), Y( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SLARGV generates a vector of real plane rotations, determined by
+* elements of the real vectors x and y. For i = 1,2,...,n
+*
+* ( c(i) s(i) ) ( x(i) ) = ( a(i) )
+* ( -s(i) c(i) ) ( y(i) ) = ( 0 )
+*
+* Arguments
+* =========
+*
+* N (input) INTEGER
+* The number of plane rotations to be generated.
+*
+* X (input/output) REAL array,
+* dimension (1+(N-1)*INCX)
+* On entry, the vector x.
+* On exit, x(i) is overwritten by a(i), for i = 1,...,n.
+*
+* INCX (input) INTEGER
+* The increment between elements of X. INCX > 0.
+*
+* Y (input/output) REAL array,
+* dimension (1+(N-1)*INCY)
+* On entry, the vector y.
+* On exit, the sines of the plane rotations.
+*
+* INCY (input) INTEGER
+* The increment between elements of Y. INCY > 0.
+*
+* C (output) REAL array, dimension (1+(N-1)*INCC)
+* The cosines of the plane rotations.
+*
+* INCC (input) INTEGER
+* The increment between elements of C. INCC > 0.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO, ONE
+ PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, IC, IX, IY
+ REAL F, G, T, TT
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, SQRT
+* ..
+* .. Executable Statements ..
+*
+ IX = 1
+ IY = 1
+ IC = 1
+ DO 10 I = 1, N
+ F = X( IX )
+ G = Y( IY )
+ IF( G.EQ.ZERO ) THEN
+ C( IC ) = ONE
+ ELSE IF( F.EQ.ZERO ) THEN
+ C( IC ) = ZERO
+ Y( IY ) = ONE
+ X( IX ) = G
+ ELSE IF( ABS( F ).GT.ABS( G ) ) THEN
+ T = G / F
+ TT = SQRT( ONE+T*T )
+ C( IC ) = ONE / TT
+ Y( IY ) = T*C( IC )
+ X( IX ) = F*TT
+ ELSE
+ T = F / G
+ TT = SQRT( ONE+T*T )
+ Y( IY ) = ONE / TT
+ C( IC ) = T*Y( IY )
+ X( IX ) = G*TT
+ END IF
+ IC = IC + INCC
+ IY = IY + INCY
+ IX = IX + INCX
+ 10 CONTINUE
+ RETURN
+*
+* End of SLARGV
+*
+ END
+ SUBROUTINE SLARNV( IDIST, ISEED, N, X )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER IDIST, N
+* ..
+* .. Array Arguments ..
+ INTEGER ISEED( 4 )
+ REAL X( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SLARNV returns a vector of n random real numbers from a uniform or
+* normal distribution.
+*
+* Arguments
+* =========
+*
+* IDIST (input) INTEGER
+* Specifies the distribution of the random numbers:
+* = 1: uniform (0,1)
+* = 2: uniform (-1,1)
+* = 3: normal (0,1)
+*
+* ISEED (input/output) INTEGER array, dimension (4)
+* On entry, the seed of the random number generator; the array
+* elements must be between 0 and 4095, and ISEED(4) must be
+* odd.
+* On exit, the seed is updated.
+*
+* N (input) INTEGER
+* The number of random numbers to be generated.
+*
+* X (output) REAL array, dimension (N)
+* The generated random numbers.
+*
+* Further Details
+* ===============
+*
+* This routine calls the auxiliary routine SLARUV to generate random
+* real numbers from a uniform (0,1) distribution, in batches of up to
+* 128 using vectorisable code. The Box-Muller method is used to
+* transform numbers from a uniform to a normal distribution.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ONE, TWO
+ PARAMETER ( ONE = 1.0E+0, TWO = 2.0E+0 )
+ INTEGER LV
+ PARAMETER ( LV = 128 )
+ REAL TWOPI
+ PARAMETER ( TWOPI = 6.2831853071795864769252867663E+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, IL, IL2, IV
+* ..
+* .. Local Arrays ..
+ REAL U( LV )
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC COS, LOG, MIN, SQRT
+* ..
+* .. External Subroutines ..
+ EXTERNAL SLARUV
+* ..
+* .. Executable Statements ..
+*
+ DO 40 IV = 1, N, LV / 2
+ IL = MIN( LV / 2, N-IV+1 )
+ IF( IDIST.EQ.3 ) THEN
+ IL2 = 2*IL
+ ELSE
+ IL2 = IL
+ END IF
+*
+* Call SLARUV to generate IL2 numbers from a uniform (0,1)
+* distribution (IL2 <= LV)
+*
+ CALL SLARUV( ISEED, IL2, U )
+*
+ IF( IDIST.EQ.1 ) THEN
+*
+* Copy generated numbers
+*
+ DO 10 I = 1, IL
+ X( IV+I-1 ) = U( I )
+ 10 CONTINUE
+ ELSE IF( IDIST.EQ.2 ) THEN
+*
+* Convert generated numbers to uniform (-1,1) distribution
+*
+ DO 20 I = 1, IL
+ X( IV+I-1 ) = TWO*U( I ) - ONE
+ 20 CONTINUE
+ ELSE IF( IDIST.EQ.3 ) THEN
+*
+* Convert generated numbers to normal (0,1) distribution
+*
+ DO 30 I = 1, IL
+ X( IV+I-1 ) = SQRT( -TWO*LOG( U( 2*I-1 ) ) )*
+ $ COS( TWOPI*U( 2*I ) )
+ 30 CONTINUE
+ END IF
+ 40 CONTINUE
+ RETURN
+*
+* End of SLARNV
+*
+ END
+ SUBROUTINE SLARRA( N, D, E, E2, SPLTOL, TNRM,
+ $ NSPLIT, ISPLIT, INFO )
+ IMPLICIT NONE
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, N, NSPLIT
+ REAL SPLTOL, TNRM
+* ..
+* .. Array Arguments ..
+ INTEGER ISPLIT( * )
+ REAL D( * ), E( * ), E2( * )
+* ..
+*
+* Purpose
+* =======
+*
+* Compute the splitting points with threshold SPLTOL.
+* SLARRA sets any "small" off-diagonal elements to zero.
+*
+* Arguments
+* =========
+*
+* N (input) INTEGER
+* The order of the matrix. N > 0.
+*
+* D (input) REAL array, dimension (N)
+* On entry, the N diagonal elements of the tridiagonal
+* matrix T.
+*
+* E (input/output) REAL array, dimension (N)
+* On entry, the first (N-1) entries contain the subdiagonal
+* elements of the tridiagonal matrix T; E(N) need not be set.
+* On exit, the entries E( ISPLIT( I ) ), 1 <= I <= NSPLIT,
+* are set to zero, the other entries of E are untouched.
+*
+* E2 (input/output) REAL array, dimension (N)
+* On entry, the first (N-1) entries contain the SQUARES of the
+* subdiagonal elements of the tridiagonal matrix T;
+* E2(N) need not be set.
+* On exit, the entries E2( ISPLIT( I ) ),
+* 1 <= I <= NSPLIT, have been set to zero
+*
+* SPLTOL (input) REAL
+* The threshold for splitting. Two criteria can be used:
+* SPLTOL<0 : criterion based on absolute off-diagonal value
+* SPLTOL>0 : criterion that preserves relative accuracy
+*
+* TNRM (input) REAL
+* The norm of the matrix.
+*
+* NSPLIT (output) INTEGER
+* The number of blocks T splits into. 1 <= NSPLIT <= N.
+*
+* ISPLIT (output) INTEGER array, dimension (N)
+* The splitting points, at which T breaks up into blocks.
+* The first block consists of rows/columns 1 to ISPLIT(1),
+* the second of rows/columns ISPLIT(1)+1 through ISPLIT(2),
+* etc., and the NSPLIT-th consists of rows/columns
+* ISPLIT(NSPLIT-1)+1 through ISPLIT(NSPLIT)=N.
+*
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+*
+* Further Details
+* ===============
+*
+* Based on contributions by
+* Beresford Parlett, University of California, Berkeley, USA
+* Jim Demmel, University of California, Berkeley, USA
+* Inderjit Dhillon, University of Texas, Austin, USA
+* Osni Marques, LBNL/NERSC, USA
+* Christof Voemel, University of California, Berkeley, USA
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO
+ PARAMETER ( ZERO = 0.0E0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I
+ REAL EABS, TMP1
+
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS
+* ..
+* .. Executable Statements ..
+*
+ INFO = 0
+
+* Compute splitting points
+ NSPLIT = 1
+ IF(SPLTOL.LT.ZERO) THEN
+* Criterion based on absolute off-diagonal value
+ TMP1 = ABS(SPLTOL)* TNRM
+ DO 9 I = 1, N-1
+ EABS = ABS( E(I) )
+ IF( EABS .LE. TMP1) THEN
+ E(I) = ZERO
+ E2(I) = ZERO
+ ISPLIT( NSPLIT ) = I
+ NSPLIT = NSPLIT + 1
+ END IF
+ 9 CONTINUE
+ ELSE
+* Criterion that guarantees relative accuracy
+ DO 10 I = 1, N-1
+ EABS = ABS( E(I) )
+ IF( EABS .LE. SPLTOL * SQRT(ABS(D(I)))*SQRT(ABS(D(I+1))) )
+ $ THEN
+ E(I) = ZERO
+ E2(I) = ZERO
+ ISPLIT( NSPLIT ) = I
+ NSPLIT = NSPLIT + 1
+ END IF
+ 10 CONTINUE
+ ENDIF
+ ISPLIT( NSPLIT ) = N
+
+ RETURN
+*
+* End of SLARRA
+*
+ END
+ SUBROUTINE SLARRB( N, D, LLD, IFIRST, ILAST, RTOL1,
+ $ RTOL2, OFFSET, W, WGAP, WERR, WORK, IWORK,
+ $ PIVMIN, SPDIAM, TWIST, INFO )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER IFIRST, ILAST, INFO, N, OFFSET, TWIST
+ REAL PIVMIN, RTOL1, RTOL2, SPDIAM
+* ..
+* .. Array Arguments ..
+ INTEGER IWORK( * )
+ REAL D( * ), LLD( * ), W( * ),
+ $ WERR( * ), WGAP( * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* Given the relatively robust representation(RRR) L D L^T, SLARRB
+* does "limited" bisection to refine the eigenvalues of L D L^T,
+* W( IFIRST-OFFSET ) through W( ILAST-OFFSET ), to more accuracy. Initial
+* guesses for these eigenvalues are input in W, the corresponding estimate
+* of the error in these guesses and their gaps are input in WERR
+* and WGAP, respectively. During bisection, intervals
+* [left, right] are maintained by storing their mid-points and
+* semi-widths in the arrays W and WERR respectively.
+*
+* Arguments
+* =========
+*
+* N (input) INTEGER
+* The order of the matrix.
+*
+* D (input) REAL array, dimension (N)
+* The N diagonal elements of the diagonal matrix D.
+*
+* LLD (input) REAL array, dimension (N-1)
+* The (N-1) elements L(i)*L(i)*D(i).
+*
+* IFIRST (input) INTEGER
+* The index of the first eigenvalue to be computed.
+*
+* ILAST (input) INTEGER
+* The index of the last eigenvalue to be computed.
+*
+* RTOL1 (input) REAL
+* RTOL2 (input) REAL
+* Tolerance for the convergence of the bisection intervals.
+* An interval [LEFT,RIGHT] has converged if
+* RIGHT-LEFT.LT.MAX( RTOL1*GAP, RTOL2*MAX(|LEFT|,|RIGHT|) )
+* where GAP is the (estimated) distance to the nearest
+* eigenvalue.
+*
+* OFFSET (input) INTEGER
+* Offset for the arrays W, WGAP and WERR, i.e., the IFIRST-OFFSET
+* through ILAST-OFFSET elements of these arrays are to be used.
+*
+* W (input/output) REAL array, dimension (N)
+* On input, W( IFIRST-OFFSET ) through W( ILAST-OFFSET ) are
+* estimates of the eigenvalues of L D L^T indexed IFIRST throug
+* ILAST.
+* On output, these estimates are refined.
+*
+* WGAP (input/output) REAL array, dimension (N-1)
+* On input, the (estimated) gaps between consecutive
+* eigenvalues of L D L^T, i.e., WGAP(I-OFFSET) is the gap between
+* eigenvalues I and I+1. Note that if IFIRST.EQ.ILAST
+* then WGAP(IFIRST-OFFSET) must be set to ZERO.
+* On output, these gaps are refined.
+*
+* WERR (input/output) REAL array, dimension (N)
+* On input, WERR( IFIRST-OFFSET ) through WERR( ILAST-OFFSET ) are
+* the errors in the estimates of the corresponding elements in W.
+* On output, these errors are refined.
+*
+* WORK (workspace) REAL array, dimension (2*N)
+* Workspace.
+*
+* IWORK (workspace) INTEGER array, dimension (2*N)
+* Workspace.
+*
+* PIVMIN (input) DOUBLE PRECISION
+* The minimum pivot in the Sturm sequence.
+*
+* SPDIAM (input) DOUBLE PRECISION
+* The spectral diameter of the matrix.
+*
+* TWIST (input) INTEGER
+* The twist index for the twisted factorization that is used
+* for the negcount.
+* TWIST = N: Compute negcount from L D L^T - LAMBDA I = L+ D+ L+^T
+* TWIST = 1: Compute negcount from L D L^T - LAMBDA I = U- D- U-^T
+* TWIST = R: Compute negcount from L D L^T - LAMBDA I = N(r) D(r) N(r)
+*
+* INFO (output) INTEGER
+* Error flag.
+*
+* Further Details
+* ===============
+*
+* Based on contributions by
+* Beresford Parlett, University of California, Berkeley, USA
+* Jim Demmel, University of California, Berkeley, USA
+* Inderjit Dhillon, University of Texas, Austin, USA
+* Osni Marques, LBNL/NERSC, USA
+* Christof Voemel, University of California, Berkeley, USA
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO, TWO, HALF
+ PARAMETER ( ZERO = 0.0E0, TWO = 2.0E0,
+ $ HALF = 0.5E0 )
+ INTEGER MAXITR
+* ..
+* .. Local Scalars ..
+ INTEGER I, I1, II, IP, ITER, K, NEGCNT, NEXT, NINT,
+ $ OLNINT, PREV, R
+ REAL BACK, CVRGD, GAP, LEFT, LGAP, MID, MNWDTH,
+ $ RGAP, RIGHT, TMP, WIDTH
+* ..
+* .. External Functions ..
+ INTEGER SLANEG
+ EXTERNAL SLANEG
+*
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+ INFO = 0
+*
+ MAXITR = INT( ( LOG( SPDIAM+PIVMIN )-LOG( PIVMIN ) ) /
+ $ LOG( TWO ) ) + 2
+ MNWDTH = TWO * PIVMIN
+*
+ R = TWIST
+ IF((R.LT.1).OR.(R.GT.N)) R = N
+*
+* Initialize unconverged intervals in [ WORK(2*I-1), WORK(2*I) ].
+* The Sturm Count, Count( WORK(2*I-1) ) is arranged to be I-1, while
+* Count( WORK(2*I) ) is stored in IWORK( 2*I ). The integer IWORK( 2*I-1 )
+* for an unconverged interval is set to the index of the next unconverged
+* interval, and is -1 or 0 for a converged interval. Thus a linked
+* list of unconverged intervals is set up.
+*
+ I1 = IFIRST
+* The number of unconverged intervals
+ NINT = 0
+* The last unconverged interval found
+ PREV = 0
+
+ RGAP = WGAP( I1-OFFSET )
+ DO 75 I = I1, ILAST
+ K = 2*I
+ II = I - OFFSET
+ LEFT = W( II ) - WERR( II )
+ RIGHT = W( II ) + WERR( II )
+ LGAP = RGAP
+ RGAP = WGAP( II )
+ GAP = MIN( LGAP, RGAP )
+
+* Make sure that [LEFT,RIGHT] contains the desired eigenvalue
+* Compute negcount from dstqds facto L+D+L+^T = L D L^T - LEFT
+*
+* Do while( NEGCNT(LEFT).GT.I-1 )
+*
+ BACK = WERR( II )
+ 20 CONTINUE
+ NEGCNT = SLANEG( N, D, LLD, LEFT, PIVMIN, R )
+ IF( NEGCNT.GT.I-1 ) THEN
+ LEFT = LEFT - BACK
+ BACK = TWO*BACK
+ GO TO 20
+ END IF
+*
+* Do while( NEGCNT(RIGHT).LT.I )
+* Compute negcount from dstqds facto L+D+L+^T = L D L^T - RIGHT
+*
+ BACK = WERR( II )
+ 50 CONTINUE
+
+ NEGCNT = SLANEG( N, D, LLD, RIGHT, PIVMIN, R )
+ IF( NEGCNT.LT.I ) THEN
+ RIGHT = RIGHT + BACK
+ BACK = TWO*BACK
+ GO TO 50
+ END IF
+ WIDTH = HALF*ABS( LEFT - RIGHT )
+ TMP = MAX( ABS( LEFT ), ABS( RIGHT ) )
+ CVRGD = MAX(RTOL1*GAP,RTOL2*TMP)
+ IF( WIDTH.LE.CVRGD .OR. WIDTH.LE.MNWDTH ) THEN
+* This interval has already converged and does not need refinement.
+* (Note that the gaps might change through refining the
+* eigenvalues, however, they can only get bigger.)
+* Remove it from the list.
+ IWORK( K-1 ) = -1
+* Make sure that I1 always points to the first unconverged interval
+ IF((I.EQ.I1).AND.(I.LT.ILAST)) I1 = I + 1
+ IF((PREV.GE.I1).AND.(I.LE.ILAST)) IWORK( 2*PREV-1 ) = I + 1
+ ELSE
+* unconverged interval found
+ PREV = I
+ NINT = NINT + 1
+ IWORK( K-1 ) = I + 1
+ IWORK( K ) = NEGCNT
+ END IF
+ WORK( K-1 ) = LEFT
+ WORK( K ) = RIGHT
+ 75 CONTINUE
+
+*
+* Do while( NINT.GT.0 ), i.e. there are still unconverged intervals
+* and while (ITER.LT.MAXITR)
+*
+ ITER = 0
+ 80 CONTINUE
+ PREV = I1 - 1
+ I = I1
+ OLNINT = NINT
+
+ DO 100 IP = 1, OLNINT
+ K = 2*I
+ II = I - OFFSET
+ RGAP = WGAP( II )
+ LGAP = RGAP
+ IF(II.GT.1) LGAP = WGAP( II-1 )
+ GAP = MIN( LGAP, RGAP )
+ NEXT = IWORK( K-1 )
+ LEFT = WORK( K-1 )
+ RIGHT = WORK( K )
+ MID = HALF*( LEFT + RIGHT )
+
+* semiwidth of interval
+ WIDTH = RIGHT - MID
+ TMP = MAX( ABS( LEFT ), ABS( RIGHT ) )
+ CVRGD = MAX(RTOL1*GAP,RTOL2*TMP)
+ IF( ( WIDTH.LE.CVRGD ) .OR. ( WIDTH.LE.MNWDTH ).OR.
+ $ ( ITER.EQ.MAXITR ) )THEN
+* reduce number of unconverged intervals
+ NINT = NINT - 1
+* Mark interval as converged.
+ IWORK( K-1 ) = 0
+ IF( I1.EQ.I ) THEN
+ I1 = NEXT
+ ELSE
+* Prev holds the last unconverged interval previously examined
+ IF(PREV.GE.I1) IWORK( 2*PREV-1 ) = NEXT
+ END IF
+ I = NEXT
+ GO TO 100
+ END IF
+ PREV = I
+*
+* Perform one bisection step
+*
+ NEGCNT = SLANEG( N, D, LLD, MID, PIVMIN, R )
+ IF( NEGCNT.LE.I-1 ) THEN
+ WORK( K-1 ) = MID
+ ELSE
+ WORK( K ) = MID
+ END IF
+ I = NEXT
+ 100 CONTINUE
+ ITER = ITER + 1
+* do another loop if there are still unconverged intervals
+* However, in the last iteration, all intervals are accepted
+* since this is the best we can do.
+ IF( ( NINT.GT.0 ).AND.(ITER.LE.MAXITR) ) GO TO 80
+*
+*
+* At this point, all the intervals have converged
+ DO 110 I = IFIRST, ILAST
+ K = 2*I
+ II = I - OFFSET
+* All intervals marked by '0' have been refined.
+ IF( IWORK( K-1 ).EQ.0 ) THEN
+ W( II ) = HALF*( WORK( K-1 )+WORK( K ) )
+ WERR( II ) = WORK( K ) - W( II )
+ END IF
+ 110 CONTINUE
+*
+ DO 111 I = IFIRST+1, ILAST
+ K = 2*I
+ II = I - OFFSET
+ WGAP( II-1 ) = MAX( ZERO,
+ $ W(II) - WERR (II) - W( II-1 ) - WERR( II-1 ))
+ 111 CONTINUE
+
+ RETURN
+*
+* End of SLARRB
+*
+ END
+ SUBROUTINE SLARRC( JOBT, N, VL, VU, D, E, PIVMIN,
+ $ EIGCNT, LCNT, RCNT, INFO )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER JOBT
+ INTEGER EIGCNT, INFO, LCNT, N, RCNT
+ REAL PIVMIN, VL, VU
+* ..
+* .. Array Arguments ..
+ REAL D( * ), E( * )
+* ..
+*
+* Purpose
+* =======
+*
+* Find the number of eigenvalues of the symmetric tridiagonal matrix T
+* that are in the interval (VL,VU] if JOBT = 'T', and of L D L^T
+* if JOBT = 'L'.
+*
+* Arguments
+* =========
+*
+* JOBT (input) CHARACTER*1
+* = 'T': Compute Sturm count for matrix T.
+* = 'L': Compute Sturm count for matrix L D L^T.
+*
+* N (input) INTEGER
+* The order of the matrix. N > 0.
+*
+* VL (input) DOUBLE PRECISION
+* VU (input) DOUBLE PRECISION
+* The lower and upper bounds for the eigenvalues.
+*
+* D (input) DOUBLE PRECISION array, dimension (N)
+* JOBT = 'T': The N diagonal elements of the tridiagonal matrix T.
+* JOBT = 'L': The N diagonal elements of the diagonal matrix D.
+*
+* E (input) DOUBLE PRECISION array, dimension (N)
+* JOBT = 'T': The N-1 offdiagonal elements of the matrix T.
+* JOBT = 'L': The N-1 offdiagonal elements of the matrix L.
+*
+* PIVMIN (input) DOUBLE PRECISION
+* The minimum pivot in the Sturm sequence for T.
+*
+* EIGCNT (output) INTEGER
+* The number of eigenvalues of the symmetric tridiagonal matrix T
+* that are in the interval (VL,VU]
+*
+* LCNT (output) INTEGER
+* RCNT (output) INTEGER
+* The left and right negcounts of the interval.
+*
+* INFO (output) INTEGER
+*
+* Further Details
+* ===============
+*
+* Based on contributions by
+* Beresford Parlett, University of California, Berkeley, USA
+* Jim Demmel, University of California, Berkeley, USA
+* Inderjit Dhillon, University of Texas, Austin, USA
+* Osni Marques, LBNL/NERSC, USA
+* Christof Voemel, University of California, Berkeley, USA
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO
+ PARAMETER ( ZERO = 0.0E0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I
+ LOGICAL MATT
+ REAL LPIVOT, RPIVOT, SL, SU, TMP, TMP2
+
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. Executable Statements ..
+*
+ INFO = 0
+ LCNT = 0
+ RCNT = 0
+ EIGCNT = 0
+ MATT = LSAME( JOBT, 'T' )
+
+
+ IF (MATT) THEN
+* Sturm sequence count on T
+ LPIVOT = D( 1 ) - VL
+ RPIVOT = D( 1 ) - VU
+ IF( LPIVOT.LE.ZERO ) THEN
+ LCNT = LCNT + 1
+ ENDIF
+ IF( RPIVOT.LE.ZERO ) THEN
+ RCNT = RCNT + 1
+ ENDIF
+ DO 10 I = 1, N-1
+ TMP = E(I)**2
+ LPIVOT = ( D( I+1 )-VL ) - TMP/LPIVOT
+ RPIVOT = ( D( I+1 )-VU ) - TMP/RPIVOT
+ IF( LPIVOT.LE.ZERO ) THEN
+ LCNT = LCNT + 1
+ ENDIF
+ IF( RPIVOT.LE.ZERO ) THEN
+ RCNT = RCNT + 1
+ ENDIF
+ 10 CONTINUE
+ ELSE
+* Sturm sequence count on L D L^T
+ SL = -VL
+ SU = -VU
+ DO 20 I = 1, N - 1
+ LPIVOT = D( I ) + SL
+ RPIVOT = D( I ) + SU
+ IF( LPIVOT.LE.ZERO ) THEN
+ LCNT = LCNT + 1
+ ENDIF
+ IF( RPIVOT.LE.ZERO ) THEN
+ RCNT = RCNT + 1
+ ENDIF
+ TMP = E(I) * D(I) * E(I)
+*
+ TMP2 = TMP / LPIVOT
+ IF( TMP2.EQ.ZERO ) THEN
+ SL = TMP - VL
+ ELSE
+ SL = SL*TMP2 - VL
+ END IF
+*
+ TMP2 = TMP / RPIVOT
+ IF( TMP2.EQ.ZERO ) THEN
+ SU = TMP - VU
+ ELSE
+ SU = SU*TMP2 - VU
+ END IF
+ 20 CONTINUE
+ LPIVOT = D( N ) + SL
+ RPIVOT = D( N ) + SU
+ IF( LPIVOT.LE.ZERO ) THEN
+ LCNT = LCNT + 1
+ ENDIF
+ IF( RPIVOT.LE.ZERO ) THEN
+ RCNT = RCNT + 1
+ ENDIF
+ ENDIF
+ EIGCNT = RCNT - LCNT
+
+ RETURN
+*
+* end of SLARRC
+*
+ END
+ 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 )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER ORDER, RANGE
+ INTEGER IL, INFO, IU, M, N, NSPLIT
+ REAL PIVMIN, RELTOL, VL, VU, WL, WU
+* ..
+* .. Array Arguments ..
+ INTEGER IBLOCK( * ), INDEXW( * ),
+ $ ISPLIT( * ), IWORK( * )
+ REAL D( * ), E( * ), E2( * ),
+ $ GERS( * ), W( * ), WERR( * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SLARRD computes the eigenvalues of a symmetric tridiagonal
+* matrix T to suitable accuracy. This is an auxiliary code to be
+* called from SSTEMR.
+* The user may ask for all eigenvalues, all eigenvalues
+* in the half-open interval (VL, VU], or the IL-th through IU-th
+* eigenvalues.
+*
+* To avoid overflow, the matrix must be scaled so that its
+* largest element is no greater than overflow**(1/2) *
+* underflow**(1/4) in absolute value, and for greatest
+* accuracy, it should not be much smaller than that.
+*
+* See W. Kahan "Accurate Eigenvalues of a Symmetric Tridiagonal
+* Matrix", Report CS41, Computer Science Dept., Stanford
+* University, July 21, 1966.
+*
+* Arguments
+* =========
+*
+* RANGE (input) CHARACTER
+* = 'A': ("All") all eigenvalues will be found.
+* = 'V': ("Value") all eigenvalues in the half-open interval
+* (VL, VU] will be found.
+* = 'I': ("Index") the IL-th through IU-th eigenvalues (of the
+* entire matrix) will be found.
+*
+* ORDER (input) CHARACTER
+* = 'B': ("By Block") the eigenvalues will be grouped by
+* split-off block (see IBLOCK, ISPLIT) and
+* ordered from smallest to largest within
+* the block.
+* = 'E': ("Entire matrix")
+* the eigenvalues for the entire matrix
+* will be ordered from smallest to
+* largest.
+*
+* N (input) INTEGER
+* The order of the tridiagonal matrix T. N >= 0.
+*
+* VL (input) REAL
+* VU (input) REAL
+* If RANGE='V', the lower and upper bounds of the interval to
+* be searched for eigenvalues. Eigenvalues less than or equal
+* to VL, or greater than VU, will not be returned. VL < VU.
+* Not referenced if RANGE = 'A' or 'I'.
+*
+* IL (input) INTEGER
+* IU (input) INTEGER
+* If RANGE='I', the indices (in ascending order) of the
+* smallest and largest eigenvalues to be returned.
+* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
+* Not referenced if RANGE = 'A' or 'V'.
+*
+* GERS (input) REAL array, dimension (2*N)
+* The N Gerschgorin intervals (the i-th Gerschgorin interval
+* is (GERS(2*i-1), GERS(2*i)).
+*
+* RELTOL (input) REAL
+* The minimum relative width of an interval. When an interval
+* is narrower than RELTOL times the larger (in
+* magnitude) endpoint, then it is considered to be
+* sufficiently small, i.e., converged. Note: this should
+* always be at least radix*machine epsilon.
+*
+* D (input) REAL array, dimension (N)
+* The n diagonal elements of the tridiagonal matrix T.
+*
+* E (input) REAL array, dimension (N-1)
+* The (n-1) off-diagonal elements of the tridiagonal matrix T.
+*
+* E2 (input) REAL array, dimension (N-1)
+* The (n-1) squared off-diagonal elements of the tridiagonal matrix T.
+*
+* PIVMIN (input) REAL
+* The minimum pivot allowed in the Sturm sequence for T.
+*
+* NSPLIT (input) INTEGER
+* The number of diagonal blocks in the matrix T.
+* 1 <= NSPLIT <= N.
+*
+* ISPLIT (input) INTEGER array, dimension (N)
+* The splitting points, at which T breaks up into submatrices.
+* The first submatrix consists of rows/columns 1 to ISPLIT(1),
+* the second of rows/columns ISPLIT(1)+1 through ISPLIT(2),
+* etc., and the NSPLIT-th consists of rows/columns
+* ISPLIT(NSPLIT-1)+1 through ISPLIT(NSPLIT)=N.
+* (Only the first NSPLIT elements will actually be used, but
+* since the user cannot know a priori what value NSPLIT will
+* have, N words must be reserved for ISPLIT.)
+*
+* M (output) INTEGER
+* The actual number of eigenvalues found. 0 <= M <= N.
+* (See also the description of INFO=2,3.)
+*
+* W (output) REAL array, dimension (N)
+* On exit, the first M elements of W will contain the
+* eigenvalue approximations. SLARRD computes an interval
+* I_j = (a_j, b_j] that includes eigenvalue j. The eigenvalue
+* approximation is given as the interval midpoint
+* W(j)= ( a_j + b_j)/2. The corresponding error is bounded by
+* WERR(j) = abs( a_j - b_j)/2
+*
+* WERR (output) REAL array, dimension (N)
+* The error bound on the corresponding eigenvalue approximation
+* in W.
+*
+* WL (output) REAL
+* WU (output) REAL
+* The interval (WL, WU] contains all the wanted eigenvalues.
+* If RANGE='V', then WL=VL and WU=VU.
+* If RANGE='A', then WL and WU are the global Gerschgorin bounds
+* on the spectrum.
+* If RANGE='I', then WL and WU are computed by SLAEBZ from the
+* index range specified.
+*
+* IBLOCK (output) INTEGER array, dimension (N)
+* At each row/column j where E(j) is zero or small, the
+* matrix T is considered to split into a block diagonal
+* matrix. On exit, if INFO = 0, IBLOCK(i) specifies to which
+* block (from 1 to the number of blocks) the eigenvalue W(i)
+* belongs. (SLARRD may use the remaining N-M elements as
+* workspace.)
+*
+* INDEXW (output) INTEGER array, dimension (N)
+* The indices of the eigenvalues within each block (submatrix);
+* for example, INDEXW(i)= j and IBLOCK(i)=k imply that the
+* i-th eigenvalue W(i) is the j-th eigenvalue in block k.
+*
+* WORK (workspace) REAL array, dimension (4*N)
+*
+* IWORK (workspace) INTEGER array, dimension (3*N)
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* > 0: some or all of the eigenvalues failed to converge or
+* were not computed:
+* =1 or 3: Bisection failed to converge for some
+* eigenvalues; these eigenvalues are flagged by a
+* negative block number. The effect is that the
+* eigenvalues may not be as accurate as the
+* absolute and relative tolerances. This is
+* generally caused by unexpectedly inaccurate
+* arithmetic.
+* =2 or 3: RANGE='I' only: Not all of the eigenvalues
+* IL:IU were found.
+* Effect: M < IU+1-IL
+* Cause: non-monotonic arithmetic, causing the
+* Sturm sequence to be non-monotonic.
+* Cure: recalculate, using RANGE='A', and pick
+* out eigenvalues IL:IU. In some cases,
+* increasing the PARAMETER "FUDGE" may
+* make things work.
+* = 4: RANGE='I', and the Gershgorin interval
+* initially used was too small. No eigenvalues
+* were computed.
+* Probable cause: your machine has sloppy
+* floating-point arithmetic.
+* Cure: Increase the PARAMETER "FUDGE",
+* recompile, and try again.
+*
+* Internal Parameters
+* ===================
+*
+* FUDGE REAL , default = 2
+* A "fudge factor" to widen the Gershgorin intervals. Ideally,
+* a value of 1 should work, but on machines with sloppy
+* arithmetic, this needs to be larger. The default for
+* publicly released versions should be large enough to handle
+* the worst machine around. Note that this has no effect
+* on accuracy of the solution.
+*
+* Based on contributions by
+* W. Kahan, University of California, Berkeley, USA
+* Beresford Parlett, University of California, Berkeley, USA
+* Jim Demmel, University of California, Berkeley, USA
+* Inderjit Dhillon, University of Texas, Austin, USA
+* Osni Marques, LBNL/NERSC, USA
+* Christof Voemel, University of California, Berkeley, USA
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO, ONE, TWO, HALF, FUDGE
+ PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0,
+ $ TWO = 2.0E0, HALF = ONE/TWO,
+ $ FUDGE = TWO )
+ INTEGER ALLRNG, VALRNG, INDRNG
+ PARAMETER ( ALLRNG = 1, VALRNG = 2, INDRNG = 3 )
+* ..
+* .. Local Scalars ..
+ LOGICAL NCNVRG, TOOFEW
+ INTEGER I, IB, IBEGIN, IDISCL, IDISCU, IE, IEND, IINFO,
+ $ IM, IN, IOFF, IOUT, IRANGE, ITMAX, ITMP1,
+ $ ITMP2, IW, IWOFF, J, JBLK, JDISC, JE, JEE, NB,
+ $ NWL, NWU
+ REAL ATOLI, EPS, GL, GU, RTOLI, SPDIAM, TMP1, TMP2,
+ $ TNORM, UFLOW, WKILL, WLU, WUL
+
+* ..
+* .. Local Arrays ..
+ INTEGER IDUMMA( 1 )
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ILAENV
+ REAL SLAMCH
+ EXTERNAL LSAME, ILAENV, SLAMCH
+* ..
+* .. External Subroutines ..
+ EXTERNAL SLAEBZ
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, INT, LOG, MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+ INFO = 0
+*
+* Decode RANGE
+*
+ IF( LSAME( RANGE, 'A' ) ) THEN
+ IRANGE = ALLRNG
+ ELSE IF( LSAME( RANGE, 'V' ) ) THEN
+ IRANGE = VALRNG
+ ELSE IF( LSAME( RANGE, 'I' ) ) THEN
+ IRANGE = INDRNG
+ ELSE
+ IRANGE = 0
+ END IF
+*
+* Check for Errors
+*
+ IF( IRANGE.LE.0 ) THEN
+ INFO = -1
+ ELSE IF( .NOT.(LSAME(ORDER,'B').OR.LSAME(ORDER,'E')) ) THEN
+ INFO = -2
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( IRANGE.EQ.VALRNG ) THEN
+ IF( VL.GE.VU )
+ $ INFO = -5
+ ELSE IF( IRANGE.EQ.INDRNG .AND.
+ $ ( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) ) THEN
+ INFO = -6
+ ELSE IF( IRANGE.EQ.INDRNG .AND.
+ $ ( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) ) THEN
+ INFO = -7
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ RETURN
+ END IF
+
+* Initialize error flags
+ INFO = 0
+ NCNVRG = .FALSE.
+ TOOFEW = .FALSE.
+
+* Quick return if possible
+ M = 0
+ IF( N.EQ.0 ) RETURN
+
+* Simplification:
+ IF( IRANGE.EQ.INDRNG .AND. IL.EQ.1 .AND. IU.EQ.N ) IRANGE = 1
+
+* Get machine constants
+ EPS = SLAMCH( 'P' )
+ UFLOW = SLAMCH( 'U' )
+
+
+* Special Case when N=1
+* Treat case of 1x1 matrix for quick return
+ IF( N.EQ.1 ) THEN
+ IF( (IRANGE.EQ.ALLRNG).OR.
+ $ ((IRANGE.EQ.VALRNG).AND.(D(1).GT.VL).AND.(D(1).LE.VU)).OR.
+ $ ((IRANGE.EQ.INDRNG).AND.(IL.EQ.1).AND.(IU.EQ.1)) ) THEN
+ M = 1
+ W(1) = D(1)
+* The computation error of the eigenvalue is zero
+ WERR(1) = ZERO
+ IBLOCK( 1 ) = 1
+ INDEXW( 1 ) = 1
+ ENDIF
+ RETURN
+ END IF
+
+* NB is the minimum vector length for vector bisection, or 0
+* if only scalar is to be done.
+ NB = ILAENV( 1, 'SSTEBZ', ' ', N, -1, -1, -1 )
+ IF( NB.LE.1 ) NB = 0
+
+* Find global spectral radius
+ GL = D(1)
+ GU = D(1)
+ DO 5 I = 1,N
+ GL = MIN( GL, GERS( 2*I - 1))
+ GU = MAX( GU, GERS(2*I) )
+ 5 CONTINUE
+* Compute global Gerschgorin bounds and spectral diameter
+ TNORM = MAX( ABS( GL ), ABS( GU ) )
+ GL = GL - FUDGE*TNORM*EPS*N - FUDGE*TWO*PIVMIN
+ GU = GU + FUDGE*TNORM*EPS*N + FUDGE*TWO*PIVMIN
+ SPDIAM = GU - GL
+* Input arguments for SLAEBZ:
+* The relative tolerance. An interval (a,b] lies within
+* "relative tolerance" if b-a < RELTOL*max(|a|,|b|),
+ RTOLI = RELTOL
+* Set the absolute tolerance for interval convergence to zero to force
+* interval convergence based on relative size of the interval.
+* This is dangerous because intervals might not converge when RELTOL is
+* small. But at least a very small number should be selected so that for
+* strongly graded matrices, the code can get relatively accurate
+* eigenvalues.
+ ATOLI = FUDGE*TWO*UFLOW + FUDGE*TWO*PIVMIN
+
+ IF( IRANGE.EQ.INDRNG ) THEN
+
+* RANGE='I': Compute an interval containing eigenvalues
+* IL through IU. The initial interval [GL,GU] from the global
+* Gerschgorin bounds GL and GU is refined by SLAEBZ.
+ ITMAX = INT( ( LOG( TNORM+PIVMIN )-LOG( PIVMIN ) ) /
+ $ LOG( TWO ) ) + 2
+ WORK( N+1 ) = GL
+ WORK( N+2 ) = GL
+ WORK( N+3 ) = GU
+ WORK( N+4 ) = GU
+ WORK( N+5 ) = GL
+ WORK( N+6 ) = GU
+ IWORK( 1 ) = -1
+ IWORK( 2 ) = -1
+ IWORK( 3 ) = N + 1
+ IWORK( 4 ) = N + 1
+ IWORK( 5 ) = IL - 1
+ IWORK( 6 ) = IU
+*
+ CALL SLAEBZ( 3, ITMAX, N, 2, 2, NB, ATOLI, RTOLI, PIVMIN,
+ $ D, E, E2, IWORK( 5 ), WORK( N+1 ), WORK( N+5 ), IOUT,
+ $ IWORK, W, IBLOCK, IINFO )
+ IF( IINFO .NE. 0 ) THEN
+ INFO = IINFO
+ RETURN
+ END IF
+* On exit, output intervals may not be ordered by ascending negcount
+ IF( IWORK( 6 ).EQ.IU ) THEN
+ WL = WORK( N+1 )
+ WLU = WORK( N+3 )
+ NWL = IWORK( 1 )
+ WU = WORK( N+4 )
+ WUL = WORK( N+2 )
+ NWU = IWORK( 4 )
+ ELSE
+ WL = WORK( N+2 )
+ WLU = WORK( N+4 )
+ NWL = IWORK( 2 )
+ WU = WORK( N+3 )
+ WUL = WORK( N+1 )
+ NWU = IWORK( 3 )
+ END IF
+* On exit, the interval [WL, WLU] contains a value with negcount NWL,
+* and [WUL, WU] contains a value with negcount NWU.
+ IF( NWL.LT.0 .OR. NWL.GE.N .OR. NWU.LT.1 .OR. NWU.GT.N ) THEN
+ INFO = 4
+ RETURN
+ END IF
+
+ ELSEIF( IRANGE.EQ.VALRNG ) THEN
+ WL = VL
+ WU = VU
+
+ ELSEIF( IRANGE.EQ.ALLRNG ) THEN
+ WL = GL
+ WU = GU
+ ENDIF
+
+
+
+* Find Eigenvalues -- Loop Over blocks and recompute NWL and NWU.
+* NWL accumulates the number of eigenvalues .le. WL,
+* NWU accumulates the number of eigenvalues .le. WU
+ M = 0
+ IEND = 0
+ INFO = 0
+ NWL = 0
+ NWU = 0
+*
+ DO 70 JBLK = 1, NSPLIT
+ IOFF = IEND
+ IBEGIN = IOFF + 1
+ IEND = ISPLIT( JBLK )
+ IN = IEND - IOFF
+*
+ IF( IN.EQ.1 ) THEN
+* 1x1 block
+ IF( WL.GE.D( IBEGIN )-PIVMIN )
+ $ NWL = NWL + 1
+ IF( WU.GE.D( IBEGIN )-PIVMIN )
+ $ NWU = NWU + 1
+ IF( IRANGE.EQ.ALLRNG .OR.
+ $ ( WL.LT.D( IBEGIN )-PIVMIN
+ $ .AND. WU.GE. D( IBEGIN )-PIVMIN ) ) THEN
+ M = M + 1
+ W( M ) = D( IBEGIN )
+ WERR(M) = ZERO
+* The gap for a single block doesn't matter for the later
+* algorithm and is assigned an arbitrary large value
+ IBLOCK( M ) = JBLK
+ INDEXW( M ) = 1
+ END IF
+
+* Disabled 2x2 case because of a failure on the following matrix
+* RANGE = 'I', IL = IU = 4
+* Original Tridiagonal, d = [
+* -0.150102010615740E+00
+* -0.849897989384260E+00
+* -0.128208148052635E-15
+* 0.128257718286320E-15
+* ];
+* e = [
+* -0.357171383266986E+00
+* -0.180411241501588E-15
+* -0.175152352710251E-15
+* ];
+*
+* ELSE IF( IN.EQ.2 ) THEN
+** 2x2 block
+* DISC = SQRT( (HALF*(D(IBEGIN)-D(IEND)))**2 + E(IBEGIN)**2 )
+* TMP1 = HALF*(D(IBEGIN)+D(IEND))
+* L1 = TMP1 - DISC
+* IF( WL.GE. L1-PIVMIN )
+* $ NWL = NWL + 1
+* IF( WU.GE. L1-PIVMIN )
+* $ NWU = NWU + 1
+* IF( IRANGE.EQ.ALLRNG .OR. ( WL.LT.L1-PIVMIN .AND. WU.GE.
+* $ L1-PIVMIN ) ) THEN
+* M = M + 1
+* W( M ) = L1
+** The uncertainty of eigenvalues of a 2x2 matrix is very small
+* WERR( M ) = EPS * ABS( W( M ) ) * TWO
+* IBLOCK( M ) = JBLK
+* INDEXW( M ) = 1
+* ENDIF
+* L2 = TMP1 + DISC
+* IF( WL.GE. L2-PIVMIN )
+* $ NWL = NWL + 1
+* IF( WU.GE. L2-PIVMIN )
+* $ NWU = NWU + 1
+* IF( IRANGE.EQ.ALLRNG .OR. ( WL.LT.L2-PIVMIN .AND. WU.GE.
+* $ L2-PIVMIN ) ) THEN
+* M = M + 1
+* W( M ) = L2
+** The uncertainty of eigenvalues of a 2x2 matrix is very small
+* WERR( M ) = EPS * ABS( W( M ) ) * TWO
+* IBLOCK( M ) = JBLK
+* INDEXW( M ) = 2
+* ENDIF
+ ELSE
+* General Case - block of size IN >= 2
+* Compute local Gerschgorin interval and use it as the initial
+* interval for SLAEBZ
+ GU = D( IBEGIN )
+ GL = D( IBEGIN )
+ TMP1 = ZERO
+
+ DO 40 J = IBEGIN, IEND
+ GL = MIN( GL, GERS( 2*J - 1))
+ GU = MAX( GU, GERS(2*J) )
+ 40 CONTINUE
+ SPDIAM = GU - GL
+ GL = GL - FUDGE*SPDIAM*EPS*IN - FUDGE*PIVMIN
+ GU = GU + FUDGE*SPDIAM*EPS*IN + FUDGE*PIVMIN
+*
+ IF( IRANGE.GT.1 ) THEN
+ IF( GU.LT.WL ) THEN
+* the local block contains none of the wanted eigenvalues
+ NWL = NWL + IN
+ NWU = NWU + IN
+ GO TO 70
+ END IF
+* refine search interval if possible, only range (WL,WU] matters
+ GL = MAX( GL, WL )
+ GU = MIN( GU, WU )
+ IF( GL.GE.GU )
+ $ GO TO 70
+ END IF
+
+* Find negcount of initial interval boundaries GL and GU
+ WORK( N+1 ) = GL
+ WORK( N+IN+1 ) = GU
+ CALL SLAEBZ( 1, 0, IN, IN, 1, NB, ATOLI, RTOLI, PIVMIN,
+ $ D( IBEGIN ), E( IBEGIN ), E2( IBEGIN ),
+ $ IDUMMA, WORK( N+1 ), WORK( N+2*IN+1 ), IM,
+ $ IWORK, W( M+1 ), IBLOCK( M+1 ), IINFO )
+ IF( IINFO .NE. 0 ) THEN
+ INFO = IINFO
+ RETURN
+ END IF
+*
+ NWL = NWL + IWORK( 1 )
+ NWU = NWU + IWORK( IN+1 )
+ IWOFF = M - IWORK( 1 )
+
+* Compute Eigenvalues
+ ITMAX = INT( ( LOG( GU-GL+PIVMIN )-LOG( PIVMIN ) ) /
+ $ LOG( TWO ) ) + 2
+ CALL SLAEBZ( 2, ITMAX, IN, IN, 1, NB, ATOLI, RTOLI, PIVMIN,
+ $ D( IBEGIN ), E( IBEGIN ), E2( IBEGIN ),
+ $ IDUMMA, WORK( N+1 ), WORK( N+2*IN+1 ), IOUT,
+ $ IWORK, W( M+1 ), IBLOCK( M+1 ), IINFO )
+ IF( IINFO .NE. 0 ) THEN
+ INFO = IINFO
+ RETURN
+ END IF
+*
+* Copy eigenvalues into W and IBLOCK
+* Use -JBLK for block number for unconverged eigenvalues.
+* Loop over the number of output intervals from SLAEBZ
+ DO 60 J = 1, IOUT
+* eigenvalue approximation is middle point of interval
+ TMP1 = HALF*( WORK( J+N )+WORK( J+IN+N ) )
+* semi length of error interval
+ TMP2 = HALF*ABS( WORK( J+N )-WORK( J+IN+N ) )
+ IF( J.GT.IOUT-IINFO ) THEN
+* Flag non-convergence.
+ NCNVRG = .TRUE.
+ IB = -JBLK
+ ELSE
+ IB = JBLK
+ END IF
+ DO 50 JE = IWORK( J ) + 1 + IWOFF,
+ $ IWORK( J+IN ) + IWOFF
+ W( JE ) = TMP1
+ WERR( JE ) = TMP2
+ INDEXW( JE ) = JE - IWOFF
+ IBLOCK( JE ) = IB
+ 50 CONTINUE
+ 60 CONTINUE
+*
+ M = M + IM
+ END IF
+ 70 CONTINUE
+
+* If RANGE='I', then (WL,WU) contains eigenvalues NWL+1,...,NWU
+* If NWL+1 < IL or NWU > IU, discard extra eigenvalues.
+ IF( IRANGE.EQ.INDRNG ) THEN
+ IDISCL = IL - 1 - NWL
+ IDISCU = NWU - IU
+*
+ IF( IDISCL.GT.0 ) THEN
+ IM = 0
+ DO 80 JE = 1, M
+* Remove some of the smallest eigenvalues from the left so that
+* at the end IDISCL =0. Move all eigenvalues up to the left.
+ IF( W( JE ).LE.WLU .AND. IDISCL.GT.0 ) THEN
+ IDISCL = IDISCL - 1
+ ELSE
+ IM = IM + 1
+ W( IM ) = W( JE )
+ WERR( IM ) = WERR( JE )
+ INDEXW( IM ) = INDEXW( JE )
+ IBLOCK( IM ) = IBLOCK( JE )
+ END IF
+ 80 CONTINUE
+ M = IM
+ END IF
+ IF( IDISCU.GT.0 ) THEN
+* Remove some of the largest eigenvalues from the right so that
+* at the end IDISCU =0. Move all eigenvalues up to the left.
+ IM=M+1
+ DO 81 JE = M, 1, -1
+ IF( W( JE ).GE.WUL .AND. IDISCU.GT.0 ) THEN
+ IDISCU = IDISCU - 1
+ ELSE
+ IM = IM - 1
+ W( IM ) = W( JE )
+ WERR( IM ) = WERR( JE )
+ INDEXW( IM ) = INDEXW( JE )
+ IBLOCK( IM ) = IBLOCK( JE )
+ END IF
+ 81 CONTINUE
+ JEE = 0
+ DO 82 JE = IM, M
+ JEE = JEE + 1
+ W( JEE ) = W( JE )
+ WERR( JEE ) = WERR( JE )
+ INDEXW( JEE ) = INDEXW( JE )
+ IBLOCK( JEE ) = IBLOCK( JE )
+ 82 CONTINUE
+ M = M-IM+1
+ END IF
+
+ IF( IDISCL.GT.0 .OR. IDISCU.GT.0 ) THEN
+* Code to deal with effects of bad arithmetic. (If N(w) is
+* monotone non-decreasing, this should never happen.)
+* Some low eigenvalues to be discarded are not in (WL,WLU],
+* or high eigenvalues to be discarded are not in (WUL,WU]
+* so just kill off the smallest IDISCL/largest IDISCU
+* eigenvalues, by marking the corresponding IBLOCK = 0
+ IF( IDISCL.GT.0 ) THEN
+ WKILL = WU
+ DO 100 JDISC = 1, IDISCL
+ IW = 0
+ DO 90 JE = 1, M
+ IF( IBLOCK( JE ).NE.0 .AND.
+ $ ( W( JE ).LT.WKILL .OR. IW.EQ.0 ) ) THEN
+ IW = JE
+ WKILL = W( JE )
+ END IF
+ 90 CONTINUE
+ IBLOCK( IW ) = 0
+ 100 CONTINUE
+ END IF
+ IF( IDISCU.GT.0 ) THEN
+ WKILL = WL
+ DO 120 JDISC = 1, IDISCU
+ IW = 0
+ DO 110 JE = 1, M
+ IF( IBLOCK( JE ).NE.0 .AND.
+ $ ( W( JE ).GE.WKILL .OR. IW.EQ.0 ) ) THEN
+ IW = JE
+ WKILL = W( JE )
+ END IF
+ 110 CONTINUE
+ IBLOCK( IW ) = 0
+ 120 CONTINUE
+ END IF
+* Now erase all eigenvalues with IBLOCK set to zero
+ IM = 0
+ DO 130 JE = 1, M
+ IF( IBLOCK( JE ).NE.0 ) THEN
+ IM = IM + 1
+ W( IM ) = W( JE )
+ WERR( IM ) = WERR( JE )
+ INDEXW( IM ) = INDEXW( JE )
+ IBLOCK( IM ) = IBLOCK( JE )
+ END IF
+ 130 CONTINUE
+ M = IM
+ END IF
+ IF( IDISCL.LT.0 .OR. IDISCU.LT.0 ) THEN
+ TOOFEW = .TRUE.
+ END IF
+ END IF
+*
+ IF(( IRANGE.EQ.ALLRNG .AND. M.NE.N ).OR.
+ $ ( IRANGE.EQ.INDRNG .AND. M.NE.IU-IL+1 ) ) THEN
+ TOOFEW = .TRUE.
+ END IF
+
+* If ORDER='B', do nothing the eigenvalues are already sorted by
+* block.
+* If ORDER='E', sort the eigenvalues from smallest to largest
+
+ IF( LSAME(ORDER,'E') .AND. NSPLIT.GT.1 ) THEN
+ DO 150 JE = 1, M - 1
+ IE = 0
+ TMP1 = W( JE )
+ DO 140 J = JE + 1, M
+ IF( W( J ).LT.TMP1 ) THEN
+ IE = J
+ TMP1 = W( J )
+ END IF
+ 140 CONTINUE
+ IF( IE.NE.0 ) THEN
+ TMP2 = WERR( IE )
+ ITMP1 = IBLOCK( IE )
+ ITMP2 = INDEXW( IE )
+ W( IE ) = W( JE )
+ WERR( IE ) = WERR( JE )
+ IBLOCK( IE ) = IBLOCK( JE )
+ INDEXW( IE ) = INDEXW( JE )
+ W( JE ) = TMP1
+ WERR( JE ) = TMP2
+ IBLOCK( JE ) = ITMP1
+ INDEXW( JE ) = ITMP2
+ END IF
+ 150 CONTINUE
+ END IF
+*
+ INFO = 0
+ IF( NCNVRG )
+ $ INFO = INFO + 1
+ IF( TOOFEW )
+ $ INFO = INFO + 2
+ RETURN
+*
+* End of SLARRD
+*
+ END
+ 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 )
+ IMPLICIT NONE
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER RANGE
+ INTEGER IL, INFO, IU, M, N, NSPLIT
+ REAL PIVMIN, RTOL1, RTOL2, SPLTOL, VL, VU
+* ..
+* .. Array Arguments ..
+ INTEGER IBLOCK( * ), ISPLIT( * ), IWORK( * ),
+ $ INDEXW( * )
+ REAL D( * ), E( * ), E2( * ), GERS( * ),
+ $ W( * ),WERR( * ), WGAP( * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* To find the desired eigenvalues of a given real symmetric
+* tridiagonal matrix T, SLARRE sets any "small" off-diagonal
+* elements to zero, and for each unreduced block T_i, it finds
+* (a) a suitable shift at one end of the block's spectrum,
+* (b) the base representation, T_i - sigma_i I = L_i D_i L_i^T, and
+* (c) eigenvalues of each L_i D_i L_i^T.
+* The representations and eigenvalues found are then used by
+* SSTEMR to compute the eigenvectors of T.
+* The accuracy varies depending on whether bisection is used to
+* find a few eigenvalues or the dqds algorithm (subroutine SLASQ2) to
+* conpute all and then discard any unwanted one.
+* As an added benefit, SLARRE also outputs the n
+* Gerschgorin intervals for the matrices L_i D_i L_i^T.
+*
+* Arguments
+* =========
+*
+* RANGE (input) CHARACTER
+* = 'A': ("All") all eigenvalues will be found.
+* = 'V': ("Value") all eigenvalues in the half-open interval
+* (VL, VU] will be found.
+* = 'I': ("Index") the IL-th through IU-th eigenvalues (of the
+* entire matrix) will be found.
+*
+* N (input) INTEGER
+* The order of the matrix. N > 0.
+*
+* VL (input/output) REAL
+* VU (input/output) REAL
+* If RANGE='V', the lower and upper bounds for the eigenvalues.
+* Eigenvalues less than or equal to VL, or greater than VU,
+* will not be returned. VL < VU.
+* If RANGE='I' or ='A', SLARRE computes bounds on the desired
+* part of the spectrum.
+*
+* IL (input) INTEGER
+* IU (input) INTEGER
+* If RANGE='I', the indices (in ascending order) of the
+* smallest and largest eigenvalues to be returned.
+* 1 <= IL <= IU <= N.
+*
+* D (input/output) REAL array, dimension (N)
+* On entry, the N diagonal elements of the tridiagonal
+* matrix T.
+* On exit, the N diagonal elements of the diagonal
+* matrices D_i.
+*
+* E (input/output) REAL array, dimension (N)
+* On entry, the first (N-1) entries contain the subdiagonal
+* elements of the tridiagonal matrix T; E(N) need not be set.
+* On exit, E contains the subdiagonal elements of the unit
+* bidiagonal matrices L_i. The entries E( ISPLIT( I ) ),
+* 1 <= I <= NSPLIT, contain the base points sigma_i on output.
+*
+* E2 (input/output) REAL array, dimension (N)
+* On entry, the first (N-1) entries contain the SQUARES of the
+* subdiagonal elements of the tridiagonal matrix T;
+* E2(N) need not be set.
+* On exit, the entries E2( ISPLIT( I ) ),
+* 1 <= I <= NSPLIT, have been set to zero
+*
+* RTOL1 (input) REAL
+* RTOL2 (input) REAL
+* Parameters for bisection.
+* An interval [LEFT,RIGHT] has converged if
+* RIGHT-LEFT.LT.MAX( RTOL1*GAP, RTOL2*MAX(|LEFT|,|RIGHT|) )
+*
+* SPLTOL (input) REAL
+* The threshold for splitting.
+*
+* NSPLIT (output) INTEGER
+* The number of blocks T splits into. 1 <= NSPLIT <= N.
+*
+* ISPLIT (output) INTEGER array, dimension (N)
+* The splitting points, at which T breaks up into blocks.
+* The first block consists of rows/columns 1 to ISPLIT(1),
+* the second of rows/columns ISPLIT(1)+1 through ISPLIT(2),
+* etc., and the NSPLIT-th consists of rows/columns
+* ISPLIT(NSPLIT-1)+1 through ISPLIT(NSPLIT)=N.
+*
+* M (output) INTEGER
+* The total number of eigenvalues (of all L_i D_i L_i^T)
+* found.
+*
+* W (output) REAL array, dimension (N)
+* The first M elements contain the eigenvalues. The
+* eigenvalues of each of the blocks, L_i D_i L_i^T, are
+* sorted in ascending order ( SLARRE may use the
+* remaining N-M elements as workspace).
+*
+* WERR (output) REAL array, dimension (N)
+* The error bound on the corresponding eigenvalue in W.
+*
+* WGAP (output) REAL array, dimension (N)
+* The separation from the right neighbor eigenvalue in W.
+* The gap is only with respect to the eigenvalues of the same block
+* as each block has its own representation tree.
+* Exception: at the right end of a block we store the left gap
+*
+* IBLOCK (output) INTEGER array, dimension (N)
+* The indices of the blocks (submatrices) associated with the
+* corresponding eigenvalues in W; IBLOCK(i)=1 if eigenvalue
+* W(i) belongs to the first block from the top, =2 if W(i)
+* belongs to the second block, etc.
+*
+* INDEXW (output) INTEGER array, dimension (N)
+* The indices of the eigenvalues within each block (submatrix);
+* for example, INDEXW(i)= 10 and IBLOCK(i)=2 imply that the
+* i-th eigenvalue W(i) is the 10-th eigenvalue in block 2
+*
+* GERS (output) REAL array, dimension (2*N)
+* The N Gerschgorin intervals (the i-th Gerschgorin interval
+* is (GERS(2*i-1), GERS(2*i)).
+*
+* PIVMIN (output) DOUBLE PRECISION
+* The minimum pivot in the Sturm sequence for T.
+*
+* WORK (workspace) REAL array, dimension (6*N)
+* Workspace.
+*
+* IWORK (workspace) INTEGER array, dimension (5*N)
+* Workspace.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* > 0: A problem occured in SLARRE.
+* < 0: One of the called subroutines signaled an internal problem.
+* Needs inspection of the corresponding parameter IINFO
+* for further information.
+*
+* =-1: Problem in SLARRD.
+* = 2: No base representation could be found in MAXTRY iterations.
+* Increasing MAXTRY and recompilation might be a remedy.
+* =-3: Problem in SLARRB when computing the refined root
+* representation for SLASQ2.
+* =-4: Problem in SLARRB when preforming bisection on the
+* desired part of the spectrum.
+* =-5: Problem in SLASQ2.
+* =-6: Problem in SLASQ2.
+*
+* Further Details
+* The base representations are required to suffer very little
+* element growth and consequently define all their eigenvalues to
+* high relative accuracy.
+* ===============
+*
+* Based on contributions by
+* Beresford Parlett, University of California, Berkeley, USA
+* Jim Demmel, University of California, Berkeley, USA
+* Inderjit Dhillon, University of Texas, Austin, USA
+* Osni Marques, LBNL/NERSC, USA
+* Christof Voemel, University of California, Berkeley, USA
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL FAC, FOUR, FOURTH, FUDGE, HALF, HNDRD,
+ $ MAXGROWTH, ONE, PERT, TWO, ZERO
+ PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0,
+ $ TWO = 2.0E0, FOUR=4.0E0,
+ $ HNDRD = 100.0E0,
+ $ PERT = 4.0E0,
+ $ HALF = ONE/TWO, FOURTH = ONE/FOUR, FAC= HALF,
+ $ MAXGROWTH = 64.0E0, FUDGE = 2.0E0 )
+ INTEGER MAXTRY, ALLRNG, INDRNG, VALRNG
+ PARAMETER ( MAXTRY = 6, ALLRNG = 1, INDRNG = 2,
+ $ VALRNG = 3 )
+* ..
+* .. Local Scalars ..
+ LOGICAL FORCEB, NOREP, USEDQD
+ INTEGER CNT, CNT1, CNT2, I, IBEGIN, IDUM, IEND, IINFO,
+ $ IN, INDL, INDU, IRANGE, J, JBLK, MB, MM,
+ $ WBEGIN, WEND
+ REAL AVGAP, BSRTOL, CLWDTH, DMAX, DPIVOT, EABS,
+ $ EMAX, EOLD, EPS, GL, GU, ISLEFT, ISRGHT, RTL,
+ $ RTOL, S1, S2, SAFMIN, SGNDEF, SIGMA, SPDIAM,
+ $ TAU, TMP, TMP1
+
+
+* ..
+* .. Local Arrays ..
+ INTEGER ISEED( 4 )
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ REAL SLAMCH
+ EXTERNAL SLAMCH, LSAME
+
+* ..
+* .. External Subroutines ..
+ EXTERNAL SCOPY, SLARNV, SLARRA, SLARRB, SLARRC, SLARRD,
+ $ SLASQ2
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, MIN
+
+* ..
+* .. Executable Statements ..
+*
+
+ INFO = 0
+
+*
+* Decode RANGE
+*
+ IF( LSAME( RANGE, 'A' ) ) THEN
+ IRANGE = ALLRNG
+ ELSE IF( LSAME( RANGE, 'V' ) ) THEN
+ IRANGE = VALRNG
+ ELSE IF( LSAME( RANGE, 'I' ) ) THEN
+ IRANGE = INDRNG
+ END IF
+
+ M = 0
+
+* Get machine constants
+ SAFMIN = SLAMCH( 'S' )
+ EPS = SLAMCH( 'P' )
+
+* Set parameters
+ RTL = HNDRD*EPS
+* If one were ever to ask for less initial precision in BSRTOL,
+* one should keep in mind that for the subset case, the extremal
+* eigenvalues must be at least as accurate as the current setting
+* (eigenvalues in the middle need not as much accuracy)
+ BSRTOL = SQRT(EPS)*(0.5E-3)
+
+* Treat case of 1x1 matrix for quick return
+ IF( N.EQ.1 ) THEN
+ IF( (IRANGE.EQ.ALLRNG).OR.
+ $ ((IRANGE.EQ.VALRNG).AND.(D(1).GT.VL).AND.(D(1).LE.VU)).OR.
+ $ ((IRANGE.EQ.INDRNG).AND.(IL.EQ.1).AND.(IU.EQ.1)) ) THEN
+ M = 1
+ W(1) = D(1)
+* The computation error of the eigenvalue is zero
+ WERR(1) = ZERO
+ WGAP(1) = ZERO
+ IBLOCK( 1 ) = 1
+ INDEXW( 1 ) = 1
+ GERS(1) = D( 1 )
+ GERS(2) = D( 1 )
+ ENDIF
+* store the shift for the initial RRR, which is zero in this case
+ E(1) = ZERO
+ RETURN
+ END IF
+
+* General case: tridiagonal matrix of order > 1
+*
+* Init WERR, WGAP. Compute Gerschgorin intervals and spectral diameter.
+* Compute maximum off-diagonal entry and pivmin.
+ GL = D(1)
+ GU = D(1)
+ EOLD = ZERO
+ EMAX = ZERO
+ E(N) = ZERO
+ DO 5 I = 1,N
+ WERR(I) = ZERO
+ WGAP(I) = ZERO
+ EABS = ABS( E(I) )
+ IF( EABS .GE. EMAX ) THEN
+ EMAX = EABS
+ END IF
+ TMP1 = EABS + EOLD
+ GERS( 2*I-1) = D(I) - TMP1
+ GL = MIN( GL, GERS( 2*I - 1))
+ GERS( 2*I ) = D(I) + TMP1
+ GU = MAX( GU, GERS(2*I) )
+ EOLD = EABS
+ 5 CONTINUE
+* The minimum pivot allowed in the Sturm sequence for T
+ PIVMIN = SAFMIN * MAX( ONE, EMAX**2 )
+* Compute spectral diameter. The Gerschgorin bounds give an
+* estimate that is wrong by at most a factor of SQRT(2)
+ SPDIAM = GU - GL
+
+* Compute splitting points
+ CALL SLARRA( N, D, E, E2, SPLTOL, SPDIAM,
+ $ NSPLIT, ISPLIT, IINFO )
+
+* Can force use of bisection instead of faster DQDS.
+* Option left in the code for future multisection work.
+ FORCEB = .FALSE.
+
+ IF( (IRANGE.EQ.ALLRNG) .AND. (.NOT. FORCEB) ) THEN
+* Set interval [VL,VU] that contains all eigenvalues
+ VL = GL
+ VU = GU
+ ELSE
+* We call SLARRD to find crude approximations to the eigenvalues
+* in the desired range. In case IRANGE = INDRNG, we also obtain the
+* interval (VL,VU] that contains all the wanted eigenvalues.
+* An interval [LEFT,RIGHT] has converged if
+* RIGHT-LEFT.LT.RTOL*MAX(ABS(LEFT),ABS(RIGHT))
+* SLARRD needs a WORK of size 4*N, IWORK of size 3*N
+ CALL SLARRD( RANGE, 'B', N, VL, VU, IL, IU, GERS,
+ $ BSRTOL, D, E, E2, PIVMIN, NSPLIT, ISPLIT,
+ $ MM, W, WERR, VL, VU, IBLOCK, INDEXW,
+ $ WORK, IWORK, IINFO )
+ IF( IINFO.NE.0 ) THEN
+ INFO = -1
+ RETURN
+ ENDIF
+* Make sure that the entries M+1 to N in W, WERR, IBLOCK, INDEXW are 0
+ DO 14 I = MM+1,N
+ W( I ) = ZERO
+ WERR( I ) = ZERO
+ IBLOCK( I ) = 0
+ INDEXW( I ) = 0
+ 14 CONTINUE
+ END IF
+
+
+***
+* Loop over unreduced blocks
+ IBEGIN = 1
+ WBEGIN = 1
+ DO 170 JBLK = 1, NSPLIT
+ IEND = ISPLIT( JBLK )
+ IN = IEND - IBEGIN + 1
+
+* 1 X 1 block
+ IF( IN.EQ.1 ) THEN
+ IF( (IRANGE.EQ.ALLRNG).OR.( (IRANGE.EQ.VALRNG).AND.
+ $ ( D( IBEGIN ).GT.VL ).AND.( D( IBEGIN ).LE.VU ) )
+ $ .OR. ( (IRANGE.EQ.INDRNG).AND.(IBLOCK(WBEGIN).EQ.JBLK))
+ $ ) THEN
+ M = M + 1
+ W( M ) = D( IBEGIN )
+ WERR(M) = ZERO
+* The gap for a single block doesn't matter for the later
+* algorithm and is assigned an arbitrary large value
+ WGAP(M) = ZERO
+ IBLOCK( M ) = JBLK
+ INDEXW( M ) = 1
+ WBEGIN = WBEGIN + 1
+ ENDIF
+* E( IEND ) holds the shift for the initial RRR
+ E( IEND ) = ZERO
+ IBEGIN = IEND + 1
+ GO TO 170
+ END IF
+*
+* Blocks of size larger than 1x1
+*
+* E( IEND ) will hold the shift for the initial RRR, for now set it =0
+ E( IEND ) = ZERO
+*
+* Find local outer bounds GL,GU for the block
+ GL = D(IBEGIN)
+ GU = D(IBEGIN)
+ DO 15 I = IBEGIN , IEND
+ GL = MIN( GERS( 2*I-1 ), GL )
+ GU = MAX( GERS( 2*I ), GU )
+ 15 CONTINUE
+ SPDIAM = GU - GL
+
+ IF(.NOT. ((IRANGE.EQ.ALLRNG).AND.(.NOT.FORCEB)) ) THEN
+* Count the number of eigenvalues in the current block.
+ MB = 0
+ DO 20 I = WBEGIN,MM
+ IF( IBLOCK(I).EQ.JBLK ) THEN
+ MB = MB+1
+ ELSE
+ GOTO 21
+ ENDIF
+ 20 CONTINUE
+ 21 CONTINUE
+
+ IF( MB.EQ.0) THEN
+* No eigenvalue in the current block lies in the desired range
+* E( IEND ) holds the shift for the initial RRR
+ E( IEND ) = ZERO
+ IBEGIN = IEND + 1
+ GO TO 170
+ ELSE
+
+* Decide whether dqds or bisection is more efficient
+ USEDQD = ( (MB .GT. FAC*IN) .AND. (.NOT.FORCEB) )
+ WEND = WBEGIN + MB - 1
+* Calculate gaps for the current block
+* In later stages, when representations for individual
+* eigenvalues are different, we use SIGMA = E( IEND ).
+ SIGMA = ZERO
+ DO 30 I = WBEGIN, WEND - 1
+ WGAP( I ) = MAX( ZERO,
+ $ W(I+1)-WERR(I+1) - (W(I)+WERR(I)) )
+ 30 CONTINUE
+ WGAP( WEND ) = MAX( ZERO,
+ $ VU - SIGMA - (W( WEND )+WERR( WEND )))
+* Find local index of the first and last desired evalue.
+ INDL = INDEXW(WBEGIN)
+ INDU = INDEXW( WEND )
+ ENDIF
+ ENDIF
+ IF(( (IRANGE.EQ.ALLRNG) .AND. (.NOT. FORCEB) ).OR.USEDQD) THEN
+* Case of DQDS
+* Find approximations to the extremal eigenvalues of the block
+ CALL SLARRK( IN, 1, GL, GU, D(IBEGIN),
+ $ E2(IBEGIN), PIVMIN, RTL, TMP, TMP1, IINFO )
+ IF( IINFO.NE.0 ) THEN
+ INFO = -1
+ RETURN
+ ENDIF
+ ISLEFT = MAX(GL, TMP - TMP1
+ $ - HNDRD * EPS* ABS(TMP - TMP1))
+
+ CALL SLARRK( IN, IN, GL, GU, D(IBEGIN),
+ $ E2(IBEGIN), PIVMIN, RTL, TMP, TMP1, IINFO )
+ IF( IINFO.NE.0 ) THEN
+ INFO = -1
+ RETURN
+ ENDIF
+ ISRGHT = MIN(GU, TMP + TMP1
+ $ + HNDRD * EPS * ABS(TMP + TMP1))
+* Improve the estimate of the spectral diameter
+ SPDIAM = ISRGHT - ISLEFT
+ ELSE
+* Case of bisection
+* Find approximations to the wanted extremal eigenvalues
+ ISLEFT = MAX(GL, W(WBEGIN) - WERR(WBEGIN)
+ $ - HNDRD * EPS*ABS(W(WBEGIN)- WERR(WBEGIN) ))
+ ISRGHT = MIN(GU,W(WEND) + WERR(WEND)
+ $ + HNDRD * EPS * ABS(W(WEND)+ WERR(WEND)))
+ ENDIF
+
+
+* Decide whether the base representation for the current block
+* L_JBLK D_JBLK L_JBLK^T = T_JBLK - sigma_JBLK I
+* should be on the left or the right end of the current block.
+* The strategy is to shift to the end which is "more populated"
+* Furthermore, decide whether to use DQDS for the computation of
+* the eigenvalue approximations at the end of SLARRE or bisection.
+* dqds is chosen if all eigenvalues are desired or the number of
+* eigenvalues to be computed is large compared to the blocksize.
+ IF( ( IRANGE.EQ.ALLRNG ) .AND. (.NOT.FORCEB) ) THEN
+* If all the eigenvalues have to be computed, we use dqd
+ USEDQD = .TRUE.
+* INDL is the local index of the first eigenvalue to compute
+ INDL = 1
+ INDU = IN
+* MB = number of eigenvalues to compute
+ MB = IN
+ WEND = WBEGIN + MB - 1
+* Define 1/4 and 3/4 points of the spectrum
+ S1 = ISLEFT + FOURTH * SPDIAM
+ S2 = ISRGHT - FOURTH * SPDIAM
+ ELSE
+* SLARRD has computed IBLOCK and INDEXW for each eigenvalue
+* approximation.
+* choose sigma
+ IF( USEDQD ) THEN
+ S1 = ISLEFT + FOURTH * SPDIAM
+ S2 = ISRGHT - FOURTH * SPDIAM
+ ELSE
+ TMP = MIN(ISRGHT,VU) - MAX(ISLEFT,VL)
+ S1 = MAX(ISLEFT,VL) + FOURTH * TMP
+ S2 = MIN(ISRGHT,VU) - FOURTH * TMP
+ ENDIF
+ ENDIF
+
+* Compute the negcount at the 1/4 and 3/4 points
+ IF(MB.GT.1) THEN
+ CALL SLARRC( 'T', IN, S1, S2, D(IBEGIN),
+ $ E(IBEGIN), PIVMIN, CNT, CNT1, CNT2, IINFO)
+ ENDIF
+
+ IF(MB.EQ.1) THEN
+ SIGMA = GL
+ SGNDEF = ONE
+ ELSEIF( CNT1 - INDL .GE. INDU - CNT2 ) THEN
+ IF( ( IRANGE.EQ.ALLRNG ) .AND. (.NOT.FORCEB) ) THEN
+ SIGMA = MAX(ISLEFT,GL)
+ ELSEIF( USEDQD ) THEN
+* use Gerschgorin bound as shift to get pos def matrix
+* for dqds
+ SIGMA = ISLEFT
+ ELSE
+* use approximation of the first desired eigenvalue of the
+* block as shift
+ SIGMA = MAX(ISLEFT,VL)
+ ENDIF
+ SGNDEF = ONE
+ ELSE
+ IF( ( IRANGE.EQ.ALLRNG ) .AND. (.NOT.FORCEB) ) THEN
+ SIGMA = MIN(ISRGHT,GU)
+ ELSEIF( USEDQD ) THEN
+* use Gerschgorin bound as shift to get neg def matrix
+* for dqds
+ SIGMA = ISRGHT
+ ELSE
+* use approximation of the first desired eigenvalue of the
+* block as shift
+ SIGMA = MIN(ISRGHT,VU)
+ ENDIF
+ SGNDEF = -ONE
+ ENDIF
+
+
+* An initial SIGMA has been chosen that will be used for computing
+* T - SIGMA I = L D L^T
+* Define the increment TAU of the shift in case the initial shift
+* needs to be refined to obtain a factorization with not too much
+* element growth.
+ IF( USEDQD ) THEN
+* The initial SIGMA was to the outer end of the spectrum
+* the matrix is definite and we need not retreat.
+ TAU = SPDIAM*EPS*N + TWO*PIVMIN
+ ELSE
+ IF(MB.GT.1) THEN
+ CLWDTH = W(WEND) + WERR(WEND) - W(WBEGIN) - WERR(WBEGIN)
+ AVGAP = ABS(CLWDTH / REAL(WEND-WBEGIN))
+ IF( SGNDEF.EQ.ONE ) THEN
+ TAU = HALF*MAX(WGAP(WBEGIN),AVGAP)
+ TAU = MAX(TAU,WERR(WBEGIN))
+ ELSE
+ TAU = HALF*MAX(WGAP(WEND-1),AVGAP)
+ TAU = MAX(TAU,WERR(WEND))
+ ENDIF
+ ELSE
+ TAU = WERR(WBEGIN)
+ ENDIF
+ ENDIF
+*
+ DO 80 IDUM = 1, MAXTRY
+* Compute L D L^T factorization of tridiagonal matrix T - sigma I.
+* Store D in WORK(1:IN), L in WORK(IN+1:2*IN), and reciprocals of
+* pivots in WORK(2*IN+1:3*IN)
+ DPIVOT = D( IBEGIN ) - SIGMA
+ WORK( 1 ) = DPIVOT
+ DMAX = ABS( WORK(1) )
+ J = IBEGIN
+ DO 70 I = 1, IN - 1
+ WORK( 2*IN+I ) = ONE / WORK( I )
+ TMP = E( J )*WORK( 2*IN+I )
+ WORK( IN+I ) = TMP
+ DPIVOT = ( D( J+1 )-SIGMA ) - TMP*E( J )
+ WORK( I+1 ) = DPIVOT
+ DMAX = MAX( DMAX, ABS(DPIVOT) )
+ J = J + 1
+ 70 CONTINUE
+* check for element growth
+ IF( DMAX .GT. MAXGROWTH*SPDIAM ) THEN
+ NOREP = .TRUE.
+ ELSE
+ NOREP = .FALSE.
+ ENDIF
+ IF( USEDQD .AND. .NOT.NOREP ) THEN
+* Ensure the definiteness of the representation
+* All entries of D (of L D L^T) must have the same sign
+ DO 71 I = 1, IN
+ TMP = SGNDEF*WORK( I )
+ IF( TMP.LT.ZERO ) NOREP = .TRUE.
+ 71 CONTINUE
+ ENDIF
+ IF(NOREP) THEN
+* Note that in the case of IRANGE=ALLRNG, we use the Gerschgorin
+* shift which makes the matrix definite. So we should end up
+* here really only in the case of IRANGE = VALRNG or INDRNG.
+ IF( IDUM.EQ.MAXTRY-1 ) THEN
+ IF( SGNDEF.EQ.ONE ) THEN
+* The fudged Gerschgorin shift should succeed
+ SIGMA =
+ $ GL - FUDGE*SPDIAM*EPS*N - FUDGE*TWO*PIVMIN
+ ELSE
+ SIGMA =
+ $ GU + FUDGE*SPDIAM*EPS*N + FUDGE*TWO*PIVMIN
+ END IF
+ ELSE
+ SIGMA = SIGMA - SGNDEF * TAU
+ TAU = TWO * TAU
+ END IF
+ ELSE
+* an initial RRR is found
+ GO TO 83
+ END IF
+ 80 CONTINUE
+* if the program reaches this point, no base representation could be
+* found in MAXTRY iterations.
+ INFO = 2
+ RETURN
+
+ 83 CONTINUE
+* At this point, we have found an initial base representation
+* T - SIGMA I = L D L^T with not too much element growth.
+* Store the shift.
+ E( IEND ) = SIGMA
+* Store D and L.
+ CALL SCOPY( IN, WORK, 1, D( IBEGIN ), 1 )
+ CALL SCOPY( IN-1, WORK( IN+1 ), 1, E( IBEGIN ), 1 )
+
+
+ IF(MB.GT.1 ) THEN
+*
+* Perturb each entry of the base representation by a small
+* (but random) relative amount to overcome difficulties with
+* glued matrices.
+*
+ DO 122 I = 1, 4
+ ISEED( I ) = 1
+ 122 CONTINUE
+
+ CALL SLARNV(2, ISEED, 2*IN-1, WORK(1))
+ DO 125 I = 1,IN-1
+ D(IBEGIN+I-1) = D(IBEGIN+I-1)*(ONE+EPS*PERT*WORK(I))
+ E(IBEGIN+I-1) = E(IBEGIN+I-1)*(ONE+EPS*PERT*WORK(IN+I))
+ 125 CONTINUE
+ D(IEND) = D(IEND)*(ONE+EPS*FOUR*WORK(IN))
+*
+ ENDIF
+*
+* Don't update the Gerschgorin intervals because keeping track
+* of the updates would be too much work in SLARRV.
+* We update W instead and use it to locate the proper Gerschgorin
+* intervals.
+
+* Compute the required eigenvalues of L D L' by bisection or dqds
+ IF ( .NOT.USEDQD ) THEN
+* If SLARRD has been used, shift the eigenvalue approximations
+* according to their representation. This is necessary for
+* a uniform SLARRV since dqds computes eigenvalues of the
+* shifted representation. In SLARRV, W will always hold the
+* UNshifted eigenvalue approximation.
+ DO 134 J=WBEGIN,WEND
+ W(J) = W(J) - SIGMA
+ WERR(J) = WERR(J) + ABS(W(J)) * EPS
+ 134 CONTINUE
+* call SLARRB to reduce eigenvalue error of the approximations
+* from SLARRD
+ DO 135 I = IBEGIN, IEND-1
+ WORK( I ) = D( I ) * E( I )**2
+ 135 CONTINUE
+* use bisection to find EV from INDL to INDU
+ CALL SLARRB(IN, D(IBEGIN), WORK(IBEGIN),
+ $ INDL, INDU, RTOL1, RTOL2, INDL-1,
+ $ W(WBEGIN), WGAP(WBEGIN), WERR(WBEGIN),
+ $ WORK( 2*N+1 ), IWORK, PIVMIN, SPDIAM,
+ $ IN, IINFO )
+ IF( IINFO .NE. 0 ) THEN
+ INFO = -4
+ RETURN
+ END IF
+* SLARRB computes all gaps correctly except for the last one
+* Record distance to VU/GU
+ WGAP( WEND ) = MAX( ZERO,
+ $ ( VU-SIGMA ) - ( W( WEND ) + WERR( WEND ) ) )
+ DO 138 I = INDL, INDU
+ M = M + 1
+ IBLOCK(M) = JBLK
+ INDEXW(M) = I
+ 138 CONTINUE
+ ELSE
+* Call dqds to get all eigs (and then possibly delete unwanted
+* eigenvalues).
+* Note that dqds finds the eigenvalues of the L D L^T representation
+* of T to high relative accuracy. High relative accuracy
+* might be lost when the shift of the RRR is subtracted to obtain
+* the eigenvalues of T. However, T is not guaranteed to define its
+* eigenvalues to high relative accuracy anyway.
+* Set RTOL to the order of the tolerance used in SLASQ2
+* This is an ESTIMATED error, the worst case bound is 4*N*EPS
+* which is usually too large and requires unnecessary work to be
+* done by bisection when computing the eigenvectors
+ RTOL = LOG(REAL(IN)) * FOUR * EPS
+ J = IBEGIN
+ DO 140 I = 1, IN - 1
+ WORK( 2*I-1 ) = ABS( D( J ) )
+ WORK( 2*I ) = E( J )*E( J )*WORK( 2*I-1 )
+ J = J + 1
+ 140 CONTINUE
+ WORK( 2*IN-1 ) = ABS( D( IEND ) )
+ WORK( 2*IN ) = ZERO
+ CALL SLASQ2( IN, WORK, IINFO )
+ IF( IINFO .NE. 0 ) THEN
+* If IINFO = -5 then an index is part of a tight cluster
+* and should be changed. The index is in IWORK(1) and the
+* gap is in WORK(N+1)
+ INFO = -5
+ RETURN
+ ELSE
+* Test that all eigenvalues are positive as expected
+ DO 149 I = 1, IN
+ IF( WORK( I ).LT.ZERO ) THEN
+ INFO = -6
+ RETURN
+ ENDIF
+ 149 CONTINUE
+ END IF
+ IF( SGNDEF.GT.ZERO ) THEN
+ DO 150 I = INDL, INDU
+ M = M + 1
+ W( M ) = WORK( IN-I+1 )
+ IBLOCK( M ) = JBLK
+ INDEXW( M ) = I
+ 150 CONTINUE
+ ELSE
+ DO 160 I = INDL, INDU
+ M = M + 1
+ W( M ) = -WORK( I )
+ IBLOCK( M ) = JBLK
+ INDEXW( M ) = I
+ 160 CONTINUE
+ END IF
+
+ DO 165 I = M - MB + 1, M
+* the value of RTOL below should be the tolerance in SLASQ2
+ WERR( I ) = RTOL * ABS( W(I) )
+ 165 CONTINUE
+ DO 166 I = M - MB + 1, M - 1
+* compute the right gap between the intervals
+ WGAP( I ) = MAX( ZERO,
+ $ W(I+1)-WERR(I+1) - (W(I)+WERR(I)) )
+ 166 CONTINUE
+ WGAP( M ) = MAX( ZERO,
+ $ ( VU-SIGMA ) - ( W( M ) + WERR( M ) ) )
+ END IF
+* proceed with next block
+ IBEGIN = IEND + 1
+ WBEGIN = WEND + 1
+ 170 CONTINUE
+*
+
+ RETURN
+*
+* end of SLARRE
+*
+ END
+ SUBROUTINE SLARRF( N, D, L, LD, CLSTRT, CLEND,
+ $ W, WGAP, WERR,
+ $ SPDIAM, CLGAPL, CLGAPR, PIVMIN, SIGMA,
+ $ DPLUS, LPLUS, WORK, INFO )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+**
+* .. Scalar Arguments ..
+ INTEGER CLSTRT, CLEND, INFO, N
+ REAL CLGAPL, CLGAPR, PIVMIN, SIGMA, SPDIAM
+* ..
+* .. Array Arguments ..
+ REAL D( * ), DPLUS( * ), L( * ), LD( * ),
+ $ LPLUS( * ), W( * ), WGAP( * ), WERR( * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* Given the initial representation L D L^T and its cluster of close
+* eigenvalues (in a relative measure), W( CLSTRT ), W( CLSTRT+1 ), ...
+* W( CLEND ), SLARRF finds a new relatively robust representation
+* L D L^T - SIGMA I = L(+) D(+) L(+)^T such that at least one of the
+* eigenvalues of L(+) D(+) L(+)^T is relatively isolated.
+*
+* Arguments
+* =========
+*
+* N (input) INTEGER
+* The order of the matrix (subblock, if the matrix splitted).
+*
+* D (input) REAL array, dimension (N)
+* The N diagonal elements of the diagonal matrix D.
+*
+* L (input) REAL array, dimension (N-1)
+* The (N-1) subdiagonal elements of the unit bidiagonal
+* matrix L.
+*
+* LD (input) REAL array, dimension (N-1)
+* The (N-1) elements L(i)*D(i).
+*
+* CLSTRT (input) INTEGER
+* The index of the first eigenvalue in the cluster.
+*
+* CLEND (input) INTEGER
+* The index of the last eigenvalue in the cluster.
+*
+* W (input) REAL array, dimension >= (CLEND-CLSTRT+1)
+* The eigenvalue APPROXIMATIONS of L D L^T in ascending order.
+* W( CLSTRT ) through W( CLEND ) form the cluster of relatively
+* close eigenalues.
+*
+* WGAP (input/output) REAL array, dimension >= (CLEND-CLSTRT+1)
+* The separation from the right neighbor eigenvalue in W.
+*
+* WERR (input) REAL array, dimension >= (CLEND-CLSTRT+1)
+* WERR contain the semiwidth of the uncertainty
+* interval of the corresponding eigenvalue APPROXIMATION in W
+*
+* SPDIAM (input) estimate of the spectral diameter obtained from the
+* Gerschgorin intervals
+*
+* CLGAPL, CLGAPR (input) absolute gap on each end of the cluster.
+* Set by the calling routine to protect against shifts too close
+* to eigenvalues outside the cluster.
+*
+* PIVMIN (input) DOUBLE PRECISION
+* The minimum pivot allowed in the Sturm sequence.
+*
+* SIGMA (output) REAL
+* The shift used to form L(+) D(+) L(+)^T.
+*
+* DPLUS (output) REAL array, dimension (N)
+* The N diagonal elements of the diagonal matrix D(+).
+*
+* LPLUS (output) REAL array, dimension (N-1)
+* The first (N-1) elements of LPLUS contain the subdiagonal
+* elements of the unit bidiagonal matrix L(+).
+*
+* WORK (workspace) REAL array, dimension (2*N)
+* Workspace.
+*
+* Further Details
+* ===============
+*
+* Based on contributions by
+* Beresford Parlett, University of California, Berkeley, USA
+* Jim Demmel, University of California, Berkeley, USA
+* Inderjit Dhillon, University of Texas, Austin, USA
+* Osni Marques, LBNL/NERSC, USA
+* Christof Voemel, University of California, Berkeley, USA
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL FOUR, MAXGROWTH1, MAXGROWTH2, ONE, QUART, TWO,
+ $ ZERO
+ PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0, TWO = 2.0E0,
+ $ FOUR = 4.0E0, QUART = 0.25E0,
+ $ MAXGROWTH1 = 8.E0,
+ $ MAXGROWTH2 = 8.E0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL DORRR1, FORCER, NOFAIL, SAWNAN1, SAWNAN2, TRYRRR1
+ INTEGER I, INDX, KTRY, KTRYMAX, SLEFT, SRIGHT, SHIFT
+ PARAMETER ( KTRYMAX = 1, SLEFT = 1, SRIGHT = 2 )
+ REAL AVGAP, BESTSHIFT, CLWDTH, EPS, FACT, FAIL,
+ $ FAIL2, GROWTHBOUND, LDELTA, LDMAX, LSIGMA,
+ $ MAX1, MAX2, MINGAP, OLDP, PROD, RDELTA, RDMAX,
+ $ RRR1, RRR2, RSIGMA, S, SMLGROWTH, TMP, ZNM2
+* ..
+* .. External Functions ..
+ LOGICAL SISNAN
+ REAL SLAMCH
+ EXTERNAL SISNAN, SLAMCH
+* ..
+* .. External Subroutines ..
+ EXTERNAL SCOPY
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS
+* ..
+* .. Executable Statements ..
+*
+ INFO = 0
+ FACT = REAL(2**KTRYMAX)
+ EPS = SLAMCH( 'Precision' )
+ SHIFT = 0
+ FORCER = .FALSE.
+
+
+* Note that we cannot guarantee that for any of the shifts tried,
+* the factorization has a small or even moderate element growth.
+* There could be Ritz values at both ends of the cluster and despite
+* backing off, there are examples where all factorizations tried
+* (in IEEE mode, allowing zero pivots & infinities) have INFINITE
+* element growth.
+* For this reason, we should use PIVMIN in this subroutine so that at
+* least the L D L^T factorization exists. It can be checked afterwards
+* whether the element growth caused bad residuals/orthogonality.
+
+* Decide whether the code should accept the best among all
+* representations despite large element growth or signal INFO=1
+ NOFAIL = .TRUE.
+*
+
+* Compute the average gap length of the cluster
+ CLWDTH = ABS(W(CLEND)-W(CLSTRT)) + WERR(CLEND) + WERR(CLSTRT)
+ AVGAP = CLWDTH / REAL(CLEND-CLSTRT)
+ MINGAP = MIN(CLGAPL, CLGAPR)
+* Initial values for shifts to both ends of cluster
+ LSIGMA = MIN(W( CLSTRT ),W( CLEND )) - WERR( CLSTRT )
+ RSIGMA = MAX(W( CLSTRT ),W( CLEND )) + WERR( CLEND )
+
+* Use a small fudge to make sure that we really shift to the outside
+ LSIGMA = LSIGMA - ABS(LSIGMA)* TWO * EPS
+ RSIGMA = RSIGMA + ABS(RSIGMA)* TWO * EPS
+
+* Compute upper bounds for how much to back off the initial shifts
+ LDMAX = QUART * MINGAP + TWO * PIVMIN
+ RDMAX = QUART * MINGAP + TWO * PIVMIN
+
+ LDELTA = MAX(AVGAP,WGAP( CLSTRT ))/FACT
+ RDELTA = MAX(AVGAP,WGAP( CLEND-1 ))/FACT
+*
+* Initialize the record of the best representation found
+*
+ S = SLAMCH( 'S' )
+ SMLGROWTH = ONE / S
+ FAIL = REAL(N-1)*MINGAP/(SPDIAM*EPS)
+ FAIL2 = REAL(N-1)*MINGAP/(SPDIAM*SQRT(EPS))
+ BESTSHIFT = LSIGMA
+*
+* while (KTRY <= KTRYMAX)
+ KTRY = 0
+ GROWTHBOUND = MAXGROWTH1*SPDIAM
+
+ 5 CONTINUE
+ SAWNAN1 = .FALSE.
+ SAWNAN2 = .FALSE.
+* Ensure that we do not back off too much of the initial shifts
+ LDELTA = MIN(LDMAX,LDELTA)
+ RDELTA = MIN(RDMAX,RDELTA)
+
+* Compute the element growth when shifting to both ends of the cluster
+* accept the shift if there is no element growth at one of the two ends
+
+* Left end
+ S = -LSIGMA
+ DPLUS( 1 ) = D( 1 ) + S
+ IF(ABS(DPLUS(1)).LT.PIVMIN) THEN
+ DPLUS(1) = -PIVMIN
+* Need to set SAWNAN1 because refined RRR test should not be used
+* in this case
+ SAWNAN1 = .TRUE.
+ ENDIF
+ MAX1 = ABS( DPLUS( 1 ) )
+ DO 6 I = 1, N - 1
+ LPLUS( I ) = LD( I ) / DPLUS( I )
+ S = S*LPLUS( I )*L( I ) - LSIGMA
+ DPLUS( I+1 ) = D( I+1 ) + S
+ IF(ABS(DPLUS(I+1)).LT.PIVMIN) THEN
+ DPLUS(I+1) = -PIVMIN
+* Need to set SAWNAN1 because refined RRR test should not be used
+* in this case
+ SAWNAN1 = .TRUE.
+ ENDIF
+ MAX1 = MAX( MAX1,ABS(DPLUS(I+1)) )
+ 6 CONTINUE
+ SAWNAN1 = SAWNAN1 .OR. SISNAN( MAX1 )
+
+ IF( FORCER .OR.
+ $ (MAX1.LE.GROWTHBOUND .AND. .NOT.SAWNAN1 ) ) THEN
+ SIGMA = LSIGMA
+ SHIFT = SLEFT
+ GOTO 100
+ ENDIF
+
+* Right end
+ S = -RSIGMA
+ WORK( 1 ) = D( 1 ) + S
+ IF(ABS(WORK(1)).LT.PIVMIN) THEN
+ WORK(1) = -PIVMIN
+* Need to set SAWNAN2 because refined RRR test should not be used
+* in this case
+ SAWNAN2 = .TRUE.
+ ENDIF
+ MAX2 = ABS( WORK( 1 ) )
+ DO 7 I = 1, N - 1
+ WORK( N+I ) = LD( I ) / WORK( I )
+ S = S*WORK( N+I )*L( I ) - RSIGMA
+ WORK( I+1 ) = D( I+1 ) + S
+ IF(ABS(WORK(I+1)).LT.PIVMIN) THEN
+ WORK(I+1) = -PIVMIN
+* Need to set SAWNAN2 because refined RRR test should not be used
+* in this case
+ SAWNAN2 = .TRUE.
+ ENDIF
+ MAX2 = MAX( MAX2,ABS(WORK(I+1)) )
+ 7 CONTINUE
+ SAWNAN2 = SAWNAN2 .OR. SISNAN( MAX2 )
+
+ IF( FORCER .OR.
+ $ (MAX2.LE.GROWTHBOUND .AND. .NOT.SAWNAN2 ) ) THEN
+ SIGMA = RSIGMA
+ SHIFT = SRIGHT
+ GOTO 100
+ ENDIF
+* If we are at this point, both shifts led to too much element growth
+
+* Record the better of the two shifts (provided it didn't lead to NaN)
+ IF(SAWNAN1.AND.SAWNAN2) THEN
+* both MAX1 and MAX2 are NaN
+ GOTO 50
+ ELSE
+ IF( .NOT.SAWNAN1 ) THEN
+ INDX = 1
+ IF(MAX1.LE.SMLGROWTH) THEN
+ SMLGROWTH = MAX1
+ BESTSHIFT = LSIGMA
+ ENDIF
+ ENDIF
+ IF( .NOT.SAWNAN2 ) THEN
+ IF(SAWNAN1 .OR. MAX2.LE.MAX1) INDX = 2
+ IF(MAX2.LE.SMLGROWTH) THEN
+ SMLGROWTH = MAX2
+ BESTSHIFT = RSIGMA
+ ENDIF
+ ENDIF
+ ENDIF
+
+* If we are here, both the left and the right shift led to
+* element growth. If the element growth is moderate, then
+* we may still accept the representation, if it passes a
+* refined test for RRR. This test supposes that no NaN occurred.
+* Moreover, we use the refined RRR test only for isolated clusters.
+ IF((CLWDTH.LT.MINGAP/REAL(128)) .AND.
+ $ (MIN(MAX1,MAX2).LT.FAIL2)
+ $ .AND.(.NOT.SAWNAN1).AND.(.NOT.SAWNAN2)) THEN
+ DORRR1 = .TRUE.
+ ELSE
+ DORRR1 = .FALSE.
+ ENDIF
+ TRYRRR1 = .TRUE.
+ IF( TRYRRR1 .AND. DORRR1 ) THEN
+ IF(INDX.EQ.1) THEN
+ TMP = ABS( DPLUS( N ) )
+ ZNM2 = ONE
+ PROD = ONE
+ OLDP = ONE
+ DO 15 I = N-1, 1, -1
+ IF( PROD .LE. EPS ) THEN
+ PROD =
+ $ ((DPLUS(I+1)*WORK(N+I+1))/(DPLUS(I)*WORK(N+I)))*OLDP
+ ELSE
+ PROD = PROD*ABS(WORK(N+I))
+ END IF
+ OLDP = PROD
+ ZNM2 = ZNM2 + PROD**2
+ TMP = MAX( TMP, ABS( DPLUS( I ) * PROD ))
+ 15 CONTINUE
+ RRR1 = TMP/( SPDIAM * SQRT( ZNM2 ) )
+ IF (RRR1.LE.MAXGROWTH2) THEN
+ SIGMA = LSIGMA
+ SHIFT = SLEFT
+ GOTO 100
+ ENDIF
+ ELSE IF(INDX.EQ.2) THEN
+ TMP = ABS( WORK( N ) )
+ ZNM2 = ONE
+ PROD = ONE
+ OLDP = ONE
+ DO 16 I = N-1, 1, -1
+ IF( PROD .LE. EPS ) THEN
+ PROD = ((WORK(I+1)*LPLUS(I+1))/(WORK(I)*LPLUS(I)))*OLDP
+ ELSE
+ PROD = PROD*ABS(LPLUS(I))
+ END IF
+ OLDP = PROD
+ ZNM2 = ZNM2 + PROD**2
+ TMP = MAX( TMP, ABS( WORK( I ) * PROD ))
+ 16 CONTINUE
+ RRR2 = TMP/( SPDIAM * SQRT( ZNM2 ) )
+ IF (RRR2.LE.MAXGROWTH2) THEN
+ SIGMA = RSIGMA
+ SHIFT = SRIGHT
+ GOTO 100
+ ENDIF
+ END IF
+ ENDIF
+
+ 50 CONTINUE
+
+ IF (KTRY.LT.KTRYMAX) THEN
+* If we are here, both shifts failed also the RRR test.
+* Back off to the outside
+ LSIGMA = MAX( LSIGMA - LDELTA,
+ $ LSIGMA - LDMAX)
+ RSIGMA = MIN( RSIGMA + RDELTA,
+ $ RSIGMA + RDMAX )
+ LDELTA = TWO * LDELTA
+ RDELTA = TWO * RDELTA
+ KTRY = KTRY + 1
+ GOTO 5
+ ELSE
+* None of the representations investigated satisfied our
+* criteria. Take the best one we found.
+ IF((SMLGROWTH.LT.FAIL).OR.NOFAIL) THEN
+ LSIGMA = BESTSHIFT
+ RSIGMA = BESTSHIFT
+ FORCER = .TRUE.
+ GOTO 5
+ ELSE
+ INFO = 1
+ RETURN
+ ENDIF
+ END IF
+
+ 100 CONTINUE
+ IF (SHIFT.EQ.SLEFT) THEN
+ ELSEIF (SHIFT.EQ.SRIGHT) THEN
+* store new L and D back into DPLUS, LPLUS
+ CALL SCOPY( N, WORK, 1, DPLUS, 1 )
+ CALL SCOPY( N-1, WORK(N+1), 1, LPLUS, 1 )
+ ENDIF
+
+ RETURN
+*
+* End of SLARRF
+*
+ END
+ SUBROUTINE SLARRJ( N, D, E2, IFIRST, ILAST,
+ $ RTOL, OFFSET, W, WERR, WORK, IWORK,
+ $ PIVMIN, SPDIAM, INFO )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER IFIRST, ILAST, INFO, N, OFFSET
+ REAL PIVMIN, RTOL, SPDIAM
+* ..
+* .. Array Arguments ..
+ INTEGER IWORK( * )
+ REAL D( * ), E2( * ), W( * ),
+ $ WERR( * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* Given the initial eigenvalue approximations of T, SLARRJ
+* does bisection to refine the eigenvalues of T,
+* W( IFIRST-OFFSET ) through W( ILAST-OFFSET ), to more accuracy. Initial
+* guesses for these eigenvalues are input in W, the corresponding estimate
+* of the error in these guesses in WERR. During bisection, intervals
+* [left, right] are maintained by storing their mid-points and
+* semi-widths in the arrays W and WERR respectively.
+*
+* Arguments
+* =========
+*
+* N (input) INTEGER
+* The order of the matrix.
+*
+* D (input) REAL array, dimension (N)
+* The N diagonal elements of T.
+*
+* E2 (input) REAL array, dimension (N-1)
+* The Squares of the (N-1) subdiagonal elements of T.
+*
+* IFIRST (input) INTEGER
+* The index of the first eigenvalue to be computed.
+*
+* ILAST (input) INTEGER
+* The index of the last eigenvalue to be computed.
+*
+* RTOL (input) REAL
+* Tolerance for the convergence of the bisection intervals.
+* An interval [LEFT,RIGHT] has converged if
+* RIGHT-LEFT.LT.RTOL*MAX(|LEFT|,|RIGHT|).
+*
+* OFFSET (input) INTEGER
+* Offset for the arrays W and WERR, i.e., the IFIRST-OFFSET
+* through ILAST-OFFSET elements of these arrays are to be used.
+*
+* W (input/output) REAL array, dimension (N)
+* On input, W( IFIRST-OFFSET ) through W( ILAST-OFFSET ) are
+* estimates of the eigenvalues of L D L^T indexed IFIRST through
+* ILAST.
+* On output, these estimates are refined.
+*
+* WERR (input/output) REAL array, dimension (N)
+* On input, WERR( IFIRST-OFFSET ) through WERR( ILAST-OFFSET ) are
+* the errors in the estimates of the corresponding elements in W.
+* On output, these errors are refined.
+*
+* WORK (workspace) REAL array, dimension (2*N)
+* Workspace.
+*
+* IWORK (workspace) INTEGER array, dimension (2*N)
+* Workspace.
+*
+* PIVMIN (input) DOUBLE PRECISION
+* The minimum pivot in the Sturm sequence for T.
+*
+* SPDIAM (input) DOUBLE PRECISION
+* The spectral diameter of T.
+*
+* INFO (output) INTEGER
+* Error flag.
+*
+* Further Details
+* ===============
+*
+* Based on contributions by
+* Beresford Parlett, University of California, Berkeley, USA
+* Jim Demmel, University of California, Berkeley, USA
+* Inderjit Dhillon, University of Texas, Austin, USA
+* Osni Marques, LBNL/NERSC, USA
+* Christof Voemel, University of California, Berkeley, USA
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO, ONE, TWO, HALF
+ PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0, TWO = 2.0E0,
+ $ HALF = 0.5E0 )
+ INTEGER MAXITR
+* ..
+* .. Local Scalars ..
+ INTEGER CNT, I, I1, I2, II, ITER, J, K, NEXT, NINT,
+ $ OLNINT, P, PREV, SAVI1
+ REAL DPLUS, FAC, LEFT, MID, RIGHT, S, TMP, WIDTH
+*
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX
+* ..
+* .. Executable Statements ..
+*
+ INFO = 0
+*
+ MAXITR = INT( ( LOG( SPDIAM+PIVMIN )-LOG( PIVMIN ) ) /
+ $ LOG( TWO ) ) + 2
+*
+* Initialize unconverged intervals in [ WORK(2*I-1), WORK(2*I) ].
+* The Sturm Count, Count( WORK(2*I-1) ) is arranged to be I-1, while
+* Count( WORK(2*I) ) is stored in IWORK( 2*I ). The integer IWORK( 2*I-1 )
+* for an unconverged interval is set to the index of the next unconverged
+* interval, and is -1 or 0 for a converged interval. Thus a linked
+* list of unconverged intervals is set up.
+*
+
+ I1 = IFIRST
+ I2 = ILAST
+* The number of unconverged intervals
+ NINT = 0
+* The last unconverged interval found
+ PREV = 0
+ DO 75 I = I1, I2
+ K = 2*I
+ II = I - OFFSET
+ LEFT = W( II ) - WERR( II )
+ MID = W(II)
+ RIGHT = W( II ) + WERR( II )
+ WIDTH = RIGHT - MID
+ TMP = MAX( ABS( LEFT ), ABS( RIGHT ) )
+
+* The following test prevents the test of converged intervals
+ IF( WIDTH.LT.RTOL*TMP ) THEN
+* This interval has already converged and does not need refinement.
+* (Note that the gaps might change through refining the
+* eigenvalues, however, they can only get bigger.)
+* Remove it from the list.
+ IWORK( K-1 ) = -1
+* Make sure that I1 always points to the first unconverged interval
+ IF((I.EQ.I1).AND.(I.LT.I2)) I1 = I + 1
+ IF((PREV.GE.I1).AND.(I.LE.I2)) IWORK( 2*PREV-1 ) = I + 1
+ ELSE
+* unconverged interval found
+ PREV = I
+* Make sure that [LEFT,RIGHT] contains the desired eigenvalue
+*
+* Do while( CNT(LEFT).GT.I-1 )
+*
+ FAC = ONE
+ 20 CONTINUE
+ CNT = 0
+ S = LEFT
+ DPLUS = D( 1 ) - S
+ IF( DPLUS.LT.ZERO ) CNT = CNT + 1
+ DO 30 J = 2, N
+ DPLUS = D( J ) - S - E2( J-1 )/DPLUS
+ IF( DPLUS.LT.ZERO ) CNT = CNT + 1
+ 30 CONTINUE
+ IF( CNT.GT.I-1 ) THEN
+ LEFT = LEFT - WERR( II )*FAC
+ FAC = TWO*FAC
+ GO TO 20
+ END IF
+*
+* Do while( CNT(RIGHT).LT.I )
+*
+ FAC = ONE
+ 50 CONTINUE
+ CNT = 0
+ S = RIGHT
+ DPLUS = D( 1 ) - S
+ IF( DPLUS.LT.ZERO ) CNT = CNT + 1
+ DO 60 J = 2, N
+ DPLUS = D( J ) - S - E2( J-1 )/DPLUS
+ IF( DPLUS.LT.ZERO ) CNT = CNT + 1
+ 60 CONTINUE
+ IF( CNT.LT.I ) THEN
+ RIGHT = RIGHT + WERR( II )*FAC
+ FAC = TWO*FAC
+ GO TO 50
+ END IF
+ NINT = NINT + 1
+ IWORK( K-1 ) = I + 1
+ IWORK( K ) = CNT
+ END IF
+ WORK( K-1 ) = LEFT
+ WORK( K ) = RIGHT
+ 75 CONTINUE
+
+
+ SAVI1 = I1
+*
+* Do while( NINT.GT.0 ), i.e. there are still unconverged intervals
+* and while (ITER.LT.MAXITR)
+*
+ ITER = 0
+ 80 CONTINUE
+ PREV = I1 - 1
+ I = I1
+ OLNINT = NINT
+
+ DO 100 P = 1, OLNINT
+ K = 2*I
+ II = I - OFFSET
+ NEXT = IWORK( K-1 )
+ LEFT = WORK( K-1 )
+ RIGHT = WORK( K )
+ MID = HALF*( LEFT + RIGHT )
+
+* semiwidth of interval
+ WIDTH = RIGHT - MID
+ TMP = MAX( ABS( LEFT ), ABS( RIGHT ) )
+
+ IF( ( WIDTH.LT.RTOL*TMP ) .OR.
+ $ (ITER.EQ.MAXITR) )THEN
+* reduce number of unconverged intervals
+ NINT = NINT - 1
+* Mark interval as converged.
+ IWORK( K-1 ) = 0
+ IF( I1.EQ.I ) THEN
+ I1 = NEXT
+ ELSE
+* Prev holds the last unconverged interval previously examined
+ IF(PREV.GE.I1) IWORK( 2*PREV-1 ) = NEXT
+ END IF
+ I = NEXT
+ GO TO 100
+ END IF
+ PREV = I
+*
+* Perform one bisection step
+*
+ CNT = 0
+ S = MID
+ DPLUS = D( 1 ) - S
+ IF( DPLUS.LT.ZERO ) CNT = CNT + 1
+ DO 90 J = 2, N
+ DPLUS = D( J ) - S - E2( J-1 )/DPLUS
+ IF( DPLUS.LT.ZERO ) CNT = CNT + 1
+ 90 CONTINUE
+ IF( CNT.LE.I-1 ) THEN
+ WORK( K-1 ) = MID
+ ELSE
+ WORK( K ) = MID
+ END IF
+ I = NEXT
+
+ 100 CONTINUE
+ ITER = ITER + 1
+* do another loop if there are still unconverged intervals
+* However, in the last iteration, all intervals are accepted
+* since this is the best we can do.
+ IF( ( NINT.GT.0 ).AND.(ITER.LE.MAXITR) ) GO TO 80
+*
+*
+* At this point, all the intervals have converged
+ DO 110 I = SAVI1, ILAST
+ K = 2*I
+ II = I - OFFSET
+* All intervals marked by '0' have been refined.
+ IF( IWORK( K-1 ).EQ.0 ) THEN
+ W( II ) = HALF*( WORK( K-1 )+WORK( K ) )
+ WERR( II ) = WORK( K ) - W( II )
+ END IF
+ 110 CONTINUE
+*
+
+ RETURN
+*
+* End of SLARRJ
+*
+ END
+ SUBROUTINE SLARRK( N, IW, GL, GU,
+ $ D, E2, PIVMIN, RELTOL, W, WERR, INFO)
+ IMPLICIT NONE
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, IW, N
+ REAL PIVMIN, RELTOL, GL, GU, W, WERR
+* ..
+* .. Array Arguments ..
+ REAL D( * ), E2( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SLARRK computes one eigenvalue of a symmetric tridiagonal
+* matrix T to suitable accuracy. This is an auxiliary code to be
+* called from SSTEMR.
+*
+* To avoid overflow, the matrix must be scaled so that its
+* largest element is no greater than overflow**(1/2) *
+* underflow**(1/4) in absolute value, and for greatest
+* accuracy, it should not be much smaller than that.
+*
+* See W. Kahan "Accurate Eigenvalues of a Symmetric Tridiagonal
+* Matrix", Report CS41, Computer Science Dept., Stanford
+* University, July 21, 1966.
+*
+* Arguments
+* =========
+*
+* N (input) INTEGER
+* The order of the tridiagonal matrix T. N >= 0.
+*
+* IW (input) INTEGER
+* The index of the eigenvalues to be returned.
+*
+* GL (input) REAL
+* GU (input) REAL
+* An upper and a lower bound on the eigenvalue.
+*
+* D (input) REAL array, dimension (N)
+* The n diagonal elements of the tridiagonal matrix T.
+*
+* E2 (input) REAL array, dimension (N-1)
+* The (n-1) squared off-diagonal elements of the tridiagonal matrix T.
+*
+* PIVMIN (input) REAL
+* The minimum pivot allowed in the Sturm sequence for T.
+*
+* RELTOL (input) REAL
+* The minimum relative width of an interval. When an interval
+* is narrower than RELTOL times the larger (in
+* magnitude) endpoint, then it is considered to be
+* sufficiently small, i.e., converged. Note: this should
+* always be at least radix*machine epsilon.
+*
+* W (output) REAL
+*
+* WERR (output) REAL
+* The error bound on the corresponding eigenvalue approximation
+* in W.
+*
+* INFO (output) INTEGER
+* = 0: Eigenvalue converged
+* = -1: Eigenvalue did NOT converge
+*
+* Internal Parameters
+* ===================
+*
+* FUDGE REAL , default = 2
+* A "fudge factor" to widen the Gershgorin intervals.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL FUDGE, HALF, TWO, ZERO
+ PARAMETER ( HALF = 0.5E0, TWO = 2.0E0,
+ $ FUDGE = TWO, ZERO = 0.0E0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, IT, ITMAX, NEGCNT
+ REAL ATOLI, EPS, LEFT, MID, RIGHT, RTOLI, TMP1,
+ $ TMP2, TNORM
+* ..
+* .. External Functions ..
+ REAL SLAMCH
+ EXTERNAL SLAMCH
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, INT, LOG, MAX
+* ..
+* .. Executable Statements ..
+*
+* Get machine constants
+ EPS = SLAMCH( 'P' )
+
+ TNORM = MAX( ABS( GL ), ABS( GU ) )
+ RTOLI = RELTOL
+ ATOLI = FUDGE*TWO*PIVMIN
+
+ ITMAX = INT( ( LOG( TNORM+PIVMIN )-LOG( PIVMIN ) ) /
+ $ LOG( TWO ) ) + 2
+
+ INFO = -1
+
+ LEFT = GL - FUDGE*TNORM*EPS*N - FUDGE*TWO*PIVMIN
+ RIGHT = GU + FUDGE*TNORM*EPS*N + FUDGE*TWO*PIVMIN
+ IT = 0
+
+ 10 CONTINUE
+*
+* Check if interval converged or maximum number of iterations reached
+*
+ TMP1 = ABS( RIGHT - LEFT )
+ TMP2 = MAX( ABS(RIGHT), ABS(LEFT) )
+ IF( TMP1.LT.MAX( ATOLI, PIVMIN, RTOLI*TMP2 ) ) THEN
+ INFO = 0
+ GOTO 30
+ ENDIF
+ IF(IT.GT.ITMAX)
+ $ GOTO 30
+
+*
+* Count number of negative pivots for mid-point
+*
+ IT = IT + 1
+ MID = HALF * (LEFT + RIGHT)
+ NEGCNT = 0
+ TMP1 = D( 1 ) - MID
+ IF( ABS( TMP1 ).LT.PIVMIN )
+ $ TMP1 = -PIVMIN
+ IF( TMP1.LE.ZERO )
+ $ NEGCNT = NEGCNT + 1
+*
+ DO 20 I = 2, N
+ TMP1 = D( I ) - E2( I-1 ) / TMP1 - MID
+ IF( ABS( TMP1 ).LT.PIVMIN )
+ $ TMP1 = -PIVMIN
+ IF( TMP1.LE.ZERO )
+ $ NEGCNT = NEGCNT + 1
+ 20 CONTINUE
+
+ IF(NEGCNT.GE.IW) THEN
+ RIGHT = MID
+ ELSE
+ LEFT = MID
+ ENDIF
+ GOTO 10
+
+ 30 CONTINUE
+*
+* Converged or maximum number of iterations reached
+*
+ W = HALF * (LEFT + RIGHT)
+ WERR = HALF * ABS( RIGHT - LEFT )
+
+ RETURN
+*
+* End of SLARRK
+*
+ END
+ SUBROUTINE SLARRR( N, D, E, INFO )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER N, INFO
+* ..
+* .. Array Arguments ..
+ REAL D( * ), E( * )
+* ..
+*
+*
+* Purpose
+* =======
+*
+* Perform tests to decide whether the symmetric tridiagonal matrix T
+* warrants expensive computations which guarantee high relative accuracy
+* in the eigenvalues.
+*
+* Arguments
+* =========
+*
+* N (input) INTEGER
+* The order of the matrix. N > 0.
+*
+* D (input) REAL array, dimension (N)
+* The N diagonal elements of the tridiagonal matrix T.
+*
+* E (input/output) REAL array, dimension (N)
+* On entry, the first (N-1) entries contain the subdiagonal
+* elements of the tridiagonal matrix T; E(N) is set to ZERO.
+*
+* INFO (output) INTEGER
+* INFO = 0(default) : the matrix warrants computations preserving
+* relative accuracy.
+* INFO = 1 : the matrix warrants computations guaranteeing
+* only absolute accuracy.
+*
+* Further Details
+* ===============
+*
+* Based on contributions by
+* Beresford Parlett, University of California, Berkeley, USA
+* Jim Demmel, University of California, Berkeley, USA
+* Inderjit Dhillon, University of Texas, Austin, USA
+* Osni Marques, LBNL/NERSC, USA
+* Christof Voemel, University of California, Berkeley, USA
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO, RELCOND
+ PARAMETER ( ZERO = 0.0E0,
+ $ RELCOND = 0.999E0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I
+ LOGICAL YESREL
+ REAL EPS, SAFMIN, SMLNUM, RMIN, TMP, TMP2,
+ $ OFFDIG, OFFDIG2
+
+* ..
+* .. External Functions ..
+ REAL SLAMCH
+ EXTERNAL SLAMCH
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS
+* ..
+* .. Executable Statements ..
+*
+* As a default, do NOT go for relative-accuracy preserving computations.
+ INFO = 1
+
+ SAFMIN = SLAMCH( 'Safe minimum' )
+ EPS = SLAMCH( 'Precision' )
+ SMLNUM = SAFMIN / EPS
+ RMIN = SQRT( SMLNUM )
+
+* Tests for relative accuracy
+*
+* Test for scaled diagonal dominance
+* Scale the diagonal entries to one and check whether the sum of the
+* off-diagonals is less than one
+*
+* The sdd relative error bounds have a 1/(1- 2*x) factor in them,
+* x = max(OFFDIG + OFFDIG2), so when x is close to 1/2, no relative
+* accuracy is promised. In the notation of the code fragment below,
+* 1/(1 - (OFFDIG + OFFDIG2)) is the condition number.
+* We don't think it is worth going into "sdd mode" unless the relative
+* condition number is reasonable, not 1/macheps.
+* The threshold should be compatible with other thresholds used in the
+* code. We set OFFDIG + OFFDIG2 <= .999 =: RELCOND, it corresponds
+* to losing at most 3 decimal digits: 1 / (1 - (OFFDIG + OFFDIG2)) <= 1000
+* instead of the current OFFDIG + OFFDIG2 < 1
+*
+ YESREL = .TRUE.
+ OFFDIG = ZERO
+ TMP = SQRT(ABS(D(1)))
+ IF (TMP.LT.RMIN) YESREL = .FALSE.
+ IF(.NOT.YESREL) GOTO 11
+ DO 10 I = 2, N
+ TMP2 = SQRT(ABS(D(I)))
+ IF (TMP2.LT.RMIN) YESREL = .FALSE.
+ IF(.NOT.YESREL) GOTO 11
+ OFFDIG2 = ABS(E(I-1))/(TMP*TMP2)
+ IF(OFFDIG+OFFDIG2.GE.RELCOND) YESREL = .FALSE.
+ IF(.NOT.YESREL) GOTO 11
+ TMP = TMP2
+ OFFDIG = OFFDIG2
+ 10 CONTINUE
+ 11 CONTINUE
+
+ IF( YESREL ) THEN
+ INFO = 0
+ RETURN
+ ELSE
+ ENDIF
+*
+
+*
+* *** MORE TO BE IMPLEMENTED ***
+*
+
+*
+* Test if the lower bidiagonal matrix L from T = L D L^T
+* (zero shift facto) is well conditioned
+*
+
+*
+* Test if the upper bidiagonal matrix U from T = U D U^T
+* (zero shift facto) is well conditioned.
+* In this case, the matrix needs to be flipped and, at the end
+* of the eigenvector computation, the flip needs to be applied
+* to the computed eigenvectors (and the support)
+*
+
+*
+ RETURN
+*
+* END OF SLARRR
+*
+ END
+ 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 )
+*
+* -- LAPACK auxiliary routine (version 3.1.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER DOL, DOU, INFO, LDZ, M, N
+ REAL MINRGP, PIVMIN, RTOL1, RTOL2, VL, VU
+* ..
+* .. Array Arguments ..
+ INTEGER IBLOCK( * ), INDEXW( * ), ISPLIT( * ),
+ $ ISUPPZ( * ), IWORK( * )
+ REAL D( * ), GERS( * ), L( * ), W( * ), WERR( * ),
+ $ WGAP( * ), WORK( * )
+ REAL Z( LDZ, * )
+* ..
+*
+* Purpose
+* =======
+*
+* SLARRV computes the eigenvectors of the tridiagonal matrix
+* T = L D L^T given L, D and APPROXIMATIONS to the eigenvalues of L D L^T.
+* The input eigenvalues should have been computed by SLARRE.
+*
+* Arguments
+* =========
+*
+* N (input) INTEGER
+* The order of the matrix. N >= 0.
+*
+* VL (input) REAL
+* VU (input) REAL
+* Lower and upper bounds of the interval that contains the desired
+* eigenvalues. VL < VU. Needed to compute gaps on the left or right
+* end of the extremal eigenvalues in the desired RANGE.
+*
+* D (input/output) REAL array, dimension (N)
+* On entry, the N diagonal elements of the diagonal matrix D.
+* On exit, D may be overwritten.
+*
+* L (input/output) REAL array, dimension (N)
+* On entry, the (N-1) subdiagonal elements of the unit
+* bidiagonal matrix L are in elements 1 to N-1 of L
+* (if the matrix is not splitted.) At the end of each block
+* is stored the corresponding shift as given by SLARRE.
+* On exit, L is overwritten.
+*
+* PIVMIN (in) DOUBLE PRECISION
+* The minimum pivot allowed in the Sturm sequence.
+*
+* ISPLIT (input) INTEGER array, dimension (N)
+* The splitting points, at which T breaks up into blocks.
+* The first block consists of rows/columns 1 to
+* ISPLIT( 1 ), the second of rows/columns ISPLIT( 1 )+1
+* through ISPLIT( 2 ), etc.
+*
+* M (input) INTEGER
+* The total number of input eigenvalues. 0 <= M <= N.
+*
+* DOL (input) INTEGER
+* DOU (input) INTEGER
+* If the user wants to compute only selected eigenvectors from all
+* the eigenvalues supplied, he can specify an index range DOL:DOU.
+* Or else the setting DOL=1, DOU=M should be applied.
+* Note that DOL and DOU refer to the order in which the eigenvalues
+* are stored in W.
+* If the user wants to compute only selected eigenpairs, then
+* the columns DOL-1 to DOU+1 of the eigenvector space Z contain the
+* computed eigenvectors. All other columns of Z are set to zero.
+*
+* MINRGP (input) REAL
+*
+* RTOL1 (input) REAL
+* RTOL2 (input) REAL
+* Parameters for bisection.
+* An interval [LEFT,RIGHT] has converged if
+* RIGHT-LEFT.LT.MAX( RTOL1*GAP, RTOL2*MAX(|LEFT|,|RIGHT|) )
+*
+* W (input/output) REAL array, dimension (N)
+* The first M elements of W contain the APPROXIMATE eigenvalues for
+* which eigenvectors are to be computed. The eigenvalues
+* should be grouped by split-off block and ordered from
+* smallest to largest within the block ( The output array
+* W from SLARRE is expected here ). Furthermore, they are with
+* respect to the shift of the corresponding root representation
+* for their block. On exit, W holds the eigenvalues of the
+* UNshifted matrix.
+*
+* WERR (input/output) REAL array, dimension (N)
+* The first M elements contain the semiwidth of the uncertainty
+* interval of the corresponding eigenvalue in W
+*
+* WGAP (input/output) REAL array, dimension (N)
+* The separation from the right neighbor eigenvalue in W.
+*
+* IBLOCK (input) INTEGER array, dimension (N)
+* The indices of the blocks (submatrices) associated with the
+* corresponding eigenvalues in W; IBLOCK(i)=1 if eigenvalue
+* W(i) belongs to the first block from the top, =2 if W(i)
+* belongs to the second block, etc.
+*
+* INDEXW (input) INTEGER array, dimension (N)
+* The indices of the eigenvalues within each block (submatrix);
+* for example, INDEXW(i)= 10 and IBLOCK(i)=2 imply that the
+* i-th eigenvalue W(i) is the 10-th eigenvalue in the second block.
+*
+* GERS (input) REAL array, dimension (2*N)
+* The N Gerschgorin intervals (the i-th Gerschgorin interval
+* is (GERS(2*i-1), GERS(2*i)). The Gerschgorin intervals should
+* be computed from the original UNshifted matrix.
+*
+* Z (output) REAL array, dimension (LDZ, max(1,M) )
+* If INFO = 0, the first M columns of Z contain the
+* orthonormal eigenvectors of the matrix T
+* corresponding to the input eigenvalues, with the i-th
+* column of Z holding the eigenvector associated with W(i).
+* Note: the user must ensure that at least max(1,M) columns are
+* supplied in the array Z.
+*
+* LDZ (input) INTEGER
+* The leading dimension of the array Z. LDZ >= 1, and if
+* JOBZ = 'V', LDZ >= max(1,N).
+*
+* ISUPPZ (output) INTEGER array, dimension ( 2*max(1,M) )
+* The support of the eigenvectors in Z, i.e., the indices
+* indicating the nonzero elements in Z. The I-th eigenvector
+* is nonzero only in elements ISUPPZ( 2*I-1 ) through
+* ISUPPZ( 2*I ).
+*
+* WORK (workspace) REAL array, dimension (12*N)
+*
+* IWORK (workspace) INTEGER array, dimension (7*N)
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+*
+* > 0: A problem occured in SLARRV.
+* < 0: One of the called subroutines signaled an internal problem.
+* Needs inspection of the corresponding parameter IINFO
+* for further information.
+*
+* =-1: Problem in SLARRB when refining a child's eigenvalues.
+* =-2: Problem in SLARRF when computing the RRR of a child.
+* When a child is inside a tight cluster, it can be difficult
+* to find an RRR. A partial remedy from the user's point of
+* view is to make the parameter MINRGP smaller and recompile.
+* However, as the orthogonality of the computed vectors is
+* proportional to 1/MINRGP, the user should be aware that
+* he might be trading in precision when he decreases MINRGP.
+* =-3: Problem in SLARRB when refining a single eigenvalue
+* after the Rayleigh correction was rejected.
+* = 5: The Rayleigh Quotient Iteration failed to converge to
+* full accuracy in MAXITR steps.
+*
+* Further Details
+* ===============
+*
+* Based on contributions by
+* Beresford Parlett, University of California, Berkeley, USA
+* Jim Demmel, University of California, Berkeley, USA
+* Inderjit Dhillon, University of Texas, Austin, USA
+* Osni Marques, LBNL/NERSC, USA
+* Christof Voemel, University of California, Berkeley, USA
+*
+* =====================================================================
+*
+* .. Parameters ..
+ INTEGER MAXITR
+ PARAMETER ( MAXITR = 10 )
+ REAL ZERO, ONE, TWO, THREE, FOUR, HALF
+ PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0,
+ $ TWO = 2.0E0, THREE = 3.0E0,
+ $ FOUR = 4.0E0, HALF = 0.5E0)
+* ..
+* .. Local Scalars ..
+ LOGICAL ESKIP, NEEDBS, STP2II, TRYRQC, USEDBS, USEDRQ
+ INTEGER DONE, I, IBEGIN, IDONE, IEND, II, IINDC1,
+ $ IINDC2, IINDR, IINDWK, IINFO, IM, IN, INDEIG,
+ $ INDLD, INDLLD, INDWRK, ISUPMN, ISUPMX, ITER,
+ $ ITMP1, J, JBLK, K, MINIWSIZE, MINWSIZE, NCLUS,
+ $ NDEPTH, NEGCNT, NEWCLS, NEWFST, NEWFTT, NEWLST,
+ $ NEWSIZ, OFFSET, OLDCLS, OLDFST, OLDIEN, OLDLST,
+ $ OLDNCL, P, PARITY, Q, WBEGIN, WEND, WINDEX,
+ $ WINDMN, WINDPL, ZFROM, ZTO, ZUSEDL, ZUSEDU,
+ $ ZUSEDW
+ REAL BSTRES, BSTW, EPS, FUDGE, GAP, GAPTOL, GL, GU,
+ $ LAMBDA, LEFT, LGAP, MINGMA, NRMINV, RESID,
+ $ RGAP, RIGHT, RQCORR, RQTOL, SAVGAP, SGNDEF,
+ $ SIGMA, SPDIAM, SSIGMA, TAU, TMP, TOL, ZTZ
+* ..
+* .. External Functions ..
+ REAL SLAMCH
+ EXTERNAL SLAMCH
+* ..
+* .. External Subroutines ..
+ EXTERNAL SCOPY, SLAR1V, SLARRB, SLARRF, SLASET,
+ $ SSCAL
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, REAL, MAX, MIN
+* ..
+* .. Executable Statements ..
+* ..
+
+* The first N entries of WORK are reserved for the eigenvalues
+ INDLD = N+1
+ INDLLD= 2*N+1
+ INDWRK= 3*N+1
+ MINWSIZE = 12 * N
+
+ DO 5 I= 1,MINWSIZE
+ WORK( I ) = ZERO
+ 5 CONTINUE
+
+* IWORK(IINDR+1:IINDR+N) hold the twist indices R for the
+* factorization used to compute the FP vector
+ IINDR = 0
+* IWORK(IINDC1+1:IINC2+N) are used to store the clusters of the current
+* layer and the one above.
+ IINDC1 = N
+ IINDC2 = 2*N
+ IINDWK = 3*N + 1
+
+ MINIWSIZE = 7 * N
+ DO 10 I= 1,MINIWSIZE
+ IWORK( I ) = 0
+ 10 CONTINUE
+
+ ZUSEDL = 1
+ IF(DOL.GT.1) THEN
+* Set lower bound for use of Z
+ ZUSEDL = DOL-1
+ ENDIF
+ ZUSEDU = M
+ IF(DOU.LT.M) THEN
+* Set lower bound for use of Z
+ ZUSEDU = DOU+1
+ ENDIF
+* The width of the part of Z that is used
+ ZUSEDW = ZUSEDU - ZUSEDL + 1
+
+
+ CALL SLASET( 'Full', N, ZUSEDW, ZERO, ZERO,
+ $ Z(1,ZUSEDL), LDZ )
+
+ EPS = SLAMCH( 'Precision' )
+ RQTOL = TWO * EPS
+*
+* Set expert flags for standard code.
+ TRYRQC = .TRUE.
+
+ IF((DOL.EQ.1).AND.(DOU.EQ.M)) THEN
+ ELSE
+* Only selected eigenpairs are computed. Since the other evalues
+* are not refined by RQ iteration, bisection has to compute to full
+* accuracy.
+ RTOL1 = FOUR * EPS
+ RTOL2 = FOUR * EPS
+ ENDIF
+
+* The entries WBEGIN:WEND in W, WERR, WGAP correspond to the
+* desired eigenvalues. The support of the nonzero eigenvector
+* entries is contained in the interval IBEGIN:IEND.
+* Remark that if k eigenpairs are desired, then the eigenvectors
+* are stored in k contiguous columns of Z.
+
+* DONE is the number of eigenvectors already computed
+ DONE = 0
+ IBEGIN = 1
+ WBEGIN = 1
+ DO 170 JBLK = 1, IBLOCK( M )
+ IEND = ISPLIT( JBLK )
+ SIGMA = L( IEND )
+* Find the eigenvectors of the submatrix indexed IBEGIN
+* through IEND.
+ WEND = WBEGIN - 1
+ 15 CONTINUE
+ IF( WEND.LT.M ) THEN
+ IF( IBLOCK( WEND+1 ).EQ.JBLK ) THEN
+ WEND = WEND + 1
+ GO TO 15
+ END IF
+ END IF
+ IF( WEND.LT.WBEGIN ) THEN
+ IBEGIN = IEND + 1
+ GO TO 170
+ ELSEIF( (WEND.LT.DOL).OR.(WBEGIN.GT.DOU) ) THEN
+ IBEGIN = IEND + 1
+ WBEGIN = WEND + 1
+ GO TO 170
+ END IF
+
+* Find local spectral diameter of the block
+ GL = GERS( 2*IBEGIN-1 )
+ GU = GERS( 2*IBEGIN )
+ DO 20 I = IBEGIN+1 , IEND
+ GL = MIN( GERS( 2*I-1 ), GL )
+ GU = MAX( GERS( 2*I ), GU )
+ 20 CONTINUE
+ SPDIAM = GU - GL
+
+* OLDIEN is the last index of the previous block
+ OLDIEN = IBEGIN - 1
+* Calculate the size of the current block
+ IN = IEND - IBEGIN + 1
+* The number of eigenvalues in the current block
+ IM = WEND - WBEGIN + 1
+
+* This is for a 1x1 block
+ IF( IBEGIN.EQ.IEND ) THEN
+ DONE = DONE+1
+ Z( IBEGIN, WBEGIN ) = ONE
+ ISUPPZ( 2*WBEGIN-1 ) = IBEGIN
+ ISUPPZ( 2*WBEGIN ) = IBEGIN
+ W( WBEGIN ) = W( WBEGIN ) + SIGMA
+ WORK( WBEGIN ) = W( WBEGIN )
+ IBEGIN = IEND + 1
+ WBEGIN = WBEGIN + 1
+ GO TO 170
+ END IF
+
+* The desired (shifted) eigenvalues are stored in W(WBEGIN:WEND)
+* Note that these can be approximations, in this case, the corresp.
+* entries of WERR give the size of the uncertainty interval.
+* The eigenvalue approximations will be refined when necessary as
+* high relative accuracy is required for the computation of the
+* corresponding eigenvectors.
+ CALL SCOPY( IM, W( WBEGIN ), 1,
+ & WORK( WBEGIN ), 1 )
+
+* We store in W the eigenvalue approximations w.r.t. the original
+* matrix T.
+ DO 30 I=1,IM
+ W(WBEGIN+I-1) = W(WBEGIN+I-1)+SIGMA
+ 30 CONTINUE
+
+
+* NDEPTH is the current depth of the representation tree
+ NDEPTH = 0
+* PARITY is either 1 or 0
+ PARITY = 1
+* NCLUS is the number of clusters for the next level of the
+* representation tree, we start with NCLUS = 1 for the root
+ NCLUS = 1
+ IWORK( IINDC1+1 ) = 1
+ IWORK( IINDC1+2 ) = IM
+
+* IDONE is the number of eigenvectors already computed in the current
+* block
+ IDONE = 0
+* loop while( IDONE.LT.IM )
+* generate the representation tree for the current block and
+* compute the eigenvectors
+ 40 CONTINUE
+ IF( IDONE.LT.IM ) THEN
+* This is a crude protection against infinitely deep trees
+ IF( NDEPTH.GT.M ) THEN
+ INFO = -2
+ RETURN
+ ENDIF
+* breadth first processing of the current level of the representation
+* tree: OLDNCL = number of clusters on current level
+ OLDNCL = NCLUS
+* reset NCLUS to count the number of child clusters
+ NCLUS = 0
+*
+ PARITY = 1 - PARITY
+ IF( PARITY.EQ.0 ) THEN
+ OLDCLS = IINDC1
+ NEWCLS = IINDC2
+ ELSE
+ OLDCLS = IINDC2
+ NEWCLS = IINDC1
+ END IF
+* Process the clusters on the current level
+ DO 150 I = 1, OLDNCL
+ J = OLDCLS + 2*I
+* OLDFST, OLDLST = first, last index of current cluster.
+* cluster indices start with 1 and are relative
+* to WBEGIN when accessing W, WGAP, WERR, Z
+ OLDFST = IWORK( J-1 )
+ OLDLST = IWORK( J )
+ IF( NDEPTH.GT.0 ) THEN
+* Retrieve relatively robust representation (RRR) of cluster
+* that has been computed at the previous level
+* The RRR is stored in Z and overwritten once the eigenvectors
+* have been computed or when the cluster is refined
+
+ IF((DOL.EQ.1).AND.(DOU.EQ.M)) THEN
+* Get representation from location of the leftmost evalue
+* of the cluster
+ J = WBEGIN + OLDFST - 1
+ ELSE
+ IF(WBEGIN+OLDFST-1.LT.DOL) THEN
+* Get representation from the left end of Z array
+ J = DOL - 1
+ ELSEIF(WBEGIN+OLDFST-1.GT.DOU) THEN
+* Get representation from the right end of Z array
+ J = DOU
+ ELSE
+ J = WBEGIN + OLDFST - 1
+ ENDIF
+ ENDIF
+ CALL SCOPY( IN, Z( IBEGIN, J ), 1, D( IBEGIN ), 1 )
+ CALL SCOPY( IN-1, Z( IBEGIN, J+1 ), 1, L( IBEGIN ),
+ $ 1 )
+ SIGMA = Z( IEND, J+1 )
+
+* Set the corresponding entries in Z to zero
+ CALL SLASET( 'Full', IN, 2, ZERO, ZERO,
+ $ Z( IBEGIN, J), LDZ )
+ END IF
+
+* Compute DL and DLL of current RRR
+ DO 50 J = IBEGIN, IEND-1
+ TMP = D( J )*L( J )
+ WORK( INDLD-1+J ) = TMP
+ WORK( INDLLD-1+J ) = TMP*L( J )
+ 50 CONTINUE
+
+ IF( NDEPTH.GT.0 ) THEN
+* P and Q are index of the first and last eigenvalue to compute
+* within the current block
+ P = INDEXW( WBEGIN-1+OLDFST )
+ Q = INDEXW( WBEGIN-1+OLDLST )
+* Offset for the arrays WORK, WGAP and WERR, i.e., th P-OFFSET
+* thru' Q-OFFSET elements of these arrays are to be used.
+C OFFSET = P-OLDFST
+ OFFSET = INDEXW( WBEGIN ) - 1
+* perform limited bisection (if necessary) to get approximate
+* eigenvalues to the precision needed.
+ CALL SLARRB( IN, D( IBEGIN ),
+ $ WORK(INDLLD+IBEGIN-1),
+ $ P, Q, RTOL1, RTOL2, OFFSET,
+ $ WORK(WBEGIN),WGAP(WBEGIN),WERR(WBEGIN),
+ $ WORK( INDWRK ), IWORK( IINDWK ),
+ $ PIVMIN, SPDIAM, IN, IINFO )
+ IF( IINFO.NE.0 ) THEN
+ INFO = -1
+ RETURN
+ ENDIF
+* We also recompute the extremal gaps. W holds all eigenvalues
+* of the unshifted matrix and must be used for computation
+* of WGAP, the entries of WORK might stem from RRRs with
+* different shifts. The gaps from WBEGIN-1+OLDFST to
+* WBEGIN-1+OLDLST are correctly computed in SLARRB.
+* However, we only allow the gaps to become greater since
+* this is what should happen when we decrease WERR
+ IF( OLDFST.GT.1) THEN
+ WGAP( WBEGIN+OLDFST-2 ) =
+ $ MAX(WGAP(WBEGIN+OLDFST-2),
+ $ W(WBEGIN+OLDFST-1)-WERR(WBEGIN+OLDFST-1)
+ $ - W(WBEGIN+OLDFST-2)-WERR(WBEGIN+OLDFST-2) )
+ ENDIF
+ IF( WBEGIN + OLDLST -1 .LT. WEND ) THEN
+ WGAP( WBEGIN+OLDLST-1 ) =
+ $ MAX(WGAP(WBEGIN+OLDLST-1),
+ $ W(WBEGIN+OLDLST)-WERR(WBEGIN+OLDLST)
+ $ - W(WBEGIN+OLDLST-1)-WERR(WBEGIN+OLDLST-1) )
+ ENDIF
+* Each time the eigenvalues in WORK get refined, we store
+* the newly found approximation with all shifts applied in W
+ DO 53 J=OLDFST,OLDLST
+ W(WBEGIN+J-1) = WORK(WBEGIN+J-1)+SIGMA
+ 53 CONTINUE
+ END IF
+
+* Process the current node.
+ NEWFST = OLDFST
+ DO 140 J = OLDFST, OLDLST
+ IF( J.EQ.OLDLST ) THEN
+* we are at the right end of the cluster, this is also the
+* boundary of the child cluster
+ NEWLST = J
+ ELSE IF ( WGAP( WBEGIN + J -1).GE.
+ $ MINRGP* ABS( WORK(WBEGIN + J -1) ) ) THEN
+* the right relative gap is big enough, the child cluster
+* (NEWFST,..,NEWLST) is well separated from the following
+ NEWLST = J
+ ELSE
+* inside a child cluster, the relative gap is not
+* big enough.
+ GOTO 140
+ END IF
+
+* Compute size of child cluster found
+ NEWSIZ = NEWLST - NEWFST + 1
+
+* NEWFTT is the place in Z where the new RRR or the computed
+* eigenvector is to be stored
+ IF((DOL.EQ.1).AND.(DOU.EQ.M)) THEN
+* Store representation at location of the leftmost evalue
+* of the cluster
+ NEWFTT = WBEGIN + NEWFST - 1
+ ELSE
+ IF(WBEGIN+NEWFST-1.LT.DOL) THEN
+* Store representation at the left end of Z array
+ NEWFTT = DOL - 1
+ ELSEIF(WBEGIN+NEWFST-1.GT.DOU) THEN
+* Store representation at the right end of Z array
+ NEWFTT = DOU
+ ELSE
+ NEWFTT = WBEGIN + NEWFST - 1
+ ENDIF
+ ENDIF
+
+ IF( NEWSIZ.GT.1) THEN
+*
+* Current child is not a singleton but a cluster.
+* Compute and store new representation of child.
+*
+*
+* Compute left and right cluster gap.
+*
+* LGAP and RGAP are not computed from WORK because
+* the eigenvalue approximations may stem from RRRs
+* different shifts. However, W hold all eigenvalues
+* of the unshifted matrix. Still, the entries in WGAP
+* have to be computed from WORK since the entries
+* in W might be of the same order so that gaps are not
+* exhibited correctly for very close eigenvalues.
+ IF( NEWFST.EQ.1 ) THEN
+ LGAP = MAX( ZERO,
+ $ W(WBEGIN)-WERR(WBEGIN) - VL )
+ ELSE
+ LGAP = WGAP( WBEGIN+NEWFST-2 )
+ ENDIF
+ RGAP = WGAP( WBEGIN+NEWLST-1 )
+*
+* Compute left- and rightmost eigenvalue of child
+* to high precision in order to shift as close
+* as possible and obtain as large relative gaps
+* as possible
+*
+ DO 55 K =1,2
+ IF(K.EQ.1) THEN
+ P = INDEXW( WBEGIN-1+NEWFST )
+ ELSE
+ P = INDEXW( WBEGIN-1+NEWLST )
+ ENDIF
+ OFFSET = INDEXW( WBEGIN ) - 1
+ CALL SLARRB( IN, D(IBEGIN),
+ $ WORK( INDLLD+IBEGIN-1 ),P,P,
+ $ RQTOL, RQTOL, OFFSET,
+ $ WORK(WBEGIN),WGAP(WBEGIN),
+ $ WERR(WBEGIN),WORK( INDWRK ),
+ $ IWORK( IINDWK ), PIVMIN, SPDIAM,
+ $ IN, IINFO )
+ 55 CONTINUE
+*
+ IF((WBEGIN+NEWLST-1.LT.DOL).OR.
+ $ (WBEGIN+NEWFST-1.GT.DOU)) THEN
+* if the cluster contains no desired eigenvalues
+* skip the computation of that branch of the rep. tree
+*
+* We could skip before the refinement of the extremal
+* eigenvalues of the child, but then the representation
+* tree could be different from the one when nothing is
+* skipped. For this reason we skip at this place.
+ IDONE = IDONE + NEWLST - NEWFST + 1
+ GOTO 139
+ ENDIF
+*
+* Compute RRR of child cluster.
+* Note that the new RRR is stored in Z
+*
+C SLARRF needs LWORK = 2*N
+ CALL SLARRF( IN, D( IBEGIN ), L( IBEGIN ),
+ $ WORK(INDLD+IBEGIN-1),
+ $ NEWFST, NEWLST, WORK(WBEGIN),
+ $ WGAP(WBEGIN), WERR(WBEGIN),
+ $ SPDIAM, LGAP, RGAP, PIVMIN, TAU,
+ $ Z(IBEGIN, NEWFTT),Z(IBEGIN, NEWFTT+1),
+ $ WORK( INDWRK ), IINFO )
+ IF( IINFO.EQ.0 ) THEN
+* a new RRR for the cluster was found by SLARRF
+* update shift and store it
+ SSIGMA = SIGMA + TAU
+ Z( IEND, NEWFTT+1 ) = SSIGMA
+* WORK() are the midpoints and WERR() the semi-width
+* Note that the entries in W are unchanged.
+ DO 116 K = NEWFST, NEWLST
+ FUDGE =
+ $ THREE*EPS*ABS(WORK(WBEGIN+K-1))
+ WORK( WBEGIN + K - 1 ) =
+ $ WORK( WBEGIN + K - 1) - TAU
+ FUDGE = FUDGE +
+ $ FOUR*EPS*ABS(WORK(WBEGIN+K-1))
+* Fudge errors
+ WERR( WBEGIN + K - 1 ) =
+ $ WERR( WBEGIN + K - 1 ) + FUDGE
+* Gaps are not fudged. Provided that WERR is small
+* when eigenvalues are close, a zero gap indicates
+* that a new representation is needed for resolving
+* the cluster. A fudge could lead to a wrong decision
+* of judging eigenvalues 'separated' which in
+* reality are not. This could have a negative impact
+* on the orthogonality of the computed eigenvectors.
+ 116 CONTINUE
+
+ NCLUS = NCLUS + 1
+ K = NEWCLS + 2*NCLUS
+ IWORK( K-1 ) = NEWFST
+ IWORK( K ) = NEWLST
+ ELSE
+ INFO = -2
+ RETURN
+ ENDIF
+ ELSE
+*
+* Compute eigenvector of singleton
+*
+ ITER = 0
+*
+ TOL = FOUR * LOG(REAL(IN)) * EPS
+*
+ K = NEWFST
+ WINDEX = WBEGIN + K - 1
+ WINDMN = MAX(WINDEX - 1,1)
+ WINDPL = MIN(WINDEX + 1,M)
+ LAMBDA = WORK( WINDEX )
+ DONE = DONE + 1
+* Check if eigenvector computation is to be skipped
+ IF((WINDEX.LT.DOL).OR.
+ $ (WINDEX.GT.DOU)) THEN
+ ESKIP = .TRUE.
+ GOTO 125
+ ELSE
+ ESKIP = .FALSE.
+ ENDIF
+ LEFT = WORK( WINDEX ) - WERR( WINDEX )
+ RIGHT = WORK( WINDEX ) + WERR( WINDEX )
+ INDEIG = INDEXW( WINDEX )
+* Note that since we compute the eigenpairs for a child,
+* all eigenvalue approximations are w.r.t the same shift.
+* In this case, the entries in WORK should be used for
+* computing the gaps since they exhibit even very small
+* differences in the eigenvalues, as opposed to the
+* entries in W which might "look" the same.
+
+ IF( K .EQ. 1) THEN
+* In the case RANGE='I' and with not much initial
+* accuracy in LAMBDA and VL, the formula
+* LGAP = MAX( ZERO, (SIGMA - VL) + LAMBDA )
+* can lead to an overestimation of the left gap and
+* thus to inadequately early RQI 'convergence'.
+* Prevent this by forcing a small left gap.
+ LGAP = EPS*MAX(ABS(LEFT),ABS(RIGHT))
+ ELSE
+ LGAP = WGAP(WINDMN)
+ ENDIF
+ IF( K .EQ. IM) THEN
+* In the case RANGE='I' and with not much initial
+* accuracy in LAMBDA and VU, the formula
+* can lead to an overestimation of the right gap and
+* thus to inadequately early RQI 'convergence'.
+* Prevent this by forcing a small right gap.
+ RGAP = EPS*MAX(ABS(LEFT),ABS(RIGHT))
+ ELSE
+ RGAP = WGAP(WINDEX)
+ ENDIF
+ GAP = MIN( LGAP, RGAP )
+ IF(( K .EQ. 1).OR.(K .EQ. IM)) THEN
+* The eigenvector support can become wrong
+* because significant entries could be cut off due to a
+* large GAPTOL parameter in LAR1V. Prevent this.
+ GAPTOL = ZERO
+ ELSE
+ GAPTOL = GAP * EPS
+ ENDIF
+ ISUPMN = IN
+ ISUPMX = 1
+* Update WGAP so that it holds the minimum gap
+* to the left or the right. This is crucial in the
+* case where bisection is used to ensure that the
+* eigenvalue is refined up to the required precision.
+* The correct value is restored afterwards.
+ SAVGAP = WGAP(WINDEX)
+ WGAP(WINDEX) = GAP
+* We want to use the Rayleigh Quotient Correction
+* as often as possible since it converges quadratically
+* when we are close enough to the desired eigenvalue.
+* However, the Rayleigh Quotient can have the wrong sign
+* and lead us away from the desired eigenvalue. In this
+* case, the best we can do is to use bisection.
+ USEDBS = .FALSE.
+ USEDRQ = .FALSE.
+* Bisection is initially turned off unless it is forced
+ NEEDBS = .NOT.TRYRQC
+ 120 CONTINUE
+* Check if bisection should be used to refine eigenvalue
+ IF(NEEDBS) THEN
+* Take the bisection as new iterate
+ USEDBS = .TRUE.
+ ITMP1 = IWORK( IINDR+WINDEX )
+ OFFSET = INDEXW( WBEGIN ) - 1
+ CALL SLARRB( IN, D(IBEGIN),
+ $ WORK(INDLLD+IBEGIN-1),INDEIG,INDEIG,
+ $ ZERO, TWO*EPS, OFFSET,
+ $ WORK(WBEGIN),WGAP(WBEGIN),
+ $ WERR(WBEGIN),WORK( INDWRK ),
+ $ IWORK( IINDWK ), PIVMIN, SPDIAM,
+ $ ITMP1, IINFO )
+ IF( IINFO.NE.0 ) THEN
+ INFO = -3
+ RETURN
+ ENDIF
+ LAMBDA = WORK( WINDEX )
+* Reset twist index from inaccurate LAMBDA to
+* force computation of true MINGMA
+ IWORK( IINDR+WINDEX ) = 0
+ ENDIF
+* Given LAMBDA, compute the eigenvector.
+ CALL SLAR1V( IN, 1, IN, LAMBDA, D( IBEGIN ),
+ $ L( IBEGIN ), WORK(INDLD+IBEGIN-1),
+ $ WORK(INDLLD+IBEGIN-1),
+ $ PIVMIN, GAPTOL, Z( IBEGIN, WINDEX ),
+ $ .NOT.USEDBS, NEGCNT, ZTZ, MINGMA,
+ $ IWORK( IINDR+WINDEX ), ISUPPZ( 2*WINDEX-1 ),
+ $ NRMINV, RESID, RQCORR, WORK( INDWRK ) )
+ IF(ITER .EQ. 0) THEN
+ BSTRES = RESID
+ BSTW = LAMBDA
+ ELSEIF(RESID.LT.BSTRES) THEN
+ BSTRES = RESID
+ BSTW = LAMBDA
+ ENDIF
+ ISUPMN = MIN(ISUPMN,ISUPPZ( 2*WINDEX-1 ))
+ ISUPMX = MAX(ISUPMX,ISUPPZ( 2*WINDEX ))
+ ITER = ITER + 1
+
+* sin alpha <= |resid|/gap
+* Note that both the residual and the gap are
+* proportional to the matrix, so ||T|| doesn't play
+* a role in the quotient
+
+*
+* Convergence test for Rayleigh-Quotient iteration
+* (omitted when Bisection has been used)
+*
+ IF( RESID.GT.TOL*GAP .AND. ABS( RQCORR ).GT.
+ $ RQTOL*ABS( LAMBDA ) .AND. .NOT. USEDBS)
+ $ THEN
+* We need to check that the RQCORR update doesn't
+* move the eigenvalue away from the desired one and
+* towards a neighbor. -> protection with bisection
+ IF(INDEIG.LE.NEGCNT) THEN
+* The wanted eigenvalue lies to the left
+ SGNDEF = -ONE
+ ELSE
+* The wanted eigenvalue lies to the right
+ SGNDEF = ONE
+ ENDIF
+* We only use the RQCORR if it improves the
+* the iterate reasonably.
+ IF( ( RQCORR*SGNDEF.GE.ZERO )
+ $ .AND.( LAMBDA + RQCORR.LE. RIGHT)
+ $ .AND.( LAMBDA + RQCORR.GE. LEFT)
+ $ ) THEN
+ USEDRQ = .TRUE.
+* Store new midpoint of bisection interval in WORK
+ IF(SGNDEF.EQ.ONE) THEN
+* The current LAMBDA is on the left of the true
+* eigenvalue
+ LEFT = LAMBDA
+* We prefer to assume that the error estimate
+* is correct. We could make the interval not
+* as a bracket but to be modified if the RQCORR
+* chooses to. In this case, the RIGHT side should
+* be modified as follows:
+* RIGHT = MAX(RIGHT, LAMBDA + RQCORR)
+ ELSE
+* The current LAMBDA is on the right of the true
+* eigenvalue
+ RIGHT = LAMBDA
+* See comment about assuming the error estimate is
+* correct above.
+* LEFT = MIN(LEFT, LAMBDA + RQCORR)
+ ENDIF
+ WORK( WINDEX ) =
+ $ HALF * (RIGHT + LEFT)
+* Take RQCORR since it has the correct sign and
+* improves the iterate reasonably
+ LAMBDA = LAMBDA + RQCORR
+* Update width of error interval
+ WERR( WINDEX ) =
+ $ HALF * (RIGHT-LEFT)
+ ELSE
+ NEEDBS = .TRUE.
+ ENDIF
+ IF(RIGHT-LEFT.LT.RQTOL*ABS(LAMBDA)) THEN
+* The eigenvalue is computed to bisection accuracy
+* compute eigenvector and stop
+ USEDBS = .TRUE.
+ GOTO 120
+ ELSEIF( ITER.LT.MAXITR ) THEN
+ GOTO 120
+ ELSEIF( ITER.EQ.MAXITR ) THEN
+ NEEDBS = .TRUE.
+ GOTO 120
+ ELSE
+ INFO = 5
+ RETURN
+ END IF
+ ELSE
+ STP2II = .FALSE.
+ IF(USEDRQ .AND. USEDBS .AND.
+ $ BSTRES.LE.RESID) THEN
+ LAMBDA = BSTW
+ STP2II = .TRUE.
+ ENDIF
+ IF (STP2II) THEN
+* improve error angle by second step
+ CALL SLAR1V( IN, 1, IN, LAMBDA,
+ $ D( IBEGIN ), L( IBEGIN ),
+ $ WORK(INDLD+IBEGIN-1),
+ $ WORK(INDLLD+IBEGIN-1),
+ $ PIVMIN, GAPTOL, Z( IBEGIN, WINDEX ),
+ $ .NOT.USEDBS, NEGCNT, ZTZ, MINGMA,
+ $ IWORK( IINDR+WINDEX ),
+ $ ISUPPZ( 2*WINDEX-1 ),
+ $ NRMINV, RESID, RQCORR, WORK( INDWRK ) )
+ ENDIF
+ WORK( WINDEX ) = LAMBDA
+ END IF
+*
+* Compute FP-vector support w.r.t. whole matrix
+*
+ ISUPPZ( 2*WINDEX-1 ) = ISUPPZ( 2*WINDEX-1 )+OLDIEN
+ ISUPPZ( 2*WINDEX ) = ISUPPZ( 2*WINDEX )+OLDIEN
+ ZFROM = ISUPPZ( 2*WINDEX-1 )
+ ZTO = ISUPPZ( 2*WINDEX )
+ ISUPMN = ISUPMN + OLDIEN
+ ISUPMX = ISUPMX + OLDIEN
+* Ensure vector is ok if support in the RQI has changed
+ IF(ISUPMN.LT.ZFROM) THEN
+ DO 122 II = ISUPMN,ZFROM-1
+ Z( II, WINDEX ) = ZERO
+ 122 CONTINUE
+ ENDIF
+ IF(ISUPMX.GT.ZTO) THEN
+ DO 123 II = ZTO+1,ISUPMX
+ Z( II, WINDEX ) = ZERO
+ 123 CONTINUE
+ ENDIF
+ CALL SSCAL( ZTO-ZFROM+1, NRMINV,
+ $ Z( ZFROM, WINDEX ), 1 )
+ 125 CONTINUE
+* Update W
+ W( WINDEX ) = LAMBDA+SIGMA
+* Recompute the gaps on the left and right
+* But only allow them to become larger and not
+* smaller (which can only happen through "bad"
+* cancellation and doesn't reflect the theory
+* where the initial gaps are underestimated due
+* to WERR being too crude.)
+ IF(.NOT.ESKIP) THEN
+ IF( K.GT.1) THEN
+ WGAP( WINDMN ) = MAX( WGAP(WINDMN),
+ $ W(WINDEX)-WERR(WINDEX)
+ $ - W(WINDMN)-WERR(WINDMN) )
+ ENDIF
+ IF( WINDEX.LT.WEND ) THEN
+ WGAP( WINDEX ) = MAX( SAVGAP,
+ $ W( WINDPL )-WERR( WINDPL )
+ $ - W( WINDEX )-WERR( WINDEX) )
+ ENDIF
+ ENDIF
+ IDONE = IDONE + 1
+ ENDIF
+* here ends the code for the current child
+*
+ 139 CONTINUE
+* Proceed to any remaining child nodes
+ NEWFST = J + 1
+ 140 CONTINUE
+ 150 CONTINUE
+ NDEPTH = NDEPTH + 1
+ GO TO 40
+ END IF
+ IBEGIN = IEND + 1
+ WBEGIN = WEND + 1
+ 170 CONTINUE
+*
+
+ RETURN
+*
+* End of SLARRV
+*
+ END
+ SUBROUTINE SLARTG( F, G, CS, SN, R )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ REAL CS, F, G, R, SN
+* ..
+*
+* Purpose
+* =======
+*
+* SLARTG generate a plane rotation so that
+*
+* [ CS SN ] . [ F ] = [ R ] where CS**2 + SN**2 = 1.
+* [ -SN CS ] [ G ] [ 0 ]
+*
+* This is a slower, more accurate version of the BLAS1 routine SROTG,
+* with the following other differences:
+* F and G are unchanged on return.
+* If G=0, then CS=1 and SN=0.
+* If F=0 and (G .ne. 0), then CS=0 and SN=1 without doing any
+* floating point operations (saves work in SBDSQR when
+* there are zeros on the diagonal).
+*
+* If F exceeds G in magnitude, CS will be positive.
+*
+* Arguments
+* =========
+*
+* F (input) REAL
+* The first component of vector to be rotated.
+*
+* G (input) REAL
+* The second component of vector to be rotated.
+*
+* CS (output) REAL
+* The cosine of the rotation.
+*
+* SN (output) REAL
+* The sine of the rotation.
+*
+* R (output) REAL
+* The nonzero component of the rotated vector.
+*
+* This version has a few statements commented out for thread safety
+* (machine parameters are computed on each entry). 10 feb 03, SJH.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO
+ PARAMETER ( ZERO = 0.0E0 )
+ REAL ONE
+ PARAMETER ( ONE = 1.0E0 )
+ REAL TWO
+ PARAMETER ( TWO = 2.0E0 )
+* ..
+* .. Local Scalars ..
+* LOGICAL FIRST
+ INTEGER COUNT, I
+ REAL EPS, F1, G1, SAFMIN, SAFMN2, SAFMX2, SCALE
+* ..
+* .. External Functions ..
+ REAL SLAMCH
+ EXTERNAL SLAMCH
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, INT, LOG, MAX, SQRT
+* ..
+* .. Save statement ..
+* SAVE FIRST, SAFMX2, SAFMIN, SAFMN2
+* ..
+* .. Data statements ..
+* DATA FIRST / .TRUE. /
+* ..
+* .. Executable Statements ..
+*
+* IF( FIRST ) THEN
+ SAFMIN = SLAMCH( 'S' )
+ EPS = SLAMCH( 'E' )
+ SAFMN2 = SLAMCH( 'B' )**INT( LOG( SAFMIN / EPS ) /
+ $ LOG( SLAMCH( 'B' ) ) / TWO )
+ SAFMX2 = ONE / SAFMN2
+* FIRST = .FALSE.
+* END IF
+ IF( G.EQ.ZERO ) THEN
+ CS = ONE
+ SN = ZERO
+ R = F
+ ELSE IF( F.EQ.ZERO ) THEN
+ CS = ZERO
+ SN = ONE
+ R = G
+ ELSE
+ F1 = F
+ G1 = G
+ SCALE = MAX( ABS( F1 ), ABS( G1 ) )
+ IF( SCALE.GE.SAFMX2 ) THEN
+ COUNT = 0
+ 10 CONTINUE
+ COUNT = COUNT + 1
+ F1 = F1*SAFMN2
+ G1 = G1*SAFMN2
+ SCALE = MAX( ABS( F1 ), ABS( G1 ) )
+ IF( SCALE.GE.SAFMX2 )
+ $ GO TO 10
+ R = SQRT( F1**2+G1**2 )
+ CS = F1 / R
+ SN = G1 / R
+ DO 20 I = 1, COUNT
+ R = R*SAFMX2
+ 20 CONTINUE
+ ELSE IF( SCALE.LE.SAFMN2 ) THEN
+ COUNT = 0
+ 30 CONTINUE
+ COUNT = COUNT + 1
+ F1 = F1*SAFMX2
+ G1 = G1*SAFMX2
+ SCALE = MAX( ABS( F1 ), ABS( G1 ) )
+ IF( SCALE.LE.SAFMN2 )
+ $ GO TO 30
+ R = SQRT( F1**2+G1**2 )
+ CS = F1 / R
+ SN = G1 / R
+ DO 40 I = 1, COUNT
+ R = R*SAFMN2
+ 40 CONTINUE
+ ELSE
+ R = SQRT( F1**2+G1**2 )
+ CS = F1 / R
+ SN = G1 / R
+ END IF
+ IF( ABS( F ).GT.ABS( G ) .AND. CS.LT.ZERO ) THEN
+ CS = -CS
+ SN = -SN
+ R = -R
+ END IF
+ END IF
+ RETURN
+*
+* End of SLARTG
+*
+ END
+ SUBROUTINE SLARTV( N, X, INCX, Y, INCY, C, S, INCC )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INCC, INCX, INCY, N
+* ..
+* .. Array Arguments ..
+ REAL C( * ), S( * ), X( * ), Y( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SLARTV applies a vector of real plane rotations to elements of the
+* real vectors x and y. For i = 1,2,...,n
+*
+* ( x(i) ) := ( c(i) s(i) ) ( x(i) )
+* ( y(i) ) ( -s(i) c(i) ) ( y(i) )
+*
+* Arguments
+* =========
+*
+* N (input) INTEGER
+* The number of plane rotations to be applied.
+*
+* X (input/output) REAL array,
+* dimension (1+(N-1)*INCX)
+* The vector x.
+*
+* INCX (input) INTEGER
+* The increment between elements of X. INCX > 0.
+*
+* Y (input/output) REAL array,
+* dimension (1+(N-1)*INCY)
+* The vector y.
+*
+* INCY (input) INTEGER
+* The increment between elements of Y. INCY > 0.
+*
+* C (input) REAL array, dimension (1+(N-1)*INCC)
+* The cosines of the plane rotations.
+*
+* S (input) REAL array, dimension (1+(N-1)*INCC)
+* The sines of the plane rotations.
+*
+* INCC (input) INTEGER
+* The increment between elements of C and S. INCC > 0.
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ INTEGER I, IC, IX, IY
+ REAL XI, YI
+* ..
+* .. Executable Statements ..
+*
+ IX = 1
+ IY = 1
+ IC = 1
+ DO 10 I = 1, N
+ XI = X( IX )
+ YI = Y( IY )
+ X( IX ) = C( IC )*XI + S( IC )*YI
+ Y( IY ) = C( IC )*YI - S( IC )*XI
+ IX = IX + INCX
+ IY = IY + INCY
+ IC = IC + INCC
+ 10 CONTINUE
+ RETURN
+*
+* End of SLARTV
+*
+ END
+ SUBROUTINE SLARUV( ISEED, N, X )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER N
+* ..
+* .. Array Arguments ..
+ INTEGER ISEED( 4 )
+ REAL X( N )
+* ..
+*
+* Purpose
+* =======
+*
+* SLARUV returns a vector of n random real numbers from a uniform (0,1)
+* distribution (n <= 128).
+*
+* This is an auxiliary routine called by SLARNV and CLARNV.
+*
+* Arguments
+* =========
+*
+* ISEED (input/output) INTEGER array, dimension (4)
+* On entry, the seed of the random number generator; the array
+* elements must be between 0 and 4095, and ISEED(4) must be
+* odd.
+* On exit, the seed is updated.
+*
+* N (input) INTEGER
+* The number of random numbers to be generated. N <= 128.
+*
+* X (output) REAL array, dimension (N)
+* The generated random numbers.
+*
+* Further Details
+* ===============
+*
+* This routine uses a multiplicative congruential method with modulus
+* 2**48 and multiplier 33952834046453 (see G.S.Fishman,
+* 'Multiplicative congruential random number generators with modulus
+* 2**b: an exhaustive analysis for b = 32 and a partial analysis for
+* b = 48', Math. Comp. 189, pp 331-344, 1990).
+*
+* 48-bit integers are stored in 4 integer array elements with 12 bits
+* per element. Hence the routine is portable across machines with
+* integers of 32 bits or more.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ONE
+ PARAMETER ( ONE = 1.0E0 )
+ INTEGER LV, IPW2
+ REAL R
+ PARAMETER ( LV = 128, IPW2 = 4096, R = ONE / IPW2 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, I1, I2, I3, I4, IT1, IT2, IT3, IT4, J
+* ..
+* .. Local Arrays ..
+ INTEGER MM( LV, 4 )
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MIN, MOD, REAL
+* ..
+* .. Data statements ..
+ DATA ( MM( 1, J ), J = 1, 4 ) / 494, 322, 2508,
+ $ 2549 /
+ DATA ( MM( 2, J ), J = 1, 4 ) / 2637, 789, 3754,
+ $ 1145 /
+ DATA ( MM( 3, J ), J = 1, 4 ) / 255, 1440, 1766,
+ $ 2253 /
+ DATA ( MM( 4, J ), J = 1, 4 ) / 2008, 752, 3572,
+ $ 305 /
+ DATA ( MM( 5, J ), J = 1, 4 ) / 1253, 2859, 2893,
+ $ 3301 /
+ DATA ( MM( 6, J ), J = 1, 4 ) / 3344, 123, 307,
+ $ 1065 /
+ DATA ( MM( 7, J ), J = 1, 4 ) / 4084, 1848, 1297,
+ $ 3133 /
+ DATA ( MM( 8, J ), J = 1, 4 ) / 1739, 643, 3966,
+ $ 2913 /
+ DATA ( MM( 9, J ), J = 1, 4 ) / 3143, 2405, 758,
+ $ 3285 /
+ DATA ( MM( 10, J ), J = 1, 4 ) / 3468, 2638, 2598,
+ $ 1241 /
+ DATA ( MM( 11, J ), J = 1, 4 ) / 688, 2344, 3406,
+ $ 1197 /
+ DATA ( MM( 12, J ), J = 1, 4 ) / 1657, 46, 2922,
+ $ 3729 /
+ DATA ( MM( 13, J ), J = 1, 4 ) / 1238, 3814, 1038,
+ $ 2501 /
+ DATA ( MM( 14, J ), J = 1, 4 ) / 3166, 913, 2934,
+ $ 1673 /
+ DATA ( MM( 15, J ), J = 1, 4 ) / 1292, 3649, 2091,
+ $ 541 /
+ DATA ( MM( 16, J ), J = 1, 4 ) / 3422, 339, 2451,
+ $ 2753 /
+ DATA ( MM( 17, J ), J = 1, 4 ) / 1270, 3808, 1580,
+ $ 949 /
+ DATA ( MM( 18, J ), J = 1, 4 ) / 2016, 822, 1958,
+ $ 2361 /
+ DATA ( MM( 19, J ), J = 1, 4 ) / 154, 2832, 2055,
+ $ 1165 /
+ DATA ( MM( 20, J ), J = 1, 4 ) / 2862, 3078, 1507,
+ $ 4081 /
+ DATA ( MM( 21, J ), J = 1, 4 ) / 697, 3633, 1078,
+ $ 2725 /
+ DATA ( MM( 22, J ), J = 1, 4 ) / 1706, 2970, 3273,
+ $ 3305 /
+ DATA ( MM( 23, J ), J = 1, 4 ) / 491, 637, 17,
+ $ 3069 /
+ DATA ( MM( 24, J ), J = 1, 4 ) / 931, 2249, 854,
+ $ 3617 /
+ DATA ( MM( 25, J ), J = 1, 4 ) / 1444, 2081, 2916,
+ $ 3733 /
+ DATA ( MM( 26, J ), J = 1, 4 ) / 444, 4019, 3971,
+ $ 409 /
+ DATA ( MM( 27, J ), J = 1, 4 ) / 3577, 1478, 2889,
+ $ 2157 /
+ DATA ( MM( 28, J ), J = 1, 4 ) / 3944, 242, 3831,
+ $ 1361 /
+ DATA ( MM( 29, J ), J = 1, 4 ) / 2184, 481, 2621,
+ $ 3973 /
+ DATA ( MM( 30, J ), J = 1, 4 ) / 1661, 2075, 1541,
+ $ 1865 /
+ DATA ( MM( 31, J ), J = 1, 4 ) / 3482, 4058, 893,
+ $ 2525 /
+ DATA ( MM( 32, J ), J = 1, 4 ) / 657, 622, 736,
+ $ 1409 /
+ DATA ( MM( 33, J ), J = 1, 4 ) / 3023, 3376, 3992,
+ $ 3445 /
+ DATA ( MM( 34, J ), J = 1, 4 ) / 3618, 812, 787,
+ $ 3577 /
+ DATA ( MM( 35, J ), J = 1, 4 ) / 1267, 234, 2125,
+ $ 77 /
+ DATA ( MM( 36, J ), J = 1, 4 ) / 1828, 641, 2364,
+ $ 3761 /
+ DATA ( MM( 37, J ), J = 1, 4 ) / 164, 4005, 2460,
+ $ 2149 /
+ DATA ( MM( 38, J ), J = 1, 4 ) / 3798, 1122, 257,
+ $ 1449 /
+ DATA ( MM( 39, J ), J = 1, 4 ) / 3087, 3135, 1574,
+ $ 3005 /
+ DATA ( MM( 40, J ), J = 1, 4 ) / 2400, 2640, 3912,
+ $ 225 /
+ DATA ( MM( 41, J ), J = 1, 4 ) / 2870, 2302, 1216,
+ $ 85 /
+ DATA ( MM( 42, J ), J = 1, 4 ) / 3876, 40, 3248,
+ $ 3673 /
+ DATA ( MM( 43, J ), J = 1, 4 ) / 1905, 1832, 3401,
+ $ 3117 /
+ DATA ( MM( 44, J ), J = 1, 4 ) / 1593, 2247, 2124,
+ $ 3089 /
+ DATA ( MM( 45, J ), J = 1, 4 ) / 1797, 2034, 2762,
+ $ 1349 /
+ DATA ( MM( 46, J ), J = 1, 4 ) / 1234, 2637, 149,
+ $ 2057 /
+ DATA ( MM( 47, J ), J = 1, 4 ) / 3460, 1287, 2245,
+ $ 413 /
+ DATA ( MM( 48, J ), J = 1, 4 ) / 328, 1691, 166,
+ $ 65 /
+ DATA ( MM( 49, J ), J = 1, 4 ) / 2861, 496, 466,
+ $ 1845 /
+ DATA ( MM( 50, J ), J = 1, 4 ) / 1950, 1597, 4018,
+ $ 697 /
+ DATA ( MM( 51, J ), J = 1, 4 ) / 617, 2394, 1399,
+ $ 3085 /
+ DATA ( MM( 52, J ), J = 1, 4 ) / 2070, 2584, 190,
+ $ 3441 /
+ DATA ( MM( 53, J ), J = 1, 4 ) / 3331, 1843, 2879,
+ $ 1573 /
+ DATA ( MM( 54, J ), J = 1, 4 ) / 769, 336, 153,
+ $ 3689 /
+ DATA ( MM( 55, J ), J = 1, 4 ) / 1558, 1472, 2320,
+ $ 2941 /
+ DATA ( MM( 56, J ), J = 1, 4 ) / 2412, 2407, 18,
+ $ 929 /
+ DATA ( MM( 57, J ), J = 1, 4 ) / 2800, 433, 712,
+ $ 533 /
+ DATA ( MM( 58, J ), J = 1, 4 ) / 189, 2096, 2159,
+ $ 2841 /
+ DATA ( MM( 59, J ), J = 1, 4 ) / 287, 1761, 2318,
+ $ 4077 /
+ DATA ( MM( 60, J ), J = 1, 4 ) / 2045, 2810, 2091,
+ $ 721 /
+ DATA ( MM( 61, J ), J = 1, 4 ) / 1227, 566, 3443,
+ $ 2821 /
+ DATA ( MM( 62, J ), J = 1, 4 ) / 2838, 442, 1510,
+ $ 2249 /
+ DATA ( MM( 63, J ), J = 1, 4 ) / 209, 41, 449,
+ $ 2397 /
+ DATA ( MM( 64, J ), J = 1, 4 ) / 2770, 1238, 1956,
+ $ 2817 /
+ DATA ( MM( 65, J ), J = 1, 4 ) / 3654, 1086, 2201,
+ $ 245 /
+ DATA ( MM( 66, J ), J = 1, 4 ) / 3993, 603, 3137,
+ $ 1913 /
+ DATA ( MM( 67, J ), J = 1, 4 ) / 192, 840, 3399,
+ $ 1997 /
+ DATA ( MM( 68, J ), J = 1, 4 ) / 2253, 3168, 1321,
+ $ 3121 /
+ DATA ( MM( 69, J ), J = 1, 4 ) / 3491, 1499, 2271,
+ $ 997 /
+ DATA ( MM( 70, J ), J = 1, 4 ) / 2889, 1084, 3667,
+ $ 1833 /
+ DATA ( MM( 71, J ), J = 1, 4 ) / 2857, 3438, 2703,
+ $ 2877 /
+ DATA ( MM( 72, J ), J = 1, 4 ) / 2094, 2408, 629,
+ $ 1633 /
+ DATA ( MM( 73, J ), J = 1, 4 ) / 1818, 1589, 2365,
+ $ 981 /
+ DATA ( MM( 74, J ), J = 1, 4 ) / 688, 2391, 2431,
+ $ 2009 /
+ DATA ( MM( 75, J ), J = 1, 4 ) / 1407, 288, 1113,
+ $ 941 /
+ DATA ( MM( 76, J ), J = 1, 4 ) / 634, 26, 3922,
+ $ 2449 /
+ DATA ( MM( 77, J ), J = 1, 4 ) / 3231, 512, 2554,
+ $ 197 /
+ DATA ( MM( 78, J ), J = 1, 4 ) / 815, 1456, 184,
+ $ 2441 /
+ DATA ( MM( 79, J ), J = 1, 4 ) / 3524, 171, 2099,
+ $ 285 /
+ DATA ( MM( 80, J ), J = 1, 4 ) / 1914, 1677, 3228,
+ $ 1473 /
+ DATA ( MM( 81, J ), J = 1, 4 ) / 516, 2657, 4012,
+ $ 2741 /
+ DATA ( MM( 82, J ), J = 1, 4 ) / 164, 2270, 1921,
+ $ 3129 /
+ DATA ( MM( 83, J ), J = 1, 4 ) / 303, 2587, 3452,
+ $ 909 /
+ DATA ( MM( 84, J ), J = 1, 4 ) / 2144, 2961, 3901,
+ $ 2801 /
+ DATA ( MM( 85, J ), J = 1, 4 ) / 3480, 1970, 572,
+ $ 421 /
+ DATA ( MM( 86, J ), J = 1, 4 ) / 119, 1817, 3309,
+ $ 4073 /
+ DATA ( MM( 87, J ), J = 1, 4 ) / 3357, 676, 3171,
+ $ 2813 /
+ DATA ( MM( 88, J ), J = 1, 4 ) / 837, 1410, 817,
+ $ 2337 /
+ DATA ( MM( 89, J ), J = 1, 4 ) / 2826, 3723, 3039,
+ $ 1429 /
+ DATA ( MM( 90, J ), J = 1, 4 ) / 2332, 2803, 1696,
+ $ 1177 /
+ DATA ( MM( 91, J ), J = 1, 4 ) / 2089, 3185, 1256,
+ $ 1901 /
+ DATA ( MM( 92, J ), J = 1, 4 ) / 3780, 184, 3715,
+ $ 81 /
+ DATA ( MM( 93, J ), J = 1, 4 ) / 1700, 663, 2077,
+ $ 1669 /
+ DATA ( MM( 94, J ), J = 1, 4 ) / 3712, 499, 3019,
+ $ 2633 /
+ DATA ( MM( 95, J ), J = 1, 4 ) / 150, 3784, 1497,
+ $ 2269 /
+ DATA ( MM( 96, J ), J = 1, 4 ) / 2000, 1631, 1101,
+ $ 129 /
+ DATA ( MM( 97, J ), J = 1, 4 ) / 3375, 1925, 717,
+ $ 1141 /
+ DATA ( MM( 98, J ), J = 1, 4 ) / 1621, 3912, 51,
+ $ 249 /
+ DATA ( MM( 99, J ), J = 1, 4 ) / 3090, 1398, 981,
+ $ 3917 /
+ DATA ( MM( 100, J ), J = 1, 4 ) / 3765, 1349, 1978,
+ $ 2481 /
+ DATA ( MM( 101, J ), J = 1, 4 ) / 1149, 1441, 1813,
+ $ 3941 /
+ DATA ( MM( 102, J ), J = 1, 4 ) / 3146, 2224, 3881,
+ $ 2217 /
+ DATA ( MM( 103, J ), J = 1, 4 ) / 33, 2411, 76,
+ $ 2749 /
+ DATA ( MM( 104, J ), J = 1, 4 ) / 3082, 1907, 3846,
+ $ 3041 /
+ DATA ( MM( 105, J ), J = 1, 4 ) / 2741, 3192, 3694,
+ $ 1877 /
+ DATA ( MM( 106, J ), J = 1, 4 ) / 359, 2786, 1682,
+ $ 345 /
+ DATA ( MM( 107, J ), J = 1, 4 ) / 3316, 382, 124,
+ $ 2861 /
+ DATA ( MM( 108, J ), J = 1, 4 ) / 1749, 37, 1660,
+ $ 1809 /
+ DATA ( MM( 109, J ), J = 1, 4 ) / 185, 759, 3997,
+ $ 3141 /
+ DATA ( MM( 110, J ), J = 1, 4 ) / 2784, 2948, 479,
+ $ 2825 /
+ DATA ( MM( 111, J ), J = 1, 4 ) / 2202, 1862, 1141,
+ $ 157 /
+ DATA ( MM( 112, J ), J = 1, 4 ) / 2199, 3802, 886,
+ $ 2881 /
+ DATA ( MM( 113, J ), J = 1, 4 ) / 1364, 2423, 3514,
+ $ 3637 /
+ DATA ( MM( 114, J ), J = 1, 4 ) / 1244, 2051, 1301,
+ $ 1465 /
+ DATA ( MM( 115, J ), J = 1, 4 ) / 2020, 2295, 3604,
+ $ 2829 /
+ DATA ( MM( 116, J ), J = 1, 4 ) / 3160, 1332, 1888,
+ $ 2161 /
+ DATA ( MM( 117, J ), J = 1, 4 ) / 2785, 1832, 1836,
+ $ 3365 /
+ DATA ( MM( 118, J ), J = 1, 4 ) / 2772, 2405, 1990,
+ $ 361 /
+ DATA ( MM( 119, J ), J = 1, 4 ) / 1217, 3638, 2058,
+ $ 2685 /
+ DATA ( MM( 120, J ), J = 1, 4 ) / 1822, 3661, 692,
+ $ 3745 /
+ DATA ( MM( 121, J ), J = 1, 4 ) / 1245, 327, 1194,
+ $ 2325 /
+ DATA ( MM( 122, J ), J = 1, 4 ) / 2252, 3660, 20,
+ $ 3609 /
+ DATA ( MM( 123, J ), J = 1, 4 ) / 3904, 716, 3285,
+ $ 3821 /
+ DATA ( MM( 124, J ), J = 1, 4 ) / 2774, 1842, 2046,
+ $ 3537 /
+ DATA ( MM( 125, J ), J = 1, 4 ) / 997, 3987, 2107,
+ $ 517 /
+ DATA ( MM( 126, J ), J = 1, 4 ) / 2573, 1368, 3508,
+ $ 3017 /
+ DATA ( MM( 127, J ), J = 1, 4 ) / 1148, 1848, 3525,
+ $ 2141 /
+ DATA ( MM( 128, J ), J = 1, 4 ) / 545, 2366, 3801,
+ $ 1537 /
+* ..
+* .. Executable Statements ..
+*
+ I1 = ISEED( 1 )
+ I2 = ISEED( 2 )
+ I3 = ISEED( 3 )
+ I4 = ISEED( 4 )
+*
+ DO 10 I = 1, MIN( N, LV )
+*
+ 20 CONTINUE
+*
+* Multiply the seed by i-th power of the multiplier modulo 2**48
+*
+ IT4 = I4*MM( I, 4 )
+ IT3 = IT4 / IPW2
+ IT4 = IT4 - IPW2*IT3
+ IT3 = IT3 + I3*MM( I, 4 ) + I4*MM( I, 3 )
+ IT2 = IT3 / IPW2
+ IT3 = IT3 - IPW2*IT2
+ IT2 = IT2 + I2*MM( I, 4 ) + I3*MM( I, 3 ) + I4*MM( I, 2 )
+ IT1 = IT2 / IPW2
+ IT2 = IT2 - IPW2*IT1
+ IT1 = IT1 + I1*MM( I, 4 ) + I2*MM( I, 3 ) + I3*MM( I, 2 ) +
+ $ I4*MM( I, 1 )
+ IT1 = MOD( IT1, IPW2 )
+*
+* Convert 48-bit integer to a real number in the interval (0,1)
+*
+ X( I ) = R*( REAL( IT1 )+R*( REAL( IT2 )+R*( REAL( IT3 )+R*
+ $ REAL( IT4 ) ) ) )
+*
+ IF (X( I ).EQ.1.0) THEN
+* If a real number has n bits of precision, and the first
+* n bits of the 48-bit integer above happen to be all 1 (which
+* will occur about once every 2**n calls), then X( I ) will
+* be rounded to exactly 1.0. In IEEE single precision arithmetic,
+* this will happen relatively often since n = 24.
+* Since X( I ) is not supposed to return exactly 0.0 or 1.0,
+* the statistically correct thing to do in this situation is
+* simply to iterate again.
+* N.B. the case X( I ) = 0.0 should not be possible.
+ I1 = I1 + 2
+ I2 = I2 + 2
+ I3 = I3 + 2
+ I4 = I4 + 2
+ GOTO 20
+ END IF
+*
+ 10 CONTINUE
+*
+* Return final value of seed
+*
+ ISEED( 1 ) = IT1
+ ISEED( 2 ) = IT2
+ ISEED( 3 ) = IT3
+ ISEED( 4 ) = IT4
+ RETURN
+*
+* End of SLARUV
+*
+ END
+ SUBROUTINE SLARZ( SIDE, M, N, L, V, INCV, TAU, C, LDC, WORK )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER SIDE
+ INTEGER INCV, L, LDC, M, N
+ REAL TAU
+* ..
+* .. Array Arguments ..
+ REAL C( LDC, * ), V( * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SLARZ applies a real elementary reflector H to a real M-by-N
+* matrix C, from either the left or the right. H is represented in the
+* form
+*
+* H = I - tau * v * v'
+*
+* where tau is a real scalar and v is a real vector.
+*
+* If tau = 0, then H is taken to be the unit matrix.
+*
+*
+* H is a product of k elementary reflectors as returned by STZRZF.
+*
+* Arguments
+* =========
+*
+* SIDE (input) CHARACTER*1
+* = 'L': form H * C
+* = 'R': form C * H
+*
+* M (input) INTEGER
+* The number of rows of the matrix C.
+*
+* N (input) INTEGER
+* The number of columns of the matrix C.
+*
+* L (input) INTEGER
+* The number of entries of the vector V containing
+* the meaningful part of the Householder vectors.
+* If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0.
+*
+* V (input) REAL array, dimension (1+(L-1)*abs(INCV))
+* The vector v in the representation of H as returned by
+* STZRZF. V is not used if TAU = 0.
+*
+* INCV (input) INTEGER
+* The increment between elements of v. INCV <> 0.
+*
+* TAU (input) REAL
+* The value tau in the representation of H.
+*
+* C (input/output) REAL array, dimension (LDC,N)
+* On entry, the M-by-N matrix C.
+* On exit, C is overwritten by the matrix H * C if SIDE = 'L',
+* or C * H if SIDE = 'R'.
+*
+* LDC (input) INTEGER
+* The leading dimension of the array C. LDC >= max(1,M).
+*
+* WORK (workspace) REAL array, dimension
+* (N) if SIDE = 'L'
+* or (M) if SIDE = 'R'
+*
+* Further Details
+* ===============
+*
+* Based on contributions by
+* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ONE, ZERO
+ PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+* ..
+* .. External Subroutines ..
+ EXTERNAL SAXPY, SCOPY, SGEMV, SGER
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. Executable Statements ..
+*
+ IF( LSAME( SIDE, 'L' ) ) THEN
+*
+* Form H * C
+*
+ IF( TAU.NE.ZERO ) THEN
+*
+* w( 1:n ) = C( 1, 1:n )
+*
+ CALL SCOPY( N, C, LDC, WORK, 1 )
+*
+* w( 1:n ) = w( 1:n ) + C( m-l+1:m, 1:n )' * v( 1:l )
+*
+ CALL SGEMV( 'Transpose', L, N, ONE, C( M-L+1, 1 ), LDC, V,
+ $ INCV, ONE, WORK, 1 )
+*
+* C( 1, 1:n ) = C( 1, 1:n ) - tau * w( 1:n )
+*
+ CALL SAXPY( N, -TAU, WORK, 1, C, LDC )
+*
+* C( m-l+1:m, 1:n ) = C( m-l+1:m, 1:n ) - ...
+* tau * v( 1:l ) * w( 1:n )'
+*
+ CALL SGER( L, N, -TAU, V, INCV, WORK, 1, C( M-L+1, 1 ),
+ $ LDC )
+ END IF
+*
+ ELSE
+*
+* Form C * H
+*
+ IF( TAU.NE.ZERO ) THEN
+*
+* w( 1:m ) = C( 1:m, 1 )
+*
+ CALL SCOPY( M, C, 1, WORK, 1 )
+*
+* w( 1:m ) = w( 1:m ) + C( 1:m, n-l+1:n, 1:n ) * v( 1:l )
+*
+ CALL SGEMV( 'No transpose', M, L, ONE, C( 1, N-L+1 ), LDC,
+ $ V, INCV, ONE, WORK, 1 )
+*
+* C( 1:m, 1 ) = C( 1:m, 1 ) - tau * w( 1:m )
+*
+ CALL SAXPY( M, -TAU, WORK, 1, C, 1 )
+*
+* C( 1:m, n-l+1:n ) = C( 1:m, n-l+1:n ) - ...
+* tau * w( 1:m ) * v( 1:l )'
+*
+ CALL SGER( M, L, -TAU, WORK, 1, V, INCV, C( 1, N-L+1 ),
+ $ LDC )
+*
+ END IF
+*
+ END IF
+*
+ RETURN
+*
+* End of SLARZ
+*
+ END
+ SUBROUTINE SLARZB( SIDE, TRANS, DIRECT, STOREV, M, N, K, L, V,
+ $ LDV, T, LDT, C, LDC, WORK, LDWORK )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER DIRECT, SIDE, STOREV, TRANS
+ INTEGER K, L, LDC, LDT, LDV, LDWORK, M, N
+* ..
+* .. Array Arguments ..
+ REAL C( LDC, * ), T( LDT, * ), V( LDV, * ),
+ $ WORK( LDWORK, * )
+* ..
+*
+* Purpose
+* =======
+*
+* SLARZB applies a real block reflector H or its transpose H**T to
+* a real distributed M-by-N C from the left or the right.
+*
+* Currently, only STOREV = 'R' and DIRECT = 'B' are supported.
+*
+* Arguments
+* =========
+*
+* SIDE (input) CHARACTER*1
+* = 'L': apply H or H' from the Left
+* = 'R': apply H or H' from the Right
+*
+* TRANS (input) CHARACTER*1
+* = 'N': apply H (No transpose)
+* = 'C': apply H' (Transpose)
+*
+* DIRECT (input) CHARACTER*1
+* Indicates how H is formed from a product of elementary
+* reflectors
+* = 'F': H = H(1) H(2) . . . H(k) (Forward, not supported yet)
+* = 'B': H = H(k) . . . H(2) H(1) (Backward)
+*
+* STOREV (input) CHARACTER*1
+* Indicates how the vectors which define the elementary
+* reflectors are stored:
+* = 'C': Columnwise (not supported yet)
+* = 'R': Rowwise
+*
+* M (input) INTEGER
+* The number of rows of the matrix C.
+*
+* N (input) INTEGER
+* The number of columns of the matrix C.
+*
+* K (input) INTEGER
+* The order of the matrix T (= the number of elementary
+* reflectors whose product defines the block reflector).
+*
+* L (input) INTEGER
+* The number of columns of the matrix V containing the
+* meaningful part of the Householder reflectors.
+* If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0.
+*
+* V (input) REAL array, dimension (LDV,NV).
+* If STOREV = 'C', NV = K; if STOREV = 'R', NV = L.
+*
+* LDV (input) INTEGER
+* The leading dimension of the array V.
+* If STOREV = 'C', LDV >= L; if STOREV = 'R', LDV >= K.
+*
+* T (input) REAL array, dimension (LDT,K)
+* The triangular K-by-K matrix T in the representation of the
+* block reflector.
+*
+* LDT (input) INTEGER
+* The leading dimension of the array T. LDT >= K.
+*
+* C (input/output) REAL array, dimension (LDC,N)
+* On entry, the M-by-N matrix C.
+* On exit, C is overwritten by H*C or H'*C or C*H or C*H'.
+*
+* LDC (input) INTEGER
+* The leading dimension of the array C. LDC >= max(1,M).
+*
+* WORK (workspace) REAL array, dimension (LDWORK,K)
+*
+* LDWORK (input) INTEGER
+* The leading dimension of the array WORK.
+* If SIDE = 'L', LDWORK >= max(1,N);
+* if SIDE = 'R', LDWORK >= max(1,M).
+*
+* Further Details
+* ===============
+*
+* Based on contributions by
+* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ONE
+ PARAMETER ( ONE = 1.0E+0 )
+* ..
+* .. Local Scalars ..
+ CHARACTER TRANST
+ INTEGER I, INFO, J
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL SCOPY, SGEMM, STRMM, XERBLA
+* ..
+* .. Executable Statements ..
+*
+* Quick return if possible
+*
+ IF( M.LE.0 .OR. N.LE.0 )
+ $ RETURN
+*
+* Check for currently supported options
+*
+ INFO = 0
+ IF( .NOT.LSAME( DIRECT, 'B' ) ) THEN
+ INFO = -3
+ ELSE IF( .NOT.LSAME( STOREV, 'R' ) ) THEN
+ INFO = -4
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SLARZB', -INFO )
+ RETURN
+ END IF
+*
+ IF( LSAME( TRANS, 'N' ) ) THEN
+ TRANST = 'T'
+ ELSE
+ TRANST = 'N'
+ END IF
+*
+ IF( LSAME( SIDE, 'L' ) ) THEN
+*
+* Form H * C or H' * C
+*
+* W( 1:n, 1:k ) = C( 1:k, 1:n )'
+*
+ DO 10 J = 1, K
+ CALL SCOPY( N, C( J, 1 ), LDC, WORK( 1, J ), 1 )
+ 10 CONTINUE
+*
+* W( 1:n, 1:k ) = W( 1:n, 1:k ) + ...
+* C( m-l+1:m, 1:n )' * V( 1:k, 1:l )'
+*
+ IF( L.GT.0 )
+ $ CALL SGEMM( 'Transpose', 'Transpose', N, K, L, ONE,
+ $ C( M-L+1, 1 ), LDC, V, LDV, ONE, WORK, LDWORK )
+*
+* W( 1:n, 1:k ) = W( 1:n, 1:k ) * T' or W( 1:m, 1:k ) * T
+*
+ CALL STRMM( 'Right', 'Lower', TRANST, 'Non-unit', N, K, ONE, T,
+ $ LDT, WORK, LDWORK )
+*
+* C( 1:k, 1:n ) = C( 1:k, 1:n ) - W( 1:n, 1:k )'
+*
+ DO 30 J = 1, N
+ DO 20 I = 1, K
+ C( I, J ) = C( I, J ) - WORK( J, I )
+ 20 CONTINUE
+ 30 CONTINUE
+*
+* C( m-l+1:m, 1:n ) = C( m-l+1:m, 1:n ) - ...
+* V( 1:k, 1:l )' * W( 1:n, 1:k )'
+*
+ IF( L.GT.0 )
+ $ CALL SGEMM( 'Transpose', 'Transpose', L, N, K, -ONE, V, LDV,
+ $ WORK, LDWORK, ONE, C( M-L+1, 1 ), LDC )
+*
+ ELSE IF( LSAME( SIDE, 'R' ) ) THEN
+*
+* Form C * H or C * H'
+*
+* W( 1:m, 1:k ) = C( 1:m, 1:k )
+*
+ DO 40 J = 1, K
+ CALL SCOPY( M, C( 1, J ), 1, WORK( 1, J ), 1 )
+ 40 CONTINUE
+*
+* W( 1:m, 1:k ) = W( 1:m, 1:k ) + ...
+* C( 1:m, n-l+1:n ) * V( 1:k, 1:l )'
+*
+ IF( L.GT.0 )
+ $ CALL SGEMM( 'No transpose', 'Transpose', M, K, L, ONE,
+ $ C( 1, N-L+1 ), LDC, V, LDV, ONE, WORK, LDWORK )
+*
+* W( 1:m, 1:k ) = W( 1:m, 1:k ) * T or W( 1:m, 1:k ) * T'
+*
+ CALL STRMM( 'Right', 'Lower', TRANS, 'Non-unit', M, K, ONE, T,
+ $ LDT, WORK, LDWORK )
+*
+* C( 1:m, 1:k ) = C( 1:m, 1:k ) - W( 1:m, 1:k )
+*
+ DO 60 J = 1, K
+ DO 50 I = 1, M
+ C( I, J ) = C( I, J ) - WORK( I, J )
+ 50 CONTINUE
+ 60 CONTINUE
+*
+* C( 1:m, n-l+1:n ) = C( 1:m, n-l+1:n ) - ...
+* W( 1:m, 1:k ) * V( 1:k, 1:l )
+*
+ IF( L.GT.0 )
+ $ CALL SGEMM( 'No transpose', 'No transpose', M, L, K, -ONE,
+ $ WORK, LDWORK, V, LDV, ONE, C( 1, N-L+1 ), LDC )
+*
+ END IF
+*
+ RETURN
+*
+* End of SLARZB
+*
+ END
+ SUBROUTINE SLARZT( DIRECT, STOREV, N, K, V, LDV, TAU, T, LDT )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER DIRECT, STOREV
+ INTEGER K, LDT, LDV, N
+* ..
+* .. Array Arguments ..
+ REAL T( LDT, * ), TAU( * ), V( LDV, * )
+* ..
+*
+* Purpose
+* =======
+*
+* SLARZT forms the triangular factor T of a real block reflector
+* H of order > n, which is defined as a product of k elementary
+* reflectors.
+*
+* If DIRECT = 'F', H = H(1) H(2) . . . H(k) and T is upper triangular;
+*
+* If DIRECT = 'B', H = H(k) . . . H(2) H(1) and T is lower triangular.
+*
+* If STOREV = 'C', the vector which defines the elementary reflector
+* H(i) is stored in the i-th column of the array V, and
+*
+* H = I - V * T * V'
+*
+* If STOREV = 'R', the vector which defines the elementary reflector
+* H(i) is stored in the i-th row of the array V, and
+*
+* H = I - V' * T * V
+*
+* Currently, only STOREV = 'R' and DIRECT = 'B' are supported.
+*
+* Arguments
+* =========
+*
+* DIRECT (input) CHARACTER*1
+* Specifies the order in which the elementary reflectors are
+* multiplied to form the block reflector:
+* = 'F': H = H(1) H(2) . . . H(k) (Forward, not supported yet)
+* = 'B': H = H(k) . . . H(2) H(1) (Backward)
+*
+* STOREV (input) CHARACTER*1
+* Specifies how the vectors which define the elementary
+* reflectors are stored (see also Further Details):
+* = 'C': columnwise (not supported yet)
+* = 'R': rowwise
+*
+* N (input) INTEGER
+* The order of the block reflector H. N >= 0.
+*
+* K (input) INTEGER
+* The order of the triangular factor T (= the number of
+* elementary reflectors). K >= 1.
+*
+* V (input/output) REAL array, dimension
+* (LDV,K) if STOREV = 'C'
+* (LDV,N) if STOREV = 'R'
+* The matrix V. See further details.
+*
+* LDV (input) INTEGER
+* The leading dimension of the array V.
+* If STOREV = 'C', LDV >= max(1,N); if STOREV = 'R', LDV >= K.
+*
+* TAU (input) REAL array, dimension (K)
+* TAU(i) must contain the scalar factor of the elementary
+* reflector H(i).
+*
+* T (output) REAL array, dimension (LDT,K)
+* The k by k triangular factor T of the block reflector.
+* If DIRECT = 'F', T is upper triangular; if DIRECT = 'B', T is
+* lower triangular. The rest of the array is not used.
+*
+* LDT (input) INTEGER
+* The leading dimension of the array T. LDT >= K.
+*
+* Further Details
+* ===============
+*
+* Based on contributions by
+* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA
+*
+* The shape of the matrix V and the storage of the vectors which define
+* the H(i) is best illustrated by the following example with n = 5 and
+* k = 3. The elements equal to 1 are not stored; the corresponding
+* array elements are modified but restored on exit. The rest of the
+* array is not used.
+*
+* DIRECT = 'F' and STOREV = 'C': DIRECT = 'F' and STOREV = 'R':
+*
+* ______V_____
+* ( v1 v2 v3 ) / \
+* ( v1 v2 v3 ) ( v1 v1 v1 v1 v1 . . . . 1 )
+* V = ( v1 v2 v3 ) ( v2 v2 v2 v2 v2 . . . 1 )
+* ( v1 v2 v3 ) ( v3 v3 v3 v3 v3 . . 1 )
+* ( v1 v2 v3 )
+* . . .
+* . . .
+* 1 . .
+* 1 .
+* 1
+*
+* DIRECT = 'B' and STOREV = 'C': DIRECT = 'B' and STOREV = 'R':
+*
+* ______V_____
+* 1 / \
+* . 1 ( 1 . . . . v1 v1 v1 v1 v1 )
+* . . 1 ( . 1 . . . v2 v2 v2 v2 v2 )
+* . . . ( . . 1 . . v3 v3 v3 v3 v3 )
+* . . .
+* ( v1 v2 v3 )
+* ( v1 v2 v3 )
+* V = ( v1 v2 v3 )
+* ( v1 v2 v3 )
+* ( v1 v2 v3 )
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO
+ PARAMETER ( ZERO = 0.0E+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, INFO, J
+* ..
+* .. External Subroutines ..
+ EXTERNAL SGEMV, STRMV, XERBLA
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. Executable Statements ..
+*
+* Check for currently supported options
+*
+ INFO = 0
+ IF( .NOT.LSAME( DIRECT, 'B' ) ) THEN
+ INFO = -1
+ ELSE IF( .NOT.LSAME( STOREV, 'R' ) ) THEN
+ INFO = -2
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SLARZT', -INFO )
+ RETURN
+ END IF
+*
+ DO 20 I = K, 1, -1
+ IF( TAU( I ).EQ.ZERO ) THEN
+*
+* H(i) = I
+*
+ DO 10 J = I, K
+ T( J, I ) = ZERO
+ 10 CONTINUE
+ ELSE
+*
+* general case
+*
+ IF( I.LT.K ) THEN
+*
+* T(i+1:k,i) = - tau(i) * V(i+1:k,1:n) * V(i,1:n)'
+*
+ CALL SGEMV( 'No transpose', K-I, N, -TAU( I ),
+ $ V( I+1, 1 ), LDV, V( I, 1 ), LDV, ZERO,
+ $ T( I+1, I ), 1 )
+*
+* T(i+1:k,i) = T(i+1:k,i+1:k) * T(i+1:k,i)
+*
+ CALL STRMV( 'Lower', 'No transpose', 'Non-unit', K-I,
+ $ T( I+1, I+1 ), LDT, T( I+1, I ), 1 )
+ END IF
+ T( I, I ) = TAU( I )
+ END IF
+ 20 CONTINUE
+ RETURN
+*
+* End of SLARZT
+*
+ END
+ SUBROUTINE SLAS2( F, G, H, SSMIN, SSMAX )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ REAL F, G, H, SSMAX, SSMIN
+* ..
+*
+* Purpose
+* =======
+*
+* SLAS2 computes the singular values of the 2-by-2 matrix
+* [ F G ]
+* [ 0 H ].
+* On return, SSMIN is the smaller singular value and SSMAX is the
+* larger singular value.
+*
+* Arguments
+* =========
+*
+* F (input) REAL
+* The (1,1) element of the 2-by-2 matrix.
+*
+* G (input) REAL
+* The (1,2) element of the 2-by-2 matrix.
+*
+* H (input) REAL
+* The (2,2) element of the 2-by-2 matrix.
+*
+* SSMIN (output) REAL
+* The smaller singular value.
+*
+* SSMAX (output) REAL
+* The larger singular value.
+*
+* Further Details
+* ===============
+*
+* Barring over/underflow, all output quantities are correct to within
+* a few units in the last place (ulps), even in the absence of a guard
+* digit in addition/subtraction.
+*
+* In IEEE arithmetic, the code works correctly if one matrix element is
+* infinite.
+*
+* Overflow will not occur unless the largest singular value itself
+* overflows, or is within a few ulps of overflow. (On machines with
+* partial overflow, like the Cray, overflow may occur if the largest
+* singular value is within a factor of 2 of overflow.)
+*
+* Underflow is harmless if underflow is gradual. Otherwise, results
+* may correspond to a matrix modified by perturbations of size near
+* the underflow threshold.
+*
+* ====================================================================
+*
+* .. Parameters ..
+ REAL ZERO
+ PARAMETER ( ZERO = 0.0E0 )
+ REAL ONE
+ PARAMETER ( ONE = 1.0E0 )
+ REAL TWO
+ PARAMETER ( TWO = 2.0E0 )
+* ..
+* .. Local Scalars ..
+ REAL AS, AT, AU, C, FA, FHMN, FHMX, GA, HA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, MIN, SQRT
+* ..
+* .. Executable Statements ..
+*
+ FA = ABS( F )
+ GA = ABS( G )
+ HA = ABS( H )
+ FHMN = MIN( FA, HA )
+ FHMX = MAX( FA, HA )
+ IF( FHMN.EQ.ZERO ) THEN
+ SSMIN = ZERO
+ IF( FHMX.EQ.ZERO ) THEN
+ SSMAX = GA
+ ELSE
+ SSMAX = MAX( FHMX, GA )*SQRT( ONE+
+ $ ( MIN( FHMX, GA ) / MAX( FHMX, GA ) )**2 )
+ END IF
+ ELSE
+ IF( GA.LT.FHMX ) THEN
+ AS = ONE + FHMN / FHMX
+ AT = ( FHMX-FHMN ) / FHMX
+ AU = ( GA / FHMX )**2
+ C = TWO / ( SQRT( AS*AS+AU )+SQRT( AT*AT+AU ) )
+ SSMIN = FHMN*C
+ SSMAX = FHMX / C
+ ELSE
+ AU = FHMX / GA
+ IF( AU.EQ.ZERO ) THEN
+*
+* Avoid possible harmful underflow if exponent range
+* asymmetric (true SSMIN may not underflow even if
+* AU underflows)
+*
+ SSMIN = ( FHMN*FHMX ) / GA
+ SSMAX = GA
+ ELSE
+ AS = ONE + FHMN / FHMX
+ AT = ( FHMX-FHMN ) / FHMX
+ C = ONE / ( SQRT( ONE+( AS*AU )**2 )+
+ $ SQRT( ONE+( AT*AU )**2 ) )
+ SSMIN = ( FHMN*C )*AU
+ SSMIN = SSMIN + SSMIN
+ SSMAX = GA / ( C+C )
+ END IF
+ END IF
+ END IF
+ RETURN
+*
+* End of SLAS2
+*
+ END
+ SUBROUTINE SLASCL( TYPE, KL, KU, CFROM, CTO, M, N, A, LDA, INFO )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER TYPE
+ INTEGER INFO, KL, KU, LDA, M, N
+ REAL CFROM, CTO
+* ..
+* .. Array Arguments ..
+ REAL A( LDA, * )
+* ..
+*
+* Purpose
+* =======
+*
+* SLASCL multiplies the M by N real matrix A by the real scalar
+* CTO/CFROM. This is done without over/underflow as long as the final
+* result CTO*A(I,J)/CFROM does not over/underflow. TYPE specifies that
+* A may be full, upper triangular, lower triangular, upper Hessenberg,
+* or banded.
+*
+* Arguments
+* =========
+*
+* TYPE (input) CHARACTER*1
+* TYPE indices the storage type of the input matrix.
+* = 'G': A is a full matrix.
+* = 'L': A is a lower triangular matrix.
+* = 'U': A is an upper triangular matrix.
+* = 'H': A is an upper Hessenberg matrix.
+* = 'B': A is a symmetric band matrix with lower bandwidth KL
+* and upper bandwidth KU and with the only the lower
+* half stored.
+* = 'Q': A is a symmetric band matrix with lower bandwidth KL
+* and upper bandwidth KU and with the only the upper
+* half stored.
+* = 'Z': A is a band matrix with lower bandwidth KL and upper
+* bandwidth KU.
+*
+* KL (input) INTEGER
+* The lower bandwidth of A. Referenced only if TYPE = 'B',
+* 'Q' or 'Z'.
+*
+* KU (input) INTEGER
+* The upper bandwidth of A. Referenced only if TYPE = 'B',
+* 'Q' or 'Z'.
+*
+* CFROM (input) REAL
+* CTO (input) REAL
+* The matrix A is multiplied by CTO/CFROM. A(I,J) is computed
+* without over/underflow if the final result CTO*A(I,J)/CFROM
+* can be represented without over/underflow. CFROM must be
+* nonzero.
+*
+* M (input) INTEGER
+* The number of rows of the matrix A. M >= 0.
+*
+* N (input) INTEGER
+* The number of columns of the matrix A. N >= 0.
+*
+* A (input/output) REAL array, dimension (LDA,N)
+* The matrix to be multiplied by CTO/CFROM. See TYPE for the
+* storage type.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,M).
+*
+* INFO (output) INTEGER
+* 0 - successful exit
+* <0 - if INFO = -i, the i-th argument had an illegal value.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO, ONE
+ PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL DONE
+ INTEGER I, ITYPE, J, K1, K2, K3, K4
+ REAL BIGNUM, CFROM1, CFROMC, CTO1, CTOC, MUL, SMLNUM
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ REAL SLAMCH
+ EXTERNAL LSAME, SLAMCH
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, MIN
+* ..
+* .. External Subroutines ..
+ EXTERNAL XERBLA
+* ..
+* .. Executable Statements ..
+*
+* Test the input arguments
+*
+ INFO = 0
+*
+ IF( LSAME( TYPE, 'G' ) ) THEN
+ ITYPE = 0
+ ELSE IF( LSAME( TYPE, 'L' ) ) THEN
+ ITYPE = 1
+ ELSE IF( LSAME( TYPE, 'U' ) ) THEN
+ ITYPE = 2
+ ELSE IF( LSAME( TYPE, 'H' ) ) THEN
+ ITYPE = 3
+ ELSE IF( LSAME( TYPE, 'B' ) ) THEN
+ ITYPE = 4
+ ELSE IF( LSAME( TYPE, 'Q' ) ) THEN
+ ITYPE = 5
+ ELSE IF( LSAME( TYPE, 'Z' ) ) THEN
+ ITYPE = 6
+ ELSE
+ ITYPE = -1
+ END IF
+*
+ IF( ITYPE.EQ.-1 ) THEN
+ INFO = -1
+ ELSE IF( CFROM.EQ.ZERO ) THEN
+ INFO = -4
+ ELSE IF( M.LT.0 ) THEN
+ INFO = -6
+ ELSE IF( N.LT.0 .OR. ( ITYPE.EQ.4 .AND. N.NE.M ) .OR.
+ $ ( ITYPE.EQ.5 .AND. N.NE.M ) ) THEN
+ INFO = -7
+ ELSE IF( ITYPE.LE.3 .AND. LDA.LT.MAX( 1, M ) ) THEN
+ INFO = -9
+ ELSE IF( ITYPE.GE.4 ) THEN
+ IF( KL.LT.0 .OR. KL.GT.MAX( M-1, 0 ) ) THEN
+ INFO = -2
+ ELSE IF( KU.LT.0 .OR. KU.GT.MAX( N-1, 0 ) .OR.
+ $ ( ( ITYPE.EQ.4 .OR. ITYPE.EQ.5 ) .AND. KL.NE.KU ) )
+ $ THEN
+ INFO = -3
+ ELSE IF( ( ITYPE.EQ.4 .AND. LDA.LT.KL+1 ) .OR.
+ $ ( ITYPE.EQ.5 .AND. LDA.LT.KU+1 ) .OR.
+ $ ( ITYPE.EQ.6 .AND. LDA.LT.2*KL+KU+1 ) ) THEN
+ INFO = -9
+ END IF
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SLASCL', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 .OR. M.EQ.0 )
+ $ RETURN
+*
+* Get machine parameters
+*
+ SMLNUM = SLAMCH( 'S' )
+ BIGNUM = ONE / SMLNUM
+*
+ CFROMC = CFROM
+ CTOC = CTO
+*
+ 10 CONTINUE
+ CFROM1 = CFROMC*SMLNUM
+ CTO1 = CTOC / BIGNUM
+ IF( ABS( CFROM1 ).GT.ABS( CTOC ) .AND. CTOC.NE.ZERO ) THEN
+ MUL = SMLNUM
+ DONE = .FALSE.
+ CFROMC = CFROM1
+ ELSE IF( ABS( CTO1 ).GT.ABS( CFROMC ) ) THEN
+ MUL = BIGNUM
+ DONE = .FALSE.
+ CTOC = CTO1
+ ELSE
+ MUL = CTOC / CFROMC
+ DONE = .TRUE.
+ END IF
+*
+ IF( ITYPE.EQ.0 ) THEN
+*
+* Full matrix
+*
+ DO 30 J = 1, N
+ DO 20 I = 1, M
+ A( I, J ) = A( I, J )*MUL
+ 20 CONTINUE
+ 30 CONTINUE
+*
+ ELSE IF( ITYPE.EQ.1 ) THEN
+*
+* Lower triangular matrix
+*
+ DO 50 J = 1, N
+ DO 40 I = J, M
+ A( I, J ) = A( I, J )*MUL
+ 40 CONTINUE
+ 50 CONTINUE
+*
+ ELSE IF( ITYPE.EQ.2 ) THEN
+*
+* Upper triangular matrix
+*
+ DO 70 J = 1, N
+ DO 60 I = 1, MIN( J, M )
+ A( I, J ) = A( I, J )*MUL
+ 60 CONTINUE
+ 70 CONTINUE
+*
+ ELSE IF( ITYPE.EQ.3 ) THEN
+*
+* Upper Hessenberg matrix
+*
+ DO 90 J = 1, N
+ DO 80 I = 1, MIN( J+1, M )
+ A( I, J ) = A( I, J )*MUL
+ 80 CONTINUE
+ 90 CONTINUE
+*
+ ELSE IF( ITYPE.EQ.4 ) THEN
+*
+* Lower half of a symmetric band matrix
+*
+ K3 = KL + 1
+ K4 = N + 1
+ DO 110 J = 1, N
+ DO 100 I = 1, MIN( K3, K4-J )
+ A( I, J ) = A( I, J )*MUL
+ 100 CONTINUE
+ 110 CONTINUE
+*
+ ELSE IF( ITYPE.EQ.5 ) THEN
+*
+* Upper half of a symmetric band matrix
+*
+ K1 = KU + 2
+ K3 = KU + 1
+ DO 130 J = 1, N
+ DO 120 I = MAX( K1-J, 1 ), K3
+ A( I, J ) = A( I, J )*MUL
+ 120 CONTINUE
+ 130 CONTINUE
+*
+ ELSE IF( ITYPE.EQ.6 ) THEN
+*
+* Band matrix
+*
+ K1 = KL + KU + 2
+ K2 = KL + 1
+ K3 = 2*KL + KU + 1
+ K4 = KL + KU + 1 + M
+ DO 150 J = 1, N
+ DO 140 I = MAX( K1-J, K2 ), MIN( K3, K4-J )
+ A( I, J ) = A( I, J )*MUL
+ 140 CONTINUE
+ 150 CONTINUE
+*
+ END IF
+*
+ IF( .NOT.DONE )
+ $ GO TO 10
+*
+ RETURN
+*
+* End of SLASCL
+*
+ END
+ SUBROUTINE SLASD0( N, SQRE, D, E, U, LDU, VT, LDVT, SMLSIZ, IWORK,
+ $ WORK, INFO )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LDU, LDVT, N, SMLSIZ, SQRE
+* ..
+* .. Array Arguments ..
+ INTEGER IWORK( * )
+ REAL D( * ), E( * ), U( LDU, * ), VT( LDVT, * ),
+ $ WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* Using a divide and conquer approach, SLASD0 computes the singular
+* value decomposition (SVD) of a real upper bidiagonal N-by-M
+* matrix B with diagonal D and offdiagonal E, where M = N + SQRE.
+* The algorithm computes orthogonal matrices U and VT such that
+* B = U * S * VT. The singular values S are overwritten on D.
+*
+* A related subroutine, SLASDA, computes only the singular values,
+* and optionally, the singular vectors in compact form.
+*
+* Arguments
+* =========
+*
+* N (input) INTEGER
+* On entry, the row dimension of the upper bidiagonal matrix.
+* This is also the dimension of the main diagonal array D.
+*
+* SQRE (input) INTEGER
+* Specifies the column dimension of the bidiagonal matrix.
+* = 0: The bidiagonal matrix has column dimension M = N;
+* = 1: The bidiagonal matrix has column dimension M = N+1;
+*
+* D (input/output) REAL array, dimension (N)
+* On entry D contains the main diagonal of the bidiagonal
+* matrix.
+* On exit D, if INFO = 0, contains its singular values.
+*
+* E (input) REAL array, dimension (M-1)
+* Contains the subdiagonal entries of the bidiagonal matrix.
+* On exit, E has been destroyed.
+*
+* U (output) REAL array, dimension at least (LDQ, N)
+* On exit, U contains the left singular vectors.
+*
+* LDU (input) INTEGER
+* On entry, leading dimension of U.
+*
+* VT (output) REAL array, dimension at least (LDVT, M)
+* On exit, VT' contains the right singular vectors.
+*
+* LDVT (input) INTEGER
+* On entry, leading dimension of VT.
+*
+* SMLSIZ (input) INTEGER
+* On entry, maximum size of the subproblems at the
+* bottom of the computation tree.
+*
+* IWORK (workspace) INTEGER array, dimension (8*N)
+*
+* WORK (workspace) REAL array, dimension (3*M**2+2*M)
+*
+* INFO (output) INTEGER
+* = 0: successful exit.
+* < 0: if INFO = -i, the i-th argument had an illegal value.
+* > 0: if INFO = 1, an singular value did not converge
+*
+* Further Details
+* ===============
+*
+* Based on contributions by
+* Ming Gu and Huan Ren, Computer Science Division, University of
+* California at Berkeley, USA
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ INTEGER I, I1, IC, IDXQ, IDXQC, IM1, INODE, ITEMP, IWK,
+ $ J, LF, LL, LVL, M, NCC, ND, NDB1, NDIML, NDIMR,
+ $ NL, NLF, NLP1, NLVL, NR, NRF, NRP1, SQREI
+ REAL ALPHA, BETA
+* ..
+* .. External Subroutines ..
+ EXTERNAL SLASD1, SLASDQ, SLASDT, XERBLA
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+*
+ IF( N.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( ( SQRE.LT.0 ) .OR. ( SQRE.GT.1 ) ) THEN
+ INFO = -2
+ END IF
+*
+ M = N + SQRE
+*
+ IF( LDU.LT.N ) THEN
+ INFO = -6
+ ELSE IF( LDVT.LT.M ) THEN
+ INFO = -8
+ ELSE IF( SMLSIZ.LT.3 ) THEN
+ INFO = -9
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SLASD0', -INFO )
+ RETURN
+ END IF
+*
+* If the input matrix is too small, call SLASDQ to find the SVD.
+*
+ IF( N.LE.SMLSIZ ) THEN
+ CALL SLASDQ( 'U', SQRE, N, M, N, 0, D, E, VT, LDVT, U, LDU, U,
+ $ LDU, WORK, INFO )
+ RETURN
+ END IF
+*
+* Set up the computation tree.
+*
+ INODE = 1
+ NDIML = INODE + N
+ NDIMR = NDIML + N
+ IDXQ = NDIMR + N
+ IWK = IDXQ + N
+ CALL SLASDT( N, NLVL, ND, IWORK( INODE ), IWORK( NDIML ),
+ $ IWORK( NDIMR ), SMLSIZ )
+*
+* For the nodes on bottom level of the tree, solve
+* their subproblems by SLASDQ.
+*
+ NDB1 = ( ND+1 ) / 2
+ NCC = 0
+ DO 30 I = NDB1, ND
+*
+* IC : center row of each node
+* NL : number of rows of left subproblem
+* NR : number of rows of right subproblem
+* NLF: starting row of the left subproblem
+* NRF: starting row of the right subproblem
+*
+ I1 = I - 1
+ IC = IWORK( INODE+I1 )
+ NL = IWORK( NDIML+I1 )
+ NLP1 = NL + 1
+ NR = IWORK( NDIMR+I1 )
+ NRP1 = NR + 1
+ NLF = IC - NL
+ NRF = IC + 1
+ SQREI = 1
+ CALL SLASDQ( 'U', SQREI, NL, NLP1, NL, NCC, D( NLF ), E( NLF ),
+ $ VT( NLF, NLF ), LDVT, U( NLF, NLF ), LDU,
+ $ U( NLF, NLF ), LDU, WORK, INFO )
+ IF( INFO.NE.0 ) THEN
+ RETURN
+ END IF
+ ITEMP = IDXQ + NLF - 2
+ DO 10 J = 1, NL
+ IWORK( ITEMP+J ) = J
+ 10 CONTINUE
+ IF( I.EQ.ND ) THEN
+ SQREI = SQRE
+ ELSE
+ SQREI = 1
+ END IF
+ NRP1 = NR + SQREI
+ CALL SLASDQ( 'U', SQREI, NR, NRP1, NR, NCC, D( NRF ), E( NRF ),
+ $ VT( NRF, NRF ), LDVT, U( NRF, NRF ), LDU,
+ $ U( NRF, NRF ), LDU, WORK, INFO )
+ IF( INFO.NE.0 ) THEN
+ RETURN
+ END IF
+ ITEMP = IDXQ + IC
+ DO 20 J = 1, NR
+ IWORK( ITEMP+J-1 ) = J
+ 20 CONTINUE
+ 30 CONTINUE
+*
+* Now conquer each subproblem bottom-up.
+*
+ DO 50 LVL = NLVL, 1, -1
+*
+* Find the first node LF and last node LL on the
+* current level LVL.
+*
+ IF( LVL.EQ.1 ) THEN
+ LF = 1
+ LL = 1
+ ELSE
+ LF = 2**( LVL-1 )
+ LL = 2*LF - 1
+ END IF
+ DO 40 I = LF, LL
+ IM1 = I - 1
+ IC = IWORK( INODE+IM1 )
+ NL = IWORK( NDIML+IM1 )
+ NR = IWORK( NDIMR+IM1 )
+ NLF = IC - NL
+ IF( ( SQRE.EQ.0 ) .AND. ( I.EQ.LL ) ) THEN
+ SQREI = SQRE
+ ELSE
+ SQREI = 1
+ END IF
+ IDXQC = IDXQ + NLF - 1
+ ALPHA = D( IC )
+ BETA = E( IC )
+ CALL SLASD1( NL, NR, SQREI, D( NLF ), ALPHA, BETA,
+ $ U( NLF, NLF ), LDU, VT( NLF, NLF ), LDVT,
+ $ IWORK( IDXQC ), IWORK( IWK ), WORK, INFO )
+ IF( INFO.NE.0 ) THEN
+ RETURN
+ END IF
+ 40 CONTINUE
+ 50 CONTINUE
+*
+ RETURN
+*
+* End of SLASD0
+*
+ END
+ SUBROUTINE SLASD1( NL, NR, SQRE, D, ALPHA, BETA, U, LDU, VT, LDVT,
+ $ IDXQ, IWORK, WORK, INFO )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LDU, LDVT, NL, NR, SQRE
+ REAL ALPHA, BETA
+* ..
+* .. Array Arguments ..
+ INTEGER IDXQ( * ), IWORK( * )
+ REAL D( * ), U( LDU, * ), VT( LDVT, * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SLASD1 computes the SVD of an upper bidiagonal N-by-M matrix B,
+* where N = NL + NR + 1 and M = N + SQRE. SLASD1 is called from SLASD0.
+*
+* A related subroutine SLASD7 handles the case in which the singular
+* values (and the singular vectors in factored form) are desired.
+*
+* SLASD1 computes the SVD as follows:
+*
+* ( D1(in) 0 0 0 )
+* B = U(in) * ( Z1' a Z2' b ) * VT(in)
+* ( 0 0 D2(in) 0 )
+*
+* = U(out) * ( D(out) 0) * VT(out)
+*
+* where Z' = (Z1' a Z2' b) = u' VT', and u is a vector of dimension M
+* with ALPHA and BETA in the NL+1 and NL+2 th entries and zeros
+* elsewhere; and the entry b is empty if SQRE = 0.
+*
+* The left singular vectors of the original matrix are stored in U, and
+* the transpose of the right singular vectors are stored in VT, and the
+* singular values are in D. The algorithm consists of three stages:
+*
+* The first stage consists of deflating the size of the problem
+* when there are multiple singular values or when there are zeros in
+* the Z vector. For each such occurence the dimension of the
+* secular equation problem is reduced by one. This stage is
+* performed by the routine SLASD2.
+*
+* The second stage consists of calculating the updated
+* singular values. This is done by finding the square roots of the
+* roots of the secular equation via the routine SLASD4 (as called
+* by SLASD3). This routine also calculates the singular vectors of
+* the current problem.
+*
+* The final stage consists of computing the updated singular vectors
+* directly using the updated singular values. The singular vectors
+* for the current problem are multiplied with the singular vectors
+* from the overall problem.
+*
+* Arguments
+* =========
+*
+* NL (input) INTEGER
+* The row dimension of the upper block. NL >= 1.
+*
+* NR (input) INTEGER
+* The row dimension of the lower block. NR >= 1.
+*
+* SQRE (input) INTEGER
+* = 0: the lower block is an NR-by-NR square matrix.
+* = 1: the lower block is an NR-by-(NR+1) rectangular matrix.
+*
+* The bidiagonal matrix has row dimension N = NL + NR + 1,
+* and column dimension M = N + SQRE.
+*
+* D (input/output) REAL array, dimension (NL+NR+1).
+* N = NL+NR+1
+* On entry D(1:NL,1:NL) contains the singular values of the
+* upper block; and D(NL+2:N) contains the singular values of
+* the lower block. On exit D(1:N) contains the singular values
+* of the modified matrix.
+*
+* ALPHA (input/output) REAL
+* Contains the diagonal element associated with the added row.
+*
+* BETA (input/output) REAL
+* Contains the off-diagonal element associated with the added
+* row.
+*
+* U (input/output) REAL array, dimension (LDU,N)
+* On entry U(1:NL, 1:NL) contains the left singular vectors of
+* the upper block; U(NL+2:N, NL+2:N) contains the left singular
+* vectors of the lower block. On exit U contains the left
+* singular vectors of the bidiagonal matrix.
+*
+* LDU (input) INTEGER
+* The leading dimension of the array U. LDU >= max( 1, N ).
+*
+* VT (input/output) REAL array, dimension (LDVT,M)
+* where M = N + SQRE.
+* On entry VT(1:NL+1, 1:NL+1)' contains the right singular
+* vectors of the upper block; VT(NL+2:M, NL+2:M)' contains
+* the right singular vectors of the lower block. On exit
+* VT' contains the right singular vectors of the
+* bidiagonal matrix.
+*
+* LDVT (input) INTEGER
+* The leading dimension of the array VT. LDVT >= max( 1, M ).
+*
+* IDXQ (output) INTEGER array, dimension (N)
+* This contains the permutation which will reintegrate the
+* subproblem just solved back into sorted order, i.e.
+* D( IDXQ( I = 1, N ) ) will be in ascending order.
+*
+* IWORK (workspace) INTEGER array, dimension (4*N)
+*
+* WORK (workspace) REAL array, dimension (3*M**2+2*M)
+*
+* INFO (output) INTEGER
+* = 0: successful exit.
+* < 0: if INFO = -i, the i-th argument had an illegal value.
+* > 0: if INFO = 1, an singular value did not converge
+*
+* Further Details
+* ===============
+*
+* Based on contributions by
+* Ming Gu and Huan Ren, Computer Science Division, University of
+* California at Berkeley, USA
+*
+* =====================================================================
+*
+* .. Parameters ..
+*
+ REAL ONE, ZERO
+ PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER COLTYP, I, IDX, IDXC, IDXP, IQ, ISIGMA, IU2,
+ $ IVT2, IZ, K, LDQ, LDU2, LDVT2, M, N, N1, N2
+ REAL ORGNRM
+* ..
+* .. External Subroutines ..
+ EXTERNAL SLAMRG, SLASCL, SLASD2, SLASD3, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+*
+ IF( NL.LT.1 ) THEN
+ INFO = -1
+ ELSE IF( NR.LT.1 ) THEN
+ INFO = -2
+ ELSE IF( ( SQRE.LT.0 ) .OR. ( SQRE.GT.1 ) ) THEN
+ INFO = -3
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SLASD1', -INFO )
+ RETURN
+ END IF
+*
+ N = NL + NR + 1
+ M = N + SQRE
+*
+* The following values are for bookkeeping purposes only. They are
+* integer pointers which indicate the portion of the workspace
+* used by a particular array in SLASD2 and SLASD3.
+*
+ LDU2 = N
+ LDVT2 = M
+*
+ IZ = 1
+ ISIGMA = IZ + M
+ IU2 = ISIGMA + N
+ IVT2 = IU2 + LDU2*N
+ IQ = IVT2 + LDVT2*M
+*
+ IDX = 1
+ IDXC = IDX + N
+ COLTYP = IDXC + N
+ IDXP = COLTYP + N
+*
+* Scale.
+*
+ ORGNRM = MAX( ABS( ALPHA ), ABS( BETA ) )
+ D( NL+1 ) = ZERO
+ DO 10 I = 1, N
+ IF( ABS( D( I ) ).GT.ORGNRM ) THEN
+ ORGNRM = ABS( D( I ) )
+ END IF
+ 10 CONTINUE
+ CALL SLASCL( 'G', 0, 0, ORGNRM, ONE, N, 1, D, N, INFO )
+ ALPHA = ALPHA / ORGNRM
+ BETA = BETA / ORGNRM
+*
+* Deflate singular values.
+*
+ CALL SLASD2( NL, NR, SQRE, K, D, WORK( IZ ), ALPHA, BETA, U, LDU,
+ $ VT, LDVT, WORK( ISIGMA ), WORK( IU2 ), LDU2,
+ $ WORK( IVT2 ), LDVT2, IWORK( IDXP ), IWORK( IDX ),
+ $ IWORK( IDXC ), IDXQ, IWORK( COLTYP ), INFO )
+*
+* Solve Secular Equation and update singular vectors.
+*
+ LDQ = K
+ CALL SLASD3( NL, NR, SQRE, K, D, WORK( IQ ), LDQ, WORK( ISIGMA ),
+ $ U, LDU, WORK( IU2 ), LDU2, VT, LDVT, WORK( IVT2 ),
+ $ LDVT2, IWORK( IDXC ), IWORK( COLTYP ), WORK( IZ ),
+ $ INFO )
+ IF( INFO.NE.0 ) THEN
+ RETURN
+ END IF
+*
+* Unscale.
+*
+ CALL SLASCL( 'G', 0, 0, ONE, ORGNRM, N, 1, D, N, INFO )
+*
+* Prepare the IDXQ sorting permutation.
+*
+ N1 = K
+ N2 = N - K
+ CALL SLAMRG( N1, N2, D, 1, -1, IDXQ )
+*
+ RETURN
+*
+* End of SLASD1
+*
+ END
+ 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 )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, K, LDU, LDU2, LDVT, LDVT2, NL, NR, SQRE
+ REAL ALPHA, BETA
+* ..
+* .. Array Arguments ..
+ INTEGER COLTYP( * ), IDX( * ), IDXC( * ), IDXP( * ),
+ $ IDXQ( * )
+ REAL D( * ), DSIGMA( * ), U( LDU, * ),
+ $ U2( LDU2, * ), VT( LDVT, * ), VT2( LDVT2, * ),
+ $ Z( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SLASD2 merges the two sets of singular values together into a single
+* sorted set. Then it tries to deflate the size of the problem.
+* There are two ways in which deflation can occur: when two or more
+* singular values are close together or if there is a tiny entry in the
+* Z vector. For each such occurrence the order of the related secular
+* equation problem is reduced by one.
+*
+* SLASD2 is called from SLASD1.
+*
+* Arguments
+* =========
+*
+* NL (input) INTEGER
+* The row dimension of the upper block. NL >= 1.
+*
+* NR (input) INTEGER
+* The row dimension of the lower block. NR >= 1.
+*
+* SQRE (input) INTEGER
+* = 0: the lower block is an NR-by-NR square matrix.
+* = 1: the lower block is an NR-by-(NR+1) rectangular matrix.
+*
+* The bidiagonal matrix has N = NL + NR + 1 rows and
+* M = N + SQRE >= N columns.
+*
+* K (output) INTEGER
+* Contains the dimension of the non-deflated matrix,
+* This is the order of the related secular equation. 1 <= K <=N.
+*
+* D (input/output) REAL array, dimension (N)
+* On entry D contains the singular values of the two submatrices
+* to be combined. On exit D contains the trailing (N-K) updated
+* singular values (those which were deflated) sorted into
+* increasing order.
+*
+* Z (output) REAL array, dimension (N)
+* On exit Z contains the updating row vector in the secular
+* equation.
+*
+* ALPHA (input) REAL
+* Contains the diagonal element associated with the added row.
+*
+* BETA (input) REAL
+* Contains the off-diagonal element associated with the added
+* row.
+*
+* U (input/output) REAL array, dimension (LDU,N)
+* On entry U contains the left singular vectors of two
+* submatrices in the two square blocks with corners at (1,1),
+* (NL, NL), and (NL+2, NL+2), (N,N).
+* On exit U contains the trailing (N-K) updated left singular
+* vectors (those which were deflated) in its last N-K columns.
+*
+* LDU (input) INTEGER
+* The leading dimension of the array U. LDU >= N.
+*
+* VT (input/output) REAL array, dimension (LDVT,M)
+* On entry VT' contains the right singular vectors of two
+* submatrices in the two square blocks with corners at (1,1),
+* (NL+1, NL+1), and (NL+2, NL+2), (M,M).
+* On exit VT' contains the trailing (N-K) updated right singular
+* vectors (those which were deflated) in its last N-K columns.
+* In case SQRE =1, the last row of VT spans the right null
+* space.
+*
+* LDVT (input) INTEGER
+* The leading dimension of the array VT. LDVT >= M.
+*
+* DSIGMA (output) REAL array, dimension (N)
+* Contains a copy of the diagonal elements (K-1 singular values
+* and one zero) in the secular equation.
+*
+* U2 (output) REAL array, dimension (LDU2,N)
+* Contains a copy of the first K-1 left singular vectors which
+* will be used by SLASD3 in a matrix multiply (SGEMM) to solve
+* for the new left singular vectors. U2 is arranged into four
+* blocks. The first block contains a column with 1 at NL+1 and
+* zero everywhere else; the second block contains non-zero
+* entries only at and above NL; the third contains non-zero
+* entries only below NL+1; and the fourth is dense.
+*
+* LDU2 (input) INTEGER
+* The leading dimension of the array U2. LDU2 >= N.
+*
+* VT2 (output) REAL array, dimension (LDVT2,N)
+* VT2' contains a copy of the first K right singular vectors
+* which will be used by SLASD3 in a matrix multiply (SGEMM) to
+* solve for the new right singular vectors. VT2 is arranged into
+* three blocks. The first block contains a row that corresponds
+* to the special 0 diagonal element in SIGMA; the second block
+* contains non-zeros only at and before NL +1; the third block
+* contains non-zeros only at and after NL +2.
+*
+* LDVT2 (input) INTEGER
+* The leading dimension of the array VT2. LDVT2 >= M.
+*
+* IDXP (workspace) INTEGER array, dimension (N)
+* This will contain the permutation used to place deflated
+* values of D at the end of the array. On output IDXP(2:K)
+* points to the nondeflated D-values and IDXP(K+1:N)
+* points to the deflated singular values.
+*
+* IDX (workspace) INTEGER array, dimension (N)
+* This will contain the permutation used to sort the contents of
+* D into ascending order.
+*
+* IDXC (output) INTEGER array, dimension (N)
+* This will contain the permutation used to arrange the columns
+* of the deflated U matrix into three groups: the first group
+* contains non-zero entries only at and above NL, the second
+* contains non-zero entries only below NL+2, and the third is
+* dense.
+*
+* IDXQ (input/output) INTEGER array, dimension (N)
+* This contains the permutation which separately sorts the two
+* sub-problems in D into ascending order. Note that entries in
+* the first hlaf of this permutation must first be moved one
+* position backward; and entries in the second half
+* must first have NL+1 added to their values.
+*
+* COLTYP (workspace/output) INTEGER array, dimension (N)
+* As workspace, this will contain a label which will indicate
+* which of the following types a column in the U2 matrix or a
+* row in the VT2 matrix is:
+* 1 : non-zero in the upper half only
+* 2 : non-zero in the lower half only
+* 3 : dense
+* 4 : deflated
+*
+* On exit, it is an array of dimension 4, with COLTYP(I) being
+* the dimension of the I-th type columns.
+*
+* INFO (output) INTEGER
+* = 0: successful exit.
+* < 0: if INFO = -i, the i-th argument had an illegal value.
+*
+* Further Details
+* ===============
+*
+* Based on contributions by
+* Ming Gu and Huan Ren, Computer Science Division, University of
+* California at Berkeley, USA
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO, ONE, TWO, EIGHT
+ PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0, TWO = 2.0E+0,
+ $ EIGHT = 8.0E+0 )
+* ..
+* .. Local Arrays ..
+ INTEGER CTOT( 4 ), PSM( 4 )
+* ..
+* .. Local Scalars ..
+ INTEGER CT, I, IDXI, IDXJ, IDXJP, J, JP, JPREV, K2, M,
+ $ N, NLP1, NLP2
+ REAL C, EPS, HLFTOL, S, TAU, TOL, Z1
+* ..
+* .. External Functions ..
+ REAL SLAMCH, SLAPY2
+ EXTERNAL SLAMCH, SLAPY2
+* ..
+* .. External Subroutines ..
+ EXTERNAL SCOPY, SLACPY, SLAMRG, SLASET, SROT, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+*
+ IF( NL.LT.1 ) THEN
+ INFO = -1
+ ELSE IF( NR.LT.1 ) THEN
+ INFO = -2
+ ELSE IF( ( SQRE.NE.1 ) .AND. ( SQRE.NE.0 ) ) THEN
+ INFO = -3
+ END IF
+*
+ N = NL + NR + 1
+ M = N + SQRE
+*
+ IF( LDU.LT.N ) THEN
+ INFO = -10
+ ELSE IF( LDVT.LT.M ) THEN
+ INFO = -12
+ ELSE IF( LDU2.LT.N ) THEN
+ INFO = -15
+ ELSE IF( LDVT2.LT.M ) THEN
+ INFO = -17
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SLASD2', -INFO )
+ RETURN
+ END IF
+*
+ NLP1 = NL + 1
+ NLP2 = NL + 2
+*
+* Generate the first part of the vector Z; and move the singular
+* values in the first part of D one position backward.
+*
+ Z1 = ALPHA*VT( NLP1, NLP1 )
+ Z( 1 ) = Z1
+ DO 10 I = NL, 1, -1
+ Z( I+1 ) = ALPHA*VT( I, NLP1 )
+ D( I+1 ) = D( I )
+ IDXQ( I+1 ) = IDXQ( I ) + 1
+ 10 CONTINUE
+*
+* Generate the second part of the vector Z.
+*
+ DO 20 I = NLP2, M
+ Z( I ) = BETA*VT( I, NLP2 )
+ 20 CONTINUE
+*
+* Initialize some reference arrays.
+*
+ DO 30 I = 2, NLP1
+ COLTYP( I ) = 1
+ 30 CONTINUE
+ DO 40 I = NLP2, N
+ COLTYP( I ) = 2
+ 40 CONTINUE
+*
+* Sort the singular values into increasing order
+*
+ DO 50 I = NLP2, N
+ IDXQ( I ) = IDXQ( I ) + NLP1
+ 50 CONTINUE
+*
+* DSIGMA, IDXC, IDXC, and the first column of U2
+* are used as storage space.
+*
+ DO 60 I = 2, N
+ DSIGMA( I ) = D( IDXQ( I ) )
+ U2( I, 1 ) = Z( IDXQ( I ) )
+ IDXC( I ) = COLTYP( IDXQ( I ) )
+ 60 CONTINUE
+*
+ CALL SLAMRG( NL, NR, DSIGMA( 2 ), 1, 1, IDX( 2 ) )
+*
+ DO 70 I = 2, N
+ IDXI = 1 + IDX( I )
+ D( I ) = DSIGMA( IDXI )
+ Z( I ) = U2( IDXI, 1 )
+ COLTYP( I ) = IDXC( IDXI )
+ 70 CONTINUE
+*
+* Calculate the allowable deflation tolerance
+*
+ EPS = SLAMCH( 'Epsilon' )
+ TOL = MAX( ABS( ALPHA ), ABS( BETA ) )
+ TOL = EIGHT*EPS*MAX( ABS( D( N ) ), TOL )
+*
+* There are 2 kinds of deflation -- first a value in the z-vector
+* is small, second two (or more) singular values are very close
+* together (their difference is small).
+*
+* If the value in the z-vector is small, we simply permute the
+* array so that the corresponding singular value is moved to the
+* end.
+*
+* If two values in the D-vector are close, we perform a two-sided
+* rotation designed to make one of the corresponding z-vector
+* entries zero, and then permute the array so that the deflated
+* singular value is moved to the end.
+*
+* If there are multiple singular values then the problem deflates.
+* Here the number of equal singular values are found. As each equal
+* singular value is found, an elementary reflector is computed to
+* rotate the corresponding singular subspace so that the
+* corresponding components of Z are zero in this new basis.
+*
+ K = 1
+ K2 = N + 1
+ DO 80 J = 2, N
+ IF( ABS( Z( J ) ).LE.TOL ) THEN
+*
+* Deflate due to small z component.
+*
+ K2 = K2 - 1
+ IDXP( K2 ) = J
+ COLTYP( J ) = 4
+ IF( J.EQ.N )
+ $ GO TO 120
+ ELSE
+ JPREV = J
+ GO TO 90
+ END IF
+ 80 CONTINUE
+ 90 CONTINUE
+ J = JPREV
+ 100 CONTINUE
+ J = J + 1
+ IF( J.GT.N )
+ $ GO TO 110
+ IF( ABS( Z( J ) ).LE.TOL ) THEN
+*
+* Deflate due to small z component.
+*
+ K2 = K2 - 1
+ IDXP( K2 ) = J
+ COLTYP( J ) = 4
+ ELSE
+*
+* Check if singular values are close enough to allow deflation.
+*
+ IF( ABS( D( J )-D( JPREV ) ).LE.TOL ) THEN
+*
+* Deflation is possible.
+*
+ S = Z( JPREV )
+ C = Z( J )
+*
+* Find sqrt(a**2+b**2) without overflow or
+* destructive underflow.
+*
+ TAU = SLAPY2( C, S )
+ C = C / TAU
+ S = -S / TAU
+ Z( J ) = TAU
+ Z( JPREV ) = ZERO
+*
+* Apply back the Givens rotation to the left and right
+* singular vector matrices.
+*
+ IDXJP = IDXQ( IDX( JPREV )+1 )
+ IDXJ = IDXQ( IDX( J )+1 )
+ IF( IDXJP.LE.NLP1 ) THEN
+ IDXJP = IDXJP - 1
+ END IF
+ IF( IDXJ.LE.NLP1 ) THEN
+ IDXJ = IDXJ - 1
+ END IF
+ CALL SROT( N, U( 1, IDXJP ), 1, U( 1, IDXJ ), 1, C, S )
+ CALL SROT( M, VT( IDXJP, 1 ), LDVT, VT( IDXJ, 1 ), LDVT, C,
+ $ S )
+ IF( COLTYP( J ).NE.COLTYP( JPREV ) ) THEN
+ COLTYP( J ) = 3
+ END IF
+ COLTYP( JPREV ) = 4
+ K2 = K2 - 1
+ IDXP( K2 ) = JPREV
+ JPREV = J
+ ELSE
+ K = K + 1
+ U2( K, 1 ) = Z( JPREV )
+ DSIGMA( K ) = D( JPREV )
+ IDXP( K ) = JPREV
+ JPREV = J
+ END IF
+ END IF
+ GO TO 100
+ 110 CONTINUE
+*
+* Record the last singular value.
+*
+ K = K + 1
+ U2( K, 1 ) = Z( JPREV )
+ DSIGMA( K ) = D( JPREV )
+ IDXP( K ) = JPREV
+*
+ 120 CONTINUE
+*
+* Count up the total number of the various types of columns, then
+* form a permutation which positions the four column types into
+* four groups of uniform structure (although one or more of these
+* groups may be empty).
+*
+ DO 130 J = 1, 4
+ CTOT( J ) = 0
+ 130 CONTINUE
+ DO 140 J = 2, N
+ CT = COLTYP( J )
+ CTOT( CT ) = CTOT( CT ) + 1
+ 140 CONTINUE
+*
+* PSM(*) = Position in SubMatrix (of types 1 through 4)
+*
+ PSM( 1 ) = 2
+ PSM( 2 ) = 2 + CTOT( 1 )
+ PSM( 3 ) = PSM( 2 ) + CTOT( 2 )
+ PSM( 4 ) = PSM( 3 ) + CTOT( 3 )
+*
+* Fill out the IDXC array so that the permutation which it induces
+* will place all type-1 columns first, all type-2 columns next,
+* then all type-3's, and finally all type-4's, starting from the
+* second column. This applies similarly to the rows of VT.
+*
+ DO 150 J = 2, N
+ JP = IDXP( J )
+ CT = COLTYP( JP )
+ IDXC( PSM( CT ) ) = J
+ PSM( CT ) = PSM( CT ) + 1
+ 150 CONTINUE
+*
+* Sort the singular values and corresponding singular vectors into
+* DSIGMA, U2, and VT2 respectively. The singular values/vectors
+* which were not deflated go into the first K slots of DSIGMA, U2,
+* and VT2 respectively, while those which were deflated go into the
+* last N - K slots, except that the first column/row will be treated
+* separately.
+*
+ DO 160 J = 2, N
+ JP = IDXP( J )
+ DSIGMA( J ) = D( JP )
+ IDXJ = IDXQ( IDX( IDXP( IDXC( J ) ) )+1 )
+ IF( IDXJ.LE.NLP1 ) THEN
+ IDXJ = IDXJ - 1
+ END IF
+ CALL SCOPY( N, U( 1, IDXJ ), 1, U2( 1, J ), 1 )
+ CALL SCOPY( M, VT( IDXJ, 1 ), LDVT, VT2( J, 1 ), LDVT2 )
+ 160 CONTINUE
+*
+* Determine DSIGMA(1), DSIGMA(2) and Z(1)
+*
+ DSIGMA( 1 ) = ZERO
+ HLFTOL = TOL / TWO
+ IF( ABS( DSIGMA( 2 ) ).LE.HLFTOL )
+ $ DSIGMA( 2 ) = HLFTOL
+ IF( M.GT.N ) THEN
+ Z( 1 ) = SLAPY2( Z1, Z( M ) )
+ IF( Z( 1 ).LE.TOL ) THEN
+ C = ONE
+ S = ZERO
+ Z( 1 ) = TOL
+ ELSE
+ C = Z1 / Z( 1 )
+ S = Z( M ) / Z( 1 )
+ END IF
+ ELSE
+ IF( ABS( Z1 ).LE.TOL ) THEN
+ Z( 1 ) = TOL
+ ELSE
+ Z( 1 ) = Z1
+ END IF
+ END IF
+*
+* Move the rest of the updating row to Z.
+*
+ CALL SCOPY( K-1, U2( 2, 1 ), 1, Z( 2 ), 1 )
+*
+* Determine the first column of U2, the first row of VT2 and the
+* last row of VT.
+*
+ CALL SLASET( 'A', N, 1, ZERO, ZERO, U2, LDU2 )
+ U2( NLP1, 1 ) = ONE
+ IF( M.GT.N ) THEN
+ DO 170 I = 1, NLP1
+ VT( M, I ) = -S*VT( NLP1, I )
+ VT2( 1, I ) = C*VT( NLP1, I )
+ 170 CONTINUE
+ DO 180 I = NLP2, M
+ VT2( 1, I ) = S*VT( M, I )
+ VT( M, I ) = C*VT( M, I )
+ 180 CONTINUE
+ ELSE
+ CALL SCOPY( M, VT( NLP1, 1 ), LDVT, VT2( 1, 1 ), LDVT2 )
+ END IF
+ IF( M.GT.N ) THEN
+ CALL SCOPY( M, VT( M, 1 ), LDVT, VT2( M, 1 ), LDVT2 )
+ END IF
+*
+* The deflated singular values and their corresponding vectors go
+* into the back of D, U, and V respectively.
+*
+ IF( N.GT.K ) THEN
+ CALL SCOPY( N-K, DSIGMA( K+1 ), 1, D( K+1 ), 1 )
+ CALL SLACPY( 'A', N, N-K, U2( 1, K+1 ), LDU2, U( 1, K+1 ),
+ $ LDU )
+ CALL SLACPY( 'A', N-K, M, VT2( K+1, 1 ), LDVT2, VT( K+1, 1 ),
+ $ LDVT )
+ END IF
+*
+* Copy CTOT into COLTYP for referencing in SLASD3.
+*
+ DO 190 J = 1, 4
+ COLTYP( J ) = CTOT( J )
+ 190 CONTINUE
+*
+ RETURN
+*
+* End of SLASD2
+*
+ END
+ SUBROUTINE SLASD3( NL, NR, SQRE, K, D, Q, LDQ, DSIGMA, U, LDU, U2,
+ $ LDU2, VT, LDVT, VT2, LDVT2, IDXC, CTOT, Z,
+ $ INFO )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, K, LDQ, LDU, LDU2, LDVT, LDVT2, NL, NR,
+ $ SQRE
+* ..
+* .. Array Arguments ..
+ INTEGER CTOT( * ), IDXC( * )
+ REAL D( * ), DSIGMA( * ), Q( LDQ, * ), U( LDU, * ),
+ $ U2( LDU2, * ), VT( LDVT, * ), VT2( LDVT2, * ),
+ $ Z( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SLASD3 finds all the square roots of the roots of the secular
+* equation, as defined by the values in D and Z. It makes the
+* appropriate calls to SLASD4 and then updates the singular
+* vectors by matrix multiplication.
+*
+* This code makes very mild assumptions about floating point
+* arithmetic. It will work on machines with a guard digit in
+* add/subtract, or on those binary machines without guard digits
+* which subtract like the Cray XMP, Cray YMP, Cray C 90, or Cray 2.
+* It could conceivably fail on hexadecimal or decimal machines
+* without guard digits, but we know of none.
+*
+* SLASD3 is called from SLASD1.
+*
+* Arguments
+* =========
+*
+* NL (input) INTEGER
+* The row dimension of the upper block. NL >= 1.
+*
+* NR (input) INTEGER
+* The row dimension of the lower block. NR >= 1.
+*
+* SQRE (input) INTEGER
+* = 0: the lower block is an NR-by-NR square matrix.
+* = 1: the lower block is an NR-by-(NR+1) rectangular matrix.
+*
+* The bidiagonal matrix has N = NL + NR + 1 rows and
+* M = N + SQRE >= N columns.
+*
+* K (input) INTEGER
+* The size of the secular equation, 1 =< K = < N.
+*
+* D (output) REAL array, dimension(K)
+* On exit the square roots of the roots of the secular equation,
+* in ascending order.
+*
+* Q (workspace) REAL array,
+* dimension at least (LDQ,K).
+*
+* LDQ (input) INTEGER
+* The leading dimension of the array Q. LDQ >= K.
+*
+* DSIGMA (input/output) REAL array, dimension(K)
+* The first K elements of this array contain the old roots
+* of the deflated updating problem. These are the poles
+* of the secular equation.
+*
+* U (output) REAL array, dimension (LDU, N)
+* The last N - K columns of this matrix contain the deflated
+* left singular vectors.
+*
+* LDU (input) INTEGER
+* The leading dimension of the array U. LDU >= N.
+*
+* U2 (input) REAL array, dimension (LDU2, N)
+* The first K columns of this matrix contain the non-deflated
+* left singular vectors for the split problem.
+*
+* LDU2 (input) INTEGER
+* The leading dimension of the array U2. LDU2 >= N.
+*
+* VT (output) REAL array, dimension (LDVT, M)
+* The last M - K columns of VT' contain the deflated
+* right singular vectors.
+*
+* LDVT (input) INTEGER
+* The leading dimension of the array VT. LDVT >= N.
+*
+* VT2 (input/output) REAL array, dimension (LDVT2, N)
+* The first K columns of VT2' contain the non-deflated
+* right singular vectors for the split problem.
+*
+* LDVT2 (input) INTEGER
+* The leading dimension of the array VT2. LDVT2 >= N.
+*
+* IDXC (input) INTEGER array, dimension (N)
+* The permutation used to arrange the columns of U (and rows of
+* VT) into three groups: the first group contains non-zero
+* entries only at and above (or before) NL +1; the second
+* contains non-zero entries only at and below (or after) NL+2;
+* and the third is dense. The first column of U and the row of
+* VT are treated separately, however.
+*
+* The rows of the singular vectors found by SLASD4
+* must be likewise permuted before the matrix multiplies can
+* take place.
+*
+* CTOT (input) INTEGER array, dimension (4)
+* A count of the total number of the various types of columns
+* in U (or rows in VT), as described in IDXC. The fourth column
+* type is any column which has been deflated.
+*
+* Z (input/output) REAL array, dimension (K)
+* The first K elements of this array contain the components
+* of the deflation-adjusted updating row vector.
+*
+* INFO (output) INTEGER
+* = 0: successful exit.
+* < 0: if INFO = -i, the i-th argument had an illegal value.
+* > 0: if INFO = 1, an singular value did not converge
+*
+* Further Details
+* ===============
+*
+* Based on contributions by
+* Ming Gu and Huan Ren, Computer Science Division, University of
+* California at Berkeley, USA
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ONE, ZERO, NEGONE
+ PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0,
+ $ NEGONE = -1.0E+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER CTEMP, I, J, JC, KTEMP, M, N, NLP1, NLP2, NRP1
+ REAL RHO, TEMP
+* ..
+* .. External Functions ..
+ REAL SLAMC3, SNRM2
+ EXTERNAL SLAMC3, SNRM2
+* ..
+* .. External Subroutines ..
+ EXTERNAL SCOPY, SGEMM, SLACPY, SLASCL, SLASD4, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, SIGN, SQRT
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+*
+ IF( NL.LT.1 ) THEN
+ INFO = -1
+ ELSE IF( NR.LT.1 ) THEN
+ INFO = -2
+ ELSE IF( ( SQRE.NE.1 ) .AND. ( SQRE.NE.0 ) ) THEN
+ INFO = -3
+ END IF
+*
+ N = NL + NR + 1
+ M = N + SQRE
+ NLP1 = NL + 1
+ NLP2 = NL + 2
+*
+ IF( ( K.LT.1 ) .OR. ( K.GT.N ) ) THEN
+ INFO = -4
+ ELSE IF( LDQ.LT.K ) THEN
+ INFO = -7
+ ELSE IF( LDU.LT.N ) THEN
+ INFO = -10
+ ELSE IF( LDU2.LT.N ) THEN
+ INFO = -12
+ ELSE IF( LDVT.LT.M ) THEN
+ INFO = -14
+ ELSE IF( LDVT2.LT.M ) THEN
+ INFO = -16
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SLASD3', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( K.EQ.1 ) THEN
+ D( 1 ) = ABS( Z( 1 ) )
+ CALL SCOPY( M, VT2( 1, 1 ), LDVT2, VT( 1, 1 ), LDVT )
+ IF( Z( 1 ).GT.ZERO ) THEN
+ CALL SCOPY( N, U2( 1, 1 ), 1, U( 1, 1 ), 1 )
+ ELSE
+ DO 10 I = 1, N
+ U( I, 1 ) = -U2( I, 1 )
+ 10 CONTINUE
+ END IF
+ RETURN
+ END IF
+*
+* Modify values DSIGMA(i) to make sure all DSIGMA(i)-DSIGMA(j) can
+* be computed with high relative accuracy (barring over/underflow).
+* This is a problem on machines without a guard digit in
+* add/subtract (Cray XMP, Cray YMP, Cray C 90 and Cray 2).
+* The following code replaces DSIGMA(I) by 2*DSIGMA(I)-DSIGMA(I),
+* which on any of these machines zeros out the bottommost
+* bit of DSIGMA(I) if it is 1; this makes the subsequent
+* subtractions DSIGMA(I)-DSIGMA(J) unproblematic when cancellation
+* occurs. On binary machines with a guard digit (almost all
+* machines) it does not change DSIGMA(I) at all. On hexadecimal
+* and decimal machines with a guard digit, it slightly
+* changes the bottommost bits of DSIGMA(I). It does not account
+* for hexadecimal or decimal machines without guard digits
+* (we know of none). We use a subroutine call to compute
+* 2*DSIGMA(I) to prevent optimizing compilers from eliminating
+* this code.
+*
+ DO 20 I = 1, K
+ DSIGMA( I ) = SLAMC3( DSIGMA( I ), DSIGMA( I ) ) - DSIGMA( I )
+ 20 CONTINUE
+*
+* Keep a copy of Z.
+*
+ CALL SCOPY( K, Z, 1, Q, 1 )
+*
+* Normalize Z.
+*
+ RHO = SNRM2( K, Z, 1 )
+ CALL SLASCL( 'G', 0, 0, RHO, ONE, K, 1, Z, K, INFO )
+ RHO = RHO*RHO
+*
+* Find the new singular values.
+*
+ DO 30 J = 1, K
+ CALL SLASD4( K, J, DSIGMA, Z, U( 1, J ), RHO, D( J ),
+ $ VT( 1, J ), INFO )
+*
+* If the zero finder fails, the computation is terminated.
+*
+ IF( INFO.NE.0 ) THEN
+ RETURN
+ END IF
+ 30 CONTINUE
+*
+* Compute updated Z.
+*
+ DO 60 I = 1, K
+ Z( I ) = U( I, K )*VT( I, K )
+ DO 40 J = 1, I - 1
+ Z( I ) = Z( I )*( U( I, J )*VT( I, J ) /
+ $ ( DSIGMA( I )-DSIGMA( J ) ) /
+ $ ( DSIGMA( I )+DSIGMA( J ) ) )
+ 40 CONTINUE
+ DO 50 J = I, K - 1
+ Z( I ) = Z( I )*( U( I, J )*VT( I, J ) /
+ $ ( DSIGMA( I )-DSIGMA( J+1 ) ) /
+ $ ( DSIGMA( I )+DSIGMA( J+1 ) ) )
+ 50 CONTINUE
+ Z( I ) = SIGN( SQRT( ABS( Z( I ) ) ), Q( I, 1 ) )
+ 60 CONTINUE
+*
+* Compute left singular vectors of the modified diagonal matrix,
+* and store related information for the right singular vectors.
+*
+ DO 90 I = 1, K
+ VT( 1, I ) = Z( 1 ) / U( 1, I ) / VT( 1, I )
+ U( 1, I ) = NEGONE
+ DO 70 J = 2, K
+ VT( J, I ) = Z( J ) / U( J, I ) / VT( J, I )
+ U( J, I ) = DSIGMA( J )*VT( J, I )
+ 70 CONTINUE
+ TEMP = SNRM2( K, U( 1, I ), 1 )
+ Q( 1, I ) = U( 1, I ) / TEMP
+ DO 80 J = 2, K
+ JC = IDXC( J )
+ Q( J, I ) = U( JC, I ) / TEMP
+ 80 CONTINUE
+ 90 CONTINUE
+*
+* Update the left singular vector matrix.
+*
+ IF( K.EQ.2 ) THEN
+ CALL SGEMM( 'N', 'N', N, K, K, ONE, U2, LDU2, Q, LDQ, ZERO, U,
+ $ LDU )
+ GO TO 100
+ END IF
+ IF( CTOT( 1 ).GT.0 ) THEN
+ CALL SGEMM( 'N', 'N', NL, K, CTOT( 1 ), ONE, U2( 1, 2 ), LDU2,
+ $ Q( 2, 1 ), LDQ, ZERO, U( 1, 1 ), LDU )
+ IF( CTOT( 3 ).GT.0 ) THEN
+ KTEMP = 2 + CTOT( 1 ) + CTOT( 2 )
+ CALL SGEMM( 'N', 'N', NL, K, CTOT( 3 ), ONE, U2( 1, KTEMP ),
+ $ LDU2, Q( KTEMP, 1 ), LDQ, ONE, U( 1, 1 ), LDU )
+ END IF
+ ELSE IF( CTOT( 3 ).GT.0 ) THEN
+ KTEMP = 2 + CTOT( 1 ) + CTOT( 2 )
+ CALL SGEMM( 'N', 'N', NL, K, CTOT( 3 ), ONE, U2( 1, KTEMP ),
+ $ LDU2, Q( KTEMP, 1 ), LDQ, ZERO, U( 1, 1 ), LDU )
+ ELSE
+ CALL SLACPY( 'F', NL, K, U2, LDU2, U, LDU )
+ END IF
+ CALL SCOPY( K, Q( 1, 1 ), LDQ, U( NLP1, 1 ), LDU )
+ KTEMP = 2 + CTOT( 1 )
+ CTEMP = CTOT( 2 ) + CTOT( 3 )
+ CALL SGEMM( 'N', 'N', NR, K, CTEMP, ONE, U2( NLP2, KTEMP ), LDU2,
+ $ Q( KTEMP, 1 ), LDQ, ZERO, U( NLP2, 1 ), LDU )
+*
+* Generate the right singular vectors.
+*
+ 100 CONTINUE
+ DO 120 I = 1, K
+ TEMP = SNRM2( K, VT( 1, I ), 1 )
+ Q( I, 1 ) = VT( 1, I ) / TEMP
+ DO 110 J = 2, K
+ JC = IDXC( J )
+ Q( I, J ) = VT( JC, I ) / TEMP
+ 110 CONTINUE
+ 120 CONTINUE
+*
+* Update the right singular vector matrix.
+*
+ IF( K.EQ.2 ) THEN
+ CALL SGEMM( 'N', 'N', K, M, K, ONE, Q, LDQ, VT2, LDVT2, ZERO,
+ $ VT, LDVT )
+ RETURN
+ END IF
+ KTEMP = 1 + CTOT( 1 )
+ CALL SGEMM( 'N', 'N', K, NLP1, KTEMP, ONE, Q( 1, 1 ), LDQ,
+ $ VT2( 1, 1 ), LDVT2, ZERO, VT( 1, 1 ), LDVT )
+ KTEMP = 2 + CTOT( 1 ) + CTOT( 2 )
+ IF( KTEMP.LE.LDVT2 )
+ $ CALL SGEMM( 'N', 'N', K, NLP1, CTOT( 3 ), ONE, Q( 1, KTEMP ),
+ $ LDQ, VT2( KTEMP, 1 ), LDVT2, ONE, VT( 1, 1 ),
+ $ LDVT )
+*
+ KTEMP = CTOT( 1 ) + 1
+ NRP1 = NR + SQRE
+ IF( KTEMP.GT.1 ) THEN
+ DO 130 I = 1, K
+ Q( I, KTEMP ) = Q( I, 1 )
+ 130 CONTINUE
+ DO 140 I = NLP2, M
+ VT2( KTEMP, I ) = VT2( 1, I )
+ 140 CONTINUE
+ END IF
+ CTEMP = 1 + CTOT( 2 ) + CTOT( 3 )
+ CALL SGEMM( 'N', 'N', K, NRP1, CTEMP, ONE, Q( 1, KTEMP ), LDQ,
+ $ VT2( KTEMP, NLP2 ), LDVT2, ZERO, VT( 1, NLP2 ), LDVT )
+*
+ RETURN
+*
+* End of SLASD3
+*
+ END
+ SUBROUTINE SLASD4( N, I, D, Z, DELTA, RHO, SIGMA, WORK, INFO )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER I, INFO, N
+ REAL RHO, SIGMA
+* ..
+* .. Array Arguments ..
+ REAL D( * ), DELTA( * ), WORK( * ), Z( * )
+* ..
+*
+* Purpose
+* =======
+*
+* This subroutine computes the square root of the I-th updated
+* eigenvalue of a positive symmetric rank-one modification to
+* a positive diagonal matrix whose entries are given as the squares
+* of the corresponding entries in the array d, and that
+*
+* 0 <= D(i) < D(j) for i < j
+*
+* and that RHO > 0. This is arranged by the calling routine, and is
+* no loss in generality. The rank-one modified system is thus
+*
+* diag( D ) * diag( D ) + RHO * Z * Z_transpose.
+*
+* where we assume the Euclidean norm of Z is 1.
+*
+* The method consists of approximating the rational functions in the
+* secular equation by simpler interpolating rational functions.
+*
+* Arguments
+* =========
+*
+* N (input) INTEGER
+* The length of all arrays.
+*
+* I (input) INTEGER
+* The index of the eigenvalue to be computed. 1 <= I <= N.
+*
+* D (input) REAL array, dimension ( N )
+* The original eigenvalues. It is assumed that they are in
+* order, 0 <= D(I) < D(J) for I < J.
+*
+* Z (input) REAL array, dimension (N)
+* The components of the updating vector.
+*
+* DELTA (output) REAL array, dimension (N)
+* If N .ne. 1, DELTA contains (D(j) - sigma_I) in its j-th
+* component. If N = 1, then DELTA(1) = 1. The vector DELTA
+* contains the information necessary to construct the
+* (singular) eigenvectors.
+*
+* RHO (input) REAL
+* The scalar in the symmetric updating formula.
+*
+* SIGMA (output) REAL
+* The computed sigma_I, the I-th updated eigenvalue.
+*
+* WORK (workspace) REAL array, dimension (N)
+* If N .ne. 1, WORK contains (D(j) + sigma_I) in its j-th
+* component. If N = 1, then WORK( 1 ) = 1.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* > 0: if INFO = 1, the updating process failed.
+*
+* Internal Parameters
+* ===================
+*
+* Logical variable ORGATI (origin-at-i?) is used for distinguishing
+* whether D(i) or D(i+1) is treated as the origin.
+*
+* ORGATI = .true. origin at i
+* ORGATI = .false. origin at i+1
+*
+* Logical variable SWTCH3 (switch-for-3-poles?) is for noting
+* if we are working with THREE poles!
+*
+* MAXIT is the maximum number of iterations allowed for each
+* eigenvalue.
+*
+* Further Details
+* ===============
+*
+* Based on contributions by
+* Ren-Cang Li, Computer Science Division, University of California
+* at Berkeley, USA
+*
+* =====================================================================
+*
+* .. Parameters ..
+ INTEGER MAXIT
+ PARAMETER ( MAXIT = 20 )
+ REAL ZERO, ONE, TWO, THREE, FOUR, EIGHT, TEN
+ PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0, TWO = 2.0E+0,
+ $ THREE = 3.0E+0, FOUR = 4.0E+0, EIGHT = 8.0E+0,
+ $ TEN = 10.0E+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL ORGATI, SWTCH, SWTCH3
+ INTEGER II, IIM1, IIP1, IP1, ITER, J, NITER
+ REAL A, B, C, DELSQ, DELSQ2, DPHI, DPSI, DTIIM,
+ $ DTIIP, DTIPSQ, DTISQ, DTNSQ, DTNSQ1, DW, EPS,
+ $ ERRETM, ETA, PHI, PREW, PSI, RHOINV, SG2LB,
+ $ SG2UB, TAU, TEMP, TEMP1, TEMP2, W
+* ..
+* .. Local Arrays ..
+ REAL DD( 3 ), ZZ( 3 )
+* ..
+* .. External Subroutines ..
+ EXTERNAL SLAED6, SLASD5
+* ..
+* .. External Functions ..
+ REAL SLAMCH
+ EXTERNAL SLAMCH
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, MIN, SQRT
+* ..
+* .. Executable Statements ..
+*
+* Since this routine is called in an inner loop, we do no argument
+* checking.
+*
+* Quick return for N=1 and 2.
+*
+ INFO = 0
+ IF( N.EQ.1 ) THEN
+*
+* Presumably, I=1 upon entry
+*
+ SIGMA = SQRT( D( 1 )*D( 1 )+RHO*Z( 1 )*Z( 1 ) )
+ DELTA( 1 ) = ONE
+ WORK( 1 ) = ONE
+ RETURN
+ END IF
+ IF( N.EQ.2 ) THEN
+ CALL SLASD5( I, D, Z, DELTA, RHO, SIGMA, WORK )
+ RETURN
+ END IF
+*
+* Compute machine epsilon
+*
+ EPS = SLAMCH( 'Epsilon' )
+ RHOINV = ONE / RHO
+*
+* The case I = N
+*
+ IF( I.EQ.N ) THEN
+*
+* Initialize some basic variables
+*
+ II = N - 1
+ NITER = 1
+*
+* Calculate initial guess
+*
+ TEMP = RHO / TWO
+*
+* If ||Z||_2 is not one, then TEMP should be set to
+* RHO * ||Z||_2^2 / TWO
+*
+ TEMP1 = TEMP / ( D( N )+SQRT( D( N )*D( N )+TEMP ) )
+ DO 10 J = 1, N
+ WORK( J ) = D( J ) + D( N ) + TEMP1
+ DELTA( J ) = ( D( J )-D( N ) ) - TEMP1
+ 10 CONTINUE
+*
+ PSI = ZERO
+ DO 20 J = 1, N - 2
+ PSI = PSI + Z( J )*Z( J ) / ( DELTA( J )*WORK( J ) )
+ 20 CONTINUE
+*
+ C = RHOINV + PSI
+ W = C + Z( II )*Z( II ) / ( DELTA( II )*WORK( II ) ) +
+ $ Z( N )*Z( N ) / ( DELTA( N )*WORK( N ) )
+*
+ IF( W.LE.ZERO ) THEN
+ TEMP1 = SQRT( D( N )*D( N )+RHO )
+ TEMP = Z( N-1 )*Z( N-1 ) / ( ( D( N-1 )+TEMP1 )*
+ $ ( D( N )-D( N-1 )+RHO / ( D( N )+TEMP1 ) ) ) +
+ $ Z( N )*Z( N ) / RHO
+*
+* The following TAU is to approximate
+* SIGMA_n^2 - D( N )*D( N )
+*
+ IF( C.LE.TEMP ) THEN
+ TAU = RHO
+ ELSE
+ DELSQ = ( D( N )-D( N-1 ) )*( D( N )+D( N-1 ) )
+ A = -C*DELSQ + Z( N-1 )*Z( N-1 ) + Z( N )*Z( N )
+ B = Z( N )*Z( N )*DELSQ
+ IF( A.LT.ZERO ) THEN
+ TAU = TWO*B / ( SQRT( A*A+FOUR*B*C )-A )
+ ELSE
+ TAU = ( A+SQRT( A*A+FOUR*B*C ) ) / ( TWO*C )
+ END IF
+ END IF
+*
+* It can be proved that
+* D(N)^2+RHO/2 <= SIGMA_n^2 < D(N)^2+TAU <= D(N)^2+RHO
+*
+ ELSE
+ DELSQ = ( D( N )-D( N-1 ) )*( D( N )+D( N-1 ) )
+ A = -C*DELSQ + Z( N-1 )*Z( N-1 ) + Z( N )*Z( N )
+ B = Z( N )*Z( N )*DELSQ
+*
+* The following TAU is to approximate
+* SIGMA_n^2 - D( N )*D( N )
+*
+ IF( A.LT.ZERO ) THEN
+ TAU = TWO*B / ( SQRT( A*A+FOUR*B*C )-A )
+ ELSE
+ TAU = ( A+SQRT( A*A+FOUR*B*C ) ) / ( TWO*C )
+ END IF
+*
+* It can be proved that
+* D(N)^2 < D(N)^2+TAU < SIGMA(N)^2 < D(N)^2+RHO/2
+*
+ END IF
+*
+* The following ETA is to approximate SIGMA_n - D( N )
+*
+ ETA = TAU / ( D( N )+SQRT( D( N )*D( N )+TAU ) )
+*
+ SIGMA = D( N ) + ETA
+ DO 30 J = 1, N
+ DELTA( J ) = ( D( J )-D( I ) ) - ETA
+ WORK( J ) = D( J ) + D( I ) + ETA
+ 30 CONTINUE
+*
+* Evaluate PSI and the derivative DPSI
+*
+ DPSI = ZERO
+ PSI = ZERO
+ ERRETM = ZERO
+ DO 40 J = 1, II
+ TEMP = Z( J ) / ( DELTA( J )*WORK( J ) )
+ PSI = PSI + Z( J )*TEMP
+ DPSI = DPSI + TEMP*TEMP
+ ERRETM = ERRETM + PSI
+ 40 CONTINUE
+ ERRETM = ABS( ERRETM )
+*
+* Evaluate PHI and the derivative DPHI
+*
+ TEMP = Z( N ) / ( DELTA( N )*WORK( N ) )
+ PHI = Z( N )*TEMP
+ DPHI = TEMP*TEMP
+ ERRETM = EIGHT*( -PHI-PSI ) + ERRETM - PHI + RHOINV +
+ $ ABS( TAU )*( DPSI+DPHI )
+*
+ W = RHOINV + PHI + PSI
+*
+* Test for convergence
+*
+ IF( ABS( W ).LE.EPS*ERRETM ) THEN
+ GO TO 240
+ END IF
+*
+* Calculate the new step
+*
+ NITER = NITER + 1
+ DTNSQ1 = WORK( N-1 )*DELTA( N-1 )
+ DTNSQ = WORK( N )*DELTA( N )
+ C = W - DTNSQ1*DPSI - DTNSQ*DPHI
+ A = ( DTNSQ+DTNSQ1 )*W - DTNSQ*DTNSQ1*( DPSI+DPHI )
+ B = DTNSQ*DTNSQ1*W
+ IF( C.LT.ZERO )
+ $ C = ABS( C )
+ IF( C.EQ.ZERO ) THEN
+ ETA = RHO - SIGMA*SIGMA
+ ELSE IF( A.GE.ZERO ) THEN
+ ETA = ( A+SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C )
+ ELSE
+ ETA = TWO*B / ( A-SQRT( ABS( A*A-FOUR*B*C ) ) )
+ END IF
+*
+* Note, eta should be positive if w is negative, and
+* eta should be negative otherwise. However,
+* if for some reason caused by roundoff, eta*w > 0,
+* we simply use one Newton step instead. This way
+* will guarantee eta*w < 0.
+*
+ IF( W*ETA.GT.ZERO )
+ $ ETA = -W / ( DPSI+DPHI )
+ TEMP = ETA - DTNSQ
+ IF( TEMP.GT.RHO )
+ $ ETA = RHO + DTNSQ
+*
+ TAU = TAU + ETA
+ ETA = ETA / ( SIGMA+SQRT( ETA+SIGMA*SIGMA ) )
+ DO 50 J = 1, N
+ DELTA( J ) = DELTA( J ) - ETA
+ WORK( J ) = WORK( J ) + ETA
+ 50 CONTINUE
+*
+ SIGMA = SIGMA + ETA
+*
+* Evaluate PSI and the derivative DPSI
+*
+ DPSI = ZERO
+ PSI = ZERO
+ ERRETM = ZERO
+ DO 60 J = 1, II
+ TEMP = Z( J ) / ( WORK( J )*DELTA( J ) )
+ PSI = PSI + Z( J )*TEMP
+ DPSI = DPSI + TEMP*TEMP
+ ERRETM = ERRETM + PSI
+ 60 CONTINUE
+ ERRETM = ABS( ERRETM )
+*
+* Evaluate PHI and the derivative DPHI
+*
+ TEMP = Z( N ) / ( WORK( N )*DELTA( N ) )
+ PHI = Z( N )*TEMP
+ DPHI = TEMP*TEMP
+ ERRETM = EIGHT*( -PHI-PSI ) + ERRETM - PHI + RHOINV +
+ $ ABS( TAU )*( DPSI+DPHI )
+*
+ W = RHOINV + PHI + PSI
+*
+* Main loop to update the values of the array DELTA
+*
+ ITER = NITER + 1
+*
+ DO 90 NITER = ITER, MAXIT
+*
+* Test for convergence
+*
+ IF( ABS( W ).LE.EPS*ERRETM ) THEN
+ GO TO 240
+ END IF
+*
+* Calculate the new step
+*
+ DTNSQ1 = WORK( N-1 )*DELTA( N-1 )
+ DTNSQ = WORK( N )*DELTA( N )
+ C = W - DTNSQ1*DPSI - DTNSQ*DPHI
+ A = ( DTNSQ+DTNSQ1 )*W - DTNSQ1*DTNSQ*( DPSI+DPHI )
+ B = DTNSQ1*DTNSQ*W
+ IF( A.GE.ZERO ) THEN
+ ETA = ( A+SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C )
+ ELSE
+ ETA = TWO*B / ( A-SQRT( ABS( A*A-FOUR*B*C ) ) )
+ END IF
+*
+* Note, eta should be positive if w is negative, and
+* eta should be negative otherwise. However,
+* if for some reason caused by roundoff, eta*w > 0,
+* we simply use one Newton step instead. This way
+* will guarantee eta*w < 0.
+*
+ IF( W*ETA.GT.ZERO )
+ $ ETA = -W / ( DPSI+DPHI )
+ TEMP = ETA - DTNSQ
+ IF( TEMP.LE.ZERO )
+ $ ETA = ETA / TWO
+*
+ TAU = TAU + ETA
+ ETA = ETA / ( SIGMA+SQRT( ETA+SIGMA*SIGMA ) )
+ DO 70 J = 1, N
+ DELTA( J ) = DELTA( J ) - ETA
+ WORK( J ) = WORK( J ) + ETA
+ 70 CONTINUE
+*
+ SIGMA = SIGMA + ETA
+*
+* Evaluate PSI and the derivative DPSI
+*
+ DPSI = ZERO
+ PSI = ZERO
+ ERRETM = ZERO
+ DO 80 J = 1, II
+ TEMP = Z( J ) / ( WORK( J )*DELTA( J ) )
+ PSI = PSI + Z( J )*TEMP
+ DPSI = DPSI + TEMP*TEMP
+ ERRETM = ERRETM + PSI
+ 80 CONTINUE
+ ERRETM = ABS( ERRETM )
+*
+* Evaluate PHI and the derivative DPHI
+*
+ TEMP = Z( N ) / ( WORK( N )*DELTA( N ) )
+ PHI = Z( N )*TEMP
+ DPHI = TEMP*TEMP
+ ERRETM = EIGHT*( -PHI-PSI ) + ERRETM - PHI + RHOINV +
+ $ ABS( TAU )*( DPSI+DPHI )
+*
+ W = RHOINV + PHI + PSI
+ 90 CONTINUE
+*
+* Return with INFO = 1, NITER = MAXIT and not converged
+*
+ INFO = 1
+ GO TO 240
+*
+* End for the case I = N
+*
+ ELSE
+*
+* The case for I < N
+*
+ NITER = 1
+ IP1 = I + 1
+*
+* Calculate initial guess
+*
+ DELSQ = ( D( IP1 )-D( I ) )*( D( IP1 )+D( I ) )
+ DELSQ2 = DELSQ / TWO
+ TEMP = DELSQ2 / ( D( I )+SQRT( D( I )*D( I )+DELSQ2 ) )
+ DO 100 J = 1, N
+ WORK( J ) = D( J ) + D( I ) + TEMP
+ DELTA( J ) = ( D( J )-D( I ) ) - TEMP
+ 100 CONTINUE
+*
+ PSI = ZERO
+ DO 110 J = 1, I - 1
+ PSI = PSI + Z( J )*Z( J ) / ( WORK( J )*DELTA( J ) )
+ 110 CONTINUE
+*
+ PHI = ZERO
+ DO 120 J = N, I + 2, -1
+ PHI = PHI + Z( J )*Z( J ) / ( WORK( J )*DELTA( J ) )
+ 120 CONTINUE
+ C = RHOINV + PSI + PHI
+ W = C + Z( I )*Z( I ) / ( WORK( I )*DELTA( I ) ) +
+ $ Z( IP1 )*Z( IP1 ) / ( WORK( IP1 )*DELTA( IP1 ) )
+*
+ IF( W.GT.ZERO ) THEN
+*
+* d(i)^2 < the ith sigma^2 < (d(i)^2+d(i+1)^2)/2
+*
+* We choose d(i) as origin.
+*
+ ORGATI = .TRUE.
+ SG2LB = ZERO
+ SG2UB = DELSQ2
+ A = C*DELSQ + Z( I )*Z( I ) + Z( IP1 )*Z( IP1 )
+ B = Z( I )*Z( I )*DELSQ
+ IF( A.GT.ZERO ) THEN
+ TAU = TWO*B / ( A+SQRT( ABS( A*A-FOUR*B*C ) ) )
+ ELSE
+ TAU = ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C )
+ END IF
+*
+* TAU now is an estimation of SIGMA^2 - D( I )^2. The
+* following, however, is the corresponding estimation of
+* SIGMA - D( I ).
+*
+ ETA = TAU / ( D( I )+SQRT( D( I )*D( I )+TAU ) )
+ ELSE
+*
+* (d(i)^2+d(i+1)^2)/2 <= the ith sigma^2 < d(i+1)^2/2
+*
+* We choose d(i+1) as origin.
+*
+ ORGATI = .FALSE.
+ SG2LB = -DELSQ2
+ SG2UB = ZERO
+ A = C*DELSQ - Z( I )*Z( I ) - Z( IP1 )*Z( IP1 )
+ B = Z( IP1 )*Z( IP1 )*DELSQ
+ IF( A.LT.ZERO ) THEN
+ TAU = TWO*B / ( A-SQRT( ABS( A*A+FOUR*B*C ) ) )
+ ELSE
+ TAU = -( A+SQRT( ABS( A*A+FOUR*B*C ) ) ) / ( TWO*C )
+ END IF
+*
+* TAU now is an estimation of SIGMA^2 - D( IP1 )^2. The
+* following, however, is the corresponding estimation of
+* SIGMA - D( IP1 ).
+*
+ ETA = TAU / ( D( IP1 )+SQRT( ABS( D( IP1 )*D( IP1 )+
+ $ TAU ) ) )
+ END IF
+*
+ IF( ORGATI ) THEN
+ II = I
+ SIGMA = D( I ) + ETA
+ DO 130 J = 1, N
+ WORK( J ) = D( J ) + D( I ) + ETA
+ DELTA( J ) = ( D( J )-D( I ) ) - ETA
+ 130 CONTINUE
+ ELSE
+ II = I + 1
+ SIGMA = D( IP1 ) + ETA
+ DO 140 J = 1, N
+ WORK( J ) = D( J ) + D( IP1 ) + ETA
+ DELTA( J ) = ( D( J )-D( IP1 ) ) - ETA
+ 140 CONTINUE
+ END IF
+ IIM1 = II - 1
+ IIP1 = II + 1
+*
+* Evaluate PSI and the derivative DPSI
+*
+ DPSI = ZERO
+ PSI = ZERO
+ ERRETM = ZERO
+ DO 150 J = 1, IIM1
+ TEMP = Z( J ) / ( WORK( J )*DELTA( J ) )
+ PSI = PSI + Z( J )*TEMP
+ DPSI = DPSI + TEMP*TEMP
+ ERRETM = ERRETM + PSI
+ 150 CONTINUE
+ ERRETM = ABS( ERRETM )
+*
+* Evaluate PHI and the derivative DPHI
+*
+ DPHI = ZERO
+ PHI = ZERO
+ DO 160 J = N, IIP1, -1
+ TEMP = Z( J ) / ( WORK( J )*DELTA( J ) )
+ PHI = PHI + Z( J )*TEMP
+ DPHI = DPHI + TEMP*TEMP
+ ERRETM = ERRETM + PHI
+ 160 CONTINUE
+*
+ W = RHOINV + PHI + PSI
+*
+* W is the value of the secular function with
+* its ii-th element removed.
+*
+ SWTCH3 = .FALSE.
+ IF( ORGATI ) THEN
+ IF( W.LT.ZERO )
+ $ SWTCH3 = .TRUE.
+ ELSE
+ IF( W.GT.ZERO )
+ $ SWTCH3 = .TRUE.
+ END IF
+ IF( II.EQ.1 .OR. II.EQ.N )
+ $ SWTCH3 = .FALSE.
+*
+ TEMP = Z( II ) / ( WORK( II )*DELTA( II ) )
+ DW = DPSI + DPHI + TEMP*TEMP
+ TEMP = Z( II )*TEMP
+ W = W + TEMP
+ ERRETM = EIGHT*( PHI-PSI ) + ERRETM + TWO*RHOINV +
+ $ THREE*ABS( TEMP ) + ABS( TAU )*DW
+*
+* Test for convergence
+*
+ IF( ABS( W ).LE.EPS*ERRETM ) THEN
+ GO TO 240
+ END IF
+*
+ IF( W.LE.ZERO ) THEN
+ SG2LB = MAX( SG2LB, TAU )
+ ELSE
+ SG2UB = MIN( SG2UB, TAU )
+ END IF
+*
+* Calculate the new step
+*
+ NITER = NITER + 1
+ IF( .NOT.SWTCH3 ) THEN
+ DTIPSQ = WORK( IP1 )*DELTA( IP1 )
+ DTISQ = WORK( I )*DELTA( I )
+ IF( ORGATI ) THEN
+ C = W - DTIPSQ*DW + DELSQ*( Z( I ) / DTISQ )**2
+ ELSE
+ C = W - DTISQ*DW - DELSQ*( Z( IP1 ) / DTIPSQ )**2
+ END IF
+ A = ( DTIPSQ+DTISQ )*W - DTIPSQ*DTISQ*DW
+ B = DTIPSQ*DTISQ*W
+ IF( C.EQ.ZERO ) THEN
+ IF( A.EQ.ZERO ) THEN
+ IF( ORGATI ) THEN
+ A = Z( I )*Z( I ) + DTIPSQ*DTIPSQ*( DPSI+DPHI )
+ ELSE
+ A = Z( IP1 )*Z( IP1 ) + DTISQ*DTISQ*( DPSI+DPHI )
+ END IF
+ END IF
+ ETA = B / A
+ ELSE IF( A.LE.ZERO ) THEN
+ ETA = ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C )
+ ELSE
+ ETA = TWO*B / ( A+SQRT( ABS( A*A-FOUR*B*C ) ) )
+ END IF
+ ELSE
+*
+* Interpolation using THREE most relevant poles
+*
+ DTIIM = WORK( IIM1 )*DELTA( IIM1 )
+ DTIIP = WORK( IIP1 )*DELTA( IIP1 )
+ TEMP = RHOINV + PSI + PHI
+ IF( ORGATI ) THEN
+ TEMP1 = Z( IIM1 ) / DTIIM
+ TEMP1 = TEMP1*TEMP1
+ C = ( TEMP - DTIIP*( DPSI+DPHI ) ) -
+ $ ( D( IIM1 )-D( IIP1 ) )*( D( IIM1 )+D( IIP1 ) )*TEMP1
+ ZZ( 1 ) = Z( IIM1 )*Z( IIM1 )
+ IF( DPSI.LT.TEMP1 ) THEN
+ ZZ( 3 ) = DTIIP*DTIIP*DPHI
+ ELSE
+ ZZ( 3 ) = DTIIP*DTIIP*( ( DPSI-TEMP1 )+DPHI )
+ END IF
+ ELSE
+ TEMP1 = Z( IIP1 ) / DTIIP
+ TEMP1 = TEMP1*TEMP1
+ C = ( TEMP - DTIIM*( DPSI+DPHI ) ) -
+ $ ( D( IIP1 )-D( IIM1 ) )*( D( IIM1 )+D( IIP1 ) )*TEMP1
+ IF( DPHI.LT.TEMP1 ) THEN
+ ZZ( 1 ) = DTIIM*DTIIM*DPSI
+ ELSE
+ ZZ( 1 ) = DTIIM*DTIIM*( DPSI+( DPHI-TEMP1 ) )
+ END IF
+ ZZ( 3 ) = Z( IIP1 )*Z( IIP1 )
+ END IF
+ ZZ( 2 ) = Z( II )*Z( II )
+ DD( 1 ) = DTIIM
+ DD( 2 ) = DELTA( II )*WORK( II )
+ DD( 3 ) = DTIIP
+ CALL SLAED6( NITER, ORGATI, C, DD, ZZ, W, ETA, INFO )
+ IF( INFO.NE.0 )
+ $ GO TO 240
+ END IF
+*
+* Note, eta should be positive if w is negative, and
+* eta should be negative otherwise. However,
+* if for some reason caused by roundoff, eta*w > 0,
+* we simply use one Newton step instead. This way
+* will guarantee eta*w < 0.
+*
+ IF( W*ETA.GE.ZERO )
+ $ ETA = -W / DW
+ IF( ORGATI ) THEN
+ TEMP1 = WORK( I )*DELTA( I )
+ TEMP = ETA - TEMP1
+ ELSE
+ TEMP1 = WORK( IP1 )*DELTA( IP1 )
+ TEMP = ETA - TEMP1
+ END IF
+ IF( TEMP.GT.SG2UB .OR. TEMP.LT.SG2LB ) THEN
+ IF( W.LT.ZERO ) THEN
+ ETA = ( SG2UB-TAU ) / TWO
+ ELSE
+ ETA = ( SG2LB-TAU ) / TWO
+ END IF
+ END IF
+*
+ TAU = TAU + ETA
+ ETA = ETA / ( SIGMA+SQRT( SIGMA*SIGMA+ETA ) )
+*
+ PREW = W
+*
+ SIGMA = SIGMA + ETA
+ DO 170 J = 1, N
+ WORK( J ) = WORK( J ) + ETA
+ DELTA( J ) = DELTA( J ) - ETA
+ 170 CONTINUE
+*
+* Evaluate PSI and the derivative DPSI
+*
+ DPSI = ZERO
+ PSI = ZERO
+ ERRETM = ZERO
+ DO 180 J = 1, IIM1
+ TEMP = Z( J ) / ( WORK( J )*DELTA( J ) )
+ PSI = PSI + Z( J )*TEMP
+ DPSI = DPSI + TEMP*TEMP
+ ERRETM = ERRETM + PSI
+ 180 CONTINUE
+ ERRETM = ABS( ERRETM )
+*
+* Evaluate PHI and the derivative DPHI
+*
+ DPHI = ZERO
+ PHI = ZERO
+ DO 190 J = N, IIP1, -1
+ TEMP = Z( J ) / ( WORK( J )*DELTA( J ) )
+ PHI = PHI + Z( J )*TEMP
+ DPHI = DPHI + TEMP*TEMP
+ ERRETM = ERRETM + PHI
+ 190 CONTINUE
+*
+ TEMP = Z( II ) / ( WORK( II )*DELTA( II ) )
+ DW = DPSI + DPHI + TEMP*TEMP
+ TEMP = Z( II )*TEMP
+ W = RHOINV + PHI + PSI + TEMP
+ ERRETM = EIGHT*( PHI-PSI ) + ERRETM + TWO*RHOINV +
+ $ THREE*ABS( TEMP ) + ABS( TAU )*DW
+*
+ IF( W.LE.ZERO ) THEN
+ SG2LB = MAX( SG2LB, TAU )
+ ELSE
+ SG2UB = MIN( SG2UB, TAU )
+ END IF
+*
+ SWTCH = .FALSE.
+ IF( ORGATI ) THEN
+ IF( -W.GT.ABS( PREW ) / TEN )
+ $ SWTCH = .TRUE.
+ ELSE
+ IF( W.GT.ABS( PREW ) / TEN )
+ $ SWTCH = .TRUE.
+ END IF
+*
+* Main loop to update the values of the array DELTA and WORK
+*
+ ITER = NITER + 1
+*
+ DO 230 NITER = ITER, MAXIT
+*
+* Test for convergence
+*
+ IF( ABS( W ).LE.EPS*ERRETM ) THEN
+ GO TO 240
+ END IF
+*
+* Calculate the new step
+*
+ IF( .NOT.SWTCH3 ) THEN
+ DTIPSQ = WORK( IP1 )*DELTA( IP1 )
+ DTISQ = WORK( I )*DELTA( I )
+ IF( .NOT.SWTCH ) THEN
+ IF( ORGATI ) THEN
+ C = W - DTIPSQ*DW + DELSQ*( Z( I ) / DTISQ )**2
+ ELSE
+ C = W - DTISQ*DW - DELSQ*( Z( IP1 ) / DTIPSQ )**2
+ END IF
+ ELSE
+ TEMP = Z( II ) / ( WORK( II )*DELTA( II ) )
+ IF( ORGATI ) THEN
+ DPSI = DPSI + TEMP*TEMP
+ ELSE
+ DPHI = DPHI + TEMP*TEMP
+ END IF
+ C = W - DTISQ*DPSI - DTIPSQ*DPHI
+ END IF
+ A = ( DTIPSQ+DTISQ )*W - DTIPSQ*DTISQ*DW
+ B = DTIPSQ*DTISQ*W
+ IF( C.EQ.ZERO ) THEN
+ IF( A.EQ.ZERO ) THEN
+ IF( .NOT.SWTCH ) THEN
+ IF( ORGATI ) THEN
+ A = Z( I )*Z( I ) + DTIPSQ*DTIPSQ*
+ $ ( DPSI+DPHI )
+ ELSE
+ A = Z( IP1 )*Z( IP1 ) +
+ $ DTISQ*DTISQ*( DPSI+DPHI )
+ END IF
+ ELSE
+ A = DTISQ*DTISQ*DPSI + DTIPSQ*DTIPSQ*DPHI
+ END IF
+ END IF
+ ETA = B / A
+ ELSE IF( A.LE.ZERO ) THEN
+ ETA = ( A-SQRT( ABS( A*A-FOUR*B*C ) ) ) / ( TWO*C )
+ ELSE
+ ETA = TWO*B / ( A+SQRT( ABS( A*A-FOUR*B*C ) ) )
+ END IF
+ ELSE
+*
+* Interpolation using THREE most relevant poles
+*
+ DTIIM = WORK( IIM1 )*DELTA( IIM1 )
+ DTIIP = WORK( IIP1 )*DELTA( IIP1 )
+ TEMP = RHOINV + PSI + PHI
+ IF( SWTCH ) THEN
+ C = TEMP - DTIIM*DPSI - DTIIP*DPHI
+ ZZ( 1 ) = DTIIM*DTIIM*DPSI
+ ZZ( 3 ) = DTIIP*DTIIP*DPHI
+ ELSE
+ IF( ORGATI ) THEN
+ TEMP1 = Z( IIM1 ) / DTIIM
+ TEMP1 = TEMP1*TEMP1
+ TEMP2 = ( D( IIM1 )-D( IIP1 ) )*
+ $ ( D( IIM1 )+D( IIP1 ) )*TEMP1
+ C = TEMP - DTIIP*( DPSI+DPHI ) - TEMP2
+ ZZ( 1 ) = Z( IIM1 )*Z( IIM1 )
+ IF( DPSI.LT.TEMP1 ) THEN
+ ZZ( 3 ) = DTIIP*DTIIP*DPHI
+ ELSE
+ ZZ( 3 ) = DTIIP*DTIIP*( ( DPSI-TEMP1 )+DPHI )
+ END IF
+ ELSE
+ TEMP1 = Z( IIP1 ) / DTIIP
+ TEMP1 = TEMP1*TEMP1
+ TEMP2 = ( D( IIP1 )-D( IIM1 ) )*
+ $ ( D( IIM1 )+D( IIP1 ) )*TEMP1
+ C = TEMP - DTIIM*( DPSI+DPHI ) - TEMP2
+ IF( DPHI.LT.TEMP1 ) THEN
+ ZZ( 1 ) = DTIIM*DTIIM*DPSI
+ ELSE
+ ZZ( 1 ) = DTIIM*DTIIM*( DPSI+( DPHI-TEMP1 ) )
+ END IF
+ ZZ( 3 ) = Z( IIP1 )*Z( IIP1 )
+ END IF
+ END IF
+ DD( 1 ) = DTIIM
+ DD( 2 ) = DELTA( II )*WORK( II )
+ DD( 3 ) = DTIIP
+ CALL SLAED6( NITER, ORGATI, C, DD, ZZ, W, ETA, INFO )
+ IF( INFO.NE.0 )
+ $ GO TO 240
+ END IF
+*
+* Note, eta should be positive if w is negative, and
+* eta should be negative otherwise. However,
+* if for some reason caused by roundoff, eta*w > 0,
+* we simply use one Newton step instead. This way
+* will guarantee eta*w < 0.
+*
+ IF( W*ETA.GE.ZERO )
+ $ ETA = -W / DW
+ IF( ORGATI ) THEN
+ TEMP1 = WORK( I )*DELTA( I )
+ TEMP = ETA - TEMP1
+ ELSE
+ TEMP1 = WORK( IP1 )*DELTA( IP1 )
+ TEMP = ETA - TEMP1
+ END IF
+ IF( TEMP.GT.SG2UB .OR. TEMP.LT.SG2LB ) THEN
+ IF( W.LT.ZERO ) THEN
+ ETA = ( SG2UB-TAU ) / TWO
+ ELSE
+ ETA = ( SG2LB-TAU ) / TWO
+ END IF
+ END IF
+*
+ TAU = TAU + ETA
+ ETA = ETA / ( SIGMA+SQRT( SIGMA*SIGMA+ETA ) )
+*
+ SIGMA = SIGMA + ETA
+ DO 200 J = 1, N
+ WORK( J ) = WORK( J ) + ETA
+ DELTA( J ) = DELTA( J ) - ETA
+ 200 CONTINUE
+*
+ PREW = W
+*
+* Evaluate PSI and the derivative DPSI
+*
+ DPSI = ZERO
+ PSI = ZERO
+ ERRETM = ZERO
+ DO 210 J = 1, IIM1
+ TEMP = Z( J ) / ( WORK( J )*DELTA( J ) )
+ PSI = PSI + Z( J )*TEMP
+ DPSI = DPSI + TEMP*TEMP
+ ERRETM = ERRETM + PSI
+ 210 CONTINUE
+ ERRETM = ABS( ERRETM )
+*
+* Evaluate PHI and the derivative DPHI
+*
+ DPHI = ZERO
+ PHI = ZERO
+ DO 220 J = N, IIP1, -1
+ TEMP = Z( J ) / ( WORK( J )*DELTA( J ) )
+ PHI = PHI + Z( J )*TEMP
+ DPHI = DPHI + TEMP*TEMP
+ ERRETM = ERRETM + PHI
+ 220 CONTINUE
+*
+ TEMP = Z( II ) / ( WORK( II )*DELTA( II ) )
+ DW = DPSI + DPHI + TEMP*TEMP
+ TEMP = Z( II )*TEMP
+ W = RHOINV + PHI + PSI + TEMP
+ ERRETM = EIGHT*( PHI-PSI ) + ERRETM + TWO*RHOINV +
+ $ THREE*ABS( TEMP ) + ABS( TAU )*DW
+ IF( W*PREW.GT.ZERO .AND. ABS( W ).GT.ABS( PREW ) / TEN )
+ $ SWTCH = .NOT.SWTCH
+*
+ IF( W.LE.ZERO ) THEN
+ SG2LB = MAX( SG2LB, TAU )
+ ELSE
+ SG2UB = MIN( SG2UB, TAU )
+ END IF
+*
+ 230 CONTINUE
+*
+* Return with INFO = 1, NITER = MAXIT and not converged
+*
+ INFO = 1
+*
+ END IF
+*
+ 240 CONTINUE
+ RETURN
+*
+* End of SLASD4
+*
+ END
+ SUBROUTINE SLASD5( I, D, Z, DELTA, RHO, DSIGMA, WORK )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER I
+ REAL DSIGMA, RHO
+* ..
+* .. Array Arguments ..
+ REAL D( 2 ), DELTA( 2 ), WORK( 2 ), Z( 2 )
+* ..
+*
+* Purpose
+* =======
+*
+* This subroutine computes the square root of the I-th eigenvalue
+* of a positive symmetric rank-one modification of a 2-by-2 diagonal
+* matrix
+*
+* diag( D ) * diag( D ) + RHO * Z * transpose(Z) .
+*
+* The diagonal entries in the array D are assumed to satisfy
+*
+* 0 <= D(i) < D(j) for i < j .
+*
+* We also assume RHO > 0 and that the Euclidean norm of the vector
+* Z is one.
+*
+* Arguments
+* =========
+*
+* I (input) INTEGER
+* The index of the eigenvalue to be computed. I = 1 or I = 2.
+*
+* D (input) REAL array, dimension (2)
+* The original eigenvalues. We assume 0 <= D(1) < D(2).
+*
+* Z (input) REAL array, dimension (2)
+* The components of the updating vector.
+*
+* DELTA (output) REAL array, dimension (2)
+* Contains (D(j) - sigma_I) in its j-th component.
+* The vector DELTA contains the information necessary
+* to construct the eigenvectors.
+*
+* RHO (input) REAL
+* The scalar in the symmetric updating formula.
+*
+* DSIGMA (output) REAL
+* The computed sigma_I, the I-th updated eigenvalue.
+*
+* WORK (workspace) REAL array, dimension (2)
+* WORK contains (D(j) + sigma_I) in its j-th component.
+*
+* Further Details
+* ===============
+*
+* Based on contributions by
+* Ren-Cang Li, Computer Science Division, University of California
+* at Berkeley, USA
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO, ONE, TWO, THREE, FOUR
+ PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0, TWO = 2.0E+0,
+ $ THREE = 3.0E+0, FOUR = 4.0E+0 )
+* ..
+* .. Local Scalars ..
+ REAL B, C, DEL, DELSQ, TAU, W
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, SQRT
+* ..
+* .. Executable Statements ..
+*
+ DEL = D( 2 ) - D( 1 )
+ DELSQ = DEL*( D( 2 )+D( 1 ) )
+ IF( I.EQ.1 ) THEN
+ W = ONE + FOUR*RHO*( Z( 2 )*Z( 2 ) / ( D( 1 )+THREE*D( 2 ) )-
+ $ Z( 1 )*Z( 1 ) / ( THREE*D( 1 )+D( 2 ) ) ) / DEL
+ IF( W.GT.ZERO ) THEN
+ B = DELSQ + RHO*( Z( 1 )*Z( 1 )+Z( 2 )*Z( 2 ) )
+ C = RHO*Z( 1 )*Z( 1 )*DELSQ
+*
+* B > ZERO, always
+*
+* The following TAU is DSIGMA * DSIGMA - D( 1 ) * D( 1 )
+*
+ TAU = TWO*C / ( B+SQRT( ABS( B*B-FOUR*C ) ) )
+*
+* The following TAU is DSIGMA - D( 1 )
+*
+ TAU = TAU / ( D( 1 )+SQRT( D( 1 )*D( 1 )+TAU ) )
+ DSIGMA = D( 1 ) + TAU
+ DELTA( 1 ) = -TAU
+ DELTA( 2 ) = DEL - TAU
+ WORK( 1 ) = TWO*D( 1 ) + TAU
+ WORK( 2 ) = ( D( 1 )+TAU ) + D( 2 )
+* DELTA( 1 ) = -Z( 1 ) / TAU
+* DELTA( 2 ) = Z( 2 ) / ( DEL-TAU )
+ ELSE
+ B = -DELSQ + RHO*( Z( 1 )*Z( 1 )+Z( 2 )*Z( 2 ) )
+ C = RHO*Z( 2 )*Z( 2 )*DELSQ
+*
+* The following TAU is DSIGMA * DSIGMA - D( 2 ) * D( 2 )
+*
+ IF( B.GT.ZERO ) THEN
+ TAU = -TWO*C / ( B+SQRT( B*B+FOUR*C ) )
+ ELSE
+ TAU = ( B-SQRT( B*B+FOUR*C ) ) / TWO
+ END IF
+*
+* The following TAU is DSIGMA - D( 2 )
+*
+ TAU = TAU / ( D( 2 )+SQRT( ABS( D( 2 )*D( 2 )+TAU ) ) )
+ DSIGMA = D( 2 ) + TAU
+ DELTA( 1 ) = -( DEL+TAU )
+ DELTA( 2 ) = -TAU
+ WORK( 1 ) = D( 1 ) + TAU + D( 2 )
+ WORK( 2 ) = TWO*D( 2 ) + TAU
+* DELTA( 1 ) = -Z( 1 ) / ( DEL+TAU )
+* DELTA( 2 ) = -Z( 2 ) / TAU
+ END IF
+* TEMP = SQRT( DELTA( 1 )*DELTA( 1 )+DELTA( 2 )*DELTA( 2 ) )
+* DELTA( 1 ) = DELTA( 1 ) / TEMP
+* DELTA( 2 ) = DELTA( 2 ) / TEMP
+ ELSE
+*
+* Now I=2
+*
+ B = -DELSQ + RHO*( Z( 1 )*Z( 1 )+Z( 2 )*Z( 2 ) )
+ C = RHO*Z( 2 )*Z( 2 )*DELSQ
+*
+* The following TAU is DSIGMA * DSIGMA - D( 2 ) * D( 2 )
+*
+ IF( B.GT.ZERO ) THEN
+ TAU = ( B+SQRT( B*B+FOUR*C ) ) / TWO
+ ELSE
+ TAU = TWO*C / ( -B+SQRT( B*B+FOUR*C ) )
+ END IF
+*
+* The following TAU is DSIGMA - D( 2 )
+*
+ TAU = TAU / ( D( 2 )+SQRT( D( 2 )*D( 2 )+TAU ) )
+ DSIGMA = D( 2 ) + TAU
+ DELTA( 1 ) = -( DEL+TAU )
+ DELTA( 2 ) = -TAU
+ WORK( 1 ) = D( 1 ) + TAU + D( 2 )
+ WORK( 2 ) = TWO*D( 2 ) + TAU
+* DELTA( 1 ) = -Z( 1 ) / ( DEL+TAU )
+* DELTA( 2 ) = -Z( 2 ) / TAU
+* TEMP = SQRT( DELTA( 1 )*DELTA( 1 )+DELTA( 2 )*DELTA( 2 ) )
+* DELTA( 1 ) = DELTA( 1 ) / TEMP
+* DELTA( 2 ) = DELTA( 2 ) / TEMP
+ END IF
+ RETURN
+*
+* End of SLASD5
+*
+ END
+ 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 )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER GIVPTR, ICOMPQ, INFO, K, LDGCOL, LDGNUM, NL,
+ $ NR, SQRE
+ REAL ALPHA, BETA, C, S
+* ..
+* .. Array Arguments ..
+ INTEGER GIVCOL( LDGCOL, * ), IDXQ( * ), IWORK( * ),
+ $ PERM( * )
+ REAL D( * ), DIFL( * ), DIFR( * ),
+ $ GIVNUM( LDGNUM, * ), POLES( LDGNUM, * ),
+ $ VF( * ), VL( * ), WORK( * ), Z( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SLASD6 computes the SVD of an updated upper bidiagonal matrix B
+* obtained by merging two smaller ones by appending a row. This
+* routine is used only for the problem which requires all singular
+* values and optionally singular vector matrices in factored form.
+* B is an N-by-M matrix with N = NL + NR + 1 and M = N + SQRE.
+* A related subroutine, SLASD1, handles the case in which all singular
+* values and singular vectors of the bidiagonal matrix are desired.
+*
+* SLASD6 computes the SVD as follows:
+*
+* ( D1(in) 0 0 0 )
+* B = U(in) * ( Z1' a Z2' b ) * VT(in)
+* ( 0 0 D2(in) 0 )
+*
+* = U(out) * ( D(out) 0) * VT(out)
+*
+* where Z' = (Z1' a Z2' b) = u' VT', and u is a vector of dimension M
+* with ALPHA and BETA in the NL+1 and NL+2 th entries and zeros
+* elsewhere; and the entry b is empty if SQRE = 0.
+*
+* The singular values of B can be computed using D1, D2, the first
+* components of all the right singular vectors of the lower block, and
+* the last components of all the right singular vectors of the upper
+* block. These components are stored and updated in VF and VL,
+* respectively, in SLASD6. Hence U and VT are not explicitly
+* referenced.
+*
+* The singular values are stored in D. The algorithm consists of two
+* stages:
+*
+* The first stage consists of deflating the size of the problem
+* when there are multiple singular values or if there is a zero
+* in the Z vector. For each such occurence the dimension of the
+* secular equation problem is reduced by one. This stage is
+* performed by the routine SLASD7.
+*
+* The second stage consists of calculating the updated
+* singular values. This is done by finding the roots of the
+* secular equation via the routine SLASD4 (as called by SLASD8).
+* This routine also updates VF and VL and computes the distances
+* between the updated singular values and the old singular
+* values.
+*
+* SLASD6 is called from SLASDA.
+*
+* Arguments
+* =========
+*
+* ICOMPQ (input) INTEGER
+* Specifies whether singular vectors are to be computed in
+* factored form:
+* = 0: Compute singular values only.
+* = 1: Compute singular vectors in factored form as well.
+*
+* NL (input) INTEGER
+* The row dimension of the upper block. NL >= 1.
+*
+* NR (input) INTEGER
+* The row dimension of the lower block. NR >= 1.
+*
+* SQRE (input) INTEGER
+* = 0: the lower block is an NR-by-NR square matrix.
+* = 1: the lower block is an NR-by-(NR+1) rectangular matrix.
+*
+* The bidiagonal matrix has row dimension N = NL + NR + 1,
+* and column dimension M = N + SQRE.
+*
+* D (input/output) REAL array, dimension (NL+NR+1).
+* On entry D(1:NL,1:NL) contains the singular values of the
+* upper block, and D(NL+2:N) contains the singular values
+* of the lower block. On exit D(1:N) contains the singular
+* values of the modified matrix.
+*
+* VF (input/output) REAL array, dimension (M)
+* On entry, VF(1:NL+1) contains the first components of all
+* right singular vectors of the upper block; and VF(NL+2:M)
+* contains the first components of all right singular vectors
+* of the lower block. On exit, VF contains the first components
+* of all right singular vectors of the bidiagonal matrix.
+*
+* VL (input/output) REAL array, dimension (M)
+* On entry, VL(1:NL+1) contains the last components of all
+* right singular vectors of the upper block; and VL(NL+2:M)
+* contains the last components of all right singular vectors of
+* the lower block. On exit, VL contains the last components of
+* all right singular vectors of the bidiagonal matrix.
+*
+* ALPHA (input/output) REAL
+* Contains the diagonal element associated with the added row.
+*
+* BETA (input/output) REAL
+* Contains the off-diagonal element associated with the added
+* row.
+*
+* IDXQ (output) INTEGER array, dimension (N)
+* This contains the permutation which will reintegrate the
+* subproblem just solved back into sorted order, i.e.
+* D( IDXQ( I = 1, N ) ) will be in ascending order.
+*
+* PERM (output) INTEGER array, dimension ( N )
+* The permutations (from deflation and sorting) to be applied
+* to each block. Not referenced if ICOMPQ = 0.
+*
+* GIVPTR (output) INTEGER
+* The number of Givens rotations which took place in this
+* subproblem. Not referenced if ICOMPQ = 0.
+*
+* GIVCOL (output) INTEGER array, dimension ( LDGCOL, 2 )
+* Each pair of numbers indicates a pair of columns to take place
+* in a Givens rotation. Not referenced if ICOMPQ = 0.
+*
+* LDGCOL (input) INTEGER
+* leading dimension of GIVCOL, must be at least N.
+*
+* GIVNUM (output) REAL array, dimension ( LDGNUM, 2 )
+* Each number indicates the C or S value to be used in the
+* corresponding Givens rotation. Not referenced if ICOMPQ = 0.
+*
+* LDGNUM (input) INTEGER
+* The leading dimension of GIVNUM and POLES, must be at least N.
+*
+* POLES (output) REAL array, dimension ( LDGNUM, 2 )
+* On exit, POLES(1,*) is an array containing the new singular
+* values obtained from solving the secular equation, and
+* POLES(2,*) is an array containing the poles in the secular
+* equation. Not referenced if ICOMPQ = 0.
+*
+* DIFL (output) REAL array, dimension ( N )
+* On exit, DIFL(I) is the distance between I-th updated
+* (undeflated) singular value and the I-th (undeflated) old
+* singular value.
+*
+* DIFR (output) REAL array,
+* dimension ( LDGNUM, 2 ) if ICOMPQ = 1 and
+* dimension ( N ) if ICOMPQ = 0.
+* On exit, DIFR(I, 1) is the distance between I-th updated
+* (undeflated) singular value and the I+1-th (undeflated) old
+* singular value.
+*
+* If ICOMPQ = 1, DIFR(1:K,2) is an array containing the
+* normalizing factors for the right singular vector matrix.
+*
+* See SLASD8 for details on DIFL and DIFR.
+*
+* Z (output) REAL array, dimension ( M )
+* The first elements of this array contain the components
+* of the deflation-adjusted updating row vector.
+*
+* K (output) INTEGER
+* Contains the dimension of the non-deflated matrix,
+* This is the order of the related secular equation. 1 <= K <=N.
+*
+* C (output) REAL
+* C contains garbage if SQRE =0 and the C-value of a Givens
+* rotation related to the right null space if SQRE = 1.
+*
+* S (output) REAL
+* S contains garbage if SQRE =0 and the S-value of a Givens
+* rotation related to the right null space if SQRE = 1.
+*
+* WORK (workspace) REAL array, dimension ( 4 * M )
+*
+* IWORK (workspace) INTEGER array, dimension ( 3 * N )
+*
+* INFO (output) INTEGER
+* = 0: successful exit.
+* < 0: if INFO = -i, the i-th argument had an illegal value.
+* > 0: if INFO = 1, an singular value did not converge
+*
+* Further Details
+* ===============
+*
+* Based on contributions by
+* Ming Gu and Huan Ren, Computer Science Division, University of
+* California at Berkeley, USA
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ONE, ZERO
+ PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, IDX, IDXC, IDXP, ISIGMA, IVFW, IVLW, IW, M,
+ $ N, N1, N2
+ REAL ORGNRM
+* ..
+* .. External Subroutines ..
+ EXTERNAL SCOPY, SLAMRG, SLASCL, SLASD7, SLASD8, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ N = NL + NR + 1
+ M = N + SQRE
+*
+ IF( ( ICOMPQ.LT.0 ) .OR. ( ICOMPQ.GT.1 ) ) THEN
+ INFO = -1
+ ELSE IF( NL.LT.1 ) THEN
+ INFO = -2
+ ELSE IF( NR.LT.1 ) THEN
+ INFO = -3
+ ELSE IF( ( SQRE.LT.0 ) .OR. ( SQRE.GT.1 ) ) THEN
+ INFO = -4
+ ELSE IF( LDGCOL.LT.N ) THEN
+ INFO = -14
+ ELSE IF( LDGNUM.LT.N ) THEN
+ INFO = -16
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SLASD6', -INFO )
+ RETURN
+ END IF
+*
+* The following values are for bookkeeping purposes only. They are
+* integer pointers which indicate the portion of the workspace
+* used by a particular array in SLASD7 and SLASD8.
+*
+ ISIGMA = 1
+ IW = ISIGMA + N
+ IVFW = IW + M
+ IVLW = IVFW + M
+*
+ IDX = 1
+ IDXC = IDX + N
+ IDXP = IDXC + N
+*
+* Scale.
+*
+ ORGNRM = MAX( ABS( ALPHA ), ABS( BETA ) )
+ D( NL+1 ) = ZERO
+ DO 10 I = 1, N
+ IF( ABS( D( I ) ).GT.ORGNRM ) THEN
+ ORGNRM = ABS( D( I ) )
+ END IF
+ 10 CONTINUE
+ CALL SLASCL( 'G', 0, 0, ORGNRM, ONE, N, 1, D, N, INFO )
+ ALPHA = ALPHA / ORGNRM
+ BETA = BETA / ORGNRM
+*
+* Sort and Deflate singular values.
+*
+ CALL SLASD7( ICOMPQ, NL, NR, SQRE, K, D, Z, WORK( IW ), VF,
+ $ WORK( IVFW ), VL, WORK( IVLW ), ALPHA, BETA,
+ $ WORK( ISIGMA ), IWORK( IDX ), IWORK( IDXP ), IDXQ,
+ $ PERM, GIVPTR, GIVCOL, LDGCOL, GIVNUM, LDGNUM, C, S,
+ $ INFO )
+*
+* Solve Secular Equation, compute DIFL, DIFR, and update VF, VL.
+*
+ CALL SLASD8( ICOMPQ, K, D, Z, VF, VL, DIFL, DIFR, LDGNUM,
+ $ WORK( ISIGMA ), WORK( IW ), INFO )
+*
+* Save the poles if ICOMPQ = 1.
+*
+ IF( ICOMPQ.EQ.1 ) THEN
+ CALL SCOPY( K, D, 1, POLES( 1, 1 ), 1 )
+ CALL SCOPY( K, WORK( ISIGMA ), 1, POLES( 1, 2 ), 1 )
+ END IF
+*
+* Unscale.
+*
+ CALL SLASCL( 'G', 0, 0, ONE, ORGNRM, N, 1, D, N, INFO )
+*
+* Prepare the IDXQ sorting permutation.
+*
+ N1 = K
+ N2 = N - K
+ CALL SLAMRG( N1, N2, D, 1, -1, IDXQ )
+*
+ RETURN
+*
+* End of SLASD6
+*
+ END
+ 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 )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER GIVPTR, ICOMPQ, INFO, K, LDGCOL, LDGNUM, NL,
+ $ NR, SQRE
+ REAL ALPHA, BETA, C, S
+* ..
+* .. Array Arguments ..
+ INTEGER GIVCOL( LDGCOL, * ), IDX( * ), IDXP( * ),
+ $ IDXQ( * ), PERM( * )
+ REAL D( * ), DSIGMA( * ), GIVNUM( LDGNUM, * ),
+ $ VF( * ), VFW( * ), VL( * ), VLW( * ), Z( * ),
+ $ ZW( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SLASD7 merges the two sets of singular values together into a single
+* sorted set. Then it tries to deflate the size of the problem. There
+* are two ways in which deflation can occur: when two or more singular
+* values are close together or if there is a tiny entry in the Z
+* vector. For each such occurrence the order of the related
+* secular equation problem is reduced by one.
+*
+* SLASD7 is called from SLASD6.
+*
+* Arguments
+* =========
+*
+* ICOMPQ (input) INTEGER
+* Specifies whether singular vectors are to be computed
+* in compact form, as follows:
+* = 0: Compute singular values only.
+* = 1: Compute singular vectors of upper
+* bidiagonal matrix in compact form.
+*
+* NL (input) INTEGER
+* The row dimension of the upper block. NL >= 1.
+*
+* NR (input) INTEGER
+* The row dimension of the lower block. NR >= 1.
+*
+* SQRE (input) INTEGER
+* = 0: the lower block is an NR-by-NR square matrix.
+* = 1: the lower block is an NR-by-(NR+1) rectangular matrix.
+*
+* The bidiagonal matrix has
+* N = NL + NR + 1 rows and
+* M = N + SQRE >= N columns.
+*
+* K (output) INTEGER
+* Contains the dimension of the non-deflated matrix, this is
+* the order of the related secular equation. 1 <= K <=N.
+*
+* D (input/output) REAL array, dimension ( N )
+* On entry D contains the singular values of the two submatrices
+* to be combined. On exit D contains the trailing (N-K) updated
+* singular values (those which were deflated) sorted into
+* increasing order.
+*
+* Z (output) REAL array, dimension ( M )
+* On exit Z contains the updating row vector in the secular
+* equation.
+*
+* ZW (workspace) REAL array, dimension ( M )
+* Workspace for Z.
+*
+* VF (input/output) REAL array, dimension ( M )
+* On entry, VF(1:NL+1) contains the first components of all
+* right singular vectors of the upper block; and VF(NL+2:M)
+* contains the first components of all right singular vectors
+* of the lower block. On exit, VF contains the first components
+* of all right singular vectors of the bidiagonal matrix.
+*
+* VFW (workspace) REAL array, dimension ( M )
+* Workspace for VF.
+*
+* VL (input/output) REAL array, dimension ( M )
+* On entry, VL(1:NL+1) contains the last components of all
+* right singular vectors of the upper block; and VL(NL+2:M)
+* contains the last components of all right singular vectors
+* of the lower block. On exit, VL contains the last components
+* of all right singular vectors of the bidiagonal matrix.
+*
+* VLW (workspace) REAL array, dimension ( M )
+* Workspace for VL.
+*
+* ALPHA (input) REAL
+* Contains the diagonal element associated with the added row.
+*
+* BETA (input) REAL
+* Contains the off-diagonal element associated with the added
+* row.
+*
+* DSIGMA (output) REAL array, dimension ( N )
+* Contains a copy of the diagonal elements (K-1 singular values
+* and one zero) in the secular equation.
+*
+* IDX (workspace) INTEGER array, dimension ( N )
+* This will contain the permutation used to sort the contents of
+* D into ascending order.
+*
+* IDXP (workspace) INTEGER array, dimension ( N )
+* This will contain the permutation used to place deflated
+* values of D at the end of the array. On output IDXP(2:K)
+* points to the nondeflated D-values and IDXP(K+1:N)
+* points to the deflated singular values.
+*
+* IDXQ (input) INTEGER array, dimension ( N )
+* This contains the permutation which separately sorts the two
+* sub-problems in D into ascending order. Note that entries in
+* the first half of this permutation must first be moved one
+* position backward; and entries in the second half
+* must first have NL+1 added to their values.
+*
+* PERM (output) INTEGER array, dimension ( N )
+* The permutations (from deflation and sorting) to be applied
+* to each singular block. Not referenced if ICOMPQ = 0.
+*
+* GIVPTR (output) INTEGER
+* The number of Givens rotations which took place in this
+* subproblem. Not referenced if ICOMPQ = 0.
+*
+* GIVCOL (output) INTEGER array, dimension ( LDGCOL, 2 )
+* Each pair of numbers indicates a pair of columns to take place
+* in a Givens rotation. Not referenced if ICOMPQ = 0.
+*
+* LDGCOL (input) INTEGER
+* The leading dimension of GIVCOL, must be at least N.
+*
+* GIVNUM (output) REAL array, dimension ( LDGNUM, 2 )
+* Each number indicates the C or S value to be used in the
+* corresponding Givens rotation. Not referenced if ICOMPQ = 0.
+*
+* LDGNUM (input) INTEGER
+* The leading dimension of GIVNUM, must be at least N.
+*
+* C (output) REAL
+* C contains garbage if SQRE =0 and the C-value of a Givens
+* rotation related to the right null space if SQRE = 1.
+*
+* S (output) REAL
+* S contains garbage if SQRE =0 and the S-value of a Givens
+* rotation related to the right null space if SQRE = 1.
+*
+* INFO (output) INTEGER
+* = 0: successful exit.
+* < 0: if INFO = -i, the i-th argument had an illegal value.
+*
+* Further Details
+* ===============
+*
+* Based on contributions by
+* Ming Gu and Huan Ren, Computer Science Division, University of
+* California at Berkeley, USA
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO, ONE, TWO, EIGHT
+ PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0, TWO = 2.0E+0,
+ $ EIGHT = 8.0E+0 )
+* ..
+* .. Local Scalars ..
+*
+ INTEGER I, IDXI, IDXJ, IDXJP, J, JP, JPREV, K2, M, N,
+ $ NLP1, NLP2
+ REAL EPS, HLFTOL, TAU, TOL, Z1
+* ..
+* .. External Subroutines ..
+ EXTERNAL SCOPY, SLAMRG, SROT, XERBLA
+* ..
+* .. External Functions ..
+ REAL SLAMCH, SLAPY2
+ EXTERNAL SLAMCH, SLAPY2
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ N = NL + NR + 1
+ M = N + SQRE
+*
+ IF( ( ICOMPQ.LT.0 ) .OR. ( ICOMPQ.GT.1 ) ) THEN
+ INFO = -1
+ ELSE IF( NL.LT.1 ) THEN
+ INFO = -2
+ ELSE IF( NR.LT.1 ) THEN
+ INFO = -3
+ ELSE IF( ( SQRE.LT.0 ) .OR. ( SQRE.GT.1 ) ) THEN
+ INFO = -4
+ ELSE IF( LDGCOL.LT.N ) THEN
+ INFO = -22
+ ELSE IF( LDGNUM.LT.N ) THEN
+ INFO = -24
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SLASD7', -INFO )
+ RETURN
+ END IF
+*
+ NLP1 = NL + 1
+ NLP2 = NL + 2
+ IF( ICOMPQ.EQ.1 ) THEN
+ GIVPTR = 0
+ END IF
+*
+* Generate the first part of the vector Z and move the singular
+* values in the first part of D one position backward.
+*
+ Z1 = ALPHA*VL( NLP1 )
+ VL( NLP1 ) = ZERO
+ TAU = VF( NLP1 )
+ DO 10 I = NL, 1, -1
+ Z( I+1 ) = ALPHA*VL( I )
+ VL( I ) = ZERO
+ VF( I+1 ) = VF( I )
+ D( I+1 ) = D( I )
+ IDXQ( I+1 ) = IDXQ( I ) + 1
+ 10 CONTINUE
+ VF( 1 ) = TAU
+*
+* Generate the second part of the vector Z.
+*
+ DO 20 I = NLP2, M
+ Z( I ) = BETA*VF( I )
+ VF( I ) = ZERO
+ 20 CONTINUE
+*
+* Sort the singular values into increasing order
+*
+ DO 30 I = NLP2, N
+ IDXQ( I ) = IDXQ( I ) + NLP1
+ 30 CONTINUE
+*
+* DSIGMA, IDXC, IDXC, and ZW are used as storage space.
+*
+ DO 40 I = 2, N
+ DSIGMA( I ) = D( IDXQ( I ) )
+ ZW( I ) = Z( IDXQ( I ) )
+ VFW( I ) = VF( IDXQ( I ) )
+ VLW( I ) = VL( IDXQ( I ) )
+ 40 CONTINUE
+*
+ CALL SLAMRG( NL, NR, DSIGMA( 2 ), 1, 1, IDX( 2 ) )
+*
+ DO 50 I = 2, N
+ IDXI = 1 + IDX( I )
+ D( I ) = DSIGMA( IDXI )
+ Z( I ) = ZW( IDXI )
+ VF( I ) = VFW( IDXI )
+ VL( I ) = VLW( IDXI )
+ 50 CONTINUE
+*
+* Calculate the allowable deflation tolerence
+*
+ EPS = SLAMCH( 'Epsilon' )
+ TOL = MAX( ABS( ALPHA ), ABS( BETA ) )
+ TOL = EIGHT*EIGHT*EPS*MAX( ABS( D( N ) ), TOL )
+*
+* There are 2 kinds of deflation -- first a value in the z-vector
+* is small, second two (or more) singular values are very close
+* together (their difference is small).
+*
+* If the value in the z-vector is small, we simply permute the
+* array so that the corresponding singular value is moved to the
+* end.
+*
+* If two values in the D-vector are close, we perform a two-sided
+* rotation designed to make one of the corresponding z-vector
+* entries zero, and then permute the array so that the deflated
+* singular value is moved to the end.
+*
+* If there are multiple singular values then the problem deflates.
+* Here the number of equal singular values are found. As each equal
+* singular value is found, an elementary reflector is computed to
+* rotate the corresponding singular subspace so that the
+* corresponding components of Z are zero in this new basis.
+*
+ K = 1
+ K2 = N + 1
+ DO 60 J = 2, N
+ IF( ABS( Z( J ) ).LE.TOL ) THEN
+*
+* Deflate due to small z component.
+*
+ K2 = K2 - 1
+ IDXP( K2 ) = J
+ IF( J.EQ.N )
+ $ GO TO 100
+ ELSE
+ JPREV = J
+ GO TO 70
+ END IF
+ 60 CONTINUE
+ 70 CONTINUE
+ J = JPREV
+ 80 CONTINUE
+ J = J + 1
+ IF( J.GT.N )
+ $ GO TO 90
+ IF( ABS( Z( J ) ).LE.TOL ) THEN
+*
+* Deflate due to small z component.
+*
+ K2 = K2 - 1
+ IDXP( K2 ) = J
+ ELSE
+*
+* Check if singular values are close enough to allow deflation.
+*
+ IF( ABS( D( J )-D( JPREV ) ).LE.TOL ) THEN
+*
+* Deflation is possible.
+*
+ S = Z( JPREV )
+ C = Z( J )
+*
+* Find sqrt(a**2+b**2) without overflow or
+* destructive underflow.
+*
+ TAU = SLAPY2( C, S )
+ Z( J ) = TAU
+ Z( JPREV ) = ZERO
+ C = C / TAU
+ S = -S / TAU
+*
+* Record the appropriate Givens rotation
+*
+ IF( ICOMPQ.EQ.1 ) THEN
+ GIVPTR = GIVPTR + 1
+ IDXJP = IDXQ( IDX( JPREV )+1 )
+ IDXJ = IDXQ( IDX( J )+1 )
+ IF( IDXJP.LE.NLP1 ) THEN
+ IDXJP = IDXJP - 1
+ END IF
+ IF( IDXJ.LE.NLP1 ) THEN
+ IDXJ = IDXJ - 1
+ END IF
+ GIVCOL( GIVPTR, 2 ) = IDXJP
+ GIVCOL( GIVPTR, 1 ) = IDXJ
+ GIVNUM( GIVPTR, 2 ) = C
+ GIVNUM( GIVPTR, 1 ) = S
+ END IF
+ CALL SROT( 1, VF( JPREV ), 1, VF( J ), 1, C, S )
+ CALL SROT( 1, VL( JPREV ), 1, VL( J ), 1, C, S )
+ K2 = K2 - 1
+ IDXP( K2 ) = JPREV
+ JPREV = J
+ ELSE
+ K = K + 1
+ ZW( K ) = Z( JPREV )
+ DSIGMA( K ) = D( JPREV )
+ IDXP( K ) = JPREV
+ JPREV = J
+ END IF
+ END IF
+ GO TO 80
+ 90 CONTINUE
+*
+* Record the last singular value.
+*
+ K = K + 1
+ ZW( K ) = Z( JPREV )
+ DSIGMA( K ) = D( JPREV )
+ IDXP( K ) = JPREV
+*
+ 100 CONTINUE
+*
+* Sort the singular values into DSIGMA. The singular values which
+* were not deflated go into the first K slots of DSIGMA, except
+* that DSIGMA(1) is treated separately.
+*
+ DO 110 J = 2, N
+ JP = IDXP( J )
+ DSIGMA( J ) = D( JP )
+ VFW( J ) = VF( JP )
+ VLW( J ) = VL( JP )
+ 110 CONTINUE
+ IF( ICOMPQ.EQ.1 ) THEN
+ DO 120 J = 2, N
+ JP = IDXP( J )
+ PERM( J ) = IDXQ( IDX( JP )+1 )
+ IF( PERM( J ).LE.NLP1 ) THEN
+ PERM( J ) = PERM( J ) - 1
+ END IF
+ 120 CONTINUE
+ END IF
+*
+* The deflated singular values go back into the last N - K slots of
+* D.
+*
+ CALL SCOPY( N-K, DSIGMA( K+1 ), 1, D( K+1 ), 1 )
+*
+* Determine DSIGMA(1), DSIGMA(2), Z(1), VF(1), VL(1), VF(M), and
+* VL(M).
+*
+ DSIGMA( 1 ) = ZERO
+ HLFTOL = TOL / TWO
+ IF( ABS( DSIGMA( 2 ) ).LE.HLFTOL )
+ $ DSIGMA( 2 ) = HLFTOL
+ IF( M.GT.N ) THEN
+ Z( 1 ) = SLAPY2( Z1, Z( M ) )
+ IF( Z( 1 ).LE.TOL ) THEN
+ C = ONE
+ S = ZERO
+ Z( 1 ) = TOL
+ ELSE
+ C = Z1 / Z( 1 )
+ S = -Z( M ) / Z( 1 )
+ END IF
+ CALL SROT( 1, VF( M ), 1, VF( 1 ), 1, C, S )
+ CALL SROT( 1, VL( M ), 1, VL( 1 ), 1, C, S )
+ ELSE
+ IF( ABS( Z1 ).LE.TOL ) THEN
+ Z( 1 ) = TOL
+ ELSE
+ Z( 1 ) = Z1
+ END IF
+ END IF
+*
+* Restore Z, VF, and VL.
+*
+ CALL SCOPY( K-1, ZW( 2 ), 1, Z( 2 ), 1 )
+ CALL SCOPY( N-1, VFW( 2 ), 1, VF( 2 ), 1 )
+ CALL SCOPY( N-1, VLW( 2 ), 1, VL( 2 ), 1 )
+*
+ RETURN
+*
+* End of SLASD7
+*
+ END
+ SUBROUTINE SLASD8( ICOMPQ, K, D, Z, VF, VL, DIFL, DIFR, LDDIFR,
+ $ DSIGMA, WORK, INFO )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER ICOMPQ, INFO, K, LDDIFR
+* ..
+* .. Array Arguments ..
+ REAL D( * ), DIFL( * ), DIFR( LDDIFR, * ),
+ $ DSIGMA( * ), VF( * ), VL( * ), WORK( * ),
+ $ Z( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SLASD8 finds the square roots of the roots of the secular equation,
+* as defined by the values in DSIGMA and Z. It makes the appropriate
+* calls to SLASD4, and stores, for each element in D, the distance
+* to its two nearest poles (elements in DSIGMA). It also updates
+* the arrays VF and VL, the first and last components of all the
+* right singular vectors of the original bidiagonal matrix.
+*
+* SLASD8 is called from SLASD6.
+*
+* Arguments
+* =========
+*
+* ICOMPQ (input) INTEGER
+* Specifies whether singular vectors are to be computed in
+* factored form in the calling routine:
+* = 0: Compute singular values only.
+* = 1: Compute singular vectors in factored form as well.
+*
+* K (input) INTEGER
+* The number of terms in the rational function to be solved
+* by SLASD4. K >= 1.
+*
+* D (output) REAL array, dimension ( K )
+* On output, D contains the updated singular values.
+*
+* Z (input) REAL array, dimension ( K )
+* The first K elements of this array contain the components
+* of the deflation-adjusted updating row vector.
+*
+* VF (input/output) REAL array, dimension ( K )
+* On entry, VF contains information passed through DBEDE8.
+* On exit, VF contains the first K components of the first
+* components of all right singular vectors of the bidiagonal
+* matrix.
+*
+* VL (input/output) REAL array, dimension ( K )
+* On entry, VL contains information passed through DBEDE8.
+* On exit, VL contains the first K components of the last
+* components of all right singular vectors of the bidiagonal
+* matrix.
+*
+* DIFL (output) REAL array, dimension ( K )
+* On exit, DIFL(I) = D(I) - DSIGMA(I).
+*
+* DIFR (output) REAL array,
+* dimension ( LDDIFR, 2 ) if ICOMPQ = 1 and
+* dimension ( K ) if ICOMPQ = 0.
+* On exit, DIFR(I,1) = D(I) - DSIGMA(I+1), DIFR(K,1) is not
+* defined and will not be referenced.
+*
+* If ICOMPQ = 1, DIFR(1:K,2) is an array containing the
+* normalizing factors for the right singular vector matrix.
+*
+* LDDIFR (input) INTEGER
+* The leading dimension of DIFR, must be at least K.
+*
+* DSIGMA (input) REAL array, dimension ( K )
+* The first K elements of this array contain the old roots
+* of the deflated updating problem. These are the poles
+* of the secular equation.
+*
+* WORK (workspace) REAL array, dimension at least 3 * K
+*
+* INFO (output) INTEGER
+* = 0: successful exit.
+* < 0: if INFO = -i, the i-th argument had an illegal value.
+* > 0: if INFO = 1, an singular value did not converge
+*
+* Further Details
+* ===============
+*
+* Based on contributions by
+* Ming Gu and Huan Ren, Computer Science Division, University of
+* California at Berkeley, USA
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ONE
+ PARAMETER ( ONE = 1.0E+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, IWK1, IWK2, IWK2I, IWK3, IWK3I, J
+ REAL DIFLJ, DIFRJ, DJ, DSIGJ, DSIGJP, RHO, TEMP
+* ..
+* .. External Subroutines ..
+ EXTERNAL SCOPY, SLASCL, SLASD4, SLASET, XERBLA
+* ..
+* .. External Functions ..
+ REAL SDOT, SLAMC3, SNRM2
+ EXTERNAL SDOT, SLAMC3, SNRM2
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, SIGN, SQRT
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+*
+ IF( ( ICOMPQ.LT.0 ) .OR. ( ICOMPQ.GT.1 ) ) THEN
+ INFO = -1
+ ELSE IF( K.LT.1 ) THEN
+ INFO = -2
+ ELSE IF( LDDIFR.LT.K ) THEN
+ INFO = -9
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SLASD8', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( K.EQ.1 ) THEN
+ D( 1 ) = ABS( Z( 1 ) )
+ DIFL( 1 ) = D( 1 )
+ IF( ICOMPQ.EQ.1 ) THEN
+ DIFL( 2 ) = ONE
+ DIFR( 1, 2 ) = ONE
+ END IF
+ RETURN
+ END IF
+*
+* Modify values DSIGMA(i) to make sure all DSIGMA(i)-DSIGMA(j) can
+* be computed with high relative accuracy (barring over/underflow).
+* This is a problem on machines without a guard digit in
+* add/subtract (Cray XMP, Cray YMP, Cray C 90 and Cray 2).
+* The following code replaces DSIGMA(I) by 2*DSIGMA(I)-DSIGMA(I),
+* which on any of these machines zeros out the bottommost
+* bit of DSIGMA(I) if it is 1; this makes the subsequent
+* subtractions DSIGMA(I)-DSIGMA(J) unproblematic when cancellation
+* occurs. On binary machines with a guard digit (almost all
+* machines) it does not change DSIGMA(I) at all. On hexadecimal
+* and decimal machines with a guard digit, it slightly
+* changes the bottommost bits of DSIGMA(I). It does not account
+* for hexadecimal or decimal machines without guard digits
+* (we know of none). We use a subroutine call to compute
+* 2*DSIGMA(I) to prevent optimizing compilers from eliminating
+* this code.
+*
+ DO 10 I = 1, K
+ DSIGMA( I ) = SLAMC3( DSIGMA( I ), DSIGMA( I ) ) - DSIGMA( I )
+ 10 CONTINUE
+*
+* Book keeping.
+*
+ IWK1 = 1
+ IWK2 = IWK1 + K
+ IWK3 = IWK2 + K
+ IWK2I = IWK2 - 1
+ IWK3I = IWK3 - 1
+*
+* Normalize Z.
+*
+ RHO = SNRM2( K, Z, 1 )
+ CALL SLASCL( 'G', 0, 0, RHO, ONE, K, 1, Z, K, INFO )
+ RHO = RHO*RHO
+*
+* Initialize WORK(IWK3).
+*
+ CALL SLASET( 'A', K, 1, ONE, ONE, WORK( IWK3 ), K )
+*
+* Compute the updated singular values, the arrays DIFL, DIFR,
+* and the updated Z.
+*
+ DO 40 J = 1, K
+ CALL SLASD4( K, J, DSIGMA, Z, WORK( IWK1 ), RHO, D( J ),
+ $ WORK( IWK2 ), INFO )
+*
+* If the root finder fails, the computation is terminated.
+*
+ IF( INFO.NE.0 ) THEN
+ RETURN
+ END IF
+ WORK( IWK3I+J ) = WORK( IWK3I+J )*WORK( J )*WORK( IWK2I+J )
+ DIFL( J ) = -WORK( J )
+ DIFR( J, 1 ) = -WORK( J+1 )
+ DO 20 I = 1, J - 1
+ WORK( IWK3I+I ) = WORK( IWK3I+I )*WORK( I )*
+ $ WORK( IWK2I+I ) / ( DSIGMA( I )-
+ $ DSIGMA( J ) ) / ( DSIGMA( I )+
+ $ DSIGMA( J ) )
+ 20 CONTINUE
+ DO 30 I = J + 1, K
+ WORK( IWK3I+I ) = WORK( IWK3I+I )*WORK( I )*
+ $ WORK( IWK2I+I ) / ( DSIGMA( I )-
+ $ DSIGMA( J ) ) / ( DSIGMA( I )+
+ $ DSIGMA( J ) )
+ 30 CONTINUE
+ 40 CONTINUE
+*
+* Compute updated Z.
+*
+ DO 50 I = 1, K
+ Z( I ) = SIGN( SQRT( ABS( WORK( IWK3I+I ) ) ), Z( I ) )
+ 50 CONTINUE
+*
+* Update VF and VL.
+*
+ DO 80 J = 1, K
+ DIFLJ = DIFL( J )
+ DJ = D( J )
+ DSIGJ = -DSIGMA( J )
+ IF( J.LT.K ) THEN
+ DIFRJ = -DIFR( J, 1 )
+ DSIGJP = -DSIGMA( J+1 )
+ END IF
+ WORK( J ) = -Z( J ) / DIFLJ / ( DSIGMA( J )+DJ )
+ DO 60 I = 1, J - 1
+ WORK( I ) = Z( I ) / ( SLAMC3( DSIGMA( I ), DSIGJ )-DIFLJ )
+ $ / ( DSIGMA( I )+DJ )
+ 60 CONTINUE
+ DO 70 I = J + 1, K
+ WORK( I ) = Z( I ) / ( SLAMC3( DSIGMA( I ), DSIGJP )+DIFRJ )
+ $ / ( DSIGMA( I )+DJ )
+ 70 CONTINUE
+ TEMP = SNRM2( K, WORK, 1 )
+ WORK( IWK2I+J ) = SDOT( K, WORK, 1, VF, 1 ) / TEMP
+ WORK( IWK3I+J ) = SDOT( K, WORK, 1, VL, 1 ) / TEMP
+ IF( ICOMPQ.EQ.1 ) THEN
+ DIFR( J, 2 ) = TEMP
+ END IF
+ 80 CONTINUE
+*
+ CALL SCOPY( K, WORK( IWK2 ), 1, VF, 1 )
+ CALL SCOPY( K, WORK( IWK3 ), 1, VL, 1 )
+*
+ RETURN
+*
+* End of SLASD8
+*
+ END
+ 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 )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER ICOMPQ, INFO, LDGCOL, LDU, N, SMLSIZ, SQRE
+* ..
+* .. Array Arguments ..
+ INTEGER GIVCOL( LDGCOL, * ), GIVPTR( * ), IWORK( * ),
+ $ K( * ), PERM( LDGCOL, * )
+ REAL C( * ), D( * ), DIFL( LDU, * ), DIFR( LDU, * ),
+ $ E( * ), GIVNUM( LDU, * ), POLES( LDU, * ),
+ $ S( * ), U( LDU, * ), VT( LDU, * ), WORK( * ),
+ $ Z( LDU, * )
+* ..
+*
+* Purpose
+* =======
+*
+* Using a divide and conquer approach, SLASDA computes the singular
+* value decomposition (SVD) of a real upper bidiagonal N-by-M matrix
+* B with diagonal D and offdiagonal E, where M = N + SQRE. The
+* algorithm computes the singular values in the SVD B = U * S * VT.
+* The orthogonal matrices U and VT are optionally computed in
+* compact form.
+*
+* A related subroutine, SLASD0, computes the singular values and
+* the singular vectors in explicit form.
+*
+* Arguments
+* =========
+*
+* ICOMPQ (input) INTEGER
+* Specifies whether singular vectors are to be computed
+* in compact form, as follows
+* = 0: Compute singular values only.
+* = 1: Compute singular vectors of upper bidiagonal
+* matrix in compact form.
+*
+* SMLSIZ (input) INTEGER
+* The maximum size of the subproblems at the bottom of the
+* computation tree.
+*
+* N (input) INTEGER
+* The row dimension of the upper bidiagonal matrix. This is
+* also the dimension of the main diagonal array D.
+*
+* SQRE (input) INTEGER
+* Specifies the column dimension of the bidiagonal matrix.
+* = 0: The bidiagonal matrix has column dimension M = N;
+* = 1: The bidiagonal matrix has column dimension M = N + 1.
+*
+* D (input/output) REAL array, dimension ( N )
+* On entry D contains the main diagonal of the bidiagonal
+* matrix. On exit D, if INFO = 0, contains its singular values.
+*
+* E (input) REAL array, dimension ( M-1 )
+* Contains the subdiagonal entries of the bidiagonal matrix.
+* On exit, E has been destroyed.
+*
+* U (output) REAL array,
+* dimension ( LDU, SMLSIZ ) if ICOMPQ = 1, and not referenced
+* if ICOMPQ = 0. If ICOMPQ = 1, on exit, U contains the left
+* singular vector matrices of all subproblems at the bottom
+* level.
+*
+* LDU (input) INTEGER, LDU = > N.
+* The leading dimension of arrays U, VT, DIFL, DIFR, POLES,
+* GIVNUM, and Z.
+*
+* VT (output) REAL array,
+* dimension ( LDU, SMLSIZ+1 ) if ICOMPQ = 1, and not referenced
+* if ICOMPQ = 0. If ICOMPQ = 1, on exit, VT' contains the right
+* singular vector matrices of all subproblems at the bottom
+* level.
+*
+* K (output) INTEGER array, dimension ( N )
+* if ICOMPQ = 1 and dimension 1 if ICOMPQ = 0.
+* If ICOMPQ = 1, on exit, K(I) is the dimension of the I-th
+* secular equation on the computation tree.
+*
+* DIFL (output) REAL array, dimension ( LDU, NLVL ),
+* where NLVL = floor(log_2 (N/SMLSIZ))).
+*
+* DIFR (output) REAL array,
+* dimension ( LDU, 2 * NLVL ) if ICOMPQ = 1 and
+* dimension ( N ) if ICOMPQ = 0.
+* If ICOMPQ = 1, on exit, DIFL(1:N, I) and DIFR(1:N, 2 * I - 1)
+* record distances between singular values on the I-th
+* level and singular values on the (I -1)-th level, and
+* DIFR(1:N, 2 * I ) contains the normalizing factors for
+* the right singular vector matrix. See SLASD8 for details.
+*
+* Z (output) REAL array,
+* dimension ( LDU, NLVL ) if ICOMPQ = 1 and
+* dimension ( N ) if ICOMPQ = 0.
+* The first K elements of Z(1, I) contain the components of
+* the deflation-adjusted updating row vector for subproblems
+* on the I-th level.
+*
+* POLES (output) REAL array,
+* dimension ( LDU, 2 * NLVL ) if ICOMPQ = 1, and not referenced
+* if ICOMPQ = 0. If ICOMPQ = 1, on exit, POLES(1, 2*I - 1) and
+* POLES(1, 2*I) contain the new and old singular values
+* involved in the secular equations on the I-th level.
+*
+* GIVPTR (output) INTEGER array,
+* dimension ( N ) if ICOMPQ = 1, and not referenced if
+* ICOMPQ = 0. If ICOMPQ = 1, on exit, GIVPTR( I ) records
+* the number of Givens rotations performed on the I-th
+* problem on the computation tree.
+*
+* GIVCOL (output) INTEGER array,
+* dimension ( LDGCOL, 2 * NLVL ) if ICOMPQ = 1, and not
+* referenced if ICOMPQ = 0. If ICOMPQ = 1, on exit, for each I,
+* GIVCOL(1, 2 *I - 1) and GIVCOL(1, 2 *I) record the locations
+* of Givens rotations performed on the I-th level on the
+* computation tree.
+*
+* LDGCOL (input) INTEGER, LDGCOL = > N.
+* The leading dimension of arrays GIVCOL and PERM.
+*
+* PERM (output) INTEGER array, dimension ( LDGCOL, NLVL )
+* if ICOMPQ = 1, and not referenced
+* if ICOMPQ = 0. If ICOMPQ = 1, on exit, PERM(1, I) records
+* permutations done on the I-th level of the computation tree.
+*
+* GIVNUM (output) REAL array,
+* dimension ( LDU, 2 * NLVL ) if ICOMPQ = 1, and not
+* referenced if ICOMPQ = 0. If ICOMPQ = 1, on exit, for each I,
+* GIVNUM(1, 2 *I - 1) and GIVNUM(1, 2 *I) record the C- and S-
+* values of Givens rotations performed on the I-th level on
+* the computation tree.
+*
+* C (output) REAL array,
+* dimension ( N ) if ICOMPQ = 1, and dimension 1 if ICOMPQ = 0.
+* If ICOMPQ = 1 and the I-th subproblem is not square, on exit,
+* C( I ) contains the C-value of a Givens rotation related to
+* the right null space of the I-th subproblem.
+*
+* S (output) REAL array, dimension ( N ) if
+* ICOMPQ = 1, and dimension 1 if ICOMPQ = 0. If ICOMPQ = 1
+* and the I-th subproblem is not square, on exit, S( I )
+* contains the S-value of a Givens rotation related to
+* the right null space of the I-th subproblem.
+*
+* WORK (workspace) REAL array, dimension
+* (6 * N + (SMLSIZ + 1)*(SMLSIZ + 1)).
+*
+* IWORK (workspace) INTEGER array, dimension (7*N).
+*
+* INFO (output) INTEGER
+* = 0: successful exit.
+* < 0: if INFO = -i, the i-th argument had an illegal value.
+* > 0: if INFO = 1, an singular value did not converge
+*
+* Further Details
+* ===============
+*
+* Based on contributions by
+* Ming Gu and Huan Ren, Computer Science Division, University of
+* California at Berkeley, USA
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO, ONE
+ PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, I1, IC, IDXQ, IDXQI, IM1, INODE, ITEMP, IWK,
+ $ J, LF, LL, LVL, LVL2, M, NCC, ND, NDB1, NDIML,
+ $ NDIMR, NL, NLF, NLP1, NLVL, NR, NRF, NRP1, NRU,
+ $ NWORK1, NWORK2, SMLSZP, SQREI, VF, VFI, VL, VLI
+ REAL ALPHA, BETA
+* ..
+* .. External Subroutines ..
+ EXTERNAL SCOPY, SLASD6, SLASDQ, SLASDT, SLASET, XERBLA
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+*
+ IF( ( ICOMPQ.LT.0 ) .OR. ( ICOMPQ.GT.1 ) ) THEN
+ INFO = -1
+ ELSE IF( SMLSIZ.LT.3 ) THEN
+ INFO = -2
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( ( SQRE.LT.0 ) .OR. ( SQRE.GT.1 ) ) THEN
+ INFO = -4
+ ELSE IF( LDU.LT.( N+SQRE ) ) THEN
+ INFO = -8
+ ELSE IF( LDGCOL.LT.N ) THEN
+ INFO = -17
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SLASDA', -INFO )
+ RETURN
+ END IF
+*
+ M = N + SQRE
+*
+* If the input matrix is too small, call SLASDQ to find the SVD.
+*
+ IF( N.LE.SMLSIZ ) THEN
+ IF( ICOMPQ.EQ.0 ) THEN
+ CALL SLASDQ( 'U', SQRE, N, 0, 0, 0, D, E, VT, LDU, U, LDU,
+ $ U, LDU, WORK, INFO )
+ ELSE
+ CALL SLASDQ( 'U', SQRE, N, M, N, 0, D, E, VT, LDU, U, LDU,
+ $ U, LDU, WORK, INFO )
+ END IF
+ RETURN
+ END IF
+*
+* Book-keeping and set up the computation tree.
+*
+ INODE = 1
+ NDIML = INODE + N
+ NDIMR = NDIML + N
+ IDXQ = NDIMR + N
+ IWK = IDXQ + N
+*
+ NCC = 0
+ NRU = 0
+*
+ SMLSZP = SMLSIZ + 1
+ VF = 1
+ VL = VF + M
+ NWORK1 = VL + M
+ NWORK2 = NWORK1 + SMLSZP*SMLSZP
+*
+ CALL SLASDT( N, NLVL, ND, IWORK( INODE ), IWORK( NDIML ),
+ $ IWORK( NDIMR ), SMLSIZ )
+*
+* for the nodes on bottom level of the tree, solve
+* their subproblems by SLASDQ.
+*
+ NDB1 = ( ND+1 ) / 2
+ DO 30 I = NDB1, ND
+*
+* IC : center row of each node
+* NL : number of rows of left subproblem
+* NR : number of rows of right subproblem
+* NLF: starting row of the left subproblem
+* NRF: starting row of the right subproblem
+*
+ I1 = I - 1
+ IC = IWORK( INODE+I1 )
+ NL = IWORK( NDIML+I1 )
+ NLP1 = NL + 1
+ NR = IWORK( NDIMR+I1 )
+ NLF = IC - NL
+ NRF = IC + 1
+ IDXQI = IDXQ + NLF - 2
+ VFI = VF + NLF - 1
+ VLI = VL + NLF - 1
+ SQREI = 1
+ IF( ICOMPQ.EQ.0 ) THEN
+ CALL SLASET( 'A', NLP1, NLP1, ZERO, ONE, WORK( NWORK1 ),
+ $ SMLSZP )
+ CALL SLASDQ( 'U', SQREI, NL, NLP1, NRU, NCC, D( NLF ),
+ $ E( NLF ), WORK( NWORK1 ), SMLSZP,
+ $ WORK( NWORK2 ), NL, WORK( NWORK2 ), NL,
+ $ WORK( NWORK2 ), INFO )
+ ITEMP = NWORK1 + NL*SMLSZP
+ CALL SCOPY( NLP1, WORK( NWORK1 ), 1, WORK( VFI ), 1 )
+ CALL SCOPY( NLP1, WORK( ITEMP ), 1, WORK( VLI ), 1 )
+ ELSE
+ CALL SLASET( 'A', NL, NL, ZERO, ONE, U( NLF, 1 ), LDU )
+ CALL SLASET( 'A', NLP1, NLP1, ZERO, ONE, VT( NLF, 1 ), LDU )
+ CALL SLASDQ( 'U', SQREI, NL, NLP1, NL, NCC, D( NLF ),
+ $ E( NLF ), VT( NLF, 1 ), LDU, U( NLF, 1 ), LDU,
+ $ U( NLF, 1 ), LDU, WORK( NWORK1 ), INFO )
+ CALL SCOPY( NLP1, VT( NLF, 1 ), 1, WORK( VFI ), 1 )
+ CALL SCOPY( NLP1, VT( NLF, NLP1 ), 1, WORK( VLI ), 1 )
+ END IF
+ IF( INFO.NE.0 ) THEN
+ RETURN
+ END IF
+ DO 10 J = 1, NL
+ IWORK( IDXQI+J ) = J
+ 10 CONTINUE
+ IF( ( I.EQ.ND ) .AND. ( SQRE.EQ.0 ) ) THEN
+ SQREI = 0
+ ELSE
+ SQREI = 1
+ END IF
+ IDXQI = IDXQI + NLP1
+ VFI = VFI + NLP1
+ VLI = VLI + NLP1
+ NRP1 = NR + SQREI
+ IF( ICOMPQ.EQ.0 ) THEN
+ CALL SLASET( 'A', NRP1, NRP1, ZERO, ONE, WORK( NWORK1 ),
+ $ SMLSZP )
+ CALL SLASDQ( 'U', SQREI, NR, NRP1, NRU, NCC, D( NRF ),
+ $ E( NRF ), WORK( NWORK1 ), SMLSZP,
+ $ WORK( NWORK2 ), NR, WORK( NWORK2 ), NR,
+ $ WORK( NWORK2 ), INFO )
+ ITEMP = NWORK1 + ( NRP1-1 )*SMLSZP
+ CALL SCOPY( NRP1, WORK( NWORK1 ), 1, WORK( VFI ), 1 )
+ CALL SCOPY( NRP1, WORK( ITEMP ), 1, WORK( VLI ), 1 )
+ ELSE
+ CALL SLASET( 'A', NR, NR, ZERO, ONE, U( NRF, 1 ), LDU )
+ CALL SLASET( 'A', NRP1, NRP1, ZERO, ONE, VT( NRF, 1 ), LDU )
+ CALL SLASDQ( 'U', SQREI, NR, NRP1, NR, NCC, D( NRF ),
+ $ E( NRF ), VT( NRF, 1 ), LDU, U( NRF, 1 ), LDU,
+ $ U( NRF, 1 ), LDU, WORK( NWORK1 ), INFO )
+ CALL SCOPY( NRP1, VT( NRF, 1 ), 1, WORK( VFI ), 1 )
+ CALL SCOPY( NRP1, VT( NRF, NRP1 ), 1, WORK( VLI ), 1 )
+ END IF
+ IF( INFO.NE.0 ) THEN
+ RETURN
+ END IF
+ DO 20 J = 1, NR
+ IWORK( IDXQI+J ) = J
+ 20 CONTINUE
+ 30 CONTINUE
+*
+* Now conquer each subproblem bottom-up.
+*
+ J = 2**NLVL
+ DO 50 LVL = NLVL, 1, -1
+ LVL2 = LVL*2 - 1
+*
+* Find the first node LF and last node LL on
+* the current level LVL.
+*
+ IF( LVL.EQ.1 ) THEN
+ LF = 1
+ LL = 1
+ ELSE
+ LF = 2**( LVL-1 )
+ LL = 2*LF - 1
+ END IF
+ DO 40 I = LF, LL
+ IM1 = I - 1
+ IC = IWORK( INODE+IM1 )
+ NL = IWORK( NDIML+IM1 )
+ NR = IWORK( NDIMR+IM1 )
+ NLF = IC - NL
+ NRF = IC + 1
+ IF( I.EQ.LL ) THEN
+ SQREI = SQRE
+ ELSE
+ SQREI = 1
+ END IF
+ VFI = VF + NLF - 1
+ VLI = VL + NLF - 1
+ IDXQI = IDXQ + NLF - 1
+ ALPHA = D( IC )
+ BETA = E( IC )
+ IF( ICOMPQ.EQ.0 ) THEN
+ CALL SLASD6( ICOMPQ, NL, NR, SQREI, D( NLF ),
+ $ WORK( VFI ), WORK( VLI ), ALPHA, BETA,
+ $ IWORK( IDXQI ), PERM, GIVPTR( 1 ), GIVCOL,
+ $ LDGCOL, GIVNUM, LDU, POLES, DIFL, DIFR, Z,
+ $ K( 1 ), C( 1 ), S( 1 ), WORK( NWORK1 ),
+ $ IWORK( IWK ), INFO )
+ ELSE
+ J = J - 1
+ CALL SLASD6( ICOMPQ, NL, NR, SQREI, D( NLF ),
+ $ WORK( VFI ), WORK( VLI ), ALPHA, BETA,
+ $ IWORK( IDXQI ), PERM( NLF, LVL ),
+ $ GIVPTR( J ), GIVCOL( NLF, LVL2 ), LDGCOL,
+ $ GIVNUM( NLF, LVL2 ), LDU,
+ $ POLES( NLF, LVL2 ), DIFL( NLF, LVL ),
+ $ DIFR( NLF, LVL2 ), Z( NLF, LVL ), K( J ),
+ $ C( J ), S( J ), WORK( NWORK1 ),
+ $ IWORK( IWK ), INFO )
+ END IF
+ IF( INFO.NE.0 ) THEN
+ RETURN
+ END IF
+ 40 CONTINUE
+ 50 CONTINUE
+*
+ RETURN
+*
+* End of SLASDA
+*
+ END
+ SUBROUTINE SLASDQ( UPLO, SQRE, N, NCVT, NRU, NCC, D, E, VT, LDVT,
+ $ U, LDU, C, LDC, WORK, INFO )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, LDC, LDU, LDVT, N, NCC, NCVT, NRU, SQRE
+* ..
+* .. Array Arguments ..
+ REAL C( LDC, * ), D( * ), E( * ), U( LDU, * ),
+ $ VT( LDVT, * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SLASDQ computes the singular value decomposition (SVD) of a real
+* (upper or lower) bidiagonal matrix with diagonal D and offdiagonal
+* E, accumulating the transformations if desired. Letting B denote
+* the input bidiagonal matrix, the algorithm computes orthogonal
+* matrices Q and P such that B = Q * S * P' (P' denotes the transpose
+* of P). The singular values S are overwritten on D.
+*
+* The input matrix U is changed to U * Q if desired.
+* The input matrix VT is changed to P' * VT if desired.
+* The input matrix C is changed to Q' * C if desired.
+*
+* See "Computing Small Singular Values of Bidiagonal Matrices With
+* Guaranteed High Relative Accuracy," by J. Demmel and W. Kahan,
+* LAPACK Working Note #3, for a detailed description of the algorithm.
+*
+* Arguments
+* =========
+*
+* UPLO (input) CHARACTER*1
+* On entry, UPLO specifies whether the input bidiagonal matrix
+* is upper or lower bidiagonal, and wether it is square are
+* not.
+* UPLO = 'U' or 'u' B is upper bidiagonal.
+* UPLO = 'L' or 'l' B is lower bidiagonal.
+*
+* SQRE (input) INTEGER
+* = 0: then the input matrix is N-by-N.
+* = 1: then the input matrix is N-by-(N+1) if UPLU = 'U' and
+* (N+1)-by-N if UPLU = 'L'.
+*
+* The bidiagonal matrix has
+* N = NL + NR + 1 rows and
+* M = N + SQRE >= N columns.
+*
+* N (input) INTEGER
+* On entry, N specifies the number of rows and columns
+* in the matrix. N must be at least 0.
+*
+* NCVT (input) INTEGER
+* On entry, NCVT specifies the number of columns of
+* the matrix VT. NCVT must be at least 0.
+*
+* NRU (input) INTEGER
+* On entry, NRU specifies the number of rows of
+* the matrix U. NRU must be at least 0.
+*
+* NCC (input) INTEGER
+* On entry, NCC specifies the number of columns of
+* the matrix C. NCC must be at least 0.
+*
+* D (input/output) REAL array, dimension (N)
+* On entry, D contains the diagonal entries of the
+* bidiagonal matrix whose SVD is desired. On normal exit,
+* D contains the singular values in ascending order.
+*
+* E (input/output) REAL array.
+* dimension is (N-1) if SQRE = 0 and N if SQRE = 1.
+* On entry, the entries of E contain the offdiagonal entries
+* of the bidiagonal matrix whose SVD is desired. On normal
+* exit, E will contain 0. If the algorithm does not converge,
+* D and E will contain the diagonal and superdiagonal entries
+* of a bidiagonal matrix orthogonally equivalent to the one
+* given as input.
+*
+* VT (input/output) REAL array, dimension (LDVT, NCVT)
+* On entry, contains a matrix which on exit has been
+* premultiplied by P', dimension N-by-NCVT if SQRE = 0
+* and (N+1)-by-NCVT if SQRE = 1 (not referenced if NCVT=0).
+*
+* LDVT (input) INTEGER
+* On entry, LDVT specifies the leading dimension of VT as
+* declared in the calling (sub) program. LDVT must be at
+* least 1. If NCVT is nonzero LDVT must also be at least N.
+*
+* U (input/output) REAL array, dimension (LDU, N)
+* On entry, contains a matrix which on exit has been
+* postmultiplied by Q, dimension NRU-by-N if SQRE = 0
+* and NRU-by-(N+1) if SQRE = 1 (not referenced if NRU=0).
+*
+* LDU (input) INTEGER
+* On entry, LDU specifies the leading dimension of U as
+* declared in the calling (sub) program. LDU must be at
+* least max( 1, NRU ) .
+*
+* C (input/output) REAL array, dimension (LDC, NCC)
+* On entry, contains an N-by-NCC matrix which on exit
+* has been premultiplied by Q' dimension N-by-NCC if SQRE = 0
+* and (N+1)-by-NCC if SQRE = 1 (not referenced if NCC=0).
+*
+* LDC (input) INTEGER
+* On entry, LDC specifies the leading dimension of C as
+* declared in the calling (sub) program. LDC must be at
+* least 1. If NCC is nonzero, LDC must also be at least N.
+*
+* WORK (workspace) REAL array, dimension (4*N)
+* Workspace. Only referenced if one of NCVT, NRU, or NCC is
+* nonzero, and if N is at least 2.
+*
+* INFO (output) INTEGER
+* On exit, a value of 0 indicates a successful exit.
+* If INFO < 0, argument number -INFO is illegal.
+* If INFO > 0, the algorithm did not converge, and INFO
+* specifies how many superdiagonals did not converge.
+*
+* Further Details
+* ===============
+*
+* Based on contributions by
+* Ming Gu and Huan Ren, Computer Science Division, University of
+* California at Berkeley, USA
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO
+ PARAMETER ( ZERO = 0.0E+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL ROTATE
+ INTEGER I, ISUB, IUPLO, J, NP1, SQRE1
+ REAL CS, R, SMIN, SN
+* ..
+* .. External Subroutines ..
+ EXTERNAL SBDSQR, SLARTG, SLASR, SSWAP, XERBLA
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ IUPLO = 0
+ IF( LSAME( UPLO, 'U' ) )
+ $ IUPLO = 1
+ IF( LSAME( UPLO, 'L' ) )
+ $ IUPLO = 2
+ IF( IUPLO.EQ.0 ) THEN
+ INFO = -1
+ ELSE IF( ( SQRE.LT.0 ) .OR. ( SQRE.GT.1 ) ) THEN
+ INFO = -2
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( NCVT.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( NRU.LT.0 ) THEN
+ INFO = -5
+ ELSE IF( NCC.LT.0 ) THEN
+ INFO = -6
+ ELSE IF( ( NCVT.EQ.0 .AND. LDVT.LT.1 ) .OR.
+ $ ( NCVT.GT.0 .AND. LDVT.LT.MAX( 1, N ) ) ) THEN
+ INFO = -10
+ ELSE IF( LDU.LT.MAX( 1, NRU ) ) THEN
+ INFO = -12
+ ELSE IF( ( NCC.EQ.0 .AND. LDC.LT.1 ) .OR.
+ $ ( NCC.GT.0 .AND. LDC.LT.MAX( 1, N ) ) ) THEN
+ INFO = -14
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SLASDQ', -INFO )
+ RETURN
+ END IF
+ IF( N.EQ.0 )
+ $ RETURN
+*
+* ROTATE is true if any singular vectors desired, false otherwise
+*
+ ROTATE = ( NCVT.GT.0 ) .OR. ( NRU.GT.0 ) .OR. ( NCC.GT.0 )
+ NP1 = N + 1
+ SQRE1 = SQRE
+*
+* If matrix non-square upper bidiagonal, rotate to be lower
+* bidiagonal. The rotations are on the right.
+*
+ IF( ( IUPLO.EQ.1 ) .AND. ( SQRE1.EQ.1 ) ) THEN
+ DO 10 I = 1, N - 1
+ CALL SLARTG( D( I ), E( I ), CS, SN, R )
+ D( I ) = R
+ E( I ) = SN*D( I+1 )
+ D( I+1 ) = CS*D( I+1 )
+ IF( ROTATE ) THEN
+ WORK( I ) = CS
+ WORK( N+I ) = SN
+ END IF
+ 10 CONTINUE
+ CALL SLARTG( D( N ), E( N ), CS, SN, R )
+ D( N ) = R
+ E( N ) = ZERO
+ IF( ROTATE ) THEN
+ WORK( N ) = CS
+ WORK( N+N ) = SN
+ END IF
+ IUPLO = 2
+ SQRE1 = 0
+*
+* Update singular vectors if desired.
+*
+ IF( NCVT.GT.0 )
+ $ CALL SLASR( 'L', 'V', 'F', NP1, NCVT, WORK( 1 ),
+ $ WORK( NP1 ), VT, LDVT )
+ END IF
+*
+* If matrix lower bidiagonal, rotate to be upper bidiagonal
+* by applying Givens rotations on the left.
+*
+ IF( IUPLO.EQ.2 ) THEN
+ DO 20 I = 1, N - 1
+ CALL SLARTG( D( I ), E( I ), CS, SN, R )
+ D( I ) = R
+ E( I ) = SN*D( I+1 )
+ D( I+1 ) = CS*D( I+1 )
+ IF( ROTATE ) THEN
+ WORK( I ) = CS
+ WORK( N+I ) = SN
+ END IF
+ 20 CONTINUE
+*
+* If matrix (N+1)-by-N lower bidiagonal, one additional
+* rotation is needed.
+*
+ IF( SQRE1.EQ.1 ) THEN
+ CALL SLARTG( D( N ), E( N ), CS, SN, R )
+ D( N ) = R
+ IF( ROTATE ) THEN
+ WORK( N ) = CS
+ WORK( N+N ) = SN
+ END IF
+ END IF
+*
+* Update singular vectors if desired.
+*
+ IF( NRU.GT.0 ) THEN
+ IF( SQRE1.EQ.0 ) THEN
+ CALL SLASR( 'R', 'V', 'F', NRU, N, WORK( 1 ),
+ $ WORK( NP1 ), U, LDU )
+ ELSE
+ CALL SLASR( 'R', 'V', 'F', NRU, NP1, WORK( 1 ),
+ $ WORK( NP1 ), U, LDU )
+ END IF
+ END IF
+ IF( NCC.GT.0 ) THEN
+ IF( SQRE1.EQ.0 ) THEN
+ CALL SLASR( 'L', 'V', 'F', N, NCC, WORK( 1 ),
+ $ WORK( NP1 ), C, LDC )
+ ELSE
+ CALL SLASR( 'L', 'V', 'F', NP1, NCC, WORK( 1 ),
+ $ WORK( NP1 ), C, LDC )
+ END IF
+ END IF
+ END IF
+*
+* Call SBDSQR to compute the SVD of the reduced real
+* N-by-N upper bidiagonal matrix.
+*
+ CALL SBDSQR( 'U', N, NCVT, NRU, NCC, D, E, VT, LDVT, U, LDU, C,
+ $ LDC, WORK, INFO )
+*
+* Sort the singular values into ascending order (insertion sort on
+* singular values, but only one transposition per singular vector)
+*
+ DO 40 I = 1, N
+*
+* Scan for smallest D(I).
+*
+ ISUB = I
+ SMIN = D( I )
+ DO 30 J = I + 1, N
+ IF( D( J ).LT.SMIN ) THEN
+ ISUB = J
+ SMIN = D( J )
+ END IF
+ 30 CONTINUE
+ IF( ISUB.NE.I ) THEN
+*
+* Swap singular values and vectors.
+*
+ D( ISUB ) = D( I )
+ D( I ) = SMIN
+ IF( NCVT.GT.0 )
+ $ CALL SSWAP( NCVT, VT( ISUB, 1 ), LDVT, VT( I, 1 ), LDVT )
+ IF( NRU.GT.0 )
+ $ CALL SSWAP( NRU, U( 1, ISUB ), 1, U( 1, I ), 1 )
+ IF( NCC.GT.0 )
+ $ CALL SSWAP( NCC, C( ISUB, 1 ), LDC, C( I, 1 ), LDC )
+ END IF
+ 40 CONTINUE
+*
+ RETURN
+*
+* End of SLASDQ
+*
+ END
+ SUBROUTINE SLASDT( N, LVL, ND, INODE, NDIML, NDIMR, MSUB )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER LVL, MSUB, N, ND
+* ..
+* .. Array Arguments ..
+ INTEGER INODE( * ), NDIML( * ), NDIMR( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SLASDT creates a tree of subproblems for bidiagonal divide and
+* conquer.
+*
+* Arguments
+* =========
+*
+* N (input) INTEGER
+* On entry, the number of diagonal elements of the
+* bidiagonal matrix.
+*
+* LVL (output) INTEGER
+* On exit, the number of levels on the computation tree.
+*
+* ND (output) INTEGER
+* On exit, the number of nodes on the tree.
+*
+* INODE (output) INTEGER array, dimension ( N )
+* On exit, centers of subproblems.
+*
+* NDIML (output) INTEGER array, dimension ( N )
+* On exit, row dimensions of left children.
+*
+* NDIMR (output) INTEGER array, dimension ( N )
+* On exit, row dimensions of right children.
+*
+* MSUB (input) INTEGER.
+* On entry, the maximum row dimension each subproblem at the
+* bottom of the tree can be of.
+*
+* Further Details
+* ===============
+*
+* Based on contributions by
+* Ming Gu and Huan Ren, Computer Science Division, University of
+* California at Berkeley, USA
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL TWO
+ PARAMETER ( TWO = 2.0E+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, IL, IR, LLST, MAXN, NCRNT, NLVL
+ REAL TEMP
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC INT, LOG, MAX, REAL
+* ..
+* .. Executable Statements ..
+*
+* Find the number of levels on the tree.
+*
+ MAXN = MAX( 1, N )
+ TEMP = LOG( REAL( MAXN ) / REAL( MSUB+1 ) ) / LOG( TWO )
+ LVL = INT( TEMP ) + 1
+*
+ I = N / 2
+ INODE( 1 ) = I + 1
+ NDIML( 1 ) = I
+ NDIMR( 1 ) = N - I - 1
+ IL = 0
+ IR = 1
+ LLST = 1
+ DO 20 NLVL = 1, LVL - 1
+*
+* Constructing the tree at (NLVL+1)-st level. The number of
+* nodes created on this level is LLST * 2.
+*
+ DO 10 I = 0, LLST - 1
+ IL = IL + 2
+ IR = IR + 2
+ NCRNT = LLST + I
+ NDIML( IL ) = NDIML( NCRNT ) / 2
+ NDIMR( IL ) = NDIML( NCRNT ) - NDIML( IL ) - 1
+ INODE( IL ) = INODE( NCRNT ) - NDIMR( IL ) - 1
+ NDIML( IR ) = NDIMR( NCRNT ) / 2
+ NDIMR( IR ) = NDIMR( NCRNT ) - NDIML( IR ) - 1
+ INODE( IR ) = INODE( NCRNT ) + NDIML( IR ) + 1
+ 10 CONTINUE
+ LLST = LLST*2
+ 20 CONTINUE
+ ND = LLST*2 - 1
+*
+ RETURN
+*
+* End of SLASDT
+*
+ END
+ SUBROUTINE SLASET( UPLO, M, N, ALPHA, BETA, A, LDA )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER LDA, M, N
+ REAL ALPHA, BETA
+* ..
+* .. Array Arguments ..
+ REAL A( LDA, * )
+* ..
+*
+* Purpose
+* =======
+*
+* SLASET initializes an m-by-n matrix A to BETA on the diagonal and
+* ALPHA on the offdiagonals.
+*
+* Arguments
+* =========
+*
+* UPLO (input) CHARACTER*1
+* Specifies the part of the matrix A to be set.
+* = 'U': Upper triangular part is set; the strictly lower
+* triangular part of A is not changed.
+* = 'L': Lower triangular part is set; the strictly upper
+* triangular part of A is not changed.
+* Otherwise: All of the matrix A is set.
+*
+* M (input) INTEGER
+* The number of rows of the matrix A. M >= 0.
+*
+* N (input) INTEGER
+* The number of columns of the matrix A. N >= 0.
+*
+* ALPHA (input) REAL
+* The constant to which the offdiagonal elements are to be set.
+*
+* BETA (input) REAL
+* The constant to which the diagonal elements are to be set.
+*
+* A (input/output) REAL array, dimension (LDA,N)
+* On exit, the leading m-by-n submatrix of A is set as follows:
+*
+* if UPLO = 'U', A(i,j) = ALPHA, 1<=i<=j-1, 1<=j<=n,
+* if UPLO = 'L', A(i,j) = ALPHA, j+1<=i<=m, 1<=j<=n,
+* otherwise, A(i,j) = ALPHA, 1<=i<=m, 1<=j<=n, i.ne.j,
+*
+* and, for all UPLO, A(i,i) = BETA, 1<=i<=min(m,n).
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,M).
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ INTEGER I, J
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MIN
+* ..
+* .. Executable Statements ..
+*
+ IF( LSAME( UPLO, 'U' ) ) THEN
+*
+* Set the strictly upper triangular or trapezoidal part of the
+* array to ALPHA.
+*
+ DO 20 J = 2, N
+ DO 10 I = 1, MIN( J-1, M )
+ A( I, J ) = ALPHA
+ 10 CONTINUE
+ 20 CONTINUE
+*
+ ELSE IF( LSAME( UPLO, 'L' ) ) THEN
+*
+* Set the strictly lower triangular or trapezoidal part of the
+* array to ALPHA.
+*
+ DO 40 J = 1, MIN( M, N )
+ DO 30 I = J + 1, M
+ A( I, J ) = ALPHA
+ 30 CONTINUE
+ 40 CONTINUE
+*
+ ELSE
+*
+* Set the leading m-by-n submatrix to ALPHA.
+*
+ DO 60 J = 1, N
+ DO 50 I = 1, M
+ A( I, J ) = ALPHA
+ 50 CONTINUE
+ 60 CONTINUE
+ END IF
+*
+* Set the first min(M,N) diagonal elements to BETA.
+*
+ DO 70 I = 1, MIN( M, N )
+ A( I, I ) = BETA
+ 70 CONTINUE
+*
+ RETURN
+*
+* End of SLASET
+*
+ END
+ SUBROUTINE SLASQ1( N, D, E, WORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, N
+* ..
+* .. Array Arguments ..
+ REAL D( * ), E( * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SLASQ1 computes the singular values of a real N-by-N bidiagonal
+* matrix with diagonal D and off-diagonal E. The singular values
+* are computed to high relative accuracy, in the absence of
+* denormalization, underflow and overflow. The algorithm was first
+* presented in
+*
+* "Accurate singular values and differential qd algorithms" by K. V.
+* Fernando and B. N. Parlett, Numer. Math., Vol-67, No. 2, pp. 191-230,
+* 1994,
+*
+* and the present implementation is described in "An implementation of
+* the dqds Algorithm (Positive Case)", LAPACK Working Note.
+*
+* Arguments
+* =========
+*
+* N (input) INTEGER
+* The number of rows and columns in the matrix. N >= 0.
+*
+* D (input/output) REAL array, dimension (N)
+* On entry, D contains the diagonal elements of the
+* bidiagonal matrix whose SVD is desired. On normal exit,
+* D contains the singular values in decreasing order.
+*
+* E (input/output) REAL array, dimension (N)
+* On entry, elements E(1:N-1) contain the off-diagonal elements
+* of the bidiagonal matrix whose SVD is desired.
+* On exit, E is overwritten.
+*
+* WORK (workspace) REAL array, dimension (4*N)
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* > 0: the algorithm failed
+* = 1, a split was marked by a positive value in E
+* = 2, current block of Z not diagonalized after 30*N
+* iterations (in inner while loop)
+* = 3, termination criterion of outer while loop not met
+* (program created more than N unreduced blocks)
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO
+ PARAMETER ( ZERO = 0.0E0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, IINFO
+ REAL EPS, SCALE, SAFMIN, SIGMN, SIGMX
+* ..
+* .. External Subroutines ..
+ EXTERNAL SCOPY, SLAS2, SLASCL, SLASQ2, SLASRT, XERBLA
+* ..
+* .. External Functions ..
+ REAL SLAMCH
+ EXTERNAL SLAMCH
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, SQRT
+* ..
+* .. Executable Statements ..
+*
+ INFO = 0
+ IF( N.LT.0 ) THEN
+ INFO = -2
+ CALL XERBLA( 'SLASQ1', -INFO )
+ RETURN
+ ELSE IF( N.EQ.0 ) THEN
+ RETURN
+ ELSE IF( N.EQ.1 ) THEN
+ D( 1 ) = ABS( D( 1 ) )
+ RETURN
+ ELSE IF( N.EQ.2 ) THEN
+ CALL SLAS2( D( 1 ), E( 1 ), D( 2 ), SIGMN, SIGMX )
+ D( 1 ) = SIGMX
+ D( 2 ) = SIGMN
+ RETURN
+ END IF
+*
+* Estimate the largest singular value.
+*
+ SIGMX = ZERO
+ DO 10 I = 1, N - 1
+ D( I ) = ABS( D( I ) )
+ SIGMX = MAX( SIGMX, ABS( E( I ) ) )
+ 10 CONTINUE
+ D( N ) = ABS( D( N ) )
+*
+* Early return if SIGMX is zero (matrix is already diagonal).
+*
+ IF( SIGMX.EQ.ZERO ) THEN
+ CALL SLASRT( 'D', N, D, IINFO )
+ RETURN
+ END IF
+*
+ DO 20 I = 1, N
+ SIGMX = MAX( SIGMX, D( I ) )
+ 20 CONTINUE
+*
+* Copy D and E into WORK (in the Z format) and scale (squaring the
+* input data makes scaling by a power of the radix pointless).
+*
+ EPS = SLAMCH( 'Precision' )
+ SAFMIN = SLAMCH( 'Safe minimum' )
+ SCALE = SQRT( EPS / SAFMIN )
+ CALL SCOPY( N, D, 1, WORK( 1 ), 2 )
+ CALL SCOPY( N-1, E, 1, WORK( 2 ), 2 )
+ CALL SLASCL( 'G', 0, 0, SIGMX, SCALE, 2*N-1, 1, WORK, 2*N-1,
+ $ IINFO )
+*
+* Compute the q's and e's.
+*
+ DO 30 I = 1, 2*N - 1
+ WORK( I ) = WORK( I )**2
+ 30 CONTINUE
+ WORK( 2*N ) = ZERO
+*
+ CALL SLASQ2( N, WORK, INFO )
+*
+ IF( INFO.EQ.0 ) THEN
+ DO 40 I = 1, N
+ D( I ) = SQRT( WORK( I ) )
+ 40 CONTINUE
+ CALL SLASCL( 'G', 0, 0, SCALE, SIGMX, N, 1, D, N, IINFO )
+ END IF
+*
+ RETURN
+*
+* End of SLASQ1
+*
+ END
+ SUBROUTINE SLASQ2( N, Z, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* Modified to call SLAZQ3 in place of SLASQ3, 13 Feb 03, SJH.
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, N
+* ..
+* .. Array Arguments ..
+ REAL Z( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SLASQ2 computes all the eigenvalues of the symmetric positive
+* definite tridiagonal matrix associated with the qd array Z to high
+* relative accuracy are computed to high relative accuracy, in the
+* absence of denormalization, underflow and overflow.
+*
+* To see the relation of Z to the tridiagonal matrix, let L be a
+* unit lower bidiagonal matrix with subdiagonals Z(2,4,6,,..) and
+* let U be an upper bidiagonal matrix with 1's above and diagonal
+* Z(1,3,5,,..). The tridiagonal is L*U or, if you prefer, the
+* symmetric tridiagonal to which it is similar.
+*
+* Note : SLASQ2 defines a logical variable, IEEE, which is true
+* on machines which follow ieee-754 floating-point standard in their
+* handling of infinities and NaNs, and false otherwise. This variable
+* is passed to SLAZQ3.
+*
+* Arguments
+* =========
+*
+* N (input) INTEGER
+* The number of rows and columns in the matrix. N >= 0.
+*
+* Z (workspace) REAL array, dimension (4*N)
+* On entry Z holds the qd array. On exit, entries 1 to N hold
+* the eigenvalues in decreasing order, Z( 2*N+1 ) holds the
+* trace, and Z( 2*N+2 ) holds the sum of the eigenvalues. If
+* N > 2, then Z( 2*N+3 ) holds the iteration count, Z( 2*N+4 )
+* holds NDIVS/NIN^2, and Z( 2*N+5 ) holds the percentage of
+* shifts that failed.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if the i-th argument is a scalar and had an illegal
+* value, then INFO = -i, if the i-th argument is an
+* array and the j-entry had an illegal value, then
+* INFO = -(i*100+j)
+* > 0: the algorithm failed
+* = 1, a split was marked by a positive value in E
+* = 2, current block of Z not diagonalized after 30*N
+* iterations (in inner while loop)
+* = 3, termination criterion of outer while loop not met
+* (program created more than N unreduced blocks)
+*
+* Further Details
+* ===============
+* Local Variables: I0:N0 defines a current unreduced segment of Z.
+* The shifts are accumulated in SIGMA. Iteration count is in ITER.
+* Ping-pong is controlled by PP (alternates between 0 and 1).
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL CBIAS
+ PARAMETER ( CBIAS = 1.50E0 )
+ REAL ZERO, HALF, ONE, TWO, FOUR, HUNDRD
+ PARAMETER ( ZERO = 0.0E0, HALF = 0.5E0, ONE = 1.0E0,
+ $ TWO = 2.0E0, FOUR = 4.0E0, HUNDRD = 100.0E0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL IEEE
+ INTEGER I0, I4, IINFO, IPN4, ITER, IWHILA, IWHILB, K,
+ $ N0, NBIG, NDIV, NFAIL, PP, SPLT, TTYPE
+ REAL D, DESIG, DMIN, DMIN1, DMIN2, DN, DN1, DN2, E,
+ $ EMAX, EMIN, EPS, OLDEMN, QMAX, QMIN, S, SAFMIN,
+ $ SIGMA, T, TAU, TEMP, TOL, TOL2, TRACE, ZMAX
+* ..
+* .. External Subroutines ..
+ EXTERNAL SLAZQ3, SLASRT, XERBLA
+* ..
+* .. External Functions ..
+ INTEGER ILAENV
+ REAL SLAMCH
+ EXTERNAL ILAENV, SLAMCH
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, MIN, REAL, SQRT
+* ..
+* .. Executable Statements ..
+*
+* Test the input arguments.
+* (in case SLASQ2 is not called by SLASQ1)
+*
+ INFO = 0
+ EPS = SLAMCH( 'Precision' )
+ SAFMIN = SLAMCH( 'Safe minimum' )
+ TOL = EPS*HUNDRD
+ TOL2 = TOL**2
+*
+ IF( N.LT.0 ) THEN
+ INFO = -1
+ CALL XERBLA( 'SLASQ2', 1 )
+ RETURN
+ ELSE IF( N.EQ.0 ) THEN
+ RETURN
+ ELSE IF( N.EQ.1 ) THEN
+*
+* 1-by-1 case.
+*
+ IF( Z( 1 ).LT.ZERO ) THEN
+ INFO = -201
+ CALL XERBLA( 'SLASQ2', 2 )
+ END IF
+ RETURN
+ ELSE IF( N.EQ.2 ) THEN
+*
+* 2-by-2 case.
+*
+ IF( Z( 2 ).LT.ZERO .OR. Z( 3 ).LT.ZERO ) THEN
+ INFO = -2
+ CALL XERBLA( 'SLASQ2', 2 )
+ RETURN
+ ELSE IF( Z( 3 ).GT.Z( 1 ) ) THEN
+ D = Z( 3 )
+ Z( 3 ) = Z( 1 )
+ Z( 1 ) = D
+ END IF
+ Z( 5 ) = Z( 1 ) + Z( 2 ) + Z( 3 )
+ IF( Z( 2 ).GT.Z( 3 )*TOL2 ) THEN
+ T = HALF*( ( Z( 1 )-Z( 3 ) )+Z( 2 ) )
+ S = Z( 3 )*( Z( 2 ) / T )
+ IF( S.LE.T ) THEN
+ S = Z( 3 )*( Z( 2 ) / ( T*( ONE+SQRT( ONE+S / T ) ) ) )
+ ELSE
+ S = Z( 3 )*( Z( 2 ) / ( T+SQRT( T )*SQRT( T+S ) ) )
+ END IF
+ T = Z( 1 ) + ( S+Z( 2 ) )
+ Z( 3 ) = Z( 3 )*( Z( 1 ) / T )
+ Z( 1 ) = T
+ END IF
+ Z( 2 ) = Z( 3 )
+ Z( 6 ) = Z( 2 ) + Z( 1 )
+ RETURN
+ END IF
+*
+* Check for negative data and compute sums of q's and e's.
+*
+ Z( 2*N ) = ZERO
+ EMIN = Z( 2 )
+ QMAX = ZERO
+ ZMAX = ZERO
+ D = ZERO
+ E = ZERO
+*
+ DO 10 K = 1, 2*( N-1 ), 2
+ IF( Z( K ).LT.ZERO ) THEN
+ INFO = -( 200+K )
+ CALL XERBLA( 'SLASQ2', 2 )
+ RETURN
+ ELSE IF( Z( K+1 ).LT.ZERO ) THEN
+ INFO = -( 200+K+1 )
+ CALL XERBLA( 'SLASQ2', 2 )
+ RETURN
+ END IF
+ D = D + Z( K )
+ E = E + Z( K+1 )
+ QMAX = MAX( QMAX, Z( K ) )
+ EMIN = MIN( EMIN, Z( K+1 ) )
+ ZMAX = MAX( QMAX, ZMAX, Z( K+1 ) )
+ 10 CONTINUE
+ IF( Z( 2*N-1 ).LT.ZERO ) THEN
+ INFO = -( 200+2*N-1 )
+ CALL XERBLA( 'SLASQ2', 2 )
+ RETURN
+ END IF
+ D = D + Z( 2*N-1 )
+ QMAX = MAX( QMAX, Z( 2*N-1 ) )
+ ZMAX = MAX( QMAX, ZMAX )
+*
+* Check for diagonality.
+*
+ IF( E.EQ.ZERO ) THEN
+ DO 20 K = 2, N
+ Z( K ) = Z( 2*K-1 )
+ 20 CONTINUE
+ CALL SLASRT( 'D', N, Z, IINFO )
+ Z( 2*N-1 ) = D
+ RETURN
+ END IF
+*
+ TRACE = D + E
+*
+* Check for zero data.
+*
+ IF( TRACE.EQ.ZERO ) THEN
+ Z( 2*N-1 ) = ZERO
+ RETURN
+ END IF
+*
+* Check whether the machine is IEEE conformable.
+*
+ IEEE = ILAENV( 10, 'SLASQ2', 'N', 1, 2, 3, 4 ).EQ.1 .AND.
+ $ ILAENV( 11, 'SLASQ2', 'N', 1, 2, 3, 4 ).EQ.1
+*
+* Rearrange data for locality: Z=(q1,qq1,e1,ee1,q2,qq2,e2,ee2,...).
+*
+ DO 30 K = 2*N, 2, -2
+ Z( 2*K ) = ZERO
+ Z( 2*K-1 ) = Z( K )
+ Z( 2*K-2 ) = ZERO
+ Z( 2*K-3 ) = Z( K-1 )
+ 30 CONTINUE
+*
+ I0 = 1
+ N0 = N
+*
+* Reverse the qd-array, if warranted.
+*
+ IF( CBIAS*Z( 4*I0-3 ).LT.Z( 4*N0-3 ) ) THEN
+ IPN4 = 4*( I0+N0 )
+ DO 40 I4 = 4*I0, 2*( I0+N0-1 ), 4
+ TEMP = Z( I4-3 )
+ Z( I4-3 ) = Z( IPN4-I4-3 )
+ Z( IPN4-I4-3 ) = TEMP
+ TEMP = Z( I4-1 )
+ Z( I4-1 ) = Z( IPN4-I4-5 )
+ Z( IPN4-I4-5 ) = TEMP
+ 40 CONTINUE
+ END IF
+*
+* Initial split checking via dqd and Li's test.
+*
+ PP = 0
+*
+ DO 80 K = 1, 2
+*
+ D = Z( 4*N0+PP-3 )
+ DO 50 I4 = 4*( N0-1 ) + PP, 4*I0 + PP, -4
+ IF( Z( I4-1 ).LE.TOL2*D ) THEN
+ Z( I4-1 ) = -ZERO
+ D = Z( I4-3 )
+ ELSE
+ D = Z( I4-3 )*( D / ( D+Z( I4-1 ) ) )
+ END IF
+ 50 CONTINUE
+*
+* dqd maps Z to ZZ plus Li's test.
+*
+ EMIN = Z( 4*I0+PP+1 )
+ D = Z( 4*I0+PP-3 )
+ DO 60 I4 = 4*I0 + PP, 4*( N0-1 ) + PP, 4
+ Z( I4-2*PP-2 ) = D + Z( I4-1 )
+ IF( Z( I4-1 ).LE.TOL2*D ) THEN
+ Z( I4-1 ) = -ZERO
+ Z( I4-2*PP-2 ) = D
+ Z( I4-2*PP ) = ZERO
+ D = Z( I4+1 )
+ ELSE IF( SAFMIN*Z( I4+1 ).LT.Z( I4-2*PP-2 ) .AND.
+ $ SAFMIN*Z( I4-2*PP-2 ).LT.Z( I4+1 ) ) THEN
+ TEMP = Z( I4+1 ) / Z( I4-2*PP-2 )
+ Z( I4-2*PP ) = Z( I4-1 )*TEMP
+ D = D*TEMP
+ ELSE
+ Z( I4-2*PP ) = Z( I4+1 )*( Z( I4-1 ) / Z( I4-2*PP-2 ) )
+ D = Z( I4+1 )*( D / Z( I4-2*PP-2 ) )
+ END IF
+ EMIN = MIN( EMIN, Z( I4-2*PP ) )
+ 60 CONTINUE
+ Z( 4*N0-PP-2 ) = D
+*
+* Now find qmax.
+*
+ QMAX = Z( 4*I0-PP-2 )
+ DO 70 I4 = 4*I0 - PP + 2, 4*N0 - PP - 2, 4
+ QMAX = MAX( QMAX, Z( I4 ) )
+ 70 CONTINUE
+*
+* Prepare for the next iteration on K.
+*
+ PP = 1 - PP
+ 80 CONTINUE
+*
+* Initialise variables to pass to SLAZQ3
+*
+ TTYPE = 0
+ DMIN1 = ZERO
+ DMIN2 = ZERO
+ DN = ZERO
+ DN1 = ZERO
+ DN2 = ZERO
+ TAU = ZERO
+*
+ ITER = 2
+ NFAIL = 0
+ NDIV = 2*( N0-I0 )
+*
+ DO 140 IWHILA = 1, N + 1
+ IF( N0.LT.1 )
+ $ GO TO 150
+*
+* While array unfinished do
+*
+* E(N0) holds the value of SIGMA when submatrix in I0:N0
+* splits from the rest of the array, but is negated.
+*
+ DESIG = ZERO
+ IF( N0.EQ.N ) THEN
+ SIGMA = ZERO
+ ELSE
+ SIGMA = -Z( 4*N0-1 )
+ END IF
+ IF( SIGMA.LT.ZERO ) THEN
+ INFO = 1
+ RETURN
+ END IF
+*
+* Find last unreduced submatrix's top index I0, find QMAX and
+* EMIN. Find Gershgorin-type bound if Q's much greater than E's.
+*
+ EMAX = ZERO
+ IF( N0.GT.I0 ) THEN
+ EMIN = ABS( Z( 4*N0-5 ) )
+ ELSE
+ EMIN = ZERO
+ END IF
+ QMIN = Z( 4*N0-3 )
+ QMAX = QMIN
+ DO 90 I4 = 4*N0, 8, -4
+ IF( Z( I4-5 ).LE.ZERO )
+ $ GO TO 100
+ IF( QMIN.GE.FOUR*EMAX ) THEN
+ QMIN = MIN( QMIN, Z( I4-3 ) )
+ EMAX = MAX( EMAX, Z( I4-5 ) )
+ END IF
+ QMAX = MAX( QMAX, Z( I4-7 )+Z( I4-5 ) )
+ EMIN = MIN( EMIN, Z( I4-5 ) )
+ 90 CONTINUE
+ I4 = 4
+*
+ 100 CONTINUE
+ I0 = I4 / 4
+*
+* Store EMIN for passing to SLAZQ3.
+*
+ Z( 4*N0-1 ) = EMIN
+*
+* Put -(initial shift) into DMIN.
+*
+ DMIN = -MAX( ZERO, QMIN-TWO*SQRT( QMIN )*SQRT( EMAX ) )
+*
+* Now I0:N0 is unreduced. PP = 0 for ping, PP = 1 for pong.
+*
+ PP = 0
+*
+ NBIG = 30*( N0-I0+1 )
+ DO 120 IWHILB = 1, NBIG
+ IF( I0.GT.N0 )
+ $ GO TO 130
+*
+* While submatrix unfinished take a good dqds step.
+*
+ CALL SLAZQ3( I0, N0, Z, PP, DMIN, SIGMA, DESIG, QMAX, NFAIL,
+ $ ITER, NDIV, IEEE, TTYPE, DMIN1, DMIN2, DN, DN1,
+ $ DN2, TAU )
+*
+ PP = 1 - PP
+*
+* When EMIN is very small check for splits.
+*
+ IF( PP.EQ.0 .AND. N0-I0.GE.3 ) THEN
+ IF( Z( 4*N0 ).LE.TOL2*QMAX .OR.
+ $ Z( 4*N0-1 ).LE.TOL2*SIGMA ) THEN
+ SPLT = I0 - 1
+ QMAX = Z( 4*I0-3 )
+ EMIN = Z( 4*I0-1 )
+ OLDEMN = Z( 4*I0 )
+ DO 110 I4 = 4*I0, 4*( N0-3 ), 4
+ IF( Z( I4 ).LE.TOL2*Z( I4-3 ) .OR.
+ $ Z( I4-1 ).LE.TOL2*SIGMA ) THEN
+ Z( I4-1 ) = -SIGMA
+ SPLT = I4 / 4
+ QMAX = ZERO
+ EMIN = Z( I4+3 )
+ OLDEMN = Z( I4+4 )
+ ELSE
+ QMAX = MAX( QMAX, Z( I4+1 ) )
+ EMIN = MIN( EMIN, Z( I4-1 ) )
+ OLDEMN = MIN( OLDEMN, Z( I4 ) )
+ END IF
+ 110 CONTINUE
+ Z( 4*N0-1 ) = EMIN
+ Z( 4*N0 ) = OLDEMN
+ I0 = SPLT + 1
+ END IF
+ END IF
+*
+ 120 CONTINUE
+*
+ INFO = 2
+ RETURN
+*
+* end IWHILB
+*
+ 130 CONTINUE
+*
+ 140 CONTINUE
+*
+ INFO = 3
+ RETURN
+*
+* end IWHILA
+*
+ 150 CONTINUE
+*
+* Move q's to the front.
+*
+ DO 160 K = 2, N
+ Z( K ) = Z( 4*K-3 )
+ 160 CONTINUE
+*
+* Sort and compute sum of eigenvalues.
+*
+ CALL SLASRT( 'D', N, Z, IINFO )
+*
+ E = ZERO
+ DO 170 K = N, 1, -1
+ E = E + Z( K )
+ 170 CONTINUE
+*
+* Store trace, sum(eigenvalues) and information on performance.
+*
+ Z( 2*N+1 ) = TRACE
+ Z( 2*N+2 ) = E
+ Z( 2*N+3 ) = REAL( ITER )
+ Z( 2*N+4 ) = REAL( NDIV ) / REAL( N**2 )
+ Z( 2*N+5 ) = HUNDRD*NFAIL / REAL( ITER )
+ RETURN
+*
+* End of SLASQ2
+*
+ END
+ SUBROUTINE SLASQ3( I0, N0, Z, PP, DMIN, SIGMA, DESIG, QMAX, NFAIL,
+ $ ITER, NDIV, IEEE )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ LOGICAL IEEE
+ INTEGER I0, ITER, N0, NDIV, NFAIL, PP
+ REAL DESIG, DMIN, QMAX, SIGMA
+* ..
+* .. Array Arguments ..
+ REAL Z( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SLASQ3 checks for deflation, computes a shift (TAU) and calls dqds.
+* In case of failure it changes shifts, and tries again until output
+* is positive.
+*
+* Arguments
+* =========
+*
+* I0 (input) INTEGER
+* First index.
+*
+* N0 (input) INTEGER
+* Last index.
+*
+* Z (input) REAL array, dimension ( 4*N )
+* Z holds the qd array.
+*
+* PP (input) INTEGER
+* PP=0 for ping, PP=1 for pong.
+*
+* DMIN (output) REAL
+* Minimum value of d.
+*
+* SIGMA (output) REAL
+* Sum of shifts used in current segment.
+*
+* DESIG (input/output) REAL
+* Lower order part of SIGMA
+*
+* QMAX (input) REAL
+* Maximum value of q.
+*
+* NFAIL (output) INTEGER
+* Number of times shift was too big.
+*
+* ITER (output) INTEGER
+* Number of iterations.
+*
+* NDIV (output) INTEGER
+* Number of divisions.
+*
+* TTYPE (output) INTEGER
+* Shift type.
+*
+* IEEE (input) LOGICAL
+* Flag for IEEE or non IEEE arithmetic (passed to SLASQ5).
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL CBIAS
+ PARAMETER ( CBIAS = 1.50E0 )
+ REAL ZERO, QURTR, HALF, ONE, TWO, HUNDRD
+ PARAMETER ( ZERO = 0.0E0, QURTR = 0.250E0, HALF = 0.5E0,
+ $ ONE = 1.0E0, TWO = 2.0E0, HUNDRD = 100.0E0 )
+* ..
+* .. Local Scalars ..
+ INTEGER IPN4, J4, N0IN, NN, TTYPE
+ REAL DMIN1, DMIN2, DN, DN1, DN2, EPS, S, SAFMIN, T,
+ $ TAU, TEMP, TOL, TOL2
+* ..
+* .. External Subroutines ..
+ EXTERNAL SLASQ4, SLASQ5, SLASQ6
+* ..
+* .. External Function ..
+ REAL SLAMCH
+ EXTERNAL SLAMCH
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, MIN, SQRT
+* ..
+* .. Save statement ..
+ SAVE TTYPE
+ SAVE DMIN1, DMIN2, DN, DN1, DN2, TAU
+* ..
+* .. Data statement ..
+ DATA TTYPE / 0 /
+ DATA DMIN1 / ZERO /, DMIN2 / ZERO /, DN / ZERO /,
+ $ DN1 / ZERO /, DN2 / ZERO /, TAU / ZERO /
+* ..
+* .. Executable Statements ..
+*
+ N0IN = N0
+ EPS = SLAMCH( 'Precision' )
+ SAFMIN = SLAMCH( 'Safe minimum' )
+ TOL = EPS*HUNDRD
+ TOL2 = TOL**2
+*
+* Check for deflation.
+*
+ 10 CONTINUE
+*
+ IF( N0.LT.I0 )
+ $ RETURN
+ IF( N0.EQ.I0 )
+ $ GO TO 20
+ NN = 4*N0 + PP
+ IF( N0.EQ.( I0+1 ) )
+ $ GO TO 40
+*
+* Check whether E(N0-1) is negligible, 1 eigenvalue.
+*
+ IF( Z( NN-5 ).GT.TOL2*( SIGMA+Z( NN-3 ) ) .AND.
+ $ Z( NN-2*PP-4 ).GT.TOL2*Z( NN-7 ) )
+ $ GO TO 30
+*
+ 20 CONTINUE
+*
+ Z( 4*N0-3 ) = Z( 4*N0+PP-3 ) + SIGMA
+ N0 = N0 - 1
+ GO TO 10
+*
+* Check whether E(N0-2) is negligible, 2 eigenvalues.
+*
+ 30 CONTINUE
+*
+ IF( Z( NN-9 ).GT.TOL2*SIGMA .AND.
+ $ Z( NN-2*PP-8 ).GT.TOL2*Z( NN-11 ) )
+ $ GO TO 50
+*
+ 40 CONTINUE
+*
+ IF( Z( NN-3 ).GT.Z( NN-7 ) ) THEN
+ S = Z( NN-3 )
+ Z( NN-3 ) = Z( NN-7 )
+ Z( NN-7 ) = S
+ END IF
+ IF( Z( NN-5 ).GT.Z( NN-3 )*TOL2 ) THEN
+ T = HALF*( ( Z( NN-7 )-Z( NN-3 ) )+Z( NN-5 ) )
+ S = Z( NN-3 )*( Z( NN-5 ) / T )
+ IF( S.LE.T ) THEN
+ S = Z( NN-3 )*( Z( NN-5 ) /
+ $ ( T*( ONE+SQRT( ONE+S / T ) ) ) )
+ ELSE
+ S = Z( NN-3 )*( Z( NN-5 ) / ( T+SQRT( T )*SQRT( T+S ) ) )
+ END IF
+ T = Z( NN-7 ) + ( S+Z( NN-5 ) )
+ Z( NN-3 ) = Z( NN-3 )*( Z( NN-7 ) / T )
+ Z( NN-7 ) = T
+ END IF
+ Z( 4*N0-7 ) = Z( NN-7 ) + SIGMA
+ Z( 4*N0-3 ) = Z( NN-3 ) + SIGMA
+ N0 = N0 - 2
+ GO TO 10
+*
+ 50 CONTINUE
+*
+* Reverse the qd-array, if warranted.
+*
+ IF( DMIN.LE.ZERO .OR. N0.LT.N0IN ) THEN
+ IF( CBIAS*Z( 4*I0+PP-3 ).LT.Z( 4*N0+PP-3 ) ) THEN
+ IPN4 = 4*( I0+N0 )
+ DO 60 J4 = 4*I0, 2*( I0+N0-1 ), 4
+ TEMP = Z( J4-3 )
+ Z( J4-3 ) = Z( IPN4-J4-3 )
+ Z( IPN4-J4-3 ) = TEMP
+ TEMP = Z( J4-2 )
+ Z( J4-2 ) = Z( IPN4-J4-2 )
+ Z( IPN4-J4-2 ) = TEMP
+ TEMP = Z( J4-1 )
+ Z( J4-1 ) = Z( IPN4-J4-5 )
+ Z( IPN4-J4-5 ) = TEMP
+ TEMP = Z( J4 )
+ Z( J4 ) = Z( IPN4-J4-4 )
+ Z( IPN4-J4-4 ) = TEMP
+ 60 CONTINUE
+ IF( N0-I0.LE.4 ) THEN
+ Z( 4*N0+PP-1 ) = Z( 4*I0+PP-1 )
+ Z( 4*N0-PP ) = Z( 4*I0-PP )
+ END IF
+ DMIN2 = MIN( DMIN2, Z( 4*N0+PP-1 ) )
+ Z( 4*N0+PP-1 ) = MIN( Z( 4*N0+PP-1 ), Z( 4*I0+PP-1 ),
+ $ Z( 4*I0+PP+3 ) )
+ Z( 4*N0-PP ) = MIN( Z( 4*N0-PP ), Z( 4*I0-PP ),
+ $ Z( 4*I0-PP+4 ) )
+ QMAX = MAX( QMAX, Z( 4*I0+PP-3 ), Z( 4*I0+PP+1 ) )
+ DMIN = -ZERO
+ END IF
+ END IF
+*
+ IF( DMIN.LT.ZERO .OR. SAFMIN*QMAX.LT.MIN( Z( 4*N0+PP-1 ),
+ $ Z( 4*N0+PP-9 ), DMIN2+Z( 4*N0-PP ) ) ) THEN
+*
+* Choose a shift.
+*
+ CALL SLASQ4( I0, N0, Z, PP, N0IN, DMIN, DMIN1, DMIN2, DN, DN1,
+ $ DN2, TAU, TTYPE )
+*
+* Call dqds until DMIN > 0.
+*
+ 80 CONTINUE
+*
+ CALL SLASQ5( I0, N0, Z, PP, TAU, DMIN, DMIN1, DMIN2, DN,
+ $ DN1, DN2, IEEE )
+*
+ NDIV = NDIV + ( N0-I0+2 )
+ ITER = ITER + 1
+*
+* Check status.
+*
+ IF( DMIN.GE.ZERO .AND. DMIN1.GT.ZERO ) THEN
+*
+* Success.
+*
+ GO TO 100
+*
+ ELSE IF( DMIN.LT.ZERO .AND. DMIN1.GT.ZERO .AND.
+ $ Z( 4*( N0-1 )-PP ).LT.TOL*( SIGMA+DN1 ) .AND.
+ $ ABS( DN ).LT.TOL*SIGMA ) THEN
+*
+* Convergence hidden by negative DN.
+*
+ Z( 4*( N0-1 )-PP+2 ) = ZERO
+ DMIN = ZERO
+ GO TO 100
+ ELSE IF( DMIN.LT.ZERO ) THEN
+*
+* TAU too big. Select new TAU and try again.
+*
+ NFAIL = NFAIL + 1
+ IF( TTYPE.LT.-22 ) THEN
+*
+* Failed twice. Play it safe.
+*
+ TAU = ZERO
+ ELSE IF( DMIN1.GT.ZERO ) THEN
+*
+* Late failure. Gives excellent shift.
+*
+ TAU = ( TAU+DMIN )*( ONE-TWO*EPS )
+ TTYPE = TTYPE - 11
+ ELSE
+*
+* Early failure. Divide by 4.
+*
+ TAU = QURTR*TAU
+ TTYPE = TTYPE - 12
+ END IF
+ GO TO 80
+ ELSE IF( DMIN.NE.DMIN ) THEN
+*
+* NaN.
+*
+ TAU = ZERO
+ GO TO 80
+ ELSE
+*
+* Possible underflow. Play it safe.
+*
+ GO TO 90
+ END IF
+ END IF
+*
+* Risk of underflow.
+*
+ 90 CONTINUE
+ CALL SLASQ6( I0, N0, Z, PP, DMIN, DMIN1, DMIN2, DN, DN1, DN2 )
+ NDIV = NDIV + ( N0-I0+2 )
+ ITER = ITER + 1
+ TAU = ZERO
+*
+ 100 CONTINUE
+ IF( TAU.LT.SIGMA ) THEN
+ DESIG = DESIG + TAU
+ T = SIGMA + DESIG
+ DESIG = DESIG - ( T-SIGMA )
+ ELSE
+ T = SIGMA + TAU
+ DESIG = SIGMA - ( T-TAU ) + DESIG
+ END IF
+ SIGMA = T
+*
+ RETURN
+*
+* End of SLASQ3
+*
+ END
+ SUBROUTINE SLASQ4( I0, N0, Z, PP, N0IN, DMIN, DMIN1, DMIN2, DN,
+ $ DN1, DN2, TAU, TTYPE )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER I0, N0, N0IN, PP, TTYPE
+ REAL DMIN, DMIN1, DMIN2, DN, DN1, DN2, TAU
+* ..
+* .. Array Arguments ..
+ REAL Z( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SLASQ4 computes an approximation TAU to the smallest eigenvalue
+* using values of d from the previous transform.
+*
+* I0 (input) INTEGER
+* First index.
+*
+* N0 (input) INTEGER
+* Last index.
+*
+* Z (input) REAL array, dimension ( 4*N )
+* Z holds the qd array.
+*
+* PP (input) INTEGER
+* PP=0 for ping, PP=1 for pong.
+*
+* N0IN (input) INTEGER
+* The value of N0 at start of EIGTEST.
+*
+* DMIN (input) REAL
+* Minimum value of d.
+*
+* DMIN1 (input) REAL
+* Minimum value of d, excluding D( N0 ).
+*
+* DMIN2 (input) REAL
+* Minimum value of d, excluding D( N0 ) and D( N0-1 ).
+*
+* DN (input) REAL
+* d(N)
+*
+* DN1 (input) REAL
+* d(N-1)
+*
+* DN2 (input) REAL
+* d(N-2)
+*
+* TAU (output) REAL
+* This is the shift.
+*
+* TTYPE (output) INTEGER
+* Shift type.
+*
+* Further Details
+* ===============
+* CNST1 = 9/16
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL CNST1, CNST2, CNST3
+ PARAMETER ( CNST1 = 0.5630E0, CNST2 = 1.010E0,
+ $ CNST3 = 1.050E0 )
+ REAL QURTR, THIRD, HALF, ZERO, ONE, TWO, HUNDRD
+ PARAMETER ( QURTR = 0.250E0, THIRD = 0.3330E0,
+ $ HALF = 0.50E0, ZERO = 0.0E0, ONE = 1.0E0,
+ $ TWO = 2.0E0, HUNDRD = 100.0E0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I4, NN, NP
+ REAL A2, B1, B2, G, GAM, GAP1, GAP2, S
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN, SQRT
+* ..
+* .. Save statement ..
+ SAVE G
+* ..
+* .. Data statement ..
+ DATA G / ZERO /
+* ..
+* .. Executable Statements ..
+*
+* A negative DMIN forces the shift to take that absolute value
+* TTYPE records the type of shift.
+*
+ IF( DMIN.LE.ZERO ) THEN
+ TAU = -DMIN
+ TTYPE = -1
+ RETURN
+ END IF
+*
+ NN = 4*N0 + PP
+ IF( N0IN.EQ.N0 ) THEN
+*
+* No eigenvalues deflated.
+*
+ IF( DMIN.EQ.DN .OR. DMIN.EQ.DN1 ) THEN
+*
+ B1 = SQRT( Z( NN-3 ) )*SQRT( Z( NN-5 ) )
+ B2 = SQRT( Z( NN-7 ) )*SQRT( Z( NN-9 ) )
+ A2 = Z( NN-7 ) + Z( NN-5 )
+*
+* Cases 2 and 3.
+*
+ IF( DMIN.EQ.DN .AND. DMIN1.EQ.DN1 ) THEN
+ GAP2 = DMIN2 - A2 - DMIN2*QURTR
+ IF( GAP2.GT.ZERO .AND. GAP2.GT.B2 ) THEN
+ GAP1 = A2 - DN - ( B2 / GAP2 )*B2
+ ELSE
+ GAP1 = A2 - DN - ( B1+B2 )
+ END IF
+ IF( GAP1.GT.ZERO .AND. GAP1.GT.B1 ) THEN
+ S = MAX( DN-( B1 / GAP1 )*B1, HALF*DMIN )
+ TTYPE = -2
+ ELSE
+ S = ZERO
+ IF( DN.GT.B1 )
+ $ S = DN - B1
+ IF( A2.GT.( B1+B2 ) )
+ $ S = MIN( S, A2-( B1+B2 ) )
+ S = MAX( S, THIRD*DMIN )
+ TTYPE = -3
+ END IF
+ ELSE
+*
+* Case 4.
+*
+ TTYPE = -4
+ S = QURTR*DMIN
+ IF( DMIN.EQ.DN ) THEN
+ GAM = DN
+ A2 = ZERO
+ IF( Z( NN-5 ) .GT. Z( NN-7 ) )
+ $ RETURN
+ B2 = Z( NN-5 ) / Z( NN-7 )
+ NP = NN - 9
+ ELSE
+ NP = NN - 2*PP
+ B2 = Z( NP-2 )
+ GAM = DN1
+ IF( Z( NP-4 ) .GT. Z( NP-2 ) )
+ $ RETURN
+ A2 = Z( NP-4 ) / Z( NP-2 )
+ IF( Z( NN-9 ) .GT. Z( NN-11 ) )
+ $ RETURN
+ B2 = Z( NN-9 ) / Z( NN-11 )
+ NP = NN - 13
+ END IF
+*
+* Approximate contribution to norm squared from I < NN-1.
+*
+ A2 = A2 + B2
+ DO 10 I4 = NP, 4*I0 - 1 + PP, -4
+ IF( B2.EQ.ZERO )
+ $ GO TO 20
+ B1 = B2
+ IF( Z( I4 ) .GT. Z( I4-2 ) )
+ $ RETURN
+ B2 = B2*( Z( I4 ) / Z( I4-2 ) )
+ A2 = A2 + B2
+ IF( HUNDRD*MAX( B2, B1 ).LT.A2 .OR. CNST1.LT.A2 )
+ $ GO TO 20
+ 10 CONTINUE
+ 20 CONTINUE
+ A2 = CNST3*A2
+*
+* Rayleigh quotient residual bound.
+*
+ IF( A2.LT.CNST1 )
+ $ S = GAM*( ONE-SQRT( A2 ) ) / ( ONE+A2 )
+ END IF
+ ELSE IF( DMIN.EQ.DN2 ) THEN
+*
+* Case 5.
+*
+ TTYPE = -5
+ S = QURTR*DMIN
+*
+* Compute contribution to norm squared from I > NN-2.
+*
+ NP = NN - 2*PP
+ B1 = Z( NP-2 )
+ B2 = Z( NP-6 )
+ GAM = DN2
+ IF( Z( NP-8 ).GT.B2 .OR. Z( NP-4 ).GT.B1 )
+ $ RETURN
+ A2 = ( Z( NP-8 ) / B2 )*( ONE+Z( NP-4 ) / B1 )
+*
+* Approximate contribution to norm squared from I < NN-2.
+*
+ IF( N0-I0.GT.2 ) THEN
+ B2 = Z( NN-13 ) / Z( NN-15 )
+ A2 = A2 + B2
+ DO 30 I4 = NN - 17, 4*I0 - 1 + PP, -4
+ IF( B2.EQ.ZERO )
+ $ GO TO 40
+ B1 = B2
+ IF( Z( I4 ) .GT. Z( I4-2 ) )
+ $ RETURN
+ B2 = B2*( Z( I4 ) / Z( I4-2 ) )
+ A2 = A2 + B2
+ IF( HUNDRD*MAX( B2, B1 ).LT.A2 .OR. CNST1.LT.A2 )
+ $ GO TO 40
+ 30 CONTINUE
+ 40 CONTINUE
+ A2 = CNST3*A2
+ END IF
+*
+ IF( A2.LT.CNST1 )
+ $ S = GAM*( ONE-SQRT( A2 ) ) / ( ONE+A2 )
+ ELSE
+*
+* Case 6, no information to guide us.
+*
+ IF( TTYPE.EQ.-6 ) THEN
+ G = G + THIRD*( ONE-G )
+ ELSE IF( TTYPE.EQ.-18 ) THEN
+ G = QURTR*THIRD
+ ELSE
+ G = QURTR
+ END IF
+ S = G*DMIN
+ TTYPE = -6
+ END IF
+*
+ ELSE IF( N0IN.EQ.( N0+1 ) ) THEN
+*
+* One eigenvalue just deflated. Use DMIN1, DN1 for DMIN and DN.
+*
+ IF( DMIN1.EQ.DN1 .AND. DMIN2.EQ.DN2 ) THEN
+*
+* Cases 7 and 8.
+*
+ TTYPE = -7
+ S = THIRD*DMIN1
+ IF( Z( NN-5 ).GT.Z( NN-7 ) )
+ $ RETURN
+ B1 = Z( NN-5 ) / Z( NN-7 )
+ B2 = B1
+ IF( B2.EQ.ZERO )
+ $ GO TO 60
+ DO 50 I4 = 4*N0 - 9 + PP, 4*I0 - 1 + PP, -4
+ A2 = B1
+ IF( Z( I4 ).GT.Z( I4-2 ) )
+ $ RETURN
+ B1 = B1*( Z( I4 ) / Z( I4-2 ) )
+ B2 = B2 + B1
+ IF( HUNDRD*MAX( B1, A2 ).LT.B2 )
+ $ GO TO 60
+ 50 CONTINUE
+ 60 CONTINUE
+ B2 = SQRT( CNST3*B2 )
+ A2 = DMIN1 / ( ONE+B2**2 )
+ GAP2 = HALF*DMIN2 - A2
+ IF( GAP2.GT.ZERO .AND. GAP2.GT.B2*A2 ) THEN
+ S = MAX( S, A2*( ONE-CNST2*A2*( B2 / GAP2 )*B2 ) )
+ ELSE
+ S = MAX( S, A2*( ONE-CNST2*B2 ) )
+ TTYPE = -8
+ END IF
+ ELSE
+*
+* Case 9.
+*
+ S = QURTR*DMIN1
+ IF( DMIN1.EQ.DN1 )
+ $ S = HALF*DMIN1
+ TTYPE = -9
+ END IF
+*
+ ELSE IF( N0IN.EQ.( N0+2 ) ) THEN
+*
+* Two eigenvalues deflated. Use DMIN2, DN2 for DMIN and DN.
+*
+* Cases 10 and 11.
+*
+ IF( DMIN2.EQ.DN2 .AND. TWO*Z( NN-5 ).LT.Z( NN-7 ) ) THEN
+ TTYPE = -10
+ S = THIRD*DMIN2
+ IF( Z( NN-5 ).GT.Z( NN-7 ) )
+ $ RETURN
+ B1 = Z( NN-5 ) / Z( NN-7 )
+ B2 = B1
+ IF( B2.EQ.ZERO )
+ $ GO TO 80
+ DO 70 I4 = 4*N0 - 9 + PP, 4*I0 - 1 + PP, -4
+ IF( Z( I4 ).GT.Z( I4-2 ) )
+ $ RETURN
+ B1 = B1*( Z( I4 ) / Z( I4-2 ) )
+ B2 = B2 + B1
+ IF( HUNDRD*B1.LT.B2 )
+ $ GO TO 80
+ 70 CONTINUE
+ 80 CONTINUE
+ B2 = SQRT( CNST3*B2 )
+ A2 = DMIN2 / ( ONE+B2**2 )
+ GAP2 = Z( NN-7 ) + Z( NN-9 ) -
+ $ SQRT( Z( NN-11 ) )*SQRT( Z( NN-9 ) ) - A2
+ IF( GAP2.GT.ZERO .AND. GAP2.GT.B2*A2 ) THEN
+ S = MAX( S, A2*( ONE-CNST2*A2*( B2 / GAP2 )*B2 ) )
+ ELSE
+ S = MAX( S, A2*( ONE-CNST2*B2 ) )
+ END IF
+ ELSE
+ S = QURTR*DMIN2
+ TTYPE = -11
+ END IF
+ ELSE IF( N0IN.GT.( N0+2 ) ) THEN
+*
+* Case 12, more than two eigenvalues deflated. No information.
+*
+ S = ZERO
+ TTYPE = -12
+ END IF
+*
+ TAU = S
+ RETURN
+*
+* End of SLASQ4
+*
+ END
+ SUBROUTINE SLASQ5( I0, N0, Z, PP, TAU, DMIN, DMIN1, DMIN2, DN,
+ $ DNM1, DNM2, IEEE )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ LOGICAL IEEE
+ INTEGER I0, N0, PP
+ REAL DMIN, DMIN1, DMIN2, DN, DNM1, DNM2, TAU
+* ..
+* .. Array Arguments ..
+ REAL Z( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SLASQ5 computes one dqds transform in ping-pong form, one
+* version for IEEE machines another for non IEEE machines.
+*
+* Arguments
+* =========
+*
+* I0 (input) INTEGER
+* First index.
+*
+* N0 (input) INTEGER
+* Last index.
+*
+* Z (input) REAL array, dimension ( 4*N )
+* Z holds the qd array. EMIN is stored in Z(4*N0) to avoid
+* an extra argument.
+*
+* PP (input) INTEGER
+* PP=0 for ping, PP=1 for pong.
+*
+* TAU (input) REAL
+* This is the shift.
+*
+* DMIN (output) REAL
+* Minimum value of d.
+*
+* DMIN1 (output) REAL
+* Minimum value of d, excluding D( N0 ).
+*
+* DMIN2 (output) REAL
+* Minimum value of d, excluding D( N0 ) and D( N0-1 ).
+*
+* DN (output) REAL
+* d(N0), the last value of d.
+*
+* DNM1 (output) REAL
+* d(N0-1).
+*
+* DNM2 (output) REAL
+* d(N0-2).
+*
+* IEEE (input) LOGICAL
+* Flag for IEEE or non IEEE arithmetic.
+*
+* =====================================================================
+*
+* .. Parameter ..
+ REAL ZERO
+ PARAMETER ( ZERO = 0.0E0 )
+* ..
+* .. Local Scalars ..
+ INTEGER J4, J4P2
+ REAL D, EMIN, TEMP
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MIN
+* ..
+* .. Executable Statements ..
+*
+ IF( ( N0-I0-1 ).LE.0 )
+ $ RETURN
+*
+ J4 = 4*I0 + PP - 3
+ EMIN = Z( J4+4 )
+ D = Z( J4 ) - TAU
+ DMIN = D
+ DMIN1 = -Z( J4 )
+*
+ IF( IEEE ) THEN
+*
+* Code for IEEE arithmetic.
+*
+ IF( PP.EQ.0 ) THEN
+ DO 10 J4 = 4*I0, 4*( N0-3 ), 4
+ Z( J4-2 ) = D + Z( J4-1 )
+ TEMP = Z( J4+1 ) / Z( J4-2 )
+ D = D*TEMP - TAU
+ DMIN = MIN( DMIN, D )
+ Z( J4 ) = Z( J4-1 )*TEMP
+ EMIN = MIN( Z( J4 ), EMIN )
+ 10 CONTINUE
+ ELSE
+ DO 20 J4 = 4*I0, 4*( N0-3 ), 4
+ Z( J4-3 ) = D + Z( J4 )
+ TEMP = Z( J4+2 ) / Z( J4-3 )
+ D = D*TEMP - TAU
+ DMIN = MIN( DMIN, D )
+ Z( J4-1 ) = Z( J4 )*TEMP
+ EMIN = MIN( Z( J4-1 ), EMIN )
+ 20 CONTINUE
+ END IF
+*
+* Unroll last two steps.
+*
+ DNM2 = D
+ DMIN2 = DMIN
+ J4 = 4*( N0-2 ) - PP
+ J4P2 = J4 + 2*PP - 1
+ Z( J4-2 ) = DNM2 + Z( J4P2 )
+ Z( J4 ) = Z( J4P2+2 )*( Z( J4P2 ) / Z( J4-2 ) )
+ DNM1 = Z( J4P2+2 )*( DNM2 / Z( J4-2 ) ) - TAU
+ DMIN = MIN( DMIN, DNM1 )
+*
+ DMIN1 = DMIN
+ J4 = J4 + 4
+ J4P2 = J4 + 2*PP - 1
+ Z( J4-2 ) = DNM1 + Z( J4P2 )
+ Z( J4 ) = Z( J4P2+2 )*( Z( J4P2 ) / Z( J4-2 ) )
+ DN = Z( J4P2+2 )*( DNM1 / Z( J4-2 ) ) - TAU
+ DMIN = MIN( DMIN, DN )
+*
+ ELSE
+*
+* Code for non IEEE arithmetic.
+*
+ IF( PP.EQ.0 ) THEN
+ DO 30 J4 = 4*I0, 4*( N0-3 ), 4
+ Z( J4-2 ) = D + Z( J4-1 )
+ IF( D.LT.ZERO ) THEN
+ RETURN
+ ELSE
+ Z( J4 ) = Z( J4+1 )*( Z( J4-1 ) / Z( J4-2 ) )
+ D = Z( J4+1 )*( D / Z( J4-2 ) ) - TAU
+ END IF
+ DMIN = MIN( DMIN, D )
+ EMIN = MIN( EMIN, Z( J4 ) )
+ 30 CONTINUE
+ ELSE
+ DO 40 J4 = 4*I0, 4*( N0-3 ), 4
+ Z( J4-3 ) = D + Z( J4 )
+ IF( D.LT.ZERO ) THEN
+ RETURN
+ ELSE
+ Z( J4-1 ) = Z( J4+2 )*( Z( J4 ) / Z( J4-3 ) )
+ D = Z( J4+2 )*( D / Z( J4-3 ) ) - TAU
+ END IF
+ DMIN = MIN( DMIN, D )
+ EMIN = MIN( EMIN, Z( J4-1 ) )
+ 40 CONTINUE
+ END IF
+*
+* Unroll last two steps.
+*
+ DNM2 = D
+ DMIN2 = DMIN
+ J4 = 4*( N0-2 ) - PP
+ J4P2 = J4 + 2*PP - 1
+ Z( J4-2 ) = DNM2 + Z( J4P2 )
+ IF( DNM2.LT.ZERO ) THEN
+ RETURN
+ ELSE
+ Z( J4 ) = Z( J4P2+2 )*( Z( J4P2 ) / Z( J4-2 ) )
+ DNM1 = Z( J4P2+2 )*( DNM2 / Z( J4-2 ) ) - TAU
+ END IF
+ DMIN = MIN( DMIN, DNM1 )
+*
+ DMIN1 = DMIN
+ J4 = J4 + 4
+ J4P2 = J4 + 2*PP - 1
+ Z( J4-2 ) = DNM1 + Z( J4P2 )
+ IF( DNM1.LT.ZERO ) THEN
+ RETURN
+ ELSE
+ Z( J4 ) = Z( J4P2+2 )*( Z( J4P2 ) / Z( J4-2 ) )
+ DN = Z( J4P2+2 )*( DNM1 / Z( J4-2 ) ) - TAU
+ END IF
+ DMIN = MIN( DMIN, DN )
+*
+ END IF
+*
+ Z( J4+2 ) = DN
+ Z( 4*N0-PP ) = EMIN
+ RETURN
+*
+* End of SLASQ5
+*
+ END
+ SUBROUTINE SLASQ6( I0, N0, Z, PP, DMIN, DMIN1, DMIN2, DN,
+ $ DNM1, DNM2 )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER I0, N0, PP
+ REAL DMIN, DMIN1, DMIN2, DN, DNM1, DNM2
+* ..
+* .. Array Arguments ..
+ REAL Z( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SLASQ6 computes one dqd (shift equal to zero) transform in
+* ping-pong form, with protection against underflow and overflow.
+*
+* Arguments
+* =========
+*
+* I0 (input) INTEGER
+* First index.
+*
+* N0 (input) INTEGER
+* Last index.
+*
+* Z (input) REAL array, dimension ( 4*N )
+* Z holds the qd array. EMIN is stored in Z(4*N0) to avoid
+* an extra argument.
+*
+* PP (input) INTEGER
+* PP=0 for ping, PP=1 for pong.
+*
+* DMIN (output) REAL
+* Minimum value of d.
+*
+* DMIN1 (output) REAL
+* Minimum value of d, excluding D( N0 ).
+*
+* DMIN2 (output) REAL
+* Minimum value of d, excluding D( N0 ) and D( N0-1 ).
+*
+* DN (output) REAL
+* d(N0), the last value of d.
+*
+* DNM1 (output) REAL
+* d(N0-1).
+*
+* DNM2 (output) REAL
+* d(N0-2).
+*
+* =====================================================================
+*
+* .. Parameter ..
+ REAL ZERO
+ PARAMETER ( ZERO = 0.0E0 )
+* ..
+* .. Local Scalars ..
+ INTEGER J4, J4P2
+ REAL D, EMIN, SAFMIN, TEMP
+* ..
+* .. External Function ..
+ REAL SLAMCH
+ EXTERNAL SLAMCH
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MIN
+* ..
+* .. Executable Statements ..
+*
+ IF( ( N0-I0-1 ).LE.0 )
+ $ RETURN
+*
+ SAFMIN = SLAMCH( 'Safe minimum' )
+ J4 = 4*I0 + PP - 3
+ EMIN = Z( J4+4 )
+ D = Z( J4 )
+ DMIN = D
+*
+ IF( PP.EQ.0 ) THEN
+ DO 10 J4 = 4*I0, 4*( N0-3 ), 4
+ Z( J4-2 ) = D + Z( J4-1 )
+ IF( Z( J4-2 ).EQ.ZERO ) THEN
+ Z( J4 ) = ZERO
+ D = Z( J4+1 )
+ DMIN = D
+ EMIN = ZERO
+ ELSE IF( SAFMIN*Z( J4+1 ).LT.Z( J4-2 ) .AND.
+ $ SAFMIN*Z( J4-2 ).LT.Z( J4+1 ) ) THEN
+ TEMP = Z( J4+1 ) / Z( J4-2 )
+ Z( J4 ) = Z( J4-1 )*TEMP
+ D = D*TEMP
+ ELSE
+ Z( J4 ) = Z( J4+1 )*( Z( J4-1 ) / Z( J4-2 ) )
+ D = Z( J4+1 )*( D / Z( J4-2 ) )
+ END IF
+ DMIN = MIN( DMIN, D )
+ EMIN = MIN( EMIN, Z( J4 ) )
+ 10 CONTINUE
+ ELSE
+ DO 20 J4 = 4*I0, 4*( N0-3 ), 4
+ Z( J4-3 ) = D + Z( J4 )
+ IF( Z( J4-3 ).EQ.ZERO ) THEN
+ Z( J4-1 ) = ZERO
+ D = Z( J4+2 )
+ DMIN = D
+ EMIN = ZERO
+ ELSE IF( SAFMIN*Z( J4+2 ).LT.Z( J4-3 ) .AND.
+ $ SAFMIN*Z( J4-3 ).LT.Z( J4+2 ) ) THEN
+ TEMP = Z( J4+2 ) / Z( J4-3 )
+ Z( J4-1 ) = Z( J4 )*TEMP
+ D = D*TEMP
+ ELSE
+ Z( J4-1 ) = Z( J4+2 )*( Z( J4 ) / Z( J4-3 ) )
+ D = Z( J4+2 )*( D / Z( J4-3 ) )
+ END IF
+ DMIN = MIN( DMIN, D )
+ EMIN = MIN( EMIN, Z( J4-1 ) )
+ 20 CONTINUE
+ END IF
+*
+* Unroll last two steps.
+*
+ DNM2 = D
+ DMIN2 = DMIN
+ J4 = 4*( N0-2 ) - PP
+ J4P2 = J4 + 2*PP - 1
+ Z( J4-2 ) = DNM2 + Z( J4P2 )
+ IF( Z( J4-2 ).EQ.ZERO ) THEN
+ Z( J4 ) = ZERO
+ DNM1 = Z( J4P2+2 )
+ DMIN = DNM1
+ EMIN = ZERO
+ ELSE IF( SAFMIN*Z( J4P2+2 ).LT.Z( J4-2 ) .AND.
+ $ SAFMIN*Z( J4-2 ).LT.Z( J4P2+2 ) ) THEN
+ TEMP = Z( J4P2+2 ) / Z( J4-2 )
+ Z( J4 ) = Z( J4P2 )*TEMP
+ DNM1 = DNM2*TEMP
+ ELSE
+ Z( J4 ) = Z( J4P2+2 )*( Z( J4P2 ) / Z( J4-2 ) )
+ DNM1 = Z( J4P2+2 )*( DNM2 / Z( J4-2 ) )
+ END IF
+ DMIN = MIN( DMIN, DNM1 )
+*
+ DMIN1 = DMIN
+ J4 = J4 + 4
+ J4P2 = J4 + 2*PP - 1
+ Z( J4-2 ) = DNM1 + Z( J4P2 )
+ IF( Z( J4-2 ).EQ.ZERO ) THEN
+ Z( J4 ) = ZERO
+ DN = Z( J4P2+2 )
+ DMIN = DN
+ EMIN = ZERO
+ ELSE IF( SAFMIN*Z( J4P2+2 ).LT.Z( J4-2 ) .AND.
+ $ SAFMIN*Z( J4-2 ).LT.Z( J4P2+2 ) ) THEN
+ TEMP = Z( J4P2+2 ) / Z( J4-2 )
+ Z( J4 ) = Z( J4P2 )*TEMP
+ DN = DNM1*TEMP
+ ELSE
+ Z( J4 ) = Z( J4P2+2 )*( Z( J4P2 ) / Z( J4-2 ) )
+ DN = Z( J4P2+2 )*( DNM1 / Z( J4-2 ) )
+ END IF
+ DMIN = MIN( DMIN, DN )
+*
+ Z( J4+2 ) = DN
+ Z( 4*N0-PP ) = EMIN
+ RETURN
+*
+* End of SLASQ6
+*
+ END
+ SUBROUTINE SLASR( SIDE, PIVOT, DIRECT, M, N, C, S, A, LDA )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER DIRECT, PIVOT, SIDE
+ INTEGER LDA, M, N
+* ..
+* .. Array Arguments ..
+ REAL A( LDA, * ), C( * ), S( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SLASR applies a sequence of plane rotations to a real matrix A,
+* from either the left or the right.
+*
+* When SIDE = 'L', the transformation takes the form
+*
+* A := P*A
+*
+* and when SIDE = 'R', the transformation takes the form
+*
+* A := A*P**T
+*
+* where P is an orthogonal matrix consisting of a sequence of z plane
+* rotations, with z = M when SIDE = 'L' and z = N when SIDE = 'R',
+* and P**T is the transpose of P.
+*
+* When DIRECT = 'F' (Forward sequence), then
+*
+* P = P(z-1) * ... * P(2) * P(1)
+*
+* and when DIRECT = 'B' (Backward sequence), then
+*
+* P = P(1) * P(2) * ... * P(z-1)
+*
+* where P(k) is a plane rotation matrix defined by the 2-by-2 rotation
+*
+* R(k) = ( c(k) s(k) )
+* = ( -s(k) c(k) ).
+*
+* When PIVOT = 'V' (Variable pivot), the rotation is performed
+* for the plane (k,k+1), i.e., P(k) has the form
+*
+* P(k) = ( 1 )
+* ( ... )
+* ( 1 )
+* ( c(k) s(k) )
+* ( -s(k) c(k) )
+* ( 1 )
+* ( ... )
+* ( 1 )
+*
+* where R(k) appears as a rank-2 modification to the identity matrix in
+* rows and columns k and k+1.
+*
+* When PIVOT = 'T' (Top pivot), the rotation is performed for the
+* plane (1,k+1), so P(k) has the form
+*
+* P(k) = ( c(k) s(k) )
+* ( 1 )
+* ( ... )
+* ( 1 )
+* ( -s(k) c(k) )
+* ( 1 )
+* ( ... )
+* ( 1 )
+*
+* where R(k) appears in rows and columns 1 and k+1.
+*
+* Similarly, when PIVOT = 'B' (Bottom pivot), the rotation is
+* performed for the plane (k,z), giving P(k) the form
+*
+* P(k) = ( 1 )
+* ( ... )
+* ( 1 )
+* ( c(k) s(k) )
+* ( 1 )
+* ( ... )
+* ( 1 )
+* ( -s(k) c(k) )
+*
+* where R(k) appears in rows and columns k and z. The rotations are
+* performed without ever forming P(k) explicitly.
+*
+* Arguments
+* =========
+*
+* SIDE (input) CHARACTER*1
+* Specifies whether the plane rotation matrix P is applied to
+* A on the left or the right.
+* = 'L': Left, compute A := P*A
+* = 'R': Right, compute A:= A*P**T
+*
+* PIVOT (input) CHARACTER*1
+* Specifies the plane for which P(k) is a plane rotation
+* matrix.
+* = 'V': Variable pivot, the plane (k,k+1)
+* = 'T': Top pivot, the plane (1,k+1)
+* = 'B': Bottom pivot, the plane (k,z)
+*
+* DIRECT (input) CHARACTER*1
+* Specifies whether P is a forward or backward sequence of
+* plane rotations.
+* = 'F': Forward, P = P(z-1)*...*P(2)*P(1)
+* = 'B': Backward, P = P(1)*P(2)*...*P(z-1)
+*
+* M (input) INTEGER
+* The number of rows of the matrix A. If m <= 1, an immediate
+* return is effected.
+*
+* N (input) INTEGER
+* The number of columns of the matrix A. If n <= 1, an
+* immediate return is effected.
+*
+* C (input) REAL array, dimension
+* (M-1) if SIDE = 'L'
+* (N-1) if SIDE = 'R'
+* The cosines c(k) of the plane rotations.
+*
+* S (input) REAL array, dimension
+* (M-1) if SIDE = 'L'
+* (N-1) if SIDE = 'R'
+* The sines s(k) of the plane rotations. The 2-by-2 plane
+* rotation part of the matrix P(k), R(k), has the form
+* R(k) = ( c(k) s(k) )
+* ( -s(k) c(k) ).
+*
+* A (input/output) REAL array, dimension (LDA,N)
+* The M-by-N matrix A. On exit, A is overwritten by P*A if
+* SIDE = 'R' or by A*P**T if SIDE = 'L'.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,M).
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ONE, ZERO
+ PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, INFO, J
+ REAL CTEMP, STEMP, TEMP
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters
+*
+ INFO = 0
+ IF( .NOT.( LSAME( SIDE, 'L' ) .OR. LSAME( SIDE, 'R' ) ) ) THEN
+ INFO = 1
+ ELSE IF( .NOT.( LSAME( PIVOT, 'V' ) .OR. LSAME( PIVOT,
+ $ 'T' ) .OR. LSAME( PIVOT, 'B' ) ) ) THEN
+ INFO = 2
+ ELSE IF( .NOT.( LSAME( DIRECT, 'F' ) .OR. LSAME( DIRECT, 'B' ) ) )
+ $ THEN
+ INFO = 3
+ ELSE IF( M.LT.0 ) THEN
+ INFO = 4
+ ELSE IF( N.LT.0 ) THEN
+ INFO = 5
+ ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+ INFO = 9
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SLASR ', INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( ( M.EQ.0 ) .OR. ( N.EQ.0 ) )
+ $ RETURN
+ IF( LSAME( SIDE, 'L' ) ) THEN
+*
+* Form P * A
+*
+ IF( LSAME( PIVOT, 'V' ) ) THEN
+ IF( LSAME( DIRECT, 'F' ) ) THEN
+ DO 20 J = 1, M - 1
+ CTEMP = C( J )
+ STEMP = S( J )
+ IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
+ DO 10 I = 1, N
+ TEMP = A( J+1, I )
+ A( J+1, I ) = CTEMP*TEMP - STEMP*A( J, I )
+ A( J, I ) = STEMP*TEMP + CTEMP*A( J, I )
+ 10 CONTINUE
+ END IF
+ 20 CONTINUE
+ ELSE IF( LSAME( DIRECT, 'B' ) ) THEN
+ DO 40 J = M - 1, 1, -1
+ CTEMP = C( J )
+ STEMP = S( J )
+ IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
+ DO 30 I = 1, N
+ TEMP = A( J+1, I )
+ A( J+1, I ) = CTEMP*TEMP - STEMP*A( J, I )
+ A( J, I ) = STEMP*TEMP + CTEMP*A( J, I )
+ 30 CONTINUE
+ END IF
+ 40 CONTINUE
+ END IF
+ ELSE IF( LSAME( PIVOT, 'T' ) ) THEN
+ IF( LSAME( DIRECT, 'F' ) ) THEN
+ DO 60 J = 2, M
+ CTEMP = C( J-1 )
+ STEMP = S( J-1 )
+ IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
+ DO 50 I = 1, N
+ TEMP = A( J, I )
+ A( J, I ) = CTEMP*TEMP - STEMP*A( 1, I )
+ A( 1, I ) = STEMP*TEMP + CTEMP*A( 1, I )
+ 50 CONTINUE
+ END IF
+ 60 CONTINUE
+ ELSE IF( LSAME( DIRECT, 'B' ) ) THEN
+ DO 80 J = M, 2, -1
+ CTEMP = C( J-1 )
+ STEMP = S( J-1 )
+ IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
+ DO 70 I = 1, N
+ TEMP = A( J, I )
+ A( J, I ) = CTEMP*TEMP - STEMP*A( 1, I )
+ A( 1, I ) = STEMP*TEMP + CTEMP*A( 1, I )
+ 70 CONTINUE
+ END IF
+ 80 CONTINUE
+ END IF
+ ELSE IF( LSAME( PIVOT, 'B' ) ) THEN
+ IF( LSAME( DIRECT, 'F' ) ) THEN
+ DO 100 J = 1, M - 1
+ CTEMP = C( J )
+ STEMP = S( J )
+ IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
+ DO 90 I = 1, N
+ TEMP = A( J, I )
+ A( J, I ) = STEMP*A( M, I ) + CTEMP*TEMP
+ A( M, I ) = CTEMP*A( M, I ) - STEMP*TEMP
+ 90 CONTINUE
+ END IF
+ 100 CONTINUE
+ ELSE IF( LSAME( DIRECT, 'B' ) ) THEN
+ DO 120 J = M - 1, 1, -1
+ CTEMP = C( J )
+ STEMP = S( J )
+ IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
+ DO 110 I = 1, N
+ TEMP = A( J, I )
+ A( J, I ) = STEMP*A( M, I ) + CTEMP*TEMP
+ A( M, I ) = CTEMP*A( M, I ) - STEMP*TEMP
+ 110 CONTINUE
+ END IF
+ 120 CONTINUE
+ END IF
+ END IF
+ ELSE IF( LSAME( SIDE, 'R' ) ) THEN
+*
+* Form A * P'
+*
+ IF( LSAME( PIVOT, 'V' ) ) THEN
+ IF( LSAME( DIRECT, 'F' ) ) THEN
+ DO 140 J = 1, N - 1
+ CTEMP = C( J )
+ STEMP = S( J )
+ IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
+ DO 130 I = 1, M
+ TEMP = A( I, J+1 )
+ A( I, J+1 ) = CTEMP*TEMP - STEMP*A( I, J )
+ A( I, J ) = STEMP*TEMP + CTEMP*A( I, J )
+ 130 CONTINUE
+ END IF
+ 140 CONTINUE
+ ELSE IF( LSAME( DIRECT, 'B' ) ) THEN
+ DO 160 J = N - 1, 1, -1
+ CTEMP = C( J )
+ STEMP = S( J )
+ IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
+ DO 150 I = 1, M
+ TEMP = A( I, J+1 )
+ A( I, J+1 ) = CTEMP*TEMP - STEMP*A( I, J )
+ A( I, J ) = STEMP*TEMP + CTEMP*A( I, J )
+ 150 CONTINUE
+ END IF
+ 160 CONTINUE
+ END IF
+ ELSE IF( LSAME( PIVOT, 'T' ) ) THEN
+ IF( LSAME( DIRECT, 'F' ) ) THEN
+ DO 180 J = 2, N
+ CTEMP = C( J-1 )
+ STEMP = S( J-1 )
+ IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
+ DO 170 I = 1, M
+ TEMP = A( I, J )
+ A( I, J ) = CTEMP*TEMP - STEMP*A( I, 1 )
+ A( I, 1 ) = STEMP*TEMP + CTEMP*A( I, 1 )
+ 170 CONTINUE
+ END IF
+ 180 CONTINUE
+ ELSE IF( LSAME( DIRECT, 'B' ) ) THEN
+ DO 200 J = N, 2, -1
+ CTEMP = C( J-1 )
+ STEMP = S( J-1 )
+ IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
+ DO 190 I = 1, M
+ TEMP = A( I, J )
+ A( I, J ) = CTEMP*TEMP - STEMP*A( I, 1 )
+ A( I, 1 ) = STEMP*TEMP + CTEMP*A( I, 1 )
+ 190 CONTINUE
+ END IF
+ 200 CONTINUE
+ END IF
+ ELSE IF( LSAME( PIVOT, 'B' ) ) THEN
+ IF( LSAME( DIRECT, 'F' ) ) THEN
+ DO 220 J = 1, N - 1
+ CTEMP = C( J )
+ STEMP = S( J )
+ IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
+ DO 210 I = 1, M
+ TEMP = A( I, J )
+ A( I, J ) = STEMP*A( I, N ) + CTEMP*TEMP
+ A( I, N ) = CTEMP*A( I, N ) - STEMP*TEMP
+ 210 CONTINUE
+ END IF
+ 220 CONTINUE
+ ELSE IF( LSAME( DIRECT, 'B' ) ) THEN
+ DO 240 J = N - 1, 1, -1
+ CTEMP = C( J )
+ STEMP = S( J )
+ IF( ( CTEMP.NE.ONE ) .OR. ( STEMP.NE.ZERO ) ) THEN
+ DO 230 I = 1, M
+ TEMP = A( I, J )
+ A( I, J ) = STEMP*A( I, N ) + CTEMP*TEMP
+ A( I, N ) = CTEMP*A( I, N ) - STEMP*TEMP
+ 230 CONTINUE
+ END IF
+ 240 CONTINUE
+ END IF
+ END IF
+ END IF
+*
+ RETURN
+*
+* End of SLASR
+*
+ END
+ SUBROUTINE SLASRT( ID, N, D, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER ID
+ INTEGER INFO, N
+* ..
+* .. Array Arguments ..
+ REAL D( * )
+* ..
+*
+* Purpose
+* =======
+*
+* Sort the numbers in D in increasing order (if ID = 'I') or
+* in decreasing order (if ID = 'D' ).
+*
+* Use Quick Sort, reverting to Insertion sort on arrays of
+* size <= 20. Dimension of STACK limits N to about 2**32.
+*
+* Arguments
+* =========
+*
+* ID (input) CHARACTER*1
+* = 'I': sort D in increasing order;
+* = 'D': sort D in decreasing order.
+*
+* N (input) INTEGER
+* The length of the array D.
+*
+* D (input/output) REAL array, dimension (N)
+* On entry, the array to be sorted.
+* On exit, D has been sorted into increasing order
+* (D(1) <= ... <= D(N) ) or into decreasing order
+* (D(1) >= ... >= D(N) ), depending on ID.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+*
+* =====================================================================
+*
+* .. Parameters ..
+ INTEGER SELECT
+ PARAMETER ( SELECT = 20 )
+* ..
+* .. Local Scalars ..
+ INTEGER DIR, ENDD, I, J, START, STKPNT
+ REAL D1, D2, D3, DMNMX, TMP
+* ..
+* .. Local Arrays ..
+ INTEGER STACK( 2, 32 )
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL XERBLA
+* ..
+* .. Executable Statements ..
+*
+* Test the input paramters.
+*
+ INFO = 0
+ DIR = -1
+ IF( LSAME( ID, 'D' ) ) THEN
+ DIR = 0
+ ELSE IF( LSAME( ID, 'I' ) ) THEN
+ DIR = 1
+ END IF
+ IF( DIR.EQ.-1 ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SLASRT', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.LE.1 )
+ $ RETURN
+*
+ STKPNT = 1
+ STACK( 1, 1 ) = 1
+ STACK( 2, 1 ) = N
+ 10 CONTINUE
+ START = STACK( 1, STKPNT )
+ ENDD = STACK( 2, STKPNT )
+ STKPNT = STKPNT - 1
+ IF( ENDD-START.LE.SELECT .AND. ENDD-START.GT.0 ) THEN
+*
+* Do Insertion sort on D( START:ENDD )
+*
+ IF( DIR.EQ.0 ) THEN
+*
+* Sort into decreasing order
+*
+ DO 30 I = START + 1, ENDD
+ DO 20 J = I, START + 1, -1
+ IF( D( J ).GT.D( J-1 ) ) THEN
+ DMNMX = D( J )
+ D( J ) = D( J-1 )
+ D( J-1 ) = DMNMX
+ ELSE
+ GO TO 30
+ END IF
+ 20 CONTINUE
+ 30 CONTINUE
+*
+ ELSE
+*
+* Sort into increasing order
+*
+ DO 50 I = START + 1, ENDD
+ DO 40 J = I, START + 1, -1
+ IF( D( J ).LT.D( J-1 ) ) THEN
+ DMNMX = D( J )
+ D( J ) = D( J-1 )
+ D( J-1 ) = DMNMX
+ ELSE
+ GO TO 50
+ END IF
+ 40 CONTINUE
+ 50 CONTINUE
+*
+ END IF
+*
+ ELSE IF( ENDD-START.GT.SELECT ) THEN
+*
+* Partition D( START:ENDD ) and stack parts, largest one first
+*
+* Choose partition entry as median of 3
+*
+ D1 = D( START )
+ D2 = D( ENDD )
+ I = ( START+ENDD ) / 2
+ D3 = D( I )
+ IF( D1.LT.D2 ) THEN
+ IF( D3.LT.D1 ) THEN
+ DMNMX = D1
+ ELSE IF( D3.LT.D2 ) THEN
+ DMNMX = D3
+ ELSE
+ DMNMX = D2
+ END IF
+ ELSE
+ IF( D3.LT.D2 ) THEN
+ DMNMX = D2
+ ELSE IF( D3.LT.D1 ) THEN
+ DMNMX = D3
+ ELSE
+ DMNMX = D1
+ END IF
+ END IF
+*
+ IF( DIR.EQ.0 ) THEN
+*
+* Sort into decreasing order
+*
+ I = START - 1
+ J = ENDD + 1
+ 60 CONTINUE
+ 70 CONTINUE
+ J = J - 1
+ IF( D( J ).LT.DMNMX )
+ $ GO TO 70
+ 80 CONTINUE
+ I = I + 1
+ IF( D( I ).GT.DMNMX )
+ $ GO TO 80
+ IF( I.LT.J ) THEN
+ TMP = D( I )
+ D( I ) = D( J )
+ D( J ) = TMP
+ GO TO 60
+ END IF
+ IF( J-START.GT.ENDD-J-1 ) THEN
+ STKPNT = STKPNT + 1
+ STACK( 1, STKPNT ) = START
+ STACK( 2, STKPNT ) = J
+ STKPNT = STKPNT + 1
+ STACK( 1, STKPNT ) = J + 1
+ STACK( 2, STKPNT ) = ENDD
+ ELSE
+ STKPNT = STKPNT + 1
+ STACK( 1, STKPNT ) = J + 1
+ STACK( 2, STKPNT ) = ENDD
+ STKPNT = STKPNT + 1
+ STACK( 1, STKPNT ) = START
+ STACK( 2, STKPNT ) = J
+ END IF
+ ELSE
+*
+* Sort into increasing order
+*
+ I = START - 1
+ J = ENDD + 1
+ 90 CONTINUE
+ 100 CONTINUE
+ J = J - 1
+ IF( D( J ).GT.DMNMX )
+ $ GO TO 100
+ 110 CONTINUE
+ I = I + 1
+ IF( D( I ).LT.DMNMX )
+ $ GO TO 110
+ IF( I.LT.J ) THEN
+ TMP = D( I )
+ D( I ) = D( J )
+ D( J ) = TMP
+ GO TO 90
+ END IF
+ IF( J-START.GT.ENDD-J-1 ) THEN
+ STKPNT = STKPNT + 1
+ STACK( 1, STKPNT ) = START
+ STACK( 2, STKPNT ) = J
+ STKPNT = STKPNT + 1
+ STACK( 1, STKPNT ) = J + 1
+ STACK( 2, STKPNT ) = ENDD
+ ELSE
+ STKPNT = STKPNT + 1
+ STACK( 1, STKPNT ) = J + 1
+ STACK( 2, STKPNT ) = ENDD
+ STKPNT = STKPNT + 1
+ STACK( 1, STKPNT ) = START
+ STACK( 2, STKPNT ) = J
+ END IF
+ END IF
+ END IF
+ IF( STKPNT.GT.0 )
+ $ GO TO 10
+ RETURN
+*
+* End of SLASRT
+*
+ END
+ SUBROUTINE SLASSQ( N, X, INCX, SCALE, SUMSQ )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INCX, N
+ REAL SCALE, SUMSQ
+* ..
+* .. Array Arguments ..
+ REAL X( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SLASSQ returns the values scl and smsq such that
+*
+* ( scl**2 )*smsq = x( 1 )**2 +...+ x( n )**2 + ( scale**2 )*sumsq,
+*
+* where x( i ) = X( 1 + ( i - 1 )*INCX ). The value of sumsq is
+* assumed to be non-negative and scl returns the value
+*
+* scl = max( scale, abs( x( i ) ) ).
+*
+* scale and sumsq must be supplied in SCALE and SUMSQ and
+* scl and smsq are overwritten on SCALE and SUMSQ respectively.
+*
+* The routine makes only one pass through the vector x.
+*
+* Arguments
+* =========
+*
+* N (input) INTEGER
+* The number of elements to be used from the vector X.
+*
+* X (input) REAL array, dimension (N)
+* The vector for which a scaled sum of squares is computed.
+* x( i ) = X( 1 + ( i - 1 )*INCX ), 1 <= i <= n.
+*
+* INCX (input) INTEGER
+* The increment between successive values of the vector X.
+* INCX > 0.
+*
+* SCALE (input/output) REAL
+* On entry, the value scale in the equation above.
+* On exit, SCALE is overwritten with scl , the scaling factor
+* for the sum of squares.
+*
+* SUMSQ (input/output) REAL
+* On entry, the value sumsq in the equation above.
+* On exit, SUMSQ is overwritten with smsq , the basic sum of
+* squares from which scl has been factored out.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO
+ PARAMETER ( ZERO = 0.0E+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER IX
+ REAL ABSXI
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS
+* ..
+* .. Executable Statements ..
+*
+ IF( N.GT.0 ) THEN
+ DO 10 IX = 1, 1 + ( N-1 )*INCX, INCX
+ IF( X( IX ).NE.ZERO ) THEN
+ ABSXI = ABS( X( IX ) )
+ IF( SCALE.LT.ABSXI ) THEN
+ SUMSQ = 1 + SUMSQ*( SCALE / ABSXI )**2
+ SCALE = ABSXI
+ ELSE
+ SUMSQ = SUMSQ + ( ABSXI / SCALE )**2
+ END IF
+ END IF
+ 10 CONTINUE
+ END IF
+ RETURN
+*
+* End of SLASSQ
+*
+ END
+ SUBROUTINE SLASV2( F, G, H, SSMIN, SSMAX, SNR, CSR, SNL, CSL )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ REAL CSL, CSR, F, G, H, SNL, SNR, SSMAX, SSMIN
+* ..
+*
+* Purpose
+* =======
+*
+* SLASV2 computes the singular value decomposition of a 2-by-2
+* triangular matrix
+* [ F G ]
+* [ 0 H ].
+* On return, abs(SSMAX) is the larger singular value, abs(SSMIN) is the
+* smaller singular value, and (CSL,SNL) and (CSR,SNR) are the left and
+* right singular vectors for abs(SSMAX), giving the decomposition
+*
+* [ CSL SNL ] [ F G ] [ CSR -SNR ] = [ SSMAX 0 ]
+* [-SNL CSL ] [ 0 H ] [ SNR CSR ] [ 0 SSMIN ].
+*
+* Arguments
+* =========
+*
+* F (input) REAL
+* The (1,1) element of the 2-by-2 matrix.
+*
+* G (input) REAL
+* The (1,2) element of the 2-by-2 matrix.
+*
+* H (input) REAL
+* The (2,2) element of the 2-by-2 matrix.
+*
+* SSMIN (output) REAL
+* abs(SSMIN) is the smaller singular value.
+*
+* SSMAX (output) REAL
+* abs(SSMAX) is the larger singular value.
+*
+* SNL (output) REAL
+* CSL (output) REAL
+* The vector (CSL, SNL) is a unit left singular vector for the
+* singular value abs(SSMAX).
+*
+* SNR (output) REAL
+* CSR (output) REAL
+* The vector (CSR, SNR) is a unit right singular vector for the
+* singular value abs(SSMAX).
+*
+* Further Details
+* ===============
+*
+* Any input parameter may be aliased with any output parameter.
+*
+* Barring over/underflow and assuming a guard digit in subtraction, all
+* output quantities are correct to within a few units in the last
+* place (ulps).
+*
+* In IEEE arithmetic, the code works correctly if one matrix element is
+* infinite.
+*
+* Overflow will not occur unless the largest singular value itself
+* overflows or is within a few ulps of overflow. (On machines with
+* partial overflow, like the Cray, overflow may occur if the largest
+* singular value is within a factor of 2 of overflow.)
+*
+* Underflow is harmless if underflow is gradual. Otherwise, results
+* may correspond to a matrix modified by perturbations of size near
+* the underflow threshold.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO
+ PARAMETER ( ZERO = 0.0E0 )
+ REAL HALF
+ PARAMETER ( HALF = 0.5E0 )
+ REAL ONE
+ PARAMETER ( ONE = 1.0E0 )
+ REAL TWO
+ PARAMETER ( TWO = 2.0E0 )
+ REAL FOUR
+ PARAMETER ( FOUR = 4.0E0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL GASMAL, SWAP
+ INTEGER PMAX
+ REAL A, CLT, CRT, D, FA, FT, GA, GT, HA, HT, L, M,
+ $ MM, R, S, SLT, SRT, T, TEMP, TSIGN, TT
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, SIGN, SQRT
+* ..
+* .. External Functions ..
+ REAL SLAMCH
+ EXTERNAL SLAMCH
+* ..
+* .. Executable Statements ..
+*
+ FT = F
+ FA = ABS( FT )
+ HT = H
+ HA = ABS( H )
+*
+* PMAX points to the maximum absolute element of matrix
+* PMAX = 1 if F largest in absolute values
+* PMAX = 2 if G largest in absolute values
+* PMAX = 3 if H largest in absolute values
+*
+ PMAX = 1
+ SWAP = ( HA.GT.FA )
+ IF( SWAP ) THEN
+ PMAX = 3
+ TEMP = FT
+ FT = HT
+ HT = TEMP
+ TEMP = FA
+ FA = HA
+ HA = TEMP
+*
+* Now FA .ge. HA
+*
+ END IF
+ GT = G
+ GA = ABS( GT )
+ IF( GA.EQ.ZERO ) THEN
+*
+* Diagonal matrix
+*
+ SSMIN = HA
+ SSMAX = FA
+ CLT = ONE
+ CRT = ONE
+ SLT = ZERO
+ SRT = ZERO
+ ELSE
+ GASMAL = .TRUE.
+ IF( GA.GT.FA ) THEN
+ PMAX = 2
+ IF( ( FA / GA ).LT.SLAMCH( 'EPS' ) ) THEN
+*
+* Case of very large GA
+*
+ GASMAL = .FALSE.
+ SSMAX = GA
+ IF( HA.GT.ONE ) THEN
+ SSMIN = FA / ( GA / HA )
+ ELSE
+ SSMIN = ( FA / GA )*HA
+ END IF
+ CLT = ONE
+ SLT = HT / GT
+ SRT = ONE
+ CRT = FT / GT
+ END IF
+ END IF
+ IF( GASMAL ) THEN
+*
+* Normal case
+*
+ D = FA - HA
+ IF( D.EQ.FA ) THEN
+*
+* Copes with infinite F or H
+*
+ L = ONE
+ ELSE
+ L = D / FA
+ END IF
+*
+* Note that 0 .le. L .le. 1
+*
+ M = GT / FT
+*
+* Note that abs(M) .le. 1/macheps
+*
+ T = TWO - L
+*
+* Note that T .ge. 1
+*
+ MM = M*M
+ TT = T*T
+ S = SQRT( TT+MM )
+*
+* Note that 1 .le. S .le. 1 + 1/macheps
+*
+ IF( L.EQ.ZERO ) THEN
+ R = ABS( M )
+ ELSE
+ R = SQRT( L*L+MM )
+ END IF
+*
+* Note that 0 .le. R .le. 1 + 1/macheps
+*
+ A = HALF*( S+R )
+*
+* Note that 1 .le. A .le. 1 + abs(M)
+*
+ SSMIN = HA / A
+ SSMAX = FA*A
+ IF( MM.EQ.ZERO ) THEN
+*
+* Note that M is very tiny
+*
+ IF( L.EQ.ZERO ) THEN
+ T = SIGN( TWO, FT )*SIGN( ONE, GT )
+ ELSE
+ T = GT / SIGN( D, FT ) + M / T
+ END IF
+ ELSE
+ T = ( M / ( S+T )+M / ( R+L ) )*( ONE+A )
+ END IF
+ L = SQRT( T*T+FOUR )
+ CRT = TWO / L
+ SRT = T / L
+ CLT = ( CRT+SRT*M ) / A
+ SLT = ( HT / FT )*SRT / A
+ END IF
+ END IF
+ IF( SWAP ) THEN
+ CSL = SRT
+ SNL = CRT
+ CSR = SLT
+ SNR = CLT
+ ELSE
+ CSL = CLT
+ SNL = SLT
+ CSR = CRT
+ SNR = SRT
+ END IF
+*
+* Correct signs of SSMAX and SSMIN
+*
+ IF( PMAX.EQ.1 )
+ $ TSIGN = SIGN( ONE, CSR )*SIGN( ONE, CSL )*SIGN( ONE, F )
+ IF( PMAX.EQ.2 )
+ $ TSIGN = SIGN( ONE, SNR )*SIGN( ONE, CSL )*SIGN( ONE, G )
+ IF( PMAX.EQ.3 )
+ $ TSIGN = SIGN( ONE, SNR )*SIGN( ONE, SNL )*SIGN( ONE, H )
+ SSMAX = SIGN( SSMAX, TSIGN )
+ SSMIN = SIGN( SSMIN, TSIGN*SIGN( ONE, F )*SIGN( ONE, H ) )
+ RETURN
+*
+* End of SLASV2
+*
+ END
+ SUBROUTINE SLASWP( N, A, LDA, K1, K2, IPIV, INCX )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INCX, K1, K2, LDA, N
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ REAL A( LDA, * )
+* ..
+*
+* Purpose
+* =======
+*
+* SLASWP performs a series of row interchanges on the matrix A.
+* One row interchange is initiated for each of rows K1 through K2 of A.
+*
+* Arguments
+* =========
+*
+* N (input) INTEGER
+* The number of columns of the matrix A.
+*
+* A (input/output) REAL array, dimension (LDA,N)
+* On entry, the matrix of column dimension N to which the row
+* interchanges will be applied.
+* On exit, the permuted matrix.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A.
+*
+* K1 (input) INTEGER
+* The first element of IPIV for which a row interchange will
+* be done.
+*
+* K2 (input) INTEGER
+* The last element of IPIV for which a row interchange will
+* be done.
+*
+* IPIV (input) INTEGER array, dimension (K2*abs(INCX))
+* The vector of pivot indices. Only the elements in positions
+* K1 through K2 of IPIV are accessed.
+* IPIV(K) = L implies rows K and L are to be interchanged.
+*
+* INCX (input) INTEGER
+* The increment between successive values of IPIV. If IPIV
+* is negative, the pivots are applied in reverse order.
+*
+* Further Details
+* ===============
+*
+* Modified by
+* R. C. Whaley, Computer Science Dept., Univ. of Tenn., Knoxville, USA
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ INTEGER I, I1, I2, INC, IP, IX, IX0, J, K, N32
+ REAL TEMP
+* ..
+* .. Executable Statements ..
+*
+* Interchange row I with row IPIV(I) for each of rows K1 through K2.
+*
+ IF( INCX.GT.0 ) THEN
+ IX0 = K1
+ I1 = K1
+ I2 = K2
+ INC = 1
+ ELSE IF( INCX.LT.0 ) THEN
+ IX0 = 1 + ( 1-K2 )*INCX
+ I1 = K2
+ I2 = K1
+ INC = -1
+ ELSE
+ RETURN
+ END IF
+*
+ N32 = ( N / 32 )*32
+ IF( N32.NE.0 ) THEN
+ DO 30 J = 1, N32, 32
+ IX = IX0
+ DO 20 I = I1, I2, INC
+ IP = IPIV( IX )
+ IF( IP.NE.I ) THEN
+ DO 10 K = J, J + 31
+ TEMP = A( I, K )
+ A( I, K ) = A( IP, K )
+ A( IP, K ) = TEMP
+ 10 CONTINUE
+ END IF
+ IX = IX + INCX
+ 20 CONTINUE
+ 30 CONTINUE
+ END IF
+ IF( N32.NE.N ) THEN
+ N32 = N32 + 1
+ IX = IX0
+ DO 50 I = I1, I2, INC
+ IP = IPIV( IX )
+ IF( IP.NE.I ) THEN
+ DO 40 K = N32, N
+ TEMP = A( I, K )
+ A( I, K ) = A( IP, K )
+ A( IP, K ) = TEMP
+ 40 CONTINUE
+ END IF
+ IX = IX + INCX
+ 50 CONTINUE
+ END IF
+*
+ RETURN
+*
+* End of SLASWP
+*
+ END
+ SUBROUTINE SLASY2( LTRANL, LTRANR, ISGN, N1, N2, TL, LDTL, TR,
+ $ LDTR, B, LDB, SCALE, X, LDX, XNORM, INFO )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ LOGICAL LTRANL, LTRANR
+ INTEGER INFO, ISGN, LDB, LDTL, LDTR, LDX, N1, N2
+ REAL SCALE, XNORM
+* ..
+* .. Array Arguments ..
+ REAL B( LDB, * ), TL( LDTL, * ), TR( LDTR, * ),
+ $ X( LDX, * )
+* ..
+*
+* Purpose
+* =======
+*
+* SLASY2 solves for the N1 by N2 matrix X, 1 <= N1,N2 <= 2, in
+*
+* op(TL)*X + ISGN*X*op(TR) = SCALE*B,
+*
+* where TL is N1 by N1, TR is N2 by N2, B is N1 by N2, and ISGN = 1 or
+* -1. op(T) = T or T', where T' denotes the transpose of T.
+*
+* Arguments
+* =========
+*
+* LTRANL (input) LOGICAL
+* On entry, LTRANL specifies the op(TL):
+* = .FALSE., op(TL) = TL,
+* = .TRUE., op(TL) = TL'.
+*
+* LTRANR (input) LOGICAL
+* On entry, LTRANR specifies the op(TR):
+* = .FALSE., op(TR) = TR,
+* = .TRUE., op(TR) = TR'.
+*
+* ISGN (input) INTEGER
+* On entry, ISGN specifies the sign of the equation
+* as described before. ISGN may only be 1 or -1.
+*
+* N1 (input) INTEGER
+* On entry, N1 specifies the order of matrix TL.
+* N1 may only be 0, 1 or 2.
+*
+* N2 (input) INTEGER
+* On entry, N2 specifies the order of matrix TR.
+* N2 may only be 0, 1 or 2.
+*
+* TL (input) REAL array, dimension (LDTL,2)
+* On entry, TL contains an N1 by N1 matrix.
+*
+* LDTL (input) INTEGER
+* The leading dimension of the matrix TL. LDTL >= max(1,N1).
+*
+* TR (input) REAL array, dimension (LDTR,2)
+* On entry, TR contains an N2 by N2 matrix.
+*
+* LDTR (input) INTEGER
+* The leading dimension of the matrix TR. LDTR >= max(1,N2).
+*
+* B (input) REAL array, dimension (LDB,2)
+* On entry, the N1 by N2 matrix B contains the right-hand
+* side of the equation.
+*
+* LDB (input) INTEGER
+* The leading dimension of the matrix B. LDB >= max(1,N1).
+*
+* SCALE (output) REAL
+* On exit, SCALE contains the scale factor. SCALE is chosen
+* less than or equal to 1 to prevent the solution overflowing.
+*
+* X (output) REAL array, dimension (LDX,2)
+* On exit, X contains the N1 by N2 solution.
+*
+* LDX (input) INTEGER
+* The leading dimension of the matrix X. LDX >= max(1,N1).
+*
+* XNORM (output) REAL
+* On exit, XNORM is the infinity-norm of the solution.
+*
+* INFO (output) INTEGER
+* On exit, INFO is set to
+* 0: successful exit.
+* 1: TL and TR have too close eigenvalues, so TL or
+* TR is perturbed to get a nonsingular equation.
+* NOTE: In the interests of speed, this routine does not
+* check the inputs for errors.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO, ONE
+ PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+ REAL TWO, HALF, EIGHT
+ PARAMETER ( TWO = 2.0E+0, HALF = 0.5E+0, EIGHT = 8.0E+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL BSWAP, XSWAP
+ INTEGER I, IP, IPIV, IPSV, J, JP, JPSV, K
+ REAL BET, EPS, GAM, L21, SGN, SMIN, SMLNUM, TAU1,
+ $ TEMP, U11, U12, U22, XMAX
+* ..
+* .. Local Arrays ..
+ LOGICAL BSWPIV( 4 ), XSWPIV( 4 )
+ INTEGER JPIV( 4 ), LOCL21( 4 ), LOCU12( 4 ),
+ $ LOCU22( 4 )
+ REAL BTMP( 4 ), T16( 4, 4 ), TMP( 4 ), X2( 2 )
+* ..
+* .. External Functions ..
+ INTEGER ISAMAX
+ REAL SLAMCH
+ EXTERNAL ISAMAX, SLAMCH
+* ..
+* .. External Subroutines ..
+ EXTERNAL SCOPY, SSWAP
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX
+* ..
+* .. Data statements ..
+ DATA LOCU12 / 3, 4, 1, 2 / , LOCL21 / 2, 1, 4, 3 / ,
+ $ LOCU22 / 4, 3, 2, 1 /
+ DATA XSWPIV / .FALSE., .FALSE., .TRUE., .TRUE. /
+ DATA BSWPIV / .FALSE., .TRUE., .FALSE., .TRUE. /
+* ..
+* .. Executable Statements ..
+*
+* Do not check the input parameters for errors
+*
+ INFO = 0
+*
+* Quick return if possible
+*
+ IF( N1.EQ.0 .OR. N2.EQ.0 )
+ $ RETURN
+*
+* Set constants to control overflow
+*
+ EPS = SLAMCH( 'P' )
+ SMLNUM = SLAMCH( 'S' ) / EPS
+ SGN = ISGN
+*
+ K = N1 + N1 + N2 - 2
+ GO TO ( 10, 20, 30, 50 )K
+*
+* 1 by 1: TL11*X + SGN*X*TR11 = B11
+*
+ 10 CONTINUE
+ TAU1 = TL( 1, 1 ) + SGN*TR( 1, 1 )
+ BET = ABS( TAU1 )
+ IF( BET.LE.SMLNUM ) THEN
+ TAU1 = SMLNUM
+ BET = SMLNUM
+ INFO = 1
+ END IF
+*
+ SCALE = ONE
+ GAM = ABS( B( 1, 1 ) )
+ IF( SMLNUM*GAM.GT.BET )
+ $ SCALE = ONE / GAM
+*
+ X( 1, 1 ) = ( B( 1, 1 )*SCALE ) / TAU1
+ XNORM = ABS( X( 1, 1 ) )
+ RETURN
+*
+* 1 by 2:
+* TL11*[X11 X12] + ISGN*[X11 X12]*op[TR11 TR12] = [B11 B12]
+* [TR21 TR22]
+*
+ 20 CONTINUE
+*
+ SMIN = MAX( EPS*MAX( ABS( TL( 1, 1 ) ), ABS( TR( 1, 1 ) ),
+ $ ABS( TR( 1, 2 ) ), ABS( TR( 2, 1 ) ), ABS( TR( 2, 2 ) ) ),
+ $ SMLNUM )
+ TMP( 1 ) = TL( 1, 1 ) + SGN*TR( 1, 1 )
+ TMP( 4 ) = TL( 1, 1 ) + SGN*TR( 2, 2 )
+ IF( LTRANR ) THEN
+ TMP( 2 ) = SGN*TR( 2, 1 )
+ TMP( 3 ) = SGN*TR( 1, 2 )
+ ELSE
+ TMP( 2 ) = SGN*TR( 1, 2 )
+ TMP( 3 ) = SGN*TR( 2, 1 )
+ END IF
+ BTMP( 1 ) = B( 1, 1 )
+ BTMP( 2 ) = B( 1, 2 )
+ GO TO 40
+*
+* 2 by 1:
+* op[TL11 TL12]*[X11] + ISGN* [X11]*TR11 = [B11]
+* [TL21 TL22] [X21] [X21] [B21]
+*
+ 30 CONTINUE
+ SMIN = MAX( EPS*MAX( ABS( TR( 1, 1 ) ), ABS( TL( 1, 1 ) ),
+ $ ABS( TL( 1, 2 ) ), ABS( TL( 2, 1 ) ), ABS( TL( 2, 2 ) ) ),
+ $ SMLNUM )
+ TMP( 1 ) = TL( 1, 1 ) + SGN*TR( 1, 1 )
+ TMP( 4 ) = TL( 2, 2 ) + SGN*TR( 1, 1 )
+ IF( LTRANL ) THEN
+ TMP( 2 ) = TL( 1, 2 )
+ TMP( 3 ) = TL( 2, 1 )
+ ELSE
+ TMP( 2 ) = TL( 2, 1 )
+ TMP( 3 ) = TL( 1, 2 )
+ END IF
+ BTMP( 1 ) = B( 1, 1 )
+ BTMP( 2 ) = B( 2, 1 )
+ 40 CONTINUE
+*
+* Solve 2 by 2 system using complete pivoting.
+* Set pivots less than SMIN to SMIN.
+*
+ IPIV = ISAMAX( 4, TMP, 1 )
+ U11 = TMP( IPIV )
+ IF( ABS( U11 ).LE.SMIN ) THEN
+ INFO = 1
+ U11 = SMIN
+ END IF
+ U12 = TMP( LOCU12( IPIV ) )
+ L21 = TMP( LOCL21( IPIV ) ) / U11
+ U22 = TMP( LOCU22( IPIV ) ) - U12*L21
+ XSWAP = XSWPIV( IPIV )
+ BSWAP = BSWPIV( IPIV )
+ IF( ABS( U22 ).LE.SMIN ) THEN
+ INFO = 1
+ U22 = SMIN
+ END IF
+ IF( BSWAP ) THEN
+ TEMP = BTMP( 2 )
+ BTMP( 2 ) = BTMP( 1 ) - L21*TEMP
+ BTMP( 1 ) = TEMP
+ ELSE
+ BTMP( 2 ) = BTMP( 2 ) - L21*BTMP( 1 )
+ END IF
+ SCALE = ONE
+ IF( ( TWO*SMLNUM )*ABS( BTMP( 2 ) ).GT.ABS( U22 ) .OR.
+ $ ( TWO*SMLNUM )*ABS( BTMP( 1 ) ).GT.ABS( U11 ) ) THEN
+ SCALE = HALF / MAX( ABS( BTMP( 1 ) ), ABS( BTMP( 2 ) ) )
+ BTMP( 1 ) = BTMP( 1 )*SCALE
+ BTMP( 2 ) = BTMP( 2 )*SCALE
+ END IF
+ X2( 2 ) = BTMP( 2 ) / U22
+ X2( 1 ) = BTMP( 1 ) / U11 - ( U12 / U11 )*X2( 2 )
+ IF( XSWAP ) THEN
+ TEMP = X2( 2 )
+ X2( 2 ) = X2( 1 )
+ X2( 1 ) = TEMP
+ END IF
+ X( 1, 1 ) = X2( 1 )
+ IF( N1.EQ.1 ) THEN
+ X( 1, 2 ) = X2( 2 )
+ XNORM = ABS( X( 1, 1 ) ) + ABS( X( 1, 2 ) )
+ ELSE
+ X( 2, 1 ) = X2( 2 )
+ XNORM = MAX( ABS( X( 1, 1 ) ), ABS( X( 2, 1 ) ) )
+ END IF
+ RETURN
+*
+* 2 by 2:
+* op[TL11 TL12]*[X11 X12] +ISGN* [X11 X12]*op[TR11 TR12] = [B11 B12]
+* [TL21 TL22] [X21 X22] [X21 X22] [TR21 TR22] [B21 B22]
+*
+* Solve equivalent 4 by 4 system using complete pivoting.
+* Set pivots less than SMIN to SMIN.
+*
+ 50 CONTINUE
+ SMIN = MAX( ABS( TR( 1, 1 ) ), ABS( TR( 1, 2 ) ),
+ $ ABS( TR( 2, 1 ) ), ABS( TR( 2, 2 ) ) )
+ SMIN = MAX( SMIN, ABS( TL( 1, 1 ) ), ABS( TL( 1, 2 ) ),
+ $ ABS( TL( 2, 1 ) ), ABS( TL( 2, 2 ) ) )
+ SMIN = MAX( EPS*SMIN, SMLNUM )
+ BTMP( 1 ) = ZERO
+ CALL SCOPY( 16, BTMP, 0, T16, 1 )
+ T16( 1, 1 ) = TL( 1, 1 ) + SGN*TR( 1, 1 )
+ T16( 2, 2 ) = TL( 2, 2 ) + SGN*TR( 1, 1 )
+ T16( 3, 3 ) = TL( 1, 1 ) + SGN*TR( 2, 2 )
+ T16( 4, 4 ) = TL( 2, 2 ) + SGN*TR( 2, 2 )
+ IF( LTRANL ) THEN
+ T16( 1, 2 ) = TL( 2, 1 )
+ T16( 2, 1 ) = TL( 1, 2 )
+ T16( 3, 4 ) = TL( 2, 1 )
+ T16( 4, 3 ) = TL( 1, 2 )
+ ELSE
+ T16( 1, 2 ) = TL( 1, 2 )
+ T16( 2, 1 ) = TL( 2, 1 )
+ T16( 3, 4 ) = TL( 1, 2 )
+ T16( 4, 3 ) = TL( 2, 1 )
+ END IF
+ IF( LTRANR ) THEN
+ T16( 1, 3 ) = SGN*TR( 1, 2 )
+ T16( 2, 4 ) = SGN*TR( 1, 2 )
+ T16( 3, 1 ) = SGN*TR( 2, 1 )
+ T16( 4, 2 ) = SGN*TR( 2, 1 )
+ ELSE
+ T16( 1, 3 ) = SGN*TR( 2, 1 )
+ T16( 2, 4 ) = SGN*TR( 2, 1 )
+ T16( 3, 1 ) = SGN*TR( 1, 2 )
+ T16( 4, 2 ) = SGN*TR( 1, 2 )
+ END IF
+ BTMP( 1 ) = B( 1, 1 )
+ BTMP( 2 ) = B( 2, 1 )
+ BTMP( 3 ) = B( 1, 2 )
+ BTMP( 4 ) = B( 2, 2 )
+*
+* Perform elimination
+*
+ DO 100 I = 1, 3
+ XMAX = ZERO
+ DO 70 IP = I, 4
+ DO 60 JP = I, 4
+ IF( ABS( T16( IP, JP ) ).GE.XMAX ) THEN
+ XMAX = ABS( T16( IP, JP ) )
+ IPSV = IP
+ JPSV = JP
+ END IF
+ 60 CONTINUE
+ 70 CONTINUE
+ IF( IPSV.NE.I ) THEN
+ CALL SSWAP( 4, T16( IPSV, 1 ), 4, T16( I, 1 ), 4 )
+ TEMP = BTMP( I )
+ BTMP( I ) = BTMP( IPSV )
+ BTMP( IPSV ) = TEMP
+ END IF
+ IF( JPSV.NE.I )
+ $ CALL SSWAP( 4, T16( 1, JPSV ), 1, T16( 1, I ), 1 )
+ JPIV( I ) = JPSV
+ IF( ABS( T16( I, I ) ).LT.SMIN ) THEN
+ INFO = 1
+ T16( I, I ) = SMIN
+ END IF
+ DO 90 J = I + 1, 4
+ T16( J, I ) = T16( J, I ) / T16( I, I )
+ BTMP( J ) = BTMP( J ) - T16( J, I )*BTMP( I )
+ DO 80 K = I + 1, 4
+ T16( J, K ) = T16( J, K ) - T16( J, I )*T16( I, K )
+ 80 CONTINUE
+ 90 CONTINUE
+ 100 CONTINUE
+ IF( ABS( T16( 4, 4 ) ).LT.SMIN )
+ $ T16( 4, 4 ) = SMIN
+ SCALE = ONE
+ IF( ( EIGHT*SMLNUM )*ABS( BTMP( 1 ) ).GT.ABS( T16( 1, 1 ) ) .OR.
+ $ ( EIGHT*SMLNUM )*ABS( BTMP( 2 ) ).GT.ABS( T16( 2, 2 ) ) .OR.
+ $ ( EIGHT*SMLNUM )*ABS( BTMP( 3 ) ).GT.ABS( T16( 3, 3 ) ) .OR.
+ $ ( EIGHT*SMLNUM )*ABS( BTMP( 4 ) ).GT.ABS( T16( 4, 4 ) ) ) THEN
+ SCALE = ( ONE / EIGHT ) / MAX( ABS( BTMP( 1 ) ),
+ $ ABS( BTMP( 2 ) ), ABS( BTMP( 3 ) ), ABS( BTMP( 4 ) ) )
+ BTMP( 1 ) = BTMP( 1 )*SCALE
+ BTMP( 2 ) = BTMP( 2 )*SCALE
+ BTMP( 3 ) = BTMP( 3 )*SCALE
+ BTMP( 4 ) = BTMP( 4 )*SCALE
+ END IF
+ DO 120 I = 1, 4
+ K = 5 - I
+ TEMP = ONE / T16( K, K )
+ TMP( K ) = BTMP( K )*TEMP
+ DO 110 J = K + 1, 4
+ TMP( K ) = TMP( K ) - ( TEMP*T16( K, J ) )*TMP( J )
+ 110 CONTINUE
+ 120 CONTINUE
+ DO 130 I = 1, 3
+ IF( JPIV( 4-I ).NE.4-I ) THEN
+ TEMP = TMP( 4-I )
+ TMP( 4-I ) = TMP( JPIV( 4-I ) )
+ TMP( JPIV( 4-I ) ) = TEMP
+ END IF
+ 130 CONTINUE
+ X( 1, 1 ) = TMP( 1 )
+ X( 2, 1 ) = TMP( 2 )
+ X( 1, 2 ) = TMP( 3 )
+ X( 2, 2 ) = TMP( 4 )
+ XNORM = MAX( ABS( TMP( 1 ) )+ABS( TMP( 3 ) ),
+ $ ABS( TMP( 2 ) )+ABS( TMP( 4 ) ) )
+ RETURN
+*
+* End of SLASY2
+*
+ END
+ SUBROUTINE SLASYF( UPLO, N, NB, KB, A, LDA, IPIV, W, LDW, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, KB, LDA, LDW, N, NB
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ REAL A( LDA, * ), W( LDW, * )
+* ..
+*
+* Purpose
+* =======
+*
+* SLASYF computes a partial factorization of a real symmetric matrix A
+* using the Bunch-Kaufman diagonal pivoting method. The partial
+* factorization has the form:
+*
+* A = ( I U12 ) ( A11 0 ) ( I 0 ) if UPLO = 'U', or:
+* ( 0 U22 ) ( 0 D ) ( U12' U22' )
+*
+* A = ( L11 0 ) ( D 0 ) ( L11' L21' ) if UPLO = 'L'
+* ( L21 I ) ( 0 A22 ) ( 0 I )
+*
+* where the order of D is at most NB. The actual order is returned in
+* the argument KB, and is either NB or NB-1, or N if N <= NB.
+*
+* SLASYF is an auxiliary routine called by SSYTRF. It uses blocked code
+* (calling Level 3 BLAS) to update the submatrix A11 (if UPLO = 'U') or
+* A22 (if UPLO = 'L').
+*
+* Arguments
+* =========
+*
+* UPLO (input) CHARACTER*1
+* Specifies whether the upper or lower triangular part of the
+* symmetric matrix A is stored:
+* = 'U': Upper triangular
+* = 'L': Lower triangular
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* NB (input) INTEGER
+* The maximum number of columns of the matrix A that should be
+* factored. NB should be at least 2 to allow for 2-by-2 pivot
+* blocks.
+*
+* KB (output) INTEGER
+* The number of columns of A that were actually factored.
+* KB is either NB-1 or NB, or N if N <= NB.
+*
+* A (input/output) REAL array, dimension (LDA,N)
+* On entry, the symmetric matrix A. If UPLO = 'U', the leading
+* n-by-n upper triangular part of A contains the upper
+* triangular part of the matrix A, and the strictly lower
+* triangular part of A is not referenced. If UPLO = 'L', the
+* leading n-by-n lower triangular part of A contains the lower
+* triangular part of the matrix A, and the strictly upper
+* triangular part of A is not referenced.
+* On exit, A contains details of the partial factorization.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,N).
+*
+* IPIV (output) INTEGER array, dimension (N)
+* Details of the interchanges and the block structure of D.
+* If UPLO = 'U', only the last KB elements of IPIV are set;
+* if UPLO = 'L', only the first KB elements are set.
+*
+* If IPIV(k) > 0, then rows and columns k and IPIV(k) were
+* interchanged and D(k,k) is a 1-by-1 diagonal block.
+* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and
+* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)
+* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =
+* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were
+* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
+*
+* W (workspace) REAL array, dimension (LDW,NB)
+*
+* LDW (input) INTEGER
+* The leading dimension of the array W. LDW >= max(1,N).
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* > 0: if INFO = k, D(k,k) is exactly zero. The factorization
+* has been completed, but the block diagonal matrix D is
+* exactly singular.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO, ONE
+ PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+ REAL EIGHT, SEVTEN
+ PARAMETER ( EIGHT = 8.0E+0, SEVTEN = 17.0E+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER IMAX, J, JB, JJ, JMAX, JP, K, KK, KKW, KP,
+ $ KSTEP, KW
+ REAL ABSAKK, ALPHA, COLMAX, D11, D21, D22, R1,
+ $ ROWMAX, T
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ISAMAX
+ EXTERNAL LSAME, ISAMAX
+* ..
+* .. External Subroutines ..
+ EXTERNAL SCOPY, SGEMM, SGEMV, SSCAL, SSWAP
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, MIN, SQRT
+* ..
+* .. Executable Statements ..
+*
+ INFO = 0
+*
+* Initialize ALPHA for use in choosing pivot block size.
+*
+ ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT
+*
+ IF( LSAME( UPLO, 'U' ) ) THEN
+*
+* Factorize the trailing columns of A using the upper triangle
+* of A and working backwards, and compute the matrix W = U12*D
+* for use in updating A11
+*
+* K is the main loop index, decreasing from N in steps of 1 or 2
+*
+* KW is the column of W which corresponds to column K of A
+*
+ K = N
+ 10 CONTINUE
+ KW = NB + K - N
+*
+* Exit from loop
+*
+ IF( ( K.LE.N-NB+1 .AND. NB.LT.N ) .OR. K.LT.1 )
+ $ GO TO 30
+*
+* Copy column K of A to column KW of W and update it
+*
+ CALL SCOPY( K, A( 1, K ), 1, W( 1, KW ), 1 )
+ IF( K.LT.N )
+ $ CALL SGEMV( 'No transpose', K, N-K, -ONE, A( 1, K+1 ), LDA,
+ $ W( K, KW+1 ), LDW, ONE, W( 1, KW ), 1 )
+*
+ KSTEP = 1
+*
+* Determine rows and columns to be interchanged and whether
+* a 1-by-1 or 2-by-2 pivot block will be used
+*
+ ABSAKK = ABS( W( K, KW ) )
+*
+* IMAX is the row-index of the largest off-diagonal element in
+* column K, and COLMAX is its absolute value
+*
+ IF( K.GT.1 ) THEN
+ IMAX = ISAMAX( K-1, W( 1, KW ), 1 )
+ COLMAX = ABS( W( IMAX, KW ) )
+ ELSE
+ COLMAX = ZERO
+ END IF
+*
+ IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN
+*
+* Column K is zero: set INFO and continue
+*
+ IF( INFO.EQ.0 )
+ $ INFO = K
+ KP = K
+ ELSE
+ IF( ABSAKK.GE.ALPHA*COLMAX ) THEN
+*
+* no interchange, use 1-by-1 pivot block
+*
+ KP = K
+ ELSE
+*
+* Copy column IMAX to column KW-1 of W and update it
+*
+ CALL SCOPY( IMAX, A( 1, IMAX ), 1, W( 1, KW-1 ), 1 )
+ CALL SCOPY( K-IMAX, A( IMAX, IMAX+1 ), LDA,
+ $ W( IMAX+1, KW-1 ), 1 )
+ IF( K.LT.N )
+ $ CALL SGEMV( 'No transpose', K, N-K, -ONE, A( 1, K+1 ),
+ $ LDA, W( IMAX, KW+1 ), LDW, ONE,
+ $ W( 1, KW-1 ), 1 )
+*
+* JMAX is the column-index of the largest off-diagonal
+* element in row IMAX, and ROWMAX is its absolute value
+*
+ JMAX = IMAX + ISAMAX( K-IMAX, W( IMAX+1, KW-1 ), 1 )
+ ROWMAX = ABS( W( JMAX, KW-1 ) )
+ IF( IMAX.GT.1 ) THEN
+ JMAX = ISAMAX( IMAX-1, W( 1, KW-1 ), 1 )
+ ROWMAX = MAX( ROWMAX, ABS( W( JMAX, KW-1 ) ) )
+ END IF
+*
+ IF( ABSAKK.GE.ALPHA*COLMAX*( COLMAX / ROWMAX ) ) THEN
+*
+* no interchange, use 1-by-1 pivot block
+*
+ KP = K
+ ELSE IF( ABS( W( IMAX, KW-1 ) ).GE.ALPHA*ROWMAX ) THEN
+*
+* interchange rows and columns K and IMAX, use 1-by-1
+* pivot block
+*
+ KP = IMAX
+*
+* copy column KW-1 of W to column KW
+*
+ CALL SCOPY( K, W( 1, KW-1 ), 1, W( 1, KW ), 1 )
+ ELSE
+*
+* interchange rows and columns K-1 and IMAX, use 2-by-2
+* pivot block
+*
+ KP = IMAX
+ KSTEP = 2
+ END IF
+ END IF
+*
+ KK = K - KSTEP + 1
+ KKW = NB + KK - N
+*
+* Updated column KP is already stored in column KKW of W
+*
+ IF( KP.NE.KK ) THEN
+*
+* Copy non-updated column KK to column KP
+*
+ A( KP, K ) = A( KK, K )
+ CALL SCOPY( K-1-KP, A( KP+1, KK ), 1, A( KP, KP+1 ),
+ $ LDA )
+ CALL SCOPY( KP, A( 1, KK ), 1, A( 1, KP ), 1 )
+*
+* Interchange rows KK and KP in last KK columns of A and W
+*
+ CALL SSWAP( N-KK+1, A( KK, KK ), LDA, A( KP, KK ), LDA )
+ CALL SSWAP( N-KK+1, W( KK, KKW ), LDW, W( KP, KKW ),
+ $ LDW )
+ END IF
+*
+ IF( KSTEP.EQ.1 ) THEN
+*
+* 1-by-1 pivot block D(k): column KW of W now holds
+*
+* W(k) = U(k)*D(k)
+*
+* where U(k) is the k-th column of U
+*
+* Store U(k) in column k of A
+*
+ CALL SCOPY( K, W( 1, KW ), 1, A( 1, K ), 1 )
+ R1 = ONE / A( K, K )
+ CALL SSCAL( K-1, R1, A( 1, K ), 1 )
+ ELSE
+*
+* 2-by-2 pivot block D(k): columns KW and KW-1 of W now
+* hold
+*
+* ( W(k-1) W(k) ) = ( U(k-1) U(k) )*D(k)
+*
+* where U(k) and U(k-1) are the k-th and (k-1)-th columns
+* of U
+*
+ IF( K.GT.2 ) THEN
+*
+* Store U(k) and U(k-1) in columns k and k-1 of A
+*
+ D21 = W( K-1, KW )
+ D11 = W( K, KW ) / D21
+ D22 = W( K-1, KW-1 ) / D21
+ T = ONE / ( D11*D22-ONE )
+ D21 = T / D21
+ DO 20 J = 1, K - 2
+ A( J, K-1 ) = D21*( D11*W( J, KW-1 )-W( J, KW ) )
+ A( J, K ) = D21*( D22*W( J, KW )-W( J, KW-1 ) )
+ 20 CONTINUE
+ END IF
+*
+* Copy D(k) to A
+*
+ A( K-1, K-1 ) = W( K-1, KW-1 )
+ A( K-1, K ) = W( K-1, KW )
+ A( K, K ) = W( K, KW )
+ END IF
+ END IF
+*
+* Store details of the interchanges in IPIV
+*
+ IF( KSTEP.EQ.1 ) THEN
+ IPIV( K ) = KP
+ ELSE
+ IPIV( K ) = -KP
+ IPIV( K-1 ) = -KP
+ END IF
+*
+* Decrease K and return to the start of the main loop
+*
+ K = K - KSTEP
+ GO TO 10
+*
+ 30 CONTINUE
+*
+* Update the upper triangle of A11 (= A(1:k,1:k)) as
+*
+* A11 := A11 - U12*D*U12' = A11 - U12*W'
+*
+* computing blocks of NB columns at a time
+*
+ DO 50 J = ( ( K-1 ) / NB )*NB + 1, 1, -NB
+ JB = MIN( NB, K-J+1 )
+*
+* Update the upper triangle of the diagonal block
+*
+ DO 40 JJ = J, J + JB - 1
+ CALL SGEMV( 'No transpose', JJ-J+1, N-K, -ONE,
+ $ A( J, K+1 ), LDA, W( JJ, KW+1 ), LDW, ONE,
+ $ A( J, JJ ), 1 )
+ 40 CONTINUE
+*
+* Update the rectangular superdiagonal block
+*
+ CALL SGEMM( 'No transpose', 'Transpose', J-1, JB, N-K, -ONE,
+ $ A( 1, K+1 ), LDA, W( J, KW+1 ), LDW, ONE,
+ $ A( 1, J ), LDA )
+ 50 CONTINUE
+*
+* Put U12 in standard form by partially undoing the interchanges
+* in columns k+1:n
+*
+ J = K + 1
+ 60 CONTINUE
+ JJ = J
+ JP = IPIV( J )
+ IF( JP.LT.0 ) THEN
+ JP = -JP
+ J = J + 1
+ END IF
+ J = J + 1
+ IF( JP.NE.JJ .AND. J.LE.N )
+ $ CALL SSWAP( N-J+1, A( JP, J ), LDA, A( JJ, J ), LDA )
+ IF( J.LE.N )
+ $ GO TO 60
+*
+* Set KB to the number of columns factorized
+*
+ KB = N - K
+*
+ ELSE
+*
+* Factorize the leading columns of A using the lower triangle
+* of A and working forwards, and compute the matrix W = L21*D
+* for use in updating A22
+*
+* K is the main loop index, increasing from 1 in steps of 1 or 2
+*
+ K = 1
+ 70 CONTINUE
+*
+* Exit from loop
+*
+ IF( ( K.GE.NB .AND. NB.LT.N ) .OR. K.GT.N )
+ $ GO TO 90
+*
+* Copy column K of A to column K of W and update it
+*
+ CALL SCOPY( N-K+1, A( K, K ), 1, W( K, K ), 1 )
+ CALL SGEMV( 'No transpose', N-K+1, K-1, -ONE, A( K, 1 ), LDA,
+ $ W( K, 1 ), LDW, ONE, W( K, K ), 1 )
+*
+ KSTEP = 1
+*
+* Determine rows and columns to be interchanged and whether
+* a 1-by-1 or 2-by-2 pivot block will be used
+*
+ ABSAKK = ABS( W( K, K ) )
+*
+* IMAX is the row-index of the largest off-diagonal element in
+* column K, and COLMAX is its absolute value
+*
+ IF( K.LT.N ) THEN
+ IMAX = K + ISAMAX( N-K, W( K+1, K ), 1 )
+ COLMAX = ABS( W( IMAX, K ) )
+ ELSE
+ COLMAX = ZERO
+ END IF
+*
+ IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN
+*
+* Column K is zero: set INFO and continue
+*
+ IF( INFO.EQ.0 )
+ $ INFO = K
+ KP = K
+ ELSE
+ IF( ABSAKK.GE.ALPHA*COLMAX ) THEN
+*
+* no interchange, use 1-by-1 pivot block
+*
+ KP = K
+ ELSE
+*
+* Copy column IMAX to column K+1 of W and update it
+*
+ CALL SCOPY( IMAX-K, A( IMAX, K ), LDA, W( K, K+1 ), 1 )
+ CALL SCOPY( N-IMAX+1, A( IMAX, IMAX ), 1, W( IMAX, K+1 ),
+ $ 1 )
+ CALL SGEMV( 'No transpose', N-K+1, K-1, -ONE, A( K, 1 ),
+ $ LDA, W( IMAX, 1 ), LDW, ONE, W( K, K+1 ), 1 )
+*
+* JMAX is the column-index of the largest off-diagonal
+* element in row IMAX, and ROWMAX is its absolute value
+*
+ JMAX = K - 1 + ISAMAX( IMAX-K, W( K, K+1 ), 1 )
+ ROWMAX = ABS( W( JMAX, K+1 ) )
+ IF( IMAX.LT.N ) THEN
+ JMAX = IMAX + ISAMAX( N-IMAX, W( IMAX+1, K+1 ), 1 )
+ ROWMAX = MAX( ROWMAX, ABS( W( JMAX, K+1 ) ) )
+ END IF
+*
+ IF( ABSAKK.GE.ALPHA*COLMAX*( COLMAX / ROWMAX ) ) THEN
+*
+* no interchange, use 1-by-1 pivot block
+*
+ KP = K
+ ELSE IF( ABS( W( IMAX, K+1 ) ).GE.ALPHA*ROWMAX ) THEN
+*
+* interchange rows and columns K and IMAX, use 1-by-1
+* pivot block
+*
+ KP = IMAX
+*
+* copy column K+1 of W to column K
+*
+ CALL SCOPY( N-K+1, W( K, K+1 ), 1, W( K, K ), 1 )
+ ELSE
+*
+* interchange rows and columns K+1 and IMAX, use 2-by-2
+* pivot block
+*
+ KP = IMAX
+ KSTEP = 2
+ END IF
+ END IF
+*
+ KK = K + KSTEP - 1
+*
+* Updated column KP is already stored in column KK of W
+*
+ IF( KP.NE.KK ) THEN
+*
+* Copy non-updated column KK to column KP
+*
+ A( KP, K ) = A( KK, K )
+ CALL SCOPY( KP-K-1, A( K+1, KK ), 1, A( KP, K+1 ), LDA )
+ CALL SCOPY( N-KP+1, A( KP, KK ), 1, A( KP, KP ), 1 )
+*
+* Interchange rows KK and KP in first KK columns of A and W
+*
+ CALL SSWAP( KK, A( KK, 1 ), LDA, A( KP, 1 ), LDA )
+ CALL SSWAP( KK, W( KK, 1 ), LDW, W( KP, 1 ), LDW )
+ END IF
+*
+ IF( KSTEP.EQ.1 ) THEN
+*
+* 1-by-1 pivot block D(k): column k of W now holds
+*
+* W(k) = L(k)*D(k)
+*
+* where L(k) is the k-th column of L
+*
+* Store L(k) in column k of A
+*
+ CALL SCOPY( N-K+1, W( K, K ), 1, A( K, K ), 1 )
+ IF( K.LT.N ) THEN
+ R1 = ONE / A( K, K )
+ CALL SSCAL( N-K, R1, A( K+1, K ), 1 )
+ END IF
+ ELSE
+*
+* 2-by-2 pivot block D(k): columns k and k+1 of W now hold
+*
+* ( W(k) W(k+1) ) = ( L(k) L(k+1) )*D(k)
+*
+* where L(k) and L(k+1) are the k-th and (k+1)-th columns
+* of L
+*
+ IF( K.LT.N-1 ) THEN
+*
+* Store L(k) and L(k+1) in columns k and k+1 of A
+*
+ D21 = W( K+1, K )
+ D11 = W( K+1, K+1 ) / D21
+ D22 = W( K, K ) / D21
+ T = ONE / ( D11*D22-ONE )
+ D21 = T / D21
+ DO 80 J = K + 2, N
+ A( J, K ) = D21*( D11*W( J, K )-W( J, K+1 ) )
+ A( J, K+1 ) = D21*( D22*W( J, K+1 )-W( J, K ) )
+ 80 CONTINUE
+ END IF
+*
+* Copy D(k) to A
+*
+ A( K, K ) = W( K, K )
+ A( K+1, K ) = W( K+1, K )
+ A( K+1, K+1 ) = W( K+1, K+1 )
+ END IF
+ END IF
+*
+* Store details of the interchanges in IPIV
+*
+ IF( KSTEP.EQ.1 ) THEN
+ IPIV( K ) = KP
+ ELSE
+ IPIV( K ) = -KP
+ IPIV( K+1 ) = -KP
+ END IF
+*
+* Increase K and return to the start of the main loop
+*
+ K = K + KSTEP
+ GO TO 70
+*
+ 90 CONTINUE
+*
+* Update the lower triangle of A22 (= A(k:n,k:n)) as
+*
+* A22 := A22 - L21*D*L21' = A22 - L21*W'
+*
+* computing blocks of NB columns at a time
+*
+ DO 110 J = K, N, NB
+ JB = MIN( NB, N-J+1 )
+*
+* Update the lower triangle of the diagonal block
+*
+ DO 100 JJ = J, J + JB - 1
+ CALL SGEMV( 'No transpose', J+JB-JJ, K-1, -ONE,
+ $ A( JJ, 1 ), LDA, W( JJ, 1 ), LDW, ONE,
+ $ A( JJ, JJ ), 1 )
+ 100 CONTINUE
+*
+* Update the rectangular subdiagonal block
+*
+ IF( J+JB.LE.N )
+ $ CALL SGEMM( 'No transpose', 'Transpose', N-J-JB+1, JB,
+ $ K-1, -ONE, A( J+JB, 1 ), LDA, W( J, 1 ), LDW,
+ $ ONE, A( J+JB, J ), LDA )
+ 110 CONTINUE
+*
+* Put L21 in standard form by partially undoing the interchanges
+* in columns 1:k-1
+*
+ J = K - 1
+ 120 CONTINUE
+ JJ = J
+ JP = IPIV( J )
+ IF( JP.LT.0 ) THEN
+ JP = -JP
+ J = J - 1
+ END IF
+ J = J - 1
+ IF( JP.NE.JJ .AND. J.GE.1 )
+ $ CALL SSWAP( J, A( JP, 1 ), LDA, A( JJ, 1 ), LDA )
+ IF( J.GE.1 )
+ $ GO TO 120
+*
+* Set KB to the number of columns factorized
+*
+ KB = K - 1
+*
+ END IF
+ RETURN
+*
+* End of SLASYF
+*
+ END
+ SUBROUTINE SLATBS( UPLO, TRANS, DIAG, NORMIN, N, KD, AB, LDAB, X,
+ $ SCALE, CNORM, INFO )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER DIAG, NORMIN, TRANS, UPLO
+ INTEGER INFO, KD, LDAB, N
+ REAL SCALE
+* ..
+* .. Array Arguments ..
+ REAL AB( LDAB, * ), CNORM( * ), X( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SLATBS solves one of the triangular systems
+*
+* A *x = s*b or A'*x = s*b
+*
+* with scaling to prevent overflow, where A is an upper or lower
+* triangular band matrix. Here A' denotes the transpose of A, x and b
+* are n-element vectors, and s is a scaling factor, usually less than
+* or equal to 1, chosen so that the components of x will be less than
+* the overflow threshold. If the unscaled problem will not cause
+* overflow, the Level 2 BLAS routine STBSV is called. If the matrix A
+* is singular (A(j,j) = 0 for some j), then s is set to 0 and a
+* non-trivial solution to A*x = 0 is returned.
+*
+* Arguments
+* =========
+*
+* UPLO (input) CHARACTER*1
+* Specifies whether the matrix A is upper or lower triangular.
+* = 'U': Upper triangular
+* = 'L': Lower triangular
+*
+* TRANS (input) CHARACTER*1
+* Specifies the operation applied to A.
+* = 'N': Solve A * x = s*b (No transpose)
+* = 'T': Solve A'* x = s*b (Transpose)
+* = 'C': Solve A'* x = s*b (Conjugate transpose = Transpose)
+*
+* DIAG (input) CHARACTER*1
+* Specifies whether or not the matrix A is unit triangular.
+* = 'N': Non-unit triangular
+* = 'U': Unit triangular
+*
+* NORMIN (input) CHARACTER*1
+* Specifies whether CNORM has been set or not.
+* = 'Y': CNORM contains the column norms on entry
+* = 'N': CNORM is not set on entry. On exit, the norms will
+* be computed and stored in CNORM.
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* KD (input) INTEGER
+* The number of subdiagonals or superdiagonals in the
+* triangular matrix A. KD >= 0.
+*
+* AB (input) REAL array, dimension (LDAB,N)
+* The upper or lower triangular band matrix A, stored in the
+* first KD+1 rows of the array. The j-th column of A is stored
+* in the j-th column of the array AB as follows:
+* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
+* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).
+*
+* LDAB (input) INTEGER
+* The leading dimension of the array AB. LDAB >= KD+1.
+*
+* X (input/output) REAL array, dimension (N)
+* On entry, the right hand side b of the triangular system.
+* On exit, X is overwritten by the solution vector x.
+*
+* SCALE (output) REAL
+* The scaling factor s for the triangular system
+* A * x = s*b or A'* x = s*b.
+* If SCALE = 0, the matrix A is singular or badly scaled, and
+* the vector x is an exact or approximate solution to A*x = 0.
+*
+* CNORM (input or output) REAL array, dimension (N)
+*
+* If NORMIN = 'Y', CNORM is an input argument and CNORM(j)
+* contains the norm of the off-diagonal part of the j-th column
+* of A. If TRANS = 'N', CNORM(j) must be greater than or equal
+* to the infinity-norm, and if TRANS = 'T' or 'C', CNORM(j)
+* must be greater than or equal to the 1-norm.
+*
+* If NORMIN = 'N', CNORM is an output argument and CNORM(j)
+* returns the 1-norm of the offdiagonal part of the j-th column
+* of A.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -k, the k-th argument had an illegal value
+*
+* Further Details
+* ======= =======
+*
+* A rough bound on x is computed; if that is less than overflow, STBSV
+* is called, otherwise, specific code is used which checks for possible
+* overflow or divide-by-zero at every operation.
+*
+* A columnwise scheme is used for solving A*x = b. The basic algorithm
+* if A is lower triangular is
+*
+* x[1:n] := b[1:n]
+* for j = 1, ..., n
+* x(j) := x(j) / A(j,j)
+* x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j]
+* end
+*
+* Define bounds on the components of x after j iterations of the loop:
+* M(j) = bound on x[1:j]
+* G(j) = bound on x[j+1:n]
+* Initially, let M(0) = 0 and G(0) = max{x(i), i=1,...,n}.
+*
+* Then for iteration j+1 we have
+* M(j+1) <= G(j) / | A(j+1,j+1) |
+* G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] |
+* <= G(j) ( 1 + CNORM(j+1) / | A(j+1,j+1) | )
+*
+* where CNORM(j+1) is greater than or equal to the infinity-norm of
+* column j+1 of A, not counting the diagonal. Hence
+*
+* G(j) <= G(0) product ( 1 + CNORM(i) / | A(i,i) | )
+* 1<=i<=j
+* and
+*
+* |x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + CNORM(i) / |A(i,i)| )
+* 1<=i< j
+*
+* Since |x(j)| <= M(j), we use the Level 2 BLAS routine STBSV if the
+* reciprocal of the largest M(j), j=1,..,n, is larger than
+* max(underflow, 1/overflow).
+*
+* The bound on x(j) is also used to determine when a step in the
+* columnwise method can be performed without fear of overflow. If
+* the computed bound is greater than a large constant, x is scaled to
+* prevent overflow, but if the bound overflows, x is set to 0, x(j) to
+* 1, and scale to 0, and a non-trivial solution to A*x = 0 is found.
+*
+* Similarly, a row-wise scheme is used to solve A'*x = b. The basic
+* algorithm for A upper triangular is
+*
+* for j = 1, ..., n
+* x(j) := ( b(j) - A[1:j-1,j]' * x[1:j-1] ) / A(j,j)
+* end
+*
+* We simultaneously compute two bounds
+* G(j) = bound on ( b(i) - A[1:i-1,i]' * x[1:i-1] ), 1<=i<=j
+* M(j) = bound on x(i), 1<=i<=j
+*
+* The initial values are G(0) = 0, M(0) = max{b(i), i=1,..,n}, and we
+* add the constraint G(j) >= G(j-1) and M(j) >= M(j-1) for j >= 1.
+* Then the bound on x(j) is
+*
+* M(j) <= M(j-1) * ( 1 + CNORM(j) ) / | A(j,j) |
+*
+* <= M(0) * product ( ( 1 + CNORM(i) ) / |A(i,i)| )
+* 1<=i<=j
+*
+* and we can safely call STBSV if 1/M(n) and 1/G(n) are both greater
+* than max(underflow, 1/overflow).
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO, HALF, ONE
+ PARAMETER ( ZERO = 0.0E+0, HALF = 0.5E+0, ONE = 1.0E+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL NOTRAN, NOUNIT, UPPER
+ INTEGER I, IMAX, J, JFIRST, JINC, JLAST, JLEN, MAIND
+ REAL BIGNUM, GROW, REC, SMLNUM, SUMJ, TJJ, TJJS,
+ $ TMAX, TSCAL, USCAL, XBND, XJ, XMAX
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ISAMAX
+ REAL SASUM, SDOT, SLAMCH
+ EXTERNAL LSAME, ISAMAX, SASUM, SDOT, SLAMCH
+* ..
+* .. External Subroutines ..
+ EXTERNAL SAXPY, SSCAL, STBSV, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ NOTRAN = LSAME( TRANS, 'N' )
+ NOUNIT = LSAME( DIAG, 'N' )
+*
+* Test the input parameters.
+*
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT.
+ $ LSAME( TRANS, 'C' ) ) THEN
+ INFO = -2
+ ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
+ INFO = -3
+ ELSE IF( .NOT.LSAME( NORMIN, 'Y' ) .AND. .NOT.
+ $ LSAME( NORMIN, 'N' ) ) THEN
+ INFO = -4
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -5
+ ELSE IF( KD.LT.0 ) THEN
+ INFO = -6
+ ELSE IF( LDAB.LT.KD+1 ) THEN
+ INFO = -8
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SLATBS', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+* Determine machine dependent parameters to control overflow.
+*
+ SMLNUM = SLAMCH( 'Safe minimum' ) / SLAMCH( 'Precision' )
+ BIGNUM = ONE / SMLNUM
+ SCALE = ONE
+*
+ IF( LSAME( NORMIN, 'N' ) ) THEN
+*
+* Compute the 1-norm of each column, not including the diagonal.
+*
+ IF( UPPER ) THEN
+*
+* A is upper triangular.
+*
+ DO 10 J = 1, N
+ JLEN = MIN( KD, J-1 )
+ CNORM( J ) = SASUM( JLEN, AB( KD+1-JLEN, J ), 1 )
+ 10 CONTINUE
+ ELSE
+*
+* A is lower triangular.
+*
+ DO 20 J = 1, N
+ JLEN = MIN( KD, N-J )
+ IF( JLEN.GT.0 ) THEN
+ CNORM( J ) = SASUM( JLEN, AB( 2, J ), 1 )
+ ELSE
+ CNORM( J ) = ZERO
+ END IF
+ 20 CONTINUE
+ END IF
+ END IF
+*
+* Scale the column norms by TSCAL if the maximum element in CNORM is
+* greater than BIGNUM.
+*
+ IMAX = ISAMAX( N, CNORM, 1 )
+ TMAX = CNORM( IMAX )
+ IF( TMAX.LE.BIGNUM ) THEN
+ TSCAL = ONE
+ ELSE
+ TSCAL = ONE / ( SMLNUM*TMAX )
+ CALL SSCAL( N, TSCAL, CNORM, 1 )
+ END IF
+*
+* Compute a bound on the computed solution vector to see if the
+* Level 2 BLAS routine STBSV can be used.
+*
+ J = ISAMAX( N, X, 1 )
+ XMAX = ABS( X( J ) )
+ XBND = XMAX
+ IF( NOTRAN ) THEN
+*
+* Compute the growth in A * x = b.
+*
+ IF( UPPER ) THEN
+ JFIRST = N
+ JLAST = 1
+ JINC = -1
+ MAIND = KD + 1
+ ELSE
+ JFIRST = 1
+ JLAST = N
+ JINC = 1
+ MAIND = 1
+ END IF
+*
+ IF( TSCAL.NE.ONE ) THEN
+ GROW = ZERO
+ GO TO 50
+ END IF
+*
+ IF( NOUNIT ) THEN
+*
+* A is non-unit triangular.
+*
+* Compute GROW = 1/G(j) and XBND = 1/M(j).
+* Initially, G(0) = max{x(i), i=1,...,n}.
+*
+ GROW = ONE / MAX( XBND, SMLNUM )
+ XBND = GROW
+ DO 30 J = JFIRST, JLAST, JINC
+*
+* Exit the loop if the growth factor is too small.
+*
+ IF( GROW.LE.SMLNUM )
+ $ GO TO 50
+*
+* M(j) = G(j-1) / abs(A(j,j))
+*
+ TJJ = ABS( AB( MAIND, J ) )
+ XBND = MIN( XBND, MIN( ONE, TJJ )*GROW )
+ IF( TJJ+CNORM( J ).GE.SMLNUM ) THEN
+*
+* G(j) = G(j-1)*( 1 + CNORM(j) / abs(A(j,j)) )
+*
+ GROW = GROW*( TJJ / ( TJJ+CNORM( J ) ) )
+ ELSE
+*
+* G(j) could overflow, set GROW to 0.
+*
+ GROW = ZERO
+ END IF
+ 30 CONTINUE
+ GROW = XBND
+ ELSE
+*
+* A is unit triangular.
+*
+* Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}.
+*
+ GROW = MIN( ONE, ONE / MAX( XBND, SMLNUM ) )
+ DO 40 J = JFIRST, JLAST, JINC
+*
+* Exit the loop if the growth factor is too small.
+*
+ IF( GROW.LE.SMLNUM )
+ $ GO TO 50
+*
+* G(j) = G(j-1)*( 1 + CNORM(j) )
+*
+ GROW = GROW*( ONE / ( ONE+CNORM( J ) ) )
+ 40 CONTINUE
+ END IF
+ 50 CONTINUE
+*
+ ELSE
+*
+* Compute the growth in A' * x = b.
+*
+ IF( UPPER ) THEN
+ JFIRST = 1
+ JLAST = N
+ JINC = 1
+ MAIND = KD + 1
+ ELSE
+ JFIRST = N
+ JLAST = 1
+ JINC = -1
+ MAIND = 1
+ END IF
+*
+ IF( TSCAL.NE.ONE ) THEN
+ GROW = ZERO
+ GO TO 80
+ END IF
+*
+ IF( NOUNIT ) THEN
+*
+* A is non-unit triangular.
+*
+* Compute GROW = 1/G(j) and XBND = 1/M(j).
+* Initially, M(0) = max{x(i), i=1,...,n}.
+*
+ GROW = ONE / MAX( XBND, SMLNUM )
+ XBND = GROW
+ DO 60 J = JFIRST, JLAST, JINC
+*
+* Exit the loop if the growth factor is too small.
+*
+ IF( GROW.LE.SMLNUM )
+ $ GO TO 80
+*
+* G(j) = max( G(j-1), M(j-1)*( 1 + CNORM(j) ) )
+*
+ XJ = ONE + CNORM( J )
+ GROW = MIN( GROW, XBND / XJ )
+*
+* M(j) = M(j-1)*( 1 + CNORM(j) ) / abs(A(j,j))
+*
+ TJJ = ABS( AB( MAIND, J ) )
+ IF( XJ.GT.TJJ )
+ $ XBND = XBND*( TJJ / XJ )
+ 60 CONTINUE
+ GROW = MIN( GROW, XBND )
+ ELSE
+*
+* A is unit triangular.
+*
+* Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}.
+*
+ GROW = MIN( ONE, ONE / MAX( XBND, SMLNUM ) )
+ DO 70 J = JFIRST, JLAST, JINC
+*
+* Exit the loop if the growth factor is too small.
+*
+ IF( GROW.LE.SMLNUM )
+ $ GO TO 80
+*
+* G(j) = ( 1 + CNORM(j) )*G(j-1)
+*
+ XJ = ONE + CNORM( J )
+ GROW = GROW / XJ
+ 70 CONTINUE
+ END IF
+ 80 CONTINUE
+ END IF
+*
+ IF( ( GROW*TSCAL ).GT.SMLNUM ) THEN
+*
+* Use the Level 2 BLAS solve if the reciprocal of the bound on
+* elements of X is not too small.
+*
+ CALL STBSV( UPLO, TRANS, DIAG, N, KD, AB, LDAB, X, 1 )
+ ELSE
+*
+* Use a Level 1 BLAS solve, scaling intermediate results.
+*
+ IF( XMAX.GT.BIGNUM ) THEN
+*
+* Scale X so that its components are less than or equal to
+* BIGNUM in absolute value.
+*
+ SCALE = BIGNUM / XMAX
+ CALL SSCAL( N, SCALE, X, 1 )
+ XMAX = BIGNUM
+ END IF
+*
+ IF( NOTRAN ) THEN
+*
+* Solve A * x = b
+*
+ DO 100 J = JFIRST, JLAST, JINC
+*
+* Compute x(j) = b(j) / A(j,j), scaling x if necessary.
+*
+ XJ = ABS( X( J ) )
+ IF( NOUNIT ) THEN
+ TJJS = AB( MAIND, J )*TSCAL
+ ELSE
+ TJJS = TSCAL
+ IF( TSCAL.EQ.ONE )
+ $ GO TO 95
+ END IF
+ TJJ = ABS( TJJS )
+ IF( TJJ.GT.SMLNUM ) THEN
+*
+* abs(A(j,j)) > SMLNUM:
+*
+ IF( TJJ.LT.ONE ) THEN
+ IF( XJ.GT.TJJ*BIGNUM ) THEN
+*
+* Scale x by 1/b(j).
+*
+ REC = ONE / XJ
+ CALL SSCAL( N, REC, X, 1 )
+ SCALE = SCALE*REC
+ XMAX = XMAX*REC
+ END IF
+ END IF
+ X( J ) = X( J ) / TJJS
+ XJ = ABS( X( J ) )
+ ELSE IF( TJJ.GT.ZERO ) THEN
+*
+* 0 < abs(A(j,j)) <= SMLNUM:
+*
+ IF( XJ.GT.TJJ*BIGNUM ) THEN
+*
+* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM
+* to avoid overflow when dividing by A(j,j).
+*
+ REC = ( TJJ*BIGNUM ) / XJ
+ IF( CNORM( J ).GT.ONE ) THEN
+*
+* Scale by 1/CNORM(j) to avoid overflow when
+* multiplying x(j) times column j.
+*
+ REC = REC / CNORM( J )
+ END IF
+ CALL SSCAL( N, REC, X, 1 )
+ SCALE = SCALE*REC
+ XMAX = XMAX*REC
+ END IF
+ X( J ) = X( J ) / TJJS
+ XJ = ABS( X( J ) )
+ ELSE
+*
+* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and
+* scale = 0, and compute a solution to A*x = 0.
+*
+ DO 90 I = 1, N
+ X( I ) = ZERO
+ 90 CONTINUE
+ X( J ) = ONE
+ XJ = ONE
+ SCALE = ZERO
+ XMAX = ZERO
+ END IF
+ 95 CONTINUE
+*
+* Scale x if necessary to avoid overflow when adding a
+* multiple of column j of A.
+*
+ IF( XJ.GT.ONE ) THEN
+ REC = ONE / XJ
+ IF( CNORM( J ).GT.( BIGNUM-XMAX )*REC ) THEN
+*
+* Scale x by 1/(2*abs(x(j))).
+*
+ REC = REC*HALF
+ CALL SSCAL( N, REC, X, 1 )
+ SCALE = SCALE*REC
+ END IF
+ ELSE IF( XJ*CNORM( J ).GT.( BIGNUM-XMAX ) ) THEN
+*
+* Scale x by 1/2.
+*
+ CALL SSCAL( N, HALF, X, 1 )
+ SCALE = SCALE*HALF
+ END IF
+*
+ IF( UPPER ) THEN
+ IF( J.GT.1 ) THEN
+*
+* Compute the update
+* x(max(1,j-kd):j-1) := x(max(1,j-kd):j-1) -
+* x(j)* A(max(1,j-kd):j-1,j)
+*
+ JLEN = MIN( KD, J-1 )
+ CALL SAXPY( JLEN, -X( J )*TSCAL,
+ $ AB( KD+1-JLEN, J ), 1, X( J-JLEN ), 1 )
+ I = ISAMAX( J-1, X, 1 )
+ XMAX = ABS( X( I ) )
+ END IF
+ ELSE IF( J.LT.N ) THEN
+*
+* Compute the update
+* x(j+1:min(j+kd,n)) := x(j+1:min(j+kd,n)) -
+* x(j) * A(j+1:min(j+kd,n),j)
+*
+ JLEN = MIN( KD, N-J )
+ IF( JLEN.GT.0 )
+ $ CALL SAXPY( JLEN, -X( J )*TSCAL, AB( 2, J ), 1,
+ $ X( J+1 ), 1 )
+ I = J + ISAMAX( N-J, X( J+1 ), 1 )
+ XMAX = ABS( X( I ) )
+ END IF
+ 100 CONTINUE
+*
+ ELSE
+*
+* Solve A' * x = b
+*
+ DO 140 J = JFIRST, JLAST, JINC
+*
+* Compute x(j) = b(j) - sum A(k,j)*x(k).
+* k<>j
+*
+ XJ = ABS( X( J ) )
+ USCAL = TSCAL
+ REC = ONE / MAX( XMAX, ONE )
+ IF( CNORM( J ).GT.( BIGNUM-XJ )*REC ) THEN
+*
+* If x(j) could overflow, scale x by 1/(2*XMAX).
+*
+ REC = REC*HALF
+ IF( NOUNIT ) THEN
+ TJJS = AB( MAIND, J )*TSCAL
+ ELSE
+ TJJS = TSCAL
+ END IF
+ TJJ = ABS( TJJS )
+ IF( TJJ.GT.ONE ) THEN
+*
+* Divide by A(j,j) when scaling x if A(j,j) > 1.
+*
+ REC = MIN( ONE, REC*TJJ )
+ USCAL = USCAL / TJJS
+ END IF
+ IF( REC.LT.ONE ) THEN
+ CALL SSCAL( N, REC, X, 1 )
+ SCALE = SCALE*REC
+ XMAX = XMAX*REC
+ END IF
+ END IF
+*
+ SUMJ = ZERO
+ IF( USCAL.EQ.ONE ) THEN
+*
+* If the scaling needed for A in the dot product is 1,
+* call SDOT to perform the dot product.
+*
+ IF( UPPER ) THEN
+ JLEN = MIN( KD, J-1 )
+ SUMJ = SDOT( JLEN, AB( KD+1-JLEN, J ), 1,
+ $ X( J-JLEN ), 1 )
+ ELSE
+ JLEN = MIN( KD, N-J )
+ IF( JLEN.GT.0 )
+ $ SUMJ = SDOT( JLEN, AB( 2, J ), 1, X( J+1 ), 1 )
+ END IF
+ ELSE
+*
+* Otherwise, use in-line code for the dot product.
+*
+ IF( UPPER ) THEN
+ JLEN = MIN( KD, J-1 )
+ DO 110 I = 1, JLEN
+ SUMJ = SUMJ + ( AB( KD+I-JLEN, J )*USCAL )*
+ $ X( J-JLEN-1+I )
+ 110 CONTINUE
+ ELSE
+ JLEN = MIN( KD, N-J )
+ DO 120 I = 1, JLEN
+ SUMJ = SUMJ + ( AB( I+1, J )*USCAL )*X( J+I )
+ 120 CONTINUE
+ END IF
+ END IF
+*
+ IF( USCAL.EQ.TSCAL ) THEN
+*
+* Compute x(j) := ( x(j) - sumj ) / A(j,j) if 1/A(j,j)
+* was not used to scale the dotproduct.
+*
+ X( J ) = X( J ) - SUMJ
+ XJ = ABS( X( J ) )
+ IF( NOUNIT ) THEN
+*
+* Compute x(j) = x(j) / A(j,j), scaling if necessary.
+*
+ TJJS = AB( MAIND, J )*TSCAL
+ ELSE
+ TJJS = TSCAL
+ IF( TSCAL.EQ.ONE )
+ $ GO TO 135
+ END IF
+ TJJ = ABS( TJJS )
+ IF( TJJ.GT.SMLNUM ) THEN
+*
+* abs(A(j,j)) > SMLNUM:
+*
+ IF( TJJ.LT.ONE ) THEN
+ IF( XJ.GT.TJJ*BIGNUM ) THEN
+*
+* Scale X by 1/abs(x(j)).
+*
+ REC = ONE / XJ
+ CALL SSCAL( N, REC, X, 1 )
+ SCALE = SCALE*REC
+ XMAX = XMAX*REC
+ END IF
+ END IF
+ X( J ) = X( J ) / TJJS
+ ELSE IF( TJJ.GT.ZERO ) THEN
+*
+* 0 < abs(A(j,j)) <= SMLNUM:
+*
+ IF( XJ.GT.TJJ*BIGNUM ) THEN
+*
+* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM.
+*
+ REC = ( TJJ*BIGNUM ) / XJ
+ CALL SSCAL( N, REC, X, 1 )
+ SCALE = SCALE*REC
+ XMAX = XMAX*REC
+ END IF
+ X( J ) = X( J ) / TJJS
+ ELSE
+*
+* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and
+* scale = 0, and compute a solution to A'*x = 0.
+*
+ DO 130 I = 1, N
+ X( I ) = ZERO
+ 130 CONTINUE
+ X( J ) = ONE
+ SCALE = ZERO
+ XMAX = ZERO
+ END IF
+ 135 CONTINUE
+ ELSE
+*
+* Compute x(j) := x(j) / A(j,j) - sumj if the dot
+* product has already been divided by 1/A(j,j).
+*
+ X( J ) = X( J ) / TJJS - SUMJ
+ END IF
+ XMAX = MAX( XMAX, ABS( X( J ) ) )
+ 140 CONTINUE
+ END IF
+ SCALE = SCALE / TSCAL
+ END IF
+*
+* Scale the column norms by 1/TSCAL for return.
+*
+ IF( TSCAL.NE.ONE ) THEN
+ CALL SSCAL( N, ONE / TSCAL, CNORM, 1 )
+ END IF
+*
+ RETURN
+*
+* End of SLATBS
+*
+ END
+ SUBROUTINE SLATDF( IJOB, N, Z, LDZ, RHS, RDSUM, RDSCAL, IPIV,
+ $ JPIV )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER IJOB, LDZ, N
+ REAL RDSCAL, RDSUM
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * ), JPIV( * )
+ REAL RHS( * ), Z( LDZ, * )
+* ..
+*
+* Purpose
+* =======
+*
+* SLATDF uses the LU factorization of the n-by-n matrix Z computed by
+* SGETC2 and computes a contribution to the reciprocal Dif-estimate
+* by solving Z * x = b for x, and choosing the r.h.s. b such that
+* the norm of x is as large as possible. On entry RHS = b holds the
+* contribution from earlier solved sub-systems, and on return RHS = x.
+*
+* The factorization of Z returned by SGETC2 has the form Z = P*L*U*Q,
+* where P and Q are permutation matrices. L is lower triangular with
+* unit diagonal elements and U is upper triangular.
+*
+* Arguments
+* =========
+*
+* IJOB (input) INTEGER
+* IJOB = 2: First compute an approximative null-vector e
+* of Z using SGECON, e is normalized and solve for
+* Zx = +-e - f with the sign giving the greater value
+* of 2-norm(x). About 5 times as expensive as Default.
+* IJOB .ne. 2: Local look ahead strategy where all entries of
+* the r.h.s. b is choosen as either +1 or -1 (Default).
+*
+* N (input) INTEGER
+* The number of columns of the matrix Z.
+*
+* Z (input) REAL array, dimension (LDZ, N)
+* On entry, the LU part of the factorization of the n-by-n
+* matrix Z computed by SGETC2: Z = P * L * U * Q
+*
+* LDZ (input) INTEGER
+* The leading dimension of the array Z. LDA >= max(1, N).
+*
+* RHS (input/output) REAL array, dimension N.
+* On entry, RHS contains contributions from other subsystems.
+* On exit, RHS contains the solution of the subsystem with
+* entries acoording to the value of IJOB (see above).
+*
+* RDSUM (input/output) REAL
+* On entry, the sum of squares of computed contributions to
+* the Dif-estimate under computation by STGSYL, where the
+* scaling factor RDSCAL (see below) has been factored out.
+* On exit, the corresponding sum of squares updated with the
+* contributions from the current sub-system.
+* If TRANS = 'T' RDSUM is not touched.
+* NOTE: RDSUM only makes sense when STGSY2 is called by STGSYL.
+*
+* RDSCAL (input/output) REAL
+* On entry, scaling factor used to prevent overflow in RDSUM.
+* On exit, RDSCAL is updated w.r.t. the current contributions
+* in RDSUM.
+* If TRANS = 'T', RDSCAL is not touched.
+* NOTE: RDSCAL only makes sense when STGSY2 is called by
+* STGSYL.
+*
+* IPIV (input) INTEGER array, dimension (N).
+* The pivot indices; for 1 <= i <= N, row i of the
+* matrix has been interchanged with row IPIV(i).
+*
+* JPIV (input) INTEGER array, dimension (N).
+* The pivot indices; for 1 <= j <= N, column j of the
+* matrix has been interchanged with column JPIV(j).
+*
+* Further Details
+* ===============
+*
+* Based on contributions by
+* Bo Kagstrom and Peter Poromaa, Department of Computing Science,
+* Umea University, S-901 87 Umea, Sweden.
+*
+* This routine is a further developed implementation of algorithm
+* BSOLVE in [1] using complete pivoting in the LU factorization.
+*
+* [1] Bo Kagstrom and Lars Westin,
+* Generalized Schur Methods with Condition Estimators for
+* Solving the Generalized Sylvester Equation, IEEE Transactions
+* on Automatic Control, Vol. 34, No. 7, July 1989, pp 745-751.
+*
+* [2] Peter Poromaa,
+* On Efficient and Robust Estimators for the Separation
+* between two Regular Matrix Pairs with Applications in
+* Condition Estimation. Report IMINF-95.05, Departement of
+* Computing Science, Umea University, S-901 87 Umea, Sweden, 1995.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ INTEGER MAXDIM
+ PARAMETER ( MAXDIM = 8 )
+ REAL ZERO, ONE
+ PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, INFO, J, K
+ REAL BM, BP, PMONE, SMINU, SPLUS, TEMP
+* ..
+* .. Local Arrays ..
+ INTEGER IWORK( MAXDIM )
+ REAL WORK( 4*MAXDIM ), XM( MAXDIM ), XP( MAXDIM )
+* ..
+* .. External Subroutines ..
+ EXTERNAL SAXPY, SCOPY, SGECON, SGESC2, SLASSQ, SLASWP,
+ $ SSCAL
+* ..
+* .. External Functions ..
+ REAL SASUM, SDOT
+ EXTERNAL SASUM, SDOT
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, SQRT
+* ..
+* .. Executable Statements ..
+*
+ IF( IJOB.NE.2 ) THEN
+*
+* Apply permutations IPIV to RHS
+*
+ CALL SLASWP( 1, RHS, LDZ, 1, N-1, IPIV, 1 )
+*
+* Solve for L-part choosing RHS either to +1 or -1.
+*
+ PMONE = -ONE
+*
+ DO 10 J = 1, N - 1
+ BP = RHS( J ) + ONE
+ BM = RHS( J ) - ONE
+ SPLUS = ONE
+*
+* Look-ahead for L-part RHS(1:N-1) = + or -1, SPLUS and
+* SMIN computed more efficiently than in BSOLVE [1].
+*
+ SPLUS = SPLUS + SDOT( N-J, Z( J+1, J ), 1, Z( J+1, J ), 1 )
+ SMINU = SDOT( N-J, Z( J+1, J ), 1, RHS( J+1 ), 1 )
+ SPLUS = SPLUS*RHS( J )
+ IF( SPLUS.GT.SMINU ) THEN
+ RHS( J ) = BP
+ ELSE IF( SMINU.GT.SPLUS ) THEN
+ RHS( J ) = BM
+ ELSE
+*
+* In this case the updating sums are equal and we can
+* choose RHS(J) +1 or -1. The first time this happens
+* we choose -1, thereafter +1. This is a simple way to
+* get good estimates of matrices like Byers well-known
+* example (see [1]). (Not done in BSOLVE.)
+*
+ RHS( J ) = RHS( J ) + PMONE
+ PMONE = ONE
+ END IF
+*
+* Compute the remaining r.h.s.
+*
+ TEMP = -RHS( J )
+ CALL SAXPY( N-J, TEMP, Z( J+1, J ), 1, RHS( J+1 ), 1 )
+*
+ 10 CONTINUE
+*
+* Solve for U-part, look-ahead for RHS(N) = +-1. This is not done
+* in BSOLVE and will hopefully give us a better estimate because
+* any ill-conditioning of the original matrix is transfered to U
+* and not to L. U(N, N) is an approximation to sigma_min(LU).
+*
+ CALL SCOPY( N-1, RHS, 1, XP, 1 )
+ XP( N ) = RHS( N ) + ONE
+ RHS( N ) = RHS( N ) - ONE
+ SPLUS = ZERO
+ SMINU = ZERO
+ DO 30 I = N, 1, -1
+ TEMP = ONE / Z( I, I )
+ XP( I ) = XP( I )*TEMP
+ RHS( I ) = RHS( I )*TEMP
+ DO 20 K = I + 1, N
+ XP( I ) = XP( I ) - XP( K )*( Z( I, K )*TEMP )
+ RHS( I ) = RHS( I ) - RHS( K )*( Z( I, K )*TEMP )
+ 20 CONTINUE
+ SPLUS = SPLUS + ABS( XP( I ) )
+ SMINU = SMINU + ABS( RHS( I ) )
+ 30 CONTINUE
+ IF( SPLUS.GT.SMINU )
+ $ CALL SCOPY( N, XP, 1, RHS, 1 )
+*
+* Apply the permutations JPIV to the computed solution (RHS)
+*
+ CALL SLASWP( 1, RHS, LDZ, 1, N-1, JPIV, -1 )
+*
+* Compute the sum of squares
+*
+ CALL SLASSQ( N, RHS, 1, RDSCAL, RDSUM )
+*
+ ELSE
+*
+* IJOB = 2, Compute approximate nullvector XM of Z
+*
+ CALL SGECON( 'I', N, Z, LDZ, ONE, TEMP, WORK, IWORK, INFO )
+ CALL SCOPY( N, WORK( N+1 ), 1, XM, 1 )
+*
+* Compute RHS
+*
+ CALL SLASWP( 1, XM, LDZ, 1, N-1, IPIV, -1 )
+ TEMP = ONE / SQRT( SDOT( N, XM, 1, XM, 1 ) )
+ CALL SSCAL( N, TEMP, XM, 1 )
+ CALL SCOPY( N, XM, 1, XP, 1 )
+ CALL SAXPY( N, ONE, RHS, 1, XP, 1 )
+ CALL SAXPY( N, -ONE, XM, 1, RHS, 1 )
+ CALL SGESC2( N, Z, LDZ, RHS, IPIV, JPIV, TEMP )
+ CALL SGESC2( N, Z, LDZ, XP, IPIV, JPIV, TEMP )
+ IF( SASUM( N, XP, 1 ).GT.SASUM( N, RHS, 1 ) )
+ $ CALL SCOPY( N, XP, 1, RHS, 1 )
+*
+* Compute the sum of squares
+*
+ CALL SLASSQ( N, RHS, 1, RDSCAL, RDSUM )
+*
+ END IF
+*
+ RETURN
+*
+* End of SLATDF
+*
+ END
+ SUBROUTINE SLATPS( UPLO, TRANS, DIAG, NORMIN, N, AP, X, SCALE,
+ $ CNORM, INFO )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER DIAG, NORMIN, TRANS, UPLO
+ INTEGER INFO, N
+ REAL SCALE
+* ..
+* .. Array Arguments ..
+ REAL AP( * ), CNORM( * ), X( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SLATPS solves one of the triangular systems
+*
+* A *x = s*b or A'*x = s*b
+*
+* with scaling to prevent overflow, where A is an upper or lower
+* triangular matrix stored in packed form. Here A' denotes the
+* transpose of A, x and b are n-element vectors, and s is a scaling
+* factor, usually less than or equal to 1, chosen so that the
+* components of x will be less than the overflow threshold. If the
+* unscaled problem will not cause overflow, the Level 2 BLAS routine
+* STPSV is called. If the matrix A is singular (A(j,j) = 0 for some j),
+* then s is set to 0 and a non-trivial solution to A*x = 0 is returned.
+*
+* Arguments
+* =========
+*
+* UPLO (input) CHARACTER*1
+* Specifies whether the matrix A is upper or lower triangular.
+* = 'U': Upper triangular
+* = 'L': Lower triangular
+*
+* TRANS (input) CHARACTER*1
+* Specifies the operation applied to A.
+* = 'N': Solve A * x = s*b (No transpose)
+* = 'T': Solve A'* x = s*b (Transpose)
+* = 'C': Solve A'* x = s*b (Conjugate transpose = Transpose)
+*
+* DIAG (input) CHARACTER*1
+* Specifies whether or not the matrix A is unit triangular.
+* = 'N': Non-unit triangular
+* = 'U': Unit triangular
+*
+* NORMIN (input) CHARACTER*1
+* Specifies whether CNORM has been set or not.
+* = 'Y': CNORM contains the column norms on entry
+* = 'N': CNORM is not set on entry. On exit, the norms will
+* be computed and stored in CNORM.
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* AP (input) REAL array, dimension (N*(N+1)/2)
+* The upper or lower triangular matrix A, packed columnwise in
+* a linear array. The j-th column of A is stored in the array
+* AP as follows:
+* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
+* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
+*
+* X (input/output) REAL array, dimension (N)
+* On entry, the right hand side b of the triangular system.
+* On exit, X is overwritten by the solution vector x.
+*
+* SCALE (output) REAL
+* The scaling factor s for the triangular system
+* A * x = s*b or A'* x = s*b.
+* If SCALE = 0, the matrix A is singular or badly scaled, and
+* the vector x is an exact or approximate solution to A*x = 0.
+*
+* CNORM (input or output) REAL array, dimension (N)
+*
+* If NORMIN = 'Y', CNORM is an input argument and CNORM(j)
+* contains the norm of the off-diagonal part of the j-th column
+* of A. If TRANS = 'N', CNORM(j) must be greater than or equal
+* to the infinity-norm, and if TRANS = 'T' or 'C', CNORM(j)
+* must be greater than or equal to the 1-norm.
+*
+* If NORMIN = 'N', CNORM is an output argument and CNORM(j)
+* returns the 1-norm of the offdiagonal part of the j-th column
+* of A.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -k, the k-th argument had an illegal value
+*
+* Further Details
+* ======= =======
+*
+* A rough bound on x is computed; if that is less than overflow, STPSV
+* is called, otherwise, specific code is used which checks for possible
+* overflow or divide-by-zero at every operation.
+*
+* A columnwise scheme is used for solving A*x = b. The basic algorithm
+* if A is lower triangular is
+*
+* x[1:n] := b[1:n]
+* for j = 1, ..., n
+* x(j) := x(j) / A(j,j)
+* x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j]
+* end
+*
+* Define bounds on the components of x after j iterations of the loop:
+* M(j) = bound on x[1:j]
+* G(j) = bound on x[j+1:n]
+* Initially, let M(0) = 0 and G(0) = max{x(i), i=1,...,n}.
+*
+* Then for iteration j+1 we have
+* M(j+1) <= G(j) / | A(j+1,j+1) |
+* G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] |
+* <= G(j) ( 1 + CNORM(j+1) / | A(j+1,j+1) | )
+*
+* where CNORM(j+1) is greater than or equal to the infinity-norm of
+* column j+1 of A, not counting the diagonal. Hence
+*
+* G(j) <= G(0) product ( 1 + CNORM(i) / | A(i,i) | )
+* 1<=i<=j
+* and
+*
+* |x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + CNORM(i) / |A(i,i)| )
+* 1<=i< j
+*
+* Since |x(j)| <= M(j), we use the Level 2 BLAS routine STPSV if the
+* reciprocal of the largest M(j), j=1,..,n, is larger than
+* max(underflow, 1/overflow).
+*
+* The bound on x(j) is also used to determine when a step in the
+* columnwise method can be performed without fear of overflow. If
+* the computed bound is greater than a large constant, x is scaled to
+* prevent overflow, but if the bound overflows, x is set to 0, x(j) to
+* 1, and scale to 0, and a non-trivial solution to A*x = 0 is found.
+*
+* Similarly, a row-wise scheme is used to solve A'*x = b. The basic
+* algorithm for A upper triangular is
+*
+* for j = 1, ..., n
+* x(j) := ( b(j) - A[1:j-1,j]' * x[1:j-1] ) / A(j,j)
+* end
+*
+* We simultaneously compute two bounds
+* G(j) = bound on ( b(i) - A[1:i-1,i]' * x[1:i-1] ), 1<=i<=j
+* M(j) = bound on x(i), 1<=i<=j
+*
+* The initial values are G(0) = 0, M(0) = max{b(i), i=1,..,n}, and we
+* add the constraint G(j) >= G(j-1) and M(j) >= M(j-1) for j >= 1.
+* Then the bound on x(j) is
+*
+* M(j) <= M(j-1) * ( 1 + CNORM(j) ) / | A(j,j) |
+*
+* <= M(0) * product ( ( 1 + CNORM(i) ) / |A(i,i)| )
+* 1<=i<=j
+*
+* and we can safely call STPSV if 1/M(n) and 1/G(n) are both greater
+* than max(underflow, 1/overflow).
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO, HALF, ONE
+ PARAMETER ( ZERO = 0.0E+0, HALF = 0.5E+0, ONE = 1.0E+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL NOTRAN, NOUNIT, UPPER
+ INTEGER I, IMAX, IP, J, JFIRST, JINC, JLAST, JLEN
+ REAL BIGNUM, GROW, REC, SMLNUM, SUMJ, TJJ, TJJS,
+ $ TMAX, TSCAL, USCAL, XBND, XJ, XMAX
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ISAMAX
+ REAL SASUM, SDOT, SLAMCH
+ EXTERNAL LSAME, ISAMAX, SASUM, SDOT, SLAMCH
+* ..
+* .. External Subroutines ..
+ EXTERNAL SAXPY, SSCAL, STPSV, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ NOTRAN = LSAME( TRANS, 'N' )
+ NOUNIT = LSAME( DIAG, 'N' )
+*
+* Test the input parameters.
+*
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT.
+ $ LSAME( TRANS, 'C' ) ) THEN
+ INFO = -2
+ ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
+ INFO = -3
+ ELSE IF( .NOT.LSAME( NORMIN, 'Y' ) .AND. .NOT.
+ $ LSAME( NORMIN, 'N' ) ) THEN
+ INFO = -4
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -5
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SLATPS', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+* Determine machine dependent parameters to control overflow.
+*
+ SMLNUM = SLAMCH( 'Safe minimum' ) / SLAMCH( 'Precision' )
+ BIGNUM = ONE / SMLNUM
+ SCALE = ONE
+*
+ IF( LSAME( NORMIN, 'N' ) ) THEN
+*
+* Compute the 1-norm of each column, not including the diagonal.
+*
+ IF( UPPER ) THEN
+*
+* A is upper triangular.
+*
+ IP = 1
+ DO 10 J = 1, N
+ CNORM( J ) = SASUM( J-1, AP( IP ), 1 )
+ IP = IP + J
+ 10 CONTINUE
+ ELSE
+*
+* A is lower triangular.
+*
+ IP = 1
+ DO 20 J = 1, N - 1
+ CNORM( J ) = SASUM( N-J, AP( IP+1 ), 1 )
+ IP = IP + N - J + 1
+ 20 CONTINUE
+ CNORM( N ) = ZERO
+ END IF
+ END IF
+*
+* Scale the column norms by TSCAL if the maximum element in CNORM is
+* greater than BIGNUM.
+*
+ IMAX = ISAMAX( N, CNORM, 1 )
+ TMAX = CNORM( IMAX )
+ IF( TMAX.LE.BIGNUM ) THEN
+ TSCAL = ONE
+ ELSE
+ TSCAL = ONE / ( SMLNUM*TMAX )
+ CALL SSCAL( N, TSCAL, CNORM, 1 )
+ END IF
+*
+* Compute a bound on the computed solution vector to see if the
+* Level 2 BLAS routine STPSV can be used.
+*
+ J = ISAMAX( N, X, 1 )
+ XMAX = ABS( X( J ) )
+ XBND = XMAX
+ IF( NOTRAN ) THEN
+*
+* Compute the growth in A * x = b.
+*
+ IF( UPPER ) THEN
+ JFIRST = N
+ JLAST = 1
+ JINC = -1
+ ELSE
+ JFIRST = 1
+ JLAST = N
+ JINC = 1
+ END IF
+*
+ IF( TSCAL.NE.ONE ) THEN
+ GROW = ZERO
+ GO TO 50
+ END IF
+*
+ IF( NOUNIT ) THEN
+*
+* A is non-unit triangular.
+*
+* Compute GROW = 1/G(j) and XBND = 1/M(j).
+* Initially, G(0) = max{x(i), i=1,...,n}.
+*
+ GROW = ONE / MAX( XBND, SMLNUM )
+ XBND = GROW
+ IP = JFIRST*( JFIRST+1 ) / 2
+ JLEN = N
+ DO 30 J = JFIRST, JLAST, JINC
+*
+* Exit the loop if the growth factor is too small.
+*
+ IF( GROW.LE.SMLNUM )
+ $ GO TO 50
+*
+* M(j) = G(j-1) / abs(A(j,j))
+*
+ TJJ = ABS( AP( IP ) )
+ XBND = MIN( XBND, MIN( ONE, TJJ )*GROW )
+ IF( TJJ+CNORM( J ).GE.SMLNUM ) THEN
+*
+* G(j) = G(j-1)*( 1 + CNORM(j) / abs(A(j,j)) )
+*
+ GROW = GROW*( TJJ / ( TJJ+CNORM( J ) ) )
+ ELSE
+*
+* G(j) could overflow, set GROW to 0.
+*
+ GROW = ZERO
+ END IF
+ IP = IP + JINC*JLEN
+ JLEN = JLEN - 1
+ 30 CONTINUE
+ GROW = XBND
+ ELSE
+*
+* A is unit triangular.
+*
+* Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}.
+*
+ GROW = MIN( ONE, ONE / MAX( XBND, SMLNUM ) )
+ DO 40 J = JFIRST, JLAST, JINC
+*
+* Exit the loop if the growth factor is too small.
+*
+ IF( GROW.LE.SMLNUM )
+ $ GO TO 50
+*
+* G(j) = G(j-1)*( 1 + CNORM(j) )
+*
+ GROW = GROW*( ONE / ( ONE+CNORM( J ) ) )
+ 40 CONTINUE
+ END IF
+ 50 CONTINUE
+*
+ ELSE
+*
+* Compute the growth in A' * x = b.
+*
+ IF( UPPER ) THEN
+ JFIRST = 1
+ JLAST = N
+ JINC = 1
+ ELSE
+ JFIRST = N
+ JLAST = 1
+ JINC = -1
+ END IF
+*
+ IF( TSCAL.NE.ONE ) THEN
+ GROW = ZERO
+ GO TO 80
+ END IF
+*
+ IF( NOUNIT ) THEN
+*
+* A is non-unit triangular.
+*
+* Compute GROW = 1/G(j) and XBND = 1/M(j).
+* Initially, M(0) = max{x(i), i=1,...,n}.
+*
+ GROW = ONE / MAX( XBND, SMLNUM )
+ XBND = GROW
+ IP = JFIRST*( JFIRST+1 ) / 2
+ JLEN = 1
+ DO 60 J = JFIRST, JLAST, JINC
+*
+* Exit the loop if the growth factor is too small.
+*
+ IF( GROW.LE.SMLNUM )
+ $ GO TO 80
+*
+* G(j) = max( G(j-1), M(j-1)*( 1 + CNORM(j) ) )
+*
+ XJ = ONE + CNORM( J )
+ GROW = MIN( GROW, XBND / XJ )
+*
+* M(j) = M(j-1)*( 1 + CNORM(j) ) / abs(A(j,j))
+*
+ TJJ = ABS( AP( IP ) )
+ IF( XJ.GT.TJJ )
+ $ XBND = XBND*( TJJ / XJ )
+ JLEN = JLEN + 1
+ IP = IP + JINC*JLEN
+ 60 CONTINUE
+ GROW = MIN( GROW, XBND )
+ ELSE
+*
+* A is unit triangular.
+*
+* Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}.
+*
+ GROW = MIN( ONE, ONE / MAX( XBND, SMLNUM ) )
+ DO 70 J = JFIRST, JLAST, JINC
+*
+* Exit the loop if the growth factor is too small.
+*
+ IF( GROW.LE.SMLNUM )
+ $ GO TO 80
+*
+* G(j) = ( 1 + CNORM(j) )*G(j-1)
+*
+ XJ = ONE + CNORM( J )
+ GROW = GROW / XJ
+ 70 CONTINUE
+ END IF
+ 80 CONTINUE
+ END IF
+*
+ IF( ( GROW*TSCAL ).GT.SMLNUM ) THEN
+*
+* Use the Level 2 BLAS solve if the reciprocal of the bound on
+* elements of X is not too small.
+*
+ CALL STPSV( UPLO, TRANS, DIAG, N, AP, X, 1 )
+ ELSE
+*
+* Use a Level 1 BLAS solve, scaling intermediate results.
+*
+ IF( XMAX.GT.BIGNUM ) THEN
+*
+* Scale X so that its components are less than or equal to
+* BIGNUM in absolute value.
+*
+ SCALE = BIGNUM / XMAX
+ CALL SSCAL( N, SCALE, X, 1 )
+ XMAX = BIGNUM
+ END IF
+*
+ IF( NOTRAN ) THEN
+*
+* Solve A * x = b
+*
+ IP = JFIRST*( JFIRST+1 ) / 2
+ DO 100 J = JFIRST, JLAST, JINC
+*
+* Compute x(j) = b(j) / A(j,j), scaling x if necessary.
+*
+ XJ = ABS( X( J ) )
+ IF( NOUNIT ) THEN
+ TJJS = AP( IP )*TSCAL
+ ELSE
+ TJJS = TSCAL
+ IF( TSCAL.EQ.ONE )
+ $ GO TO 95
+ END IF
+ TJJ = ABS( TJJS )
+ IF( TJJ.GT.SMLNUM ) THEN
+*
+* abs(A(j,j)) > SMLNUM:
+*
+ IF( TJJ.LT.ONE ) THEN
+ IF( XJ.GT.TJJ*BIGNUM ) THEN
+*
+* Scale x by 1/b(j).
+*
+ REC = ONE / XJ
+ CALL SSCAL( N, REC, X, 1 )
+ SCALE = SCALE*REC
+ XMAX = XMAX*REC
+ END IF
+ END IF
+ X( J ) = X( J ) / TJJS
+ XJ = ABS( X( J ) )
+ ELSE IF( TJJ.GT.ZERO ) THEN
+*
+* 0 < abs(A(j,j)) <= SMLNUM:
+*
+ IF( XJ.GT.TJJ*BIGNUM ) THEN
+*
+* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM
+* to avoid overflow when dividing by A(j,j).
+*
+ REC = ( TJJ*BIGNUM ) / XJ
+ IF( CNORM( J ).GT.ONE ) THEN
+*
+* Scale by 1/CNORM(j) to avoid overflow when
+* multiplying x(j) times column j.
+*
+ REC = REC / CNORM( J )
+ END IF
+ CALL SSCAL( N, REC, X, 1 )
+ SCALE = SCALE*REC
+ XMAX = XMAX*REC
+ END IF
+ X( J ) = X( J ) / TJJS
+ XJ = ABS( X( J ) )
+ ELSE
+*
+* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and
+* scale = 0, and compute a solution to A*x = 0.
+*
+ DO 90 I = 1, N
+ X( I ) = ZERO
+ 90 CONTINUE
+ X( J ) = ONE
+ XJ = ONE
+ SCALE = ZERO
+ XMAX = ZERO
+ END IF
+ 95 CONTINUE
+*
+* Scale x if necessary to avoid overflow when adding a
+* multiple of column j of A.
+*
+ IF( XJ.GT.ONE ) THEN
+ REC = ONE / XJ
+ IF( CNORM( J ).GT.( BIGNUM-XMAX )*REC ) THEN
+*
+* Scale x by 1/(2*abs(x(j))).
+*
+ REC = REC*HALF
+ CALL SSCAL( N, REC, X, 1 )
+ SCALE = SCALE*REC
+ END IF
+ ELSE IF( XJ*CNORM( J ).GT.( BIGNUM-XMAX ) ) THEN
+*
+* Scale x by 1/2.
+*
+ CALL SSCAL( N, HALF, X, 1 )
+ SCALE = SCALE*HALF
+ END IF
+*
+ IF( UPPER ) THEN
+ IF( J.GT.1 ) THEN
+*
+* Compute the update
+* x(1:j-1) := x(1:j-1) - x(j) * A(1:j-1,j)
+*
+ CALL SAXPY( J-1, -X( J )*TSCAL, AP( IP-J+1 ), 1, X,
+ $ 1 )
+ I = ISAMAX( J-1, X, 1 )
+ XMAX = ABS( X( I ) )
+ END IF
+ IP = IP - J
+ ELSE
+ IF( J.LT.N ) THEN
+*
+* Compute the update
+* x(j+1:n) := x(j+1:n) - x(j) * A(j+1:n,j)
+*
+ CALL SAXPY( N-J, -X( J )*TSCAL, AP( IP+1 ), 1,
+ $ X( J+1 ), 1 )
+ I = J + ISAMAX( N-J, X( J+1 ), 1 )
+ XMAX = ABS( X( I ) )
+ END IF
+ IP = IP + N - J + 1
+ END IF
+ 100 CONTINUE
+*
+ ELSE
+*
+* Solve A' * x = b
+*
+ IP = JFIRST*( JFIRST+1 ) / 2
+ JLEN = 1
+ DO 140 J = JFIRST, JLAST, JINC
+*
+* Compute x(j) = b(j) - sum A(k,j)*x(k).
+* k<>j
+*
+ XJ = ABS( X( J ) )
+ USCAL = TSCAL
+ REC = ONE / MAX( XMAX, ONE )
+ IF( CNORM( J ).GT.( BIGNUM-XJ )*REC ) THEN
+*
+* If x(j) could overflow, scale x by 1/(2*XMAX).
+*
+ REC = REC*HALF
+ IF( NOUNIT ) THEN
+ TJJS = AP( IP )*TSCAL
+ ELSE
+ TJJS = TSCAL
+ END IF
+ TJJ = ABS( TJJS )
+ IF( TJJ.GT.ONE ) THEN
+*
+* Divide by A(j,j) when scaling x if A(j,j) > 1.
+*
+ REC = MIN( ONE, REC*TJJ )
+ USCAL = USCAL / TJJS
+ END IF
+ IF( REC.LT.ONE ) THEN
+ CALL SSCAL( N, REC, X, 1 )
+ SCALE = SCALE*REC
+ XMAX = XMAX*REC
+ END IF
+ END IF
+*
+ SUMJ = ZERO
+ IF( USCAL.EQ.ONE ) THEN
+*
+* If the scaling needed for A in the dot product is 1,
+* call SDOT to perform the dot product.
+*
+ IF( UPPER ) THEN
+ SUMJ = SDOT( J-1, AP( IP-J+1 ), 1, X, 1 )
+ ELSE IF( J.LT.N ) THEN
+ SUMJ = SDOT( N-J, AP( IP+1 ), 1, X( J+1 ), 1 )
+ END IF
+ ELSE
+*
+* Otherwise, use in-line code for the dot product.
+*
+ IF( UPPER ) THEN
+ DO 110 I = 1, J - 1
+ SUMJ = SUMJ + ( AP( IP-J+I )*USCAL )*X( I )
+ 110 CONTINUE
+ ELSE IF( J.LT.N ) THEN
+ DO 120 I = 1, N - J
+ SUMJ = SUMJ + ( AP( IP+I )*USCAL )*X( J+I )
+ 120 CONTINUE
+ END IF
+ END IF
+*
+ IF( USCAL.EQ.TSCAL ) THEN
+*
+* Compute x(j) := ( x(j) - sumj ) / A(j,j) if 1/A(j,j)
+* was not used to scale the dotproduct.
+*
+ X( J ) = X( J ) - SUMJ
+ XJ = ABS( X( J ) )
+ IF( NOUNIT ) THEN
+*
+* Compute x(j) = x(j) / A(j,j), scaling if necessary.
+*
+ TJJS = AP( IP )*TSCAL
+ ELSE
+ TJJS = TSCAL
+ IF( TSCAL.EQ.ONE )
+ $ GO TO 135
+ END IF
+ TJJ = ABS( TJJS )
+ IF( TJJ.GT.SMLNUM ) THEN
+*
+* abs(A(j,j)) > SMLNUM:
+*
+ IF( TJJ.LT.ONE ) THEN
+ IF( XJ.GT.TJJ*BIGNUM ) THEN
+*
+* Scale X by 1/abs(x(j)).
+*
+ REC = ONE / XJ
+ CALL SSCAL( N, REC, X, 1 )
+ SCALE = SCALE*REC
+ XMAX = XMAX*REC
+ END IF
+ END IF
+ X( J ) = X( J ) / TJJS
+ ELSE IF( TJJ.GT.ZERO ) THEN
+*
+* 0 < abs(A(j,j)) <= SMLNUM:
+*
+ IF( XJ.GT.TJJ*BIGNUM ) THEN
+*
+* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM.
+*
+ REC = ( TJJ*BIGNUM ) / XJ
+ CALL SSCAL( N, REC, X, 1 )
+ SCALE = SCALE*REC
+ XMAX = XMAX*REC
+ END IF
+ X( J ) = X( J ) / TJJS
+ ELSE
+*
+* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and
+* scale = 0, and compute a solution to A'*x = 0.
+*
+ DO 130 I = 1, N
+ X( I ) = ZERO
+ 130 CONTINUE
+ X( J ) = ONE
+ SCALE = ZERO
+ XMAX = ZERO
+ END IF
+ 135 CONTINUE
+ ELSE
+*
+* Compute x(j) := x(j) / A(j,j) - sumj if the dot
+* product has already been divided by 1/A(j,j).
+*
+ X( J ) = X( J ) / TJJS - SUMJ
+ END IF
+ XMAX = MAX( XMAX, ABS( X( J ) ) )
+ JLEN = JLEN + 1
+ IP = IP + JINC*JLEN
+ 140 CONTINUE
+ END IF
+ SCALE = SCALE / TSCAL
+ END IF
+*
+* Scale the column norms by 1/TSCAL for return.
+*
+ IF( TSCAL.NE.ONE ) THEN
+ CALL SSCAL( N, ONE / TSCAL, CNORM, 1 )
+ END IF
+*
+ RETURN
+*
+* End of SLATPS
+*
+ END
+ SUBROUTINE SLATRD( UPLO, N, NB, A, LDA, E, TAU, W, LDW )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER LDA, LDW, N, NB
+* ..
+* .. Array Arguments ..
+ REAL A( LDA, * ), E( * ), TAU( * ), W( LDW, * )
+* ..
+*
+* Purpose
+* =======
+*
+* SLATRD reduces NB rows and columns of a real symmetric matrix A to
+* symmetric tridiagonal form by an orthogonal similarity
+* transformation Q' * A * Q, and returns the matrices V and W which are
+* needed to apply the transformation to the unreduced part of A.
+*
+* If UPLO = 'U', SLATRD reduces the last NB rows and columns of a
+* matrix, of which the upper triangle is supplied;
+* if UPLO = 'L', SLATRD reduces the first NB rows and columns of a
+* matrix, of which the lower triangle is supplied.
+*
+* This is an auxiliary routine called by SSYTRD.
+*
+* Arguments
+* =========
+*
+* UPLO (input) CHARACTER*1
+* Specifies whether the upper or lower triangular part of the
+* symmetric matrix A is stored:
+* = 'U': Upper triangular
+* = 'L': Lower triangular
+*
+* N (input) INTEGER
+* The order of the matrix A.
+*
+* NB (input) INTEGER
+* The number of rows and columns to be reduced.
+*
+* A (input/output) REAL array, dimension (LDA,N)
+* On entry, the symmetric matrix A. If UPLO = 'U', the leading
+* n-by-n upper triangular part of A contains the upper
+* triangular part of the matrix A, and the strictly lower
+* triangular part of A is not referenced. If UPLO = 'L', the
+* leading n-by-n lower triangular part of A contains the lower
+* triangular part of the matrix A, and the strictly upper
+* triangular part of A is not referenced.
+* On exit:
+* if UPLO = 'U', the last NB columns have been reduced to
+* tridiagonal form, with the diagonal elements overwriting
+* the diagonal elements of A; the elements above the diagonal
+* with the array TAU, represent the orthogonal matrix Q as a
+* product of elementary reflectors;
+* if UPLO = 'L', the first NB columns have been reduced to
+* tridiagonal form, with the diagonal elements overwriting
+* the diagonal elements of A; the elements below the diagonal
+* with the array TAU, represent the orthogonal matrix Q as a
+* product of elementary reflectors.
+* See Further Details.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= (1,N).
+*
+* E (output) REAL array, dimension (N-1)
+* If UPLO = 'U', E(n-nb:n-1) contains the superdiagonal
+* elements of the last NB columns of the reduced matrix;
+* if UPLO = 'L', E(1:nb) contains the subdiagonal elements of
+* the first NB columns of the reduced matrix.
+*
+* TAU (output) REAL array, dimension (N-1)
+* The scalar factors of the elementary reflectors, stored in
+* TAU(n-nb:n-1) if UPLO = 'U', and in TAU(1:nb) if UPLO = 'L'.
+* See Further Details.
+*
+* W (output) REAL array, dimension (LDW,NB)
+* The n-by-nb matrix W required to update the unreduced part
+* of A.
+*
+* LDW (input) INTEGER
+* The leading dimension of the array W. LDW >= max(1,N).
+*
+* Further Details
+* ===============
+*
+* If UPLO = 'U', the matrix Q is represented as a product of elementary
+* reflectors
+*
+* Q = H(n) H(n-1) . . . H(n-nb+1).
+*
+* Each H(i) has the form
+*
+* H(i) = I - tau * v * v'
+*
+* where tau is a real scalar, and v is a real vector with
+* v(i:n) = 0 and v(i-1) = 1; v(1:i-1) is stored on exit in A(1:i-1,i),
+* and tau in TAU(i-1).
+*
+* If UPLO = 'L', the matrix Q is represented as a product of elementary
+* reflectors
+*
+* Q = H(1) H(2) . . . H(nb).
+*
+* Each H(i) has the form
+*
+* H(i) = I - tau * v * v'
+*
+* where tau is a real scalar, and v is a real vector with
+* v(1:i) = 0 and v(i+1) = 1; v(i+1:n) is stored on exit in A(i+1:n,i),
+* and tau in TAU(i).
+*
+* The elements of the vectors v together form the n-by-nb matrix V
+* which is needed, with W, to apply the transformation to the unreduced
+* part of the matrix, using a symmetric rank-2k update of the form:
+* A := A - V*W' - W*V'.
+*
+* The contents of A on exit are illustrated by the following examples
+* with n = 5 and nb = 2:
+*
+* if UPLO = 'U': if UPLO = 'L':
+*
+* ( a a a v4 v5 ) ( d )
+* ( a a v4 v5 ) ( 1 d )
+* ( a 1 v5 ) ( v1 1 a )
+* ( d 1 ) ( v1 v2 a a )
+* ( d ) ( v1 v2 a a a )
+*
+* where d denotes a diagonal element of the reduced matrix, a denotes
+* an element of the original matrix that is unchanged, and vi denotes
+* an element of the vector defining H(i).
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO, ONE, HALF
+ PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0, HALF = 0.5E+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, IW
+ REAL ALPHA
+* ..
+* .. External Subroutines ..
+ EXTERNAL SAXPY, SGEMV, SLARFG, SSCAL, SSYMV
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ REAL SDOT
+ EXTERNAL LSAME, SDOT
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MIN
+* ..
+* .. Executable Statements ..
+*
+* Quick return if possible
+*
+ IF( N.LE.0 )
+ $ RETURN
+*
+ IF( LSAME( UPLO, 'U' ) ) THEN
+*
+* Reduce last NB columns of upper triangle
+*
+ DO 10 I = N, N - NB + 1, -1
+ IW = I - N + NB
+ IF( I.LT.N ) THEN
+*
+* Update A(1:i,i)
+*
+ CALL SGEMV( 'No transpose', I, N-I, -ONE, A( 1, I+1 ),
+ $ LDA, W( I, IW+1 ), LDW, ONE, A( 1, I ), 1 )
+ CALL SGEMV( 'No transpose', I, N-I, -ONE, W( 1, IW+1 ),
+ $ LDW, A( I, I+1 ), LDA, ONE, A( 1, I ), 1 )
+ END IF
+ IF( I.GT.1 ) THEN
+*
+* Generate elementary reflector H(i) to annihilate
+* A(1:i-2,i)
+*
+ CALL SLARFG( I-1, A( I-1, I ), A( 1, I ), 1, TAU( I-1 ) )
+ E( I-1 ) = A( I-1, I )
+ A( I-1, I ) = ONE
+*
+* Compute W(1:i-1,i)
+*
+ CALL SSYMV( 'Upper', I-1, ONE, A, LDA, A( 1, I ), 1,
+ $ ZERO, W( 1, IW ), 1 )
+ IF( I.LT.N ) THEN
+ CALL SGEMV( 'Transpose', I-1, N-I, ONE, W( 1, IW+1 ),
+ $ LDW, A( 1, I ), 1, ZERO, W( I+1, IW ), 1 )
+ CALL SGEMV( 'No transpose', I-1, N-I, -ONE,
+ $ A( 1, I+1 ), LDA, W( I+1, IW ), 1, ONE,
+ $ W( 1, IW ), 1 )
+ CALL SGEMV( 'Transpose', I-1, N-I, ONE, A( 1, I+1 ),
+ $ LDA, A( 1, I ), 1, ZERO, W( I+1, IW ), 1 )
+ CALL SGEMV( 'No transpose', I-1, N-I, -ONE,
+ $ W( 1, IW+1 ), LDW, W( I+1, IW ), 1, ONE,
+ $ W( 1, IW ), 1 )
+ END IF
+ CALL SSCAL( I-1, TAU( I-1 ), W( 1, IW ), 1 )
+ ALPHA = -HALF*TAU( I-1 )*SDOT( I-1, W( 1, IW ), 1,
+ $ A( 1, I ), 1 )
+ CALL SAXPY( I-1, ALPHA, A( 1, I ), 1, W( 1, IW ), 1 )
+ END IF
+*
+ 10 CONTINUE
+ ELSE
+*
+* Reduce first NB columns of lower triangle
+*
+ DO 20 I = 1, NB
+*
+* Update A(i:n,i)
+*
+ CALL SGEMV( 'No transpose', N-I+1, I-1, -ONE, A( I, 1 ),
+ $ LDA, W( I, 1 ), LDW, ONE, A( I, I ), 1 )
+ CALL SGEMV( 'No transpose', N-I+1, I-1, -ONE, W( I, 1 ),
+ $ LDW, A( I, 1 ), LDA, ONE, A( I, I ), 1 )
+ IF( I.LT.N ) THEN
+*
+* Generate elementary reflector H(i) to annihilate
+* A(i+2:n,i)
+*
+ CALL SLARFG( N-I, A( I+1, I ), A( MIN( I+2, N ), I ), 1,
+ $ TAU( I ) )
+ E( I ) = A( I+1, I )
+ A( I+1, I ) = ONE
+*
+* Compute W(i+1:n,i)
+*
+ CALL SSYMV( 'Lower', N-I, ONE, A( I+1, I+1 ), LDA,
+ $ A( I+1, I ), 1, ZERO, W( I+1, I ), 1 )
+ CALL SGEMV( 'Transpose', N-I, I-1, ONE, W( I+1, 1 ), LDW,
+ $ A( I+1, I ), 1, ZERO, W( 1, I ), 1 )
+ CALL SGEMV( 'No transpose', N-I, I-1, -ONE, A( I+1, 1 ),
+ $ LDA, W( 1, I ), 1, ONE, W( I+1, I ), 1 )
+ CALL SGEMV( 'Transpose', N-I, I-1, ONE, A( I+1, 1 ), LDA,
+ $ A( I+1, I ), 1, ZERO, W( 1, I ), 1 )
+ CALL SGEMV( 'No transpose', N-I, I-1, -ONE, W( I+1, 1 ),
+ $ LDW, W( 1, I ), 1, ONE, W( I+1, I ), 1 )
+ CALL SSCAL( N-I, TAU( I ), W( I+1, I ), 1 )
+ ALPHA = -HALF*TAU( I )*SDOT( N-I, W( I+1, I ), 1,
+ $ A( I+1, I ), 1 )
+ CALL SAXPY( N-I, ALPHA, A( I+1, I ), 1, W( I+1, I ), 1 )
+ END IF
+*
+ 20 CONTINUE
+ END IF
+*
+ RETURN
+*
+* End of SLATRD
+*
+ END
+ SUBROUTINE SLATRS( UPLO, TRANS, DIAG, NORMIN, N, A, LDA, X, SCALE,
+ $ CNORM, INFO )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER DIAG, NORMIN, TRANS, UPLO
+ INTEGER INFO, LDA, N
+ REAL SCALE
+* ..
+* .. Array Arguments ..
+ REAL A( LDA, * ), CNORM( * ), X( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SLATRS solves one of the triangular systems
+*
+* A *x = s*b or A'*x = s*b
+*
+* with scaling to prevent overflow. Here A is an upper or lower
+* triangular matrix, A' denotes the transpose of A, x and b are
+* n-element vectors, and s is a scaling factor, usually less than
+* or equal to 1, chosen so that the components of x will be less than
+* the overflow threshold. If the unscaled problem will not cause
+* overflow, the Level 2 BLAS routine STRSV is called. If the matrix A
+* is singular (A(j,j) = 0 for some j), then s is set to 0 and a
+* non-trivial solution to A*x = 0 is returned.
+*
+* Arguments
+* =========
+*
+* UPLO (input) CHARACTER*1
+* Specifies whether the matrix A is upper or lower triangular.
+* = 'U': Upper triangular
+* = 'L': Lower triangular
+*
+* TRANS (input) CHARACTER*1
+* Specifies the operation applied to A.
+* = 'N': Solve A * x = s*b (No transpose)
+* = 'T': Solve A'* x = s*b (Transpose)
+* = 'C': Solve A'* x = s*b (Conjugate transpose = Transpose)
+*
+* DIAG (input) CHARACTER*1
+* Specifies whether or not the matrix A is unit triangular.
+* = 'N': Non-unit triangular
+* = 'U': Unit triangular
+*
+* NORMIN (input) CHARACTER*1
+* Specifies whether CNORM has been set or not.
+* = 'Y': CNORM contains the column norms on entry
+* = 'N': CNORM is not set on entry. On exit, the norms will
+* be computed and stored in CNORM.
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* A (input) REAL array, dimension (LDA,N)
+* The triangular matrix A. If UPLO = 'U', the leading n by n
+* upper triangular part of the array A contains the upper
+* triangular matrix, and the strictly lower triangular part of
+* A is not referenced. If UPLO = 'L', the leading n by n lower
+* triangular part of the array A contains the lower triangular
+* matrix, and the strictly upper triangular part of A is not
+* referenced. If DIAG = 'U', the diagonal elements of A are
+* also not referenced and are assumed to be 1.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max (1,N).
+*
+* X (input/output) REAL array, dimension (N)
+* On entry, the right hand side b of the triangular system.
+* On exit, X is overwritten by the solution vector x.
+*
+* SCALE (output) REAL
+* The scaling factor s for the triangular system
+* A * x = s*b or A'* x = s*b.
+* If SCALE = 0, the matrix A is singular or badly scaled, and
+* the vector x is an exact or approximate solution to A*x = 0.
+*
+* CNORM (input or output) REAL array, dimension (N)
+*
+* If NORMIN = 'Y', CNORM is an input argument and CNORM(j)
+* contains the norm of the off-diagonal part of the j-th column
+* of A. If TRANS = 'N', CNORM(j) must be greater than or equal
+* to the infinity-norm, and if TRANS = 'T' or 'C', CNORM(j)
+* must be greater than or equal to the 1-norm.
+*
+* If NORMIN = 'N', CNORM is an output argument and CNORM(j)
+* returns the 1-norm of the offdiagonal part of the j-th column
+* of A.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -k, the k-th argument had an illegal value
+*
+* Further Details
+* ======= =======
+*
+* A rough bound on x is computed; if that is less than overflow, STRSV
+* is called, otherwise, specific code is used which checks for possible
+* overflow or divide-by-zero at every operation.
+*
+* A columnwise scheme is used for solving A*x = b. The basic algorithm
+* if A is lower triangular is
+*
+* x[1:n] := b[1:n]
+* for j = 1, ..., n
+* x(j) := x(j) / A(j,j)
+* x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j]
+* end
+*
+* Define bounds on the components of x after j iterations of the loop:
+* M(j) = bound on x[1:j]
+* G(j) = bound on x[j+1:n]
+* Initially, let M(0) = 0 and G(0) = max{x(i), i=1,...,n}.
+*
+* Then for iteration j+1 we have
+* M(j+1) <= G(j) / | A(j+1,j+1) |
+* G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] |
+* <= G(j) ( 1 + CNORM(j+1) / | A(j+1,j+1) | )
+*
+* where CNORM(j+1) is greater than or equal to the infinity-norm of
+* column j+1 of A, not counting the diagonal. Hence
+*
+* G(j) <= G(0) product ( 1 + CNORM(i) / | A(i,i) | )
+* 1<=i<=j
+* and
+*
+* |x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + CNORM(i) / |A(i,i)| )
+* 1<=i< j
+*
+* Since |x(j)| <= M(j), we use the Level 2 BLAS routine STRSV if the
+* reciprocal of the largest M(j), j=1,..,n, is larger than
+* max(underflow, 1/overflow).
+*
+* The bound on x(j) is also used to determine when a step in the
+* columnwise method can be performed without fear of overflow. If
+* the computed bound is greater than a large constant, x is scaled to
+* prevent overflow, but if the bound overflows, x is set to 0, x(j) to
+* 1, and scale to 0, and a non-trivial solution to A*x = 0 is found.
+*
+* Similarly, a row-wise scheme is used to solve A'*x = b. The basic
+* algorithm for A upper triangular is
+*
+* for j = 1, ..., n
+* x(j) := ( b(j) - A[1:j-1,j]' * x[1:j-1] ) / A(j,j)
+* end
+*
+* We simultaneously compute two bounds
+* G(j) = bound on ( b(i) - A[1:i-1,i]' * x[1:i-1] ), 1<=i<=j
+* M(j) = bound on x(i), 1<=i<=j
+*
+* The initial values are G(0) = 0, M(0) = max{b(i), i=1,..,n}, and we
+* add the constraint G(j) >= G(j-1) and M(j) >= M(j-1) for j >= 1.
+* Then the bound on x(j) is
+*
+* M(j) <= M(j-1) * ( 1 + CNORM(j) ) / | A(j,j) |
+*
+* <= M(0) * product ( ( 1 + CNORM(i) ) / |A(i,i)| )
+* 1<=i<=j
+*
+* and we can safely call STRSV if 1/M(n) and 1/G(n) are both greater
+* than max(underflow, 1/overflow).
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO, HALF, ONE
+ PARAMETER ( ZERO = 0.0E+0, HALF = 0.5E+0, ONE = 1.0E+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL NOTRAN, NOUNIT, UPPER
+ INTEGER I, IMAX, J, JFIRST, JINC, JLAST
+ REAL BIGNUM, GROW, REC, SMLNUM, SUMJ, TJJ, TJJS,
+ $ TMAX, TSCAL, USCAL, XBND, XJ, XMAX
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ISAMAX
+ REAL SASUM, SDOT, SLAMCH
+ EXTERNAL LSAME, ISAMAX, SASUM, SDOT, SLAMCH
+* ..
+* .. External Subroutines ..
+ EXTERNAL SAXPY, SSCAL, STRSV, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ NOTRAN = LSAME( TRANS, 'N' )
+ NOUNIT = LSAME( DIAG, 'N' )
+*
+* Test the input parameters.
+*
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT.
+ $ LSAME( TRANS, 'C' ) ) THEN
+ INFO = -2
+ ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
+ INFO = -3
+ ELSE IF( .NOT.LSAME( NORMIN, 'Y' ) .AND. .NOT.
+ $ LSAME( NORMIN, 'N' ) ) THEN
+ INFO = -4
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -5
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -7
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SLATRS', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+* Determine machine dependent parameters to control overflow.
+*
+ SMLNUM = SLAMCH( 'Safe minimum' ) / SLAMCH( 'Precision' )
+ BIGNUM = ONE / SMLNUM
+ SCALE = ONE
+*
+ IF( LSAME( NORMIN, 'N' ) ) THEN
+*
+* Compute the 1-norm of each column, not including the diagonal.
+*
+ IF( UPPER ) THEN
+*
+* A is upper triangular.
+*
+ DO 10 J = 1, N
+ CNORM( J ) = SASUM( J-1, A( 1, J ), 1 )
+ 10 CONTINUE
+ ELSE
+*
+* A is lower triangular.
+*
+ DO 20 J = 1, N - 1
+ CNORM( J ) = SASUM( N-J, A( J+1, J ), 1 )
+ 20 CONTINUE
+ CNORM( N ) = ZERO
+ END IF
+ END IF
+*
+* Scale the column norms by TSCAL if the maximum element in CNORM is
+* greater than BIGNUM.
+*
+ IMAX = ISAMAX( N, CNORM, 1 )
+ TMAX = CNORM( IMAX )
+ IF( TMAX.LE.BIGNUM ) THEN
+ TSCAL = ONE
+ ELSE
+ TSCAL = ONE / ( SMLNUM*TMAX )
+ CALL SSCAL( N, TSCAL, CNORM, 1 )
+ END IF
+*
+* Compute a bound on the computed solution vector to see if the
+* Level 2 BLAS routine STRSV can be used.
+*
+ J = ISAMAX( N, X, 1 )
+ XMAX = ABS( X( J ) )
+ XBND = XMAX
+ IF( NOTRAN ) THEN
+*
+* Compute the growth in A * x = b.
+*
+ IF( UPPER ) THEN
+ JFIRST = N
+ JLAST = 1
+ JINC = -1
+ ELSE
+ JFIRST = 1
+ JLAST = N
+ JINC = 1
+ END IF
+*
+ IF( TSCAL.NE.ONE ) THEN
+ GROW = ZERO
+ GO TO 50
+ END IF
+*
+ IF( NOUNIT ) THEN
+*
+* A is non-unit triangular.
+*
+* Compute GROW = 1/G(j) and XBND = 1/M(j).
+* Initially, G(0) = max{x(i), i=1,...,n}.
+*
+ GROW = ONE / MAX( XBND, SMLNUM )
+ XBND = GROW
+ DO 30 J = JFIRST, JLAST, JINC
+*
+* Exit the loop if the growth factor is too small.
+*
+ IF( GROW.LE.SMLNUM )
+ $ GO TO 50
+*
+* M(j) = G(j-1) / abs(A(j,j))
+*
+ TJJ = ABS( A( J, J ) )
+ XBND = MIN( XBND, MIN( ONE, TJJ )*GROW )
+ IF( TJJ+CNORM( J ).GE.SMLNUM ) THEN
+*
+* G(j) = G(j-1)*( 1 + CNORM(j) / abs(A(j,j)) )
+*
+ GROW = GROW*( TJJ / ( TJJ+CNORM( J ) ) )
+ ELSE
+*
+* G(j) could overflow, set GROW to 0.
+*
+ GROW = ZERO
+ END IF
+ 30 CONTINUE
+ GROW = XBND
+ ELSE
+*
+* A is unit triangular.
+*
+* Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}.
+*
+ GROW = MIN( ONE, ONE / MAX( XBND, SMLNUM ) )
+ DO 40 J = JFIRST, JLAST, JINC
+*
+* Exit the loop if the growth factor is too small.
+*
+ IF( GROW.LE.SMLNUM )
+ $ GO TO 50
+*
+* G(j) = G(j-1)*( 1 + CNORM(j) )
+*
+ GROW = GROW*( ONE / ( ONE+CNORM( J ) ) )
+ 40 CONTINUE
+ END IF
+ 50 CONTINUE
+*
+ ELSE
+*
+* Compute the growth in A' * x = b.
+*
+ IF( UPPER ) THEN
+ JFIRST = 1
+ JLAST = N
+ JINC = 1
+ ELSE
+ JFIRST = N
+ JLAST = 1
+ JINC = -1
+ END IF
+*
+ IF( TSCAL.NE.ONE ) THEN
+ GROW = ZERO
+ GO TO 80
+ END IF
+*
+ IF( NOUNIT ) THEN
+*
+* A is non-unit triangular.
+*
+* Compute GROW = 1/G(j) and XBND = 1/M(j).
+* Initially, M(0) = max{x(i), i=1,...,n}.
+*
+ GROW = ONE / MAX( XBND, SMLNUM )
+ XBND = GROW
+ DO 60 J = JFIRST, JLAST, JINC
+*
+* Exit the loop if the growth factor is too small.
+*
+ IF( GROW.LE.SMLNUM )
+ $ GO TO 80
+*
+* G(j) = max( G(j-1), M(j-1)*( 1 + CNORM(j) ) )
+*
+ XJ = ONE + CNORM( J )
+ GROW = MIN( GROW, XBND / XJ )
+*
+* M(j) = M(j-1)*( 1 + CNORM(j) ) / abs(A(j,j))
+*
+ TJJ = ABS( A( J, J ) )
+ IF( XJ.GT.TJJ )
+ $ XBND = XBND*( TJJ / XJ )
+ 60 CONTINUE
+ GROW = MIN( GROW, XBND )
+ ELSE
+*
+* A is unit triangular.
+*
+* Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}.
+*
+ GROW = MIN( ONE, ONE / MAX( XBND, SMLNUM ) )
+ DO 70 J = JFIRST, JLAST, JINC
+*
+* Exit the loop if the growth factor is too small.
+*
+ IF( GROW.LE.SMLNUM )
+ $ GO TO 80
+*
+* G(j) = ( 1 + CNORM(j) )*G(j-1)
+*
+ XJ = ONE + CNORM( J )
+ GROW = GROW / XJ
+ 70 CONTINUE
+ END IF
+ 80 CONTINUE
+ END IF
+*
+ IF( ( GROW*TSCAL ).GT.SMLNUM ) THEN
+*
+* Use the Level 2 BLAS solve if the reciprocal of the bound on
+* elements of X is not too small.
+*
+ CALL STRSV( UPLO, TRANS, DIAG, N, A, LDA, X, 1 )
+ ELSE
+*
+* Use a Level 1 BLAS solve, scaling intermediate results.
+*
+ IF( XMAX.GT.BIGNUM ) THEN
+*
+* Scale X so that its components are less than or equal to
+* BIGNUM in absolute value.
+*
+ SCALE = BIGNUM / XMAX
+ CALL SSCAL( N, SCALE, X, 1 )
+ XMAX = BIGNUM
+ END IF
+*
+ IF( NOTRAN ) THEN
+*
+* Solve A * x = b
+*
+ DO 100 J = JFIRST, JLAST, JINC
+*
+* Compute x(j) = b(j) / A(j,j), scaling x if necessary.
+*
+ XJ = ABS( X( J ) )
+ IF( NOUNIT ) THEN
+ TJJS = A( J, J )*TSCAL
+ ELSE
+ TJJS = TSCAL
+ IF( TSCAL.EQ.ONE )
+ $ GO TO 95
+ END IF
+ TJJ = ABS( TJJS )
+ IF( TJJ.GT.SMLNUM ) THEN
+*
+* abs(A(j,j)) > SMLNUM:
+*
+ IF( TJJ.LT.ONE ) THEN
+ IF( XJ.GT.TJJ*BIGNUM ) THEN
+*
+* Scale x by 1/b(j).
+*
+ REC = ONE / XJ
+ CALL SSCAL( N, REC, X, 1 )
+ SCALE = SCALE*REC
+ XMAX = XMAX*REC
+ END IF
+ END IF
+ X( J ) = X( J ) / TJJS
+ XJ = ABS( X( J ) )
+ ELSE IF( TJJ.GT.ZERO ) THEN
+*
+* 0 < abs(A(j,j)) <= SMLNUM:
+*
+ IF( XJ.GT.TJJ*BIGNUM ) THEN
+*
+* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM
+* to avoid overflow when dividing by A(j,j).
+*
+ REC = ( TJJ*BIGNUM ) / XJ
+ IF( CNORM( J ).GT.ONE ) THEN
+*
+* Scale by 1/CNORM(j) to avoid overflow when
+* multiplying x(j) times column j.
+*
+ REC = REC / CNORM( J )
+ END IF
+ CALL SSCAL( N, REC, X, 1 )
+ SCALE = SCALE*REC
+ XMAX = XMAX*REC
+ END IF
+ X( J ) = X( J ) / TJJS
+ XJ = ABS( X( J ) )
+ ELSE
+*
+* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and
+* scale = 0, and compute a solution to A*x = 0.
+*
+ DO 90 I = 1, N
+ X( I ) = ZERO
+ 90 CONTINUE
+ X( J ) = ONE
+ XJ = ONE
+ SCALE = ZERO
+ XMAX = ZERO
+ END IF
+ 95 CONTINUE
+*
+* Scale x if necessary to avoid overflow when adding a
+* multiple of column j of A.
+*
+ IF( XJ.GT.ONE ) THEN
+ REC = ONE / XJ
+ IF( CNORM( J ).GT.( BIGNUM-XMAX )*REC ) THEN
+*
+* Scale x by 1/(2*abs(x(j))).
+*
+ REC = REC*HALF
+ CALL SSCAL( N, REC, X, 1 )
+ SCALE = SCALE*REC
+ END IF
+ ELSE IF( XJ*CNORM( J ).GT.( BIGNUM-XMAX ) ) THEN
+*
+* Scale x by 1/2.
+*
+ CALL SSCAL( N, HALF, X, 1 )
+ SCALE = SCALE*HALF
+ END IF
+*
+ IF( UPPER ) THEN
+ IF( J.GT.1 ) THEN
+*
+* Compute the update
+* x(1:j-1) := x(1:j-1) - x(j) * A(1:j-1,j)
+*
+ CALL SAXPY( J-1, -X( J )*TSCAL, A( 1, J ), 1, X,
+ $ 1 )
+ I = ISAMAX( J-1, X, 1 )
+ XMAX = ABS( X( I ) )
+ END IF
+ ELSE
+ IF( J.LT.N ) THEN
+*
+* Compute the update
+* x(j+1:n) := x(j+1:n) - x(j) * A(j+1:n,j)
+*
+ CALL SAXPY( N-J, -X( J )*TSCAL, A( J+1, J ), 1,
+ $ X( J+1 ), 1 )
+ I = J + ISAMAX( N-J, X( J+1 ), 1 )
+ XMAX = ABS( X( I ) )
+ END IF
+ END IF
+ 100 CONTINUE
+*
+ ELSE
+*
+* Solve A' * x = b
+*
+ DO 140 J = JFIRST, JLAST, JINC
+*
+* Compute x(j) = b(j) - sum A(k,j)*x(k).
+* k<>j
+*
+ XJ = ABS( X( J ) )
+ USCAL = TSCAL
+ REC = ONE / MAX( XMAX, ONE )
+ IF( CNORM( J ).GT.( BIGNUM-XJ )*REC ) THEN
+*
+* If x(j) could overflow, scale x by 1/(2*XMAX).
+*
+ REC = REC*HALF
+ IF( NOUNIT ) THEN
+ TJJS = A( J, J )*TSCAL
+ ELSE
+ TJJS = TSCAL
+ END IF
+ TJJ = ABS( TJJS )
+ IF( TJJ.GT.ONE ) THEN
+*
+* Divide by A(j,j) when scaling x if A(j,j) > 1.
+*
+ REC = MIN( ONE, REC*TJJ )
+ USCAL = USCAL / TJJS
+ END IF
+ IF( REC.LT.ONE ) THEN
+ CALL SSCAL( N, REC, X, 1 )
+ SCALE = SCALE*REC
+ XMAX = XMAX*REC
+ END IF
+ END IF
+*
+ SUMJ = ZERO
+ IF( USCAL.EQ.ONE ) THEN
+*
+* If the scaling needed for A in the dot product is 1,
+* call SDOT to perform the dot product.
+*
+ IF( UPPER ) THEN
+ SUMJ = SDOT( J-1, A( 1, J ), 1, X, 1 )
+ ELSE IF( J.LT.N ) THEN
+ SUMJ = SDOT( N-J, A( J+1, J ), 1, X( J+1 ), 1 )
+ END IF
+ ELSE
+*
+* Otherwise, use in-line code for the dot product.
+*
+ IF( UPPER ) THEN
+ DO 110 I = 1, J - 1
+ SUMJ = SUMJ + ( A( I, J )*USCAL )*X( I )
+ 110 CONTINUE
+ ELSE IF( J.LT.N ) THEN
+ DO 120 I = J + 1, N
+ SUMJ = SUMJ + ( A( I, J )*USCAL )*X( I )
+ 120 CONTINUE
+ END IF
+ END IF
+*
+ IF( USCAL.EQ.TSCAL ) THEN
+*
+* Compute x(j) := ( x(j) - sumj ) / A(j,j) if 1/A(j,j)
+* was not used to scale the dotproduct.
+*
+ X( J ) = X( J ) - SUMJ
+ XJ = ABS( X( J ) )
+ IF( NOUNIT ) THEN
+ TJJS = A( J, J )*TSCAL
+ ELSE
+ TJJS = TSCAL
+ IF( TSCAL.EQ.ONE )
+ $ GO TO 135
+ END IF
+*
+* Compute x(j) = x(j) / A(j,j), scaling if necessary.
+*
+ TJJ = ABS( TJJS )
+ IF( TJJ.GT.SMLNUM ) THEN
+*
+* abs(A(j,j)) > SMLNUM:
+*
+ IF( TJJ.LT.ONE ) THEN
+ IF( XJ.GT.TJJ*BIGNUM ) THEN
+*
+* Scale X by 1/abs(x(j)).
+*
+ REC = ONE / XJ
+ CALL SSCAL( N, REC, X, 1 )
+ SCALE = SCALE*REC
+ XMAX = XMAX*REC
+ END IF
+ END IF
+ X( J ) = X( J ) / TJJS
+ ELSE IF( TJJ.GT.ZERO ) THEN
+*
+* 0 < abs(A(j,j)) <= SMLNUM:
+*
+ IF( XJ.GT.TJJ*BIGNUM ) THEN
+*
+* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM.
+*
+ REC = ( TJJ*BIGNUM ) / XJ
+ CALL SSCAL( N, REC, X, 1 )
+ SCALE = SCALE*REC
+ XMAX = XMAX*REC
+ END IF
+ X( J ) = X( J ) / TJJS
+ ELSE
+*
+* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and
+* scale = 0, and compute a solution to A'*x = 0.
+*
+ DO 130 I = 1, N
+ X( I ) = ZERO
+ 130 CONTINUE
+ X( J ) = ONE
+ SCALE = ZERO
+ XMAX = ZERO
+ END IF
+ 135 CONTINUE
+ ELSE
+*
+* Compute x(j) := x(j) / A(j,j) - sumj if the dot
+* product has already been divided by 1/A(j,j).
+*
+ X( J ) = X( J ) / TJJS - SUMJ
+ END IF
+ XMAX = MAX( XMAX, ABS( X( J ) ) )
+ 140 CONTINUE
+ END IF
+ SCALE = SCALE / TSCAL
+ END IF
+*
+* Scale the column norms by 1/TSCAL for return.
+*
+ IF( TSCAL.NE.ONE ) THEN
+ CALL SSCAL( N, ONE / TSCAL, CNORM, 1 )
+ END IF
+*
+ RETURN
+*
+* End of SLATRS
+*
+ END
+ SUBROUTINE SLATRZ( M, N, L, A, LDA, TAU, WORK )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER L, LDA, M, N
+* ..
+* .. Array Arguments ..
+ REAL A( LDA, * ), TAU( * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SLATRZ factors the M-by-(M+L) real upper trapezoidal matrix
+* [ A1 A2 ] = [ A(1:M,1:M) A(1:M,N-L+1:N) ] as ( R 0 ) * Z, by means
+* of orthogonal transformations. Z is an (M+L)-by-(M+L) orthogonal
+* matrix and, R and A1 are M-by-M upper triangular matrices.
+*
+* Arguments
+* =========
+*
+* M (input) INTEGER
+* The number of rows of the matrix A. M >= 0.
+*
+* N (input) INTEGER
+* The number of columns of the matrix A. N >= 0.
+*
+* L (input) INTEGER
+* The number of columns of the matrix A containing the
+* meaningful part of the Householder vectors. N-M >= L >= 0.
+*
+* A (input/output) REAL array, dimension (LDA,N)
+* On entry, the leading M-by-N upper trapezoidal part of the
+* array A must contain the matrix to be factorized.
+* On exit, the leading M-by-M upper triangular part of A
+* contains the upper triangular matrix R, and elements N-L+1 to
+* N of the first M rows of A, with the array TAU, represent the
+* orthogonal matrix Z as a product of M elementary reflectors.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,M).
+*
+* TAU (output) REAL array, dimension (M)
+* The scalar factors of the elementary reflectors.
+*
+* WORK (workspace) REAL array, dimension (M)
+*
+* Further Details
+* ===============
+*
+* Based on contributions by
+* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA
+*
+* The factorization is obtained by Householder's method. The kth
+* transformation matrix, Z( k ), which is used to introduce zeros into
+* the ( m - k + 1 )th row of A, is given in the form
+*
+* Z( k ) = ( I 0 ),
+* ( 0 T( k ) )
+*
+* where
+*
+* T( k ) = I - tau*u( k )*u( k )', u( k ) = ( 1 ),
+* ( 0 )
+* ( z( k ) )
+*
+* tau is a scalar and z( k ) is an l element vector. tau and z( k )
+* are chosen to annihilate the elements of the kth row of A2.
+*
+* The scalar tau is returned in the kth element of TAU and the vector
+* u( k ) in the kth row of A2, such that the elements of z( k ) are
+* in a( k, l + 1 ), ..., a( k, n ). The elements of R are returned in
+* the upper triangular part of A1.
+*
+* Z is given by
+*
+* Z = Z( 1 ) * Z( 2 ) * ... * Z( m ).
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO
+ PARAMETER ( ZERO = 0.0E+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I
+* ..
+* .. External Subroutines ..
+ EXTERNAL SLARFG, SLARZ
+* ..
+* .. Executable Statements ..
+*
+* Test the input arguments
+*
+* Quick return if possible
+*
+ IF( M.EQ.0 ) THEN
+ RETURN
+ ELSE IF( M.EQ.N ) THEN
+ DO 10 I = 1, N
+ TAU( I ) = ZERO
+ 10 CONTINUE
+ RETURN
+ END IF
+*
+ DO 20 I = M, 1, -1
+*
+* Generate elementary reflector H(i) to annihilate
+* [ A(i,i) A(i,n-l+1:n) ]
+*
+ CALL SLARFG( L+1, A( I, I ), A( I, N-L+1 ), LDA, TAU( I ) )
+*
+* Apply H(i) to A(1:i-1,i:n) from the right
+*
+ CALL SLARZ( 'Right', I-1, N-I+1, L, A( I, N-L+1 ), LDA,
+ $ TAU( I ), A( 1, I ), LDA, WORK )
+*
+ 20 CONTINUE
+*
+ RETURN
+*
+* End of SLATRZ
+*
+ END
+ SUBROUTINE SLATZM( SIDE, M, N, V, INCV, TAU, C1, C2, LDC, WORK )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER SIDE
+ INTEGER INCV, LDC, M, N
+ REAL TAU
+* ..
+* .. Array Arguments ..
+ REAL C1( LDC, * ), C2( LDC, * ), V( * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* This routine is deprecated and has been replaced by routine SORMRZ.
+*
+* SLATZM applies a Householder matrix generated by STZRQF to a matrix.
+*
+* Let P = I - tau*u*u', u = ( 1 ),
+* ( v )
+* where v is an (m-1) vector if SIDE = 'L', or a (n-1) vector if
+* SIDE = 'R'.
+*
+* If SIDE equals 'L', let
+* C = [ C1 ] 1
+* [ C2 ] m-1
+* n
+* Then C is overwritten by P*C.
+*
+* If SIDE equals 'R', let
+* C = [ C1, C2 ] m
+* 1 n-1
+* Then C is overwritten by C*P.
+*
+* Arguments
+* =========
+*
+* SIDE (input) CHARACTER*1
+* = 'L': form P * C
+* = 'R': form C * P
+*
+* M (input) INTEGER
+* The number of rows of the matrix C.
+*
+* N (input) INTEGER
+* The number of columns of the matrix C.
+*
+* V (input) REAL array, dimension
+* (1 + (M-1)*abs(INCV)) if SIDE = 'L'
+* (1 + (N-1)*abs(INCV)) if SIDE = 'R'
+* The vector v in the representation of P. V is not used
+* if TAU = 0.
+*
+* INCV (input) INTEGER
+* The increment between elements of v. INCV <> 0
+*
+* TAU (input) REAL
+* The value tau in the representation of P.
+*
+* C1 (input/output) REAL array, dimension
+* (LDC,N) if SIDE = 'L'
+* (M,1) if SIDE = 'R'
+* On entry, the n-vector C1 if SIDE = 'L', or the m-vector C1
+* if SIDE = 'R'.
+*
+* On exit, the first row of P*C if SIDE = 'L', or the first
+* column of C*P if SIDE = 'R'.
+*
+* C2 (input/output) REAL array, dimension
+* (LDC, N) if SIDE = 'L'
+* (LDC, N-1) if SIDE = 'R'
+* On entry, the (m - 1) x n matrix C2 if SIDE = 'L', or the
+* m x (n - 1) matrix C2 if SIDE = 'R'.
+*
+* On exit, rows 2:m of P*C if SIDE = 'L', or columns 2:m of C*P
+* if SIDE = 'R'.
+*
+* LDC (input) INTEGER
+* The leading dimension of the arrays C1 and C2. LDC >= (1,M).
+*
+* WORK (workspace) REAL array, dimension
+* (N) if SIDE = 'L'
+* (M) if SIDE = 'R'
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ONE, ZERO
+ PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+* ..
+* .. External Subroutines ..
+ EXTERNAL SAXPY, SCOPY, SGEMV, SGER
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MIN
+* ..
+* .. Executable Statements ..
+*
+ IF( ( MIN( M, N ).EQ.0 ) .OR. ( TAU.EQ.ZERO ) )
+ $ RETURN
+*
+ IF( LSAME( SIDE, 'L' ) ) THEN
+*
+* w := C1 + v' * C2
+*
+ CALL SCOPY( N, C1, LDC, WORK, 1 )
+ CALL SGEMV( 'Transpose', M-1, N, ONE, C2, LDC, V, INCV, ONE,
+ $ WORK, 1 )
+*
+* [ C1 ] := [ C1 ] - tau* [ 1 ] * w'
+* [ C2 ] [ C2 ] [ v ]
+*
+ CALL SAXPY( N, -TAU, WORK, 1, C1, LDC )
+ CALL SGER( M-1, N, -TAU, V, INCV, WORK, 1, C2, LDC )
+*
+ ELSE IF( LSAME( SIDE, 'R' ) ) THEN
+*
+* w := C1 + C2 * v
+*
+ CALL SCOPY( M, C1, 1, WORK, 1 )
+ CALL SGEMV( 'No transpose', M, N-1, ONE, C2, LDC, V, INCV, ONE,
+ $ WORK, 1 )
+*
+* [ C1, C2 ] := [ C1, C2 ] - tau* w * [ 1 , v']
+*
+ CALL SAXPY( M, -TAU, WORK, 1, C1, 1 )
+ CALL SGER( M, N-1, -TAU, WORK, 1, V, INCV, C2, LDC )
+ END IF
+*
+ RETURN
+*
+* End of SLATZM
+*
+ END
+ SUBROUTINE SLAUU2( UPLO, N, A, LDA, INFO )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, LDA, N
+* ..
+* .. Array Arguments ..
+ REAL A( LDA, * )
+* ..
+*
+* Purpose
+* =======
+*
+* SLAUU2 computes the product U * U' or L' * L, where the triangular
+* factor U or L is stored in the upper or lower triangular part of
+* the array A.
+*
+* If UPLO = 'U' or 'u' then the upper triangle of the result is stored,
+* overwriting the factor U in A.
+* If UPLO = 'L' or 'l' then the lower triangle of the result is stored,
+* overwriting the factor L in A.
+*
+* This is the unblocked form of the algorithm, calling Level 2 BLAS.
+*
+* Arguments
+* =========
+*
+* UPLO (input) CHARACTER*1
+* Specifies whether the triangular factor stored in the array A
+* is upper or lower triangular:
+* = 'U': Upper triangular
+* = 'L': Lower triangular
+*
+* N (input) INTEGER
+* The order of the triangular factor U or L. N >= 0.
+*
+* A (input/output) REAL array, dimension (LDA,N)
+* On entry, the triangular factor U or L.
+* On exit, if UPLO = 'U', the upper triangle of A is
+* overwritten with the upper triangle of the product U * U';
+* if UPLO = 'L', the lower triangle of A is overwritten with
+* the lower triangle of the product L' * L.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,N).
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -k, the k-th argument had an illegal value
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ONE
+ PARAMETER ( ONE = 1.0E+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL UPPER
+ INTEGER I
+ REAL AII
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ REAL SDOT
+ EXTERNAL LSAME, SDOT
+* ..
+* .. External Subroutines ..
+ EXTERNAL SGEMV, SSCAL, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -4
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SLAUU2', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+ IF( UPPER ) THEN
+*
+* Compute the product U * U'.
+*
+ DO 10 I = 1, N
+ AII = A( I, I )
+ IF( I.LT.N ) THEN
+ A( I, I ) = SDOT( N-I+1, A( I, I ), LDA, A( I, I ), LDA )
+ CALL SGEMV( 'No transpose', I-1, N-I, ONE, A( 1, I+1 ),
+ $ LDA, A( I, I+1 ), LDA, AII, A( 1, I ), 1 )
+ ELSE
+ CALL SSCAL( I, AII, A( 1, I ), 1 )
+ END IF
+ 10 CONTINUE
+*
+ ELSE
+*
+* Compute the product L' * L.
+*
+ DO 20 I = 1, N
+ AII = A( I, I )
+ IF( I.LT.N ) THEN
+ A( I, I ) = SDOT( N-I+1, A( I, I ), 1, A( I, I ), 1 )
+ CALL SGEMV( 'Transpose', N-I, I-1, ONE, A( I+1, 1 ), LDA,
+ $ A( I+1, I ), 1, AII, A( I, 1 ), LDA )
+ ELSE
+ CALL SSCAL( I, AII, A( I, 1 ), LDA )
+ END IF
+ 20 CONTINUE
+ END IF
+*
+ RETURN
+*
+* End of SLAUU2
+*
+ END
+ SUBROUTINE SLAUUM( UPLO, N, A, LDA, INFO )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, LDA, N
+* ..
+* .. Array Arguments ..
+ REAL A( LDA, * )
+* ..
+*
+* Purpose
+* =======
+*
+* SLAUUM computes the product U * U' or L' * L, where the triangular
+* factor U or L is stored in the upper or lower triangular part of
+* the array A.
+*
+* If UPLO = 'U' or 'u' then the upper triangle of the result is stored,
+* overwriting the factor U in A.
+* If UPLO = 'L' or 'l' then the lower triangle of the result is stored,
+* overwriting the factor L in A.
+*
+* This is the blocked form of the algorithm, calling Level 3 BLAS.
+*
+* Arguments
+* =========
+*
+* UPLO (input) CHARACTER*1
+* Specifies whether the triangular factor stored in the array A
+* is upper or lower triangular:
+* = 'U': Upper triangular
+* = 'L': Lower triangular
+*
+* N (input) INTEGER
+* The order of the triangular factor U or L. N >= 0.
+*
+* A (input/output) REAL array, dimension (LDA,N)
+* On entry, the triangular factor U or L.
+* On exit, if UPLO = 'U', the upper triangle of A is
+* overwritten with the upper triangle of the product U * U';
+* if UPLO = 'L', the lower triangle of A is overwritten with
+* the lower triangle of the product L' * L.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,N).
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -k, the k-th argument had an illegal value
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ONE
+ PARAMETER ( ONE = 1.0E+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL UPPER
+ INTEGER I, IB, NB
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ILAENV
+ EXTERNAL LSAME, ILAENV
+* ..
+* .. External Subroutines ..
+ EXTERNAL SGEMM, SLAUU2, SSYRK, STRMM, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -4
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SLAUUM', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+* Determine the block size for this environment.
+*
+ NB = ILAENV( 1, 'SLAUUM', UPLO, N, -1, -1, -1 )
+*
+ IF( NB.LE.1 .OR. NB.GE.N ) THEN
+*
+* Use unblocked code
+*
+ CALL SLAUU2( UPLO, N, A, LDA, INFO )
+ ELSE
+*
+* Use blocked code
+*
+ IF( UPPER ) THEN
+*
+* Compute the product U * U'.
+*
+ DO 10 I = 1, N, NB
+ IB = MIN( NB, N-I+1 )
+ CALL STRMM( 'Right', 'Upper', 'Transpose', 'Non-unit',
+ $ I-1, IB, ONE, A( I, I ), LDA, A( 1, I ),
+ $ LDA )
+ CALL SLAUU2( 'Upper', IB, A( I, I ), LDA, INFO )
+ IF( I+IB.LE.N ) THEN
+ CALL SGEMM( 'No transpose', 'Transpose', I-1, IB,
+ $ N-I-IB+1, ONE, A( 1, I+IB ), LDA,
+ $ A( I, I+IB ), LDA, ONE, A( 1, I ), LDA )
+ CALL SSYRK( 'Upper', 'No transpose', IB, N-I-IB+1,
+ $ ONE, A( I, I+IB ), LDA, ONE, A( I, I ),
+ $ LDA )
+ END IF
+ 10 CONTINUE
+ ELSE
+*
+* Compute the product L' * L.
+*
+ DO 20 I = 1, N, NB
+ IB = MIN( NB, N-I+1 )
+ CALL STRMM( 'Left', 'Lower', 'Transpose', 'Non-unit', IB,
+ $ I-1, ONE, A( I, I ), LDA, A( I, 1 ), LDA )
+ CALL SLAUU2( 'Lower', IB, A( I, I ), LDA, INFO )
+ IF( I+IB.LE.N ) THEN
+ CALL SGEMM( 'Transpose', 'No transpose', IB, I-1,
+ $ N-I-IB+1, ONE, A( I+IB, I ), LDA,
+ $ A( I+IB, 1 ), LDA, ONE, A( I, 1 ), LDA )
+ CALL SSYRK( 'Lower', 'Transpose', IB, N-I-IB+1, ONE,
+ $ A( I+IB, I ), LDA, ONE, A( I, I ), LDA )
+ END IF
+ 20 CONTINUE
+ END IF
+ END IF
+*
+ RETURN
+*
+* End of SLAUUM
+*
+ END
+ SUBROUTINE SLAZQ3( I0, N0, Z, PP, DMIN, SIGMA, DESIG, QMAX, NFAIL,
+ $ ITER, NDIV, IEEE, TTYPE, DMIN1, DMIN2, DN, DN1,
+ $ DN2, TAU )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ LOGICAL IEEE
+ INTEGER I0, ITER, N0, NDIV, NFAIL, PP, TTYPE
+ REAL DESIG, DMIN, DMIN1, DMIN2, DN, DN1, DN2, QMAX,
+ $ SIGMA, TAU
+* ..
+* .. Array Arguments ..
+ REAL Z( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SLAZQ3 checks for deflation, computes a shift (TAU) and calls dqds.
+* In case of failure it changes shifts, and tries again until output
+* is positive.
+*
+* Arguments
+* =========
+*
+* I0 (input) INTEGER
+* First index.
+*
+* N0 (input) INTEGER
+* Last index.
+*
+* Z (input) REAL array, dimension ( 4*N )
+* Z holds the qd array.
+*
+* PP (input) INTEGER
+* PP=0 for ping, PP=1 for pong.
+*
+* DMIN (output) REAL
+* Minimum value of d.
+*
+* SIGMA (output) REAL
+* Sum of shifts used in current segment.
+*
+* DESIG (input/output) REAL
+* Lower order part of SIGMA
+*
+* QMAX (input) REAL
+* Maximum value of q.
+*
+* NFAIL (output) INTEGER
+* Number of times shift was too big.
+*
+* ITER (output) INTEGER
+* Number of iterations.
+*
+* NDIV (output) INTEGER
+* Number of divisions.
+*
+* IEEE (input) LOGICAL
+* Flag for IEEE or non IEEE arithmetic (passed to SLASQ5).
+*
+* TTYPE (input/output) INTEGER
+* Shift type. TTYPE is passed as an argument in order to save
+* its value between calls to SLAZQ3
+*
+* DMIN1 (input/output) REAL
+* DMIN2 (input/output) REAL
+* DN (input/output) REAL
+* DN1 (input/output) REAL
+* DN2 (input/output) REAL
+* TAU (input/output) REAL
+* These are passed as arguments in order to save their values
+* between calls to SLAZQ3
+*
+* This is a thread safe version of SLASQ3, which passes TTYPE, DMIN1,
+* DMIN2, DN, DN1. DN2 and TAU through the argument list in place of
+* declaring them in a SAVE statment.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL CBIAS
+ PARAMETER ( CBIAS = 1.50E0 )
+ REAL ZERO, QURTR, HALF, ONE, TWO, HUNDRD
+ PARAMETER ( ZERO = 0.0E0, QURTR = 0.250E0, HALF = 0.5E0,
+ $ ONE = 1.0E0, TWO = 2.0E0, HUNDRD = 100.0E0 )
+* ..
+* .. Local Scalars ..
+ INTEGER IPN4, J4, N0IN, NN
+ REAL EPS, G, S, SAFMIN, T, TEMP, TOL, TOL2
+* ..
+* .. External Subroutines ..
+ EXTERNAL SLASQ5, SLASQ6, SLAZQ4
+* ..
+* .. External Function ..
+ REAL SLAMCH
+ EXTERNAL SLAMCH
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MIN, SQRT
+* ..
+* .. Executable Statements ..
+*
+ N0IN = N0
+ EPS = SLAMCH( 'Precision' )
+ SAFMIN = SLAMCH( 'Safe minimum' )
+ TOL = EPS*HUNDRD
+ TOL2 = TOL**2
+ G = ZERO
+*
+* Check for deflation.
+*
+ 10 CONTINUE
+*
+ IF( N0.LT.I0 )
+ $ RETURN
+ IF( N0.EQ.I0 )
+ $ GO TO 20
+ NN = 4*N0 + PP
+ IF( N0.EQ.( I0+1 ) )
+ $ GO TO 40
+*
+* Check whether E(N0-1) is negligible, 1 eigenvalue.
+*
+ IF( Z( NN-5 ).GT.TOL2*( SIGMA+Z( NN-3 ) ) .AND.
+ $ Z( NN-2*PP-4 ).GT.TOL2*Z( NN-7 ) )
+ $ GO TO 30
+*
+ 20 CONTINUE
+*
+ Z( 4*N0-3 ) = Z( 4*N0+PP-3 ) + SIGMA
+ N0 = N0 - 1
+ GO TO 10
+*
+* Check whether E(N0-2) is negligible, 2 eigenvalues.
+*
+ 30 CONTINUE
+*
+ IF( Z( NN-9 ).GT.TOL2*SIGMA .AND.
+ $ Z( NN-2*PP-8 ).GT.TOL2*Z( NN-11 ) )
+ $ GO TO 50
+*
+ 40 CONTINUE
+*
+ IF( Z( NN-3 ).GT.Z( NN-7 ) ) THEN
+ S = Z( NN-3 )
+ Z( NN-3 ) = Z( NN-7 )
+ Z( NN-7 ) = S
+ END IF
+ IF( Z( NN-5 ).GT.Z( NN-3 )*TOL2 ) THEN
+ T = HALF*( ( Z( NN-7 )-Z( NN-3 ) )+Z( NN-5 ) )
+ S = Z( NN-3 )*( Z( NN-5 ) / T )
+ IF( S.LE.T ) THEN
+ S = Z( NN-3 )*( Z( NN-5 ) /
+ $ ( T*( ONE+SQRT( ONE+S / T ) ) ) )
+ ELSE
+ S = Z( NN-3 )*( Z( NN-5 ) / ( T+SQRT( T )*SQRT( T+S ) ) )
+ END IF
+ T = Z( NN-7 ) + ( S+Z( NN-5 ) )
+ Z( NN-3 ) = Z( NN-3 )*( Z( NN-7 ) / T )
+ Z( NN-7 ) = T
+ END IF
+ Z( 4*N0-7 ) = Z( NN-7 ) + SIGMA
+ Z( 4*N0-3 ) = Z( NN-3 ) + SIGMA
+ N0 = N0 - 2
+ GO TO 10
+*
+ 50 CONTINUE
+*
+* Reverse the qd-array, if warranted.
+*
+ IF( DMIN.LE.ZERO .OR. N0.LT.N0IN ) THEN
+ IF( CBIAS*Z( 4*I0+PP-3 ).LT.Z( 4*N0+PP-3 ) ) THEN
+ IPN4 = 4*( I0+N0 )
+ DO 60 J4 = 4*I0, 2*( I0+N0-1 ), 4
+ TEMP = Z( J4-3 )
+ Z( J4-3 ) = Z( IPN4-J4-3 )
+ Z( IPN4-J4-3 ) = TEMP
+ TEMP = Z( J4-2 )
+ Z( J4-2 ) = Z( IPN4-J4-2 )
+ Z( IPN4-J4-2 ) = TEMP
+ TEMP = Z( J4-1 )
+ Z( J4-1 ) = Z( IPN4-J4-5 )
+ Z( IPN4-J4-5 ) = TEMP
+ TEMP = Z( J4 )
+ Z( J4 ) = Z( IPN4-J4-4 )
+ Z( IPN4-J4-4 ) = TEMP
+ 60 CONTINUE
+ IF( N0-I0.LE.4 ) THEN
+ Z( 4*N0+PP-1 ) = Z( 4*I0+PP-1 )
+ Z( 4*N0-PP ) = Z( 4*I0-PP )
+ END IF
+ DMIN2 = MIN( DMIN2, Z( 4*N0+PP-1 ) )
+ Z( 4*N0+PP-1 ) = MIN( Z( 4*N0+PP-1 ), Z( 4*I0+PP-1 ),
+ $ Z( 4*I0+PP+3 ) )
+ Z( 4*N0-PP ) = MIN( Z( 4*N0-PP ), Z( 4*I0-PP ),
+ $ Z( 4*I0-PP+4 ) )
+ QMAX = MAX( QMAX, Z( 4*I0+PP-3 ), Z( 4*I0+PP+1 ) )
+ DMIN = -ZERO
+ END IF
+ END IF
+*
+ IF( DMIN.LT.ZERO .OR. SAFMIN*QMAX.LT.MIN( Z( 4*N0+PP-1 ),
+ $ Z( 4*N0+PP-9 ), DMIN2+Z( 4*N0-PP ) ) ) THEN
+*
+* Choose a shift.
+*
+ CALL SLAZQ4( I0, N0, Z, PP, N0IN, DMIN, DMIN1, DMIN2, DN, DN1,
+ $ DN2, TAU, TTYPE, G )
+*
+* Call dqds until DMIN > 0.
+*
+ 80 CONTINUE
+*
+ CALL SLASQ5( I0, N0, Z, PP, TAU, DMIN, DMIN1, DMIN2, DN,
+ $ DN1, DN2, IEEE )
+*
+ NDIV = NDIV + ( N0-I0+2 )
+ ITER = ITER + 1
+*
+* Check status.
+*
+ IF( DMIN.GE.ZERO .AND. DMIN1.GT.ZERO ) THEN
+*
+* Success.
+*
+ GO TO 100
+*
+ ELSE IF( DMIN.LT.ZERO .AND. DMIN1.GT.ZERO .AND.
+ $ Z( 4*( N0-1 )-PP ).LT.TOL*( SIGMA+DN1 ) .AND.
+ $ ABS( DN ).LT.TOL*SIGMA ) THEN
+*
+* Convergence hidden by negative DN.
+*
+ Z( 4*( N0-1 )-PP+2 ) = ZERO
+ DMIN = ZERO
+ GO TO 100
+ ELSE IF( DMIN.LT.ZERO ) THEN
+*
+* TAU too big. Select new TAU and try again.
+*
+ NFAIL = NFAIL + 1
+ IF( TTYPE.LT.-22 ) THEN
+*
+* Failed twice. Play it safe.
+*
+ TAU = ZERO
+ ELSE IF( DMIN1.GT.ZERO ) THEN
+*
+* Late failure. Gives excellent shift.
+*
+ TAU = ( TAU+DMIN )*( ONE-TWO*EPS )
+ TTYPE = TTYPE - 11
+ ELSE
+*
+* Early failure. Divide by 4.
+*
+ TAU = QURTR*TAU
+ TTYPE = TTYPE - 12
+ END IF
+ GO TO 80
+ ELSE IF( DMIN.NE.DMIN ) THEN
+*
+* NaN.
+*
+ TAU = ZERO
+ GO TO 80
+ ELSE
+*
+* Possible underflow. Play it safe.
+*
+ GO TO 90
+ END IF
+ END IF
+*
+* Risk of underflow.
+*
+ 90 CONTINUE
+ CALL SLASQ6( I0, N0, Z, PP, DMIN, DMIN1, DMIN2, DN, DN1, DN2 )
+ NDIV = NDIV + ( N0-I0+2 )
+ ITER = ITER + 1
+ TAU = ZERO
+*
+ 100 CONTINUE
+ IF( TAU.LT.SIGMA ) THEN
+ DESIG = DESIG + TAU
+ T = SIGMA + DESIG
+ DESIG = DESIG - ( T-SIGMA )
+ ELSE
+ T = SIGMA + TAU
+ DESIG = SIGMA - ( T-TAU ) + DESIG
+ END IF
+ SIGMA = T
+*
+ RETURN
+*
+* End of SLAZQ3
+*
+ END
+ SUBROUTINE SLAZQ4( I0, N0, Z, PP, N0IN, DMIN, DMIN1, DMIN2, DN,
+ $ DN1, DN2, TAU, TTYPE, G )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER I0, N0, N0IN, PP, TTYPE
+ REAL DMIN, DMIN1, DMIN2, DN, DN1, DN2, G, TAU
+* ..
+* .. Array Arguments ..
+ REAL Z( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SLAZQ4 computes an approximation TAU to the smallest eigenvalue
+* using values of d from the previous transform.
+*
+* I0 (input) INTEGER
+* First index.
+*
+* N0 (input) INTEGER
+* Last index.
+*
+* Z (input) REAL array, dimension ( 4*N )
+* Z holds the qd array.
+*
+* PP (input) INTEGER
+* PP=0 for ping, PP=1 for pong.
+*
+* N0IN (input) INTEGER
+* The value of N0 at start of EIGTEST.
+*
+* DMIN (input) REAL
+* Minimum value of d.
+*
+* DMIN1 (input) REAL
+* Minimum value of d, excluding D( N0 ).
+*
+* DMIN2 (input) REAL
+* Minimum value of d, excluding D( N0 ) and D( N0-1 ).
+*
+* DN (input) REAL
+* d(N)
+*
+* DN1 (input) REAL
+* d(N-1)
+*
+* DN2 (input) REAL
+* d(N-2)
+*
+* TAU (output) REAL
+* This is the shift.
+*
+* TTYPE (output) INTEGER
+* Shift type.
+*
+* G (input/output) REAL
+* G is passed as an argument in order to save its value between
+* calls to SLAZQ4
+*
+* Further Details
+* ===============
+* CNST1 = 9/16
+*
+* This is a thread safe version of SLASQ4, which passes G through the
+* argument list in place of declaring G in a SAVE statment.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL CNST1, CNST2, CNST3
+ PARAMETER ( CNST1 = 0.5630E0, CNST2 = 1.010E0,
+ $ CNST3 = 1.050E0 )
+ REAL QURTR, THIRD, HALF, ZERO, ONE, TWO, HUNDRD
+ PARAMETER ( QURTR = 0.250E0, THIRD = 0.3330E0,
+ $ HALF = 0.50E0, ZERO = 0.0E0, ONE = 1.0E0,
+ $ TWO = 2.0E0, HUNDRD = 100.0E0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I4, NN, NP
+ REAL A2, B1, B2, GAM, GAP1, GAP2, S
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN, SQRT
+* ..
+* .. Executable Statements ..
+*
+* A negative DMIN forces the shift to take that absolute value
+* TTYPE records the type of shift.
+*
+ IF( DMIN.LE.ZERO ) THEN
+ TAU = -DMIN
+ TTYPE = -1
+ RETURN
+ END IF
+*
+ NN = 4*N0 + PP
+ IF( N0IN.EQ.N0 ) THEN
+*
+* No eigenvalues deflated.
+*
+ IF( DMIN.EQ.DN .OR. DMIN.EQ.DN1 ) THEN
+*
+ B1 = SQRT( Z( NN-3 ) )*SQRT( Z( NN-5 ) )
+ B2 = SQRT( Z( NN-7 ) )*SQRT( Z( NN-9 ) )
+ A2 = Z( NN-7 ) + Z( NN-5 )
+*
+* Cases 2 and 3.
+*
+ IF( DMIN.EQ.DN .AND. DMIN1.EQ.DN1 ) THEN
+ GAP2 = DMIN2 - A2 - DMIN2*QURTR
+ IF( GAP2.GT.ZERO .AND. GAP2.GT.B2 ) THEN
+ GAP1 = A2 - DN - ( B2 / GAP2 )*B2
+ ELSE
+ GAP1 = A2 - DN - ( B1+B2 )
+ END IF
+ IF( GAP1.GT.ZERO .AND. GAP1.GT.B1 ) THEN
+ S = MAX( DN-( B1 / GAP1 )*B1, HALF*DMIN )
+ TTYPE = -2
+ ELSE
+ S = ZERO
+ IF( DN.GT.B1 )
+ $ S = DN - B1
+ IF( A2.GT.( B1+B2 ) )
+ $ S = MIN( S, A2-( B1+B2 ) )
+ S = MAX( S, THIRD*DMIN )
+ TTYPE = -3
+ END IF
+ ELSE
+*
+* Case 4.
+*
+ TTYPE = -4
+ S = QURTR*DMIN
+ IF( DMIN.EQ.DN ) THEN
+ GAM = DN
+ A2 = ZERO
+ IF( Z( NN-5 ) .GT. Z( NN-7 ) )
+ $ RETURN
+ B2 = Z( NN-5 ) / Z( NN-7 )
+ NP = NN - 9
+ ELSE
+ NP = NN - 2*PP
+ B2 = Z( NP-2 )
+ GAM = DN1
+ IF( Z( NP-4 ) .GT. Z( NP-2 ) )
+ $ RETURN
+ A2 = Z( NP-4 ) / Z( NP-2 )
+ IF( Z( NN-9 ) .GT. Z( NN-11 ) )
+ $ RETURN
+ B2 = Z( NN-9 ) / Z( NN-11 )
+ NP = NN - 13
+ END IF
+*
+* Approximate contribution to norm squared from I < NN-1.
+*
+ A2 = A2 + B2
+ DO 10 I4 = NP, 4*I0 - 1 + PP, -4
+ IF( B2.EQ.ZERO )
+ $ GO TO 20
+ B1 = B2
+ IF( Z( I4 ) .GT. Z( I4-2 ) )
+ $ RETURN
+ B2 = B2*( Z( I4 ) / Z( I4-2 ) )
+ A2 = A2 + B2
+ IF( HUNDRD*MAX( B2, B1 ).LT.A2 .OR. CNST1.LT.A2 )
+ $ GO TO 20
+ 10 CONTINUE
+ 20 CONTINUE
+ A2 = CNST3*A2
+*
+* Rayleigh quotient residual bound.
+*
+ IF( A2.LT.CNST1 )
+ $ S = GAM*( ONE-SQRT( A2 ) ) / ( ONE+A2 )
+ END IF
+ ELSE IF( DMIN.EQ.DN2 ) THEN
+*
+* Case 5.
+*
+ TTYPE = -5
+ S = QURTR*DMIN
+*
+* Compute contribution to norm squared from I > NN-2.
+*
+ NP = NN - 2*PP
+ B1 = Z( NP-2 )
+ B2 = Z( NP-6 )
+ GAM = DN2
+ IF( Z( NP-8 ).GT.B2 .OR. Z( NP-4 ).GT.B1 )
+ $ RETURN
+ A2 = ( Z( NP-8 ) / B2 )*( ONE+Z( NP-4 ) / B1 )
+*
+* Approximate contribution to norm squared from I < NN-2.
+*
+ IF( N0-I0.GT.2 ) THEN
+ B2 = Z( NN-13 ) / Z( NN-15 )
+ A2 = A2 + B2
+ DO 30 I4 = NN - 17, 4*I0 - 1 + PP, -4
+ IF( B2.EQ.ZERO )
+ $ GO TO 40
+ B1 = B2
+ IF( Z( I4 ) .GT. Z( I4-2 ) )
+ $ RETURN
+ B2 = B2*( Z( I4 ) / Z( I4-2 ) )
+ A2 = A2 + B2
+ IF( HUNDRD*MAX( B2, B1 ).LT.A2 .OR. CNST1.LT.A2 )
+ $ GO TO 40
+ 30 CONTINUE
+ 40 CONTINUE
+ A2 = CNST3*A2
+ END IF
+*
+ IF( A2.LT.CNST1 )
+ $ S = GAM*( ONE-SQRT( A2 ) ) / ( ONE+A2 )
+ ELSE
+*
+* Case 6, no information to guide us.
+*
+ IF( TTYPE.EQ.-6 ) THEN
+ G = G + THIRD*( ONE-G )
+ ELSE IF( TTYPE.EQ.-18 ) THEN
+ G = QURTR*THIRD
+ ELSE
+ G = QURTR
+ END IF
+ S = G*DMIN
+ TTYPE = -6
+ END IF
+*
+ ELSE IF( N0IN.EQ.( N0+1 ) ) THEN
+*
+* One eigenvalue just deflated. Use DMIN1, DN1 for DMIN and DN.
+*
+ IF( DMIN1.EQ.DN1 .AND. DMIN2.EQ.DN2 ) THEN
+*
+* Cases 7 and 8.
+*
+ TTYPE = -7
+ S = THIRD*DMIN1
+ IF( Z( NN-5 ).GT.Z( NN-7 ) )
+ $ RETURN
+ B1 = Z( NN-5 ) / Z( NN-7 )
+ B2 = B1
+ IF( B2.EQ.ZERO )
+ $ GO TO 60
+ DO 50 I4 = 4*N0 - 9 + PP, 4*I0 - 1 + PP, -4
+ A2 = B1
+ IF( Z( I4 ).GT.Z( I4-2 ) )
+ $ RETURN
+ B1 = B1*( Z( I4 ) / Z( I4-2 ) )
+ B2 = B2 + B1
+ IF( HUNDRD*MAX( B1, A2 ).LT.B2 )
+ $ GO TO 60
+ 50 CONTINUE
+ 60 CONTINUE
+ B2 = SQRT( CNST3*B2 )
+ A2 = DMIN1 / ( ONE+B2**2 )
+ GAP2 = HALF*DMIN2 - A2
+ IF( GAP2.GT.ZERO .AND. GAP2.GT.B2*A2 ) THEN
+ S = MAX( S, A2*( ONE-CNST2*A2*( B2 / GAP2 )*B2 ) )
+ ELSE
+ S = MAX( S, A2*( ONE-CNST2*B2 ) )
+ TTYPE = -8
+ END IF
+ ELSE
+*
+* Case 9.
+*
+ S = QURTR*DMIN1
+ IF( DMIN1.EQ.DN1 )
+ $ S = HALF*DMIN1
+ TTYPE = -9
+ END IF
+*
+ ELSE IF( N0IN.EQ.( N0+2 ) ) THEN
+*
+* Two eigenvalues deflated. Use DMIN2, DN2 for DMIN and DN.
+*
+* Cases 10 and 11.
+*
+ IF( DMIN2.EQ.DN2 .AND. TWO*Z( NN-5 ).LT.Z( NN-7 ) ) THEN
+ TTYPE = -10
+ S = THIRD*DMIN2
+ IF( Z( NN-5 ).GT.Z( NN-7 ) )
+ $ RETURN
+ B1 = Z( NN-5 ) / Z( NN-7 )
+ B2 = B1
+ IF( B2.EQ.ZERO )
+ $ GO TO 80
+ DO 70 I4 = 4*N0 - 9 + PP, 4*I0 - 1 + PP, -4
+ IF( Z( I4 ).GT.Z( I4-2 ) )
+ $ RETURN
+ B1 = B1*( Z( I4 ) / Z( I4-2 ) )
+ B2 = B2 + B1
+ IF( HUNDRD*B1.LT.B2 )
+ $ GO TO 80
+ 70 CONTINUE
+ 80 CONTINUE
+ B2 = SQRT( CNST3*B2 )
+ A2 = DMIN2 / ( ONE+B2**2 )
+ GAP2 = Z( NN-7 ) + Z( NN-9 ) -
+ $ SQRT( Z( NN-11 ) )*SQRT( Z( NN-9 ) ) - A2
+ IF( GAP2.GT.ZERO .AND. GAP2.GT.B2*A2 ) THEN
+ S = MAX( S, A2*( ONE-CNST2*A2*( B2 / GAP2 )*B2 ) )
+ ELSE
+ S = MAX( S, A2*( ONE-CNST2*B2 ) )
+ END IF
+ ELSE
+ S = QURTR*DMIN2
+ TTYPE = -11
+ END IF
+ ELSE IF( N0IN.GT.( N0+2 ) ) THEN
+*
+* Case 12, more than two eigenvalues deflated. No information.
+*
+ S = ZERO
+ TTYPE = -12
+ END IF
+*
+ TAU = S
+ RETURN
+*
+* End of SLAZQ4
+*
+ END
+ SUBROUTINE SOPGTR( UPLO, N, AP, TAU, Q, LDQ, WORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, LDQ, N
+* ..
+* .. Array Arguments ..
+ REAL AP( * ), Q( LDQ, * ), TAU( * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SOPGTR generates a real orthogonal matrix Q which is defined as the
+* product of n-1 elementary reflectors H(i) of order n, as returned by
+* SSPTRD using packed storage:
+*
+* if UPLO = 'U', Q = H(n-1) . . . H(2) H(1),
+*
+* if UPLO = 'L', Q = H(1) H(2) . . . H(n-1).
+*
+* Arguments
+* =========
+*
+* UPLO (input) CHARACTER*1
+* = 'U': Upper triangular packed storage used in previous
+* call to SSPTRD;
+* = 'L': Lower triangular packed storage used in previous
+* call to SSPTRD.
+*
+* N (input) INTEGER
+* The order of the matrix Q. N >= 0.
+*
+* AP (input) REAL array, dimension (N*(N+1)/2)
+* The vectors which define the elementary reflectors, as
+* returned by SSPTRD.
+*
+* TAU (input) REAL array, dimension (N-1)
+* TAU(i) must contain the scalar factor of the elementary
+* reflector H(i), as returned by SSPTRD.
+*
+* Q (output) REAL array, dimension (LDQ,N)
+* The N-by-N orthogonal matrix Q.
+*
+* LDQ (input) INTEGER
+* The leading dimension of the array Q. LDQ >= max(1,N).
+*
+* WORK (workspace) REAL array, dimension (N-1)
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO, ONE
+ PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL UPPER
+ INTEGER I, IINFO, IJ, J
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL SORG2L, SORG2R, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input arguments
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN
+ INFO = -6
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SOPGTR', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+ IF( UPPER ) THEN
+*
+* Q was determined by a call to SSPTRD with UPLO = 'U'
+*
+* Unpack the vectors which define the elementary reflectors and
+* set the last row and column of Q equal to those of the unit
+* matrix
+*
+ IJ = 2
+ DO 20 J = 1, N - 1
+ DO 10 I = 1, J - 1
+ Q( I, J ) = AP( IJ )
+ IJ = IJ + 1
+ 10 CONTINUE
+ IJ = IJ + 2
+ Q( N, J ) = ZERO
+ 20 CONTINUE
+ DO 30 I = 1, N - 1
+ Q( I, N ) = ZERO
+ 30 CONTINUE
+ Q( N, N ) = ONE
+*
+* Generate Q(1:n-1,1:n-1)
+*
+ CALL SORG2L( N-1, N-1, N-1, Q, LDQ, TAU, WORK, IINFO )
+*
+ ELSE
+*
+* Q was determined by a call to SSPTRD with UPLO = 'L'.
+*
+* Unpack the vectors which define the elementary reflectors and
+* set the first row and column of Q equal to those of the unit
+* matrix
+*
+ Q( 1, 1 ) = ONE
+ DO 40 I = 2, N
+ Q( I, 1 ) = ZERO
+ 40 CONTINUE
+ IJ = 3
+ DO 60 J = 2, N
+ Q( 1, J ) = ZERO
+ DO 50 I = J + 1, N
+ Q( I, J ) = AP( IJ )
+ IJ = IJ + 1
+ 50 CONTINUE
+ IJ = IJ + 2
+ 60 CONTINUE
+ IF( N.GT.1 ) THEN
+*
+* Generate Q(2:n,2:n)
+*
+ CALL SORG2R( N-1, N-1, N-1, Q( 2, 2 ), LDQ, TAU, WORK,
+ $ IINFO )
+ END IF
+ END IF
+ RETURN
+*
+* End of SOPGTR
+*
+ END
+ SUBROUTINE SOPMTR( SIDE, UPLO, TRANS, M, N, AP, TAU, C, LDC, WORK,
+ $ INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER SIDE, TRANS, UPLO
+ INTEGER INFO, LDC, M, N
+* ..
+* .. Array Arguments ..
+ REAL AP( * ), C( LDC, * ), TAU( * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SOPMTR overwrites the general real M-by-N matrix C with
+*
+* SIDE = 'L' SIDE = 'R'
+* TRANS = 'N': Q * C C * Q
+* TRANS = 'T': Q**T * C C * Q**T
+*
+* where Q is a real orthogonal matrix of order nq, with nq = m if
+* SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of
+* nq-1 elementary reflectors, as returned by SSPTRD using packed
+* storage:
+*
+* if UPLO = 'U', Q = H(nq-1) . . . H(2) H(1);
+*
+* if UPLO = 'L', Q = H(1) H(2) . . . H(nq-1).
+*
+* Arguments
+* =========
+*
+* SIDE (input) CHARACTER*1
+* = 'L': apply Q or Q**T from the Left;
+* = 'R': apply Q or Q**T from the Right.
+*
+* UPLO (input) CHARACTER*1
+* = 'U': Upper triangular packed storage used in previous
+* call to SSPTRD;
+* = 'L': Lower triangular packed storage used in previous
+* call to SSPTRD.
+*
+* TRANS (input) CHARACTER*1
+* = 'N': No transpose, apply Q;
+* = 'T': Transpose, apply Q**T.
+*
+* M (input) INTEGER
+* The number of rows of the matrix C. M >= 0.
+*
+* N (input) INTEGER
+* The number of columns of the matrix C. N >= 0.
+*
+* AP (input) REAL array, dimension
+* (M*(M+1)/2) if SIDE = 'L'
+* (N*(N+1)/2) if SIDE = 'R'
+* The vectors which define the elementary reflectors, as
+* returned by SSPTRD. AP is modified by the routine but
+* restored on exit.
+*
+* TAU (input) REAL array, dimension (M-1) if SIDE = 'L'
+* or (N-1) if SIDE = 'R'
+* TAU(i) must contain the scalar factor of the elementary
+* reflector H(i), as returned by SSPTRD.
+*
+* C (input/output) REAL array, dimension (LDC,N)
+* On entry, the M-by-N matrix C.
+* On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q.
+*
+* LDC (input) INTEGER
+* The leading dimension of the array C. LDC >= max(1,M).
+*
+* WORK (workspace) REAL array, dimension
+* (N) if SIDE = 'L'
+* (M) if SIDE = 'R'
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ONE
+ PARAMETER ( ONE = 1.0E+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL FORWRD, LEFT, NOTRAN, UPPER
+ INTEGER I, I1, I2, I3, IC, II, JC, MI, NI, NQ
+ REAL AII
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL SLARF, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input arguments
+*
+ INFO = 0
+ LEFT = LSAME( SIDE, 'L' )
+ NOTRAN = LSAME( TRANS, 'N' )
+ UPPER = LSAME( UPLO, 'U' )
+*
+* NQ is the order of Q
+*
+ IF( LEFT ) THEN
+ NQ = M
+ ELSE
+ NQ = N
+ END IF
+ IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN
+ INFO = -1
+ ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -2
+ ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN
+ INFO = -3
+ ELSE IF( M.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -5
+ ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
+ INFO = -9
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SOPMTR', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( M.EQ.0 .OR. N.EQ.0 )
+ $ RETURN
+*
+ IF( UPPER ) THEN
+*
+* Q was determined by a call to SSPTRD with UPLO = 'U'
+*
+ FORWRD = ( LEFT .AND. NOTRAN ) .OR.
+ $ ( .NOT.LEFT .AND. .NOT.NOTRAN )
+*
+ IF( FORWRD ) THEN
+ I1 = 1
+ I2 = NQ - 1
+ I3 = 1
+ II = 2
+ ELSE
+ I1 = NQ - 1
+ I2 = 1
+ I3 = -1
+ II = NQ*( NQ+1 ) / 2 - 1
+ END IF
+*
+ IF( LEFT ) THEN
+ NI = N
+ ELSE
+ MI = M
+ END IF
+*
+ DO 10 I = I1, I2, I3
+ IF( LEFT ) THEN
+*
+* H(i) is applied to C(1:i,1:n)
+*
+ MI = I
+ ELSE
+*
+* H(i) is applied to C(1:m,1:i)
+*
+ NI = I
+ END IF
+*
+* Apply H(i)
+*
+ AII = AP( II )
+ AP( II ) = ONE
+ CALL SLARF( SIDE, MI, NI, AP( II-I+1 ), 1, TAU( I ), C, LDC,
+ $ WORK )
+ AP( II ) = AII
+*
+ IF( FORWRD ) THEN
+ II = II + I + 2
+ ELSE
+ II = II - I - 1
+ END IF
+ 10 CONTINUE
+ ELSE
+*
+* Q was determined by a call to SSPTRD with UPLO = 'L'.
+*
+ FORWRD = ( LEFT .AND. .NOT.NOTRAN ) .OR.
+ $ ( .NOT.LEFT .AND. NOTRAN )
+*
+ IF( FORWRD ) THEN
+ I1 = 1
+ I2 = NQ - 1
+ I3 = 1
+ II = 2
+ ELSE
+ I1 = NQ - 1
+ I2 = 1
+ I3 = -1
+ II = NQ*( NQ+1 ) / 2 - 1
+ END IF
+*
+ IF( LEFT ) THEN
+ NI = N
+ JC = 1
+ ELSE
+ MI = M
+ IC = 1
+ END IF
+*
+ DO 20 I = I1, I2, I3
+ AII = AP( II )
+ AP( II ) = ONE
+ IF( LEFT ) THEN
+*
+* H(i) is applied to C(i+1:m,1:n)
+*
+ MI = M - I
+ IC = I + 1
+ ELSE
+*
+* H(i) is applied to C(1:m,i+1:n)
+*
+ NI = N - I
+ JC = I + 1
+ END IF
+*
+* Apply H(i)
+*
+ CALL SLARF( SIDE, MI, NI, AP( II ), 1, TAU( I ),
+ $ C( IC, JC ), LDC, WORK )
+ AP( II ) = AII
+*
+ IF( FORWRD ) THEN
+ II = II + NQ - I + 1
+ ELSE
+ II = II - NQ + I - 2
+ END IF
+ 20 CONTINUE
+ END IF
+ RETURN
+*
+* End of SOPMTR
+*
+ END
+ SUBROUTINE SORG2L( M, N, K, A, LDA, TAU, WORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, K, LDA, M, N
+* ..
+* .. Array Arguments ..
+ REAL A( LDA, * ), TAU( * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SORG2L generates an m by n real matrix Q with orthonormal columns,
+* which is defined as the last n columns of a product of k elementary
+* reflectors of order m
+*
+* Q = H(k) . . . H(2) H(1)
+*
+* as returned by SGEQLF.
+*
+* Arguments
+* =========
+*
+* M (input) INTEGER
+* The number of rows of the matrix Q. M >= 0.
+*
+* N (input) INTEGER
+* The number of columns of the matrix Q. M >= N >= 0.
+*
+* K (input) INTEGER
+* The number of elementary reflectors whose product defines the
+* matrix Q. N >= K >= 0.
+*
+* A (input/output) REAL array, dimension (LDA,N)
+* On entry, the (n-k+i)-th column must contain the vector which
+* defines the elementary reflector H(i), for i = 1,2,...,k, as
+* returned by SGEQLF in the last k columns of its array
+* argument A.
+* On exit, the m by n matrix Q.
+*
+* LDA (input) INTEGER
+* The first dimension of the array A. LDA >= max(1,M).
+*
+* TAU (input) REAL array, dimension (K)
+* TAU(i) must contain the scalar factor of the elementary
+* reflector H(i), as returned by SGEQLF.
+*
+* WORK (workspace) REAL array, dimension (N)
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument has an illegal value
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ONE, ZERO
+ PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, II, J, L
+* ..
+* .. External Subroutines ..
+ EXTERNAL SLARF, SSCAL, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input arguments
+*
+ INFO = 0
+ IF( M.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 .OR. N.GT.M ) THEN
+ INFO = -2
+ ELSE IF( K.LT.0 .OR. K.GT.N ) THEN
+ INFO = -3
+ ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+ INFO = -5
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SORG2L', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.LE.0 )
+ $ RETURN
+*
+* Initialise columns 1:n-k to columns of the unit matrix
+*
+ DO 20 J = 1, N - K
+ DO 10 L = 1, M
+ A( L, J ) = ZERO
+ 10 CONTINUE
+ A( M-N+J, J ) = ONE
+ 20 CONTINUE
+*
+ DO 40 I = 1, K
+ II = N - K + I
+*
+* Apply H(i) to A(1:m-k+i,1:n-k+i) from the left
+*
+ A( M-N+II, II ) = ONE
+ CALL SLARF( 'Left', M-N+II, II-1, A( 1, II ), 1, TAU( I ), A,
+ $ LDA, WORK )
+ CALL SSCAL( M-N+II-1, -TAU( I ), A( 1, II ), 1 )
+ A( M-N+II, II ) = ONE - TAU( I )
+*
+* Set A(m-k+i+1:m,n-k+i) to zero
+*
+ DO 30 L = M - N + II + 1, M
+ A( L, II ) = ZERO
+ 30 CONTINUE
+ 40 CONTINUE
+ RETURN
+*
+* End of SORG2L
+*
+ END
+ SUBROUTINE SORG2R( M, N, K, A, LDA, TAU, WORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, K, LDA, M, N
+* ..
+* .. Array Arguments ..
+ REAL A( LDA, * ), TAU( * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SORG2R generates an m by n real matrix Q with orthonormal columns,
+* which is defined as the first n columns of a product of k elementary
+* reflectors of order m
+*
+* Q = H(1) H(2) . . . H(k)
+*
+* as returned by SGEQRF.
+*
+* Arguments
+* =========
+*
+* M (input) INTEGER
+* The number of rows of the matrix Q. M >= 0.
+*
+* N (input) INTEGER
+* The number of columns of the matrix Q. M >= N >= 0.
+*
+* K (input) INTEGER
+* The number of elementary reflectors whose product defines the
+* matrix Q. N >= K >= 0.
+*
+* A (input/output) REAL array, dimension (LDA,N)
+* On entry, the i-th column must contain the vector which
+* defines the elementary reflector H(i), for i = 1,2,...,k, as
+* returned by SGEQRF in the first k columns of its array
+* argument A.
+* On exit, the m-by-n matrix Q.
+*
+* LDA (input) INTEGER
+* The first dimension of the array A. LDA >= max(1,M).
+*
+* TAU (input) REAL array, dimension (K)
+* TAU(i) must contain the scalar factor of the elementary
+* reflector H(i), as returned by SGEQRF.
+*
+* WORK (workspace) REAL array, dimension (N)
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument has an illegal value
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ONE, ZERO
+ PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, J, L
+* ..
+* .. External Subroutines ..
+ EXTERNAL SLARF, SSCAL, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input arguments
+*
+ INFO = 0
+ IF( M.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 .OR. N.GT.M ) THEN
+ INFO = -2
+ ELSE IF( K.LT.0 .OR. K.GT.N ) THEN
+ INFO = -3
+ ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+ INFO = -5
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SORG2R', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.LE.0 )
+ $ RETURN
+*
+* Initialise columns k+1:n to columns of the unit matrix
+*
+ DO 20 J = K + 1, N
+ DO 10 L = 1, M
+ A( L, J ) = ZERO
+ 10 CONTINUE
+ A( J, J ) = ONE
+ 20 CONTINUE
+*
+ DO 40 I = K, 1, -1
+*
+* Apply H(i) to A(i:m,i:n) from the left
+*
+ IF( I.LT.N ) THEN
+ A( I, I ) = ONE
+ CALL SLARF( 'Left', M-I+1, N-I, A( I, I ), 1, TAU( I ),
+ $ A( I, I+1 ), LDA, WORK )
+ END IF
+ IF( I.LT.M )
+ $ CALL SSCAL( M-I, -TAU( I ), A( I+1, I ), 1 )
+ A( I, I ) = ONE - TAU( I )
+*
+* Set A(1:i-1,i) to zero
+*
+ DO 30 L = 1, I - 1
+ A( L, I ) = ZERO
+ 30 CONTINUE
+ 40 CONTINUE
+ RETURN
+*
+* End of SORG2R
+*
+ END
+ SUBROUTINE SORGBR( VECT, M, N, K, A, LDA, TAU, WORK, LWORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER VECT
+ INTEGER INFO, K, LDA, LWORK, M, N
+* ..
+* .. Array Arguments ..
+ REAL A( LDA, * ), TAU( * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SORGBR generates one of the real orthogonal matrices Q or P**T
+* determined by SGEBRD when reducing a real matrix A to bidiagonal
+* form: A = Q * B * P**T. Q and P**T are defined as products of
+* elementary reflectors H(i) or G(i) respectively.
+*
+* If VECT = 'Q', A is assumed to have been an M-by-K matrix, and Q
+* is of order M:
+* if m >= k, Q = H(1) H(2) . . . H(k) and SORGBR returns the first n
+* columns of Q, where m >= n >= k;
+* if m < k, Q = H(1) H(2) . . . H(m-1) and SORGBR returns Q as an
+* M-by-M matrix.
+*
+* If VECT = 'P', A is assumed to have been a K-by-N matrix, and P**T
+* is of order N:
+* if k < n, P**T = G(k) . . . G(2) G(1) and SORGBR returns the first m
+* rows of P**T, where n >= m >= k;
+* if k >= n, P**T = G(n-1) . . . G(2) G(1) and SORGBR returns P**T as
+* an N-by-N matrix.
+*
+* Arguments
+* =========
+*
+* VECT (input) CHARACTER*1
+* Specifies whether the matrix Q or the matrix P**T is
+* required, as defined in the transformation applied by SGEBRD:
+* = 'Q': generate Q;
+* = 'P': generate P**T.
+*
+* M (input) INTEGER
+* The number of rows of the matrix Q or P**T to be returned.
+* M >= 0.
+*
+* N (input) INTEGER
+* The number of columns of the matrix Q or P**T to be returned.
+* N >= 0.
+* If VECT = 'Q', M >= N >= min(M,K);
+* if VECT = 'P', N >= M >= min(N,K).
+*
+* K (input) INTEGER
+* If VECT = 'Q', the number of columns in the original M-by-K
+* matrix reduced by SGEBRD.
+* If VECT = 'P', the number of rows in the original K-by-N
+* matrix reduced by SGEBRD.
+* K >= 0.
+*
+* A (input/output) REAL array, dimension (LDA,N)
+* On entry, the vectors which define the elementary reflectors,
+* as returned by SGEBRD.
+* On exit, the M-by-N matrix Q or P**T.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,M).
+*
+* TAU (input) REAL array, dimension
+* (min(M,K)) if VECT = 'Q'
+* (min(N,K)) if VECT = 'P'
+* TAU(i) must contain the scalar factor of the elementary
+* reflector H(i) or G(i), which determines Q or P**T, as
+* returned by SGEBRD in its array argument TAUQ or TAUP.
+*
+* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))
+* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+* LWORK (input) INTEGER
+* The dimension of the array WORK. LWORK >= max(1,min(M,N)).
+* For optimum performance LWORK >= min(M,N)*NB, where NB
+* is the optimal blocksize.
+*
+* If LWORK = -1, then a workspace query is assumed; the routine
+* only calculates the optimal size of the WORK array, returns
+* this value as the first entry of the WORK array, and no error
+* message related to LWORK is issued by XERBLA.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO, ONE
+ PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL LQUERY, WANTQ
+ INTEGER I, IINFO, J, LWKOPT, MN, NB
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ILAENV
+ EXTERNAL ILAENV, LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL SORGLQ, SORGQR, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+* Test the input arguments
+*
+ INFO = 0
+ WANTQ = LSAME( VECT, 'Q' )
+ MN = MIN( M, N )
+ LQUERY = ( LWORK.EQ.-1 )
+ IF( .NOT.WANTQ .AND. .NOT.LSAME( VECT, 'P' ) ) THEN
+ INFO = -1
+ ELSE IF( M.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( N.LT.0 .OR. ( WANTQ .AND. ( N.GT.M .OR. N.LT.MIN( M,
+ $ K ) ) ) .OR. ( .NOT.WANTQ .AND. ( M.GT.N .OR. M.LT.
+ $ MIN( N, K ) ) ) ) THEN
+ INFO = -3
+ ELSE IF( K.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+ INFO = -6
+ ELSE IF( LWORK.LT.MAX( 1, MN ) .AND. .NOT.LQUERY ) THEN
+ INFO = -9
+ END IF
+*
+ IF( INFO.EQ.0 ) THEN
+ IF( WANTQ ) THEN
+ NB = ILAENV( 1, 'SORGQR', ' ', M, N, K, -1 )
+ ELSE
+ NB = ILAENV( 1, 'SORGLQ', ' ', M, N, K, -1 )
+ END IF
+ LWKOPT = MAX( 1, MN )*NB
+ WORK( 1 ) = LWKOPT
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SORGBR', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( M.EQ.0 .OR. N.EQ.0 ) THEN
+ WORK( 1 ) = 1
+ RETURN
+ END IF
+*
+ IF( WANTQ ) THEN
+*
+* Form Q, determined by a call to SGEBRD to reduce an m-by-k
+* matrix
+*
+ IF( M.GE.K ) THEN
+*
+* If m >= k, assume m >= n >= k
+*
+ CALL SORGQR( M, N, K, A, LDA, TAU, WORK, LWORK, IINFO )
+*
+ ELSE
+*
+* If m < k, assume m = n
+*
+* Shift the vectors which define the elementary reflectors one
+* column to the right, and set the first row and column of Q
+* to those of the unit matrix
+*
+ DO 20 J = M, 2, -1
+ A( 1, J ) = ZERO
+ DO 10 I = J + 1, M
+ A( I, J ) = A( I, J-1 )
+ 10 CONTINUE
+ 20 CONTINUE
+ A( 1, 1 ) = ONE
+ DO 30 I = 2, M
+ A( I, 1 ) = ZERO
+ 30 CONTINUE
+ IF( M.GT.1 ) THEN
+*
+* Form Q(2:m,2:m)
+*
+ CALL SORGQR( M-1, M-1, M-1, A( 2, 2 ), LDA, TAU, WORK,
+ $ LWORK, IINFO )
+ END IF
+ END IF
+ ELSE
+*
+* Form P', determined by a call to SGEBRD to reduce a k-by-n
+* matrix
+*
+ IF( K.LT.N ) THEN
+*
+* If k < n, assume k <= m <= n
+*
+ CALL SORGLQ( M, N, K, A, LDA, TAU, WORK, LWORK, IINFO )
+*
+ ELSE
+*
+* If k >= n, assume m = n
+*
+* Shift the vectors which define the elementary reflectors one
+* row downward, and set the first row and column of P' to
+* those of the unit matrix
+*
+ A( 1, 1 ) = ONE
+ DO 40 I = 2, N
+ A( I, 1 ) = ZERO
+ 40 CONTINUE
+ DO 60 J = 2, N
+ DO 50 I = J - 1, 2, -1
+ A( I, J ) = A( I-1, J )
+ 50 CONTINUE
+ A( 1, J ) = ZERO
+ 60 CONTINUE
+ IF( N.GT.1 ) THEN
+*
+* Form P'(2:n,2:n)
+*
+ CALL SORGLQ( N-1, N-1, N-1, A( 2, 2 ), LDA, TAU, WORK,
+ $ LWORK, IINFO )
+ END IF
+ END IF
+ END IF
+ WORK( 1 ) = LWKOPT
+ RETURN
+*
+* End of SORGBR
+*
+ END
+ SUBROUTINE SORGHR( N, ILO, IHI, A, LDA, TAU, WORK, LWORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER IHI, ILO, INFO, LDA, LWORK, N
+* ..
+* .. Array Arguments ..
+ REAL A( LDA, * ), TAU( * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SORGHR generates a real orthogonal matrix Q which is defined as the
+* product of IHI-ILO elementary reflectors of order N, as returned by
+* SGEHRD:
+*
+* Q = H(ilo) H(ilo+1) . . . H(ihi-1).
+*
+* Arguments
+* =========
+*
+* N (input) INTEGER
+* The order of the matrix Q. N >= 0.
+*
+* ILO (input) INTEGER
+* IHI (input) INTEGER
+* ILO and IHI must have the same values as in the previous call
+* of SGEHRD. Q is equal to the unit matrix except in the
+* submatrix Q(ilo+1:ihi,ilo+1:ihi).
+* 1 <= ILO <= IHI <= N, if N > 0; ILO=1 and IHI=0, if N=0.
+*
+* A (input/output) REAL array, dimension (LDA,N)
+* On entry, the vectors which define the elementary reflectors,
+* as returned by SGEHRD.
+* On exit, the N-by-N orthogonal matrix Q.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,N).
+*
+* TAU (input) REAL array, dimension (N-1)
+* TAU(i) must contain the scalar factor of the elementary
+* reflector H(i), as returned by SGEHRD.
+*
+* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))
+* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+* LWORK (input) INTEGER
+* The dimension of the array WORK. LWORK >= IHI-ILO.
+* For optimum performance LWORK >= (IHI-ILO)*NB, where NB is
+* the optimal blocksize.
+*
+* If LWORK = -1, then a workspace query is assumed; the routine
+* only calculates the optimal size of the WORK array, returns
+* this value as the first entry of the WORK array, and no error
+* message related to LWORK is issued by XERBLA.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO, ONE
+ PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL LQUERY
+ INTEGER I, IINFO, J, LWKOPT, NB, NH
+* ..
+* .. External Subroutines ..
+ EXTERNAL SORGQR, XERBLA
+* ..
+* .. External Functions ..
+ INTEGER ILAENV
+ EXTERNAL ILAENV
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+* Test the input arguments
+*
+ INFO = 0
+ NH = IHI - ILO
+ LQUERY = ( LWORK.EQ.-1 )
+ IF( N.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, N ) ) THEN
+ INFO = -2
+ ELSE IF( IHI.LT.MIN( ILO, N ) .OR. IHI.GT.N ) THEN
+ INFO = -3
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -5
+ ELSE IF( LWORK.LT.MAX( 1, NH ) .AND. .NOT.LQUERY ) THEN
+ INFO = -8
+ END IF
+*
+ IF( INFO.EQ.0 ) THEN
+ NB = ILAENV( 1, 'SORGQR', ' ', NH, NH, NH, -1 )
+ LWKOPT = MAX( 1, NH )*NB
+ WORK( 1 ) = LWKOPT
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SORGHR', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 ) THEN
+ WORK( 1 ) = 1
+ RETURN
+ END IF
+*
+* Shift the vectors which define the elementary reflectors one
+* column to the right, and set the first ilo and the last n-ihi
+* rows and columns to those of the unit matrix
+*
+ DO 40 J = IHI, ILO + 1, -1
+ DO 10 I = 1, J - 1
+ A( I, J ) = ZERO
+ 10 CONTINUE
+ DO 20 I = J + 1, IHI
+ A( I, J ) = A( I, J-1 )
+ 20 CONTINUE
+ DO 30 I = IHI + 1, N
+ A( I, J ) = ZERO
+ 30 CONTINUE
+ 40 CONTINUE
+ DO 60 J = 1, ILO
+ DO 50 I = 1, N
+ A( I, J ) = ZERO
+ 50 CONTINUE
+ A( J, J ) = ONE
+ 60 CONTINUE
+ DO 80 J = IHI + 1, N
+ DO 70 I = 1, N
+ A( I, J ) = ZERO
+ 70 CONTINUE
+ A( J, J ) = ONE
+ 80 CONTINUE
+*
+ IF( NH.GT.0 ) THEN
+*
+* Generate Q(ilo+1:ihi,ilo+1:ihi)
+*
+ CALL SORGQR( NH, NH, NH, A( ILO+1, ILO+1 ), LDA, TAU( ILO ),
+ $ WORK, LWORK, IINFO )
+ END IF
+ WORK( 1 ) = LWKOPT
+ RETURN
+*
+* End of SORGHR
+*
+ END
+ SUBROUTINE SORGL2( M, N, K, A, LDA, TAU, WORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, K, LDA, M, N
+* ..
+* .. Array Arguments ..
+ REAL A( LDA, * ), TAU( * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SORGL2 generates an m by n real matrix Q with orthonormal rows,
+* which is defined as the first m rows of a product of k elementary
+* reflectors of order n
+*
+* Q = H(k) . . . H(2) H(1)
+*
+* as returned by SGELQF.
+*
+* Arguments
+* =========
+*
+* M (input) INTEGER
+* The number of rows of the matrix Q. M >= 0.
+*
+* N (input) INTEGER
+* The number of columns of the matrix Q. N >= M.
+*
+* K (input) INTEGER
+* The number of elementary reflectors whose product defines the
+* matrix Q. M >= K >= 0.
+*
+* A (input/output) REAL array, dimension (LDA,N)
+* On entry, the i-th row must contain the vector which defines
+* the elementary reflector H(i), for i = 1,2,...,k, as returned
+* by SGELQF in the first k rows of its array argument A.
+* On exit, the m-by-n matrix Q.
+*
+* LDA (input) INTEGER
+* The first dimension of the array A. LDA >= max(1,M).
+*
+* TAU (input) REAL array, dimension (K)
+* TAU(i) must contain the scalar factor of the elementary
+* reflector H(i), as returned by SGELQF.
+*
+* WORK (workspace) REAL array, dimension (M)
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument has an illegal value
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ONE, ZERO
+ PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, J, L
+* ..
+* .. External Subroutines ..
+ EXTERNAL SLARF, SSCAL, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input arguments
+*
+ INFO = 0
+ IF( M.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( N.LT.M ) THEN
+ INFO = -2
+ ELSE IF( K.LT.0 .OR. K.GT.M ) THEN
+ INFO = -3
+ ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+ INFO = -5
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SORGL2', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( M.LE.0 )
+ $ RETURN
+*
+ IF( K.LT.M ) THEN
+*
+* Initialise rows k+1:m to rows of the unit matrix
+*
+ DO 20 J = 1, N
+ DO 10 L = K + 1, M
+ A( L, J ) = ZERO
+ 10 CONTINUE
+ IF( J.GT.K .AND. J.LE.M )
+ $ A( J, J ) = ONE
+ 20 CONTINUE
+ END IF
+*
+ DO 40 I = K, 1, -1
+*
+* Apply H(i) to A(i:m,i:n) from the right
+*
+ IF( I.LT.N ) THEN
+ IF( I.LT.M ) THEN
+ A( I, I ) = ONE
+ CALL SLARF( 'Right', M-I, N-I+1, A( I, I ), LDA,
+ $ TAU( I ), A( I+1, I ), LDA, WORK )
+ END IF
+ CALL SSCAL( N-I, -TAU( I ), A( I, I+1 ), LDA )
+ END IF
+ A( I, I ) = ONE - TAU( I )
+*
+* Set A(i,1:i-1) to zero
+*
+ DO 30 L = 1, I - 1
+ A( I, L ) = ZERO
+ 30 CONTINUE
+ 40 CONTINUE
+ RETURN
+*
+* End of SORGL2
+*
+ END
+ SUBROUTINE SORGLQ( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, K, LDA, LWORK, M, N
+* ..
+* .. Array Arguments ..
+ REAL A( LDA, * ), TAU( * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SORGLQ generates an M-by-N real matrix Q with orthonormal rows,
+* which is defined as the first M rows of a product of K elementary
+* reflectors of order N
+*
+* Q = H(k) . . . H(2) H(1)
+*
+* as returned by SGELQF.
+*
+* Arguments
+* =========
+*
+* M (input) INTEGER
+* The number of rows of the matrix Q. M >= 0.
+*
+* N (input) INTEGER
+* The number of columns of the matrix Q. N >= M.
+*
+* K (input) INTEGER
+* The number of elementary reflectors whose product defines the
+* matrix Q. M >= K >= 0.
+*
+* A (input/output) REAL array, dimension (LDA,N)
+* On entry, the i-th row must contain the vector which defines
+* the elementary reflector H(i), for i = 1,2,...,k, as returned
+* by SGELQF in the first k rows of its array argument A.
+* On exit, the M-by-N matrix Q.
+*
+* LDA (input) INTEGER
+* The first dimension of the array A. LDA >= max(1,M).
+*
+* TAU (input) REAL array, dimension (K)
+* TAU(i) must contain the scalar factor of the elementary
+* reflector H(i), as returned by SGELQF.
+*
+* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))
+* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+* LWORK (input) INTEGER
+* The dimension of the array WORK. LWORK >= max(1,M).
+* For optimum performance LWORK >= M*NB, where NB is
+* the optimal blocksize.
+*
+* If LWORK = -1, then a workspace query is assumed; the routine
+* only calculates the optimal size of the WORK array, returns
+* this value as the first entry of the WORK array, and no error
+* message related to LWORK is issued by XERBLA.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument has an illegal value
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO
+ PARAMETER ( ZERO = 0.0E+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL LQUERY
+ INTEGER I, IB, IINFO, IWS, J, KI, KK, L, LDWORK,
+ $ LWKOPT, NB, NBMIN, NX
+* ..
+* .. External Subroutines ..
+ EXTERNAL SLARFB, SLARFT, SORGL2, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN
+* ..
+* .. External Functions ..
+ INTEGER ILAENV
+ EXTERNAL ILAENV
+* ..
+* .. Executable Statements ..
+*
+* Test the input arguments
+*
+ INFO = 0
+ NB = ILAENV( 1, 'SORGLQ', ' ', M, N, K, -1 )
+ LWKOPT = MAX( 1, M )*NB
+ WORK( 1 ) = LWKOPT
+ LQUERY = ( LWORK.EQ.-1 )
+ IF( M.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( N.LT.M ) THEN
+ INFO = -2
+ ELSE IF( K.LT.0 .OR. K.GT.M ) THEN
+ INFO = -3
+ ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+ INFO = -5
+ ELSE IF( LWORK.LT.MAX( 1, M ) .AND. .NOT.LQUERY ) THEN
+ INFO = -8
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SORGLQ', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( M.LE.0 ) THEN
+ WORK( 1 ) = 1
+ RETURN
+ END IF
+*
+ NBMIN = 2
+ NX = 0
+ IWS = M
+ IF( NB.GT.1 .AND. NB.LT.K ) THEN
+*
+* Determine when to cross over from blocked to unblocked code.
+*
+ NX = MAX( 0, ILAENV( 3, 'SORGLQ', ' ', M, N, K, -1 ) )
+ IF( NX.LT.K ) THEN
+*
+* Determine if workspace is large enough for blocked code.
+*
+ LDWORK = M
+ IWS = LDWORK*NB
+ IF( LWORK.LT.IWS ) THEN
+*
+* Not enough workspace to use optimal NB: reduce NB and
+* determine the minimum value of NB.
+*
+ NB = LWORK / LDWORK
+ NBMIN = MAX( 2, ILAENV( 2, 'SORGLQ', ' ', M, N, K, -1 ) )
+ END IF
+ END IF
+ END IF
+*
+ IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN
+*
+* Use blocked code after the last block.
+* The first kk rows are handled by the block method.
+*
+ KI = ( ( K-NX-1 ) / NB )*NB
+ KK = MIN( K, KI+NB )
+*
+* Set A(kk+1:m,1:kk) to zero.
+*
+ DO 20 J = 1, KK
+ DO 10 I = KK + 1, M
+ A( I, J ) = ZERO
+ 10 CONTINUE
+ 20 CONTINUE
+ ELSE
+ KK = 0
+ END IF
+*
+* Use unblocked code for the last or only block.
+*
+ IF( KK.LT.M )
+ $ CALL SORGL2( M-KK, N-KK, K-KK, A( KK+1, KK+1 ), LDA,
+ $ TAU( KK+1 ), WORK, IINFO )
+*
+ IF( KK.GT.0 ) THEN
+*
+* Use blocked code
+*
+ DO 50 I = KI + 1, 1, -NB
+ IB = MIN( NB, K-I+1 )
+ IF( I+IB.LE.M ) THEN
+*
+* Form the triangular factor of the block reflector
+* H = H(i) H(i+1) . . . H(i+ib-1)
+*
+ CALL SLARFT( 'Forward', 'Rowwise', N-I+1, IB, A( I, I ),
+ $ LDA, TAU( I ), WORK, LDWORK )
+*
+* Apply H' to A(i+ib:m,i:n) from the right
+*
+ CALL SLARFB( 'Right', 'Transpose', 'Forward', 'Rowwise',
+ $ M-I-IB+1, N-I+1, IB, A( I, I ), LDA, WORK,
+ $ LDWORK, A( I+IB, I ), LDA, WORK( IB+1 ),
+ $ LDWORK )
+ END IF
+*
+* Apply H' to columns i:n of current block
+*
+ CALL SORGL2( IB, N-I+1, IB, A( I, I ), LDA, TAU( I ), WORK,
+ $ IINFO )
+*
+* Set columns 1:i-1 of current block to zero
+*
+ DO 40 J = 1, I - 1
+ DO 30 L = I, I + IB - 1
+ A( L, J ) = ZERO
+ 30 CONTINUE
+ 40 CONTINUE
+ 50 CONTINUE
+ END IF
+*
+ WORK( 1 ) = IWS
+ RETURN
+*
+* End of SORGLQ
+*
+ END
+ SUBROUTINE SORGQL( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, K, LDA, LWORK, M, N
+* ..
+* .. Array Arguments ..
+ REAL A( LDA, * ), TAU( * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SORGQL generates an M-by-N real matrix Q with orthonormal columns,
+* which is defined as the last N columns of a product of K elementary
+* reflectors of order M
+*
+* Q = H(k) . . . H(2) H(1)
+*
+* as returned by SGEQLF.
+*
+* Arguments
+* =========
+*
+* M (input) INTEGER
+* The number of rows of the matrix Q. M >= 0.
+*
+* N (input) INTEGER
+* The number of columns of the matrix Q. M >= N >= 0.
+*
+* K (input) INTEGER
+* The number of elementary reflectors whose product defines the
+* matrix Q. N >= K >= 0.
+*
+* A (input/output) REAL array, dimension (LDA,N)
+* On entry, the (n-k+i)-th column must contain the vector which
+* defines the elementary reflector H(i), for i = 1,2,...,k, as
+* returned by SGEQLF in the last k columns of its array
+* argument A.
+* On exit, the M-by-N matrix Q.
+*
+* LDA (input) INTEGER
+* The first dimension of the array A. LDA >= max(1,M).
+*
+* TAU (input) REAL array, dimension (K)
+* TAU(i) must contain the scalar factor of the elementary
+* reflector H(i), as returned by SGEQLF.
+*
+* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))
+* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+* LWORK (input) INTEGER
+* The dimension of the array WORK. LWORK >= max(1,N).
+* For optimum performance LWORK >= N*NB, where NB is the
+* optimal blocksize.
+*
+* If LWORK = -1, then a workspace query is assumed; the routine
+* only calculates the optimal size of the WORK array, returns
+* this value as the first entry of the WORK array, and no error
+* message related to LWORK is issued by XERBLA.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument has an illegal value
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO
+ PARAMETER ( ZERO = 0.0E+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL LQUERY
+ INTEGER I, IB, IINFO, IWS, J, KK, L, LDWORK, LWKOPT,
+ $ NB, NBMIN, NX
+* ..
+* .. External Subroutines ..
+ EXTERNAL SLARFB, SLARFT, SORG2L, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN
+* ..
+* .. External Functions ..
+ INTEGER ILAENV
+ EXTERNAL ILAENV
+* ..
+* .. Executable Statements ..
+*
+* Test the input arguments
+*
+ INFO = 0
+ LQUERY = ( LWORK.EQ.-1 )
+ IF( M.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 .OR. N.GT.M ) THEN
+ INFO = -2
+ ELSE IF( K.LT.0 .OR. K.GT.N ) THEN
+ INFO = -3
+ ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+ INFO = -5
+ END IF
+*
+ IF( INFO.EQ.0 ) THEN
+ IF( N.EQ.0 ) THEN
+ LWKOPT = 1
+ ELSE
+ NB = ILAENV( 1, 'SORGQL', ' ', M, N, K, -1 )
+ LWKOPT = N*NB
+ END IF
+ WORK( 1 ) = LWKOPT
+*
+ IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN
+ INFO = -8
+ END IF
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SORGQL', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.LE.0 ) THEN
+ RETURN
+ END IF
+*
+ NBMIN = 2
+ NX = 0
+ IWS = N
+ IF( NB.GT.1 .AND. NB.LT.K ) THEN
+*
+* Determine when to cross over from blocked to unblocked code.
+*
+ NX = MAX( 0, ILAENV( 3, 'SORGQL', ' ', M, N, K, -1 ) )
+ IF( NX.LT.K ) THEN
+*
+* Determine if workspace is large enough for blocked code.
+*
+ LDWORK = N
+ IWS = LDWORK*NB
+ IF( LWORK.LT.IWS ) THEN
+*
+* Not enough workspace to use optimal NB: reduce NB and
+* determine the minimum value of NB.
+*
+ NB = LWORK / LDWORK
+ NBMIN = MAX( 2, ILAENV( 2, 'SORGQL', ' ', M, N, K, -1 ) )
+ END IF
+ END IF
+ END IF
+*
+ IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN
+*
+* Use blocked code after the first block.
+* The last kk columns are handled by the block method.
+*
+ KK = MIN( K, ( ( K-NX+NB-1 ) / NB )*NB )
+*
+* Set A(m-kk+1:m,1:n-kk) to zero.
+*
+ DO 20 J = 1, N - KK
+ DO 10 I = M - KK + 1, M
+ A( I, J ) = ZERO
+ 10 CONTINUE
+ 20 CONTINUE
+ ELSE
+ KK = 0
+ END IF
+*
+* Use unblocked code for the first or only block.
+*
+ CALL SORG2L( M-KK, N-KK, K-KK, A, LDA, TAU, WORK, IINFO )
+*
+ IF( KK.GT.0 ) THEN
+*
+* Use blocked code
+*
+ DO 50 I = K - KK + 1, K, NB
+ IB = MIN( NB, K-I+1 )
+ IF( N-K+I.GT.1 ) THEN
+*
+* Form the triangular factor of the block reflector
+* H = H(i+ib-1) . . . H(i+1) H(i)
+*
+ CALL SLARFT( 'Backward', 'Columnwise', M-K+I+IB-1, IB,
+ $ A( 1, N-K+I ), LDA, TAU( I ), WORK, LDWORK )
+*
+* Apply H to A(1:m-k+i+ib-1,1:n-k+i-1) from the left
+*
+ CALL SLARFB( 'Left', 'No transpose', 'Backward',
+ $ 'Columnwise', M-K+I+IB-1, N-K+I-1, IB,
+ $ A( 1, N-K+I ), LDA, WORK, LDWORK, A, LDA,
+ $ WORK( IB+1 ), LDWORK )
+ END IF
+*
+* Apply H to rows 1:m-k+i+ib-1 of current block
+*
+ CALL SORG2L( M-K+I+IB-1, IB, IB, A( 1, N-K+I ), LDA,
+ $ TAU( I ), WORK, IINFO )
+*
+* Set rows m-k+i+ib:m of current block to zero
+*
+ DO 40 J = N - K + I, N - K + I + IB - 1
+ DO 30 L = M - K + I + IB, M
+ A( L, J ) = ZERO
+ 30 CONTINUE
+ 40 CONTINUE
+ 50 CONTINUE
+ END IF
+*
+ WORK( 1 ) = IWS
+ RETURN
+*
+* End of SORGQL
+*
+ END
+ SUBROUTINE SORGQR( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, K, LDA, LWORK, M, N
+* ..
+* .. Array Arguments ..
+ REAL A( LDA, * ), TAU( * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SORGQR generates an M-by-N real matrix Q with orthonormal columns,
+* which is defined as the first N columns of a product of K elementary
+* reflectors of order M
+*
+* Q = H(1) H(2) . . . H(k)
+*
+* as returned by SGEQRF.
+*
+* Arguments
+* =========
+*
+* M (input) INTEGER
+* The number of rows of the matrix Q. M >= 0.
+*
+* N (input) INTEGER
+* The number of columns of the matrix Q. M >= N >= 0.
+*
+* K (input) INTEGER
+* The number of elementary reflectors whose product defines the
+* matrix Q. N >= K >= 0.
+*
+* A (input/output) REAL array, dimension (LDA,N)
+* On entry, the i-th column must contain the vector which
+* defines the elementary reflector H(i), for i = 1,2,...,k, as
+* returned by SGEQRF in the first k columns of its array
+* argument A.
+* On exit, the M-by-N matrix Q.
+*
+* LDA (input) INTEGER
+* The first dimension of the array A. LDA >= max(1,M).
+*
+* TAU (input) REAL array, dimension (K)
+* TAU(i) must contain the scalar factor of the elementary
+* reflector H(i), as returned by SGEQRF.
+*
+* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))
+* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+* LWORK (input) INTEGER
+* The dimension of the array WORK. LWORK >= max(1,N).
+* For optimum performance LWORK >= N*NB, where NB is the
+* optimal blocksize.
+*
+* If LWORK = -1, then a workspace query is assumed; the routine
+* only calculates the optimal size of the WORK array, returns
+* this value as the first entry of the WORK array, and no error
+* message related to LWORK is issued by XERBLA.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument has an illegal value
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO
+ PARAMETER ( ZERO = 0.0E+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL LQUERY
+ INTEGER I, IB, IINFO, IWS, J, KI, KK, L, LDWORK,
+ $ LWKOPT, NB, NBMIN, NX
+* ..
+* .. External Subroutines ..
+ EXTERNAL SLARFB, SLARFT, SORG2R, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN
+* ..
+* .. External Functions ..
+ INTEGER ILAENV
+ EXTERNAL ILAENV
+* ..
+* .. Executable Statements ..
+*
+* Test the input arguments
+*
+ INFO = 0
+ NB = ILAENV( 1, 'SORGQR', ' ', M, N, K, -1 )
+ LWKOPT = MAX( 1, N )*NB
+ WORK( 1 ) = LWKOPT
+ LQUERY = ( LWORK.EQ.-1 )
+ IF( M.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 .OR. N.GT.M ) THEN
+ INFO = -2
+ ELSE IF( K.LT.0 .OR. K.GT.N ) THEN
+ INFO = -3
+ ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+ INFO = -5
+ ELSE IF( LWORK.LT.MAX( 1, N ) .AND. .NOT.LQUERY ) THEN
+ INFO = -8
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SORGQR', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.LE.0 ) THEN
+ WORK( 1 ) = 1
+ RETURN
+ END IF
+*
+ NBMIN = 2
+ NX = 0
+ IWS = N
+ IF( NB.GT.1 .AND. NB.LT.K ) THEN
+*
+* Determine when to cross over from blocked to unblocked code.
+*
+ NX = MAX( 0, ILAENV( 3, 'SORGQR', ' ', M, N, K, -1 ) )
+ IF( NX.LT.K ) THEN
+*
+* Determine if workspace is large enough for blocked code.
+*
+ LDWORK = N
+ IWS = LDWORK*NB
+ IF( LWORK.LT.IWS ) THEN
+*
+* Not enough workspace to use optimal NB: reduce NB and
+* determine the minimum value of NB.
+*
+ NB = LWORK / LDWORK
+ NBMIN = MAX( 2, ILAENV( 2, 'SORGQR', ' ', M, N, K, -1 ) )
+ END IF
+ END IF
+ END IF
+*
+ IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN
+*
+* Use blocked code after the last block.
+* The first kk columns are handled by the block method.
+*
+ KI = ( ( K-NX-1 ) / NB )*NB
+ KK = MIN( K, KI+NB )
+*
+* Set A(1:kk,kk+1:n) to zero.
+*
+ DO 20 J = KK + 1, N
+ DO 10 I = 1, KK
+ A( I, J ) = ZERO
+ 10 CONTINUE
+ 20 CONTINUE
+ ELSE
+ KK = 0
+ END IF
+*
+* Use unblocked code for the last or only block.
+*
+ IF( KK.LT.N )
+ $ CALL SORG2R( M-KK, N-KK, K-KK, A( KK+1, KK+1 ), LDA,
+ $ TAU( KK+1 ), WORK, IINFO )
+*
+ IF( KK.GT.0 ) THEN
+*
+* Use blocked code
+*
+ DO 50 I = KI + 1, 1, -NB
+ IB = MIN( NB, K-I+1 )
+ IF( I+IB.LE.N ) THEN
+*
+* Form the triangular factor of the block reflector
+* H = H(i) H(i+1) . . . H(i+ib-1)
+*
+ CALL SLARFT( 'Forward', 'Columnwise', M-I+1, IB,
+ $ A( I, I ), LDA, TAU( I ), WORK, LDWORK )
+*
+* Apply H to A(i:m,i+ib:n) from the left
+*
+ CALL SLARFB( 'Left', 'No transpose', 'Forward',
+ $ 'Columnwise', M-I+1, N-I-IB+1, IB,
+ $ A( I, I ), LDA, WORK, LDWORK, A( I, I+IB ),
+ $ LDA, WORK( IB+1 ), LDWORK )
+ END IF
+*
+* Apply H to rows i:m of current block
+*
+ CALL SORG2R( M-I+1, IB, IB, A( I, I ), LDA, TAU( I ), WORK,
+ $ IINFO )
+*
+* Set rows 1:i-1 of current block to zero
+*
+ DO 40 J = I, I + IB - 1
+ DO 30 L = 1, I - 1
+ A( L, J ) = ZERO
+ 30 CONTINUE
+ 40 CONTINUE
+ 50 CONTINUE
+ END IF
+*
+ WORK( 1 ) = IWS
+ RETURN
+*
+* End of SORGQR
+*
+ END
+ SUBROUTINE SORGR2( M, N, K, A, LDA, TAU, WORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, K, LDA, M, N
+* ..
+* .. Array Arguments ..
+ REAL A( LDA, * ), TAU( * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SORGR2 generates an m by n real matrix Q with orthonormal rows,
+* which is defined as the last m rows of a product of k elementary
+* reflectors of order n
+*
+* Q = H(1) H(2) . . . H(k)
+*
+* as returned by SGERQF.
+*
+* Arguments
+* =========
+*
+* M (input) INTEGER
+* The number of rows of the matrix Q. M >= 0.
+*
+* N (input) INTEGER
+* The number of columns of the matrix Q. N >= M.
+*
+* K (input) INTEGER
+* The number of elementary reflectors whose product defines the
+* matrix Q. M >= K >= 0.
+*
+* A (input/output) REAL array, dimension (LDA,N)
+* On entry, the (m-k+i)-th row must contain the vector which
+* defines the elementary reflector H(i), for i = 1,2,...,k, as
+* returned by SGERQF in the last k rows of its array argument
+* A.
+* On exit, the m by n matrix Q.
+*
+* LDA (input) INTEGER
+* The first dimension of the array A. LDA >= max(1,M).
+*
+* TAU (input) REAL array, dimension (K)
+* TAU(i) must contain the scalar factor of the elementary
+* reflector H(i), as returned by SGERQF.
+*
+* WORK (workspace) REAL array, dimension (M)
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument has an illegal value
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ONE, ZERO
+ PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, II, J, L
+* ..
+* .. External Subroutines ..
+ EXTERNAL SLARF, SSCAL, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input arguments
+*
+ INFO = 0
+ IF( M.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( N.LT.M ) THEN
+ INFO = -2
+ ELSE IF( K.LT.0 .OR. K.GT.M ) THEN
+ INFO = -3
+ ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+ INFO = -5
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SORGR2', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( M.LE.0 )
+ $ RETURN
+*
+ IF( K.LT.M ) THEN
+*
+* Initialise rows 1:m-k to rows of the unit matrix
+*
+ DO 20 J = 1, N
+ DO 10 L = 1, M - K
+ A( L, J ) = ZERO
+ 10 CONTINUE
+ IF( J.GT.N-M .AND. J.LE.N-K )
+ $ A( M-N+J, J ) = ONE
+ 20 CONTINUE
+ END IF
+*
+ DO 40 I = 1, K
+ II = M - K + I
+*
+* Apply H(i) to A(1:m-k+i,1:n-k+i) from the right
+*
+ A( II, N-M+II ) = ONE
+ CALL SLARF( 'Right', II-1, N-M+II, A( II, 1 ), LDA, TAU( I ),
+ $ A, LDA, WORK )
+ CALL SSCAL( N-M+II-1, -TAU( I ), A( II, 1 ), LDA )
+ A( II, N-M+II ) = ONE - TAU( I )
+*
+* Set A(m-k+i,n-k+i+1:n) to zero
+*
+ DO 30 L = N - M + II + 1, N
+ A( II, L ) = ZERO
+ 30 CONTINUE
+ 40 CONTINUE
+ RETURN
+*
+* End of SORGR2
+*
+ END
+ SUBROUTINE SORGRQ( M, N, K, A, LDA, TAU, WORK, LWORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, K, LDA, LWORK, M, N
+* ..
+* .. Array Arguments ..
+ REAL A( LDA, * ), TAU( * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SORGRQ generates an M-by-N real matrix Q with orthonormal rows,
+* which is defined as the last M rows of a product of K elementary
+* reflectors of order N
+*
+* Q = H(1) H(2) . . . H(k)
+*
+* as returned by SGERQF.
+*
+* Arguments
+* =========
+*
+* M (input) INTEGER
+* The number of rows of the matrix Q. M >= 0.
+*
+* N (input) INTEGER
+* The number of columns of the matrix Q. N >= M.
+*
+* K (input) INTEGER
+* The number of elementary reflectors whose product defines the
+* matrix Q. M >= K >= 0.
+*
+* A (input/output) REAL array, dimension (LDA,N)
+* On entry, the (m-k+i)-th row must contain the vector which
+* defines the elementary reflector H(i), for i = 1,2,...,k, as
+* returned by SGERQF in the last k rows of its array argument
+* A.
+* On exit, the M-by-N matrix Q.
+*
+* LDA (input) INTEGER
+* The first dimension of the array A. LDA >= max(1,M).
+*
+* TAU (input) REAL array, dimension (K)
+* TAU(i) must contain the scalar factor of the elementary
+* reflector H(i), as returned by SGERQF.
+*
+* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))
+* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+* LWORK (input) INTEGER
+* The dimension of the array WORK. LWORK >= max(1,M).
+* For optimum performance LWORK >= M*NB, where NB is the
+* optimal blocksize.
+*
+* If LWORK = -1, then a workspace query is assumed; the routine
+* only calculates the optimal size of the WORK array, returns
+* this value as the first entry of the WORK array, and no error
+* message related to LWORK is issued by XERBLA.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument has an illegal value
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO
+ PARAMETER ( ZERO = 0.0E+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL LQUERY
+ INTEGER I, IB, II, IINFO, IWS, J, KK, L, LDWORK,
+ $ LWKOPT, NB, NBMIN, NX
+* ..
+* .. External Subroutines ..
+ EXTERNAL SLARFB, SLARFT, SORGR2, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN
+* ..
+* .. External Functions ..
+ INTEGER ILAENV
+ EXTERNAL ILAENV
+* ..
+* .. Executable Statements ..
+*
+* Test the input arguments
+*
+ INFO = 0
+ LQUERY = ( LWORK.EQ.-1 )
+ IF( M.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( N.LT.M ) THEN
+ INFO = -2
+ ELSE IF( K.LT.0 .OR. K.GT.M ) THEN
+ INFO = -3
+ ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+ INFO = -5
+ END IF
+*
+ IF( INFO.EQ.0 ) THEN
+ IF( M.LE.0 ) THEN
+ LWKOPT = 1
+ ELSE
+ NB = ILAENV( 1, 'SORGRQ', ' ', M, N, K, -1 )
+ LWKOPT = M*NB
+ END IF
+ WORK( 1 ) = LWKOPT
+*
+ IF( LWORK.LT.MAX( 1, M ) .AND. .NOT.LQUERY ) THEN
+ INFO = -8
+ END IF
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SORGRQ', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( M.LE.0 ) THEN
+ RETURN
+ END IF
+*
+ NBMIN = 2
+ NX = 0
+ IWS = M
+ IF( NB.GT.1 .AND. NB.LT.K ) THEN
+*
+* Determine when to cross over from blocked to unblocked code.
+*
+ NX = MAX( 0, ILAENV( 3, 'SORGRQ', ' ', M, N, K, -1 ) )
+ IF( NX.LT.K ) THEN
+*
+* Determine if workspace is large enough for blocked code.
+*
+ LDWORK = M
+ IWS = LDWORK*NB
+ IF( LWORK.LT.IWS ) THEN
+*
+* Not enough workspace to use optimal NB: reduce NB and
+* determine the minimum value of NB.
+*
+ NB = LWORK / LDWORK
+ NBMIN = MAX( 2, ILAENV( 2, 'SORGRQ', ' ', M, N, K, -1 ) )
+ END IF
+ END IF
+ END IF
+*
+ IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN
+*
+* Use blocked code after the first block.
+* The last kk rows are handled by the block method.
+*
+ KK = MIN( K, ( ( K-NX+NB-1 ) / NB )*NB )
+*
+* Set A(1:m-kk,n-kk+1:n) to zero.
+*
+ DO 20 J = N - KK + 1, N
+ DO 10 I = 1, M - KK
+ A( I, J ) = ZERO
+ 10 CONTINUE
+ 20 CONTINUE
+ ELSE
+ KK = 0
+ END IF
+*
+* Use unblocked code for the first or only block.
+*
+ CALL SORGR2( M-KK, N-KK, K-KK, A, LDA, TAU, WORK, IINFO )
+*
+ IF( KK.GT.0 ) THEN
+*
+* Use blocked code
+*
+ DO 50 I = K - KK + 1, K, NB
+ IB = MIN( NB, K-I+1 )
+ II = M - K + I
+ IF( II.GT.1 ) THEN
+*
+* Form the triangular factor of the block reflector
+* H = H(i+ib-1) . . . H(i+1) H(i)
+*
+ CALL SLARFT( 'Backward', 'Rowwise', N-K+I+IB-1, IB,
+ $ A( II, 1 ), LDA, TAU( I ), WORK, LDWORK )
+*
+* Apply H' to A(1:m-k+i-1,1:n-k+i+ib-1) from the right
+*
+ CALL SLARFB( 'Right', 'Transpose', 'Backward', 'Rowwise',
+ $ II-1, N-K+I+IB-1, IB, A( II, 1 ), LDA, WORK,
+ $ LDWORK, A, LDA, WORK( IB+1 ), LDWORK )
+ END IF
+*
+* Apply H' to columns 1:n-k+i+ib-1 of current block
+*
+ CALL SORGR2( IB, N-K+I+IB-1, IB, A( II, 1 ), LDA, TAU( I ),
+ $ WORK, IINFO )
+*
+* Set columns n-k+i+ib:n of current block to zero
+*
+ DO 40 L = N - K + I + IB, N
+ DO 30 J = II, II + IB - 1
+ A( J, L ) = ZERO
+ 30 CONTINUE
+ 40 CONTINUE
+ 50 CONTINUE
+ END IF
+*
+ WORK( 1 ) = IWS
+ RETURN
+*
+* End of SORGRQ
+*
+ END
+ SUBROUTINE SORGTR( UPLO, N, A, LDA, TAU, WORK, LWORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, LDA, LWORK, N
+* ..
+* .. Array Arguments ..
+ REAL A( LDA, * ), TAU( * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SORGTR generates a real orthogonal matrix Q which is defined as the
+* product of n-1 elementary reflectors of order N, as returned by
+* SSYTRD:
+*
+* if UPLO = 'U', Q = H(n-1) . . . H(2) H(1),
+*
+* if UPLO = 'L', Q = H(1) H(2) . . . H(n-1).
+*
+* Arguments
+* =========
+*
+* UPLO (input) CHARACTER*1
+* = 'U': Upper triangle of A contains elementary reflectors
+* from SSYTRD;
+* = 'L': Lower triangle of A contains elementary reflectors
+* from SSYTRD.
+*
+* N (input) INTEGER
+* The order of the matrix Q. N >= 0.
+*
+* A (input/output) REAL array, dimension (LDA,N)
+* On entry, the vectors which define the elementary reflectors,
+* as returned by SSYTRD.
+* On exit, the N-by-N orthogonal matrix Q.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,N).
+*
+* TAU (input) REAL array, dimension (N-1)
+* TAU(i) must contain the scalar factor of the elementary
+* reflector H(i), as returned by SSYTRD.
+*
+* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))
+* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+* LWORK (input) INTEGER
+* The dimension of the array WORK. LWORK >= max(1,N-1).
+* For optimum performance LWORK >= (N-1)*NB, where NB is
+* the optimal blocksize.
+*
+* If LWORK = -1, then a workspace query is assumed; the routine
+* only calculates the optimal size of the WORK array, returns
+* this value as the first entry of the WORK array, and no error
+* message related to LWORK is issued by XERBLA.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO, ONE
+ PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL LQUERY, UPPER
+ INTEGER I, IINFO, J, LWKOPT, NB
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ILAENV
+ EXTERNAL ILAENV, LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL SORGQL, SORGQR, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input arguments
+*
+ INFO = 0
+ LQUERY = ( LWORK.EQ.-1 )
+ UPPER = LSAME( UPLO, 'U' )
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -4
+ ELSE IF( LWORK.LT.MAX( 1, N-1 ) .AND. .NOT.LQUERY ) THEN
+ INFO = -7
+ END IF
+*
+ IF( INFO.EQ.0 ) THEN
+ IF ( UPPER ) THEN
+ NB = ILAENV( 1, 'SORGQL', ' ', N-1, N-1, N-1, -1 )
+ ELSE
+ NB = ILAENV( 1, 'SORGQR', ' ', N-1, N-1, N-1, -1 )
+ END IF
+ LWKOPT = MAX( 1, N-1 )*NB
+ WORK( 1 ) = LWKOPT
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SORGTR', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 ) THEN
+ WORK( 1 ) = 1
+ RETURN
+ END IF
+*
+ IF( UPPER ) THEN
+*
+* Q was determined by a call to SSYTRD with UPLO = 'U'
+*
+* Shift the vectors which define the elementary reflectors one
+* column to the left, and set the last row and column of Q to
+* those of the unit matrix
+*
+ DO 20 J = 1, N - 1
+ DO 10 I = 1, J - 1
+ A( I, J ) = A( I, J+1 )
+ 10 CONTINUE
+ A( N, J ) = ZERO
+ 20 CONTINUE
+ DO 30 I = 1, N - 1
+ A( I, N ) = ZERO
+ 30 CONTINUE
+ A( N, N ) = ONE
+*
+* Generate Q(1:n-1,1:n-1)
+*
+ CALL SORGQL( N-1, N-1, N-1, A, LDA, TAU, WORK, LWORK, IINFO )
+*
+ ELSE
+*
+* Q was determined by a call to SSYTRD with UPLO = 'L'.
+*
+* Shift the vectors which define the elementary reflectors one
+* column to the right, and set the first row and column of Q to
+* those of the unit matrix
+*
+ DO 50 J = N, 2, -1
+ A( 1, J ) = ZERO
+ DO 40 I = J + 1, N
+ A( I, J ) = A( I, J-1 )
+ 40 CONTINUE
+ 50 CONTINUE
+ A( 1, 1 ) = ONE
+ DO 60 I = 2, N
+ A( I, 1 ) = ZERO
+ 60 CONTINUE
+ IF( N.GT.1 ) THEN
+*
+* Generate Q(2:n,2:n)
+*
+ CALL SORGQR( N-1, N-1, N-1, A( 2, 2 ), LDA, TAU, WORK,
+ $ LWORK, IINFO )
+ END IF
+ END IF
+ WORK( 1 ) = LWKOPT
+ RETURN
+*
+* End of SORGTR
+*
+ END
+ SUBROUTINE SORM2L( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
+ $ WORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER SIDE, TRANS
+ INTEGER INFO, K, LDA, LDC, M, N
+* ..
+* .. Array Arguments ..
+ REAL A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SORM2L overwrites the general real m by n matrix C with
+*
+* Q * C if SIDE = 'L' and TRANS = 'N', or
+*
+* Q'* C if SIDE = 'L' and TRANS = 'T', or
+*
+* C * Q if SIDE = 'R' and TRANS = 'N', or
+*
+* C * Q' if SIDE = 'R' and TRANS = 'T',
+*
+* where Q is a real orthogonal matrix defined as the product of k
+* elementary reflectors
+*
+* Q = H(k) . . . H(2) H(1)
+*
+* as returned by SGEQLF. Q is of order m if SIDE = 'L' and of order n
+* if SIDE = 'R'.
+*
+* Arguments
+* =========
+*
+* SIDE (input) CHARACTER*1
+* = 'L': apply Q or Q' from the Left
+* = 'R': apply Q or Q' from the Right
+*
+* TRANS (input) CHARACTER*1
+* = 'N': apply Q (No transpose)
+* = 'T': apply Q' (Transpose)
+*
+* M (input) INTEGER
+* The number of rows of the matrix C. M >= 0.
+*
+* N (input) INTEGER
+* The number of columns of the matrix C. N >= 0.
+*
+* K (input) INTEGER
+* The number of elementary reflectors whose product defines
+* the matrix Q.
+* If SIDE = 'L', M >= K >= 0;
+* if SIDE = 'R', N >= K >= 0.
+*
+* A (input) REAL array, dimension (LDA,K)
+* The i-th column must contain the vector which defines the
+* elementary reflector H(i), for i = 1,2,...,k, as returned by
+* SGEQLF in the last k columns of its array argument A.
+* A is modified by the routine but restored on exit.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A.
+* If SIDE = 'L', LDA >= max(1,M);
+* if SIDE = 'R', LDA >= max(1,N).
+*
+* TAU (input) REAL array, dimension (K)
+* TAU(i) must contain the scalar factor of the elementary
+* reflector H(i), as returned by SGEQLF.
+*
+* C (input/output) REAL array, dimension (LDC,N)
+* On entry, the m by n matrix C.
+* On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q.
+*
+* LDC (input) INTEGER
+* The leading dimension of the array C. LDC >= max(1,M).
+*
+* WORK (workspace) REAL array, dimension
+* (N) if SIDE = 'L',
+* (M) if SIDE = 'R'
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ONE
+ PARAMETER ( ONE = 1.0E+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL LEFT, NOTRAN
+ INTEGER I, I1, I2, I3, MI, NI, NQ
+ REAL AII
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL SLARF, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input arguments
+*
+ INFO = 0
+ LEFT = LSAME( SIDE, 'L' )
+ NOTRAN = LSAME( TRANS, 'N' )
+*
+* NQ is the order of Q
+*
+ IF( LEFT ) THEN
+ NQ = M
+ ELSE
+ NQ = N
+ END IF
+ IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN
+ INFO = -1
+ ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN
+ INFO = -2
+ ELSE IF( M.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN
+ INFO = -5
+ ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN
+ INFO = -7
+ ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
+ INFO = -10
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SORM2L', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 )
+ $ RETURN
+*
+ IF( ( LEFT .AND. NOTRAN ) .OR. ( .NOT.LEFT .AND. .NOT.NOTRAN ) )
+ $ THEN
+ I1 = 1
+ I2 = K
+ I3 = 1
+ ELSE
+ I1 = K
+ I2 = 1
+ I3 = -1
+ END IF
+*
+ IF( LEFT ) THEN
+ NI = N
+ ELSE
+ MI = M
+ END IF
+*
+ DO 10 I = I1, I2, I3
+ IF( LEFT ) THEN
+*
+* H(i) is applied to C(1:m-k+i,1:n)
+*
+ MI = M - K + I
+ ELSE
+*
+* H(i) is applied to C(1:m,1:n-k+i)
+*
+ NI = N - K + I
+ END IF
+*
+* Apply H(i)
+*
+ AII = A( NQ-K+I, I )
+ A( NQ-K+I, I ) = ONE
+ CALL SLARF( SIDE, MI, NI, A( 1, I ), 1, TAU( I ), C, LDC,
+ $ WORK )
+ A( NQ-K+I, I ) = AII
+ 10 CONTINUE
+ RETURN
+*
+* End of SORM2L
+*
+ END
+ SUBROUTINE SORM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
+ $ WORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER SIDE, TRANS
+ INTEGER INFO, K, LDA, LDC, M, N
+* ..
+* .. Array Arguments ..
+ REAL A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SORM2R overwrites the general real m by n matrix C with
+*
+* Q * C if SIDE = 'L' and TRANS = 'N', or
+*
+* Q'* C if SIDE = 'L' and TRANS = 'T', or
+*
+* C * Q if SIDE = 'R' and TRANS = 'N', or
+*
+* C * Q' if SIDE = 'R' and TRANS = 'T',
+*
+* where Q is a real orthogonal matrix defined as the product of k
+* elementary reflectors
+*
+* Q = H(1) H(2) . . . H(k)
+*
+* as returned by SGEQRF. Q is of order m if SIDE = 'L' and of order n
+* if SIDE = 'R'.
+*
+* Arguments
+* =========
+*
+* SIDE (input) CHARACTER*1
+* = 'L': apply Q or Q' from the Left
+* = 'R': apply Q or Q' from the Right
+*
+* TRANS (input) CHARACTER*1
+* = 'N': apply Q (No transpose)
+* = 'T': apply Q' (Transpose)
+*
+* M (input) INTEGER
+* The number of rows of the matrix C. M >= 0.
+*
+* N (input) INTEGER
+* The number of columns of the matrix C. N >= 0.
+*
+* K (input) INTEGER
+* The number of elementary reflectors whose product defines
+* the matrix Q.
+* If SIDE = 'L', M >= K >= 0;
+* if SIDE = 'R', N >= K >= 0.
+*
+* A (input) REAL array, dimension (LDA,K)
+* The i-th column must contain the vector which defines the
+* elementary reflector H(i), for i = 1,2,...,k, as returned by
+* SGEQRF in the first k columns of its array argument A.
+* A is modified by the routine but restored on exit.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A.
+* If SIDE = 'L', LDA >= max(1,M);
+* if SIDE = 'R', LDA >= max(1,N).
+*
+* TAU (input) REAL array, dimension (K)
+* TAU(i) must contain the scalar factor of the elementary
+* reflector H(i), as returned by SGEQRF.
+*
+* C (input/output) REAL array, dimension (LDC,N)
+* On entry, the m by n matrix C.
+* On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q.
+*
+* LDC (input) INTEGER
+* The leading dimension of the array C. LDC >= max(1,M).
+*
+* WORK (workspace) REAL array, dimension
+* (N) if SIDE = 'L',
+* (M) if SIDE = 'R'
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ONE
+ PARAMETER ( ONE = 1.0E+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL LEFT, NOTRAN
+ INTEGER I, I1, I2, I3, IC, JC, MI, NI, NQ
+ REAL AII
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL SLARF, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input arguments
+*
+ INFO = 0
+ LEFT = LSAME( SIDE, 'L' )
+ NOTRAN = LSAME( TRANS, 'N' )
+*
+* NQ is the order of Q
+*
+ IF( LEFT ) THEN
+ NQ = M
+ ELSE
+ NQ = N
+ END IF
+ IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN
+ INFO = -1
+ ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN
+ INFO = -2
+ ELSE IF( M.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN
+ INFO = -5
+ ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN
+ INFO = -7
+ ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
+ INFO = -10
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SORM2R', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 )
+ $ RETURN
+*
+ IF( ( LEFT .AND. .NOT.NOTRAN ) .OR. ( .NOT.LEFT .AND. NOTRAN ) )
+ $ THEN
+ I1 = 1
+ I2 = K
+ I3 = 1
+ ELSE
+ I1 = K
+ I2 = 1
+ I3 = -1
+ END IF
+*
+ IF( LEFT ) THEN
+ NI = N
+ JC = 1
+ ELSE
+ MI = M
+ IC = 1
+ END IF
+*
+ DO 10 I = I1, I2, I3
+ IF( LEFT ) THEN
+*
+* H(i) is applied to C(i:m,1:n)
+*
+ MI = M - I + 1
+ IC = I
+ ELSE
+*
+* H(i) is applied to C(1:m,i:n)
+*
+ NI = N - I + 1
+ JC = I
+ END IF
+*
+* Apply H(i)
+*
+ AII = A( I, I )
+ A( I, I ) = ONE
+ CALL SLARF( SIDE, MI, NI, A( I, I ), 1, TAU( I ), C( IC, JC ),
+ $ LDC, WORK )
+ A( I, I ) = AII
+ 10 CONTINUE
+ RETURN
+*
+* End of SORM2R
+*
+ END
+ SUBROUTINE SORMBR( VECT, SIDE, TRANS, M, N, K, A, LDA, TAU, C,
+ $ LDC, WORK, LWORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER SIDE, TRANS, VECT
+ INTEGER INFO, K, LDA, LDC, LWORK, M, N
+* ..
+* .. Array Arguments ..
+ REAL A( LDA, * ), C( LDC, * ), TAU( * ),
+ $ WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* If VECT = 'Q', SORMBR overwrites the general real M-by-N matrix C
+* with
+* SIDE = 'L' SIDE = 'R'
+* TRANS = 'N': Q * C C * Q
+* TRANS = 'T': Q**T * C C * Q**T
+*
+* If VECT = 'P', SORMBR overwrites the general real M-by-N matrix C
+* with
+* SIDE = 'L' SIDE = 'R'
+* TRANS = 'N': P * C C * P
+* TRANS = 'T': P**T * C C * P**T
+*
+* Here Q and P**T are the orthogonal matrices determined by SGEBRD when
+* reducing a real matrix A to bidiagonal form: A = Q * B * P**T. Q and
+* P**T are defined as products of elementary reflectors H(i) and G(i)
+* respectively.
+*
+* Let nq = m if SIDE = 'L' and nq = n if SIDE = 'R'. Thus nq is the
+* order of the orthogonal matrix Q or P**T that is applied.
+*
+* If VECT = 'Q', A is assumed to have been an NQ-by-K matrix:
+* if nq >= k, Q = H(1) H(2) . . . H(k);
+* if nq < k, Q = H(1) H(2) . . . H(nq-1).
+*
+* If VECT = 'P', A is assumed to have been a K-by-NQ matrix:
+* if k < nq, P = G(1) G(2) . . . G(k);
+* if k >= nq, P = G(1) G(2) . . . G(nq-1).
+*
+* Arguments
+* =========
+*
+* VECT (input) CHARACTER*1
+* = 'Q': apply Q or Q**T;
+* = 'P': apply P or P**T.
+*
+* SIDE (input) CHARACTER*1
+* = 'L': apply Q, Q**T, P or P**T from the Left;
+* = 'R': apply Q, Q**T, P or P**T from the Right.
+*
+* TRANS (input) CHARACTER*1
+* = 'N': No transpose, apply Q or P;
+* = 'T': Transpose, apply Q**T or P**T.
+*
+* M (input) INTEGER
+* The number of rows of the matrix C. M >= 0.
+*
+* N (input) INTEGER
+* The number of columns of the matrix C. N >= 0.
+*
+* K (input) INTEGER
+* If VECT = 'Q', the number of columns in the original
+* matrix reduced by SGEBRD.
+* If VECT = 'P', the number of rows in the original
+* matrix reduced by SGEBRD.
+* K >= 0.
+*
+* A (input) REAL array, dimension
+* (LDA,min(nq,K)) if VECT = 'Q'
+* (LDA,nq) if VECT = 'P'
+* The vectors which define the elementary reflectors H(i) and
+* G(i), whose products determine the matrices Q and P, as
+* returned by SGEBRD.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A.
+* If VECT = 'Q', LDA >= max(1,nq);
+* if VECT = 'P', LDA >= max(1,min(nq,K)).
+*
+* TAU (input) REAL array, dimension (min(nq,K))
+* TAU(i) must contain the scalar factor of the elementary
+* reflector H(i) or G(i) which determines Q or P, as returned
+* by SGEBRD in the array argument TAUQ or TAUP.
+*
+* C (input/output) REAL array, dimension (LDC,N)
+* On entry, the M-by-N matrix C.
+* On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q
+* or P*C or P**T*C or C*P or C*P**T.
+*
+* LDC (input) INTEGER
+* The leading dimension of the array C. LDC >= max(1,M).
+*
+* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))
+* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+* LWORK (input) INTEGER
+* The dimension of the array WORK.
+* If SIDE = 'L', LWORK >= max(1,N);
+* if SIDE = 'R', LWORK >= max(1,M).
+* For optimum performance LWORK >= N*NB if SIDE = 'L', and
+* LWORK >= M*NB if SIDE = 'R', where NB is the optimal
+* blocksize.
+*
+* If LWORK = -1, then a workspace query is assumed; the routine
+* only calculates the optimal size of the WORK array, returns
+* this value as the first entry of the WORK array, and no error
+* message related to LWORK is issued by XERBLA.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ LOGICAL APPLYQ, LEFT, LQUERY, NOTRAN
+ CHARACTER TRANST
+ INTEGER I1, I2, IINFO, LWKOPT, MI, NB, NI, NQ, NW
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ILAENV
+ EXTERNAL ILAENV, LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL SORMLQ, SORMQR, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+* Test the input arguments
+*
+ INFO = 0
+ APPLYQ = LSAME( VECT, 'Q' )
+ LEFT = LSAME( SIDE, 'L' )
+ NOTRAN = LSAME( TRANS, 'N' )
+ LQUERY = ( LWORK.EQ.-1 )
+*
+* NQ is the order of Q or P and NW is the minimum dimension of WORK
+*
+ IF( LEFT ) THEN
+ NQ = M
+ NW = N
+ ELSE
+ NQ = N
+ NW = M
+ END IF
+ IF( .NOT.APPLYQ .AND. .NOT.LSAME( VECT, 'P' ) ) THEN
+ INFO = -1
+ ELSE IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN
+ INFO = -2
+ ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN
+ INFO = -3
+ ELSE IF( M.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -5
+ ELSE IF( K.LT.0 ) THEN
+ INFO = -6
+ ELSE IF( ( APPLYQ .AND. LDA.LT.MAX( 1, NQ ) ) .OR.
+ $ ( .NOT.APPLYQ .AND. LDA.LT.MAX( 1, MIN( NQ, K ) ) ) )
+ $ THEN
+ INFO = -8
+ ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
+ INFO = -11
+ ELSE IF( LWORK.LT.MAX( 1, NW ) .AND. .NOT.LQUERY ) THEN
+ INFO = -13
+ END IF
+*
+ IF( INFO.EQ.0 ) THEN
+ IF( APPLYQ ) THEN
+ IF( LEFT ) THEN
+ NB = ILAENV( 1, 'SORMQR', SIDE // TRANS, M-1, N, M-1,
+ $ -1 )
+ ELSE
+ NB = ILAENV( 1, 'SORMQR', SIDE // TRANS, M, N-1, N-1,
+ $ -1 )
+ END IF
+ ELSE
+ IF( LEFT ) THEN
+ NB = ILAENV( 1, 'SORMLQ', SIDE // TRANS, M-1, N, M-1,
+ $ -1 )
+ ELSE
+ NB = ILAENV( 1, 'SORMLQ', SIDE // TRANS, M, N-1, N-1,
+ $ -1 )
+ END IF
+ END IF
+ LWKOPT = MAX( 1, NW )*NB
+ WORK( 1 ) = LWKOPT
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SORMBR', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ WORK( 1 ) = 1
+ IF( M.EQ.0 .OR. N.EQ.0 )
+ $ RETURN
+*
+ IF( APPLYQ ) THEN
+*
+* Apply Q
+*
+ IF( NQ.GE.K ) THEN
+*
+* Q was determined by a call to SGEBRD with nq >= k
+*
+ CALL SORMQR( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
+ $ WORK, LWORK, IINFO )
+ ELSE IF( NQ.GT.1 ) THEN
+*
+* Q was determined by a call to SGEBRD with nq < k
+*
+ IF( LEFT ) THEN
+ MI = M - 1
+ NI = N
+ I1 = 2
+ I2 = 1
+ ELSE
+ MI = M
+ NI = N - 1
+ I1 = 1
+ I2 = 2
+ END IF
+ CALL SORMQR( SIDE, TRANS, MI, NI, NQ-1, A( 2, 1 ), LDA, TAU,
+ $ C( I1, I2 ), LDC, WORK, LWORK, IINFO )
+ END IF
+ ELSE
+*
+* Apply P
+*
+ IF( NOTRAN ) THEN
+ TRANST = 'T'
+ ELSE
+ TRANST = 'N'
+ END IF
+ IF( NQ.GT.K ) THEN
+*
+* P was determined by a call to SGEBRD with nq > k
+*
+ CALL SORMLQ( SIDE, TRANST, M, N, K, A, LDA, TAU, C, LDC,
+ $ WORK, LWORK, IINFO )
+ ELSE IF( NQ.GT.1 ) THEN
+*
+* P was determined by a call to SGEBRD with nq <= k
+*
+ IF( LEFT ) THEN
+ MI = M - 1
+ NI = N
+ I1 = 2
+ I2 = 1
+ ELSE
+ MI = M
+ NI = N - 1
+ I1 = 1
+ I2 = 2
+ END IF
+ CALL SORMLQ( SIDE, TRANST, MI, NI, NQ-1, A( 1, 2 ), LDA,
+ $ TAU, C( I1, I2 ), LDC, WORK, LWORK, IINFO )
+ END IF
+ END IF
+ WORK( 1 ) = LWKOPT
+ RETURN
+*
+* End of SORMBR
+*
+ END
+ SUBROUTINE SORMHR( SIDE, TRANS, M, N, ILO, IHI, A, LDA, TAU, C,
+ $ LDC, WORK, LWORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER SIDE, TRANS
+ INTEGER IHI, ILO, INFO, LDA, LDC, LWORK, M, N
+* ..
+* .. Array Arguments ..
+ REAL A( LDA, * ), C( LDC, * ), TAU( * ),
+ $ WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SORMHR overwrites the general real M-by-N matrix C with
+*
+* SIDE = 'L' SIDE = 'R'
+* TRANS = 'N': Q * C C * Q
+* TRANS = 'T': Q**T * C C * Q**T
+*
+* where Q is a real orthogonal matrix of order nq, with nq = m if
+* SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of
+* IHI-ILO elementary reflectors, as returned by SGEHRD:
+*
+* Q = H(ilo) H(ilo+1) . . . H(ihi-1).
+*
+* Arguments
+* =========
+*
+* SIDE (input) CHARACTER*1
+* = 'L': apply Q or Q**T from the Left;
+* = 'R': apply Q or Q**T from the Right.
+*
+* TRANS (input) CHARACTER*1
+* = 'N': No transpose, apply Q;
+* = 'T': Transpose, apply Q**T.
+*
+* M (input) INTEGER
+* The number of rows of the matrix C. M >= 0.
+*
+* N (input) INTEGER
+* The number of columns of the matrix C. N >= 0.
+*
+* ILO (input) INTEGER
+* IHI (input) INTEGER
+* ILO and IHI must have the same values as in the previous call
+* of SGEHRD. Q is equal to the unit matrix except in the
+* submatrix Q(ilo+1:ihi,ilo+1:ihi).
+* If SIDE = 'L', then 1 <= ILO <= IHI <= M, if M > 0, and
+* ILO = 1 and IHI = 0, if M = 0;
+* if SIDE = 'R', then 1 <= ILO <= IHI <= N, if N > 0, and
+* ILO = 1 and IHI = 0, if N = 0.
+*
+* A (input) REAL array, dimension
+* (LDA,M) if SIDE = 'L'
+* (LDA,N) if SIDE = 'R'
+* The vectors which define the elementary reflectors, as
+* returned by SGEHRD.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A.
+* LDA >= max(1,M) if SIDE = 'L'; LDA >= max(1,N) if SIDE = 'R'.
+*
+* TAU (input) REAL array, dimension
+* (M-1) if SIDE = 'L'
+* (N-1) if SIDE = 'R'
+* TAU(i) must contain the scalar factor of the elementary
+* reflector H(i), as returned by SGEHRD.
+*
+* C (input/output) REAL array, dimension (LDC,N)
+* On entry, the M-by-N matrix C.
+* On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q.
+*
+* LDC (input) INTEGER
+* The leading dimension of the array C. LDC >= max(1,M).
+*
+* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))
+* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+* LWORK (input) INTEGER
+* The dimension of the array WORK.
+* If SIDE = 'L', LWORK >= max(1,N);
+* if SIDE = 'R', LWORK >= max(1,M).
+* For optimum performance LWORK >= N*NB if SIDE = 'L', and
+* LWORK >= M*NB if SIDE = 'R', where NB is the optimal
+* blocksize.
+*
+* If LWORK = -1, then a workspace query is assumed; the routine
+* only calculates the optimal size of the WORK array, returns
+* this value as the first entry of the WORK array, and no error
+* message related to LWORK is issued by XERBLA.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ LOGICAL LEFT, LQUERY
+ INTEGER I1, I2, IINFO, LWKOPT, MI, NB, NH, NI, NQ, NW
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ILAENV
+ EXTERNAL ILAENV, LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL SORMQR, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+* Test the input arguments
+*
+ INFO = 0
+ NH = IHI - ILO
+ LEFT = LSAME( SIDE, 'L' )
+ LQUERY = ( LWORK.EQ.-1 )
+*
+* NQ is the order of Q and NW is the minimum dimension of WORK
+*
+ IF( LEFT ) THEN
+ NQ = M
+ NW = N
+ ELSE
+ NQ = N
+ NW = M
+ END IF
+ IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN
+ INFO = -1
+ ELSE IF( .NOT.LSAME( TRANS, 'N' ) .AND. .NOT.LSAME( TRANS, 'T' ) )
+ $ THEN
+ INFO = -2
+ ELSE IF( M.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( ILO.LT.1 .OR. ILO.GT.MAX( 1, NQ ) ) THEN
+ INFO = -5
+ ELSE IF( IHI.LT.MIN( ILO, NQ ) .OR. IHI.GT.NQ ) THEN
+ INFO = -6
+ ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN
+ INFO = -8
+ ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
+ INFO = -11
+ ELSE IF( LWORK.LT.MAX( 1, NW ) .AND. .NOT.LQUERY ) THEN
+ INFO = -13
+ END IF
+*
+ IF( INFO.EQ.0 ) THEN
+ IF( LEFT ) THEN
+ NB = ILAENV( 1, 'SORMQR', SIDE // TRANS, NH, N, NH, -1 )
+ ELSE
+ NB = ILAENV( 1, 'SORMQR', SIDE // TRANS, M, NH, NH, -1 )
+ END IF
+ LWKOPT = MAX( 1, NW )*NB
+ WORK( 1 ) = LWKOPT
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SORMHR', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( M.EQ.0 .OR. N.EQ.0 .OR. NH.EQ.0 ) THEN
+ WORK( 1 ) = 1
+ RETURN
+ END IF
+*
+ IF( LEFT ) THEN
+ MI = NH
+ NI = N
+ I1 = ILO + 1
+ I2 = 1
+ ELSE
+ MI = M
+ NI = NH
+ I1 = 1
+ I2 = ILO + 1
+ END IF
+*
+ CALL SORMQR( SIDE, TRANS, MI, NI, NH, A( ILO+1, ILO ), LDA,
+ $ TAU( ILO ), C( I1, I2 ), LDC, WORK, LWORK, IINFO )
+*
+ WORK( 1 ) = LWKOPT
+ RETURN
+*
+* End of SORMHR
+*
+ END
+ SUBROUTINE SORML2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
+ $ WORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER SIDE, TRANS
+ INTEGER INFO, K, LDA, LDC, M, N
+* ..
+* .. Array Arguments ..
+ REAL A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SORML2 overwrites the general real m by n matrix C with
+*
+* Q * C if SIDE = 'L' and TRANS = 'N', or
+*
+* Q'* C if SIDE = 'L' and TRANS = 'T', or
+*
+* C * Q if SIDE = 'R' and TRANS = 'N', or
+*
+* C * Q' if SIDE = 'R' and TRANS = 'T',
+*
+* where Q is a real orthogonal matrix defined as the product of k
+* elementary reflectors
+*
+* Q = H(k) . . . H(2) H(1)
+*
+* as returned by SGELQF. Q is of order m if SIDE = 'L' and of order n
+* if SIDE = 'R'.
+*
+* Arguments
+* =========
+*
+* SIDE (input) CHARACTER*1
+* = 'L': apply Q or Q' from the Left
+* = 'R': apply Q or Q' from the Right
+*
+* TRANS (input) CHARACTER*1
+* = 'N': apply Q (No transpose)
+* = 'T': apply Q' (Transpose)
+*
+* M (input) INTEGER
+* The number of rows of the matrix C. M >= 0.
+*
+* N (input) INTEGER
+* The number of columns of the matrix C. N >= 0.
+*
+* K (input) INTEGER
+* The number of elementary reflectors whose product defines
+* the matrix Q.
+* If SIDE = 'L', M >= K >= 0;
+* if SIDE = 'R', N >= K >= 0.
+*
+* A (input) REAL array, dimension
+* (LDA,M) if SIDE = 'L',
+* (LDA,N) if SIDE = 'R'
+* The i-th row must contain the vector which defines the
+* elementary reflector H(i), for i = 1,2,...,k, as returned by
+* SGELQF in the first k rows of its array argument A.
+* A is modified by the routine but restored on exit.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,K).
+*
+* TAU (input) REAL array, dimension (K)
+* TAU(i) must contain the scalar factor of the elementary
+* reflector H(i), as returned by SGELQF.
+*
+* C (input/output) REAL array, dimension (LDC,N)
+* On entry, the m by n matrix C.
+* On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q.
+*
+* LDC (input) INTEGER
+* The leading dimension of the array C. LDC >= max(1,M).
+*
+* WORK (workspace) REAL array, dimension
+* (N) if SIDE = 'L',
+* (M) if SIDE = 'R'
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ONE
+ PARAMETER ( ONE = 1.0E+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL LEFT, NOTRAN
+ INTEGER I, I1, I2, I3, IC, JC, MI, NI, NQ
+ REAL AII
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL SLARF, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input arguments
+*
+ INFO = 0
+ LEFT = LSAME( SIDE, 'L' )
+ NOTRAN = LSAME( TRANS, 'N' )
+*
+* NQ is the order of Q
+*
+ IF( LEFT ) THEN
+ NQ = M
+ ELSE
+ NQ = N
+ END IF
+ IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN
+ INFO = -1
+ ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN
+ INFO = -2
+ ELSE IF( M.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN
+ INFO = -5
+ ELSE IF( LDA.LT.MAX( 1, K ) ) THEN
+ INFO = -7
+ ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
+ INFO = -10
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SORML2', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 )
+ $ RETURN
+*
+ IF( ( LEFT .AND. NOTRAN ) .OR. ( .NOT.LEFT .AND. .NOT.NOTRAN ) )
+ $ THEN
+ I1 = 1
+ I2 = K
+ I3 = 1
+ ELSE
+ I1 = K
+ I2 = 1
+ I3 = -1
+ END IF
+*
+ IF( LEFT ) THEN
+ NI = N
+ JC = 1
+ ELSE
+ MI = M
+ IC = 1
+ END IF
+*
+ DO 10 I = I1, I2, I3
+ IF( LEFT ) THEN
+*
+* H(i) is applied to C(i:m,1:n)
+*
+ MI = M - I + 1
+ IC = I
+ ELSE
+*
+* H(i) is applied to C(1:m,i:n)
+*
+ NI = N - I + 1
+ JC = I
+ END IF
+*
+* Apply H(i)
+*
+ AII = A( I, I )
+ A( I, I ) = ONE
+ CALL SLARF( SIDE, MI, NI, A( I, I ), LDA, TAU( I ),
+ $ C( IC, JC ), LDC, WORK )
+ A( I, I ) = AII
+ 10 CONTINUE
+ RETURN
+*
+* End of SORML2
+*
+ END
+ SUBROUTINE SORMLQ( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
+ $ WORK, LWORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER SIDE, TRANS
+ INTEGER INFO, K, LDA, LDC, LWORK, M, N
+* ..
+* .. Array Arguments ..
+ REAL A( LDA, * ), C( LDC, * ), TAU( * ),
+ $ WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SORMLQ overwrites the general real M-by-N matrix C with
+*
+* SIDE = 'L' SIDE = 'R'
+* TRANS = 'N': Q * C C * Q
+* TRANS = 'T': Q**T * C C * Q**T
+*
+* where Q is a real orthogonal matrix defined as the product of k
+* elementary reflectors
+*
+* Q = H(k) . . . H(2) H(1)
+*
+* as returned by SGELQF. Q is of order M if SIDE = 'L' and of order N
+* if SIDE = 'R'.
+*
+* Arguments
+* =========
+*
+* SIDE (input) CHARACTER*1
+* = 'L': apply Q or Q**T from the Left;
+* = 'R': apply Q or Q**T from the Right.
+*
+* TRANS (input) CHARACTER*1
+* = 'N': No transpose, apply Q;
+* = 'T': Transpose, apply Q**T.
+*
+* M (input) INTEGER
+* The number of rows of the matrix C. M >= 0.
+*
+* N (input) INTEGER
+* The number of columns of the matrix C. N >= 0.
+*
+* K (input) INTEGER
+* The number of elementary reflectors whose product defines
+* the matrix Q.
+* If SIDE = 'L', M >= K >= 0;
+* if SIDE = 'R', N >= K >= 0.
+*
+* A (input) REAL array, dimension
+* (LDA,M) if SIDE = 'L',
+* (LDA,N) if SIDE = 'R'
+* The i-th row must contain the vector which defines the
+* elementary reflector H(i), for i = 1,2,...,k, as returned by
+* SGELQF in the first k rows of its array argument A.
+* A is modified by the routine but restored on exit.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,K).
+*
+* TAU (input) REAL array, dimension (K)
+* TAU(i) must contain the scalar factor of the elementary
+* reflector H(i), as returned by SGELQF.
+*
+* C (input/output) REAL array, dimension (LDC,N)
+* On entry, the M-by-N matrix C.
+* On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q.
+*
+* LDC (input) INTEGER
+* The leading dimension of the array C. LDC >= max(1,M).
+*
+* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))
+* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+* LWORK (input) INTEGER
+* The dimension of the array WORK.
+* If SIDE = 'L', LWORK >= max(1,N);
+* if SIDE = 'R', LWORK >= max(1,M).
+* For optimum performance LWORK >= N*NB if SIDE = 'L', and
+* LWORK >= M*NB if SIDE = 'R', where NB is the optimal
+* blocksize.
+*
+* If LWORK = -1, then a workspace query is assumed; the routine
+* only calculates the optimal size of the WORK array, returns
+* this value as the first entry of the WORK array, and no error
+* message related to LWORK is issued by XERBLA.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+*
+* =====================================================================
+*
+* .. Parameters ..
+ INTEGER NBMAX, LDT
+ PARAMETER ( NBMAX = 64, LDT = NBMAX+1 )
+* ..
+* .. Local Scalars ..
+ LOGICAL LEFT, LQUERY, NOTRAN
+ CHARACTER TRANST
+ INTEGER I, I1, I2, I3, IB, IC, IINFO, IWS, JC, LDWORK,
+ $ LWKOPT, MI, NB, NBMIN, NI, NQ, NW
+* ..
+* .. Local Arrays ..
+ REAL T( LDT, NBMAX )
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ILAENV
+ EXTERNAL LSAME, ILAENV
+* ..
+* .. External Subroutines ..
+ EXTERNAL SLARFB, SLARFT, SORML2, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+* Test the input arguments
+*
+ INFO = 0
+ LEFT = LSAME( SIDE, 'L' )
+ NOTRAN = LSAME( TRANS, 'N' )
+ LQUERY = ( LWORK.EQ.-1 )
+*
+* NQ is the order of Q and NW is the minimum dimension of WORK
+*
+ IF( LEFT ) THEN
+ NQ = M
+ NW = N
+ ELSE
+ NQ = N
+ NW = M
+ END IF
+ IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN
+ INFO = -1
+ ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN
+ INFO = -2
+ ELSE IF( M.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN
+ INFO = -5
+ ELSE IF( LDA.LT.MAX( 1, K ) ) THEN
+ INFO = -7
+ ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
+ INFO = -10
+ ELSE IF( LWORK.LT.MAX( 1, NW ) .AND. .NOT.LQUERY ) THEN
+ INFO = -12
+ END IF
+*
+ IF( INFO.EQ.0 ) THEN
+*
+* Determine the block size. NB may be at most NBMAX, where NBMAX
+* is used to define the local array T.
+*
+ NB = MIN( NBMAX, ILAENV( 1, 'SORMLQ', SIDE // TRANS, M, N, K,
+ $ -1 ) )
+ LWKOPT = MAX( 1, NW )*NB
+ WORK( 1 ) = LWKOPT
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SORMLQ', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) THEN
+ WORK( 1 ) = 1
+ RETURN
+ END IF
+*
+ NBMIN = 2
+ LDWORK = NW
+ IF( NB.GT.1 .AND. NB.LT.K ) THEN
+ IWS = NW*NB
+ IF( LWORK.LT.IWS ) THEN
+ NB = LWORK / LDWORK
+ NBMIN = MAX( 2, ILAENV( 2, 'SORMLQ', SIDE // TRANS, M, N, K,
+ $ -1 ) )
+ END IF
+ ELSE
+ IWS = NW
+ END IF
+*
+ IF( NB.LT.NBMIN .OR. NB.GE.K ) THEN
+*
+* Use unblocked code
+*
+ CALL SORML2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK,
+ $ IINFO )
+ ELSE
+*
+* Use blocked code
+*
+ IF( ( LEFT .AND. NOTRAN ) .OR.
+ $ ( .NOT.LEFT .AND. .NOT.NOTRAN ) ) THEN
+ I1 = 1
+ I2 = K
+ I3 = NB
+ ELSE
+ I1 = ( ( K-1 ) / NB )*NB + 1
+ I2 = 1
+ I3 = -NB
+ END IF
+*
+ IF( LEFT ) THEN
+ NI = N
+ JC = 1
+ ELSE
+ MI = M
+ IC = 1
+ END IF
+*
+ IF( NOTRAN ) THEN
+ TRANST = 'T'
+ ELSE
+ TRANST = 'N'
+ END IF
+*
+ DO 10 I = I1, I2, I3
+ IB = MIN( NB, K-I+1 )
+*
+* Form the triangular factor of the block reflector
+* H = H(i) H(i+1) . . . H(i+ib-1)
+*
+ CALL SLARFT( 'Forward', 'Rowwise', NQ-I+1, IB, A( I, I ),
+ $ LDA, TAU( I ), T, LDT )
+ IF( LEFT ) THEN
+*
+* H or H' is applied to C(i:m,1:n)
+*
+ MI = M - I + 1
+ IC = I
+ ELSE
+*
+* H or H' is applied to C(1:m,i:n)
+*
+ NI = N - I + 1
+ JC = I
+ END IF
+*
+* Apply H or H'
+*
+ CALL SLARFB( SIDE, TRANST, 'Forward', 'Rowwise', MI, NI, IB,
+ $ A( I, I ), LDA, T, LDT, C( IC, JC ), LDC, WORK,
+ $ LDWORK )
+ 10 CONTINUE
+ END IF
+ WORK( 1 ) = LWKOPT
+ RETURN
+*
+* End of SORMLQ
+*
+ END
+ SUBROUTINE SORMQL( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
+ $ WORK, LWORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER SIDE, TRANS
+ INTEGER INFO, K, LDA, LDC, LWORK, M, N
+* ..
+* .. Array Arguments ..
+ REAL A( LDA, * ), C( LDC, * ), TAU( * ),
+ $ WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SORMQL overwrites the general real M-by-N matrix C with
+*
+* SIDE = 'L' SIDE = 'R'
+* TRANS = 'N': Q * C C * Q
+* TRANS = 'T': Q**T * C C * Q**T
+*
+* where Q is a real orthogonal matrix defined as the product of k
+* elementary reflectors
+*
+* Q = H(k) . . . H(2) H(1)
+*
+* as returned by SGEQLF. Q is of order M if SIDE = 'L' and of order N
+* if SIDE = 'R'.
+*
+* Arguments
+* =========
+*
+* SIDE (input) CHARACTER*1
+* = 'L': apply Q or Q**T from the Left;
+* = 'R': apply Q or Q**T from the Right.
+*
+* TRANS (input) CHARACTER*1
+* = 'N': No transpose, apply Q;
+* = 'T': Transpose, apply Q**T.
+*
+* M (input) INTEGER
+* The number of rows of the matrix C. M >= 0.
+*
+* N (input) INTEGER
+* The number of columns of the matrix C. N >= 0.
+*
+* K (input) INTEGER
+* The number of elementary reflectors whose product defines
+* the matrix Q.
+* If SIDE = 'L', M >= K >= 0;
+* if SIDE = 'R', N >= K >= 0.
+*
+* A (input) REAL array, dimension (LDA,K)
+* The i-th column must contain the vector which defines the
+* elementary reflector H(i), for i = 1,2,...,k, as returned by
+* SGEQLF in the last k columns of its array argument A.
+* A is modified by the routine but restored on exit.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A.
+* If SIDE = 'L', LDA >= max(1,M);
+* if SIDE = 'R', LDA >= max(1,N).
+*
+* TAU (input) REAL array, dimension (K)
+* TAU(i) must contain the scalar factor of the elementary
+* reflector H(i), as returned by SGEQLF.
+*
+* C (input/output) REAL array, dimension (LDC,N)
+* On entry, the M-by-N matrix C.
+* On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q.
+*
+* LDC (input) INTEGER
+* The leading dimension of the array C. LDC >= max(1,M).
+*
+* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))
+* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+* LWORK (input) INTEGER
+* The dimension of the array WORK.
+* If SIDE = 'L', LWORK >= max(1,N);
+* if SIDE = 'R', LWORK >= max(1,M).
+* For optimum performance LWORK >= N*NB if SIDE = 'L', and
+* LWORK >= M*NB if SIDE = 'R', where NB is the optimal
+* blocksize.
+*
+* If LWORK = -1, then a workspace query is assumed; the routine
+* only calculates the optimal size of the WORK array, returns
+* this value as the first entry of the WORK array, and no error
+* message related to LWORK is issued by XERBLA.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+*
+* =====================================================================
+*
+* .. Parameters ..
+ INTEGER NBMAX, LDT
+ PARAMETER ( NBMAX = 64, LDT = NBMAX+1 )
+* ..
+* .. Local Scalars ..
+ LOGICAL LEFT, LQUERY, NOTRAN
+ INTEGER I, I1, I2, I3, IB, IINFO, IWS, LDWORK, LWKOPT,
+ $ MI, NB, NBMIN, NI, NQ, NW
+* ..
+* .. Local Arrays ..
+ REAL T( LDT, NBMAX )
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ILAENV
+ EXTERNAL LSAME, ILAENV
+* ..
+* .. External Subroutines ..
+ EXTERNAL SLARFB, SLARFT, SORM2L, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+* Test the input arguments
+*
+ INFO = 0
+ LEFT = LSAME( SIDE, 'L' )
+ NOTRAN = LSAME( TRANS, 'N' )
+ LQUERY = ( LWORK.EQ.-1 )
+*
+* NQ is the order of Q and NW is the minimum dimension of WORK
+*
+ IF( LEFT ) THEN
+ NQ = M
+ NW = MAX( 1, N )
+ ELSE
+ NQ = N
+ NW = MAX( 1, M )
+ END IF
+ IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN
+ INFO = -1
+ ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN
+ INFO = -2
+ ELSE IF( M.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN
+ INFO = -5
+ ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN
+ INFO = -7
+ ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
+ INFO = -10
+ END IF
+*
+ IF( INFO.EQ.0 ) THEN
+ IF( M.EQ.0 .OR. N.EQ.0 ) THEN
+ LWKOPT = 1
+ ELSE
+*
+* Determine the block size. NB may be at most NBMAX, where
+* NBMAX is used to define the local array T.
+*
+*
+ NB = MIN( NBMAX, ILAENV( 1, 'SORMQL', SIDE // TRANS, M, N,
+ $ K, -1 ) )
+ LWKOPT = NW*NB
+ END IF
+ WORK( 1 ) = LWKOPT
+*
+ IF( LWORK.LT.NW .AND. .NOT.LQUERY ) THEN
+ INFO = -12
+ END IF
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SORMQL', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( M.EQ.0 .OR. N.EQ.0 ) THEN
+ RETURN
+ END IF
+*
+ NBMIN = 2
+ LDWORK = NW
+ IF( NB.GT.1 .AND. NB.LT.K ) THEN
+ IWS = NW*NB
+ IF( LWORK.LT.IWS ) THEN
+ NB = LWORK / LDWORK
+ NBMIN = MAX( 2, ILAENV( 2, 'SORMQL', SIDE // TRANS, M, N, K,
+ $ -1 ) )
+ END IF
+ ELSE
+ IWS = NW
+ END IF
+*
+ IF( NB.LT.NBMIN .OR. NB.GE.K ) THEN
+*
+* Use unblocked code
+*
+ CALL SORM2L( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK,
+ $ IINFO )
+ ELSE
+*
+* Use blocked code
+*
+ IF( ( LEFT .AND. NOTRAN ) .OR.
+ $ ( .NOT.LEFT .AND. .NOT.NOTRAN ) ) THEN
+ I1 = 1
+ I2 = K
+ I3 = NB
+ ELSE
+ I1 = ( ( K-1 ) / NB )*NB + 1
+ I2 = 1
+ I3 = -NB
+ END IF
+*
+ IF( LEFT ) THEN
+ NI = N
+ ELSE
+ MI = M
+ END IF
+*
+ DO 10 I = I1, I2, I3
+ IB = MIN( NB, K-I+1 )
+*
+* Form the triangular factor of the block reflector
+* H = H(i+ib-1) . . . H(i+1) H(i)
+*
+ CALL SLARFT( 'Backward', 'Columnwise', NQ-K+I+IB-1, IB,
+ $ A( 1, I ), LDA, TAU( I ), T, LDT )
+ IF( LEFT ) THEN
+*
+* H or H' is applied to C(1:m-k+i+ib-1,1:n)
+*
+ MI = M - K + I + IB - 1
+ ELSE
+*
+* H or H' is applied to C(1:m,1:n-k+i+ib-1)
+*
+ NI = N - K + I + IB - 1
+ END IF
+*
+* Apply H or H'
+*
+ CALL SLARFB( SIDE, TRANS, 'Backward', 'Columnwise', MI, NI,
+ $ IB, A( 1, I ), LDA, T, LDT, C, LDC, WORK,
+ $ LDWORK )
+ 10 CONTINUE
+ END IF
+ WORK( 1 ) = LWKOPT
+ RETURN
+*
+* End of SORMQL
+*
+ END
+ SUBROUTINE SORMQR( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
+ $ WORK, LWORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER SIDE, TRANS
+ INTEGER INFO, K, LDA, LDC, LWORK, M, N
+* ..
+* .. Array Arguments ..
+ REAL A( LDA, * ), C( LDC, * ), TAU( * ),
+ $ WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SORMQR overwrites the general real M-by-N matrix C with
+*
+* SIDE = 'L' SIDE = 'R'
+* TRANS = 'N': Q * C C * Q
+* TRANS = 'T': Q**T * C C * Q**T
+*
+* where Q is a real orthogonal matrix defined as the product of k
+* elementary reflectors
+*
+* Q = H(1) H(2) . . . H(k)
+*
+* as returned by SGEQRF. Q is of order M if SIDE = 'L' and of order N
+* if SIDE = 'R'.
+*
+* Arguments
+* =========
+*
+* SIDE (input) CHARACTER*1
+* = 'L': apply Q or Q**T from the Left;
+* = 'R': apply Q or Q**T from the Right.
+*
+* TRANS (input) CHARACTER*1
+* = 'N': No transpose, apply Q;
+* = 'T': Transpose, apply Q**T.
+*
+* M (input) INTEGER
+* The number of rows of the matrix C. M >= 0.
+*
+* N (input) INTEGER
+* The number of columns of the matrix C. N >= 0.
+*
+* K (input) INTEGER
+* The number of elementary reflectors whose product defines
+* the matrix Q.
+* If SIDE = 'L', M >= K >= 0;
+* if SIDE = 'R', N >= K >= 0.
+*
+* A (input) REAL array, dimension (LDA,K)
+* The i-th column must contain the vector which defines the
+* elementary reflector H(i), for i = 1,2,...,k, as returned by
+* SGEQRF in the first k columns of its array argument A.
+* A is modified by the routine but restored on exit.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A.
+* If SIDE = 'L', LDA >= max(1,M);
+* if SIDE = 'R', LDA >= max(1,N).
+*
+* TAU (input) REAL array, dimension (K)
+* TAU(i) must contain the scalar factor of the elementary
+* reflector H(i), as returned by SGEQRF.
+*
+* C (input/output) REAL array, dimension (LDC,N)
+* On entry, the M-by-N matrix C.
+* On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q.
+*
+* LDC (input) INTEGER
+* The leading dimension of the array C. LDC >= max(1,M).
+*
+* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))
+* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+* LWORK (input) INTEGER
+* The dimension of the array WORK.
+* If SIDE = 'L', LWORK >= max(1,N);
+* if SIDE = 'R', LWORK >= max(1,M).
+* For optimum performance LWORK >= N*NB if SIDE = 'L', and
+* LWORK >= M*NB if SIDE = 'R', where NB is the optimal
+* blocksize.
+*
+* If LWORK = -1, then a workspace query is assumed; the routine
+* only calculates the optimal size of the WORK array, returns
+* this value as the first entry of the WORK array, and no error
+* message related to LWORK is issued by XERBLA.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+*
+* =====================================================================
+*
+* .. Parameters ..
+ INTEGER NBMAX, LDT
+ PARAMETER ( NBMAX = 64, LDT = NBMAX+1 )
+* ..
+* .. Local Scalars ..
+ LOGICAL LEFT, LQUERY, NOTRAN
+ INTEGER I, I1, I2, I3, IB, IC, IINFO, IWS, JC, LDWORK,
+ $ LWKOPT, MI, NB, NBMIN, NI, NQ, NW
+* ..
+* .. Local Arrays ..
+ REAL T( LDT, NBMAX )
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ILAENV
+ EXTERNAL LSAME, ILAENV
+* ..
+* .. External Subroutines ..
+ EXTERNAL SLARFB, SLARFT, SORM2R, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+* Test the input arguments
+*
+ INFO = 0
+ LEFT = LSAME( SIDE, 'L' )
+ NOTRAN = LSAME( TRANS, 'N' )
+ LQUERY = ( LWORK.EQ.-1 )
+*
+* NQ is the order of Q and NW is the minimum dimension of WORK
+*
+ IF( LEFT ) THEN
+ NQ = M
+ NW = N
+ ELSE
+ NQ = N
+ NW = M
+ END IF
+ IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN
+ INFO = -1
+ ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN
+ INFO = -2
+ ELSE IF( M.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN
+ INFO = -5
+ ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN
+ INFO = -7
+ ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
+ INFO = -10
+ ELSE IF( LWORK.LT.MAX( 1, NW ) .AND. .NOT.LQUERY ) THEN
+ INFO = -12
+ END IF
+*
+ IF( INFO.EQ.0 ) THEN
+*
+* Determine the block size. NB may be at most NBMAX, where NBMAX
+* is used to define the local array T.
+*
+ NB = MIN( NBMAX, ILAENV( 1, 'SORMQR', SIDE // TRANS, M, N, K,
+ $ -1 ) )
+ LWKOPT = MAX( 1, NW )*NB
+ WORK( 1 ) = LWKOPT
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SORMQR', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 ) THEN
+ WORK( 1 ) = 1
+ RETURN
+ END IF
+*
+ NBMIN = 2
+ LDWORK = NW
+ IF( NB.GT.1 .AND. NB.LT.K ) THEN
+ IWS = NW*NB
+ IF( LWORK.LT.IWS ) THEN
+ NB = LWORK / LDWORK
+ NBMIN = MAX( 2, ILAENV( 2, 'SORMQR', SIDE // TRANS, M, N, K,
+ $ -1 ) )
+ END IF
+ ELSE
+ IWS = NW
+ END IF
+*
+ IF( NB.LT.NBMIN .OR. NB.GE.K ) THEN
+*
+* Use unblocked code
+*
+ CALL SORM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK,
+ $ IINFO )
+ ELSE
+*
+* Use blocked code
+*
+ IF( ( LEFT .AND. .NOT.NOTRAN ) .OR.
+ $ ( .NOT.LEFT .AND. NOTRAN ) ) THEN
+ I1 = 1
+ I2 = K
+ I3 = NB
+ ELSE
+ I1 = ( ( K-1 ) / NB )*NB + 1
+ I2 = 1
+ I3 = -NB
+ END IF
+*
+ IF( LEFT ) THEN
+ NI = N
+ JC = 1
+ ELSE
+ MI = M
+ IC = 1
+ END IF
+*
+ DO 10 I = I1, I2, I3
+ IB = MIN( NB, K-I+1 )
+*
+* Form the triangular factor of the block reflector
+* H = H(i) H(i+1) . . . H(i+ib-1)
+*
+ CALL SLARFT( 'Forward', 'Columnwise', NQ-I+1, IB, A( I, I ),
+ $ LDA, TAU( I ), T, LDT )
+ IF( LEFT ) THEN
+*
+* H or H' is applied to C(i:m,1:n)
+*
+ MI = M - I + 1
+ IC = I
+ ELSE
+*
+* H or H' is applied to C(1:m,i:n)
+*
+ NI = N - I + 1
+ JC = I
+ END IF
+*
+* Apply H or H'
+*
+ CALL SLARFB( SIDE, TRANS, 'Forward', 'Columnwise', MI, NI,
+ $ IB, A( I, I ), LDA, T, LDT, C( IC, JC ), LDC,
+ $ WORK, LDWORK )
+ 10 CONTINUE
+ END IF
+ WORK( 1 ) = LWKOPT
+ RETURN
+*
+* End of SORMQR
+*
+ END
+ SUBROUTINE SORMR2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
+ $ WORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER SIDE, TRANS
+ INTEGER INFO, K, LDA, LDC, M, N
+* ..
+* .. Array Arguments ..
+ REAL A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SORMR2 overwrites the general real m by n matrix C with
+*
+* Q * C if SIDE = 'L' and TRANS = 'N', or
+*
+* Q'* C if SIDE = 'L' and TRANS = 'T', or
+*
+* C * Q if SIDE = 'R' and TRANS = 'N', or
+*
+* C * Q' if SIDE = 'R' and TRANS = 'T',
+*
+* where Q is a real orthogonal matrix defined as the product of k
+* elementary reflectors
+*
+* Q = H(1) H(2) . . . H(k)
+*
+* as returned by SGERQF. Q is of order m if SIDE = 'L' and of order n
+* if SIDE = 'R'.
+*
+* Arguments
+* =========
+*
+* SIDE (input) CHARACTER*1
+* = 'L': apply Q or Q' from the Left
+* = 'R': apply Q or Q' from the Right
+*
+* TRANS (input) CHARACTER*1
+* = 'N': apply Q (No transpose)
+* = 'T': apply Q' (Transpose)
+*
+* M (input) INTEGER
+* The number of rows of the matrix C. M >= 0.
+*
+* N (input) INTEGER
+* The number of columns of the matrix C. N >= 0.
+*
+* K (input) INTEGER
+* The number of elementary reflectors whose product defines
+* the matrix Q.
+* If SIDE = 'L', M >= K >= 0;
+* if SIDE = 'R', N >= K >= 0.
+*
+* A (input) REAL array, dimension
+* (LDA,M) if SIDE = 'L',
+* (LDA,N) if SIDE = 'R'
+* The i-th row must contain the vector which defines the
+* elementary reflector H(i), for i = 1,2,...,k, as returned by
+* SGERQF in the last k rows of its array argument A.
+* A is modified by the routine but restored on exit.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,K).
+*
+* TAU (input) REAL array, dimension (K)
+* TAU(i) must contain the scalar factor of the elementary
+* reflector H(i), as returned by SGERQF.
+*
+* C (input/output) REAL array, dimension (LDC,N)
+* On entry, the m by n matrix C.
+* On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q.
+*
+* LDC (input) INTEGER
+* The leading dimension of the array C. LDC >= max(1,M).
+*
+* WORK (workspace) REAL array, dimension
+* (N) if SIDE = 'L',
+* (M) if SIDE = 'R'
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ONE
+ PARAMETER ( ONE = 1.0E+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL LEFT, NOTRAN
+ INTEGER I, I1, I2, I3, MI, NI, NQ
+ REAL AII
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL SLARF, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input arguments
+*
+ INFO = 0
+ LEFT = LSAME( SIDE, 'L' )
+ NOTRAN = LSAME( TRANS, 'N' )
+*
+* NQ is the order of Q
+*
+ IF( LEFT ) THEN
+ NQ = M
+ ELSE
+ NQ = N
+ END IF
+ IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN
+ INFO = -1
+ ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN
+ INFO = -2
+ ELSE IF( M.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN
+ INFO = -5
+ ELSE IF( LDA.LT.MAX( 1, K ) ) THEN
+ INFO = -7
+ ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
+ INFO = -10
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SORMR2', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 )
+ $ RETURN
+*
+ IF( ( LEFT .AND. .NOT.NOTRAN ) .OR. ( .NOT.LEFT .AND. NOTRAN ) )
+ $ THEN
+ I1 = 1
+ I2 = K
+ I3 = 1
+ ELSE
+ I1 = K
+ I2 = 1
+ I3 = -1
+ END IF
+*
+ IF( LEFT ) THEN
+ NI = N
+ ELSE
+ MI = M
+ END IF
+*
+ DO 10 I = I1, I2, I3
+ IF( LEFT ) THEN
+*
+* H(i) is applied to C(1:m-k+i,1:n)
+*
+ MI = M - K + I
+ ELSE
+*
+* H(i) is applied to C(1:m,1:n-k+i)
+*
+ NI = N - K + I
+ END IF
+*
+* Apply H(i)
+*
+ AII = A( I, NQ-K+I )
+ A( I, NQ-K+I ) = ONE
+ CALL SLARF( SIDE, MI, NI, A( I, 1 ), LDA, TAU( I ), C, LDC,
+ $ WORK )
+ A( I, NQ-K+I ) = AII
+ 10 CONTINUE
+ RETURN
+*
+* End of SORMR2
+*
+ END
+ SUBROUTINE SORMR3( SIDE, TRANS, M, N, K, L, A, LDA, TAU, C, LDC,
+ $ WORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER SIDE, TRANS
+ INTEGER INFO, K, L, LDA, LDC, M, N
+* ..
+* .. Array Arguments ..
+ REAL A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SORMR3 overwrites the general real m by n matrix C with
+*
+* Q * C if SIDE = 'L' and TRANS = 'N', or
+*
+* Q'* C if SIDE = 'L' and TRANS = 'T', or
+*
+* C * Q if SIDE = 'R' and TRANS = 'N', or
+*
+* C * Q' if SIDE = 'R' and TRANS = 'T',
+*
+* where Q is a real orthogonal matrix defined as the product of k
+* elementary reflectors
+*
+* Q = H(1) H(2) . . . H(k)
+*
+* as returned by STZRZF. Q is of order m if SIDE = 'L' and of order n
+* if SIDE = 'R'.
+*
+* Arguments
+* =========
+*
+* SIDE (input) CHARACTER*1
+* = 'L': apply Q or Q' from the Left
+* = 'R': apply Q or Q' from the Right
+*
+* TRANS (input) CHARACTER*1
+* = 'N': apply Q (No transpose)
+* = 'T': apply Q' (Transpose)
+*
+* M (input) INTEGER
+* The number of rows of the matrix C. M >= 0.
+*
+* N (input) INTEGER
+* The number of columns of the matrix C. N >= 0.
+*
+* K (input) INTEGER
+* The number of elementary reflectors whose product defines
+* the matrix Q.
+* If SIDE = 'L', M >= K >= 0;
+* if SIDE = 'R', N >= K >= 0.
+*
+* L (input) INTEGER
+* The number of columns of the matrix A containing
+* the meaningful part of the Householder reflectors.
+* If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0.
+*
+* A (input) REAL array, dimension
+* (LDA,M) if SIDE = 'L',
+* (LDA,N) if SIDE = 'R'
+* The i-th row must contain the vector which defines the
+* elementary reflector H(i), for i = 1,2,...,k, as returned by
+* STZRZF in the last k rows of its array argument A.
+* A is modified by the routine but restored on exit.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,K).
+*
+* TAU (input) REAL array, dimension (K)
+* TAU(i) must contain the scalar factor of the elementary
+* reflector H(i), as returned by STZRZF.
+*
+* C (input/output) REAL array, dimension (LDC,N)
+* On entry, the m-by-n matrix C.
+* On exit, C is overwritten by Q*C or Q'*C or C*Q' or C*Q.
+*
+* LDC (input) INTEGER
+* The leading dimension of the array C. LDC >= max(1,M).
+*
+* WORK (workspace) REAL array, dimension
+* (N) if SIDE = 'L',
+* (M) if SIDE = 'R'
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+*
+* Further Details
+* ===============
+*
+* Based on contributions by
+* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ LOGICAL LEFT, NOTRAN
+ INTEGER I, I1, I2, I3, IC, JA, JC, MI, NI, NQ
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL SLARZ, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input arguments
+*
+ INFO = 0
+ LEFT = LSAME( SIDE, 'L' )
+ NOTRAN = LSAME( TRANS, 'N' )
+*
+* NQ is the order of Q
+*
+ IF( LEFT ) THEN
+ NQ = M
+ ELSE
+ NQ = N
+ END IF
+ IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN
+ INFO = -1
+ ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN
+ INFO = -2
+ ELSE IF( M.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN
+ INFO = -5
+ ELSE IF( L.LT.0 .OR. ( LEFT .AND. ( L.GT.M ) ) .OR.
+ $ ( .NOT.LEFT .AND. ( L.GT.N ) ) ) THEN
+ INFO = -6
+ ELSE IF( LDA.LT.MAX( 1, K ) ) THEN
+ INFO = -8
+ ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
+ INFO = -11
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SORMR3', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 )
+ $ RETURN
+*
+ IF( ( LEFT .AND. .NOT.NOTRAN .OR. .NOT.LEFT .AND. NOTRAN ) ) THEN
+ I1 = 1
+ I2 = K
+ I3 = 1
+ ELSE
+ I1 = K
+ I2 = 1
+ I3 = -1
+ END IF
+*
+ IF( LEFT ) THEN
+ NI = N
+ JA = M - L + 1
+ JC = 1
+ ELSE
+ MI = M
+ JA = N - L + 1
+ IC = 1
+ END IF
+*
+ DO 10 I = I1, I2, I3
+ IF( LEFT ) THEN
+*
+* H(i) or H(i)' is applied to C(i:m,1:n)
+*
+ MI = M - I + 1
+ IC = I
+ ELSE
+*
+* H(i) or H(i)' is applied to C(1:m,i:n)
+*
+ NI = N - I + 1
+ JC = I
+ END IF
+*
+* Apply H(i) or H(i)'
+*
+ CALL SLARZ( SIDE, MI, NI, L, A( I, JA ), LDA, TAU( I ),
+ $ C( IC, JC ), LDC, WORK )
+*
+ 10 CONTINUE
+*
+ RETURN
+*
+* End of SORMR3
+*
+ END
+ SUBROUTINE SORMRQ( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
+ $ WORK, LWORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER SIDE, TRANS
+ INTEGER INFO, K, LDA, LDC, LWORK, M, N
+* ..
+* .. Array Arguments ..
+ REAL A( LDA, * ), C( LDC, * ), TAU( * ),
+ $ WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SORMRQ overwrites the general real M-by-N matrix C with
+*
+* SIDE = 'L' SIDE = 'R'
+* TRANS = 'N': Q * C C * Q
+* TRANS = 'T': Q**T * C C * Q**T
+*
+* where Q is a real orthogonal matrix defined as the product of k
+* elementary reflectors
+*
+* Q = H(1) H(2) . . . H(k)
+*
+* as returned by SGERQF. Q is of order M if SIDE = 'L' and of order N
+* if SIDE = 'R'.
+*
+* Arguments
+* =========
+*
+* SIDE (input) CHARACTER*1
+* = 'L': apply Q or Q**T from the Left;
+* = 'R': apply Q or Q**T from the Right.
+*
+* TRANS (input) CHARACTER*1
+* = 'N': No transpose, apply Q;
+* = 'T': Transpose, apply Q**T.
+*
+* M (input) INTEGER
+* The number of rows of the matrix C. M >= 0.
+*
+* N (input) INTEGER
+* The number of columns of the matrix C. N >= 0.
+*
+* K (input) INTEGER
+* The number of elementary reflectors whose product defines
+* the matrix Q.
+* If SIDE = 'L', M >= K >= 0;
+* if SIDE = 'R', N >= K >= 0.
+*
+* A (input) REAL array, dimension
+* (LDA,M) if SIDE = 'L',
+* (LDA,N) if SIDE = 'R'
+* The i-th row must contain the vector which defines the
+* elementary reflector H(i), for i = 1,2,...,k, as returned by
+* SGERQF in the last k rows of its array argument A.
+* A is modified by the routine but restored on exit.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,K).
+*
+* TAU (input) REAL array, dimension (K)
+* TAU(i) must contain the scalar factor of the elementary
+* reflector H(i), as returned by SGERQF.
+*
+* C (input/output) REAL array, dimension (LDC,N)
+* On entry, the M-by-N matrix C.
+* On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q.
+*
+* LDC (input) INTEGER
+* The leading dimension of the array C. LDC >= max(1,M).
+*
+* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))
+* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+* LWORK (input) INTEGER
+* The dimension of the array WORK.
+* If SIDE = 'L', LWORK >= max(1,N);
+* if SIDE = 'R', LWORK >= max(1,M).
+* For optimum performance LWORK >= N*NB if SIDE = 'L', and
+* LWORK >= M*NB if SIDE = 'R', where NB is the optimal
+* blocksize.
+*
+* If LWORK = -1, then a workspace query is assumed; the routine
+* only calculates the optimal size of the WORK array, returns
+* this value as the first entry of the WORK array, and no error
+* message related to LWORK is issued by XERBLA.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+*
+* =====================================================================
+*
+* .. Parameters ..
+ INTEGER NBMAX, LDT
+ PARAMETER ( NBMAX = 64, LDT = NBMAX+1 )
+* ..
+* .. Local Scalars ..
+ LOGICAL LEFT, LQUERY, NOTRAN
+ CHARACTER TRANST
+ INTEGER I, I1, I2, I3, IB, IINFO, IWS, LDWORK, LWKOPT,
+ $ MI, NB, NBMIN, NI, NQ, NW
+* ..
+* .. Local Arrays ..
+ REAL T( LDT, NBMAX )
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ILAENV
+ EXTERNAL LSAME, ILAENV
+* ..
+* .. External Subroutines ..
+ EXTERNAL SLARFB, SLARFT, SORMR2, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+* Test the input arguments
+*
+ INFO = 0
+ LEFT = LSAME( SIDE, 'L' )
+ NOTRAN = LSAME( TRANS, 'N' )
+ LQUERY = ( LWORK.EQ.-1 )
+*
+* NQ is the order of Q and NW is the minimum dimension of WORK
+*
+ IF( LEFT ) THEN
+ NQ = M
+ NW = MAX( 1, N )
+ ELSE
+ NQ = N
+ NW = MAX( 1, M )
+ END IF
+ IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN
+ INFO = -1
+ ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN
+ INFO = -2
+ ELSE IF( M.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN
+ INFO = -5
+ ELSE IF( LDA.LT.MAX( 1, K ) ) THEN
+ INFO = -7
+ ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
+ INFO = -10
+ END IF
+*
+ IF( INFO.EQ.0 ) THEN
+ IF( M.EQ.0 .OR. N.EQ.0 ) THEN
+ LWKOPT = 1
+ ELSE
+*
+* Determine the block size. NB may be at most NBMAX, where
+* NBMAX is used to define the local array T.
+*
+ NB = MIN( NBMAX, ILAENV( 1, 'SORMRQ', SIDE // TRANS, M, N,
+ $ K, -1 ) )
+ LWKOPT = NW*NB
+ END IF
+ WORK( 1 ) = LWKOPT
+*
+ IF( LWORK.LT.NW .AND. .NOT.LQUERY ) THEN
+ INFO = -12
+ END IF
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SORMRQ', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( M.EQ.0 .OR. N.EQ.0 ) THEN
+ RETURN
+ END IF
+*
+ NBMIN = 2
+ LDWORK = NW
+ IF( NB.GT.1 .AND. NB.LT.K ) THEN
+ IWS = NW*NB
+ IF( LWORK.LT.IWS ) THEN
+ NB = LWORK / LDWORK
+ NBMIN = MAX( 2, ILAENV( 2, 'SORMRQ', SIDE // TRANS, M, N, K,
+ $ -1 ) )
+ END IF
+ ELSE
+ IWS = NW
+ END IF
+*
+ IF( NB.LT.NBMIN .OR. NB.GE.K ) THEN
+*
+* Use unblocked code
+*
+ CALL SORMR2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC, WORK,
+ $ IINFO )
+ ELSE
+*
+* Use blocked code
+*
+ IF( ( LEFT .AND. .NOT.NOTRAN ) .OR.
+ $ ( .NOT.LEFT .AND. NOTRAN ) ) THEN
+ I1 = 1
+ I2 = K
+ I3 = NB
+ ELSE
+ I1 = ( ( K-1 ) / NB )*NB + 1
+ I2 = 1
+ I3 = -NB
+ END IF
+*
+ IF( LEFT ) THEN
+ NI = N
+ ELSE
+ MI = M
+ END IF
+*
+ IF( NOTRAN ) THEN
+ TRANST = 'T'
+ ELSE
+ TRANST = 'N'
+ END IF
+*
+ DO 10 I = I1, I2, I3
+ IB = MIN( NB, K-I+1 )
+*
+* Form the triangular factor of the block reflector
+* H = H(i+ib-1) . . . H(i+1) H(i)
+*
+ CALL SLARFT( 'Backward', 'Rowwise', NQ-K+I+IB-1, IB,
+ $ A( I, 1 ), LDA, TAU( I ), T, LDT )
+ IF( LEFT ) THEN
+*
+* H or H' is applied to C(1:m-k+i+ib-1,1:n)
+*
+ MI = M - K + I + IB - 1
+ ELSE
+*
+* H or H' is applied to C(1:m,1:n-k+i+ib-1)
+*
+ NI = N - K + I + IB - 1
+ END IF
+*
+* Apply H or H'
+*
+ CALL SLARFB( SIDE, TRANST, 'Backward', 'Rowwise', MI, NI,
+ $ IB, A( I, 1 ), LDA, T, LDT, C, LDC, WORK,
+ $ LDWORK )
+ 10 CONTINUE
+ END IF
+ WORK( 1 ) = LWKOPT
+ RETURN
+*
+* End of SORMRQ
+*
+ END
+ SUBROUTINE SORMRZ( SIDE, TRANS, M, N, K, L, A, LDA, TAU, C, LDC,
+ $ WORK, LWORK, INFO )
+*
+* -- LAPACK routine (version 3.1.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* January 2007
+*
+* .. Scalar Arguments ..
+ CHARACTER SIDE, TRANS
+ INTEGER INFO, K, L, LDA, LDC, LWORK, M, N
+* ..
+* .. Array Arguments ..
+ REAL A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SORMRZ overwrites the general real M-by-N matrix C with
+*
+* SIDE = 'L' SIDE = 'R'
+* TRANS = 'N': Q * C C * Q
+* TRANS = 'T': Q**T * C C * Q**T
+*
+* where Q is a real orthogonal matrix defined as the product of k
+* elementary reflectors
+*
+* Q = H(1) H(2) . . . H(k)
+*
+* as returned by STZRZF. Q is of order M if SIDE = 'L' and of order N
+* if SIDE = 'R'.
+*
+* Arguments
+* =========
+*
+* SIDE (input) CHARACTER*1
+* = 'L': apply Q or Q**T from the Left;
+* = 'R': apply Q or Q**T from the Right.
+*
+* TRANS (input) CHARACTER*1
+* = 'N': No transpose, apply Q;
+* = 'T': Transpose, apply Q**T.
+*
+* M (input) INTEGER
+* The number of rows of the matrix C. M >= 0.
+*
+* N (input) INTEGER
+* The number of columns of the matrix C. N >= 0.
+*
+* K (input) INTEGER
+* The number of elementary reflectors whose product defines
+* the matrix Q.
+* If SIDE = 'L', M >= K >= 0;
+* if SIDE = 'R', N >= K >= 0.
+*
+* L (input) INTEGER
+* The number of columns of the matrix A containing
+* the meaningful part of the Householder reflectors.
+* If SIDE = 'L', M >= L >= 0, if SIDE = 'R', N >= L >= 0.
+*
+* A (input) REAL array, dimension
+* (LDA,M) if SIDE = 'L',
+* (LDA,N) if SIDE = 'R'
+* The i-th row must contain the vector which defines the
+* elementary reflector H(i), for i = 1,2,...,k, as returned by
+* STZRZF in the last k rows of its array argument A.
+* A is modified by the routine but restored on exit.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,K).
+*
+* TAU (input) REAL array, dimension (K)
+* TAU(i) must contain the scalar factor of the elementary
+* reflector H(i), as returned by STZRZF.
+*
+* C (input/output) REAL array, dimension (LDC,N)
+* On entry, the M-by-N matrix C.
+* On exit, C is overwritten by Q*C or Q**H*C or C*Q**H or C*Q.
+*
+* LDC (input) INTEGER
+* The leading dimension of the array C. LDC >= max(1,M).
+*
+* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))
+* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+* LWORK (input) INTEGER
+* The dimension of the array WORK.
+* If SIDE = 'L', LWORK >= max(1,N);
+* if SIDE = 'R', LWORK >= max(1,M).
+* For optimum performance LWORK >= N*NB if SIDE = 'L', and
+* LWORK >= M*NB if SIDE = 'R', where NB is the optimal
+* blocksize.
+*
+* If LWORK = -1, then a workspace query is assumed; the routine
+* only calculates the optimal size of the WORK array, returns
+* this value as the first entry of the WORK array, and no error
+* message related to LWORK is issued by XERBLA.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+*
+* Further Details
+* ===============
+*
+* Based on contributions by
+* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA
+*
+* =====================================================================
+*
+* .. Parameters ..
+ INTEGER NBMAX, LDT
+ PARAMETER ( NBMAX = 64, LDT = NBMAX+1 )
+* ..
+* .. Local Scalars ..
+ LOGICAL LEFT, LQUERY, NOTRAN
+ CHARACTER TRANST
+ INTEGER I, I1, I2, I3, IB, IC, IINFO, IWS, JA, JC,
+ $ LDWORK, LWKOPT, MI, NB, NBMIN, NI, NQ, NW
+* ..
+* .. Local Arrays ..
+ REAL T( LDT, NBMAX )
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ILAENV
+ EXTERNAL LSAME, ILAENV
+* ..
+* .. External Subroutines ..
+ EXTERNAL SLARZB, SLARZT, SORMR3, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+* Test the input arguments
+*
+ INFO = 0
+ LEFT = LSAME( SIDE, 'L' )
+ NOTRAN = LSAME( TRANS, 'N' )
+ LQUERY = ( LWORK.EQ.-1 )
+*
+* NQ is the order of Q and NW is the minimum dimension of WORK
+*
+ IF( LEFT ) THEN
+ NQ = M
+ NW = MAX( 1, N )
+ ELSE
+ NQ = N
+ NW = MAX( 1, M )
+ END IF
+ IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN
+ INFO = -1
+ ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN
+ INFO = -2
+ ELSE IF( M.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN
+ INFO = -5
+ ELSE IF( L.LT.0 .OR. ( LEFT .AND. ( L.GT.M ) ) .OR.
+ $ ( .NOT.LEFT .AND. ( L.GT.N ) ) ) THEN
+ INFO = -6
+ ELSE IF( LDA.LT.MAX( 1, K ) ) THEN
+ INFO = -8
+ ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
+ INFO = -11
+ END IF
+*
+ IF( INFO.EQ.0 ) THEN
+ IF( M.EQ.0 .OR. N.EQ.0 ) THEN
+ LWKOPT = 1
+ ELSE
+*
+* Determine the block size. NB may be at most NBMAX, where
+* NBMAX is used to define the local array T.
+*
+ NB = MIN( NBMAX, ILAENV( 1, 'SORMRQ', SIDE // TRANS, M, N,
+ $ K, -1 ) )
+ LWKOPT = NW*NB
+ END IF
+ WORK( 1 ) = LWKOPT
+*
+ IF( LWORK.LT.MAX( 1, NW ) .AND. .NOT.LQUERY ) THEN
+ INFO = -13
+ END IF
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SORMRZ', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( M.EQ.0 .OR. N.EQ.0 ) THEN
+ RETURN
+ END IF
+*
+ NBMIN = 2
+ LDWORK = NW
+ IF( NB.GT.1 .AND. NB.LT.K ) THEN
+ IWS = NW*NB
+ IF( LWORK.LT.IWS ) THEN
+ NB = LWORK / LDWORK
+ NBMIN = MAX( 2, ILAENV( 2, 'SORMRQ', SIDE // TRANS, M, N, K,
+ $ -1 ) )
+ END IF
+ ELSE
+ IWS = NW
+ END IF
+*
+ IF( NB.LT.NBMIN .OR. NB.GE.K ) THEN
+*
+* Use unblocked code
+*
+ CALL SORMR3( SIDE, TRANS, M, N, K, L, A, LDA, TAU, C, LDC,
+ $ WORK, IINFO )
+ ELSE
+*
+* Use blocked code
+*
+ IF( ( LEFT .AND. .NOT.NOTRAN ) .OR.
+ $ ( .NOT.LEFT .AND. NOTRAN ) ) THEN
+ I1 = 1
+ I2 = K
+ I3 = NB
+ ELSE
+ I1 = ( ( K-1 ) / NB )*NB + 1
+ I2 = 1
+ I3 = -NB
+ END IF
+*
+ IF( LEFT ) THEN
+ NI = N
+ JC = 1
+ JA = M - L + 1
+ ELSE
+ MI = M
+ IC = 1
+ JA = N - L + 1
+ END IF
+*
+ IF( NOTRAN ) THEN
+ TRANST = 'T'
+ ELSE
+ TRANST = 'N'
+ END IF
+*
+ DO 10 I = I1, I2, I3
+ IB = MIN( NB, K-I+1 )
+*
+* Form the triangular factor of the block reflector
+* H = H(i+ib-1) . . . H(i+1) H(i)
+*
+ CALL SLARZT( 'Backward', 'Rowwise', L, IB, A( I, JA ), LDA,
+ $ TAU( I ), T, LDT )
+*
+ IF( LEFT ) THEN
+*
+* H or H' is applied to C(i:m,1:n)
+*
+ MI = M - I + 1
+ IC = I
+ ELSE
+*
+* H or H' is applied to C(1:m,i:n)
+*
+ NI = N - I + 1
+ JC = I
+ END IF
+*
+* Apply H or H'
+*
+ CALL SLARZB( SIDE, TRANST, 'Backward', 'Rowwise', MI, NI,
+ $ IB, L, A( I, JA ), LDA, T, LDT, C( IC, JC ),
+ $ LDC, WORK, LDWORK )
+ 10 CONTINUE
+*
+ END IF
+*
+ WORK( 1 ) = LWKOPT
+*
+ RETURN
+*
+* End of SORMRZ
+*
+ END
+ SUBROUTINE SORMTR( SIDE, UPLO, TRANS, M, N, A, LDA, TAU, C, LDC,
+ $ WORK, LWORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER SIDE, TRANS, UPLO
+ INTEGER INFO, LDA, LDC, LWORK, M, N
+* ..
+* .. Array Arguments ..
+ REAL A( LDA, * ), C( LDC, * ), TAU( * ),
+ $ WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SORMTR overwrites the general real M-by-N matrix C with
+*
+* SIDE = 'L' SIDE = 'R'
+* TRANS = 'N': Q * C C * Q
+* TRANS = 'T': Q**T * C C * Q**T
+*
+* where Q is a real orthogonal matrix of order nq, with nq = m if
+* SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of
+* nq-1 elementary reflectors, as returned by SSYTRD:
+*
+* if UPLO = 'U', Q = H(nq-1) . . . H(2) H(1);
+*
+* if UPLO = 'L', Q = H(1) H(2) . . . H(nq-1).
+*
+* Arguments
+* =========
+*
+* SIDE (input) CHARACTER*1
+* = 'L': apply Q or Q**T from the Left;
+* = 'R': apply Q or Q**T from the Right.
+*
+* UPLO (input) CHARACTER*1
+* = 'U': Upper triangle of A contains elementary reflectors
+* from SSYTRD;
+* = 'L': Lower triangle of A contains elementary reflectors
+* from SSYTRD.
+*
+* TRANS (input) CHARACTER*1
+* = 'N': No transpose, apply Q;
+* = 'T': Transpose, apply Q**T.
+*
+* M (input) INTEGER
+* The number of rows of the matrix C. M >= 0.
+*
+* N (input) INTEGER
+* The number of columns of the matrix C. N >= 0.
+*
+* A (input) REAL array, dimension
+* (LDA,M) if SIDE = 'L'
+* (LDA,N) if SIDE = 'R'
+* The vectors which define the elementary reflectors, as
+* returned by SSYTRD.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A.
+* LDA >= max(1,M) if SIDE = 'L'; LDA >= max(1,N) if SIDE = 'R'.
+*
+* TAU (input) REAL array, dimension
+* (M-1) if SIDE = 'L'
+* (N-1) if SIDE = 'R'
+* TAU(i) must contain the scalar factor of the elementary
+* reflector H(i), as returned by SSYTRD.
+*
+* C (input/output) REAL array, dimension (LDC,N)
+* On entry, the M-by-N matrix C.
+* On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q.
+*
+* LDC (input) INTEGER
+* The leading dimension of the array C. LDC >= max(1,M).
+*
+* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))
+* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+* LWORK (input) INTEGER
+* The dimension of the array WORK.
+* If SIDE = 'L', LWORK >= max(1,N);
+* if SIDE = 'R', LWORK >= max(1,M).
+* For optimum performance LWORK >= N*NB if SIDE = 'L', and
+* LWORK >= M*NB if SIDE = 'R', where NB is the optimal
+* blocksize.
+*
+* If LWORK = -1, then a workspace query is assumed; the routine
+* only calculates the optimal size of the WORK array, returns
+* this value as the first entry of the WORK array, and no error
+* message related to LWORK is issued by XERBLA.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ LOGICAL LEFT, LQUERY, UPPER
+ INTEGER I1, I2, IINFO, LWKOPT, MI, NI, NB, NQ, NW
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ILAENV
+ EXTERNAL ILAENV, LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL SORMQL, SORMQR, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input arguments
+*
+ INFO = 0
+ LEFT = LSAME( SIDE, 'L' )
+ UPPER = LSAME( UPLO, 'U' )
+ LQUERY = ( LWORK.EQ.-1 )
+*
+* NQ is the order of Q and NW is the minimum dimension of WORK
+*
+ IF( LEFT ) THEN
+ NQ = M
+ NW = N
+ ELSE
+ NQ = N
+ NW = M
+ END IF
+ IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN
+ INFO = -1
+ ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -2
+ ELSE IF( .NOT.LSAME( TRANS, 'N' ) .AND. .NOT.LSAME( TRANS, 'T' ) )
+ $ THEN
+ INFO = -3
+ ELSE IF( M.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -5
+ ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN
+ INFO = -7
+ ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
+ INFO = -10
+ ELSE IF( LWORK.LT.MAX( 1, NW ) .AND. .NOT.LQUERY ) THEN
+ INFO = -12
+ END IF
+*
+ IF( INFO.EQ.0 ) THEN
+ IF( UPPER ) THEN
+ IF( LEFT ) THEN
+ NB = ILAENV( 1, 'SORMQL', SIDE // TRANS, M-1, N, M-1,
+ $ -1 )
+ ELSE
+ NB = ILAENV( 1, 'SORMQL', SIDE // TRANS, M, N-1, N-1,
+ $ -1 )
+ END IF
+ ELSE
+ IF( LEFT ) THEN
+ NB = ILAENV( 1, 'SORMQR', SIDE // TRANS, M-1, N, M-1,
+ $ -1 )
+ ELSE
+ NB = ILAENV( 1, 'SORMQR', SIDE // TRANS, M, N-1, N-1,
+ $ -1 )
+ END IF
+ END IF
+ LWKOPT = MAX( 1, NW )*NB
+ WORK( 1 ) = LWKOPT
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SORMTR', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( M.EQ.0 .OR. N.EQ.0 .OR. NQ.EQ.1 ) THEN
+ WORK( 1 ) = 1
+ RETURN
+ END IF
+*
+ IF( LEFT ) THEN
+ MI = M - 1
+ NI = N
+ ELSE
+ MI = M
+ NI = N - 1
+ END IF
+*
+ IF( UPPER ) THEN
+*
+* Q was determined by a call to SSYTRD with UPLO = 'U'
+*
+ CALL SORMQL( SIDE, TRANS, MI, NI, NQ-1, A( 1, 2 ), LDA, TAU, C,
+ $ LDC, WORK, LWORK, IINFO )
+ ELSE
+*
+* Q was determined by a call to SSYTRD with UPLO = 'L'
+*
+ IF( LEFT ) THEN
+ I1 = 2
+ I2 = 1
+ ELSE
+ I1 = 1
+ I2 = 2
+ END IF
+ CALL SORMQR( SIDE, TRANS, MI, NI, NQ-1, A( 2, 1 ), LDA, TAU,
+ $ C( I1, I2 ), LDC, WORK, LWORK, IINFO )
+ END IF
+ WORK( 1 ) = LWKOPT
+ RETURN
+*
+* End of SORMTR
+*
+ END
+ SUBROUTINE SPBCON( UPLO, N, KD, AB, LDAB, ANORM, RCOND, WORK,
+ $ IWORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* Modified to call SLACN2 in place of SLACON, 7 Feb 03, SJH.
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, KD, LDAB, N
+ REAL ANORM, RCOND
+* ..
+* .. Array Arguments ..
+ INTEGER IWORK( * )
+ REAL AB( LDAB, * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SPBCON estimates the reciprocal of the condition number (in the
+* 1-norm) of a real symmetric positive definite band matrix using the
+* Cholesky factorization A = U**T*U or A = L*L**T computed by SPBTRF.
+*
+* An estimate is obtained for norm(inv(A)), and the reciprocal of the
+* condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).
+*
+* Arguments
+* =========
+*
+* UPLO (input) CHARACTER*1
+* = 'U': Upper triangular factor stored in AB;
+* = 'L': Lower triangular factor stored in AB.
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* KD (input) INTEGER
+* The number of superdiagonals of the matrix A if UPLO = 'U',
+* or the number of subdiagonals if UPLO = 'L'. KD >= 0.
+*
+* AB (input) REAL array, dimension (LDAB,N)
+* The triangular factor U or L from the Cholesky factorization
+* A = U**T*U or A = L*L**T of the band matrix A, stored in the
+* first KD+1 rows of the array. The j-th column of U or L is
+* stored in the j-th column of the array AB as follows:
+* if UPLO ='U', AB(kd+1+i-j,j) = U(i,j) for max(1,j-kd)<=i<=j;
+* if UPLO ='L', AB(1+i-j,j) = L(i,j) for j<=i<=min(n,j+kd).
+*
+* LDAB (input) INTEGER
+* The leading dimension of the array AB. LDAB >= KD+1.
+*
+* ANORM (input) REAL
+* The 1-norm (or infinity-norm) of the symmetric band matrix A.
+*
+* RCOND (output) REAL
+* The reciprocal of the condition number of the matrix A,
+* computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an
+* estimate of the 1-norm of inv(A) computed in this routine.
+*
+* WORK (workspace) REAL array, dimension (3*N)
+*
+* IWORK (workspace) INTEGER array, dimension (N)
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ONE, ZERO
+ PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL UPPER
+ CHARACTER NORMIN
+ INTEGER IX, KASE
+ REAL AINVNM, SCALE, SCALEL, SCALEU, SMLNUM
+* ..
+* .. Local Arrays ..
+ INTEGER ISAVE( 3 )
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ISAMAX
+ REAL SLAMCH
+ EXTERNAL LSAME, ISAMAX, SLAMCH
+* ..
+* .. External Subroutines ..
+ EXTERNAL SLACN2, SLATBS, SRSCL, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( KD.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( LDAB.LT.KD+1 ) THEN
+ INFO = -5
+ ELSE IF( ANORM.LT.ZERO ) THEN
+ INFO = -6
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SPBCON', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ RCOND = ZERO
+ IF( N.EQ.0 ) THEN
+ RCOND = ONE
+ RETURN
+ ELSE IF( ANORM.EQ.ZERO ) THEN
+ RETURN
+ END IF
+*
+ SMLNUM = SLAMCH( 'Safe minimum' )
+*
+* Estimate the 1-norm of the inverse.
+*
+ KASE = 0
+ NORMIN = 'N'
+ 10 CONTINUE
+ CALL SLACN2( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE, ISAVE )
+ IF( KASE.NE.0 ) THEN
+ IF( UPPER ) THEN
+*
+* Multiply by inv(U').
+*
+ CALL SLATBS( 'Upper', 'Transpose', 'Non-unit', NORMIN, N,
+ $ KD, AB, LDAB, WORK, SCALEL, WORK( 2*N+1 ),
+ $ INFO )
+ NORMIN = 'Y'
+*
+* Multiply by inv(U).
+*
+ CALL SLATBS( 'Upper', 'No transpose', 'Non-unit', NORMIN, N,
+ $ KD, AB, LDAB, WORK, SCALEU, WORK( 2*N+1 ),
+ $ INFO )
+ ELSE
+*
+* Multiply by inv(L).
+*
+ CALL SLATBS( 'Lower', 'No transpose', 'Non-unit', NORMIN, N,
+ $ KD, AB, LDAB, WORK, SCALEL, WORK( 2*N+1 ),
+ $ INFO )
+ NORMIN = 'Y'
+*
+* Multiply by inv(L').
+*
+ CALL SLATBS( 'Lower', 'Transpose', 'Non-unit', NORMIN, N,
+ $ KD, AB, LDAB, WORK, SCALEU, WORK( 2*N+1 ),
+ $ INFO )
+ END IF
+*
+* Multiply by 1/SCALE if doing so will not cause overflow.
+*
+ SCALE = SCALEL*SCALEU
+ IF( SCALE.NE.ONE ) THEN
+ IX = ISAMAX( N, WORK, 1 )
+ IF( SCALE.LT.ABS( WORK( IX ) )*SMLNUM .OR. SCALE.EQ.ZERO )
+ $ GO TO 20
+ CALL SRSCL( N, SCALE, WORK, 1 )
+ END IF
+ GO TO 10
+ END IF
+*
+* Compute the estimate of the reciprocal condition number.
+*
+ IF( AINVNM.NE.ZERO )
+ $ RCOND = ( ONE / AINVNM ) / ANORM
+*
+ 20 CONTINUE
+*
+ RETURN
+*
+* End of SPBCON
+*
+ END
+ SUBROUTINE SPBEQU( UPLO, N, KD, AB, LDAB, S, SCOND, AMAX, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, KD, LDAB, N
+ REAL AMAX, SCOND
+* ..
+* .. Array Arguments ..
+ REAL AB( LDAB, * ), S( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SPBEQU computes row and column scalings intended to equilibrate a
+* symmetric positive definite band matrix A and reduce its condition
+* number (with respect to the two-norm). S contains the scale factors,
+* S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with
+* elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This
+* choice of S puts the condition number of B within a factor N of the
+* smallest possible condition number over all possible diagonal
+* scalings.
+*
+* Arguments
+* =========
+*
+* UPLO (input) CHARACTER*1
+* = 'U': Upper triangular of A is stored;
+* = 'L': Lower triangular of A is stored.
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* KD (input) INTEGER
+* The number of superdiagonals of the matrix A if UPLO = 'U',
+* or the number of subdiagonals if UPLO = 'L'. KD >= 0.
+*
+* AB (input) REAL array, dimension (LDAB,N)
+* The upper or lower triangle of the symmetric band matrix A,
+* stored in the first KD+1 rows of the array. The j-th column
+* of A is stored in the j-th column of the array AB as follows:
+* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
+* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).
+*
+* LDAB (input) INTEGER
+* The leading dimension of the array A. LDAB >= KD+1.
+*
+* S (output) REAL array, dimension (N)
+* If INFO = 0, S contains the scale factors for A.
+*
+* SCOND (output) REAL
+* If INFO = 0, S contains the ratio of the smallest S(i) to
+* the largest S(i). If SCOND >= 0.1 and AMAX is neither too
+* large nor too small, it is not worth scaling by S.
+*
+* AMAX (output) REAL
+* Absolute value of largest matrix element. If AMAX is very
+* close to overflow or very close to underflow, the matrix
+* should be scaled.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value.
+* > 0: if INFO = i, the i-th diagonal element is nonpositive.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO, ONE
+ PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL UPPER
+ INTEGER I, J
+ REAL SMIN
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN, SQRT
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( KD.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( LDAB.LT.KD+1 ) THEN
+ INFO = -5
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SPBEQU', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 ) THEN
+ SCOND = ONE
+ AMAX = ZERO
+ RETURN
+ END IF
+*
+ IF( UPPER ) THEN
+ J = KD + 1
+ ELSE
+ J = 1
+ END IF
+*
+* Initialize SMIN and AMAX.
+*
+ S( 1 ) = AB( J, 1 )
+ SMIN = S( 1 )
+ AMAX = S( 1 )
+*
+* Find the minimum and maximum diagonal elements.
+*
+ DO 10 I = 2, N
+ S( I ) = AB( J, I )
+ SMIN = MIN( SMIN, S( I ) )
+ AMAX = MAX( AMAX, S( I ) )
+ 10 CONTINUE
+*
+ IF( SMIN.LE.ZERO ) THEN
+*
+* Find the first non-positive diagonal element and return.
+*
+ DO 20 I = 1, N
+ IF( S( I ).LE.ZERO ) THEN
+ INFO = I
+ RETURN
+ END IF
+ 20 CONTINUE
+ ELSE
+*
+* Set the scale factors to the reciprocals
+* of the diagonal elements.
+*
+ DO 30 I = 1, N
+ S( I ) = ONE / SQRT( S( I ) )
+ 30 CONTINUE
+*
+* Compute SCOND = min(S(I)) / max(S(I))
+*
+ SCOND = SQRT( SMIN ) / SQRT( AMAX )
+ END IF
+ RETURN
+*
+* End of SPBEQU
+*
+ END
+ SUBROUTINE SPBRFS( UPLO, N, KD, NRHS, AB, LDAB, AFB, LDAFB, B,
+ $ LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* Modified to call SLACN2 in place of SLACON, 7 Feb 03, SJH.
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, KD, LDAB, LDAFB, LDB, LDX, N, NRHS
+* ..
+* .. Array Arguments ..
+ INTEGER IWORK( * )
+ REAL AB( LDAB, * ), AFB( LDAFB, * ), B( LDB, * ),
+ $ BERR( * ), FERR( * ), WORK( * ), X( LDX, * )
+* ..
+*
+* Purpose
+* =======
+*
+* SPBRFS improves the computed solution to a system of linear
+* equations when the coefficient matrix is symmetric positive definite
+* and banded, and provides error bounds and backward error estimates
+* for the solution.
+*
+* Arguments
+* =========
+*
+* UPLO (input) CHARACTER*1
+* = 'U': Upper triangle of A is stored;
+* = 'L': Lower triangle of A is stored.
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* KD (input) INTEGER
+* The number of superdiagonals of the matrix A if UPLO = 'U',
+* or the number of subdiagonals if UPLO = 'L'. KD >= 0.
+*
+* NRHS (input) INTEGER
+* The number of right hand sides, i.e., the number of columns
+* of the matrices B and X. NRHS >= 0.
+*
+* AB (input) REAL array, dimension (LDAB,N)
+* The upper or lower triangle of the symmetric band matrix A,
+* stored in the first KD+1 rows of the array. The j-th column
+* of A is stored in the j-th column of the array AB as follows:
+* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
+* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).
+*
+* LDAB (input) INTEGER
+* The leading dimension of the array AB. LDAB >= KD+1.
+*
+* AFB (input) REAL array, dimension (LDAFB,N)
+* The triangular factor U or L from the Cholesky factorization
+* A = U**T*U or A = L*L**T of the band matrix A as computed by
+* SPBTRF, in the same storage format as A (see AB).
+*
+* LDAFB (input) INTEGER
+* The leading dimension of the array AFB. LDAFB >= KD+1.
+*
+* B (input) REAL array, dimension (LDB,NRHS)
+* The right hand side matrix B.
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. LDB >= max(1,N).
+*
+* X (input/output) REAL array, dimension (LDX,NRHS)
+* On entry, the solution matrix X, as computed by SPBTRS.
+* On exit, the improved solution matrix X.
+*
+* LDX (input) INTEGER
+* The leading dimension of the array X. LDX >= max(1,N).
+*
+* FERR (output) REAL array, dimension (NRHS)
+* The estimated forward error bound for each solution vector
+* X(j) (the j-th column of the solution matrix X).
+* If XTRUE is the true solution corresponding to X(j), FERR(j)
+* is an estimated upper bound for the magnitude of the largest
+* element in (X(j) - XTRUE) divided by the magnitude of the
+* largest element in X(j). The estimate is as reliable as
+* the estimate for RCOND, and is almost always a slight
+* overestimate of the true error.
+*
+* BERR (output) REAL array, dimension (NRHS)
+* The componentwise relative backward error of each solution
+* vector X(j) (i.e., the smallest relative change in
+* any element of A or B that makes X(j) an exact solution).
+*
+* WORK (workspace) REAL array, dimension (3*N)
+*
+* IWORK (workspace) INTEGER array, dimension (N)
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+*
+* Internal Parameters
+* ===================
+*
+* ITMAX is the maximum number of steps of iterative refinement.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ INTEGER ITMAX
+ PARAMETER ( ITMAX = 5 )
+ REAL ZERO
+ PARAMETER ( ZERO = 0.0E+0 )
+ REAL ONE
+ PARAMETER ( ONE = 1.0E+0 )
+ REAL TWO
+ PARAMETER ( TWO = 2.0E+0 )
+ REAL THREE
+ PARAMETER ( THREE = 3.0E+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL UPPER
+ INTEGER COUNT, I, J, K, KASE, L, NZ
+ REAL EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK
+* ..
+* .. Local Arrays ..
+ INTEGER ISAVE( 3 )
+* ..
+* .. External Subroutines ..
+ EXTERNAL SAXPY, SCOPY, SLACN2, SPBTRS, SSBMV, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, MIN
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ REAL SLAMCH
+ EXTERNAL LSAME, SLAMCH
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( KD.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( NRHS.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( LDAB.LT.KD+1 ) THEN
+ INFO = -6
+ ELSE IF( LDAFB.LT.KD+1 ) THEN
+ INFO = -8
+ ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -10
+ ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
+ INFO = -12
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SPBRFS', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN
+ DO 10 J = 1, NRHS
+ FERR( J ) = ZERO
+ BERR( J ) = ZERO
+ 10 CONTINUE
+ RETURN
+ END IF
+*
+* NZ = maximum number of nonzero elements in each row of A, plus 1
+*
+ NZ = MIN( N+1, 2*KD+2 )
+ EPS = SLAMCH( 'Epsilon' )
+ SAFMIN = SLAMCH( 'Safe minimum' )
+ SAFE1 = NZ*SAFMIN
+ SAFE2 = SAFE1 / EPS
+*
+* Do for each right hand side
+*
+ DO 140 J = 1, NRHS
+*
+ COUNT = 1
+ LSTRES = THREE
+ 20 CONTINUE
+*
+* Loop until stopping criterion is satisfied.
+*
+* Compute residual R = B - A * X
+*
+ CALL SCOPY( N, B( 1, J ), 1, WORK( N+1 ), 1 )
+ CALL SSBMV( UPLO, N, KD, -ONE, AB, LDAB, X( 1, J ), 1, ONE,
+ $ WORK( N+1 ), 1 )
+*
+* Compute componentwise relative backward error from formula
+*
+* max(i) ( abs(R(i)) / ( abs(A)*abs(X) + abs(B) )(i) )
+*
+* where abs(Z) is the componentwise absolute value of the matrix
+* or vector Z. If the i-th component of the denominator is less
+* than SAFE2, then SAFE1 is added to the i-th components of the
+* numerator and denominator before dividing.
+*
+ DO 30 I = 1, N
+ WORK( I ) = ABS( B( I, J ) )
+ 30 CONTINUE
+*
+* Compute abs(A)*abs(X) + abs(B).
+*
+ IF( UPPER ) THEN
+ DO 50 K = 1, N
+ S = ZERO
+ XK = ABS( X( K, J ) )
+ L = KD + 1 - K
+ DO 40 I = MAX( 1, K-KD ), K - 1
+ WORK( I ) = WORK( I ) + ABS( AB( L+I, K ) )*XK
+ S = S + ABS( AB( L+I, K ) )*ABS( X( I, J ) )
+ 40 CONTINUE
+ WORK( K ) = WORK( K ) + ABS( AB( KD+1, K ) )*XK + S
+ 50 CONTINUE
+ ELSE
+ DO 70 K = 1, N
+ S = ZERO
+ XK = ABS( X( K, J ) )
+ WORK( K ) = WORK( K ) + ABS( AB( 1, K ) )*XK
+ L = 1 - K
+ DO 60 I = K + 1, MIN( N, K+KD )
+ WORK( I ) = WORK( I ) + ABS( AB( L+I, K ) )*XK
+ S = S + ABS( AB( L+I, K ) )*ABS( X( I, J ) )
+ 60 CONTINUE
+ WORK( K ) = WORK( K ) + S
+ 70 CONTINUE
+ END IF
+ S = ZERO
+ DO 80 I = 1, N
+ IF( WORK( I ).GT.SAFE2 ) THEN
+ S = MAX( S, ABS( WORK( N+I ) ) / WORK( I ) )
+ ELSE
+ S = MAX( S, ( ABS( WORK( N+I ) )+SAFE1 ) /
+ $ ( WORK( I )+SAFE1 ) )
+ END IF
+ 80 CONTINUE
+ BERR( J ) = S
+*
+* Test stopping criterion. Continue iterating if
+* 1) The residual BERR(J) is larger than machine epsilon, and
+* 2) BERR(J) decreased by at least a factor of 2 during the
+* last iteration, and
+* 3) At most ITMAX iterations tried.
+*
+ IF( BERR( J ).GT.EPS .AND. TWO*BERR( J ).LE.LSTRES .AND.
+ $ COUNT.LE.ITMAX ) THEN
+*
+* Update solution and try again.
+*
+ CALL SPBTRS( UPLO, N, KD, 1, AFB, LDAFB, WORK( N+1 ), N,
+ $ INFO )
+ CALL SAXPY( N, ONE, WORK( N+1 ), 1, X( 1, J ), 1 )
+ LSTRES = BERR( J )
+ COUNT = COUNT + 1
+ GO TO 20
+ END IF
+*
+* Bound error from formula
+*
+* norm(X - XTRUE) / norm(X) .le. FERR =
+* norm( abs(inv(A))*
+* ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X)
+*
+* where
+* norm(Z) is the magnitude of the largest component of Z
+* inv(A) is the inverse of A
+* abs(Z) is the componentwise absolute value of the matrix or
+* vector Z
+* NZ is the maximum number of nonzeros in any row of A, plus 1
+* EPS is machine epsilon
+*
+* The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B))
+* is incremented by SAFE1 if the i-th component of
+* abs(A)*abs(X) + abs(B) is less than SAFE2.
+*
+* Use SLACN2 to estimate the infinity-norm of the matrix
+* inv(A) * diag(W),
+* where W = abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) )))
+*
+ DO 90 I = 1, N
+ IF( WORK( I ).GT.SAFE2 ) THEN
+ WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I )
+ ELSE
+ WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I ) + SAFE1
+ END IF
+ 90 CONTINUE
+*
+ KASE = 0
+ 100 CONTINUE
+ CALL SLACN2( N, WORK( 2*N+1 ), WORK( N+1 ), IWORK, FERR( J ),
+ $ KASE, ISAVE )
+ IF( KASE.NE.0 ) THEN
+ IF( KASE.EQ.1 ) THEN
+*
+* Multiply by diag(W)*inv(A').
+*
+ CALL SPBTRS( UPLO, N, KD, 1, AFB, LDAFB, WORK( N+1 ), N,
+ $ INFO )
+ DO 110 I = 1, N
+ WORK( N+I ) = WORK( N+I )*WORK( I )
+ 110 CONTINUE
+ ELSE IF( KASE.EQ.2 ) THEN
+*
+* Multiply by inv(A)*diag(W).
+*
+ DO 120 I = 1, N
+ WORK( N+I ) = WORK( N+I )*WORK( I )
+ 120 CONTINUE
+ CALL SPBTRS( UPLO, N, KD, 1, AFB, LDAFB, WORK( N+1 ), N,
+ $ INFO )
+ END IF
+ GO TO 100
+ END IF
+*
+* Normalize error.
+*
+ LSTRES = ZERO
+ DO 130 I = 1, N
+ LSTRES = MAX( LSTRES, ABS( X( I, J ) ) )
+ 130 CONTINUE
+ IF( LSTRES.NE.ZERO )
+ $ FERR( J ) = FERR( J ) / LSTRES
+*
+ 140 CONTINUE
+*
+ RETURN
+*
+* End of SPBRFS
+*
+ END
+ SUBROUTINE SPBSTF( UPLO, N, KD, AB, LDAB, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, KD, LDAB, N
+* ..
+* .. Array Arguments ..
+ REAL AB( LDAB, * )
+* ..
+*
+* Purpose
+* =======
+*
+* SPBSTF computes a split Cholesky factorization of a real
+* symmetric positive definite band matrix A.
+*
+* This routine is designed to be used in conjunction with SSBGST.
+*
+* The factorization has the form A = S**T*S where S is a band matrix
+* of the same bandwidth as A and the following structure:
+*
+* S = ( U )
+* ( M L )
+*
+* where U is upper triangular of order m = (n+kd)/2, and L is lower
+* triangular of order n-m.
+*
+* Arguments
+* =========
+*
+* UPLO (input) CHARACTER*1
+* = 'U': Upper triangle of A is stored;
+* = 'L': Lower triangle of A is stored.
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* KD (input) INTEGER
+* The number of superdiagonals of the matrix A if UPLO = 'U',
+* or the number of subdiagonals if UPLO = 'L'. KD >= 0.
+*
+* AB (input/output) REAL array, dimension (LDAB,N)
+* On entry, the upper or lower triangle of the symmetric band
+* matrix A, stored in the first kd+1 rows of the array. The
+* j-th column of A is stored in the j-th column of the array AB
+* as follows:
+* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
+* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).
+*
+* On exit, if INFO = 0, the factor S from the split Cholesky
+* factorization A = S**T*S. See Further Details.
+*
+* LDAB (input) INTEGER
+* The leading dimension of the array AB. LDAB >= KD+1.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* > 0: if INFO = i, the factorization could not be completed,
+* because the updated element a(i,i) was negative; the
+* matrix A is not positive definite.
+*
+* Further Details
+* ===============
+*
+* The band storage scheme is illustrated by the following example, when
+* N = 7, KD = 2:
+*
+* S = ( s11 s12 s13 )
+* ( s22 s23 s24 )
+* ( s33 s34 )
+* ( s44 )
+* ( s53 s54 s55 )
+* ( s64 s65 s66 )
+* ( s75 s76 s77 )
+*
+* If UPLO = 'U', the array AB holds:
+*
+* on entry: on exit:
+*
+* * * a13 a24 a35 a46 a57 * * s13 s24 s53 s64 s75
+* * a12 a23 a34 a45 a56 a67 * s12 s23 s34 s54 s65 s76
+* a11 a22 a33 a44 a55 a66 a77 s11 s22 s33 s44 s55 s66 s77
+*
+* If UPLO = 'L', the array AB holds:
+*
+* on entry: on exit:
+*
+* a11 a22 a33 a44 a55 a66 a77 s11 s22 s33 s44 s55 s66 s77
+* a21 a32 a43 a54 a65 a76 * s12 s23 s34 s54 s65 s76 *
+* a31 a42 a53 a64 a64 * * s13 s24 s53 s64 s75 * *
+*
+* Array elements marked * are not used by the routine.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ONE, ZERO
+ PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL UPPER
+ INTEGER J, KLD, KM, M
+ REAL AJJ
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL SSCAL, SSYR, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN, SQRT
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( KD.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( LDAB.LT.KD+1 ) THEN
+ INFO = -5
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SPBSTF', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+ KLD = MAX( 1, LDAB-1 )
+*
+* Set the splitting point m.
+*
+ M = ( N+KD ) / 2
+*
+ IF( UPPER ) THEN
+*
+* Factorize A(m+1:n,m+1:n) as L**T*L, and update A(1:m,1:m).
+*
+ DO 10 J = N, M + 1, -1
+*
+* Compute s(j,j) and test for non-positive-definiteness.
+*
+ AJJ = AB( KD+1, J )
+ IF( AJJ.LE.ZERO )
+ $ GO TO 50
+ AJJ = SQRT( AJJ )
+ AB( KD+1, J ) = AJJ
+ KM = MIN( J-1, KD )
+*
+* Compute elements j-km:j-1 of the j-th column and update the
+* the leading submatrix within the band.
+*
+ CALL SSCAL( KM, ONE / AJJ, AB( KD+1-KM, J ), 1 )
+ CALL SSYR( 'Upper', KM, -ONE, AB( KD+1-KM, J ), 1,
+ $ AB( KD+1, J-KM ), KLD )
+ 10 CONTINUE
+*
+* Factorize the updated submatrix A(1:m,1:m) as U**T*U.
+*
+ DO 20 J = 1, M
+*
+* Compute s(j,j) and test for non-positive-definiteness.
+*
+ AJJ = AB( KD+1, J )
+ IF( AJJ.LE.ZERO )
+ $ GO TO 50
+ AJJ = SQRT( AJJ )
+ AB( KD+1, J ) = AJJ
+ KM = MIN( KD, M-J )
+*
+* Compute elements j+1:j+km of the j-th row and update the
+* trailing submatrix within the band.
+*
+ IF( KM.GT.0 ) THEN
+ CALL SSCAL( KM, ONE / AJJ, AB( KD, J+1 ), KLD )
+ CALL SSYR( 'Upper', KM, -ONE, AB( KD, J+1 ), KLD,
+ $ AB( KD+1, J+1 ), KLD )
+ END IF
+ 20 CONTINUE
+ ELSE
+*
+* Factorize A(m+1:n,m+1:n) as L**T*L, and update A(1:m,1:m).
+*
+ DO 30 J = N, M + 1, -1
+*
+* Compute s(j,j) and test for non-positive-definiteness.
+*
+ AJJ = AB( 1, J )
+ IF( AJJ.LE.ZERO )
+ $ GO TO 50
+ AJJ = SQRT( AJJ )
+ AB( 1, J ) = AJJ
+ KM = MIN( J-1, KD )
+*
+* Compute elements j-km:j-1 of the j-th row and update the
+* trailing submatrix within the band.
+*
+ CALL SSCAL( KM, ONE / AJJ, AB( KM+1, J-KM ), KLD )
+ CALL SSYR( 'Lower', KM, -ONE, AB( KM+1, J-KM ), KLD,
+ $ AB( 1, J-KM ), KLD )
+ 30 CONTINUE
+*
+* Factorize the updated submatrix A(1:m,1:m) as U**T*U.
+*
+ DO 40 J = 1, M
+*
+* Compute s(j,j) and test for non-positive-definiteness.
+*
+ AJJ = AB( 1, J )
+ IF( AJJ.LE.ZERO )
+ $ GO TO 50
+ AJJ = SQRT( AJJ )
+ AB( 1, J ) = AJJ
+ KM = MIN( KD, M-J )
+*
+* Compute elements j+1:j+km of the j-th column and update the
+* trailing submatrix within the band.
+*
+ IF( KM.GT.0 ) THEN
+ CALL SSCAL( KM, ONE / AJJ, AB( 2, J ), 1 )
+ CALL SSYR( 'Lower', KM, -ONE, AB( 2, J ), 1,
+ $ AB( 1, J+1 ), KLD )
+ END IF
+ 40 CONTINUE
+ END IF
+ RETURN
+*
+ 50 CONTINUE
+ INFO = J
+ RETURN
+*
+* End of SPBSTF
+*
+ END
+ SUBROUTINE SPBSV( UPLO, N, KD, NRHS, AB, LDAB, B, LDB, INFO )
+*
+* -- LAPACK driver routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, KD, LDAB, LDB, N, NRHS
+* ..
+* .. Array Arguments ..
+ REAL AB( LDAB, * ), B( LDB, * )
+* ..
+*
+* Purpose
+* =======
+*
+* SPBSV computes the solution to a real system of linear equations
+* A * X = B,
+* where A is an N-by-N symmetric positive definite band matrix and X
+* and B are N-by-NRHS matrices.
+*
+* The Cholesky decomposition is used to factor A as
+* A = U**T * U, if UPLO = 'U', or
+* A = L * L**T, if UPLO = 'L',
+* where U is an upper triangular band matrix, and L is a lower
+* triangular band matrix, with the same number of superdiagonals or
+* subdiagonals as A. The factored form of A is then used to solve the
+* system of equations A * X = B.
+*
+* Arguments
+* =========
+*
+* UPLO (input) CHARACTER*1
+* = 'U': Upper triangle of A is stored;
+* = 'L': Lower triangle of A is stored.
+*
+* N (input) INTEGER
+* The number of linear equations, i.e., the order of the
+* matrix A. N >= 0.
+*
+* KD (input) INTEGER
+* The number of superdiagonals of the matrix A if UPLO = 'U',
+* or the number of subdiagonals if UPLO = 'L'. KD >= 0.
+*
+* NRHS (input) INTEGER
+* The number of right hand sides, i.e., the number of columns
+* of the matrix B. NRHS >= 0.
+*
+* AB (input/output) REAL array, dimension (LDAB,N)
+* On entry, the upper or lower triangle of the symmetric band
+* matrix A, stored in the first KD+1 rows of the array. The
+* j-th column of A is stored in the j-th column of the array AB
+* as follows:
+* if UPLO = 'U', AB(KD+1+i-j,j) = A(i,j) for max(1,j-KD)<=i<=j;
+* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(N,j+KD).
+* See below for further details.
+*
+* On exit, if INFO = 0, the triangular factor U or L from the
+* Cholesky factorization A = U**T*U or A = L*L**T of the band
+* matrix A, in the same storage format as A.
+*
+* LDAB (input) INTEGER
+* The leading dimension of the array AB. LDAB >= KD+1.
+*
+* B (input/output) REAL array, dimension (LDB,NRHS)
+* On entry, the N-by-NRHS right hand side matrix B.
+* On exit, if INFO = 0, the N-by-NRHS solution matrix X.
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. LDB >= max(1,N).
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* > 0: if INFO = i, the leading minor of order i of A is not
+* positive definite, so the factorization could not be
+* completed, and the solution has not been computed.
+*
+* Further Details
+* ===============
+*
+* The band storage scheme is illustrated by the following example, when
+* N = 6, KD = 2, and UPLO = 'U':
+*
+* On entry: On exit:
+*
+* * * a13 a24 a35 a46 * * u13 u24 u35 u46
+* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56
+* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66
+*
+* Similarly, if UPLO = 'L' the format of A is as follows:
+*
+* On entry: On exit:
+*
+* a11 a22 a33 a44 a55 a66 l11 l22 l33 l44 l55 l66
+* a21 a32 a43 a54 a65 * l21 l32 l43 l54 l65 *
+* a31 a42 a53 a64 * * l31 l42 l53 l64 * *
+*
+* Array elements marked * are not used by the routine.
+*
+* =====================================================================
+*
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL SPBTRF, SPBTRS, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( KD.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( NRHS.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( LDAB.LT.KD+1 ) THEN
+ INFO = -6
+ ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -8
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SPBSV ', -INFO )
+ RETURN
+ END IF
+*
+* Compute the Cholesky factorization A = U'*U or A = L*L'.
+*
+ CALL SPBTRF( UPLO, N, KD, AB, LDAB, INFO )
+ IF( INFO.EQ.0 ) THEN
+*
+* Solve the system A*X = B, overwriting B with X.
+*
+ CALL SPBTRS( UPLO, N, KD, NRHS, AB, LDAB, B, LDB, INFO )
+*
+ END IF
+ RETURN
+*
+* End of SPBSV
+*
+ END
+ SUBROUTINE SPBSVX( FACT, UPLO, N, KD, NRHS, AB, LDAB, AFB, LDAFB,
+ $ EQUED, S, B, LDB, X, LDX, RCOND, FERR, BERR,
+ $ WORK, IWORK, INFO )
+*
+* -- LAPACK driver routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER EQUED, FACT, UPLO
+ INTEGER INFO, KD, LDAB, LDAFB, LDB, LDX, N, NRHS
+ REAL RCOND
+* ..
+* .. Array Arguments ..
+ INTEGER IWORK( * )
+ REAL AB( LDAB, * ), AFB( LDAFB, * ), B( LDB, * ),
+ $ BERR( * ), FERR( * ), S( * ), WORK( * ),
+ $ X( LDX, * )
+* ..
+*
+* Purpose
+* =======
+*
+* SPBSVX uses the Cholesky factorization A = U**T*U or A = L*L**T to
+* compute the solution to a real system of linear equations
+* A * X = B,
+* where A is an N-by-N symmetric positive definite band matrix and X
+* and B are N-by-NRHS matrices.
+*
+* Error bounds on the solution and a condition estimate are also
+* provided.
+*
+* Description
+* ===========
+*
+* The following steps are performed:
+*
+* 1. If FACT = 'E', real scaling factors are computed to equilibrate
+* the system:
+* diag(S) * A * diag(S) * inv(diag(S)) * X = diag(S) * B
+* Whether or not the system will be equilibrated depends on the
+* scaling of the matrix A, but if equilibration is used, A is
+* overwritten by diag(S)*A*diag(S) and B by diag(S)*B.
+*
+* 2. If FACT = 'N' or 'E', the Cholesky decomposition is used to
+* factor the matrix A (after equilibration if FACT = 'E') as
+* A = U**T * U, if UPLO = 'U', or
+* A = L * L**T, if UPLO = 'L',
+* where U is an upper triangular band matrix, and L is a lower
+* triangular band matrix.
+*
+* 3. If the leading i-by-i principal minor is not positive definite,
+* then the routine returns with INFO = i. Otherwise, the factored
+* form of A is used to estimate the condition number of the matrix
+* A. If the reciprocal of the condition number is less than machine
+* precision, INFO = N+1 is returned as a warning, but the routine
+* still goes on to solve for X and compute error bounds as
+* described below.
+*
+* 4. The system of equations is solved for X using the factored form
+* of A.
+*
+* 5. Iterative refinement is applied to improve the computed solution
+* matrix and calculate error bounds and backward error estimates
+* for it.
+*
+* 6. If equilibration was used, the matrix X is premultiplied by
+* diag(S) so that it solves the original system before
+* equilibration.
+*
+* Arguments
+* =========
+*
+* FACT (input) CHARACTER*1
+* Specifies whether or not the factored form of the matrix A is
+* supplied on entry, and if not, whether the matrix A should be
+* equilibrated before it is factored.
+* = 'F': On entry, AFB contains the factored form of A.
+* If EQUED = 'Y', the matrix A has been equilibrated
+* with scaling factors given by S. AB and AFB will not
+* be modified.
+* = 'N': The matrix A will be copied to AFB and factored.
+* = 'E': The matrix A will be equilibrated if necessary, then
+* copied to AFB and factored.
+*
+* UPLO (input) CHARACTER*1
+* = 'U': Upper triangle of A is stored;
+* = 'L': Lower triangle of A is stored.
+*
+* N (input) INTEGER
+* The number of linear equations, i.e., the order of the
+* matrix A. N >= 0.
+*
+* KD (input) INTEGER
+* The number of superdiagonals of the matrix A if UPLO = 'U',
+* or the number of subdiagonals if UPLO = 'L'. KD >= 0.
+*
+* NRHS (input) INTEGER
+* The number of right-hand sides, i.e., the number of columns
+* of the matrices B and X. NRHS >= 0.
+*
+* AB (input/output) REAL array, dimension (LDAB,N)
+* On entry, the upper or lower triangle of the symmetric band
+* matrix A, stored in the first KD+1 rows of the array, except
+* if FACT = 'F' and EQUED = 'Y', then A must contain the
+* equilibrated matrix diag(S)*A*diag(S). The j-th column of A
+* is stored in the j-th column of the array AB as follows:
+* if UPLO = 'U', AB(KD+1+i-j,j) = A(i,j) for max(1,j-KD)<=i<=j;
+* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(N,j+KD).
+* See below for further details.
+*
+* On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by
+* diag(S)*A*diag(S).
+*
+* LDAB (input) INTEGER
+* The leading dimension of the array A. LDAB >= KD+1.
+*
+* AFB (input or output) REAL array, dimension (LDAFB,N)
+* If FACT = 'F', then AFB is an input argument and on entry
+* contains the triangular factor U or L from the Cholesky
+* factorization A = U**T*U or A = L*L**T of the band matrix
+* A, in the same storage format as A (see AB). If EQUED = 'Y',
+* then AFB is the factored form of the equilibrated matrix A.
+*
+* If FACT = 'N', then AFB is an output argument and on exit
+* returns the triangular factor U or L from the Cholesky
+* factorization A = U**T*U or A = L*L**T.
+*
+* If FACT = 'E', then AFB is an output argument and on exit
+* returns the triangular factor U or L from the Cholesky
+* factorization A = U**T*U or A = L*L**T of the equilibrated
+* matrix A (see the description of A for the form of the
+* equilibrated matrix).
+*
+* LDAFB (input) INTEGER
+* The leading dimension of the array AFB. LDAFB >= KD+1.
+*
+* EQUED (input or output) CHARACTER*1
+* Specifies the form of equilibration that was done.
+* = 'N': No equilibration (always true if FACT = 'N').
+* = 'Y': Equilibration was done, i.e., A has been replaced by
+* diag(S) * A * diag(S).
+* EQUED is an input argument if FACT = 'F'; otherwise, it is an
+* output argument.
+*
+* S (input or output) REAL array, dimension (N)
+* The scale factors for A; not accessed if EQUED = 'N'. S is
+* an input argument if FACT = 'F'; otherwise, S is an output
+* argument. If FACT = 'F' and EQUED = 'Y', each element of S
+* must be positive.
+*
+* B (input/output) REAL array, dimension (LDB,NRHS)
+* On entry, the N-by-NRHS right hand side matrix B.
+* On exit, if EQUED = 'N', B is not modified; if EQUED = 'Y',
+* B is overwritten by diag(S) * B.
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. LDB >= max(1,N).
+*
+* X (output) REAL array, dimension (LDX,NRHS)
+* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X to
+* the original system of equations. Note that if EQUED = 'Y',
+* A and B are modified on exit, and the solution to the
+* equilibrated system is inv(diag(S))*X.
+*
+* LDX (input) INTEGER
+* The leading dimension of the array X. LDX >= max(1,N).
+*
+* RCOND (output) REAL
+* The estimate of the reciprocal condition number of the matrix
+* A after equilibration (if done). If RCOND is less than the
+* machine precision (in particular, if RCOND = 0), the matrix
+* is singular to working precision. This condition is
+* indicated by a return code of INFO > 0.
+*
+* FERR (output) REAL array, dimension (NRHS)
+* The estimated forward error bound for each solution vector
+* X(j) (the j-th column of the solution matrix X).
+* If XTRUE is the true solution corresponding to X(j), FERR(j)
+* is an estimated upper bound for the magnitude of the largest
+* element in (X(j) - XTRUE) divided by the magnitude of the
+* largest element in X(j). The estimate is as reliable as
+* the estimate for RCOND, and is almost always a slight
+* overestimate of the true error.
+*
+* BERR (output) REAL array, dimension (NRHS)
+* The componentwise relative backward error of each solution
+* vector X(j) (i.e., the smallest relative change in
+* any element of A or B that makes X(j) an exact solution).
+*
+* WORK (workspace) REAL array, dimension (3*N)
+*
+* IWORK (workspace) INTEGER array, dimension (N)
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* > 0: if INFO = i, and i is
+* <= N: the leading minor of order i of A is
+* not positive definite, so the factorization
+* could not be completed, and the solution has not
+* been computed. RCOND = 0 is returned.
+* = N+1: U is nonsingular, but RCOND is less than machine
+* precision, meaning that the matrix is singular
+* to working precision. Nevertheless, the
+* solution and error bounds are computed because
+* there are a number of situations where the
+* computed solution can be more accurate than the
+* value of RCOND would suggest.
+*
+* Further Details
+* ===============
+*
+* The band storage scheme is illustrated by the following example, when
+* N = 6, KD = 2, and UPLO = 'U':
+*
+* Two-dimensional storage of the symmetric matrix A:
+*
+* a11 a12 a13
+* a22 a23 a24
+* a33 a34 a35
+* a44 a45 a46
+* a55 a56
+* (aij=conjg(aji)) a66
+*
+* Band storage of the upper triangle of A:
+*
+* * * a13 a24 a35 a46
+* * a12 a23 a34 a45 a56
+* a11 a22 a33 a44 a55 a66
+*
+* Similarly, if UPLO = 'L' the format of A is as follows:
+*
+* a11 a22 a33 a44 a55 a66
+* a21 a32 a43 a54 a65 *
+* a31 a42 a53 a64 * *
+*
+* Array elements marked * are not used by the routine.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO, ONE
+ PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL EQUIL, NOFACT, RCEQU, UPPER
+ INTEGER I, INFEQU, J, J1, J2
+ REAL AMAX, ANORM, BIGNUM, SCOND, SMAX, SMIN, SMLNUM
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ REAL SLAMCH, SLANSB
+ EXTERNAL LSAME, SLAMCH, SLANSB
+* ..
+* .. External Subroutines ..
+ EXTERNAL SCOPY, SLACPY, SLAQSB, SPBCON, SPBEQU, SPBRFS,
+ $ SPBTRF, SPBTRS, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+ INFO = 0
+ NOFACT = LSAME( FACT, 'N' )
+ EQUIL = LSAME( FACT, 'E' )
+ UPPER = LSAME( UPLO, 'U' )
+ IF( NOFACT .OR. EQUIL ) THEN
+ EQUED = 'N'
+ RCEQU = .FALSE.
+ ELSE
+ RCEQU = LSAME( EQUED, 'Y' )
+ SMLNUM = SLAMCH( 'Safe minimum' )
+ BIGNUM = ONE / SMLNUM
+ END IF
+*
+* Test the input parameters.
+*
+ IF( .NOT.NOFACT .AND. .NOT.EQUIL .AND. .NOT.LSAME( FACT, 'F' ) )
+ $ THEN
+ INFO = -1
+ ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -2
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( KD.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( NRHS.LT.0 ) THEN
+ INFO = -5
+ ELSE IF( LDAB.LT.KD+1 ) THEN
+ INFO = -7
+ ELSE IF( LDAFB.LT.KD+1 ) THEN
+ INFO = -9
+ ELSE IF( LSAME( FACT, 'F' ) .AND. .NOT.
+ $ ( RCEQU .OR. LSAME( EQUED, 'N' ) ) ) THEN
+ INFO = -10
+ ELSE
+ IF( RCEQU ) THEN
+ SMIN = BIGNUM
+ SMAX = ZERO
+ DO 10 J = 1, N
+ SMIN = MIN( SMIN, S( J ) )
+ SMAX = MAX( SMAX, S( J ) )
+ 10 CONTINUE
+ IF( SMIN.LE.ZERO ) THEN
+ INFO = -11
+ ELSE IF( N.GT.0 ) THEN
+ SCOND = MAX( SMIN, SMLNUM ) / MIN( SMAX, BIGNUM )
+ ELSE
+ SCOND = ONE
+ END IF
+ END IF
+ IF( INFO.EQ.0 ) THEN
+ IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -13
+ ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
+ INFO = -15
+ END IF
+ END IF
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SPBSVX', -INFO )
+ RETURN
+ END IF
+*
+ IF( EQUIL ) THEN
+*
+* Compute row and column scalings to equilibrate the matrix A.
+*
+ CALL SPBEQU( UPLO, N, KD, AB, LDAB, S, SCOND, AMAX, INFEQU )
+ IF( INFEQU.EQ.0 ) THEN
+*
+* Equilibrate the matrix.
+*
+ CALL SLAQSB( UPLO, N, KD, AB, LDAB, S, SCOND, AMAX, EQUED )
+ RCEQU = LSAME( EQUED, 'Y' )
+ END IF
+ END IF
+*
+* Scale the right-hand side.
+*
+ IF( RCEQU ) THEN
+ DO 30 J = 1, NRHS
+ DO 20 I = 1, N
+ B( I, J ) = S( I )*B( I, J )
+ 20 CONTINUE
+ 30 CONTINUE
+ END IF
+*
+ IF( NOFACT .OR. EQUIL ) THEN
+*
+* Compute the Cholesky factorization A = U'*U or A = L*L'.
+*
+ IF( UPPER ) THEN
+ DO 40 J = 1, N
+ J1 = MAX( J-KD, 1 )
+ CALL SCOPY( J-J1+1, AB( KD+1-J+J1, J ), 1,
+ $ AFB( KD+1-J+J1, J ), 1 )
+ 40 CONTINUE
+ ELSE
+ DO 50 J = 1, N
+ J2 = MIN( J+KD, N )
+ CALL SCOPY( J2-J+1, AB( 1, J ), 1, AFB( 1, J ), 1 )
+ 50 CONTINUE
+ END IF
+*
+ CALL SPBTRF( UPLO, N, KD, AFB, LDAFB, INFO )
+*
+* Return if INFO is non-zero.
+*
+ IF( INFO.GT.0 )THEN
+ RCOND = ZERO
+ RETURN
+ END IF
+ END IF
+*
+* Compute the norm of the matrix A.
+*
+ ANORM = SLANSB( '1', UPLO, N, KD, AB, LDAB, WORK )
+*
+* Compute the reciprocal of the condition number of A.
+*
+ CALL SPBCON( UPLO, N, KD, AFB, LDAFB, ANORM, RCOND, WORK, IWORK,
+ $ INFO )
+*
+* Compute the solution matrix X.
+*
+ CALL SLACPY( 'Full', N, NRHS, B, LDB, X, LDX )
+ CALL SPBTRS( UPLO, N, KD, NRHS, AFB, LDAFB, X, LDX, INFO )
+*
+* Use iterative refinement to improve the computed solution and
+* compute error bounds and backward error estimates for it.
+*
+ CALL SPBRFS( UPLO, N, KD, NRHS, AB, LDAB, AFB, LDAFB, B, LDB, X,
+ $ LDX, FERR, BERR, WORK, IWORK, INFO )
+*
+* Transform the solution matrix X to a solution of the original
+* system.
+*
+ IF( RCEQU ) THEN
+ DO 70 J = 1, NRHS
+ DO 60 I = 1, N
+ X( I, J ) = S( I )*X( I, J )
+ 60 CONTINUE
+ 70 CONTINUE
+ DO 80 J = 1, NRHS
+ FERR( J ) = FERR( J ) / SCOND
+ 80 CONTINUE
+ END IF
+*
+* Set INFO = N+1 if the matrix is singular to working precision.
+*
+ IF( RCOND.LT.SLAMCH( 'Epsilon' ) )
+ $ INFO = N + 1
+*
+ RETURN
+*
+* End of SPBSVX
+*
+ END
+ SUBROUTINE SPBTF2( UPLO, N, KD, AB, LDAB, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, KD, LDAB, N
+* ..
+* .. Array Arguments ..
+ REAL AB( LDAB, * )
+* ..
+*
+* Purpose
+* =======
+*
+* SPBTF2 computes the Cholesky factorization of a real symmetric
+* positive definite band matrix A.
+*
+* The factorization has the form
+* A = U' * U , if UPLO = 'U', or
+* A = L * L', if UPLO = 'L',
+* where U is an upper triangular matrix, U' is the transpose of U, and
+* L is lower triangular.
+*
+* This is the unblocked version of the algorithm, calling Level 2 BLAS.
+*
+* Arguments
+* =========
+*
+* UPLO (input) CHARACTER*1
+* Specifies whether the upper or lower triangular part of the
+* symmetric matrix A is stored:
+* = 'U': Upper triangular
+* = 'L': Lower triangular
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* KD (input) INTEGER
+* The number of super-diagonals of the matrix A if UPLO = 'U',
+* or the number of sub-diagonals if UPLO = 'L'. KD >= 0.
+*
+* AB (input/output) REAL array, dimension (LDAB,N)
+* On entry, the upper or lower triangle of the symmetric band
+* matrix A, stored in the first KD+1 rows of the array. The
+* j-th column of A is stored in the j-th column of the array AB
+* as follows:
+* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
+* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).
+*
+* On exit, if INFO = 0, the triangular factor U or L from the
+* Cholesky factorization A = U'*U or A = L*L' of the band
+* matrix A, in the same storage format as A.
+*
+* LDAB (input) INTEGER
+* The leading dimension of the array AB. LDAB >= KD+1.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -k, the k-th argument had an illegal value
+* > 0: if INFO = k, the leading minor of order k is not
+* positive definite, and the factorization could not be
+* completed.
+*
+* Further Details
+* ===============
+*
+* The band storage scheme is illustrated by the following example, when
+* N = 6, KD = 2, and UPLO = 'U':
+*
+* On entry: On exit:
+*
+* * * a13 a24 a35 a46 * * u13 u24 u35 u46
+* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56
+* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66
+*
+* Similarly, if UPLO = 'L' the format of A is as follows:
+*
+* On entry: On exit:
+*
+* a11 a22 a33 a44 a55 a66 l11 l22 l33 l44 l55 l66
+* a21 a32 a43 a54 a65 * l21 l32 l43 l54 l65 *
+* a31 a42 a53 a64 * * l31 l42 l53 l64 * *
+*
+* Array elements marked * are not used by the routine.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ONE, ZERO
+ PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL UPPER
+ INTEGER J, KLD, KN
+ REAL AJJ
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL SSCAL, SSYR, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN, SQRT
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( KD.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( LDAB.LT.KD+1 ) THEN
+ INFO = -5
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SPBTF2', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+ KLD = MAX( 1, LDAB-1 )
+*
+ IF( UPPER ) THEN
+*
+* Compute the Cholesky factorization A = U'*U.
+*
+ DO 10 J = 1, N
+*
+* Compute U(J,J) and test for non-positive-definiteness.
+*
+ AJJ = AB( KD+1, J )
+ IF( AJJ.LE.ZERO )
+ $ GO TO 30
+ AJJ = SQRT( AJJ )
+ AB( KD+1, J ) = AJJ
+*
+* Compute elements J+1:J+KN of row J and update the
+* trailing submatrix within the band.
+*
+ KN = MIN( KD, N-J )
+ IF( KN.GT.0 ) THEN
+ CALL SSCAL( KN, ONE / AJJ, AB( KD, J+1 ), KLD )
+ CALL SSYR( 'Upper', KN, -ONE, AB( KD, J+1 ), KLD,
+ $ AB( KD+1, J+1 ), KLD )
+ END IF
+ 10 CONTINUE
+ ELSE
+*
+* Compute the Cholesky factorization A = L*L'.
+*
+ DO 20 J = 1, N
+*
+* Compute L(J,J) and test for non-positive-definiteness.
+*
+ AJJ = AB( 1, J )
+ IF( AJJ.LE.ZERO )
+ $ GO TO 30
+ AJJ = SQRT( AJJ )
+ AB( 1, J ) = AJJ
+*
+* Compute elements J+1:J+KN of column J and update the
+* trailing submatrix within the band.
+*
+ KN = MIN( KD, N-J )
+ IF( KN.GT.0 ) THEN
+ CALL SSCAL( KN, ONE / AJJ, AB( 2, J ), 1 )
+ CALL SSYR( 'Lower', KN, -ONE, AB( 2, J ), 1,
+ $ AB( 1, J+1 ), KLD )
+ END IF
+ 20 CONTINUE
+ END IF
+ RETURN
+*
+ 30 CONTINUE
+ INFO = J
+ RETURN
+*
+* End of SPBTF2
+*
+ END
+ SUBROUTINE SPBTRF( UPLO, N, KD, AB, LDAB, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, KD, LDAB, N
+* ..
+* .. Array Arguments ..
+ REAL AB( LDAB, * )
+* ..
+*
+* Purpose
+* =======
+*
+* SPBTRF computes the Cholesky factorization of a real symmetric
+* positive definite band matrix A.
+*
+* The factorization has the form
+* A = U**T * U, if UPLO = 'U', or
+* A = L * L**T, if UPLO = 'L',
+* where U is an upper triangular matrix and L is lower triangular.
+*
+* Arguments
+* =========
+*
+* UPLO (input) CHARACTER*1
+* = 'U': Upper triangle of A is stored;
+* = 'L': Lower triangle of A is stored.
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* KD (input) INTEGER
+* The number of superdiagonals of the matrix A if UPLO = 'U',
+* or the number of subdiagonals if UPLO = 'L'. KD >= 0.
+*
+* AB (input/output) REAL array, dimension (LDAB,N)
+* On entry, the upper or lower triangle of the symmetric band
+* matrix A, stored in the first KD+1 rows of the array. The
+* j-th column of A is stored in the j-th column of the array AB
+* as follows:
+* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
+* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).
+*
+* On exit, if INFO = 0, the triangular factor U or L from the
+* Cholesky factorization A = U**T*U or A = L*L**T of the band
+* matrix A, in the same storage format as A.
+*
+* LDAB (input) INTEGER
+* The leading dimension of the array AB. LDAB >= KD+1.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* > 0: if INFO = i, the leading minor of order i is not
+* positive definite, and the factorization could not be
+* completed.
+*
+* Further Details
+* ===============
+*
+* The band storage scheme is illustrated by the following example, when
+* N = 6, KD = 2, and UPLO = 'U':
+*
+* On entry: On exit:
+*
+* * * a13 a24 a35 a46 * * u13 u24 u35 u46
+* * a12 a23 a34 a45 a56 * u12 u23 u34 u45 u56
+* a11 a22 a33 a44 a55 a66 u11 u22 u33 u44 u55 u66
+*
+* Similarly, if UPLO = 'L' the format of A is as follows:
+*
+* On entry: On exit:
+*
+* a11 a22 a33 a44 a55 a66 l11 l22 l33 l44 l55 l66
+* a21 a32 a43 a54 a65 * l21 l32 l43 l54 l65 *
+* a31 a42 a53 a64 * * l31 l42 l53 l64 * *
+*
+* Array elements marked * are not used by the routine.
+*
+* Contributed by
+* Peter Mayes and Giuseppe Radicati, IBM ECSEC, Rome, March 23, 1989
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ONE, ZERO
+ PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+ INTEGER NBMAX, LDWORK
+ PARAMETER ( NBMAX = 32, LDWORK = NBMAX+1 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, I2, I3, IB, II, J, JJ, NB
+* ..
+* .. Local Arrays ..
+ REAL WORK( LDWORK, NBMAX )
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ILAENV
+ EXTERNAL LSAME, ILAENV
+* ..
+* .. External Subroutines ..
+ EXTERNAL SGEMM, SPBTF2, SPOTF2, SSYRK, STRSM, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MIN
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ IF( ( .NOT.LSAME( UPLO, 'U' ) ) .AND.
+ $ ( .NOT.LSAME( UPLO, 'L' ) ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( KD.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( LDAB.LT.KD+1 ) THEN
+ INFO = -5
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SPBTRF', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+* Determine the block size for this environment
+*
+ NB = ILAENV( 1, 'SPBTRF', UPLO, N, KD, -1, -1 )
+*
+* The block size must not exceed the semi-bandwidth KD, and must not
+* exceed the limit set by the size of the local array WORK.
+*
+ NB = MIN( NB, NBMAX )
+*
+ IF( NB.LE.1 .OR. NB.GT.KD ) THEN
+*
+* Use unblocked code
+*
+ CALL SPBTF2( UPLO, N, KD, AB, LDAB, INFO )
+ ELSE
+*
+* Use blocked code
+*
+ IF( LSAME( UPLO, 'U' ) ) THEN
+*
+* Compute the Cholesky factorization of a symmetric band
+* matrix, given the upper triangle of the matrix in band
+* storage.
+*
+* Zero the upper triangle of the work array.
+*
+ DO 20 J = 1, NB
+ DO 10 I = 1, J - 1
+ WORK( I, J ) = ZERO
+ 10 CONTINUE
+ 20 CONTINUE
+*
+* Process the band matrix one diagonal block at a time.
+*
+ DO 70 I = 1, N, NB
+ IB = MIN( NB, N-I+1 )
+*
+* Factorize the diagonal block
+*
+ CALL SPOTF2( UPLO, IB, AB( KD+1, I ), LDAB-1, II )
+ IF( II.NE.0 ) THEN
+ INFO = I + II - 1
+ GO TO 150
+ END IF
+ IF( I+IB.LE.N ) THEN
+*
+* Update the relevant part of the trailing submatrix.
+* If A11 denotes the diagonal block which has just been
+* factorized, then we need to update the remaining
+* blocks in the diagram:
+*
+* A11 A12 A13
+* A22 A23
+* A33
+*
+* The numbers of rows and columns in the partitioning
+* are IB, I2, I3 respectively. The blocks A12, A22 and
+* A23 are empty if IB = KD. The upper triangle of A13
+* lies outside the band.
+*
+ I2 = MIN( KD-IB, N-I-IB+1 )
+ I3 = MIN( IB, N-I-KD+1 )
+*
+ IF( I2.GT.0 ) THEN
+*
+* Update A12
+*
+ CALL STRSM( 'Left', 'Upper', 'Transpose',
+ $ 'Non-unit', IB, I2, ONE, AB( KD+1, I ),
+ $ LDAB-1, AB( KD+1-IB, I+IB ), LDAB-1 )
+*
+* Update A22
+*
+ CALL SSYRK( 'Upper', 'Transpose', I2, IB, -ONE,
+ $ AB( KD+1-IB, I+IB ), LDAB-1, ONE,
+ $ AB( KD+1, I+IB ), LDAB-1 )
+ END IF
+*
+ IF( I3.GT.0 ) THEN
+*
+* Copy the lower triangle of A13 into the work array.
+*
+ DO 40 JJ = 1, I3
+ DO 30 II = JJ, IB
+ WORK( II, JJ ) = AB( II-JJ+1, JJ+I+KD-1 )
+ 30 CONTINUE
+ 40 CONTINUE
+*
+* Update A13 (in the work array).
+*
+ CALL STRSM( 'Left', 'Upper', 'Transpose',
+ $ 'Non-unit', IB, I3, ONE, AB( KD+1, I ),
+ $ LDAB-1, WORK, LDWORK )
+*
+* Update A23
+*
+ IF( I2.GT.0 )
+ $ CALL SGEMM( 'Transpose', 'No Transpose', I2, I3,
+ $ IB, -ONE, AB( KD+1-IB, I+IB ),
+ $ LDAB-1, WORK, LDWORK, ONE,
+ $ AB( 1+IB, I+KD ), LDAB-1 )
+*
+* Update A33
+*
+ CALL SSYRK( 'Upper', 'Transpose', I3, IB, -ONE,
+ $ WORK, LDWORK, ONE, AB( KD+1, I+KD ),
+ $ LDAB-1 )
+*
+* Copy the lower triangle of A13 back into place.
+*
+ DO 60 JJ = 1, I3
+ DO 50 II = JJ, IB
+ AB( II-JJ+1, JJ+I+KD-1 ) = WORK( II, JJ )
+ 50 CONTINUE
+ 60 CONTINUE
+ END IF
+ END IF
+ 70 CONTINUE
+ ELSE
+*
+* Compute the Cholesky factorization of a symmetric band
+* matrix, given the lower triangle of the matrix in band
+* storage.
+*
+* Zero the lower triangle of the work array.
+*
+ DO 90 J = 1, NB
+ DO 80 I = J + 1, NB
+ WORK( I, J ) = ZERO
+ 80 CONTINUE
+ 90 CONTINUE
+*
+* Process the band matrix one diagonal block at a time.
+*
+ DO 140 I = 1, N, NB
+ IB = MIN( NB, N-I+1 )
+*
+* Factorize the diagonal block
+*
+ CALL SPOTF2( UPLO, IB, AB( 1, I ), LDAB-1, II )
+ IF( II.NE.0 ) THEN
+ INFO = I + II - 1
+ GO TO 150
+ END IF
+ IF( I+IB.LE.N ) THEN
+*
+* Update the relevant part of the trailing submatrix.
+* If A11 denotes the diagonal block which has just been
+* factorized, then we need to update the remaining
+* blocks in the diagram:
+*
+* A11
+* A21 A22
+* A31 A32 A33
+*
+* The numbers of rows and columns in the partitioning
+* are IB, I2, I3 respectively. The blocks A21, A22 and
+* A32 are empty if IB = KD. The lower triangle of A31
+* lies outside the band.
+*
+ I2 = MIN( KD-IB, N-I-IB+1 )
+ I3 = MIN( IB, N-I-KD+1 )
+*
+ IF( I2.GT.0 ) THEN
+*
+* Update A21
+*
+ CALL STRSM( 'Right', 'Lower', 'Transpose',
+ $ 'Non-unit', I2, IB, ONE, AB( 1, I ),
+ $ LDAB-1, AB( 1+IB, I ), LDAB-1 )
+*
+* Update A22
+*
+ CALL SSYRK( 'Lower', 'No Transpose', I2, IB, -ONE,
+ $ AB( 1+IB, I ), LDAB-1, ONE,
+ $ AB( 1, I+IB ), LDAB-1 )
+ END IF
+*
+ IF( I3.GT.0 ) THEN
+*
+* Copy the upper triangle of A31 into the work array.
+*
+ DO 110 JJ = 1, IB
+ DO 100 II = 1, MIN( JJ, I3 )
+ WORK( II, JJ ) = AB( KD+1-JJ+II, JJ+I-1 )
+ 100 CONTINUE
+ 110 CONTINUE
+*
+* Update A31 (in the work array).
+*
+ CALL STRSM( 'Right', 'Lower', 'Transpose',
+ $ 'Non-unit', I3, IB, ONE, AB( 1, I ),
+ $ LDAB-1, WORK, LDWORK )
+*
+* Update A32
+*
+ IF( I2.GT.0 )
+ $ CALL SGEMM( 'No transpose', 'Transpose', I3, I2,
+ $ IB, -ONE, WORK, LDWORK,
+ $ AB( 1+IB, I ), LDAB-1, ONE,
+ $ AB( 1+KD-IB, I+IB ), LDAB-1 )
+*
+* Update A33
+*
+ CALL SSYRK( 'Lower', 'No Transpose', I3, IB, -ONE,
+ $ WORK, LDWORK, ONE, AB( 1, I+KD ),
+ $ LDAB-1 )
+*
+* Copy the upper triangle of A31 back into place.
+*
+ DO 130 JJ = 1, IB
+ DO 120 II = 1, MIN( JJ, I3 )
+ AB( KD+1-JJ+II, JJ+I-1 ) = WORK( II, JJ )
+ 120 CONTINUE
+ 130 CONTINUE
+ END IF
+ END IF
+ 140 CONTINUE
+ END IF
+ END IF
+ RETURN
+*
+ 150 CONTINUE
+ RETURN
+*
+* End of SPBTRF
+*
+ END
+ SUBROUTINE SPBTRS( UPLO, N, KD, NRHS, AB, LDAB, B, LDB, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, KD, LDAB, LDB, N, NRHS
+* ..
+* .. Array Arguments ..
+ REAL AB( LDAB, * ), B( LDB, * )
+* ..
+*
+* Purpose
+* =======
+*
+* SPBTRS solves a system of linear equations A*X = B with a symmetric
+* positive definite band matrix A using the Cholesky factorization
+* A = U**T*U or A = L*L**T computed by SPBTRF.
+*
+* Arguments
+* =========
+*
+* UPLO (input) CHARACTER*1
+* = 'U': Upper triangular factor stored in AB;
+* = 'L': Lower triangular factor stored in AB.
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* KD (input) INTEGER
+* The number of superdiagonals of the matrix A if UPLO = 'U',
+* or the number of subdiagonals if UPLO = 'L'. KD >= 0.
+*
+* NRHS (input) INTEGER
+* The number of right hand sides, i.e., the number of columns
+* of the matrix B. NRHS >= 0.
+*
+* AB (input) REAL array, dimension (LDAB,N)
+* The triangular factor U or L from the Cholesky factorization
+* A = U**T*U or A = L*L**T of the band matrix A, stored in the
+* first KD+1 rows of the array. The j-th column of U or L is
+* stored in the j-th column of the array AB as follows:
+* if UPLO ='U', AB(kd+1+i-j,j) = U(i,j) for max(1,j-kd)<=i<=j;
+* if UPLO ='L', AB(1+i-j,j) = L(i,j) for j<=i<=min(n,j+kd).
+*
+* LDAB (input) INTEGER
+* The leading dimension of the array AB. LDAB >= KD+1.
+*
+* B (input/output) REAL array, dimension (LDB,NRHS)
+* On entry, the right hand side matrix B.
+* On exit, the solution matrix X.
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. LDB >= max(1,N).
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ LOGICAL UPPER
+ INTEGER J
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL STBSV, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( KD.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( NRHS.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( LDAB.LT.KD+1 ) THEN
+ INFO = -6
+ ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -8
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SPBTRS', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 .OR. NRHS.EQ.0 )
+ $ RETURN
+*
+ IF( UPPER ) THEN
+*
+* Solve A*X = B where A = U'*U.
+*
+ DO 10 J = 1, NRHS
+*
+* Solve U'*X = B, overwriting B with X.
+*
+ CALL STBSV( 'Upper', 'Transpose', 'Non-unit', N, KD, AB,
+ $ LDAB, B( 1, J ), 1 )
+*
+* Solve U*X = B, overwriting B with X.
+*
+ CALL STBSV( 'Upper', 'No transpose', 'Non-unit', N, KD, AB,
+ $ LDAB, B( 1, J ), 1 )
+ 10 CONTINUE
+ ELSE
+*
+* Solve A*X = B where A = L*L'.
+*
+ DO 20 J = 1, NRHS
+*
+* Solve L*X = B, overwriting B with X.
+*
+ CALL STBSV( 'Lower', 'No transpose', 'Non-unit', N, KD, AB,
+ $ LDAB, B( 1, J ), 1 )
+*
+* Solve L'*X = B, overwriting B with X.
+*
+ CALL STBSV( 'Lower', 'Transpose', 'Non-unit', N, KD, AB,
+ $ LDAB, B( 1, J ), 1 )
+ 20 CONTINUE
+ END IF
+*
+ RETURN
+*
+* End of SPBTRS
+*
+ END
+ SUBROUTINE SPOCON( UPLO, N, A, LDA, ANORM, RCOND, WORK, IWORK,
+ $ INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* Modified to call SLACN2 in place of SLACON, 7 Feb 03, SJH.
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, LDA, N
+ REAL ANORM, RCOND
+* ..
+* .. Array Arguments ..
+ INTEGER IWORK( * )
+ REAL A( LDA, * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SPOCON estimates the reciprocal of the condition number (in the
+* 1-norm) of a real symmetric positive definite matrix using the
+* Cholesky factorization A = U**T*U or A = L*L**T computed by SPOTRF.
+*
+* An estimate is obtained for norm(inv(A)), and the reciprocal of the
+* condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).
+*
+* Arguments
+* =========
+*
+* UPLO (input) CHARACTER*1
+* = 'U': Upper triangle of A is stored;
+* = 'L': Lower triangle of A is stored.
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* A (input) REAL array, dimension (LDA,N)
+* The triangular factor U or L from the Cholesky factorization
+* A = U**T*U or A = L*L**T, as computed by SPOTRF.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,N).
+*
+* ANORM (input) REAL
+* The 1-norm (or infinity-norm) of the symmetric matrix A.
+*
+* RCOND (output) REAL
+* The reciprocal of the condition number of the matrix A,
+* computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an
+* estimate of the 1-norm of inv(A) computed in this routine.
+*
+* WORK (workspace) REAL array, dimension (3*N)
+*
+* IWORK (workspace) INTEGER array, dimension (N)
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ONE, ZERO
+ PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL UPPER
+ CHARACTER NORMIN
+ INTEGER IX, KASE
+ REAL AINVNM, SCALE, SCALEL, SCALEU, SMLNUM
+* ..
+* .. Local Arrays ..
+ INTEGER ISAVE( 3 )
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ISAMAX
+ REAL SLAMCH
+ EXTERNAL LSAME, ISAMAX, SLAMCH
+* ..
+* .. External Subroutines ..
+ EXTERNAL SLACN2, SLATRS, SRSCL, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -4
+ ELSE IF( ANORM.LT.ZERO ) THEN
+ INFO = -5
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SPOCON', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ RCOND = ZERO
+ IF( N.EQ.0 ) THEN
+ RCOND = ONE
+ RETURN
+ ELSE IF( ANORM.EQ.ZERO ) THEN
+ RETURN
+ END IF
+*
+ SMLNUM = SLAMCH( 'Safe minimum' )
+*
+* Estimate the 1-norm of inv(A).
+*
+ KASE = 0
+ NORMIN = 'N'
+ 10 CONTINUE
+ CALL SLACN2( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE, ISAVE )
+ IF( KASE.NE.0 ) THEN
+ IF( UPPER ) THEN
+*
+* Multiply by inv(U').
+*
+ CALL SLATRS( 'Upper', 'Transpose', 'Non-unit', NORMIN, N, A,
+ $ LDA, WORK, SCALEL, WORK( 2*N+1 ), INFO )
+ NORMIN = 'Y'
+*
+* Multiply by inv(U).
+*
+ CALL SLATRS( 'Upper', 'No transpose', 'Non-unit', NORMIN, N,
+ $ A, LDA, WORK, SCALEU, WORK( 2*N+1 ), INFO )
+ ELSE
+*
+* Multiply by inv(L).
+*
+ CALL SLATRS( 'Lower', 'No transpose', 'Non-unit', NORMIN, N,
+ $ A, LDA, WORK, SCALEL, WORK( 2*N+1 ), INFO )
+ NORMIN = 'Y'
+*
+* Multiply by inv(L').
+*
+ CALL SLATRS( 'Lower', 'Transpose', 'Non-unit', NORMIN, N, A,
+ $ LDA, WORK, SCALEU, WORK( 2*N+1 ), INFO )
+ END IF
+*
+* Multiply by 1/SCALE if doing so will not cause overflow.
+*
+ SCALE = SCALEL*SCALEU
+ IF( SCALE.NE.ONE ) THEN
+ IX = ISAMAX( N, WORK, 1 )
+ IF( SCALE.LT.ABS( WORK( IX ) )*SMLNUM .OR. SCALE.EQ.ZERO )
+ $ GO TO 20
+ CALL SRSCL( N, SCALE, WORK, 1 )
+ END IF
+ GO TO 10
+ END IF
+*
+* Compute the estimate of the reciprocal condition number.
+*
+ IF( AINVNM.NE.ZERO )
+ $ RCOND = ( ONE / AINVNM ) / ANORM
+*
+ 20 CONTINUE
+ RETURN
+*
+* End of SPOCON
+*
+ END
+ SUBROUTINE SPOEQU( N, A, LDA, S, SCOND, AMAX, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LDA, N
+ REAL AMAX, SCOND
+* ..
+* .. Array Arguments ..
+ REAL A( LDA, * ), S( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SPOEQU computes row and column scalings intended to equilibrate a
+* symmetric positive definite matrix A and reduce its condition number
+* (with respect to the two-norm). S contains the scale factors,
+* S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with
+* elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal. This
+* choice of S puts the condition number of B within a factor N of the
+* smallest possible condition number over all possible diagonal
+* scalings.
+*
+* Arguments
+* =========
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* A (input) REAL array, dimension (LDA,N)
+* The N-by-N symmetric positive definite matrix whose scaling
+* factors are to be computed. Only the diagonal elements of A
+* are referenced.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,N).
+*
+* S (output) REAL array, dimension (N)
+* If INFO = 0, S contains the scale factors for A.
+*
+* SCOND (output) REAL
+* If INFO = 0, S contains the ratio of the smallest S(i) to
+* the largest S(i). If SCOND >= 0.1 and AMAX is neither too
+* large nor too small, it is not worth scaling by S.
+*
+* AMAX (output) REAL
+* Absolute value of largest matrix element. If AMAX is very
+* close to overflow or very close to underflow, the matrix
+* should be scaled.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* > 0: if INFO = i, the i-th diagonal element is nonpositive.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO, ONE
+ PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I
+ REAL SMIN
+* ..
+* .. External Subroutines ..
+ EXTERNAL XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN, SQRT
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ IF( N.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -3
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SPOEQU', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 ) THEN
+ SCOND = ONE
+ AMAX = ZERO
+ RETURN
+ END IF
+*
+* Find the minimum and maximum diagonal elements.
+*
+ S( 1 ) = A( 1, 1 )
+ SMIN = S( 1 )
+ AMAX = S( 1 )
+ DO 10 I = 2, N
+ S( I ) = A( I, I )
+ SMIN = MIN( SMIN, S( I ) )
+ AMAX = MAX( AMAX, S( I ) )
+ 10 CONTINUE
+*
+ IF( SMIN.LE.ZERO ) THEN
+*
+* Find the first non-positive diagonal element and return.
+*
+ DO 20 I = 1, N
+ IF( S( I ).LE.ZERO ) THEN
+ INFO = I
+ RETURN
+ END IF
+ 20 CONTINUE
+ ELSE
+*
+* Set the scale factors to the reciprocals
+* of the diagonal elements.
+*
+ DO 30 I = 1, N
+ S( I ) = ONE / SQRT( S( I ) )
+ 30 CONTINUE
+*
+* Compute SCOND = min(S(I)) / max(S(I))
+*
+ SCOND = SQRT( SMIN ) / SQRT( AMAX )
+ END IF
+ RETURN
+*
+* End of SPOEQU
+*
+ END
+ SUBROUTINE SPORFS( UPLO, N, NRHS, A, LDA, AF, LDAF, B, LDB, X,
+ $ LDX, FERR, BERR, WORK, IWORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* Modified to call SLACN2 in place of SLACON, 7 Feb 03, SJH.
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS
+* ..
+* .. Array Arguments ..
+ INTEGER IWORK( * )
+ REAL A( LDA, * ), AF( LDAF, * ), B( LDB, * ),
+ $ BERR( * ), FERR( * ), WORK( * ), X( LDX, * )
+* ..
+*
+* Purpose
+* =======
+*
+* SPORFS improves the computed solution to a system of linear
+* equations when the coefficient matrix is symmetric positive definite,
+* and provides error bounds and backward error estimates for the
+* solution.
+*
+* Arguments
+* =========
+*
+* UPLO (input) CHARACTER*1
+* = 'U': Upper triangle of A is stored;
+* = 'L': Lower triangle of A is stored.
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* NRHS (input) INTEGER
+* The number of right hand sides, i.e., the number of columns
+* of the matrices B and X. NRHS >= 0.
+*
+* A (input) REAL array, dimension (LDA,N)
+* The symmetric matrix A. If UPLO = 'U', the leading N-by-N
+* upper triangular part of A contains the upper triangular part
+* of the matrix A, and the strictly lower triangular part of A
+* is not referenced. If UPLO = 'L', the leading N-by-N lower
+* triangular part of A contains the lower triangular part of
+* the matrix A, and the strictly upper triangular part of A is
+* not referenced.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,N).
+*
+* AF (input) REAL array, dimension (LDAF,N)
+* The triangular factor U or L from the Cholesky factorization
+* A = U**T*U or A = L*L**T, as computed by SPOTRF.
+*
+* LDAF (input) INTEGER
+* The leading dimension of the array AF. LDAF >= max(1,N).
+*
+* B (input) REAL array, dimension (LDB,NRHS)
+* The right hand side matrix B.
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. LDB >= max(1,N).
+*
+* X (input/output) REAL array, dimension (LDX,NRHS)
+* On entry, the solution matrix X, as computed by SPOTRS.
+* On exit, the improved solution matrix X.
+*
+* LDX (input) INTEGER
+* The leading dimension of the array X. LDX >= max(1,N).
+*
+* FERR (output) REAL array, dimension (NRHS)
+* The estimated forward error bound for each solution vector
+* X(j) (the j-th column of the solution matrix X).
+* If XTRUE is the true solution corresponding to X(j), FERR(j)
+* is an estimated upper bound for the magnitude of the largest
+* element in (X(j) - XTRUE) divided by the magnitude of the
+* largest element in X(j). The estimate is as reliable as
+* the estimate for RCOND, and is almost always a slight
+* overestimate of the true error.
+*
+* BERR (output) REAL array, dimension (NRHS)
+* The componentwise relative backward error of each solution
+* vector X(j) (i.e., the smallest relative change in
+* any element of A or B that makes X(j) an exact solution).
+*
+* WORK (workspace) REAL array, dimension (3*N)
+*
+* IWORK (workspace) INTEGER array, dimension (N)
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+*
+* Internal Parameters
+* ===================
+*
+* ITMAX is the maximum number of steps of iterative refinement.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ INTEGER ITMAX
+ PARAMETER ( ITMAX = 5 )
+ REAL ZERO
+ PARAMETER ( ZERO = 0.0E+0 )
+ REAL ONE
+ PARAMETER ( ONE = 1.0E+0 )
+ REAL TWO
+ PARAMETER ( TWO = 2.0E+0 )
+ REAL THREE
+ PARAMETER ( THREE = 3.0E+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL UPPER
+ INTEGER COUNT, I, J, K, KASE, NZ
+ REAL EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK
+* ..
+* .. Local Arrays ..
+ INTEGER ISAVE( 3 )
+* ..
+* .. External Subroutines ..
+ EXTERNAL SAXPY, SCOPY, SLACN2, SPOTRS, SSYMV, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ REAL SLAMCH
+ EXTERNAL LSAME, SLAMCH
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( NRHS.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -5
+ ELSE IF( LDAF.LT.MAX( 1, N ) ) THEN
+ INFO = -7
+ ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -9
+ ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
+ INFO = -11
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SPORFS', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN
+ DO 10 J = 1, NRHS
+ FERR( J ) = ZERO
+ BERR( J ) = ZERO
+ 10 CONTINUE
+ RETURN
+ END IF
+*
+* NZ = maximum number of nonzero elements in each row of A, plus 1
+*
+ NZ = N + 1
+ EPS = SLAMCH( 'Epsilon' )
+ SAFMIN = SLAMCH( 'Safe minimum' )
+ SAFE1 = NZ*SAFMIN
+ SAFE2 = SAFE1 / EPS
+*
+* Do for each right hand side
+*
+ DO 140 J = 1, NRHS
+*
+ COUNT = 1
+ LSTRES = THREE
+ 20 CONTINUE
+*
+* Loop until stopping criterion is satisfied.
+*
+* Compute residual R = B - A * X
+*
+ CALL SCOPY( N, B( 1, J ), 1, WORK( N+1 ), 1 )
+ CALL SSYMV( UPLO, N, -ONE, A, LDA, X( 1, J ), 1, ONE,
+ $ WORK( N+1 ), 1 )
+*
+* Compute componentwise relative backward error from formula
+*
+* max(i) ( abs(R(i)) / ( abs(A)*abs(X) + abs(B) )(i) )
+*
+* where abs(Z) is the componentwise absolute value of the matrix
+* or vector Z. If the i-th component of the denominator is less
+* than SAFE2, then SAFE1 is added to the i-th components of the
+* numerator and denominator before dividing.
+*
+ DO 30 I = 1, N
+ WORK( I ) = ABS( B( I, J ) )
+ 30 CONTINUE
+*
+* Compute abs(A)*abs(X) + abs(B).
+*
+ IF( UPPER ) THEN
+ DO 50 K = 1, N
+ S = ZERO
+ XK = ABS( X( K, J ) )
+ DO 40 I = 1, K - 1
+ WORK( I ) = WORK( I ) + ABS( A( I, K ) )*XK
+ S = S + ABS( A( I, K ) )*ABS( X( I, J ) )
+ 40 CONTINUE
+ WORK( K ) = WORK( K ) + ABS( A( K, K ) )*XK + S
+ 50 CONTINUE
+ ELSE
+ DO 70 K = 1, N
+ S = ZERO
+ XK = ABS( X( K, J ) )
+ WORK( K ) = WORK( K ) + ABS( A( K, K ) )*XK
+ DO 60 I = K + 1, N
+ WORK( I ) = WORK( I ) + ABS( A( I, K ) )*XK
+ S = S + ABS( A( I, K ) )*ABS( X( I, J ) )
+ 60 CONTINUE
+ WORK( K ) = WORK( K ) + S
+ 70 CONTINUE
+ END IF
+ S = ZERO
+ DO 80 I = 1, N
+ IF( WORK( I ).GT.SAFE2 ) THEN
+ S = MAX( S, ABS( WORK( N+I ) ) / WORK( I ) )
+ ELSE
+ S = MAX( S, ( ABS( WORK( N+I ) )+SAFE1 ) /
+ $ ( WORK( I )+SAFE1 ) )
+ END IF
+ 80 CONTINUE
+ BERR( J ) = S
+*
+* Test stopping criterion. Continue iterating if
+* 1) The residual BERR(J) is larger than machine epsilon, and
+* 2) BERR(J) decreased by at least a factor of 2 during the
+* last iteration, and
+* 3) At most ITMAX iterations tried.
+*
+ IF( BERR( J ).GT.EPS .AND. TWO*BERR( J ).LE.LSTRES .AND.
+ $ COUNT.LE.ITMAX ) THEN
+*
+* Update solution and try again.
+*
+ CALL SPOTRS( UPLO, N, 1, AF, LDAF, WORK( N+1 ), N, INFO )
+ CALL SAXPY( N, ONE, WORK( N+1 ), 1, X( 1, J ), 1 )
+ LSTRES = BERR( J )
+ COUNT = COUNT + 1
+ GO TO 20
+ END IF
+*
+* Bound error from formula
+*
+* norm(X - XTRUE) / norm(X) .le. FERR =
+* norm( abs(inv(A))*
+* ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X)
+*
+* where
+* norm(Z) is the magnitude of the largest component of Z
+* inv(A) is the inverse of A
+* abs(Z) is the componentwise absolute value of the matrix or
+* vector Z
+* NZ is the maximum number of nonzeros in any row of A, plus 1
+* EPS is machine epsilon
+*
+* The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B))
+* is incremented by SAFE1 if the i-th component of
+* abs(A)*abs(X) + abs(B) is less than SAFE2.
+*
+* Use SLACN2 to estimate the infinity-norm of the matrix
+* inv(A) * diag(W),
+* where W = abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) )))
+*
+ DO 90 I = 1, N
+ IF( WORK( I ).GT.SAFE2 ) THEN
+ WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I )
+ ELSE
+ WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I ) + SAFE1
+ END IF
+ 90 CONTINUE
+*
+ KASE = 0
+ 100 CONTINUE
+ CALL SLACN2( N, WORK( 2*N+1 ), WORK( N+1 ), IWORK, FERR( J ),
+ $ KASE, ISAVE )
+ IF( KASE.NE.0 ) THEN
+ IF( KASE.EQ.1 ) THEN
+*
+* Multiply by diag(W)*inv(A').
+*
+ CALL SPOTRS( UPLO, N, 1, AF, LDAF, WORK( N+1 ), N, INFO )
+ DO 110 I = 1, N
+ WORK( N+I ) = WORK( I )*WORK( N+I )
+ 110 CONTINUE
+ ELSE IF( KASE.EQ.2 ) THEN
+*
+* Multiply by inv(A)*diag(W).
+*
+ DO 120 I = 1, N
+ WORK( N+I ) = WORK( I )*WORK( N+I )
+ 120 CONTINUE
+ CALL SPOTRS( UPLO, N, 1, AF, LDAF, WORK( N+1 ), N, INFO )
+ END IF
+ GO TO 100
+ END IF
+*
+* Normalize error.
+*
+ LSTRES = ZERO
+ DO 130 I = 1, N
+ LSTRES = MAX( LSTRES, ABS( X( I, J ) ) )
+ 130 CONTINUE
+ IF( LSTRES.NE.ZERO )
+ $ FERR( J ) = FERR( J ) / LSTRES
+*
+ 140 CONTINUE
+*
+ RETURN
+*
+* End of SPORFS
+*
+ END
+ SUBROUTINE SPOSV( UPLO, N, NRHS, A, LDA, B, LDB, INFO )
+*
+* -- LAPACK driver routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, LDA, LDB, N, NRHS
+* ..
+* .. Array Arguments ..
+ REAL A( LDA, * ), B( LDB, * )
+* ..
+*
+* Purpose
+* =======
+*
+* SPOSV computes the solution to a real system of linear equations
+* A * X = B,
+* where A is an N-by-N symmetric positive definite matrix and X and B
+* are N-by-NRHS matrices.
+*
+* The Cholesky decomposition is used to factor A as
+* A = U**T* U, if UPLO = 'U', or
+* A = L * L**T, if UPLO = 'L',
+* where U is an upper triangular matrix and L is a lower triangular
+* matrix. The factored form of A is then used to solve the system of
+* equations A * X = B.
+*
+* Arguments
+* =========
+*
+* UPLO (input) CHARACTER*1
+* = 'U': Upper triangle of A is stored;
+* = 'L': Lower triangle of A is stored.
+*
+* N (input) INTEGER
+* The number of linear equations, i.e., the order of the
+* matrix A. N >= 0.
+*
+* NRHS (input) INTEGER
+* The number of right hand sides, i.e., the number of columns
+* of the matrix B. NRHS >= 0.
+*
+* A (input/output) REAL array, dimension (LDA,N)
+* On entry, the symmetric matrix A. If UPLO = 'U', the leading
+* N-by-N upper triangular part of A contains the upper
+* triangular part of the matrix A, and the strictly lower
+* triangular part of A is not referenced. If UPLO = 'L', the
+* leading N-by-N lower triangular part of A contains the lower
+* triangular part of the matrix A, and the strictly upper
+* triangular part of A is not referenced.
+*
+* On exit, if INFO = 0, the factor U or L from the Cholesky
+* factorization A = U**T*U or A = L*L**T.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,N).
+*
+* B (input/output) REAL array, dimension (LDB,NRHS)
+* On entry, the N-by-NRHS right hand side matrix B.
+* On exit, if INFO = 0, the N-by-NRHS solution matrix X.
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. LDB >= max(1,N).
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* > 0: if INFO = i, the leading minor of order i of A is not
+* positive definite, so the factorization could not be
+* completed, and the solution has not been computed.
+*
+* =====================================================================
+*
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL SPOTRF, SPOTRS, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( NRHS.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -5
+ ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -7
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SPOSV ', -INFO )
+ RETURN
+ END IF
+*
+* Compute the Cholesky factorization A = U'*U or A = L*L'.
+*
+ CALL SPOTRF( UPLO, N, A, LDA, INFO )
+ IF( INFO.EQ.0 ) THEN
+*
+* Solve the system A*X = B, overwriting B with X.
+*
+ CALL SPOTRS( UPLO, N, NRHS, A, LDA, B, LDB, INFO )
+*
+ END IF
+ RETURN
+*
+* End of SPOSV
+*
+ END
+ SUBROUTINE SPOSVX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, EQUED,
+ $ S, B, LDB, X, LDX, RCOND, FERR, BERR, WORK,
+ $ IWORK, INFO )
+*
+* -- LAPACK driver routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER EQUED, FACT, UPLO
+ INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS
+ REAL RCOND
+* ..
+* .. Array Arguments ..
+ INTEGER IWORK( * )
+ REAL A( LDA, * ), AF( LDAF, * ), B( LDB, * ),
+ $ BERR( * ), FERR( * ), S( * ), WORK( * ),
+ $ X( LDX, * )
+* ..
+*
+* Purpose
+* =======
+*
+* SPOSVX uses the Cholesky factorization A = U**T*U or A = L*L**T to
+* compute the solution to a real system of linear equations
+* A * X = B,
+* where A is an N-by-N symmetric positive definite matrix and X and B
+* are N-by-NRHS matrices.
+*
+* Error bounds on the solution and a condition estimate are also
+* provided.
+*
+* Description
+* ===========
+*
+* The following steps are performed:
+*
+* 1. If FACT = 'E', real scaling factors are computed to equilibrate
+* the system:
+* diag(S) * A * diag(S) * inv(diag(S)) * X = diag(S) * B
+* Whether or not the system will be equilibrated depends on the
+* scaling of the matrix A, but if equilibration is used, A is
+* overwritten by diag(S)*A*diag(S) and B by diag(S)*B.
+*
+* 2. If FACT = 'N' or 'E', the Cholesky decomposition is used to
+* factor the matrix A (after equilibration if FACT = 'E') as
+* A = U**T* U, if UPLO = 'U', or
+* A = L * L**T, if UPLO = 'L',
+* where U is an upper triangular matrix and L is a lower triangular
+* matrix.
+*
+* 3. If the leading i-by-i principal minor is not positive definite,
+* then the routine returns with INFO = i. Otherwise, the factored
+* form of A is used to estimate the condition number of the matrix
+* A. If the reciprocal of the condition number is less than machine
+* precision, INFO = N+1 is returned as a warning, but the routine
+* still goes on to solve for X and compute error bounds as
+* described below.
+*
+* 4. The system of equations is solved for X using the factored form
+* of A.
+*
+* 5. Iterative refinement is applied to improve the computed solution
+* matrix and calculate error bounds and backward error estimates
+* for it.
+*
+* 6. If equilibration was used, the matrix X is premultiplied by
+* diag(S) so that it solves the original system before
+* equilibration.
+*
+* Arguments
+* =========
+*
+* FACT (input) CHARACTER*1
+* Specifies whether or not the factored form of the matrix A is
+* supplied on entry, and if not, whether the matrix A should be
+* equilibrated before it is factored.
+* = 'F': On entry, AF contains the factored form of A.
+* If EQUED = 'Y', the matrix A has been equilibrated
+* with scaling factors given by S. A and AF will not
+* be modified.
+* = 'N': The matrix A will be copied to AF and factored.
+* = 'E': The matrix A will be equilibrated if necessary, then
+* copied to AF and factored.
+*
+* UPLO (input) CHARACTER*1
+* = 'U': Upper triangle of A is stored;
+* = 'L': Lower triangle of A is stored.
+*
+* N (input) INTEGER
+* The number of linear equations, i.e., the order of the
+* matrix A. N >= 0.
+*
+* NRHS (input) INTEGER
+* The number of right hand sides, i.e., the number of columns
+* of the matrices B and X. NRHS >= 0.
+*
+* A (input/output) REAL array, dimension (LDA,N)
+* On entry, the symmetric matrix A, except if FACT = 'F' and
+* EQUED = 'Y', then A must contain the equilibrated matrix
+* diag(S)*A*diag(S). If UPLO = 'U', the leading
+* N-by-N upper triangular part of A contains the upper
+* triangular part of the matrix A, and the strictly lower
+* triangular part of A is not referenced. If UPLO = 'L', the
+* leading N-by-N lower triangular part of A contains the lower
+* triangular part of the matrix A, and the strictly upper
+* triangular part of A is not referenced. A is not modified if
+* FACT = 'F' or 'N', or if FACT = 'E' and EQUED = 'N' on exit.
+*
+* On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by
+* diag(S)*A*diag(S).
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,N).
+*
+* AF (input or output) REAL array, dimension (LDAF,N)
+* If FACT = 'F', then AF is an input argument and on entry
+* contains the triangular factor U or L from the Cholesky
+* factorization A = U**T*U or A = L*L**T, in the same storage
+* format as A. If EQUED .ne. 'N', then AF is the factored form
+* of the equilibrated matrix diag(S)*A*diag(S).
+*
+* If FACT = 'N', then AF is an output argument and on exit
+* returns the triangular factor U or L from the Cholesky
+* factorization A = U**T*U or A = L*L**T of the original
+* matrix A.
+*
+* If FACT = 'E', then AF is an output argument and on exit
+* returns the triangular factor U or L from the Cholesky
+* factorization A = U**T*U or A = L*L**T of the equilibrated
+* matrix A (see the description of A for the form of the
+* equilibrated matrix).
+*
+* LDAF (input) INTEGER
+* The leading dimension of the array AF. LDAF >= max(1,N).
+*
+* EQUED (input or output) CHARACTER*1
+* Specifies the form of equilibration that was done.
+* = 'N': No equilibration (always true if FACT = 'N').
+* = 'Y': Equilibration was done, i.e., A has been replaced by
+* diag(S) * A * diag(S).
+* EQUED is an input argument if FACT = 'F'; otherwise, it is an
+* output argument.
+*
+* S (input or output) REAL array, dimension (N)
+* The scale factors for A; not accessed if EQUED = 'N'. S is
+* an input argument if FACT = 'F'; otherwise, S is an output
+* argument. If FACT = 'F' and EQUED = 'Y', each element of S
+* must be positive.
+*
+* B (input/output) REAL array, dimension (LDB,NRHS)
+* On entry, the N-by-NRHS right hand side matrix B.
+* On exit, if EQUED = 'N', B is not modified; if EQUED = 'Y',
+* B is overwritten by diag(S) * B.
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. LDB >= max(1,N).
+*
+* X (output) REAL array, dimension (LDX,NRHS)
+* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X to
+* the original system of equations. Note that if EQUED = 'Y',
+* A and B are modified on exit, and the solution to the
+* equilibrated system is inv(diag(S))*X.
+*
+* LDX (input) INTEGER
+* The leading dimension of the array X. LDX >= max(1,N).
+*
+* RCOND (output) REAL
+* The estimate of the reciprocal condition number of the matrix
+* A after equilibration (if done). If RCOND is less than the
+* machine precision (in particular, if RCOND = 0), the matrix
+* is singular to working precision. This condition is
+* indicated by a return code of INFO > 0.
+*
+* FERR (output) REAL array, dimension (NRHS)
+* The estimated forward error bound for each solution vector
+* X(j) (the j-th column of the solution matrix X).
+* If XTRUE is the true solution corresponding to X(j), FERR(j)
+* is an estimated upper bound for the magnitude of the largest
+* element in (X(j) - XTRUE) divided by the magnitude of the
+* largest element in X(j). The estimate is as reliable as
+* the estimate for RCOND, and is almost always a slight
+* overestimate of the true error.
+*
+* BERR (output) REAL array, dimension (NRHS)
+* The componentwise relative backward error of each solution
+* vector X(j) (i.e., the smallest relative change in
+* any element of A or B that makes X(j) an exact solution).
+*
+* WORK (workspace) REAL array, dimension (3*N)
+*
+* IWORK (workspace) INTEGER array, dimension (N)
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* > 0: if INFO = i, and i is
+* <= N: the leading minor of order i of A is
+* not positive definite, so the factorization
+* could not be completed, and the solution has not
+* been computed. RCOND = 0 is returned.
+* = N+1: U is nonsingular, but RCOND is less than machine
+* precision, meaning that the matrix is singular
+* to working precision. Nevertheless, the
+* solution and error bounds are computed because
+* there are a number of situations where the
+* computed solution can be more accurate than the
+* value of RCOND would suggest.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO, ONE
+ PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL EQUIL, NOFACT, RCEQU
+ INTEGER I, INFEQU, J
+ REAL AMAX, ANORM, BIGNUM, SCOND, SMAX, SMIN, SMLNUM
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ REAL SLAMCH, SLANSY
+ EXTERNAL LSAME, SLAMCH, SLANSY
+* ..
+* .. External Subroutines ..
+ EXTERNAL SLACPY, SLAQSY, SPOCON, SPOEQU, SPORFS, SPOTRF,
+ $ SPOTRS, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+ INFO = 0
+ NOFACT = LSAME( FACT, 'N' )
+ EQUIL = LSAME( FACT, 'E' )
+ IF( NOFACT .OR. EQUIL ) THEN
+ EQUED = 'N'
+ RCEQU = .FALSE.
+ ELSE
+ RCEQU = LSAME( EQUED, 'Y' )
+ SMLNUM = SLAMCH( 'Safe minimum' )
+ BIGNUM = ONE / SMLNUM
+ END IF
+*
+* Test the input parameters.
+*
+ IF( .NOT.NOFACT .AND. .NOT.EQUIL .AND. .NOT.LSAME( FACT, 'F' ) )
+ $ THEN
+ INFO = -1
+ ELSE IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) )
+ $ THEN
+ INFO = -2
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( NRHS.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -6
+ ELSE IF( LDAF.LT.MAX( 1, N ) ) THEN
+ INFO = -8
+ ELSE IF( LSAME( FACT, 'F' ) .AND. .NOT.
+ $ ( RCEQU .OR. LSAME( EQUED, 'N' ) ) ) THEN
+ INFO = -9
+ ELSE
+ IF( RCEQU ) THEN
+ SMIN = BIGNUM
+ SMAX = ZERO
+ DO 10 J = 1, N
+ SMIN = MIN( SMIN, S( J ) )
+ SMAX = MAX( SMAX, S( J ) )
+ 10 CONTINUE
+ IF( SMIN.LE.ZERO ) THEN
+ INFO = -10
+ ELSE IF( N.GT.0 ) THEN
+ SCOND = MAX( SMIN, SMLNUM ) / MIN( SMAX, BIGNUM )
+ ELSE
+ SCOND = ONE
+ END IF
+ END IF
+ IF( INFO.EQ.0 ) THEN
+ IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -12
+ ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
+ INFO = -14
+ END IF
+ END IF
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SPOSVX', -INFO )
+ RETURN
+ END IF
+*
+ IF( EQUIL ) THEN
+*
+* Compute row and column scalings to equilibrate the matrix A.
+*
+ CALL SPOEQU( N, A, LDA, S, SCOND, AMAX, INFEQU )
+ IF( INFEQU.EQ.0 ) THEN
+*
+* Equilibrate the matrix.
+*
+ CALL SLAQSY( UPLO, N, A, LDA, S, SCOND, AMAX, EQUED )
+ RCEQU = LSAME( EQUED, 'Y' )
+ END IF
+ END IF
+*
+* Scale the right hand side.
+*
+ IF( RCEQU ) THEN
+ DO 30 J = 1, NRHS
+ DO 20 I = 1, N
+ B( I, J ) = S( I )*B( I, J )
+ 20 CONTINUE
+ 30 CONTINUE
+ END IF
+*
+ IF( NOFACT .OR. EQUIL ) THEN
+*
+* Compute the Cholesky factorization A = U'*U or A = L*L'.
+*
+ CALL SLACPY( UPLO, N, N, A, LDA, AF, LDAF )
+ CALL SPOTRF( UPLO, N, AF, LDAF, INFO )
+*
+* Return if INFO is non-zero.
+*
+ IF( INFO.GT.0 )THEN
+ RCOND = ZERO
+ RETURN
+ END IF
+ END IF
+*
+* Compute the norm of the matrix A.
+*
+ ANORM = SLANSY( '1', UPLO, N, A, LDA, WORK )
+*
+* Compute the reciprocal of the condition number of A.
+*
+ CALL SPOCON( UPLO, N, AF, LDAF, ANORM, RCOND, WORK, IWORK, INFO )
+*
+* Compute the solution matrix X.
+*
+ CALL SLACPY( 'Full', N, NRHS, B, LDB, X, LDX )
+ CALL SPOTRS( UPLO, N, NRHS, AF, LDAF, X, LDX, INFO )
+*
+* Use iterative refinement to improve the computed solution and
+* compute error bounds and backward error estimates for it.
+*
+ CALL SPORFS( UPLO, N, NRHS, A, LDA, AF, LDAF, B, LDB, X, LDX,
+ $ FERR, BERR, WORK, IWORK, INFO )
+*
+* Transform the solution matrix X to a solution of the original
+* system.
+*
+ IF( RCEQU ) THEN
+ DO 50 J = 1, NRHS
+ DO 40 I = 1, N
+ X( I, J ) = S( I )*X( I, J )
+ 40 CONTINUE
+ 50 CONTINUE
+ DO 60 J = 1, NRHS
+ FERR( J ) = FERR( J ) / SCOND
+ 60 CONTINUE
+ END IF
+*
+* Set INFO = N+1 if the matrix is singular to working precision.
+*
+ IF( RCOND.LT.SLAMCH( 'Epsilon' ) )
+ $ INFO = N + 1
+*
+ RETURN
+*
+* End of SPOSVX
+*
+ END
+ SUBROUTINE SPOTF2( UPLO, N, A, LDA, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, LDA, N
+* ..
+* .. Array Arguments ..
+ REAL A( LDA, * )
+* ..
+*
+* Purpose
+* =======
+*
+* SPOTF2 computes the Cholesky factorization of a real symmetric
+* positive definite matrix A.
+*
+* The factorization has the form
+* A = U' * U , if UPLO = 'U', or
+* A = L * L', if UPLO = 'L',
+* where U is an upper triangular matrix and L is lower triangular.
+*
+* This is the unblocked version of the algorithm, calling Level 2 BLAS.
+*
+* Arguments
+* =========
+*
+* UPLO (input) CHARACTER*1
+* Specifies whether the upper or lower triangular part of the
+* symmetric matrix A is stored.
+* = 'U': Upper triangular
+* = 'L': Lower triangular
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* A (input/output) REAL array, dimension (LDA,N)
+* On entry, the symmetric matrix A. If UPLO = 'U', the leading
+* n by n upper triangular part of A contains the upper
+* triangular part of the matrix A, and the strictly lower
+* triangular part of A is not referenced. If UPLO = 'L', the
+* leading n by n lower triangular part of A contains the lower
+* triangular part of the matrix A, and the strictly upper
+* triangular part of A is not referenced.
+*
+* On exit, if INFO = 0, the factor U or L from the Cholesky
+* factorization A = U'*U or A = L*L'.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,N).
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -k, the k-th argument had an illegal value
+* > 0: if INFO = k, the leading minor of order k is not
+* positive definite, and the factorization could not be
+* completed.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ONE, ZERO
+ PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL UPPER
+ INTEGER J
+ REAL AJJ
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ REAL SDOT
+ EXTERNAL LSAME, SDOT
+* ..
+* .. External Subroutines ..
+ EXTERNAL SGEMV, SSCAL, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, SQRT
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -4
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SPOTF2', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+ IF( UPPER ) THEN
+*
+* Compute the Cholesky factorization A = U'*U.
+*
+ DO 10 J = 1, N
+*
+* Compute U(J,J) and test for non-positive-definiteness.
+*
+ AJJ = A( J, J ) - SDOT( J-1, A( 1, J ), 1, A( 1, J ), 1 )
+ IF( AJJ.LE.ZERO ) THEN
+ A( J, J ) = AJJ
+ GO TO 30
+ END IF
+ AJJ = SQRT( AJJ )
+ A( J, J ) = AJJ
+*
+* Compute elements J+1:N of row J.
+*
+ IF( J.LT.N ) THEN
+ CALL SGEMV( 'Transpose', J-1, N-J, -ONE, A( 1, J+1 ),
+ $ LDA, A( 1, J ), 1, ONE, A( J, J+1 ), LDA )
+ CALL SSCAL( N-J, ONE / AJJ, A( J, J+1 ), LDA )
+ END IF
+ 10 CONTINUE
+ ELSE
+*
+* Compute the Cholesky factorization A = L*L'.
+*
+ DO 20 J = 1, N
+*
+* Compute L(J,J) and test for non-positive-definiteness.
+*
+ AJJ = A( J, J ) - SDOT( J-1, A( J, 1 ), LDA, A( J, 1 ),
+ $ LDA )
+ IF( AJJ.LE.ZERO ) THEN
+ A( J, J ) = AJJ
+ GO TO 30
+ END IF
+ AJJ = SQRT( AJJ )
+ A( J, J ) = AJJ
+*
+* Compute elements J+1:N of column J.
+*
+ IF( J.LT.N ) THEN
+ CALL SGEMV( 'No transpose', N-J, J-1, -ONE, A( J+1, 1 ),
+ $ LDA, A( J, 1 ), LDA, ONE, A( J+1, J ), 1 )
+ CALL SSCAL( N-J, ONE / AJJ, A( J+1, J ), 1 )
+ END IF
+ 20 CONTINUE
+ END IF
+ GO TO 40
+*
+ 30 CONTINUE
+ INFO = J
+*
+ 40 CONTINUE
+ RETURN
+*
+* End of SPOTF2
+*
+ END
+ SUBROUTINE SPOTRF( UPLO, N, A, LDA, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, LDA, N
+* ..
+* .. Array Arguments ..
+ REAL A( LDA, * )
+* ..
+*
+* Purpose
+* =======
+*
+* SPOTRF computes the Cholesky factorization of a real symmetric
+* positive definite matrix A.
+*
+* The factorization has the form
+* A = U**T * U, if UPLO = 'U', or
+* A = L * L**T, if UPLO = 'L',
+* where U is an upper triangular matrix and L is lower triangular.
+*
+* This is the block version of the algorithm, calling Level 3 BLAS.
+*
+* Arguments
+* =========
+*
+* UPLO (input) CHARACTER*1
+* = 'U': Upper triangle of A is stored;
+* = 'L': Lower triangle of A is stored.
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* A (input/output) REAL array, dimension (LDA,N)
+* On entry, the symmetric matrix A. If UPLO = 'U', the leading
+* N-by-N upper triangular part of A contains the upper
+* triangular part of the matrix A, and the strictly lower
+* triangular part of A is not referenced. If UPLO = 'L', the
+* leading N-by-N lower triangular part of A contains the lower
+* triangular part of the matrix A, and the strictly upper
+* triangular part of A is not referenced.
+*
+* On exit, if INFO = 0, the factor U or L from the Cholesky
+* factorization A = U**T*U or A = L*L**T.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,N).
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* > 0: if INFO = i, the leading minor of order i is not
+* positive definite, and the factorization could not be
+* completed.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ONE
+ PARAMETER ( ONE = 1.0E+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL UPPER
+ INTEGER J, JB, NB
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ILAENV
+ EXTERNAL LSAME, ILAENV
+* ..
+* .. External Subroutines ..
+ EXTERNAL SGEMM, SPOTF2, SSYRK, STRSM, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -4
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SPOTRF', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+* Determine the block size for this environment.
+*
+ NB = ILAENV( 1, 'SPOTRF', UPLO, N, -1, -1, -1 )
+ IF( NB.LE.1 .OR. NB.GE.N ) THEN
+*
+* Use unblocked code.
+*
+ CALL SPOTF2( UPLO, N, A, LDA, INFO )
+ ELSE
+*
+* Use blocked code.
+*
+ IF( UPPER ) THEN
+*
+* Compute the Cholesky factorization A = U'*U.
+*
+ DO 10 J = 1, N, NB
+*
+* Update and factorize the current diagonal block and test
+* for non-positive-definiteness.
+*
+ JB = MIN( NB, N-J+1 )
+ CALL SSYRK( 'Upper', 'Transpose', JB, J-1, -ONE,
+ $ A( 1, J ), LDA, ONE, A( J, J ), LDA )
+ CALL SPOTF2( 'Upper', JB, A( J, J ), LDA, INFO )
+ IF( INFO.NE.0 )
+ $ GO TO 30
+ IF( J+JB.LE.N ) THEN
+*
+* Compute the current block row.
+*
+ CALL SGEMM( 'Transpose', 'No transpose', JB, N-J-JB+1,
+ $ J-1, -ONE, A( 1, J ), LDA, A( 1, J+JB ),
+ $ LDA, ONE, A( J, J+JB ), LDA )
+ CALL STRSM( 'Left', 'Upper', 'Transpose', 'Non-unit',
+ $ JB, N-J-JB+1, ONE, A( J, J ), LDA,
+ $ A( J, J+JB ), LDA )
+ END IF
+ 10 CONTINUE
+*
+ ELSE
+*
+* Compute the Cholesky factorization A = L*L'.
+*
+ DO 20 J = 1, N, NB
+*
+* Update and factorize the current diagonal block and test
+* for non-positive-definiteness.
+*
+ JB = MIN( NB, N-J+1 )
+ CALL SSYRK( 'Lower', 'No transpose', JB, J-1, -ONE,
+ $ A( J, 1 ), LDA, ONE, A( J, J ), LDA )
+ CALL SPOTF2( 'Lower', JB, A( J, J ), LDA, INFO )
+ IF( INFO.NE.0 )
+ $ GO TO 30
+ IF( J+JB.LE.N ) THEN
+*
+* Compute the current block column.
+*
+ CALL SGEMM( 'No transpose', 'Transpose', N-J-JB+1, JB,
+ $ J-1, -ONE, A( J+JB, 1 ), LDA, A( J, 1 ),
+ $ LDA, ONE, A( J+JB, J ), LDA )
+ CALL STRSM( 'Right', 'Lower', 'Transpose', 'Non-unit',
+ $ N-J-JB+1, JB, ONE, A( J, J ), LDA,
+ $ A( J+JB, J ), LDA )
+ END IF
+ 20 CONTINUE
+ END IF
+ END IF
+ GO TO 40
+*
+ 30 CONTINUE
+ INFO = INFO + J - 1
+*
+ 40 CONTINUE
+ RETURN
+*
+* End of SPOTRF
+*
+ END
+ SUBROUTINE SPOTRI( UPLO, N, A, LDA, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, LDA, N
+* ..
+* .. Array Arguments ..
+ REAL A( LDA, * )
+* ..
+*
+* Purpose
+* =======
+*
+* SPOTRI computes the inverse of a real symmetric positive definite
+* matrix A using the Cholesky factorization A = U**T*U or A = L*L**T
+* computed by SPOTRF.
+*
+* Arguments
+* =========
+*
+* UPLO (input) CHARACTER*1
+* = 'U': Upper triangle of A is stored;
+* = 'L': Lower triangle of A is stored.
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* A (input/output) REAL array, dimension (LDA,N)
+* On entry, the triangular factor U or L from the Cholesky
+* factorization A = U**T*U or A = L*L**T, as computed by
+* SPOTRF.
+* On exit, the upper or lower triangle of the (symmetric)
+* inverse of A, overwriting the input factor U or L.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,N).
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* > 0: if INFO = i, the (i,i) element of the factor U or L is
+* zero, and the inverse could not be computed.
+*
+* =====================================================================
+*
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL SLAUUM, STRTRI, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -4
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SPOTRI', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+* Invert the triangular Cholesky factor U or L.
+*
+ CALL STRTRI( UPLO, 'Non-unit', N, A, LDA, INFO )
+ IF( INFO.GT.0 )
+ $ RETURN
+*
+* Form inv(U)*inv(U)' or inv(L)'*inv(L).
+*
+ CALL SLAUUM( UPLO, N, A, LDA, INFO )
+*
+ RETURN
+*
+* End of SPOTRI
+*
+ END
+ SUBROUTINE SPOTRS( UPLO, N, NRHS, A, LDA, B, LDB, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, LDA, LDB, N, NRHS
+* ..
+* .. Array Arguments ..
+ REAL A( LDA, * ), B( LDB, * )
+* ..
+*
+* Purpose
+* =======
+*
+* SPOTRS solves a system of linear equations A*X = B with a symmetric
+* positive definite matrix A using the Cholesky factorization
+* A = U**T*U or A = L*L**T computed by SPOTRF.
+*
+* Arguments
+* =========
+*
+* UPLO (input) CHARACTER*1
+* = 'U': Upper triangle of A is stored;
+* = 'L': Lower triangle of A is stored.
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* NRHS (input) INTEGER
+* The number of right hand sides, i.e., the number of columns
+* of the matrix B. NRHS >= 0.
+*
+* A (input) REAL array, dimension (LDA,N)
+* The triangular factor U or L from the Cholesky factorization
+* A = U**T*U or A = L*L**T, as computed by SPOTRF.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,N).
+*
+* B (input/output) REAL array, dimension (LDB,NRHS)
+* On entry, the right hand side matrix B.
+* On exit, the solution matrix X.
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. LDB >= max(1,N).
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ONE
+ PARAMETER ( ONE = 1.0E+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL UPPER
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL STRSM, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( NRHS.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -5
+ ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -7
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SPOTRS', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 .OR. NRHS.EQ.0 )
+ $ RETURN
+*
+ IF( UPPER ) THEN
+*
+* Solve A*X = B where A = U'*U.
+*
+* Solve U'*X = B, overwriting B with X.
+*
+ CALL STRSM( 'Left', 'Upper', 'Transpose', 'Non-unit', N, NRHS,
+ $ ONE, A, LDA, B, LDB )
+*
+* Solve U*X = B, overwriting B with X.
+*
+ CALL STRSM( 'Left', 'Upper', 'No transpose', 'Non-unit', N,
+ $ NRHS, ONE, A, LDA, B, LDB )
+ ELSE
+*
+* Solve A*X = B where A = L*L'.
+*
+* Solve L*X = B, overwriting B with X.
+*
+ CALL STRSM( 'Left', 'Lower', 'No transpose', 'Non-unit', N,
+ $ NRHS, ONE, A, LDA, B, LDB )
+*
+* Solve L'*X = B, overwriting B with X.
+*
+ CALL STRSM( 'Left', 'Lower', 'Transpose', 'Non-unit', N, NRHS,
+ $ ONE, A, LDA, B, LDB )
+ END IF
+*
+ RETURN
+*
+* End of SPOTRS
+*
+ END
+ SUBROUTINE SPPCON( UPLO, N, AP, ANORM, RCOND, WORK, IWORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* Modified to call SLACN2 in place of SLACON, 7 Feb 03, SJH.
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, N
+ REAL ANORM, RCOND
+* ..
+* .. Array Arguments ..
+ INTEGER IWORK( * )
+ REAL AP( * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SPPCON estimates the reciprocal of the condition number (in the
+* 1-norm) of a real symmetric positive definite packed matrix using
+* the Cholesky factorization A = U**T*U or A = L*L**T computed by
+* SPPTRF.
+*
+* An estimate is obtained for norm(inv(A)), and the reciprocal of the
+* condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).
+*
+* Arguments
+* =========
+*
+* UPLO (input) CHARACTER*1
+* = 'U': Upper triangle of A is stored;
+* = 'L': Lower triangle of A is stored.
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* AP (input) REAL array, dimension (N*(N+1)/2)
+* The triangular factor U or L from the Cholesky factorization
+* A = U**T*U or A = L*L**T, packed columnwise in a linear
+* array. The j-th column of U or L is stored in the array AP
+* as follows:
+* if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j;
+* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n.
+*
+* ANORM (input) REAL
+* The 1-norm (or infinity-norm) of the symmetric matrix A.
+*
+* RCOND (output) REAL
+* The reciprocal of the condition number of the matrix A,
+* computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an
+* estimate of the 1-norm of inv(A) computed in this routine.
+*
+* WORK (workspace) REAL array, dimension (3*N)
+*
+* IWORK (workspace) INTEGER array, dimension (N)
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ONE, ZERO
+ PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL UPPER
+ CHARACTER NORMIN
+ INTEGER IX, KASE
+ REAL AINVNM, SCALE, SCALEL, SCALEU, SMLNUM
+* ..
+* .. Local Arrays ..
+ INTEGER ISAVE( 3 )
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ISAMAX
+ REAL SLAMCH
+ EXTERNAL LSAME, ISAMAX, SLAMCH
+* ..
+* .. External Subroutines ..
+ EXTERNAL SLACN2, SLATPS, SRSCL, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( ANORM.LT.ZERO ) THEN
+ INFO = -4
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SPPCON', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ RCOND = ZERO
+ IF( N.EQ.0 ) THEN
+ RCOND = ONE
+ RETURN
+ ELSE IF( ANORM.EQ.ZERO ) THEN
+ RETURN
+ END IF
+*
+ SMLNUM = SLAMCH( 'Safe minimum' )
+*
+* Estimate the 1-norm of the inverse.
+*
+ KASE = 0
+ NORMIN = 'N'
+ 10 CONTINUE
+ CALL SLACN2( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE, ISAVE )
+ IF( KASE.NE.0 ) THEN
+ IF( UPPER ) THEN
+*
+* Multiply by inv(U').
+*
+ CALL SLATPS( 'Upper', 'Transpose', 'Non-unit', NORMIN, N,
+ $ AP, WORK, SCALEL, WORK( 2*N+1 ), INFO )
+ NORMIN = 'Y'
+*
+* Multiply by inv(U).
+*
+ CALL SLATPS( 'Upper', 'No transpose', 'Non-unit', NORMIN, N,
+ $ AP, WORK, SCALEU, WORK( 2*N+1 ), INFO )
+ ELSE
+*
+* Multiply by inv(L).
+*
+ CALL SLATPS( 'Lower', 'No transpose', 'Non-unit', NORMIN, N,
+ $ AP, WORK, SCALEL, WORK( 2*N+1 ), INFO )
+ NORMIN = 'Y'
+*
+* Multiply by inv(L').
+*
+ CALL SLATPS( 'Lower', 'Transpose', 'Non-unit', NORMIN, N,
+ $ AP, WORK, SCALEU, WORK( 2*N+1 ), INFO )
+ END IF
+*
+* Multiply by 1/SCALE if doing so will not cause overflow.
+*
+ SCALE = SCALEL*SCALEU
+ IF( SCALE.NE.ONE ) THEN
+ IX = ISAMAX( N, WORK, 1 )
+ IF( SCALE.LT.ABS( WORK( IX ) )*SMLNUM .OR. SCALE.EQ.ZERO )
+ $ GO TO 20
+ CALL SRSCL( N, SCALE, WORK, 1 )
+ END IF
+ GO TO 10
+ END IF
+*
+* Compute the estimate of the reciprocal condition number.
+*
+ IF( AINVNM.NE.ZERO )
+ $ RCOND = ( ONE / AINVNM ) / ANORM
+*
+ 20 CONTINUE
+ RETURN
+*
+* End of SPPCON
+*
+ END
+ SUBROUTINE SPPEQU( UPLO, N, AP, S, SCOND, AMAX, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, N
+ REAL AMAX, SCOND
+* ..
+* .. Array Arguments ..
+ REAL AP( * ), S( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SPPEQU computes row and column scalings intended to equilibrate a
+* symmetric positive definite matrix A in packed storage and reduce
+* its condition number (with respect to the two-norm). S contains the
+* scale factors, S(i)=1/sqrt(A(i,i)), chosen so that the scaled matrix
+* B with elements B(i,j)=S(i)*A(i,j)*S(j) has ones on the diagonal.
+* This choice of S puts the condition number of B within a factor N of
+* the smallest possible condition number over all possible diagonal
+* scalings.
+*
+* Arguments
+* =========
+*
+* UPLO (input) CHARACTER*1
+* = 'U': Upper triangle of A is stored;
+* = 'L': Lower triangle of A is stored.
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* AP (input) REAL array, dimension (N*(N+1)/2)
+* The upper or lower triangle of the symmetric matrix A, packed
+* columnwise in a linear array. The j-th column of A is stored
+* in the array AP as follows:
+* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
+* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
+*
+* S (output) REAL array, dimension (N)
+* If INFO = 0, S contains the scale factors for A.
+*
+* SCOND (output) REAL
+* If INFO = 0, S contains the ratio of the smallest S(i) to
+* the largest S(i). If SCOND >= 0.1 and AMAX is neither too
+* large nor too small, it is not worth scaling by S.
+*
+* AMAX (output) REAL
+* Absolute value of largest matrix element. If AMAX is very
+* close to overflow or very close to underflow, the matrix
+* should be scaled.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* > 0: if INFO = i, the i-th diagonal element is nonpositive.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ONE, ZERO
+ PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL UPPER
+ INTEGER I, JJ
+ REAL SMIN
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN, SQRT
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SPPEQU', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 ) THEN
+ SCOND = ONE
+ AMAX = ZERO
+ RETURN
+ END IF
+*
+* Initialize SMIN and AMAX.
+*
+ S( 1 ) = AP( 1 )
+ SMIN = S( 1 )
+ AMAX = S( 1 )
+*
+ IF( UPPER ) THEN
+*
+* UPLO = 'U': Upper triangle of A is stored.
+* Find the minimum and maximum diagonal elements.
+*
+ JJ = 1
+ DO 10 I = 2, N
+ JJ = JJ + I
+ S( I ) = AP( JJ )
+ SMIN = MIN( SMIN, S( I ) )
+ AMAX = MAX( AMAX, S( I ) )
+ 10 CONTINUE
+*
+ ELSE
+*
+* UPLO = 'L': Lower triangle of A is stored.
+* Find the minimum and maximum diagonal elements.
+*
+ JJ = 1
+ DO 20 I = 2, N
+ JJ = JJ + N - I + 2
+ S( I ) = AP( JJ )
+ SMIN = MIN( SMIN, S( I ) )
+ AMAX = MAX( AMAX, S( I ) )
+ 20 CONTINUE
+ END IF
+*
+ IF( SMIN.LE.ZERO ) THEN
+*
+* Find the first non-positive diagonal element and return.
+*
+ DO 30 I = 1, N
+ IF( S( I ).LE.ZERO ) THEN
+ INFO = I
+ RETURN
+ END IF
+ 30 CONTINUE
+ ELSE
+*
+* Set the scale factors to the reciprocals
+* of the diagonal elements.
+*
+ DO 40 I = 1, N
+ S( I ) = ONE / SQRT( S( I ) )
+ 40 CONTINUE
+*
+* Compute SCOND = min(S(I)) / max(S(I))
+*
+ SCOND = SQRT( SMIN ) / SQRT( AMAX )
+ END IF
+ RETURN
+*
+* End of SPPEQU
+*
+ END
+ SUBROUTINE SPPRFS( UPLO, N, NRHS, AP, AFP, B, LDB, X, LDX, FERR,
+ $ BERR, WORK, IWORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* Modified to call SLACN2 in place of SLACON, 7 Feb 03, SJH.
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, LDB, LDX, N, NRHS
+* ..
+* .. Array Arguments ..
+ INTEGER IWORK( * )
+ REAL AFP( * ), AP( * ), B( LDB, * ), BERR( * ),
+ $ FERR( * ), WORK( * ), X( LDX, * )
+* ..
+*
+* Purpose
+* =======
+*
+* SPPRFS improves the computed solution to a system of linear
+* equations when the coefficient matrix is symmetric positive definite
+* and packed, and provides error bounds and backward error estimates
+* for the solution.
+*
+* Arguments
+* =========
+*
+* UPLO (input) CHARACTER*1
+* = 'U': Upper triangle of A is stored;
+* = 'L': Lower triangle of A is stored.
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* NRHS (input) INTEGER
+* The number of right hand sides, i.e., the number of columns
+* of the matrices B and X. NRHS >= 0.
+*
+* AP (input) REAL array, dimension (N*(N+1)/2)
+* The upper or lower triangle of the symmetric matrix A, packed
+* columnwise in a linear array. The j-th column of A is stored
+* in the array AP as follows:
+* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
+* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
+*
+* AFP (input) REAL array, dimension (N*(N+1)/2)
+* The triangular factor U or L from the Cholesky factorization
+* A = U**T*U or A = L*L**T, as computed by SPPTRF/CPPTRF,
+* packed columnwise in a linear array in the same format as A
+* (see AP).
+*
+* B (input) REAL array, dimension (LDB,NRHS)
+* The right hand side matrix B.
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. LDB >= max(1,N).
+*
+* X (input/output) REAL array, dimension (LDX,NRHS)
+* On entry, the solution matrix X, as computed by SPPTRS.
+* On exit, the improved solution matrix X.
+*
+* LDX (input) INTEGER
+* The leading dimension of the array X. LDX >= max(1,N).
+*
+* FERR (output) REAL array, dimension (NRHS)
+* The estimated forward error bound for each solution vector
+* X(j) (the j-th column of the solution matrix X).
+* If XTRUE is the true solution corresponding to X(j), FERR(j)
+* is an estimated upper bound for the magnitude of the largest
+* element in (X(j) - XTRUE) divided by the magnitude of the
+* largest element in X(j). The estimate is as reliable as
+* the estimate for RCOND, and is almost always a slight
+* overestimate of the true error.
+*
+* BERR (output) REAL array, dimension (NRHS)
+* The componentwise relative backward error of each solution
+* vector X(j) (i.e., the smallest relative change in
+* any element of A or B that makes X(j) an exact solution).
+*
+* WORK (workspace) REAL array, dimension (3*N)
+*
+* IWORK (workspace) INTEGER array, dimension (N)
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+*
+* Internal Parameters
+* ===================
+*
+* ITMAX is the maximum number of steps of iterative refinement.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ INTEGER ITMAX
+ PARAMETER ( ITMAX = 5 )
+ REAL ZERO
+ PARAMETER ( ZERO = 0.0E+0 )
+ REAL ONE
+ PARAMETER ( ONE = 1.0E+0 )
+ REAL TWO
+ PARAMETER ( TWO = 2.0E+0 )
+ REAL THREE
+ PARAMETER ( THREE = 3.0E+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL UPPER
+ INTEGER COUNT, I, IK, J, K, KASE, KK, NZ
+ REAL EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK
+* ..
+* .. Local Arrays ..
+ INTEGER ISAVE( 3 )
+* ..
+* .. External Subroutines ..
+ EXTERNAL SAXPY, SCOPY, SLACN2, SPPTRS, SSPMV, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ REAL SLAMCH
+ EXTERNAL LSAME, SLAMCH
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( NRHS.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -7
+ ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
+ INFO = -9
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SPPRFS', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN
+ DO 10 J = 1, NRHS
+ FERR( J ) = ZERO
+ BERR( J ) = ZERO
+ 10 CONTINUE
+ RETURN
+ END IF
+*
+* NZ = maximum number of nonzero elements in each row of A, plus 1
+*
+ NZ = N + 1
+ EPS = SLAMCH( 'Epsilon' )
+ SAFMIN = SLAMCH( 'Safe minimum' )
+ SAFE1 = NZ*SAFMIN
+ SAFE2 = SAFE1 / EPS
+*
+* Do for each right hand side
+*
+ DO 140 J = 1, NRHS
+*
+ COUNT = 1
+ LSTRES = THREE
+ 20 CONTINUE
+*
+* Loop until stopping criterion is satisfied.
+*
+* Compute residual R = B - A * X
+*
+ CALL SCOPY( N, B( 1, J ), 1, WORK( N+1 ), 1 )
+ CALL SSPMV( UPLO, N, -ONE, AP, X( 1, J ), 1, ONE, WORK( N+1 ),
+ $ 1 )
+*
+* Compute componentwise relative backward error from formula
+*
+* max(i) ( abs(R(i)) / ( abs(A)*abs(X) + abs(B) )(i) )
+*
+* where abs(Z) is the componentwise absolute value of the matrix
+* or vector Z. If the i-th component of the denominator is less
+* than SAFE2, then SAFE1 is added to the i-th components of the
+* numerator and denominator before dividing.
+*
+ DO 30 I = 1, N
+ WORK( I ) = ABS( B( I, J ) )
+ 30 CONTINUE
+*
+* Compute abs(A)*abs(X) + abs(B).
+*
+ KK = 1
+ IF( UPPER ) THEN
+ DO 50 K = 1, N
+ S = ZERO
+ XK = ABS( X( K, J ) )
+ IK = KK
+ DO 40 I = 1, K - 1
+ WORK( I ) = WORK( I ) + ABS( AP( IK ) )*XK
+ S = S + ABS( AP( IK ) )*ABS( X( I, J ) )
+ IK = IK + 1
+ 40 CONTINUE
+ WORK( K ) = WORK( K ) + ABS( AP( KK+K-1 ) )*XK + S
+ KK = KK + K
+ 50 CONTINUE
+ ELSE
+ DO 70 K = 1, N
+ S = ZERO
+ XK = ABS( X( K, J ) )
+ WORK( K ) = WORK( K ) + ABS( AP( KK ) )*XK
+ IK = KK + 1
+ DO 60 I = K + 1, N
+ WORK( I ) = WORK( I ) + ABS( AP( IK ) )*XK
+ S = S + ABS( AP( IK ) )*ABS( X( I, J ) )
+ IK = IK + 1
+ 60 CONTINUE
+ WORK( K ) = WORK( K ) + S
+ KK = KK + ( N-K+1 )
+ 70 CONTINUE
+ END IF
+ S = ZERO
+ DO 80 I = 1, N
+ IF( WORK( I ).GT.SAFE2 ) THEN
+ S = MAX( S, ABS( WORK( N+I ) ) / WORK( I ) )
+ ELSE
+ S = MAX( S, ( ABS( WORK( N+I ) )+SAFE1 ) /
+ $ ( WORK( I )+SAFE1 ) )
+ END IF
+ 80 CONTINUE
+ BERR( J ) = S
+*
+* Test stopping criterion. Continue iterating if
+* 1) The residual BERR(J) is larger than machine epsilon, and
+* 2) BERR(J) decreased by at least a factor of 2 during the
+* last iteration, and
+* 3) At most ITMAX iterations tried.
+*
+ IF( BERR( J ).GT.EPS .AND. TWO*BERR( J ).LE.LSTRES .AND.
+ $ COUNT.LE.ITMAX ) THEN
+*
+* Update solution and try again.
+*
+ CALL SPPTRS( UPLO, N, 1, AFP, WORK( N+1 ), N, INFO )
+ CALL SAXPY( N, ONE, WORK( N+1 ), 1, X( 1, J ), 1 )
+ LSTRES = BERR( J )
+ COUNT = COUNT + 1
+ GO TO 20
+ END IF
+*
+* Bound error from formula
+*
+* norm(X - XTRUE) / norm(X) .le. FERR =
+* norm( abs(inv(A))*
+* ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X)
+*
+* where
+* norm(Z) is the magnitude of the largest component of Z
+* inv(A) is the inverse of A
+* abs(Z) is the componentwise absolute value of the matrix or
+* vector Z
+* NZ is the maximum number of nonzeros in any row of A, plus 1
+* EPS is machine epsilon
+*
+* The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B))
+* is incremented by SAFE1 if the i-th component of
+* abs(A)*abs(X) + abs(B) is less than SAFE2.
+*
+* Use SLACN2 to estimate the infinity-norm of the matrix
+* inv(A) * diag(W),
+* where W = abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) )))
+*
+ DO 90 I = 1, N
+ IF( WORK( I ).GT.SAFE2 ) THEN
+ WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I )
+ ELSE
+ WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I ) + SAFE1
+ END IF
+ 90 CONTINUE
+*
+ KASE = 0
+ 100 CONTINUE
+ CALL SLACN2( N, WORK( 2*N+1 ), WORK( N+1 ), IWORK, FERR( J ),
+ $ KASE, ISAVE )
+ IF( KASE.NE.0 ) THEN
+ IF( KASE.EQ.1 ) THEN
+*
+* Multiply by diag(W)*inv(A').
+*
+ CALL SPPTRS( UPLO, N, 1, AFP, WORK( N+1 ), N, INFO )
+ DO 110 I = 1, N
+ WORK( N+I ) = WORK( I )*WORK( N+I )
+ 110 CONTINUE
+ ELSE IF( KASE.EQ.2 ) THEN
+*
+* Multiply by inv(A)*diag(W).
+*
+ DO 120 I = 1, N
+ WORK( N+I ) = WORK( I )*WORK( N+I )
+ 120 CONTINUE
+ CALL SPPTRS( UPLO, N, 1, AFP, WORK( N+1 ), N, INFO )
+ END IF
+ GO TO 100
+ END IF
+*
+* Normalize error.
+*
+ LSTRES = ZERO
+ DO 130 I = 1, N
+ LSTRES = MAX( LSTRES, ABS( X( I, J ) ) )
+ 130 CONTINUE
+ IF( LSTRES.NE.ZERO )
+ $ FERR( J ) = FERR( J ) / LSTRES
+*
+ 140 CONTINUE
+*
+ RETURN
+*
+* End of SPPRFS
+*
+ END
+ SUBROUTINE SPPSV( UPLO, N, NRHS, AP, B, LDB, INFO )
+*
+* -- LAPACK driver routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, LDB, N, NRHS
+* ..
+* .. Array Arguments ..
+ REAL AP( * ), B( LDB, * )
+* ..
+*
+* Purpose
+* =======
+*
+* SPPSV computes the solution to a real system of linear equations
+* A * X = B,
+* where A is an N-by-N symmetric positive definite matrix stored in
+* packed format and X and B are N-by-NRHS matrices.
+*
+* The Cholesky decomposition is used to factor A as
+* A = U**T* U, if UPLO = 'U', or
+* A = L * L**T, if UPLO = 'L',
+* where U is an upper triangular matrix and L is a lower triangular
+* matrix. The factored form of A is then used to solve the system of
+* equations A * X = B.
+*
+* Arguments
+* =========
+*
+* UPLO (input) CHARACTER*1
+* = 'U': Upper triangle of A is stored;
+* = 'L': Lower triangle of A is stored.
+*
+* N (input) INTEGER
+* The number of linear equations, i.e., the order of the
+* matrix A. N >= 0.
+*
+* NRHS (input) INTEGER
+* The number of right hand sides, i.e., the number of columns
+* of the matrix B. NRHS >= 0.
+*
+* AP (input/output) REAL array, dimension (N*(N+1)/2)
+* On entry, the upper or lower triangle of the symmetric matrix
+* A, packed columnwise in a linear array. The j-th column of A
+* is stored in the array AP as follows:
+* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
+* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
+* See below for further details.
+*
+* On exit, if INFO = 0, the factor U or L from the Cholesky
+* factorization A = U**T*U or A = L*L**T, in the same storage
+* format as A.
+*
+* B (input/output) REAL array, dimension (LDB,NRHS)
+* On entry, the N-by-NRHS right hand side matrix B.
+* On exit, if INFO = 0, the N-by-NRHS solution matrix X.
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. LDB >= max(1,N).
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* > 0: if INFO = i, the leading minor of order i of A is not
+* positive definite, so the factorization could not be
+* completed, and the solution has not been computed.
+*
+* Further Details
+* ===============
+*
+* The packed storage scheme is illustrated by the following example
+* when N = 4, UPLO = 'U':
+*
+* Two-dimensional storage of the symmetric matrix A:
+*
+* a11 a12 a13 a14
+* a22 a23 a24
+* a33 a34 (aij = conjg(aji))
+* a44
+*
+* Packed storage of the upper triangle of A:
+*
+* AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]
+*
+* =====================================================================
+*
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL SPPTRF, SPPTRS, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( NRHS.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -6
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SPPSV ', -INFO )
+ RETURN
+ END IF
+*
+* Compute the Cholesky factorization A = U'*U or A = L*L'.
+*
+ CALL SPPTRF( UPLO, N, AP, INFO )
+ IF( INFO.EQ.0 ) THEN
+*
+* Solve the system A*X = B, overwriting B with X.
+*
+ CALL SPPTRS( UPLO, N, NRHS, AP, B, LDB, INFO )
+*
+ END IF
+ RETURN
+*
+* End of SPPSV
+*
+ END
+ SUBROUTINE SPPSVX( FACT, UPLO, N, NRHS, AP, AFP, EQUED, S, B, LDB,
+ $ X, LDX, RCOND, FERR, BERR, WORK, IWORK, INFO )
+*
+* -- LAPACK driver routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER EQUED, FACT, UPLO
+ INTEGER INFO, LDB, LDX, N, NRHS
+ REAL RCOND
+* ..
+* .. Array Arguments ..
+ INTEGER IWORK( * )
+ REAL AFP( * ), AP( * ), B( LDB, * ), BERR( * ),
+ $ FERR( * ), S( * ), WORK( * ), X( LDX, * )
+* ..
+*
+* Purpose
+* =======
+*
+* SPPSVX uses the Cholesky factorization A = U**T*U or A = L*L**T to
+* compute the solution to a real system of linear equations
+* A * X = B,
+* where A is an N-by-N symmetric positive definite matrix stored in
+* packed format and X and B are N-by-NRHS matrices.
+*
+* Error bounds on the solution and a condition estimate are also
+* provided.
+*
+* Description
+* ===========
+*
+* The following steps are performed:
+*
+* 1. If FACT = 'E', real scaling factors are computed to equilibrate
+* the system:
+* diag(S) * A * diag(S) * inv(diag(S)) * X = diag(S) * B
+* Whether or not the system will be equilibrated depends on the
+* scaling of the matrix A, but if equilibration is used, A is
+* overwritten by diag(S)*A*diag(S) and B by diag(S)*B.
+*
+* 2. If FACT = 'N' or 'E', the Cholesky decomposition is used to
+* factor the matrix A (after equilibration if FACT = 'E') as
+* A = U**T* U, if UPLO = 'U', or
+* A = L * L**T, if UPLO = 'L',
+* where U is an upper triangular matrix and L is a lower triangular
+* matrix.
+*
+* 3. If the leading i-by-i principal minor is not positive definite,
+* then the routine returns with INFO = i. Otherwise, the factored
+* form of A is used to estimate the condition number of the matrix
+* A. If the reciprocal of the condition number is less than machine
+* precision, INFO = N+1 is returned as a warning, but the routine
+* still goes on to solve for X and compute error bounds as
+* described below.
+*
+* 4. The system of equations is solved for X using the factored form
+* of A.
+*
+* 5. Iterative refinement is applied to improve the computed solution
+* matrix and calculate error bounds and backward error estimates
+* for it.
+*
+* 6. If equilibration was used, the matrix X is premultiplied by
+* diag(S) so that it solves the original system before
+* equilibration.
+*
+* Arguments
+* =========
+*
+* FACT (input) CHARACTER*1
+* Specifies whether or not the factored form of the matrix A is
+* supplied on entry, and if not, whether the matrix A should be
+* equilibrated before it is factored.
+* = 'F': On entry, AFP contains the factored form of A.
+* If EQUED = 'Y', the matrix A has been equilibrated
+* with scaling factors given by S. AP and AFP will not
+* be modified.
+* = 'N': The matrix A will be copied to AFP and factored.
+* = 'E': The matrix A will be equilibrated if necessary, then
+* copied to AFP and factored.
+*
+* UPLO (input) CHARACTER*1
+* = 'U': Upper triangle of A is stored;
+* = 'L': Lower triangle of A is stored.
+*
+* N (input) INTEGER
+* The number of linear equations, i.e., the order of the
+* matrix A. N >= 0.
+*
+* NRHS (input) INTEGER
+* The number of right hand sides, i.e., the number of columns
+* of the matrices B and X. NRHS >= 0.
+*
+* AP (input/output) REAL array, dimension (N*(N+1)/2)
+* On entry, the upper or lower triangle of the symmetric matrix
+* A, packed columnwise in a linear array, except if FACT = 'F'
+* and EQUED = 'Y', then A must contain the equilibrated matrix
+* diag(S)*A*diag(S). The j-th column of A is stored in the
+* array AP as follows:
+* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
+* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
+* See below for further details. A is not modified if
+* FACT = 'F' or 'N', or if FACT = 'E' and EQUED = 'N' on exit.
+*
+* On exit, if FACT = 'E' and EQUED = 'Y', A is overwritten by
+* diag(S)*A*diag(S).
+*
+* AFP (input or output) REAL array, dimension
+* (N*(N+1)/2)
+* If FACT = 'F', then AFP is an input argument and on entry
+* contains the triangular factor U or L from the Cholesky
+* factorization A = U'*U or A = L*L', in the same storage
+* format as A. If EQUED .ne. 'N', then AFP is the factored
+* form of the equilibrated matrix A.
+*
+* If FACT = 'N', then AFP is an output argument and on exit
+* returns the triangular factor U or L from the Cholesky
+* factorization A = U'*U or A = L*L' of the original matrix A.
+*
+* If FACT = 'E', then AFP is an output argument and on exit
+* returns the triangular factor U or L from the Cholesky
+* factorization A = U'*U or A = L*L' of the equilibrated
+* matrix A (see the description of AP for the form of the
+* equilibrated matrix).
+*
+* EQUED (input or output) CHARACTER*1
+* Specifies the form of equilibration that was done.
+* = 'N': No equilibration (always true if FACT = 'N').
+* = 'Y': Equilibration was done, i.e., A has been replaced by
+* diag(S) * A * diag(S).
+* EQUED is an input argument if FACT = 'F'; otherwise, it is an
+* output argument.
+*
+* S (input or output) REAL array, dimension (N)
+* The scale factors for A; not accessed if EQUED = 'N'. S is
+* an input argument if FACT = 'F'; otherwise, S is an output
+* argument. If FACT = 'F' and EQUED = 'Y', each element of S
+* must be positive.
+*
+* B (input/output) REAL array, dimension (LDB,NRHS)
+* On entry, the N-by-NRHS right hand side matrix B.
+* On exit, if EQUED = 'N', B is not modified; if EQUED = 'Y',
+* B is overwritten by diag(S) * B.
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. LDB >= max(1,N).
+*
+* X (output) REAL array, dimension (LDX,NRHS)
+* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X to
+* the original system of equations. Note that if EQUED = 'Y',
+* A and B are modified on exit, and the solution to the
+* equilibrated system is inv(diag(S))*X.
+*
+* LDX (input) INTEGER
+* The leading dimension of the array X. LDX >= max(1,N).
+*
+* RCOND (output) REAL
+* The estimate of the reciprocal condition number of the matrix
+* A after equilibration (if done). If RCOND is less than the
+* machine precision (in particular, if RCOND = 0), the matrix
+* is singular to working precision. This condition is
+* indicated by a return code of INFO > 0.
+*
+* FERR (output) REAL array, dimension (NRHS)
+* The estimated forward error bound for each solution vector
+* X(j) (the j-th column of the solution matrix X).
+* If XTRUE is the true solution corresponding to X(j), FERR(j)
+* is an estimated upper bound for the magnitude of the largest
+* element in (X(j) - XTRUE) divided by the magnitude of the
+* largest element in X(j). The estimate is as reliable as
+* the estimate for RCOND, and is almost always a slight
+* overestimate of the true error.
+*
+* BERR (output) REAL array, dimension (NRHS)
+* The componentwise relative backward error of each solution
+* vector X(j) (i.e., the smallest relative change in
+* any element of A or B that makes X(j) an exact solution).
+*
+* WORK (workspace) REAL array, dimension (3*N)
+*
+* IWORK (workspace) INTEGER array, dimension (N)
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* > 0: if INFO = i, and i is
+* <= N: the leading minor of order i of A is
+* not positive definite, so the factorization
+* could not be completed, and the solution has not
+* been computed. RCOND = 0 is returned.
+* = N+1: U is nonsingular, but RCOND is less than machine
+* precision, meaning that the matrix is singular
+* to working precision. Nevertheless, the
+* solution and error bounds are computed because
+* there are a number of situations where the
+* computed solution can be more accurate than the
+* value of RCOND would suggest.
+*
+* Further Details
+* ===============
+*
+* The packed storage scheme is illustrated by the following example
+* when N = 4, UPLO = 'U':
+*
+* Two-dimensional storage of the symmetric matrix A:
+*
+* a11 a12 a13 a14
+* a22 a23 a24
+* a33 a34 (aij = conjg(aji))
+* a44
+*
+* Packed storage of the upper triangle of A:
+*
+* AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO, ONE
+ PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL EQUIL, NOFACT, RCEQU
+ INTEGER I, INFEQU, J
+ REAL AMAX, ANORM, BIGNUM, SCOND, SMAX, SMIN, SMLNUM
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ REAL SLAMCH, SLANSP
+ EXTERNAL LSAME, SLAMCH, SLANSP
+* ..
+* .. External Subroutines ..
+ EXTERNAL SCOPY, SLACPY, SLAQSP, SPPCON, SPPEQU, SPPRFS,
+ $ SPPTRF, SPPTRS, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+ INFO = 0
+ NOFACT = LSAME( FACT, 'N' )
+ EQUIL = LSAME( FACT, 'E' )
+ IF( NOFACT .OR. EQUIL ) THEN
+ EQUED = 'N'
+ RCEQU = .FALSE.
+ ELSE
+ RCEQU = LSAME( EQUED, 'Y' )
+ SMLNUM = SLAMCH( 'Safe minimum' )
+ BIGNUM = ONE / SMLNUM
+ END IF
+*
+* Test the input parameters.
+*
+ IF( .NOT.NOFACT .AND. .NOT.EQUIL .AND. .NOT.LSAME( FACT, 'F' ) )
+ $ THEN
+ INFO = -1
+ ELSE IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) )
+ $ THEN
+ INFO = -2
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( NRHS.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( LSAME( FACT, 'F' ) .AND. .NOT.
+ $ ( RCEQU .OR. LSAME( EQUED, 'N' ) ) ) THEN
+ INFO = -7
+ ELSE
+ IF( RCEQU ) THEN
+ SMIN = BIGNUM
+ SMAX = ZERO
+ DO 10 J = 1, N
+ SMIN = MIN( SMIN, S( J ) )
+ SMAX = MAX( SMAX, S( J ) )
+ 10 CONTINUE
+ IF( SMIN.LE.ZERO ) THEN
+ INFO = -8
+ ELSE IF( N.GT.0 ) THEN
+ SCOND = MAX( SMIN, SMLNUM ) / MIN( SMAX, BIGNUM )
+ ELSE
+ SCOND = ONE
+ END IF
+ END IF
+ IF( INFO.EQ.0 ) THEN
+ IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -10
+ ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
+ INFO = -12
+ END IF
+ END IF
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SPPSVX', -INFO )
+ RETURN
+ END IF
+*
+ IF( EQUIL ) THEN
+*
+* Compute row and column scalings to equilibrate the matrix A.
+*
+ CALL SPPEQU( UPLO, N, AP, S, SCOND, AMAX, INFEQU )
+ IF( INFEQU.EQ.0 ) THEN
+*
+* Equilibrate the matrix.
+*
+ CALL SLAQSP( UPLO, N, AP, S, SCOND, AMAX, EQUED )
+ RCEQU = LSAME( EQUED, 'Y' )
+ END IF
+ END IF
+*
+* Scale the right-hand side.
+*
+ IF( RCEQU ) THEN
+ DO 30 J = 1, NRHS
+ DO 20 I = 1, N
+ B( I, J ) = S( I )*B( I, J )
+ 20 CONTINUE
+ 30 CONTINUE
+ END IF
+*
+ IF( NOFACT .OR. EQUIL ) THEN
+*
+* Compute the Cholesky factorization A = U'*U or A = L*L'.
+*
+ CALL SCOPY( N*( N+1 ) / 2, AP, 1, AFP, 1 )
+ CALL SPPTRF( UPLO, N, AFP, INFO )
+*
+* Return if INFO is non-zero.
+*
+ IF( INFO.GT.0 )THEN
+ RCOND = ZERO
+ RETURN
+ END IF
+ END IF
+*
+* Compute the norm of the matrix A.
+*
+ ANORM = SLANSP( 'I', UPLO, N, AP, WORK )
+*
+* Compute the reciprocal of the condition number of A.
+*
+ CALL SPPCON( UPLO, N, AFP, ANORM, RCOND, WORK, IWORK, INFO )
+*
+* Compute the solution matrix X.
+*
+ CALL SLACPY( 'Full', N, NRHS, B, LDB, X, LDX )
+ CALL SPPTRS( UPLO, N, NRHS, AFP, X, LDX, INFO )
+*
+* Use iterative refinement to improve the computed solution and
+* compute error bounds and backward error estimates for it.
+*
+ CALL SPPRFS( UPLO, N, NRHS, AP, AFP, B, LDB, X, LDX, FERR, BERR,
+ $ WORK, IWORK, INFO )
+*
+* Transform the solution matrix X to a solution of the original
+* system.
+*
+ IF( RCEQU ) THEN
+ DO 50 J = 1, NRHS
+ DO 40 I = 1, N
+ X( I, J ) = S( I )*X( I, J )
+ 40 CONTINUE
+ 50 CONTINUE
+ DO 60 J = 1, NRHS
+ FERR( J ) = FERR( J ) / SCOND
+ 60 CONTINUE
+ END IF
+*
+* Set INFO = N+1 if the matrix is singular to working precision.
+*
+ IF( RCOND.LT.SLAMCH( 'Epsilon' ) )
+ $ INFO = N + 1
+*
+ RETURN
+*
+* End of SPPSVX
+*
+ END
+ SUBROUTINE SPPTRF( UPLO, N, AP, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, N
+* ..
+* .. Array Arguments ..
+ REAL AP( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SPPTRF computes the Cholesky factorization of a real symmetric
+* positive definite matrix A stored in packed format.
+*
+* The factorization has the form
+* A = U**T * U, if UPLO = 'U', or
+* A = L * L**T, if UPLO = 'L',
+* where U is an upper triangular matrix and L is lower triangular.
+*
+* Arguments
+* =========
+*
+* UPLO (input) CHARACTER*1
+* = 'U': Upper triangle of A is stored;
+* = 'L': Lower triangle of A is stored.
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* AP (input/output) REAL array, dimension (N*(N+1)/2)
+* On entry, the upper or lower triangle of the symmetric matrix
+* A, packed columnwise in a linear array. The j-th column of A
+* is stored in the array AP as follows:
+* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
+* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
+* See below for further details.
+*
+* On exit, if INFO = 0, the triangular factor U or L from the
+* Cholesky factorization A = U**T*U or A = L*L**T, in the same
+* storage format as A.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* > 0: if INFO = i, the leading minor of order i is not
+* positive definite, and the factorization could not be
+* completed.
+*
+* Further Details
+* ======= =======
+*
+* The packed storage scheme is illustrated by the following example
+* when N = 4, UPLO = 'U':
+*
+* Two-dimensional storage of the symmetric matrix A:
+*
+* a11 a12 a13 a14
+* a22 a23 a24
+* a33 a34 (aij = aji)
+* a44
+*
+* Packed storage of the upper triangle of A:
+*
+* AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ONE, ZERO
+ PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL UPPER
+ INTEGER J, JC, JJ
+ REAL AJJ
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ REAL SDOT
+ EXTERNAL LSAME, SDOT
+* ..
+* .. External Subroutines ..
+ EXTERNAL SSCAL, SSPR, STPSV, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC SQRT
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SPPTRF', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+ IF( UPPER ) THEN
+*
+* Compute the Cholesky factorization A = U'*U.
+*
+ JJ = 0
+ DO 10 J = 1, N
+ JC = JJ + 1
+ JJ = JJ + J
+*
+* Compute elements 1:J-1 of column J.
+*
+ IF( J.GT.1 )
+ $ CALL STPSV( 'Upper', 'Transpose', 'Non-unit', J-1, AP,
+ $ AP( JC ), 1 )
+*
+* Compute U(J,J) and test for non-positive-definiteness.
+*
+ AJJ = AP( JJ ) - SDOT( J-1, AP( JC ), 1, AP( JC ), 1 )
+ IF( AJJ.LE.ZERO ) THEN
+ AP( JJ ) = AJJ
+ GO TO 30
+ END IF
+ AP( JJ ) = SQRT( AJJ )
+ 10 CONTINUE
+ ELSE
+*
+* Compute the Cholesky factorization A = L*L'.
+*
+ JJ = 1
+ DO 20 J = 1, N
+*
+* Compute L(J,J) and test for non-positive-definiteness.
+*
+ AJJ = AP( JJ )
+ IF( AJJ.LE.ZERO ) THEN
+ AP( JJ ) = AJJ
+ GO TO 30
+ END IF
+ AJJ = SQRT( AJJ )
+ AP( JJ ) = AJJ
+*
+* Compute elements J+1:N of column J and update the trailing
+* submatrix.
+*
+ IF( J.LT.N ) THEN
+ CALL SSCAL( N-J, ONE / AJJ, AP( JJ+1 ), 1 )
+ CALL SSPR( 'Lower', N-J, -ONE, AP( JJ+1 ), 1,
+ $ AP( JJ+N-J+1 ) )
+ JJ = JJ + N - J + 1
+ END IF
+ 20 CONTINUE
+ END IF
+ GO TO 40
+*
+ 30 CONTINUE
+ INFO = J
+*
+ 40 CONTINUE
+ RETURN
+*
+* End of SPPTRF
+*
+ END
+ SUBROUTINE SPPTRI( UPLO, N, AP, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, N
+* ..
+* .. Array Arguments ..
+ REAL AP( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SPPTRI computes the inverse of a real symmetric positive definite
+* matrix A using the Cholesky factorization A = U**T*U or A = L*L**T
+* computed by SPPTRF.
+*
+* Arguments
+* =========
+*
+* UPLO (input) CHARACTER*1
+* = 'U': Upper triangular factor is stored in AP;
+* = 'L': Lower triangular factor is stored in AP.
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* AP (input/output) REAL array, dimension (N*(N+1)/2)
+* On entry, the triangular factor U or L from the Cholesky
+* factorization A = U**T*U or A = L*L**T, packed columnwise as
+* a linear array. The j-th column of U or L is stored in the
+* array AP as follows:
+* if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j;
+* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n.
+*
+* On exit, the upper or lower triangle of the (symmetric)
+* inverse of A, overwriting the input factor U or L.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* > 0: if INFO = i, the (i,i) element of the factor U or L is
+* zero, and the inverse could not be computed.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ONE
+ PARAMETER ( ONE = 1.0E+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL UPPER
+ INTEGER J, JC, JJ, JJN
+ REAL AJJ
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ REAL SDOT
+ EXTERNAL LSAME, SDOT
+* ..
+* .. External Subroutines ..
+ EXTERNAL SSCAL, SSPR, STPMV, STPTRI, XERBLA
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SPPTRI', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+* Invert the triangular Cholesky factor U or L.
+*
+ CALL STPTRI( UPLO, 'Non-unit', N, AP, INFO )
+ IF( INFO.GT.0 )
+ $ RETURN
+*
+ IF( UPPER ) THEN
+*
+* Compute the product inv(U) * inv(U)'.
+*
+ JJ = 0
+ DO 10 J = 1, N
+ JC = JJ + 1
+ JJ = JJ + J
+ IF( J.GT.1 )
+ $ CALL SSPR( 'Upper', J-1, ONE, AP( JC ), 1, AP )
+ AJJ = AP( JJ )
+ CALL SSCAL( J, AJJ, AP( JC ), 1 )
+ 10 CONTINUE
+*
+ ELSE
+*
+* Compute the product inv(L)' * inv(L).
+*
+ JJ = 1
+ DO 20 J = 1, N
+ JJN = JJ + N - J + 1
+ AP( JJ ) = SDOT( N-J+1, AP( JJ ), 1, AP( JJ ), 1 )
+ IF( J.LT.N )
+ $ CALL STPMV( 'Lower', 'Transpose', 'Non-unit', N-J,
+ $ AP( JJN ), AP( JJ+1 ), 1 )
+ JJ = JJN
+ 20 CONTINUE
+ END IF
+*
+ RETURN
+*
+* End of SPPTRI
+*
+ END
+ SUBROUTINE SPPTRS( UPLO, N, NRHS, AP, B, LDB, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, LDB, N, NRHS
+* ..
+* .. Array Arguments ..
+ REAL AP( * ), B( LDB, * )
+* ..
+*
+* Purpose
+* =======
+*
+* SPPTRS solves a system of linear equations A*X = B with a symmetric
+* positive definite matrix A in packed storage using the Cholesky
+* factorization A = U**T*U or A = L*L**T computed by SPPTRF.
+*
+* Arguments
+* =========
+*
+* UPLO (input) CHARACTER*1
+* = 'U': Upper triangle of A is stored;
+* = 'L': Lower triangle of A is stored.
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* NRHS (input) INTEGER
+* The number of right hand sides, i.e., the number of columns
+* of the matrix B. NRHS >= 0.
+*
+* AP (input) REAL array, dimension (N*(N+1)/2)
+* The triangular factor U or L from the Cholesky factorization
+* A = U**T*U or A = L*L**T, packed columnwise in a linear
+* array. The j-th column of U or L is stored in the array AP
+* as follows:
+* if UPLO = 'U', AP(i + (j-1)*j/2) = U(i,j) for 1<=i<=j;
+* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = L(i,j) for j<=i<=n.
+*
+* B (input/output) REAL array, dimension (LDB,NRHS)
+* On entry, the right hand side matrix B.
+* On exit, the solution matrix X.
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. LDB >= max(1,N).
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ LOGICAL UPPER
+ INTEGER I
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL STPSV, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( NRHS.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -6
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SPPTRS', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 .OR. NRHS.EQ.0 )
+ $ RETURN
+*
+ IF( UPPER ) THEN
+*
+* Solve A*X = B where A = U'*U.
+*
+ DO 10 I = 1, NRHS
+*
+* Solve U'*X = B, overwriting B with X.
+*
+ CALL STPSV( 'Upper', 'Transpose', 'Non-unit', N, AP,
+ $ B( 1, I ), 1 )
+*
+* Solve U*X = B, overwriting B with X.
+*
+ CALL STPSV( 'Upper', 'No transpose', 'Non-unit', N, AP,
+ $ B( 1, I ), 1 )
+ 10 CONTINUE
+ ELSE
+*
+* Solve A*X = B where A = L*L'.
+*
+ DO 20 I = 1, NRHS
+*
+* Solve L*Y = B, overwriting B with X.
+*
+ CALL STPSV( 'Lower', 'No transpose', 'Non-unit', N, AP,
+ $ B( 1, I ), 1 )
+*
+* Solve L'*X = Y, overwriting B with X.
+*
+ CALL STPSV( 'Lower', 'Transpose', 'Non-unit', N, AP,
+ $ B( 1, I ), 1 )
+ 20 CONTINUE
+ END IF
+*
+ RETURN
+*
+* End of SPPTRS
+*
+ END
+ SUBROUTINE SPTCON( N, D, E, ANORM, RCOND, WORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, N
+ REAL ANORM, RCOND
+* ..
+* .. Array Arguments ..
+ REAL D( * ), E( * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SPTCON computes the reciprocal of the condition number (in the
+* 1-norm) of a real symmetric positive definite tridiagonal matrix
+* using the factorization A = L*D*L**T or A = U**T*D*U computed by
+* SPTTRF.
+*
+* Norm(inv(A)) is computed by a direct method, and the reciprocal of
+* the condition number is computed as
+* RCOND = 1 / (ANORM * norm(inv(A))).
+*
+* Arguments
+* =========
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* D (input) REAL array, dimension (N)
+* The n diagonal elements of the diagonal matrix D from the
+* factorization of A, as computed by SPTTRF.
+*
+* E (input) REAL array, dimension (N-1)
+* The (n-1) off-diagonal elements of the unit bidiagonal factor
+* U or L from the factorization of A, as computed by SPTTRF.
+*
+* ANORM (input) REAL
+* The 1-norm of the original matrix A.
+*
+* RCOND (output) REAL
+* The reciprocal of the condition number of the matrix A,
+* computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is the
+* 1-norm of inv(A) computed in this routine.
+*
+* WORK (workspace) REAL array, dimension (N)
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+*
+* Further Details
+* ===============
+*
+* The method used is described in Nicholas J. Higham, "Efficient
+* Algorithms for Computing the Condition Number of a Tridiagonal
+* Matrix", SIAM J. Sci. Stat. Comput., Vol. 7, No. 1, January 1986.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ONE, ZERO
+ PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, IX
+ REAL AINVNM
+* ..
+* .. External Functions ..
+ INTEGER ISAMAX
+ EXTERNAL ISAMAX
+* ..
+* .. External Subroutines ..
+ EXTERNAL XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS
+* ..
+* .. Executable Statements ..
+*
+* Test the input arguments.
+*
+ INFO = 0
+ IF( N.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( ANORM.LT.ZERO ) THEN
+ INFO = -4
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SPTCON', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ RCOND = ZERO
+ IF( N.EQ.0 ) THEN
+ RCOND = ONE
+ RETURN
+ ELSE IF( ANORM.EQ.ZERO ) THEN
+ RETURN
+ END IF
+*
+* Check that D(1:N) is positive.
+*
+ DO 10 I = 1, N
+ IF( D( I ).LE.ZERO )
+ $ RETURN
+ 10 CONTINUE
+*
+* Solve M(A) * x = e, where M(A) = (m(i,j)) is given by
+*
+* m(i,j) = abs(A(i,j)), i = j,
+* m(i,j) = -abs(A(i,j)), i .ne. j,
+*
+* and e = [ 1, 1, ..., 1 ]'. Note M(A) = M(L)*D*M(L)'.
+*
+* Solve M(L) * x = e.
+*
+ WORK( 1 ) = ONE
+ DO 20 I = 2, N
+ WORK( I ) = ONE + WORK( I-1 )*ABS( E( I-1 ) )
+ 20 CONTINUE
+*
+* Solve D * M(L)' * x = b.
+*
+ WORK( N ) = WORK( N ) / D( N )
+ DO 30 I = N - 1, 1, -1
+ WORK( I ) = WORK( I ) / D( I ) + WORK( I+1 )*ABS( E( I ) )
+ 30 CONTINUE
+*
+* Compute AINVNM = max(x(i)), 1<=i<=n.
+*
+ IX = ISAMAX( N, WORK, 1 )
+ AINVNM = ABS( WORK( IX ) )
+*
+* Compute the reciprocal condition number.
+*
+ IF( AINVNM.NE.ZERO )
+ $ RCOND = ( ONE / AINVNM ) / ANORM
+*
+ RETURN
+*
+* End of SPTCON
+*
+ END
+ SUBROUTINE SPTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER COMPZ
+ INTEGER INFO, LDZ, N
+* ..
+* .. Array Arguments ..
+ REAL D( * ), E( * ), WORK( * ), Z( LDZ, * )
+* ..
+*
+* Purpose
+* =======
+*
+* SPTEQR computes all eigenvalues and, optionally, eigenvectors of a
+* symmetric positive definite tridiagonal matrix by first factoring the
+* matrix using SPTTRF, and then calling SBDSQR to compute the singular
+* values of the bidiagonal factor.
+*
+* This routine computes the eigenvalues of the positive definite
+* tridiagonal matrix to high relative accuracy. This means that if the
+* eigenvalues range over many orders of magnitude in size, then the
+* small eigenvalues and corresponding eigenvectors will be computed
+* more accurately than, for example, with the standard QR method.
+*
+* The eigenvectors of a full or band symmetric positive definite matrix
+* can also be found if SSYTRD, SSPTRD, or SSBTRD has been used to
+* reduce this matrix to tridiagonal form. (The reduction to tridiagonal
+* form, however, may preclude the possibility of obtaining high
+* relative accuracy in the small eigenvalues of the original matrix, if
+* these eigenvalues range over many orders of magnitude.)
+*
+* Arguments
+* =========
+*
+* COMPZ (input) CHARACTER*1
+* = 'N': Compute eigenvalues only.
+* = 'V': Compute eigenvectors of original symmetric
+* matrix also. Array Z contains the orthogonal
+* matrix used to reduce the original matrix to
+* tridiagonal form.
+* = 'I': Compute eigenvectors of tridiagonal matrix also.
+*
+* N (input) INTEGER
+* The order of the matrix. N >= 0.
+*
+* D (input/output) REAL array, dimension (N)
+* On entry, the n diagonal elements of the tridiagonal
+* matrix.
+* On normal exit, D contains the eigenvalues, in descending
+* order.
+*
+* E (input/output) REAL array, dimension (N-1)
+* On entry, the (n-1) subdiagonal elements of the tridiagonal
+* matrix.
+* On exit, E has been destroyed.
+*
+* Z (input/output) REAL array, dimension (LDZ, N)
+* On entry, if COMPZ = 'V', the orthogonal matrix used in the
+* reduction to tridiagonal form.
+* On exit, if COMPZ = 'V', the orthonormal eigenvectors of the
+* original symmetric matrix;
+* if COMPZ = 'I', the orthonormal eigenvectors of the
+* tridiagonal matrix.
+* If INFO > 0 on exit, Z contains the eigenvectors associated
+* with only the stored eigenvalues.
+* If COMPZ = 'N', then Z is not referenced.
+*
+* LDZ (input) INTEGER
+* The leading dimension of the array Z. LDZ >= 1, and if
+* COMPZ = 'V' or 'I', LDZ >= max(1,N).
+*
+* WORK (workspace) REAL array, dimension (4*N)
+*
+* INFO (output) INTEGER
+* = 0: successful exit.
+* < 0: if INFO = -i, the i-th argument had an illegal value.
+* > 0: if INFO = i, and i is:
+* <= N the Cholesky factorization of the matrix could
+* not be performed because the i-th principal minor
+* was not positive definite.
+* > N the SVD algorithm failed to converge;
+* if INFO = N+i, i off-diagonal elements of the
+* bidiagonal factor did not converge to zero.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO, ONE
+ PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 )
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL SBDSQR, SLASET, SPTTRF, XERBLA
+* ..
+* .. Local Arrays ..
+ REAL C( 1, 1 ), VT( 1, 1 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, ICOMPZ, NRU
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, SQRT
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+*
+ IF( LSAME( COMPZ, 'N' ) ) THEN
+ ICOMPZ = 0
+ ELSE IF( LSAME( COMPZ, 'V' ) ) THEN
+ ICOMPZ = 1
+ ELSE IF( LSAME( COMPZ, 'I' ) ) THEN
+ ICOMPZ = 2
+ ELSE
+ ICOMPZ = -1
+ END IF
+ IF( ICOMPZ.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( ( LDZ.LT.1 ) .OR. ( ICOMPZ.GT.0 .AND. LDZ.LT.MAX( 1,
+ $ N ) ) ) THEN
+ INFO = -6
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SPTEQR', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+ IF( N.EQ.1 ) THEN
+ IF( ICOMPZ.GT.0 )
+ $ Z( 1, 1 ) = ONE
+ RETURN
+ END IF
+ IF( ICOMPZ.EQ.2 )
+ $ CALL SLASET( 'Full', N, N, ZERO, ONE, Z, LDZ )
+*
+* Call SPTTRF to factor the matrix.
+*
+ CALL SPTTRF( N, D, E, INFO )
+ IF( INFO.NE.0 )
+ $ RETURN
+ DO 10 I = 1, N
+ D( I ) = SQRT( D( I ) )
+ 10 CONTINUE
+ DO 20 I = 1, N - 1
+ E( I ) = E( I )*D( I )
+ 20 CONTINUE
+*
+* Call SBDSQR to compute the singular values/vectors of the
+* bidiagonal factor.
+*
+ IF( ICOMPZ.GT.0 ) THEN
+ NRU = N
+ ELSE
+ NRU = 0
+ END IF
+ CALL SBDSQR( 'Lower', N, 0, NRU, 0, D, E, VT, 1, Z, LDZ, C, 1,
+ $ WORK, INFO )
+*
+* Square the singular values.
+*
+ IF( INFO.EQ.0 ) THEN
+ DO 30 I = 1, N
+ D( I ) = D( I )*D( I )
+ 30 CONTINUE
+ ELSE
+ INFO = N + INFO
+ END IF
+*
+ RETURN
+*
+* End of SPTEQR
+*
+ END
+ SUBROUTINE SPTRFS( N, NRHS, D, E, DF, EF, B, LDB, X, LDX, FERR,
+ $ BERR, WORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LDB, LDX, N, NRHS
+* ..
+* .. Array Arguments ..
+ REAL B( LDB, * ), BERR( * ), D( * ), DF( * ),
+ $ E( * ), EF( * ), FERR( * ), WORK( * ),
+ $ X( LDX, * )
+* ..
+*
+* Purpose
+* =======
+*
+* SPTRFS improves the computed solution to a system of linear
+* equations when the coefficient matrix is symmetric positive definite
+* and tridiagonal, and provides error bounds and backward error
+* estimates for the solution.
+*
+* Arguments
+* =========
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* NRHS (input) INTEGER
+* The number of right hand sides, i.e., the number of columns
+* of the matrix B. NRHS >= 0.
+*
+* D (input) REAL array, dimension (N)
+* The n diagonal elements of the tridiagonal matrix A.
+*
+* E (input) REAL array, dimension (N-1)
+* The (n-1) subdiagonal elements of the tridiagonal matrix A.
+*
+* DF (input) REAL array, dimension (N)
+* The n diagonal elements of the diagonal matrix D from the
+* factorization computed by SPTTRF.
+*
+* EF (input) REAL array, dimension (N-1)
+* The (n-1) subdiagonal elements of the unit bidiagonal factor
+* L from the factorization computed by SPTTRF.
+*
+* B (input) REAL array, dimension (LDB,NRHS)
+* The right hand side matrix B.
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. LDB >= max(1,N).
+*
+* X (input/output) REAL array, dimension (LDX,NRHS)
+* On entry, the solution matrix X, as computed by SPTTRS.
+* On exit, the improved solution matrix X.
+*
+* LDX (input) INTEGER
+* The leading dimension of the array X. LDX >= max(1,N).
+*
+* FERR (output) REAL array, dimension (NRHS)
+* The forward error bound for each solution vector
+* X(j) (the j-th column of the solution matrix X).
+* If XTRUE is the true solution corresponding to X(j), FERR(j)
+* is an estimated upper bound for the magnitude of the largest
+* element in (X(j) - XTRUE) divided by the magnitude of the
+* largest element in X(j).
+*
+* BERR (output) REAL array, dimension (NRHS)
+* The componentwise relative backward error of each solution
+* vector X(j) (i.e., the smallest relative change in
+* any element of A or B that makes X(j) an exact solution).
+*
+* WORK (workspace) REAL array, dimension (2*N)
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+*
+* Internal Parameters
+* ===================
+*
+* ITMAX is the maximum number of steps of iterative refinement.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ INTEGER ITMAX
+ PARAMETER ( ITMAX = 5 )
+ REAL ZERO
+ PARAMETER ( ZERO = 0.0E+0 )
+ REAL ONE
+ PARAMETER ( ONE = 1.0E+0 )
+ REAL TWO
+ PARAMETER ( TWO = 2.0E+0 )
+ REAL THREE
+ PARAMETER ( THREE = 3.0E+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER COUNT, I, IX, J, NZ
+ REAL BI, CX, DX, EPS, EX, LSTRES, S, SAFE1, SAFE2,
+ $ SAFMIN
+* ..
+* .. External Subroutines ..
+ EXTERNAL SAXPY, SPTTRS, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX
+* ..
+* .. External Functions ..
+ INTEGER ISAMAX
+ REAL SLAMCH
+ EXTERNAL ISAMAX, SLAMCH
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ IF( N.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( NRHS.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -8
+ ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
+ INFO = -10
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SPTRFS', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN
+ DO 10 J = 1, NRHS
+ FERR( J ) = ZERO
+ BERR( J ) = ZERO
+ 10 CONTINUE
+ RETURN
+ END IF
+*
+* NZ = maximum number of nonzero elements in each row of A, plus 1
+*
+ NZ = 4
+ EPS = SLAMCH( 'Epsilon' )
+ SAFMIN = SLAMCH( 'Safe minimum' )
+ SAFE1 = NZ*SAFMIN
+ SAFE2 = SAFE1 / EPS
+*
+* Do for each right hand side
+*
+ DO 90 J = 1, NRHS
+*
+ COUNT = 1
+ LSTRES = THREE
+ 20 CONTINUE
+*
+* Loop until stopping criterion is satisfied.
+*
+* Compute residual R = B - A * X. Also compute
+* abs(A)*abs(x) + abs(b) for use in the backward error bound.
+*
+ IF( N.EQ.1 ) THEN
+ BI = B( 1, J )
+ DX = D( 1 )*X( 1, J )
+ WORK( N+1 ) = BI - DX
+ WORK( 1 ) = ABS( BI ) + ABS( DX )
+ ELSE
+ BI = B( 1, J )
+ DX = D( 1 )*X( 1, J )
+ EX = E( 1 )*X( 2, J )
+ WORK( N+1 ) = BI - DX - EX
+ WORK( 1 ) = ABS( BI ) + ABS( DX ) + ABS( EX )
+ DO 30 I = 2, N - 1
+ BI = B( I, J )
+ CX = E( I-1 )*X( I-1, J )
+ DX = D( I )*X( I, J )
+ EX = E( I )*X( I+1, J )
+ WORK( N+I ) = BI - CX - DX - EX
+ WORK( I ) = ABS( BI ) + ABS( CX ) + ABS( DX ) + ABS( EX )
+ 30 CONTINUE
+ BI = B( N, J )
+ CX = E( N-1 )*X( N-1, J )
+ DX = D( N )*X( N, J )
+ WORK( N+N ) = BI - CX - DX
+ WORK( N ) = ABS( BI ) + ABS( CX ) + ABS( DX )
+ END IF
+*
+* Compute componentwise relative backward error from formula
+*
+* max(i) ( abs(R(i)) / ( abs(A)*abs(X) + abs(B) )(i) )
+*
+* where abs(Z) is the componentwise absolute value of the matrix
+* or vector Z. If the i-th component of the denominator is less
+* than SAFE2, then SAFE1 is added to the i-th components of the
+* numerator and denominator before dividing.
+*
+ S = ZERO
+ DO 40 I = 1, N
+ IF( WORK( I ).GT.SAFE2 ) THEN
+ S = MAX( S, ABS( WORK( N+I ) ) / WORK( I ) )
+ ELSE
+ S = MAX( S, ( ABS( WORK( N+I ) )+SAFE1 ) /
+ $ ( WORK( I )+SAFE1 ) )
+ END IF
+ 40 CONTINUE
+ BERR( J ) = S
+*
+* Test stopping criterion. Continue iterating if
+* 1) The residual BERR(J) is larger than machine epsilon, and
+* 2) BERR(J) decreased by at least a factor of 2 during the
+* last iteration, and
+* 3) At most ITMAX iterations tried.
+*
+ IF( BERR( J ).GT.EPS .AND. TWO*BERR( J ).LE.LSTRES .AND.
+ $ COUNT.LE.ITMAX ) THEN
+*
+* Update solution and try again.
+*
+ CALL SPTTRS( N, 1, DF, EF, WORK( N+1 ), N, INFO )
+ CALL SAXPY( N, ONE, WORK( N+1 ), 1, X( 1, J ), 1 )
+ LSTRES = BERR( J )
+ COUNT = COUNT + 1
+ GO TO 20
+ END IF
+*
+* Bound error from formula
+*
+* norm(X - XTRUE) / norm(X) .le. FERR =
+* norm( abs(inv(A))*
+* ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X)
+*
+* where
+* norm(Z) is the magnitude of the largest component of Z
+* inv(A) is the inverse of A
+* abs(Z) is the componentwise absolute value of the matrix or
+* vector Z
+* NZ is the maximum number of nonzeros in any row of A, plus 1
+* EPS is machine epsilon
+*
+* The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B))
+* is incremented by SAFE1 if the i-th component of
+* abs(A)*abs(X) + abs(B) is less than SAFE2.
+*
+ DO 50 I = 1, N
+ IF( WORK( I ).GT.SAFE2 ) THEN
+ WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I )
+ ELSE
+ WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I ) + SAFE1
+ END IF
+ 50 CONTINUE
+ IX = ISAMAX( N, WORK, 1 )
+ FERR( J ) = WORK( IX )
+*
+* Estimate the norm of inv(A).
+*
+* Solve M(A) * x = e, where M(A) = (m(i,j)) is given by
+*
+* m(i,j) = abs(A(i,j)), i = j,
+* m(i,j) = -abs(A(i,j)), i .ne. j,
+*
+* and e = [ 1, 1, ..., 1 ]'. Note M(A) = M(L)*D*M(L)'.
+*
+* Solve M(L) * x = e.
+*
+ WORK( 1 ) = ONE
+ DO 60 I = 2, N
+ WORK( I ) = ONE + WORK( I-1 )*ABS( EF( I-1 ) )
+ 60 CONTINUE
+*
+* Solve D * M(L)' * x = b.
+*
+ WORK( N ) = WORK( N ) / DF( N )
+ DO 70 I = N - 1, 1, -1
+ WORK( I ) = WORK( I ) / DF( I ) + WORK( I+1 )*ABS( EF( I ) )
+ 70 CONTINUE
+*
+* Compute norm(inv(A)) = max(x(i)), 1<=i<=n.
+*
+ IX = ISAMAX( N, WORK, 1 )
+ FERR( J ) = FERR( J )*ABS( WORK( IX ) )
+*
+* Normalize error.
+*
+ LSTRES = ZERO
+ DO 80 I = 1, N
+ LSTRES = MAX( LSTRES, ABS( X( I, J ) ) )
+ 80 CONTINUE
+ IF( LSTRES.NE.ZERO )
+ $ FERR( J ) = FERR( J ) / LSTRES
+*
+ 90 CONTINUE
+*
+ RETURN
+*
+* End of SPTRFS
+*
+ END
+ SUBROUTINE SPTSV( N, NRHS, D, E, B, LDB, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LDB, N, NRHS
+* ..
+* .. Array Arguments ..
+ REAL B( LDB, * ), D( * ), E( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SPTSV computes the solution to a real system of linear equations
+* A*X = B, where A is an N-by-N symmetric positive definite tridiagonal
+* matrix, and X and B are N-by-NRHS matrices.
+*
+* A is factored as A = L*D*L**T, and the factored form of A is then
+* used to solve the system of equations.
+*
+* Arguments
+* =========
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* NRHS (input) INTEGER
+* The number of right hand sides, i.e., the number of columns
+* of the matrix B. NRHS >= 0.
+*
+* D (input/output) REAL array, dimension (N)
+* On entry, the n diagonal elements of the tridiagonal matrix
+* A. On exit, the n diagonal elements of the diagonal matrix
+* D from the factorization A = L*D*L**T.
+*
+* E (input/output) REAL array, dimension (N-1)
+* On entry, the (n-1) subdiagonal elements of the tridiagonal
+* matrix A. On exit, the (n-1) subdiagonal elements of the
+* unit bidiagonal factor L from the L*D*L**T factorization of
+* A. (E can also be regarded as the superdiagonal of the unit
+* bidiagonal factor U from the U**T*D*U factorization of A.)
+*
+* B (input/output) REAL array, dimension (LDB,NRHS)
+* On entry, the N-by-NRHS right hand side matrix B.
+* On exit, if INFO = 0, the N-by-NRHS solution matrix X.
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. LDB >= max(1,N).
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* > 0: if INFO = i, the leading minor of order i is not
+* positive definite, and the solution has not been
+* computed. The factorization has not been completed
+* unless i = N.
+*
+* =====================================================================
+*
+* .. External Subroutines ..
+ EXTERNAL SPTTRF, SPTTRS, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ IF( N.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( NRHS.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -6
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SPTSV ', -INFO )
+ RETURN
+ END IF
+*
+* Compute the L*D*L' (or U'*D*U) factorization of A.
+*
+ CALL SPTTRF( N, D, E, INFO )
+ IF( INFO.EQ.0 ) THEN
+*
+* Solve the system A*X = B, overwriting B with X.
+*
+ CALL SPTTRS( N, NRHS, D, E, B, LDB, INFO )
+ END IF
+ RETURN
+*
+* End of SPTSV
+*
+ END
+ SUBROUTINE SPTSVX( FACT, N, NRHS, D, E, DF, EF, B, LDB, X, LDX,
+ $ RCOND, FERR, BERR, WORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER FACT
+ INTEGER INFO, LDB, LDX, N, NRHS
+ REAL RCOND
+* ..
+* .. Array Arguments ..
+ REAL B( LDB, * ), BERR( * ), D( * ), DF( * ),
+ $ E( * ), EF( * ), FERR( * ), WORK( * ),
+ $ X( LDX, * )
+* ..
+*
+* Purpose
+* =======
+*
+* SPTSVX uses the factorization A = L*D*L**T to compute the solution
+* to a real system of linear equations A*X = B, where A is an N-by-N
+* symmetric positive definite tridiagonal matrix and X and B are
+* N-by-NRHS matrices.
+*
+* Error bounds on the solution and a condition estimate are also
+* provided.
+*
+* Description
+* ===========
+*
+* The following steps are performed:
+*
+* 1. If FACT = 'N', the matrix A is factored as A = L*D*L**T, where L
+* is a unit lower bidiagonal matrix and D is diagonal. The
+* factorization can also be regarded as having the form
+* A = U**T*D*U.
+*
+* 2. If the leading i-by-i principal minor is not positive definite,
+* then the routine returns with INFO = i. Otherwise, the factored
+* form of A is used to estimate the condition number of the matrix
+* A. If the reciprocal of the condition number is less than machine
+* precision, INFO = N+1 is returned as a warning, but the routine
+* still goes on to solve for X and compute error bounds as
+* described below.
+*
+* 3. The system of equations is solved for X using the factored form
+* of A.
+*
+* 4. Iterative refinement is applied to improve the computed solution
+* matrix and calculate error bounds and backward error estimates
+* for it.
+*
+* Arguments
+* =========
+*
+* FACT (input) CHARACTER*1
+* Specifies whether or not the factored form of A has been
+* supplied on entry.
+* = 'F': On entry, DF and EF contain the factored form of A.
+* D, E, DF, and EF will not be modified.
+* = 'N': The matrix A will be copied to DF and EF and
+* factored.
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* NRHS (input) INTEGER
+* The number of right hand sides, i.e., the number of columns
+* of the matrices B and X. NRHS >= 0.
+*
+* D (input) REAL array, dimension (N)
+* The n diagonal elements of the tridiagonal matrix A.
+*
+* E (input) REAL array, dimension (N-1)
+* The (n-1) subdiagonal elements of the tridiagonal matrix A.
+*
+* DF (input or output) REAL array, dimension (N)
+* If FACT = 'F', then DF is an input argument and on entry
+* contains the n diagonal elements of the diagonal matrix D
+* from the L*D*L**T factorization of A.
+* If FACT = 'N', then DF is an output argument and on exit
+* contains the n diagonal elements of the diagonal matrix D
+* from the L*D*L**T factorization of A.
+*
+* EF (input or output) REAL array, dimension (N-1)
+* If FACT = 'F', then EF is an input argument and on entry
+* contains the (n-1) subdiagonal elements of the unit
+* bidiagonal factor L from the L*D*L**T factorization of A.
+* If FACT = 'N', then EF is an output argument and on exit
+* contains the (n-1) subdiagonal elements of the unit
+* bidiagonal factor L from the L*D*L**T factorization of A.
+*
+* B (input) REAL array, dimension (LDB,NRHS)
+* The N-by-NRHS right hand side matrix B.
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. LDB >= max(1,N).
+*
+* X (output) REAL array, dimension (LDX,NRHS)
+* If INFO = 0 of INFO = N+1, the N-by-NRHS solution matrix X.
+*
+* LDX (input) INTEGER
+* The leading dimension of the array X. LDX >= max(1,N).
+*
+* RCOND (output) REAL
+* The reciprocal condition number of the matrix A. If RCOND
+* is less than the machine precision (in particular, if
+* RCOND = 0), the matrix is singular to working precision.
+* This condition is indicated by a return code of INFO > 0.
+*
+* FERR (output) REAL array, dimension (NRHS)
+* The forward error bound for each solution vector
+* X(j) (the j-th column of the solution matrix X).
+* If XTRUE is the true solution corresponding to X(j), FERR(j)
+* is an estimated upper bound for the magnitude of the largest
+* element in (X(j) - XTRUE) divided by the magnitude of the
+* largest element in X(j).
+*
+* BERR (output) REAL array, dimension (NRHS)
+* The componentwise relative backward error of each solution
+* vector X(j) (i.e., the smallest relative change in any
+* element of A or B that makes X(j) an exact solution).
+*
+* WORK (workspace) REAL array, dimension (2*N)
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* > 0: if INFO = i, and i is
+* <= N: the leading minor of order i of A is
+* not positive definite, so the factorization
+* could not be completed, and the solution has not
+* been computed. RCOND = 0 is returned.
+* = N+1: U is nonsingular, but RCOND is less than machine
+* precision, meaning that the matrix is singular
+* to working precision. Nevertheless, the
+* solution and error bounds are computed because
+* there are a number of situations where the
+* computed solution can be more accurate than the
+* value of RCOND would suggest.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO
+ PARAMETER ( ZERO = 0.0E+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL NOFACT
+ REAL ANORM
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ REAL SLAMCH, SLANST
+ EXTERNAL LSAME, SLAMCH, SLANST
+* ..
+* .. External Subroutines ..
+ EXTERNAL SCOPY, SLACPY, SPTCON, SPTRFS, SPTTRF, SPTTRS,
+ $ XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ NOFACT = LSAME( FACT, 'N' )
+ IF( .NOT.NOFACT .AND. .NOT.LSAME( FACT, 'F' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( NRHS.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -9
+ ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
+ INFO = -11
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SPTSVX', -INFO )
+ RETURN
+ END IF
+*
+ IF( NOFACT ) THEN
+*
+* Compute the L*D*L' (or U'*D*U) factorization of A.
+*
+ CALL SCOPY( N, D, 1, DF, 1 )
+ IF( N.GT.1 )
+ $ CALL SCOPY( N-1, E, 1, EF, 1 )
+ CALL SPTTRF( N, DF, EF, INFO )
+*
+* Return if INFO is non-zero.
+*
+ IF( INFO.GT.0 )THEN
+ RCOND = ZERO
+ RETURN
+ END IF
+ END IF
+*
+* Compute the norm of the matrix A.
+*
+ ANORM = SLANST( '1', N, D, E )
+*
+* Compute the reciprocal of the condition number of A.
+*
+ CALL SPTCON( N, DF, EF, ANORM, RCOND, WORK, INFO )
+*
+* Compute the solution vectors X.
+*
+ CALL SLACPY( 'Full', N, NRHS, B, LDB, X, LDX )
+ CALL SPTTRS( N, NRHS, DF, EF, X, LDX, INFO )
+*
+* Use iterative refinement to improve the computed solutions and
+* compute error bounds and backward error estimates for them.
+*
+ CALL SPTRFS( N, NRHS, D, E, DF, EF, B, LDB, X, LDX, FERR, BERR,
+ $ WORK, INFO )
+*
+* Set INFO = N+1 if the matrix is singular to working precision.
+*
+ IF( RCOND.LT.SLAMCH( 'Epsilon' ) )
+ $ INFO = N + 1
+*
+ RETURN
+*
+* End of SPTSVX
+*
+ END
+ SUBROUTINE SPTTRF( N, D, E, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, N
+* ..
+* .. Array Arguments ..
+ REAL D( * ), E( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SPTTRF computes the L*D*L' factorization of a real symmetric
+* positive definite tridiagonal matrix A. The factorization may also
+* be regarded as having the form A = U'*D*U.
+*
+* Arguments
+* =========
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* D (input/output) REAL array, dimension (N)
+* On entry, the n diagonal elements of the tridiagonal matrix
+* A. On exit, the n diagonal elements of the diagonal matrix
+* D from the L*D*L' factorization of A.
+*
+* E (input/output) REAL array, dimension (N-1)
+* On entry, the (n-1) subdiagonal elements of the tridiagonal
+* matrix A. On exit, the (n-1) subdiagonal elements of the
+* unit bidiagonal factor L from the L*D*L' factorization of A.
+* E can also be regarded as the superdiagonal of the unit
+* bidiagonal factor U from the U'*D*U factorization of A.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -k, the k-th argument had an illegal value
+* > 0: if INFO = k, the leading minor of order k is not
+* positive definite; if k < N, the factorization could not
+* be completed, while if k = N, the factorization was
+* completed, but D(N) <= 0.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO
+ PARAMETER ( ZERO = 0.0E+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, I4
+ REAL EI
+* ..
+* .. External Subroutines ..
+ EXTERNAL XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MOD
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ IF( N.LT.0 ) THEN
+ INFO = -1
+ CALL XERBLA( 'SPTTRF', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+* Compute the L*D*L' (or U'*D*U) factorization of A.
+*
+ I4 = MOD( N-1, 4 )
+ DO 10 I = 1, I4
+ IF( D( I ).LE.ZERO ) THEN
+ INFO = I
+ GO TO 30
+ END IF
+ EI = E( I )
+ E( I ) = EI / D( I )
+ D( I+1 ) = D( I+1 ) - E( I )*EI
+ 10 CONTINUE
+*
+ DO 20 I = I4 + 1, N - 4, 4
+*
+* Drop out of the loop if d(i) <= 0: the matrix is not positive
+* definite.
+*
+ IF( D( I ).LE.ZERO ) THEN
+ INFO = I
+ GO TO 30
+ END IF
+*
+* Solve for e(i) and d(i+1).
+*
+ EI = E( I )
+ E( I ) = EI / D( I )
+ D( I+1 ) = D( I+1 ) - E( I )*EI
+*
+ IF( D( I+1 ).LE.ZERO ) THEN
+ INFO = I + 1
+ GO TO 30
+ END IF
+*
+* Solve for e(i+1) and d(i+2).
+*
+ EI = E( I+1 )
+ E( I+1 ) = EI / D( I+1 )
+ D( I+2 ) = D( I+2 ) - E( I+1 )*EI
+*
+ IF( D( I+2 ).LE.ZERO ) THEN
+ INFO = I + 2
+ GO TO 30
+ END IF
+*
+* Solve for e(i+2) and d(i+3).
+*
+ EI = E( I+2 )
+ E( I+2 ) = EI / D( I+2 )
+ D( I+3 ) = D( I+3 ) - E( I+2 )*EI
+*
+ IF( D( I+3 ).LE.ZERO ) THEN
+ INFO = I + 3
+ GO TO 30
+ END IF
+*
+* Solve for e(i+3) and d(i+4).
+*
+ EI = E( I+3 )
+ E( I+3 ) = EI / D( I+3 )
+ D( I+4 ) = D( I+4 ) - E( I+3 )*EI
+ 20 CONTINUE
+*
+* Check d(n) for positive definiteness.
+*
+ IF( D( N ).LE.ZERO )
+ $ INFO = N
+*
+ 30 CONTINUE
+ RETURN
+*
+* End of SPTTRF
+*
+ END
+ SUBROUTINE SPTTRS( N, NRHS, D, E, B, LDB, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LDB, N, NRHS
+* ..
+* .. Array Arguments ..
+ REAL B( LDB, * ), D( * ), E( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SPTTRS solves a tridiagonal system of the form
+* A * X = B
+* using the L*D*L' factorization of A computed by SPTTRF. D is a
+* diagonal matrix specified in the vector D, L is a unit bidiagonal
+* matrix whose subdiagonal is specified in the vector E, and X and B
+* are N by NRHS matrices.
+*
+* Arguments
+* =========
+*
+* N (input) INTEGER
+* The order of the tridiagonal matrix A. N >= 0.
+*
+* NRHS (input) INTEGER
+* The number of right hand sides, i.e., the number of columns
+* of the matrix B. NRHS >= 0.
+*
+* D (input) REAL array, dimension (N)
+* The n diagonal elements of the diagonal matrix D from the
+* L*D*L' factorization of A.
+*
+* E (input) REAL array, dimension (N-1)
+* The (n-1) subdiagonal elements of the unit bidiagonal factor
+* L from the L*D*L' factorization of A. E can also be regarded
+* as the superdiagonal of the unit bidiagonal factor U from the
+* factorization A = U'*D*U.
+*
+* B (input/output) REAL array, dimension (LDB,NRHS)
+* On entry, the right hand side vectors B for the system of
+* linear equations.
+* On exit, the solution vectors, X.
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. LDB >= max(1,N).
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -k, the k-th argument had an illegal value
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ INTEGER J, JB, NB
+* ..
+* .. External Functions ..
+ INTEGER ILAENV
+ EXTERNAL ILAENV
+* ..
+* .. External Subroutines ..
+ EXTERNAL SPTTS2, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+* Test the input arguments.
+*
+ INFO = 0
+ IF( N.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( NRHS.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -6
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SPTTRS', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 .OR. NRHS.EQ.0 )
+ $ RETURN
+*
+* Determine the number of right-hand sides to solve at a time.
+*
+ IF( NRHS.EQ.1 ) THEN
+ NB = 1
+ ELSE
+ NB = MAX( 1, ILAENV( 1, 'SPTTRS', ' ', N, NRHS, -1, -1 ) )
+ END IF
+*
+ IF( NB.GE.NRHS ) THEN
+ CALL SPTTS2( N, NRHS, D, E, B, LDB )
+ ELSE
+ DO 10 J = 1, NRHS, NB
+ JB = MIN( NRHS-J+1, NB )
+ CALL SPTTS2( N, JB, D, E, B( 1, J ), LDB )
+ 10 CONTINUE
+ END IF
+*
+ RETURN
+*
+* End of SPTTRS
+*
+ END
+ SUBROUTINE SPTTS2( N, NRHS, D, E, B, LDB )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER LDB, N, NRHS
+* ..
+* .. Array Arguments ..
+ REAL B( LDB, * ), D( * ), E( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SPTTS2 solves a tridiagonal system of the form
+* A * X = B
+* using the L*D*L' factorization of A computed by SPTTRF. D is a
+* diagonal matrix specified in the vector D, L is a unit bidiagonal
+* matrix whose subdiagonal is specified in the vector E, and X and B
+* are N by NRHS matrices.
+*
+* Arguments
+* =========
+*
+* N (input) INTEGER
+* The order of the tridiagonal matrix A. N >= 0.
+*
+* NRHS (input) INTEGER
+* The number of right hand sides, i.e., the number of columns
+* of the matrix B. NRHS >= 0.
+*
+* D (input) REAL array, dimension (N)
+* The n diagonal elements of the diagonal matrix D from the
+* L*D*L' factorization of A.
+*
+* E (input) REAL array, dimension (N-1)
+* The (n-1) subdiagonal elements of the unit bidiagonal factor
+* L from the L*D*L' factorization of A. E can also be regarded
+* as the superdiagonal of the unit bidiagonal factor U from the
+* factorization A = U'*D*U.
+*
+* B (input/output) REAL array, dimension (LDB,NRHS)
+* On entry, the right hand side vectors B for the system of
+* linear equations.
+* On exit, the solution vectors, X.
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. LDB >= max(1,N).
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ INTEGER I, J
+* ..
+* .. External Subroutines ..
+ EXTERNAL SSCAL
+* ..
+* .. Executable Statements ..
+*
+* Quick return if possible
+*
+ IF( N.LE.1 ) THEN
+ IF( N.EQ.1 )
+ $ CALL SSCAL( NRHS, 1. / D( 1 ), B, LDB )
+ RETURN
+ END IF
+*
+* Solve A * X = B using the factorization A = L*D*L',
+* overwriting each right hand side vector with its solution.
+*
+ DO 30 J = 1, NRHS
+*
+* Solve L * x = b.
+*
+ DO 10 I = 2, N
+ B( I, J ) = B( I, J ) - B( I-1, J )*E( I-1 )
+ 10 CONTINUE
+*
+* Solve D * L' * x = b.
+*
+ B( N, J ) = B( N, J ) / D( N )
+ DO 20 I = N - 1, 1, -1
+ B( I, J ) = B( I, J ) / D( I ) - B( I+1, J )*E( I )
+ 20 CONTINUE
+ 30 CONTINUE
+*
+ RETURN
+*
+* End of SPTTS2
+*
+ END
+ SUBROUTINE SRSCL( N, SA, SX, INCX )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INCX, N
+ REAL SA
+* ..
+* .. Array Arguments ..
+ REAL SX( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SRSCL multiplies an n-element real vector x by the real scalar 1/a.
+* This is done without overflow or underflow as long as
+* the final result x/a does not overflow or underflow.
+*
+* Arguments
+* =========
+*
+* N (input) INTEGER
+* The number of components of the vector x.
+*
+* SA (input) REAL
+* The scalar a which is used to divide each component of x.
+* SA must be >= 0, or the subroutine will divide by zero.
+*
+* SX (input/output) REAL array, dimension
+* (1+(N-1)*abs(INCX))
+* The n-element vector x.
+*
+* INCX (input) INTEGER
+* The increment between successive values of the vector SX.
+* > 0: SX(1) = X(1) and SX(1+(i-1)*INCX) = x(i), 1< i<= n
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ONE, ZERO
+ PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL DONE
+ REAL BIGNUM, CDEN, CDEN1, CNUM, CNUM1, MUL, SMLNUM
+* ..
+* .. External Functions ..
+ REAL SLAMCH
+ EXTERNAL SLAMCH
+* ..
+* .. External Subroutines ..
+ EXTERNAL SLABAD, SSCAL
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS
+* ..
+* .. Executable Statements ..
+*
+* Quick return if possible
+*
+ IF( N.LE.0 )
+ $ RETURN
+*
+* Get machine parameters
+*
+ SMLNUM = SLAMCH( 'S' )
+ BIGNUM = ONE / SMLNUM
+ CALL SLABAD( SMLNUM, BIGNUM )
+*
+* Initialize the denominator to SA and the numerator to 1.
+*
+ CDEN = SA
+ CNUM = ONE
+*
+ 10 CONTINUE
+ CDEN1 = CDEN*SMLNUM
+ CNUM1 = CNUM / BIGNUM
+ IF( ABS( CDEN1 ).GT.ABS( CNUM ) .AND. CNUM.NE.ZERO ) THEN
+*
+* Pre-multiply X by SMLNUM if CDEN is large compared to CNUM.
+*
+ MUL = SMLNUM
+ DONE = .FALSE.
+ CDEN = CDEN1
+ ELSE IF( ABS( CNUM1 ).GT.ABS( CDEN ) ) THEN
+*
+* Pre-multiply X by BIGNUM if CDEN is small compared to CNUM.
+*
+ MUL = BIGNUM
+ DONE = .FALSE.
+ CNUM = CNUM1
+ ELSE
+*
+* Multiply X by CNUM / CDEN and return.
+*
+ MUL = CNUM / CDEN
+ DONE = .TRUE.
+ END IF
+*
+* Scale the vector X by MUL
+*
+ CALL SSCAL( N, MUL, SX, INCX )
+*
+ IF( .NOT.DONE )
+ $ GO TO 10
+*
+ RETURN
+*
+* End of SRSCL
+*
+ END
+ SUBROUTINE SSBEV( JOBZ, UPLO, N, KD, AB, LDAB, W, Z, LDZ, WORK,
+ $ INFO )
+*
+* -- LAPACK driver routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER JOBZ, UPLO
+ INTEGER INFO, KD, LDAB, LDZ, N
+* ..
+* .. Array Arguments ..
+ REAL AB( LDAB, * ), W( * ), WORK( * ), Z( LDZ, * )
+* ..
+*
+* Purpose
+* =======
+*
+* SSBEV computes all the eigenvalues and, optionally, eigenvectors of
+* a real symmetric band matrix A.
+*
+* Arguments
+* =========
+*
+* JOBZ (input) CHARACTER*1
+* = 'N': Compute eigenvalues only;
+* = 'V': Compute eigenvalues and eigenvectors.
+*
+* UPLO (input) CHARACTER*1
+* = 'U': Upper triangle of A is stored;
+* = 'L': Lower triangle of A is stored.
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* KD (input) INTEGER
+* The number of superdiagonals of the matrix A if UPLO = 'U',
+* or the number of subdiagonals if UPLO = 'L'. KD >= 0.
+*
+* AB (input/output) REAL array, dimension (LDAB, N)
+* On entry, the upper or lower triangle of the symmetric band
+* matrix A, stored in the first KD+1 rows of the array. The
+* j-th column of A is stored in the j-th column of the array AB
+* as follows:
+* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
+* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).
+*
+* On exit, AB is overwritten by values generated during the
+* reduction to tridiagonal form. If UPLO = 'U', the first
+* superdiagonal and the diagonal of the tridiagonal matrix T
+* are returned in rows KD and KD+1 of AB, and if UPLO = 'L',
+* the diagonal and first subdiagonal of T are returned in the
+* first two rows of AB.
+*
+* LDAB (input) INTEGER
+* The leading dimension of the array AB. LDAB >= KD + 1.
+*
+* W (output) REAL array, dimension (N)
+* If INFO = 0, the eigenvalues in ascending order.
+*
+* Z (output) REAL array, dimension (LDZ, N)
+* If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal
+* eigenvectors of the matrix A, with the i-th column of Z
+* holding the eigenvector associated with W(i).
+* If JOBZ = 'N', then Z is not referenced.
+*
+* LDZ (input) INTEGER
+* The leading dimension of the array Z. LDZ >= 1, and if
+* JOBZ = 'V', LDZ >= max(1,N).
+*
+* WORK (workspace) REAL array, dimension (max(1,3*N-2))
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* > 0: if INFO = i, the algorithm failed to converge; i
+* off-diagonal elements of an intermediate tridiagonal
+* form did not converge to zero.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO, ONE
+ PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL LOWER, WANTZ
+ INTEGER IINFO, IMAX, INDE, INDWRK, ISCALE
+ REAL ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA,
+ $ SMLNUM
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ REAL SLAMCH, SLANSB
+ EXTERNAL LSAME, SLAMCH, SLANSB
+* ..
+* .. External Subroutines ..
+ EXTERNAL SLASCL, SSBTRD, SSCAL, SSTEQR, SSTERF, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC SQRT
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ WANTZ = LSAME( JOBZ, 'V' )
+ LOWER = LSAME( UPLO, 'L' )
+*
+ INFO = 0
+ IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
+ INFO = -1
+ ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN
+ INFO = -2
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( KD.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( LDAB.LT.KD+1 ) THEN
+ INFO = -6
+ ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
+ INFO = -9
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SSBEV ', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+ IF( N.EQ.1 ) THEN
+ IF( LOWER ) THEN
+ W( 1 ) = AB( 1, 1 )
+ ELSE
+ W( 1 ) = AB( KD+1, 1 )
+ END IF
+ IF( WANTZ )
+ $ Z( 1, 1 ) = ONE
+ RETURN
+ END IF
+*
+* Get machine constants.
+*
+ SAFMIN = SLAMCH( 'Safe minimum' )
+ EPS = SLAMCH( 'Precision' )
+ SMLNUM = SAFMIN / EPS
+ BIGNUM = ONE / SMLNUM
+ RMIN = SQRT( SMLNUM )
+ RMAX = SQRT( BIGNUM )
+*
+* Scale matrix to allowable range, if necessary.
+*
+ ANRM = SLANSB( 'M', UPLO, N, KD, AB, LDAB, WORK )
+ ISCALE = 0
+ IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN
+ ISCALE = 1
+ SIGMA = RMIN / ANRM
+ ELSE IF( ANRM.GT.RMAX ) THEN
+ ISCALE = 1
+ SIGMA = RMAX / ANRM
+ END IF
+ IF( ISCALE.EQ.1 ) THEN
+ IF( LOWER ) THEN
+ CALL SLASCL( 'B', KD, KD, ONE, SIGMA, N, N, AB, LDAB, INFO )
+ ELSE
+ CALL SLASCL( 'Q', KD, KD, ONE, SIGMA, N, N, AB, LDAB, INFO )
+ END IF
+ END IF
+*
+* Call SSBTRD to reduce symmetric band matrix to tridiagonal form.
+*
+ INDE = 1
+ INDWRK = INDE + N
+ CALL SSBTRD( JOBZ, UPLO, N, KD, AB, LDAB, W, WORK( INDE ), Z, LDZ,
+ $ WORK( INDWRK ), IINFO )
+*
+* For eigenvalues only, call SSTERF. For eigenvectors, call SSTEQR.
+*
+ IF( .NOT.WANTZ ) THEN
+ CALL SSTERF( N, W, WORK( INDE ), INFO )
+ ELSE
+ CALL SSTEQR( JOBZ, N, W, WORK( INDE ), Z, LDZ, WORK( INDWRK ),
+ $ INFO )
+ END IF
+*
+* If matrix was scaled, then rescale eigenvalues appropriately.
+*
+ IF( ISCALE.EQ.1 ) THEN
+ IF( INFO.EQ.0 ) THEN
+ IMAX = N
+ ELSE
+ IMAX = INFO - 1
+ END IF
+ CALL SSCAL( IMAX, ONE / SIGMA, W, 1 )
+ END IF
+*
+ RETURN
+*
+* End of SSBEV
+*
+ END
+ SUBROUTINE SSBEVD( JOBZ, UPLO, N, KD, AB, LDAB, W, Z, LDZ, WORK,
+ $ LWORK, IWORK, LIWORK, INFO )
+*
+* -- LAPACK driver routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER JOBZ, UPLO
+ INTEGER INFO, KD, LDAB, LDZ, LIWORK, LWORK, N
+* ..
+* .. Array Arguments ..
+ INTEGER IWORK( * )
+ REAL AB( LDAB, * ), W( * ), WORK( * ), Z( LDZ, * )
+* ..
+*
+* Purpose
+* =======
+*
+* SSBEVD computes all the eigenvalues and, optionally, eigenvectors of
+* a real symmetric band matrix A. If eigenvectors are desired, it uses
+* a divide and conquer algorithm.
+*
+* The divide and conquer algorithm makes very mild assumptions about
+* floating point arithmetic. It will work on machines with a guard
+* digit in add/subtract, or on those binary machines without guard
+* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
+* Cray-2. It could conceivably fail on hexadecimal or decimal machines
+* without guard digits, but we know of none.
+*
+* Arguments
+* =========
+*
+* JOBZ (input) CHARACTER*1
+* = 'N': Compute eigenvalues only;
+* = 'V': Compute eigenvalues and eigenvectors.
+*
+* UPLO (input) CHARACTER*1
+* = 'U': Upper triangle of A is stored;
+* = 'L': Lower triangle of A is stored.
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* KD (input) INTEGER
+* The number of superdiagonals of the matrix A if UPLO = 'U',
+* or the number of subdiagonals if UPLO = 'L'. KD >= 0.
+*
+* AB (input/output) REAL array, dimension (LDAB, N)
+* On entry, the upper or lower triangle of the symmetric band
+* matrix A, stored in the first KD+1 rows of the array. The
+* j-th column of A is stored in the j-th column of the array AB
+* as follows:
+* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
+* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).
+*
+* On exit, AB is overwritten by values generated during the
+* reduction to tridiagonal form. If UPLO = 'U', the first
+* superdiagonal and the diagonal of the tridiagonal matrix T
+* are returned in rows KD and KD+1 of AB, and if UPLO = 'L',
+* the diagonal and first subdiagonal of T are returned in the
+* first two rows of AB.
+*
+* LDAB (input) INTEGER
+* The leading dimension of the array AB. LDAB >= KD + 1.
+*
+* W (output) REAL array, dimension (N)
+* If INFO = 0, the eigenvalues in ascending order.
+*
+* Z (output) REAL array, dimension (LDZ, N)
+* If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal
+* eigenvectors of the matrix A, with the i-th column of Z
+* holding the eigenvector associated with W(i).
+* If JOBZ = 'N', then Z is not referenced.
+*
+* LDZ (input) INTEGER
+* The leading dimension of the array Z. LDZ >= 1, and if
+* JOBZ = 'V', LDZ >= max(1,N).
+*
+* WORK (workspace/output) REAL array,
+* dimension (LWORK)
+* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+* LWORK (input) INTEGER
+* The dimension of the array WORK.
+* IF N <= 1, LWORK must be at least 1.
+* If JOBZ = 'N' and N > 2, LWORK must be at least 2*N.
+* If JOBZ = 'V' and N > 2, LWORK must be at least
+* ( 1 + 5*N + 2*N**2 ).
+*
+* If LWORK = -1, then a workspace query is assumed; the routine
+* only calculates the optimal sizes of the WORK and IWORK
+* arrays, returns these values as the first entries of the WORK
+* and IWORK arrays, and no error message related to LWORK or
+* LIWORK is issued by XERBLA.
+*
+* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))
+* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
+*
+* LIWORK (input) INTEGER
+* The dimension of the array LIWORK.
+* If JOBZ = 'N' or N <= 1, LIWORK must be at least 1.
+* If JOBZ = 'V' and N > 2, LIWORK must be at least 3 + 5*N.
+*
+* If LIWORK = -1, then a workspace query is assumed; the
+* routine only calculates the optimal sizes of the WORK and
+* IWORK arrays, returns these values as the first entries of
+* the WORK and IWORK arrays, and no error message related to
+* LWORK or LIWORK is issued by XERBLA.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* > 0: if INFO = i, the algorithm failed to converge; i
+* off-diagonal elements of an intermediate tridiagonal
+* form did not converge to zero.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO, ONE
+ PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL LOWER, LQUERY, WANTZ
+ INTEGER IINFO, INDE, INDWK2, INDWRK, ISCALE, LIWMIN,
+ $ LLWRK2, LWMIN
+ REAL ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA,
+ $ SMLNUM
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ REAL SLAMCH, SLANSB
+ EXTERNAL LSAME, SLAMCH, SLANSB
+* ..
+* .. External Subroutines ..
+ EXTERNAL SGEMM, SLACPY, SLASCL, SSBTRD, SSCAL, SSTEDC,
+ $ SSTERF, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC SQRT
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ WANTZ = LSAME( JOBZ, 'V' )
+ LOWER = LSAME( UPLO, 'L' )
+ LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 )
+*
+ INFO = 0
+ IF( N.LE.1 ) THEN
+ LIWMIN = 1
+ LWMIN = 1
+ ELSE
+ IF( WANTZ ) THEN
+ LIWMIN = 3 + 5*N
+ LWMIN = 1 + 5*N + 2*N**2
+ ELSE
+ LIWMIN = 1
+ LWMIN = 2*N
+ END IF
+ END IF
+ IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
+ INFO = -1
+ ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN
+ INFO = -2
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( KD.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( LDAB.LT.KD+1 ) THEN
+ INFO = -6
+ ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
+ INFO = -9
+ END IF
+*
+ IF( INFO.EQ.0 ) THEN
+ WORK( 1 ) = LWMIN
+ IWORK( 1 ) = LIWMIN
+*
+ IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
+ INFO = -11
+ ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN
+ INFO = -13
+ END IF
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SSBEVD', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+ IF( N.EQ.1 ) THEN
+ W( 1 ) = AB( 1, 1 )
+ IF( WANTZ )
+ $ Z( 1, 1 ) = ONE
+ RETURN
+ END IF
+*
+* Get machine constants.
+*
+ SAFMIN = SLAMCH( 'Safe minimum' )
+ EPS = SLAMCH( 'Precision' )
+ SMLNUM = SAFMIN / EPS
+ BIGNUM = ONE / SMLNUM
+ RMIN = SQRT( SMLNUM )
+ RMAX = SQRT( BIGNUM )
+*
+* Scale matrix to allowable range, if necessary.
+*
+ ANRM = SLANSB( 'M', UPLO, N, KD, AB, LDAB, WORK )
+ ISCALE = 0
+ IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN
+ ISCALE = 1
+ SIGMA = RMIN / ANRM
+ ELSE IF( ANRM.GT.RMAX ) THEN
+ ISCALE = 1
+ SIGMA = RMAX / ANRM
+ END IF
+ IF( ISCALE.EQ.1 ) THEN
+ IF( LOWER ) THEN
+ CALL SLASCL( 'B', KD, KD, ONE, SIGMA, N, N, AB, LDAB, INFO )
+ ELSE
+ CALL SLASCL( 'Q', KD, KD, ONE, SIGMA, N, N, AB, LDAB, INFO )
+ END IF
+ END IF
+*
+* Call SSBTRD to reduce symmetric band matrix to tridiagonal form.
+*
+ INDE = 1
+ INDWRK = INDE + N
+ INDWK2 = INDWRK + N*N
+ LLWRK2 = LWORK - INDWK2 + 1
+ CALL SSBTRD( JOBZ, UPLO, N, KD, AB, LDAB, W, WORK( INDE ), Z, LDZ,
+ $ WORK( INDWRK ), IINFO )
+*
+* For eigenvalues only, call SSTERF. For eigenvectors, call SSTEDC.
+*
+ IF( .NOT.WANTZ ) THEN
+ CALL SSTERF( N, W, WORK( INDE ), INFO )
+ ELSE
+ CALL SSTEDC( 'I', N, W, WORK( INDE ), WORK( INDWRK ), N,
+ $ WORK( INDWK2 ), LLWRK2, IWORK, LIWORK, INFO )
+ CALL SGEMM( 'N', 'N', N, N, N, ONE, Z, LDZ, WORK( INDWRK ), N,
+ $ ZERO, WORK( INDWK2 ), N )
+ CALL SLACPY( 'A', N, N, WORK( INDWK2 ), N, Z, LDZ )
+ END IF
+*
+* If matrix was scaled, then rescale eigenvalues appropriately.
+*
+ IF( ISCALE.EQ.1 )
+ $ CALL SSCAL( N, ONE / SIGMA, W, 1 )
+*
+ WORK( 1 ) = LWMIN
+ IWORK( 1 ) = LIWMIN
+ RETURN
+*
+* End of SSBEVD
+*
+ END
+ SUBROUTINE SSBEVX( JOBZ, RANGE, UPLO, N, KD, AB, LDAB, Q, LDQ, VL,
+ $ VU, IL, IU, ABSTOL, M, W, Z, LDZ, WORK, IWORK,
+ $ IFAIL, INFO )
+*
+* -- LAPACK driver routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER JOBZ, RANGE, UPLO
+ INTEGER IL, INFO, IU, KD, LDAB, LDQ, LDZ, M, N
+ REAL ABSTOL, VL, VU
+* ..
+* .. Array Arguments ..
+ INTEGER IFAIL( * ), IWORK( * )
+ REAL AB( LDAB, * ), Q( LDQ, * ), W( * ), WORK( * ),
+ $ Z( LDZ, * )
+* ..
+*
+* Purpose
+* =======
+*
+* SSBEVX computes selected eigenvalues and, optionally, eigenvectors
+* of a real symmetric band matrix A. Eigenvalues and eigenvectors can
+* be selected by specifying either a range of values or a range of
+* indices for the desired eigenvalues.
+*
+* Arguments
+* =========
+*
+* JOBZ (input) CHARACTER*1
+* = 'N': Compute eigenvalues only;
+* = 'V': Compute eigenvalues and eigenvectors.
+*
+* RANGE (input) CHARACTER*1
+* = 'A': all eigenvalues will be found;
+* = 'V': all eigenvalues in the half-open interval (VL,VU]
+* will be found;
+* = 'I': the IL-th through IU-th eigenvalues will be found.
+*
+* UPLO (input) CHARACTER*1
+* = 'U': Upper triangle of A is stored;
+* = 'L': Lower triangle of A is stored.
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* KD (input) INTEGER
+* The number of superdiagonals of the matrix A if UPLO = 'U',
+* or the number of subdiagonals if UPLO = 'L'. KD >= 0.
+*
+* AB (input/output) REAL array, dimension (LDAB, N)
+* On entry, the upper or lower triangle of the symmetric band
+* matrix A, stored in the first KD+1 rows of the array. The
+* j-th column of A is stored in the j-th column of the array AB
+* as follows:
+* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
+* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).
+*
+* On exit, AB is overwritten by values generated during the
+* reduction to tridiagonal form. If UPLO = 'U', the first
+* superdiagonal and the diagonal of the tridiagonal matrix T
+* are returned in rows KD and KD+1 of AB, and if UPLO = 'L',
+* the diagonal and first subdiagonal of T are returned in the
+* first two rows of AB.
+*
+* LDAB (input) INTEGER
+* The leading dimension of the array AB. LDAB >= KD + 1.
+*
+* Q (output) REAL array, dimension (LDQ, N)
+* If JOBZ = 'V', the N-by-N orthogonal matrix used in the
+* reduction to tridiagonal form.
+* If JOBZ = 'N', the array Q is not referenced.
+*
+* LDQ (input) INTEGER
+* The leading dimension of the array Q. If JOBZ = 'V', then
+* LDQ >= max(1,N).
+*
+* VL (input) REAL
+* VU (input) REAL
+* If RANGE='V', the lower and upper bounds of the interval to
+* be searched for eigenvalues. VL < VU.
+* Not referenced if RANGE = 'A' or 'I'.
+*
+* IL (input) INTEGER
+* IU (input) INTEGER
+* If RANGE='I', the indices (in ascending order) of the
+* smallest and largest eigenvalues to be returned.
+* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
+* Not referenced if RANGE = 'A' or 'V'.
+*
+* ABSTOL (input) REAL
+* The absolute error tolerance for the eigenvalues.
+* An approximate eigenvalue is accepted as converged
+* when it is determined to lie in an interval [a,b]
+* of width less than or equal to
+*
+* ABSTOL + EPS * max( |a|,|b| ) ,
+*
+* where EPS is the machine precision. If ABSTOL is less than
+* or equal to zero, then EPS*|T| will be used in its place,
+* where |T| is the 1-norm of the tridiagonal matrix obtained
+* by reducing AB to tridiagonal form.
+*
+* Eigenvalues will be computed most accurately when ABSTOL is
+* set to twice the underflow threshold 2*SLAMCH('S'), not zero.
+* If this routine returns with INFO>0, indicating that some
+* eigenvectors did not converge, try setting ABSTOL to
+* 2*SLAMCH('S').
+*
+* See "Computing Small Singular Values of Bidiagonal Matrices
+* with Guaranteed High Relative Accuracy," by Demmel and
+* Kahan, LAPACK Working Note #3.
+*
+* M (output) INTEGER
+* The total number of eigenvalues found. 0 <= M <= N.
+* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
+*
+* W (output) REAL array, dimension (N)
+* The first M elements contain the selected eigenvalues in
+* ascending order.
+*
+* Z (output) REAL array, dimension (LDZ, max(1,M))
+* If JOBZ = 'V', then if INFO = 0, the first M columns of Z
+* contain the orthonormal eigenvectors of the matrix A
+* corresponding to the selected eigenvalues, with the i-th
+* column of Z holding the eigenvector associated with W(i).
+* If an eigenvector fails to converge, then that column of Z
+* contains the latest approximation to the eigenvector, and the
+* index of the eigenvector is returned in IFAIL.
+* If JOBZ = 'N', then Z is not referenced.
+* Note: the user must ensure that at least max(1,M) columns are
+* supplied in the array Z; if RANGE = 'V', the exact value of M
+* is not known in advance and an upper bound must be used.
+*
+* LDZ (input) INTEGER
+* The leading dimension of the array Z. LDZ >= 1, and if
+* JOBZ = 'V', LDZ >= max(1,N).
+*
+* WORK (workspace) REAL array, dimension (7*N)
+*
+* IWORK (workspace) INTEGER array, dimension (5*N)
+*
+* IFAIL (output) INTEGER array, dimension (N)
+* If JOBZ = 'V', then if INFO = 0, the first M elements of
+* IFAIL are zero. If INFO > 0, then IFAIL contains the
+* indices of the eigenvectors that failed to converge.
+* If JOBZ = 'N', then IFAIL is not referenced.
+*
+* INFO (output) INTEGER
+* = 0: successful exit.
+* < 0: if INFO = -i, the i-th argument had an illegal value.
+* > 0: if INFO = i, then i eigenvectors failed to converge.
+* Their indices are stored in array IFAIL.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO, ONE
+ PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL ALLEIG, INDEIG, LOWER, TEST, VALEIG, WANTZ
+ CHARACTER ORDER
+ INTEGER I, IINFO, IMAX, INDD, INDE, INDEE, INDIBL,
+ $ INDISP, INDIWO, INDWRK, ISCALE, ITMP1, J, JJ,
+ $ NSPLIT
+ REAL ABSTLL, ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN,
+ $ SIGMA, SMLNUM, TMP1, VLL, VUU
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ REAL SLAMCH, SLANSB
+ EXTERNAL LSAME, SLAMCH, SLANSB
+* ..
+* .. External Subroutines ..
+ EXTERNAL SCOPY, SGEMV, SLACPY, SLASCL, SSBTRD, SSCAL,
+ $ SSTEBZ, SSTEIN, SSTEQR, SSTERF, SSWAP, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN, SQRT
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ WANTZ = LSAME( JOBZ, 'V' )
+ ALLEIG = LSAME( RANGE, 'A' )
+ VALEIG = LSAME( RANGE, 'V' )
+ INDEIG = LSAME( RANGE, 'I' )
+ LOWER = LSAME( UPLO, 'L' )
+*
+ INFO = 0
+ IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
+ INFO = -1
+ ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN
+ INFO = -2
+ ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN
+ INFO = -3
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( KD.LT.0 ) THEN
+ INFO = -5
+ ELSE IF( LDAB.LT.KD+1 ) THEN
+ INFO = -7
+ ELSE IF( WANTZ .AND. LDQ.LT.MAX( 1, N ) ) THEN
+ INFO = -9
+ ELSE
+ IF( VALEIG ) THEN
+ IF( N.GT.0 .AND. VU.LE.VL )
+ $ INFO = -11
+ ELSE IF( INDEIG ) THEN
+ IF( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) THEN
+ INFO = -12
+ ELSE IF( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) THEN
+ INFO = -13
+ END IF
+ END IF
+ END IF
+ IF( INFO.EQ.0 ) THEN
+ IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) )
+ $ INFO = -18
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SSBEVX', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ M = 0
+ IF( N.EQ.0 )
+ $ RETURN
+*
+ IF( N.EQ.1 ) THEN
+ M = 1
+ IF( LOWER ) THEN
+ TMP1 = AB( 1, 1 )
+ ELSE
+ TMP1 = AB( KD+1, 1 )
+ END IF
+ IF( VALEIG ) THEN
+ IF( .NOT.( VL.LT.TMP1 .AND. VU.GE.TMP1 ) )
+ $ M = 0
+ END IF
+ IF( M.EQ.1 ) THEN
+ W( 1 ) = TMP1
+ IF( WANTZ )
+ $ Z( 1, 1 ) = ONE
+ END IF
+ RETURN
+ END IF
+*
+* Get machine constants.
+*
+ SAFMIN = SLAMCH( 'Safe minimum' )
+ EPS = SLAMCH( 'Precision' )
+ SMLNUM = SAFMIN / EPS
+ BIGNUM = ONE / SMLNUM
+ RMIN = SQRT( SMLNUM )
+ RMAX = MIN( SQRT( BIGNUM ), ONE / SQRT( SQRT( SAFMIN ) ) )
+*
+* Scale matrix to allowable range, if necessary.
+*
+ ISCALE = 0
+ ABSTLL = ABSTOL
+ IF ( VALEIG ) THEN
+ VLL = VL
+ VUU = VU
+ ELSE
+ VLL = ZERO
+ VUU = ZERO
+ ENDIF
+ ANRM = SLANSB( 'M', UPLO, N, KD, AB, LDAB, WORK )
+ IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN
+ ISCALE = 1
+ SIGMA = RMIN / ANRM
+ ELSE IF( ANRM.GT.RMAX ) THEN
+ ISCALE = 1
+ SIGMA = RMAX / ANRM
+ END IF
+ IF( ISCALE.EQ.1 ) THEN
+ IF( LOWER ) THEN
+ CALL SLASCL( 'B', KD, KD, ONE, SIGMA, N, N, AB, LDAB, INFO )
+ ELSE
+ CALL SLASCL( 'Q', KD, KD, ONE, SIGMA, N, N, AB, LDAB, INFO )
+ END IF
+ IF( ABSTOL.GT.0 )
+ $ ABSTLL = ABSTOL*SIGMA
+ IF( VALEIG ) THEN
+ VLL = VL*SIGMA
+ VUU = VU*SIGMA
+ END IF
+ END IF
+*
+* Call SSBTRD to reduce symmetric band matrix to tridiagonal form.
+*
+ INDD = 1
+ INDE = INDD + N
+ INDWRK = INDE + N
+ CALL SSBTRD( JOBZ, UPLO, N, KD, AB, LDAB, WORK( INDD ),
+ $ WORK( INDE ), Q, LDQ, WORK( INDWRK ), IINFO )
+*
+* If all eigenvalues are desired and ABSTOL is less than or equal
+* to zero, then call SSTERF or SSTEQR. If this fails for some
+* eigenvalue, then try SSTEBZ.
+*
+ TEST = .FALSE.
+ IF (INDEIG) THEN
+ IF (IL.EQ.1 .AND. IU.EQ.N) THEN
+ TEST = .TRUE.
+ END IF
+ END IF
+ IF ((ALLEIG .OR. TEST) .AND. (ABSTOL.LE.ZERO)) THEN
+ CALL SCOPY( N, WORK( INDD ), 1, W, 1 )
+ INDEE = INDWRK + 2*N
+ IF( .NOT.WANTZ ) THEN
+ CALL SCOPY( N-1, WORK( INDE ), 1, WORK( INDEE ), 1 )
+ CALL SSTERF( N, W, WORK( INDEE ), INFO )
+ ELSE
+ CALL SLACPY( 'A', N, N, Q, LDQ, Z, LDZ )
+ CALL SCOPY( N-1, WORK( INDE ), 1, WORK( INDEE ), 1 )
+ CALL SSTEQR( JOBZ, N, W, WORK( INDEE ), Z, LDZ,
+ $ WORK( INDWRK ), INFO )
+ IF( INFO.EQ.0 ) THEN
+ DO 10 I = 1, N
+ IFAIL( I ) = 0
+ 10 CONTINUE
+ END IF
+ END IF
+ IF( INFO.EQ.0 ) THEN
+ M = N
+ GO TO 30
+ END IF
+ INFO = 0
+ END IF
+*
+* Otherwise, call SSTEBZ and, if eigenvectors are desired, SSTEIN.
+*
+ IF( WANTZ ) THEN
+ ORDER = 'B'
+ ELSE
+ ORDER = 'E'
+ END IF
+ INDIBL = 1
+ INDISP = INDIBL + N
+ INDIWO = INDISP + N
+ CALL SSTEBZ( RANGE, ORDER, N, VLL, VUU, IL, IU, ABSTLL,
+ $ WORK( INDD ), WORK( INDE ), M, NSPLIT, W,
+ $ IWORK( INDIBL ), IWORK( INDISP ), WORK( INDWRK ),
+ $ IWORK( INDIWO ), INFO )
+*
+ IF( WANTZ ) THEN
+ CALL SSTEIN( N, WORK( INDD ), WORK( INDE ), M, W,
+ $ IWORK( INDIBL ), IWORK( INDISP ), Z, LDZ,
+ $ WORK( INDWRK ), IWORK( INDIWO ), IFAIL, INFO )
+*
+* Apply orthogonal matrix used in reduction to tridiagonal
+* form to eigenvectors returned by SSTEIN.
+*
+ DO 20 J = 1, M
+ CALL SCOPY( N, Z( 1, J ), 1, WORK( 1 ), 1 )
+ CALL SGEMV( 'N', N, N, ONE, Q, LDQ, WORK, 1, ZERO,
+ $ Z( 1, J ), 1 )
+ 20 CONTINUE
+ END IF
+*
+* If matrix was scaled, then rescale eigenvalues appropriately.
+*
+ 30 CONTINUE
+ IF( ISCALE.EQ.1 ) THEN
+ IF( INFO.EQ.0 ) THEN
+ IMAX = M
+ ELSE
+ IMAX = INFO - 1
+ END IF
+ CALL SSCAL( IMAX, ONE / SIGMA, W, 1 )
+ END IF
+*
+* If eigenvalues are not in order, then sort them, along with
+* eigenvectors.
+*
+ IF( WANTZ ) THEN
+ DO 50 J = 1, M - 1
+ I = 0
+ TMP1 = W( J )
+ DO 40 JJ = J + 1, M
+ IF( W( JJ ).LT.TMP1 ) THEN
+ I = JJ
+ TMP1 = W( JJ )
+ END IF
+ 40 CONTINUE
+*
+ IF( I.NE.0 ) THEN
+ ITMP1 = IWORK( INDIBL+I-1 )
+ W( I ) = W( J )
+ IWORK( INDIBL+I-1 ) = IWORK( INDIBL+J-1 )
+ W( J ) = TMP1
+ IWORK( INDIBL+J-1 ) = ITMP1
+ CALL SSWAP( N, Z( 1, I ), 1, Z( 1, J ), 1 )
+ IF( INFO.NE.0 ) THEN
+ ITMP1 = IFAIL( I )
+ IFAIL( I ) = IFAIL( J )
+ IFAIL( J ) = ITMP1
+ END IF
+ END IF
+ 50 CONTINUE
+ END IF
+*
+ RETURN
+*
+* End of SSBEVX
+*
+ END
+ SUBROUTINE SSBGST( VECT, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, X,
+ $ LDX, WORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO, VECT
+ INTEGER INFO, KA, KB, LDAB, LDBB, LDX, N
+* ..
+* .. Array Arguments ..
+ REAL AB( LDAB, * ), BB( LDBB, * ), WORK( * ),
+ $ X( LDX, * )
+* ..
+*
+* Purpose
+* =======
+*
+* SSBGST reduces a real symmetric-definite banded generalized
+* eigenproblem A*x = lambda*B*x to standard form C*y = lambda*y,
+* such that C has the same bandwidth as A.
+*
+* B must have been previously factorized as S**T*S by SPBSTF, using a
+* split Cholesky factorization. A is overwritten by C = X**T*A*X, where
+* X = S**(-1)*Q and Q is an orthogonal matrix chosen to preserve the
+* bandwidth of A.
+*
+* Arguments
+* =========
+*
+* VECT (input) CHARACTER*1
+* = 'N': do not form the transformation matrix X;
+* = 'V': form X.
+*
+* UPLO (input) CHARACTER*1
+* = 'U': Upper triangle of A is stored;
+* = 'L': Lower triangle of A is stored.
+*
+* N (input) INTEGER
+* The order of the matrices A and B. N >= 0.
+*
+* KA (input) INTEGER
+* The number of superdiagonals of the matrix A if UPLO = 'U',
+* or the number of subdiagonals if UPLO = 'L'. KA >= 0.
+*
+* KB (input) INTEGER
+* The number of superdiagonals of the matrix B if UPLO = 'U',
+* or the number of subdiagonals if UPLO = 'L'. KA >= KB >= 0.
+*
+* AB (input/output) REAL array, dimension (LDAB,N)
+* On entry, the upper or lower triangle of the symmetric band
+* matrix A, stored in the first ka+1 rows of the array. The
+* j-th column of A is stored in the j-th column of the array AB
+* as follows:
+* if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j;
+* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+ka).
+*
+* On exit, the transformed matrix X**T*A*X, stored in the same
+* format as A.
+*
+* LDAB (input) INTEGER
+* The leading dimension of the array AB. LDAB >= KA+1.
+*
+* BB (input) REAL array, dimension (LDBB,N)
+* The banded factor S from the split Cholesky factorization of
+* B, as returned by SPBSTF, stored in the first KB+1 rows of
+* the array.
+*
+* LDBB (input) INTEGER
+* The leading dimension of the array BB. LDBB >= KB+1.
+*
+* X (output) REAL array, dimension (LDX,N)
+* If VECT = 'V', the n-by-n matrix X.
+* If VECT = 'N', the array X is not referenced.
+*
+* LDX (input) INTEGER
+* The leading dimension of the array X.
+* LDX >= max(1,N) if VECT = 'V'; LDX >= 1 otherwise.
+*
+* WORK (workspace) REAL array, dimension (2*N)
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO, ONE
+ PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL UPDATE, UPPER, WANTX
+ INTEGER I, I0, I1, I2, INCA, J, J1, J1T, J2, J2T, K,
+ $ KA1, KB1, KBT, L, M, NR, NRT, NX
+ REAL BII, RA, RA1, T
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL SGER, SLAR2V, SLARGV, SLARTG, SLARTV, SLASET,
+ $ SROT, SSCAL, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters
+*
+ WANTX = LSAME( VECT, 'V' )
+ UPPER = LSAME( UPLO, 'U' )
+ KA1 = KA + 1
+ KB1 = KB + 1
+ INFO = 0
+ IF( .NOT.WANTX .AND. .NOT.LSAME( VECT, 'N' ) ) THEN
+ INFO = -1
+ ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -2
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( KA.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( KB.LT.0 .OR. KB.GT.KA ) THEN
+ INFO = -5
+ ELSE IF( LDAB.LT.KA+1 ) THEN
+ INFO = -7
+ ELSE IF( LDBB.LT.KB+1 ) THEN
+ INFO = -9
+ ELSE IF( LDX.LT.1 .OR. WANTX .AND. LDX.LT.MAX( 1, N ) ) THEN
+ INFO = -11
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SSBGST', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+ INCA = LDAB*KA1
+*
+* Initialize X to the unit matrix, if needed
+*
+ IF( WANTX )
+ $ CALL SLASET( 'Full', N, N, ZERO, ONE, X, LDX )
+*
+* Set M to the splitting point m. It must be the same value as is
+* used in SPBSTF. The chosen value allows the arrays WORK and RWORK
+* to be of dimension (N).
+*
+ M = ( N+KB ) / 2
+*
+* The routine works in two phases, corresponding to the two halves
+* of the split Cholesky factorization of B as S**T*S where
+*
+* S = ( U )
+* ( M L )
+*
+* with U upper triangular of order m, and L lower triangular of
+* order n-m. S has the same bandwidth as B.
+*
+* S is treated as a product of elementary matrices:
+*
+* S = S(m)*S(m-1)*...*S(2)*S(1)*S(m+1)*S(m+2)*...*S(n-1)*S(n)
+*
+* where S(i) is determined by the i-th row of S.
+*
+* In phase 1, the index i takes the values n, n-1, ... , m+1;
+* in phase 2, it takes the values 1, 2, ... , m.
+*
+* For each value of i, the current matrix A is updated by forming
+* inv(S(i))**T*A*inv(S(i)). This creates a triangular bulge outside
+* the band of A. The bulge is then pushed down toward the bottom of
+* A in phase 1, and up toward the top of A in phase 2, by applying
+* plane rotations.
+*
+* There are kb*(kb+1)/2 elements in the bulge, but at most 2*kb-1
+* of them are linearly independent, so annihilating a bulge requires
+* only 2*kb-1 plane rotations. The rotations are divided into a 1st
+* set of kb-1 rotations, and a 2nd set of kb rotations.
+*
+* Wherever possible, rotations are generated and applied in vector
+* operations of length NR between the indices J1 and J2 (sometimes
+* replaced by modified values NRT, J1T or J2T).
+*
+* The cosines and sines of the rotations are stored in the array
+* WORK. The cosines of the 1st set of rotations are stored in
+* elements n+2:n+m-kb-1 and the sines of the 1st set in elements
+* 2:m-kb-1; the cosines of the 2nd set are stored in elements
+* n+m-kb+1:2*n and the sines of the second set in elements m-kb+1:n.
+*
+* The bulges are not formed explicitly; nonzero elements outside the
+* band are created only when they are required for generating new
+* rotations; they are stored in the array WORK, in positions where
+* they are later overwritten by the sines of the rotations which
+* annihilate them.
+*
+* **************************** Phase 1 *****************************
+*
+* The logical structure of this phase is:
+*
+* UPDATE = .TRUE.
+* DO I = N, M + 1, -1
+* use S(i) to update A and create a new bulge
+* apply rotations to push all bulges KA positions downward
+* END DO
+* UPDATE = .FALSE.
+* DO I = M + KA + 1, N - 1
+* apply rotations to push all bulges KA positions downward
+* END DO
+*
+* To avoid duplicating code, the two loops are merged.
+*
+ UPDATE = .TRUE.
+ I = N + 1
+ 10 CONTINUE
+ IF( UPDATE ) THEN
+ I = I - 1
+ KBT = MIN( KB, I-1 )
+ I0 = I - 1
+ I1 = MIN( N, I+KA )
+ I2 = I - KBT + KA1
+ IF( I.LT.M+1 ) THEN
+ UPDATE = .FALSE.
+ I = I + 1
+ I0 = M
+ IF( KA.EQ.0 )
+ $ GO TO 480
+ GO TO 10
+ END IF
+ ELSE
+ I = I + KA
+ IF( I.GT.N-1 )
+ $ GO TO 480
+ END IF
+*
+ IF( UPPER ) THEN
+*
+* Transform A, working with the upper triangle
+*
+ IF( UPDATE ) THEN
+*
+* Form inv(S(i))**T * A * inv(S(i))
+*
+ BII = BB( KB1, I )
+ DO 20 J = I, I1
+ AB( I-J+KA1, J ) = AB( I-J+KA1, J ) / BII
+ 20 CONTINUE
+ DO 30 J = MAX( 1, I-KA ), I
+ AB( J-I+KA1, I ) = AB( J-I+KA1, I ) / BII
+ 30 CONTINUE
+ DO 60 K = I - KBT, I - 1
+ DO 40 J = I - KBT, K
+ AB( J-K+KA1, K ) = AB( J-K+KA1, K ) -
+ $ BB( J-I+KB1, I )*AB( K-I+KA1, I ) -
+ $ BB( K-I+KB1, I )*AB( J-I+KA1, I ) +
+ $ AB( KA1, I )*BB( J-I+KB1, I )*
+ $ BB( K-I+KB1, I )
+ 40 CONTINUE
+ DO 50 J = MAX( 1, I-KA ), I - KBT - 1
+ AB( J-K+KA1, K ) = AB( J-K+KA1, K ) -
+ $ BB( K-I+KB1, I )*AB( J-I+KA1, I )
+ 50 CONTINUE
+ 60 CONTINUE
+ DO 80 J = I, I1
+ DO 70 K = MAX( J-KA, I-KBT ), I - 1
+ AB( K-J+KA1, J ) = AB( K-J+KA1, J ) -
+ $ BB( K-I+KB1, I )*AB( I-J+KA1, J )
+ 70 CONTINUE
+ 80 CONTINUE
+*
+ IF( WANTX ) THEN
+*
+* post-multiply X by inv(S(i))
+*
+ CALL SSCAL( N-M, ONE / BII, X( M+1, I ), 1 )
+ IF( KBT.GT.0 )
+ $ CALL SGER( N-M, KBT, -ONE, X( M+1, I ), 1,
+ $ BB( KB1-KBT, I ), 1, X( M+1, I-KBT ), LDX )
+ END IF
+*
+* store a(i,i1) in RA1 for use in next loop over K
+*
+ RA1 = AB( I-I1+KA1, I1 )
+ END IF
+*
+* Generate and apply vectors of rotations to chase all the
+* existing bulges KA positions down toward the bottom of the
+* band
+*
+ DO 130 K = 1, KB - 1
+ IF( UPDATE ) THEN
+*
+* Determine the rotations which would annihilate the bulge
+* which has in theory just been created
+*
+ IF( I-K+KA.LT.N .AND. I-K.GT.1 ) THEN
+*
+* generate rotation to annihilate a(i,i-k+ka+1)
+*
+ CALL SLARTG( AB( K+1, I-K+KA ), RA1,
+ $ WORK( N+I-K+KA-M ), WORK( I-K+KA-M ),
+ $ RA )
+*
+* create nonzero element a(i-k,i-k+ka+1) outside the
+* band and store it in WORK(i-k)
+*
+ T = -BB( KB1-K, I )*RA1
+ WORK( I-K ) = WORK( N+I-K+KA-M )*T -
+ $ WORK( I-K+KA-M )*AB( 1, I-K+KA )
+ AB( 1, I-K+KA ) = WORK( I-K+KA-M )*T +
+ $ WORK( N+I-K+KA-M )*AB( 1, I-K+KA )
+ RA1 = RA
+ END IF
+ END IF
+ J2 = I - K - 1 + MAX( 1, K-I0+2 )*KA1
+ NR = ( N-J2+KA ) / KA1
+ J1 = J2 + ( NR-1 )*KA1
+ IF( UPDATE ) THEN
+ J2T = MAX( J2, I+2*KA-K+1 )
+ ELSE
+ J2T = J2
+ END IF
+ NRT = ( N-J2T+KA ) / KA1
+ DO 90 J = J2T, J1, KA1
+*
+* create nonzero element a(j-ka,j+1) outside the band
+* and store it in WORK(j-m)
+*
+ WORK( J-M ) = WORK( J-M )*AB( 1, J+1 )
+ AB( 1, J+1 ) = WORK( N+J-M )*AB( 1, J+1 )
+ 90 CONTINUE
+*
+* generate rotations in 1st set to annihilate elements which
+* have been created outside the band
+*
+ IF( NRT.GT.0 )
+ $ CALL SLARGV( NRT, AB( 1, J2T ), INCA, WORK( J2T-M ), KA1,
+ $ WORK( N+J2T-M ), KA1 )
+ IF( NR.GT.0 ) THEN
+*
+* apply rotations in 1st set from the right
+*
+ DO 100 L = 1, KA - 1
+ CALL SLARTV( NR, AB( KA1-L, J2 ), INCA,
+ $ AB( KA-L, J2+1 ), INCA, WORK( N+J2-M ),
+ $ WORK( J2-M ), KA1 )
+ 100 CONTINUE
+*
+* apply rotations in 1st set from both sides to diagonal
+* blocks
+*
+ CALL SLAR2V( NR, AB( KA1, J2 ), AB( KA1, J2+1 ),
+ $ AB( KA, J2+1 ), INCA, WORK( N+J2-M ),
+ $ WORK( J2-M ), KA1 )
+*
+ END IF
+*
+* start applying rotations in 1st set from the left
+*
+ DO 110 L = KA - 1, KB - K + 1, -1
+ NRT = ( N-J2+L ) / KA1
+ IF( NRT.GT.0 )
+ $ CALL SLARTV( NRT, AB( L, J2+KA1-L ), INCA,
+ $ AB( L+1, J2+KA1-L ), INCA,
+ $ WORK( N+J2-M ), WORK( J2-M ), KA1 )
+ 110 CONTINUE
+*
+ IF( WANTX ) THEN
+*
+* post-multiply X by product of rotations in 1st set
+*
+ DO 120 J = J2, J1, KA1
+ CALL SROT( N-M, X( M+1, J ), 1, X( M+1, J+1 ), 1,
+ $ WORK( N+J-M ), WORK( J-M ) )
+ 120 CONTINUE
+ END IF
+ 130 CONTINUE
+*
+ IF( UPDATE ) THEN
+ IF( I2.LE.N .AND. KBT.GT.0 ) THEN
+*
+* create nonzero element a(i-kbt,i-kbt+ka+1) outside the
+* band and store it in WORK(i-kbt)
+*
+ WORK( I-KBT ) = -BB( KB1-KBT, I )*RA1
+ END IF
+ END IF
+*
+ DO 170 K = KB, 1, -1
+ IF( UPDATE ) THEN
+ J2 = I - K - 1 + MAX( 2, K-I0+1 )*KA1
+ ELSE
+ J2 = I - K - 1 + MAX( 1, K-I0+1 )*KA1
+ END IF
+*
+* finish applying rotations in 2nd set from the left
+*
+ DO 140 L = KB - K, 1, -1
+ NRT = ( N-J2+KA+L ) / KA1
+ IF( NRT.GT.0 )
+ $ CALL SLARTV( NRT, AB( L, J2-L+1 ), INCA,
+ $ AB( L+1, J2-L+1 ), INCA, WORK( N+J2-KA ),
+ $ WORK( J2-KA ), KA1 )
+ 140 CONTINUE
+ NR = ( N-J2+KA ) / KA1
+ J1 = J2 + ( NR-1 )*KA1
+ DO 150 J = J1, J2, -KA1
+ WORK( J ) = WORK( J-KA )
+ WORK( N+J ) = WORK( N+J-KA )
+ 150 CONTINUE
+ DO 160 J = J2, J1, KA1
+*
+* create nonzero element a(j-ka,j+1) outside the band
+* and store it in WORK(j)
+*
+ WORK( J ) = WORK( J )*AB( 1, J+1 )
+ AB( 1, J+1 ) = WORK( N+J )*AB( 1, J+1 )
+ 160 CONTINUE
+ IF( UPDATE ) THEN
+ IF( I-K.LT.N-KA .AND. K.LE.KBT )
+ $ WORK( I-K+KA ) = WORK( I-K )
+ END IF
+ 170 CONTINUE
+*
+ DO 210 K = KB, 1, -1
+ J2 = I - K - 1 + MAX( 1, K-I0+1 )*KA1
+ NR = ( N-J2+KA ) / KA1
+ J1 = J2 + ( NR-1 )*KA1
+ IF( NR.GT.0 ) THEN
+*
+* generate rotations in 2nd set to annihilate elements
+* which have been created outside the band
+*
+ CALL SLARGV( NR, AB( 1, J2 ), INCA, WORK( J2 ), KA1,
+ $ WORK( N+J2 ), KA1 )
+*
+* apply rotations in 2nd set from the right
+*
+ DO 180 L = 1, KA - 1
+ CALL SLARTV( NR, AB( KA1-L, J2 ), INCA,
+ $ AB( KA-L, J2+1 ), INCA, WORK( N+J2 ),
+ $ WORK( J2 ), KA1 )
+ 180 CONTINUE
+*
+* apply rotations in 2nd set from both sides to diagonal
+* blocks
+*
+ CALL SLAR2V( NR, AB( KA1, J2 ), AB( KA1, J2+1 ),
+ $ AB( KA, J2+1 ), INCA, WORK( N+J2 ),
+ $ WORK( J2 ), KA1 )
+*
+ END IF
+*
+* start applying rotations in 2nd set from the left
+*
+ DO 190 L = KA - 1, KB - K + 1, -1
+ NRT = ( N-J2+L ) / KA1
+ IF( NRT.GT.0 )
+ $ CALL SLARTV( NRT, AB( L, J2+KA1-L ), INCA,
+ $ AB( L+1, J2+KA1-L ), INCA, WORK( N+J2 ),
+ $ WORK( J2 ), KA1 )
+ 190 CONTINUE
+*
+ IF( WANTX ) THEN
+*
+* post-multiply X by product of rotations in 2nd set
+*
+ DO 200 J = J2, J1, KA1
+ CALL SROT( N-M, X( M+1, J ), 1, X( M+1, J+1 ), 1,
+ $ WORK( N+J ), WORK( J ) )
+ 200 CONTINUE
+ END IF
+ 210 CONTINUE
+*
+ DO 230 K = 1, KB - 1
+ J2 = I - K - 1 + MAX( 1, K-I0+2 )*KA1
+*
+* finish applying rotations in 1st set from the left
+*
+ DO 220 L = KB - K, 1, -1
+ NRT = ( N-J2+L ) / KA1
+ IF( NRT.GT.0 )
+ $ CALL SLARTV( NRT, AB( L, J2+KA1-L ), INCA,
+ $ AB( L+1, J2+KA1-L ), INCA,
+ $ WORK( N+J2-M ), WORK( J2-M ), KA1 )
+ 220 CONTINUE
+ 230 CONTINUE
+*
+ IF( KB.GT.1 ) THEN
+ DO 240 J = N - 1, I - KB + 2*KA + 1, -1
+ WORK( N+J-M ) = WORK( N+J-KA-M )
+ WORK( J-M ) = WORK( J-KA-M )
+ 240 CONTINUE
+ END IF
+*
+ ELSE
+*
+* Transform A, working with the lower triangle
+*
+ IF( UPDATE ) THEN
+*
+* Form inv(S(i))**T * A * inv(S(i))
+*
+ BII = BB( 1, I )
+ DO 250 J = I, I1
+ AB( J-I+1, I ) = AB( J-I+1, I ) / BII
+ 250 CONTINUE
+ DO 260 J = MAX( 1, I-KA ), I
+ AB( I-J+1, J ) = AB( I-J+1, J ) / BII
+ 260 CONTINUE
+ DO 290 K = I - KBT, I - 1
+ DO 270 J = I - KBT, K
+ AB( K-J+1, J ) = AB( K-J+1, J ) -
+ $ BB( I-J+1, J )*AB( I-K+1, K ) -
+ $ BB( I-K+1, K )*AB( I-J+1, J ) +
+ $ AB( 1, I )*BB( I-J+1, J )*
+ $ BB( I-K+1, K )
+ 270 CONTINUE
+ DO 280 J = MAX( 1, I-KA ), I - KBT - 1
+ AB( K-J+1, J ) = AB( K-J+1, J ) -
+ $ BB( I-K+1, K )*AB( I-J+1, J )
+ 280 CONTINUE
+ 290 CONTINUE
+ DO 310 J = I, I1
+ DO 300 K = MAX( J-KA, I-KBT ), I - 1
+ AB( J-K+1, K ) = AB( J-K+1, K ) -
+ $ BB( I-K+1, K )*AB( J-I+1, I )
+ 300 CONTINUE
+ 310 CONTINUE
+*
+ IF( WANTX ) THEN
+*
+* post-multiply X by inv(S(i))
+*
+ CALL SSCAL( N-M, ONE / BII, X( M+1, I ), 1 )
+ IF( KBT.GT.0 )
+ $ CALL SGER( N-M, KBT, -ONE, X( M+1, I ), 1,
+ $ BB( KBT+1, I-KBT ), LDBB-1,
+ $ X( M+1, I-KBT ), LDX )
+ END IF
+*
+* store a(i1,i) in RA1 for use in next loop over K
+*
+ RA1 = AB( I1-I+1, I )
+ END IF
+*
+* Generate and apply vectors of rotations to chase all the
+* existing bulges KA positions down toward the bottom of the
+* band
+*
+ DO 360 K = 1, KB - 1
+ IF( UPDATE ) THEN
+*
+* Determine the rotations which would annihilate the bulge
+* which has in theory just been created
+*
+ IF( I-K+KA.LT.N .AND. I-K.GT.1 ) THEN
+*
+* generate rotation to annihilate a(i-k+ka+1,i)
+*
+ CALL SLARTG( AB( KA1-K, I ), RA1, WORK( N+I-K+KA-M ),
+ $ WORK( I-K+KA-M ), RA )
+*
+* create nonzero element a(i-k+ka+1,i-k) outside the
+* band and store it in WORK(i-k)
+*
+ T = -BB( K+1, I-K )*RA1
+ WORK( I-K ) = WORK( N+I-K+KA-M )*T -
+ $ WORK( I-K+KA-M )*AB( KA1, I-K )
+ AB( KA1, I-K ) = WORK( I-K+KA-M )*T +
+ $ WORK( N+I-K+KA-M )*AB( KA1, I-K )
+ RA1 = RA
+ END IF
+ END IF
+ J2 = I - K - 1 + MAX( 1, K-I0+2 )*KA1
+ NR = ( N-J2+KA ) / KA1
+ J1 = J2 + ( NR-1 )*KA1
+ IF( UPDATE ) THEN
+ J2T = MAX( J2, I+2*KA-K+1 )
+ ELSE
+ J2T = J2
+ END IF
+ NRT = ( N-J2T+KA ) / KA1
+ DO 320 J = J2T, J1, KA1
+*
+* create nonzero element a(j+1,j-ka) outside the band
+* and store it in WORK(j-m)
+*
+ WORK( J-M ) = WORK( J-M )*AB( KA1, J-KA+1 )
+ AB( KA1, J-KA+1 ) = WORK( N+J-M )*AB( KA1, J-KA+1 )
+ 320 CONTINUE
+*
+* generate rotations in 1st set to annihilate elements which
+* have been created outside the band
+*
+ IF( NRT.GT.0 )
+ $ CALL SLARGV( NRT, AB( KA1, J2T-KA ), INCA, WORK( J2T-M ),
+ $ KA1, WORK( N+J2T-M ), KA1 )
+ IF( NR.GT.0 ) THEN
+*
+* apply rotations in 1st set from the left
+*
+ DO 330 L = 1, KA - 1
+ CALL SLARTV( NR, AB( L+1, J2-L ), INCA,
+ $ AB( L+2, J2-L ), INCA, WORK( N+J2-M ),
+ $ WORK( J2-M ), KA1 )
+ 330 CONTINUE
+*
+* apply rotations in 1st set from both sides to diagonal
+* blocks
+*
+ CALL SLAR2V( NR, AB( 1, J2 ), AB( 1, J2+1 ), AB( 2, J2 ),
+ $ INCA, WORK( N+J2-M ), WORK( J2-M ), KA1 )
+*
+ END IF
+*
+* start applying rotations in 1st set from the right
+*
+ DO 340 L = KA - 1, KB - K + 1, -1
+ NRT = ( N-J2+L ) / KA1
+ IF( NRT.GT.0 )
+ $ CALL SLARTV( NRT, AB( KA1-L+1, J2 ), INCA,
+ $ AB( KA1-L, J2+1 ), INCA, WORK( N+J2-M ),
+ $ WORK( J2-M ), KA1 )
+ 340 CONTINUE
+*
+ IF( WANTX ) THEN
+*
+* post-multiply X by product of rotations in 1st set
+*
+ DO 350 J = J2, J1, KA1
+ CALL SROT( N-M, X( M+1, J ), 1, X( M+1, J+1 ), 1,
+ $ WORK( N+J-M ), WORK( J-M ) )
+ 350 CONTINUE
+ END IF
+ 360 CONTINUE
+*
+ IF( UPDATE ) THEN
+ IF( I2.LE.N .AND. KBT.GT.0 ) THEN
+*
+* create nonzero element a(i-kbt+ka+1,i-kbt) outside the
+* band and store it in WORK(i-kbt)
+*
+ WORK( I-KBT ) = -BB( KBT+1, I-KBT )*RA1
+ END IF
+ END IF
+*
+ DO 400 K = KB, 1, -1
+ IF( UPDATE ) THEN
+ J2 = I - K - 1 + MAX( 2, K-I0+1 )*KA1
+ ELSE
+ J2 = I - K - 1 + MAX( 1, K-I0+1 )*KA1
+ END IF
+*
+* finish applying rotations in 2nd set from the right
+*
+ DO 370 L = KB - K, 1, -1
+ NRT = ( N-J2+KA+L ) / KA1
+ IF( NRT.GT.0 )
+ $ CALL SLARTV( NRT, AB( KA1-L+1, J2-KA ), INCA,
+ $ AB( KA1-L, J2-KA+1 ), INCA,
+ $ WORK( N+J2-KA ), WORK( J2-KA ), KA1 )
+ 370 CONTINUE
+ NR = ( N-J2+KA ) / KA1
+ J1 = J2 + ( NR-1 )*KA1
+ DO 380 J = J1, J2, -KA1
+ WORK( J ) = WORK( J-KA )
+ WORK( N+J ) = WORK( N+J-KA )
+ 380 CONTINUE
+ DO 390 J = J2, J1, KA1
+*
+* create nonzero element a(j+1,j-ka) outside the band
+* and store it in WORK(j)
+*
+ WORK( J ) = WORK( J )*AB( KA1, J-KA+1 )
+ AB( KA1, J-KA+1 ) = WORK( N+J )*AB( KA1, J-KA+1 )
+ 390 CONTINUE
+ IF( UPDATE ) THEN
+ IF( I-K.LT.N-KA .AND. K.LE.KBT )
+ $ WORK( I-K+KA ) = WORK( I-K )
+ END IF
+ 400 CONTINUE
+*
+ DO 440 K = KB, 1, -1
+ J2 = I - K - 1 + MAX( 1, K-I0+1 )*KA1
+ NR = ( N-J2+KA ) / KA1
+ J1 = J2 + ( NR-1 )*KA1
+ IF( NR.GT.0 ) THEN
+*
+* generate rotations in 2nd set to annihilate elements
+* which have been created outside the band
+*
+ CALL SLARGV( NR, AB( KA1, J2-KA ), INCA, WORK( J2 ), KA1,
+ $ WORK( N+J2 ), KA1 )
+*
+* apply rotations in 2nd set from the left
+*
+ DO 410 L = 1, KA - 1
+ CALL SLARTV( NR, AB( L+1, J2-L ), INCA,
+ $ AB( L+2, J2-L ), INCA, WORK( N+J2 ),
+ $ WORK( J2 ), KA1 )
+ 410 CONTINUE
+*
+* apply rotations in 2nd set from both sides to diagonal
+* blocks
+*
+ CALL SLAR2V( NR, AB( 1, J2 ), AB( 1, J2+1 ), AB( 2, J2 ),
+ $ INCA, WORK( N+J2 ), WORK( J2 ), KA1 )
+*
+ END IF
+*
+* start applying rotations in 2nd set from the right
+*
+ DO 420 L = KA - 1, KB - K + 1, -1
+ NRT = ( N-J2+L ) / KA1
+ IF( NRT.GT.0 )
+ $ CALL SLARTV( NRT, AB( KA1-L+1, J2 ), INCA,
+ $ AB( KA1-L, J2+1 ), INCA, WORK( N+J2 ),
+ $ WORK( J2 ), KA1 )
+ 420 CONTINUE
+*
+ IF( WANTX ) THEN
+*
+* post-multiply X by product of rotations in 2nd set
+*
+ DO 430 J = J2, J1, KA1
+ CALL SROT( N-M, X( M+1, J ), 1, X( M+1, J+1 ), 1,
+ $ WORK( N+J ), WORK( J ) )
+ 430 CONTINUE
+ END IF
+ 440 CONTINUE
+*
+ DO 460 K = 1, KB - 1
+ J2 = I - K - 1 + MAX( 1, K-I0+2 )*KA1
+*
+* finish applying rotations in 1st set from the right
+*
+ DO 450 L = KB - K, 1, -1
+ NRT = ( N-J2+L ) / KA1
+ IF( NRT.GT.0 )
+ $ CALL SLARTV( NRT, AB( KA1-L+1, J2 ), INCA,
+ $ AB( KA1-L, J2+1 ), INCA, WORK( N+J2-M ),
+ $ WORK( J2-M ), KA1 )
+ 450 CONTINUE
+ 460 CONTINUE
+*
+ IF( KB.GT.1 ) THEN
+ DO 470 J = N - 1, I - KB + 2*KA + 1, -1
+ WORK( N+J-M ) = WORK( N+J-KA-M )
+ WORK( J-M ) = WORK( J-KA-M )
+ 470 CONTINUE
+ END IF
+*
+ END IF
+*
+ GO TO 10
+*
+ 480 CONTINUE
+*
+* **************************** Phase 2 *****************************
+*
+* The logical structure of this phase is:
+*
+* UPDATE = .TRUE.
+* DO I = 1, M
+* use S(i) to update A and create a new bulge
+* apply rotations to push all bulges KA positions upward
+* END DO
+* UPDATE = .FALSE.
+* DO I = M - KA - 1, 2, -1
+* apply rotations to push all bulges KA positions upward
+* END DO
+*
+* To avoid duplicating code, the two loops are merged.
+*
+ UPDATE = .TRUE.
+ I = 0
+ 490 CONTINUE
+ IF( UPDATE ) THEN
+ I = I + 1
+ KBT = MIN( KB, M-I )
+ I0 = I + 1
+ I1 = MAX( 1, I-KA )
+ I2 = I + KBT - KA1
+ IF( I.GT.M ) THEN
+ UPDATE = .FALSE.
+ I = I - 1
+ I0 = M + 1
+ IF( KA.EQ.0 )
+ $ RETURN
+ GO TO 490
+ END IF
+ ELSE
+ I = I - KA
+ IF( I.LT.2 )
+ $ RETURN
+ END IF
+*
+ IF( I.LT.M-KBT ) THEN
+ NX = M
+ ELSE
+ NX = N
+ END IF
+*
+ IF( UPPER ) THEN
+*
+* Transform A, working with the upper triangle
+*
+ IF( UPDATE ) THEN
+*
+* Form inv(S(i))**T * A * inv(S(i))
+*
+ BII = BB( KB1, I )
+ DO 500 J = I1, I
+ AB( J-I+KA1, I ) = AB( J-I+KA1, I ) / BII
+ 500 CONTINUE
+ DO 510 J = I, MIN( N, I+KA )
+ AB( I-J+KA1, J ) = AB( I-J+KA1, J ) / BII
+ 510 CONTINUE
+ DO 540 K = I + 1, I + KBT
+ DO 520 J = K, I + KBT
+ AB( K-J+KA1, J ) = AB( K-J+KA1, J ) -
+ $ BB( I-J+KB1, J )*AB( I-K+KA1, K ) -
+ $ BB( I-K+KB1, K )*AB( I-J+KA1, J ) +
+ $ AB( KA1, I )*BB( I-J+KB1, J )*
+ $ BB( I-K+KB1, K )
+ 520 CONTINUE
+ DO 530 J = I + KBT + 1, MIN( N, I+KA )
+ AB( K-J+KA1, J ) = AB( K-J+KA1, J ) -
+ $ BB( I-K+KB1, K )*AB( I-J+KA1, J )
+ 530 CONTINUE
+ 540 CONTINUE
+ DO 560 J = I1, I
+ DO 550 K = I + 1, MIN( J+KA, I+KBT )
+ AB( J-K+KA1, K ) = AB( J-K+KA1, K ) -
+ $ BB( I-K+KB1, K )*AB( J-I+KA1, I )
+ 550 CONTINUE
+ 560 CONTINUE
+*
+ IF( WANTX ) THEN
+*
+* post-multiply X by inv(S(i))
+*
+ CALL SSCAL( NX, ONE / BII, X( 1, I ), 1 )
+ IF( KBT.GT.0 )
+ $ CALL SGER( NX, KBT, -ONE, X( 1, I ), 1, BB( KB, I+1 ),
+ $ LDBB-1, X( 1, I+1 ), LDX )
+ END IF
+*
+* store a(i1,i) in RA1 for use in next loop over K
+*
+ RA1 = AB( I1-I+KA1, I )
+ END IF
+*
+* Generate and apply vectors of rotations to chase all the
+* existing bulges KA positions up toward the top of the band
+*
+ DO 610 K = 1, KB - 1
+ IF( UPDATE ) THEN
+*
+* Determine the rotations which would annihilate the bulge
+* which has in theory just been created
+*
+ IF( I+K-KA1.GT.0 .AND. I+K.LT.M ) THEN
+*
+* generate rotation to annihilate a(i+k-ka-1,i)
+*
+ CALL SLARTG( AB( K+1, I ), RA1, WORK( N+I+K-KA ),
+ $ WORK( I+K-KA ), RA )
+*
+* create nonzero element a(i+k-ka-1,i+k) outside the
+* band and store it in WORK(m-kb+i+k)
+*
+ T = -BB( KB1-K, I+K )*RA1
+ WORK( M-KB+I+K ) = WORK( N+I+K-KA )*T -
+ $ WORK( I+K-KA )*AB( 1, I+K )
+ AB( 1, I+K ) = WORK( I+K-KA )*T +
+ $ WORK( N+I+K-KA )*AB( 1, I+K )
+ RA1 = RA
+ END IF
+ END IF
+ J2 = I + K + 1 - MAX( 1, K+I0-M+1 )*KA1
+ NR = ( J2+KA-1 ) / KA1
+ J1 = J2 - ( NR-1 )*KA1
+ IF( UPDATE ) THEN
+ J2T = MIN( J2, I-2*KA+K-1 )
+ ELSE
+ J2T = J2
+ END IF
+ NRT = ( J2T+KA-1 ) / KA1
+ DO 570 J = J1, J2T, KA1
+*
+* create nonzero element a(j-1,j+ka) outside the band
+* and store it in WORK(j)
+*
+ WORK( J ) = WORK( J )*AB( 1, J+KA-1 )
+ AB( 1, J+KA-1 ) = WORK( N+J )*AB( 1, J+KA-1 )
+ 570 CONTINUE
+*
+* generate rotations in 1st set to annihilate elements which
+* have been created outside the band
+*
+ IF( NRT.GT.0 )
+ $ CALL SLARGV( NRT, AB( 1, J1+KA ), INCA, WORK( J1 ), KA1,
+ $ WORK( N+J1 ), KA1 )
+ IF( NR.GT.0 ) THEN
+*
+* apply rotations in 1st set from the left
+*
+ DO 580 L = 1, KA - 1
+ CALL SLARTV( NR, AB( KA1-L, J1+L ), INCA,
+ $ AB( KA-L, J1+L ), INCA, WORK( N+J1 ),
+ $ WORK( J1 ), KA1 )
+ 580 CONTINUE
+*
+* apply rotations in 1st set from both sides to diagonal
+* blocks
+*
+ CALL SLAR2V( NR, AB( KA1, J1 ), AB( KA1, J1-1 ),
+ $ AB( KA, J1 ), INCA, WORK( N+J1 ),
+ $ WORK( J1 ), KA1 )
+*
+ END IF
+*
+* start applying rotations in 1st set from the right
+*
+ DO 590 L = KA - 1, KB - K + 1, -1
+ NRT = ( J2+L-1 ) / KA1
+ J1T = J2 - ( NRT-1 )*KA1
+ IF( NRT.GT.0 )
+ $ CALL SLARTV( NRT, AB( L, J1T ), INCA,
+ $ AB( L+1, J1T-1 ), INCA, WORK( N+J1T ),
+ $ WORK( J1T ), KA1 )
+ 590 CONTINUE
+*
+ IF( WANTX ) THEN
+*
+* post-multiply X by product of rotations in 1st set
+*
+ DO 600 J = J1, J2, KA1
+ CALL SROT( NX, X( 1, J ), 1, X( 1, J-1 ), 1,
+ $ WORK( N+J ), WORK( J ) )
+ 600 CONTINUE
+ END IF
+ 610 CONTINUE
+*
+ IF( UPDATE ) THEN
+ IF( I2.GT.0 .AND. KBT.GT.0 ) THEN
+*
+* create nonzero element a(i+kbt-ka-1,i+kbt) outside the
+* band and store it in WORK(m-kb+i+kbt)
+*
+ WORK( M-KB+I+KBT ) = -BB( KB1-KBT, I+KBT )*RA1
+ END IF
+ END IF
+*
+ DO 650 K = KB, 1, -1
+ IF( UPDATE ) THEN
+ J2 = I + K + 1 - MAX( 2, K+I0-M )*KA1
+ ELSE
+ J2 = I + K + 1 - MAX( 1, K+I0-M )*KA1
+ END IF
+*
+* finish applying rotations in 2nd set from the right
+*
+ DO 620 L = KB - K, 1, -1
+ NRT = ( J2+KA+L-1 ) / KA1
+ J1T = J2 - ( NRT-1 )*KA1
+ IF( NRT.GT.0 )
+ $ CALL SLARTV( NRT, AB( L, J1T+KA ), INCA,
+ $ AB( L+1, J1T+KA-1 ), INCA,
+ $ WORK( N+M-KB+J1T+KA ),
+ $ WORK( M-KB+J1T+KA ), KA1 )
+ 620 CONTINUE
+ NR = ( J2+KA-1 ) / KA1
+ J1 = J2 - ( NR-1 )*KA1
+ DO 630 J = J1, J2, KA1
+ WORK( M-KB+J ) = WORK( M-KB+J+KA )
+ WORK( N+M-KB+J ) = WORK( N+M-KB+J+KA )
+ 630 CONTINUE
+ DO 640 J = J1, J2, KA1
+*
+* create nonzero element a(j-1,j+ka) outside the band
+* and store it in WORK(m-kb+j)
+*
+ WORK( M-KB+J ) = WORK( M-KB+J )*AB( 1, J+KA-1 )
+ AB( 1, J+KA-1 ) = WORK( N+M-KB+J )*AB( 1, J+KA-1 )
+ 640 CONTINUE
+ IF( UPDATE ) THEN
+ IF( I+K.GT.KA1 .AND. K.LE.KBT )
+ $ WORK( M-KB+I+K-KA ) = WORK( M-KB+I+K )
+ END IF
+ 650 CONTINUE
+*
+ DO 690 K = KB, 1, -1
+ J2 = I + K + 1 - MAX( 1, K+I0-M )*KA1
+ NR = ( J2+KA-1 ) / KA1
+ J1 = J2 - ( NR-1 )*KA1
+ IF( NR.GT.0 ) THEN
+*
+* generate rotations in 2nd set to annihilate elements
+* which have been created outside the band
+*
+ CALL SLARGV( NR, AB( 1, J1+KA ), INCA, WORK( M-KB+J1 ),
+ $ KA1, WORK( N+M-KB+J1 ), KA1 )
+*
+* apply rotations in 2nd set from the left
+*
+ DO 660 L = 1, KA - 1
+ CALL SLARTV( NR, AB( KA1-L, J1+L ), INCA,
+ $ AB( KA-L, J1+L ), INCA,
+ $ WORK( N+M-KB+J1 ), WORK( M-KB+J1 ), KA1 )
+ 660 CONTINUE
+*
+* apply rotations in 2nd set from both sides to diagonal
+* blocks
+*
+ CALL SLAR2V( NR, AB( KA1, J1 ), AB( KA1, J1-1 ),
+ $ AB( KA, J1 ), INCA, WORK( N+M-KB+J1 ),
+ $ WORK( M-KB+J1 ), KA1 )
+*
+ END IF
+*
+* start applying rotations in 2nd set from the right
+*
+ DO 670 L = KA - 1, KB - K + 1, -1
+ NRT = ( J2+L-1 ) / KA1
+ J1T = J2 - ( NRT-1 )*KA1
+ IF( NRT.GT.0 )
+ $ CALL SLARTV( NRT, AB( L, J1T ), INCA,
+ $ AB( L+1, J1T-1 ), INCA,
+ $ WORK( N+M-KB+J1T ), WORK( M-KB+J1T ),
+ $ KA1 )
+ 670 CONTINUE
+*
+ IF( WANTX ) THEN
+*
+* post-multiply X by product of rotations in 2nd set
+*
+ DO 680 J = J1, J2, KA1
+ CALL SROT( NX, X( 1, J ), 1, X( 1, J-1 ), 1,
+ $ WORK( N+M-KB+J ), WORK( M-KB+J ) )
+ 680 CONTINUE
+ END IF
+ 690 CONTINUE
+*
+ DO 710 K = 1, KB - 1
+ J2 = I + K + 1 - MAX( 1, K+I0-M+1 )*KA1
+*
+* finish applying rotations in 1st set from the right
+*
+ DO 700 L = KB - K, 1, -1
+ NRT = ( J2+L-1 ) / KA1
+ J1T = J2 - ( NRT-1 )*KA1
+ IF( NRT.GT.0 )
+ $ CALL SLARTV( NRT, AB( L, J1T ), INCA,
+ $ AB( L+1, J1T-1 ), INCA, WORK( N+J1T ),
+ $ WORK( J1T ), KA1 )
+ 700 CONTINUE
+ 710 CONTINUE
+*
+ IF( KB.GT.1 ) THEN
+ DO 720 J = 2, MIN( I+KB, M ) - 2*KA - 1
+ WORK( N+J ) = WORK( N+J+KA )
+ WORK( J ) = WORK( J+KA )
+ 720 CONTINUE
+ END IF
+*
+ ELSE
+*
+* Transform A, working with the lower triangle
+*
+ IF( UPDATE ) THEN
+*
+* Form inv(S(i))**T * A * inv(S(i))
+*
+ BII = BB( 1, I )
+ DO 730 J = I1, I
+ AB( I-J+1, J ) = AB( I-J+1, J ) / BII
+ 730 CONTINUE
+ DO 740 J = I, MIN( N, I+KA )
+ AB( J-I+1, I ) = AB( J-I+1, I ) / BII
+ 740 CONTINUE
+ DO 770 K = I + 1, I + KBT
+ DO 750 J = K, I + KBT
+ AB( J-K+1, K ) = AB( J-K+1, K ) -
+ $ BB( J-I+1, I )*AB( K-I+1, I ) -
+ $ BB( K-I+1, I )*AB( J-I+1, I ) +
+ $ AB( 1, I )*BB( J-I+1, I )*
+ $ BB( K-I+1, I )
+ 750 CONTINUE
+ DO 760 J = I + KBT + 1, MIN( N, I+KA )
+ AB( J-K+1, K ) = AB( J-K+1, K ) -
+ $ BB( K-I+1, I )*AB( J-I+1, I )
+ 760 CONTINUE
+ 770 CONTINUE
+ DO 790 J = I1, I
+ DO 780 K = I + 1, MIN( J+KA, I+KBT )
+ AB( K-J+1, J ) = AB( K-J+1, J ) -
+ $ BB( K-I+1, I )*AB( I-J+1, J )
+ 780 CONTINUE
+ 790 CONTINUE
+*
+ IF( WANTX ) THEN
+*
+* post-multiply X by inv(S(i))
+*
+ CALL SSCAL( NX, ONE / BII, X( 1, I ), 1 )
+ IF( KBT.GT.0 )
+ $ CALL SGER( NX, KBT, -ONE, X( 1, I ), 1, BB( 2, I ), 1,
+ $ X( 1, I+1 ), LDX )
+ END IF
+*
+* store a(i,i1) in RA1 for use in next loop over K
+*
+ RA1 = AB( I-I1+1, I1 )
+ END IF
+*
+* Generate and apply vectors of rotations to chase all the
+* existing bulges KA positions up toward the top of the band
+*
+ DO 840 K = 1, KB - 1
+ IF( UPDATE ) THEN
+*
+* Determine the rotations which would annihilate the bulge
+* which has in theory just been created
+*
+ IF( I+K-KA1.GT.0 .AND. I+K.LT.M ) THEN
+*
+* generate rotation to annihilate a(i,i+k-ka-1)
+*
+ CALL SLARTG( AB( KA1-K, I+K-KA ), RA1,
+ $ WORK( N+I+K-KA ), WORK( I+K-KA ), RA )
+*
+* create nonzero element a(i+k,i+k-ka-1) outside the
+* band and store it in WORK(m-kb+i+k)
+*
+ T = -BB( K+1, I )*RA1
+ WORK( M-KB+I+K ) = WORK( N+I+K-KA )*T -
+ $ WORK( I+K-KA )*AB( KA1, I+K-KA )
+ AB( KA1, I+K-KA ) = WORK( I+K-KA )*T +
+ $ WORK( N+I+K-KA )*AB( KA1, I+K-KA )
+ RA1 = RA
+ END IF
+ END IF
+ J2 = I + K + 1 - MAX( 1, K+I0-M+1 )*KA1
+ NR = ( J2+KA-1 ) / KA1
+ J1 = J2 - ( NR-1 )*KA1
+ IF( UPDATE ) THEN
+ J2T = MIN( J2, I-2*KA+K-1 )
+ ELSE
+ J2T = J2
+ END IF
+ NRT = ( J2T+KA-1 ) / KA1
+ DO 800 J = J1, J2T, KA1
+*
+* create nonzero element a(j+ka,j-1) outside the band
+* and store it in WORK(j)
+*
+ WORK( J ) = WORK( J )*AB( KA1, J-1 )
+ AB( KA1, J-1 ) = WORK( N+J )*AB( KA1, J-1 )
+ 800 CONTINUE
+*
+* generate rotations in 1st set to annihilate elements which
+* have been created outside the band
+*
+ IF( NRT.GT.0 )
+ $ CALL SLARGV( NRT, AB( KA1, J1 ), INCA, WORK( J1 ), KA1,
+ $ WORK( N+J1 ), KA1 )
+ IF( NR.GT.0 ) THEN
+*
+* apply rotations in 1st set from the right
+*
+ DO 810 L = 1, KA - 1
+ CALL SLARTV( NR, AB( L+1, J1 ), INCA, AB( L+2, J1-1 ),
+ $ INCA, WORK( N+J1 ), WORK( J1 ), KA1 )
+ 810 CONTINUE
+*
+* apply rotations in 1st set from both sides to diagonal
+* blocks
+*
+ CALL SLAR2V( NR, AB( 1, J1 ), AB( 1, J1-1 ),
+ $ AB( 2, J1-1 ), INCA, WORK( N+J1 ),
+ $ WORK( J1 ), KA1 )
+*
+ END IF
+*
+* start applying rotations in 1st set from the left
+*
+ DO 820 L = KA - 1, KB - K + 1, -1
+ NRT = ( J2+L-1 ) / KA1
+ J1T = J2 - ( NRT-1 )*KA1
+ IF( NRT.GT.0 )
+ $ CALL SLARTV( NRT, AB( KA1-L+1, J1T-KA1+L ), INCA,
+ $ AB( KA1-L, J1T-KA1+L ), INCA,
+ $ WORK( N+J1T ), WORK( J1T ), KA1 )
+ 820 CONTINUE
+*
+ IF( WANTX ) THEN
+*
+* post-multiply X by product of rotations in 1st set
+*
+ DO 830 J = J1, J2, KA1
+ CALL SROT( NX, X( 1, J ), 1, X( 1, J-1 ), 1,
+ $ WORK( N+J ), WORK( J ) )
+ 830 CONTINUE
+ END IF
+ 840 CONTINUE
+*
+ IF( UPDATE ) THEN
+ IF( I2.GT.0 .AND. KBT.GT.0 ) THEN
+*
+* create nonzero element a(i+kbt,i+kbt-ka-1) outside the
+* band and store it in WORK(m-kb+i+kbt)
+*
+ WORK( M-KB+I+KBT ) = -BB( KBT+1, I )*RA1
+ END IF
+ END IF
+*
+ DO 880 K = KB, 1, -1
+ IF( UPDATE ) THEN
+ J2 = I + K + 1 - MAX( 2, K+I0-M )*KA1
+ ELSE
+ J2 = I + K + 1 - MAX( 1, K+I0-M )*KA1
+ END IF
+*
+* finish applying rotations in 2nd set from the left
+*
+ DO 850 L = KB - K, 1, -1
+ NRT = ( J2+KA+L-1 ) / KA1
+ J1T = J2 - ( NRT-1 )*KA1
+ IF( NRT.GT.0 )
+ $ CALL SLARTV( NRT, AB( KA1-L+1, J1T+L-1 ), INCA,
+ $ AB( KA1-L, J1T+L-1 ), INCA,
+ $ WORK( N+M-KB+J1T+KA ),
+ $ WORK( M-KB+J1T+KA ), KA1 )
+ 850 CONTINUE
+ NR = ( J2+KA-1 ) / KA1
+ J1 = J2 - ( NR-1 )*KA1
+ DO 860 J = J1, J2, KA1
+ WORK( M-KB+J ) = WORK( M-KB+J+KA )
+ WORK( N+M-KB+J ) = WORK( N+M-KB+J+KA )
+ 860 CONTINUE
+ DO 870 J = J1, J2, KA1
+*
+* create nonzero element a(j+ka,j-1) outside the band
+* and store it in WORK(m-kb+j)
+*
+ WORK( M-KB+J ) = WORK( M-KB+J )*AB( KA1, J-1 )
+ AB( KA1, J-1 ) = WORK( N+M-KB+J )*AB( KA1, J-1 )
+ 870 CONTINUE
+ IF( UPDATE ) THEN
+ IF( I+K.GT.KA1 .AND. K.LE.KBT )
+ $ WORK( M-KB+I+K-KA ) = WORK( M-KB+I+K )
+ END IF
+ 880 CONTINUE
+*
+ DO 920 K = KB, 1, -1
+ J2 = I + K + 1 - MAX( 1, K+I0-M )*KA1
+ NR = ( J2+KA-1 ) / KA1
+ J1 = J2 - ( NR-1 )*KA1
+ IF( NR.GT.0 ) THEN
+*
+* generate rotations in 2nd set to annihilate elements
+* which have been created outside the band
+*
+ CALL SLARGV( NR, AB( KA1, J1 ), INCA, WORK( M-KB+J1 ),
+ $ KA1, WORK( N+M-KB+J1 ), KA1 )
+*
+* apply rotations in 2nd set from the right
+*
+ DO 890 L = 1, KA - 1
+ CALL SLARTV( NR, AB( L+1, J1 ), INCA, AB( L+2, J1-1 ),
+ $ INCA, WORK( N+M-KB+J1 ), WORK( M-KB+J1 ),
+ $ KA1 )
+ 890 CONTINUE
+*
+* apply rotations in 2nd set from both sides to diagonal
+* blocks
+*
+ CALL SLAR2V( NR, AB( 1, J1 ), AB( 1, J1-1 ),
+ $ AB( 2, J1-1 ), INCA, WORK( N+M-KB+J1 ),
+ $ WORK( M-KB+J1 ), KA1 )
+*
+ END IF
+*
+* start applying rotations in 2nd set from the left
+*
+ DO 900 L = KA - 1, KB - K + 1, -1
+ NRT = ( J2+L-1 ) / KA1
+ J1T = J2 - ( NRT-1 )*KA1
+ IF( NRT.GT.0 )
+ $ CALL SLARTV( NRT, AB( KA1-L+1, J1T-KA1+L ), INCA,
+ $ AB( KA1-L, J1T-KA1+L ), INCA,
+ $ WORK( N+M-KB+J1T ), WORK( M-KB+J1T ),
+ $ KA1 )
+ 900 CONTINUE
+*
+ IF( WANTX ) THEN
+*
+* post-multiply X by product of rotations in 2nd set
+*
+ DO 910 J = J1, J2, KA1
+ CALL SROT( NX, X( 1, J ), 1, X( 1, J-1 ), 1,
+ $ WORK( N+M-KB+J ), WORK( M-KB+J ) )
+ 910 CONTINUE
+ END IF
+ 920 CONTINUE
+*
+ DO 940 K = 1, KB - 1
+ J2 = I + K + 1 - MAX( 1, K+I0-M+1 )*KA1
+*
+* finish applying rotations in 1st set from the left
+*
+ DO 930 L = KB - K, 1, -1
+ NRT = ( J2+L-1 ) / KA1
+ J1T = J2 - ( NRT-1 )*KA1
+ IF( NRT.GT.0 )
+ $ CALL SLARTV( NRT, AB( KA1-L+1, J1T-KA1+L ), INCA,
+ $ AB( KA1-L, J1T-KA1+L ), INCA,
+ $ WORK( N+J1T ), WORK( J1T ), KA1 )
+ 930 CONTINUE
+ 940 CONTINUE
+*
+ IF( KB.GT.1 ) THEN
+ DO 950 J = 2, MIN( I+KB, M ) - 2*KA - 1
+ WORK( N+J ) = WORK( N+J+KA )
+ WORK( J ) = WORK( J+KA )
+ 950 CONTINUE
+ END IF
+*
+ END IF
+*
+ GO TO 490
+*
+* End of SSBGST
+*
+ END
+ SUBROUTINE SSBGV( JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, W, Z,
+ $ LDZ, WORK, INFO )
+*
+* -- LAPACK driver routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER JOBZ, UPLO
+ INTEGER INFO, KA, KB, LDAB, LDBB, LDZ, N
+* ..
+* .. Array Arguments ..
+ REAL AB( LDAB, * ), BB( LDBB, * ), W( * ),
+ $ WORK( * ), Z( LDZ, * )
+* ..
+*
+* Purpose
+* =======
+*
+* SSBGV computes all the eigenvalues, and optionally, the eigenvectors
+* of a real generalized symmetric-definite banded eigenproblem, of
+* the form A*x=(lambda)*B*x. Here A and B are assumed to be symmetric
+* and banded, and B is also positive definite.
+*
+* Arguments
+* =========
+*
+* JOBZ (input) CHARACTER*1
+* = 'N': Compute eigenvalues only;
+* = 'V': Compute eigenvalues and eigenvectors.
+*
+* UPLO (input) CHARACTER*1
+* = 'U': Upper triangles of A and B are stored;
+* = 'L': Lower triangles of A and B are stored.
+*
+* N (input) INTEGER
+* The order of the matrices A and B. N >= 0.
+*
+* KA (input) INTEGER
+* The number of superdiagonals of the matrix A if UPLO = 'U',
+* or the number of subdiagonals if UPLO = 'L'. KA >= 0.
+*
+* KB (input) INTEGER
+* The number of superdiagonals of the matrix B if UPLO = 'U',
+* or the number of subdiagonals if UPLO = 'L'. KB >= 0.
+*
+* AB (input/output) REAL array, dimension (LDAB, N)
+* On entry, the upper or lower triangle of the symmetric band
+* matrix A, stored in the first ka+1 rows of the array. The
+* j-th column of A is stored in the j-th column of the array AB
+* as follows:
+* if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j;
+* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+ka).
+*
+* On exit, the contents of AB are destroyed.
+*
+* LDAB (input) INTEGER
+* The leading dimension of the array AB. LDAB >= KA+1.
+*
+* BB (input/output) REAL array, dimension (LDBB, N)
+* On entry, the upper or lower triangle of the symmetric band
+* matrix B, stored in the first kb+1 rows of the array. The
+* j-th column of B is stored in the j-th column of the array BB
+* as follows:
+* if UPLO = 'U', BB(kb+1+i-j,j) = B(i,j) for max(1,j-kb)<=i<=j;
+* if UPLO = 'L', BB(1+i-j,j) = B(i,j) for j<=i<=min(n,j+kb).
+*
+* On exit, the factor S from the split Cholesky factorization
+* B = S**T*S, as returned by SPBSTF.
+*
+* LDBB (input) INTEGER
+* The leading dimension of the array BB. LDBB >= KB+1.
+*
+* W (output) REAL array, dimension (N)
+* If INFO = 0, the eigenvalues in ascending order.
+*
+* Z (output) REAL array, dimension (LDZ, N)
+* If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of
+* eigenvectors, with the i-th column of Z holding the
+* eigenvector associated with W(i). The eigenvectors are
+* normalized so that Z**T*B*Z = I.
+* If JOBZ = 'N', then Z is not referenced.
+*
+* LDZ (input) INTEGER
+* The leading dimension of the array Z. LDZ >= 1, and if
+* JOBZ = 'V', LDZ >= N.
+*
+* WORK (workspace) REAL array, dimension (3*N)
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* > 0: if INFO = i, and i is:
+* <= N: the algorithm failed to converge:
+* i off-diagonal elements of an intermediate
+* tridiagonal form did not converge to zero;
+* > N: if INFO = N + i, for 1 <= i <= N, then SPBSTF
+* returned INFO = i: B is not positive definite.
+* The factorization of B could not be completed and
+* no eigenvalues or eigenvectors were computed.
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ LOGICAL UPPER, WANTZ
+ CHARACTER VECT
+ INTEGER IINFO, INDE, INDWRK
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL SPBSTF, SSBGST, SSBTRD, SSTEQR, SSTERF, XERBLA
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ WANTZ = LSAME( JOBZ, 'V' )
+ UPPER = LSAME( UPLO, 'U' )
+*
+ INFO = 0
+ IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
+ INFO = -1
+ ELSE IF( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN
+ INFO = -2
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( KA.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( KB.LT.0 .OR. KB.GT.KA ) THEN
+ INFO = -5
+ ELSE IF( LDAB.LT.KA+1 ) THEN
+ INFO = -7
+ ELSE IF( LDBB.LT.KB+1 ) THEN
+ INFO = -9
+ ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
+ INFO = -12
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SSBGV ', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+* Form a split Cholesky factorization of B.
+*
+ CALL SPBSTF( UPLO, N, KB, BB, LDBB, INFO )
+ IF( INFO.NE.0 ) THEN
+ INFO = N + INFO
+ RETURN
+ END IF
+*
+* Transform problem to standard eigenvalue problem.
+*
+ INDE = 1
+ INDWRK = INDE + N
+ CALL SSBGST( JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, Z, LDZ,
+ $ WORK( INDWRK ), IINFO )
+*
+* Reduce to tridiagonal form.
+*
+ IF( WANTZ ) THEN
+ VECT = 'U'
+ ELSE
+ VECT = 'N'
+ END IF
+ CALL SSBTRD( VECT, UPLO, N, KA, AB, LDAB, W, WORK( INDE ), Z, LDZ,
+ $ WORK( INDWRK ), IINFO )
+*
+* For eigenvalues only, call SSTERF. For eigenvectors, call SSTEQR.
+*
+ IF( .NOT.WANTZ ) THEN
+ CALL SSTERF( N, W, WORK( INDE ), INFO )
+ ELSE
+ CALL SSTEQR( JOBZ, N, W, WORK( INDE ), Z, LDZ, WORK( INDWRK ),
+ $ INFO )
+ END IF
+ RETURN
+*
+* End of SSBGV
+*
+ END
+ SUBROUTINE SSBGVD( JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, W,
+ $ Z, LDZ, WORK, LWORK, IWORK, LIWORK, INFO )
+*
+* -- LAPACK driver routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER JOBZ, UPLO
+ INTEGER INFO, KA, KB, LDAB, LDBB, LDZ, LIWORK, LWORK, N
+* ..
+* .. Array Arguments ..
+ INTEGER IWORK( * )
+ REAL AB( LDAB, * ), BB( LDBB, * ), W( * ),
+ $ WORK( * ), Z( LDZ, * )
+* ..
+*
+* Purpose
+* =======
+*
+* SSBGVD computes all the eigenvalues, and optionally, the eigenvectors
+* of a real generalized symmetric-definite banded eigenproblem, of the
+* form A*x=(lambda)*B*x. Here A and B are assumed to be symmetric and
+* banded, and B is also positive definite. If eigenvectors are
+* desired, it uses a divide and conquer algorithm.
+*
+* The divide and conquer algorithm makes very mild assumptions about
+* floating point arithmetic. It will work on machines with a guard
+* digit in add/subtract, or on those binary machines without guard
+* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
+* Cray-2. It could conceivably fail on hexadecimal or decimal machines
+* without guard digits, but we know of none.
+*
+* Arguments
+* =========
+*
+* JOBZ (input) CHARACTER*1
+* = 'N': Compute eigenvalues only;
+* = 'V': Compute eigenvalues and eigenvectors.
+*
+* UPLO (input) CHARACTER*1
+* = 'U': Upper triangles of A and B are stored;
+* = 'L': Lower triangles of A and B are stored.
+*
+* N (input) INTEGER
+* The order of the matrices A and B. N >= 0.
+*
+* KA (input) INTEGER
+* The number of superdiagonals of the matrix A if UPLO = 'U',
+* or the number of subdiagonals if UPLO = 'L'. KA >= 0.
+*
+* KB (input) INTEGER
+* The number of superdiagonals of the matrix B if UPLO = 'U',
+* or the number of subdiagonals if UPLO = 'L'. KB >= 0.
+*
+* AB (input/output) REAL array, dimension (LDAB, N)
+* On entry, the upper or lower triangle of the symmetric band
+* matrix A, stored in the first ka+1 rows of the array. The
+* j-th column of A is stored in the j-th column of the array AB
+* as follows:
+* if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j;
+* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+ka).
+*
+* On exit, the contents of AB are destroyed.
+*
+* LDAB (input) INTEGER
+* The leading dimension of the array AB. LDAB >= KA+1.
+*
+* BB (input/output) REAL array, dimension (LDBB, N)
+* On entry, the upper or lower triangle of the symmetric band
+* matrix B, stored in the first kb+1 rows of the array. The
+* j-th column of B is stored in the j-th column of the array BB
+* as follows:
+* if UPLO = 'U', BB(ka+1+i-j,j) = B(i,j) for max(1,j-kb)<=i<=j;
+* if UPLO = 'L', BB(1+i-j,j) = B(i,j) for j<=i<=min(n,j+kb).
+*
+* On exit, the factor S from the split Cholesky factorization
+* B = S**T*S, as returned by SPBSTF.
+*
+* LDBB (input) INTEGER
+* The leading dimension of the array BB. LDBB >= KB+1.
+*
+* W (output) REAL array, dimension (N)
+* If INFO = 0, the eigenvalues in ascending order.
+*
+* Z (output) REAL array, dimension (LDZ, N)
+* If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of
+* eigenvectors, with the i-th column of Z holding the
+* eigenvector associated with W(i). The eigenvectors are
+* normalized so Z**T*B*Z = I.
+* If JOBZ = 'N', then Z is not referenced.
+*
+* LDZ (input) INTEGER
+* The leading dimension of the array Z. LDZ >= 1, and if
+* JOBZ = 'V', LDZ >= max(1,N).
+*
+* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))
+* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+* LWORK (input) INTEGER
+* The dimension of the array WORK.
+* If N <= 1, LWORK >= 1.
+* If JOBZ = 'N' and N > 1, LWORK >= 3*N.
+* If JOBZ = 'V' and N > 1, LWORK >= 1 + 5*N + 2*N**2.
+*
+* If LWORK = -1, then a workspace query is assumed; the routine
+* only calculates the optimal sizes of the WORK and IWORK
+* arrays, returns these values as the first entries of the WORK
+* and IWORK arrays, and no error message related to LWORK or
+* LIWORK is issued by XERBLA.
+*
+* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))
+* On exit, if LIWORK > 0, IWORK(1) returns the optimal LIWORK.
+*
+* LIWORK (input) INTEGER
+* The dimension of the array IWORK.
+* If JOBZ = 'N' or N <= 1, LIWORK >= 1.
+* If JOBZ = 'V' and N > 1, LIWORK >= 3 + 5*N.
+*
+* If LIWORK = -1, then a workspace query is assumed; the
+* routine only calculates the optimal sizes of the WORK and
+* IWORK arrays, returns these values as the first entries of
+* the WORK and IWORK arrays, and no error message related to
+* LWORK or LIWORK is issued by XERBLA.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* > 0: if INFO = i, and i is:
+* <= N: the algorithm failed to converge:
+* i off-diagonal elements of an intermediate
+* tridiagonal form did not converge to zero;
+* > N: if INFO = N + i, for 1 <= i <= N, then SPBSTF
+* returned INFO = i: B is not positive definite.
+* The factorization of B could not be completed and
+* no eigenvalues or eigenvectors were computed.
+*
+* Further Details
+* ===============
+*
+* Based on contributions by
+* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ONE, ZERO
+ PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL LQUERY, UPPER, WANTZ
+ CHARACTER VECT
+ INTEGER IINFO, INDE, INDWK2, INDWRK, LIWMIN, LLWRK2,
+ $ LWMIN
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL SGEMM, SLACPY, SPBSTF, SSBGST, SSBTRD, SSTEDC,
+ $ SSTERF, XERBLA
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ WANTZ = LSAME( JOBZ, 'V' )
+ UPPER = LSAME( UPLO, 'U' )
+ LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 )
+*
+ INFO = 0
+ IF( N.LE.1 ) THEN
+ LIWMIN = 1
+ LWMIN = 1
+ ELSE IF( WANTZ ) THEN
+ LIWMIN = 3 + 5*N
+ LWMIN = 1 + 5*N + 2*N**2
+ ELSE
+ LIWMIN = 1
+ LWMIN = 2*N
+ END IF
+*
+ IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
+ INFO = -1
+ ELSE IF( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN
+ INFO = -2
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( KA.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( KB.LT.0 .OR. KB.GT.KA ) THEN
+ INFO = -5
+ ELSE IF( LDAB.LT.KA+1 ) THEN
+ INFO = -7
+ ELSE IF( LDBB.LT.KB+1 ) THEN
+ INFO = -9
+ ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
+ INFO = -12
+ END IF
+*
+ IF( INFO.EQ.0 ) THEN
+ WORK( 1 ) = LWMIN
+ IWORK( 1 ) = LIWMIN
+*
+ IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
+ INFO = -14
+ ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN
+ INFO = -16
+ END IF
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SSBGVD', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+* Form a split Cholesky factorization of B.
+*
+ CALL SPBSTF( UPLO, N, KB, BB, LDBB, INFO )
+ IF( INFO.NE.0 ) THEN
+ INFO = N + INFO
+ RETURN
+ END IF
+*
+* Transform problem to standard eigenvalue problem.
+*
+ INDE = 1
+ INDWRK = INDE + N
+ INDWK2 = INDWRK + N*N
+ LLWRK2 = LWORK - INDWK2 + 1
+ CALL SSBGST( JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, Z, LDZ,
+ $ WORK( INDWRK ), IINFO )
+*
+* Reduce to tridiagonal form.
+*
+ IF( WANTZ ) THEN
+ VECT = 'U'
+ ELSE
+ VECT = 'N'
+ END IF
+ CALL SSBTRD( VECT, UPLO, N, KA, AB, LDAB, W, WORK( INDE ), Z, LDZ,
+ $ WORK( INDWRK ), IINFO )
+*
+* For eigenvalues only, call SSTERF. For eigenvectors, call SSTEDC.
+*
+ IF( .NOT.WANTZ ) THEN
+ CALL SSTERF( N, W, WORK( INDE ), INFO )
+ ELSE
+ CALL SSTEDC( 'I', N, W, WORK( INDE ), WORK( INDWRK ), N,
+ $ WORK( INDWK2 ), LLWRK2, IWORK, LIWORK, INFO )
+ CALL SGEMM( 'N', 'N', N, N, N, ONE, Z, LDZ, WORK( INDWRK ), N,
+ $ ZERO, WORK( INDWK2 ), N )
+ CALL SLACPY( 'A', N, N, WORK( INDWK2 ), N, Z, LDZ )
+ END IF
+*
+ WORK( 1 ) = LWMIN
+ IWORK( 1 ) = LIWMIN
+*
+ RETURN
+*
+* End of SSBGVD
+*
+ END
+ 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 )
+*
+* -- LAPACK driver routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER JOBZ, RANGE, UPLO
+ INTEGER IL, INFO, IU, KA, KB, LDAB, LDBB, LDQ, LDZ, M,
+ $ N
+ REAL ABSTOL, VL, VU
+* ..
+* .. Array Arguments ..
+ INTEGER IFAIL( * ), IWORK( * )
+ REAL AB( LDAB, * ), BB( LDBB, * ), Q( LDQ, * ),
+ $ W( * ), WORK( * ), Z( LDZ, * )
+* ..
+*
+* Purpose
+* =======
+*
+* SSBGVX computes selected eigenvalues, and optionally, eigenvectors
+* of a real generalized symmetric-definite banded eigenproblem, of
+* the form A*x=(lambda)*B*x. Here A and B are assumed to be symmetric
+* and banded, and B is also positive definite. Eigenvalues and
+* eigenvectors can be selected by specifying either all eigenvalues,
+* a range of values or a range of indices for the desired eigenvalues.
+*
+* Arguments
+* =========
+*
+* JOBZ (input) CHARACTER*1
+* = 'N': Compute eigenvalues only;
+* = 'V': Compute eigenvalues and eigenvectors.
+*
+* RANGE (input) CHARACTER*1
+* = 'A': all eigenvalues will be found.
+* = 'V': all eigenvalues in the half-open interval (VL,VU]
+* will be found.
+* = 'I': the IL-th through IU-th eigenvalues will be found.
+*
+* UPLO (input) CHARACTER*1
+* = 'U': Upper triangles of A and B are stored;
+* = 'L': Lower triangles of A and B are stored.
+*
+* N (input) INTEGER
+* The order of the matrices A and B. N >= 0.
+*
+* KA (input) INTEGER
+* The number of superdiagonals of the matrix A if UPLO = 'U',
+* or the number of subdiagonals if UPLO = 'L'. KA >= 0.
+*
+* KB (input) INTEGER
+* The number of superdiagonals of the matrix B if UPLO = 'U',
+* or the number of subdiagonals if UPLO = 'L'. KB >= 0.
+*
+* AB (input/output) REAL array, dimension (LDAB, N)
+* On entry, the upper or lower triangle of the symmetric band
+* matrix A, stored in the first ka+1 rows of the array. The
+* j-th column of A is stored in the j-th column of the array AB
+* as follows:
+* if UPLO = 'U', AB(ka+1+i-j,j) = A(i,j) for max(1,j-ka)<=i<=j;
+* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+ka).
+*
+* On exit, the contents of AB are destroyed.
+*
+* LDAB (input) INTEGER
+* The leading dimension of the array AB. LDAB >= KA+1.
+*
+* BB (input/output) REAL array, dimension (LDBB, N)
+* On entry, the upper or lower triangle of the symmetric band
+* matrix B, stored in the first kb+1 rows of the array. The
+* j-th column of B is stored in the j-th column of the array BB
+* as follows:
+* if UPLO = 'U', BB(ka+1+i-j,j) = B(i,j) for max(1,j-kb)<=i<=j;
+* if UPLO = 'L', BB(1+i-j,j) = B(i,j) for j<=i<=min(n,j+kb).
+*
+* On exit, the factor S from the split Cholesky factorization
+* B = S**T*S, as returned by SPBSTF.
+*
+* LDBB (input) INTEGER
+* The leading dimension of the array BB. LDBB >= KB+1.
+*
+* Q (output) REAL array, dimension (LDQ, N)
+* If JOBZ = 'V', the n-by-n matrix used in the reduction of
+* A*x = (lambda)*B*x to standard form, i.e. C*x = (lambda)*x,
+* and consequently C to tridiagonal form.
+* If JOBZ = 'N', the array Q is not referenced.
+*
+* LDQ (input) INTEGER
+* The leading dimension of the array Q. If JOBZ = 'N',
+* LDQ >= 1. If JOBZ = 'V', LDQ >= max(1,N).
+*
+* VL (input) REAL
+* VU (input) REAL
+* If RANGE='V', the lower and upper bounds of the interval to
+* be searched for eigenvalues. VL < VU.
+* Not referenced if RANGE = 'A' or 'I'.
+*
+* IL (input) INTEGER
+* IU (input) INTEGER
+* If RANGE='I', the indices (in ascending order) of the
+* smallest and largest eigenvalues to be returned.
+* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
+* Not referenced if RANGE = 'A' or 'V'.
+*
+* ABSTOL (input) REAL
+* The absolute error tolerance for the eigenvalues.
+* An approximate eigenvalue is accepted as converged
+* when it is determined to lie in an interval [a,b]
+* of width less than or equal to
+*
+* ABSTOL + EPS * max( |a|,|b| ) ,
+*
+* where EPS is the machine precision. If ABSTOL is less than
+* or equal to zero, then EPS*|T| will be used in its place,
+* where |T| is the 1-norm of the tridiagonal matrix obtained
+* by reducing A to tridiagonal form.
+*
+* Eigenvalues will be computed most accurately when ABSTOL is
+* set to twice the underflow threshold 2*SLAMCH('S'), not zero.
+* If this routine returns with INFO>0, indicating that some
+* eigenvectors did not converge, try setting ABSTOL to
+* 2*SLAMCH('S').
+*
+* M (output) INTEGER
+* The total number of eigenvalues found. 0 <= M <= N.
+* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
+*
+* W (output) REAL array, dimension (N)
+* If INFO = 0, the eigenvalues in ascending order.
+*
+* Z (output) REAL array, dimension (LDZ, N)
+* If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of
+* eigenvectors, with the i-th column of Z holding the
+* eigenvector associated with W(i). The eigenvectors are
+* normalized so Z**T*B*Z = I.
+* If JOBZ = 'N', then Z is not referenced.
+*
+* LDZ (input) INTEGER
+* The leading dimension of the array Z. LDZ >= 1, and if
+* JOBZ = 'V', LDZ >= max(1,N).
+*
+* WORK (workspace/output) REAL array, dimension (7N)
+*
+* IWORK (workspace/output) INTEGER array, dimension (5N)
+*
+* IFAIL (output) INTEGER array, dimension (M)
+* If JOBZ = 'V', then if INFO = 0, the first M elements of
+* IFAIL are zero. If INFO > 0, then IFAIL contains the
+* indices of the eigenvalues that failed to converge.
+* If JOBZ = 'N', then IFAIL is not referenced.
+*
+* INFO (output) INTEGER
+* = 0 : successful exit
+* < 0 : if INFO = -i, the i-th argument had an illegal value
+* <= N: if INFO = i, then i eigenvectors failed to converge.
+* Their indices are stored in IFAIL.
+* > N : SPBSTF returned an error code; i.e.,
+* if INFO = N + i, for 1 <= i <= N, then the leading
+* minor of order i of B is not positive definite.
+* The factorization of B could not be completed and
+* no eigenvalues or eigenvectors were computed.
+*
+* Further Details
+* ===============
+*
+* Based on contributions by
+* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO, ONE
+ PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL ALLEIG, INDEIG, TEST, UPPER, VALEIG, WANTZ
+ CHARACTER ORDER, VECT
+ INTEGER I, IINFO, INDD, INDE, INDEE, INDIBL, INDISP,
+ $ INDIWO, INDWRK, ITMP1, J, JJ, NSPLIT
+ REAL TMP1
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL SCOPY, SGEMV, SLACPY, SPBSTF, SSBGST, SSBTRD,
+ $ SSTEBZ, SSTEIN, SSTEQR, SSTERF, SSWAP, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MIN
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ WANTZ = LSAME( JOBZ, 'V' )
+ UPPER = LSAME( UPLO, 'U' )
+ ALLEIG = LSAME( RANGE, 'A' )
+ VALEIG = LSAME( RANGE, 'V' )
+ INDEIG = LSAME( RANGE, 'I' )
+*
+ INFO = 0
+ IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
+ INFO = -1
+ ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN
+ INFO = -2
+ ELSE IF( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN
+ INFO = -3
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( KA.LT.0 ) THEN
+ INFO = -5
+ ELSE IF( KB.LT.0 .OR. KB.GT.KA ) THEN
+ INFO = -6
+ ELSE IF( LDAB.LT.KA+1 ) THEN
+ INFO = -8
+ ELSE IF( LDBB.LT.KB+1 ) THEN
+ INFO = -10
+ ELSE IF( LDQ.LT.1 .OR. ( WANTZ .AND. LDQ.LT.N ) ) THEN
+ INFO = -12
+ ELSE
+ IF( VALEIG ) THEN
+ IF( N.GT.0 .AND. VU.LE.VL )
+ $ INFO = -14
+ ELSE IF( INDEIG ) THEN
+ IF( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) THEN
+ INFO = -15
+ ELSE IF ( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) THEN
+ INFO = -16
+ END IF
+ END IF
+ END IF
+ IF( INFO.EQ.0) THEN
+ IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
+ INFO = -21
+ END IF
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SSBGVX', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ M = 0
+ IF( N.EQ.0 )
+ $ RETURN
+*
+* Form a split Cholesky factorization of B.
+*
+ CALL SPBSTF( UPLO, N, KB, BB, LDBB, INFO )
+ IF( INFO.NE.0 ) THEN
+ INFO = N + INFO
+ RETURN
+ END IF
+*
+* Transform problem to standard eigenvalue problem.
+*
+ CALL SSBGST( JOBZ, UPLO, N, KA, KB, AB, LDAB, BB, LDBB, Q, LDQ,
+ $ WORK, IINFO )
+*
+* Reduce symmetric band matrix to tridiagonal form.
+*
+ INDD = 1
+ INDE = INDD + N
+ INDWRK = INDE + N
+ IF( WANTZ ) THEN
+ VECT = 'U'
+ ELSE
+ VECT = 'N'
+ END IF
+ CALL SSBTRD( VECT, UPLO, N, KA, AB, LDAB, WORK( INDD ),
+ $ WORK( INDE ), Q, LDQ, WORK( INDWRK ), IINFO )
+*
+* If all eigenvalues are desired and ABSTOL is less than or equal
+* to zero, then call SSTERF or SSTEQR. If this fails for some
+* eigenvalue, then try SSTEBZ.
+*
+ TEST = .FALSE.
+ IF( INDEIG ) THEN
+ IF( IL.EQ.1 .AND. IU.EQ.N ) THEN
+ TEST = .TRUE.
+ END IF
+ END IF
+ IF( ( ALLEIG .OR. TEST ) .AND. ( ABSTOL.LE.ZERO ) ) THEN
+ CALL SCOPY( N, WORK( INDD ), 1, W, 1 )
+ INDEE = INDWRK + 2*N
+ CALL SCOPY( N-1, WORK( INDE ), 1, WORK( INDEE ), 1 )
+ IF( .NOT.WANTZ ) THEN
+ CALL SSTERF( N, W, WORK( INDEE ), INFO )
+ ELSE
+ CALL SLACPY( 'A', N, N, Q, LDQ, Z, LDZ )
+ CALL SSTEQR( JOBZ, N, W, WORK( INDEE ), Z, LDZ,
+ $ WORK( INDWRK ), INFO )
+ IF( INFO.EQ.0 ) THEN
+ DO 10 I = 1, N
+ IFAIL( I ) = 0
+ 10 CONTINUE
+ END IF
+ END IF
+ IF( INFO.EQ.0 ) THEN
+ M = N
+ GO TO 30
+ END IF
+ INFO = 0
+ END IF
+*
+* Otherwise, call SSTEBZ and, if eigenvectors are desired,
+* call SSTEIN.
+*
+ IF( WANTZ ) THEN
+ ORDER = 'B'
+ ELSE
+ ORDER = 'E'
+ END IF
+ INDIBL = 1
+ INDISP = INDIBL + N
+ INDIWO = INDISP + N
+ CALL SSTEBZ( RANGE, ORDER, N, VL, VU, IL, IU, ABSTOL,
+ $ WORK( INDD ), WORK( INDE ), M, NSPLIT, W,
+ $ IWORK( INDIBL ), IWORK( INDISP ), WORK( INDWRK ),
+ $ IWORK( INDIWO ), INFO )
+*
+ IF( WANTZ ) THEN
+ CALL SSTEIN( N, WORK( INDD ), WORK( INDE ), M, W,
+ $ IWORK( INDIBL ), IWORK( INDISP ), Z, LDZ,
+ $ WORK( INDWRK ), IWORK( INDIWO ), IFAIL, INFO )
+*
+* Apply transformation matrix used in reduction to tridiagonal
+* form to eigenvectors returned by SSTEIN.
+*
+ DO 20 J = 1, M
+ CALL SCOPY( N, Z( 1, J ), 1, WORK( 1 ), 1 )
+ CALL SGEMV( 'N', N, N, ONE, Q, LDQ, WORK, 1, ZERO,
+ $ Z( 1, J ), 1 )
+ 20 CONTINUE
+ END IF
+*
+ 30 CONTINUE
+*
+* If eigenvalues are not in order, then sort them, along with
+* eigenvectors.
+*
+ IF( WANTZ ) THEN
+ DO 50 J = 1, M - 1
+ I = 0
+ TMP1 = W( J )
+ DO 40 JJ = J + 1, M
+ IF( W( JJ ).LT.TMP1 ) THEN
+ I = JJ
+ TMP1 = W( JJ )
+ END IF
+ 40 CONTINUE
+*
+ IF( I.NE.0 ) THEN
+ ITMP1 = IWORK( INDIBL+I-1 )
+ W( I ) = W( J )
+ IWORK( INDIBL+I-1 ) = IWORK( INDIBL+J-1 )
+ W( J ) = TMP1
+ IWORK( INDIBL+J-1 ) = ITMP1
+ CALL SSWAP( N, Z( 1, I ), 1, Z( 1, J ), 1 )
+ IF( INFO.NE.0 ) THEN
+ ITMP1 = IFAIL( I )
+ IFAIL( I ) = IFAIL( J )
+ IFAIL( J ) = ITMP1
+ END IF
+ END IF
+ 50 CONTINUE
+ END IF
+*
+ RETURN
+*
+* End of SSBGVX
+*
+ END
+ SUBROUTINE SSBTRD( VECT, UPLO, N, KD, AB, LDAB, D, E, Q, LDQ,
+ $ WORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO, VECT
+ INTEGER INFO, KD, LDAB, LDQ, N
+* ..
+* .. Array Arguments ..
+ REAL AB( LDAB, * ), D( * ), E( * ), Q( LDQ, * ),
+ $ WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SSBTRD reduces a real symmetric band matrix A to symmetric
+* tridiagonal form T by an orthogonal similarity transformation:
+* Q**T * A * Q = T.
+*
+* Arguments
+* =========
+*
+* VECT (input) CHARACTER*1
+* = 'N': do not form Q;
+* = 'V': form Q;
+* = 'U': update a matrix X, by forming X*Q.
+*
+* UPLO (input) CHARACTER*1
+* = 'U': Upper triangle of A is stored;
+* = 'L': Lower triangle of A is stored.
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* KD (input) INTEGER
+* The number of superdiagonals of the matrix A if UPLO = 'U',
+* or the number of subdiagonals if UPLO = 'L'. KD >= 0.
+*
+* AB (input/output) REAL array, dimension (LDAB,N)
+* On entry, the upper or lower triangle of the symmetric band
+* matrix A, stored in the first KD+1 rows of the array. The
+* j-th column of A is stored in the j-th column of the array AB
+* as follows:
+* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
+* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).
+* On exit, the diagonal elements of AB are overwritten by the
+* diagonal elements of the tridiagonal matrix T; if KD > 0, the
+* elements on the first superdiagonal (if UPLO = 'U') or the
+* first subdiagonal (if UPLO = 'L') are overwritten by the
+* off-diagonal elements of T; the rest of AB is overwritten by
+* values generated during the reduction.
+*
+* LDAB (input) INTEGER
+* The leading dimension of the array AB. LDAB >= KD+1.
+*
+* D (output) REAL array, dimension (N)
+* The diagonal elements of the tridiagonal matrix T.
+*
+* E (output) REAL array, dimension (N-1)
+* The off-diagonal elements of the tridiagonal matrix T:
+* E(i) = T(i,i+1) if UPLO = 'U'; E(i) = T(i+1,i) if UPLO = 'L'.
+*
+* Q (input/output) REAL array, dimension (LDQ,N)
+* On entry, if VECT = 'U', then Q must contain an N-by-N
+* matrix X; if VECT = 'N' or 'V', then Q need not be set.
+*
+* On exit:
+* if VECT = 'V', Q contains the N-by-N orthogonal matrix Q;
+* if VECT = 'U', Q contains the product X*Q;
+* if VECT = 'N', the array Q is not referenced.
+*
+* LDQ (input) INTEGER
+* The leading dimension of the array Q.
+* LDQ >= 1, and LDQ >= N if VECT = 'V' or 'U'.
+*
+* WORK (workspace) REAL array, dimension (N)
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+*
+* Further Details
+* ===============
+*
+* Modified by Linda Kaufman, Bell Labs.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO, ONE
+ PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL INITQ, UPPER, WANTQ
+ INTEGER I, I2, IBL, INCA, INCX, IQAEND, IQB, IQEND, J,
+ $ J1, J1END, J1INC, J2, JEND, JIN, JINC, K, KD1,
+ $ KDM1, KDN, L, LAST, LEND, NQ, NR, NRT
+ REAL TEMP
+* ..
+* .. External Subroutines ..
+ EXTERNAL SLAR2V, SLARGV, SLARTG, SLARTV, SLASET, SROT,
+ $ XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters
+*
+ INITQ = LSAME( VECT, 'V' )
+ WANTQ = INITQ .OR. LSAME( VECT, 'U' )
+ UPPER = LSAME( UPLO, 'U' )
+ KD1 = KD + 1
+ KDM1 = KD - 1
+ INCX = LDAB - 1
+ IQEND = 1
+*
+ INFO = 0
+ IF( .NOT.WANTQ .AND. .NOT.LSAME( VECT, 'N' ) ) THEN
+ INFO = -1
+ ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -2
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( KD.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( LDAB.LT.KD1 ) THEN
+ INFO = -6
+ ELSE IF( LDQ.LT.MAX( 1, N ) .AND. WANTQ ) THEN
+ INFO = -10
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SSBTRD', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+* Initialize Q to the unit matrix, if needed
+*
+ IF( INITQ )
+ $ CALL SLASET( 'Full', N, N, ZERO, ONE, Q, LDQ )
+*
+* Wherever possible, plane rotations are generated and applied in
+* vector operations of length NR over the index set J1:J2:KD1.
+*
+* The cosines and sines of the plane rotations are stored in the
+* arrays D and WORK.
+*
+ INCA = KD1*LDAB
+ KDN = MIN( N-1, KD )
+ IF( UPPER ) THEN
+*
+ IF( KD.GT.1 ) THEN
+*
+* Reduce to tridiagonal form, working with upper triangle
+*
+ NR = 0
+ J1 = KDN + 2
+ J2 = 1
+*
+ DO 90 I = 1, N - 2
+*
+* Reduce i-th row of matrix to tridiagonal form
+*
+ DO 80 K = KDN + 1, 2, -1
+ J1 = J1 + KDN
+ J2 = J2 + KDN
+*
+ IF( NR.GT.0 ) THEN
+*
+* generate plane rotations to annihilate nonzero
+* elements which have been created outside the band
+*
+ CALL SLARGV( NR, AB( 1, J1-1 ), INCA, WORK( J1 ),
+ $ KD1, D( J1 ), KD1 )
+*
+* apply rotations from the right
+*
+*
+* Dependent on the the number of diagonals either
+* SLARTV or SROT is used
+*
+ IF( NR.GE.2*KD-1 ) THEN
+ DO 10 L = 1, KD - 1
+ CALL SLARTV( NR, AB( L+1, J1-1 ), INCA,
+ $ AB( L, J1 ), INCA, D( J1 ),
+ $ WORK( J1 ), KD1 )
+ 10 CONTINUE
+*
+ ELSE
+ JEND = J1 + ( NR-1 )*KD1
+ DO 20 JINC = J1, JEND, KD1
+ CALL SROT( KDM1, AB( 2, JINC-1 ), 1,
+ $ AB( 1, JINC ), 1, D( JINC ),
+ $ WORK( JINC ) )
+ 20 CONTINUE
+ END IF
+ END IF
+*
+*
+ IF( K.GT.2 ) THEN
+ IF( K.LE.N-I+1 ) THEN
+*
+* generate plane rotation to annihilate a(i,i+k-1)
+* within the band
+*
+ CALL SLARTG( AB( KD-K+3, I+K-2 ),
+ $ AB( KD-K+2, I+K-1 ), D( I+K-1 ),
+ $ WORK( I+K-1 ), TEMP )
+ AB( KD-K+3, I+K-2 ) = TEMP
+*
+* apply rotation from the right
+*
+ CALL SROT( K-3, AB( KD-K+4, I+K-2 ), 1,
+ $ AB( KD-K+3, I+K-1 ), 1, D( I+K-1 ),
+ $ WORK( I+K-1 ) )
+ END IF
+ NR = NR + 1
+ J1 = J1 - KDN - 1
+ END IF
+*
+* apply plane rotations from both sides to diagonal
+* blocks
+*
+ IF( NR.GT.0 )
+ $ CALL SLAR2V( NR, AB( KD1, J1-1 ), AB( KD1, J1 ),
+ $ AB( KD, J1 ), INCA, D( J1 ),
+ $ WORK( J1 ), KD1 )
+*
+* apply plane rotations from the left
+*
+ IF( NR.GT.0 ) THEN
+ IF( 2*KD-1.LT.NR ) THEN
+*
+* Dependent on the the number of diagonals either
+* SLARTV or SROT is used
+*
+ DO 30 L = 1, KD - 1
+ IF( J2+L.GT.N ) THEN
+ NRT = NR - 1
+ ELSE
+ NRT = NR
+ END IF
+ IF( NRT.GT.0 )
+ $ CALL SLARTV( NRT, AB( KD-L, J1+L ), INCA,
+ $ AB( KD-L+1, J1+L ), INCA,
+ $ D( J1 ), WORK( J1 ), KD1 )
+ 30 CONTINUE
+ ELSE
+ J1END = J1 + KD1*( NR-2 )
+ IF( J1END.GE.J1 ) THEN
+ DO 40 JIN = J1, J1END, KD1
+ CALL SROT( KD-1, AB( KD-1, JIN+1 ), INCX,
+ $ AB( KD, JIN+1 ), INCX,
+ $ D( JIN ), WORK( JIN ) )
+ 40 CONTINUE
+ END IF
+ LEND = MIN( KDM1, N-J2 )
+ LAST = J1END + KD1
+ IF( LEND.GT.0 )
+ $ CALL SROT( LEND, AB( KD-1, LAST+1 ), INCX,
+ $ AB( KD, LAST+1 ), INCX, D( LAST ),
+ $ WORK( LAST ) )
+ END IF
+ END IF
+*
+ IF( WANTQ ) THEN
+*
+* accumulate product of plane rotations in Q
+*
+ IF( INITQ ) THEN
+*
+* take advantage of the fact that Q was
+* initially the Identity matrix
+*
+ IQEND = MAX( IQEND, J2 )
+ I2 = MAX( 0, K-3 )
+ IQAEND = 1 + I*KD
+ IF( K.EQ.2 )
+ $ IQAEND = IQAEND + KD
+ IQAEND = MIN( IQAEND, IQEND )
+ DO 50 J = J1, J2, KD1
+ IBL = I - I2 / KDM1
+ I2 = I2 + 1
+ IQB = MAX( 1, J-IBL )
+ NQ = 1 + IQAEND - IQB
+ IQAEND = MIN( IQAEND+KD, IQEND )
+ CALL SROT( NQ, Q( IQB, J-1 ), 1, Q( IQB, J ),
+ $ 1, D( J ), WORK( J ) )
+ 50 CONTINUE
+ ELSE
+*
+ DO 60 J = J1, J2, KD1
+ CALL SROT( N, Q( 1, J-1 ), 1, Q( 1, J ), 1,
+ $ D( J ), WORK( J ) )
+ 60 CONTINUE
+ END IF
+*
+ END IF
+*
+ IF( J2+KDN.GT.N ) THEN
+*
+* adjust J2 to keep within the bounds of the matrix
+*
+ NR = NR - 1
+ J2 = J2 - KDN - 1
+ END IF
+*
+ DO 70 J = J1, J2, KD1
+*
+* create nonzero element a(j-1,j+kd) outside the band
+* and store it in WORK
+*
+ WORK( J+KD ) = WORK( J )*AB( 1, J+KD )
+ AB( 1, J+KD ) = D( J )*AB( 1, J+KD )
+ 70 CONTINUE
+ 80 CONTINUE
+ 90 CONTINUE
+ END IF
+*
+ IF( KD.GT.0 ) THEN
+*
+* copy off-diagonal elements to E
+*
+ DO 100 I = 1, N - 1
+ E( I ) = AB( KD, I+1 )
+ 100 CONTINUE
+ ELSE
+*
+* set E to zero if original matrix was diagonal
+*
+ DO 110 I = 1, N - 1
+ E( I ) = ZERO
+ 110 CONTINUE
+ END IF
+*
+* copy diagonal elements to D
+*
+ DO 120 I = 1, N
+ D( I ) = AB( KD1, I )
+ 120 CONTINUE
+*
+ ELSE
+*
+ IF( KD.GT.1 ) THEN
+*
+* Reduce to tridiagonal form, working with lower triangle
+*
+ NR = 0
+ J1 = KDN + 2
+ J2 = 1
+*
+ DO 210 I = 1, N - 2
+*
+* Reduce i-th column of matrix to tridiagonal form
+*
+ DO 200 K = KDN + 1, 2, -1
+ J1 = J1 + KDN
+ J2 = J2 + KDN
+*
+ IF( NR.GT.0 ) THEN
+*
+* generate plane rotations to annihilate nonzero
+* elements which have been created outside the band
+*
+ CALL SLARGV( NR, AB( KD1, J1-KD1 ), INCA,
+ $ WORK( J1 ), KD1, D( J1 ), KD1 )
+*
+* apply plane rotations from one side
+*
+*
+* Dependent on the the number of diagonals either
+* SLARTV or SROT is used
+*
+ IF( NR.GT.2*KD-1 ) THEN
+ DO 130 L = 1, KD - 1
+ CALL SLARTV( NR, AB( KD1-L, J1-KD1+L ), INCA,
+ $ AB( KD1-L+1, J1-KD1+L ), INCA,
+ $ D( J1 ), WORK( J1 ), KD1 )
+ 130 CONTINUE
+ ELSE
+ JEND = J1 + KD1*( NR-1 )
+ DO 140 JINC = J1, JEND, KD1
+ CALL SROT( KDM1, AB( KD, JINC-KD ), INCX,
+ $ AB( KD1, JINC-KD ), INCX,
+ $ D( JINC ), WORK( JINC ) )
+ 140 CONTINUE
+ END IF
+*
+ END IF
+*
+ IF( K.GT.2 ) THEN
+ IF( K.LE.N-I+1 ) THEN
+*
+* generate plane rotation to annihilate a(i+k-1,i)
+* within the band
+*
+ CALL SLARTG( AB( K-1, I ), AB( K, I ),
+ $ D( I+K-1 ), WORK( I+K-1 ), TEMP )
+ AB( K-1, I ) = TEMP
+*
+* apply rotation from the left
+*
+ CALL SROT( K-3, AB( K-2, I+1 ), LDAB-1,
+ $ AB( K-1, I+1 ), LDAB-1, D( I+K-1 ),
+ $ WORK( I+K-1 ) )
+ END IF
+ NR = NR + 1
+ J1 = J1 - KDN - 1
+ END IF
+*
+* apply plane rotations from both sides to diagonal
+* blocks
+*
+ IF( NR.GT.0 )
+ $ CALL SLAR2V( NR, AB( 1, J1-1 ), AB( 1, J1 ),
+ $ AB( 2, J1-1 ), INCA, D( J1 ),
+ $ WORK( J1 ), KD1 )
+*
+* apply plane rotations from the right
+*
+*
+* Dependent on the the number of diagonals either
+* SLARTV or SROT is used
+*
+ IF( NR.GT.0 ) THEN
+ IF( NR.GT.2*KD-1 ) THEN
+ DO 150 L = 1, KD - 1
+ IF( J2+L.GT.N ) THEN
+ NRT = NR - 1
+ ELSE
+ NRT = NR
+ END IF
+ IF( NRT.GT.0 )
+ $ CALL SLARTV( NRT, AB( L+2, J1-1 ), INCA,
+ $ AB( L+1, J1 ), INCA, D( J1 ),
+ $ WORK( J1 ), KD1 )
+ 150 CONTINUE
+ ELSE
+ J1END = J1 + KD1*( NR-2 )
+ IF( J1END.GE.J1 ) THEN
+ DO 160 J1INC = J1, J1END, KD1
+ CALL SROT( KDM1, AB( 3, J1INC-1 ), 1,
+ $ AB( 2, J1INC ), 1, D( J1INC ),
+ $ WORK( J1INC ) )
+ 160 CONTINUE
+ END IF
+ LEND = MIN( KDM1, N-J2 )
+ LAST = J1END + KD1
+ IF( LEND.GT.0 )
+ $ CALL SROT( LEND, AB( 3, LAST-1 ), 1,
+ $ AB( 2, LAST ), 1, D( LAST ),
+ $ WORK( LAST ) )
+ END IF
+ END IF
+*
+*
+*
+ IF( WANTQ ) THEN
+*
+* accumulate product of plane rotations in Q
+*
+ IF( INITQ ) THEN
+*
+* take advantage of the fact that Q was
+* initially the Identity matrix
+*
+ IQEND = MAX( IQEND, J2 )
+ I2 = MAX( 0, K-3 )
+ IQAEND = 1 + I*KD
+ IF( K.EQ.2 )
+ $ IQAEND = IQAEND + KD
+ IQAEND = MIN( IQAEND, IQEND )
+ DO 170 J = J1, J2, KD1
+ IBL = I - I2 / KDM1
+ I2 = I2 + 1
+ IQB = MAX( 1, J-IBL )
+ NQ = 1 + IQAEND - IQB
+ IQAEND = MIN( IQAEND+KD, IQEND )
+ CALL SROT( NQ, Q( IQB, J-1 ), 1, Q( IQB, J ),
+ $ 1, D( J ), WORK( J ) )
+ 170 CONTINUE
+ ELSE
+*
+ DO 180 J = J1, J2, KD1
+ CALL SROT( N, Q( 1, J-1 ), 1, Q( 1, J ), 1,
+ $ D( J ), WORK( J ) )
+ 180 CONTINUE
+ END IF
+ END IF
+*
+ IF( J2+KDN.GT.N ) THEN
+*
+* adjust J2 to keep within the bounds of the matrix
+*
+ NR = NR - 1
+ J2 = J2 - KDN - 1
+ END IF
+*
+ DO 190 J = J1, J2, KD1
+*
+* create nonzero element a(j+kd,j-1) outside the
+* band and store it in WORK
+*
+ WORK( J+KD ) = WORK( J )*AB( KD1, J )
+ AB( KD1, J ) = D( J )*AB( KD1, J )
+ 190 CONTINUE
+ 200 CONTINUE
+ 210 CONTINUE
+ END IF
+*
+ IF( KD.GT.0 ) THEN
+*
+* copy off-diagonal elements to E
+*
+ DO 220 I = 1, N - 1
+ E( I ) = AB( 2, I )
+ 220 CONTINUE
+ ELSE
+*
+* set E to zero if original matrix was diagonal
+*
+ DO 230 I = 1, N - 1
+ E( I ) = ZERO
+ 230 CONTINUE
+ END IF
+*
+* copy diagonal elements to D
+*
+ DO 240 I = 1, N
+ D( I ) = AB( 1, I )
+ 240 CONTINUE
+ END IF
+*
+ RETURN
+*
+* End of SSBTRD
+*
+ END
+ SUBROUTINE SSPCON( UPLO, N, AP, IPIV, ANORM, RCOND, WORK, IWORK,
+ $ INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* Modified to call SLACN2 in place of SLACON, 5 Feb 03, SJH.
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, N
+ REAL ANORM, RCOND
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * ), IWORK( * )
+ REAL AP( * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SSPCON estimates the reciprocal of the condition number (in the
+* 1-norm) of a real symmetric packed matrix A using the factorization
+* A = U*D*U**T or A = L*D*L**T computed by SSPTRF.
+*
+* An estimate is obtained for norm(inv(A)), and the reciprocal of the
+* condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).
+*
+* Arguments
+* =========
+*
+* UPLO (input) CHARACTER*1
+* Specifies whether the details of the factorization are stored
+* as an upper or lower triangular matrix.
+* = 'U': Upper triangular, form is A = U*D*U**T;
+* = 'L': Lower triangular, form is A = L*D*L**T.
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* AP (input) REAL array, dimension (N*(N+1)/2)
+* The block diagonal matrix D and the multipliers used to
+* obtain the factor U or L as computed by SSPTRF, stored as a
+* packed triangular matrix.
+*
+* IPIV (input) INTEGER array, dimension (N)
+* Details of the interchanges and the block structure of D
+* as determined by SSPTRF.
+*
+* ANORM (input) REAL
+* The 1-norm of the original matrix A.
+*
+* RCOND (output) REAL
+* The reciprocal of the condition number of the matrix A,
+* computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an
+* estimate of the 1-norm of inv(A) computed in this routine.
+*
+* WORK (workspace) REAL array, dimension (2*N)
+*
+* IWORK (workspace) INTEGER array, dimension (N)
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ONE, ZERO
+ PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL UPPER
+ INTEGER I, IP, KASE
+ REAL AINVNM
+* ..
+* .. Local Arrays ..
+ INTEGER ISAVE( 3 )
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL SLACN2, SSPTRS, XERBLA
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( ANORM.LT.ZERO ) THEN
+ INFO = -5
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SSPCON', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ RCOND = ZERO
+ IF( N.EQ.0 ) THEN
+ RCOND = ONE
+ RETURN
+ ELSE IF( ANORM.LE.ZERO ) THEN
+ RETURN
+ END IF
+*
+* Check that the diagonal matrix D is nonsingular.
+*
+ IF( UPPER ) THEN
+*
+* Upper triangular storage: examine D from bottom to top
+*
+ IP = N*( N+1 ) / 2
+ DO 10 I = N, 1, -1
+ IF( IPIV( I ).GT.0 .AND. AP( IP ).EQ.ZERO )
+ $ RETURN
+ IP = IP - I
+ 10 CONTINUE
+ ELSE
+*
+* Lower triangular storage: examine D from top to bottom.
+*
+ IP = 1
+ DO 20 I = 1, N
+ IF( IPIV( I ).GT.0 .AND. AP( IP ).EQ.ZERO )
+ $ RETURN
+ IP = IP + N - I + 1
+ 20 CONTINUE
+ END IF
+*
+* Estimate the 1-norm of the inverse.
+*
+ KASE = 0
+ 30 CONTINUE
+ CALL SLACN2( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE, ISAVE )
+ IF( KASE.NE.0 ) THEN
+*
+* Multiply by inv(L*D*L') or inv(U*D*U').
+*
+ CALL SSPTRS( UPLO, N, 1, AP, IPIV, WORK, N, INFO )
+ GO TO 30
+ END IF
+*
+* Compute the estimate of the reciprocal condition number.
+*
+ IF( AINVNM.NE.ZERO )
+ $ RCOND = ( ONE / AINVNM ) / ANORM
+*
+ RETURN
+*
+* End of SSPCON
+*
+ END
+ SUBROUTINE SSPEV( JOBZ, UPLO, N, AP, W, Z, LDZ, WORK, INFO )
+*
+* -- LAPACK driver routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER JOBZ, UPLO
+ INTEGER INFO, LDZ, N
+* ..
+* .. Array Arguments ..
+ REAL AP( * ), W( * ), WORK( * ), Z( LDZ, * )
+* ..
+*
+* Purpose
+* =======
+*
+* SSPEV computes all the eigenvalues and, optionally, eigenvectors of a
+* real symmetric matrix A in packed storage.
+*
+* Arguments
+* =========
+*
+* JOBZ (input) CHARACTER*1
+* = 'N': Compute eigenvalues only;
+* = 'V': Compute eigenvalues and eigenvectors.
+*
+* UPLO (input) CHARACTER*1
+* = 'U': Upper triangle of A is stored;
+* = 'L': Lower triangle of A is stored.
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* AP (input/output) REAL array, dimension (N*(N+1)/2)
+* On entry, the upper or lower triangle of the symmetric matrix
+* A, packed columnwise in a linear array. The j-th column of A
+* is stored in the array AP as follows:
+* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
+* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
+*
+* On exit, AP is overwritten by values generated during the
+* reduction to tridiagonal form. If UPLO = 'U', the diagonal
+* and first superdiagonal of the tridiagonal matrix T overwrite
+* the corresponding elements of A, and if UPLO = 'L', the
+* diagonal and first subdiagonal of T overwrite the
+* corresponding elements of A.
+*
+* W (output) REAL array, dimension (N)
+* If INFO = 0, the eigenvalues in ascending order.
+*
+* Z (output) REAL array, dimension (LDZ, N)
+* If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal
+* eigenvectors of the matrix A, with the i-th column of Z
+* holding the eigenvector associated with W(i).
+* If JOBZ = 'N', then Z is not referenced.
+*
+* LDZ (input) INTEGER
+* The leading dimension of the array Z. LDZ >= 1, and if
+* JOBZ = 'V', LDZ >= max(1,N).
+*
+* WORK (workspace) REAL array, dimension (3*N)
+*
+* INFO (output) INTEGER
+* = 0: successful exit.
+* < 0: if INFO = -i, the i-th argument had an illegal value.
+* > 0: if INFO = i, the algorithm failed to converge; i
+* off-diagonal elements of an intermediate tridiagonal
+* form did not converge to zero.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO, ONE
+ PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL WANTZ
+ INTEGER IINFO, IMAX, INDE, INDTAU, INDWRK, ISCALE
+ REAL ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA,
+ $ SMLNUM
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ REAL SLAMCH, SLANSP
+ EXTERNAL LSAME, SLAMCH, SLANSP
+* ..
+* .. External Subroutines ..
+ EXTERNAL SOPGTR, SSCAL, SSPTRD, SSTEQR, SSTERF, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC SQRT
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ WANTZ = LSAME( JOBZ, 'V' )
+*
+ INFO = 0
+ IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
+ INFO = -1
+ ELSE IF( .NOT.( LSAME( UPLO, 'U' ) .OR. LSAME( UPLO, 'L' ) ) )
+ $ THEN
+ INFO = -2
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
+ INFO = -7
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SSPEV ', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+ IF( N.EQ.1 ) THEN
+ W( 1 ) = AP( 1 )
+ IF( WANTZ )
+ $ Z( 1, 1 ) = ONE
+ RETURN
+ END IF
+*
+* Get machine constants.
+*
+ SAFMIN = SLAMCH( 'Safe minimum' )
+ EPS = SLAMCH( 'Precision' )
+ SMLNUM = SAFMIN / EPS
+ BIGNUM = ONE / SMLNUM
+ RMIN = SQRT( SMLNUM )
+ RMAX = SQRT( BIGNUM )
+*
+* Scale matrix to allowable range, if necessary.
+*
+ ANRM = SLANSP( 'M', UPLO, N, AP, WORK )
+ ISCALE = 0
+ IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN
+ ISCALE = 1
+ SIGMA = RMIN / ANRM
+ ELSE IF( ANRM.GT.RMAX ) THEN
+ ISCALE = 1
+ SIGMA = RMAX / ANRM
+ END IF
+ IF( ISCALE.EQ.1 ) THEN
+ CALL SSCAL( ( N*( N+1 ) ) / 2, SIGMA, AP, 1 )
+ END IF
+*
+* Call SSPTRD to reduce symmetric packed matrix to tridiagonal form.
+*
+ INDE = 1
+ INDTAU = INDE + N
+ CALL SSPTRD( UPLO, N, AP, W, WORK( INDE ), WORK( INDTAU ), IINFO )
+*
+* For eigenvalues only, call SSTERF. For eigenvectors, first call
+* SOPGTR to generate the orthogonal matrix, then call SSTEQR.
+*
+ IF( .NOT.WANTZ ) THEN
+ CALL SSTERF( N, W, WORK( INDE ), INFO )
+ ELSE
+ INDWRK = INDTAU + N
+ CALL SOPGTR( UPLO, N, AP, WORK( INDTAU ), Z, LDZ,
+ $ WORK( INDWRK ), IINFO )
+ CALL SSTEQR( JOBZ, N, W, WORK( INDE ), Z, LDZ, WORK( INDTAU ),
+ $ INFO )
+ END IF
+*
+* If matrix was scaled, then rescale eigenvalues appropriately.
+*
+ IF( ISCALE.EQ.1 ) THEN
+ IF( INFO.EQ.0 ) THEN
+ IMAX = N
+ ELSE
+ IMAX = INFO - 1
+ END IF
+ CALL SSCAL( IMAX, ONE / SIGMA, W, 1 )
+ END IF
+*
+ RETURN
+*
+* End of SSPEV
+*
+ END
+ SUBROUTINE SSPEVD( JOBZ, UPLO, N, AP, W, Z, LDZ, WORK, LWORK,
+ $ IWORK, LIWORK, INFO )
+*
+* -- LAPACK driver routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER JOBZ, UPLO
+ INTEGER INFO, LDZ, LIWORK, LWORK, N
+* ..
+* .. Array Arguments ..
+ INTEGER IWORK( * )
+ REAL AP( * ), W( * ), WORK( * ), Z( LDZ, * )
+* ..
+*
+* Purpose
+* =======
+*
+* SSPEVD computes all the eigenvalues and, optionally, eigenvectors
+* of a real symmetric matrix A in packed storage. If eigenvectors are
+* desired, it uses a divide and conquer algorithm.
+*
+* The divide and conquer algorithm makes very mild assumptions about
+* floating point arithmetic. It will work on machines with a guard
+* digit in add/subtract, or on those binary machines without guard
+* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
+* Cray-2. It could conceivably fail on hexadecimal or decimal machines
+* without guard digits, but we know of none.
+*
+* Arguments
+* =========
+*
+* JOBZ (input) CHARACTER*1
+* = 'N': Compute eigenvalues only;
+* = 'V': Compute eigenvalues and eigenvectors.
+*
+* UPLO (input) CHARACTER*1
+* = 'U': Upper triangle of A is stored;
+* = 'L': Lower triangle of A is stored.
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* AP (input/output) REAL array, dimension (N*(N+1)/2)
+* On entry, the upper or lower triangle of the symmetric matrix
+* A, packed columnwise in a linear array. The j-th column of A
+* is stored in the array AP as follows:
+* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
+* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
+*
+* On exit, AP is overwritten by values generated during the
+* reduction to tridiagonal form. If UPLO = 'U', the diagonal
+* and first superdiagonal of the tridiagonal matrix T overwrite
+* the corresponding elements of A, and if UPLO = 'L', the
+* diagonal and first subdiagonal of T overwrite the
+* corresponding elements of A.
+*
+* W (output) REAL array, dimension (N)
+* If INFO = 0, the eigenvalues in ascending order.
+*
+* Z (output) REAL array, dimension (LDZ, N)
+* If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal
+* eigenvectors of the matrix A, with the i-th column of Z
+* holding the eigenvector associated with W(i).
+* If JOBZ = 'N', then Z is not referenced.
+*
+* LDZ (input) INTEGER
+* The leading dimension of the array Z. LDZ >= 1, and if
+* JOBZ = 'V', LDZ >= max(1,N).
+*
+* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))
+* On exit, if INFO = 0, WORK(1) returns the required LWORK.
+*
+* LWORK (input) INTEGER
+* The dimension of the array WORK.
+* If N <= 1, LWORK must be at least 1.
+* If JOBZ = 'N' and N > 1, LWORK must be at least 2*N.
+* If JOBZ = 'V' and N > 1, LWORK must be at least
+* 1 + 6*N + N**2.
+*
+* If LWORK = -1, then a workspace query is assumed; the routine
+* only calculates the required sizes of the WORK and IWORK
+* arrays, returns these values as the first entries of the WORK
+* and IWORK arrays, and no error message related to LWORK or
+* LIWORK is issued by XERBLA.
+*
+* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))
+* On exit, if INFO = 0, IWORK(1) returns the required LIWORK.
+*
+* LIWORK (input) INTEGER
+* The dimension of the array IWORK.
+* If JOBZ = 'N' or N <= 1, LIWORK must be at least 1.
+* If JOBZ = 'V' and N > 1, LIWORK must be at least 3 + 5*N.
+*
+* If LIWORK = -1, then a workspace query is assumed; the
+* routine only calculates the required sizes of the WORK and
+* IWORK arrays, returns these values as the first entries of
+* the WORK and IWORK arrays, and no error message related to
+* LWORK or LIWORK is issued by XERBLA.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value.
+* > 0: if INFO = i, the algorithm failed to converge; i
+* off-diagonal elements of an intermediate tridiagonal
+* form did not converge to zero.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO, ONE
+ PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL LQUERY, WANTZ
+ INTEGER IINFO, INDE, INDTAU, INDWRK, ISCALE, LIWMIN,
+ $ LLWORK, LWMIN
+ REAL ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA,
+ $ SMLNUM
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ REAL SLAMCH, SLANSP
+ EXTERNAL LSAME, SLAMCH, SLANSP
+* ..
+* .. External Subroutines ..
+ EXTERNAL SOPMTR, SSCAL, SSPTRD, SSTEDC, SSTERF, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC SQRT
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ WANTZ = LSAME( JOBZ, 'V' )
+ LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 )
+*
+ INFO = 0
+ IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
+ INFO = -1
+ ELSE IF( .NOT.( LSAME( UPLO, 'U' ) .OR. LSAME( UPLO, 'L' ) ) )
+ $ THEN
+ INFO = -2
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
+ INFO = -7
+ END IF
+*
+ IF( INFO.EQ.0 ) THEN
+ IF( N.LE.1 ) THEN
+ LIWMIN = 1
+ LWMIN = 1
+ ELSE
+ IF( WANTZ ) THEN
+ LIWMIN = 3 + 5*N
+ LWMIN = 1 + 6*N + N**2
+ ELSE
+ LIWMIN = 1
+ LWMIN = 2*N
+ END IF
+ END IF
+ IWORK( 1 ) = LIWMIN
+ WORK( 1 ) = LWMIN
+*
+ IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
+ INFO = -9
+ ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN
+ INFO = -11
+ END IF
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SSPEVD', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+ IF( N.EQ.1 ) THEN
+ W( 1 ) = AP( 1 )
+ IF( WANTZ )
+ $ Z( 1, 1 ) = ONE
+ RETURN
+ END IF
+*
+* Get machine constants.
+*
+ SAFMIN = SLAMCH( 'Safe minimum' )
+ EPS = SLAMCH( 'Precision' )
+ SMLNUM = SAFMIN / EPS
+ BIGNUM = ONE / SMLNUM
+ RMIN = SQRT( SMLNUM )
+ RMAX = SQRT( BIGNUM )
+*
+* Scale matrix to allowable range, if necessary.
+*
+ ANRM = SLANSP( 'M', UPLO, N, AP, WORK )
+ ISCALE = 0
+ IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN
+ ISCALE = 1
+ SIGMA = RMIN / ANRM
+ ELSE IF( ANRM.GT.RMAX ) THEN
+ ISCALE = 1
+ SIGMA = RMAX / ANRM
+ END IF
+ IF( ISCALE.EQ.1 ) THEN
+ CALL SSCAL( ( N*( N+1 ) ) / 2, SIGMA, AP, 1 )
+ END IF
+*
+* Call SSPTRD to reduce symmetric packed matrix to tridiagonal form.
+*
+ INDE = 1
+ INDTAU = INDE + N
+ CALL SSPTRD( UPLO, N, AP, W, WORK( INDE ), WORK( INDTAU ), IINFO )
+*
+* For eigenvalues only, call SSTERF. For eigenvectors, first call
+* SSTEDC to generate the eigenvector matrix, WORK(INDWRK), of the
+* tridiagonal matrix, then call SOPMTR to multiply it by the
+* Householder transformations represented in AP.
+*
+ IF( .NOT.WANTZ ) THEN
+ CALL SSTERF( N, W, WORK( INDE ), INFO )
+ ELSE
+ INDWRK = INDTAU + N
+ LLWORK = LWORK - INDWRK + 1
+ CALL SSTEDC( 'I', N, W, WORK( INDE ), Z, LDZ, WORK( INDWRK ),
+ $ LLWORK, IWORK, LIWORK, INFO )
+ CALL SOPMTR( 'L', UPLO, 'N', N, N, AP, WORK( INDTAU ), Z, LDZ,
+ $ WORK( INDWRK ), IINFO )
+ END IF
+*
+* If matrix was scaled, then rescale eigenvalues appropriately.
+*
+ IF( ISCALE.EQ.1 )
+ $ CALL SSCAL( N, ONE / SIGMA, W, 1 )
+*
+ WORK( 1 ) = LWMIN
+ IWORK( 1 ) = LIWMIN
+ RETURN
+*
+* End of SSPEVD
+*
+ END
+ SUBROUTINE SSPEVX( JOBZ, RANGE, UPLO, N, AP, VL, VU, IL, IU,
+ $ ABSTOL, M, W, Z, LDZ, WORK, IWORK, IFAIL,
+ $ INFO )
+*
+* -- LAPACK driver routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER JOBZ, RANGE, UPLO
+ INTEGER IL, INFO, IU, LDZ, M, N
+ REAL ABSTOL, VL, VU
+* ..
+* .. Array Arguments ..
+ INTEGER IFAIL( * ), IWORK( * )
+ REAL AP( * ), W( * ), WORK( * ), Z( LDZ, * )
+* ..
+*
+* Purpose
+* =======
+*
+* SSPEVX computes selected eigenvalues and, optionally, eigenvectors
+* of a real symmetric matrix A in packed storage. Eigenvalues/vectors
+* can be selected by specifying either a range of values or a range of
+* indices for the desired eigenvalues.
+*
+* Arguments
+* =========
+*
+* JOBZ (input) CHARACTER*1
+* = 'N': Compute eigenvalues only;
+* = 'V': Compute eigenvalues and eigenvectors.
+*
+* RANGE (input) CHARACTER*1
+* = 'A': all eigenvalues will be found;
+* = 'V': all eigenvalues in the half-open interval (VL,VU]
+* will be found;
+* = 'I': the IL-th through IU-th eigenvalues will be found.
+*
+* UPLO (input) CHARACTER*1
+* = 'U': Upper triangle of A is stored;
+* = 'L': Lower triangle of A is stored.
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* AP (input/output) REAL array, dimension (N*(N+1)/2)
+* On entry, the upper or lower triangle of the symmetric matrix
+* A, packed columnwise in a linear array. The j-th column of A
+* is stored in the array AP as follows:
+* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
+* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
+*
+* On exit, AP is overwritten by values generated during the
+* reduction to tridiagonal form. If UPLO = 'U', the diagonal
+* and first superdiagonal of the tridiagonal matrix T overwrite
+* the corresponding elements of A, and if UPLO = 'L', the
+* diagonal and first subdiagonal of T overwrite the
+* corresponding elements of A.
+*
+* VL (input) REAL
+* VU (input) REAL
+* If RANGE='V', the lower and upper bounds of the interval to
+* be searched for eigenvalues. VL < VU.
+* Not referenced if RANGE = 'A' or 'I'.
+*
+* IL (input) INTEGER
+* IU (input) INTEGER
+* If RANGE='I', the indices (in ascending order) of the
+* smallest and largest eigenvalues to be returned.
+* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
+* Not referenced if RANGE = 'A' or 'V'.
+*
+* ABSTOL (input) REAL
+* The absolute error tolerance for the eigenvalues.
+* An approximate eigenvalue is accepted as converged
+* when it is determined to lie in an interval [a,b]
+* of width less than or equal to
+*
+* ABSTOL + EPS * max( |a|,|b| ) ,
+*
+* where EPS is the machine precision. If ABSTOL is less than
+* or equal to zero, then EPS*|T| will be used in its place,
+* where |T| is the 1-norm of the tridiagonal matrix obtained
+* by reducing AP to tridiagonal form.
+*
+* Eigenvalues will be computed most accurately when ABSTOL is
+* set to twice the underflow threshold 2*SLAMCH('S'), not zero.
+* If this routine returns with INFO>0, indicating that some
+* eigenvectors did not converge, try setting ABSTOL to
+* 2*SLAMCH('S').
+*
+* See "Computing Small Singular Values of Bidiagonal Matrices
+* with Guaranteed High Relative Accuracy," by Demmel and
+* Kahan, LAPACK Working Note #3.
+*
+* M (output) INTEGER
+* The total number of eigenvalues found. 0 <= M <= N.
+* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
+*
+* W (output) REAL array, dimension (N)
+* If INFO = 0, the selected eigenvalues in ascending order.
+*
+* Z (output) REAL array, dimension (LDZ, max(1,M))
+* If JOBZ = 'V', then if INFO = 0, the first M columns of Z
+* contain the orthonormal eigenvectors of the matrix A
+* corresponding to the selected eigenvalues, with the i-th
+* column of Z holding the eigenvector associated with W(i).
+* If an eigenvector fails to converge, then that column of Z
+* contains the latest approximation to the eigenvector, and the
+* index of the eigenvector is returned in IFAIL.
+* If JOBZ = 'N', then Z is not referenced.
+* Note: the user must ensure that at least max(1,M) columns are
+* supplied in the array Z; if RANGE = 'V', the exact value of M
+* is not known in advance and an upper bound must be used.
+*
+* LDZ (input) INTEGER
+* The leading dimension of the array Z. LDZ >= 1, and if
+* JOBZ = 'V', LDZ >= max(1,N).
+*
+* WORK (workspace) REAL array, dimension (8*N)
+*
+* IWORK (workspace) INTEGER array, dimension (5*N)
+*
+* IFAIL (output) INTEGER array, dimension (N)
+* If JOBZ = 'V', then if INFO = 0, the first M elements of
+* IFAIL are zero. If INFO > 0, then IFAIL contains the
+* indices of the eigenvectors that failed to converge.
+* If JOBZ = 'N', then IFAIL is not referenced.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* > 0: if INFO = i, then i eigenvectors failed to converge.
+* Their indices are stored in array IFAIL.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO, ONE
+ PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL ALLEIG, INDEIG, TEST, VALEIG, WANTZ
+ CHARACTER ORDER
+ INTEGER I, IINFO, IMAX, INDD, INDE, INDEE, INDIBL,
+ $ INDISP, INDIWO, INDTAU, INDWRK, ISCALE, ITMP1,
+ $ J, JJ, NSPLIT
+ REAL ABSTLL, ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN,
+ $ SIGMA, SMLNUM, TMP1, VLL, VUU
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ REAL SLAMCH, SLANSP
+ EXTERNAL LSAME, SLAMCH, SLANSP
+* ..
+* .. External Subroutines ..
+ EXTERNAL SCOPY, SOPGTR, SOPMTR, SSCAL, SSPTRD, SSTEBZ,
+ $ SSTEIN, SSTEQR, SSTERF, SSWAP, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN, SQRT
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ WANTZ = LSAME( JOBZ, 'V' )
+ ALLEIG = LSAME( RANGE, 'A' )
+ VALEIG = LSAME( RANGE, 'V' )
+ INDEIG = LSAME( RANGE, 'I' )
+*
+ INFO = 0
+ IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
+ INFO = -1
+ ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN
+ INFO = -2
+ ELSE IF( .NOT.( LSAME( UPLO, 'L' ) .OR. LSAME( UPLO, 'U' ) ) )
+ $ THEN
+ INFO = -3
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -4
+ ELSE
+ IF( VALEIG ) THEN
+ IF( N.GT.0 .AND. VU.LE.VL )
+ $ INFO = -7
+ ELSE IF( INDEIG ) THEN
+ IF( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) THEN
+ INFO = -8
+ ELSE IF( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) THEN
+ INFO = -9
+ END IF
+ END IF
+ END IF
+ IF( INFO.EQ.0 ) THEN
+ IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) )
+ $ INFO = -14
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SSPEVX', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ M = 0
+ IF( N.EQ.0 )
+ $ RETURN
+*
+ IF( N.EQ.1 ) THEN
+ IF( ALLEIG .OR. INDEIG ) THEN
+ M = 1
+ W( 1 ) = AP( 1 )
+ ELSE
+ IF( VL.LT.AP( 1 ) .AND. VU.GE.AP( 1 ) ) THEN
+ M = 1
+ W( 1 ) = AP( 1 )
+ END IF
+ END IF
+ IF( WANTZ )
+ $ Z( 1, 1 ) = ONE
+ RETURN
+ END IF
+*
+* Get machine constants.
+*
+ SAFMIN = SLAMCH( 'Safe minimum' )
+ EPS = SLAMCH( 'Precision' )
+ SMLNUM = SAFMIN / EPS
+ BIGNUM = ONE / SMLNUM
+ RMIN = SQRT( SMLNUM )
+ RMAX = MIN( SQRT( BIGNUM ), ONE / SQRT( SQRT( SAFMIN ) ) )
+*
+* Scale matrix to allowable range, if necessary.
+*
+ ISCALE = 0
+ ABSTLL = ABSTOL
+ IF ( VALEIG ) THEN
+ VLL = VL
+ VUU = VU
+ ELSE
+ VLL = ZERO
+ VUU = ZERO
+ ENDIF
+ ANRM = SLANSP( 'M', UPLO, N, AP, WORK )
+ IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN
+ ISCALE = 1
+ SIGMA = RMIN / ANRM
+ ELSE IF( ANRM.GT.RMAX ) THEN
+ ISCALE = 1
+ SIGMA = RMAX / ANRM
+ END IF
+ IF( ISCALE.EQ.1 ) THEN
+ CALL SSCAL( ( N*( N+1 ) ) / 2, SIGMA, AP, 1 )
+ IF( ABSTOL.GT.0 )
+ $ ABSTLL = ABSTOL*SIGMA
+ IF( VALEIG ) THEN
+ VLL = VL*SIGMA
+ VUU = VU*SIGMA
+ END IF
+ END IF
+*
+* Call SSPTRD to reduce symmetric packed matrix to tridiagonal form.
+*
+ INDTAU = 1
+ INDE = INDTAU + N
+ INDD = INDE + N
+ INDWRK = INDD + N
+ CALL SSPTRD( UPLO, N, AP, WORK( INDD ), WORK( INDE ),
+ $ WORK( INDTAU ), IINFO )
+*
+* If all eigenvalues are desired and ABSTOL is less than or equal
+* to zero, then call SSTERF or SOPGTR and SSTEQR. If this fails
+* for some eigenvalue, then try SSTEBZ.
+*
+ TEST = .FALSE.
+ IF (INDEIG) THEN
+ IF (IL.EQ.1 .AND. IU.EQ.N) THEN
+ TEST = .TRUE.
+ END IF
+ END IF
+ IF ((ALLEIG .OR. TEST) .AND. (ABSTOL.LE.ZERO)) THEN
+ CALL SCOPY( N, WORK( INDD ), 1, W, 1 )
+ INDEE = INDWRK + 2*N
+ IF( .NOT.WANTZ ) THEN
+ CALL SCOPY( N-1, WORK( INDE ), 1, WORK( INDEE ), 1 )
+ CALL SSTERF( N, W, WORK( INDEE ), INFO )
+ ELSE
+ CALL SOPGTR( UPLO, N, AP, WORK( INDTAU ), Z, LDZ,
+ $ WORK( INDWRK ), IINFO )
+ CALL SCOPY( N-1, WORK( INDE ), 1, WORK( INDEE ), 1 )
+ CALL SSTEQR( JOBZ, N, W, WORK( INDEE ), Z, LDZ,
+ $ WORK( INDWRK ), INFO )
+ IF( INFO.EQ.0 ) THEN
+ DO 10 I = 1, N
+ IFAIL( I ) = 0
+ 10 CONTINUE
+ END IF
+ END IF
+ IF( INFO.EQ.0 ) THEN
+ M = N
+ GO TO 20
+ END IF
+ INFO = 0
+ END IF
+*
+* Otherwise, call SSTEBZ and, if eigenvectors are desired, SSTEIN.
+*
+ IF( WANTZ ) THEN
+ ORDER = 'B'
+ ELSE
+ ORDER = 'E'
+ END IF
+ INDIBL = 1
+ INDISP = INDIBL + N
+ INDIWO = INDISP + N
+ CALL SSTEBZ( RANGE, ORDER, N, VLL, VUU, IL, IU, ABSTLL,
+ $ WORK( INDD ), WORK( INDE ), M, NSPLIT, W,
+ $ IWORK( INDIBL ), IWORK( INDISP ), WORK( INDWRK ),
+ $ IWORK( INDIWO ), INFO )
+*
+ IF( WANTZ ) THEN
+ CALL SSTEIN( N, WORK( INDD ), WORK( INDE ), M, W,
+ $ IWORK( INDIBL ), IWORK( INDISP ), Z, LDZ,
+ $ WORK( INDWRK ), IWORK( INDIWO ), IFAIL, INFO )
+*
+* Apply orthogonal matrix used in reduction to tridiagonal
+* form to eigenvectors returned by SSTEIN.
+*
+ CALL SOPMTR( 'L', UPLO, 'N', N, M, AP, WORK( INDTAU ), Z, LDZ,
+ $ WORK( INDWRK ), INFO )
+ END IF
+*
+* If matrix was scaled, then rescale eigenvalues appropriately.
+*
+ 20 CONTINUE
+ IF( ISCALE.EQ.1 ) THEN
+ IF( INFO.EQ.0 ) THEN
+ IMAX = M
+ ELSE
+ IMAX = INFO - 1
+ END IF
+ CALL SSCAL( IMAX, ONE / SIGMA, W, 1 )
+ END IF
+*
+* If eigenvalues are not in order, then sort them, along with
+* eigenvectors.
+*
+ IF( WANTZ ) THEN
+ DO 40 J = 1, M - 1
+ I = 0
+ TMP1 = W( J )
+ DO 30 JJ = J + 1, M
+ IF( W( JJ ).LT.TMP1 ) THEN
+ I = JJ
+ TMP1 = W( JJ )
+ END IF
+ 30 CONTINUE
+*
+ IF( I.NE.0 ) THEN
+ ITMP1 = IWORK( INDIBL+I-1 )
+ W( I ) = W( J )
+ IWORK( INDIBL+I-1 ) = IWORK( INDIBL+J-1 )
+ W( J ) = TMP1
+ IWORK( INDIBL+J-1 ) = ITMP1
+ CALL SSWAP( N, Z( 1, I ), 1, Z( 1, J ), 1 )
+ IF( INFO.NE.0 ) THEN
+ ITMP1 = IFAIL( I )
+ IFAIL( I ) = IFAIL( J )
+ IFAIL( J ) = ITMP1
+ END IF
+ END IF
+ 40 CONTINUE
+ END IF
+*
+ RETURN
+*
+* End of SSPEVX
+*
+ END
+ SUBROUTINE SSPGST( ITYPE, UPLO, N, AP, BP, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, ITYPE, N
+* ..
+* .. Array Arguments ..
+ REAL AP( * ), BP( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SSPGST reduces a real symmetric-definite generalized eigenproblem
+* to standard form, using packed storage.
+*
+* If ITYPE = 1, the problem is A*x = lambda*B*x,
+* and A is overwritten by inv(U**T)*A*inv(U) or inv(L)*A*inv(L**T)
+*
+* If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or
+* B*A*x = lambda*x, and A is overwritten by U*A*U**T or L**T*A*L.
+*
+* B must have been previously factorized as U**T*U or L*L**T by SPPTRF.
+*
+* Arguments
+* =========
+*
+* ITYPE (input) INTEGER
+* = 1: compute inv(U**T)*A*inv(U) or inv(L)*A*inv(L**T);
+* = 2 or 3: compute U*A*U**T or L**T*A*L.
+*
+* UPLO (input) CHARACTER*1
+* = 'U': Upper triangle of A is stored and B is factored as
+* U**T*U;
+* = 'L': Lower triangle of A is stored and B is factored as
+* L*L**T.
+*
+* N (input) INTEGER
+* The order of the matrices A and B. N >= 0.
+*
+* AP (input/output) REAL array, dimension (N*(N+1)/2)
+* On entry, the upper or lower triangle of the symmetric matrix
+* A, packed columnwise in a linear array. The j-th column of A
+* is stored in the array AP as follows:
+* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
+* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
+*
+* On exit, if INFO = 0, the transformed matrix, stored in the
+* same format as A.
+*
+* BP (input) REAL array, dimension (N*(N+1)/2)
+* The triangular factor from the Cholesky factorization of B,
+* stored in the same format as A, as returned by SPPTRF.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ONE, HALF
+ PARAMETER ( ONE = 1.0, HALF = 0.5 )
+* ..
+* .. Local Scalars ..
+ LOGICAL UPPER
+ INTEGER J, J1, J1J1, JJ, K, K1, K1K1, KK
+ REAL AJJ, AKK, BJJ, BKK, CT
+* ..
+* .. External Subroutines ..
+ EXTERNAL SAXPY, SSCAL, SSPMV, SSPR2, STPMV, STPSV,
+ $ XERBLA
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ REAL SDOT
+ EXTERNAL LSAME, SDOT
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN
+ INFO = -1
+ ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -2
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -3
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SSPGST', -INFO )
+ RETURN
+ END IF
+*
+ IF( ITYPE.EQ.1 ) THEN
+ IF( UPPER ) THEN
+*
+* Compute inv(U')*A*inv(U)
+*
+* J1 and JJ are the indices of A(1,j) and A(j,j)
+*
+ JJ = 0
+ DO 10 J = 1, N
+ J1 = JJ + 1
+ JJ = JJ + J
+*
+* Compute the j-th column of the upper triangle of A
+*
+ BJJ = BP( JJ )
+ CALL STPSV( UPLO, 'Transpose', 'Nonunit', J, BP,
+ $ AP( J1 ), 1 )
+ CALL SSPMV( UPLO, J-1, -ONE, AP, BP( J1 ), 1, ONE,
+ $ AP( J1 ), 1 )
+ CALL SSCAL( J-1, ONE / BJJ, AP( J1 ), 1 )
+ AP( JJ ) = ( AP( JJ )-SDOT( J-1, AP( J1 ), 1, BP( J1 ),
+ $ 1 ) ) / BJJ
+ 10 CONTINUE
+ ELSE
+*
+* Compute inv(L)*A*inv(L')
+*
+* KK and K1K1 are the indices of A(k,k) and A(k+1,k+1)
+*
+ KK = 1
+ DO 20 K = 1, N
+ K1K1 = KK + N - K + 1
+*
+* Update the lower triangle of A(k:n,k:n)
+*
+ AKK = AP( KK )
+ BKK = BP( KK )
+ AKK = AKK / BKK**2
+ AP( KK ) = AKK
+ IF( K.LT.N ) THEN
+ CALL SSCAL( N-K, ONE / BKK, AP( KK+1 ), 1 )
+ CT = -HALF*AKK
+ CALL SAXPY( N-K, CT, BP( KK+1 ), 1, AP( KK+1 ), 1 )
+ CALL SSPR2( UPLO, N-K, -ONE, AP( KK+1 ), 1,
+ $ BP( KK+1 ), 1, AP( K1K1 ) )
+ CALL SAXPY( N-K, CT, BP( KK+1 ), 1, AP( KK+1 ), 1 )
+ CALL STPSV( UPLO, 'No transpose', 'Non-unit', N-K,
+ $ BP( K1K1 ), AP( KK+1 ), 1 )
+ END IF
+ KK = K1K1
+ 20 CONTINUE
+ END IF
+ ELSE
+ IF( UPPER ) THEN
+*
+* Compute U*A*U'
+*
+* K1 and KK are the indices of A(1,k) and A(k,k)
+*
+ KK = 0
+ DO 30 K = 1, N
+ K1 = KK + 1
+ KK = KK + K
+*
+* Update the upper triangle of A(1:k,1:k)
+*
+ AKK = AP( KK )
+ BKK = BP( KK )
+ CALL STPMV( UPLO, 'No transpose', 'Non-unit', K-1, BP,
+ $ AP( K1 ), 1 )
+ CT = HALF*AKK
+ CALL SAXPY( K-1, CT, BP( K1 ), 1, AP( K1 ), 1 )
+ CALL SSPR2( UPLO, K-1, ONE, AP( K1 ), 1, BP( K1 ), 1,
+ $ AP )
+ CALL SAXPY( K-1, CT, BP( K1 ), 1, AP( K1 ), 1 )
+ CALL SSCAL( K-1, BKK, AP( K1 ), 1 )
+ AP( KK ) = AKK*BKK**2
+ 30 CONTINUE
+ ELSE
+*
+* Compute L'*A*L
+*
+* JJ and J1J1 are the indices of A(j,j) and A(j+1,j+1)
+*
+ JJ = 1
+ DO 40 J = 1, N
+ J1J1 = JJ + N - J + 1
+*
+* Compute the j-th column of the lower triangle of A
+*
+ AJJ = AP( JJ )
+ BJJ = BP( JJ )
+ AP( JJ ) = AJJ*BJJ + SDOT( N-J, AP( JJ+1 ), 1,
+ $ BP( JJ+1 ), 1 )
+ CALL SSCAL( N-J, BJJ, AP( JJ+1 ), 1 )
+ CALL SSPMV( UPLO, N-J, ONE, AP( J1J1 ), BP( JJ+1 ), 1,
+ $ ONE, AP( JJ+1 ), 1 )
+ CALL STPMV( UPLO, 'Transpose', 'Non-unit', N-J+1,
+ $ BP( JJ ), AP( JJ ), 1 )
+ JJ = J1J1
+ 40 CONTINUE
+ END IF
+ END IF
+ RETURN
+*
+* End of SSPGST
+*
+ END
+ SUBROUTINE SSPGV( ITYPE, JOBZ, UPLO, N, AP, BP, W, Z, LDZ, WORK,
+ $ INFO )
+*
+* -- LAPACK driver routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER JOBZ, UPLO
+ INTEGER INFO, ITYPE, LDZ, N
+* ..
+* .. Array Arguments ..
+ REAL AP( * ), BP( * ), W( * ), WORK( * ),
+ $ Z( LDZ, * )
+* ..
+*
+* Purpose
+* =======
+*
+* SSPGV computes all the eigenvalues and, optionally, the eigenvectors
+* of a real generalized symmetric-definite eigenproblem, of the form
+* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x.
+* Here A and B are assumed to be symmetric, stored in packed format,
+* and B is also positive definite.
+*
+* Arguments
+* =========
+*
+* ITYPE (input) INTEGER
+* Specifies the problem type to be solved:
+* = 1: A*x = (lambda)*B*x
+* = 2: A*B*x = (lambda)*x
+* = 3: B*A*x = (lambda)*x
+*
+* JOBZ (input) CHARACTER*1
+* = 'N': Compute eigenvalues only;
+* = 'V': Compute eigenvalues and eigenvectors.
+*
+* UPLO (input) CHARACTER*1
+* = 'U': Upper triangles of A and B are stored;
+* = 'L': Lower triangles of A and B are stored.
+*
+* N (input) INTEGER
+* The order of the matrices A and B. N >= 0.
+*
+* AP (input/output) REAL array, dimension
+* (N*(N+1)/2)
+* On entry, the upper or lower triangle of the symmetric matrix
+* A, packed columnwise in a linear array. The j-th column of A
+* is stored in the array AP as follows:
+* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
+* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
+*
+* On exit, the contents of AP are destroyed.
+*
+* BP (input/output) REAL array, dimension (N*(N+1)/2)
+* On entry, the upper or lower triangle of the symmetric matrix
+* B, packed columnwise in a linear array. The j-th column of B
+* is stored in the array BP as follows:
+* if UPLO = 'U', BP(i + (j-1)*j/2) = B(i,j) for 1<=i<=j;
+* if UPLO = 'L', BP(i + (j-1)*(2*n-j)/2) = B(i,j) for j<=i<=n.
+*
+* On exit, the triangular factor U or L from the Cholesky
+* factorization B = U**T*U or B = L*L**T, in the same storage
+* format as B.
+*
+* W (output) REAL array, dimension (N)
+* If INFO = 0, the eigenvalues in ascending order.
+*
+* Z (output) REAL array, dimension (LDZ, N)
+* If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of
+* eigenvectors. The eigenvectors are normalized as follows:
+* if ITYPE = 1 or 2, Z**T*B*Z = I;
+* if ITYPE = 3, Z**T*inv(B)*Z = I.
+* If JOBZ = 'N', then Z is not referenced.
+*
+* LDZ (input) INTEGER
+* The leading dimension of the array Z. LDZ >= 1, and if
+* JOBZ = 'V', LDZ >= max(1,N).
+*
+* WORK (workspace) REAL array, dimension (3*N)
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* > 0: SPPTRF or SSPEV returned an error code:
+* <= N: if INFO = i, SSPEV failed to converge;
+* i off-diagonal elements of an intermediate
+* tridiagonal form did not converge to zero.
+* > N: if INFO = n + i, for 1 <= i <= n, then the leading
+* minor of order i of B is not positive definite.
+* The factorization of B could not be completed and
+* no eigenvalues or eigenvectors were computed.
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ LOGICAL UPPER, WANTZ
+ CHARACTER TRANS
+ INTEGER J, NEIG
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL SPPTRF, SSPEV, SSPGST, STPMV, STPSV, XERBLA
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ WANTZ = LSAME( JOBZ, 'V' )
+ UPPER = LSAME( UPLO, 'U' )
+*
+ INFO = 0
+ IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN
+ INFO = -1
+ ELSE IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
+ INFO = -2
+ ELSE IF( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN
+ INFO = -3
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
+ INFO = -9
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SSPGV ', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+* Form a Cholesky factorization of B.
+*
+ CALL SPPTRF( UPLO, N, BP, INFO )
+ IF( INFO.NE.0 ) THEN
+ INFO = N + INFO
+ RETURN
+ END IF
+*
+* Transform problem to standard eigenvalue problem and solve.
+*
+ CALL SSPGST( ITYPE, UPLO, N, AP, BP, INFO )
+ CALL SSPEV( JOBZ, UPLO, N, AP, W, Z, LDZ, WORK, INFO )
+*
+ IF( WANTZ ) THEN
+*
+* Backtransform eigenvectors to the original problem.
+*
+ NEIG = N
+ IF( INFO.GT.0 )
+ $ NEIG = INFO - 1
+ IF( ITYPE.EQ.1 .OR. ITYPE.EQ.2 ) THEN
+*
+* For A*x=(lambda)*B*x and A*B*x=(lambda)*x;
+* backtransform eigenvectors: x = inv(L)'*y or inv(U)*y
+*
+ IF( UPPER ) THEN
+ TRANS = 'N'
+ ELSE
+ TRANS = 'T'
+ END IF
+*
+ DO 10 J = 1, NEIG
+ CALL STPSV( UPLO, TRANS, 'Non-unit', N, BP, Z( 1, J ),
+ $ 1 )
+ 10 CONTINUE
+*
+ ELSE IF( ITYPE.EQ.3 ) THEN
+*
+* For B*A*x=(lambda)*x;
+* backtransform eigenvectors: x = L*y or U'*y
+*
+ IF( UPPER ) THEN
+ TRANS = 'T'
+ ELSE
+ TRANS = 'N'
+ END IF
+*
+ DO 20 J = 1, NEIG
+ CALL STPMV( UPLO, TRANS, 'Non-unit', N, BP, Z( 1, J ),
+ $ 1 )
+ 20 CONTINUE
+ END IF
+ END IF
+ RETURN
+*
+* End of SSPGV
+*
+ END
+ SUBROUTINE SSPGVD( ITYPE, JOBZ, UPLO, N, AP, BP, W, Z, LDZ, WORK,
+ $ LWORK, IWORK, LIWORK, INFO )
+*
+* -- LAPACK driver routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER JOBZ, UPLO
+ INTEGER INFO, ITYPE, LDZ, LIWORK, LWORK, N
+* ..
+* .. Array Arguments ..
+ INTEGER IWORK( * )
+ REAL AP( * ), BP( * ), W( * ), WORK( * ),
+ $ Z( LDZ, * )
+* ..
+*
+* Purpose
+* =======
+*
+* SSPGVD computes all the eigenvalues, and optionally, the eigenvectors
+* of a real generalized symmetric-definite eigenproblem, of the form
+* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A and
+* B are assumed to be symmetric, stored in packed format, and B is also
+* positive definite.
+* If eigenvectors are desired, it uses a divide and conquer algorithm.
+*
+* The divide and conquer algorithm makes very mild assumptions about
+* floating point arithmetic. It will work on machines with a guard
+* digit in add/subtract, or on those binary machines without guard
+* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
+* Cray-2. It could conceivably fail on hexadecimal or decimal machines
+* without guard digits, but we know of none.
+*
+* Arguments
+* =========
+*
+* ITYPE (input) INTEGER
+* Specifies the problem type to be solved:
+* = 1: A*x = (lambda)*B*x
+* = 2: A*B*x = (lambda)*x
+* = 3: B*A*x = (lambda)*x
+*
+* JOBZ (input) CHARACTER*1
+* = 'N': Compute eigenvalues only;
+* = 'V': Compute eigenvalues and eigenvectors.
+*
+* UPLO (input) CHARACTER*1
+* = 'U': Upper triangles of A and B are stored;
+* = 'L': Lower triangles of A and B are stored.
+*
+* N (input) INTEGER
+* The order of the matrices A and B. N >= 0.
+*
+* AP (input/output) REAL array, dimension (N*(N+1)/2)
+* On entry, the upper or lower triangle of the symmetric matrix
+* A, packed columnwise in a linear array. The j-th column of A
+* is stored in the array AP as follows:
+* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
+* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
+*
+* On exit, the contents of AP are destroyed.
+*
+* BP (input/output) REAL array, dimension (N*(N+1)/2)
+* On entry, the upper or lower triangle of the symmetric matrix
+* B, packed columnwise in a linear array. The j-th column of B
+* is stored in the array BP as follows:
+* if UPLO = 'U', BP(i + (j-1)*j/2) = B(i,j) for 1<=i<=j;
+* if UPLO = 'L', BP(i + (j-1)*(2*n-j)/2) = B(i,j) for j<=i<=n.
+*
+* On exit, the triangular factor U or L from the Cholesky
+* factorization B = U**T*U or B = L*L**T, in the same storage
+* format as B.
+*
+* W (output) REAL array, dimension (N)
+* If INFO = 0, the eigenvalues in ascending order.
+*
+* Z (output) REAL array, dimension (LDZ, N)
+* If JOBZ = 'V', then if INFO = 0, Z contains the matrix Z of
+* eigenvectors. The eigenvectors are normalized as follows:
+* if ITYPE = 1 or 2, Z**T*B*Z = I;
+* if ITYPE = 3, Z**T*inv(B)*Z = I.
+* If JOBZ = 'N', then Z is not referenced.
+*
+* LDZ (input) INTEGER
+* The leading dimension of the array Z. LDZ >= 1, and if
+* JOBZ = 'V', LDZ >= max(1,N).
+*
+* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))
+* On exit, if INFO = 0, WORK(1) returns the required LWORK.
+*
+* LWORK (input) INTEGER
+* The dimension of the array WORK.
+* If N <= 1, LWORK >= 1.
+* If JOBZ = 'N' and N > 1, LWORK >= 2*N.
+* If JOBZ = 'V' and N > 1, LWORK >= 1 + 6*N + 2*N**2.
+*
+* If LWORK = -1, then a workspace query is assumed; the routine
+* only calculates the required sizes of the WORK and IWORK
+* arrays, returns these values as the first entries of the WORK
+* and IWORK arrays, and no error message related to LWORK or
+* LIWORK is issued by XERBLA.
+*
+* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))
+* On exit, if INFO = 0, IWORK(1) returns the required LIWORK.
+*
+* LIWORK (input) INTEGER
+* The dimension of the array IWORK.
+* If JOBZ = 'N' or N <= 1, LIWORK >= 1.
+* If JOBZ = 'V' and N > 1, LIWORK >= 3 + 5*N.
+*
+* If LIWORK = -1, then a workspace query is assumed; the
+* routine only calculates the required sizes of the WORK and
+* IWORK arrays, returns these values as the first entries of
+* the WORK and IWORK arrays, and no error message related to
+* LWORK or LIWORK is issued by XERBLA.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* > 0: SPPTRF or SSPEVD returned an error code:
+* <= N: if INFO = i, SSPEVD failed to converge;
+* i off-diagonal elements of an intermediate
+* tridiagonal form did not converge to zero;
+* > N: if INFO = N + i, for 1 <= i <= N, then the leading
+* minor of order i of B is not positive definite.
+* The factorization of B could not be completed and
+* no eigenvalues or eigenvectors were computed.
+*
+* Further Details
+* ===============
+*
+* Based on contributions by
+* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL TWO
+ PARAMETER ( TWO = 2.0E+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL LQUERY, UPPER, WANTZ
+ CHARACTER TRANS
+ INTEGER J, LIWMIN, LWMIN, NEIG
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL SPPTRF, SSPEVD, SSPGST, STPMV, STPSV, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, REAL
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ WANTZ = LSAME( JOBZ, 'V' )
+ UPPER = LSAME( UPLO, 'U' )
+ LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 )
+*
+ INFO = 0
+ IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN
+ INFO = -1
+ ELSE IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
+ INFO = -2
+ ELSE IF( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN
+ INFO = -3
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
+ INFO = -9
+ END IF
+*
+ IF( INFO.EQ.0 ) THEN
+ IF( N.LE.1 ) THEN
+ LIWMIN = 1
+ LWMIN = 1
+ ELSE
+ IF( WANTZ ) THEN
+ LIWMIN = 3 + 5*N
+ LWMIN = 1 + 6*N + 2*N**2
+ ELSE
+ LIWMIN = 1
+ LWMIN = 2*N
+ END IF
+ END IF
+ WORK( 1 ) = LWMIN
+ IWORK( 1 ) = LIWMIN
+*
+ IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
+ INFO = -11
+ ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN
+ INFO = -13
+ END IF
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SSPGVD', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+* Form a Cholesky factorization of BP.
+*
+ CALL SPPTRF( UPLO, N, BP, INFO )
+ IF( INFO.NE.0 ) THEN
+ INFO = N + INFO
+ RETURN
+ END IF
+*
+* Transform problem to standard eigenvalue problem and solve.
+*
+ CALL SSPGST( ITYPE, UPLO, N, AP, BP, INFO )
+ CALL SSPEVD( JOBZ, UPLO, N, AP, W, Z, LDZ, WORK, LWORK, IWORK,
+ $ LIWORK, INFO )
+ LWMIN = MAX( REAL( LWMIN ), REAL( WORK( 1 ) ) )
+ LIWMIN = MAX( REAL( LIWMIN ), REAL( IWORK( 1 ) ) )
+*
+ IF( WANTZ ) THEN
+*
+* Backtransform eigenvectors to the original problem.
+*
+ NEIG = N
+ IF( INFO.GT.0 )
+ $ NEIG = INFO - 1
+ IF( ITYPE.EQ.1 .OR. ITYPE.EQ.2 ) THEN
+*
+* For A*x=(lambda)*B*x and A*B*x=(lambda)*x;
+* backtransform eigenvectors: x = inv(L)'*y or inv(U)*y
+*
+ IF( UPPER ) THEN
+ TRANS = 'N'
+ ELSE
+ TRANS = 'T'
+ END IF
+*
+ DO 10 J = 1, NEIG
+ CALL STPSV( UPLO, TRANS, 'Non-unit', N, BP, Z( 1, J ),
+ $ 1 )
+ 10 CONTINUE
+*
+ ELSE IF( ITYPE.EQ.3 ) THEN
+*
+* For B*A*x=(lambda)*x;
+* backtransform eigenvectors: x = L*y or U'*y
+*
+ IF( UPPER ) THEN
+ TRANS = 'T'
+ ELSE
+ TRANS = 'N'
+ END IF
+*
+ DO 20 J = 1, NEIG
+ CALL STPMV( UPLO, TRANS, 'Non-unit', N, BP, Z( 1, J ),
+ $ 1 )
+ 20 CONTINUE
+ END IF
+ END IF
+*
+ WORK( 1 ) = LWMIN
+ IWORK( 1 ) = LIWMIN
+*
+ RETURN
+*
+* End of SSPGVD
+*
+ END
+ SUBROUTINE SSPGVX( ITYPE, JOBZ, RANGE, UPLO, N, AP, BP, VL, VU,
+ $ IL, IU, ABSTOL, M, W, Z, LDZ, WORK, IWORK,
+ $ IFAIL, INFO )
+*
+* -- LAPACK driver routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER JOBZ, RANGE, UPLO
+ INTEGER IL, INFO, ITYPE, IU, LDZ, M, N
+ REAL ABSTOL, VL, VU
+* ..
+* .. Array Arguments ..
+ INTEGER IFAIL( * ), IWORK( * )
+ REAL AP( * ), BP( * ), W( * ), WORK( * ),
+ $ Z( LDZ, * )
+* ..
+*
+* Purpose
+* =======
+*
+* SSPGVX computes selected eigenvalues, and optionally, eigenvectors
+* of a real generalized symmetric-definite eigenproblem, of the form
+* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A
+* and B are assumed to be symmetric, stored in packed storage, and B
+* is also positive definite. Eigenvalues and eigenvectors can be
+* selected by specifying either a range of values or a range of indices
+* for the desired eigenvalues.
+*
+* Arguments
+* =========
+*
+* ITYPE (input) INTEGER
+* Specifies the problem type to be solved:
+* = 1: A*x = (lambda)*B*x
+* = 2: A*B*x = (lambda)*x
+* = 3: B*A*x = (lambda)*x
+*
+* JOBZ (input) CHARACTER*1
+* = 'N': Compute eigenvalues only;
+* = 'V': Compute eigenvalues and eigenvectors.
+*
+* RANGE (input) CHARACTER*1
+* = 'A': all eigenvalues will be found.
+* = 'V': all eigenvalues in the half-open interval (VL,VU]
+* will be found.
+* = 'I': the IL-th through IU-th eigenvalues will be found.
+*
+* UPLO (input) CHARACTER*1
+* = 'U': Upper triangle of A and B are stored;
+* = 'L': Lower triangle of A and B are stored.
+*
+* N (input) INTEGER
+* The order of the matrix pencil (A,B). N >= 0.
+*
+* AP (input/output) REAL array, dimension (N*(N+1)/2)
+* On entry, the upper or lower triangle of the symmetric matrix
+* A, packed columnwise in a linear array. The j-th column of A
+* is stored in the array AP as follows:
+* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
+* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
+*
+* On exit, the contents of AP are destroyed.
+*
+* BP (input/output) REAL array, dimension (N*(N+1)/2)
+* On entry, the upper or lower triangle of the symmetric matrix
+* B, packed columnwise in a linear array. The j-th column of B
+* is stored in the array BP as follows:
+* if UPLO = 'U', BP(i + (j-1)*j/2) = B(i,j) for 1<=i<=j;
+* if UPLO = 'L', BP(i + (j-1)*(2*n-j)/2) = B(i,j) for j<=i<=n.
+*
+* On exit, the triangular factor U or L from the Cholesky
+* factorization B = U**T*U or B = L*L**T, in the same storage
+* format as B.
+*
+* VL (input) REAL
+* VU (input) REAL
+* If RANGE='V', the lower and upper bounds of the interval to
+* be searched for eigenvalues. VL < VU.
+* Not referenced if RANGE = 'A' or 'I'.
+*
+* IL (input) INTEGER
+* IU (input) INTEGER
+* If RANGE='I', the indices (in ascending order) of the
+* smallest and largest eigenvalues to be returned.
+* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
+* Not referenced if RANGE = 'A' or 'V'.
+*
+* ABSTOL (input) REAL
+* The absolute error tolerance for the eigenvalues.
+* An approximate eigenvalue is accepted as converged
+* when it is determined to lie in an interval [a,b]
+* of width less than or equal to
+*
+* ABSTOL + EPS * max( |a|,|b| ) ,
+*
+* where EPS is the machine precision. If ABSTOL is less than
+* or equal to zero, then EPS*|T| will be used in its place,
+* where |T| is the 1-norm of the tridiagonal matrix obtained
+* by reducing A to tridiagonal form.
+*
+* Eigenvalues will be computed most accurately when ABSTOL is
+* set to twice the underflow threshold 2*SLAMCH('S'), not zero.
+* If this routine returns with INFO>0, indicating that some
+* eigenvectors did not converge, try setting ABSTOL to
+* 2*SLAMCH('S').
+*
+* M (output) INTEGER
+* The total number of eigenvalues found. 0 <= M <= N.
+* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
+*
+* W (output) REAL array, dimension (N)
+* On normal exit, the first M elements contain the selected
+* eigenvalues in ascending order.
+*
+* Z (output) REAL array, dimension (LDZ, max(1,M))
+* If JOBZ = 'N', then Z is not referenced.
+* If JOBZ = 'V', then if INFO = 0, the first M columns of Z
+* contain the orthonormal eigenvectors of the matrix A
+* corresponding to the selected eigenvalues, with the i-th
+* column of Z holding the eigenvector associated with W(i).
+* The eigenvectors are normalized as follows:
+* if ITYPE = 1 or 2, Z**T*B*Z = I;
+* if ITYPE = 3, Z**T*inv(B)*Z = I.
+*
+* If an eigenvector fails to converge, then that column of Z
+* contains the latest approximation to the eigenvector, and the
+* index of the eigenvector is returned in IFAIL.
+* Note: the user must ensure that at least max(1,M) columns are
+* supplied in the array Z; if RANGE = 'V', the exact value of M
+* is not known in advance and an upper bound must be used.
+*
+* LDZ (input) INTEGER
+* The leading dimension of the array Z. LDZ >= 1, and if
+* JOBZ = 'V', LDZ >= max(1,N).
+*
+* WORK (workspace) REAL array, dimension (8*N)
+*
+* IWORK (workspace) INTEGER array, dimension (5*N)
+*
+* IFAIL (output) INTEGER array, dimension (N)
+* If JOBZ = 'V', then if INFO = 0, the first M elements of
+* IFAIL are zero. If INFO > 0, then IFAIL contains the
+* indices of the eigenvectors that failed to converge.
+* If JOBZ = 'N', then IFAIL is not referenced.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* > 0: SPPTRF or SSPEVX returned an error code:
+* <= N: if INFO = i, SSPEVX failed to converge;
+* i eigenvectors failed to converge. Their indices
+* are stored in array IFAIL.
+* > N: if INFO = N + i, for 1 <= i <= N, then the leading
+* minor of order i of B is not positive definite.
+* The factorization of B could not be completed and
+* no eigenvalues or eigenvectors were computed.
+*
+* Further Details
+* ===============
+*
+* Based on contributions by
+* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ LOGICAL ALLEIG, INDEIG, UPPER, VALEIG, WANTZ
+ CHARACTER TRANS
+ INTEGER J
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL SPPTRF, SSPEVX, SSPGST, STPMV, STPSV, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MIN
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ UPPER = LSAME( UPLO, 'U' )
+ WANTZ = LSAME( JOBZ, 'V' )
+ ALLEIG = LSAME( RANGE, 'A' )
+ VALEIG = LSAME( RANGE, 'V' )
+ INDEIG = LSAME( RANGE, 'I' )
+*
+ INFO = 0
+ IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN
+ INFO = -1
+ ELSE IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
+ INFO = -2
+ ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN
+ INFO = -3
+ ELSE IF( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN
+ INFO = -4
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -5
+ ELSE
+ IF( VALEIG ) THEN
+ IF( N.GT.0 .AND. VU.LE.VL ) THEN
+ INFO = -9
+ END IF
+ ELSE IF( INDEIG ) THEN
+ IF( IL.LT.1 ) THEN
+ INFO = -10
+ ELSE IF( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) THEN
+ INFO = -11
+ END IF
+ END IF
+ END IF
+ IF( INFO.EQ.0 ) THEN
+ IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
+ INFO = -16
+ END IF
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SSPGVX', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ M = 0
+ IF( N.EQ.0 )
+ $ RETURN
+*
+* Form a Cholesky factorization of B.
+*
+ CALL SPPTRF( UPLO, N, BP, INFO )
+ IF( INFO.NE.0 ) THEN
+ INFO = N + INFO
+ RETURN
+ END IF
+*
+* Transform problem to standard eigenvalue problem and solve.
+*
+ CALL SSPGST( ITYPE, UPLO, N, AP, BP, INFO )
+ CALL SSPEVX( JOBZ, RANGE, UPLO, N, AP, VL, VU, IL, IU, ABSTOL, M,
+ $ W, Z, LDZ, WORK, IWORK, IFAIL, INFO )
+*
+ IF( WANTZ ) THEN
+*
+* Backtransform eigenvectors to the original problem.
+*
+ IF( INFO.GT.0 )
+ $ M = INFO - 1
+ IF( ITYPE.EQ.1 .OR. ITYPE.EQ.2 ) THEN
+*
+* For A*x=(lambda)*B*x and A*B*x=(lambda)*x;
+* backtransform eigenvectors: x = inv(L)'*y or inv(U)*y
+*
+ IF( UPPER ) THEN
+ TRANS = 'N'
+ ELSE
+ TRANS = 'T'
+ END IF
+*
+ DO 10 J = 1, M
+ CALL STPSV( UPLO, TRANS, 'Non-unit', N, BP, Z( 1, J ),
+ $ 1 )
+ 10 CONTINUE
+*
+ ELSE IF( ITYPE.EQ.3 ) THEN
+*
+* For B*A*x=(lambda)*x;
+* backtransform eigenvectors: x = L*y or U'*y
+*
+ IF( UPPER ) THEN
+ TRANS = 'T'
+ ELSE
+ TRANS = 'N'
+ END IF
+*
+ DO 20 J = 1, M
+ CALL STPMV( UPLO, TRANS, 'Non-unit', N, BP, Z( 1, J ),
+ $ 1 )
+ 20 CONTINUE
+ END IF
+ END IF
+*
+ RETURN
+*
+* End of SSPGVX
+*
+ END
+ SUBROUTINE SSPRFS( UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, LDX,
+ $ FERR, BERR, WORK, IWORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* Modified to call SLACN2 in place of SLACON, 5 Feb 03, SJH.
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, LDB, LDX, N, NRHS
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * ), IWORK( * )
+ REAL AFP( * ), AP( * ), B( LDB, * ), BERR( * ),
+ $ FERR( * ), WORK( * ), X( LDX, * )
+* ..
+*
+* Purpose
+* =======
+*
+* SSPRFS improves the computed solution to a system of linear
+* equations when the coefficient matrix is symmetric indefinite
+* and packed, and provides error bounds and backward error estimates
+* for the solution.
+*
+* Arguments
+* =========
+*
+* UPLO (input) CHARACTER*1
+* = 'U': Upper triangle of A is stored;
+* = 'L': Lower triangle of A is stored.
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* NRHS (input) INTEGER
+* The number of right hand sides, i.e., the number of columns
+* of the matrices B and X. NRHS >= 0.
+*
+* AP (input) REAL array, dimension (N*(N+1)/2)
+* The upper or lower triangle of the symmetric matrix A, packed
+* columnwise in a linear array. The j-th column of A is stored
+* in the array AP as follows:
+* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
+* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
+*
+* AFP (input) REAL array, dimension (N*(N+1)/2)
+* The factored form of the matrix A. AFP contains the block
+* diagonal matrix D and the multipliers used to obtain the
+* factor U or L from the factorization A = U*D*U**T or
+* A = L*D*L**T as computed by SSPTRF, stored as a packed
+* triangular matrix.
+*
+* IPIV (input) INTEGER array, dimension (N)
+* Details of the interchanges and the block structure of D
+* as determined by SSPTRF.
+*
+* B (input) REAL array, dimension (LDB,NRHS)
+* The right hand side matrix B.
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. LDB >= max(1,N).
+*
+* X (input/output) REAL array, dimension (LDX,NRHS)
+* On entry, the solution matrix X, as computed by SSPTRS.
+* On exit, the improved solution matrix X.
+*
+* LDX (input) INTEGER
+* The leading dimension of the array X. LDX >= max(1,N).
+*
+* FERR (output) REAL array, dimension (NRHS)
+* The estimated forward error bound for each solution vector
+* X(j) (the j-th column of the solution matrix X).
+* If XTRUE is the true solution corresponding to X(j), FERR(j)
+* is an estimated upper bound for the magnitude of the largest
+* element in (X(j) - XTRUE) divided by the magnitude of the
+* largest element in X(j). The estimate is as reliable as
+* the estimate for RCOND, and is almost always a slight
+* overestimate of the true error.
+*
+* BERR (output) REAL array, dimension (NRHS)
+* The componentwise relative backward error of each solution
+* vector X(j) (i.e., the smallest relative change in
+* any element of A or B that makes X(j) an exact solution).
+*
+* WORK (workspace) REAL array, dimension (3*N)
+*
+* IWORK (workspace) INTEGER array, dimension (N)
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+*
+* Internal Parameters
+* ===================
+*
+* ITMAX is the maximum number of steps of iterative refinement.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ INTEGER ITMAX
+ PARAMETER ( ITMAX = 5 )
+ REAL ZERO
+ PARAMETER ( ZERO = 0.0E+0 )
+ REAL ONE
+ PARAMETER ( ONE = 1.0E+0 )
+ REAL TWO
+ PARAMETER ( TWO = 2.0E+0 )
+ REAL THREE
+ PARAMETER ( THREE = 3.0E+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL UPPER
+ INTEGER COUNT, I, IK, J, K, KASE, KK, NZ
+ REAL EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK
+* ..
+* .. Local Arrays ..
+ INTEGER ISAVE( 3 )
+* ..
+* .. External Subroutines ..
+ EXTERNAL SAXPY, SCOPY, SLACN2, SSPMV, SSPTRS, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ REAL SLAMCH
+ EXTERNAL LSAME, SLAMCH
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( NRHS.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -8
+ ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
+ INFO = -10
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SSPRFS', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN
+ DO 10 J = 1, NRHS
+ FERR( J ) = ZERO
+ BERR( J ) = ZERO
+ 10 CONTINUE
+ RETURN
+ END IF
+*
+* NZ = maximum number of nonzero elements in each row of A, plus 1
+*
+ NZ = N + 1
+ EPS = SLAMCH( 'Epsilon' )
+ SAFMIN = SLAMCH( 'Safe minimum' )
+ SAFE1 = NZ*SAFMIN
+ SAFE2 = SAFE1 / EPS
+*
+* Do for each right hand side
+*
+ DO 140 J = 1, NRHS
+*
+ COUNT = 1
+ LSTRES = THREE
+ 20 CONTINUE
+*
+* Loop until stopping criterion is satisfied.
+*
+* Compute residual R = B - A * X
+*
+ CALL SCOPY( N, B( 1, J ), 1, WORK( N+1 ), 1 )
+ CALL SSPMV( UPLO, N, -ONE, AP, X( 1, J ), 1, ONE, WORK( N+1 ),
+ $ 1 )
+*
+* Compute componentwise relative backward error from formula
+*
+* max(i) ( abs(R(i)) / ( abs(A)*abs(X) + abs(B) )(i) )
+*
+* where abs(Z) is the componentwise absolute value of the matrix
+* or vector Z. If the i-th component of the denominator is less
+* than SAFE2, then SAFE1 is added to the i-th components of the
+* numerator and denominator before dividing.
+*
+ DO 30 I = 1, N
+ WORK( I ) = ABS( B( I, J ) )
+ 30 CONTINUE
+*
+* Compute abs(A)*abs(X) + abs(B).
+*
+ KK = 1
+ IF( UPPER ) THEN
+ DO 50 K = 1, N
+ S = ZERO
+ XK = ABS( X( K, J ) )
+ IK = KK
+ DO 40 I = 1, K - 1
+ WORK( I ) = WORK( I ) + ABS( AP( IK ) )*XK
+ S = S + ABS( AP( IK ) )*ABS( X( I, J ) )
+ IK = IK + 1
+ 40 CONTINUE
+ WORK( K ) = WORK( K ) + ABS( AP( KK+K-1 ) )*XK + S
+ KK = KK + K
+ 50 CONTINUE
+ ELSE
+ DO 70 K = 1, N
+ S = ZERO
+ XK = ABS( X( K, J ) )
+ WORK( K ) = WORK( K ) + ABS( AP( KK ) )*XK
+ IK = KK + 1
+ DO 60 I = K + 1, N
+ WORK( I ) = WORK( I ) + ABS( AP( IK ) )*XK
+ S = S + ABS( AP( IK ) )*ABS( X( I, J ) )
+ IK = IK + 1
+ 60 CONTINUE
+ WORK( K ) = WORK( K ) + S
+ KK = KK + ( N-K+1 )
+ 70 CONTINUE
+ END IF
+ S = ZERO
+ DO 80 I = 1, N
+ IF( WORK( I ).GT.SAFE2 ) THEN
+ S = MAX( S, ABS( WORK( N+I ) ) / WORK( I ) )
+ ELSE
+ S = MAX( S, ( ABS( WORK( N+I ) )+SAFE1 ) /
+ $ ( WORK( I )+SAFE1 ) )
+ END IF
+ 80 CONTINUE
+ BERR( J ) = S
+*
+* Test stopping criterion. Continue iterating if
+* 1) The residual BERR(J) is larger than machine epsilon, and
+* 2) BERR(J) decreased by at least a factor of 2 during the
+* last iteration, and
+* 3) At most ITMAX iterations tried.
+*
+ IF( BERR( J ).GT.EPS .AND. TWO*BERR( J ).LE.LSTRES .AND.
+ $ COUNT.LE.ITMAX ) THEN
+*
+* Update solution and try again.
+*
+ CALL SSPTRS( UPLO, N, 1, AFP, IPIV, WORK( N+1 ), N, INFO )
+ CALL SAXPY( N, ONE, WORK( N+1 ), 1, X( 1, J ), 1 )
+ LSTRES = BERR( J )
+ COUNT = COUNT + 1
+ GO TO 20
+ END IF
+*
+* Bound error from formula
+*
+* norm(X - XTRUE) / norm(X) .le. FERR =
+* norm( abs(inv(A))*
+* ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X)
+*
+* where
+* norm(Z) is the magnitude of the largest component of Z
+* inv(A) is the inverse of A
+* abs(Z) is the componentwise absolute value of the matrix or
+* vector Z
+* NZ is the maximum number of nonzeros in any row of A, plus 1
+* EPS is machine epsilon
+*
+* The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B))
+* is incremented by SAFE1 if the i-th component of
+* abs(A)*abs(X) + abs(B) is less than SAFE2.
+*
+* Use SLACN2 to estimate the infinity-norm of the matrix
+* inv(A) * diag(W),
+* where W = abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) )))
+*
+ DO 90 I = 1, N
+ IF( WORK( I ).GT.SAFE2 ) THEN
+ WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I )
+ ELSE
+ WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I ) + SAFE1
+ END IF
+ 90 CONTINUE
+*
+ KASE = 0
+ 100 CONTINUE
+ CALL SLACN2( N, WORK( 2*N+1 ), WORK( N+1 ), IWORK, FERR( J ),
+ $ KASE, ISAVE )
+ IF( KASE.NE.0 ) THEN
+ IF( KASE.EQ.1 ) THEN
+*
+* Multiply by diag(W)*inv(A').
+*
+ CALL SSPTRS( UPLO, N, 1, AFP, IPIV, WORK( N+1 ), N,
+ $ INFO )
+ DO 110 I = 1, N
+ WORK( N+I ) = WORK( I )*WORK( N+I )
+ 110 CONTINUE
+ ELSE IF( KASE.EQ.2 ) THEN
+*
+* Multiply by inv(A)*diag(W).
+*
+ DO 120 I = 1, N
+ WORK( N+I ) = WORK( I )*WORK( N+I )
+ 120 CONTINUE
+ CALL SSPTRS( UPLO, N, 1, AFP, IPIV, WORK( N+1 ), N,
+ $ INFO )
+ END IF
+ GO TO 100
+ END IF
+*
+* Normalize error.
+*
+ LSTRES = ZERO
+ DO 130 I = 1, N
+ LSTRES = MAX( LSTRES, ABS( X( I, J ) ) )
+ 130 CONTINUE
+ IF( LSTRES.NE.ZERO )
+ $ FERR( J ) = FERR( J ) / LSTRES
+*
+ 140 CONTINUE
+*
+ RETURN
+*
+* End of SSPRFS
+*
+ END
+ SUBROUTINE SSPSV( UPLO, N, NRHS, AP, IPIV, B, LDB, INFO )
+*
+* -- LAPACK driver routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, LDB, N, NRHS
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ REAL AP( * ), B( LDB, * )
+* ..
+*
+* Purpose
+* =======
+*
+* SSPSV computes the solution to a real system of linear equations
+* A * X = B,
+* where A is an N-by-N symmetric matrix stored in packed format and X
+* and B are N-by-NRHS matrices.
+*
+* The diagonal pivoting method is used to factor A as
+* A = U * D * U**T, if UPLO = 'U', or
+* A = L * D * L**T, if UPLO = 'L',
+* where U (or L) is a product of permutation and unit upper (lower)
+* triangular matrices, D is symmetric and block diagonal with 1-by-1
+* and 2-by-2 diagonal blocks. The factored form of A is then used to
+* solve the system of equations A * X = B.
+*
+* Arguments
+* =========
+*
+* UPLO (input) CHARACTER*1
+* = 'U': Upper triangle of A is stored;
+* = 'L': Lower triangle of A is stored.
+*
+* N (input) INTEGER
+* The number of linear equations, i.e., the order of the
+* matrix A. N >= 0.
+*
+* NRHS (input) INTEGER
+* The number of right hand sides, i.e., the number of columns
+* of the matrix B. NRHS >= 0.
+*
+* AP (input/output) REAL array, dimension (N*(N+1)/2)
+* On entry, the upper or lower triangle of the symmetric matrix
+* A, packed columnwise in a linear array. The j-th column of A
+* is stored in the array AP as follows:
+* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
+* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
+* See below for further details.
+*
+* On exit, the block diagonal matrix D and the multipliers used
+* to obtain the factor U or L from the factorization
+* A = U*D*U**T or A = L*D*L**T as computed by SSPTRF, stored as
+* a packed triangular matrix in the same storage format as A.
+*
+* IPIV (output) INTEGER array, dimension (N)
+* Details of the interchanges and the block structure of D, as
+* determined by SSPTRF. If IPIV(k) > 0, then rows and columns
+* k and IPIV(k) were interchanged, and D(k,k) is a 1-by-1
+* diagonal block. If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0,
+* then rows and columns k-1 and -IPIV(k) were interchanged and
+* D(k-1:k,k-1:k) is a 2-by-2 diagonal block. If UPLO = 'L' and
+* IPIV(k) = IPIV(k+1) < 0, then rows and columns k+1 and
+* -IPIV(k) were interchanged and D(k:k+1,k:k+1) is a 2-by-2
+* diagonal block.
+*
+* B (input/output) REAL array, dimension (LDB,NRHS)
+* On entry, the N-by-NRHS right hand side matrix B.
+* On exit, if INFO = 0, the N-by-NRHS solution matrix X.
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. LDB >= max(1,N).
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* > 0: if INFO = i, D(i,i) is exactly zero. The factorization
+* has been completed, but the block diagonal matrix D is
+* exactly singular, so the solution could not be
+* computed.
+*
+* Further Details
+* ===============
+*
+* The packed storage scheme is illustrated by the following example
+* when N = 4, UPLO = 'U':
+*
+* Two-dimensional storage of the symmetric matrix A:
+*
+* a11 a12 a13 a14
+* a22 a23 a24
+* a33 a34 (aij = aji)
+* a44
+*
+* Packed storage of the upper triangle of A:
+*
+* AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]
+*
+* =====================================================================
+*
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL SSPTRF, SSPTRS, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( NRHS.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -7
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SSPSV ', -INFO )
+ RETURN
+ END IF
+*
+* Compute the factorization A = U*D*U' or A = L*D*L'.
+*
+ CALL SSPTRF( UPLO, N, AP, IPIV, INFO )
+ IF( INFO.EQ.0 ) THEN
+*
+* Solve the system A*X = B, overwriting B with X.
+*
+ CALL SSPTRS( UPLO, N, NRHS, AP, IPIV, B, LDB, INFO )
+*
+ END IF
+ RETURN
+*
+* End of SSPSV
+*
+ END
+ SUBROUTINE SSPSVX( FACT, UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X,
+ $ LDX, RCOND, FERR, BERR, WORK, IWORK, INFO )
+*
+* -- LAPACK driver routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER FACT, UPLO
+ INTEGER INFO, LDB, LDX, N, NRHS
+ REAL RCOND
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * ), IWORK( * )
+ REAL AFP( * ), AP( * ), B( LDB, * ), BERR( * ),
+ $ FERR( * ), WORK( * ), X( LDX, * )
+* ..
+*
+* Purpose
+* =======
+*
+* SSPSVX uses the diagonal pivoting factorization A = U*D*U**T or
+* A = L*D*L**T to compute the solution to a real system of linear
+* equations A * X = B, where A is an N-by-N symmetric matrix stored
+* in packed format and X and B are N-by-NRHS matrices.
+*
+* Error bounds on the solution and a condition estimate are also
+* provided.
+*
+* Description
+* ===========
+*
+* The following steps are performed:
+*
+* 1. If FACT = 'N', the diagonal pivoting method is used to factor A as
+* A = U * D * U**T, if UPLO = 'U', or
+* A = L * D * L**T, if UPLO = 'L',
+* where U (or L) is a product of permutation and unit upper (lower)
+* triangular matrices and D is symmetric and block diagonal with
+* 1-by-1 and 2-by-2 diagonal blocks.
+*
+* 2. If some D(i,i)=0, so that D is exactly singular, then the routine
+* returns with INFO = i. Otherwise, the factored form of A is used
+* to estimate the condition number of the matrix A. If the
+* reciprocal of the condition number is less than machine precision,
+* INFO = N+1 is returned as a warning, but the routine still goes on
+* to solve for X and compute error bounds as described below.
+*
+* 3. The system of equations is solved for X using the factored form
+* of A.
+*
+* 4. Iterative refinement is applied to improve the computed solution
+* matrix and calculate error bounds and backward error estimates
+* for it.
+*
+* Arguments
+* =========
+*
+* FACT (input) CHARACTER*1
+* Specifies whether or not the factored form of A has been
+* supplied on entry.
+* = 'F': On entry, AFP and IPIV contain the factored form of
+* A. AP, AFP and IPIV will not be modified.
+* = 'N': The matrix A will be copied to AFP and factored.
+*
+* UPLO (input) CHARACTER*1
+* = 'U': Upper triangle of A is stored;
+* = 'L': Lower triangle of A is stored.
+*
+* N (input) INTEGER
+* The number of linear equations, i.e., the order of the
+* matrix A. N >= 0.
+*
+* NRHS (input) INTEGER
+* The number of right hand sides, i.e., the number of columns
+* of the matrices B and X. NRHS >= 0.
+*
+* AP (input) REAL array, dimension (N*(N+1)/2)
+* The upper or lower triangle of the symmetric matrix A, packed
+* columnwise in a linear array. The j-th column of A is stored
+* in the array AP as follows:
+* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
+* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
+* See below for further details.
+*
+* AFP (input or output) REAL array, dimension
+* (N*(N+1)/2)
+* If FACT = 'F', then AFP is an input argument and on entry
+* contains the block diagonal matrix D and the multipliers used
+* to obtain the factor U or L from the factorization
+* A = U*D*U**T or A = L*D*L**T as computed by SSPTRF, stored as
+* a packed triangular matrix in the same storage format as A.
+*
+* If FACT = 'N', then AFP is an output argument and on exit
+* contains the block diagonal matrix D and the multipliers used
+* to obtain the factor U or L from the factorization
+* A = U*D*U**T or A = L*D*L**T as computed by SSPTRF, stored as
+* a packed triangular matrix in the same storage format as A.
+*
+* IPIV (input or output) INTEGER array, dimension (N)
+* If FACT = 'F', then IPIV is an input argument and on entry
+* contains details of the interchanges and the block structure
+* of D, as determined by SSPTRF.
+* If IPIV(k) > 0, then rows and columns k and IPIV(k) were
+* interchanged and D(k,k) is a 1-by-1 diagonal block.
+* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and
+* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)
+* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =
+* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were
+* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
+*
+* If FACT = 'N', then IPIV is an output argument and on exit
+* contains details of the interchanges and the block structure
+* of D, as determined by SSPTRF.
+*
+* B (input) REAL array, dimension (LDB,NRHS)
+* The N-by-NRHS right hand side matrix B.
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. LDB >= max(1,N).
+*
+* X (output) REAL array, dimension (LDX,NRHS)
+* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X.
+*
+* LDX (input) INTEGER
+* The leading dimension of the array X. LDX >= max(1,N).
+*
+* RCOND (output) REAL
+* The estimate of the reciprocal condition number of the matrix
+* A. If RCOND is less than the machine precision (in
+* particular, if RCOND = 0), the matrix is singular to working
+* precision. This condition is indicated by a return code of
+* INFO > 0.
+*
+* FERR (output) REAL array, dimension (NRHS)
+* The estimated forward error bound for each solution vector
+* X(j) (the j-th column of the solution matrix X).
+* If XTRUE is the true solution corresponding to X(j), FERR(j)
+* is an estimated upper bound for the magnitude of the largest
+* element in (X(j) - XTRUE) divided by the magnitude of the
+* largest element in X(j). The estimate is as reliable as
+* the estimate for RCOND, and is almost always a slight
+* overestimate of the true error.
+*
+* BERR (output) REAL array, dimension (NRHS)
+* The componentwise relative backward error of each solution
+* vector X(j) (i.e., the smallest relative change in
+* any element of A or B that makes X(j) an exact solution).
+*
+* WORK (workspace) REAL array, dimension (3*N)
+*
+* IWORK (workspace) INTEGER array, dimension (N)
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* > 0: if INFO = i, and i is
+* <= N: D(i,i) is exactly zero. The factorization
+* has been completed but the factor D is exactly
+* singular, so the solution and error bounds could
+* not be computed. RCOND = 0 is returned.
+* = N+1: D is nonsingular, but RCOND is less than machine
+* precision, meaning that the matrix is singular
+* to working precision. Nevertheless, the
+* solution and error bounds are computed because
+* there are a number of situations where the
+* computed solution can be more accurate than the
+* value of RCOND would suggest.
+*
+* Further Details
+* ===============
+*
+* The packed storage scheme is illustrated by the following example
+* when N = 4, UPLO = 'U':
+*
+* Two-dimensional storage of the symmetric matrix A:
+*
+* a11 a12 a13 a14
+* a22 a23 a24
+* a33 a34 (aij = aji)
+* a44
+*
+* Packed storage of the upper triangle of A:
+*
+* AP = [ a11, a12, a22, a13, a23, a33, a14, a24, a34, a44 ]
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO
+ PARAMETER ( ZERO = 0.0E+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL NOFACT
+ REAL ANORM
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ REAL SLAMCH, SLANSP
+ EXTERNAL LSAME, SLAMCH, SLANSP
+* ..
+* .. External Subroutines ..
+ EXTERNAL SCOPY, SLACPY, SSPCON, SSPRFS, SSPTRF, SSPTRS,
+ $ XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ NOFACT = LSAME( FACT, 'N' )
+ IF( .NOT.NOFACT .AND. .NOT.LSAME( FACT, 'F' ) ) THEN
+ INFO = -1
+ ELSE IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) )
+ $ THEN
+ INFO = -2
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( NRHS.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -9
+ ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
+ INFO = -11
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SSPSVX', -INFO )
+ RETURN
+ END IF
+*
+ IF( NOFACT ) THEN
+*
+* Compute the factorization A = U*D*U' or A = L*D*L'.
+*
+ CALL SCOPY( N*( N+1 ) / 2, AP, 1, AFP, 1 )
+ CALL SSPTRF( UPLO, N, AFP, IPIV, INFO )
+*
+* Return if INFO is non-zero.
+*
+ IF( INFO.GT.0 )THEN
+ RCOND = ZERO
+ RETURN
+ END IF
+ END IF
+*
+* Compute the norm of the matrix A.
+*
+ ANORM = SLANSP( 'I', UPLO, N, AP, WORK )
+*
+* Compute the reciprocal of the condition number of A.
+*
+ CALL SSPCON( UPLO, N, AFP, IPIV, ANORM, RCOND, WORK, IWORK, INFO )
+*
+* Compute the solution vectors X.
+*
+ CALL SLACPY( 'Full', N, NRHS, B, LDB, X, LDX )
+ CALL SSPTRS( UPLO, N, NRHS, AFP, IPIV, X, LDX, INFO )
+*
+* Use iterative refinement to improve the computed solutions and
+* compute error bounds and backward error estimates for them.
+*
+ CALL SSPRFS( UPLO, N, NRHS, AP, AFP, IPIV, B, LDB, X, LDX, FERR,
+ $ BERR, WORK, IWORK, INFO )
+*
+* Set INFO = N+1 if the matrix is singular to working precision.
+*
+ IF( RCOND.LT.SLAMCH( 'Epsilon' ) )
+ $ INFO = N + 1
+*
+ RETURN
+*
+* End of SSPSVX
+*
+ END
+ SUBROUTINE SSPTRD( UPLO, N, AP, D, E, TAU, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, N
+* ..
+* .. Array Arguments ..
+ REAL AP( * ), D( * ), E( * ), TAU( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SSPTRD reduces a real symmetric matrix A stored in packed form to
+* symmetric tridiagonal form T by an orthogonal similarity
+* transformation: Q**T * A * Q = T.
+*
+* Arguments
+* =========
+*
+* UPLO (input) CHARACTER*1
+* = 'U': Upper triangle of A is stored;
+* = 'L': Lower triangle of A is stored.
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* AP (input/output) REAL array, dimension (N*(N+1)/2)
+* On entry, the upper or lower triangle of the symmetric matrix
+* A, packed columnwise in a linear array. The j-th column of A
+* is stored in the array AP as follows:
+* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
+* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
+* On exit, if UPLO = 'U', the diagonal and first superdiagonal
+* of A are overwritten by the corresponding elements of the
+* tridiagonal matrix T, and the elements above the first
+* superdiagonal, with the array TAU, represent the orthogonal
+* matrix Q as a product of elementary reflectors; if UPLO
+* = 'L', the diagonal and first subdiagonal of A are over-
+* written by the corresponding elements of the tridiagonal
+* matrix T, and the elements below the first subdiagonal, with
+* the array TAU, represent the orthogonal matrix Q as a product
+* of elementary reflectors. See Further Details.
+*
+* D (output) REAL array, dimension (N)
+* The diagonal elements of the tridiagonal matrix T:
+* D(i) = A(i,i).
+*
+* E (output) REAL array, dimension (N-1)
+* The off-diagonal elements of the tridiagonal matrix T:
+* E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'.
+*
+* TAU (output) REAL array, dimension (N-1)
+* The scalar factors of the elementary reflectors (see Further
+* Details).
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+*
+* Further Details
+* ===============
+*
+* If UPLO = 'U', the matrix Q is represented as a product of elementary
+* reflectors
+*
+* Q = H(n-1) . . . H(2) H(1).
+*
+* Each H(i) has the form
+*
+* H(i) = I - tau * v * v'
+*
+* where tau is a real scalar, and v is a real vector with
+* v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in AP,
+* overwriting A(1:i-1,i+1), and tau is stored in TAU(i).
+*
+* If UPLO = 'L', the matrix Q is represented as a product of elementary
+* reflectors
+*
+* Q = H(1) H(2) . . . H(n-1).
+*
+* Each H(i) has the form
+*
+* H(i) = I - tau * v * v'
+*
+* where tau is a real scalar, and v is a real vector with
+* v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in AP,
+* overwriting A(i+2:n,i), and tau is stored in TAU(i).
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ONE, ZERO, HALF
+ PARAMETER ( ONE = 1.0, ZERO = 0.0, HALF = 1.0 / 2.0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL UPPER
+ INTEGER I, I1, I1I1, II
+ REAL ALPHA, TAUI
+* ..
+* .. External Subroutines ..
+ EXTERNAL SAXPY, SLARFG, SSPMV, SSPR2, XERBLA
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ REAL SDOT
+ EXTERNAL LSAME, SDOT
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SSPTRD', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.LE.0 )
+ $ RETURN
+*
+ IF( UPPER ) THEN
+*
+* Reduce the upper triangle of A.
+* I1 is the index in AP of A(1,I+1).
+*
+ I1 = N*( N-1 ) / 2 + 1
+ DO 10 I = N - 1, 1, -1
+*
+* Generate elementary reflector H(i) = I - tau * v * v'
+* to annihilate A(1:i-1,i+1)
+*
+ CALL SLARFG( I, AP( I1+I-1 ), AP( I1 ), 1, TAUI )
+ E( I ) = AP( I1+I-1 )
+*
+ IF( TAUI.NE.ZERO ) THEN
+*
+* Apply H(i) from both sides to A(1:i,1:i)
+*
+ AP( I1+I-1 ) = ONE
+*
+* Compute y := tau * A * v storing y in TAU(1:i)
+*
+ CALL SSPMV( UPLO, I, TAUI, AP, AP( I1 ), 1, ZERO, TAU,
+ $ 1 )
+*
+* Compute w := y - 1/2 * tau * (y'*v) * v
+*
+ ALPHA = -HALF*TAUI*SDOT( I, TAU, 1, AP( I1 ), 1 )
+ CALL SAXPY( I, ALPHA, AP( I1 ), 1, TAU, 1 )
+*
+* Apply the transformation as a rank-2 update:
+* A := A - v * w' - w * v'
+*
+ CALL SSPR2( UPLO, I, -ONE, AP( I1 ), 1, TAU, 1, AP )
+*
+ AP( I1+I-1 ) = E( I )
+ END IF
+ D( I+1 ) = AP( I1+I )
+ TAU( I ) = TAUI
+ I1 = I1 - I
+ 10 CONTINUE
+ D( 1 ) = AP( 1 )
+ ELSE
+*
+* Reduce the lower triangle of A. II is the index in AP of
+* A(i,i) and I1I1 is the index of A(i+1,i+1).
+*
+ II = 1
+ DO 20 I = 1, N - 1
+ I1I1 = II + N - I + 1
+*
+* Generate elementary reflector H(i) = I - tau * v * v'
+* to annihilate A(i+2:n,i)
+*
+ CALL SLARFG( N-I, AP( II+1 ), AP( II+2 ), 1, TAUI )
+ E( I ) = AP( II+1 )
+*
+ IF( TAUI.NE.ZERO ) THEN
+*
+* Apply H(i) from both sides to A(i+1:n,i+1:n)
+*
+ AP( II+1 ) = ONE
+*
+* Compute y := tau * A * v storing y in TAU(i:n-1)
+*
+ CALL SSPMV( UPLO, N-I, TAUI, AP( I1I1 ), AP( II+1 ), 1,
+ $ ZERO, TAU( I ), 1 )
+*
+* Compute w := y - 1/2 * tau * (y'*v) * v
+*
+ ALPHA = -HALF*TAUI*SDOT( N-I, TAU( I ), 1, AP( II+1 ),
+ $ 1 )
+ CALL SAXPY( N-I, ALPHA, AP( II+1 ), 1, TAU( I ), 1 )
+*
+* Apply the transformation as a rank-2 update:
+* A := A - v * w' - w * v'
+*
+ CALL SSPR2( UPLO, N-I, -ONE, AP( II+1 ), 1, TAU( I ), 1,
+ $ AP( I1I1 ) )
+*
+ AP( II+1 ) = E( I )
+ END IF
+ D( I ) = AP( II )
+ TAU( I ) = TAUI
+ II = I1I1
+ 20 CONTINUE
+ D( N ) = AP( II )
+ END IF
+*
+ RETURN
+*
+* End of SSPTRD
+*
+ END
+ SUBROUTINE SSPTRF( UPLO, N, AP, IPIV, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, N
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ REAL AP( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SSPTRF computes the factorization of a real symmetric matrix A stored
+* in packed format using the Bunch-Kaufman diagonal pivoting method:
+*
+* A = U*D*U**T or A = L*D*L**T
+*
+* where U (or L) is a product of permutation and unit upper (lower)
+* triangular matrices, and D is symmetric and block diagonal with
+* 1-by-1 and 2-by-2 diagonal blocks.
+*
+* Arguments
+* =========
+*
+* UPLO (input) CHARACTER*1
+* = 'U': Upper triangle of A is stored;
+* = 'L': Lower triangle of A is stored.
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* AP (input/output) REAL array, dimension (N*(N+1)/2)
+* On entry, the upper or lower triangle of the symmetric matrix
+* A, packed columnwise in a linear array. The j-th column of A
+* is stored in the array AP as follows:
+* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
+* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
+*
+* On exit, the block diagonal matrix D and the multipliers used
+* to obtain the factor U or L, stored as a packed triangular
+* matrix overwriting A (see below for further details).
+*
+* IPIV (output) INTEGER array, dimension (N)
+* Details of the interchanges and the block structure of D.
+* If IPIV(k) > 0, then rows and columns k and IPIV(k) were
+* interchanged and D(k,k) is a 1-by-1 diagonal block.
+* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and
+* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)
+* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =
+* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were
+* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* > 0: if INFO = i, D(i,i) is exactly zero. The factorization
+* has been completed, but the block diagonal matrix D is
+* exactly singular, and division by zero will occur if it
+* is used to solve a system of equations.
+*
+* Further Details
+* ===============
+*
+* 5-96 - Based on modifications by J. Lewis, Boeing Computer Services
+* Company
+*
+* If UPLO = 'U', then A = U*D*U', where
+* U = P(n)*U(n)* ... *P(k)U(k)* ...,
+* i.e., U is a product of terms P(k)*U(k), where k decreases from n to
+* 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1
+* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as
+* defined by IPIV(k), and U(k) is a unit upper triangular matrix, such
+* that if the diagonal block D(k) is of order s (s = 1 or 2), then
+*
+* ( I v 0 ) k-s
+* U(k) = ( 0 I 0 ) s
+* ( 0 0 I ) n-k
+* k-s s n-k
+*
+* If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k).
+* If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k),
+* and A(k,k), and v overwrites A(1:k-2,k-1:k).
+*
+* If UPLO = 'L', then A = L*D*L', where
+* L = P(1)*L(1)* ... *P(k)*L(k)* ...,
+* i.e., L is a product of terms P(k)*L(k), where k increases from 1 to
+* n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1
+* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as
+* defined by IPIV(k), and L(k) is a unit lower triangular matrix, such
+* that if the diagonal block D(k) is of order s (s = 1 or 2), then
+*
+* ( I 0 0 ) k-1
+* L(k) = ( 0 I 0 ) s
+* ( 0 v I ) n-k-s+1
+* k-1 s n-k-s+1
+*
+* If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k).
+* If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k),
+* and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1).
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO, ONE
+ PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+ REAL EIGHT, SEVTEN
+ PARAMETER ( EIGHT = 8.0E+0, SEVTEN = 17.0E+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL UPPER
+ INTEGER I, IMAX, J, JMAX, K, KC, KK, KNC, KP, KPC,
+ $ KSTEP, KX, NPP
+ REAL ABSAKK, ALPHA, COLMAX, D11, D12, D21, D22, R1,
+ $ ROWMAX, T, WK, WKM1, WKP1
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ISAMAX
+ EXTERNAL LSAME, ISAMAX
+* ..
+* .. External Subroutines ..
+ EXTERNAL SSCAL, SSPR, SSWAP, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, SQRT
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SSPTRF', -INFO )
+ RETURN
+ END IF
+*
+* Initialize ALPHA for use in choosing pivot block size.
+*
+ ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT
+*
+ IF( UPPER ) THEN
+*
+* Factorize A as U*D*U' using the upper triangle of A
+*
+* K is the main loop index, decreasing from N to 1 in steps of
+* 1 or 2
+*
+ K = N
+ KC = ( N-1 )*N / 2 + 1
+ 10 CONTINUE
+ KNC = KC
+*
+* If K < 1, exit from loop
+*
+ IF( K.LT.1 )
+ $ GO TO 110
+ KSTEP = 1
+*
+* Determine rows and columns to be interchanged and whether
+* a 1-by-1 or 2-by-2 pivot block will be used
+*
+ ABSAKK = ABS( AP( KC+K-1 ) )
+*
+* IMAX is the row-index of the largest off-diagonal element in
+* column K, and COLMAX is its absolute value
+*
+ IF( K.GT.1 ) THEN
+ IMAX = ISAMAX( K-1, AP( KC ), 1 )
+ COLMAX = ABS( AP( KC+IMAX-1 ) )
+ ELSE
+ COLMAX = ZERO
+ END IF
+*
+ IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN
+*
+* Column K is zero: set INFO and continue
+*
+ IF( INFO.EQ.0 )
+ $ INFO = K
+ KP = K
+ ELSE
+ IF( ABSAKK.GE.ALPHA*COLMAX ) THEN
+*
+* no interchange, use 1-by-1 pivot block
+*
+ KP = K
+ ELSE
+*
+* JMAX is the column-index of the largest off-diagonal
+* element in row IMAX, and ROWMAX is its absolute value
+*
+ ROWMAX = ZERO
+ JMAX = IMAX
+ KX = IMAX*( IMAX+1 ) / 2 + IMAX
+ DO 20 J = IMAX + 1, K
+ IF( ABS( AP( KX ) ).GT.ROWMAX ) THEN
+ ROWMAX = ABS( AP( KX ) )
+ JMAX = J
+ END IF
+ KX = KX + J
+ 20 CONTINUE
+ KPC = ( IMAX-1 )*IMAX / 2 + 1
+ IF( IMAX.GT.1 ) THEN
+ JMAX = ISAMAX( IMAX-1, AP( KPC ), 1 )
+ ROWMAX = MAX( ROWMAX, ABS( AP( KPC+JMAX-1 ) ) )
+ END IF
+*
+ IF( ABSAKK.GE.ALPHA*COLMAX*( COLMAX / ROWMAX ) ) THEN
+*
+* no interchange, use 1-by-1 pivot block
+*
+ KP = K
+ ELSE IF( ABS( AP( KPC+IMAX-1 ) ).GE.ALPHA*ROWMAX ) THEN
+*
+* interchange rows and columns K and IMAX, use 1-by-1
+* pivot block
+*
+ KP = IMAX
+ ELSE
+*
+* interchange rows and columns K-1 and IMAX, use 2-by-2
+* pivot block
+*
+ KP = IMAX
+ KSTEP = 2
+ END IF
+ END IF
+*
+ KK = K - KSTEP + 1
+ IF( KSTEP.EQ.2 )
+ $ KNC = KNC - K + 1
+ IF( KP.NE.KK ) THEN
+*
+* Interchange rows and columns KK and KP in the leading
+* submatrix A(1:k,1:k)
+*
+ CALL SSWAP( KP-1, AP( KNC ), 1, AP( KPC ), 1 )
+ KX = KPC + KP - 1
+ DO 30 J = KP + 1, KK - 1
+ KX = KX + J - 1
+ T = AP( KNC+J-1 )
+ AP( KNC+J-1 ) = AP( KX )
+ AP( KX ) = T
+ 30 CONTINUE
+ T = AP( KNC+KK-1 )
+ AP( KNC+KK-1 ) = AP( KPC+KP-1 )
+ AP( KPC+KP-1 ) = T
+ IF( KSTEP.EQ.2 ) THEN
+ T = AP( KC+K-2 )
+ AP( KC+K-2 ) = AP( KC+KP-1 )
+ AP( KC+KP-1 ) = T
+ END IF
+ END IF
+*
+* Update the leading submatrix
+*
+ IF( KSTEP.EQ.1 ) THEN
+*
+* 1-by-1 pivot block D(k): column k now holds
+*
+* W(k) = U(k)*D(k)
+*
+* where U(k) is the k-th column of U
+*
+* Perform a rank-1 update of A(1:k-1,1:k-1) as
+*
+* A := A - U(k)*D(k)*U(k)' = A - W(k)*1/D(k)*W(k)'
+*
+ R1 = ONE / AP( KC+K-1 )
+ CALL SSPR( UPLO, K-1, -R1, AP( KC ), 1, AP )
+*
+* Store U(k) in column k
+*
+ CALL SSCAL( K-1, R1, AP( KC ), 1 )
+ ELSE
+*
+* 2-by-2 pivot block D(k): columns k and k-1 now hold
+*
+* ( W(k-1) W(k) ) = ( U(k-1) U(k) )*D(k)
+*
+* where U(k) and U(k-1) are the k-th and (k-1)-th columns
+* of U
+*
+* Perform a rank-2 update of A(1:k-2,1:k-2) as
+*
+* A := A - ( U(k-1) U(k) )*D(k)*( U(k-1) U(k) )'
+* = A - ( W(k-1) W(k) )*inv(D(k))*( W(k-1) W(k) )'
+*
+ IF( K.GT.2 ) THEN
+*
+ D12 = AP( K-1+( K-1 )*K / 2 )
+ D22 = AP( K-1+( K-2 )*( K-1 ) / 2 ) / D12
+ D11 = AP( K+( K-1 )*K / 2 ) / D12
+ T = ONE / ( D11*D22-ONE )
+ D12 = T / D12
+*
+ DO 50 J = K - 2, 1, -1
+ WKM1 = D12*( D11*AP( J+( K-2 )*( K-1 ) / 2 )-
+ $ AP( J+( K-1 )*K / 2 ) )
+ WK = D12*( D22*AP( J+( K-1 )*K / 2 )-
+ $ AP( J+( K-2 )*( K-1 ) / 2 ) )
+ DO 40 I = J, 1, -1
+ AP( I+( J-1 )*J / 2 ) = AP( I+( J-1 )*J / 2 ) -
+ $ AP( I+( K-1 )*K / 2 )*WK -
+ $ AP( I+( K-2 )*( K-1 ) / 2 )*WKM1
+ 40 CONTINUE
+ AP( J+( K-1 )*K / 2 ) = WK
+ AP( J+( K-2 )*( K-1 ) / 2 ) = WKM1
+ 50 CONTINUE
+*
+ END IF
+*
+ END IF
+ END IF
+*
+* Store details of the interchanges in IPIV
+*
+ IF( KSTEP.EQ.1 ) THEN
+ IPIV( K ) = KP
+ ELSE
+ IPIV( K ) = -KP
+ IPIV( K-1 ) = -KP
+ END IF
+*
+* Decrease K and return to the start of the main loop
+*
+ K = K - KSTEP
+ KC = KNC - K
+ GO TO 10
+*
+ ELSE
+*
+* Factorize A as L*D*L' using the lower triangle of A
+*
+* K is the main loop index, increasing from 1 to N in steps of
+* 1 or 2
+*
+ K = 1
+ KC = 1
+ NPP = N*( N+1 ) / 2
+ 60 CONTINUE
+ KNC = KC
+*
+* If K > N, exit from loop
+*
+ IF( K.GT.N )
+ $ GO TO 110
+ KSTEP = 1
+*
+* Determine rows and columns to be interchanged and whether
+* a 1-by-1 or 2-by-2 pivot block will be used
+*
+ ABSAKK = ABS( AP( KC ) )
+*
+* IMAX is the row-index of the largest off-diagonal element in
+* column K, and COLMAX is its absolute value
+*
+ IF( K.LT.N ) THEN
+ IMAX = K + ISAMAX( N-K, AP( KC+1 ), 1 )
+ COLMAX = ABS( AP( KC+IMAX-K ) )
+ ELSE
+ COLMAX = ZERO
+ END IF
+*
+ IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN
+*
+* Column K is zero: set INFO and continue
+*
+ IF( INFO.EQ.0 )
+ $ INFO = K
+ KP = K
+ ELSE
+ IF( ABSAKK.GE.ALPHA*COLMAX ) THEN
+*
+* no interchange, use 1-by-1 pivot block
+*
+ KP = K
+ ELSE
+*
+* JMAX is the column-index of the largest off-diagonal
+* element in row IMAX, and ROWMAX is its absolute value
+*
+ ROWMAX = ZERO
+ KX = KC + IMAX - K
+ DO 70 J = K, IMAX - 1
+ IF( ABS( AP( KX ) ).GT.ROWMAX ) THEN
+ ROWMAX = ABS( AP( KX ) )
+ JMAX = J
+ END IF
+ KX = KX + N - J
+ 70 CONTINUE
+ KPC = NPP - ( N-IMAX+1 )*( N-IMAX+2 ) / 2 + 1
+ IF( IMAX.LT.N ) THEN
+ JMAX = IMAX + ISAMAX( N-IMAX, AP( KPC+1 ), 1 )
+ ROWMAX = MAX( ROWMAX, ABS( AP( KPC+JMAX-IMAX ) ) )
+ END IF
+*
+ IF( ABSAKK.GE.ALPHA*COLMAX*( COLMAX / ROWMAX ) ) THEN
+*
+* no interchange, use 1-by-1 pivot block
+*
+ KP = K
+ ELSE IF( ABS( AP( KPC ) ).GE.ALPHA*ROWMAX ) THEN
+*
+* interchange rows and columns K and IMAX, use 1-by-1
+* pivot block
+*
+ KP = IMAX
+ ELSE
+*
+* interchange rows and columns K+1 and IMAX, use 2-by-2
+* pivot block
+*
+ KP = IMAX
+ KSTEP = 2
+ END IF
+ END IF
+*
+ KK = K + KSTEP - 1
+ IF( KSTEP.EQ.2 )
+ $ KNC = KNC + N - K + 1
+ IF( KP.NE.KK ) THEN
+*
+* Interchange rows and columns KK and KP in the trailing
+* submatrix A(k:n,k:n)
+*
+ IF( KP.LT.N )
+ $ CALL SSWAP( N-KP, AP( KNC+KP-KK+1 ), 1, AP( KPC+1 ),
+ $ 1 )
+ KX = KNC + KP - KK
+ DO 80 J = KK + 1, KP - 1
+ KX = KX + N - J + 1
+ T = AP( KNC+J-KK )
+ AP( KNC+J-KK ) = AP( KX )
+ AP( KX ) = T
+ 80 CONTINUE
+ T = AP( KNC )
+ AP( KNC ) = AP( KPC )
+ AP( KPC ) = T
+ IF( KSTEP.EQ.2 ) THEN
+ T = AP( KC+1 )
+ AP( KC+1 ) = AP( KC+KP-K )
+ AP( KC+KP-K ) = T
+ END IF
+ END IF
+*
+* Update the trailing submatrix
+*
+ IF( KSTEP.EQ.1 ) THEN
+*
+* 1-by-1 pivot block D(k): column k now holds
+*
+* W(k) = L(k)*D(k)
+*
+* where L(k) is the k-th column of L
+*
+ IF( K.LT.N ) THEN
+*
+* Perform a rank-1 update of A(k+1:n,k+1:n) as
+*
+* A := A - L(k)*D(k)*L(k)' = A - W(k)*(1/D(k))*W(k)'
+*
+ R1 = ONE / AP( KC )
+ CALL SSPR( UPLO, N-K, -R1, AP( KC+1 ), 1,
+ $ AP( KC+N-K+1 ) )
+*
+* Store L(k) in column K
+*
+ CALL SSCAL( N-K, R1, AP( KC+1 ), 1 )
+ END IF
+ ELSE
+*
+* 2-by-2 pivot block D(k): columns K and K+1 now hold
+*
+* ( W(k) W(k+1) ) = ( L(k) L(k+1) )*D(k)
+*
+* where L(k) and L(k+1) are the k-th and (k+1)-th columns
+* of L
+*
+ IF( K.LT.N-1 ) THEN
+*
+* Perform a rank-2 update of A(k+2:n,k+2:n) as
+*
+* A := A - ( L(k) L(k+1) )*D(k)*( L(k) L(k+1) )'
+* = A - ( W(k) W(k+1) )*inv(D(k))*( W(k) W(k+1) )'
+*
+ D21 = AP( K+1+( K-1 )*( 2*N-K ) / 2 )
+ D11 = AP( K+1+K*( 2*N-K-1 ) / 2 ) / D21
+ D22 = AP( K+( K-1 )*( 2*N-K ) / 2 ) / D21
+ T = ONE / ( D11*D22-ONE )
+ D21 = T / D21
+*
+ DO 100 J = K + 2, N
+ WK = D21*( D11*AP( J+( K-1 )*( 2*N-K ) / 2 )-
+ $ AP( J+K*( 2*N-K-1 ) / 2 ) )
+ WKP1 = D21*( D22*AP( J+K*( 2*N-K-1 ) / 2 )-
+ $ AP( J+( K-1 )*( 2*N-K ) / 2 ) )
+*
+ DO 90 I = J, N
+ AP( I+( J-1 )*( 2*N-J ) / 2 ) = AP( I+( J-1 )*
+ $ ( 2*N-J ) / 2 ) - AP( I+( K-1 )*( 2*N-K ) /
+ $ 2 )*WK - AP( I+K*( 2*N-K-1 ) / 2 )*WKP1
+ 90 CONTINUE
+*
+ AP( J+( K-1 )*( 2*N-K ) / 2 ) = WK
+ AP( J+K*( 2*N-K-1 ) / 2 ) = WKP1
+*
+ 100 CONTINUE
+ END IF
+ END IF
+ END IF
+*
+* Store details of the interchanges in IPIV
+*
+ IF( KSTEP.EQ.1 ) THEN
+ IPIV( K ) = KP
+ ELSE
+ IPIV( K ) = -KP
+ IPIV( K+1 ) = -KP
+ END IF
+*
+* Increase K and return to the start of the main loop
+*
+ K = K + KSTEP
+ KC = KNC + N - K + 2
+ GO TO 60
+*
+ END IF
+*
+ 110 CONTINUE
+ RETURN
+*
+* End of SSPTRF
+*
+ END
+ SUBROUTINE SSPTRI( UPLO, N, AP, IPIV, WORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, N
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ REAL AP( * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SSPTRI computes the inverse of a real symmetric indefinite matrix
+* A in packed storage using the factorization A = U*D*U**T or
+* A = L*D*L**T computed by SSPTRF.
+*
+* Arguments
+* =========
+*
+* UPLO (input) CHARACTER*1
+* Specifies whether the details of the factorization are stored
+* as an upper or lower triangular matrix.
+* = 'U': Upper triangular, form is A = U*D*U**T;
+* = 'L': Lower triangular, form is A = L*D*L**T.
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* AP (input/output) REAL array, dimension (N*(N+1)/2)
+* On entry, the block diagonal matrix D and the multipliers
+* used to obtain the factor U or L as computed by SSPTRF,
+* stored as a packed triangular matrix.
+*
+* On exit, if INFO = 0, the (symmetric) inverse of the original
+* matrix, stored as a packed triangular matrix. The j-th column
+* of inv(A) is stored in the array AP as follows:
+* if UPLO = 'U', AP(i + (j-1)*j/2) = inv(A)(i,j) for 1<=i<=j;
+* if UPLO = 'L',
+* AP(i + (j-1)*(2n-j)/2) = inv(A)(i,j) for j<=i<=n.
+*
+* IPIV (input) INTEGER array, dimension (N)
+* Details of the interchanges and the block structure of D
+* as determined by SSPTRF.
+*
+* WORK (workspace) REAL array, dimension (N)
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its
+* inverse could not be computed.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ONE, ZERO
+ PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL UPPER
+ INTEGER J, K, KC, KCNEXT, KP, KPC, KSTEP, KX, NPP
+ REAL AK, AKKP1, AKP1, D, T, TEMP
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ REAL SDOT
+ EXTERNAL LSAME, SDOT
+* ..
+* .. External Subroutines ..
+ EXTERNAL SCOPY, SSPMV, SSWAP, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SSPTRI', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+* Check that the diagonal matrix D is nonsingular.
+*
+ IF( UPPER ) THEN
+*
+* Upper triangular storage: examine D from bottom to top
+*
+ KP = N*( N+1 ) / 2
+ DO 10 INFO = N, 1, -1
+ IF( IPIV( INFO ).GT.0 .AND. AP( KP ).EQ.ZERO )
+ $ RETURN
+ KP = KP - INFO
+ 10 CONTINUE
+ ELSE
+*
+* Lower triangular storage: examine D from top to bottom.
+*
+ KP = 1
+ DO 20 INFO = 1, N
+ IF( IPIV( INFO ).GT.0 .AND. AP( KP ).EQ.ZERO )
+ $ RETURN
+ KP = KP + N - INFO + 1
+ 20 CONTINUE
+ END IF
+ INFO = 0
+*
+ IF( UPPER ) THEN
+*
+* Compute inv(A) from the factorization A = U*D*U'.
+*
+* K is the main loop index, increasing from 1 to N in steps of
+* 1 or 2, depending on the size of the diagonal blocks.
+*
+ K = 1
+ KC = 1
+ 30 CONTINUE
+*
+* If K > N, exit from loop.
+*
+ IF( K.GT.N )
+ $ GO TO 50
+*
+ KCNEXT = KC + K
+ IF( IPIV( K ).GT.0 ) THEN
+*
+* 1 x 1 diagonal block
+*
+* Invert the diagonal block.
+*
+ AP( KC+K-1 ) = ONE / AP( KC+K-1 )
+*
+* Compute column K of the inverse.
+*
+ IF( K.GT.1 ) THEN
+ CALL SCOPY( K-1, AP( KC ), 1, WORK, 1 )
+ CALL SSPMV( UPLO, K-1, -ONE, AP, WORK, 1, ZERO, AP( KC ),
+ $ 1 )
+ AP( KC+K-1 ) = AP( KC+K-1 ) -
+ $ SDOT( K-1, WORK, 1, AP( KC ), 1 )
+ END IF
+ KSTEP = 1
+ ELSE
+*
+* 2 x 2 diagonal block
+*
+* Invert the diagonal block.
+*
+ T = ABS( AP( KCNEXT+K-1 ) )
+ AK = AP( KC+K-1 ) / T
+ AKP1 = AP( KCNEXT+K ) / T
+ AKKP1 = AP( KCNEXT+K-1 ) / T
+ D = T*( AK*AKP1-ONE )
+ AP( KC+K-1 ) = AKP1 / D
+ AP( KCNEXT+K ) = AK / D
+ AP( KCNEXT+K-1 ) = -AKKP1 / D
+*
+* Compute columns K and K+1 of the inverse.
+*
+ IF( K.GT.1 ) THEN
+ CALL SCOPY( K-1, AP( KC ), 1, WORK, 1 )
+ CALL SSPMV( UPLO, K-1, -ONE, AP, WORK, 1, ZERO, AP( KC ),
+ $ 1 )
+ AP( KC+K-1 ) = AP( KC+K-1 ) -
+ $ SDOT( K-1, WORK, 1, AP( KC ), 1 )
+ AP( KCNEXT+K-1 ) = AP( KCNEXT+K-1 ) -
+ $ SDOT( K-1, AP( KC ), 1, AP( KCNEXT ),
+ $ 1 )
+ CALL SCOPY( K-1, AP( KCNEXT ), 1, WORK, 1 )
+ CALL SSPMV( UPLO, K-1, -ONE, AP, WORK, 1, ZERO,
+ $ AP( KCNEXT ), 1 )
+ AP( KCNEXT+K ) = AP( KCNEXT+K ) -
+ $ SDOT( K-1, WORK, 1, AP( KCNEXT ), 1 )
+ END IF
+ KSTEP = 2
+ KCNEXT = KCNEXT + K + 1
+ END IF
+*
+ KP = ABS( IPIV( K ) )
+ IF( KP.NE.K ) THEN
+*
+* Interchange rows and columns K and KP in the leading
+* submatrix A(1:k+1,1:k+1)
+*
+ KPC = ( KP-1 )*KP / 2 + 1
+ CALL SSWAP( KP-1, AP( KC ), 1, AP( KPC ), 1 )
+ KX = KPC + KP - 1
+ DO 40 J = KP + 1, K - 1
+ KX = KX + J - 1
+ TEMP = AP( KC+J-1 )
+ AP( KC+J-1 ) = AP( KX )
+ AP( KX ) = TEMP
+ 40 CONTINUE
+ TEMP = AP( KC+K-1 )
+ AP( KC+K-1 ) = AP( KPC+KP-1 )
+ AP( KPC+KP-1 ) = TEMP
+ IF( KSTEP.EQ.2 ) THEN
+ TEMP = AP( KC+K+K-1 )
+ AP( KC+K+K-1 ) = AP( KC+K+KP-1 )
+ AP( KC+K+KP-1 ) = TEMP
+ END IF
+ END IF
+*
+ K = K + KSTEP
+ KC = KCNEXT
+ GO TO 30
+ 50 CONTINUE
+*
+ ELSE
+*
+* Compute inv(A) from the factorization A = L*D*L'.
+*
+* K is the main loop index, increasing from 1 to N in steps of
+* 1 or 2, depending on the size of the diagonal blocks.
+*
+ NPP = N*( N+1 ) / 2
+ K = N
+ KC = NPP
+ 60 CONTINUE
+*
+* If K < 1, exit from loop.
+*
+ IF( K.LT.1 )
+ $ GO TO 80
+*
+ KCNEXT = KC - ( N-K+2 )
+ IF( IPIV( K ).GT.0 ) THEN
+*
+* 1 x 1 diagonal block
+*
+* Invert the diagonal block.
+*
+ AP( KC ) = ONE / AP( KC )
+*
+* Compute column K of the inverse.
+*
+ IF( K.LT.N ) THEN
+ CALL SCOPY( N-K, AP( KC+1 ), 1, WORK, 1 )
+ CALL SSPMV( UPLO, N-K, -ONE, AP( KC+N-K+1 ), WORK, 1,
+ $ ZERO, AP( KC+1 ), 1 )
+ AP( KC ) = AP( KC ) - SDOT( N-K, WORK, 1, AP( KC+1 ), 1 )
+ END IF
+ KSTEP = 1
+ ELSE
+*
+* 2 x 2 diagonal block
+*
+* Invert the diagonal block.
+*
+ T = ABS( AP( KCNEXT+1 ) )
+ AK = AP( KCNEXT ) / T
+ AKP1 = AP( KC ) / T
+ AKKP1 = AP( KCNEXT+1 ) / T
+ D = T*( AK*AKP1-ONE )
+ AP( KCNEXT ) = AKP1 / D
+ AP( KC ) = AK / D
+ AP( KCNEXT+1 ) = -AKKP1 / D
+*
+* Compute columns K-1 and K of the inverse.
+*
+ IF( K.LT.N ) THEN
+ CALL SCOPY( N-K, AP( KC+1 ), 1, WORK, 1 )
+ CALL SSPMV( UPLO, N-K, -ONE, AP( KC+( N-K+1 ) ), WORK, 1,
+ $ ZERO, AP( KC+1 ), 1 )
+ AP( KC ) = AP( KC ) - SDOT( N-K, WORK, 1, AP( KC+1 ), 1 )
+ AP( KCNEXT+1 ) = AP( KCNEXT+1 ) -
+ $ SDOT( N-K, AP( KC+1 ), 1,
+ $ AP( KCNEXT+2 ), 1 )
+ CALL SCOPY( N-K, AP( KCNEXT+2 ), 1, WORK, 1 )
+ CALL SSPMV( UPLO, N-K, -ONE, AP( KC+( N-K+1 ) ), WORK, 1,
+ $ ZERO, AP( KCNEXT+2 ), 1 )
+ AP( KCNEXT ) = AP( KCNEXT ) -
+ $ SDOT( N-K, WORK, 1, AP( KCNEXT+2 ), 1 )
+ END IF
+ KSTEP = 2
+ KCNEXT = KCNEXT - ( N-K+3 )
+ END IF
+*
+ KP = ABS( IPIV( K ) )
+ IF( KP.NE.K ) THEN
+*
+* Interchange rows and columns K and KP in the trailing
+* submatrix A(k-1:n,k-1:n)
+*
+ KPC = NPP - ( N-KP+1 )*( N-KP+2 ) / 2 + 1
+ IF( KP.LT.N )
+ $ CALL SSWAP( N-KP, AP( KC+KP-K+1 ), 1, AP( KPC+1 ), 1 )
+ KX = KC + KP - K
+ DO 70 J = K + 1, KP - 1
+ KX = KX + N - J + 1
+ TEMP = AP( KC+J-K )
+ AP( KC+J-K ) = AP( KX )
+ AP( KX ) = TEMP
+ 70 CONTINUE
+ TEMP = AP( KC )
+ AP( KC ) = AP( KPC )
+ AP( KPC ) = TEMP
+ IF( KSTEP.EQ.2 ) THEN
+ TEMP = AP( KC-N+K-1 )
+ AP( KC-N+K-1 ) = AP( KC-N+KP-1 )
+ AP( KC-N+KP-1 ) = TEMP
+ END IF
+ END IF
+*
+ K = K - KSTEP
+ KC = KCNEXT
+ GO TO 60
+ 80 CONTINUE
+ END IF
+*
+ RETURN
+*
+* End of SSPTRI
+*
+ END
+ SUBROUTINE SSPTRS( UPLO, N, NRHS, AP, IPIV, B, LDB, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, LDB, N, NRHS
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ REAL AP( * ), B( LDB, * )
+* ..
+*
+* Purpose
+* =======
+*
+* SSPTRS solves a system of linear equations A*X = B with a real
+* symmetric matrix A stored in packed format using the factorization
+* A = U*D*U**T or A = L*D*L**T computed by SSPTRF.
+*
+* Arguments
+* =========
+*
+* UPLO (input) CHARACTER*1
+* Specifies whether the details of the factorization are stored
+* as an upper or lower triangular matrix.
+* = 'U': Upper triangular, form is A = U*D*U**T;
+* = 'L': Lower triangular, form is A = L*D*L**T.
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* NRHS (input) INTEGER
+* The number of right hand sides, i.e., the number of columns
+* of the matrix B. NRHS >= 0.
+*
+* AP (input) REAL array, dimension (N*(N+1)/2)
+* The block diagonal matrix D and the multipliers used to
+* obtain the factor U or L as computed by SSPTRF, stored as a
+* packed triangular matrix.
+*
+* IPIV (input) INTEGER array, dimension (N)
+* Details of the interchanges and the block structure of D
+* as determined by SSPTRF.
+*
+* B (input/output) REAL array, dimension (LDB,NRHS)
+* On entry, the right hand side matrix B.
+* On exit, the solution matrix X.
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. LDB >= max(1,N).
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ONE
+ PARAMETER ( ONE = 1.0E+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL UPPER
+ INTEGER J, K, KC, KP
+ REAL AK, AKM1, AKM1K, BK, BKM1, DENOM
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL SGEMV, SGER, SSCAL, SSWAP, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( NRHS.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -7
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SSPTRS', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 .OR. NRHS.EQ.0 )
+ $ RETURN
+*
+ IF( UPPER ) THEN
+*
+* Solve A*X = B, where A = U*D*U'.
+*
+* First solve U*D*X = B, overwriting B with X.
+*
+* K is the main loop index, decreasing from N to 1 in steps of
+* 1 or 2, depending on the size of the diagonal blocks.
+*
+ K = N
+ KC = N*( N+1 ) / 2 + 1
+ 10 CONTINUE
+*
+* If K < 1, exit from loop.
+*
+ IF( K.LT.1 )
+ $ GO TO 30
+*
+ KC = KC - K
+ IF( IPIV( K ).GT.0 ) THEN
+*
+* 1 x 1 diagonal block
+*
+* Interchange rows K and IPIV(K).
+*
+ KP = IPIV( K )
+ IF( KP.NE.K )
+ $ CALL SSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+*
+* Multiply by inv(U(K)), where U(K) is the transformation
+* stored in column K of A.
+*
+ CALL SGER( K-1, NRHS, -ONE, AP( KC ), 1, B( K, 1 ), LDB,
+ $ B( 1, 1 ), LDB )
+*
+* Multiply by the inverse of the diagonal block.
+*
+ CALL SSCAL( NRHS, ONE / AP( KC+K-1 ), B( K, 1 ), LDB )
+ K = K - 1
+ ELSE
+*
+* 2 x 2 diagonal block
+*
+* Interchange rows K-1 and -IPIV(K).
+*
+ KP = -IPIV( K )
+ IF( KP.NE.K-1 )
+ $ CALL SSWAP( NRHS, B( K-1, 1 ), LDB, B( KP, 1 ), LDB )
+*
+* Multiply by inv(U(K)), where U(K) is the transformation
+* stored in columns K-1 and K of A.
+*
+ CALL SGER( K-2, NRHS, -ONE, AP( KC ), 1, B( K, 1 ), LDB,
+ $ B( 1, 1 ), LDB )
+ CALL SGER( K-2, NRHS, -ONE, AP( KC-( K-1 ) ), 1,
+ $ B( K-1, 1 ), LDB, B( 1, 1 ), LDB )
+*
+* Multiply by the inverse of the diagonal block.
+*
+ AKM1K = AP( KC+K-2 )
+ AKM1 = AP( KC-1 ) / AKM1K
+ AK = AP( KC+K-1 ) / AKM1K
+ DENOM = AKM1*AK - ONE
+ DO 20 J = 1, NRHS
+ BKM1 = B( K-1, J ) / AKM1K
+ BK = B( K, J ) / AKM1K
+ B( K-1, J ) = ( AK*BKM1-BK ) / DENOM
+ B( K, J ) = ( AKM1*BK-BKM1 ) / DENOM
+ 20 CONTINUE
+ KC = KC - K + 1
+ K = K - 2
+ END IF
+*
+ GO TO 10
+ 30 CONTINUE
+*
+* Next solve U'*X = B, overwriting B with X.
+*
+* K is the main loop index, increasing from 1 to N in steps of
+* 1 or 2, depending on the size of the diagonal blocks.
+*
+ K = 1
+ KC = 1
+ 40 CONTINUE
+*
+* If K > N, exit from loop.
+*
+ IF( K.GT.N )
+ $ GO TO 50
+*
+ IF( IPIV( K ).GT.0 ) THEN
+*
+* 1 x 1 diagonal block
+*
+* Multiply by inv(U'(K)), where U(K) is the transformation
+* stored in column K of A.
+*
+ CALL SGEMV( 'Transpose', K-1, NRHS, -ONE, B, LDB, AP( KC ),
+ $ 1, ONE, B( K, 1 ), LDB )
+*
+* Interchange rows K and IPIV(K).
+*
+ KP = IPIV( K )
+ IF( KP.NE.K )
+ $ CALL SSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+ KC = KC + K
+ K = K + 1
+ ELSE
+*
+* 2 x 2 diagonal block
+*
+* Multiply by inv(U'(K+1)), where U(K+1) is the transformation
+* stored in columns K and K+1 of A.
+*
+ CALL SGEMV( 'Transpose', K-1, NRHS, -ONE, B, LDB, AP( KC ),
+ $ 1, ONE, B( K, 1 ), LDB )
+ CALL SGEMV( 'Transpose', K-1, NRHS, -ONE, B, LDB,
+ $ AP( KC+K ), 1, ONE, B( K+1, 1 ), LDB )
+*
+* Interchange rows K and -IPIV(K).
+*
+ KP = -IPIV( K )
+ IF( KP.NE.K )
+ $ CALL SSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+ KC = KC + 2*K + 1
+ K = K + 2
+ END IF
+*
+ GO TO 40
+ 50 CONTINUE
+*
+ ELSE
+*
+* Solve A*X = B, where A = L*D*L'.
+*
+* First solve L*D*X = B, overwriting B with X.
+*
+* K is the main loop index, increasing from 1 to N in steps of
+* 1 or 2, depending on the size of the diagonal blocks.
+*
+ K = 1
+ KC = 1
+ 60 CONTINUE
+*
+* If K > N, exit from loop.
+*
+ IF( K.GT.N )
+ $ GO TO 80
+*
+ IF( IPIV( K ).GT.0 ) THEN
+*
+* 1 x 1 diagonal block
+*
+* Interchange rows K and IPIV(K).
+*
+ KP = IPIV( K )
+ IF( KP.NE.K )
+ $ CALL SSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+*
+* Multiply by inv(L(K)), where L(K) is the transformation
+* stored in column K of A.
+*
+ IF( K.LT.N )
+ $ CALL SGER( N-K, NRHS, -ONE, AP( KC+1 ), 1, B( K, 1 ),
+ $ LDB, B( K+1, 1 ), LDB )
+*
+* Multiply by the inverse of the diagonal block.
+*
+ CALL SSCAL( NRHS, ONE / AP( KC ), B( K, 1 ), LDB )
+ KC = KC + N - K + 1
+ K = K + 1
+ ELSE
+*
+* 2 x 2 diagonal block
+*
+* Interchange rows K+1 and -IPIV(K).
+*
+ KP = -IPIV( K )
+ IF( KP.NE.K+1 )
+ $ CALL SSWAP( NRHS, B( K+1, 1 ), LDB, B( KP, 1 ), LDB )
+*
+* Multiply by inv(L(K)), where L(K) is the transformation
+* stored in columns K and K+1 of A.
+*
+ IF( K.LT.N-1 ) THEN
+ CALL SGER( N-K-1, NRHS, -ONE, AP( KC+2 ), 1, B( K, 1 ),
+ $ LDB, B( K+2, 1 ), LDB )
+ CALL SGER( N-K-1, NRHS, -ONE, AP( KC+N-K+2 ), 1,
+ $ B( K+1, 1 ), LDB, B( K+2, 1 ), LDB )
+ END IF
+*
+* Multiply by the inverse of the diagonal block.
+*
+ AKM1K = AP( KC+1 )
+ AKM1 = AP( KC ) / AKM1K
+ AK = AP( KC+N-K+1 ) / AKM1K
+ DENOM = AKM1*AK - ONE
+ DO 70 J = 1, NRHS
+ BKM1 = B( K, J ) / AKM1K
+ BK = B( K+1, J ) / AKM1K
+ B( K, J ) = ( AK*BKM1-BK ) / DENOM
+ B( K+1, J ) = ( AKM1*BK-BKM1 ) / DENOM
+ 70 CONTINUE
+ KC = KC + 2*( N-K ) + 1
+ K = K + 2
+ END IF
+*
+ GO TO 60
+ 80 CONTINUE
+*
+* Next solve L'*X = B, overwriting B with X.
+*
+* K is the main loop index, decreasing from N to 1 in steps of
+* 1 or 2, depending on the size of the diagonal blocks.
+*
+ K = N
+ KC = N*( N+1 ) / 2 + 1
+ 90 CONTINUE
+*
+* If K < 1, exit from loop.
+*
+ IF( K.LT.1 )
+ $ GO TO 100
+*
+ KC = KC - ( N-K+1 )
+ IF( IPIV( K ).GT.0 ) THEN
+*
+* 1 x 1 diagonal block
+*
+* Multiply by inv(L'(K)), where L(K) is the transformation
+* stored in column K of A.
+*
+ IF( K.LT.N )
+ $ CALL SGEMV( 'Transpose', N-K, NRHS, -ONE, B( K+1, 1 ),
+ $ LDB, AP( KC+1 ), 1, ONE, B( K, 1 ), LDB )
+*
+* Interchange rows K and IPIV(K).
+*
+ KP = IPIV( K )
+ IF( KP.NE.K )
+ $ CALL SSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+ K = K - 1
+ ELSE
+*
+* 2 x 2 diagonal block
+*
+* Multiply by inv(L'(K-1)), where L(K-1) is the transformation
+* stored in columns K-1 and K of A.
+*
+ IF( K.LT.N ) THEN
+ CALL SGEMV( 'Transpose', N-K, NRHS, -ONE, B( K+1, 1 ),
+ $ LDB, AP( KC+1 ), 1, ONE, B( K, 1 ), LDB )
+ CALL SGEMV( 'Transpose', N-K, NRHS, -ONE, B( K+1, 1 ),
+ $ LDB, AP( KC-( N-K ) ), 1, ONE, B( K-1, 1 ),
+ $ LDB )
+ END IF
+*
+* Interchange rows K and -IPIV(K).
+*
+ KP = -IPIV( K )
+ IF( KP.NE.K )
+ $ CALL SSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+ KC = KC - ( N-K+2 )
+ K = K - 2
+ END IF
+*
+ GO TO 90
+ 100 CONTINUE
+ END IF
+*
+ RETURN
+*
+* End of SSPTRS
+*
+ END
+ SUBROUTINE SSTEBZ( RANGE, ORDER, N, VL, VU, IL, IU, ABSTOL, D, E,
+ $ M, NSPLIT, W, IBLOCK, ISPLIT, WORK, IWORK,
+ $ INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+* 8-18-00: Increase FUDGE factor for T3E (eca)
+*
+* .. Scalar Arguments ..
+ CHARACTER ORDER, RANGE
+ INTEGER IL, INFO, IU, M, N, NSPLIT
+ REAL ABSTOL, VL, VU
+* ..
+* .. Array Arguments ..
+ INTEGER IBLOCK( * ), ISPLIT( * ), IWORK( * )
+ REAL D( * ), E( * ), W( * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SSTEBZ computes the eigenvalues of a symmetric tridiagonal
+* matrix T. The user may ask for all eigenvalues, all eigenvalues
+* in the half-open interval (VL, VU], or the IL-th through IU-th
+* eigenvalues.
+*
+* To avoid overflow, the matrix must be scaled so that its
+* largest element is no greater than overflow**(1/2) *
+* underflow**(1/4) in absolute value, and for greatest
+* accuracy, it should not be much smaller than that.
+*
+* See W. Kahan "Accurate Eigenvalues of a Symmetric Tridiagonal
+* Matrix", Report CS41, Computer Science Dept., Stanford
+* University, July 21, 1966.
+*
+* Arguments
+* =========
+*
+* RANGE (input) CHARACTER*1
+* = 'A': ("All") all eigenvalues will be found.
+* = 'V': ("Value") all eigenvalues in the half-open interval
+* (VL, VU] will be found.
+* = 'I': ("Index") the IL-th through IU-th eigenvalues (of the
+* entire matrix) will be found.
+*
+* ORDER (input) CHARACTER*1
+* = 'B': ("By Block") the eigenvalues will be grouped by
+* split-off block (see IBLOCK, ISPLIT) and
+* ordered from smallest to largest within
+* the block.
+* = 'E': ("Entire matrix")
+* the eigenvalues for the entire matrix
+* will be ordered from smallest to
+* largest.
+*
+* N (input) INTEGER
+* The order of the tridiagonal matrix T. N >= 0.
+*
+* VL (input) REAL
+* VU (input) REAL
+* If RANGE='V', the lower and upper bounds of the interval to
+* be searched for eigenvalues. Eigenvalues less than or equal
+* to VL, or greater than VU, will not be returned. VL < VU.
+* Not referenced if RANGE = 'A' or 'I'.
+*
+* IL (input) INTEGER
+* IU (input) INTEGER
+* If RANGE='I', the indices (in ascending order) of the
+* smallest and largest eigenvalues to be returned.
+* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
+* Not referenced if RANGE = 'A' or 'V'.
+*
+* ABSTOL (input) REAL
+* The absolute tolerance for the eigenvalues. An eigenvalue
+* (or cluster) is considered to be located if it has been
+* determined to lie in an interval whose width is ABSTOL or
+* less. If ABSTOL is less than or equal to zero, then ULP*|T|
+* will be used, where |T| means the 1-norm of T.
+*
+* Eigenvalues will be computed most accurately when ABSTOL is
+* set to twice the underflow threshold 2*SLAMCH('S'), not zero.
+*
+* D (input) REAL array, dimension (N)
+* The n diagonal elements of the tridiagonal matrix T.
+*
+* E (input) REAL array, dimension (N-1)
+* The (n-1) off-diagonal elements of the tridiagonal matrix T.
+*
+* M (output) INTEGER
+* The actual number of eigenvalues found. 0 <= M <= N.
+* (See also the description of INFO=2,3.)
+*
+* NSPLIT (output) INTEGER
+* The number of diagonal blocks in the matrix T.
+* 1 <= NSPLIT <= N.
+*
+* W (output) REAL array, dimension (N)
+* On exit, the first M elements of W will contain the
+* eigenvalues. (SSTEBZ may use the remaining N-M elements as
+* workspace.)
+*
+* IBLOCK (output) INTEGER array, dimension (N)
+* At each row/column j where E(j) is zero or small, the
+* matrix T is considered to split into a block diagonal
+* matrix. On exit, if INFO = 0, IBLOCK(i) specifies to which
+* block (from 1 to the number of blocks) the eigenvalue W(i)
+* belongs. (SSTEBZ may use the remaining N-M elements as
+* workspace.)
+*
+* ISPLIT (output) INTEGER array, dimension (N)
+* The splitting points, at which T breaks up into submatrices.
+* The first submatrix consists of rows/columns 1 to ISPLIT(1),
+* the second of rows/columns ISPLIT(1)+1 through ISPLIT(2),
+* etc., and the NSPLIT-th consists of rows/columns
+* ISPLIT(NSPLIT-1)+1 through ISPLIT(NSPLIT)=N.
+* (Only the first NSPLIT elements will actually be used, but
+* since the user cannot know a priori what value NSPLIT will
+* have, N words must be reserved for ISPLIT.)
+*
+* WORK (workspace) REAL array, dimension (4*N)
+*
+* IWORK (workspace) INTEGER array, dimension (3*N)
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* > 0: some or all of the eigenvalues failed to converge or
+* were not computed:
+* =1 or 3: Bisection failed to converge for some
+* eigenvalues; these eigenvalues are flagged by a
+* negative block number. The effect is that the
+* eigenvalues may not be as accurate as the
+* absolute and relative tolerances. This is
+* generally caused by unexpectedly inaccurate
+* arithmetic.
+* =2 or 3: RANGE='I' only: Not all of the eigenvalues
+* IL:IU were found.
+* Effect: M < IU+1-IL
+* Cause: non-monotonic arithmetic, causing the
+* Sturm sequence to be non-monotonic.
+* Cure: recalculate, using RANGE='A', and pick
+* out eigenvalues IL:IU. In some cases,
+* increasing the PARAMETER "FUDGE" may
+* make things work.
+* = 4: RANGE='I', and the Gershgorin interval
+* initially used was too small. No eigenvalues
+* were computed.
+* Probable cause: your machine has sloppy
+* floating-point arithmetic.
+* Cure: Increase the PARAMETER "FUDGE",
+* recompile, and try again.
+*
+* Internal Parameters
+* ===================
+*
+* RELFAC REAL, default = 2.0e0
+* The relative tolerance. An interval (a,b] lies within
+* "relative tolerance" if b-a < RELFAC*ulp*max(|a|,|b|),
+* where "ulp" is the machine precision (distance from 1 to
+* the next larger floating point number.)
+*
+* FUDGE REAL, default = 2
+* A "fudge factor" to widen the Gershgorin intervals. Ideally,
+* a value of 1 should work, but on machines with sloppy
+* arithmetic, this needs to be larger. The default for
+* publicly released versions should be large enough to handle
+* the worst machine around. Note that this has no effect
+* on accuracy of the solution.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO, ONE, TWO, HALF
+ PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0, TWO = 2.0E0,
+ $ HALF = 1.0E0 / TWO )
+ REAL FUDGE, RELFAC
+ PARAMETER ( FUDGE = 2.1E0, RELFAC = 2.0E0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL NCNVRG, TOOFEW
+ INTEGER IB, IBEGIN, IDISCL, IDISCU, IE, IEND, IINFO,
+ $ IM, IN, IOFF, IORDER, IOUT, IRANGE, ITMAX,
+ $ ITMP1, IW, IWOFF, J, JB, JDISC, JE, NB, NWL,
+ $ NWU
+ REAL ATOLI, BNORM, GL, GU, PIVMIN, RTOLI, SAFEMN,
+ $ TMP1, TMP2, TNORM, ULP, WKILL, WL, WLU, WU, WUL
+* ..
+* .. Local Arrays ..
+ INTEGER IDUMMA( 1 )
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ILAENV
+ REAL SLAMCH
+ EXTERNAL LSAME, ILAENV, SLAMCH
+* ..
+* .. External Subroutines ..
+ EXTERNAL SLAEBZ, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, INT, LOG, MAX, MIN, SQRT
+* ..
+* .. Executable Statements ..
+*
+ INFO = 0
+*
+* Decode RANGE
+*
+ IF( LSAME( RANGE, 'A' ) ) THEN
+ IRANGE = 1
+ ELSE IF( LSAME( RANGE, 'V' ) ) THEN
+ IRANGE = 2
+ ELSE IF( LSAME( RANGE, 'I' ) ) THEN
+ IRANGE = 3
+ ELSE
+ IRANGE = 0
+ END IF
+*
+* Decode ORDER
+*
+ IF( LSAME( ORDER, 'B' ) ) THEN
+ IORDER = 2
+ ELSE IF( LSAME( ORDER, 'E' ) ) THEN
+ IORDER = 1
+ ELSE
+ IORDER = 0
+ END IF
+*
+* Check for Errors
+*
+ IF( IRANGE.LE.0 ) THEN
+ INFO = -1
+ ELSE IF( IORDER.LE.0 ) THEN
+ INFO = -2
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( IRANGE.EQ.2 ) THEN
+ IF( VL.GE.VU ) INFO = -5
+ ELSE IF( IRANGE.EQ.3 .AND. ( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) )
+ $ THEN
+ INFO = -6
+ ELSE IF( IRANGE.EQ.3 .AND. ( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) )
+ $ THEN
+ INFO = -7
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SSTEBZ', -INFO )
+ RETURN
+ END IF
+*
+* Initialize error flags
+*
+ INFO = 0
+ NCNVRG = .FALSE.
+ TOOFEW = .FALSE.
+*
+* Quick return if possible
+*
+ M = 0
+ IF( N.EQ.0 )
+ $ RETURN
+*
+* Simplifications:
+*
+ IF( IRANGE.EQ.3 .AND. IL.EQ.1 .AND. IU.EQ.N )
+ $ IRANGE = 1
+*
+* Get machine constants
+* NB is the minimum vector length for vector bisection, or 0
+* if only scalar is to be done.
+*
+ SAFEMN = SLAMCH( 'S' )
+ ULP = SLAMCH( 'P' )
+ RTOLI = ULP*RELFAC
+ NB = ILAENV( 1, 'SSTEBZ', ' ', N, -1, -1, -1 )
+ IF( NB.LE.1 )
+ $ NB = 0
+*
+* Special Case when N=1
+*
+ IF( N.EQ.1 ) THEN
+ NSPLIT = 1
+ ISPLIT( 1 ) = 1
+ IF( IRANGE.EQ.2 .AND. ( VL.GE.D( 1 ) .OR. VU.LT.D( 1 ) ) ) THEN
+ M = 0
+ ELSE
+ W( 1 ) = D( 1 )
+ IBLOCK( 1 ) = 1
+ M = 1
+ END IF
+ RETURN
+ END IF
+*
+* Compute Splitting Points
+*
+ NSPLIT = 1
+ WORK( N ) = ZERO
+ PIVMIN = ONE
+*
+CDIR$ NOVECTOR
+ DO 10 J = 2, N
+ TMP1 = E( J-1 )**2
+ IF( ABS( D( J )*D( J-1 ) )*ULP**2+SAFEMN.GT.TMP1 ) THEN
+ ISPLIT( NSPLIT ) = J - 1
+ NSPLIT = NSPLIT + 1
+ WORK( J-1 ) = ZERO
+ ELSE
+ WORK( J-1 ) = TMP1
+ PIVMIN = MAX( PIVMIN, TMP1 )
+ END IF
+ 10 CONTINUE
+ ISPLIT( NSPLIT ) = N
+ PIVMIN = PIVMIN*SAFEMN
+*
+* Compute Interval and ATOLI
+*
+ IF( IRANGE.EQ.3 ) THEN
+*
+* RANGE='I': Compute the interval containing eigenvalues
+* IL through IU.
+*
+* Compute Gershgorin interval for entire (split) matrix
+* and use it as the initial interval
+*
+ GU = D( 1 )
+ GL = D( 1 )
+ TMP1 = ZERO
+*
+ DO 20 J = 1, N - 1
+ TMP2 = SQRT( WORK( J ) )
+ GU = MAX( GU, D( J )+TMP1+TMP2 )
+ GL = MIN( GL, D( J )-TMP1-TMP2 )
+ TMP1 = TMP2
+ 20 CONTINUE
+*
+ GU = MAX( GU, D( N )+TMP1 )
+ GL = MIN( GL, D( N )-TMP1 )
+ TNORM = MAX( ABS( GL ), ABS( GU ) )
+ GL = GL - FUDGE*TNORM*ULP*N - FUDGE*TWO*PIVMIN
+ GU = GU + FUDGE*TNORM*ULP*N + FUDGE*PIVMIN
+*
+* Compute Iteration parameters
+*
+ ITMAX = INT( ( LOG( TNORM+PIVMIN )-LOG( PIVMIN ) ) /
+ $ LOG( TWO ) ) + 2
+ IF( ABSTOL.LE.ZERO ) THEN
+ ATOLI = ULP*TNORM
+ ELSE
+ ATOLI = ABSTOL
+ END IF
+*
+ WORK( N+1 ) = GL
+ WORK( N+2 ) = GL
+ WORK( N+3 ) = GU
+ WORK( N+4 ) = GU
+ WORK( N+5 ) = GL
+ WORK( N+6 ) = GU
+ IWORK( 1 ) = -1
+ IWORK( 2 ) = -1
+ IWORK( 3 ) = N + 1
+ IWORK( 4 ) = N + 1
+ IWORK( 5 ) = IL - 1
+ IWORK( 6 ) = IU
+*
+ CALL SLAEBZ( 3, ITMAX, N, 2, 2, NB, ATOLI, RTOLI, PIVMIN, D, E,
+ $ WORK, IWORK( 5 ), WORK( N+1 ), WORK( N+5 ), IOUT,
+ $ IWORK, W, IBLOCK, IINFO )
+*
+ IF( IWORK( 6 ).EQ.IU ) THEN
+ WL = WORK( N+1 )
+ WLU = WORK( N+3 )
+ NWL = IWORK( 1 )
+ WU = WORK( N+4 )
+ WUL = WORK( N+2 )
+ NWU = IWORK( 4 )
+ ELSE
+ WL = WORK( N+2 )
+ WLU = WORK( N+4 )
+ NWL = IWORK( 2 )
+ WU = WORK( N+3 )
+ WUL = WORK( N+1 )
+ NWU = IWORK( 3 )
+ END IF
+*
+ IF( NWL.LT.0 .OR. NWL.GE.N .OR. NWU.LT.1 .OR. NWU.GT.N ) THEN
+ INFO = 4
+ RETURN
+ END IF
+ ELSE
+*
+* RANGE='A' or 'V' -- Set ATOLI
+*
+ TNORM = MAX( ABS( D( 1 ) )+ABS( E( 1 ) ),
+ $ ABS( D( N ) )+ABS( E( N-1 ) ) )
+*
+ DO 30 J = 2, N - 1
+ TNORM = MAX( TNORM, ABS( D( J ) )+ABS( E( J-1 ) )+
+ $ ABS( E( J ) ) )
+ 30 CONTINUE
+*
+ IF( ABSTOL.LE.ZERO ) THEN
+ ATOLI = ULP*TNORM
+ ELSE
+ ATOLI = ABSTOL
+ END IF
+*
+ IF( IRANGE.EQ.2 ) THEN
+ WL = VL
+ WU = VU
+ ELSE
+ WL = ZERO
+ WU = ZERO
+ END IF
+ END IF
+*
+* Find Eigenvalues -- Loop Over Blocks and recompute NWL and NWU.
+* NWL accumulates the number of eigenvalues .le. WL,
+* NWU accumulates the number of eigenvalues .le. WU
+*
+ M = 0
+ IEND = 0
+ INFO = 0
+ NWL = 0
+ NWU = 0
+*
+ DO 70 JB = 1, NSPLIT
+ IOFF = IEND
+ IBEGIN = IOFF + 1
+ IEND = ISPLIT( JB )
+ IN = IEND - IOFF
+*
+ IF( IN.EQ.1 ) THEN
+*
+* Special Case -- IN=1
+*
+ IF( IRANGE.EQ.1 .OR. WL.GE.D( IBEGIN )-PIVMIN )
+ $ NWL = NWL + 1
+ IF( IRANGE.EQ.1 .OR. WU.GE.D( IBEGIN )-PIVMIN )
+ $ NWU = NWU + 1
+ IF( IRANGE.EQ.1 .OR. ( WL.LT.D( IBEGIN )-PIVMIN .AND. WU.GE.
+ $ D( IBEGIN )-PIVMIN ) ) THEN
+ M = M + 1
+ W( M ) = D( IBEGIN )
+ IBLOCK( M ) = JB
+ END IF
+ ELSE
+*
+* General Case -- IN > 1
+*
+* Compute Gershgorin Interval
+* and use it as the initial interval
+*
+ GU = D( IBEGIN )
+ GL = D( IBEGIN )
+ TMP1 = ZERO
+*
+ DO 40 J = IBEGIN, IEND - 1
+ TMP2 = ABS( E( J ) )
+ GU = MAX( GU, D( J )+TMP1+TMP2 )
+ GL = MIN( GL, D( J )-TMP1-TMP2 )
+ TMP1 = TMP2
+ 40 CONTINUE
+*
+ GU = MAX( GU, D( IEND )+TMP1 )
+ GL = MIN( GL, D( IEND )-TMP1 )
+ BNORM = MAX( ABS( GL ), ABS( GU ) )
+ GL = GL - FUDGE*BNORM*ULP*IN - FUDGE*PIVMIN
+ GU = GU + FUDGE*BNORM*ULP*IN + FUDGE*PIVMIN
+*
+* Compute ATOLI for the current submatrix
+*
+ IF( ABSTOL.LE.ZERO ) THEN
+ ATOLI = ULP*MAX( ABS( GL ), ABS( GU ) )
+ ELSE
+ ATOLI = ABSTOL
+ END IF
+*
+ IF( IRANGE.GT.1 ) THEN
+ IF( GU.LT.WL ) THEN
+ NWL = NWL + IN
+ NWU = NWU + IN
+ GO TO 70
+ END IF
+ GL = MAX( GL, WL )
+ GU = MIN( GU, WU )
+ IF( GL.GE.GU )
+ $ GO TO 70
+ END IF
+*
+* Set Up Initial Interval
+*
+ WORK( N+1 ) = GL
+ WORK( N+IN+1 ) = GU
+ CALL SLAEBZ( 1, 0, IN, IN, 1, NB, ATOLI, RTOLI, PIVMIN,
+ $ D( IBEGIN ), E( IBEGIN ), WORK( IBEGIN ),
+ $ IDUMMA, WORK( N+1 ), WORK( N+2*IN+1 ), IM,
+ $ IWORK, W( M+1 ), IBLOCK( M+1 ), IINFO )
+*
+ NWL = NWL + IWORK( 1 )
+ NWU = NWU + IWORK( IN+1 )
+ IWOFF = M - IWORK( 1 )
+*
+* Compute Eigenvalues
+*
+ ITMAX = INT( ( LOG( GU-GL+PIVMIN )-LOG( PIVMIN ) ) /
+ $ LOG( TWO ) ) + 2
+ CALL SLAEBZ( 2, ITMAX, IN, IN, 1, NB, ATOLI, RTOLI, PIVMIN,
+ $ D( IBEGIN ), E( IBEGIN ), WORK( IBEGIN ),
+ $ IDUMMA, WORK( N+1 ), WORK( N+2*IN+1 ), IOUT,
+ $ IWORK, W( M+1 ), IBLOCK( M+1 ), IINFO )
+*
+* Copy Eigenvalues Into W and IBLOCK
+* Use -JB for block number for unconverged eigenvalues.
+*
+ DO 60 J = 1, IOUT
+ TMP1 = HALF*( WORK( J+N )+WORK( J+IN+N ) )
+*
+* Flag non-convergence.
+*
+ IF( J.GT.IOUT-IINFO ) THEN
+ NCNVRG = .TRUE.
+ IB = -JB
+ ELSE
+ IB = JB
+ END IF
+ DO 50 JE = IWORK( J ) + 1 + IWOFF,
+ $ IWORK( J+IN ) + IWOFF
+ W( JE ) = TMP1
+ IBLOCK( JE ) = IB
+ 50 CONTINUE
+ 60 CONTINUE
+*
+ M = M + IM
+ END IF
+ 70 CONTINUE
+*
+* If RANGE='I', then (WL,WU) contains eigenvalues NWL+1,...,NWU
+* If NWL+1 < IL or NWU > IU, discard extra eigenvalues.
+*
+ IF( IRANGE.EQ.3 ) THEN
+ IM = 0
+ IDISCL = IL - 1 - NWL
+ IDISCU = NWU - IU
+*
+ IF( IDISCL.GT.0 .OR. IDISCU.GT.0 ) THEN
+ DO 80 JE = 1, M
+ IF( W( JE ).LE.WLU .AND. IDISCL.GT.0 ) THEN
+ IDISCL = IDISCL - 1
+ ELSE IF( W( JE ).GE.WUL .AND. IDISCU.GT.0 ) THEN
+ IDISCU = IDISCU - 1
+ ELSE
+ IM = IM + 1
+ W( IM ) = W( JE )
+ IBLOCK( IM ) = IBLOCK( JE )
+ END IF
+ 80 CONTINUE
+ M = IM
+ END IF
+ IF( IDISCL.GT.0 .OR. IDISCU.GT.0 ) THEN
+*
+* Code to deal with effects of bad arithmetic:
+* Some low eigenvalues to be discarded are not in (WL,WLU],
+* or high eigenvalues to be discarded are not in (WUL,WU]
+* so just kill off the smallest IDISCL/largest IDISCU
+* eigenvalues, by simply finding the smallest/largest
+* eigenvalue(s).
+*
+* (If N(w) is monotone non-decreasing, this should never
+* happen.)
+*
+ IF( IDISCL.GT.0 ) THEN
+ WKILL = WU
+ DO 100 JDISC = 1, IDISCL
+ IW = 0
+ DO 90 JE = 1, M
+ IF( IBLOCK( JE ).NE.0 .AND.
+ $ ( W( JE ).LT.WKILL .OR. IW.EQ.0 ) ) THEN
+ IW = JE
+ WKILL = W( JE )
+ END IF
+ 90 CONTINUE
+ IBLOCK( IW ) = 0
+ 100 CONTINUE
+ END IF
+ IF( IDISCU.GT.0 ) THEN
+*
+ WKILL = WL
+ DO 120 JDISC = 1, IDISCU
+ IW = 0
+ DO 110 JE = 1, M
+ IF( IBLOCK( JE ).NE.0 .AND.
+ $ ( W( JE ).GT.WKILL .OR. IW.EQ.0 ) ) THEN
+ IW = JE
+ WKILL = W( JE )
+ END IF
+ 110 CONTINUE
+ IBLOCK( IW ) = 0
+ 120 CONTINUE
+ END IF
+ IM = 0
+ DO 130 JE = 1, M
+ IF( IBLOCK( JE ).NE.0 ) THEN
+ IM = IM + 1
+ W( IM ) = W( JE )
+ IBLOCK( IM ) = IBLOCK( JE )
+ END IF
+ 130 CONTINUE
+ M = IM
+ END IF
+ IF( IDISCL.LT.0 .OR. IDISCU.LT.0 ) THEN
+ TOOFEW = .TRUE.
+ END IF
+ END IF
+*
+* If ORDER='B', do nothing -- the eigenvalues are already sorted
+* by block.
+* If ORDER='E', sort the eigenvalues from smallest to largest
+*
+ IF( IORDER.EQ.1 .AND. NSPLIT.GT.1 ) THEN
+ DO 150 JE = 1, M - 1
+ IE = 0
+ TMP1 = W( JE )
+ DO 140 J = JE + 1, M
+ IF( W( J ).LT.TMP1 ) THEN
+ IE = J
+ TMP1 = W( J )
+ END IF
+ 140 CONTINUE
+*
+ IF( IE.NE.0 ) THEN
+ ITMP1 = IBLOCK( IE )
+ W( IE ) = W( JE )
+ IBLOCK( IE ) = IBLOCK( JE )
+ W( JE ) = TMP1
+ IBLOCK( JE ) = ITMP1
+ END IF
+ 150 CONTINUE
+ END IF
+*
+ INFO = 0
+ IF( NCNVRG )
+ $ INFO = INFO + 1
+ IF( TOOFEW )
+ $ INFO = INFO + 2
+ RETURN
+*
+* End of SSTEBZ
+*
+ END
+ SUBROUTINE SSTEDC( COMPZ, N, D, E, Z, LDZ, WORK, LWORK, IWORK,
+ $ LIWORK, INFO )
+*
+* -- LAPACK driver routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER COMPZ
+ INTEGER INFO, LDZ, LIWORK, LWORK, N
+* ..
+* .. Array Arguments ..
+ INTEGER IWORK( * )
+ REAL D( * ), E( * ), WORK( * ), Z( LDZ, * )
+* ..
+*
+* Purpose
+* =======
+*
+* SSTEDC computes all eigenvalues and, optionally, eigenvectors of a
+* symmetric tridiagonal matrix using the divide and conquer method.
+* The eigenvectors of a full or band real symmetric matrix can also be
+* found if SSYTRD or SSPTRD or SSBTRD has been used to reduce this
+* matrix to tridiagonal form.
+*
+* This code makes very mild assumptions about floating point
+* arithmetic. It will work on machines with a guard digit in
+* add/subtract, or on those binary machines without guard digits
+* which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or Cray-2.
+* It could conceivably fail on hexadecimal or decimal machines
+* without guard digits, but we know of none. See SLAED3 for details.
+*
+* Arguments
+* =========
+*
+* COMPZ (input) CHARACTER*1
+* = 'N': Compute eigenvalues only.
+* = 'I': Compute eigenvectors of tridiagonal matrix also.
+* = 'V': Compute eigenvectors of original dense symmetric
+* matrix also. On entry, Z contains the orthogonal
+* matrix used to reduce the original matrix to
+* tridiagonal form.
+*
+* N (input) INTEGER
+* The dimension of the symmetric tridiagonal matrix. N >= 0.
+*
+* D (input/output) REAL array, dimension (N)
+* On entry, the diagonal elements of the tridiagonal matrix.
+* On exit, if INFO = 0, the eigenvalues in ascending order.
+*
+* E (input/output) REAL array, dimension (N-1)
+* On entry, the subdiagonal elements of the tridiagonal matrix.
+* On exit, E has been destroyed.
+*
+* Z (input/output) REAL array, dimension (LDZ,N)
+* On entry, if COMPZ = 'V', then Z contains the orthogonal
+* matrix used in the reduction to tridiagonal form.
+* On exit, if INFO = 0, then if COMPZ = 'V', Z contains the
+* orthonormal eigenvectors of the original symmetric matrix,
+* and if COMPZ = 'I', Z contains the orthonormal eigenvectors
+* of the symmetric tridiagonal matrix.
+* If COMPZ = 'N', then Z is not referenced.
+*
+* LDZ (input) INTEGER
+* The leading dimension of the array Z. LDZ >= 1.
+* If eigenvectors are desired, then LDZ >= max(1,N).
+*
+* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))
+* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+* LWORK (input) INTEGER
+* The dimension of the array WORK.
+* If COMPZ = 'N' or N <= 1 then LWORK must be at least 1.
+* If COMPZ = 'V' and N > 1 then LWORK must be at least
+* ( 1 + 3*N + 2*N*lg N + 3*N**2 ),
+* where lg( N ) = smallest integer k such
+* that 2**k >= N.
+* If COMPZ = 'I' and N > 1 then LWORK must be at least
+* ( 1 + 4*N + N**2 ).
+* Note that for COMPZ = 'I' or 'V', then if N is less than or
+* equal to the minimum divide size, usually 25, then LWORK need
+* only be max(1,2*(N-1)).
+*
+* If LWORK = -1, then a workspace query is assumed; the routine
+* only calculates the optimal size of the WORK array, returns
+* this value as the first entry of the WORK array, and no error
+* message related to LWORK is issued by XERBLA.
+*
+* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))
+* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
+*
+* LIWORK (input) INTEGER
+* The dimension of the array IWORK.
+* If COMPZ = 'N' or N <= 1 then LIWORK must be at least 1.
+* If COMPZ = 'V' and N > 1 then LIWORK must be at least
+* ( 6 + 6*N + 5*N*lg N ).
+* If COMPZ = 'I' and N > 1 then LIWORK must be at least
+* ( 3 + 5*N ).
+* Note that for COMPZ = 'I' or 'V', then if N is less than or
+* equal to the minimum divide size, usually 25, then LIWORK
+* need only be 1.
+*
+* If LIWORK = -1, then a workspace query is assumed; the
+* routine only calculates the optimal size of the IWORK array,
+* returns this value as the first entry of the IWORK array, and
+* no error message related to LIWORK is issued by XERBLA.
+*
+* INFO (output) INTEGER
+* = 0: successful exit.
+* < 0: if INFO = -i, the i-th argument had an illegal value.
+* > 0: The algorithm failed to compute an eigenvalue while
+* working on the submatrix lying in rows and columns
+* INFO/(N+1) through mod(INFO,N+1).
+*
+* Further Details
+* ===============
+*
+* Based on contributions by
+* Jeff Rutter, Computer Science Division, University of California
+* at Berkeley, USA
+* Modified by Francoise Tisseur, University of Tennessee.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO, ONE, TWO
+ PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0, TWO = 2.0E0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL LQUERY
+ INTEGER FINISH, I, ICOMPZ, II, J, K, LGN, LIWMIN,
+ $ LWMIN, M, SMLSIZ, START, STOREZ, STRTRW
+ REAL EPS, ORGNRM, P, TINY
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ILAENV
+ REAL SLAMCH, SLANST
+ EXTERNAL ILAENV, LSAME, SLAMCH, SLANST
+* ..
+* .. External Subroutines ..
+ EXTERNAL SGEMM, SLACPY, SLAED0, SLASCL, SLASET, SLASRT,
+ $ SSTEQR, SSTERF, SSWAP, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, INT, LOG, MAX, MOD, REAL, SQRT
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 )
+*
+ IF( LSAME( COMPZ, 'N' ) ) THEN
+ ICOMPZ = 0
+ ELSE IF( LSAME( COMPZ, 'V' ) ) THEN
+ ICOMPZ = 1
+ ELSE IF( LSAME( COMPZ, 'I' ) ) THEN
+ ICOMPZ = 2
+ ELSE
+ ICOMPZ = -1
+ END IF
+ IF( ICOMPZ.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( ( LDZ.LT.1 ) .OR.
+ $ ( ICOMPZ.GT.0 .AND. LDZ.LT.MAX( 1, N ) ) ) THEN
+ INFO = -6
+ END IF
+*
+ IF( INFO.EQ.0 ) THEN
+*
+* Compute the workspace requirements
+*
+ SMLSIZ = ILAENV( 9, 'SSTEDC', ' ', 0, 0, 0, 0 )
+ IF( N.LE.1 .OR. ICOMPZ.EQ.0 ) THEN
+ LIWMIN = 1
+ LWMIN = 1
+ ELSE IF( N.LE.SMLSIZ ) THEN
+ LIWMIN = 1
+ LWMIN = 2*( N - 1 )
+ ELSE
+ LGN = INT( LOG( REAL( N ) )/LOG( TWO ) )
+ IF( 2**LGN.LT.N )
+ $ LGN = LGN + 1
+ IF( 2**LGN.LT.N )
+ $ LGN = LGN + 1
+ IF( ICOMPZ.EQ.1 ) THEN
+ LWMIN = 1 + 3*N + 2*N*LGN + 3*N**2
+ LIWMIN = 6 + 6*N + 5*N*LGN
+ ELSE IF( ICOMPZ.EQ.2 ) THEN
+ LWMIN = 1 + 4*N + N**2
+ LIWMIN = 3 + 5*N
+ END IF
+ END IF
+ WORK( 1 ) = LWMIN
+ IWORK( 1 ) = LIWMIN
+*
+ IF( LWORK.LT.LWMIN .AND. .NOT. LQUERY ) THEN
+ INFO = -8
+ ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT. LQUERY ) THEN
+ INFO = -10
+ END IF
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SSTEDC', -INFO )
+ RETURN
+ ELSE IF (LQUERY) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 )
+ $ RETURN
+ IF( N.EQ.1 ) THEN
+ IF( ICOMPZ.NE.0 )
+ $ Z( 1, 1 ) = ONE
+ RETURN
+ END IF
+*
+* If the following conditional clause is removed, then the routine
+* will use the Divide and Conquer routine to compute only the
+* eigenvalues, which requires (3N + 3N**2) real workspace and
+* (2 + 5N + 2N lg(N)) integer workspace.
+* Since on many architectures SSTERF is much faster than any other
+* algorithm for finding eigenvalues only, it is used here
+* as the default. If the conditional clause is removed, then
+* information on the size of workspace needs to be changed.
+*
+* If COMPZ = 'N', use SSTERF to compute the eigenvalues.
+*
+ IF( ICOMPZ.EQ.0 ) THEN
+ CALL SSTERF( N, D, E, INFO )
+ GO TO 50
+ END IF
+*
+* If N is smaller than the minimum divide size (SMLSIZ+1), then
+* solve the problem with another solver.
+*
+ IF( N.LE.SMLSIZ ) THEN
+*
+ CALL SSTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO )
+*
+ ELSE
+*
+* If COMPZ = 'V', the Z matrix must be stored elsewhere for later
+* use.
+*
+ IF( ICOMPZ.EQ.1 ) THEN
+ STOREZ = 1 + N*N
+ ELSE
+ STOREZ = 1
+ END IF
+*
+ IF( ICOMPZ.EQ.2 ) THEN
+ CALL SLASET( 'Full', N, N, ZERO, ONE, Z, LDZ )
+ END IF
+*
+* Scale.
+*
+ ORGNRM = SLANST( 'M', N, D, E )
+ IF( ORGNRM.EQ.ZERO )
+ $ GO TO 50
+*
+ EPS = SLAMCH( 'Epsilon' )
+*
+ START = 1
+*
+* while ( START <= N )
+*
+ 10 CONTINUE
+ IF( START.LE.N ) THEN
+*
+* Let FINISH be the position of the next subdiagonal entry
+* such that E( FINISH ) <= TINY or FINISH = N if no such
+* subdiagonal exists. The matrix identified by the elements
+* between START and FINISH constitutes an independent
+* sub-problem.
+*
+ FINISH = START
+ 20 CONTINUE
+ IF( FINISH.LT.N ) THEN
+ TINY = EPS*SQRT( ABS( D( FINISH ) ) )*
+ $ SQRT( ABS( D( FINISH+1 ) ) )
+ IF( ABS( E( FINISH ) ).GT.TINY ) THEN
+ FINISH = FINISH + 1
+ GO TO 20
+ END IF
+ END IF
+*
+* (Sub) Problem determined. Compute its size and solve it.
+*
+ M = FINISH - START + 1
+ IF( M.EQ.1 ) THEN
+ START = FINISH + 1
+ GO TO 10
+ END IF
+ IF( M.GT.SMLSIZ ) THEN
+*
+* Scale.
+*
+ ORGNRM = SLANST( 'M', M, D( START ), E( START ) )
+ CALL SLASCL( 'G', 0, 0, ORGNRM, ONE, M, 1, D( START ), M,
+ $ INFO )
+ CALL SLASCL( 'G', 0, 0, ORGNRM, ONE, M-1, 1, E( START ),
+ $ M-1, INFO )
+*
+ IF( ICOMPZ.EQ.1 ) THEN
+ STRTRW = 1
+ ELSE
+ STRTRW = START
+ END IF
+ CALL SLAED0( ICOMPZ, N, M, D( START ), E( START ),
+ $ Z( STRTRW, START ), LDZ, WORK( 1 ), N,
+ $ WORK( STOREZ ), IWORK, INFO )
+ IF( INFO.NE.0 ) THEN
+ INFO = ( INFO / ( M+1 )+START-1 )*( N+1 ) +
+ $ MOD( INFO, ( M+1 ) ) + START - 1
+ GO TO 50
+ END IF
+*
+* Scale back.
+*
+ CALL SLASCL( 'G', 0, 0, ONE, ORGNRM, M, 1, D( START ), M,
+ $ INFO )
+*
+ ELSE
+ IF( ICOMPZ.EQ.1 ) THEN
+*
+* Since QR won't update a Z matrix which is larger than
+* the length of D, we must solve the sub-problem in a
+* workspace and then multiply back into Z.
+*
+ CALL SSTEQR( 'I', M, D( START ), E( START ), WORK, M,
+ $ WORK( M*M+1 ), INFO )
+ CALL SLACPY( 'A', N, M, Z( 1, START ), LDZ,
+ $ WORK( STOREZ ), N )
+ CALL SGEMM( 'N', 'N', N, M, M, ONE,
+ $ WORK( STOREZ ), N, WORK, M, ZERO,
+ $ Z( 1, START ), LDZ )
+ ELSE IF( ICOMPZ.EQ.2 ) THEN
+ CALL SSTEQR( 'I', M, D( START ), E( START ),
+ $ Z( START, START ), LDZ, WORK, INFO )
+ ELSE
+ CALL SSTERF( M, D( START ), E( START ), INFO )
+ END IF
+ IF( INFO.NE.0 ) THEN
+ INFO = START*( N+1 ) + FINISH
+ GO TO 50
+ END IF
+ END IF
+*
+ START = FINISH + 1
+ GO TO 10
+ END IF
+*
+* endwhile
+*
+* If the problem split any number of times, then the eigenvalues
+* will not be properly ordered. Here we permute the eigenvalues
+* (and the associated eigenvectors) into ascending order.
+*
+ IF( M.NE.N ) THEN
+ IF( ICOMPZ.EQ.0 ) THEN
+*
+* Use Quick Sort
+*
+ CALL SLASRT( 'I', N, D, INFO )
+*
+ ELSE
+*
+* Use Selection Sort to minimize swaps of eigenvectors
+*
+ DO 40 II = 2, N
+ I = II - 1
+ K = I
+ P = D( I )
+ DO 30 J = II, N
+ IF( D( J ).LT.P ) THEN
+ K = J
+ P = D( J )
+ END IF
+ 30 CONTINUE
+ IF( K.NE.I ) THEN
+ D( K ) = D( I )
+ D( I ) = P
+ CALL SSWAP( N, Z( 1, I ), 1, Z( 1, K ), 1 )
+ END IF
+ 40 CONTINUE
+ END IF
+ END IF
+ END IF
+*
+ 50 CONTINUE
+ WORK( 1 ) = LWMIN
+ IWORK( 1 ) = LIWMIN
+*
+ RETURN
+*
+* End of SSTEDC
+*
+ END
+ SUBROUTINE SSTEGR( JOBZ, RANGE, N, D, E, VL, VU, IL, IU,
+ $ ABSTOL, M, W, Z, LDZ, ISUPPZ, WORK, LWORK, IWORK,
+ $ LIWORK, INFO )
+
+ IMPLICIT NONE
+*
+*
+* -- LAPACK computational routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER JOBZ, RANGE
+ INTEGER IL, INFO, IU, LDZ, LIWORK, LWORK, M, N
+ REAL ABSTOL, VL, VU
+* ..
+* .. Array Arguments ..
+ INTEGER ISUPPZ( * ), IWORK( * )
+ REAL D( * ), E( * ), W( * ), WORK( * )
+ REAL Z( LDZ, * )
+* ..
+*
+* Purpose
+* =======
+*
+* SSTEGR computes selected eigenvalues and, optionally, eigenvectors
+* of a real symmetric tridiagonal matrix T. Any such unreduced matrix has
+* a well defined set of pairwise different real eigenvalues, the corresponding
+* real eigenvectors are pairwise orthogonal.
+*
+* The spectrum may be computed either completely or partially by specifying
+* either an interval (VL,VU] or a range of indices IL:IU for the desired
+* eigenvalues.
+*
+* SSTEGR is a compatability wrapper around the improved SSTEMR routine.
+* See SSTEMR for further details.
+*
+* One important change is that the ABSTOL parameter no longer provides any
+* benefit and hence is no longer used.
+*
+* Note : SSTEGR and SSTEMR work only on machines which follow
+* IEEE-754 floating-point standard in their handling of infinities and
+* NaNs. Normal execution may create these exceptiona values and hence
+* may abort due to a floating point exception in environments which
+* do not conform to the IEEE-754 standard.
+*
+* Arguments
+* =========
+*
+* JOBZ (input) CHARACTER*1
+* = 'N': Compute eigenvalues only;
+* = 'V': Compute eigenvalues and eigenvectors.
+*
+* RANGE (input) CHARACTER*1
+* = 'A': all eigenvalues will be found.
+* = 'V': all eigenvalues in the half-open interval (VL,VU]
+* will be found.
+* = 'I': the IL-th through IU-th eigenvalues will be found.
+*
+* N (input) INTEGER
+* The order of the matrix. N >= 0.
+*
+* D (input/output) REAL array, dimension (N)
+* On entry, the N diagonal elements of the tridiagonal matrix
+* T. On exit, D is overwritten.
+*
+* E (input/output) REAL array, dimension (N)
+* On entry, the (N-1) subdiagonal elements of the tridiagonal
+* matrix T in elements 1 to N-1 of E. E(N) need not be set on
+* input, but is used internally as workspace.
+* On exit, E is overwritten.
+*
+* VL (input) REAL
+* VU (input) REAL
+* If RANGE='V', the lower and upper bounds of the interval to
+* be searched for eigenvalues. VL < VU.
+* Not referenced if RANGE = 'A' or 'I'.
+*
+* IL (input) INTEGER
+* IU (input) INTEGER
+* If RANGE='I', the indices (in ascending order) of the
+* smallest and largest eigenvalues to be returned.
+* 1 <= IL <= IU <= N, if N > 0.
+* Not referenced if RANGE = 'A' or 'V'.
+*
+* ABSTOL (input) REAL
+* Unused. Was the absolute error tolerance for the
+* eigenvalues/eigenvectors in previous versions.
+*
+* M (output) INTEGER
+* The total number of eigenvalues found. 0 <= M <= N.
+* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
+*
+* W (output) REAL array, dimension (N)
+* The first M elements contain the selected eigenvalues in
+* ascending order.
+*
+* Z (output) REAL array, dimension (LDZ, max(1,M) )
+* If JOBZ = 'V', and if INFO = 0, then the first M columns of Z
+* contain the orthonormal eigenvectors of the matrix T
+* corresponding to the selected eigenvalues, with the i-th
+* column of Z holding the eigenvector associated with W(i).
+* If JOBZ = 'N', then Z is not referenced.
+* Note: the user must ensure that at least max(1,M) columns are
+* supplied in the array Z; if RANGE = 'V', the exact value of M
+* is not known in advance and an upper bound must be used.
+* Supplying N columns is always safe.
+*
+* LDZ (input) INTEGER
+* The leading dimension of the array Z. LDZ >= 1, and if
+* JOBZ = 'V', then LDZ >= max(1,N).
+*
+* ISUPPZ (output) INTEGER ARRAY, dimension ( 2*max(1,M) )
+* The support of the eigenvectors in Z, i.e., the indices
+* indicating the nonzero elements in Z. The i-th computed eigenvector
+* is nonzero only in elements ISUPPZ( 2*i-1 ) through
+* ISUPPZ( 2*i ). This is relevant in the case when the matrix
+* is split. ISUPPZ is only accessed when JOBZ is 'V' and N > 0.
+*
+* WORK (workspace/output) REAL array, dimension (LWORK)
+* On exit, if INFO = 0, WORK(1) returns the optimal
+* (and minimal) LWORK.
+*
+* LWORK (input) INTEGER
+* The dimension of the array WORK. LWORK >= max(1,18*N)
+* if JOBZ = 'V', and LWORK >= max(1,12*N) if JOBZ = 'N'.
+* If LWORK = -1, then a workspace query is assumed; the routine
+* only calculates the optimal size of the WORK array, returns
+* this value as the first entry of the WORK array, and no error
+* message related to LWORK is issued by XERBLA.
+*
+* IWORK (workspace/output) INTEGER array, dimension (LIWORK)
+* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
+*
+* LIWORK (input) INTEGER
+* The dimension of the array IWORK. LIWORK >= max(1,10*N)
+* if the eigenvectors are desired, and LIWORK >= max(1,8*N)
+* if only the eigenvalues are to be computed.
+* If LIWORK = -1, then a workspace query is assumed; the
+* routine only calculates the optimal size of the IWORK array,
+* returns this value as the first entry of the IWORK array, and
+* no error message related to LIWORK is issued by XERBLA.
+*
+* INFO (output) INTEGER
+* On exit, INFO
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* > 0: if INFO = 1X, internal error in SLARRE,
+* if INFO = 2X, internal error in SLARRV.
+* Here, the digit X = ABS( IINFO ) < 10, where IINFO is
+* the nonzero error code returned by SLARRE or
+* SLARRV, respectively.
+*
+* Further Details
+* ===============
+*
+* Based on contributions by
+* Inderjit Dhillon, IBM Almaden, USA
+* Osni Marques, LBNL/NERSC, USA
+* Christof Voemel, LBNL/NERSC, USA
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ LOGICAL TRYRAC
+* ..
+* .. External Subroutines ..
+ EXTERNAL SSTEMR
+* ..
+* .. Executable Statements ..
+ INFO = 0
+ TRYRAC = .FALSE.
+
+ CALL SSTEMR( JOBZ, RANGE, N, D, E, VL, VU, IL, IU,
+ $ M, W, Z, LDZ, N, ISUPPZ, TRYRAC, WORK, LWORK,
+ $ IWORK, LIWORK, INFO )
+*
+* End of SSTEGR
+*
+ END
+ SUBROUTINE SSTEIN( N, D, E, M, W, IBLOCK, ISPLIT, Z, LDZ, WORK,
+ $ IWORK, IFAIL, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LDZ, M, N
+* ..
+* .. Array Arguments ..
+ INTEGER IBLOCK( * ), IFAIL( * ), ISPLIT( * ),
+ $ IWORK( * )
+ REAL D( * ), E( * ), W( * ), WORK( * ), Z( LDZ, * )
+* ..
+*
+* Purpose
+* =======
+*
+* SSTEIN computes the eigenvectors of a real symmetric tridiagonal
+* matrix T corresponding to specified eigenvalues, using inverse
+* iteration.
+*
+* The maximum number of iterations allowed for each eigenvector is
+* specified by an internal parameter MAXITS (currently set to 5).
+*
+* Arguments
+* =========
+*
+* N (input) INTEGER
+* The order of the matrix. N >= 0.
+*
+* D (input) REAL array, dimension (N)
+* The n diagonal elements of the tridiagonal matrix T.
+*
+* E (input) REAL array, dimension (N-1)
+* The (n-1) subdiagonal elements of the tridiagonal matrix
+* T, in elements 1 to N-1.
+*
+* M (input) INTEGER
+* The number of eigenvectors to be found. 0 <= M <= N.
+*
+* W (input) REAL array, dimension (N)
+* The first M elements of W contain the eigenvalues for
+* which eigenvectors are to be computed. The eigenvalues
+* should be grouped by split-off block and ordered from
+* smallest to largest within the block. ( The output array
+* W from SSTEBZ with ORDER = 'B' is expected here. )
+*
+* IBLOCK (input) INTEGER array, dimension (N)
+* The submatrix indices associated with the corresponding
+* eigenvalues in W; IBLOCK(i)=1 if eigenvalue W(i) belongs to
+* the first submatrix from the top, =2 if W(i) belongs to
+* the second submatrix, etc. ( The output array IBLOCK
+* from SSTEBZ is expected here. )
+*
+* ISPLIT (input) INTEGER array, dimension (N)
+* The splitting points, at which T breaks up into submatrices.
+* The first submatrix consists of rows/columns 1 to
+* ISPLIT( 1 ), the second of rows/columns ISPLIT( 1 )+1
+* through ISPLIT( 2 ), etc.
+* ( The output array ISPLIT from SSTEBZ is expected here. )
+*
+* Z (output) REAL array, dimension (LDZ, M)
+* The computed eigenvectors. The eigenvector associated
+* with the eigenvalue W(i) is stored in the i-th column of
+* Z. Any vector which fails to converge is set to its current
+* iterate after MAXITS iterations.
+*
+* LDZ (input) INTEGER
+* The leading dimension of the array Z. LDZ >= max(1,N).
+*
+* WORK (workspace) REAL array, dimension (5*N)
+*
+* IWORK (workspace) INTEGER array, dimension (N)
+*
+* IFAIL (output) INTEGER array, dimension (M)
+* On normal exit, all elements of IFAIL are zero.
+* If one or more eigenvectors fail to converge after
+* MAXITS iterations, then their indices are stored in
+* array IFAIL.
+*
+* INFO (output) INTEGER
+* = 0: successful exit.
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* > 0: if INFO = i, then i eigenvectors failed to converge
+* in MAXITS iterations. Their indices are stored in
+* array IFAIL.
+*
+* Internal Parameters
+* ===================
+*
+* MAXITS INTEGER, default = 5
+* The maximum number of iterations performed.
+*
+* EXTRA INTEGER, default = 2
+* The number of iterations performed after norm growth
+* criterion is satisfied, should be at least 1.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO, ONE, TEN, ODM3, ODM1
+ PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0, TEN = 1.0E+1,
+ $ ODM3 = 1.0E-3, ODM1 = 1.0E-1 )
+ INTEGER MAXITS, EXTRA
+ PARAMETER ( MAXITS = 5, EXTRA = 2 )
+* ..
+* .. Local Scalars ..
+ INTEGER B1, BLKSIZ, BN, GPIND, I, IINFO, INDRV1,
+ $ INDRV2, INDRV3, INDRV4, INDRV5, ITS, J, J1,
+ $ JBLK, JMAX, NBLK, NRMCHK
+ REAL CTR, EPS, EPS1, NRM, ONENRM, ORTOL, PERTOL,
+ $ SCL, SEP, STPCRT, TOL, XJ, XJM
+* ..
+* .. Local Arrays ..
+ INTEGER ISEED( 4 )
+* ..
+* .. External Functions ..
+ INTEGER ISAMAX
+ REAL SASUM, SDOT, SLAMCH, SNRM2
+ EXTERNAL ISAMAX, SASUM, SDOT, SLAMCH, SNRM2
+* ..
+* .. External Subroutines ..
+ EXTERNAL SAXPY, SCOPY, SLAGTF, SLAGTS, SLARNV, SSCAL,
+ $ XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, SQRT
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ DO 10 I = 1, M
+ IFAIL( I ) = 0
+ 10 CONTINUE
+*
+ IF( N.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( M.LT.0 .OR. M.GT.N ) THEN
+ INFO = -4
+ ELSE IF( LDZ.LT.MAX( 1, N ) ) THEN
+ INFO = -9
+ ELSE
+ DO 20 J = 2, M
+ IF( IBLOCK( J ).LT.IBLOCK( J-1 ) ) THEN
+ INFO = -6
+ GO TO 30
+ END IF
+ IF( IBLOCK( J ).EQ.IBLOCK( J-1 ) .AND. W( J ).LT.W( J-1 ) )
+ $ THEN
+ INFO = -5
+ GO TO 30
+ END IF
+ 20 CONTINUE
+ 30 CONTINUE
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SSTEIN', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 .OR. M.EQ.0 ) THEN
+ RETURN
+ ELSE IF( N.EQ.1 ) THEN
+ Z( 1, 1 ) = ONE
+ RETURN
+ END IF
+*
+* Get machine constants.
+*
+ EPS = SLAMCH( 'Precision' )
+*
+* Initialize seed for random number generator SLARNV.
+*
+ DO 40 I = 1, 4
+ ISEED( I ) = 1
+ 40 CONTINUE
+*
+* Initialize pointers.
+*
+ INDRV1 = 0
+ INDRV2 = INDRV1 + N
+ INDRV3 = INDRV2 + N
+ INDRV4 = INDRV3 + N
+ INDRV5 = INDRV4 + N
+*
+* Compute eigenvectors of matrix blocks.
+*
+ J1 = 1
+ DO 160 NBLK = 1, IBLOCK( M )
+*
+* Find starting and ending indices of block nblk.
+*
+ IF( NBLK.EQ.1 ) THEN
+ B1 = 1
+ ELSE
+ B1 = ISPLIT( NBLK-1 ) + 1
+ END IF
+ BN = ISPLIT( NBLK )
+ BLKSIZ = BN - B1 + 1
+ IF( BLKSIZ.EQ.1 )
+ $ GO TO 60
+ GPIND = B1
+*
+* Compute reorthogonalization criterion and stopping criterion.
+*
+ ONENRM = ABS( D( B1 ) ) + ABS( E( B1 ) )
+ ONENRM = MAX( ONENRM, ABS( D( BN ) )+ABS( E( BN-1 ) ) )
+ DO 50 I = B1 + 1, BN - 1
+ ONENRM = MAX( ONENRM, ABS( D( I ) )+ABS( E( I-1 ) )+
+ $ ABS( E( I ) ) )
+ 50 CONTINUE
+ ORTOL = ODM3*ONENRM
+*
+ STPCRT = SQRT( ODM1 / BLKSIZ )
+*
+* Loop through eigenvalues of block nblk.
+*
+ 60 CONTINUE
+ JBLK = 0
+ DO 150 J = J1, M
+ IF( IBLOCK( J ).NE.NBLK ) THEN
+ J1 = J
+ GO TO 160
+ END IF
+ JBLK = JBLK + 1
+ XJ = W( J )
+*
+* Skip all the work if the block size is one.
+*
+ IF( BLKSIZ.EQ.1 ) THEN
+ WORK( INDRV1+1 ) = ONE
+ GO TO 120
+ END IF
+*
+* If eigenvalues j and j-1 are too close, add a relatively
+* small perturbation.
+*
+ IF( JBLK.GT.1 ) THEN
+ EPS1 = ABS( EPS*XJ )
+ PERTOL = TEN*EPS1
+ SEP = XJ - XJM
+ IF( SEP.LT.PERTOL )
+ $ XJ = XJM + PERTOL
+ END IF
+*
+ ITS = 0
+ NRMCHK = 0
+*
+* Get random starting vector.
+*
+ CALL SLARNV( 2, ISEED, BLKSIZ, WORK( INDRV1+1 ) )
+*
+* Copy the matrix T so it won't be destroyed in factorization.
+*
+ CALL SCOPY( BLKSIZ, D( B1 ), 1, WORK( INDRV4+1 ), 1 )
+ CALL SCOPY( BLKSIZ-1, E( B1 ), 1, WORK( INDRV2+2 ), 1 )
+ CALL SCOPY( BLKSIZ-1, E( B1 ), 1, WORK( INDRV3+1 ), 1 )
+*
+* Compute LU factors with partial pivoting ( PT = LU )
+*
+ TOL = ZERO
+ CALL SLAGTF( BLKSIZ, WORK( INDRV4+1 ), XJ, WORK( INDRV2+2 ),
+ $ WORK( INDRV3+1 ), TOL, WORK( INDRV5+1 ), IWORK,
+ $ IINFO )
+*
+* Update iteration count.
+*
+ 70 CONTINUE
+ ITS = ITS + 1
+ IF( ITS.GT.MAXITS )
+ $ GO TO 100
+*
+* Normalize and scale the righthand side vector Pb.
+*
+ SCL = BLKSIZ*ONENRM*MAX( EPS,
+ $ ABS( WORK( INDRV4+BLKSIZ ) ) ) /
+ $ SASUM( BLKSIZ, WORK( INDRV1+1 ), 1 )
+ CALL SSCAL( BLKSIZ, SCL, WORK( INDRV1+1 ), 1 )
+*
+* Solve the system LU = Pb.
+*
+ CALL SLAGTS( -1, BLKSIZ, WORK( INDRV4+1 ), WORK( INDRV2+2 ),
+ $ WORK( INDRV3+1 ), WORK( INDRV5+1 ), IWORK,
+ $ WORK( INDRV1+1 ), TOL, IINFO )
+*
+* Reorthogonalize by modified Gram-Schmidt if eigenvalues are
+* close enough.
+*
+ IF( JBLK.EQ.1 )
+ $ GO TO 90
+ IF( ABS( XJ-XJM ).GT.ORTOL )
+ $ GPIND = J
+ IF( GPIND.NE.J ) THEN
+ DO 80 I = GPIND, J - 1
+ CTR = -SDOT( BLKSIZ, WORK( INDRV1+1 ), 1, Z( B1, I ),
+ $ 1 )
+ CALL SAXPY( BLKSIZ, CTR, Z( B1, I ), 1,
+ $ WORK( INDRV1+1 ), 1 )
+ 80 CONTINUE
+ END IF
+*
+* Check the infinity norm of the iterate.
+*
+ 90 CONTINUE
+ JMAX = ISAMAX( BLKSIZ, WORK( INDRV1+1 ), 1 )
+ NRM = ABS( WORK( INDRV1+JMAX ) )
+*
+* Continue for additional iterations after norm reaches
+* stopping criterion.
+*
+ IF( NRM.LT.STPCRT )
+ $ GO TO 70
+ NRMCHK = NRMCHK + 1
+ IF( NRMCHK.LT.EXTRA+1 )
+ $ GO TO 70
+*
+ GO TO 110
+*
+* If stopping criterion was not satisfied, update info and
+* store eigenvector number in array ifail.
+*
+ 100 CONTINUE
+ INFO = INFO + 1
+ IFAIL( INFO ) = J
+*
+* Accept iterate as jth eigenvector.
+*
+ 110 CONTINUE
+ SCL = ONE / SNRM2( BLKSIZ, WORK( INDRV1+1 ), 1 )
+ JMAX = ISAMAX( BLKSIZ, WORK( INDRV1+1 ), 1 )
+ IF( WORK( INDRV1+JMAX ).LT.ZERO )
+ $ SCL = -SCL
+ CALL SSCAL( BLKSIZ, SCL, WORK( INDRV1+1 ), 1 )
+ 120 CONTINUE
+ DO 130 I = 1, N
+ Z( I, J ) = ZERO
+ 130 CONTINUE
+ DO 140 I = 1, BLKSIZ
+ Z( B1+I-1, J ) = WORK( INDRV1+I )
+ 140 CONTINUE
+*
+* Save the shift to check eigenvalue spacing at next
+* iteration.
+*
+ XJM = XJ
+*
+ 150 CONTINUE
+ 160 CONTINUE
+*
+ RETURN
+*
+* End of SSTEIN
+*
+ END
+ SUBROUTINE SSTEMR( JOBZ, RANGE, N, D, E, VL, VU, IL, IU,
+ $ M, W, Z, LDZ, NZC, ISUPPZ, TRYRAC, WORK, LWORK,
+ $ IWORK, LIWORK, INFO )
+ IMPLICIT NONE
+*
+* -- LAPACK computational routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER JOBZ, RANGE
+ LOGICAL TRYRAC
+ INTEGER IL, INFO, IU, LDZ, NZC, LIWORK, LWORK, M, N
+ REAL VL, VU
+* ..
+* .. Array Arguments ..
+ INTEGER ISUPPZ( * ), IWORK( * )
+ REAL D( * ), E( * ), W( * ), WORK( * )
+ REAL Z( LDZ, * )
+* ..
+*
+* Purpose
+* =======
+*
+* SSTEMR computes selected eigenvalues and, optionally, eigenvectors
+* of a real symmetric tridiagonal matrix T. Any such unreduced matrix has
+* a well defined set of pairwise different real eigenvalues, the corresponding
+* real eigenvectors are pairwise orthogonal.
+*
+* The spectrum may be computed either completely or partially by specifying
+* either an interval (VL,VU] or a range of indices IL:IU for the desired
+* eigenvalues.
+*
+* Depending on the number of desired eigenvalues, these are computed either
+* by bisection or the dqds algorithm. Numerically orthogonal eigenvectors are
+* computed by the use of various suitable L D L^T factorizations near clusters
+* of close eigenvalues (referred to as RRRs, Relatively Robust
+* Representations). An informal sketch of the algorithm follows.
+*
+* For each unreduced block (submatrix) of T,
+* (a) Compute T - sigma I = L D L^T, so that L and D
+* define all the wanted eigenvalues to high relative accuracy.
+* This means that small relative changes in the entries of D and L
+* cause only small relative changes in the eigenvalues and
+* eigenvectors. The standard (unfactored) representation of the
+* tridiagonal matrix T does not have this property in general.
+* (b) Compute the eigenvalues to suitable accuracy.
+* If the eigenvectors are desired, the algorithm attains full
+* accuracy of the computed eigenvalues only right before
+* the corresponding vectors have to be computed, see steps c) and d).
+* (c) For each cluster of close eigenvalues, select a new
+* shift close to the cluster, find a new factorization, and refine
+* the shifted eigenvalues to suitable accuracy.
+* (d) For each eigenvalue with a large enough relative separation compute
+* the corresponding eigenvector by forming a rank revealing twisted
+* factorization. Go back to (c) for any clusters that remain.
+*
+* For more details, see:
+* - Inderjit S. Dhillon and Beresford N. Parlett: "Multiple representations
+* to compute orthogonal eigenvectors of symmetric tridiagonal matrices,"
+* Linear Algebra and its Applications, 387(1), pp. 1-28, August 2004.
+* - Inderjit Dhillon and Beresford Parlett: "Orthogonal Eigenvectors and
+* Relative Gaps," SIAM Journal on Matrix Analysis and Applications, Vol. 25,
+* 2004. Also LAPACK Working Note 154.
+* - Inderjit Dhillon: "A new O(n^2) algorithm for the symmetric
+* tridiagonal eigenvalue/eigenvector problem",
+* Computer Science Division Technical Report No. UCB/CSD-97-971,
+* UC Berkeley, May 1997.
+*
+* Notes:
+* 1.SSTEMR works only on machines which follow IEEE-754
+* floating-point standard in their handling of infinities and NaNs.
+* This permits the use of efficient inner loops avoiding a check for
+* zero divisors.
+*
+* Arguments
+* =========
+*
+* JOBZ (input) CHARACTER*1
+* = 'N': Compute eigenvalues only;
+* = 'V': Compute eigenvalues and eigenvectors.
+*
+* RANGE (input) CHARACTER*1
+* = 'A': all eigenvalues will be found.
+* = 'V': all eigenvalues in the half-open interval (VL,VU]
+* will be found.
+* = 'I': the IL-th through IU-th eigenvalues will be found.
+*
+* N (input) INTEGER
+* The order of the matrix. N >= 0.
+*
+* D (input/output) REAL array, dimension (N)
+* On entry, the N diagonal elements of the tridiagonal matrix
+* T. On exit, D is overwritten.
+*
+* E (input/output) REAL array, dimension (N)
+* On entry, the (N-1) subdiagonal elements of the tridiagonal
+* matrix T in elements 1 to N-1 of E. E(N) need not be set on
+* input, but is used internally as workspace.
+* On exit, E is overwritten.
+*
+* VL (input) REAL
+* VU (input) REAL
+* If RANGE='V', the lower and upper bounds of the interval to
+* be searched for eigenvalues. VL < VU.
+* Not referenced if RANGE = 'A' or 'I'.
+*
+* IL (input) INTEGER
+* IU (input) INTEGER
+* If RANGE='I', the indices (in ascending order) of the
+* smallest and largest eigenvalues to be returned.
+* 1 <= IL <= IU <= N, if N > 0.
+* Not referenced if RANGE = 'A' or 'V'.
+*
+* M (output) INTEGER
+* The total number of eigenvalues found. 0 <= M <= N.
+* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
+*
+* W (output) REAL array, dimension (N)
+* The first M elements contain the selected eigenvalues in
+* ascending order.
+*
+* Z (output) REAL array, dimension (LDZ, max(1,M) )
+* If JOBZ = 'V', and if INFO = 0, then the first M columns of Z
+* contain the orthonormal eigenvectors of the matrix T
+* corresponding to the selected eigenvalues, with the i-th
+* column of Z holding the eigenvector associated with W(i).
+* If JOBZ = 'N', then Z is not referenced.
+* Note: the user must ensure that at least max(1,M) columns are
+* supplied in the array Z; if RANGE = 'V', the exact value of M
+* is not known in advance and can be computed with a workspace
+* query by setting NZC = -1, see below.
+*
+* LDZ (input) INTEGER
+* The leading dimension of the array Z. LDZ >= 1, and if
+* JOBZ = 'V', then LDZ >= max(1,N).
+*
+* NZC (input) INTEGER
+* The number of eigenvectors to be held in the array Z.
+* If RANGE = 'A', then NZC >= max(1,N).
+* If RANGE = 'V', then NZC >= the number of eigenvalues in (VL,VU].
+* If RANGE = 'I', then NZC >= IU-IL+1.
+* If NZC = -1, then a workspace query is assumed; the
+* routine calculates the number of columns of the array Z that
+* are needed to hold the eigenvectors.
+* This value is returned as the first entry of the Z array, and
+* no error message related to NZC is issued by XERBLA.
+*
+* ISUPPZ (output) INTEGER ARRAY, dimension ( 2*max(1,M) )
+* The support of the eigenvectors in Z, i.e., the indices
+* indicating the nonzero elements in Z. The i-th computed eigenvector
+* is nonzero only in elements ISUPPZ( 2*i-1 ) through
+* ISUPPZ( 2*i ). This is relevant in the case when the matrix
+* is split. ISUPPZ is only accessed when JOBZ is 'V' and N > 0.
+*
+* TRYRAC (input/output) LOGICAL
+* If TRYRAC.EQ..TRUE., indicates that the code should check whether
+* the tridiagonal matrix defines its eigenvalues to high relative
+* accuracy. If so, the code uses relative-accuracy preserving
+* algorithms that might be (a bit) slower depending on the matrix.
+* If the matrix does not define its eigenvalues to high relative
+* accuracy, the code can uses possibly faster algorithms.
+* If TRYRAC.EQ..FALSE., the code is not required to guarantee
+* relatively accurate eigenvalues and can use the fastest possible
+* techniques.
+* On exit, a .TRUE. TRYRAC will be set to .FALSE. if the matrix
+* does not define its eigenvalues to high relative accuracy.
+*
+* WORK (workspace/output) REAL array, dimension (LWORK)
+* On exit, if INFO = 0, WORK(1) returns the optimal
+* (and minimal) LWORK.
+*
+* LWORK (input) INTEGER
+* The dimension of the array WORK. LWORK >= max(1,18*N)
+* if JOBZ = 'V', and LWORK >= max(1,12*N) if JOBZ = 'N'.
+* If LWORK = -1, then a workspace query is assumed; the routine
+* only calculates the optimal size of the WORK array, returns
+* this value as the first entry of the WORK array, and no error
+* message related to LWORK is issued by XERBLA.
+*
+* IWORK (workspace/output) INTEGER array, dimension (LIWORK)
+* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
+*
+* LIWORK (input) INTEGER
+* The dimension of the array IWORK. LIWORK >= max(1,10*N)
+* if the eigenvectors are desired, and LIWORK >= max(1,8*N)
+* if only the eigenvalues are to be computed.
+* If LIWORK = -1, then a workspace query is assumed; the
+* routine only calculates the optimal size of the IWORK array,
+* returns this value as the first entry of the IWORK array, and
+* no error message related to LIWORK is issued by XERBLA.
+*
+* INFO (output) INTEGER
+* On exit, INFO
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* > 0: if INFO = 1X, internal error in SLARRE,
+* if INFO = 2X, internal error in SLARRV.
+* Here, the digit X = ABS( IINFO ) < 10, where IINFO is
+* the nonzero error code returned by SLARRE or
+* SLARRV, respectively.
+*
+*
+* Further Details
+* ===============
+*
+* Based on contributions by
+* Beresford Parlett, University of California, Berkeley, USA
+* Jim Demmel, University of California, Berkeley, USA
+* Inderjit Dhillon, University of Texas, Austin, USA
+* Osni Marques, LBNL/NERSC, USA
+* Christof Voemel, University of California, Berkeley, USA
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO, ONE, FOUR, MINRGP
+ PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0,
+ $ FOUR = 4.0E0,
+ $ MINRGP = 3.0E-3 )
+* ..
+* .. Local Scalars ..
+ LOGICAL ALLEIG, INDEIG, LQUERY, VALEIG, WANTZ, ZQUERY
+ INTEGER I, IBEGIN, IEND, IFIRST, IIL, IINDBL, IINDW,
+ $ IINDWK, IINFO, IINSPL, IIU, ILAST, IN, INDD,
+ $ INDE2, INDERR, INDGP, INDGRS, INDWRK, ITMP,
+ $ ITMP2, J, JBLK, JJ, LIWMIN, LWMIN, NSPLIT,
+ $ NZCMIN, OFFSET, WBEGIN, WEND
+ REAL BIGNUM, CS, EPS, PIVMIN, R1, R2, RMAX, RMIN,
+ $ RTOL1, RTOL2, SAFMIN, SCALE, SMLNUM, SN,
+ $ THRESH, TMP, TNRM, WL, WU
+* ..
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ REAL SLAMCH, SLANST
+ EXTERNAL LSAME, SLAMCH, SLANST
+* ..
+* .. External Subroutines ..
+ EXTERNAL SCOPY, SLAE2, SLAEV2, SLARRC, SLARRE, SLARRJ,
+ $ SLARRR, SLARRV, SLASRT, SSCAL, SSWAP, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN, SQRT
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ WANTZ = LSAME( JOBZ, 'V' )
+ ALLEIG = LSAME( RANGE, 'A' )
+ VALEIG = LSAME( RANGE, 'V' )
+ INDEIG = LSAME( RANGE, 'I' )
+*
+ LQUERY = ( ( LWORK.EQ.-1 ).OR.( LIWORK.EQ.-1 ) )
+ ZQUERY = ( NZC.EQ.-1 )
+ TRYRAC = ( INFO.NE.0 )
+
+* SSTEMR needs WORK of size 6*N, IWORK of size 3*N.
+* In addition, SLARRE needs WORK of size 6*N, IWORK of size 5*N.
+* Furthermore, SLARRV needs WORK of size 12*N, IWORK of size 7*N.
+ IF( WANTZ ) THEN
+ LWMIN = 18*N
+ LIWMIN = 10*N
+ ELSE
+* need less workspace if only the eigenvalues are wanted
+ LWMIN = 12*N
+ LIWMIN = 8*N
+ ENDIF
+
+ WL = ZERO
+ WU = ZERO
+ IIL = 0
+ IIU = 0
+
+ IF( VALEIG ) THEN
+* We do not reference VL, VU in the cases RANGE = 'I','A'
+* The interval (WL, WU] contains all the wanted eigenvalues.
+* It is either given by the user or computed in SLARRE.
+ WL = VL
+ WU = VU
+ ELSEIF( INDEIG ) THEN
+* We do not reference IL, IU in the cases RANGE = 'V','A'
+ IIL = IL
+ IIU = IU
+ ENDIF
+*
+ INFO = 0
+ IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
+ INFO = -1
+ ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN
+ INFO = -2
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( VALEIG .AND. N.GT.0 .AND. WU.LE.WL ) THEN
+ INFO = -7
+ ELSE IF( INDEIG .AND. ( IIL.LT.1 .OR. IIL.GT.N ) ) THEN
+ INFO = -8
+ ELSE IF( INDEIG .AND. ( IIU.LT.IIL .OR. IIU.GT.N ) ) THEN
+ INFO = -9
+ ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
+ INFO = -13
+ ELSE IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
+ INFO = -17
+ ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN
+ INFO = -19
+ END IF
+*
+* Get machine constants.
+*
+ SAFMIN = SLAMCH( 'Safe minimum' )
+ EPS = SLAMCH( 'Precision' )
+ SMLNUM = SAFMIN / EPS
+ BIGNUM = ONE / SMLNUM
+ RMIN = SQRT( SMLNUM )
+ RMAX = MIN( SQRT( BIGNUM ), ONE / SQRT( SQRT( SAFMIN ) ) )
+*
+ IF( INFO.EQ.0 ) THEN
+ WORK( 1 ) = LWMIN
+ IWORK( 1 ) = LIWMIN
+*
+ IF( WANTZ .AND. ALLEIG ) THEN
+ NZCMIN = N
+ ELSE IF( WANTZ .AND. VALEIG ) THEN
+ CALL SLARRC( 'T', N, VL, VU, D, E, SAFMIN,
+ $ NZCMIN, ITMP, ITMP2, INFO )
+ ELSE IF( WANTZ .AND. INDEIG ) THEN
+ NZCMIN = IIU-IIL+1
+ ELSE
+* WANTZ .EQ. FALSE.
+ NZCMIN = 0
+ ENDIF
+ IF( ZQUERY .AND. INFO.EQ.0 ) THEN
+ Z( 1,1 ) = NZCMIN
+ ELSE IF( NZC.LT.NZCMIN .AND. .NOT.ZQUERY ) THEN
+ INFO = -14
+ END IF
+ END IF
+
+ IF( INFO.NE.0 ) THEN
+*
+ CALL XERBLA( 'SSTEMR', -INFO )
+*
+ RETURN
+ ELSE IF( LQUERY .OR. ZQUERY ) THEN
+ RETURN
+ END IF
+*
+* Handle N = 0, 1, and 2 cases immediately
+*
+ M = 0
+ IF( N.EQ.0 )
+ $ RETURN
+*
+ IF( N.EQ.1 ) THEN
+ IF( ALLEIG .OR. INDEIG ) THEN
+ M = 1
+ W( 1 ) = D( 1 )
+ ELSE
+ IF( WL.LT.D( 1 ) .AND. WU.GE.D( 1 ) ) THEN
+ M = 1
+ W( 1 ) = D( 1 )
+ END IF
+ END IF
+ IF( WANTZ.AND.(.NOT.ZQUERY) ) THEN
+ Z( 1, 1 ) = ONE
+ ISUPPZ(1) = 1
+ ISUPPZ(2) = 1
+ END IF
+ RETURN
+ END IF
+*
+ IF( N.EQ.2 ) THEN
+ IF( .NOT.WANTZ ) THEN
+ CALL SLAE2( D(1), E(1), D(2), R1, R2 )
+ ELSE IF( WANTZ.AND.(.NOT.ZQUERY) ) THEN
+ CALL SLAEV2( D(1), E(1), D(2), R1, R2, CS, SN )
+ END IF
+ IF( ALLEIG.OR.
+ $ (VALEIG.AND.(R2.GT.WL).AND.
+ $ (R2.LE.WU)).OR.
+ $ (INDEIG.AND.(IIL.EQ.1)) ) THEN
+ M = M+1
+ W( M ) = R2
+ IF( WANTZ.AND.(.NOT.ZQUERY) ) THEN
+ Z( 1, M ) = -SN
+ Z( 2, M ) = CS
+* Note: At most one of SN and CS can be zero.
+ IF (SN.NE.ZERO) THEN
+ IF (CS.NE.ZERO) THEN
+ ISUPPZ(2*M-1) = 1
+ ISUPPZ(2*M-1) = 2
+ ELSE
+ ISUPPZ(2*M-1) = 1
+ ISUPPZ(2*M-1) = 1
+ END IF
+ ELSE
+ ISUPPZ(2*M-1) = 2
+ ISUPPZ(2*M) = 2
+ END IF
+ ENDIF
+ ENDIF
+ IF( ALLEIG.OR.
+ $ (VALEIG.AND.(R1.GT.WL).AND.
+ $ (R1.LE.WU)).OR.
+ $ (INDEIG.AND.(IIU.EQ.2)) ) THEN
+ M = M+1
+ W( M ) = R1
+ IF( WANTZ.AND.(.NOT.ZQUERY) ) THEN
+ Z( 1, M ) = CS
+ Z( 2, M ) = SN
+* Note: At most one of SN and CS can be zero.
+ IF (SN.NE.ZERO) THEN
+ IF (CS.NE.ZERO) THEN
+ ISUPPZ(2*M-1) = 1
+ ISUPPZ(2*M-1) = 2
+ ELSE
+ ISUPPZ(2*M-1) = 1
+ ISUPPZ(2*M-1) = 1
+ END IF
+ ELSE
+ ISUPPZ(2*M-1) = 2
+ ISUPPZ(2*M) = 2
+ END IF
+ ENDIF
+ ENDIF
+ RETURN
+ END IF
+
+* Continue with general N
+
+ INDGRS = 1
+ INDERR = 2*N + 1
+ INDGP = 3*N + 1
+ INDD = 4*N + 1
+ INDE2 = 5*N + 1
+ INDWRK = 6*N + 1
+*
+ IINSPL = 1
+ IINDBL = N + 1
+ IINDW = 2*N + 1
+ IINDWK = 3*N + 1
+*
+* Scale matrix to allowable range, if necessary.
+* The allowable range is related to the PIVMIN parameter; see the
+* comments in SLARRD. The preference for scaling small values
+* up is heuristic; we expect users' matrices not to be close to the
+* RMAX threshold.
+*
+ SCALE = ONE
+ TNRM = SLANST( 'M', N, D, E )
+ IF( TNRM.GT.ZERO .AND. TNRM.LT.RMIN ) THEN
+ SCALE = RMIN / TNRM
+ ELSE IF( TNRM.GT.RMAX ) THEN
+ SCALE = RMAX / TNRM
+ END IF
+ IF( SCALE.NE.ONE ) THEN
+ CALL SSCAL( N, SCALE, D, 1 )
+ CALL SSCAL( N-1, SCALE, E, 1 )
+ TNRM = TNRM*SCALE
+ IF( VALEIG ) THEN
+* If eigenvalues in interval have to be found,
+* scale (WL, WU] accordingly
+ WL = WL*SCALE
+ WU = WU*SCALE
+ ENDIF
+ END IF
+*
+* Compute the desired eigenvalues of the tridiagonal after splitting
+* into smaller subblocks if the corresponding off-diagonal elements
+* are small
+* THRESH is the splitting parameter for SLARRE
+* A negative THRESH forces the old splitting criterion based on the
+* size of the off-diagonal. A positive THRESH switches to splitting
+* which preserves relative accuracy.
+*
+ IF( TRYRAC ) THEN
+* Test whether the matrix warrants the more expensive relative approach.
+ CALL SLARRR( N, D, E, IINFO )
+ ELSE
+* The user does not care about relative accurately eigenvalues
+ IINFO = -1
+ ENDIF
+* Set the splitting criterion
+ IF (IINFO.EQ.0) THEN
+ THRESH = EPS
+ ELSE
+ THRESH = -EPS
+* relative accuracy is desired but T does not guarantee it
+ TRYRAC = .FALSE.
+ ENDIF
+*
+ IF( TRYRAC ) THEN
+* Copy original diagonal, needed to guarantee relative accuracy
+ CALL SCOPY(N,D,1,WORK(INDD),1)
+ ENDIF
+* Store the squares of the offdiagonal values of T
+ DO 5 J = 1, N-1
+ WORK( INDE2+J-1 ) = E(J)**2
+ 5 CONTINUE
+
+* Set the tolerance parameters for bisection
+ IF( .NOT.WANTZ ) THEN
+* SLARRE computes the eigenvalues to full precision.
+ RTOL1 = FOUR * EPS
+ RTOL2 = FOUR * EPS
+ ELSE
+* SLARRE computes the eigenvalues to less than full precision.
+* SLARRV will refine the eigenvalue approximations, and we can
+* need less accurate initial bisection in SLARRE.
+* Note: these settings do only affect the subset case and SLARRE
+ RTOL1 = MAX( SQRT(EPS)*5.0E-2, FOUR * EPS )
+ RTOL2 = MAX( SQRT(EPS)*5.0E-3, FOUR * EPS )
+ ENDIF
+ CALL SLARRE( RANGE, N, WL, WU, IIL, IIU, D, E,
+ $ WORK(INDE2), RTOL1, RTOL2, THRESH, NSPLIT,
+ $ IWORK( IINSPL ), M, W, WORK( INDERR ),
+ $ WORK( INDGP ), IWORK( IINDBL ),
+ $ IWORK( IINDW ), WORK( INDGRS ), PIVMIN,
+ $ WORK( INDWRK ), IWORK( IINDWK ), IINFO )
+ IF( IINFO.NE.0 ) THEN
+ INFO = 10 + ABS( IINFO )
+ RETURN
+ END IF
+* Note that if RANGE .NE. 'V', SLARRE computes bounds on the desired
+* part of the spectrum. All desired eigenvalues are contained in
+* (WL,WU]
+
+
+ IF( WANTZ ) THEN
+*
+* Compute the desired eigenvectors corresponding to the computed
+* eigenvalues
+*
+ CALL SLARRV( N, WL, WU, D, E,
+ $ PIVMIN, IWORK( IINSPL ), M,
+ $ 1, M, MINRGP, RTOL1, RTOL2,
+ $ W, WORK( INDERR ), WORK( INDGP ), IWORK( IINDBL ),
+ $ IWORK( IINDW ), WORK( INDGRS ), Z, LDZ,
+ $ ISUPPZ, WORK( INDWRK ), IWORK( IINDWK ), IINFO )
+ IF( IINFO.NE.0 ) THEN
+ INFO = 20 + ABS( IINFO )
+ RETURN
+ END IF
+ ELSE
+* SLARRE computes eigenvalues of the (shifted) root representation
+* SLARRV returns the eigenvalues of the unshifted matrix.
+* However, if the eigenvectors are not desired by the user, we need
+* to apply the corresponding shifts from SLARRE to obtain the
+* eigenvalues of the original matrix.
+ DO 20 J = 1, M
+ ITMP = IWORK( IINDBL+J-1 )
+ W( J ) = W( J ) + E( IWORK( IINSPL+ITMP-1 ) )
+ 20 CONTINUE
+ END IF
+*
+
+ IF ( TRYRAC ) THEN
+* Refine computed eigenvalues so that they are relatively accurate
+* with respect to the original matrix T.
+ IBEGIN = 1
+ WBEGIN = 1
+ DO 39 JBLK = 1, IWORK( IINDBL+M-1 )
+ IEND = IWORK( IINSPL+JBLK-1 )
+ IN = IEND - IBEGIN + 1
+ WEND = WBEGIN - 1
+* check if any eigenvalues have to be refined in this block
+ 36 CONTINUE
+ IF( WEND.LT.M ) THEN
+ IF( IWORK( IINDBL+WEND ).EQ.JBLK ) THEN
+ WEND = WEND + 1
+ GO TO 36
+ END IF
+ END IF
+ IF( WEND.LT.WBEGIN ) THEN
+ IBEGIN = IEND + 1
+ GO TO 39
+ END IF
+
+ OFFSET = IWORK(IINDW+WBEGIN-1)-1
+ IFIRST = IWORK(IINDW+WBEGIN-1)
+ ILAST = IWORK(IINDW+WEND-1)
+ RTOL2 = FOUR * EPS
+ CALL SLARRJ( IN,
+ $ WORK(INDD+IBEGIN-1), WORK(INDE2+IBEGIN-1),
+ $ IFIRST, ILAST, RTOL2, OFFSET, W(WBEGIN),
+ $ WORK( INDERR+WBEGIN-1 ),
+ $ WORK( INDWRK ), IWORK( IINDWK ), PIVMIN,
+ $ TNRM, IINFO )
+ IBEGIN = IEND + 1
+ WBEGIN = WEND + 1
+ 39 CONTINUE
+ ENDIF
+*
+* If matrix was scaled, then rescale eigenvalues appropriately.
+*
+ IF( SCALE.NE.ONE ) THEN
+ CALL SSCAL( M, ONE / SCALE, W, 1 )
+ END IF
+*
+* If eigenvalues are not in increasing order, then sort them,
+* possibly along with eigenvectors.
+*
+ IF( NSPLIT.GT.1 ) THEN
+ IF( .NOT. WANTZ ) THEN
+ CALL SLASRT( 'I', M, W, IINFO )
+ IF( IINFO.NE.0 ) THEN
+ INFO = 3
+ RETURN
+ END IF
+ ELSE
+ DO 60 J = 1, M - 1
+ I = 0
+ TMP = W( J )
+ DO 50 JJ = J + 1, M
+ IF( W( JJ ).LT.TMP ) THEN
+ I = JJ
+ TMP = W( JJ )
+ END IF
+ 50 CONTINUE
+ IF( I.NE.0 ) THEN
+ W( I ) = W( J )
+ W( J ) = TMP
+ IF( WANTZ ) THEN
+ CALL SSWAP( N, Z( 1, I ), 1, Z( 1, J ), 1 )
+ ITMP = ISUPPZ( 2*I-1 )
+ ISUPPZ( 2*I-1 ) = ISUPPZ( 2*J-1 )
+ ISUPPZ( 2*J-1 ) = ITMP
+ ITMP = ISUPPZ( 2*I )
+ ISUPPZ( 2*I ) = ISUPPZ( 2*J )
+ ISUPPZ( 2*J ) = ITMP
+ END IF
+ END IF
+ 60 CONTINUE
+ END IF
+ ENDIF
+*
+*
+ WORK( 1 ) = LWMIN
+ IWORK( 1 ) = LIWMIN
+ RETURN
+*
+* End of SSTEMR
+*
+ END
+ SUBROUTINE SSTEQR( COMPZ, N, D, E, Z, LDZ, WORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER COMPZ
+ INTEGER INFO, LDZ, N
+* ..
+* .. Array Arguments ..
+ REAL D( * ), E( * ), WORK( * ), Z( LDZ, * )
+* ..
+*
+* Purpose
+* =======
+*
+* SSTEQR computes all eigenvalues and, optionally, eigenvectors of a
+* symmetric tridiagonal matrix using the implicit QL or QR method.
+* The eigenvectors of a full or band symmetric matrix can also be found
+* if SSYTRD or SSPTRD or SSBTRD has been used to reduce this matrix to
+* tridiagonal form.
+*
+* Arguments
+* =========
+*
+* COMPZ (input) CHARACTER*1
+* = 'N': Compute eigenvalues only.
+* = 'V': Compute eigenvalues and eigenvectors of the original
+* symmetric matrix. On entry, Z must contain the
+* orthogonal matrix used to reduce the original matrix
+* to tridiagonal form.
+* = 'I': Compute eigenvalues and eigenvectors of the
+* tridiagonal matrix. Z is initialized to the identity
+* matrix.
+*
+* N (input) INTEGER
+* The order of the matrix. N >= 0.
+*
+* D (input/output) REAL array, dimension (N)
+* On entry, the diagonal elements of the tridiagonal matrix.
+* On exit, if INFO = 0, the eigenvalues in ascending order.
+*
+* E (input/output) REAL array, dimension (N-1)
+* On entry, the (n-1) subdiagonal elements of the tridiagonal
+* matrix.
+* On exit, E has been destroyed.
+*
+* Z (input/output) REAL array, dimension (LDZ, N)
+* On entry, if COMPZ = 'V', then Z contains the orthogonal
+* matrix used in the reduction to tridiagonal form.
+* On exit, if INFO = 0, then if COMPZ = 'V', Z contains the
+* orthonormal eigenvectors of the original symmetric matrix,
+* and if COMPZ = 'I', Z contains the orthonormal eigenvectors
+* of the symmetric tridiagonal matrix.
+* If COMPZ = 'N', then Z is not referenced.
+*
+* LDZ (input) INTEGER
+* The leading dimension of the array Z. LDZ >= 1, and if
+* eigenvectors are desired, then LDZ >= max(1,N).
+*
+* WORK (workspace) REAL array, dimension (max(1,2*N-2))
+* If COMPZ = 'N', then WORK is not referenced.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* > 0: the algorithm has failed to find all the eigenvalues in
+* a total of 30*N iterations; if INFO = i, then i
+* elements of E have not converged to zero; on exit, D
+* and E contain the elements of a symmetric tridiagonal
+* matrix which is orthogonally similar to the original
+* matrix.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO, ONE, TWO, THREE
+ PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0, TWO = 2.0E0,
+ $ THREE = 3.0E0 )
+ INTEGER MAXIT
+ PARAMETER ( MAXIT = 30 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, ICOMPZ, II, ISCALE, J, JTOT, K, L, L1, LEND,
+ $ LENDM1, LENDP1, LENDSV, LM1, LSV, M, MM, MM1,
+ $ NM1, NMAXIT
+ REAL ANORM, B, C, EPS, EPS2, F, G, P, R, RT1, RT2,
+ $ S, SAFMAX, SAFMIN, SSFMAX, SSFMIN, TST
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ REAL SLAMCH, SLANST, SLAPY2
+ EXTERNAL LSAME, SLAMCH, SLANST, SLAPY2
+* ..
+* .. External Subroutines ..
+ EXTERNAL SLAE2, SLAEV2, SLARTG, SLASCL, SLASET, SLASR,
+ $ SLASRT, SSWAP, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, SIGN, SQRT
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+*
+ IF( LSAME( COMPZ, 'N' ) ) THEN
+ ICOMPZ = 0
+ ELSE IF( LSAME( COMPZ, 'V' ) ) THEN
+ ICOMPZ = 1
+ ELSE IF( LSAME( COMPZ, 'I' ) ) THEN
+ ICOMPZ = 2
+ ELSE
+ ICOMPZ = -1
+ END IF
+ IF( ICOMPZ.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( ( LDZ.LT.1 ) .OR. ( ICOMPZ.GT.0 .AND. LDZ.LT.MAX( 1,
+ $ N ) ) ) THEN
+ INFO = -6
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SSTEQR', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+ IF( N.EQ.1 ) THEN
+ IF( ICOMPZ.EQ.2 )
+ $ Z( 1, 1 ) = ONE
+ RETURN
+ END IF
+*
+* Determine the unit roundoff and over/underflow thresholds.
+*
+ EPS = SLAMCH( 'E' )
+ EPS2 = EPS**2
+ SAFMIN = SLAMCH( 'S' )
+ SAFMAX = ONE / SAFMIN
+ SSFMAX = SQRT( SAFMAX ) / THREE
+ SSFMIN = SQRT( SAFMIN ) / EPS2
+*
+* Compute the eigenvalues and eigenvectors of the tridiagonal
+* matrix.
+*
+ IF( ICOMPZ.EQ.2 )
+ $ CALL SLASET( 'Full', N, N, ZERO, ONE, Z, LDZ )
+*
+ NMAXIT = N*MAXIT
+ JTOT = 0
+*
+* Determine where the matrix splits and choose QL or QR iteration
+* for each block, according to whether top or bottom diagonal
+* element is smaller.
+*
+ L1 = 1
+ NM1 = N - 1
+*
+ 10 CONTINUE
+ IF( L1.GT.N )
+ $ GO TO 160
+ IF( L1.GT.1 )
+ $ E( L1-1 ) = ZERO
+ IF( L1.LE.NM1 ) THEN
+ DO 20 M = L1, NM1
+ TST = ABS( E( M ) )
+ IF( TST.EQ.ZERO )
+ $ GO TO 30
+ IF( TST.LE.( SQRT( ABS( D( M ) ) )*SQRT( ABS( D( M+
+ $ 1 ) ) ) )*EPS ) THEN
+ E( M ) = ZERO
+ GO TO 30
+ END IF
+ 20 CONTINUE
+ END IF
+ M = N
+*
+ 30 CONTINUE
+ L = L1
+ LSV = L
+ LEND = M
+ LENDSV = LEND
+ L1 = M + 1
+ IF( LEND.EQ.L )
+ $ GO TO 10
+*
+* Scale submatrix in rows and columns L to LEND
+*
+ ANORM = SLANST( 'I', LEND-L+1, D( L ), E( L ) )
+ ISCALE = 0
+ IF( ANORM.EQ.ZERO )
+ $ GO TO 10
+ IF( ANORM.GT.SSFMAX ) THEN
+ ISCALE = 1
+ CALL SLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L+1, 1, D( L ), N,
+ $ INFO )
+ CALL SLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L, 1, E( L ), N,
+ $ INFO )
+ ELSE IF( ANORM.LT.SSFMIN ) THEN
+ ISCALE = 2
+ CALL SLASCL( 'G', 0, 0, ANORM, SSFMIN, LEND-L+1, 1, D( L ), N,
+ $ INFO )
+ CALL SLASCL( 'G', 0, 0, ANORM, SSFMIN, LEND-L, 1, E( L ), N,
+ $ INFO )
+ END IF
+*
+* Choose between QL and QR iteration
+*
+ IF( ABS( D( LEND ) ).LT.ABS( D( L ) ) ) THEN
+ LEND = LSV
+ L = LENDSV
+ END IF
+*
+ IF( LEND.GT.L ) THEN
+*
+* QL Iteration
+*
+* Look for small subdiagonal element.
+*
+ 40 CONTINUE
+ IF( L.NE.LEND ) THEN
+ LENDM1 = LEND - 1
+ DO 50 M = L, LENDM1
+ TST = ABS( E( M ) )**2
+ IF( TST.LE.( EPS2*ABS( D( M ) ) )*ABS( D( M+1 ) )+
+ $ SAFMIN )GO TO 60
+ 50 CONTINUE
+ END IF
+*
+ M = LEND
+*
+ 60 CONTINUE
+ IF( M.LT.LEND )
+ $ E( M ) = ZERO
+ P = D( L )
+ IF( M.EQ.L )
+ $ GO TO 80
+*
+* If remaining matrix is 2-by-2, use SLAE2 or SLAEV2
+* to compute its eigensystem.
+*
+ IF( M.EQ.L+1 ) THEN
+ IF( ICOMPZ.GT.0 ) THEN
+ CALL SLAEV2( D( L ), E( L ), D( L+1 ), RT1, RT2, C, S )
+ WORK( L ) = C
+ WORK( N-1+L ) = S
+ CALL SLASR( 'R', 'V', 'B', N, 2, WORK( L ),
+ $ WORK( N-1+L ), Z( 1, L ), LDZ )
+ ELSE
+ CALL SLAE2( D( L ), E( L ), D( L+1 ), RT1, RT2 )
+ END IF
+ D( L ) = RT1
+ D( L+1 ) = RT2
+ E( L ) = ZERO
+ L = L + 2
+ IF( L.LE.LEND )
+ $ GO TO 40
+ GO TO 140
+ END IF
+*
+ IF( JTOT.EQ.NMAXIT )
+ $ GO TO 140
+ JTOT = JTOT + 1
+*
+* Form shift.
+*
+ G = ( D( L+1 )-P ) / ( TWO*E( L ) )
+ R = SLAPY2( G, ONE )
+ G = D( M ) - P + ( E( L ) / ( G+SIGN( R, G ) ) )
+*
+ S = ONE
+ C = ONE
+ P = ZERO
+*
+* Inner loop
+*
+ MM1 = M - 1
+ DO 70 I = MM1, L, -1
+ F = S*E( I )
+ B = C*E( I )
+ CALL SLARTG( G, F, C, S, R )
+ IF( I.NE.M-1 )
+ $ E( I+1 ) = R
+ G = D( I+1 ) - P
+ R = ( D( I )-G )*S + TWO*C*B
+ P = S*R
+ D( I+1 ) = G + P
+ G = C*R - B
+*
+* If eigenvectors are desired, then save rotations.
+*
+ IF( ICOMPZ.GT.0 ) THEN
+ WORK( I ) = C
+ WORK( N-1+I ) = -S
+ END IF
+*
+ 70 CONTINUE
+*
+* If eigenvectors are desired, then apply saved rotations.
+*
+ IF( ICOMPZ.GT.0 ) THEN
+ MM = M - L + 1
+ CALL SLASR( 'R', 'V', 'B', N, MM, WORK( L ), WORK( N-1+L ),
+ $ Z( 1, L ), LDZ )
+ END IF
+*
+ D( L ) = D( L ) - P
+ E( L ) = G
+ GO TO 40
+*
+* Eigenvalue found.
+*
+ 80 CONTINUE
+ D( L ) = P
+*
+ L = L + 1
+ IF( L.LE.LEND )
+ $ GO TO 40
+ GO TO 140
+*
+ ELSE
+*
+* QR Iteration
+*
+* Look for small superdiagonal element.
+*
+ 90 CONTINUE
+ IF( L.NE.LEND ) THEN
+ LENDP1 = LEND + 1
+ DO 100 M = L, LENDP1, -1
+ TST = ABS( E( M-1 ) )**2
+ IF( TST.LE.( EPS2*ABS( D( M ) ) )*ABS( D( M-1 ) )+
+ $ SAFMIN )GO TO 110
+ 100 CONTINUE
+ END IF
+*
+ M = LEND
+*
+ 110 CONTINUE
+ IF( M.GT.LEND )
+ $ E( M-1 ) = ZERO
+ P = D( L )
+ IF( M.EQ.L )
+ $ GO TO 130
+*
+* If remaining matrix is 2-by-2, use SLAE2 or SLAEV2
+* to compute its eigensystem.
+*
+ IF( M.EQ.L-1 ) THEN
+ IF( ICOMPZ.GT.0 ) THEN
+ CALL SLAEV2( D( L-1 ), E( L-1 ), D( L ), RT1, RT2, C, S )
+ WORK( M ) = C
+ WORK( N-1+M ) = S
+ CALL SLASR( 'R', 'V', 'F', N, 2, WORK( M ),
+ $ WORK( N-1+M ), Z( 1, L-1 ), LDZ )
+ ELSE
+ CALL SLAE2( D( L-1 ), E( L-1 ), D( L ), RT1, RT2 )
+ END IF
+ D( L-1 ) = RT1
+ D( L ) = RT2
+ E( L-1 ) = ZERO
+ L = L - 2
+ IF( L.GE.LEND )
+ $ GO TO 90
+ GO TO 140
+ END IF
+*
+ IF( JTOT.EQ.NMAXIT )
+ $ GO TO 140
+ JTOT = JTOT + 1
+*
+* Form shift.
+*
+ G = ( D( L-1 )-P ) / ( TWO*E( L-1 ) )
+ R = SLAPY2( G, ONE )
+ G = D( M ) - P + ( E( L-1 ) / ( G+SIGN( R, G ) ) )
+*
+ S = ONE
+ C = ONE
+ P = ZERO
+*
+* Inner loop
+*
+ LM1 = L - 1
+ DO 120 I = M, LM1
+ F = S*E( I )
+ B = C*E( I )
+ CALL SLARTG( G, F, C, S, R )
+ IF( I.NE.M )
+ $ E( I-1 ) = R
+ G = D( I ) - P
+ R = ( D( I+1 )-G )*S + TWO*C*B
+ P = S*R
+ D( I ) = G + P
+ G = C*R - B
+*
+* If eigenvectors are desired, then save rotations.
+*
+ IF( ICOMPZ.GT.0 ) THEN
+ WORK( I ) = C
+ WORK( N-1+I ) = S
+ END IF
+*
+ 120 CONTINUE
+*
+* If eigenvectors are desired, then apply saved rotations.
+*
+ IF( ICOMPZ.GT.0 ) THEN
+ MM = L - M + 1
+ CALL SLASR( 'R', 'V', 'F', N, MM, WORK( M ), WORK( N-1+M ),
+ $ Z( 1, M ), LDZ )
+ END IF
+*
+ D( L ) = D( L ) - P
+ E( LM1 ) = G
+ GO TO 90
+*
+* Eigenvalue found.
+*
+ 130 CONTINUE
+ D( L ) = P
+*
+ L = L - 1
+ IF( L.GE.LEND )
+ $ GO TO 90
+ GO TO 140
+*
+ END IF
+*
+* Undo scaling if necessary
+*
+ 140 CONTINUE
+ IF( ISCALE.EQ.1 ) THEN
+ CALL SLASCL( 'G', 0, 0, SSFMAX, ANORM, LENDSV-LSV+1, 1,
+ $ D( LSV ), N, INFO )
+ CALL SLASCL( 'G', 0, 0, SSFMAX, ANORM, LENDSV-LSV, 1, E( LSV ),
+ $ N, INFO )
+ ELSE IF( ISCALE.EQ.2 ) THEN
+ CALL SLASCL( 'G', 0, 0, SSFMIN, ANORM, LENDSV-LSV+1, 1,
+ $ D( LSV ), N, INFO )
+ CALL SLASCL( 'G', 0, 0, SSFMIN, ANORM, LENDSV-LSV, 1, E( LSV ),
+ $ N, INFO )
+ END IF
+*
+* Check for no convergence to an eigenvalue after a total
+* of N*MAXIT iterations.
+*
+ IF( JTOT.LT.NMAXIT )
+ $ GO TO 10
+ DO 150 I = 1, N - 1
+ IF( E( I ).NE.ZERO )
+ $ INFO = INFO + 1
+ 150 CONTINUE
+ GO TO 190
+*
+* Order eigenvalues and eigenvectors.
+*
+ 160 CONTINUE
+ IF( ICOMPZ.EQ.0 ) THEN
+*
+* Use Quick Sort
+*
+ CALL SLASRT( 'I', N, D, INFO )
+*
+ ELSE
+*
+* Use Selection Sort to minimize swaps of eigenvectors
+*
+ DO 180 II = 2, N
+ I = II - 1
+ K = I
+ P = D( I )
+ DO 170 J = II, N
+ IF( D( J ).LT.P ) THEN
+ K = J
+ P = D( J )
+ END IF
+ 170 CONTINUE
+ IF( K.NE.I ) THEN
+ D( K ) = D( I )
+ D( I ) = P
+ CALL SSWAP( N, Z( 1, I ), 1, Z( 1, K ), 1 )
+ END IF
+ 180 CONTINUE
+ END IF
+*
+ 190 CONTINUE
+ RETURN
+*
+* End of SSTEQR
+*
+ END
+ SUBROUTINE SSTERF( N, D, E, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, N
+* ..
+* .. Array Arguments ..
+ REAL D( * ), E( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SSTERF computes all eigenvalues of a symmetric tridiagonal matrix
+* using the Pal-Walker-Kahan variant of the QL or QR algorithm.
+*
+* Arguments
+* =========
+*
+* N (input) INTEGER
+* The order of the matrix. N >= 0.
+*
+* D (input/output) REAL array, dimension (N)
+* On entry, the n diagonal elements of the tridiagonal matrix.
+* On exit, if INFO = 0, the eigenvalues in ascending order.
+*
+* E (input/output) REAL array, dimension (N-1)
+* On entry, the (n-1) subdiagonal elements of the tridiagonal
+* matrix.
+* On exit, E has been destroyed.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* > 0: the algorithm failed to find all of the eigenvalues in
+* a total of 30*N iterations; if INFO = i, then i
+* elements of E have not converged to zero.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO, ONE, TWO, THREE
+ PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0, TWO = 2.0E0,
+ $ THREE = 3.0E0 )
+ INTEGER MAXIT
+ PARAMETER ( MAXIT = 30 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, ISCALE, JTOT, L, L1, LEND, LENDSV, LSV, M,
+ $ NMAXIT
+ REAL ALPHA, ANORM, BB, C, EPS, EPS2, GAMMA, OLDC,
+ $ OLDGAM, P, R, RT1, RT2, RTE, S, SAFMAX, SAFMIN,
+ $ SIGMA, SSFMAX, SSFMIN
+* ..
+* .. External Functions ..
+ REAL SLAMCH, SLANST, SLAPY2
+ EXTERNAL SLAMCH, SLANST, SLAPY2
+* ..
+* .. External Subroutines ..
+ EXTERNAL SLAE2, SLASCL, SLASRT, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, SIGN, SQRT
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+*
+* Quick return if possible
+*
+ IF( N.LT.0 ) THEN
+ INFO = -1
+ CALL XERBLA( 'SSTERF', -INFO )
+ RETURN
+ END IF
+ IF( N.LE.1 )
+ $ RETURN
+*
+* Determine the unit roundoff for this environment.
+*
+ EPS = SLAMCH( 'E' )
+ EPS2 = EPS**2
+ SAFMIN = SLAMCH( 'S' )
+ SAFMAX = ONE / SAFMIN
+ SSFMAX = SQRT( SAFMAX ) / THREE
+ SSFMIN = SQRT( SAFMIN ) / EPS2
+*
+* Compute the eigenvalues of the tridiagonal matrix.
+*
+ NMAXIT = N*MAXIT
+ SIGMA = ZERO
+ JTOT = 0
+*
+* Determine where the matrix splits and choose QL or QR iteration
+* for each block, according to whether top or bottom diagonal
+* element is smaller.
+*
+ L1 = 1
+*
+ 10 CONTINUE
+ IF( L1.GT.N )
+ $ GO TO 170
+ IF( L1.GT.1 )
+ $ E( L1-1 ) = ZERO
+ DO 20 M = L1, N - 1
+ IF( ABS( E( M ) ).LE.( SQRT( ABS( D( M ) ) )*
+ $ SQRT( ABS( D( M+1 ) ) ) )*EPS ) THEN
+ E( M ) = ZERO
+ GO TO 30
+ END IF
+ 20 CONTINUE
+ M = N
+*
+ 30 CONTINUE
+ L = L1
+ LSV = L
+ LEND = M
+ LENDSV = LEND
+ L1 = M + 1
+ IF( LEND.EQ.L )
+ $ GO TO 10
+*
+* Scale submatrix in rows and columns L to LEND
+*
+ ANORM = SLANST( 'I', LEND-L+1, D( L ), E( L ) )
+ ISCALE = 0
+ IF( ANORM.GT.SSFMAX ) THEN
+ ISCALE = 1
+ CALL SLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L+1, 1, D( L ), N,
+ $ INFO )
+ CALL SLASCL( 'G', 0, 0, ANORM, SSFMAX, LEND-L, 1, E( L ), N,
+ $ INFO )
+ ELSE IF( ANORM.LT.SSFMIN ) THEN
+ ISCALE = 2
+ CALL SLASCL( 'G', 0, 0, ANORM, SSFMIN, LEND-L+1, 1, D( L ), N,
+ $ INFO )
+ CALL SLASCL( 'G', 0, 0, ANORM, SSFMIN, LEND-L, 1, E( L ), N,
+ $ INFO )
+ END IF
+*
+ DO 40 I = L, LEND - 1
+ E( I ) = E( I )**2
+ 40 CONTINUE
+*
+* Choose between QL and QR iteration
+*
+ IF( ABS( D( LEND ) ).LT.ABS( D( L ) ) ) THEN
+ LEND = LSV
+ L = LENDSV
+ END IF
+*
+ IF( LEND.GE.L ) THEN
+*
+* QL Iteration
+*
+* Look for small subdiagonal element.
+*
+ 50 CONTINUE
+ IF( L.NE.LEND ) THEN
+ DO 60 M = L, LEND - 1
+ IF( ABS( E( M ) ).LE.EPS2*ABS( D( M )*D( M+1 ) ) )
+ $ GO TO 70
+ 60 CONTINUE
+ END IF
+ M = LEND
+*
+ 70 CONTINUE
+ IF( M.LT.LEND )
+ $ E( M ) = ZERO
+ P = D( L )
+ IF( M.EQ.L )
+ $ GO TO 90
+*
+* If remaining matrix is 2 by 2, use SLAE2 to compute its
+* eigenvalues.
+*
+ IF( M.EQ.L+1 ) THEN
+ RTE = SQRT( E( L ) )
+ CALL SLAE2( D( L ), RTE, D( L+1 ), RT1, RT2 )
+ D( L ) = RT1
+ D( L+1 ) = RT2
+ E( L ) = ZERO
+ L = L + 2
+ IF( L.LE.LEND )
+ $ GO TO 50
+ GO TO 150
+ END IF
+*
+ IF( JTOT.EQ.NMAXIT )
+ $ GO TO 150
+ JTOT = JTOT + 1
+*
+* Form shift.
+*
+ RTE = SQRT( E( L ) )
+ SIGMA = ( D( L+1 )-P ) / ( TWO*RTE )
+ R = SLAPY2( SIGMA, ONE )
+ SIGMA = P - ( RTE / ( SIGMA+SIGN( R, SIGMA ) ) )
+*
+ C = ONE
+ S = ZERO
+ GAMMA = D( M ) - SIGMA
+ P = GAMMA*GAMMA
+*
+* Inner loop
+*
+ DO 80 I = M - 1, L, -1
+ BB = E( I )
+ R = P + BB
+ IF( I.NE.M-1 )
+ $ E( I+1 ) = S*R
+ OLDC = C
+ C = P / R
+ S = BB / R
+ OLDGAM = GAMMA
+ ALPHA = D( I )
+ GAMMA = C*( ALPHA-SIGMA ) - S*OLDGAM
+ D( I+1 ) = OLDGAM + ( ALPHA-GAMMA )
+ IF( C.NE.ZERO ) THEN
+ P = ( GAMMA*GAMMA ) / C
+ ELSE
+ P = OLDC*BB
+ END IF
+ 80 CONTINUE
+*
+ E( L ) = S*P
+ D( L ) = SIGMA + GAMMA
+ GO TO 50
+*
+* Eigenvalue found.
+*
+ 90 CONTINUE
+ D( L ) = P
+*
+ L = L + 1
+ IF( L.LE.LEND )
+ $ GO TO 50
+ GO TO 150
+*
+ ELSE
+*
+* QR Iteration
+*
+* Look for small superdiagonal element.
+*
+ 100 CONTINUE
+ DO 110 M = L, LEND + 1, -1
+ IF( ABS( E( M-1 ) ).LE.EPS2*ABS( D( M )*D( M-1 ) ) )
+ $ GO TO 120
+ 110 CONTINUE
+ M = LEND
+*
+ 120 CONTINUE
+ IF( M.GT.LEND )
+ $ E( M-1 ) = ZERO
+ P = D( L )
+ IF( M.EQ.L )
+ $ GO TO 140
+*
+* If remaining matrix is 2 by 2, use SLAE2 to compute its
+* eigenvalues.
+*
+ IF( M.EQ.L-1 ) THEN
+ RTE = SQRT( E( L-1 ) )
+ CALL SLAE2( D( L ), RTE, D( L-1 ), RT1, RT2 )
+ D( L ) = RT1
+ D( L-1 ) = RT2
+ E( L-1 ) = ZERO
+ L = L - 2
+ IF( L.GE.LEND )
+ $ GO TO 100
+ GO TO 150
+ END IF
+*
+ IF( JTOT.EQ.NMAXIT )
+ $ GO TO 150
+ JTOT = JTOT + 1
+*
+* Form shift.
+*
+ RTE = SQRT( E( L-1 ) )
+ SIGMA = ( D( L-1 )-P ) / ( TWO*RTE )
+ R = SLAPY2( SIGMA, ONE )
+ SIGMA = P - ( RTE / ( SIGMA+SIGN( R, SIGMA ) ) )
+*
+ C = ONE
+ S = ZERO
+ GAMMA = D( M ) - SIGMA
+ P = GAMMA*GAMMA
+*
+* Inner loop
+*
+ DO 130 I = M, L - 1
+ BB = E( I )
+ R = P + BB
+ IF( I.NE.M )
+ $ E( I-1 ) = S*R
+ OLDC = C
+ C = P / R
+ S = BB / R
+ OLDGAM = GAMMA
+ ALPHA = D( I+1 )
+ GAMMA = C*( ALPHA-SIGMA ) - S*OLDGAM
+ D( I ) = OLDGAM + ( ALPHA-GAMMA )
+ IF( C.NE.ZERO ) THEN
+ P = ( GAMMA*GAMMA ) / C
+ ELSE
+ P = OLDC*BB
+ END IF
+ 130 CONTINUE
+*
+ E( L-1 ) = S*P
+ D( L ) = SIGMA + GAMMA
+ GO TO 100
+*
+* Eigenvalue found.
+*
+ 140 CONTINUE
+ D( L ) = P
+*
+ L = L - 1
+ IF( L.GE.LEND )
+ $ GO TO 100
+ GO TO 150
+*
+ END IF
+*
+* Undo scaling if necessary
+*
+ 150 CONTINUE
+ IF( ISCALE.EQ.1 )
+ $ CALL SLASCL( 'G', 0, 0, SSFMAX, ANORM, LENDSV-LSV+1, 1,
+ $ D( LSV ), N, INFO )
+ IF( ISCALE.EQ.2 )
+ $ CALL SLASCL( 'G', 0, 0, SSFMIN, ANORM, LENDSV-LSV+1, 1,
+ $ D( LSV ), N, INFO )
+*
+* Check for no convergence to an eigenvalue after a total
+* of N*MAXIT iterations.
+*
+ IF( JTOT.LT.NMAXIT )
+ $ GO TO 10
+ DO 160 I = 1, N - 1
+ IF( E( I ).NE.ZERO )
+ $ INFO = INFO + 1
+ 160 CONTINUE
+ GO TO 180
+*
+* Sort eigenvalues in increasing order.
+*
+ 170 CONTINUE
+ CALL SLASRT( 'I', N, D, INFO )
+*
+ 180 CONTINUE
+ RETURN
+*
+* End of SSTERF
+*
+ END
+ SUBROUTINE SSTEV( JOBZ, N, D, E, Z, LDZ, WORK, INFO )
+*
+* -- LAPACK driver routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER JOBZ
+ INTEGER INFO, LDZ, N
+* ..
+* .. Array Arguments ..
+ REAL D( * ), E( * ), WORK( * ), Z( LDZ, * )
+* ..
+*
+* Purpose
+* =======
+*
+* SSTEV computes all eigenvalues and, optionally, eigenvectors of a
+* real symmetric tridiagonal matrix A.
+*
+* Arguments
+* =========
+*
+* JOBZ (input) CHARACTER*1
+* = 'N': Compute eigenvalues only;
+* = 'V': Compute eigenvalues and eigenvectors.
+*
+* N (input) INTEGER
+* The order of the matrix. N >= 0.
+*
+* D (input/output) REAL array, dimension (N)
+* On entry, the n diagonal elements of the tridiagonal matrix
+* A.
+* On exit, if INFO = 0, the eigenvalues in ascending order.
+*
+* E (input/output) REAL array, dimension (N-1)
+* On entry, the (n-1) subdiagonal elements of the tridiagonal
+* matrix A, stored in elements 1 to N-1 of E.
+* On exit, the contents of E are destroyed.
+*
+* Z (output) REAL array, dimension (LDZ, N)
+* If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal
+* eigenvectors of the matrix A, with the i-th column of Z
+* holding the eigenvector associated with D(i).
+* If JOBZ = 'N', then Z is not referenced.
+*
+* LDZ (input) INTEGER
+* The leading dimension of the array Z. LDZ >= 1, and if
+* JOBZ = 'V', LDZ >= max(1,N).
+*
+* WORK (workspace) REAL array, dimension (max(1,2*N-2))
+* If JOBZ = 'N', WORK is not referenced.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* > 0: if INFO = i, the algorithm failed to converge; i
+* off-diagonal elements of E did not converge to zero.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO, ONE
+ PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL WANTZ
+ INTEGER IMAX, ISCALE
+ REAL BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA, SMLNUM,
+ $ TNRM
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ REAL SLAMCH, SLANST
+ EXTERNAL LSAME, SLAMCH, SLANST
+* ..
+* .. External Subroutines ..
+ EXTERNAL SSCAL, SSTEQR, SSTERF, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC SQRT
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ WANTZ = LSAME( JOBZ, 'V' )
+*
+ INFO = 0
+ IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
+ INFO = -6
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SSTEV ', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+ IF( N.EQ.1 ) THEN
+ IF( WANTZ )
+ $ Z( 1, 1 ) = ONE
+ RETURN
+ END IF
+*
+* Get machine constants.
+*
+ SAFMIN = SLAMCH( 'Safe minimum' )
+ EPS = SLAMCH( 'Precision' )
+ SMLNUM = SAFMIN / EPS
+ BIGNUM = ONE / SMLNUM
+ RMIN = SQRT( SMLNUM )
+ RMAX = SQRT( BIGNUM )
+*
+* Scale matrix to allowable range, if necessary.
+*
+ ISCALE = 0
+ TNRM = SLANST( 'M', N, D, E )
+ IF( TNRM.GT.ZERO .AND. TNRM.LT.RMIN ) THEN
+ ISCALE = 1
+ SIGMA = RMIN / TNRM
+ ELSE IF( TNRM.GT.RMAX ) THEN
+ ISCALE = 1
+ SIGMA = RMAX / TNRM
+ END IF
+ IF( ISCALE.EQ.1 ) THEN
+ CALL SSCAL( N, SIGMA, D, 1 )
+ CALL SSCAL( N-1, SIGMA, E( 1 ), 1 )
+ END IF
+*
+* For eigenvalues only, call SSTERF. For eigenvalues and
+* eigenvectors, call SSTEQR.
+*
+ IF( .NOT.WANTZ ) THEN
+ CALL SSTERF( N, D, E, INFO )
+ ELSE
+ CALL SSTEQR( 'I', N, D, E, Z, LDZ, WORK, INFO )
+ END IF
+*
+* If matrix was scaled, then rescale eigenvalues appropriately.
+*
+ IF( ISCALE.EQ.1 ) THEN
+ IF( INFO.EQ.0 ) THEN
+ IMAX = N
+ ELSE
+ IMAX = INFO - 1
+ END IF
+ CALL SSCAL( IMAX, ONE / SIGMA, D, 1 )
+ END IF
+*
+ RETURN
+*
+* End of SSTEV
+*
+ END
+ SUBROUTINE SSTEVD( JOBZ, N, D, E, Z, LDZ, WORK, LWORK, IWORK,
+ $ LIWORK, INFO )
+*
+* -- LAPACK driver routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER JOBZ
+ INTEGER INFO, LDZ, LIWORK, LWORK, N
+* ..
+* .. Array Arguments ..
+ INTEGER IWORK( * )
+ REAL D( * ), E( * ), WORK( * ), Z( LDZ, * )
+* ..
+*
+* Purpose
+* =======
+*
+* SSTEVD computes all eigenvalues and, optionally, eigenvectors of a
+* real symmetric tridiagonal matrix. If eigenvectors are desired, it
+* uses a divide and conquer algorithm.
+*
+* The divide and conquer algorithm makes very mild assumptions about
+* floating point arithmetic. It will work on machines with a guard
+* digit in add/subtract, or on those binary machines without guard
+* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
+* Cray-2. It could conceivably fail on hexadecimal or decimal machines
+* without guard digits, but we know of none.
+*
+* Arguments
+* =========
+*
+* JOBZ (input) CHARACTER*1
+* = 'N': Compute eigenvalues only;
+* = 'V': Compute eigenvalues and eigenvectors.
+*
+* N (input) INTEGER
+* The order of the matrix. N >= 0.
+*
+* D (input/output) REAL array, dimension (N)
+* On entry, the n diagonal elements of the tridiagonal matrix
+* A.
+* On exit, if INFO = 0, the eigenvalues in ascending order.
+*
+* E (input/output) REAL array, dimension (N-1)
+* On entry, the (n-1) subdiagonal elements of the tridiagonal
+* matrix A, stored in elements 1 to N-1 of E.
+* On exit, the contents of E are destroyed.
+*
+* Z (output) REAL array, dimension (LDZ, N)
+* If JOBZ = 'V', then if INFO = 0, Z contains the orthonormal
+* eigenvectors of the matrix A, with the i-th column of Z
+* holding the eigenvector associated with D(i).
+* If JOBZ = 'N', then Z is not referenced.
+*
+* LDZ (input) INTEGER
+* The leading dimension of the array Z. LDZ >= 1, and if
+* JOBZ = 'V', LDZ >= max(1,N).
+*
+* WORK (workspace/output) REAL array,
+* dimension (LWORK)
+* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+* LWORK (input) INTEGER
+* The dimension of the array WORK.
+* If JOBZ = 'N' or N <= 1 then LWORK must be at least 1.
+* If JOBZ = 'V' and N > 1 then LWORK must be at least
+* ( 1 + 4*N + N**2 ).
+*
+* If LWORK = -1, then a workspace query is assumed; the routine
+* only calculates the optimal sizes of the WORK and IWORK
+* arrays, returns these values as the first entries of the WORK
+* and IWORK arrays, and no error message related to LWORK or
+* LIWORK is issued by XERBLA.
+*
+* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))
+* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
+*
+* LIWORK (input) INTEGER
+* The dimension of the array IWORK.
+* If JOBZ = 'N' or N <= 1 then LIWORK must be at least 1.
+* If JOBZ = 'V' and N > 1 then LIWORK must be at least 3+5*N.
+*
+* If LIWORK = -1, then a workspace query is assumed; the
+* routine only calculates the optimal sizes of the WORK and
+* IWORK arrays, returns these values as the first entries of
+* the WORK and IWORK arrays, and no error message related to
+* LWORK or LIWORK is issued by XERBLA.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* > 0: if INFO = i, the algorithm failed to converge; i
+* off-diagonal elements of E did not converge to zero.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO, ONE
+ PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL LQUERY, WANTZ
+ INTEGER ISCALE, LIWMIN, LWMIN
+ REAL BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA, SMLNUM,
+ $ TNRM
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ REAL SLAMCH, SLANST
+ EXTERNAL LSAME, SLAMCH, SLANST
+* ..
+* .. External Subroutines ..
+ EXTERNAL SSCAL, SSTEDC, SSTERF, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC SQRT
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ WANTZ = LSAME( JOBZ, 'V' )
+ LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 )
+*
+ INFO = 0
+ LIWMIN = 1
+ LWMIN = 1
+ IF( N.GT.1 .AND. WANTZ ) THEN
+ LWMIN = 1 + 4*N + N**2
+ LIWMIN = 3 + 5*N
+ END IF
+*
+ IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
+ INFO = -6
+ END IF
+*
+ IF( INFO.EQ.0 ) THEN
+ WORK( 1 ) = LWMIN
+ IWORK( 1 ) = LIWMIN
+*
+ IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
+ INFO = -8
+ ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN
+ INFO = -10
+ END IF
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SSTEVD', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+ IF( N.EQ.1 ) THEN
+ IF( WANTZ )
+ $ Z( 1, 1 ) = ONE
+ RETURN
+ END IF
+*
+* Get machine constants.
+*
+ SAFMIN = SLAMCH( 'Safe minimum' )
+ EPS = SLAMCH( 'Precision' )
+ SMLNUM = SAFMIN / EPS
+ BIGNUM = ONE / SMLNUM
+ RMIN = SQRT( SMLNUM )
+ RMAX = SQRT( BIGNUM )
+*
+* Scale matrix to allowable range, if necessary.
+*
+ ISCALE = 0
+ TNRM = SLANST( 'M', N, D, E )
+ IF( TNRM.GT.ZERO .AND. TNRM.LT.RMIN ) THEN
+ ISCALE = 1
+ SIGMA = RMIN / TNRM
+ ELSE IF( TNRM.GT.RMAX ) THEN
+ ISCALE = 1
+ SIGMA = RMAX / TNRM
+ END IF
+ IF( ISCALE.EQ.1 ) THEN
+ CALL SSCAL( N, SIGMA, D, 1 )
+ CALL SSCAL( N-1, SIGMA, E( 1 ), 1 )
+ END IF
+*
+* For eigenvalues only, call SSTERF. For eigenvalues and
+* eigenvectors, call SSTEDC.
+*
+ IF( .NOT.WANTZ ) THEN
+ CALL SSTERF( N, D, E, INFO )
+ ELSE
+ CALL SSTEDC( 'I', N, D, E, Z, LDZ, WORK, LWORK, IWORK, LIWORK,
+ $ INFO )
+ END IF
+*
+* If matrix was scaled, then rescale eigenvalues appropriately.
+*
+ IF( ISCALE.EQ.1 )
+ $ CALL SSCAL( N, ONE / SIGMA, D, 1 )
+*
+ WORK( 1 ) = LWMIN
+ IWORK( 1 ) = LIWMIN
+*
+ RETURN
+*
+* End of SSTEVD
+*
+ END
+ SUBROUTINE SSTEVR( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, ABSTOL,
+ $ M, W, Z, LDZ, ISUPPZ, WORK, LWORK, IWORK,
+ $ LIWORK, INFO )
+*
+* -- LAPACK driver routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER JOBZ, RANGE
+ INTEGER IL, INFO, IU, LDZ, LIWORK, LWORK, M, N
+ REAL ABSTOL, VL, VU
+* ..
+* .. Array Arguments ..
+ INTEGER ISUPPZ( * ), IWORK( * )
+ REAL D( * ), E( * ), W( * ), WORK( * ), Z( LDZ, * )
+* ..
+*
+* Purpose
+* =======
+*
+* SSTEVR computes selected eigenvalues and, optionally, eigenvectors
+* of a real symmetric tridiagonal matrix T. Eigenvalues and
+* eigenvectors can be selected by specifying either a range of values
+* or a range of indices for the desired eigenvalues.
+*
+* Whenever possible, SSTEVR calls SSTEMR to compute the
+* eigenspectrum using Relatively Robust Representations. SSTEMR
+* computes eigenvalues by the dqds algorithm, while orthogonal
+* eigenvectors are computed from various "good" L D L^T representations
+* (also known as Relatively Robust Representations). Gram-Schmidt
+* orthogonalization is avoided as far as possible. More specifically,
+* the various steps of the algorithm are as follows. For the i-th
+* unreduced block of T,
+* (a) Compute T - sigma_i = L_i D_i L_i^T, such that L_i D_i L_i^T
+* is a relatively robust representation,
+* (b) Compute the eigenvalues, lambda_j, of L_i D_i L_i^T to high
+* relative accuracy by the dqds algorithm,
+* (c) If there is a cluster of close eigenvalues, "choose" sigma_i
+* close to the cluster, and go to step (a),
+* (d) Given the approximate eigenvalue lambda_j of L_i D_i L_i^T,
+* compute the corresponding eigenvector by forming a
+* rank-revealing twisted factorization.
+* The desired accuracy of the output can be specified by the input
+* parameter ABSTOL.
+*
+* For more details, see "A new O(n^2) algorithm for the symmetric
+* tridiagonal eigenvalue/eigenvector problem", by Inderjit Dhillon,
+* Computer Science Division Technical Report No. UCB//CSD-97-971,
+* UC Berkeley, May 1997.
+*
+*
+* Note 1 : SSTEVR calls SSTEMR when the full spectrum is requested
+* on machines which conform to the ieee-754 floating point standard.
+* SSTEVR calls SSTEBZ and SSTEIN on non-ieee machines and
+* when partial spectrum requests are made.
+*
+* Normal execution of SSTEMR may create NaNs and infinities and
+* hence may abort due to a floating point exception in environments
+* which do not handle NaNs and infinities in the ieee standard default
+* manner.
+*
+* Arguments
+* =========
+*
+* JOBZ (input) CHARACTER*1
+* = 'N': Compute eigenvalues only;
+* = 'V': Compute eigenvalues and eigenvectors.
+*
+* RANGE (input) CHARACTER*1
+* = 'A': all eigenvalues will be found.
+* = 'V': all eigenvalues in the half-open interval (VL,VU]
+* will be found.
+* = 'I': the IL-th through IU-th eigenvalues will be found.
+********** For RANGE = 'V' or 'I' and IU - IL < N - 1, SSTEBZ and
+********** SSTEIN are called
+*
+* N (input) INTEGER
+* The order of the matrix. N >= 0.
+*
+* D (input/output) REAL array, dimension (N)
+* On entry, the n diagonal elements of the tridiagonal matrix
+* A.
+* On exit, D may be multiplied by a constant factor chosen
+* to avoid over/underflow in computing the eigenvalues.
+*
+* E (input/output) REAL array, dimension (max(1,N-1))
+* On entry, the (n-1) subdiagonal elements of the tridiagonal
+* matrix A in elements 1 to N-1 of E.
+* On exit, E may be multiplied by a constant factor chosen
+* to avoid over/underflow in computing the eigenvalues.
+*
+* VL (input) REAL
+* VU (input) REAL
+* If RANGE='V', the lower and upper bounds of the interval to
+* be searched for eigenvalues. VL < VU.
+* Not referenced if RANGE = 'A' or 'I'.
+*
+* IL (input) INTEGER
+* IU (input) INTEGER
+* If RANGE='I', the indices (in ascending order) of the
+* smallest and largest eigenvalues to be returned.
+* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
+* Not referenced if RANGE = 'A' or 'V'.
+*
+* ABSTOL (input) REAL
+* The absolute error tolerance for the eigenvalues.
+* An approximate eigenvalue is accepted as converged
+* when it is determined to lie in an interval [a,b]
+* of width less than or equal to
+*
+* ABSTOL + EPS * max( |a|,|b| ) ,
+*
+* where EPS is the machine precision. If ABSTOL is less than
+* or equal to zero, then EPS*|T| will be used in its place,
+* where |T| is the 1-norm of the tridiagonal matrix obtained
+* by reducing A to tridiagonal form.
+*
+* See "Computing Small Singular Values of Bidiagonal Matrices
+* with Guaranteed High Relative Accuracy," by Demmel and
+* Kahan, LAPACK Working Note #3.
+*
+* If high relative accuracy is important, set ABSTOL to
+* SLAMCH( 'Safe minimum' ). Doing so will guarantee that
+* eigenvalues are computed to high relative accuracy when
+* possible in future releases. The current code does not
+* make any guarantees about high relative accuracy, but
+* future releases will. See J. Barlow and J. Demmel,
+* "Computing Accurate Eigensystems of Scaled Diagonally
+* Dominant Matrices", LAPACK Working Note #7, for a discussion
+* of which matrices define their eigenvalues to high relative
+* accuracy.
+*
+* M (output) INTEGER
+* The total number of eigenvalues found. 0 <= M <= N.
+* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
+*
+* W (output) REAL array, dimension (N)
+* The first M elements contain the selected eigenvalues in
+* ascending order.
+*
+* Z (output) REAL array, dimension (LDZ, max(1,M) )
+* If JOBZ = 'V', then if INFO = 0, the first M columns of Z
+* contain the orthonormal eigenvectors of the matrix A
+* corresponding to the selected eigenvalues, with the i-th
+* column of Z holding the eigenvector associated with W(i).
+* Note: the user must ensure that at least max(1,M) columns are
+* supplied in the array Z; if RANGE = 'V', the exact value of M
+* is not known in advance and an upper bound must be used.
+*
+* LDZ (input) INTEGER
+* The leading dimension of the array Z. LDZ >= 1, and if
+* JOBZ = 'V', LDZ >= max(1,N).
+*
+* ISUPPZ (output) INTEGER array, dimension ( 2*max(1,M) )
+* The support of the eigenvectors in Z, i.e., the indices
+* indicating the nonzero elements in Z. The i-th eigenvector
+* is nonzero only in elements ISUPPZ( 2*i-1 ) through
+* ISUPPZ( 2*i ).
+********** Implemented only for RANGE = 'A' or 'I' and IU - IL = N - 1
+*
+* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))
+* On exit, if INFO = 0, WORK(1) returns the optimal (and
+* minimal) LWORK.
+*
+* LWORK (input) INTEGER
+* The dimension of the array WORK. LWORK >= 20*N.
+*
+* If LWORK = -1, then a workspace query is assumed; the routine
+* only calculates the optimal sizes of the WORK and IWORK
+* arrays, returns these values as the first entries of the WORK
+* and IWORK arrays, and no error message related to LWORK or
+* LIWORK is issued by XERBLA.
+*
+* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))
+* On exit, if INFO = 0, IWORK(1) returns the optimal (and
+* minimal) LIWORK.
+*
+* LIWORK (input) INTEGER
+* The dimension of the array IWORK. LIWORK >= 10*N.
+*
+* If LIWORK = -1, then a workspace query is assumed; the
+* routine only calculates the optimal sizes of the WORK and
+* IWORK arrays, returns these values as the first entries of
+* the WORK and IWORK arrays, and no error message related to
+* LWORK or LIWORK is issued by XERBLA.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* > 0: Internal error
+*
+* Further Details
+* ===============
+*
+* Based on contributions by
+* Inderjit Dhillon, IBM Almaden, USA
+* Osni Marques, LBNL/NERSC, USA
+* Ken Stanley, Computer Science Division, University of
+* California at Berkeley, USA
+* Jason Riedy, Computer Science Division, University of
+* California at Berkeley, USA
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO, ONE, TWO
+ PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0, TWO = 2.0E+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL ALLEIG, INDEIG, TEST, LQUERY, VALEIG, WANTZ,
+ $ TRYRAC
+ CHARACTER ORDER
+ INTEGER I, IEEEOK, IMAX, INDIBL, INDIFL, INDISP,
+ $ INDIWO, ISCALE, J, JJ, LIWMIN, LWMIN, NSPLIT
+ REAL BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA, SMLNUM,
+ $ TMP1, TNRM, VLL, VUU
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ILAENV
+ REAL SLAMCH, SLANST
+ EXTERNAL LSAME, ILAENV, SLAMCH, SLANST
+* ..
+* .. External Subroutines ..
+ EXTERNAL SCOPY, SSCAL, SSTEBZ, SSTEMR, SSTEIN, SSTERF,
+ $ SSWAP, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN, SQRT
+* ..
+* .. Executable Statements ..
+*
+*
+* Test the input parameters.
+*
+ IEEEOK = ILAENV( 10, 'SSTEVR', 'N', 1, 2, 3, 4 )
+*
+ WANTZ = LSAME( JOBZ, 'V' )
+ ALLEIG = LSAME( RANGE, 'A' )
+ VALEIG = LSAME( RANGE, 'V' )
+ INDEIG = LSAME( RANGE, 'I' )
+*
+ LQUERY = ( ( LWORK.EQ.-1 ) .OR. ( LIWORK.EQ.-1 ) )
+ LWMIN = MAX( 1, 20*N )
+ LIWMIN = MAX(1, 10*N )
+*
+*
+ INFO = 0
+ IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
+ INFO = -1
+ ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN
+ INFO = -2
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -3
+ ELSE
+ IF( VALEIG ) THEN
+ IF( N.GT.0 .AND. VU.LE.VL )
+ $ INFO = -7
+ ELSE IF( INDEIG ) THEN
+ IF( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) THEN
+ INFO = -8
+ ELSE IF( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) THEN
+ INFO = -9
+ END IF
+ END IF
+ END IF
+ IF( INFO.EQ.0 ) THEN
+ IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
+ INFO = -14
+ END IF
+ END IF
+*
+ IF( INFO.EQ.0 ) THEN
+ WORK( 1 ) = LWMIN
+ IWORK( 1 ) = LIWMIN
+*
+ IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
+ INFO = -17
+ ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN
+ INFO = -19
+ END IF
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SSTEVR', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ M = 0
+ IF( N.EQ.0 )
+ $ RETURN
+*
+ IF( N.EQ.1 ) THEN
+ IF( ALLEIG .OR. INDEIG ) THEN
+ M = 1
+ W( 1 ) = D( 1 )
+ ELSE
+ IF( VL.LT.D( 1 ) .AND. VU.GE.D( 1 ) ) THEN
+ M = 1
+ W( 1 ) = D( 1 )
+ END IF
+ END IF
+ IF( WANTZ )
+ $ Z( 1, 1 ) = ONE
+ RETURN
+ END IF
+*
+* Get machine constants.
+*
+ SAFMIN = SLAMCH( 'Safe minimum' )
+ EPS = SLAMCH( 'Precision' )
+ SMLNUM = SAFMIN / EPS
+ BIGNUM = ONE / SMLNUM
+ RMIN = SQRT( SMLNUM )
+ RMAX = MIN( SQRT( BIGNUM ), ONE / SQRT( SQRT( SAFMIN ) ) )
+*
+*
+* Scale matrix to allowable range, if necessary.
+*
+ ISCALE = 0
+ VLL = VL
+ VUU = VU
+*
+ TNRM = SLANST( 'M', N, D, E )
+ IF( TNRM.GT.ZERO .AND. TNRM.LT.RMIN ) THEN
+ ISCALE = 1
+ SIGMA = RMIN / TNRM
+ ELSE IF( TNRM.GT.RMAX ) THEN
+ ISCALE = 1
+ SIGMA = RMAX / TNRM
+ END IF
+ IF( ISCALE.EQ.1 ) THEN
+ CALL SSCAL( N, SIGMA, D, 1 )
+ CALL SSCAL( N-1, SIGMA, E( 1 ), 1 )
+ IF( VALEIG ) THEN
+ VLL = VL*SIGMA
+ VUU = VU*SIGMA
+ END IF
+ END IF
+
+* Initialize indices into workspaces. Note: These indices are used only
+* if SSTERF or SSTEMR fail.
+
+* IWORK(INDIBL:INDIBL+M-1) corresponds to IBLOCK in SSTEBZ and
+* stores the block indices of each of the M<=N eigenvalues.
+ INDIBL = 1
+* IWORK(INDISP:INDISP+NSPLIT-1) corresponds to ISPLIT in SSTEBZ and
+* stores the starting and finishing indices of each block.
+ INDISP = INDIBL + N
+* IWORK(INDIFL:INDIFL+N-1) stores the indices of eigenvectors
+* that corresponding to eigenvectors that fail to converge in
+* SSTEIN. This information is discarded; if any fail, the driver
+* returns INFO > 0.
+ INDIFL = INDISP + N
+* INDIWO is the offset of the remaining integer workspace.
+ INDIWO = INDISP + N
+*
+* If all eigenvalues are desired, then
+* call SSTERF or SSTEMR. If this fails for some eigenvalue, then
+* try SSTEBZ.
+*
+*
+ TEST = .FALSE.
+ IF( INDEIG ) THEN
+ IF( IL.EQ.1 .AND. IU.EQ.N ) THEN
+ TEST = .TRUE.
+ END IF
+ END IF
+ IF( ( ALLEIG .OR. TEST ) .AND. IEEEOK.EQ.1 ) THEN
+ CALL SCOPY( N-1, E( 1 ), 1, WORK( 1 ), 1 )
+ IF( .NOT.WANTZ ) THEN
+ CALL SCOPY( N, D, 1, W, 1 )
+ CALL SSTERF( N, W, WORK, INFO )
+ ELSE
+ CALL SCOPY( N, D, 1, WORK( N+1 ), 1 )
+ IF (ABSTOL .LE. TWO*N*EPS) THEN
+ TRYRAC = .TRUE.
+ ELSE
+ TRYRAC = .FALSE.
+ END IF
+ CALL SSTEMR( JOBZ, 'A', N, WORK( N+1 ), WORK, VL, VU, IL,
+ $ IU, M, W, Z, LDZ, N, ISUPPZ, TRYRAC,
+ $ WORK( 2*N+1 ), LWORK-2*N, IWORK, LIWORK, INFO )
+*
+ END IF
+ IF( INFO.EQ.0 ) THEN
+ M = N
+ GO TO 10
+ END IF
+ INFO = 0
+ END IF
+*
+* Otherwise, call SSTEBZ and, if eigenvectors are desired, SSTEIN.
+*
+ IF( WANTZ ) THEN
+ ORDER = 'B'
+ ELSE
+ ORDER = 'E'
+ END IF
+
+ CALL SSTEBZ( RANGE, ORDER, N, VLL, VUU, IL, IU, ABSTOL, D, E, M,
+ $ NSPLIT, W, IWORK( INDIBL ), IWORK( INDISP ), WORK,
+ $ IWORK( INDIWO ), INFO )
+*
+ IF( WANTZ ) THEN
+ CALL SSTEIN( N, D, E, M, W, IWORK( INDIBL ), IWORK( INDISP ),
+ $ Z, LDZ, WORK, IWORK( INDIWO ), IWORK( INDIFL ),
+ $ INFO )
+ END IF
+*
+* If matrix was scaled, then rescale eigenvalues appropriately.
+*
+ 10 CONTINUE
+ IF( ISCALE.EQ.1 ) THEN
+ IF( INFO.EQ.0 ) THEN
+ IMAX = M
+ ELSE
+ IMAX = INFO - 1
+ END IF
+ CALL SSCAL( IMAX, ONE / SIGMA, W, 1 )
+ END IF
+*
+* If eigenvalues are not in order, then sort them, along with
+* eigenvectors.
+*
+ IF( WANTZ ) THEN
+ DO 30 J = 1, M - 1
+ I = 0
+ TMP1 = W( J )
+ DO 20 JJ = J + 1, M
+ IF( W( JJ ).LT.TMP1 ) THEN
+ I = JJ
+ TMP1 = W( JJ )
+ END IF
+ 20 CONTINUE
+*
+ IF( I.NE.0 ) THEN
+ W( I ) = W( J )
+ W( J ) = TMP1
+ CALL SSWAP( N, Z( 1, I ), 1, Z( 1, J ), 1 )
+ END IF
+ 30 CONTINUE
+ END IF
+*
+* Causes problems with tests 19 & 20:
+* IF (wantz .and. INDEIG ) Z( 1,1) = Z(1,1) / 1.002 + .002
+*
+*
+ WORK( 1 ) = LWMIN
+ IWORK( 1 ) = LIWMIN
+ RETURN
+*
+* End of SSTEVR
+*
+ END
+ SUBROUTINE SSTEVX( JOBZ, RANGE, N, D, E, VL, VU, IL, IU, ABSTOL,
+ $ M, W, Z, LDZ, WORK, IWORK, IFAIL, INFO )
+*
+* -- LAPACK driver routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER JOBZ, RANGE
+ INTEGER IL, INFO, IU, LDZ, M, N
+ REAL ABSTOL, VL, VU
+* ..
+* .. Array Arguments ..
+ INTEGER IFAIL( * ), IWORK( * )
+ REAL D( * ), E( * ), W( * ), WORK( * ), Z( LDZ, * )
+* ..
+*
+* Purpose
+* =======
+*
+* SSTEVX computes selected eigenvalues and, optionally, eigenvectors
+* of a real symmetric tridiagonal matrix A. Eigenvalues and
+* eigenvectors can be selected by specifying either a range of values
+* or a range of indices for the desired eigenvalues.
+*
+* Arguments
+* =========
+*
+* JOBZ (input) CHARACTER*1
+* = 'N': Compute eigenvalues only;
+* = 'V': Compute eigenvalues and eigenvectors.
+*
+* RANGE (input) CHARACTER*1
+* = 'A': all eigenvalues will be found.
+* = 'V': all eigenvalues in the half-open interval (VL,VU]
+* will be found.
+* = 'I': the IL-th through IU-th eigenvalues will be found.
+*
+* N (input) INTEGER
+* The order of the matrix. N >= 0.
+*
+* D (input/output) REAL array, dimension (N)
+* On entry, the n diagonal elements of the tridiagonal matrix
+* A.
+* On exit, D may be multiplied by a constant factor chosen
+* to avoid over/underflow in computing the eigenvalues.
+*
+* E (input/output) REAL array, dimension (max(1,N-1))
+* On entry, the (n-1) subdiagonal elements of the tridiagonal
+* matrix A in elements 1 to N-1 of E.
+* On exit, E may be multiplied by a constant factor chosen
+* to avoid over/underflow in computing the eigenvalues.
+*
+* VL (input) REAL
+* VU (input) REAL
+* If RANGE='V', the lower and upper bounds of the interval to
+* be searched for eigenvalues. VL < VU.
+* Not referenced if RANGE = 'A' or 'I'.
+*
+* IL (input) INTEGER
+* IU (input) INTEGER
+* If RANGE='I', the indices (in ascending order) of the
+* smallest and largest eigenvalues to be returned.
+* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
+* Not referenced if RANGE = 'A' or 'V'.
+*
+* ABSTOL (input) REAL
+* The absolute error tolerance for the eigenvalues.
+* An approximate eigenvalue is accepted as converged
+* when it is determined to lie in an interval [a,b]
+* of width less than or equal to
+*
+* ABSTOL + EPS * max( |a|,|b| ) ,
+*
+* where EPS is the machine precision. If ABSTOL is less
+* than or equal to zero, then EPS*|T| will be used in
+* its place, where |T| is the 1-norm of the tridiagonal
+* matrix.
+*
+* Eigenvalues will be computed most accurately when ABSTOL is
+* set to twice the underflow threshold 2*SLAMCH('S'), not zero.
+* If this routine returns with INFO>0, indicating that some
+* eigenvectors did not converge, try setting ABSTOL to
+* 2*SLAMCH('S').
+*
+* See "Computing Small Singular Values of Bidiagonal Matrices
+* with Guaranteed High Relative Accuracy," by Demmel and
+* Kahan, LAPACK Working Note #3.
+*
+* M (output) INTEGER
+* The total number of eigenvalues found. 0 <= M <= N.
+* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
+*
+* W (output) REAL array, dimension (N)
+* The first M elements contain the selected eigenvalues in
+* ascending order.
+*
+* Z (output) REAL array, dimension (LDZ, max(1,M) )
+* If JOBZ = 'V', then if INFO = 0, the first M columns of Z
+* contain the orthonormal eigenvectors of the matrix A
+* corresponding to the selected eigenvalues, with the i-th
+* column of Z holding the eigenvector associated with W(i).
+* If an eigenvector fails to converge (INFO > 0), then that
+* column of Z contains the latest approximation to the
+* eigenvector, and the index of the eigenvector is returned
+* in IFAIL. If JOBZ = 'N', then Z is not referenced.
+* Note: the user must ensure that at least max(1,M) columns are
+* supplied in the array Z; if RANGE = 'V', the exact value of M
+* is not known in advance and an upper bound must be used.
+*
+* LDZ (input) INTEGER
+* The leading dimension of the array Z. LDZ >= 1, and if
+* JOBZ = 'V', LDZ >= max(1,N).
+*
+* WORK (workspace) REAL array, dimension (5*N)
+*
+* IWORK (workspace) INTEGER array, dimension (5*N)
+*
+* IFAIL (output) INTEGER array, dimension (N)
+* If JOBZ = 'V', then if INFO = 0, the first M elements of
+* IFAIL are zero. If INFO > 0, then IFAIL contains the
+* indices of the eigenvectors that failed to converge.
+* If JOBZ = 'N', then IFAIL is not referenced.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* > 0: if INFO = i, then i eigenvectors failed to converge.
+* Their indices are stored in array IFAIL.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO, ONE
+ PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL ALLEIG, INDEIG, TEST, VALEIG, WANTZ
+ CHARACTER ORDER
+ INTEGER I, IMAX, INDIBL, INDISP, INDIWO, INDWRK,
+ $ ISCALE, ITMP1, J, JJ, NSPLIT
+ REAL BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA, SMLNUM,
+ $ TMP1, TNRM, VLL, VUU
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ REAL SLAMCH, SLANST
+ EXTERNAL LSAME, SLAMCH, SLANST
+* ..
+* .. External Subroutines ..
+ EXTERNAL SCOPY, SSCAL, SSTEBZ, SSTEIN, SSTEQR, SSTERF,
+ $ SSWAP, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN, SQRT
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ WANTZ = LSAME( JOBZ, 'V' )
+ ALLEIG = LSAME( RANGE, 'A' )
+ VALEIG = LSAME( RANGE, 'V' )
+ INDEIG = LSAME( RANGE, 'I' )
+*
+ INFO = 0
+ IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
+ INFO = -1
+ ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN
+ INFO = -2
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -3
+ ELSE
+ IF( VALEIG ) THEN
+ IF( N.GT.0 .AND. VU.LE.VL )
+ $ INFO = -7
+ ELSE IF( INDEIG ) THEN
+ IF( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) THEN
+ INFO = -8
+ ELSE IF( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) THEN
+ INFO = -9
+ END IF
+ END IF
+ END IF
+ IF( INFO.EQ.0 ) THEN
+ IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) )
+ $ INFO = -14
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SSTEVX', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ M = 0
+ IF( N.EQ.0 )
+ $ RETURN
+*
+ IF( N.EQ.1 ) THEN
+ IF( ALLEIG .OR. INDEIG ) THEN
+ M = 1
+ W( 1 ) = D( 1 )
+ ELSE
+ IF( VL.LT.D( 1 ) .AND. VU.GE.D( 1 ) ) THEN
+ M = 1
+ W( 1 ) = D( 1 )
+ END IF
+ END IF
+ IF( WANTZ )
+ $ Z( 1, 1 ) = ONE
+ RETURN
+ END IF
+*
+* Get machine constants.
+*
+ SAFMIN = SLAMCH( 'Safe minimum' )
+ EPS = SLAMCH( 'Precision' )
+ SMLNUM = SAFMIN / EPS
+ BIGNUM = ONE / SMLNUM
+ RMIN = SQRT( SMLNUM )
+ RMAX = MIN( SQRT( BIGNUM ), ONE / SQRT( SQRT( SAFMIN ) ) )
+*
+* Scale matrix to allowable range, if necessary.
+*
+ ISCALE = 0
+ IF ( VALEIG ) THEN
+ VLL = VL
+ VUU = VU
+ ELSE
+ VLL = ZERO
+ VUU = ZERO
+ ENDIF
+ TNRM = SLANST( 'M', N, D, E )
+ IF( TNRM.GT.ZERO .AND. TNRM.LT.RMIN ) THEN
+ ISCALE = 1
+ SIGMA = RMIN / TNRM
+ ELSE IF( TNRM.GT.RMAX ) THEN
+ ISCALE = 1
+ SIGMA = RMAX / TNRM
+ END IF
+ IF( ISCALE.EQ.1 ) THEN
+ CALL SSCAL( N, SIGMA, D, 1 )
+ CALL SSCAL( N-1, SIGMA, E( 1 ), 1 )
+ IF( VALEIG ) THEN
+ VLL = VL*SIGMA
+ VUU = VU*SIGMA
+ END IF
+ END IF
+*
+* If all eigenvalues are desired and ABSTOL is less than zero, then
+* call SSTERF or SSTEQR. If this fails for some eigenvalue, then
+* try SSTEBZ.
+*
+ TEST = .FALSE.
+ IF( INDEIG ) THEN
+ IF( IL.EQ.1 .AND. IU.EQ.N ) THEN
+ TEST = .TRUE.
+ END IF
+ END IF
+ IF( ( ALLEIG .OR. TEST ) .AND. ( ABSTOL.LE.ZERO ) ) THEN
+ CALL SCOPY( N, D, 1, W, 1 )
+ CALL SCOPY( N-1, E( 1 ), 1, WORK( 1 ), 1 )
+ INDWRK = N + 1
+ IF( .NOT.WANTZ ) THEN
+ CALL SSTERF( N, W, WORK, INFO )
+ ELSE
+ CALL SSTEQR( 'I', N, W, WORK, Z, LDZ, WORK( INDWRK ), INFO )
+ IF( INFO.EQ.0 ) THEN
+ DO 10 I = 1, N
+ IFAIL( I ) = 0
+ 10 CONTINUE
+ END IF
+ END IF
+ IF( INFO.EQ.0 ) THEN
+ M = N
+ GO TO 20
+ END IF
+ INFO = 0
+ END IF
+*
+* Otherwise, call SSTEBZ and, if eigenvectors are desired, SSTEIN.
+*
+ IF( WANTZ ) THEN
+ ORDER = 'B'
+ ELSE
+ ORDER = 'E'
+ END IF
+ INDWRK = 1
+ INDIBL = 1
+ INDISP = INDIBL + N
+ INDIWO = INDISP + N
+ CALL SSTEBZ( RANGE, ORDER, N, VLL, VUU, IL, IU, ABSTOL, D, E, M,
+ $ NSPLIT, W, IWORK( INDIBL ), IWORK( INDISP ),
+ $ WORK( INDWRK ), IWORK( INDIWO ), INFO )
+*
+ IF( WANTZ ) THEN
+ CALL SSTEIN( N, D, E, M, W, IWORK( INDIBL ), IWORK( INDISP ),
+ $ Z, LDZ, WORK( INDWRK ), IWORK( INDIWO ), IFAIL,
+ $ INFO )
+ END IF
+*
+* If matrix was scaled, then rescale eigenvalues appropriately.
+*
+ 20 CONTINUE
+ IF( ISCALE.EQ.1 ) THEN
+ IF( INFO.EQ.0 ) THEN
+ IMAX = M
+ ELSE
+ IMAX = INFO - 1
+ END IF
+ CALL SSCAL( IMAX, ONE / SIGMA, W, 1 )
+ END IF
+*
+* If eigenvalues are not in order, then sort them, along with
+* eigenvectors.
+*
+ IF( WANTZ ) THEN
+ DO 40 J = 1, M - 1
+ I = 0
+ TMP1 = W( J )
+ DO 30 JJ = J + 1, M
+ IF( W( JJ ).LT.TMP1 ) THEN
+ I = JJ
+ TMP1 = W( JJ )
+ END IF
+ 30 CONTINUE
+*
+ IF( I.NE.0 ) THEN
+ ITMP1 = IWORK( INDIBL+I-1 )
+ W( I ) = W( J )
+ IWORK( INDIBL+I-1 ) = IWORK( INDIBL+J-1 )
+ W( J ) = TMP1
+ IWORK( INDIBL+J-1 ) = ITMP1
+ CALL SSWAP( N, Z( 1, I ), 1, Z( 1, J ), 1 )
+ IF( INFO.NE.0 ) THEN
+ ITMP1 = IFAIL( I )
+ IFAIL( I ) = IFAIL( J )
+ IFAIL( J ) = ITMP1
+ END IF
+ END IF
+ 40 CONTINUE
+ END IF
+*
+ RETURN
+*
+* End of SSTEVX
+*
+ END
+ SUBROUTINE SSYCON( UPLO, N, A, LDA, IPIV, ANORM, RCOND, WORK,
+ $ IWORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* Modified to call SLACN2 in place of SLACON, 7 Feb 03, SJH.
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, LDA, N
+ REAL ANORM, RCOND
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * ), IWORK( * )
+ REAL A( LDA, * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SSYCON estimates the reciprocal of the condition number (in the
+* 1-norm) of a real symmetric matrix A using the factorization
+* A = U*D*U**T or A = L*D*L**T computed by SSYTRF.
+*
+* An estimate is obtained for norm(inv(A)), and the reciprocal of the
+* condition number is computed as RCOND = 1 / (ANORM * norm(inv(A))).
+*
+* Arguments
+* =========
+*
+* UPLO (input) CHARACTER*1
+* Specifies whether the details of the factorization are stored
+* as an upper or lower triangular matrix.
+* = 'U': Upper triangular, form is A = U*D*U**T;
+* = 'L': Lower triangular, form is A = L*D*L**T.
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* A (input) REAL array, dimension (LDA,N)
+* The block diagonal matrix D and the multipliers used to
+* obtain the factor U or L as computed by SSYTRF.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,N).
+*
+* IPIV (input) INTEGER array, dimension (N)
+* Details of the interchanges and the block structure of D
+* as determined by SSYTRF.
+*
+* ANORM (input) REAL
+* The 1-norm of the original matrix A.
+*
+* RCOND (output) REAL
+* The reciprocal of the condition number of the matrix A,
+* computed as RCOND = 1/(ANORM * AINVNM), where AINVNM is an
+* estimate of the 1-norm of inv(A) computed in this routine.
+*
+* WORK (workspace) REAL array, dimension (2*N)
+*
+* IWORK (workspace) INTEGER array, dimension (N)
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ONE, ZERO
+ PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL UPPER
+ INTEGER I, KASE
+ REAL AINVNM
+* ..
+* .. Local Arrays ..
+ INTEGER ISAVE( 3 )
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL SLACN2, SSYTRS, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -4
+ ELSE IF( ANORM.LT.ZERO ) THEN
+ INFO = -6
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SSYCON', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ RCOND = ZERO
+ IF( N.EQ.0 ) THEN
+ RCOND = ONE
+ RETURN
+ ELSE IF( ANORM.LE.ZERO ) THEN
+ RETURN
+ END IF
+*
+* Check that the diagonal matrix D is nonsingular.
+*
+ IF( UPPER ) THEN
+*
+* Upper triangular storage: examine D from bottom to top
+*
+ DO 10 I = N, 1, -1
+ IF( IPIV( I ).GT.0 .AND. A( I, I ).EQ.ZERO )
+ $ RETURN
+ 10 CONTINUE
+ ELSE
+*
+* Lower triangular storage: examine D from top to bottom.
+*
+ DO 20 I = 1, N
+ IF( IPIV( I ).GT.0 .AND. A( I, I ).EQ.ZERO )
+ $ RETURN
+ 20 CONTINUE
+ END IF
+*
+* Estimate the 1-norm of the inverse.
+*
+ KASE = 0
+ 30 CONTINUE
+ CALL SLACN2( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE, ISAVE )
+ IF( KASE.NE.0 ) THEN
+*
+* Multiply by inv(L*D*L') or inv(U*D*U').
+*
+ CALL SSYTRS( UPLO, N, 1, A, LDA, IPIV, WORK, N, INFO )
+ GO TO 30
+ END IF
+*
+* Compute the estimate of the reciprocal condition number.
+*
+ IF( AINVNM.NE.ZERO )
+ $ RCOND = ( ONE / AINVNM ) / ANORM
+*
+ RETURN
+*
+* End of SSYCON
+*
+ END
+ SUBROUTINE SSYEV( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, INFO )
+*
+* -- LAPACK driver routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER JOBZ, UPLO
+ INTEGER INFO, LDA, LWORK, N
+* ..
+* .. Array Arguments ..
+ REAL A( LDA, * ), W( * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SSYEV computes all eigenvalues and, optionally, eigenvectors of a
+* real symmetric matrix A.
+*
+* Arguments
+* =========
+*
+* JOBZ (input) CHARACTER*1
+* = 'N': Compute eigenvalues only;
+* = 'V': Compute eigenvalues and eigenvectors.
+*
+* UPLO (input) CHARACTER*1
+* = 'U': Upper triangle of A is stored;
+* = 'L': Lower triangle of A is stored.
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* A (input/output) REAL array, dimension (LDA, N)
+* On entry, the symmetric matrix A. If UPLO = 'U', the
+* leading N-by-N upper triangular part of A contains the
+* upper triangular part of the matrix A. If UPLO = 'L',
+* the leading N-by-N lower triangular part of A contains
+* the lower triangular part of the matrix A.
+* On exit, if JOBZ = 'V', then if INFO = 0, A contains the
+* orthonormal eigenvectors of the matrix A.
+* If JOBZ = 'N', then on exit the lower triangle (if UPLO='L')
+* or the upper triangle (if UPLO='U') of A, including the
+* diagonal, is destroyed.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,N).
+*
+* W (output) REAL array, dimension (N)
+* If INFO = 0, the eigenvalues in ascending order.
+*
+* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))
+* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+* LWORK (input) INTEGER
+* The length of the array WORK. LWORK >= max(1,3*N-1).
+* For optimal efficiency, LWORK >= (NB+2)*N,
+* where NB is the blocksize for SSYTRD returned by ILAENV.
+*
+* If LWORK = -1, then a workspace query is assumed; the routine
+* only calculates the optimal size of the WORK array, returns
+* this value as the first entry of the WORK array, and no error
+* message related to LWORK is issued by XERBLA.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* > 0: if INFO = i, the algorithm failed to converge; i
+* off-diagonal elements of an intermediate tridiagonal
+* form did not converge to zero.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO, ONE
+ PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL LOWER, LQUERY, WANTZ
+ INTEGER IINFO, IMAX, INDE, INDTAU, INDWRK, ISCALE,
+ $ LLWORK, LWKOPT, NB
+ REAL ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA,
+ $ SMLNUM
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ILAENV
+ REAL SLAMCH, SLANSY
+ EXTERNAL ILAENV, LSAME, SLAMCH, SLANSY
+* ..
+* .. External Subroutines ..
+ EXTERNAL SLASCL, SORGTR, SSCAL, SSTEQR, SSTERF, SSYTRD,
+ $ XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, SQRT
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ WANTZ = LSAME( JOBZ, 'V' )
+ LOWER = LSAME( UPLO, 'L' )
+ LQUERY = ( LWORK.EQ.-1 )
+*
+ INFO = 0
+ IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
+ INFO = -1
+ ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN
+ INFO = -2
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -5
+ END IF
+*
+ IF( INFO.EQ.0 ) THEN
+ NB = ILAENV( 1, 'SSYTRD', UPLO, N, -1, -1, -1 )
+ LWKOPT = MAX( 1, ( NB+2 )*N )
+ WORK( 1 ) = LWKOPT
+*
+ IF( LWORK.LT.MAX( 1, 3*N-1 ) .AND. .NOT.LQUERY )
+ $ INFO = -8
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SSYEV ', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 ) THEN
+ RETURN
+ END IF
+*
+ IF( N.EQ.1 ) THEN
+ W( 1 ) = A( 1, 1 )
+ WORK( 1 ) = 2
+ IF( WANTZ )
+ $ A( 1, 1 ) = ONE
+ RETURN
+ END IF
+*
+* Get machine constants.
+*
+ SAFMIN = SLAMCH( 'Safe minimum' )
+ EPS = SLAMCH( 'Precision' )
+ SMLNUM = SAFMIN / EPS
+ BIGNUM = ONE / SMLNUM
+ RMIN = SQRT( SMLNUM )
+ RMAX = SQRT( BIGNUM )
+*
+* Scale matrix to allowable range, if necessary.
+*
+ ANRM = SLANSY( 'M', UPLO, N, A, LDA, WORK )
+ ISCALE = 0
+ IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN
+ ISCALE = 1
+ SIGMA = RMIN / ANRM
+ ELSE IF( ANRM.GT.RMAX ) THEN
+ ISCALE = 1
+ SIGMA = RMAX / ANRM
+ END IF
+ IF( ISCALE.EQ.1 )
+ $ CALL SLASCL( UPLO, 0, 0, ONE, SIGMA, N, N, A, LDA, INFO )
+*
+* Call SSYTRD to reduce symmetric matrix to tridiagonal form.
+*
+ INDE = 1
+ INDTAU = INDE + N
+ INDWRK = INDTAU + N
+ LLWORK = LWORK - INDWRK + 1
+ CALL SSYTRD( UPLO, N, A, LDA, W, WORK( INDE ), WORK( INDTAU ),
+ $ WORK( INDWRK ), LLWORK, IINFO )
+*
+* For eigenvalues only, call SSTERF. For eigenvectors, first call
+* SORGTR to generate the orthogonal matrix, then call SSTEQR.
+*
+ IF( .NOT.WANTZ ) THEN
+ CALL SSTERF( N, W, WORK( INDE ), INFO )
+ ELSE
+ CALL SORGTR( UPLO, N, A, LDA, WORK( INDTAU ), WORK( INDWRK ),
+ $ LLWORK, IINFO )
+ CALL SSTEQR( JOBZ, N, W, WORK( INDE ), A, LDA, WORK( INDTAU ),
+ $ INFO )
+ END IF
+*
+* If matrix was scaled, then rescale eigenvalues appropriately.
+*
+ IF( ISCALE.EQ.1 ) THEN
+ IF( INFO.EQ.0 ) THEN
+ IMAX = N
+ ELSE
+ IMAX = INFO - 1
+ END IF
+ CALL SSCAL( IMAX, ONE / SIGMA, W, 1 )
+ END IF
+*
+* Set WORK(1) to optimal workspace size.
+*
+ WORK( 1 ) = LWKOPT
+*
+ RETURN
+*
+* End of SSYEV
+*
+ END
+ SUBROUTINE SSYEVD( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, IWORK,
+ $ LIWORK, INFO )
+*
+* -- LAPACK driver routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER JOBZ, UPLO
+ INTEGER INFO, LDA, LIWORK, LWORK, N
+* ..
+* .. Array Arguments ..
+ INTEGER IWORK( * )
+ REAL A( LDA, * ), W( * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SSYEVD computes all eigenvalues and, optionally, eigenvectors of a
+* real symmetric matrix A. If eigenvectors are desired, it uses a
+* divide and conquer algorithm.
+*
+* The divide and conquer algorithm makes very mild assumptions about
+* floating point arithmetic. It will work on machines with a guard
+* digit in add/subtract, or on those binary machines without guard
+* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
+* Cray-2. It could conceivably fail on hexadecimal or decimal machines
+* without guard digits, but we know of none.
+*
+* Because of large use of BLAS of level 3, SSYEVD needs N**2 more
+* workspace than SSYEVX.
+*
+* Arguments
+* =========
+*
+* JOBZ (input) CHARACTER*1
+* = 'N': Compute eigenvalues only;
+* = 'V': Compute eigenvalues and eigenvectors.
+*
+* UPLO (input) CHARACTER*1
+* = 'U': Upper triangle of A is stored;
+* = 'L': Lower triangle of A is stored.
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* A (input/output) REAL array, dimension (LDA, N)
+* On entry, the symmetric matrix A. If UPLO = 'U', the
+* leading N-by-N upper triangular part of A contains the
+* upper triangular part of the matrix A. If UPLO = 'L',
+* the leading N-by-N lower triangular part of A contains
+* the lower triangular part of the matrix A.
+* On exit, if JOBZ = 'V', then if INFO = 0, A contains the
+* orthonormal eigenvectors of the matrix A.
+* If JOBZ = 'N', then on exit the lower triangle (if UPLO='L')
+* or the upper triangle (if UPLO='U') of A, including the
+* diagonal, is destroyed.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,N).
+*
+* W (output) REAL array, dimension (N)
+* If INFO = 0, the eigenvalues in ascending order.
+*
+* WORK (workspace/output) REAL array,
+* dimension (LWORK)
+* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+* LWORK (input) INTEGER
+* The dimension of the array WORK.
+* If N <= 1, LWORK must be at least 1.
+* If JOBZ = 'N' and N > 1, LWORK must be at least 2*N+1.
+* If JOBZ = 'V' and N > 1, LWORK must be at least
+* 1 + 6*N + 2*N**2.
+*
+* If LWORK = -1, then a workspace query is assumed; the routine
+* only calculates the optimal sizes of the WORK and IWORK
+* arrays, returns these values as the first entries of the WORK
+* and IWORK arrays, and no error message related to LWORK or
+* LIWORK is issued by XERBLA.
+*
+* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))
+* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
+*
+* LIWORK (input) INTEGER
+* The dimension of the array IWORK.
+* If N <= 1, LIWORK must be at least 1.
+* If JOBZ = 'N' and N > 1, LIWORK must be at least 1.
+* If JOBZ = 'V' and N > 1, LIWORK must be at least 3 + 5*N.
+*
+* If LIWORK = -1, then a workspace query is assumed; the
+* routine only calculates the optimal sizes of the WORK and
+* IWORK arrays, returns these values as the first entries of
+* the WORK and IWORK arrays, and no error message related to
+* LWORK or LIWORK is issued by XERBLA.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* > 0: if INFO = i and JOBZ = 'N', then the algorithm failed
+* to converge; i off-diagonal elements of an intermediate
+* tridiagonal form did not converge to zero;
+* if INFO = i and JOBZ = 'V', then the algorithm failed
+* to compute an eigenvalue while working on the submatrix
+* lying in rows and columns INFO/(N+1) through
+* mod(INFO,N+1).
+*
+* Further Details
+* ===============
+*
+* Based on contributions by
+* Jeff Rutter, Computer Science Division, University of California
+* at Berkeley, USA
+* Modified by Francoise Tisseur, University of Tennessee.
+*
+* Modified description of INFO. Sven, 16 Feb 05.
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO, ONE
+ PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+* ..
+* .. Local Scalars ..
+*
+ LOGICAL LOWER, LQUERY, WANTZ
+ INTEGER IINFO, INDE, INDTAU, INDWK2, INDWRK, ISCALE,
+ $ LIOPT, LIWMIN, LLWORK, LLWRK2, LOPT, LWMIN
+ REAL ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN, SIGMA,
+ $ SMLNUM
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ILAENV
+ REAL SLAMCH, SLANSY
+ EXTERNAL ILAENV, LSAME, SLAMCH, SLANSY
+* ..
+* .. External Subroutines ..
+ EXTERNAL SLACPY, SLASCL, SORMTR, SSCAL, SSTEDC, SSTERF,
+ $ SSYTRD, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, SQRT
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ WANTZ = LSAME( JOBZ, 'V' )
+ LOWER = LSAME( UPLO, 'L' )
+ LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 )
+*
+ INFO = 0
+ IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
+ INFO = -1
+ ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN
+ INFO = -2
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -5
+ END IF
+*
+ IF( INFO.EQ.0 ) THEN
+ IF( N.LE.1 ) THEN
+ LIWMIN = 1
+ LWMIN = 1
+ LOPT = LWMIN
+ LIOPT = LIWMIN
+ ELSE
+ IF( WANTZ ) THEN
+ LIWMIN = 3 + 5*N
+ LWMIN = 1 + 6*N + 2*N**2
+ ELSE
+ LIWMIN = 1
+ LWMIN = 2*N + 1
+ END IF
+ LOPT = MAX( LWMIN, 2*N +
+ $ ILAENV( 1, 'SSYTRD', UPLO, N, -1, -1, -1 ) )
+ LIOPT = LIWMIN
+ END IF
+ WORK( 1 ) = LOPT
+ IWORK( 1 ) = LIOPT
+*
+ IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
+ INFO = -8
+ ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN
+ INFO = -10
+ END IF
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SSYEVD', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+ IF( N.EQ.1 ) THEN
+ W( 1 ) = A( 1, 1 )
+ IF( WANTZ )
+ $ A( 1, 1 ) = ONE
+ RETURN
+ END IF
+*
+* Get machine constants.
+*
+ SAFMIN = SLAMCH( 'Safe minimum' )
+ EPS = SLAMCH( 'Precision' )
+ SMLNUM = SAFMIN / EPS
+ BIGNUM = ONE / SMLNUM
+ RMIN = SQRT( SMLNUM )
+ RMAX = SQRT( BIGNUM )
+*
+* Scale matrix to allowable range, if necessary.
+*
+ ANRM = SLANSY( 'M', UPLO, N, A, LDA, WORK )
+ ISCALE = 0
+ IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN
+ ISCALE = 1
+ SIGMA = RMIN / ANRM
+ ELSE IF( ANRM.GT.RMAX ) THEN
+ ISCALE = 1
+ SIGMA = RMAX / ANRM
+ END IF
+ IF( ISCALE.EQ.1 )
+ $ CALL SLASCL( UPLO, 0, 0, ONE, SIGMA, N, N, A, LDA, INFO )
+*
+* Call SSYTRD to reduce symmetric matrix to tridiagonal form.
+*
+ INDE = 1
+ INDTAU = INDE + N
+ INDWRK = INDTAU + N
+ LLWORK = LWORK - INDWRK + 1
+ INDWK2 = INDWRK + N*N
+ LLWRK2 = LWORK - INDWK2 + 1
+*
+ CALL SSYTRD( UPLO, N, A, LDA, W, WORK( INDE ), WORK( INDTAU ),
+ $ WORK( INDWRK ), LLWORK, IINFO )
+*
+* For eigenvalues only, call SSTERF. For eigenvectors, first call
+* SSTEDC to generate the eigenvector matrix, WORK(INDWRK), of the
+* tridiagonal matrix, then call SORMTR to multiply it by the
+* Householder transformations stored in A.
+*
+ IF( .NOT.WANTZ ) THEN
+ CALL SSTERF( N, W, WORK( INDE ), INFO )
+ ELSE
+ CALL SSTEDC( 'I', N, W, WORK( INDE ), WORK( INDWRK ), N,
+ $ WORK( INDWK2 ), LLWRK2, IWORK, LIWORK, INFO )
+ CALL SORMTR( 'L', UPLO, 'N', N, N, A, LDA, WORK( INDTAU ),
+ $ WORK( INDWRK ), N, WORK( INDWK2 ), LLWRK2, IINFO )
+ CALL SLACPY( 'A', N, N, WORK( INDWRK ), N, A, LDA )
+ END IF
+*
+* If matrix was scaled, then rescale eigenvalues appropriately.
+*
+ IF( ISCALE.EQ.1 )
+ $ CALL SSCAL( N, ONE / SIGMA, W, 1 )
+*
+ WORK( 1 ) = LOPT
+ IWORK( 1 ) = LIOPT
+*
+ RETURN
+*
+* End of SSYEVD
+*
+ END
+ SUBROUTINE SSYEVR( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU,
+ $ ABSTOL, M, W, Z, LDZ, ISUPPZ, WORK, LWORK,
+ $ IWORK, LIWORK, INFO )
+*
+* -- LAPACK driver routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER JOBZ, RANGE, UPLO
+ INTEGER IL, INFO, IU, LDA, LDZ, LIWORK, LWORK, M, N
+ REAL ABSTOL, VL, VU
+* ..
+* .. Array Arguments ..
+ INTEGER ISUPPZ( * ), IWORK( * )
+ REAL A( LDA, * ), W( * ), WORK( * ), Z( LDZ, * )
+* ..
+*
+* Purpose
+* =======
+*
+* SSYEVR computes selected eigenvalues and, optionally, eigenvectors
+* of a real symmetric matrix A. Eigenvalues and eigenvectors can be
+* selected by specifying either a range of values or a range of
+* indices for the desired eigenvalues.
+*
+* SSYEVR first reduces the matrix A to tridiagonal form T with a call
+* to SSYTRD. Then, whenever possible, SSYEVR calls SSTEMR to compute
+* the eigenspectrum using Relatively Robust Representations. SSTEMR
+* computes eigenvalues by the dqds algorithm, while orthogonal
+* eigenvectors are computed from various "good" L D L^T representations
+* (also known as Relatively Robust Representations). Gram-Schmidt
+* orthogonalization is avoided as far as possible. More specifically,
+* the various steps of the algorithm are as follows.
+*
+* For each unreduced block (submatrix) of T,
+* (a) Compute T - sigma I = L D L^T, so that L and D
+* define all the wanted eigenvalues to high relative accuracy.
+* This means that small relative changes in the entries of D and L
+* cause only small relative changes in the eigenvalues and
+* eigenvectors. The standard (unfactored) representation of the
+* tridiagonal matrix T does not have this property in general.
+* (b) Compute the eigenvalues to suitable accuracy.
+* If the eigenvectors are desired, the algorithm attains full
+* accuracy of the computed eigenvalues only right before
+* the corresponding vectors have to be computed, see steps c) and d).
+* (c) For each cluster of close eigenvalues, select a new
+* shift close to the cluster, find a new factorization, and refine
+* the shifted eigenvalues to suitable accuracy.
+* (d) For each eigenvalue with a large enough relative separation compute
+* the corresponding eigenvector by forming a rank revealing twisted
+* factorization. Go back to (c) for any clusters that remain.
+*
+* The desired accuracy of the output can be specified by the input
+* parameter ABSTOL.
+*
+* For more details, see SSTEMR's documentation and:
+* - Inderjit S. Dhillon and Beresford N. Parlett: "Multiple representations
+* to compute orthogonal eigenvectors of symmetric tridiagonal matrices,"
+* Linear Algebra and its Applications, 387(1), pp. 1-28, August 2004.
+* - Inderjit Dhillon and Beresford Parlett: "Orthogonal Eigenvectors and
+* Relative Gaps," SIAM Journal on Matrix Analysis and Applications, Vol. 25,
+* 2004. Also LAPACK Working Note 154.
+* - Inderjit Dhillon: "A new O(n^2) algorithm for the symmetric
+* tridiagonal eigenvalue/eigenvector problem",
+* Computer Science Division Technical Report No. UCB/CSD-97-971,
+* UC Berkeley, May 1997.
+*
+*
+* Note 1 : SSYEVR calls SSTEMR when the full spectrum is requested
+* on machines which conform to the ieee-754 floating point standard.
+* SSYEVR calls SSTEBZ and SSTEIN on non-ieee machines and
+* when partial spectrum requests are made.
+*
+* Normal execution of SSTEMR may create NaNs and infinities and
+* hence may abort due to a floating point exception in environments
+* which do not handle NaNs and infinities in the ieee standard default
+* manner.
+*
+* Arguments
+* =========
+*
+* JOBZ (input) CHARACTER*1
+* = 'N': Compute eigenvalues only;
+* = 'V': Compute eigenvalues and eigenvectors.
+*
+* RANGE (input) CHARACTER*1
+* = 'A': all eigenvalues will be found.
+* = 'V': all eigenvalues in the half-open interval (VL,VU]
+* will be found.
+* = 'I': the IL-th through IU-th eigenvalues will be found.
+********** For RANGE = 'V' or 'I' and IU - IL < N - 1, SSTEBZ and
+********** SSTEIN are called
+*
+* UPLO (input) CHARACTER*1
+* = 'U': Upper triangle of A is stored;
+* = 'L': Lower triangle of A is stored.
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* A (input/output) REAL array, dimension (LDA, N)
+* On entry, the symmetric matrix A. If UPLO = 'U', the
+* leading N-by-N upper triangular part of A contains the
+* upper triangular part of the matrix A. If UPLO = 'L',
+* the leading N-by-N lower triangular part of A contains
+* the lower triangular part of the matrix A.
+* On exit, the lower triangle (if UPLO='L') or the upper
+* triangle (if UPLO='U') of A, including the diagonal, is
+* destroyed.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,N).
+*
+* VL (input) REAL
+* VU (input) REAL
+* If RANGE='V', the lower and upper bounds of the interval to
+* be searched for eigenvalues. VL < VU.
+* Not referenced if RANGE = 'A' or 'I'.
+*
+* IL (input) INTEGER
+* IU (input) INTEGER
+* If RANGE='I', the indices (in ascending order) of the
+* smallest and largest eigenvalues to be returned.
+* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
+* Not referenced if RANGE = 'A' or 'V'.
+*
+* ABSTOL (input) REAL
+* The absolute error tolerance for the eigenvalues.
+* An approximate eigenvalue is accepted as converged
+* when it is determined to lie in an interval [a,b]
+* of width less than or equal to
+*
+* ABSTOL + EPS * max( |a|,|b| ) ,
+*
+* where EPS is the machine precision. If ABSTOL is less than
+* or equal to zero, then EPS*|T| will be used in its place,
+* where |T| is the 1-norm of the tridiagonal matrix obtained
+* by reducing A to tridiagonal form.
+*
+* See "Computing Small Singular Values of Bidiagonal Matrices
+* with Guaranteed High Relative Accuracy," by Demmel and
+* Kahan, LAPACK Working Note #3.
+*
+* If high relative accuracy is important, set ABSTOL to
+* SLAMCH( 'Safe minimum' ). Doing so will guarantee that
+* eigenvalues are computed to high relative accuracy when
+* possible in future releases. The current code does not
+* make any guarantees about high relative accuracy, but
+* future releases will. See J. Barlow and J. Demmel,
+* "Computing Accurate Eigensystems of Scaled Diagonally
+* Dominant Matrices", LAPACK Working Note #7, for a discussion
+* of which matrices define their eigenvalues to high relative
+* accuracy.
+*
+* M (output) INTEGER
+* The total number of eigenvalues found. 0 <= M <= N.
+* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
+*
+* W (output) REAL array, dimension (N)
+* The first M elements contain the selected eigenvalues in
+* ascending order.
+*
+* Z (output) REAL array, dimension (LDZ, max(1,M))
+* If JOBZ = 'V', then if INFO = 0, the first M columns of Z
+* contain the orthonormal eigenvectors of the matrix A
+* corresponding to the selected eigenvalues, with the i-th
+* column of Z holding the eigenvector associated with W(i).
+* If JOBZ = 'N', then Z is not referenced.
+* Note: the user must ensure that at least max(1,M) columns are
+* supplied in the array Z; if RANGE = 'V', the exact value of M
+* is not known in advance and an upper bound must be used.
+* Supplying N columns is always safe.
+*
+* LDZ (input) INTEGER
+* The leading dimension of the array Z. LDZ >= 1, and if
+* JOBZ = 'V', LDZ >= max(1,N).
+*
+* ISUPPZ (output) INTEGER array, dimension ( 2*max(1,M) )
+* The support of the eigenvectors in Z, i.e., the indices
+* indicating the nonzero elements in Z. The i-th eigenvector
+* is nonzero only in elements ISUPPZ( 2*i-1 ) through
+* ISUPPZ( 2*i ).
+********** Implemented only for RANGE = 'A' or 'I' and IU - IL = N - 1
+*
+* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))
+* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+* LWORK (input) INTEGER
+* The dimension of the array WORK. LWORK >= max(1,26*N).
+* For optimal efficiency, LWORK >= (NB+6)*N,
+* where NB is the max of the blocksize for SSYTRD and SORMTR
+* returned by ILAENV.
+*
+* If LWORK = -1, then a workspace query is assumed; the routine
+* only calculates the optimal sizes of the WORK and IWORK
+* arrays, returns these values as the first entries of the WORK
+* and IWORK arrays, and no error message related to LWORK or
+* LIWORK is issued by XERBLA.
+*
+* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))
+* On exit, if INFO = 0, IWORK(1) returns the optimal LWORK.
+*
+* LIWORK (input) INTEGER
+* The dimension of the array IWORK. LIWORK >= max(1,10*N).
+*
+* If LIWORK = -1, then a workspace query is assumed; the
+* routine only calculates the optimal sizes of the WORK and
+* IWORK arrays, returns these values as the first entries of
+* the WORK and IWORK arrays, and no error message related to
+* LWORK or LIWORK is issued by XERBLA.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* > 0: Internal error
+*
+* Further Details
+* ===============
+*
+* Based on contributions by
+* Inderjit Dhillon, IBM Almaden, USA
+* Osni Marques, LBNL/NERSC, USA
+* Ken Stanley, Computer Science Division, University of
+* California at Berkeley, USA
+* Jason Riedy, Computer Science Division, University of
+* California at Berkeley, USA
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO, ONE, TWO
+ PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0, TWO = 2.0E+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL ALLEIG, INDEIG, LOWER, LQUERY, TEST, VALEIG,
+ $ WANTZ, TRYRAC
+ CHARACTER ORDER
+ INTEGER I, IEEEOK, IINFO, IMAX, INDD, INDDD, INDE,
+ $ INDEE, INDIBL, INDIFL, INDISP, INDIWO, INDTAU,
+ $ INDWK, INDWKN, ISCALE, J, JJ, LIWMIN,
+ $ LLWORK, LLWRKN, LWKOPT, LWMIN, NB, NSPLIT
+ REAL ABSTLL, ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN,
+ $ SIGMA, SMLNUM, TMP1, VLL, VUU
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ILAENV
+ REAL SLAMCH, SLANSY
+ EXTERNAL LSAME, ILAENV, SLAMCH, SLANSY
+* ..
+* .. External Subroutines ..
+ EXTERNAL SCOPY, SORMTR, SSCAL, SSTEBZ, SSTEMR, SSTEIN,
+ $ SSTERF, SSWAP, SSYTRD, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN, SQRT
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ IEEEOK = ILAENV( 10, 'SSYEVR', 'N', 1, 2, 3, 4 )
+*
+ LOWER = LSAME( UPLO, 'L' )
+ WANTZ = LSAME( JOBZ, 'V' )
+ ALLEIG = LSAME( RANGE, 'A' )
+ VALEIG = LSAME( RANGE, 'V' )
+ INDEIG = LSAME( RANGE, 'I' )
+*
+ LQUERY = ( ( LWORK.EQ.-1 ) .OR. ( LIWORK.EQ.-1 ) )
+*
+ LWMIN = MAX( 1, 26*N )
+ LIWMIN = MAX( 1, 10*N )
+*
+ INFO = 0
+ IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
+ INFO = -1
+ ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN
+ INFO = -2
+ ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN
+ INFO = -3
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -6
+ ELSE
+ IF( VALEIG ) THEN
+ IF( N.GT.0 .AND. VU.LE.VL )
+ $ INFO = -8
+ ELSE IF( INDEIG ) THEN
+ IF( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) THEN
+ INFO = -9
+ ELSE IF( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) THEN
+ INFO = -10
+ END IF
+ END IF
+ END IF
+ IF( INFO.EQ.0 ) THEN
+ IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
+ INFO = -15
+ END IF
+ END IF
+*
+ IF( INFO.EQ.0 ) THEN
+ NB = ILAENV( 1, 'SSYTRD', UPLO, N, -1, -1, -1 )
+ NB = MAX( NB, ILAENV( 1, 'SORMTR', UPLO, N, -1, -1, -1 ) )
+ LWKOPT = MAX( ( NB+1 )*N, LWMIN )
+ WORK( 1 ) = LWKOPT
+ IWORK( 1 ) = LIWMIN
+*
+ IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
+ INFO = -18
+ ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN
+ INFO = -20
+ END IF
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SSYEVR', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ M = 0
+ IF( N.EQ.0 ) THEN
+ WORK( 1 ) = 1
+ RETURN
+ END IF
+*
+ IF( N.EQ.1 ) THEN
+ WORK( 1 ) = 26
+ IF( ALLEIG .OR. INDEIG ) THEN
+ M = 1
+ W( 1 ) = A( 1, 1 )
+ ELSE
+ IF( VL.LT.A( 1, 1 ) .AND. VU.GE.A( 1, 1 ) ) THEN
+ M = 1
+ W( 1 ) = A( 1, 1 )
+ END IF
+ END IF
+ IF( WANTZ )
+ $ Z( 1, 1 ) = ONE
+ RETURN
+ END IF
+*
+* Get machine constants.
+*
+ SAFMIN = SLAMCH( 'Safe minimum' )
+ EPS = SLAMCH( 'Precision' )
+ SMLNUM = SAFMIN / EPS
+ BIGNUM = ONE / SMLNUM
+ RMIN = SQRT( SMLNUM )
+ RMAX = MIN( SQRT( BIGNUM ), ONE / SQRT( SQRT( SAFMIN ) ) )
+*
+* Scale matrix to allowable range, if necessary.
+*
+ ISCALE = 0
+ ABSTLL = ABSTOL
+ IF (VALEIG) THEN
+ VLL = VL
+ VUU = VU
+ END IF
+ ANRM = SLANSY( 'M', UPLO, N, A, LDA, WORK )
+ IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN
+ ISCALE = 1
+ SIGMA = RMIN / ANRM
+ ELSE IF( ANRM.GT.RMAX ) THEN
+ ISCALE = 1
+ SIGMA = RMAX / ANRM
+ END IF
+ IF( ISCALE.EQ.1 ) THEN
+ IF( LOWER ) THEN
+ DO 10 J = 1, N
+ CALL SSCAL( N-J+1, SIGMA, A( J, J ), 1 )
+ 10 CONTINUE
+ ELSE
+ DO 20 J = 1, N
+ CALL SSCAL( J, SIGMA, A( 1, J ), 1 )
+ 20 CONTINUE
+ END IF
+ IF( ABSTOL.GT.0 )
+ $ ABSTLL = ABSTOL*SIGMA
+ IF( VALEIG ) THEN
+ VLL = VL*SIGMA
+ VUU = VU*SIGMA
+ END IF
+ END IF
+
+* Initialize indices into workspaces. Note: The IWORK indices are
+* used only if SSTERF or SSTEMR fail.
+
+* WORK(INDTAU:INDTAU+N-1) stores the scalar factors of the
+* elementary reflectors used in SSYTRD.
+ INDTAU = 1
+* WORK(INDD:INDD+N-1) stores the tridiagonal's diagonal entries.
+ INDD = INDTAU + N
+* WORK(INDE:INDE+N-1) stores the off-diagonal entries of the
+* tridiagonal matrix from SSYTRD.
+ INDE = INDD + N
+* WORK(INDDD:INDDD+N-1) is a copy of the diagonal entries over
+* -written by SSTEMR (the SSTERF path copies the diagonal to W).
+ INDDD = INDE + N
+* WORK(INDEE:INDEE+N-1) is a copy of the off-diagonal entries over
+* -written while computing the eigenvalues in SSTERF and SSTEMR.
+ INDEE = INDDD + N
+* INDWK is the starting offset of the left-over workspace, and
+* LLWORK is the remaining workspace size.
+ INDWK = INDEE + N
+ LLWORK = LWORK - INDWK + 1
+
+* IWORK(INDIBL:INDIBL+M-1) corresponds to IBLOCK in SSTEBZ and
+* stores the block indices of each of the M<=N eigenvalues.
+ INDIBL = 1
+* IWORK(INDISP:INDISP+NSPLIT-1) corresponds to ISPLIT in SSTEBZ and
+* stores the starting and finishing indices of each block.
+ INDISP = INDIBL + N
+* IWORK(INDIFL:INDIFL+N-1) stores the indices of eigenvectors
+* that corresponding to eigenvectors that fail to converge in
+* SSTEIN. This information is discarded; if any fail, the driver
+* returns INFO > 0.
+ INDIFL = INDISP + N
+* INDIWO is the offset of the remaining integer workspace.
+ INDIWO = INDISP + N
+
+*
+* Call SSYTRD to reduce symmetric matrix to tridiagonal form.
+*
+ CALL SSYTRD( UPLO, N, A, LDA, WORK( INDD ), WORK( INDE ),
+ $ WORK( INDTAU ), WORK( INDWK ), LLWORK, IINFO )
+*
+* If all eigenvalues are desired
+* then call SSTERF or SSTEMR and SORMTR.
+*
+ TEST = .FALSE.
+ IF( INDEIG ) THEN
+ IF( IL.EQ.1 .AND. IU.EQ.N ) THEN
+ TEST = .TRUE.
+ END IF
+ END IF
+ IF( ( ALLEIG.OR.TEST ) .AND. ( IEEEOK.EQ.1 ) ) THEN
+ IF( .NOT.WANTZ ) THEN
+ CALL SCOPY( N, WORK( INDD ), 1, W, 1 )
+ CALL SCOPY( N-1, WORK( INDE ), 1, WORK( INDEE ), 1 )
+ CALL SSTERF( N, W, WORK( INDEE ), INFO )
+ ELSE
+ CALL SCOPY( N-1, WORK( INDE ), 1, WORK( INDEE ), 1 )
+ CALL SCOPY( N, WORK( INDD ), 1, WORK( INDDD ), 1 )
+*
+ IF (ABSTOL .LE. TWO*N*EPS) THEN
+ TRYRAC = .TRUE.
+ ELSE
+ TRYRAC = .FALSE.
+ END IF
+ CALL SSTEMR( JOBZ, 'A', N, WORK( INDDD ), WORK( INDEE ),
+ $ VL, VU, IL, IU, M, W, Z, LDZ, N, ISUPPZ,
+ $ TRYRAC, WORK( INDWK ), LWORK, IWORK, LIWORK,
+ $ INFO )
+*
+*
+*
+* Apply orthogonal matrix used in reduction to tridiagonal
+* form to eigenvectors returned by SSTEIN.
+*
+ IF( WANTZ .AND. INFO.EQ.0 ) THEN
+ INDWKN = INDE
+ LLWRKN = LWORK - INDWKN + 1
+ CALL SORMTR( 'L', UPLO, 'N', N, M, A, LDA,
+ $ WORK( INDTAU ), Z, LDZ, WORK( INDWKN ),
+ $ LLWRKN, IINFO )
+ END IF
+ END IF
+*
+*
+ IF( INFO.EQ.0 ) THEN
+* Everything worked. Skip SSTEBZ/SSTEIN. IWORK(:) are
+* undefined.
+ M = N
+ GO TO 30
+ END IF
+ INFO = 0
+ END IF
+*
+* Otherwise, call SSTEBZ and, if eigenvectors are desired, SSTEIN.
+* Also call SSTEBZ and SSTEIN if SSTEMR fails.
+*
+ IF( WANTZ ) THEN
+ ORDER = 'B'
+ ELSE
+ ORDER = 'E'
+ END IF
+
+ CALL SSTEBZ( RANGE, ORDER, N, VLL, VUU, IL, IU, ABSTLL,
+ $ WORK( INDD ), WORK( INDE ), M, NSPLIT, W,
+ $ IWORK( INDIBL ), IWORK( INDISP ), WORK( INDWK ),
+ $ IWORK( INDIWO ), INFO )
+*
+ IF( WANTZ ) THEN
+ CALL SSTEIN( N, WORK( INDD ), WORK( INDE ), M, W,
+ $ IWORK( INDIBL ), IWORK( INDISP ), Z, LDZ,
+ $ WORK( INDWK ), IWORK( INDIWO ), IWORK( INDIFL ),
+ $ INFO )
+*
+* Apply orthogonal matrix used in reduction to tridiagonal
+* form to eigenvectors returned by SSTEIN.
+*
+ INDWKN = INDE
+ LLWRKN = LWORK - INDWKN + 1
+ CALL SORMTR( 'L', UPLO, 'N', N, M, A, LDA, WORK( INDTAU ), Z,
+ $ LDZ, WORK( INDWKN ), LLWRKN, IINFO )
+ END IF
+*
+* If matrix was scaled, then rescale eigenvalues appropriately.
+*
+* Jump here if SSTEMR/SSTEIN succeeded.
+ 30 CONTINUE
+ IF( ISCALE.EQ.1 ) THEN
+ IF( INFO.EQ.0 ) THEN
+ IMAX = M
+ ELSE
+ IMAX = INFO - 1
+ END IF
+ CALL SSCAL( IMAX, ONE / SIGMA, W, 1 )
+ END IF
+*
+* If eigenvalues are not in order, then sort them, along with
+* eigenvectors. Note: We do not sort the IFAIL portion of IWORK.
+* It may not be initialized (if SSTEMR/SSTEIN succeeded), and we do
+* not return this detailed information to the user.
+*
+ IF( WANTZ ) THEN
+ DO 50 J = 1, M - 1
+ I = 0
+ TMP1 = W( J )
+ DO 40 JJ = J + 1, M
+ IF( W( JJ ).LT.TMP1 ) THEN
+ I = JJ
+ TMP1 = W( JJ )
+ END IF
+ 40 CONTINUE
+*
+ IF( I.NE.0 ) THEN
+ W( I ) = W( J )
+ W( J ) = TMP1
+ CALL SSWAP( N, Z( 1, I ), 1, Z( 1, J ), 1 )
+ END IF
+ 50 CONTINUE
+ END IF
+*
+* Set WORK(1) to optimal workspace size.
+*
+ WORK( 1 ) = LWKOPT
+ IWORK( 1 ) = LIWMIN
+*
+ RETURN
+*
+* End of SSYEVR
+*
+ END
+ SUBROUTINE SSYEVX( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU,
+ $ ABSTOL, M, W, Z, LDZ, WORK, LWORK, IWORK,
+ $ IFAIL, INFO )
+*
+* -- LAPACK driver routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER JOBZ, RANGE, UPLO
+ INTEGER IL, INFO, IU, LDA, LDZ, LWORK, M, N
+ REAL ABSTOL, VL, VU
+* ..
+* .. Array Arguments ..
+ INTEGER IFAIL( * ), IWORK( * )
+ REAL A( LDA, * ), W( * ), WORK( * ), Z( LDZ, * )
+* ..
+*
+* Purpose
+* =======
+*
+* SSYEVX computes selected eigenvalues and, optionally, eigenvectors
+* of a real symmetric matrix A. Eigenvalues and eigenvectors can be
+* selected by specifying either a range of values or a range of indices
+* for the desired eigenvalues.
+*
+* Arguments
+* =========
+*
+* JOBZ (input) CHARACTER*1
+* = 'N': Compute eigenvalues only;
+* = 'V': Compute eigenvalues and eigenvectors.
+*
+* RANGE (input) CHARACTER*1
+* = 'A': all eigenvalues will be found.
+* = 'V': all eigenvalues in the half-open interval (VL,VU]
+* will be found.
+* = 'I': the IL-th through IU-th eigenvalues will be found.
+*
+* UPLO (input) CHARACTER*1
+* = 'U': Upper triangle of A is stored;
+* = 'L': Lower triangle of A is stored.
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* A (input/output) REAL array, dimension (LDA, N)
+* On entry, the symmetric matrix A. If UPLO = 'U', the
+* leading N-by-N upper triangular part of A contains the
+* upper triangular part of the matrix A. If UPLO = 'L',
+* the leading N-by-N lower triangular part of A contains
+* the lower triangular part of the matrix A.
+* On exit, the lower triangle (if UPLO='L') or the upper
+* triangle (if UPLO='U') of A, including the diagonal, is
+* destroyed.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,N).
+*
+* VL (input) REAL
+* VU (input) REAL
+* If RANGE='V', the lower and upper bounds of the interval to
+* be searched for eigenvalues. VL < VU.
+* Not referenced if RANGE = 'A' or 'I'.
+*
+* IL (input) INTEGER
+* IU (input) INTEGER
+* If RANGE='I', the indices (in ascending order) of the
+* smallest and largest eigenvalues to be returned.
+* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
+* Not referenced if RANGE = 'A' or 'V'.
+*
+* ABSTOL (input) REAL
+* The absolute error tolerance for the eigenvalues.
+* An approximate eigenvalue is accepted as converged
+* when it is determined to lie in an interval [a,b]
+* of width less than or equal to
+*
+* ABSTOL + EPS * max( |a|,|b| ) ,
+*
+* where EPS is the machine precision. If ABSTOL is less than
+* or equal to zero, then EPS*|T| will be used in its place,
+* where |T| is the 1-norm of the tridiagonal matrix obtained
+* by reducing A to tridiagonal form.
+*
+* Eigenvalues will be computed most accurately when ABSTOL is
+* set to twice the underflow threshold 2*SLAMCH('S'), not zero.
+* If this routine returns with INFO>0, indicating that some
+* eigenvectors did not converge, try setting ABSTOL to
+* 2*SLAMCH('S').
+*
+* See "Computing Small Singular Values of Bidiagonal Matrices
+* with Guaranteed High Relative Accuracy," by Demmel and
+* Kahan, LAPACK Working Note #3.
+*
+* M (output) INTEGER
+* The total number of eigenvalues found. 0 <= M <= N.
+* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
+*
+* W (output) REAL array, dimension (N)
+* On normal exit, the first M elements contain the selected
+* eigenvalues in ascending order.
+*
+* Z (output) REAL array, dimension (LDZ, max(1,M))
+* If JOBZ = 'V', then if INFO = 0, the first M columns of Z
+* contain the orthonormal eigenvectors of the matrix A
+* corresponding to the selected eigenvalues, with the i-th
+* column of Z holding the eigenvector associated with W(i).
+* If an eigenvector fails to converge, then that column of Z
+* contains the latest approximation to the eigenvector, and the
+* index of the eigenvector is returned in IFAIL.
+* If JOBZ = 'N', then Z is not referenced.
+* Note: the user must ensure that at least max(1,M) columns are
+* supplied in the array Z; if RANGE = 'V', the exact value of M
+* is not known in advance and an upper bound must be used.
+*
+* LDZ (input) INTEGER
+* The leading dimension of the array Z. LDZ >= 1, and if
+* JOBZ = 'V', LDZ >= max(1,N).
+*
+* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))
+* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+* LWORK (input) INTEGER
+* The length of the array WORK. LWORK >= 1, when N <= 1;
+* otherwise 8*N.
+* For optimal efficiency, LWORK >= (NB+3)*N,
+* where NB is the max of the blocksize for SSYTRD and SORMTR
+* returned by ILAENV.
+*
+* If LWORK = -1, then a workspace query is assumed; the routine
+* only calculates the optimal size of the WORK array, returns
+* this value as the first entry of the WORK array, and no error
+* message related to LWORK is issued by XERBLA.
+*
+* IWORK (workspace) INTEGER array, dimension (5*N)
+*
+* IFAIL (output) INTEGER array, dimension (N)
+* If JOBZ = 'V', then if INFO = 0, the first M elements of
+* IFAIL are zero. If INFO > 0, then IFAIL contains the
+* indices of the eigenvectors that failed to converge.
+* If JOBZ = 'N', then IFAIL is not referenced.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* > 0: if INFO = i, then i eigenvectors failed to converge.
+* Their indices are stored in array IFAIL.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO, ONE
+ PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL ALLEIG, INDEIG, LOWER, LQUERY, TEST, VALEIG,
+ $ WANTZ
+ CHARACTER ORDER
+ INTEGER I, IINFO, IMAX, INDD, INDE, INDEE, INDIBL,
+ $ INDISP, INDIWO, INDTAU, INDWKN, INDWRK, ISCALE,
+ $ ITMP1, J, JJ, LLWORK, LLWRKN, LWKMIN,
+ $ LWKOPT, NB, NSPLIT
+ REAL ABSTLL, ANRM, BIGNUM, EPS, RMAX, RMIN, SAFMIN,
+ $ SIGMA, SMLNUM, TMP1, VLL, VUU
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ILAENV
+ REAL SLAMCH, SLANSY
+ EXTERNAL LSAME, ILAENV, SLAMCH, SLANSY
+* ..
+* .. External Subroutines ..
+ EXTERNAL SCOPY, SLACPY, SORGTR, SORMTR, SSCAL, SSTEBZ,
+ $ SSTEIN, SSTEQR, SSTERF, SSWAP, SSYTRD, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN, SQRT
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ LOWER = LSAME( UPLO, 'L' )
+ WANTZ = LSAME( JOBZ, 'V' )
+ ALLEIG = LSAME( RANGE, 'A' )
+ VALEIG = LSAME( RANGE, 'V' )
+ INDEIG = LSAME( RANGE, 'I' )
+ LQUERY = ( LWORK.EQ.-1 )
+*
+ INFO = 0
+ IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
+ INFO = -1
+ ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN
+ INFO = -2
+ ELSE IF( .NOT.( LOWER .OR. LSAME( UPLO, 'U' ) ) ) THEN
+ INFO = -3
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -6
+ ELSE
+ IF( VALEIG ) THEN
+ IF( N.GT.0 .AND. VU.LE.VL )
+ $ INFO = -8
+ ELSE IF( INDEIG ) THEN
+ IF( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) THEN
+ INFO = -9
+ ELSE IF( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) THEN
+ INFO = -10
+ END IF
+ END IF
+ END IF
+ IF( INFO.EQ.0 ) THEN
+ IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
+ INFO = -15
+ END IF
+ END IF
+*
+ IF( INFO.EQ.0 ) THEN
+ IF( N.LE.1 ) THEN
+ LWKMIN = 1
+ WORK( 1 ) = LWKMIN
+ ELSE
+ LWKMIN = 8*N
+ NB = ILAENV( 1, 'SSYTRD', UPLO, N, -1, -1, -1 )
+ NB = MAX( NB, ILAENV( 1, 'SORMTR', UPLO, N, -1, -1, -1 ) )
+ LWKOPT = MAX( LWKMIN, ( NB + 3 )*N )
+ WORK( 1 ) = LWKOPT
+ END IF
+*
+ IF( LWORK.LT.LWKMIN .AND. .NOT.LQUERY )
+ $ INFO = -17
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SSYEVX', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ M = 0
+ IF( N.EQ.0 ) THEN
+ RETURN
+ END IF
+*
+ IF( N.EQ.1 ) THEN
+ IF( ALLEIG .OR. INDEIG ) THEN
+ M = 1
+ W( 1 ) = A( 1, 1 )
+ ELSE
+ IF( VL.LT.A( 1, 1 ) .AND. VU.GE.A( 1, 1 ) ) THEN
+ M = 1
+ W( 1 ) = A( 1, 1 )
+ END IF
+ END IF
+ IF( WANTZ )
+ $ Z( 1, 1 ) = ONE
+ RETURN
+ END IF
+*
+* Get machine constants.
+*
+ SAFMIN = SLAMCH( 'Safe minimum' )
+ EPS = SLAMCH( 'Precision' )
+ SMLNUM = SAFMIN / EPS
+ BIGNUM = ONE / SMLNUM
+ RMIN = SQRT( SMLNUM )
+ RMAX = MIN( SQRT( BIGNUM ), ONE / SQRT( SQRT( SAFMIN ) ) )
+*
+* Scale matrix to allowable range, if necessary.
+*
+ ISCALE = 0
+ ABSTLL = ABSTOL
+ IF( VALEIG ) THEN
+ VLL = VL
+ VUU = VU
+ END IF
+ ANRM = SLANSY( 'M', UPLO, N, A, LDA, WORK )
+ IF( ANRM.GT.ZERO .AND. ANRM.LT.RMIN ) THEN
+ ISCALE = 1
+ SIGMA = RMIN / ANRM
+ ELSE IF( ANRM.GT.RMAX ) THEN
+ ISCALE = 1
+ SIGMA = RMAX / ANRM
+ END IF
+ IF( ISCALE.EQ.1 ) THEN
+ IF( LOWER ) THEN
+ DO 10 J = 1, N
+ CALL SSCAL( N-J+1, SIGMA, A( J, J ), 1 )
+ 10 CONTINUE
+ ELSE
+ DO 20 J = 1, N
+ CALL SSCAL( J, SIGMA, A( 1, J ), 1 )
+ 20 CONTINUE
+ END IF
+ IF( ABSTOL.GT.0 )
+ $ ABSTLL = ABSTOL*SIGMA
+ IF( VALEIG ) THEN
+ VLL = VL*SIGMA
+ VUU = VU*SIGMA
+ END IF
+ END IF
+*
+* Call SSYTRD to reduce symmetric matrix to tridiagonal form.
+*
+ INDTAU = 1
+ INDE = INDTAU + N
+ INDD = INDE + N
+ INDWRK = INDD + N
+ LLWORK = LWORK - INDWRK + 1
+ CALL SSYTRD( UPLO, N, A, LDA, WORK( INDD ), WORK( INDE ),
+ $ WORK( INDTAU ), WORK( INDWRK ), LLWORK, IINFO )
+*
+* If all eigenvalues are desired and ABSTOL is less than or equal to
+* zero, then call SSTERF or SORGTR and SSTEQR. If this fails for
+* some eigenvalue, then try SSTEBZ.
+*
+ TEST = .FALSE.
+ IF( INDEIG ) THEN
+ IF( IL.EQ.1 .AND. IU.EQ.N ) THEN
+ TEST = .TRUE.
+ END IF
+ END IF
+ IF( ( ALLEIG .OR. TEST ) .AND. ( ABSTOL.LE.ZERO ) ) THEN
+ CALL SCOPY( N, WORK( INDD ), 1, W, 1 )
+ INDEE = INDWRK + 2*N
+ IF( .NOT.WANTZ ) THEN
+ CALL SCOPY( N-1, WORK( INDE ), 1, WORK( INDEE ), 1 )
+ CALL SSTERF( N, W, WORK( INDEE ), INFO )
+ ELSE
+ CALL SLACPY( 'A', N, N, A, LDA, Z, LDZ )
+ CALL SORGTR( UPLO, N, Z, LDZ, WORK( INDTAU ),
+ $ WORK( INDWRK ), LLWORK, IINFO )
+ CALL SCOPY( N-1, WORK( INDE ), 1, WORK( INDEE ), 1 )
+ CALL SSTEQR( JOBZ, N, W, WORK( INDEE ), Z, LDZ,
+ $ WORK( INDWRK ), INFO )
+ IF( INFO.EQ.0 ) THEN
+ DO 30 I = 1, N
+ IFAIL( I ) = 0
+ 30 CONTINUE
+ END IF
+ END IF
+ IF( INFO.EQ.0 ) THEN
+ M = N
+ GO TO 40
+ END IF
+ INFO = 0
+ END IF
+*
+* Otherwise, call SSTEBZ and, if eigenvectors are desired, SSTEIN.
+*
+ IF( WANTZ ) THEN
+ ORDER = 'B'
+ ELSE
+ ORDER = 'E'
+ END IF
+ INDIBL = 1
+ INDISP = INDIBL + N
+ INDIWO = INDISP + N
+ CALL SSTEBZ( RANGE, ORDER, N, VLL, VUU, IL, IU, ABSTLL,
+ $ WORK( INDD ), WORK( INDE ), M, NSPLIT, W,
+ $ IWORK( INDIBL ), IWORK( INDISP ), WORK( INDWRK ),
+ $ IWORK( INDIWO ), INFO )
+*
+ IF( WANTZ ) THEN
+ CALL SSTEIN( N, WORK( INDD ), WORK( INDE ), M, W,
+ $ IWORK( INDIBL ), IWORK( INDISP ), Z, LDZ,
+ $ WORK( INDWRK ), IWORK( INDIWO ), IFAIL, INFO )
+*
+* Apply orthogonal matrix used in reduction to tridiagonal
+* form to eigenvectors returned by SSTEIN.
+*
+ INDWKN = INDE
+ LLWRKN = LWORK - INDWKN + 1
+ CALL SORMTR( 'L', UPLO, 'N', N, M, A, LDA, WORK( INDTAU ), Z,
+ $ LDZ, WORK( INDWKN ), LLWRKN, IINFO )
+ END IF
+*
+* If matrix was scaled, then rescale eigenvalues appropriately.
+*
+ 40 CONTINUE
+ IF( ISCALE.EQ.1 ) THEN
+ IF( INFO.EQ.0 ) THEN
+ IMAX = M
+ ELSE
+ IMAX = INFO - 1
+ END IF
+ CALL SSCAL( IMAX, ONE / SIGMA, W, 1 )
+ END IF
+*
+* If eigenvalues are not in order, then sort them, along with
+* eigenvectors.
+*
+ IF( WANTZ ) THEN
+ DO 60 J = 1, M - 1
+ I = 0
+ TMP1 = W( J )
+ DO 50 JJ = J + 1, M
+ IF( W( JJ ).LT.TMP1 ) THEN
+ I = JJ
+ TMP1 = W( JJ )
+ END IF
+ 50 CONTINUE
+*
+ IF( I.NE.0 ) THEN
+ ITMP1 = IWORK( INDIBL+I-1 )
+ W( I ) = W( J )
+ IWORK( INDIBL+I-1 ) = IWORK( INDIBL+J-1 )
+ W( J ) = TMP1
+ IWORK( INDIBL+J-1 ) = ITMP1
+ CALL SSWAP( N, Z( 1, I ), 1, Z( 1, J ), 1 )
+ IF( INFO.NE.0 ) THEN
+ ITMP1 = IFAIL( I )
+ IFAIL( I ) = IFAIL( J )
+ IFAIL( J ) = ITMP1
+ END IF
+ END IF
+ 60 CONTINUE
+ END IF
+*
+* Set WORK(1) to optimal workspace size.
+*
+ WORK( 1 ) = LWKOPT
+*
+ RETURN
+*
+* End of SSYEVX
+*
+ END
+ SUBROUTINE SSYGS2( ITYPE, UPLO, N, A, LDA, B, LDB, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, ITYPE, LDA, LDB, N
+* ..
+* .. Array Arguments ..
+ REAL A( LDA, * ), B( LDB, * )
+* ..
+*
+* Purpose
+* =======
+*
+* SSYGS2 reduces a real symmetric-definite generalized eigenproblem
+* to standard form.
+*
+* If ITYPE = 1, the problem is A*x = lambda*B*x,
+* and A is overwritten by inv(U')*A*inv(U) or inv(L)*A*inv(L')
+*
+* If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or
+* B*A*x = lambda*x, and A is overwritten by U*A*U` or L'*A*L.
+*
+* B must have been previously factorized as U'*U or L*L' by SPOTRF.
+*
+* Arguments
+* =========
+*
+* ITYPE (input) INTEGER
+* = 1: compute inv(U')*A*inv(U) or inv(L)*A*inv(L');
+* = 2 or 3: compute U*A*U' or L'*A*L.
+*
+* UPLO (input) CHARACTER*1
+* Specifies whether the upper or lower triangular part of the
+* symmetric matrix A is stored, and how B has been factorized.
+* = 'U': Upper triangular
+* = 'L': Lower triangular
+*
+* N (input) INTEGER
+* The order of the matrices A and B. N >= 0.
+*
+* A (input/output) REAL array, dimension (LDA,N)
+* On entry, the symmetric matrix A. If UPLO = 'U', the leading
+* n by n upper triangular part of A contains the upper
+* triangular part of the matrix A, and the strictly lower
+* triangular part of A is not referenced. If UPLO = 'L', the
+* leading n by n lower triangular part of A contains the lower
+* triangular part of the matrix A, and the strictly upper
+* triangular part of A is not referenced.
+*
+* On exit, if INFO = 0, the transformed matrix, stored in the
+* same format as A.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,N).
+*
+* B (input) REAL array, dimension (LDB,N)
+* The triangular factor from the Cholesky factorization of B,
+* as returned by SPOTRF.
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. LDB >= max(1,N).
+*
+* INFO (output) INTEGER
+* = 0: successful exit.
+* < 0: if INFO = -i, the i-th argument had an illegal value.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ONE, HALF
+ PARAMETER ( ONE = 1.0, HALF = 0.5 )
+* ..
+* .. Local Scalars ..
+ LOGICAL UPPER
+ INTEGER K
+ REAL AKK, BKK, CT
+* ..
+* .. External Subroutines ..
+ EXTERNAL SAXPY, SSCAL, SSYR2, STRMV, STRSV, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN
+ INFO = -1
+ ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -2
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -5
+ ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -7
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SSYGS2', -INFO )
+ RETURN
+ END IF
+*
+ IF( ITYPE.EQ.1 ) THEN
+ IF( UPPER ) THEN
+*
+* Compute inv(U')*A*inv(U)
+*
+ DO 10 K = 1, N
+*
+* Update the upper triangle of A(k:n,k:n)
+*
+ AKK = A( K, K )
+ BKK = B( K, K )
+ AKK = AKK / BKK**2
+ A( K, K ) = AKK
+ IF( K.LT.N ) THEN
+ CALL SSCAL( N-K, ONE / BKK, A( K, K+1 ), LDA )
+ CT = -HALF*AKK
+ CALL SAXPY( N-K, CT, B( K, K+1 ), LDB, A( K, K+1 ),
+ $ LDA )
+ CALL SSYR2( UPLO, N-K, -ONE, A( K, K+1 ), LDA,
+ $ B( K, K+1 ), LDB, A( K+1, K+1 ), LDA )
+ CALL SAXPY( N-K, CT, B( K, K+1 ), LDB, A( K, K+1 ),
+ $ LDA )
+ CALL STRSV( UPLO, 'Transpose', 'Non-unit', N-K,
+ $ B( K+1, K+1 ), LDB, A( K, K+1 ), LDA )
+ END IF
+ 10 CONTINUE
+ ELSE
+*
+* Compute inv(L)*A*inv(L')
+*
+ DO 20 K = 1, N
+*
+* Update the lower triangle of A(k:n,k:n)
+*
+ AKK = A( K, K )
+ BKK = B( K, K )
+ AKK = AKK / BKK**2
+ A( K, K ) = AKK
+ IF( K.LT.N ) THEN
+ CALL SSCAL( N-K, ONE / BKK, A( K+1, K ), 1 )
+ CT = -HALF*AKK
+ CALL SAXPY( N-K, CT, B( K+1, K ), 1, A( K+1, K ), 1 )
+ CALL SSYR2( UPLO, N-K, -ONE, A( K+1, K ), 1,
+ $ B( K+1, K ), 1, A( K+1, K+1 ), LDA )
+ CALL SAXPY( N-K, CT, B( K+1, K ), 1, A( K+1, K ), 1 )
+ CALL STRSV( UPLO, 'No transpose', 'Non-unit', N-K,
+ $ B( K+1, K+1 ), LDB, A( K+1, K ), 1 )
+ END IF
+ 20 CONTINUE
+ END IF
+ ELSE
+ IF( UPPER ) THEN
+*
+* Compute U*A*U'
+*
+ DO 30 K = 1, N
+*
+* Update the upper triangle of A(1:k,1:k)
+*
+ AKK = A( K, K )
+ BKK = B( K, K )
+ CALL STRMV( UPLO, 'No transpose', 'Non-unit', K-1, B,
+ $ LDB, A( 1, K ), 1 )
+ CT = HALF*AKK
+ CALL SAXPY( K-1, CT, B( 1, K ), 1, A( 1, K ), 1 )
+ CALL SSYR2( UPLO, K-1, ONE, A( 1, K ), 1, B( 1, K ), 1,
+ $ A, LDA )
+ CALL SAXPY( K-1, CT, B( 1, K ), 1, A( 1, K ), 1 )
+ CALL SSCAL( K-1, BKK, A( 1, K ), 1 )
+ A( K, K ) = AKK*BKK**2
+ 30 CONTINUE
+ ELSE
+*
+* Compute L'*A*L
+*
+ DO 40 K = 1, N
+*
+* Update the lower triangle of A(1:k,1:k)
+*
+ AKK = A( K, K )
+ BKK = B( K, K )
+ CALL STRMV( UPLO, 'Transpose', 'Non-unit', K-1, B, LDB,
+ $ A( K, 1 ), LDA )
+ CT = HALF*AKK
+ CALL SAXPY( K-1, CT, B( K, 1 ), LDB, A( K, 1 ), LDA )
+ CALL SSYR2( UPLO, K-1, ONE, A( K, 1 ), LDA, B( K, 1 ),
+ $ LDB, A, LDA )
+ CALL SAXPY( K-1, CT, B( K, 1 ), LDB, A( K, 1 ), LDA )
+ CALL SSCAL( K-1, BKK, A( K, 1 ), LDA )
+ A( K, K ) = AKK*BKK**2
+ 40 CONTINUE
+ END IF
+ END IF
+ RETURN
+*
+* End of SSYGS2
+*
+ END
+ SUBROUTINE SSYGST( ITYPE, UPLO, N, A, LDA, B, LDB, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, ITYPE, LDA, LDB, N
+* ..
+* .. Array Arguments ..
+ REAL A( LDA, * ), B( LDB, * )
+* ..
+*
+* Purpose
+* =======
+*
+* SSYGST reduces a real symmetric-definite generalized eigenproblem
+* to standard form.
+*
+* If ITYPE = 1, the problem is A*x = lambda*B*x,
+* and A is overwritten by inv(U**T)*A*inv(U) or inv(L)*A*inv(L**T)
+*
+* If ITYPE = 2 or 3, the problem is A*B*x = lambda*x or
+* B*A*x = lambda*x, and A is overwritten by U*A*U**T or L**T*A*L.
+*
+* B must have been previously factorized as U**T*U or L*L**T by SPOTRF.
+*
+* Arguments
+* =========
+*
+* ITYPE (input) INTEGER
+* = 1: compute inv(U**T)*A*inv(U) or inv(L)*A*inv(L**T);
+* = 2 or 3: compute U*A*U**T or L**T*A*L.
+*
+* UPLO (input) CHARACTER*1
+* = 'U': Upper triangle of A is stored and B is factored as
+* U**T*U;
+* = 'L': Lower triangle of A is stored and B is factored as
+* L*L**T.
+*
+* N (input) INTEGER
+* The order of the matrices A and B. N >= 0.
+*
+* A (input/output) REAL array, dimension (LDA,N)
+* On entry, the symmetric matrix A. If UPLO = 'U', the leading
+* N-by-N upper triangular part of A contains the upper
+* triangular part of the matrix A, and the strictly lower
+* triangular part of A is not referenced. If UPLO = 'L', the
+* leading N-by-N lower triangular part of A contains the lower
+* triangular part of the matrix A, and the strictly upper
+* triangular part of A is not referenced.
+*
+* On exit, if INFO = 0, the transformed matrix, stored in the
+* same format as A.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,N).
+*
+* B (input) REAL array, dimension (LDB,N)
+* The triangular factor from the Cholesky factorization of B,
+* as returned by SPOTRF.
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. LDB >= max(1,N).
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ONE, HALF
+ PARAMETER ( ONE = 1.0, HALF = 0.5 )
+* ..
+* .. Local Scalars ..
+ LOGICAL UPPER
+ INTEGER K, KB, NB
+* ..
+* .. External Subroutines ..
+ EXTERNAL SSYGS2, SSYMM, SSYR2K, STRMM, STRSM, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ILAENV
+ EXTERNAL LSAME, ILAENV
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN
+ INFO = -1
+ ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -2
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -5
+ ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -7
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SSYGST', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+* Determine the block size for this environment.
+*
+ NB = ILAENV( 1, 'SSYGST', UPLO, N, -1, -1, -1 )
+*
+ IF( NB.LE.1 .OR. NB.GE.N ) THEN
+*
+* Use unblocked code
+*
+ CALL SSYGS2( ITYPE, UPLO, N, A, LDA, B, LDB, INFO )
+ ELSE
+*
+* Use blocked code
+*
+ IF( ITYPE.EQ.1 ) THEN
+ IF( UPPER ) THEN
+*
+* Compute inv(U')*A*inv(U)
+*
+ DO 10 K = 1, N, NB
+ KB = MIN( N-K+1, NB )
+*
+* Update the upper triangle of A(k:n,k:n)
+*
+ CALL SSYGS2( ITYPE, UPLO, KB, A( K, K ), LDA,
+ $ B( K, K ), LDB, INFO )
+ IF( K+KB.LE.N ) THEN
+ CALL STRSM( 'Left', UPLO, 'Transpose', 'Non-unit',
+ $ KB, N-K-KB+1, ONE, B( K, K ), LDB,
+ $ A( K, K+KB ), LDA )
+ CALL SSYMM( 'Left', UPLO, KB, N-K-KB+1, -HALF,
+ $ A( K, K ), LDA, B( K, K+KB ), LDB, ONE,
+ $ A( K, K+KB ), LDA )
+ CALL SSYR2K( UPLO, 'Transpose', N-K-KB+1, KB, -ONE,
+ $ A( K, K+KB ), LDA, B( K, K+KB ), LDB,
+ $ ONE, A( K+KB, K+KB ), LDA )
+ CALL SSYMM( 'Left', UPLO, KB, N-K-KB+1, -HALF,
+ $ A( K, K ), LDA, B( K, K+KB ), LDB, ONE,
+ $ A( K, K+KB ), LDA )
+ CALL STRSM( 'Right', UPLO, 'No transpose',
+ $ 'Non-unit', KB, N-K-KB+1, ONE,
+ $ B( K+KB, K+KB ), LDB, A( K, K+KB ),
+ $ LDA )
+ END IF
+ 10 CONTINUE
+ ELSE
+*
+* Compute inv(L)*A*inv(L')
+*
+ DO 20 K = 1, N, NB
+ KB = MIN( N-K+1, NB )
+*
+* Update the lower triangle of A(k:n,k:n)
+*
+ CALL SSYGS2( ITYPE, UPLO, KB, A( K, K ), LDA,
+ $ B( K, K ), LDB, INFO )
+ IF( K+KB.LE.N ) THEN
+ CALL STRSM( 'Right', UPLO, 'Transpose', 'Non-unit',
+ $ N-K-KB+1, KB, ONE, B( K, K ), LDB,
+ $ A( K+KB, K ), LDA )
+ CALL SSYMM( 'Right', UPLO, N-K-KB+1, KB, -HALF,
+ $ A( K, K ), LDA, B( K+KB, K ), LDB, ONE,
+ $ A( K+KB, K ), LDA )
+ CALL SSYR2K( UPLO, 'No transpose', N-K-KB+1, KB,
+ $ -ONE, A( K+KB, K ), LDA, B( K+KB, K ),
+ $ LDB, ONE, A( K+KB, K+KB ), LDA )
+ CALL SSYMM( 'Right', UPLO, N-K-KB+1, KB, -HALF,
+ $ A( K, K ), LDA, B( K+KB, K ), LDB, ONE,
+ $ A( K+KB, K ), LDA )
+ CALL STRSM( 'Left', UPLO, 'No transpose',
+ $ 'Non-unit', N-K-KB+1, KB, ONE,
+ $ B( K+KB, K+KB ), LDB, A( K+KB, K ),
+ $ LDA )
+ END IF
+ 20 CONTINUE
+ END IF
+ ELSE
+ IF( UPPER ) THEN
+*
+* Compute U*A*U'
+*
+ DO 30 K = 1, N, NB
+ KB = MIN( N-K+1, NB )
+*
+* Update the upper triangle of A(1:k+kb-1,1:k+kb-1)
+*
+ CALL STRMM( 'Left', UPLO, 'No transpose', 'Non-unit',
+ $ K-1, KB, ONE, B, LDB, A( 1, K ), LDA )
+ CALL SSYMM( 'Right', UPLO, K-1, KB, HALF, A( K, K ),
+ $ LDA, B( 1, K ), LDB, ONE, A( 1, K ), LDA )
+ CALL SSYR2K( UPLO, 'No transpose', K-1, KB, ONE,
+ $ A( 1, K ), LDA, B( 1, K ), LDB, ONE, A,
+ $ LDA )
+ CALL SSYMM( 'Right', UPLO, K-1, KB, HALF, A( K, K ),
+ $ LDA, B( 1, K ), LDB, ONE, A( 1, K ), LDA )
+ CALL STRMM( 'Right', UPLO, 'Transpose', 'Non-unit',
+ $ K-1, KB, ONE, B( K, K ), LDB, A( 1, K ),
+ $ LDA )
+ CALL SSYGS2( ITYPE, UPLO, KB, A( K, K ), LDA,
+ $ B( K, K ), LDB, INFO )
+ 30 CONTINUE
+ ELSE
+*
+* Compute L'*A*L
+*
+ DO 40 K = 1, N, NB
+ KB = MIN( N-K+1, NB )
+*
+* Update the lower triangle of A(1:k+kb-1,1:k+kb-1)
+*
+ CALL STRMM( 'Right', UPLO, 'No transpose', 'Non-unit',
+ $ KB, K-1, ONE, B, LDB, A( K, 1 ), LDA )
+ CALL SSYMM( 'Left', UPLO, KB, K-1, HALF, A( K, K ),
+ $ LDA, B( K, 1 ), LDB, ONE, A( K, 1 ), LDA )
+ CALL SSYR2K( UPLO, 'Transpose', K-1, KB, ONE,
+ $ A( K, 1 ), LDA, B( K, 1 ), LDB, ONE, A,
+ $ LDA )
+ CALL SSYMM( 'Left', UPLO, KB, K-1, HALF, A( K, K ),
+ $ LDA, B( K, 1 ), LDB, ONE, A( K, 1 ), LDA )
+ CALL STRMM( 'Left', UPLO, 'Transpose', 'Non-unit', KB,
+ $ K-1, ONE, B( K, K ), LDB, A( K, 1 ), LDA )
+ CALL SSYGS2( ITYPE, UPLO, KB, A( K, K ), LDA,
+ $ B( K, K ), LDB, INFO )
+ 40 CONTINUE
+ END IF
+ END IF
+ END IF
+ RETURN
+*
+* End of SSYGST
+*
+ END
+ SUBROUTINE SSYGV( ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, W, WORK,
+ $ LWORK, INFO )
+*
+* -- LAPACK driver routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER JOBZ, UPLO
+ INTEGER INFO, ITYPE, LDA, LDB, LWORK, N
+* ..
+* .. Array Arguments ..
+ REAL A( LDA, * ), B( LDB, * ), W( * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SSYGV computes all the eigenvalues, and optionally, the eigenvectors
+* of a real generalized symmetric-definite eigenproblem, of the form
+* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x.
+* Here A and B are assumed to be symmetric and B is also
+* positive definite.
+*
+* Arguments
+* =========
+*
+* ITYPE (input) INTEGER
+* Specifies the problem type to be solved:
+* = 1: A*x = (lambda)*B*x
+* = 2: A*B*x = (lambda)*x
+* = 3: B*A*x = (lambda)*x
+*
+* JOBZ (input) CHARACTER*1
+* = 'N': Compute eigenvalues only;
+* = 'V': Compute eigenvalues and eigenvectors.
+*
+* UPLO (input) CHARACTER*1
+* = 'U': Upper triangles of A and B are stored;
+* = 'L': Lower triangles of A and B are stored.
+*
+* N (input) INTEGER
+* The order of the matrices A and B. N >= 0.
+*
+* A (input/output) REAL array, dimension (LDA, N)
+* On entry, the symmetric matrix A. If UPLO = 'U', the
+* leading N-by-N upper triangular part of A contains the
+* upper triangular part of the matrix A. If UPLO = 'L',
+* the leading N-by-N lower triangular part of A contains
+* the lower triangular part of the matrix A.
+*
+* On exit, if JOBZ = 'V', then if INFO = 0, A contains the
+* matrix Z of eigenvectors. The eigenvectors are normalized
+* as follows:
+* if ITYPE = 1 or 2, Z**T*B*Z = I;
+* if ITYPE = 3, Z**T*inv(B)*Z = I.
+* If JOBZ = 'N', then on exit the upper triangle (if UPLO='U')
+* or the lower triangle (if UPLO='L') of A, including the
+* diagonal, is destroyed.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,N).
+*
+* B (input/output) REAL array, dimension (LDB, N)
+* On entry, the symmetric positive definite matrix B.
+* If UPLO = 'U', the leading N-by-N upper triangular part of B
+* contains the upper triangular part of the matrix B.
+* If UPLO = 'L', the leading N-by-N lower triangular part of B
+* contains the lower triangular part of the matrix B.
+*
+* On exit, if INFO <= N, the part of B containing the matrix is
+* overwritten by the triangular factor U or L from the Cholesky
+* factorization B = U**T*U or B = L*L**T.
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. LDB >= max(1,N).
+*
+* W (output) REAL array, dimension (N)
+* If INFO = 0, the eigenvalues in ascending order.
+*
+* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))
+* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+* LWORK (input) INTEGER
+* The length of the array WORK. LWORK >= max(1,3*N-1).
+* For optimal efficiency, LWORK >= (NB+2)*N,
+* where NB is the blocksize for SSYTRD returned by ILAENV.
+*
+* If LWORK = -1, then a workspace query is assumed; the routine
+* only calculates the optimal size of the WORK array, returns
+* this value as the first entry of the WORK array, and no error
+* message related to LWORK is issued by XERBLA.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* > 0: SPOTRF or SSYEV returned an error code:
+* <= N: if INFO = i, SSYEV failed to converge;
+* i off-diagonal elements of an intermediate
+* tridiagonal form did not converge to zero;
+* > N: if INFO = N + i, for 1 <= i <= N, then the leading
+* minor of order i of B is not positive definite.
+* The factorization of B could not be completed and
+* no eigenvalues or eigenvectors were computed.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ONE
+ PARAMETER ( ONE = 1.0E+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL LQUERY, UPPER, WANTZ
+ CHARACTER TRANS
+ INTEGER LWKMIN, LWKOPT, NB, NEIG
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ILAENV
+ EXTERNAL ILAENV, LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL SPOTRF, SSYEV, SSYGST, STRMM, STRSM, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ WANTZ = LSAME( JOBZ, 'V' )
+ UPPER = LSAME( UPLO, 'U' )
+ LQUERY = ( LWORK.EQ.-1 )
+*
+ INFO = 0
+ IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN
+ INFO = -1
+ ELSE IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
+ INFO = -2
+ ELSE IF( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN
+ INFO = -3
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -6
+ ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -8
+ END IF
+*
+ IF( INFO.EQ.0 ) THEN
+ LWKMIN = MAX( 1, 3*N - 1 )
+ NB = ILAENV( 1, 'SSYTRD', UPLO, N, -1, -1, -1 )
+ LWKOPT = MAX( LWKMIN, ( NB + 2 )*N )
+ WORK( 1 ) = LWKOPT
+*
+ IF( LWORK.LT.LWKMIN .AND. .NOT.LQUERY ) THEN
+ INFO = -11
+ END IF
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SSYGV ', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+* Form a Cholesky factorization of B.
+*
+ CALL SPOTRF( UPLO, N, B, LDB, INFO )
+ IF( INFO.NE.0 ) THEN
+ INFO = N + INFO
+ RETURN
+ END IF
+*
+* Transform problem to standard eigenvalue problem and solve.
+*
+ CALL SSYGST( ITYPE, UPLO, N, A, LDA, B, LDB, INFO )
+ CALL SSYEV( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, INFO )
+*
+ IF( WANTZ ) THEN
+*
+* Backtransform eigenvectors to the original problem.
+*
+ NEIG = N
+ IF( INFO.GT.0 )
+ $ NEIG = INFO - 1
+ IF( ITYPE.EQ.1 .OR. ITYPE.EQ.2 ) THEN
+*
+* For A*x=(lambda)*B*x and A*B*x=(lambda)*x;
+* backtransform eigenvectors: x = inv(L)'*y or inv(U)*y
+*
+ IF( UPPER ) THEN
+ TRANS = 'N'
+ ELSE
+ TRANS = 'T'
+ END IF
+*
+ CALL STRSM( 'Left', UPLO, TRANS, 'Non-unit', N, NEIG, ONE,
+ $ B, LDB, A, LDA )
+*
+ ELSE IF( ITYPE.EQ.3 ) THEN
+*
+* For B*A*x=(lambda)*x;
+* backtransform eigenvectors: x = L*y or U'*y
+*
+ IF( UPPER ) THEN
+ TRANS = 'T'
+ ELSE
+ TRANS = 'N'
+ END IF
+*
+ CALL STRMM( 'Left', UPLO, TRANS, 'Non-unit', N, NEIG, ONE,
+ $ B, LDB, A, LDA )
+ END IF
+ END IF
+*
+ WORK( 1 ) = LWKOPT
+ RETURN
+*
+* End of SSYGV
+*
+ END
+ SUBROUTINE SSYGVD( ITYPE, JOBZ, UPLO, N, A, LDA, B, LDB, W, WORK,
+ $ LWORK, IWORK, LIWORK, INFO )
+*
+* -- LAPACK driver routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER JOBZ, UPLO
+ INTEGER INFO, ITYPE, LDA, LDB, LIWORK, LWORK, N
+* ..
+* .. Array Arguments ..
+ INTEGER IWORK( * )
+ REAL A( LDA, * ), B( LDB, * ), W( * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SSYGVD computes all the eigenvalues, and optionally, the eigenvectors
+* of a real generalized symmetric-definite eigenproblem, of the form
+* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A and
+* B are assumed to be symmetric and B is also positive definite.
+* If eigenvectors are desired, it uses a divide and conquer algorithm.
+*
+* The divide and conquer algorithm makes very mild assumptions about
+* floating point arithmetic. It will work on machines with a guard
+* digit in add/subtract, or on those binary machines without guard
+* digits which subtract like the Cray X-MP, Cray Y-MP, Cray C-90, or
+* Cray-2. It could conceivably fail on hexadecimal or decimal machines
+* without guard digits, but we know of none.
+*
+* Arguments
+* =========
+*
+* ITYPE (input) INTEGER
+* Specifies the problem type to be solved:
+* = 1: A*x = (lambda)*B*x
+* = 2: A*B*x = (lambda)*x
+* = 3: B*A*x = (lambda)*x
+*
+* JOBZ (input) CHARACTER*1
+* = 'N': Compute eigenvalues only;
+* = 'V': Compute eigenvalues and eigenvectors.
+*
+* UPLO (input) CHARACTER*1
+* = 'U': Upper triangles of A and B are stored;
+* = 'L': Lower triangles of A and B are stored.
+*
+* N (input) INTEGER
+* The order of the matrices A and B. N >= 0.
+*
+* A (input/output) REAL array, dimension (LDA, N)
+* On entry, the symmetric matrix A. If UPLO = 'U', the
+* leading N-by-N upper triangular part of A contains the
+* upper triangular part of the matrix A. If UPLO = 'L',
+* the leading N-by-N lower triangular part of A contains
+* the lower triangular part of the matrix A.
+*
+* On exit, if JOBZ = 'V', then if INFO = 0, A contains the
+* matrix Z of eigenvectors. The eigenvectors are normalized
+* as follows:
+* if ITYPE = 1 or 2, Z**T*B*Z = I;
+* if ITYPE = 3, Z**T*inv(B)*Z = I.
+* If JOBZ = 'N', then on exit the upper triangle (if UPLO='U')
+* or the lower triangle (if UPLO='L') of A, including the
+* diagonal, is destroyed.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,N).
+*
+* B (input/output) REAL array, dimension (LDB, N)
+* On entry, the symmetric matrix B. If UPLO = 'U', the
+* leading N-by-N upper triangular part of B contains the
+* upper triangular part of the matrix B. If UPLO = 'L',
+* the leading N-by-N lower triangular part of B contains
+* the lower triangular part of the matrix B.
+*
+* On exit, if INFO <= N, the part of B containing the matrix is
+* overwritten by the triangular factor U or L from the Cholesky
+* factorization B = U**T*U or B = L*L**T.
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. LDB >= max(1,N).
+*
+* W (output) REAL array, dimension (N)
+* If INFO = 0, the eigenvalues in ascending order.
+*
+* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))
+* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+* LWORK (input) INTEGER
+* The dimension of the array WORK.
+* If N <= 1, LWORK >= 1.
+* If JOBZ = 'N' and N > 1, LWORK >= 2*N+1.
+* If JOBZ = 'V' and N > 1, LWORK >= 1 + 6*N + 2*N**2.
+*
+* If LWORK = -1, then a workspace query is assumed; the routine
+* only calculates the optimal sizes of the WORK and IWORK
+* arrays, returns these values as the first entries of the WORK
+* and IWORK arrays, and no error message related to LWORK or
+* LIWORK is issued by XERBLA.
+*
+* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))
+* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
+*
+* LIWORK (input) INTEGER
+* The dimension of the array IWORK.
+* If N <= 1, LIWORK >= 1.
+* If JOBZ = 'N' and N > 1, LIWORK >= 1.
+* If JOBZ = 'V' and N > 1, LIWORK >= 3 + 5*N.
+*
+* If LIWORK = -1, then a workspace query is assumed; the
+* routine only calculates the optimal sizes of the WORK and
+* IWORK arrays, returns these values as the first entries of
+* the WORK and IWORK arrays, and no error message related to
+* LWORK or LIWORK is issued by XERBLA.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* > 0: SPOTRF or SSYEVD returned an error code:
+* <= N: if INFO = i and JOBZ = 'N', then the algorithm
+* failed to converge; i off-diagonal elements of an
+* intermediate tridiagonal form did not converge to
+* zero;
+* if INFO = i and JOBZ = 'V', then the algorithm
+* failed to compute an eigenvalue while working on
+* the submatrix lying in rows and columns INFO/(N+1)
+* through mod(INFO,N+1);
+* > N: if INFO = N + i, for 1 <= i <= N, then the leading
+* minor of order i of B is not positive definite.
+* The factorization of B could not be completed and
+* no eigenvalues or eigenvectors were computed.
+*
+* Further Details
+* ===============
+*
+* Based on contributions by
+* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA
+*
+* Modified so that no backsubstitution is performed if SSYEVD fails to
+* converge (NEIG in old code could be greater than N causing out of
+* bounds reference to A - reported by Ralf Meyer). Also corrected the
+* description of INFO and the test on ITYPE. Sven, 16 Feb 05.
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ONE
+ PARAMETER ( ONE = 1.0E+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL LQUERY, UPPER, WANTZ
+ CHARACTER TRANS
+ INTEGER LIOPT, LIWMIN, LOPT, LWMIN
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL SPOTRF, SSYEVD, SSYGST, STRMM, STRSM, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, REAL
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ WANTZ = LSAME( JOBZ, 'V' )
+ UPPER = LSAME( UPLO, 'U' )
+ LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 )
+*
+ INFO = 0
+ IF( N.LE.1 ) THEN
+ LIWMIN = 1
+ LWMIN = 1
+ ELSE IF( WANTZ ) THEN
+ LIWMIN = 3 + 5*N
+ LWMIN = 1 + 6*N + 2*N**2
+ ELSE
+ LIWMIN = 1
+ LWMIN = 2*N + 1
+ END IF
+ LOPT = LWMIN
+ LIOPT = LIWMIN
+ IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN
+ INFO = -1
+ ELSE IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
+ INFO = -2
+ ELSE IF( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN
+ INFO = -3
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -6
+ ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -8
+ END IF
+*
+ IF( INFO.EQ.0 ) THEN
+ WORK( 1 ) = LOPT
+ IWORK( 1 ) = LIOPT
+*
+ IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
+ INFO = -11
+ ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN
+ INFO = -13
+ END IF
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SSYGVD', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+* Form a Cholesky factorization of B.
+*
+ CALL SPOTRF( UPLO, N, B, LDB, INFO )
+ IF( INFO.NE.0 ) THEN
+ INFO = N + INFO
+ RETURN
+ END IF
+*
+* Transform problem to standard eigenvalue problem and solve.
+*
+ CALL SSYGST( ITYPE, UPLO, N, A, LDA, B, LDB, INFO )
+ CALL SSYEVD( JOBZ, UPLO, N, A, LDA, W, WORK, LWORK, IWORK, LIWORK,
+ $ INFO )
+ LOPT = MAX( REAL( LOPT ), REAL( WORK( 1 ) ) )
+ LIOPT = MAX( REAL( LIOPT ), REAL( IWORK( 1 ) ) )
+*
+ IF( WANTZ .AND. INFO.EQ.0 ) THEN
+*
+* Backtransform eigenvectors to the original problem.
+*
+ IF( ITYPE.EQ.1 .OR. ITYPE.EQ.2 ) THEN
+*
+* For A*x=(lambda)*B*x and A*B*x=(lambda)*x;
+* backtransform eigenvectors: x = inv(L)'*y or inv(U)*y
+*
+ IF( UPPER ) THEN
+ TRANS = 'N'
+ ELSE
+ TRANS = 'T'
+ END IF
+*
+ CALL STRSM( 'Left', UPLO, TRANS, 'Non-unit', N, N, ONE,
+ $ B, LDB, A, LDA )
+*
+ ELSE IF( ITYPE.EQ.3 ) THEN
+*
+* For B*A*x=(lambda)*x;
+* backtransform eigenvectors: x = L*y or U'*y
+*
+ IF( UPPER ) THEN
+ TRANS = 'T'
+ ELSE
+ TRANS = 'N'
+ END IF
+*
+ CALL STRMM( 'Left', UPLO, TRANS, 'Non-unit', N, N, ONE,
+ $ B, LDB, A, LDA )
+ END IF
+ END IF
+*
+ WORK( 1 ) = LOPT
+ IWORK( 1 ) = LIOPT
+*
+ RETURN
+*
+* End of SSYGVD
+*
+ END
+ 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 )
+*
+* -- LAPACK driver routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER JOBZ, RANGE, UPLO
+ INTEGER IL, INFO, ITYPE, IU, LDA, LDB, LDZ, LWORK, M, N
+ REAL ABSTOL, VL, VU
+* ..
+* .. Array Arguments ..
+ INTEGER IFAIL( * ), IWORK( * )
+ REAL A( LDA, * ), B( LDB, * ), W( * ), WORK( * ),
+ $ Z( LDZ, * )
+* ..
+*
+* Purpose
+* =======
+*
+* SSYGVX computes selected eigenvalues, and optionally, eigenvectors
+* of a real generalized symmetric-definite eigenproblem, of the form
+* A*x=(lambda)*B*x, A*Bx=(lambda)*x, or B*A*x=(lambda)*x. Here A
+* and B are assumed to be symmetric and B is also positive definite.
+* Eigenvalues and eigenvectors can be selected by specifying either a
+* range of values or a range of indices for the desired eigenvalues.
+*
+* Arguments
+* =========
+*
+* ITYPE (input) INTEGER
+* Specifies the problem type to be solved:
+* = 1: A*x = (lambda)*B*x
+* = 2: A*B*x = (lambda)*x
+* = 3: B*A*x = (lambda)*x
+*
+* JOBZ (input) CHARACTER*1
+* = 'N': Compute eigenvalues only;
+* = 'V': Compute eigenvalues and eigenvectors.
+*
+* RANGE (input) CHARACTER*1
+* = 'A': all eigenvalues will be found.
+* = 'V': all eigenvalues in the half-open interval (VL,VU]
+* will be found.
+* = 'I': the IL-th through IU-th eigenvalues will be found.
+*
+* UPLO (input) CHARACTER*1
+* = 'U': Upper triangle of A and B are stored;
+* = 'L': Lower triangle of A and B are stored.
+*
+* N (input) INTEGER
+* The order of the matrix pencil (A,B). N >= 0.
+*
+* A (input/output) REAL array, dimension (LDA, N)
+* On entry, the symmetric matrix A. If UPLO = 'U', the
+* leading N-by-N upper triangular part of A contains the
+* upper triangular part of the matrix A. If UPLO = 'L',
+* the leading N-by-N lower triangular part of A contains
+* the lower triangular part of the matrix A.
+*
+* On exit, the lower triangle (if UPLO='L') or the upper
+* triangle (if UPLO='U') of A, including the diagonal, is
+* destroyed.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,N).
+*
+* B (input/output) REAL array, dimension (LDA, N)
+* On entry, the symmetric matrix B. If UPLO = 'U', the
+* leading N-by-N upper triangular part of B contains the
+* upper triangular part of the matrix B. If UPLO = 'L',
+* the leading N-by-N lower triangular part of B contains
+* the lower triangular part of the matrix B.
+*
+* On exit, if INFO <= N, the part of B containing the matrix is
+* overwritten by the triangular factor U or L from the Cholesky
+* factorization B = U**T*U or B = L*L**T.
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. LDB >= max(1,N).
+*
+* VL (input) REAL
+* VU (input) REAL
+* If RANGE='V', the lower and upper bounds of the interval to
+* be searched for eigenvalues. VL < VU.
+* Not referenced if RANGE = 'A' or 'I'.
+*
+* IL (input) INTEGER
+* IU (input) INTEGER
+* If RANGE='I', the indices (in ascending order) of the
+* smallest and largest eigenvalues to be returned.
+* 1 <= IL <= IU <= N, if N > 0; IL = 1 and IU = 0 if N = 0.
+* Not referenced if RANGE = 'A' or 'V'.
+*
+* ABSTOL (input) REAL
+* The absolute error tolerance for the eigenvalues.
+* An approximate eigenvalue is accepted as converged
+* when it is determined to lie in an interval [a,b]
+* of width less than or equal to
+*
+* ABSTOL + EPS * max( |a|,|b| ) ,
+*
+* where EPS is the machine precision. If ABSTOL is less than
+* or equal to zero, then EPS*|T| will be used in its place,
+* where |T| is the 1-norm of the tridiagonal matrix obtained
+* by reducing A to tridiagonal form.
+*
+* Eigenvalues will be computed most accurately when ABSTOL is
+* set to twice the underflow threshold 2*DLAMCH('S'), not zero.
+* If this routine returns with INFO>0, indicating that some
+* eigenvectors did not converge, try setting ABSTOL to
+* 2*SLAMCH('S').
+*
+* M (output) INTEGER
+* The total number of eigenvalues found. 0 <= M <= N.
+* If RANGE = 'A', M = N, and if RANGE = 'I', M = IU-IL+1.
+*
+* W (output) REAL array, dimension (N)
+* On normal exit, the first M elements contain the selected
+* eigenvalues in ascending order.
+*
+* Z (output) REAL array, dimension (LDZ, max(1,M))
+* If JOBZ = 'N', then Z is not referenced.
+* If JOBZ = 'V', then if INFO = 0, the first M columns of Z
+* contain the orthonormal eigenvectors of the matrix A
+* corresponding to the selected eigenvalues, with the i-th
+* column of Z holding the eigenvector associated with W(i).
+* The eigenvectors are normalized as follows:
+* if ITYPE = 1 or 2, Z**T*B*Z = I;
+* if ITYPE = 3, Z**T*inv(B)*Z = I.
+*
+* If an eigenvector fails to converge, then that column of Z
+* contains the latest approximation to the eigenvector, and the
+* index of the eigenvector is returned in IFAIL.
+* Note: the user must ensure that at least max(1,M) columns are
+* supplied in the array Z; if RANGE = 'V', the exact value of M
+* is not known in advance and an upper bound must be used.
+*
+* LDZ (input) INTEGER
+* The leading dimension of the array Z. LDZ >= 1, and if
+* JOBZ = 'V', LDZ >= max(1,N).
+*
+* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))
+* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+* LWORK (input) INTEGER
+* The length of the array WORK. LWORK >= max(1,8*N).
+* For optimal efficiency, LWORK >= (NB+3)*N,
+* where NB is the blocksize for SSYTRD returned by ILAENV.
+*
+* If LWORK = -1, then a workspace query is assumed; the routine
+* only calculates the optimal size of the WORK array, returns
+* this value as the first entry of the WORK array, and no error
+* message related to LWORK is issued by XERBLA.
+*
+* IWORK (workspace) INTEGER array, dimension (5*N)
+*
+* IFAIL (output) INTEGER array, dimension (N)
+* If JOBZ = 'V', then if INFO = 0, the first M elements of
+* IFAIL are zero. If INFO > 0, then IFAIL contains the
+* indices of the eigenvectors that failed to converge.
+* If JOBZ = 'N', then IFAIL is not referenced.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* > 0: SPOTRF or SSYEVX returned an error code:
+* <= N: if INFO = i, SSYEVX failed to converge;
+* i eigenvectors failed to converge. Their indices
+* are stored in array IFAIL.
+* > N: if INFO = N + i, for 1 <= i <= N, then the leading
+* minor of order i of B is not positive definite.
+* The factorization of B could not be completed and
+* no eigenvalues or eigenvectors were computed.
+*
+* Further Details
+* ===============
+*
+* Based on contributions by
+* Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ONE
+ PARAMETER ( ONE = 1.0E+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL ALLEIG, INDEIG, LQUERY, UPPER, VALEIG, WANTZ
+ CHARACTER TRANS
+ INTEGER LWKMIN, LWKOPT, NB
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ILAENV
+ EXTERNAL ILAENV, LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL SPOTRF, SSYEVX, SSYGST, STRMM, STRSM, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ UPPER = LSAME( UPLO, 'U' )
+ WANTZ = LSAME( JOBZ, 'V' )
+ ALLEIG = LSAME( RANGE, 'A' )
+ VALEIG = LSAME( RANGE, 'V' )
+ INDEIG = LSAME( RANGE, 'I' )
+ LQUERY = ( LWORK.EQ.-1 )
+*
+ INFO = 0
+ IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN
+ INFO = -1
+ ELSE IF( .NOT.( WANTZ .OR. LSAME( JOBZ, 'N' ) ) ) THEN
+ INFO = -2
+ ELSE IF( .NOT.( ALLEIG .OR. VALEIG .OR. INDEIG ) ) THEN
+ INFO = -3
+ ELSE IF( .NOT.( UPPER .OR. LSAME( UPLO, 'L' ) ) ) THEN
+ INFO = -4
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -5
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -7
+ ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -9
+ ELSE
+ IF( VALEIG ) THEN
+ IF( N.GT.0 .AND. VU.LE.VL )
+ $ INFO = -11
+ ELSE IF( INDEIG ) THEN
+ IF( IL.LT.1 .OR. IL.GT.MAX( 1, N ) ) THEN
+ INFO = -12
+ ELSE IF( IU.LT.MIN( N, IL ) .OR. IU.GT.N ) THEN
+ INFO = -13
+ END IF
+ END IF
+ END IF
+ IF (INFO.EQ.0) THEN
+ IF (LDZ.LT.1 .OR. (WANTZ .AND. LDZ.LT.N)) THEN
+ INFO = -18
+ END IF
+ END IF
+*
+ IF( INFO.EQ.0 ) THEN
+ LWKMIN = MAX( 1, 8*N )
+ NB = ILAENV( 1, 'SSYTRD', UPLO, N, -1, -1, -1 )
+ LWKOPT = MAX( LWKMIN, ( NB + 3 )*N )
+ WORK( 1 ) = LWKOPT
+*
+ IF( LWORK.LT.LWKMIN .AND. .NOT.LQUERY ) THEN
+ INFO = -20
+ END IF
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SSYGVX', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ M = 0
+ IF( N.EQ.0 ) THEN
+ RETURN
+ END IF
+*
+* Form a Cholesky factorization of B.
+*
+ CALL SPOTRF( UPLO, N, B, LDB, INFO )
+ IF( INFO.NE.0 ) THEN
+ INFO = N + INFO
+ RETURN
+ END IF
+*
+* Transform problem to standard eigenvalue problem and solve.
+*
+ CALL SSYGST( ITYPE, UPLO, N, A, LDA, B, LDB, INFO )
+ CALL SSYEVX( JOBZ, RANGE, UPLO, N, A, LDA, VL, VU, IL, IU, ABSTOL,
+ $ M, W, Z, LDZ, WORK, LWORK, IWORK, IFAIL, INFO )
+*
+ IF( WANTZ ) THEN
+*
+* Backtransform eigenvectors to the original problem.
+*
+ IF( INFO.GT.0 )
+ $ M = INFO - 1
+ IF( ITYPE.EQ.1 .OR. ITYPE.EQ.2 ) THEN
+*
+* For A*x=(lambda)*B*x and A*B*x=(lambda)*x;
+* backtransform eigenvectors: x = inv(L)'*y or inv(U)*y
+*
+ IF( UPPER ) THEN
+ TRANS = 'N'
+ ELSE
+ TRANS = 'T'
+ END IF
+*
+ CALL STRSM( 'Left', UPLO, TRANS, 'Non-unit', N, M, ONE, B,
+ $ LDB, Z, LDZ )
+*
+ ELSE IF( ITYPE.EQ.3 ) THEN
+*
+* For B*A*x=(lambda)*x;
+* backtransform eigenvectors: x = L*y or U'*y
+*
+ IF( UPPER ) THEN
+ TRANS = 'T'
+ ELSE
+ TRANS = 'N'
+ END IF
+*
+ CALL STRMM( 'Left', UPLO, TRANS, 'Non-unit', N, M, ONE, B,
+ $ LDB, Z, LDZ )
+ END IF
+ END IF
+*
+* Set WORK(1) to optimal workspace size.
+*
+ WORK( 1 ) = LWKOPT
+*
+ RETURN
+*
+* End of SSYGVX
+*
+ END
+ SUBROUTINE SSYRFS( UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB,
+ $ X, LDX, FERR, BERR, WORK, IWORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* Modified to call SLACN2 in place of SLACON, 7 Feb 03, SJH.
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, LDA, LDAF, LDB, LDX, N, NRHS
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * ), IWORK( * )
+ REAL A( LDA, * ), AF( LDAF, * ), B( LDB, * ),
+ $ BERR( * ), FERR( * ), WORK( * ), X( LDX, * )
+* ..
+*
+* Purpose
+* =======
+*
+* SSYRFS improves the computed solution to a system of linear
+* equations when the coefficient matrix is symmetric indefinite, and
+* provides error bounds and backward error estimates for the solution.
+*
+* Arguments
+* =========
+*
+* UPLO (input) CHARACTER*1
+* = 'U': Upper triangle of A is stored;
+* = 'L': Lower triangle of A is stored.
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* NRHS (input) INTEGER
+* The number of right hand sides, i.e., the number of columns
+* of the matrices B and X. NRHS >= 0.
+*
+* A (input) REAL array, dimension (LDA,N)
+* The symmetric matrix A. If UPLO = 'U', the leading N-by-N
+* upper triangular part of A contains the upper triangular part
+* of the matrix A, and the strictly lower triangular part of A
+* is not referenced. If UPLO = 'L', the leading N-by-N lower
+* triangular part of A contains the lower triangular part of
+* the matrix A, and the strictly upper triangular part of A is
+* not referenced.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,N).
+*
+* AF (input) REAL array, dimension (LDAF,N)
+* The factored form of the matrix A. AF contains the block
+* diagonal matrix D and the multipliers used to obtain the
+* factor U or L from the factorization A = U*D*U**T or
+* A = L*D*L**T as computed by SSYTRF.
+*
+* LDAF (input) INTEGER
+* The leading dimension of the array AF. LDAF >= max(1,N).
+*
+* IPIV (input) INTEGER array, dimension (N)
+* Details of the interchanges and the block structure of D
+* as determined by SSYTRF.
+*
+* B (input) REAL array, dimension (LDB,NRHS)
+* The right hand side matrix B.
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. LDB >= max(1,N).
+*
+* X (input/output) REAL array, dimension (LDX,NRHS)
+* On entry, the solution matrix X, as computed by SSYTRS.
+* On exit, the improved solution matrix X.
+*
+* LDX (input) INTEGER
+* The leading dimension of the array X. LDX >= max(1,N).
+*
+* FERR (output) REAL array, dimension (NRHS)
+* The estimated forward error bound for each solution vector
+* X(j) (the j-th column of the solution matrix X).
+* If XTRUE is the true solution corresponding to X(j), FERR(j)
+* is an estimated upper bound for the magnitude of the largest
+* element in (X(j) - XTRUE) divided by the magnitude of the
+* largest element in X(j). The estimate is as reliable as
+* the estimate for RCOND, and is almost always a slight
+* overestimate of the true error.
+*
+* BERR (output) REAL array, dimension (NRHS)
+* The componentwise relative backward error of each solution
+* vector X(j) (i.e., the smallest relative change in
+* any element of A or B that makes X(j) an exact solution).
+*
+* WORK (workspace) REAL array, dimension (3*N)
+*
+* IWORK (workspace) INTEGER array, dimension (N)
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+*
+* Internal Parameters
+* ===================
+*
+* ITMAX is the maximum number of steps of iterative refinement.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ INTEGER ITMAX
+ PARAMETER ( ITMAX = 5 )
+ REAL ZERO
+ PARAMETER ( ZERO = 0.0E+0 )
+ REAL ONE
+ PARAMETER ( ONE = 1.0E+0 )
+ REAL TWO
+ PARAMETER ( TWO = 2.0E+0 )
+ REAL THREE
+ PARAMETER ( THREE = 3.0E+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL UPPER
+ INTEGER COUNT, I, J, K, KASE, NZ
+ REAL EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK
+* ..
+* .. Local Arrays ..
+ INTEGER ISAVE( 3 )
+* ..
+* .. External Subroutines ..
+ EXTERNAL SAXPY, SCOPY, SLACN2, SSYMV, SSYTRS, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ REAL SLAMCH
+ EXTERNAL LSAME, SLAMCH
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( NRHS.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -5
+ ELSE IF( LDAF.LT.MAX( 1, N ) ) THEN
+ INFO = -7
+ ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -10
+ ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
+ INFO = -12
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SSYRFS', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN
+ DO 10 J = 1, NRHS
+ FERR( J ) = ZERO
+ BERR( J ) = ZERO
+ 10 CONTINUE
+ RETURN
+ END IF
+*
+* NZ = maximum number of nonzero elements in each row of A, plus 1
+*
+ NZ = N + 1
+ EPS = SLAMCH( 'Epsilon' )
+ SAFMIN = SLAMCH( 'Safe minimum' )
+ SAFE1 = NZ*SAFMIN
+ SAFE2 = SAFE1 / EPS
+*
+* Do for each right hand side
+*
+ DO 140 J = 1, NRHS
+*
+ COUNT = 1
+ LSTRES = THREE
+ 20 CONTINUE
+*
+* Loop until stopping criterion is satisfied.
+*
+* Compute residual R = B - A * X
+*
+ CALL SCOPY( N, B( 1, J ), 1, WORK( N+1 ), 1 )
+ CALL SSYMV( UPLO, N, -ONE, A, LDA, X( 1, J ), 1, ONE,
+ $ WORK( N+1 ), 1 )
+*
+* Compute componentwise relative backward error from formula
+*
+* max(i) ( abs(R(i)) / ( abs(A)*abs(X) + abs(B) )(i) )
+*
+* where abs(Z) is the componentwise absolute value of the matrix
+* or vector Z. If the i-th component of the denominator is less
+* than SAFE2, then SAFE1 is added to the i-th components of the
+* numerator and denominator before dividing.
+*
+ DO 30 I = 1, N
+ WORK( I ) = ABS( B( I, J ) )
+ 30 CONTINUE
+*
+* Compute abs(A)*abs(X) + abs(B).
+*
+ IF( UPPER ) THEN
+ DO 50 K = 1, N
+ S = ZERO
+ XK = ABS( X( K, J ) )
+ DO 40 I = 1, K - 1
+ WORK( I ) = WORK( I ) + ABS( A( I, K ) )*XK
+ S = S + ABS( A( I, K ) )*ABS( X( I, J ) )
+ 40 CONTINUE
+ WORK( K ) = WORK( K ) + ABS( A( K, K ) )*XK + S
+ 50 CONTINUE
+ ELSE
+ DO 70 K = 1, N
+ S = ZERO
+ XK = ABS( X( K, J ) )
+ WORK( K ) = WORK( K ) + ABS( A( K, K ) )*XK
+ DO 60 I = K + 1, N
+ WORK( I ) = WORK( I ) + ABS( A( I, K ) )*XK
+ S = S + ABS( A( I, K ) )*ABS( X( I, J ) )
+ 60 CONTINUE
+ WORK( K ) = WORK( K ) + S
+ 70 CONTINUE
+ END IF
+ S = ZERO
+ DO 80 I = 1, N
+ IF( WORK( I ).GT.SAFE2 ) THEN
+ S = MAX( S, ABS( WORK( N+I ) ) / WORK( I ) )
+ ELSE
+ S = MAX( S, ( ABS( WORK( N+I ) )+SAFE1 ) /
+ $ ( WORK( I )+SAFE1 ) )
+ END IF
+ 80 CONTINUE
+ BERR( J ) = S
+*
+* Test stopping criterion. Continue iterating if
+* 1) The residual BERR(J) is larger than machine epsilon, and
+* 2) BERR(J) decreased by at least a factor of 2 during the
+* last iteration, and
+* 3) At most ITMAX iterations tried.
+*
+ IF( BERR( J ).GT.EPS .AND. TWO*BERR( J ).LE.LSTRES .AND.
+ $ COUNT.LE.ITMAX ) THEN
+*
+* Update solution and try again.
+*
+ CALL SSYTRS( UPLO, N, 1, AF, LDAF, IPIV, WORK( N+1 ), N,
+ $ INFO )
+ CALL SAXPY( N, ONE, WORK( N+1 ), 1, X( 1, J ), 1 )
+ LSTRES = BERR( J )
+ COUNT = COUNT + 1
+ GO TO 20
+ END IF
+*
+* Bound error from formula
+*
+* norm(X - XTRUE) / norm(X) .le. FERR =
+* norm( abs(inv(A))*
+* ( abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) ))) / norm(X)
+*
+* where
+* norm(Z) is the magnitude of the largest component of Z
+* inv(A) is the inverse of A
+* abs(Z) is the componentwise absolute value of the matrix or
+* vector Z
+* NZ is the maximum number of nonzeros in any row of A, plus 1
+* EPS is machine epsilon
+*
+* The i-th component of abs(R)+NZ*EPS*(abs(A)*abs(X)+abs(B))
+* is incremented by SAFE1 if the i-th component of
+* abs(A)*abs(X) + abs(B) is less than SAFE2.
+*
+* Use SLACN2 to estimate the infinity-norm of the matrix
+* inv(A) * diag(W),
+* where W = abs(R) + NZ*EPS*( abs(A)*abs(X)+abs(B) )))
+*
+ DO 90 I = 1, N
+ IF( WORK( I ).GT.SAFE2 ) THEN
+ WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I )
+ ELSE
+ WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I ) + SAFE1
+ END IF
+ 90 CONTINUE
+*
+ KASE = 0
+ 100 CONTINUE
+ CALL SLACN2( N, WORK( 2*N+1 ), WORK( N+1 ), IWORK, FERR( J ),
+ $ KASE, ISAVE )
+ IF( KASE.NE.0 ) THEN
+ IF( KASE.EQ.1 ) THEN
+*
+* Multiply by diag(W)*inv(A').
+*
+ CALL SSYTRS( UPLO, N, 1, AF, LDAF, IPIV, WORK( N+1 ), N,
+ $ INFO )
+ DO 110 I = 1, N
+ WORK( N+I ) = WORK( I )*WORK( N+I )
+ 110 CONTINUE
+ ELSE IF( KASE.EQ.2 ) THEN
+*
+* Multiply by inv(A)*diag(W).
+*
+ DO 120 I = 1, N
+ WORK( N+I ) = WORK( I )*WORK( N+I )
+ 120 CONTINUE
+ CALL SSYTRS( UPLO, N, 1, AF, LDAF, IPIV, WORK( N+1 ), N,
+ $ INFO )
+ END IF
+ GO TO 100
+ END IF
+*
+* Normalize error.
+*
+ LSTRES = ZERO
+ DO 130 I = 1, N
+ LSTRES = MAX( LSTRES, ABS( X( I, J ) ) )
+ 130 CONTINUE
+ IF( LSTRES.NE.ZERO )
+ $ FERR( J ) = FERR( J ) / LSTRES
+*
+ 140 CONTINUE
+*
+ RETURN
+*
+* End of SSYRFS
+*
+ END
+ SUBROUTINE SSYSV( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, WORK,
+ $ LWORK, INFO )
+*
+* -- LAPACK driver routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, LDA, LDB, LWORK, N, NRHS
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ REAL A( LDA, * ), B( LDB, * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SSYSV computes the solution to a real system of linear equations
+* A * X = B,
+* where A is an N-by-N symmetric matrix and X and B are N-by-NRHS
+* matrices.
+*
+* The diagonal pivoting method is used to factor A as
+* A = U * D * U**T, if UPLO = 'U', or
+* A = L * D * L**T, if UPLO = 'L',
+* where U (or L) is a product of permutation and unit upper (lower)
+* triangular matrices, and D is symmetric and block diagonal with
+* 1-by-1 and 2-by-2 diagonal blocks. The factored form of A is then
+* used to solve the system of equations A * X = B.
+*
+* Arguments
+* =========
+*
+* UPLO (input) CHARACTER*1
+* = 'U': Upper triangle of A is stored;
+* = 'L': Lower triangle of A is stored.
+*
+* N (input) INTEGER
+* The number of linear equations, i.e., the order of the
+* matrix A. N >= 0.
+*
+* NRHS (input) INTEGER
+* The number of right hand sides, i.e., the number of columns
+* of the matrix B. NRHS >= 0.
+*
+* A (input/output) REAL array, dimension (LDA,N)
+* On entry, the symmetric matrix A. If UPLO = 'U', the leading
+* N-by-N upper triangular part of A contains the upper
+* triangular part of the matrix A, and the strictly lower
+* triangular part of A is not referenced. If UPLO = 'L', the
+* leading N-by-N lower triangular part of A contains the lower
+* triangular part of the matrix A, and the strictly upper
+* triangular part of A is not referenced.
+*
+* On exit, if INFO = 0, the block diagonal matrix D and the
+* multipliers used to obtain the factor U or L from the
+* factorization A = U*D*U**T or A = L*D*L**T as computed by
+* SSYTRF.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,N).
+*
+* IPIV (output) INTEGER array, dimension (N)
+* Details of the interchanges and the block structure of D, as
+* determined by SSYTRF. If IPIV(k) > 0, then rows and columns
+* k and IPIV(k) were interchanged, and D(k,k) is a 1-by-1
+* diagonal block. If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0,
+* then rows and columns k-1 and -IPIV(k) were interchanged and
+* D(k-1:k,k-1:k) is a 2-by-2 diagonal block. If UPLO = 'L' and
+* IPIV(k) = IPIV(k+1) < 0, then rows and columns k+1 and
+* -IPIV(k) were interchanged and D(k:k+1,k:k+1) is a 2-by-2
+* diagonal block.
+*
+* B (input/output) REAL array, dimension (LDB,NRHS)
+* On entry, the N-by-NRHS right hand side matrix B.
+* On exit, if INFO = 0, the N-by-NRHS solution matrix X.
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. LDB >= max(1,N).
+*
+* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))
+* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+* LWORK (input) INTEGER
+* The length of WORK. LWORK >= 1, and for best performance
+* LWORK >= max(1,N*NB), where NB is the optimal blocksize for
+* SSYTRF.
+*
+* If LWORK = -1, then a workspace query is assumed; the routine
+* only calculates the optimal size of the WORK array, returns
+* this value as the first entry of the WORK array, and no error
+* message related to LWORK is issued by XERBLA.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* > 0: if INFO = i, D(i,i) is exactly zero. The factorization
+* has been completed, but the block diagonal matrix D is
+* exactly singular, so the solution could not be computed.
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ LOGICAL LQUERY
+ INTEGER LWKOPT, NB
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ILAENV
+ EXTERNAL ILAENV, LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL SSYTRF, SSYTRS, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ LQUERY = ( LWORK.EQ.-1 )
+ IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( NRHS.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -5
+ ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -8
+ ELSE IF( LWORK.LT.1 .AND. .NOT.LQUERY ) THEN
+ INFO = -10
+ END IF
+*
+ IF( INFO.EQ.0 ) THEN
+ IF( N.EQ.0 ) THEN
+ LWKOPT = 1
+ ELSE
+ NB = ILAENV( 1, 'SSYTRF', UPLO, N, -1, -1, -1 )
+ LWKOPT = N*NB
+ END IF
+ WORK( 1 ) = LWKOPT
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SSYSV ', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Compute the factorization A = U*D*U' or A = L*D*L'.
+*
+ CALL SSYTRF( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO )
+ IF( INFO.EQ.0 ) THEN
+*
+* Solve the system A*X = B, overwriting B with X.
+*
+ CALL SSYTRS( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO )
+*
+ END IF
+*
+ WORK( 1 ) = LWKOPT
+*
+ RETURN
+*
+* End of SSYSV
+*
+ END
+ SUBROUTINE SSYSVX( FACT, UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, B,
+ $ LDB, X, LDX, RCOND, FERR, BERR, WORK, LWORK,
+ $ IWORK, INFO )
+*
+* -- LAPACK driver routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER FACT, UPLO
+ INTEGER INFO, LDA, LDAF, LDB, LDX, LWORK, N, NRHS
+ REAL RCOND
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * ), IWORK( * )
+ REAL A( LDA, * ), AF( LDAF, * ), B( LDB, * ),
+ $ BERR( * ), FERR( * ), WORK( * ), X( LDX, * )
+* ..
+*
+* Purpose
+* =======
+*
+* SSYSVX uses the diagonal pivoting factorization to compute the
+* solution to a real system of linear equations A * X = B,
+* where A is an N-by-N symmetric matrix and X and B are N-by-NRHS
+* matrices.
+*
+* Error bounds on the solution and a condition estimate are also
+* provided.
+*
+* Description
+* ===========
+*
+* The following steps are performed:
+*
+* 1. If FACT = 'N', the diagonal pivoting method is used to factor A.
+* The form of the factorization is
+* A = U * D * U**T, if UPLO = 'U', or
+* A = L * D * L**T, if UPLO = 'L',
+* where U (or L) is a product of permutation and unit upper (lower)
+* triangular matrices, and D is symmetric and block diagonal with
+* 1-by-1 and 2-by-2 diagonal blocks.
+*
+* 2. If some D(i,i)=0, so that D is exactly singular, then the routine
+* returns with INFO = i. Otherwise, the factored form of A is used
+* to estimate the condition number of the matrix A. If the
+* reciprocal of the condition number is less than machine precision,
+* INFO = N+1 is returned as a warning, but the routine still goes on
+* to solve for X and compute error bounds as described below.
+*
+* 3. The system of equations is solved for X using the factored form
+* of A.
+*
+* 4. Iterative refinement is applied to improve the computed solution
+* matrix and calculate error bounds and backward error estimates
+* for it.
+*
+* Arguments
+* =========
+*
+* FACT (input) CHARACTER*1
+* Specifies whether or not the factored form of A has been
+* supplied on entry.
+* = 'F': On entry, AF and IPIV contain the factored form of
+* A. AF and IPIV will not be modified.
+* = 'N': The matrix A will be copied to AF and factored.
+*
+* UPLO (input) CHARACTER*1
+* = 'U': Upper triangle of A is stored;
+* = 'L': Lower triangle of A is stored.
+*
+* N (input) INTEGER
+* The number of linear equations, i.e., the order of the
+* matrix A. N >= 0.
+*
+* NRHS (input) INTEGER
+* The number of right hand sides, i.e., the number of columns
+* of the matrices B and X. NRHS >= 0.
+*
+* A (input) REAL array, dimension (LDA,N)
+* The symmetric matrix A. If UPLO = 'U', the leading N-by-N
+* upper triangular part of A contains the upper triangular part
+* of the matrix A, and the strictly lower triangular part of A
+* is not referenced. If UPLO = 'L', the leading N-by-N lower
+* triangular part of A contains the lower triangular part of
+* the matrix A, and the strictly upper triangular part of A is
+* not referenced.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,N).
+*
+* AF (input or output) REAL array, dimension (LDAF,N)
+* If FACT = 'F', then AF is an input argument and on entry
+* contains the block diagonal matrix D and the multipliers used
+* to obtain the factor U or L from the factorization
+* A = U*D*U**T or A = L*D*L**T as computed by SSYTRF.
+*
+* If FACT = 'N', then AF is an output argument and on exit
+* returns the block diagonal matrix D and the multipliers used
+* to obtain the factor U or L from the factorization
+* A = U*D*U**T or A = L*D*L**T.
+*
+* LDAF (input) INTEGER
+* The leading dimension of the array AF. LDAF >= max(1,N).
+*
+* IPIV (input or output) INTEGER array, dimension (N)
+* If FACT = 'F', then IPIV is an input argument and on entry
+* contains details of the interchanges and the block structure
+* of D, as determined by SSYTRF.
+* If IPIV(k) > 0, then rows and columns k and IPIV(k) were
+* interchanged and D(k,k) is a 1-by-1 diagonal block.
+* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and
+* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)
+* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =
+* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were
+* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
+*
+* If FACT = 'N', then IPIV is an output argument and on exit
+* contains details of the interchanges and the block structure
+* of D, as determined by SSYTRF.
+*
+* B (input) REAL array, dimension (LDB,NRHS)
+* The N-by-NRHS right hand side matrix B.
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. LDB >= max(1,N).
+*
+* X (output) REAL array, dimension (LDX,NRHS)
+* If INFO = 0 or INFO = N+1, the N-by-NRHS solution matrix X.
+*
+* LDX (input) INTEGER
+* The leading dimension of the array X. LDX >= max(1,N).
+*
+* RCOND (output) REAL
+* The estimate of the reciprocal condition number of the matrix
+* A. If RCOND is less than the machine precision (in
+* particular, if RCOND = 0), the matrix is singular to working
+* precision. This condition is indicated by a return code of
+* INFO > 0.
+*
+* FERR (output) REAL array, dimension (NRHS)
+* The estimated forward error bound for each solution vector
+* X(j) (the j-th column of the solution matrix X).
+* If XTRUE is the true solution corresponding to X(j), FERR(j)
+* is an estimated upper bound for the magnitude of the largest
+* element in (X(j) - XTRUE) divided by the magnitude of the
+* largest element in X(j). The estimate is as reliable as
+* the estimate for RCOND, and is almost always a slight
+* overestimate of the true error.
+*
+* BERR (output) REAL array, dimension (NRHS)
+* The componentwise relative backward error of each solution
+* vector X(j) (i.e., the smallest relative change in
+* any element of A or B that makes X(j) an exact solution).
+*
+* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))
+* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+* LWORK (input) INTEGER
+* The length of WORK. LWORK >= max(1,3*N), and for best
+* performance, when FACT = 'N', LWORK >= max(1,3*N,N*NB), where
+* NB is the optimal blocksize for SSYTRF.
+*
+* If LWORK = -1, then a workspace query is assumed; the routine
+* only calculates the optimal size of the WORK array, returns
+* this value as the first entry of the WORK array, and no error
+* message related to LWORK is issued by XERBLA.
+*
+* IWORK (workspace) INTEGER array, dimension (N)
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* > 0: if INFO = i, and i is
+* <= N: D(i,i) is exactly zero. The factorization
+* has been completed but the factor D is exactly
+* singular, so the solution and error bounds could
+* not be computed. RCOND = 0 is returned.
+* = N+1: D is nonsingular, but RCOND is less than machine
+* precision, meaning that the matrix is singular
+* to working precision. Nevertheless, the
+* solution and error bounds are computed because
+* there are a number of situations where the
+* computed solution can be more accurate than the
+* value of RCOND would suggest.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO
+ PARAMETER ( ZERO = 0.0E+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL LQUERY, NOFACT
+ INTEGER LWKOPT, NB
+ REAL ANORM
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ILAENV
+ REAL SLAMCH, SLANSY
+ EXTERNAL ILAENV, LSAME, SLAMCH, SLANSY
+* ..
+* .. External Subroutines ..
+ EXTERNAL SLACPY, SSYCON, SSYRFS, SSYTRF, SSYTRS, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ NOFACT = LSAME( FACT, 'N' )
+ LQUERY = ( LWORK.EQ.-1 )
+ IF( .NOT.NOFACT .AND. .NOT.LSAME( FACT, 'F' ) ) THEN
+ INFO = -1
+ ELSE IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) )
+ $ THEN
+ INFO = -2
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( NRHS.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -6
+ ELSE IF( LDAF.LT.MAX( 1, N ) ) THEN
+ INFO = -8
+ ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -11
+ ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
+ INFO = -13
+ ELSE IF( LWORK.LT.MAX( 1, 3*N ) .AND. .NOT.LQUERY ) THEN
+ INFO = -18
+ END IF
+*
+ IF( INFO.EQ.0 ) THEN
+ LWKOPT = MAX( 1, 3*N )
+ IF( NOFACT ) THEN
+ NB = ILAENV( 1, 'SSYTRF', UPLO, N, -1, -1, -1 )
+ LWKOPT = MAX( LWKOPT, N*NB )
+ END IF
+ WORK( 1 ) = LWKOPT
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SSYSVX', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+ IF( NOFACT ) THEN
+*
+* Compute the factorization A = U*D*U' or A = L*D*L'.
+*
+ CALL SLACPY( UPLO, N, N, A, LDA, AF, LDAF )
+ CALL SSYTRF( UPLO, N, AF, LDAF, IPIV, WORK, LWORK, INFO )
+*
+* Return if INFO is non-zero.
+*
+ IF( INFO.GT.0 )THEN
+ RCOND = ZERO
+ RETURN
+ END IF
+ END IF
+*
+* Compute the norm of the matrix A.
+*
+ ANORM = SLANSY( 'I', UPLO, N, A, LDA, WORK )
+*
+* Compute the reciprocal of the condition number of A.
+*
+ CALL SSYCON( UPLO, N, AF, LDAF, IPIV, ANORM, RCOND, WORK, IWORK,
+ $ INFO )
+*
+* Compute the solution vectors X.
+*
+ CALL SLACPY( 'Full', N, NRHS, B, LDB, X, LDX )
+ CALL SSYTRS( UPLO, N, NRHS, AF, LDAF, IPIV, X, LDX, INFO )
+*
+* Use iterative refinement to improve the computed solutions and
+* compute error bounds and backward error estimates for them.
+*
+ CALL SSYRFS( UPLO, N, NRHS, A, LDA, AF, LDAF, IPIV, B, LDB, X,
+ $ LDX, FERR, BERR, WORK, IWORK, INFO )
+*
+* Set INFO = N+1 if the matrix is singular to working precision.
+*
+ IF( RCOND.LT.SLAMCH( 'Epsilon' ) )
+ $ INFO = N + 1
+*
+ WORK( 1 ) = LWKOPT
+*
+ RETURN
+*
+* End of SSYSVX
+*
+ END
+ SUBROUTINE SSYTD2( UPLO, N, A, LDA, D, E, TAU, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, LDA, N
+* ..
+* .. Array Arguments ..
+ REAL A( LDA, * ), D( * ), E( * ), TAU( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SSYTD2 reduces a real symmetric matrix A to symmetric tridiagonal
+* form T by an orthogonal similarity transformation: Q' * A * Q = T.
+*
+* Arguments
+* =========
+*
+* UPLO (input) CHARACTER*1
+* Specifies whether the upper or lower triangular part of the
+* symmetric matrix A is stored:
+* = 'U': Upper triangular
+* = 'L': Lower triangular
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* A (input/output) REAL array, dimension (LDA,N)
+* On entry, the symmetric matrix A. If UPLO = 'U', the leading
+* n-by-n upper triangular part of A contains the upper
+* triangular part of the matrix A, and the strictly lower
+* triangular part of A is not referenced. If UPLO = 'L', the
+* leading n-by-n lower triangular part of A contains the lower
+* triangular part of the matrix A, and the strictly upper
+* triangular part of A is not referenced.
+* On exit, if UPLO = 'U', the diagonal and first superdiagonal
+* of A are overwritten by the corresponding elements of the
+* tridiagonal matrix T, and the elements above the first
+* superdiagonal, with the array TAU, represent the orthogonal
+* matrix Q as a product of elementary reflectors; if UPLO
+* = 'L', the diagonal and first subdiagonal of A are over-
+* written by the corresponding elements of the tridiagonal
+* matrix T, and the elements below the first subdiagonal, with
+* the array TAU, represent the orthogonal matrix Q as a product
+* of elementary reflectors. See Further Details.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,N).
+*
+* D (output) REAL array, dimension (N)
+* The diagonal elements of the tridiagonal matrix T:
+* D(i) = A(i,i).
+*
+* E (output) REAL array, dimension (N-1)
+* The off-diagonal elements of the tridiagonal matrix T:
+* E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'.
+*
+* TAU (output) REAL array, dimension (N-1)
+* The scalar factors of the elementary reflectors (see Further
+* Details).
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value.
+*
+* Further Details
+* ===============
+*
+* If UPLO = 'U', the matrix Q is represented as a product of elementary
+* reflectors
+*
+* Q = H(n-1) . . . H(2) H(1).
+*
+* Each H(i) has the form
+*
+* H(i) = I - tau * v * v'
+*
+* where tau is a real scalar, and v is a real vector with
+* v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in
+* A(1:i-1,i+1), and tau in TAU(i).
+*
+* If UPLO = 'L', the matrix Q is represented as a product of elementary
+* reflectors
+*
+* Q = H(1) H(2) . . . H(n-1).
+*
+* Each H(i) has the form
+*
+* H(i) = I - tau * v * v'
+*
+* where tau is a real scalar, and v is a real vector with
+* v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in A(i+2:n,i),
+* and tau in TAU(i).
+*
+* The contents of A on exit are illustrated by the following examples
+* with n = 5:
+*
+* if UPLO = 'U': if UPLO = 'L':
+*
+* ( d e v2 v3 v4 ) ( d )
+* ( d e v3 v4 ) ( e d )
+* ( d e v4 ) ( v1 e d )
+* ( d e ) ( v1 v2 e d )
+* ( d ) ( v1 v2 v3 e d )
+*
+* where d and e denote diagonal and off-diagonal elements of T, and vi
+* denotes an element of the vector defining H(i).
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ONE, ZERO, HALF
+ PARAMETER ( ONE = 1.0, ZERO = 0.0, HALF = 1.0 / 2.0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL UPPER
+ INTEGER I
+ REAL ALPHA, TAUI
+* ..
+* .. External Subroutines ..
+ EXTERNAL SAXPY, SLARFG, SSYMV, SSYR2, XERBLA
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ REAL SDOT
+ EXTERNAL LSAME, SDOT
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -4
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SSYTD2', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.LE.0 )
+ $ RETURN
+*
+ IF( UPPER ) THEN
+*
+* Reduce the upper triangle of A
+*
+ DO 10 I = N - 1, 1, -1
+*
+* Generate elementary reflector H(i) = I - tau * v * v'
+* to annihilate A(1:i-1,i+1)
+*
+ CALL SLARFG( I, A( I, I+1 ), A( 1, I+1 ), 1, TAUI )
+ E( I ) = A( I, I+1 )
+*
+ IF( TAUI.NE.ZERO ) THEN
+*
+* Apply H(i) from both sides to A(1:i,1:i)
+*
+ A( I, I+1 ) = ONE
+*
+* Compute x := tau * A * v storing x in TAU(1:i)
+*
+ CALL SSYMV( UPLO, I, TAUI, A, LDA, A( 1, I+1 ), 1, ZERO,
+ $ TAU, 1 )
+*
+* Compute w := x - 1/2 * tau * (x'*v) * v
+*
+ ALPHA = -HALF*TAUI*SDOT( I, TAU, 1, A( 1, I+1 ), 1 )
+ CALL SAXPY( I, ALPHA, A( 1, I+1 ), 1, TAU, 1 )
+*
+* Apply the transformation as a rank-2 update:
+* A := A - v * w' - w * v'
+*
+ CALL SSYR2( UPLO, I, -ONE, A( 1, I+1 ), 1, TAU, 1, A,
+ $ LDA )
+*
+ A( I, I+1 ) = E( I )
+ END IF
+ D( I+1 ) = A( I+1, I+1 )
+ TAU( I ) = TAUI
+ 10 CONTINUE
+ D( 1 ) = A( 1, 1 )
+ ELSE
+*
+* Reduce the lower triangle of A
+*
+ DO 20 I = 1, N - 1
+*
+* Generate elementary reflector H(i) = I - tau * v * v'
+* to annihilate A(i+2:n,i)
+*
+ CALL SLARFG( N-I, A( I+1, I ), A( MIN( I+2, N ), I ), 1,
+ $ TAUI )
+ E( I ) = A( I+1, I )
+*
+ IF( TAUI.NE.ZERO ) THEN
+*
+* Apply H(i) from both sides to A(i+1:n,i+1:n)
+*
+ A( I+1, I ) = ONE
+*
+* Compute x := tau * A * v storing y in TAU(i:n-1)
+*
+ CALL SSYMV( UPLO, N-I, TAUI, A( I+1, I+1 ), LDA,
+ $ A( I+1, I ), 1, ZERO, TAU( I ), 1 )
+*
+* Compute w := x - 1/2 * tau * (x'*v) * v
+*
+ ALPHA = -HALF*TAUI*SDOT( N-I, TAU( I ), 1, A( I+1, I ),
+ $ 1 )
+ CALL SAXPY( N-I, ALPHA, A( I+1, I ), 1, TAU( I ), 1 )
+*
+* Apply the transformation as a rank-2 update:
+* A := A - v * w' - w * v'
+*
+ CALL SSYR2( UPLO, N-I, -ONE, A( I+1, I ), 1, TAU( I ), 1,
+ $ A( I+1, I+1 ), LDA )
+*
+ A( I+1, I ) = E( I )
+ END IF
+ D( I ) = A( I, I )
+ TAU( I ) = TAUI
+ 20 CONTINUE
+ D( N ) = A( N, N )
+ END IF
+*
+ RETURN
+*
+* End of SSYTD2
+*
+ END
+ SUBROUTINE SSYTF2( UPLO, N, A, LDA, IPIV, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, LDA, N
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ REAL A( LDA, * )
+* ..
+*
+* Purpose
+* =======
+*
+* SSYTF2 computes the factorization of a real symmetric matrix A using
+* the Bunch-Kaufman diagonal pivoting method:
+*
+* A = U*D*U' or A = L*D*L'
+*
+* where U (or L) is a product of permutation and unit upper (lower)
+* triangular matrices, U' is the transpose of U, and D is symmetric and
+* block diagonal with 1-by-1 and 2-by-2 diagonal blocks.
+*
+* This is the unblocked version of the algorithm, calling Level 2 BLAS.
+*
+* Arguments
+* =========
+*
+* UPLO (input) CHARACTER*1
+* Specifies whether the upper or lower triangular part of the
+* symmetric matrix A is stored:
+* = 'U': Upper triangular
+* = 'L': Lower triangular
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* A (input/output) REAL array, dimension (LDA,N)
+* On entry, the symmetric matrix A. If UPLO = 'U', the leading
+* n-by-n upper triangular part of A contains the upper
+* triangular part of the matrix A, and the strictly lower
+* triangular part of A is not referenced. If UPLO = 'L', the
+* leading n-by-n lower triangular part of A contains the lower
+* triangular part of the matrix A, and the strictly upper
+* triangular part of A is not referenced.
+*
+* On exit, the block diagonal matrix D and the multipliers used
+* to obtain the factor U or L (see below for further details).
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,N).
+*
+* IPIV (output) INTEGER array, dimension (N)
+* Details of the interchanges and the block structure of D.
+* If IPIV(k) > 0, then rows and columns k and IPIV(k) were
+* interchanged and D(k,k) is a 1-by-1 diagonal block.
+* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and
+* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)
+* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =
+* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were
+* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -k, the k-th argument had an illegal value
+* > 0: if INFO = k, D(k,k) is exactly zero. The factorization
+* has been completed, but the block diagonal matrix D is
+* exactly singular, and division by zero will occur if it
+* is used to solve a system of equations.
+*
+* Further Details
+* ===============
+*
+* 09-29-06 - patch from
+* Bobby Cheng, MathWorks
+*
+* Replace l.204 and l.372
+* IF( MAX( ABSAKK, COLMAX ).EQ.ZERO ) THEN
+* by
+* IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) .OR. SISNAN(ABSAKK) ) THEN
+*
+* 01-01-96 - Based on modifications by
+* J. Lewis, Boeing Computer Services Company
+* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA
+* 1-96 - Based on modifications by J. Lewis, Boeing Computer Services
+* Company
+*
+* If UPLO = 'U', then A = U*D*U', where
+* U = P(n)*U(n)* ... *P(k)U(k)* ...,
+* i.e., U is a product of terms P(k)*U(k), where k decreases from n to
+* 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1
+* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as
+* defined by IPIV(k), and U(k) is a unit upper triangular matrix, such
+* that if the diagonal block D(k) is of order s (s = 1 or 2), then
+*
+* ( I v 0 ) k-s
+* U(k) = ( 0 I 0 ) s
+* ( 0 0 I ) n-k
+* k-s s n-k
+*
+* If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k).
+* If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k),
+* and A(k,k), and v overwrites A(1:k-2,k-1:k).
+*
+* If UPLO = 'L', then A = L*D*L', where
+* L = P(1)*L(1)* ... *P(k)*L(k)* ...,
+* i.e., L is a product of terms P(k)*L(k), where k increases from 1 to
+* n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1
+* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as
+* defined by IPIV(k), and L(k) is a unit lower triangular matrix, such
+* that if the diagonal block D(k) is of order s (s = 1 or 2), then
+*
+* ( I 0 0 ) k-1
+* L(k) = ( 0 I 0 ) s
+* ( 0 v I ) n-k-s+1
+* k-1 s n-k-s+1
+*
+* If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k).
+* If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k),
+* and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1).
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO, ONE
+ PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+ REAL EIGHT, SEVTEN
+ PARAMETER ( EIGHT = 8.0E+0, SEVTEN = 17.0E+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL UPPER
+ INTEGER I, IMAX, J, JMAX, K, KK, KP, KSTEP
+ REAL ABSAKK, ALPHA, COLMAX, D11, D12, D21, D22, R1,
+ $ ROWMAX, T, WK, WKM1, WKP1
+* ..
+* .. External Functions ..
+ LOGICAL LSAME, SISNAN
+ INTEGER ISAMAX
+ EXTERNAL LSAME, ISAMAX, SISNAN
+* ..
+* .. External Subroutines ..
+ EXTERNAL SSCAL, SSWAP, SSYR, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, SQRT
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -4
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SSYTF2', -INFO )
+ RETURN
+ END IF
+*
+* Initialize ALPHA for use in choosing pivot block size.
+*
+ ALPHA = ( ONE+SQRT( SEVTEN ) ) / EIGHT
+*
+ IF( UPPER ) THEN
+*
+* Factorize A as U*D*U' using the upper triangle of A
+*
+* K is the main loop index, decreasing from N to 1 in steps of
+* 1 or 2
+*
+ K = N
+ 10 CONTINUE
+*
+* If K < 1, exit from loop
+*
+ IF( K.LT.1 )
+ $ GO TO 70
+ KSTEP = 1
+*
+* Determine rows and columns to be interchanged and whether
+* a 1-by-1 or 2-by-2 pivot block will be used
+*
+ ABSAKK = ABS( A( K, K ) )
+*
+* IMAX is the row-index of the largest off-diagonal element in
+* column K, and COLMAX is its absolute value
+*
+ IF( K.GT.1 ) THEN
+ IMAX = ISAMAX( K-1, A( 1, K ), 1 )
+ COLMAX = ABS( A( IMAX, K ) )
+ ELSE
+ COLMAX = ZERO
+ END IF
+*
+ IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) .OR. SISNAN(ABSAKK) ) THEN
+*
+* Column K is zero or contains a NaN: set INFO and continue
+*
+ IF( INFO.EQ.0 )
+ $ INFO = K
+ KP = K
+ ELSE
+ IF( ABSAKK.GE.ALPHA*COLMAX ) THEN
+*
+* no interchange, use 1-by-1 pivot block
+*
+ KP = K
+ ELSE
+*
+* JMAX is the column-index of the largest off-diagonal
+* element in row IMAX, and ROWMAX is its absolute value
+*
+ JMAX = IMAX + ISAMAX( K-IMAX, A( IMAX, IMAX+1 ), LDA )
+ ROWMAX = ABS( A( IMAX, JMAX ) )
+ IF( IMAX.GT.1 ) THEN
+ JMAX = ISAMAX( IMAX-1, A( 1, IMAX ), 1 )
+ ROWMAX = MAX( ROWMAX, ABS( A( JMAX, IMAX ) ) )
+ END IF
+*
+ IF( ABSAKK.GE.ALPHA*COLMAX*( COLMAX / ROWMAX ) ) THEN
+*
+* no interchange, use 1-by-1 pivot block
+*
+ KP = K
+ ELSE IF( ABS( A( IMAX, IMAX ) ).GE.ALPHA*ROWMAX ) THEN
+*
+* interchange rows and columns K and IMAX, use 1-by-1
+* pivot block
+*
+ KP = IMAX
+ ELSE
+*
+* interchange rows and columns K-1 and IMAX, use 2-by-2
+* pivot block
+*
+ KP = IMAX
+ KSTEP = 2
+ END IF
+ END IF
+*
+ KK = K - KSTEP + 1
+ IF( KP.NE.KK ) THEN
+*
+* Interchange rows and columns KK and KP in the leading
+* submatrix A(1:k,1:k)
+*
+ CALL SSWAP( KP-1, A( 1, KK ), 1, A( 1, KP ), 1 )
+ CALL SSWAP( KK-KP-1, A( KP+1, KK ), 1, A( KP, KP+1 ),
+ $ LDA )
+ T = A( KK, KK )
+ A( KK, KK ) = A( KP, KP )
+ A( KP, KP ) = T
+ IF( KSTEP.EQ.2 ) THEN
+ T = A( K-1, K )
+ A( K-1, K ) = A( KP, K )
+ A( KP, K ) = T
+ END IF
+ END IF
+*
+* Update the leading submatrix
+*
+ IF( KSTEP.EQ.1 ) THEN
+*
+* 1-by-1 pivot block D(k): column k now holds
+*
+* W(k) = U(k)*D(k)
+*
+* where U(k) is the k-th column of U
+*
+* Perform a rank-1 update of A(1:k-1,1:k-1) as
+*
+* A := A - U(k)*D(k)*U(k)' = A - W(k)*1/D(k)*W(k)'
+*
+ R1 = ONE / A( K, K )
+ CALL SSYR( UPLO, K-1, -R1, A( 1, K ), 1, A, LDA )
+*
+* Store U(k) in column k
+*
+ CALL SSCAL( K-1, R1, A( 1, K ), 1 )
+ ELSE
+*
+* 2-by-2 pivot block D(k): columns k and k-1 now hold
+*
+* ( W(k-1) W(k) ) = ( U(k-1) U(k) )*D(k)
+*
+* where U(k) and U(k-1) are the k-th and (k-1)-th columns
+* of U
+*
+* Perform a rank-2 update of A(1:k-2,1:k-2) as
+*
+* A := A - ( U(k-1) U(k) )*D(k)*( U(k-1) U(k) )'
+* = A - ( W(k-1) W(k) )*inv(D(k))*( W(k-1) W(k) )'
+*
+ IF( K.GT.2 ) THEN
+*
+ D12 = A( K-1, K )
+ D22 = A( K-1, K-1 ) / D12
+ D11 = A( K, K ) / D12
+ T = ONE / ( D11*D22-ONE )
+ D12 = T / D12
+*
+ DO 30 J = K - 2, 1, -1
+ WKM1 = D12*( D11*A( J, K-1 )-A( J, K ) )
+ WK = D12*( D22*A( J, K )-A( J, K-1 ) )
+ DO 20 I = J, 1, -1
+ A( I, J ) = A( I, J ) - A( I, K )*WK -
+ $ A( I, K-1 )*WKM1
+ 20 CONTINUE
+ A( J, K ) = WK
+ A( J, K-1 ) = WKM1
+ 30 CONTINUE
+*
+ END IF
+*
+ END IF
+ END IF
+*
+* Store details of the interchanges in IPIV
+*
+ IF( KSTEP.EQ.1 ) THEN
+ IPIV( K ) = KP
+ ELSE
+ IPIV( K ) = -KP
+ IPIV( K-1 ) = -KP
+ END IF
+*
+* Decrease K and return to the start of the main loop
+*
+ K = K - KSTEP
+ GO TO 10
+*
+ ELSE
+*
+* Factorize A as L*D*L' using the lower triangle of A
+*
+* K is the main loop index, increasing from 1 to N in steps of
+* 1 or 2
+*
+ K = 1
+ 40 CONTINUE
+*
+* If K > N, exit from loop
+*
+ IF( K.GT.N )
+ $ GO TO 70
+ KSTEP = 1
+*
+* Determine rows and columns to be interchanged and whether
+* a 1-by-1 or 2-by-2 pivot block will be used
+*
+ ABSAKK = ABS( A( K, K ) )
+*
+* IMAX is the row-index of the largest off-diagonal element in
+* column K, and COLMAX is its absolute value
+*
+ IF( K.LT.N ) THEN
+ IMAX = K + ISAMAX( N-K, A( K+1, K ), 1 )
+ COLMAX = ABS( A( IMAX, K ) )
+ ELSE
+ COLMAX = ZERO
+ END IF
+*
+ IF( (MAX( ABSAKK, COLMAX ).EQ.ZERO) .OR. SISNAN(ABSAKK) ) THEN
+*
+* Column K is zero or contains a NaN: set INFO and continue
+*
+ IF( INFO.EQ.0 )
+ $ INFO = K
+ KP = K
+ ELSE
+ IF( ABSAKK.GE.ALPHA*COLMAX ) THEN
+*
+* no interchange, use 1-by-1 pivot block
+*
+ KP = K
+ ELSE
+*
+* JMAX is the column-index of the largest off-diagonal
+* element in row IMAX, and ROWMAX is its absolute value
+*
+ JMAX = K - 1 + ISAMAX( IMAX-K, A( IMAX, K ), LDA )
+ ROWMAX = ABS( A( IMAX, JMAX ) )
+ IF( IMAX.LT.N ) THEN
+ JMAX = IMAX + ISAMAX( N-IMAX, A( IMAX+1, IMAX ), 1 )
+ ROWMAX = MAX( ROWMAX, ABS( A( JMAX, IMAX ) ) )
+ END IF
+*
+ IF( ABSAKK.GE.ALPHA*COLMAX*( COLMAX / ROWMAX ) ) THEN
+*
+* no interchange, use 1-by-1 pivot block
+*
+ KP = K
+ ELSE IF( ABS( A( IMAX, IMAX ) ).GE.ALPHA*ROWMAX ) THEN
+*
+* interchange rows and columns K and IMAX, use 1-by-1
+* pivot block
+*
+ KP = IMAX
+ ELSE
+*
+* interchange rows and columns K+1 and IMAX, use 2-by-2
+* pivot block
+*
+ KP = IMAX
+ KSTEP = 2
+ END IF
+ END IF
+*
+ KK = K + KSTEP - 1
+ IF( KP.NE.KK ) THEN
+*
+* Interchange rows and columns KK and KP in the trailing
+* submatrix A(k:n,k:n)
+*
+ IF( KP.LT.N )
+ $ CALL SSWAP( N-KP, A( KP+1, KK ), 1, A( KP+1, KP ), 1 )
+ CALL SSWAP( KP-KK-1, A( KK+1, KK ), 1, A( KP, KK+1 ),
+ $ LDA )
+ T = A( KK, KK )
+ A( KK, KK ) = A( KP, KP )
+ A( KP, KP ) = T
+ IF( KSTEP.EQ.2 ) THEN
+ T = A( K+1, K )
+ A( K+1, K ) = A( KP, K )
+ A( KP, K ) = T
+ END IF
+ END IF
+*
+* Update the trailing submatrix
+*
+ IF( KSTEP.EQ.1 ) THEN
+*
+* 1-by-1 pivot block D(k): column k now holds
+*
+* W(k) = L(k)*D(k)
+*
+* where L(k) is the k-th column of L
+*
+ IF( K.LT.N ) THEN
+*
+* Perform a rank-1 update of A(k+1:n,k+1:n) as
+*
+* A := A - L(k)*D(k)*L(k)' = A - W(k)*(1/D(k))*W(k)'
+*
+ D11 = ONE / A( K, K )
+ CALL SSYR( UPLO, N-K, -D11, A( K+1, K ), 1,
+ $ A( K+1, K+1 ), LDA )
+*
+* Store L(k) in column K
+*
+ CALL SSCAL( N-K, D11, A( K+1, K ), 1 )
+ END IF
+ ELSE
+*
+* 2-by-2 pivot block D(k)
+*
+ IF( K.LT.N-1 ) THEN
+*
+* Perform a rank-2 update of A(k+2:n,k+2:n) as
+*
+* A := A - ( (A(k) A(k+1))*D(k)**(-1) ) * (A(k) A(k+1))'
+*
+* where L(k) and L(k+1) are the k-th and (k+1)-th
+* columns of L
+*
+ D21 = A( K+1, K )
+ D11 = A( K+1, K+1 ) / D21
+ D22 = A( K, K ) / D21
+ T = ONE / ( D11*D22-ONE )
+ D21 = T / D21
+*
+ DO 60 J = K + 2, N
+*
+ WK = D21*( D11*A( J, K )-A( J, K+1 ) )
+ WKP1 = D21*( D22*A( J, K+1 )-A( J, K ) )
+*
+ DO 50 I = J, N
+ A( I, J ) = A( I, J ) - A( I, K )*WK -
+ $ A( I, K+1 )*WKP1
+ 50 CONTINUE
+*
+ A( J, K ) = WK
+ A( J, K+1 ) = WKP1
+*
+ 60 CONTINUE
+ END IF
+ END IF
+ END IF
+*
+* Store details of the interchanges in IPIV
+*
+ IF( KSTEP.EQ.1 ) THEN
+ IPIV( K ) = KP
+ ELSE
+ IPIV( K ) = -KP
+ IPIV( K+1 ) = -KP
+ END IF
+*
+* Increase K and return to the start of the main loop
+*
+ K = K + KSTEP
+ GO TO 40
+*
+ END IF
+*
+ 70 CONTINUE
+*
+ RETURN
+*
+* End of SSYTF2
+*
+ END
+ SUBROUTINE SSYTRD( UPLO, N, A, LDA, D, E, TAU, WORK, LWORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, LDA, LWORK, N
+* ..
+* .. Array Arguments ..
+ REAL A( LDA, * ), D( * ), E( * ), TAU( * ),
+ $ WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SSYTRD reduces a real symmetric matrix A to real symmetric
+* tridiagonal form T by an orthogonal similarity transformation:
+* Q**T * A * Q = T.
+*
+* Arguments
+* =========
+*
+* UPLO (input) CHARACTER*1
+* = 'U': Upper triangle of A is stored;
+* = 'L': Lower triangle of A is stored.
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* A (input/output) REAL array, dimension (LDA,N)
+* On entry, the symmetric matrix A. If UPLO = 'U', the leading
+* N-by-N upper triangular part of A contains the upper
+* triangular part of the matrix A, and the strictly lower
+* triangular part of A is not referenced. If UPLO = 'L', the
+* leading N-by-N lower triangular part of A contains the lower
+* triangular part of the matrix A, and the strictly upper
+* triangular part of A is not referenced.
+* On exit, if UPLO = 'U', the diagonal and first superdiagonal
+* of A are overwritten by the corresponding elements of the
+* tridiagonal matrix T, and the elements above the first
+* superdiagonal, with the array TAU, represent the orthogonal
+* matrix Q as a product of elementary reflectors; if UPLO
+* = 'L', the diagonal and first subdiagonal of A are over-
+* written by the corresponding elements of the tridiagonal
+* matrix T, and the elements below the first subdiagonal, with
+* the array TAU, represent the orthogonal matrix Q as a product
+* of elementary reflectors. See Further Details.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,N).
+*
+* D (output) REAL array, dimension (N)
+* The diagonal elements of the tridiagonal matrix T:
+* D(i) = A(i,i).
+*
+* E (output) REAL array, dimension (N-1)
+* The off-diagonal elements of the tridiagonal matrix T:
+* E(i) = A(i,i+1) if UPLO = 'U', E(i) = A(i+1,i) if UPLO = 'L'.
+*
+* TAU (output) REAL array, dimension (N-1)
+* The scalar factors of the elementary reflectors (see Further
+* Details).
+*
+* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))
+* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+* LWORK (input) INTEGER
+* The dimension of the array WORK. LWORK >= 1.
+* For optimum performance LWORK >= N*NB, where NB is the
+* optimal blocksize.
+*
+* If LWORK = -1, then a workspace query is assumed; the routine
+* only calculates the optimal size of the WORK array, returns
+* this value as the first entry of the WORK array, and no error
+* message related to LWORK is issued by XERBLA.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+*
+* Further Details
+* ===============
+*
+* If UPLO = 'U', the matrix Q is represented as a product of elementary
+* reflectors
+*
+* Q = H(n-1) . . . H(2) H(1).
+*
+* Each H(i) has the form
+*
+* H(i) = I - tau * v * v'
+*
+* where tau is a real scalar, and v is a real vector with
+* v(i+1:n) = 0 and v(i) = 1; v(1:i-1) is stored on exit in
+* A(1:i-1,i+1), and tau in TAU(i).
+*
+* If UPLO = 'L', the matrix Q is represented as a product of elementary
+* reflectors
+*
+* Q = H(1) H(2) . . . H(n-1).
+*
+* Each H(i) has the form
+*
+* H(i) = I - tau * v * v'
+*
+* where tau is a real scalar, and v is a real vector with
+* v(1:i) = 0 and v(i+1) = 1; v(i+2:n) is stored on exit in A(i+2:n,i),
+* and tau in TAU(i).
+*
+* The contents of A on exit are illustrated by the following examples
+* with n = 5:
+*
+* if UPLO = 'U': if UPLO = 'L':
+*
+* ( d e v2 v3 v4 ) ( d )
+* ( d e v3 v4 ) ( e d )
+* ( d e v4 ) ( v1 e d )
+* ( d e ) ( v1 v2 e d )
+* ( d ) ( v1 v2 v3 e d )
+*
+* where d and e denote diagonal and off-diagonal elements of T, and vi
+* denotes an element of the vector defining H(i).
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ONE
+ PARAMETER ( ONE = 1.0E+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL LQUERY, UPPER
+ INTEGER I, IINFO, IWS, J, KK, LDWORK, LWKOPT, NB,
+ $ NBMIN, NX
+* ..
+* .. External Subroutines ..
+ EXTERNAL SLATRD, SSYR2K, SSYTD2, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ILAENV
+ EXTERNAL LSAME, ILAENV
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ LQUERY = ( LWORK.EQ.-1 )
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -4
+ ELSE IF( LWORK.LT.1 .AND. .NOT.LQUERY ) THEN
+ INFO = -9
+ END IF
+*
+ IF( INFO.EQ.0 ) THEN
+*
+* Determine the block size.
+*
+ NB = ILAENV( 1, 'SSYTRD', UPLO, N, -1, -1, -1 )
+ LWKOPT = N*NB
+ WORK( 1 ) = LWKOPT
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SSYTRD', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 ) THEN
+ WORK( 1 ) = 1
+ RETURN
+ END IF
+*
+ NX = N
+ IWS = 1
+ IF( NB.GT.1 .AND. NB.LT.N ) THEN
+*
+* Determine when to cross over from blocked to unblocked code
+* (last block is always handled by unblocked code).
+*
+ NX = MAX( NB, ILAENV( 3, 'SSYTRD', UPLO, N, -1, -1, -1 ) )
+ IF( NX.LT.N ) THEN
+*
+* Determine if workspace is large enough for blocked code.
+*
+ LDWORK = N
+ IWS = LDWORK*NB
+ IF( LWORK.LT.IWS ) THEN
+*
+* Not enough workspace to use optimal NB: determine the
+* minimum value of NB, and reduce NB or force use of
+* unblocked code by setting NX = N.
+*
+ NB = MAX( LWORK / LDWORK, 1 )
+ NBMIN = ILAENV( 2, 'SSYTRD', UPLO, N, -1, -1, -1 )
+ IF( NB.LT.NBMIN )
+ $ NX = N
+ END IF
+ ELSE
+ NX = N
+ END IF
+ ELSE
+ NB = 1
+ END IF
+*
+ IF( UPPER ) THEN
+*
+* Reduce the upper triangle of A.
+* Columns 1:kk are handled by the unblocked method.
+*
+ KK = N - ( ( N-NX+NB-1 ) / NB )*NB
+ DO 20 I = N - NB + 1, KK + 1, -NB
+*
+* Reduce columns i:i+nb-1 to tridiagonal form and form the
+* matrix W which is needed to update the unreduced part of
+* the matrix
+*
+ CALL SLATRD( UPLO, I+NB-1, NB, A, LDA, E, TAU, WORK,
+ $ LDWORK )
+*
+* Update the unreduced submatrix A(1:i-1,1:i-1), using an
+* update of the form: A := A - V*W' - W*V'
+*
+ CALL SSYR2K( UPLO, 'No transpose', I-1, NB, -ONE, A( 1, I ),
+ $ LDA, WORK, LDWORK, ONE, A, LDA )
+*
+* Copy superdiagonal elements back into A, and diagonal
+* elements into D
+*
+ DO 10 J = I, I + NB - 1
+ A( J-1, J ) = E( J-1 )
+ D( J ) = A( J, J )
+ 10 CONTINUE
+ 20 CONTINUE
+*
+* Use unblocked code to reduce the last or only block
+*
+ CALL SSYTD2( UPLO, KK, A, LDA, D, E, TAU, IINFO )
+ ELSE
+*
+* Reduce the lower triangle of A
+*
+ DO 40 I = 1, N - NX, NB
+*
+* Reduce columns i:i+nb-1 to tridiagonal form and form the
+* matrix W which is needed to update the unreduced part of
+* the matrix
+*
+ CALL SLATRD( UPLO, N-I+1, NB, A( I, I ), LDA, E( I ),
+ $ TAU( I ), WORK, LDWORK )
+*
+* Update the unreduced submatrix A(i+ib:n,i+ib:n), using
+* an update of the form: A := A - V*W' - W*V'
+*
+ CALL SSYR2K( UPLO, 'No transpose', N-I-NB+1, NB, -ONE,
+ $ A( I+NB, I ), LDA, WORK( NB+1 ), LDWORK, ONE,
+ $ A( I+NB, I+NB ), LDA )
+*
+* Copy subdiagonal elements back into A, and diagonal
+* elements into D
+*
+ DO 30 J = I, I + NB - 1
+ A( J+1, J ) = E( J )
+ D( J ) = A( J, J )
+ 30 CONTINUE
+ 40 CONTINUE
+*
+* Use unblocked code to reduce the last or only block
+*
+ CALL SSYTD2( UPLO, N-I+1, A( I, I ), LDA, D( I ), E( I ),
+ $ TAU( I ), IINFO )
+ END IF
+*
+ WORK( 1 ) = LWKOPT
+ RETURN
+*
+* End of SSYTRD
+*
+ END
+ SUBROUTINE SSYTRF( UPLO, N, A, LDA, IPIV, WORK, LWORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, LDA, LWORK, N
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ REAL A( LDA, * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SSYTRF computes the factorization of a real symmetric matrix A using
+* the Bunch-Kaufman diagonal pivoting method. The form of the
+* factorization is
+*
+* A = U*D*U**T or A = L*D*L**T
+*
+* where U (or L) is a product of permutation and unit upper (lower)
+* triangular matrices, and D is symmetric and block diagonal with
+* 1-by-1 and 2-by-2 diagonal blocks.
+*
+* This is the blocked version of the algorithm, calling Level 3 BLAS.
+*
+* Arguments
+* =========
+*
+* UPLO (input) CHARACTER*1
+* = 'U': Upper triangle of A is stored;
+* = 'L': Lower triangle of A is stored.
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* A (input/output) REAL array, dimension (LDA,N)
+* On entry, the symmetric matrix A. If UPLO = 'U', the leading
+* N-by-N upper triangular part of A contains the upper
+* triangular part of the matrix A, and the strictly lower
+* triangular part of A is not referenced. If UPLO = 'L', the
+* leading N-by-N lower triangular part of A contains the lower
+* triangular part of the matrix A, and the strictly upper
+* triangular part of A is not referenced.
+*
+* On exit, the block diagonal matrix D and the multipliers used
+* to obtain the factor U or L (see below for further details).
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,N).
+*
+* IPIV (output) INTEGER array, dimension (N)
+* Details of the interchanges and the block structure of D.
+* If IPIV(k) > 0, then rows and columns k and IPIV(k) were
+* interchanged and D(k,k) is a 1-by-1 diagonal block.
+* If UPLO = 'U' and IPIV(k) = IPIV(k-1) < 0, then rows and
+* columns k-1 and -IPIV(k) were interchanged and D(k-1:k,k-1:k)
+* is a 2-by-2 diagonal block. If UPLO = 'L' and IPIV(k) =
+* IPIV(k+1) < 0, then rows and columns k+1 and -IPIV(k) were
+* interchanged and D(k:k+1,k:k+1) is a 2-by-2 diagonal block.
+*
+* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))
+* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+* LWORK (input) INTEGER
+* The length of WORK. LWORK >=1. For best performance
+* LWORK >= N*NB, where NB is the block size returned by ILAENV.
+*
+* If LWORK = -1, then a workspace query is assumed; the routine
+* only calculates the optimal size of the WORK array, returns
+* this value as the first entry of the WORK array, and no error
+* message related to LWORK is issued by XERBLA.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* > 0: if INFO = i, D(i,i) is exactly zero. The factorization
+* has been completed, but the block diagonal matrix D is
+* exactly singular, and division by zero will occur if it
+* is used to solve a system of equations.
+*
+* Further Details
+* ===============
+*
+* If UPLO = 'U', then A = U*D*U', where
+* U = P(n)*U(n)* ... *P(k)U(k)* ...,
+* i.e., U is a product of terms P(k)*U(k), where k decreases from n to
+* 1 in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1
+* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as
+* defined by IPIV(k), and U(k) is a unit upper triangular matrix, such
+* that if the diagonal block D(k) is of order s (s = 1 or 2), then
+*
+* ( I v 0 ) k-s
+* U(k) = ( 0 I 0 ) s
+* ( 0 0 I ) n-k
+* k-s s n-k
+*
+* If s = 1, D(k) overwrites A(k,k), and v overwrites A(1:k-1,k).
+* If s = 2, the upper triangle of D(k) overwrites A(k-1,k-1), A(k-1,k),
+* and A(k,k), and v overwrites A(1:k-2,k-1:k).
+*
+* If UPLO = 'L', then A = L*D*L', where
+* L = P(1)*L(1)* ... *P(k)*L(k)* ...,
+* i.e., L is a product of terms P(k)*L(k), where k increases from 1 to
+* n in steps of 1 or 2, and D is a block diagonal matrix with 1-by-1
+* and 2-by-2 diagonal blocks D(k). P(k) is a permutation matrix as
+* defined by IPIV(k), and L(k) is a unit lower triangular matrix, such
+* that if the diagonal block D(k) is of order s (s = 1 or 2), then
+*
+* ( I 0 0 ) k-1
+* L(k) = ( 0 I 0 ) s
+* ( 0 v I ) n-k-s+1
+* k-1 s n-k-s+1
+*
+* If s = 1, D(k) overwrites A(k,k), and v overwrites A(k+1:n,k).
+* If s = 2, the lower triangle of D(k) overwrites A(k,k), A(k+1,k),
+* and A(k+1,k+1), and v overwrites A(k+2:n,k:k+1).
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ LOGICAL LQUERY, UPPER
+ INTEGER IINFO, IWS, J, K, KB, LDWORK, LWKOPT, NB, NBMIN
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ILAENV
+ EXTERNAL LSAME, ILAENV
+* ..
+* .. External Subroutines ..
+ EXTERNAL SLASYF, SSYTF2, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ LQUERY = ( LWORK.EQ.-1 )
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -4
+ ELSE IF( LWORK.LT.1 .AND. .NOT.LQUERY ) THEN
+ INFO = -7
+ END IF
+*
+ IF( INFO.EQ.0 ) THEN
+*
+* Determine the block size
+*
+ NB = ILAENV( 1, 'SSYTRF', UPLO, N, -1, -1, -1 )
+ LWKOPT = N*NB
+ WORK( 1 ) = LWKOPT
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SSYTRF', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+ NBMIN = 2
+ LDWORK = N
+ IF( NB.GT.1 .AND. NB.LT.N ) THEN
+ IWS = LDWORK*NB
+ IF( LWORK.LT.IWS ) THEN
+ NB = MAX( LWORK / LDWORK, 1 )
+ NBMIN = MAX( 2, ILAENV( 2, 'SSYTRF', UPLO, N, -1, -1, -1 ) )
+ END IF
+ ELSE
+ IWS = 1
+ END IF
+ IF( NB.LT.NBMIN )
+ $ NB = N
+*
+ IF( UPPER ) THEN
+*
+* Factorize A as U*D*U' using the upper triangle of A
+*
+* K is the main loop index, decreasing from N to 1 in steps of
+* KB, where KB is the number of columns factorized by SLASYF;
+* KB is either NB or NB-1, or K for the last block
+*
+ K = N
+ 10 CONTINUE
+*
+* If K < 1, exit from loop
+*
+ IF( K.LT.1 )
+ $ GO TO 40
+*
+ IF( K.GT.NB ) THEN
+*
+* Factorize columns k-kb+1:k of A and use blocked code to
+* update columns 1:k-kb
+*
+ CALL SLASYF( UPLO, K, NB, KB, A, LDA, IPIV, WORK, LDWORK,
+ $ IINFO )
+ ELSE
+*
+* Use unblocked code to factorize columns 1:k of A
+*
+ CALL SSYTF2( UPLO, K, A, LDA, IPIV, IINFO )
+ KB = K
+ END IF
+*
+* Set INFO on the first occurrence of a zero pivot
+*
+ IF( INFO.EQ.0 .AND. IINFO.GT.0 )
+ $ INFO = IINFO
+*
+* Decrease K and return to the start of the main loop
+*
+ K = K - KB
+ GO TO 10
+*
+ ELSE
+*
+* Factorize A as L*D*L' using the lower triangle of A
+*
+* K is the main loop index, increasing from 1 to N in steps of
+* KB, where KB is the number of columns factorized by SLASYF;
+* KB is either NB or NB-1, or N-K+1 for the last block
+*
+ K = 1
+ 20 CONTINUE
+*
+* If K > N, exit from loop
+*
+ IF( K.GT.N )
+ $ GO TO 40
+*
+ IF( K.LE.N-NB ) THEN
+*
+* Factorize columns k:k+kb-1 of A and use blocked code to
+* update columns k+kb:n
+*
+ CALL SLASYF( UPLO, N-K+1, NB, KB, A( K, K ), LDA, IPIV( K ),
+ $ WORK, LDWORK, IINFO )
+ ELSE
+*
+* Use unblocked code to factorize columns k:n of A
+*
+ CALL SSYTF2( UPLO, N-K+1, A( K, K ), LDA, IPIV( K ), IINFO )
+ KB = N - K + 1
+ END IF
+*
+* Set INFO on the first occurrence of a zero pivot
+*
+ IF( INFO.EQ.0 .AND. IINFO.GT.0 )
+ $ INFO = IINFO + K - 1
+*
+* Adjust IPIV
+*
+ DO 30 J = K, K + KB - 1
+ IF( IPIV( J ).GT.0 ) THEN
+ IPIV( J ) = IPIV( J ) + K - 1
+ ELSE
+ IPIV( J ) = IPIV( J ) - K + 1
+ END IF
+ 30 CONTINUE
+*
+* Increase K and return to the start of the main loop
+*
+ K = K + KB
+ GO TO 20
+*
+ END IF
+*
+ 40 CONTINUE
+ WORK( 1 ) = LWKOPT
+ RETURN
+*
+* End of SSYTRF
+*
+ END
+ SUBROUTINE SSYTRI( UPLO, N, A, LDA, IPIV, WORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, LDA, N
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ REAL A( LDA, * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* SSYTRI computes the inverse of a real symmetric indefinite matrix
+* A using the factorization A = U*D*U**T or A = L*D*L**T computed by
+* SSYTRF.
+*
+* Arguments
+* =========
+*
+* UPLO (input) CHARACTER*1
+* Specifies whether the details of the factorization are stored
+* as an upper or lower triangular matrix.
+* = 'U': Upper triangular, form is A = U*D*U**T;
+* = 'L': Lower triangular, form is A = L*D*L**T.
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* A (input/output) REAL array, dimension (LDA,N)
+* On entry, the block diagonal matrix D and the multipliers
+* used to obtain the factor U or L as computed by SSYTRF.
+*
+* On exit, if INFO = 0, the (symmetric) inverse of the original
+* matrix. If UPLO = 'U', the upper triangular part of the
+* inverse is formed and the part of A below the diagonal is not
+* referenced; if UPLO = 'L' the lower triangular part of the
+* inverse is formed and the part of A above the diagonal is
+* not referenced.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,N).
+*
+* IPIV (input) INTEGER array, dimension (N)
+* Details of the interchanges and the block structure of D
+* as determined by SSYTRF.
+*
+* WORK (workspace) REAL array, dimension (N)
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* > 0: if INFO = i, D(i,i) = 0; the matrix is singular and its
+* inverse could not be computed.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ONE, ZERO
+ PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL UPPER
+ INTEGER K, KP, KSTEP
+ REAL AK, AKKP1, AKP1, D, T, TEMP
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ REAL SDOT
+ EXTERNAL LSAME, SDOT
+* ..
+* .. External Subroutines ..
+ EXTERNAL SCOPY, SSWAP, SSYMV, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -4
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SSYTRI', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+* Check that the diagonal matrix D is nonsingular.
+*
+ IF( UPPER ) THEN
+*
+* Upper triangular storage: examine D from bottom to top
+*
+ DO 10 INFO = N, 1, -1
+ IF( IPIV( INFO ).GT.0 .AND. A( INFO, INFO ).EQ.ZERO )
+ $ RETURN
+ 10 CONTINUE
+ ELSE
+*
+* Lower triangular storage: examine D from top to bottom.
+*
+ DO 20 INFO = 1, N
+ IF( IPIV( INFO ).GT.0 .AND. A( INFO, INFO ).EQ.ZERO )
+ $ RETURN
+ 20 CONTINUE
+ END IF
+ INFO = 0
+*
+ IF( UPPER ) THEN
+*
+* Compute inv(A) from the factorization A = U*D*U'.
+*
+* K is the main loop index, increasing from 1 to N in steps of
+* 1 or 2, depending on the size of the diagonal blocks.
+*
+ K = 1
+ 30 CONTINUE
+*
+* If K > N, exit from loop.
+*
+ IF( K.GT.N )
+ $ GO TO 40
+*
+ IF( IPIV( K ).GT.0 ) THEN
+*
+* 1 x 1 diagonal block
+*
+* Invert the diagonal block.
+*
+ A( K, K ) = ONE / A( K, K )
+*
+* Compute column K of the inverse.
+*
+ IF( K.GT.1 ) THEN
+ CALL SCOPY( K-1, A( 1, K ), 1, WORK, 1 )
+ CALL SSYMV( UPLO, K-1, -ONE, A, LDA, WORK, 1, ZERO,
+ $ A( 1, K ), 1 )
+ A( K, K ) = A( K, K ) - SDOT( K-1, WORK, 1, A( 1, K ),
+ $ 1 )
+ END IF
+ KSTEP = 1
+ ELSE
+*
+* 2 x 2 diagonal block
+*
+* Invert the diagonal block.
+*
+ T = ABS( A( K, K+1 ) )
+ AK = A( K, K ) / T
+ AKP1 = A( K+1, K+1 ) / T
+ AKKP1 = A( K, K+1 ) / T
+ D = T*( AK*AKP1-ONE )
+ A( K, K ) = AKP1 / D
+ A( K+1, K+1 ) = AK / D
+ A( K, K+1 ) = -AKKP1 / D
+*
+* Compute columns K and K+1 of the inverse.
+*
+ IF( K.GT.1 ) THEN
+ CALL SCOPY( K-1, A( 1, K ), 1, WORK, 1 )
+ CALL SSYMV( UPLO, K-1, -ONE, A, LDA, WORK, 1, ZERO,
+ $ A( 1, K ), 1 )
+ A( K, K ) = A( K, K ) - SDOT( K-1, WORK, 1, A( 1, K ),
+ $ 1 )
+ A( K, K+1 ) = A( K, K+1 ) -
+ $ SDOT( K-1, A( 1, K ), 1, A( 1, K+1 ), 1 )
+ CALL SCOPY( K-1, A( 1, K+1 ), 1, WORK, 1 )
+ CALL SSYMV( UPLO, K-1, -ONE, A, LDA, WORK, 1, ZERO,
+ $ A( 1, K+1 ), 1 )
+ A( K+1, K+1 ) = A( K+1, K+1 ) -
+ $ SDOT( K-1, WORK, 1, A( 1, K+1 ), 1 )
+ END IF
+ KSTEP = 2
+ END IF
+*
+ KP = ABS( IPIV( K ) )
+ IF( KP.NE.K ) THEN
+*
+* Interchange rows and columns K and KP in the leading
+* submatrix A(1:k+1,1:k+1)
+*
+ CALL SSWAP( KP-1, A( 1, K ), 1, A( 1, KP ), 1 )
+ CALL SSWAP( K-KP-1, A( KP+1, K ), 1, A( KP, KP+1 ), LDA )
+ TEMP = A( K, K )
+ A( K, K ) = A( KP, KP )
+ A( KP, KP ) = TEMP
+ IF( KSTEP.EQ.2 ) THEN
+ TEMP = A( K, K+1 )
+ A( K, K+1 ) = A( KP, K+1 )
+ A( KP, K+1 ) = TEMP
+ END IF
+ END IF
+*
+ K = K + KSTEP
+ GO TO 30
+ 40 CONTINUE
+*
+ ELSE
+*
+* Compute inv(A) from the factorization A = L*D*L'.
+*
+* K is the main loop index, increasing from 1 to N in steps of
+* 1 or 2, depending on the size of the diagonal blocks.
+*
+ K = N
+ 50 CONTINUE
+*
+* If K < 1, exit from loop.
+*
+ IF( K.LT.1 )
+ $ GO TO 60
+*
+ IF( IPIV( K ).GT.0 ) THEN
+*
+* 1 x 1 diagonal block
+*
+* Invert the diagonal block.
+*
+ A( K, K ) = ONE / A( K, K )
+*
+* Compute column K of the inverse.
+*
+ IF( K.LT.N ) THEN
+ CALL SCOPY( N-K, A( K+1, K ), 1, WORK, 1 )
+ CALL SSYMV( UPLO, N-K, -ONE, A( K+1, K+1 ), LDA, WORK, 1,
+ $ ZERO, A( K+1, K ), 1 )
+ A( K, K ) = A( K, K ) - SDOT( N-K, WORK, 1, A( K+1, K ),
+ $ 1 )
+ END IF
+ KSTEP = 1
+ ELSE
+*
+* 2 x 2 diagonal block
+*
+* Invert the diagonal block.
+*
+ T = ABS( A( K, K-1 ) )
+ AK = A( K-1, K-1 ) / T
+ AKP1 = A( K, K ) / T
+ AKKP1 = A( K, K-1 ) / T
+ D = T*( AK*AKP1-ONE )
+ A( K-1, K-1 ) = AKP1 / D
+ A( K, K ) = AK / D
+ A( K, K-1 ) = -AKKP1 / D
+*
+* Compute columns K-1 and K of the inverse.
+*
+ IF( K.LT.N ) THEN
+ CALL SCOPY( N-K, A( K+1, K ), 1, WORK, 1 )
+ CALL SSYMV( UPLO, N-K, -ONE, A( K+1, K+1 ), LDA, WORK, 1,
+ $ ZERO, A( K+1, K ), 1 )
+ A( K, K ) = A( K, K ) - SDOT( N-K, WORK, 1, A( K+1, K ),
+ $ 1 )
+ A( K, K-1 ) = A( K, K-1 ) -
+ $ SDOT( N-K, A( K+1, K ), 1, A( K+1, K-1 ),
+ $ 1 )
+ CALL SCOPY( N-K, A( K+1, K-1 ), 1, WORK, 1 )
+ CALL SSYMV( UPLO, N-K, -ONE, A( K+1, K+1 ), LDA, WORK, 1,
+ $ ZERO, A( K+1, K-1 ), 1 )
+ A( K-1, K-1 ) = A( K-1, K-1 ) -
+ $ SDOT( N-K, WORK, 1, A( K+1, K-1 ), 1 )
+ END IF
+ KSTEP = 2
+ END IF
+*
+ KP = ABS( IPIV( K ) )
+ IF( KP.NE.K ) THEN
+*
+* Interchange rows and columns K and KP in the trailing
+* submatrix A(k-1:n,k-1:n)
+*
+ IF( KP.LT.N )
+ $ CALL SSWAP( N-KP, A( KP+1, K ), 1, A( KP+1, KP ), 1 )
+ CALL SSWAP( KP-K-1, A( K+1, K ), 1, A( KP, K+1 ), LDA )
+ TEMP = A( K, K )
+ A( K, K ) = A( KP, KP )
+ A( KP, KP ) = TEMP
+ IF( KSTEP.EQ.2 ) THEN
+ TEMP = A( K, K-1 )
+ A( K, K-1 ) = A( KP, K-1 )
+ A( KP, K-1 ) = TEMP
+ END IF
+ END IF
+*
+ K = K - KSTEP
+ GO TO 50
+ 60 CONTINUE
+ END IF
+*
+ RETURN
+*
+* End of SSYTRI
+*
+ END
+ SUBROUTINE SSYTRS( UPLO, N, NRHS, A, LDA, IPIV, B, LDB, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INFO, LDA, LDB, N, NRHS
+* ..
+* .. Array Arguments ..
+ INTEGER IPIV( * )
+ REAL A( LDA, * ), B( LDB, * )
+* ..
+*
+* Purpose
+* =======
+*
+* SSYTRS solves a system of linear equations A*X = B with a real
+* symmetric matrix A using the factorization A = U*D*U**T or
+* A = L*D*L**T computed by SSYTRF.
+*
+* Arguments
+* =========
+*
+* UPLO (input) CHARACTER*1
+* Specifies whether the details of the factorization are stored
+* as an upper or lower triangular matrix.
+* = 'U': Upper triangular, form is A = U*D*U**T;
+* = 'L': Lower triangular, form is A = L*D*L**T.
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* NRHS (input) INTEGER
+* The number of right hand sides, i.e., the number of columns
+* of the matrix B. NRHS >= 0.
+*
+* A (input) REAL array, dimension (LDA,N)
+* The block diagonal matrix D and the multipliers used to
+* obtain the factor U or L as computed by SSYTRF.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,N).
+*
+* IPIV (input) INTEGER array, dimension (N)
+* Details of the interchanges and the block structure of D
+* as determined by SSYTRF.
+*
+* B (input/output) REAL array, dimension (LDB,NRHS)
+* On entry, the right hand side matrix B.
+* On exit, the solution matrix X.
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. LDB >= max(1,N).
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ONE
+ PARAMETER ( ONE = 1.0E+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL UPPER
+ INTEGER J, K, KP
+ REAL AK, AKM1, AKM1K, BK, BKM1, DENOM
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL SGEMV, SGER, SSCAL, SSWAP, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( NRHS.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -5
+ ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -8
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'SSYTRS', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 .OR. NRHS.EQ.0 )
+ $ RETURN
+*
+ IF( UPPER ) THEN
+*
+* Solve A*X = B, where A = U*D*U'.
+*
+* First solve U*D*X = B, overwriting B with X.
+*
+* K is the main loop index, decreasing from N to 1 in steps of
+* 1 or 2, depending on the size of the diagonal blocks.
+*
+ K = N
+ 10 CONTINUE
+*
+* If K < 1, exit from loop.
+*
+ IF( K.LT.1 )
+ $ GO TO 30
+*
+ IF( IPIV( K ).GT.0 ) THEN
+*
+* 1 x 1 diagonal block
+*
+* Interchange rows K and IPIV(K).
+*
+ KP = IPIV( K )
+ IF( KP.NE.K )
+ $ CALL SSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+*
+* Multiply by inv(U(K)), where U(K) is the transformation
+* stored in column K of A.
+*
+ CALL SGER( K-1, NRHS, -ONE, A( 1, K ), 1, B( K, 1 ), LDB,
+ $ B( 1, 1 ), LDB )
+*
+* Multiply by the inverse of the diagonal block.
+*
+ CALL SSCAL( NRHS, ONE / A( K, K ), B( K, 1 ), LDB )
+ K = K - 1
+ ELSE
+*
+* 2 x 2 diagonal block
+*
+* Interchange rows K-1 and -IPIV(K).
+*
+ KP = -IPIV( K )
+ IF( KP.NE.K-1 )
+ $ CALL SSWAP( NRHS, B( K-1, 1 ), LDB, B( KP, 1 ), LDB )
+*
+* Multiply by inv(U(K)), where U(K) is the transformation
+* stored in columns K-1 and K of A.
+*
+ CALL SGER( K-2, NRHS, -ONE, A( 1, K ), 1, B( K, 1 ), LDB,
+ $ B( 1, 1 ), LDB )
+ CALL SGER( K-2, NRHS, -ONE, A( 1, K-1 ), 1, B( K-1, 1 ),
+ $ LDB, B( 1, 1 ), LDB )
+*
+* Multiply by the inverse of the diagonal block.
+*
+ AKM1K = A( K-1, K )
+ AKM1 = A( K-1, K-1 ) / AKM1K
+ AK = A( K, K ) / AKM1K
+ DENOM = AKM1*AK - ONE
+ DO 20 J = 1, NRHS
+ BKM1 = B( K-1, J ) / AKM1K
+ BK = B( K, J ) / AKM1K
+ B( K-1, J ) = ( AK*BKM1-BK ) / DENOM
+ B( K, J ) = ( AKM1*BK-BKM1 ) / DENOM
+ 20 CONTINUE
+ K = K - 2
+ END IF
+*
+ GO TO 10
+ 30 CONTINUE
+*
+* Next solve U'*X = B, overwriting B with X.
+*
+* K is the main loop index, increasing from 1 to N in steps of
+* 1 or 2, depending on the size of the diagonal blocks.
+*
+ K = 1
+ 40 CONTINUE
+*
+* If K > N, exit from loop.
+*
+ IF( K.GT.N )
+ $ GO TO 50
+*
+ IF( IPIV( K ).GT.0 ) THEN
+*
+* 1 x 1 diagonal block
+*
+* Multiply by inv(U'(K)), where U(K) is the transformation
+* stored in column K of A.
+*
+ CALL SGEMV( 'Transpose', K-1, NRHS, -ONE, B, LDB, A( 1, K ),
+ $ 1, ONE, B( K, 1 ), LDB )
+*
+* Interchange rows K and IPIV(K).
+*
+ KP = IPIV( K )
+ IF( KP.NE.K )
+ $ CALL SSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+ K = K + 1
+ ELSE
+*
+* 2 x 2 diagonal block
+*
+* Multiply by inv(U'(K+1)), where U(K+1) is the transformation
+* stored in columns K and K+1 of A.
+*
+ CALL SGEMV( 'Transpose', K-1, NRHS, -ONE, B, LDB, A( 1, K ),
+ $ 1, ONE, B( K, 1 ), LDB )
+ CALL SGEMV( 'Transpose', K-1, NRHS, -ONE, B, LDB,
+ $ A( 1, K+1 ), 1, ONE, B( K+1, 1 ), LDB )
+*
+* Interchange rows K and -IPIV(K).
+*
+ KP = -IPIV( K )
+ IF( KP.NE.K )
+ $ CALL SSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+ K = K + 2
+ END IF
+*
+ GO TO 40
+ 50 CONTINUE
+*
+ ELSE
+*
+* Solve A*X = B, where A = L*D*L'.
+*
+* First solve L*D*X = B, overwriting B with X.
+*
+* K is the main loop index, increasing from 1 to N in steps of
+* 1 or 2, depending on the size of the diagonal blocks.
+*
+ K = 1
+ 60 CONTINUE
+*
+* If K > N, exit from loop.
+*
+ IF( K.GT.N )
+ $ GO TO 80
+*
+ IF( IPIV( K ).GT.0 ) THEN
+*
+* 1 x 1 diagonal block
+*
+* Interchange rows K and IPIV(K).
+*
+ KP = IPIV( K )
+ IF( KP.NE.K )
+ $ CALL SSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+*
+* Multiply by inv(L(K)), where L(K) is the transformation
+* stored in column K of A.
+*
+ IF( K.LT.N )
+ $ CALL SGER( N-K, NRHS, -ONE, A( K+1, K ), 1, B( K, 1 ),
+ $ LDB, B( K+1, 1 ), LDB )
+*
+* Multiply by the inverse of the diagonal block.
+*
+ CALL SSCAL( NRHS, ONE / A( K, K ), B( K, 1 ), LDB )
+ K = K + 1
+ ELSE
+*
+* 2 x 2 diagonal block
+*
+* Interchange rows K+1 and -IPIV(K).
+*
+ KP = -IPIV( K )
+ IF( KP.NE.K+1 )
+ $ CALL SSWAP( NRHS, B( K+1, 1 ), LDB, B( KP, 1 ), LDB )
+*
+* Multiply by inv(L(K)), where L(K) is the transformation
+* stored in columns K and K+1 of A.
+*
+ IF( K.LT.N-1 ) THEN
+ CALL SGER( N-K-1, NRHS, -ONE, A( K+2, K ), 1, B( K, 1 ),
+ $ LDB, B( K+2, 1 ), LDB )
+ CALL SGER( N-K-1, NRHS, -ONE, A( K+2, K+1 ), 1,
+ $ B( K+1, 1 ), LDB, B( K+2, 1 ), LDB )
+ END IF
+*
+* Multiply by the inverse of the diagonal block.
+*
+ AKM1K = A( K+1, K )
+ AKM1 = A( K, K ) / AKM1K
+ AK = A( K+1, K+1 ) / AKM1K
+ DENOM = AKM1*AK - ONE
+ DO 70 J = 1, NRHS
+ BKM1 = B( K, J ) / AKM1K
+ BK = B( K+1, J ) / AKM1K
+ B( K, J ) = ( AK*BKM1-BK ) / DENOM
+ B( K+1, J ) = ( AKM1*BK-BKM1 ) / DENOM
+ 70 CONTINUE
+ K = K + 2
+ END IF
+*
+ GO TO 60
+ 80 CONTINUE
+*
+* Next solve L'*X = B, overwriting B with X.
+*
+* K is the main loop index, decreasing from N to 1 in steps of
+* 1 or 2, depending on the size of the diagonal blocks.
+*
+ K = N
+ 90 CONTINUE
+*
+* If K < 1, exit from loop.
+*
+ IF( K.LT.1 )
+ $ GO TO 100
+*
+ IF( IPIV( K ).GT.0 ) THEN
+*
+* 1 x 1 diagonal block
+*
+* Multiply by inv(L'(K)), where L(K) is the transformation
+* stored in column K of A.
+*
+ IF( K.LT.N )
+ $ CALL SGEMV( 'Transpose', N-K, NRHS, -ONE, B( K+1, 1 ),
+ $ LDB, A( K+1, K ), 1, ONE, B( K, 1 ), LDB )
+*
+* Interchange rows K and IPIV(K).
+*
+ KP = IPIV( K )
+ IF( KP.NE.K )
+ $ CALL SSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+ K = K - 1
+ ELSE
+*
+* 2 x 2 diagonal block
+*
+* Multiply by inv(L'(K-1)), where L(K-1) is the transformation
+* stored in columns K-1 and K of A.
+*
+ IF( K.LT.N ) THEN
+ CALL SGEMV( 'Transpose', N-K, NRHS, -ONE, B( K+1, 1 ),
+ $ LDB, A( K+1, K ), 1, ONE, B( K, 1 ), LDB )
+ CALL SGEMV( 'Transpose', N-K, NRHS, -ONE, B( K+1, 1 ),
+ $ LDB, A( K+1, K-1 ), 1, ONE, B( K-1, 1 ),
+ $ LDB )
+ END IF
+*
+* Interchange rows K and -IPIV(K).
+*
+ KP = -IPIV( K )
+ IF( KP.NE.K )
+ $ CALL SSWAP( NRHS, B( K, 1 ), LDB, B( KP, 1 ), LDB )
+ K = K - 2
+ END IF
+*
+ GO TO 90
+ 100 CONTINUE
+ END IF
+*
+ RETURN
+*
+* End of SSYTRS
+*
+ END
+ SUBROUTINE STBCON( NORM, UPLO, DIAG, N, KD, AB, LDAB, RCOND, WORK,
+ $ IWORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* Modified to call SLACN2 in place of SLACON, 7 Feb 03, SJH.
+*
+* .. Scalar Arguments ..
+ CHARACTER DIAG, NORM, UPLO
+ INTEGER INFO, KD, LDAB, N
+ REAL RCOND
+* ..
+* .. Array Arguments ..
+ INTEGER IWORK( * )
+ REAL AB( LDAB, * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* STBCON estimates the reciprocal of the condition number of a
+* triangular band matrix A, in either the 1-norm or the infinity-norm.
+*
+* The norm of A is computed and an estimate is obtained for
+* norm(inv(A)), then the reciprocal of the condition number is
+* computed as
+* RCOND = 1 / ( norm(A) * norm(inv(A)) ).
+*
+* Arguments
+* =========
+*
+* NORM (input) CHARACTER*1
+* Specifies whether the 1-norm condition number or the
+* infinity-norm condition number is required:
+* = '1' or 'O': 1-norm;
+* = 'I': Infinity-norm.
+*
+* UPLO (input) CHARACTER*1
+* = 'U': A is upper triangular;
+* = 'L': A is lower triangular.
+*
+* DIAG (input) CHARACTER*1
+* = 'N': A is non-unit triangular;
+* = 'U': A is unit triangular.
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* KD (input) INTEGER
+* The number of superdiagonals or subdiagonals of the
+* triangular band matrix A. KD >= 0.
+*
+* AB (input) REAL array, dimension (LDAB,N)
+* The upper or lower triangular band matrix A, stored in the
+* first kd+1 rows of the array. The j-th column of A is stored
+* in the j-th column of the array AB as follows:
+* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
+* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).
+* If DIAG = 'U', the diagonal elements of A are not referenced
+* and are assumed to be 1.
+*
+* LDAB (input) INTEGER
+* The leading dimension of the array AB. LDAB >= KD+1.
+*
+* RCOND (output) REAL
+* The reciprocal of the condition number of the matrix A,
+* computed as RCOND = 1/(norm(A) * norm(inv(A))).
+*
+* WORK (workspace) REAL array, dimension (3*N)
+*
+* IWORK (workspace) INTEGER array, dimension (N)
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ONE, ZERO
+ PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL NOUNIT, ONENRM, UPPER
+ CHARACTER NORMIN
+ INTEGER IX, KASE, KASE1
+ REAL AINVNM, ANORM, SCALE, SMLNUM, XNORM
+* ..
+* .. Local Arrays ..
+ INTEGER ISAVE( 3 )
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ISAMAX
+ REAL SLAMCH, SLANTB
+ EXTERNAL LSAME, ISAMAX, SLAMCH, SLANTB
+* ..
+* .. External Subroutines ..
+ EXTERNAL SLACN2, SLATBS, SRSCL, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, REAL
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ ONENRM = NORM.EQ.'1' .OR. LSAME( NORM, 'O' )
+ NOUNIT = LSAME( DIAG, 'N' )
+*
+ IF( .NOT.ONENRM .AND. .NOT.LSAME( NORM, 'I' ) ) THEN
+ INFO = -1
+ ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -2
+ ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
+ INFO = -3
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( KD.LT.0 ) THEN
+ INFO = -5
+ ELSE IF( LDAB.LT.KD+1 ) THEN
+ INFO = -7
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'STBCON', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 ) THEN
+ RCOND = ONE
+ RETURN
+ END IF
+*
+ RCOND = ZERO
+ SMLNUM = SLAMCH( 'Safe minimum' )*REAL( MAX( 1, N ) )
+*
+* Compute the norm of the triangular matrix A.
+*
+ ANORM = SLANTB( NORM, UPLO, DIAG, N, KD, AB, LDAB, WORK )
+*
+* Continue only if ANORM > 0.
+*
+ IF( ANORM.GT.ZERO ) THEN
+*
+* Estimate the norm of the inverse of A.
+*
+ AINVNM = ZERO
+ NORMIN = 'N'
+ IF( ONENRM ) THEN
+ KASE1 = 1
+ ELSE
+ KASE1 = 2
+ END IF
+ KASE = 0
+ 10 CONTINUE
+ CALL SLACN2( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE, ISAVE )
+ IF( KASE.NE.0 ) THEN
+ IF( KASE.EQ.KASE1 ) THEN
+*
+* Multiply by inv(A).
+*
+ CALL SLATBS( UPLO, 'No transpose', DIAG, NORMIN, N, KD,
+ $ AB, LDAB, WORK, SCALE, WORK( 2*N+1 ), INFO )
+ ELSE
+*
+* Multiply by inv(A').
+*
+ CALL SLATBS( UPLO, 'Transpose', DIAG, NORMIN, N, KD, AB,
+ $ LDAB, WORK, SCALE, WORK( 2*N+1 ), INFO )
+ END IF
+ NORMIN = 'Y'
+*
+* Multiply by 1/SCALE if doing so will not cause overflow.
+*
+ IF( SCALE.NE.ONE ) THEN
+ IX = ISAMAX( N, WORK, 1 )
+ XNORM = ABS( WORK( IX ) )
+ IF( SCALE.LT.XNORM*SMLNUM .OR. SCALE.EQ.ZERO )
+ $ GO TO 20
+ CALL SRSCL( N, SCALE, WORK, 1 )
+ END IF
+ GO TO 10
+ END IF
+*
+* Compute the estimate of the reciprocal condition number.
+*
+ IF( AINVNM.NE.ZERO )
+ $ RCOND = ( ONE / ANORM ) / AINVNM
+ END IF
+*
+ 20 CONTINUE
+ RETURN
+*
+* End of STBCON
+*
+ END
+ SUBROUTINE STBRFS( UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, B,
+ $ LDB, X, LDX, FERR, BERR, WORK, IWORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* Modified to call SLACN2 in place of SLACON, 7 Feb 03, SJH.
+*
+* .. Scalar Arguments ..
+ CHARACTER DIAG, TRANS, UPLO
+ INTEGER INFO, KD, LDAB, LDB, LDX, N, NRHS
+* ..
+* .. Array Arguments ..
+ INTEGER IWORK( * )
+ REAL AB( LDAB, * ), B( LDB, * ), BERR( * ),
+ $ FERR( * ), WORK( * ), X( LDX, * )
+* ..
+*
+* Purpose
+* =======
+*
+* STBRFS provides error bounds and backward error estimates for the
+* solution to a system of linear equations with a triangular band
+* coefficient matrix.
+*
+* The solution matrix X must be computed by STBTRS or some other
+* means before entering this routine. STBRFS does not do iterative
+* refinement because doing so cannot improve the backward error.
+*
+* Arguments
+* =========
+*
+* UPLO (input) CHARACTER*1
+* = 'U': A is upper triangular;
+* = 'L': A is lower triangular.
+*
+* TRANS (input) CHARACTER*1
+* Specifies the form of the system of equations:
+* = 'N': A * X = B (No transpose)
+* = 'T': A**T * X = B (Transpose)
+* = 'C': A**H * X = B (Conjugate transpose = Transpose)
+*
+* DIAG (input) CHARACTER*1
+* = 'N': A is non-unit triangular;
+* = 'U': A is unit triangular.
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* KD (input) INTEGER
+* The number of superdiagonals or subdiagonals of the
+* triangular band matrix A. KD >= 0.
+*
+* NRHS (input) INTEGER
+* The number of right hand sides, i.e., the number of columns
+* of the matrices B and X. NRHS >= 0.
+*
+* AB (input) REAL array, dimension (LDAB,N)
+* The upper or lower triangular band matrix A, stored in the
+* first kd+1 rows of the array. The j-th column of A is stored
+* in the j-th column of the array AB as follows:
+* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
+* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).
+* If DIAG = 'U', the diagonal elements of A are not referenced
+* and are assumed to be 1.
+*
+* LDAB (input) INTEGER
+* The leading dimension of the array AB. LDAB >= KD+1.
+*
+* B (input) REAL array, dimension (LDB,NRHS)
+* The right hand side matrix B.
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. LDB >= max(1,N).
+*
+* X (input) REAL array, dimension (LDX,NRHS)
+* The solution matrix X.
+*
+* LDX (input) INTEGER
+* The leading dimension of the array X. LDX >= max(1,N).
+*
+* FERR (output) REAL array, dimension (NRHS)
+* The estimated forward error bound for each solution vector
+* X(j) (the j-th column of the solution matrix X).
+* If XTRUE is the true solution corresponding to X(j), FERR(j)
+* is an estimated upper bound for the magnitude of the largest
+* element in (X(j) - XTRUE) divided by the magnitude of the
+* largest element in X(j). The estimate is as reliable as
+* the estimate for RCOND, and is almost always a slight
+* overestimate of the true error.
+*
+* BERR (output) REAL array, dimension (NRHS)
+* The componentwise relative backward error of each solution
+* vector X(j) (i.e., the smallest relative change in
+* any element of A or B that makes X(j) an exact solution).
+*
+* WORK (workspace) REAL array, dimension (3*N)
+*
+* IWORK (workspace) INTEGER array, dimension (N)
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO
+ PARAMETER ( ZERO = 0.0E+0 )
+ REAL ONE
+ PARAMETER ( ONE = 1.0E+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL NOTRAN, NOUNIT, UPPER
+ CHARACTER TRANST
+ INTEGER I, J, K, KASE, NZ
+ REAL EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK
+* ..
+* .. Local Arrays ..
+ INTEGER ISAVE( 3 )
+* ..
+* .. External Subroutines ..
+ EXTERNAL SAXPY, SCOPY, SLACN2, STBMV, STBSV, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, MIN
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ REAL SLAMCH
+ EXTERNAL LSAME, SLAMCH
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ NOTRAN = LSAME( TRANS, 'N' )
+ NOUNIT = LSAME( DIAG, 'N' )
+*
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT.
+ $ LSAME( TRANS, 'C' ) ) THEN
+ INFO = -2
+ ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
+ INFO = -3
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( KD.LT.0 ) THEN
+ INFO = -5
+ ELSE IF( NRHS.LT.0 ) THEN
+ INFO = -6
+ ELSE IF( LDAB.LT.KD+1 ) THEN
+ INFO = -8
+ ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -10
+ ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
+ INFO = -12
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'STBRFS', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN
+ DO 10 J = 1, NRHS
+ FERR( J ) = ZERO
+ BERR( J ) = ZERO
+ 10 CONTINUE
+ RETURN
+ END IF
+*
+ IF( NOTRAN ) THEN
+ TRANST = 'T'
+ ELSE
+ TRANST = 'N'
+ END IF
+*
+* NZ = maximum number of nonzero elements in each row of A, plus 1
+*
+ NZ = KD + 2
+ EPS = SLAMCH( 'Epsilon' )
+ SAFMIN = SLAMCH( 'Safe minimum' )
+ SAFE1 = NZ*SAFMIN
+ SAFE2 = SAFE1 / EPS
+*
+* Do for each right hand side
+*
+ DO 250 J = 1, NRHS
+*
+* Compute residual R = B - op(A) * X,
+* where op(A) = A or A', depending on TRANS.
+*
+ CALL SCOPY( N, X( 1, J ), 1, WORK( N+1 ), 1 )
+ CALL STBMV( UPLO, TRANS, DIAG, N, KD, AB, LDAB, WORK( N+1 ),
+ $ 1 )
+ CALL SAXPY( N, -ONE, B( 1, J ), 1, WORK( N+1 ), 1 )
+*
+* Compute componentwise relative backward error from formula
+*
+* max(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) )
+*
+* where abs(Z) is the componentwise absolute value of the matrix
+* or vector Z. If the i-th component of the denominator is less
+* than SAFE2, then SAFE1 is added to the i-th components of the
+* numerator and denominator before dividing.
+*
+ DO 20 I = 1, N
+ WORK( I ) = ABS( B( I, J ) )
+ 20 CONTINUE
+*
+ IF( NOTRAN ) THEN
+*
+* Compute abs(A)*abs(X) + abs(B).
+*
+ IF( UPPER ) THEN
+ IF( NOUNIT ) THEN
+ DO 40 K = 1, N
+ XK = ABS( X( K, J ) )
+ DO 30 I = MAX( 1, K-KD ), K
+ WORK( I ) = WORK( I ) +
+ $ ABS( AB( KD+1+I-K, K ) )*XK
+ 30 CONTINUE
+ 40 CONTINUE
+ ELSE
+ DO 60 K = 1, N
+ XK = ABS( X( K, J ) )
+ DO 50 I = MAX( 1, K-KD ), K - 1
+ WORK( I ) = WORK( I ) +
+ $ ABS( AB( KD+1+I-K, K ) )*XK
+ 50 CONTINUE
+ WORK( K ) = WORK( K ) + XK
+ 60 CONTINUE
+ END IF
+ ELSE
+ IF( NOUNIT ) THEN
+ DO 80 K = 1, N
+ XK = ABS( X( K, J ) )
+ DO 70 I = K, MIN( N, K+KD )
+ WORK( I ) = WORK( I ) + ABS( AB( 1+I-K, K ) )*XK
+ 70 CONTINUE
+ 80 CONTINUE
+ ELSE
+ DO 100 K = 1, N
+ XK = ABS( X( K, J ) )
+ DO 90 I = K + 1, MIN( N, K+KD )
+ WORK( I ) = WORK( I ) + ABS( AB( 1+I-K, K ) )*XK
+ 90 CONTINUE
+ WORK( K ) = WORK( K ) + XK
+ 100 CONTINUE
+ END IF
+ END IF
+ ELSE
+*
+* Compute abs(A')*abs(X) + abs(B).
+*
+ IF( UPPER ) THEN
+ IF( NOUNIT ) THEN
+ DO 120 K = 1, N
+ S = ZERO
+ DO 110 I = MAX( 1, K-KD ), K
+ S = S + ABS( AB( KD+1+I-K, K ) )*
+ $ ABS( X( I, J ) )
+ 110 CONTINUE
+ WORK( K ) = WORK( K ) + S
+ 120 CONTINUE
+ ELSE
+ DO 140 K = 1, N
+ S = ABS( X( K, J ) )
+ DO 130 I = MAX( 1, K-KD ), K - 1
+ S = S + ABS( AB( KD+1+I-K, K ) )*
+ $ ABS( X( I, J ) )
+ 130 CONTINUE
+ WORK( K ) = WORK( K ) + S
+ 140 CONTINUE
+ END IF
+ ELSE
+ IF( NOUNIT ) THEN
+ DO 160 K = 1, N
+ S = ZERO
+ DO 150 I = K, MIN( N, K+KD )
+ S = S + ABS( AB( 1+I-K, K ) )*ABS( X( I, J ) )
+ 150 CONTINUE
+ WORK( K ) = WORK( K ) + S
+ 160 CONTINUE
+ ELSE
+ DO 180 K = 1, N
+ S = ABS( X( K, J ) )
+ DO 170 I = K + 1, MIN( N, K+KD )
+ S = S + ABS( AB( 1+I-K, K ) )*ABS( X( I, J ) )
+ 170 CONTINUE
+ WORK( K ) = WORK( K ) + S
+ 180 CONTINUE
+ END IF
+ END IF
+ END IF
+ S = ZERO
+ DO 190 I = 1, N
+ IF( WORK( I ).GT.SAFE2 ) THEN
+ S = MAX( S, ABS( WORK( N+I ) ) / WORK( I ) )
+ ELSE
+ S = MAX( S, ( ABS( WORK( N+I ) )+SAFE1 ) /
+ $ ( WORK( I )+SAFE1 ) )
+ END IF
+ 190 CONTINUE
+ BERR( J ) = S
+*
+* Bound error from formula
+*
+* norm(X - XTRUE) / norm(X) .le. FERR =
+* norm( abs(inv(op(A)))*
+* ( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X)
+*
+* where
+* norm(Z) is the magnitude of the largest component of Z
+* inv(op(A)) is the inverse of op(A)
+* abs(Z) is the componentwise absolute value of the matrix or
+* vector Z
+* NZ is the maximum number of nonzeros in any row of A, plus 1
+* EPS is machine epsilon
+*
+* The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B))
+* is incremented by SAFE1 if the i-th component of
+* abs(op(A))*abs(X) + abs(B) is less than SAFE2.
+*
+* Use SLACN2 to estimate the infinity-norm of the matrix
+* inv(op(A)) * diag(W),
+* where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) )))
+*
+ DO 200 I = 1, N
+ IF( WORK( I ).GT.SAFE2 ) THEN
+ WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I )
+ ELSE
+ WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I ) + SAFE1
+ END IF
+ 200 CONTINUE
+*
+ KASE = 0
+ 210 CONTINUE
+ CALL SLACN2( N, WORK( 2*N+1 ), WORK( N+1 ), IWORK, FERR( J ),
+ $ KASE, ISAVE )
+ IF( KASE.NE.0 ) THEN
+ IF( KASE.EQ.1 ) THEN
+*
+* Multiply by diag(W)*inv(op(A)').
+*
+ CALL STBSV( UPLO, TRANST, DIAG, N, KD, AB, LDAB,
+ $ WORK( N+1 ), 1 )
+ DO 220 I = 1, N
+ WORK( N+I ) = WORK( I )*WORK( N+I )
+ 220 CONTINUE
+ ELSE
+*
+* Multiply by inv(op(A))*diag(W).
+*
+ DO 230 I = 1, N
+ WORK( N+I ) = WORK( I )*WORK( N+I )
+ 230 CONTINUE
+ CALL STBSV( UPLO, TRANS, DIAG, N, KD, AB, LDAB,
+ $ WORK( N+1 ), 1 )
+ END IF
+ GO TO 210
+ END IF
+*
+* Normalize error.
+*
+ LSTRES = ZERO
+ DO 240 I = 1, N
+ LSTRES = MAX( LSTRES, ABS( X( I, J ) ) )
+ 240 CONTINUE
+ IF( LSTRES.NE.ZERO )
+ $ FERR( J ) = FERR( J ) / LSTRES
+*
+ 250 CONTINUE
+*
+ RETURN
+*
+* End of STBRFS
+*
+ END
+ SUBROUTINE STBTRS( UPLO, TRANS, DIAG, N, KD, NRHS, AB, LDAB, B,
+ $ LDB, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER DIAG, TRANS, UPLO
+ INTEGER INFO, KD, LDAB, LDB, N, NRHS
+* ..
+* .. Array Arguments ..
+ REAL AB( LDAB, * ), B( LDB, * )
+* ..
+*
+* Purpose
+* =======
+*
+* STBTRS solves a triangular system of the form
+*
+* A * X = B or A**T * X = B,
+*
+* where A is a triangular band matrix of order N, and B is an
+* N-by NRHS matrix. A check is made to verify that A is nonsingular.
+*
+* Arguments
+* =========
+*
+* UPLO (input) CHARACTER*1
+* = 'U': A is upper triangular;
+* = 'L': A is lower triangular.
+*
+* TRANS (input) CHARACTER*1
+* Specifies the form the system of equations:
+* = 'N': A * X = B (No transpose)
+* = 'T': A**T * X = B (Transpose)
+* = 'C': A**H * X = B (Conjugate transpose = Transpose)
+*
+* DIAG (input) CHARACTER*1
+* = 'N': A is non-unit triangular;
+* = 'U': A is unit triangular.
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* KD (input) INTEGER
+* The number of superdiagonals or subdiagonals of the
+* triangular band matrix A. KD >= 0.
+*
+* NRHS (input) INTEGER
+* The number of right hand sides, i.e., the number of columns
+* of the matrix B. NRHS >= 0.
+*
+* AB (input) REAL array, dimension (LDAB,N)
+* The upper or lower triangular band matrix A, stored in the
+* first kd+1 rows of AB. The j-th column of A is stored
+* in the j-th column of the array AB as follows:
+* if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
+* if UPLO = 'L', AB(1+i-j,j) = A(i,j) for j<=i<=min(n,j+kd).
+* If DIAG = 'U', the diagonal elements of A are not referenced
+* and are assumed to be 1.
+*
+* LDAB (input) INTEGER
+* The leading dimension of the array AB. LDAB >= KD+1.
+*
+* B (input/output) REAL array, dimension (LDB,NRHS)
+* On entry, the right hand side matrix B.
+* On exit, if INFO = 0, the solution matrix X.
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. LDB >= max(1,N).
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* > 0: if INFO = i, the i-th diagonal element of A is zero,
+* indicating that the matrix is singular and the
+* solutions X have not been computed.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO
+ PARAMETER ( ZERO = 0.0E+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL NOUNIT, UPPER
+ INTEGER J
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL STBSV, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ NOUNIT = LSAME( DIAG, 'N' )
+ UPPER = LSAME( UPLO, 'U' )
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( .NOT.LSAME( TRANS, 'N' ) .AND. .NOT.
+ $ LSAME( TRANS, 'T' ) .AND. .NOT.LSAME( TRANS, 'C' ) ) THEN
+ INFO = -2
+ ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
+ INFO = -3
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( KD.LT.0 ) THEN
+ INFO = -5
+ ELSE IF( NRHS.LT.0 ) THEN
+ INFO = -6
+ ELSE IF( LDAB.LT.KD+1 ) THEN
+ INFO = -8
+ ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -10
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'STBTRS', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+* Check for singularity.
+*
+ IF( NOUNIT ) THEN
+ IF( UPPER ) THEN
+ DO 10 INFO = 1, N
+ IF( AB( KD+1, INFO ).EQ.ZERO )
+ $ RETURN
+ 10 CONTINUE
+ ELSE
+ DO 20 INFO = 1, N
+ IF( AB( 1, INFO ).EQ.ZERO )
+ $ RETURN
+ 20 CONTINUE
+ END IF
+ END IF
+ INFO = 0
+*
+* Solve A * X = B or A' * X = B.
+*
+ DO 30 J = 1, NRHS
+ CALL STBSV( UPLO, TRANS, DIAG, N, KD, AB, LDAB, B( 1, J ), 1 )
+ 30 CONTINUE
+*
+ RETURN
+*
+* End of STBTRS
+*
+ END
+ SUBROUTINE STGEVC( SIDE, HOWMNY, SELECT, N, S, LDS, P, LDP, VL,
+ $ LDVL, VR, LDVR, MM, M, WORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER HOWMNY, SIDE
+ INTEGER INFO, LDP, LDS, LDVL, LDVR, M, MM, N
+* ..
+* .. Array Arguments ..
+ LOGICAL SELECT( * )
+ REAL P( LDP, * ), S( LDS, * ), VL( LDVL, * ),
+ $ VR( LDVR, * ), WORK( * )
+* ..
+*
+*
+* Purpose
+* =======
+*
+* STGEVC computes some or all of the right and/or left eigenvectors of
+* a pair of real matrices (S,P), where S is a quasi-triangular matrix
+* and P is upper triangular. Matrix pairs of this type are produced by
+* the generalized Schur factorization of a matrix pair (A,B):
+*
+* A = Q*S*Z**T, B = Q*P*Z**T
+*
+* as computed by SGGHRD + SHGEQZ.
+*
+* The right eigenvector x and the left eigenvector y of (S,P)
+* corresponding to an eigenvalue w are defined by:
+*
+* S*x = w*P*x, (y**H)*S = w*(y**H)*P,
+*
+* where y**H denotes the conjugate tranpose of y.
+* The eigenvalues are not input to this routine, but are computed
+* directly from the diagonal blocks of S and P.
+*
+* This routine returns the matrices X and/or Y of right and left
+* eigenvectors of (S,P), or the products Z*X and/or Q*Y,
+* where Z and Q are input matrices.
+* If Q and Z are the orthogonal factors from the generalized Schur
+* factorization of a matrix pair (A,B), then Z*X and Q*Y
+* are the matrices of right and left eigenvectors of (A,B).
+*
+* Arguments
+* =========
+*
+* SIDE (input) CHARACTER*1
+* = 'R': compute right eigenvectors only;
+* = 'L': compute left eigenvectors only;
+* = 'B': compute both right and left eigenvectors.
+*
+* HOWMNY (input) CHARACTER*1
+* = 'A': compute all right and/or left eigenvectors;
+* = 'B': compute all right and/or left eigenvectors,
+* backtransformed by the matrices in VR and/or VL;
+* = 'S': compute selected right and/or left eigenvectors,
+* specified by the logical array SELECT.
+*
+* SELECT (input) LOGICAL array, dimension (N)
+* If HOWMNY='S', SELECT specifies the eigenvectors to be
+* computed. If w(j) is a real eigenvalue, the corresponding
+* real eigenvector is computed if SELECT(j) is .TRUE..
+* If w(j) and w(j+1) are the real and imaginary parts of a
+* complex eigenvalue, the corresponding complex eigenvector
+* is computed if either SELECT(j) or SELECT(j+1) is .TRUE.,
+* and on exit SELECT(j) is set to .TRUE. and SELECT(j+1) is
+* set to .FALSE..
+* Not referenced if HOWMNY = 'A' or 'B'.
+*
+* N (input) INTEGER
+* The order of the matrices S and P. N >= 0.
+*
+* S (input) REAL array, dimension (LDS,N)
+* The upper quasi-triangular matrix S from a generalized Schur
+* factorization, as computed by SHGEQZ.
+*
+* LDS (input) INTEGER
+* The leading dimension of array S. LDS >= max(1,N).
+*
+* P (input) REAL array, dimension (LDP,N)
+* The upper triangular matrix P from a generalized Schur
+* factorization, as computed by SHGEQZ.
+* 2-by-2 diagonal blocks of P corresponding to 2-by-2 blocks
+* of S must be in positive diagonal form.
+*
+* LDP (input) INTEGER
+* The leading dimension of array P. LDP >= max(1,N).
+*
+* VL (input/output) REAL array, dimension (LDVL,MM)
+* On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must
+* contain an N-by-N matrix Q (usually the orthogonal matrix Q
+* of left Schur vectors returned by SHGEQZ).
+* On exit, if SIDE = 'L' or 'B', VL contains:
+* if HOWMNY = 'A', the matrix Y of left eigenvectors of (S,P);
+* if HOWMNY = 'B', the matrix Q*Y;
+* if HOWMNY = 'S', the left eigenvectors of (S,P) specified by
+* SELECT, stored consecutively in the columns of
+* VL, in the same order as their eigenvalues.
+*
+* A complex eigenvector corresponding to a complex eigenvalue
+* is stored in two consecutive columns, the first holding the
+* real part, and the second the imaginary part.
+*
+* Not referenced if SIDE = 'R'.
+*
+* LDVL (input) INTEGER
+* The leading dimension of array VL. LDVL >= 1, and if
+* SIDE = 'L' or 'B', LDVL >= N.
+*
+* VR (input/output) REAL array, dimension (LDVR,MM)
+* On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must
+* contain an N-by-N matrix Z (usually the orthogonal matrix Z
+* of right Schur vectors returned by SHGEQZ).
+*
+* On exit, if SIDE = 'R' or 'B', VR contains:
+* if HOWMNY = 'A', the matrix X of right eigenvectors of (S,P);
+* if HOWMNY = 'B' or 'b', the matrix Z*X;
+* if HOWMNY = 'S' or 's', the right eigenvectors of (S,P)
+* specified by SELECT, stored consecutively in the
+* columns of VR, in the same order as their
+* eigenvalues.
+*
+* A complex eigenvector corresponding to a complex eigenvalue
+* is stored in two consecutive columns, the first holding the
+* real part and the second the imaginary part.
+*
+* Not referenced if SIDE = 'L'.
+*
+* LDVR (input) INTEGER
+* The leading dimension of the array VR. LDVR >= 1, and if
+* SIDE = 'R' or 'B', LDVR >= N.
+*
+* MM (input) INTEGER
+* The number of columns in the arrays VL and/or VR. MM >= M.
+*
+* M (output) INTEGER
+* The number of columns in the arrays VL and/or VR actually
+* used to store the eigenvectors. If HOWMNY = 'A' or 'B', M
+* is set to N. Each selected real eigenvector occupies one
+* column and each selected complex eigenvector occupies two
+* columns.
+*
+* WORK (workspace) REAL array, dimension (6*N)
+*
+* INFO (output) INTEGER
+* = 0: successful exit.
+* < 0: if INFO = -i, the i-th argument had an illegal value.
+* > 0: the 2-by-2 block (INFO:INFO+1) does not have a complex
+* eigenvalue.
+*
+* Further Details
+* ===============
+*
+* Allocation of workspace:
+* ---------- -- ---------
+*
+* WORK( j ) = 1-norm of j-th column of A, above the diagonal
+* WORK( N+j ) = 1-norm of j-th column of B, above the diagonal
+* WORK( 2*N+1:3*N ) = real part of eigenvector
+* WORK( 3*N+1:4*N ) = imaginary part of eigenvector
+* WORK( 4*N+1:5*N ) = real part of back-transformed eigenvector
+* WORK( 5*N+1:6*N ) = imaginary part of back-transformed eigenvector
+*
+* Rowwise vs. columnwise solution methods:
+* ------- -- ---------- -------- -------
+*
+* Finding a generalized eigenvector consists basically of solving the
+* singular triangular system
+*
+* (A - w B) x = 0 (for right) or: (A - w B)**H y = 0 (for left)
+*
+* Consider finding the i-th right eigenvector (assume all eigenvalues
+* are real). The equation to be solved is:
+* n i
+* 0 = sum C(j,k) v(k) = sum C(j,k) v(k) for j = i,. . .,1
+* k=j k=j
+*
+* where C = (A - w B) (The components v(i+1:n) are 0.)
+*
+* The "rowwise" method is:
+*
+* (1) v(i) := 1
+* for j = i-1,. . .,1:
+* i
+* (2) compute s = - sum C(j,k) v(k) and
+* k=j+1
+*
+* (3) v(j) := s / C(j,j)
+*
+* Step 2 is sometimes called the "dot product" step, since it is an
+* inner product between the j-th row and the portion of the eigenvector
+* that has been computed so far.
+*
+* The "columnwise" method consists basically in doing the sums
+* for all the rows in parallel. As each v(j) is computed, the
+* contribution of v(j) times the j-th column of C is added to the
+* partial sums. Since FORTRAN arrays are stored columnwise, this has
+* the advantage that at each step, the elements of C that are accessed
+* are adjacent to one another, whereas with the rowwise method, the
+* elements accessed at a step are spaced LDS (and LDP) words apart.
+*
+* When finding left eigenvectors, the matrix in question is the
+* transpose of the one in storage, so the rowwise method then
+* actually accesses columns of A and B at each step, and so is the
+* preferred method.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO, ONE, SAFETY
+ PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0,
+ $ SAFETY = 1.0E+2 )
+* ..
+* .. Local Scalars ..
+ LOGICAL COMPL, COMPR, IL2BY2, ILABAD, ILALL, ILBACK,
+ $ ILBBAD, ILCOMP, ILCPLX, LSA, LSB
+ INTEGER I, IBEG, IEIG, IEND, IHWMNY, IINFO, IM, ISIDE,
+ $ J, JA, JC, JE, JR, JW, NA, NW
+ REAL ACOEF, ACOEFA, ANORM, ASCALE, BCOEFA, BCOEFI,
+ $ BCOEFR, BIG, BIGNUM, BNORM, BSCALE, CIM2A,
+ $ CIM2B, CIMAGA, CIMAGB, CRE2A, CRE2B, CREALA,
+ $ CREALB, DMIN, SAFMIN, SALFAR, SBETA, SCALE,
+ $ SMALL, TEMP, TEMP2, TEMP2I, TEMP2R, ULP, XMAX,
+ $ XSCALE
+* ..
+* .. Local Arrays ..
+ REAL BDIAG( 2 ), SUM( 2, 2 ), SUMS( 2, 2 ),
+ $ SUMP( 2, 2 )
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ REAL SLAMCH
+ EXTERNAL LSAME, SLAMCH
+* ..
+* .. External Subroutines ..
+ EXTERNAL SGEMV, SLABAD, SLACPY, SLAG2, SLALN2, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+* Decode and Test the input parameters
+*
+ IF( LSAME( HOWMNY, 'A' ) ) THEN
+ IHWMNY = 1
+ ILALL = .TRUE.
+ ILBACK = .FALSE.
+ ELSE IF( LSAME( HOWMNY, 'S' ) ) THEN
+ IHWMNY = 2
+ ILALL = .FALSE.
+ ILBACK = .FALSE.
+ ELSE IF( LSAME( HOWMNY, 'B' ) ) THEN
+ IHWMNY = 3
+ ILALL = .TRUE.
+ ILBACK = .TRUE.
+ ELSE
+ IHWMNY = -1
+ ILALL = .TRUE.
+ END IF
+*
+ IF( LSAME( SIDE, 'R' ) ) THEN
+ ISIDE = 1
+ COMPL = .FALSE.
+ COMPR = .TRUE.
+ ELSE IF( LSAME( SIDE, 'L' ) ) THEN
+ ISIDE = 2
+ COMPL = .TRUE.
+ COMPR = .FALSE.
+ ELSE IF( LSAME( SIDE, 'B' ) ) THEN
+ ISIDE = 3
+ COMPL = .TRUE.
+ COMPR = .TRUE.
+ ELSE
+ ISIDE = -1
+ END IF
+*
+ INFO = 0
+ IF( ISIDE.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( IHWMNY.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( LDS.LT.MAX( 1, N ) ) THEN
+ INFO = -6
+ ELSE IF( LDP.LT.MAX( 1, N ) ) THEN
+ INFO = -8
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'STGEVC', -INFO )
+ RETURN
+ END IF
+*
+* Count the number of eigenvectors to be computed
+*
+ IF( .NOT.ILALL ) THEN
+ IM = 0
+ ILCPLX = .FALSE.
+ DO 10 J = 1, N
+ IF( ILCPLX ) THEN
+ ILCPLX = .FALSE.
+ GO TO 10
+ END IF
+ IF( J.LT.N ) THEN
+ IF( S( J+1, J ).NE.ZERO )
+ $ ILCPLX = .TRUE.
+ END IF
+ IF( ILCPLX ) THEN
+ IF( SELECT( J ) .OR. SELECT( J+1 ) )
+ $ IM = IM + 2
+ ELSE
+ IF( SELECT( J ) )
+ $ IM = IM + 1
+ END IF
+ 10 CONTINUE
+ ELSE
+ IM = N
+ END IF
+*
+* Check 2-by-2 diagonal blocks of A, B
+*
+ ILABAD = .FALSE.
+ ILBBAD = .FALSE.
+ DO 20 J = 1, N - 1
+ IF( S( J+1, J ).NE.ZERO ) THEN
+ IF( P( J, J ).EQ.ZERO .OR. P( J+1, J+1 ).EQ.ZERO .OR.
+ $ P( J, J+1 ).NE.ZERO )ILBBAD = .TRUE.
+ IF( J.LT.N-1 ) THEN
+ IF( S( J+2, J+1 ).NE.ZERO )
+ $ ILABAD = .TRUE.
+ END IF
+ END IF
+ 20 CONTINUE
+*
+ IF( ILABAD ) THEN
+ INFO = -5
+ ELSE IF( ILBBAD ) THEN
+ INFO = -7
+ ELSE IF( COMPL .AND. LDVL.LT.N .OR. LDVL.LT.1 ) THEN
+ INFO = -10
+ ELSE IF( COMPR .AND. LDVR.LT.N .OR. LDVR.LT.1 ) THEN
+ INFO = -12
+ ELSE IF( MM.LT.IM ) THEN
+ INFO = -13
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'STGEVC', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ M = IM
+ IF( N.EQ.0 )
+ $ RETURN
+*
+* Machine Constants
+*
+ SAFMIN = SLAMCH( 'Safe minimum' )
+ BIG = ONE / SAFMIN
+ CALL SLABAD( SAFMIN, BIG )
+ ULP = SLAMCH( 'Epsilon' )*SLAMCH( 'Base' )
+ SMALL = SAFMIN*N / ULP
+ BIG = ONE / SMALL
+ BIGNUM = ONE / ( SAFMIN*N )
+*
+* Compute the 1-norm of each column of the strictly upper triangular
+* part (i.e., excluding all elements belonging to the diagonal
+* blocks) of A and B to check for possible overflow in the
+* triangular solver.
+*
+ ANORM = ABS( S( 1, 1 ) )
+ IF( N.GT.1 )
+ $ ANORM = ANORM + ABS( S( 2, 1 ) )
+ BNORM = ABS( P( 1, 1 ) )
+ WORK( 1 ) = ZERO
+ WORK( N+1 ) = ZERO
+*
+ DO 50 J = 2, N
+ TEMP = ZERO
+ TEMP2 = ZERO
+ IF( S( J, J-1 ).EQ.ZERO ) THEN
+ IEND = J - 1
+ ELSE
+ IEND = J - 2
+ END IF
+ DO 30 I = 1, IEND
+ TEMP = TEMP + ABS( S( I, J ) )
+ TEMP2 = TEMP2 + ABS( P( I, J ) )
+ 30 CONTINUE
+ WORK( J ) = TEMP
+ WORK( N+J ) = TEMP2
+ DO 40 I = IEND + 1, MIN( J+1, N )
+ TEMP = TEMP + ABS( S( I, J ) )
+ TEMP2 = TEMP2 + ABS( P( I, J ) )
+ 40 CONTINUE
+ ANORM = MAX( ANORM, TEMP )
+ BNORM = MAX( BNORM, TEMP2 )
+ 50 CONTINUE
+*
+ ASCALE = ONE / MAX( ANORM, SAFMIN )
+ BSCALE = ONE / MAX( BNORM, SAFMIN )
+*
+* Left eigenvectors
+*
+ IF( COMPL ) THEN
+ IEIG = 0
+*
+* Main loop over eigenvalues
+*
+ ILCPLX = .FALSE.
+ DO 220 JE = 1, N
+*
+* Skip this iteration if (a) HOWMNY='S' and SELECT=.FALSE., or
+* (b) this would be the second of a complex pair.
+* Check for complex eigenvalue, so as to be sure of which
+* entry(-ies) of SELECT to look at.
+*
+ IF( ILCPLX ) THEN
+ ILCPLX = .FALSE.
+ GO TO 220
+ END IF
+ NW = 1
+ IF( JE.LT.N ) THEN
+ IF( S( JE+1, JE ).NE.ZERO ) THEN
+ ILCPLX = .TRUE.
+ NW = 2
+ END IF
+ END IF
+ IF( ILALL ) THEN
+ ILCOMP = .TRUE.
+ ELSE IF( ILCPLX ) THEN
+ ILCOMP = SELECT( JE ) .OR. SELECT( JE+1 )
+ ELSE
+ ILCOMP = SELECT( JE )
+ END IF
+ IF( .NOT.ILCOMP )
+ $ GO TO 220
+*
+* Decide if (a) singular pencil, (b) real eigenvalue, or
+* (c) complex eigenvalue.
+*
+ IF( .NOT.ILCPLX ) THEN
+ IF( ABS( S( JE, JE ) ).LE.SAFMIN .AND.
+ $ ABS( P( JE, JE ) ).LE.SAFMIN ) THEN
+*
+* Singular matrix pencil -- return unit eigenvector
+*
+ IEIG = IEIG + 1
+ DO 60 JR = 1, N
+ VL( JR, IEIG ) = ZERO
+ 60 CONTINUE
+ VL( IEIG, IEIG ) = ONE
+ GO TO 220
+ END IF
+ END IF
+*
+* Clear vector
+*
+ DO 70 JR = 1, NW*N
+ WORK( 2*N+JR ) = ZERO
+ 70 CONTINUE
+* T
+* Compute coefficients in ( a A - b B ) y = 0
+* a is ACOEF
+* b is BCOEFR + i*BCOEFI
+*
+ IF( .NOT.ILCPLX ) THEN
+*
+* Real eigenvalue
+*
+ TEMP = ONE / MAX( ABS( S( JE, JE ) )*ASCALE,
+ $ ABS( P( JE, JE ) )*BSCALE, SAFMIN )
+ SALFAR = ( TEMP*S( JE, JE ) )*ASCALE
+ SBETA = ( TEMP*P( JE, JE ) )*BSCALE
+ ACOEF = SBETA*ASCALE
+ BCOEFR = SALFAR*BSCALE
+ BCOEFI = ZERO
+*
+* Scale to avoid underflow
+*
+ SCALE = ONE
+ LSA = ABS( SBETA ).GE.SAFMIN .AND. ABS( ACOEF ).LT.SMALL
+ LSB = ABS( SALFAR ).GE.SAFMIN .AND. ABS( BCOEFR ).LT.
+ $ SMALL
+ IF( LSA )
+ $ SCALE = ( SMALL / ABS( SBETA ) )*MIN( ANORM, BIG )
+ IF( LSB )
+ $ SCALE = MAX( SCALE, ( SMALL / ABS( SALFAR ) )*
+ $ MIN( BNORM, BIG ) )
+ IF( LSA .OR. LSB ) THEN
+ SCALE = MIN( SCALE, ONE /
+ $ ( SAFMIN*MAX( ONE, ABS( ACOEF ),
+ $ ABS( BCOEFR ) ) ) )
+ IF( LSA ) THEN
+ ACOEF = ASCALE*( SCALE*SBETA )
+ ELSE
+ ACOEF = SCALE*ACOEF
+ END IF
+ IF( LSB ) THEN
+ BCOEFR = BSCALE*( SCALE*SALFAR )
+ ELSE
+ BCOEFR = SCALE*BCOEFR
+ END IF
+ END IF
+ ACOEFA = ABS( ACOEF )
+ BCOEFA = ABS( BCOEFR )
+*
+* First component is 1
+*
+ WORK( 2*N+JE ) = ONE
+ XMAX = ONE
+ ELSE
+*
+* Complex eigenvalue
+*
+ CALL SLAG2( S( JE, JE ), LDS, P( JE, JE ), LDP,
+ $ SAFMIN*SAFETY, ACOEF, TEMP, BCOEFR, TEMP2,
+ $ BCOEFI )
+ BCOEFI = -BCOEFI
+ IF( BCOEFI.EQ.ZERO ) THEN
+ INFO = JE
+ RETURN
+ END IF
+*
+* Scale to avoid over/underflow
+*
+ ACOEFA = ABS( ACOEF )
+ BCOEFA = ABS( BCOEFR ) + ABS( BCOEFI )
+ SCALE = ONE
+ IF( ACOEFA*ULP.LT.SAFMIN .AND. ACOEFA.GE.SAFMIN )
+ $ SCALE = ( SAFMIN / ULP ) / ACOEFA
+ IF( BCOEFA*ULP.LT.SAFMIN .AND. BCOEFA.GE.SAFMIN )
+ $ SCALE = MAX( SCALE, ( SAFMIN / ULP ) / BCOEFA )
+ IF( SAFMIN*ACOEFA.GT.ASCALE )
+ $ SCALE = ASCALE / ( SAFMIN*ACOEFA )
+ IF( SAFMIN*BCOEFA.GT.BSCALE )
+ $ SCALE = MIN( SCALE, BSCALE / ( SAFMIN*BCOEFA ) )
+ IF( SCALE.NE.ONE ) THEN
+ ACOEF = SCALE*ACOEF
+ ACOEFA = ABS( ACOEF )
+ BCOEFR = SCALE*BCOEFR
+ BCOEFI = SCALE*BCOEFI
+ BCOEFA = ABS( BCOEFR ) + ABS( BCOEFI )
+ END IF
+*
+* Compute first two components of eigenvector
+*
+ TEMP = ACOEF*S( JE+1, JE )
+ TEMP2R = ACOEF*S( JE, JE ) - BCOEFR*P( JE, JE )
+ TEMP2I = -BCOEFI*P( JE, JE )
+ IF( ABS( TEMP ).GT.ABS( TEMP2R )+ABS( TEMP2I ) ) THEN
+ WORK( 2*N+JE ) = ONE
+ WORK( 3*N+JE ) = ZERO
+ WORK( 2*N+JE+1 ) = -TEMP2R / TEMP
+ WORK( 3*N+JE+1 ) = -TEMP2I / TEMP
+ ELSE
+ WORK( 2*N+JE+1 ) = ONE
+ WORK( 3*N+JE+1 ) = ZERO
+ TEMP = ACOEF*S( JE, JE+1 )
+ WORK( 2*N+JE ) = ( BCOEFR*P( JE+1, JE+1 )-ACOEF*
+ $ S( JE+1, JE+1 ) ) / TEMP
+ WORK( 3*N+JE ) = BCOEFI*P( JE+1, JE+1 ) / TEMP
+ END IF
+ XMAX = MAX( ABS( WORK( 2*N+JE ) )+ABS( WORK( 3*N+JE ) ),
+ $ ABS( WORK( 2*N+JE+1 ) )+ABS( WORK( 3*N+JE+1 ) ) )
+ END IF
+*
+ DMIN = MAX( ULP*ACOEFA*ANORM, ULP*BCOEFA*BNORM, SAFMIN )
+*
+* T
+* Triangular solve of (a A - b B) y = 0
+*
+* T
+* (rowwise in (a A - b B) , or columnwise in (a A - b B) )
+*
+ IL2BY2 = .FALSE.
+*
+ DO 160 J = JE + NW, N
+ IF( IL2BY2 ) THEN
+ IL2BY2 = .FALSE.
+ GO TO 160
+ END IF
+*
+ NA = 1
+ BDIAG( 1 ) = P( J, J )
+ IF( J.LT.N ) THEN
+ IF( S( J+1, J ).NE.ZERO ) THEN
+ IL2BY2 = .TRUE.
+ BDIAG( 2 ) = P( J+1, J+1 )
+ NA = 2
+ END IF
+ END IF
+*
+* Check whether scaling is necessary for dot products
+*
+ XSCALE = ONE / MAX( ONE, XMAX )
+ TEMP = MAX( WORK( J ), WORK( N+J ),
+ $ ACOEFA*WORK( J )+BCOEFA*WORK( N+J ) )
+ IF( IL2BY2 )
+ $ TEMP = MAX( TEMP, WORK( J+1 ), WORK( N+J+1 ),
+ $ ACOEFA*WORK( J+1 )+BCOEFA*WORK( N+J+1 ) )
+ IF( TEMP.GT.BIGNUM*XSCALE ) THEN
+ DO 90 JW = 0, NW - 1
+ DO 80 JR = JE, J - 1
+ WORK( ( JW+2 )*N+JR ) = XSCALE*
+ $ WORK( ( JW+2 )*N+JR )
+ 80 CONTINUE
+ 90 CONTINUE
+ XMAX = XMAX*XSCALE
+ END IF
+*
+* Compute dot products
+*
+* j-1
+* SUM = sum conjg( a*S(k,j) - b*P(k,j) )*x(k)
+* k=je
+*
+* To reduce the op count, this is done as
+*
+* _ j-1 _ j-1
+* a*conjg( sum S(k,j)*x(k) ) - b*conjg( sum P(k,j)*x(k) )
+* k=je k=je
+*
+* which may cause underflow problems if A or B are close
+* to underflow. (E.g., less than SMALL.)
+*
+*
+* A series of compiler directives to defeat vectorization
+* for the next loop
+*
+*$PL$ CMCHAR=' '
+CDIR$ NEXTSCALAR
+C$DIR SCALAR
+CDIR$ NEXT SCALAR
+CVD$L NOVECTOR
+CDEC$ NOVECTOR
+CVD$ NOVECTOR
+*VDIR NOVECTOR
+*VOCL LOOP,SCALAR
+CIBM PREFER SCALAR
+*$PL$ CMCHAR='*'
+*
+ DO 120 JW = 1, NW
+*
+*$PL$ CMCHAR=' '
+CDIR$ NEXTSCALAR
+C$DIR SCALAR
+CDIR$ NEXT SCALAR
+CVD$L NOVECTOR
+CDEC$ NOVECTOR
+CVD$ NOVECTOR
+*VDIR NOVECTOR
+*VOCL LOOP,SCALAR
+CIBM PREFER SCALAR
+*$PL$ CMCHAR='*'
+*
+ DO 110 JA = 1, NA
+ SUMS( JA, JW ) = ZERO
+ SUMP( JA, JW ) = ZERO
+*
+ DO 100 JR = JE, J - 1
+ SUMS( JA, JW ) = SUMS( JA, JW ) +
+ $ S( JR, J+JA-1 )*
+ $ WORK( ( JW+1 )*N+JR )
+ SUMP( JA, JW ) = SUMP( JA, JW ) +
+ $ P( JR, J+JA-1 )*
+ $ WORK( ( JW+1 )*N+JR )
+ 100 CONTINUE
+ 110 CONTINUE
+ 120 CONTINUE
+*
+*$PL$ CMCHAR=' '
+CDIR$ NEXTSCALAR
+C$DIR SCALAR
+CDIR$ NEXT SCALAR
+CVD$L NOVECTOR
+CDEC$ NOVECTOR
+CVD$ NOVECTOR
+*VDIR NOVECTOR
+*VOCL LOOP,SCALAR
+CIBM PREFER SCALAR
+*$PL$ CMCHAR='*'
+*
+ DO 130 JA = 1, NA
+ IF( ILCPLX ) THEN
+ SUM( JA, 1 ) = -ACOEF*SUMS( JA, 1 ) +
+ $ BCOEFR*SUMP( JA, 1 ) -
+ $ BCOEFI*SUMP( JA, 2 )
+ SUM( JA, 2 ) = -ACOEF*SUMS( JA, 2 ) +
+ $ BCOEFR*SUMP( JA, 2 ) +
+ $ BCOEFI*SUMP( JA, 1 )
+ ELSE
+ SUM( JA, 1 ) = -ACOEF*SUMS( JA, 1 ) +
+ $ BCOEFR*SUMP( JA, 1 )
+ END IF
+ 130 CONTINUE
+*
+* T
+* Solve ( a A - b B ) y = SUM(,)
+* with scaling and perturbation of the denominator
+*
+ CALL SLALN2( .TRUE., NA, NW, DMIN, ACOEF, S( J, J ), LDS,
+ $ BDIAG( 1 ), BDIAG( 2 ), SUM, 2, BCOEFR,
+ $ BCOEFI, WORK( 2*N+J ), N, SCALE, TEMP,
+ $ IINFO )
+ IF( SCALE.LT.ONE ) THEN
+ DO 150 JW = 0, NW - 1
+ DO 140 JR = JE, J - 1
+ WORK( ( JW+2 )*N+JR ) = SCALE*
+ $ WORK( ( JW+2 )*N+JR )
+ 140 CONTINUE
+ 150 CONTINUE
+ XMAX = SCALE*XMAX
+ END IF
+ XMAX = MAX( XMAX, TEMP )
+ 160 CONTINUE
+*
+* Copy eigenvector to VL, back transforming if
+* HOWMNY='B'.
+*
+ IEIG = IEIG + 1
+ IF( ILBACK ) THEN
+ DO 170 JW = 0, NW - 1
+ CALL SGEMV( 'N', N, N+1-JE, ONE, VL( 1, JE ), LDVL,
+ $ WORK( ( JW+2 )*N+JE ), 1, ZERO,
+ $ WORK( ( JW+4 )*N+1 ), 1 )
+ 170 CONTINUE
+ CALL SLACPY( ' ', N, NW, WORK( 4*N+1 ), N, VL( 1, JE ),
+ $ LDVL )
+ IBEG = 1
+ ELSE
+ CALL SLACPY( ' ', N, NW, WORK( 2*N+1 ), N, VL( 1, IEIG ),
+ $ LDVL )
+ IBEG = JE
+ END IF
+*
+* Scale eigenvector
+*
+ XMAX = ZERO
+ IF( ILCPLX ) THEN
+ DO 180 J = IBEG, N
+ XMAX = MAX( XMAX, ABS( VL( J, IEIG ) )+
+ $ ABS( VL( J, IEIG+1 ) ) )
+ 180 CONTINUE
+ ELSE
+ DO 190 J = IBEG, N
+ XMAX = MAX( XMAX, ABS( VL( J, IEIG ) ) )
+ 190 CONTINUE
+ END IF
+*
+ IF( XMAX.GT.SAFMIN ) THEN
+ XSCALE = ONE / XMAX
+*
+ DO 210 JW = 0, NW - 1
+ DO 200 JR = IBEG, N
+ VL( JR, IEIG+JW ) = XSCALE*VL( JR, IEIG+JW )
+ 200 CONTINUE
+ 210 CONTINUE
+ END IF
+ IEIG = IEIG + NW - 1
+*
+ 220 CONTINUE
+ END IF
+*
+* Right eigenvectors
+*
+ IF( COMPR ) THEN
+ IEIG = IM + 1
+*
+* Main loop over eigenvalues
+*
+ ILCPLX = .FALSE.
+ DO 500 JE = N, 1, -1
+*
+* Skip this iteration if (a) HOWMNY='S' and SELECT=.FALSE., or
+* (b) this would be the second of a complex pair.
+* Check for complex eigenvalue, so as to be sure of which
+* entry(-ies) of SELECT to look at -- if complex, SELECT(JE)
+* or SELECT(JE-1).
+* If this is a complex pair, the 2-by-2 diagonal block
+* corresponding to the eigenvalue is in rows/columns JE-1:JE
+*
+ IF( ILCPLX ) THEN
+ ILCPLX = .FALSE.
+ GO TO 500
+ END IF
+ NW = 1
+ IF( JE.GT.1 ) THEN
+ IF( S( JE, JE-1 ).NE.ZERO ) THEN
+ ILCPLX = .TRUE.
+ NW = 2
+ END IF
+ END IF
+ IF( ILALL ) THEN
+ ILCOMP = .TRUE.
+ ELSE IF( ILCPLX ) THEN
+ ILCOMP = SELECT( JE ) .OR. SELECT( JE-1 )
+ ELSE
+ ILCOMP = SELECT( JE )
+ END IF
+ IF( .NOT.ILCOMP )
+ $ GO TO 500
+*
+* Decide if (a) singular pencil, (b) real eigenvalue, or
+* (c) complex eigenvalue.
+*
+ IF( .NOT.ILCPLX ) THEN
+ IF( ABS( S( JE, JE ) ).LE.SAFMIN .AND.
+ $ ABS( P( JE, JE ) ).LE.SAFMIN ) THEN
+*
+* Singular matrix pencil -- unit eigenvector
+*
+ IEIG = IEIG - 1
+ DO 230 JR = 1, N
+ VR( JR, IEIG ) = ZERO
+ 230 CONTINUE
+ VR( IEIG, IEIG ) = ONE
+ GO TO 500
+ END IF
+ END IF
+*
+* Clear vector
+*
+ DO 250 JW = 0, NW - 1
+ DO 240 JR = 1, N
+ WORK( ( JW+2 )*N+JR ) = ZERO
+ 240 CONTINUE
+ 250 CONTINUE
+*
+* Compute coefficients in ( a A - b B ) x = 0
+* a is ACOEF
+* b is BCOEFR + i*BCOEFI
+*
+ IF( .NOT.ILCPLX ) THEN
+*
+* Real eigenvalue
+*
+ TEMP = ONE / MAX( ABS( S( JE, JE ) )*ASCALE,
+ $ ABS( P( JE, JE ) )*BSCALE, SAFMIN )
+ SALFAR = ( TEMP*S( JE, JE ) )*ASCALE
+ SBETA = ( TEMP*P( JE, JE ) )*BSCALE
+ ACOEF = SBETA*ASCALE
+ BCOEFR = SALFAR*BSCALE
+ BCOEFI = ZERO
+*
+* Scale to avoid underflow
+*
+ SCALE = ONE
+ LSA = ABS( SBETA ).GE.SAFMIN .AND. ABS( ACOEF ).LT.SMALL
+ LSB = ABS( SALFAR ).GE.SAFMIN .AND. ABS( BCOEFR ).LT.
+ $ SMALL
+ IF( LSA )
+ $ SCALE = ( SMALL / ABS( SBETA ) )*MIN( ANORM, BIG )
+ IF( LSB )
+ $ SCALE = MAX( SCALE, ( SMALL / ABS( SALFAR ) )*
+ $ MIN( BNORM, BIG ) )
+ IF( LSA .OR. LSB ) THEN
+ SCALE = MIN( SCALE, ONE /
+ $ ( SAFMIN*MAX( ONE, ABS( ACOEF ),
+ $ ABS( BCOEFR ) ) ) )
+ IF( LSA ) THEN
+ ACOEF = ASCALE*( SCALE*SBETA )
+ ELSE
+ ACOEF = SCALE*ACOEF
+ END IF
+ IF( LSB ) THEN
+ BCOEFR = BSCALE*( SCALE*SALFAR )
+ ELSE
+ BCOEFR = SCALE*BCOEFR
+ END IF
+ END IF
+ ACOEFA = ABS( ACOEF )
+ BCOEFA = ABS( BCOEFR )
+*
+* First component is 1
+*
+ WORK( 2*N+JE ) = ONE
+ XMAX = ONE
+*
+* Compute contribution from column JE of A and B to sum
+* (See "Further Details", above.)
+*
+ DO 260 JR = 1, JE - 1
+ WORK( 2*N+JR ) = BCOEFR*P( JR, JE ) -
+ $ ACOEF*S( JR, JE )
+ 260 CONTINUE
+ ELSE
+*
+* Complex eigenvalue
+*
+ CALL SLAG2( S( JE-1, JE-1 ), LDS, P( JE-1, JE-1 ), LDP,
+ $ SAFMIN*SAFETY, ACOEF, TEMP, BCOEFR, TEMP2,
+ $ BCOEFI )
+ IF( BCOEFI.EQ.ZERO ) THEN
+ INFO = JE - 1
+ RETURN
+ END IF
+*
+* Scale to avoid over/underflow
+*
+ ACOEFA = ABS( ACOEF )
+ BCOEFA = ABS( BCOEFR ) + ABS( BCOEFI )
+ SCALE = ONE
+ IF( ACOEFA*ULP.LT.SAFMIN .AND. ACOEFA.GE.SAFMIN )
+ $ SCALE = ( SAFMIN / ULP ) / ACOEFA
+ IF( BCOEFA*ULP.LT.SAFMIN .AND. BCOEFA.GE.SAFMIN )
+ $ SCALE = MAX( SCALE, ( SAFMIN / ULP ) / BCOEFA )
+ IF( SAFMIN*ACOEFA.GT.ASCALE )
+ $ SCALE = ASCALE / ( SAFMIN*ACOEFA )
+ IF( SAFMIN*BCOEFA.GT.BSCALE )
+ $ SCALE = MIN( SCALE, BSCALE / ( SAFMIN*BCOEFA ) )
+ IF( SCALE.NE.ONE ) THEN
+ ACOEF = SCALE*ACOEF
+ ACOEFA = ABS( ACOEF )
+ BCOEFR = SCALE*BCOEFR
+ BCOEFI = SCALE*BCOEFI
+ BCOEFA = ABS( BCOEFR ) + ABS( BCOEFI )
+ END IF
+*
+* Compute first two components of eigenvector
+* and contribution to sums
+*
+ TEMP = ACOEF*S( JE, JE-1 )
+ TEMP2R = ACOEF*S( JE, JE ) - BCOEFR*P( JE, JE )
+ TEMP2I = -BCOEFI*P( JE, JE )
+ IF( ABS( TEMP ).GE.ABS( TEMP2R )+ABS( TEMP2I ) ) THEN
+ WORK( 2*N+JE ) = ONE
+ WORK( 3*N+JE ) = ZERO
+ WORK( 2*N+JE-1 ) = -TEMP2R / TEMP
+ WORK( 3*N+JE-1 ) = -TEMP2I / TEMP
+ ELSE
+ WORK( 2*N+JE-1 ) = ONE
+ WORK( 3*N+JE-1 ) = ZERO
+ TEMP = ACOEF*S( JE-1, JE )
+ WORK( 2*N+JE ) = ( BCOEFR*P( JE-1, JE-1 )-ACOEF*
+ $ S( JE-1, JE-1 ) ) / TEMP
+ WORK( 3*N+JE ) = BCOEFI*P( JE-1, JE-1 ) / TEMP
+ END IF
+*
+ XMAX = MAX( ABS( WORK( 2*N+JE ) )+ABS( WORK( 3*N+JE ) ),
+ $ ABS( WORK( 2*N+JE-1 ) )+ABS( WORK( 3*N+JE-1 ) ) )
+*
+* Compute contribution from columns JE and JE-1
+* of A and B to the sums.
+*
+ CREALA = ACOEF*WORK( 2*N+JE-1 )
+ CIMAGA = ACOEF*WORK( 3*N+JE-1 )
+ CREALB = BCOEFR*WORK( 2*N+JE-1 ) -
+ $ BCOEFI*WORK( 3*N+JE-1 )
+ CIMAGB = BCOEFI*WORK( 2*N+JE-1 ) +
+ $ BCOEFR*WORK( 3*N+JE-1 )
+ CRE2A = ACOEF*WORK( 2*N+JE )
+ CIM2A = ACOEF*WORK( 3*N+JE )
+ CRE2B = BCOEFR*WORK( 2*N+JE ) - BCOEFI*WORK( 3*N+JE )
+ CIM2B = BCOEFI*WORK( 2*N+JE ) + BCOEFR*WORK( 3*N+JE )
+ DO 270 JR = 1, JE - 2
+ WORK( 2*N+JR ) = -CREALA*S( JR, JE-1 ) +
+ $ CREALB*P( JR, JE-1 ) -
+ $ CRE2A*S( JR, JE ) + CRE2B*P( JR, JE )
+ WORK( 3*N+JR ) = -CIMAGA*S( JR, JE-1 ) +
+ $ CIMAGB*P( JR, JE-1 ) -
+ $ CIM2A*S( JR, JE ) + CIM2B*P( JR, JE )
+ 270 CONTINUE
+ END IF
+*
+ DMIN = MAX( ULP*ACOEFA*ANORM, ULP*BCOEFA*BNORM, SAFMIN )
+*
+* Columnwise triangular solve of (a A - b B) x = 0
+*
+ IL2BY2 = .FALSE.
+ DO 370 J = JE - NW, 1, -1
+*
+* If a 2-by-2 block, is in position j-1:j, wait until
+* next iteration to process it (when it will be j:j+1)
+*
+ IF( .NOT.IL2BY2 .AND. J.GT.1 ) THEN
+ IF( S( J, J-1 ).NE.ZERO ) THEN
+ IL2BY2 = .TRUE.
+ GO TO 370
+ END IF
+ END IF
+ BDIAG( 1 ) = P( J, J )
+ IF( IL2BY2 ) THEN
+ NA = 2
+ BDIAG( 2 ) = P( J+1, J+1 )
+ ELSE
+ NA = 1
+ END IF
+*
+* Compute x(j) (and x(j+1), if 2-by-2 block)
+*
+ CALL SLALN2( .FALSE., NA, NW, DMIN, ACOEF, S( J, J ),
+ $ LDS, BDIAG( 1 ), BDIAG( 2 ), WORK( 2*N+J ),
+ $ N, BCOEFR, BCOEFI, SUM, 2, SCALE, TEMP,
+ $ IINFO )
+ IF( SCALE.LT.ONE ) THEN
+*
+ DO 290 JW = 0, NW - 1
+ DO 280 JR = 1, JE
+ WORK( ( JW+2 )*N+JR ) = SCALE*
+ $ WORK( ( JW+2 )*N+JR )
+ 280 CONTINUE
+ 290 CONTINUE
+ END IF
+ XMAX = MAX( SCALE*XMAX, TEMP )
+*
+ DO 310 JW = 1, NW
+ DO 300 JA = 1, NA
+ WORK( ( JW+1 )*N+J+JA-1 ) = SUM( JA, JW )
+ 300 CONTINUE
+ 310 CONTINUE
+*
+* w = w + x(j)*(a S(*,j) - b P(*,j) ) with scaling
+*
+ IF( J.GT.1 ) THEN
+*
+* Check whether scaling is necessary for sum.
+*
+ XSCALE = ONE / MAX( ONE, XMAX )
+ TEMP = ACOEFA*WORK( J ) + BCOEFA*WORK( N+J )
+ IF( IL2BY2 )
+ $ TEMP = MAX( TEMP, ACOEFA*WORK( J+1 )+BCOEFA*
+ $ WORK( N+J+1 ) )
+ TEMP = MAX( TEMP, ACOEFA, BCOEFA )
+ IF( TEMP.GT.BIGNUM*XSCALE ) THEN
+*
+ DO 330 JW = 0, NW - 1
+ DO 320 JR = 1, JE
+ WORK( ( JW+2 )*N+JR ) = XSCALE*
+ $ WORK( ( JW+2 )*N+JR )
+ 320 CONTINUE
+ 330 CONTINUE
+ XMAX = XMAX*XSCALE
+ END IF
+*
+* Compute the contributions of the off-diagonals of
+* column j (and j+1, if 2-by-2 block) of A and B to the
+* sums.
+*
+*
+ DO 360 JA = 1, NA
+ IF( ILCPLX ) THEN
+ CREALA = ACOEF*WORK( 2*N+J+JA-1 )
+ CIMAGA = ACOEF*WORK( 3*N+J+JA-1 )
+ CREALB = BCOEFR*WORK( 2*N+J+JA-1 ) -
+ $ BCOEFI*WORK( 3*N+J+JA-1 )
+ CIMAGB = BCOEFI*WORK( 2*N+J+JA-1 ) +
+ $ BCOEFR*WORK( 3*N+J+JA-1 )
+ DO 340 JR = 1, J - 1
+ WORK( 2*N+JR ) = WORK( 2*N+JR ) -
+ $ CREALA*S( JR, J+JA-1 ) +
+ $ CREALB*P( JR, J+JA-1 )
+ WORK( 3*N+JR ) = WORK( 3*N+JR ) -
+ $ CIMAGA*S( JR, J+JA-1 ) +
+ $ CIMAGB*P( JR, J+JA-1 )
+ 340 CONTINUE
+ ELSE
+ CREALA = ACOEF*WORK( 2*N+J+JA-1 )
+ CREALB = BCOEFR*WORK( 2*N+J+JA-1 )
+ DO 350 JR = 1, J - 1
+ WORK( 2*N+JR ) = WORK( 2*N+JR ) -
+ $ CREALA*S( JR, J+JA-1 ) +
+ $ CREALB*P( JR, J+JA-1 )
+ 350 CONTINUE
+ END IF
+ 360 CONTINUE
+ END IF
+*
+ IL2BY2 = .FALSE.
+ 370 CONTINUE
+*
+* Copy eigenvector to VR, back transforming if
+* HOWMNY='B'.
+*
+ IEIG = IEIG - NW
+ IF( ILBACK ) THEN
+*
+ DO 410 JW = 0, NW - 1
+ DO 380 JR = 1, N
+ WORK( ( JW+4 )*N+JR ) = WORK( ( JW+2 )*N+1 )*
+ $ VR( JR, 1 )
+ 380 CONTINUE
+*
+* A series of compiler directives to defeat
+* vectorization for the next loop
+*
+*
+ DO 400 JC = 2, JE
+ DO 390 JR = 1, N
+ WORK( ( JW+4 )*N+JR ) = WORK( ( JW+4 )*N+JR ) +
+ $ WORK( ( JW+2 )*N+JC )*VR( JR, JC )
+ 390 CONTINUE
+ 400 CONTINUE
+ 410 CONTINUE
+*
+ DO 430 JW = 0, NW - 1
+ DO 420 JR = 1, N
+ VR( JR, IEIG+JW ) = WORK( ( JW+4 )*N+JR )
+ 420 CONTINUE
+ 430 CONTINUE
+*
+ IEND = N
+ ELSE
+ DO 450 JW = 0, NW - 1
+ DO 440 JR = 1, N
+ VR( JR, IEIG+JW ) = WORK( ( JW+2 )*N+JR )
+ 440 CONTINUE
+ 450 CONTINUE
+*
+ IEND = JE
+ END IF
+*
+* Scale eigenvector
+*
+ XMAX = ZERO
+ IF( ILCPLX ) THEN
+ DO 460 J = 1, IEND
+ XMAX = MAX( XMAX, ABS( VR( J, IEIG ) )+
+ $ ABS( VR( J, IEIG+1 ) ) )
+ 460 CONTINUE
+ ELSE
+ DO 470 J = 1, IEND
+ XMAX = MAX( XMAX, ABS( VR( J, IEIG ) ) )
+ 470 CONTINUE
+ END IF
+*
+ IF( XMAX.GT.SAFMIN ) THEN
+ XSCALE = ONE / XMAX
+ DO 490 JW = 0, NW - 1
+ DO 480 JR = 1, IEND
+ VR( JR, IEIG+JW ) = XSCALE*VR( JR, IEIG+JW )
+ 480 CONTINUE
+ 490 CONTINUE
+ END IF
+ 500 CONTINUE
+ END IF
+*
+ RETURN
+*
+* End of STGEVC
+*
+ END
+ SUBROUTINE STGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z,
+ $ LDZ, J1, N1, N2, WORK, LWORK, INFO )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ LOGICAL WANTQ, WANTZ
+ INTEGER INFO, J1, LDA, LDB, LDQ, LDZ, LWORK, N, N1, N2
+* ..
+* .. Array Arguments ..
+ REAL A( LDA, * ), B( LDB, * ), Q( LDQ, * ),
+ $ WORK( * ), Z( LDZ, * )
+* ..
+*
+* Purpose
+* =======
+*
+* STGEX2 swaps adjacent diagonal blocks (A11, B11) and (A22, B22)
+* of size 1-by-1 or 2-by-2 in an upper (quasi) triangular matrix pair
+* (A, B) by an orthogonal equivalence transformation.
+*
+* (A, B) must be in generalized real Schur canonical form (as returned
+* by SGGES), i.e. A is block upper triangular with 1-by-1 and 2-by-2
+* diagonal blocks. B is upper triangular.
+*
+* Optionally, the matrices Q and Z of generalized Schur vectors are
+* updated.
+*
+* Q(in) * A(in) * Z(in)' = Q(out) * A(out) * Z(out)'
+* Q(in) * B(in) * Z(in)' = Q(out) * B(out) * Z(out)'
+*
+*
+* Arguments
+* =========
+*
+* WANTQ (input) LOGICAL
+* .TRUE. : update the left transformation matrix Q;
+* .FALSE.: do not update Q.
+*
+* WANTZ (input) LOGICAL
+* .TRUE. : update the right transformation matrix Z;
+* .FALSE.: do not update Z.
+*
+* N (input) INTEGER
+* The order of the matrices A and B. N >= 0.
+*
+* A (input/output) REAL arrays, dimensions (LDA,N)
+* On entry, the matrix A in the pair (A, B).
+* On exit, the updated matrix A.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,N).
+*
+* B (input/output) REAL arrays, dimensions (LDB,N)
+* On entry, the matrix B in the pair (A, B).
+* On exit, the updated matrix B.
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. LDB >= max(1,N).
+*
+* Q (input/output) REAL array, dimension (LDZ,N)
+* On entry, if WANTQ = .TRUE., the orthogonal matrix Q.
+* On exit, the updated matrix Q.
+* Not referenced if WANTQ = .FALSE..
+*
+* LDQ (input) INTEGER
+* The leading dimension of the array Q. LDQ >= 1.
+* If WANTQ = .TRUE., LDQ >= N.
+*
+* Z (input/output) REAL array, dimension (LDZ,N)
+* On entry, if WANTZ =.TRUE., the orthogonal matrix Z.
+* On exit, the updated matrix Z.
+* Not referenced if WANTZ = .FALSE..
+*
+* LDZ (input) INTEGER
+* The leading dimension of the array Z. LDZ >= 1.
+* If WANTZ = .TRUE., LDZ >= N.
+*
+* J1 (input) INTEGER
+* The index to the first block (A11, B11). 1 <= J1 <= N.
+*
+* N1 (input) INTEGER
+* The order of the first block (A11, B11). N1 = 0, 1 or 2.
+*
+* N2 (input) INTEGER
+* The order of the second block (A22, B22). N2 = 0, 1 or 2.
+*
+* WORK (workspace) REAL array, dimension (MAX(1,LWORK)).
+*
+* LWORK (input) INTEGER
+* The dimension of the array WORK.
+* LWORK >= MAX( N*(N2+N1), (N2+N1)*(N2+N1)*2 )
+*
+* INFO (output) INTEGER
+* =0: Successful exit
+* >0: If INFO = 1, the transformed matrix (A, B) would be
+* too far from generalized Schur form; the blocks are
+* not swapped and (A, B) and (Q, Z) are unchanged.
+* The problem of swapping is too ill-conditioned.
+* <0: If INFO = -16: LWORK is too small. Appropriate value
+* for LWORK is returned in WORK(1).
+*
+* Further Details
+* ===============
+*
+* Based on contributions by
+* Bo Kagstrom and Peter Poromaa, Department of Computing Science,
+* Umea University, S-901 87 Umea, Sweden.
+*
+* In the current code both weak and strong stability tests are
+* performed. The user can omit the strong stability test by changing
+* the internal logical parameter WANDS to .FALSE.. See ref. [2] for
+* details.
+*
+* [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the
+* Generalized Real Schur Form of a Regular Matrix Pair (A, B), in
+* M.S. Moonen et al (eds), Linear Algebra for Large Scale and
+* Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218.
+*
+* [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified
+* Eigenvalues of a Regular Matrix Pair (A, B) and Condition
+* Estimation: Theory, Algorithms and Software,
+* Report UMINF - 94.04, Department of Computing Science, Umea
+* University, S-901 87 Umea, Sweden, 1994. Also as LAPACK Working
+* Note 87. To appear in Numerical Algorithms, 1996.
+*
+* =====================================================================
+* Replaced various illegal calls to SCOPY by calls to SLASET, or by DO
+* loops. Sven Hammarling, 1/5/02.
+*
+* .. Parameters ..
+ REAL ZERO, ONE
+ PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+ REAL TEN
+ PARAMETER ( TEN = 1.0E+01 )
+ INTEGER LDST
+ PARAMETER ( LDST = 4 )
+ LOGICAL WANDS
+ PARAMETER ( WANDS = .TRUE. )
+* ..
+* .. Local Scalars ..
+ LOGICAL STRONG, WEAK
+ INTEGER I, IDUM, LINFO, M
+ REAL BQRA21, BRQA21, DDUM, DNORM, DSCALE, DSUM, EPS,
+ $ F, G, SA, SB, SCALE, SMLNUM, SS, THRESH, WS
+* ..
+* .. Local Arrays ..
+ INTEGER IWORK( LDST )
+ REAL AI( 2 ), AR( 2 ), BE( 2 ), IR( LDST, LDST ),
+ $ IRCOP( LDST, LDST ), LI( LDST, LDST ),
+ $ LICOP( LDST, LDST ), S( LDST, LDST ),
+ $ SCPY( LDST, LDST ), T( LDST, LDST ),
+ $ TAUL( LDST ), TAUR( LDST ), TCPY( LDST, LDST )
+* ..
+* .. External Functions ..
+ REAL SLAMCH
+ EXTERNAL SLAMCH
+* ..
+* .. External Subroutines ..
+ EXTERNAL SGEMM, SGEQR2, SGERQ2, SLACPY, SLAGV2, SLARTG,
+ $ SLASET, SLASSQ, SORG2R, SORGR2, SORM2R, SORMR2,
+ $ SROT, SSCAL, STGSY2
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, SQRT
+* ..
+* .. Executable Statements ..
+*
+ INFO = 0
+*
+* Quick return if possible
+*
+ IF( N.LE.1 .OR. N1.LE.0 .OR. N2.LE.0 )
+ $ RETURN
+ IF( N1.GT.N .OR. ( J1+N1 ).GT.N )
+ $ RETURN
+ M = N1 + N2
+ IF( LWORK.LT.MAX( N*M, M*M*2 ) ) THEN
+ INFO = -16
+ WORK( 1 ) = MAX( N*M, M*M*2 )
+ RETURN
+ END IF
+*
+ WEAK = .FALSE.
+ STRONG = .FALSE.
+*
+* Make a local copy of selected block
+*
+ CALL SLASET( 'Full', LDST, LDST, ZERO, ZERO, LI, LDST )
+ CALL SLASET( 'Full', LDST, LDST, ZERO, ZERO, IR, LDST )
+ CALL SLACPY( 'Full', M, M, A( J1, J1 ), LDA, S, LDST )
+ CALL SLACPY( 'Full', M, M, B( J1, J1 ), LDB, T, LDST )
+*
+* Compute threshold for testing acceptance of swapping.
+*
+ EPS = SLAMCH( 'P' )
+ SMLNUM = SLAMCH( 'S' ) / EPS
+ DSCALE = ZERO
+ DSUM = ONE
+ CALL SLACPY( 'Full', M, M, S, LDST, WORK, M )
+ CALL SLASSQ( M*M, WORK, 1, DSCALE, DSUM )
+ CALL SLACPY( 'Full', M, M, T, LDST, WORK, M )
+ CALL SLASSQ( M*M, WORK, 1, DSCALE, DSUM )
+ DNORM = DSCALE*SQRT( DSUM )
+ THRESH = MAX( TEN*EPS*DNORM, SMLNUM )
+*
+ IF( M.EQ.2 ) THEN
+*
+* CASE 1: Swap 1-by-1 and 1-by-1 blocks.
+*
+* Compute orthogonal QL and RQ that swap 1-by-1 and 1-by-1 blocks
+* using Givens rotations and perform the swap tentatively.
+*
+ F = S( 2, 2 )*T( 1, 1 ) - T( 2, 2 )*S( 1, 1 )
+ G = S( 2, 2 )*T( 1, 2 ) - T( 2, 2 )*S( 1, 2 )
+ SB = ABS( T( 2, 2 ) )
+ SA = ABS( S( 2, 2 ) )
+ CALL SLARTG( F, G, IR( 1, 2 ), IR( 1, 1 ), DDUM )
+ IR( 2, 1 ) = -IR( 1, 2 )
+ IR( 2, 2 ) = IR( 1, 1 )
+ CALL SROT( 2, S( 1, 1 ), 1, S( 1, 2 ), 1, IR( 1, 1 ),
+ $ IR( 2, 1 ) )
+ CALL SROT( 2, T( 1, 1 ), 1, T( 1, 2 ), 1, IR( 1, 1 ),
+ $ IR( 2, 1 ) )
+ IF( SA.GE.SB ) THEN
+ CALL SLARTG( S( 1, 1 ), S( 2, 1 ), LI( 1, 1 ), LI( 2, 1 ),
+ $ DDUM )
+ ELSE
+ CALL SLARTG( T( 1, 1 ), T( 2, 1 ), LI( 1, 1 ), LI( 2, 1 ),
+ $ DDUM )
+ END IF
+ CALL SROT( 2, S( 1, 1 ), LDST, S( 2, 1 ), LDST, LI( 1, 1 ),
+ $ LI( 2, 1 ) )
+ CALL SROT( 2, T( 1, 1 ), LDST, T( 2, 1 ), LDST, LI( 1, 1 ),
+ $ LI( 2, 1 ) )
+ LI( 2, 2 ) = LI( 1, 1 )
+ LI( 1, 2 ) = -LI( 2, 1 )
+*
+* Weak stability test:
+* |S21| + |T21| <= O(EPS * F-norm((S, T)))
+*
+ WS = ABS( S( 2, 1 ) ) + ABS( T( 2, 1 ) )
+ WEAK = WS.LE.THRESH
+ IF( .NOT.WEAK )
+ $ GO TO 70
+*
+ IF( WANDS ) THEN
+*
+* Strong stability test:
+* F-norm((A-QL'*S*QR, B-QL'*T*QR)) <= O(EPS*F-norm((A,B)))
+*
+ CALL SLACPY( 'Full', M, M, A( J1, J1 ), LDA, WORK( M*M+1 ),
+ $ M )
+ CALL SGEMM( 'N', 'N', M, M, M, ONE, LI, LDST, S, LDST, ZERO,
+ $ WORK, M )
+ CALL SGEMM( 'N', 'T', M, M, M, -ONE, WORK, M, IR, LDST, ONE,
+ $ WORK( M*M+1 ), M )
+ DSCALE = ZERO
+ DSUM = ONE
+ CALL SLASSQ( M*M, WORK( M*M+1 ), 1, DSCALE, DSUM )
+*
+ CALL SLACPY( 'Full', M, M, B( J1, J1 ), LDB, WORK( M*M+1 ),
+ $ M )
+ CALL SGEMM( 'N', 'N', M, M, M, ONE, LI, LDST, T, LDST, ZERO,
+ $ WORK, M )
+ CALL SGEMM( 'N', 'T', M, M, M, -ONE, WORK, M, IR, LDST, ONE,
+ $ WORK( M*M+1 ), M )
+ CALL SLASSQ( M*M, WORK( M*M+1 ), 1, DSCALE, DSUM )
+ SS = DSCALE*SQRT( DSUM )
+ STRONG = SS.LE.THRESH
+ IF( .NOT.STRONG )
+ $ GO TO 70
+ END IF
+*
+* Update (A(J1:J1+M-1, M+J1:N), B(J1:J1+M-1, M+J1:N)) and
+* (A(1:J1-1, J1:J1+M), B(1:J1-1, J1:J1+M)).
+*
+ CALL SROT( J1+1, A( 1, J1 ), 1, A( 1, J1+1 ), 1, IR( 1, 1 ),
+ $ IR( 2, 1 ) )
+ CALL SROT( J1+1, B( 1, J1 ), 1, B( 1, J1+1 ), 1, IR( 1, 1 ),
+ $ IR( 2, 1 ) )
+ CALL SROT( N-J1+1, A( J1, J1 ), LDA, A( J1+1, J1 ), LDA,
+ $ LI( 1, 1 ), LI( 2, 1 ) )
+ CALL SROT( N-J1+1, B( J1, J1 ), LDB, B( J1+1, J1 ), LDB,
+ $ LI( 1, 1 ), LI( 2, 1 ) )
+*
+* Set N1-by-N2 (2,1) - blocks to ZERO.
+*
+ A( J1+1, J1 ) = ZERO
+ B( J1+1, J1 ) = ZERO
+*
+* Accumulate transformations into Q and Z if requested.
+*
+ IF( WANTZ )
+ $ CALL SROT( N, Z( 1, J1 ), 1, Z( 1, J1+1 ), 1, IR( 1, 1 ),
+ $ IR( 2, 1 ) )
+ IF( WANTQ )
+ $ CALL SROT( N, Q( 1, J1 ), 1, Q( 1, J1+1 ), 1, LI( 1, 1 ),
+ $ LI( 2, 1 ) )
+*
+* Exit with INFO = 0 if swap was successfully performed.
+*
+ RETURN
+*
+ ELSE
+*
+* CASE 2: Swap 1-by-1 and 2-by-2 blocks, or 2-by-2
+* and 2-by-2 blocks.
+*
+* Solve the generalized Sylvester equation
+* S11 * R - L * S22 = SCALE * S12
+* T11 * R - L * T22 = SCALE * T12
+* for R and L. Solutions in LI and IR.
+*
+ CALL SLACPY( 'Full', N1, N2, T( 1, N1+1 ), LDST, LI, LDST )
+ CALL SLACPY( 'Full', N1, N2, S( 1, N1+1 ), LDST,
+ $ IR( N2+1, N1+1 ), LDST )
+ CALL STGSY2( 'N', 0, N1, N2, S, LDST, S( N1+1, N1+1 ), LDST,
+ $ IR( N2+1, N1+1 ), LDST, T, LDST, T( N1+1, N1+1 ),
+ $ LDST, LI, LDST, SCALE, DSUM, DSCALE, IWORK, IDUM,
+ $ LINFO )
+*
+* Compute orthogonal matrix QL:
+*
+* QL' * LI = [ TL ]
+* [ 0 ]
+* where
+* LI = [ -L ]
+* [ SCALE * identity(N2) ]
+*
+ DO 10 I = 1, N2
+ CALL SSCAL( N1, -ONE, LI( 1, I ), 1 )
+ LI( N1+I, I ) = SCALE
+ 10 CONTINUE
+ CALL SGEQR2( M, N2, LI, LDST, TAUL, WORK, LINFO )
+ IF( LINFO.NE.0 )
+ $ GO TO 70
+ CALL SORG2R( M, M, N2, LI, LDST, TAUL, WORK, LINFO )
+ IF( LINFO.NE.0 )
+ $ GO TO 70
+*
+* Compute orthogonal matrix RQ:
+*
+* IR * RQ' = [ 0 TR],
+*
+* where IR = [ SCALE * identity(N1), R ]
+*
+ DO 20 I = 1, N1
+ IR( N2+I, I ) = SCALE
+ 20 CONTINUE
+ CALL SGERQ2( N1, M, IR( N2+1, 1 ), LDST, TAUR, WORK, LINFO )
+ IF( LINFO.NE.0 )
+ $ GO TO 70
+ CALL SORGR2( M, M, N1, IR, LDST, TAUR, WORK, LINFO )
+ IF( LINFO.NE.0 )
+ $ GO TO 70
+*
+* Perform the swapping tentatively:
+*
+ CALL SGEMM( 'T', 'N', M, M, M, ONE, LI, LDST, S, LDST, ZERO,
+ $ WORK, M )
+ CALL SGEMM( 'N', 'T', M, M, M, ONE, WORK, M, IR, LDST, ZERO, S,
+ $ LDST )
+ CALL SGEMM( 'T', 'N', M, M, M, ONE, LI, LDST, T, LDST, ZERO,
+ $ WORK, M )
+ CALL SGEMM( 'N', 'T', M, M, M, ONE, WORK, M, IR, LDST, ZERO, T,
+ $ LDST )
+ CALL SLACPY( 'F', M, M, S, LDST, SCPY, LDST )
+ CALL SLACPY( 'F', M, M, T, LDST, TCPY, LDST )
+ CALL SLACPY( 'F', M, M, IR, LDST, IRCOP, LDST )
+ CALL SLACPY( 'F', M, M, LI, LDST, LICOP, LDST )
+*
+* Triangularize the B-part by an RQ factorization.
+* Apply transformation (from left) to A-part, giving S.
+*
+ CALL SGERQ2( M, M, T, LDST, TAUR, WORK, LINFO )
+ IF( LINFO.NE.0 )
+ $ GO TO 70
+ CALL SORMR2( 'R', 'T', M, M, M, T, LDST, TAUR, S, LDST, WORK,
+ $ LINFO )
+ IF( LINFO.NE.0 )
+ $ GO TO 70
+ CALL SORMR2( 'L', 'N', M, M, M, T, LDST, TAUR, IR, LDST, WORK,
+ $ LINFO )
+ IF( LINFO.NE.0 )
+ $ GO TO 70
+*
+* Compute F-norm(S21) in BRQA21. (T21 is 0.)
+*
+ DSCALE = ZERO
+ DSUM = ONE
+ DO 30 I = 1, N2
+ CALL SLASSQ( N1, S( N2+1, I ), 1, DSCALE, DSUM )
+ 30 CONTINUE
+ BRQA21 = DSCALE*SQRT( DSUM )
+*
+* Triangularize the B-part by a QR factorization.
+* Apply transformation (from right) to A-part, giving S.
+*
+ CALL SGEQR2( M, M, TCPY, LDST, TAUL, WORK, LINFO )
+ IF( LINFO.NE.0 )
+ $ GO TO 70
+ CALL SORM2R( 'L', 'T', M, M, M, TCPY, LDST, TAUL, SCPY, LDST,
+ $ WORK, INFO )
+ CALL SORM2R( 'R', 'N', M, M, M, TCPY, LDST, TAUL, LICOP, LDST,
+ $ WORK, INFO )
+ IF( LINFO.NE.0 )
+ $ GO TO 70
+*
+* Compute F-norm(S21) in BQRA21. (T21 is 0.)
+*
+ DSCALE = ZERO
+ DSUM = ONE
+ DO 40 I = 1, N2
+ CALL SLASSQ( N1, SCPY( N2+1, I ), 1, DSCALE, DSUM )
+ 40 CONTINUE
+ BQRA21 = DSCALE*SQRT( DSUM )
+*
+* Decide which method to use.
+* Weak stability test:
+* F-norm(S21) <= O(EPS * F-norm((S, T)))
+*
+ IF( BQRA21.LE.BRQA21 .AND. BQRA21.LE.THRESH ) THEN
+ CALL SLACPY( 'F', M, M, SCPY, LDST, S, LDST )
+ CALL SLACPY( 'F', M, M, TCPY, LDST, T, LDST )
+ CALL SLACPY( 'F', M, M, IRCOP, LDST, IR, LDST )
+ CALL SLACPY( 'F', M, M, LICOP, LDST, LI, LDST )
+ ELSE IF( BRQA21.GE.THRESH ) THEN
+ GO TO 70
+ END IF
+*
+* Set lower triangle of B-part to zero
+*
+ CALL SLASET( 'Lower', M-1, M-1, ZERO, ZERO, T(2,1), LDST )
+*
+ IF( WANDS ) THEN
+*
+* Strong stability test:
+* F-norm((A-QL*S*QR', B-QL*T*QR')) <= O(EPS*F-norm((A,B)))
+*
+ CALL SLACPY( 'Full', M, M, A( J1, J1 ), LDA, WORK( M*M+1 ),
+ $ M )
+ CALL SGEMM( 'N', 'N', M, M, M, ONE, LI, LDST, S, LDST, ZERO,
+ $ WORK, M )
+ CALL SGEMM( 'N', 'N', M, M, M, -ONE, WORK, M, IR, LDST, ONE,
+ $ WORK( M*M+1 ), M )
+ DSCALE = ZERO
+ DSUM = ONE
+ CALL SLASSQ( M*M, WORK( M*M+1 ), 1, DSCALE, DSUM )
+*
+ CALL SLACPY( 'Full', M, M, B( J1, J1 ), LDB, WORK( M*M+1 ),
+ $ M )
+ CALL SGEMM( 'N', 'N', M, M, M, ONE, LI, LDST, T, LDST, ZERO,
+ $ WORK, M )
+ CALL SGEMM( 'N', 'N', M, M, M, -ONE, WORK, M, IR, LDST, ONE,
+ $ WORK( M*M+1 ), M )
+ CALL SLASSQ( M*M, WORK( M*M+1 ), 1, DSCALE, DSUM )
+ SS = DSCALE*SQRT( DSUM )
+ STRONG = ( SS.LE.THRESH )
+ IF( .NOT.STRONG )
+ $ GO TO 70
+*
+ END IF
+*
+* If the swap is accepted ("weakly" and "strongly"), apply the
+* transformations and set N1-by-N2 (2,1)-block to zero.
+*
+ CALL SLASET( 'Full', N1, N2, ZERO, ZERO, S(N2+1,1), LDST )
+*
+* copy back M-by-M diagonal block starting at index J1 of (A, B)
+*
+ CALL SLACPY( 'F', M, M, S, LDST, A( J1, J1 ), LDA )
+ CALL SLACPY( 'F', M, M, T, LDST, B( J1, J1 ), LDB )
+ CALL SLASET( 'Full', LDST, LDST, ZERO, ZERO, T, LDST )
+*
+* Standardize existing 2-by-2 blocks.
+*
+ DO 50 I = 1, M*M
+ WORK(I) = ZERO
+ 50 CONTINUE
+ WORK( 1 ) = ONE
+ T( 1, 1 ) = ONE
+ IDUM = LWORK - M*M - 2
+ IF( N2.GT.1 ) THEN
+ CALL SLAGV2( A( J1, J1 ), LDA, B( J1, J1 ), LDB, AR, AI, BE,
+ $ WORK( 1 ), WORK( 2 ), T( 1, 1 ), T( 2, 1 ) )
+ WORK( M+1 ) = -WORK( 2 )
+ WORK( M+2 ) = WORK( 1 )
+ T( N2, N2 ) = T( 1, 1 )
+ T( 1, 2 ) = -T( 2, 1 )
+ END IF
+ WORK( M*M ) = ONE
+ T( M, M ) = ONE
+*
+ IF( N1.GT.1 ) THEN
+ CALL SLAGV2( A( J1+N2, J1+N2 ), LDA, B( J1+N2, J1+N2 ), LDB,
+ $ TAUR, TAUL, WORK( M*M+1 ), WORK( N2*M+N2+1 ),
+ $ WORK( N2*M+N2+2 ), T( N2+1, N2+1 ),
+ $ T( M, M-1 ) )
+ WORK( M*M ) = WORK( N2*M+N2+1 )
+ WORK( M*M-1 ) = -WORK( N2*M+N2+2 )
+ T( M, M ) = T( N2+1, N2+1 )
+ T( M-1, M ) = -T( M, M-1 )
+ END IF
+ CALL SGEMM( 'T', 'N', N2, N1, N2, ONE, WORK, M, A( J1, J1+N2 ),
+ $ LDA, ZERO, WORK( M*M+1 ), N2 )
+ CALL SLACPY( 'Full', N2, N1, WORK( M*M+1 ), N2, A( J1, J1+N2 ),
+ $ LDA )
+ CALL SGEMM( 'T', 'N', N2, N1, N2, ONE, WORK, M, B( J1, J1+N2 ),
+ $ LDB, ZERO, WORK( M*M+1 ), N2 )
+ CALL SLACPY( 'Full', N2, N1, WORK( M*M+1 ), N2, B( J1, J1+N2 ),
+ $ LDB )
+ CALL SGEMM( 'N', 'N', M, M, M, ONE, LI, LDST, WORK, M, ZERO,
+ $ WORK( M*M+1 ), M )
+ CALL SLACPY( 'Full', M, M, WORK( M*M+1 ), M, LI, LDST )
+ CALL SGEMM( 'N', 'N', N2, N1, N1, ONE, A( J1, J1+N2 ), LDA,
+ $ T( N2+1, N2+1 ), LDST, ZERO, WORK, N2 )
+ CALL SLACPY( 'Full', N2, N1, WORK, N2, A( J1, J1+N2 ), LDA )
+ CALL SGEMM( 'N', 'N', N2, N1, N1, ONE, B( J1, J1+N2 ), LDB,
+ $ T( N2+1, N2+1 ), LDST, ZERO, WORK, N2 )
+ CALL SLACPY( 'Full', N2, N1, WORK, N2, B( J1, J1+N2 ), LDB )
+ CALL SGEMM( 'T', 'N', M, M, M, ONE, IR, LDST, T, LDST, ZERO,
+ $ WORK, M )
+ CALL SLACPY( 'Full', M, M, WORK, M, IR, LDST )
+*
+* Accumulate transformations into Q and Z if requested.
+*
+ IF( WANTQ ) THEN
+ CALL SGEMM( 'N', 'N', N, M, M, ONE, Q( 1, J1 ), LDQ, LI,
+ $ LDST, ZERO, WORK, N )
+ CALL SLACPY( 'Full', N, M, WORK, N, Q( 1, J1 ), LDQ )
+*
+ END IF
+*
+ IF( WANTZ ) THEN
+ CALL SGEMM( 'N', 'N', N, M, M, ONE, Z( 1, J1 ), LDZ, IR,
+ $ LDST, ZERO, WORK, N )
+ CALL SLACPY( 'Full', N, M, WORK, N, Z( 1, J1 ), LDZ )
+*
+ END IF
+*
+* Update (A(J1:J1+M-1, M+J1:N), B(J1:J1+M-1, M+J1:N)) and
+* (A(1:J1-1, J1:J1+M), B(1:J1-1, J1:J1+M)).
+*
+ I = J1 + M
+ IF( I.LE.N ) THEN
+ CALL SGEMM( 'T', 'N', M, N-I+1, M, ONE, LI, LDST,
+ $ A( J1, I ), LDA, ZERO, WORK, M )
+ CALL SLACPY( 'Full', M, N-I+1, WORK, M, A( J1, I ), LDA )
+ CALL SGEMM( 'T', 'N', M, N-I+1, M, ONE, LI, LDST,
+ $ B( J1, I ), LDB, ZERO, WORK, M )
+ CALL SLACPY( 'Full', M, N-I+1, WORK, M, B( J1, I ), LDB )
+ END IF
+ I = J1 - 1
+ IF( I.GT.0 ) THEN
+ CALL SGEMM( 'N', 'N', I, M, M, ONE, A( 1, J1 ), LDA, IR,
+ $ LDST, ZERO, WORK, I )
+ CALL SLACPY( 'Full', I, M, WORK, I, A( 1, J1 ), LDA )
+ CALL SGEMM( 'N', 'N', I, M, M, ONE, B( 1, J1 ), LDB, IR,
+ $ LDST, ZERO, WORK, I )
+ CALL SLACPY( 'Full', I, M, WORK, I, B( 1, J1 ), LDB )
+ END IF
+*
+* Exit with INFO = 0 if swap was successfully performed.
+*
+ RETURN
+*
+ END IF
+*
+* Exit with INFO = 1 if swap was rejected.
+*
+ 70 CONTINUE
+*
+ INFO = 1
+ RETURN
+*
+* End of STGEX2
+*
+ END
+ SUBROUTINE STGEXC( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z,
+ $ LDZ, IFST, ILST, WORK, LWORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ LOGICAL WANTQ, WANTZ
+ INTEGER IFST, ILST, INFO, LDA, LDB, LDQ, LDZ, LWORK, N
+* ..
+* .. Array Arguments ..
+ REAL A( LDA, * ), B( LDB, * ), Q( LDQ, * ),
+ $ WORK( * ), Z( LDZ, * )
+* ..
+*
+* Purpose
+* =======
+*
+* STGEXC reorders the generalized real Schur decomposition of a real
+* matrix pair (A,B) using an orthogonal equivalence transformation
+*
+* (A, B) = Q * (A, B) * Z',
+*
+* so that the diagonal block of (A, B) with row index IFST is moved
+* to row ILST.
+*
+* (A, B) must be in generalized real Schur canonical form (as returned
+* by SGGES), i.e. A is block upper triangular with 1-by-1 and 2-by-2
+* diagonal blocks. B is upper triangular.
+*
+* Optionally, the matrices Q and Z of generalized Schur vectors are
+* updated.
+*
+* Q(in) * A(in) * Z(in)' = Q(out) * A(out) * Z(out)'
+* Q(in) * B(in) * Z(in)' = Q(out) * B(out) * Z(out)'
+*
+*
+* Arguments
+* =========
+*
+* WANTQ (input) LOGICAL
+* .TRUE. : update the left transformation matrix Q;
+* .FALSE.: do not update Q.
+*
+* WANTZ (input) LOGICAL
+* .TRUE. : update the right transformation matrix Z;
+* .FALSE.: do not update Z.
+*
+* N (input) INTEGER
+* The order of the matrices A and B. N >= 0.
+*
+* A (input/output) REAL array, dimension (LDA,N)
+* On entry, the matrix A in generalized real Schur canonical
+* form.
+* On exit, the updated matrix A, again in generalized
+* real Schur canonical form.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,N).
+*
+* B (input/output) REAL array, dimension (LDB,N)
+* On entry, the matrix B in generalized real Schur canonical
+* form (A,B).
+* On exit, the updated matrix B, again in generalized
+* real Schur canonical form (A,B).
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. LDB >= max(1,N).
+*
+* Q (input/output) REAL array, dimension (LDZ,N)
+* On entry, if WANTQ = .TRUE., the orthogonal matrix Q.
+* On exit, the updated matrix Q.
+* If WANTQ = .FALSE., Q is not referenced.
+*
+* LDQ (input) INTEGER
+* The leading dimension of the array Q. LDQ >= 1.
+* If WANTQ = .TRUE., LDQ >= N.
+*
+* Z (input/output) REAL array, dimension (LDZ,N)
+* On entry, if WANTZ = .TRUE., the orthogonal matrix Z.
+* On exit, the updated matrix Z.
+* If WANTZ = .FALSE., Z is not referenced.
+*
+* LDZ (input) INTEGER
+* The leading dimension of the array Z. LDZ >= 1.
+* If WANTZ = .TRUE., LDZ >= N.
+*
+* IFST (input/output) INTEGER
+* ILST (input/output) INTEGER
+* Specify the reordering of the diagonal blocks of (A, B).
+* The block with row index IFST is moved to row ILST, by a
+* sequence of swapping between adjacent blocks.
+* On exit, if IFST pointed on entry to the second row of
+* a 2-by-2 block, it is changed to point to the first row;
+* ILST always points to the first row of the block in its
+* final position (which may differ from its input value by
+* +1 or -1). 1 <= IFST, ILST <= N.
+*
+* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))
+* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+* LWORK (input) INTEGER
+* The dimension of the array WORK.
+* LWORK >= 1 when N <= 1, otherwise LWORK >= 4*N + 16.
+*
+* If LWORK = -1, then a workspace query is assumed; the routine
+* only calculates the optimal size of the WORK array, returns
+* this value as the first entry of the WORK array, and no error
+* message related to LWORK is issued by XERBLA.
+*
+* INFO (output) INTEGER
+* =0: successful exit.
+* <0: if INFO = -i, the i-th argument had an illegal value.
+* =1: The transformed matrix pair (A, B) would be too far
+* from generalized Schur form; the problem is ill-
+* conditioned. (A, B) may have been partially reordered,
+* and ILST points to the first row of the current
+* position of the block being moved.
+*
+* Further Details
+* ===============
+*
+* Based on contributions by
+* Bo Kagstrom and Peter Poromaa, Department of Computing Science,
+* Umea University, S-901 87 Umea, Sweden.
+*
+* [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the
+* Generalized Real Schur Form of a Regular Matrix Pair (A, B), in
+* M.S. Moonen et al (eds), Linear Algebra for Large Scale and
+* Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO
+ PARAMETER ( ZERO = 0.0E+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL LQUERY
+ INTEGER HERE, LWMIN, NBF, NBL, NBNEXT
+* ..
+* .. External Subroutines ..
+ EXTERNAL STGEX2, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+* Decode and test input arguments.
+*
+ INFO = 0
+ LQUERY = ( LWORK.EQ.-1 )
+ IF( N.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -5
+ ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -7
+ ELSE IF( LDQ.LT.1 .OR. WANTQ .AND. ( LDQ.LT.MAX( 1, N ) ) ) THEN
+ INFO = -9
+ ELSE IF( LDZ.LT.1 .OR. WANTZ .AND. ( LDZ.LT.MAX( 1, N ) ) ) THEN
+ INFO = -11
+ ELSE IF( IFST.LT.1 .OR. IFST.GT.N ) THEN
+ INFO = -12
+ ELSE IF( ILST.LT.1 .OR. ILST.GT.N ) THEN
+ INFO = -13
+ END IF
+*
+ IF( INFO.EQ.0 ) THEN
+ IF( N.LE.1 ) THEN
+ LWMIN = 1
+ ELSE
+ LWMIN = 4*N + 16
+ END IF
+ WORK(1) = LWMIN
+*
+ IF (LWORK.LT.LWMIN .AND. .NOT.LQUERY) THEN
+ INFO = -15
+ END IF
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'STGEXC', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.LE.1 )
+ $ RETURN
+*
+* Determine the first row of the specified block and find out
+* if it is 1-by-1 or 2-by-2.
+*
+ IF( IFST.GT.1 ) THEN
+ IF( A( IFST, IFST-1 ).NE.ZERO )
+ $ IFST = IFST - 1
+ END IF
+ NBF = 1
+ IF( IFST.LT.N ) THEN
+ IF( A( IFST+1, IFST ).NE.ZERO )
+ $ NBF = 2
+ END IF
+*
+* Determine the first row of the final block
+* and find out if it is 1-by-1 or 2-by-2.
+*
+ IF( ILST.GT.1 ) THEN
+ IF( A( ILST, ILST-1 ).NE.ZERO )
+ $ ILST = ILST - 1
+ END IF
+ NBL = 1
+ IF( ILST.LT.N ) THEN
+ IF( A( ILST+1, ILST ).NE.ZERO )
+ $ NBL = 2
+ END IF
+ IF( IFST.EQ.ILST )
+ $ RETURN
+*
+ IF( IFST.LT.ILST ) THEN
+*
+* Update ILST.
+*
+ IF( NBF.EQ.2 .AND. NBL.EQ.1 )
+ $ ILST = ILST - 1
+ IF( NBF.EQ.1 .AND. NBL.EQ.2 )
+ $ ILST = ILST + 1
+*
+ HERE = IFST
+*
+ 10 CONTINUE
+*
+* Swap with next one below.
+*
+ IF( NBF.EQ.1 .OR. NBF.EQ.2 ) THEN
+*
+* Current block either 1-by-1 or 2-by-2.
+*
+ NBNEXT = 1
+ IF( HERE+NBF+1.LE.N ) THEN
+ IF( A( HERE+NBF+1, HERE+NBF ).NE.ZERO )
+ $ NBNEXT = 2
+ END IF
+ CALL STGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z,
+ $ LDZ, HERE, NBF, NBNEXT, WORK, LWORK, INFO )
+ IF( INFO.NE.0 ) THEN
+ ILST = HERE
+ RETURN
+ END IF
+ HERE = HERE + NBNEXT
+*
+* Test if 2-by-2 block breaks into two 1-by-1 blocks.
+*
+ IF( NBF.EQ.2 ) THEN
+ IF( A( HERE+1, HERE ).EQ.ZERO )
+ $ NBF = 3
+ END IF
+*
+ ELSE
+*
+* Current block consists of two 1-by-1 blocks, each of which
+* must be swapped individually.
+*
+ NBNEXT = 1
+ IF( HERE+3.LE.N ) THEN
+ IF( A( HERE+3, HERE+2 ).NE.ZERO )
+ $ NBNEXT = 2
+ END IF
+ CALL STGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z,
+ $ LDZ, HERE+1, 1, NBNEXT, WORK, LWORK, INFO )
+ IF( INFO.NE.0 ) THEN
+ ILST = HERE
+ RETURN
+ END IF
+ IF( NBNEXT.EQ.1 ) THEN
+*
+* Swap two 1-by-1 blocks.
+*
+ CALL STGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z,
+ $ LDZ, HERE, 1, 1, WORK, LWORK, INFO )
+ IF( INFO.NE.0 ) THEN
+ ILST = HERE
+ RETURN
+ END IF
+ HERE = HERE + 1
+*
+ ELSE
+*
+* Recompute NBNEXT in case of 2-by-2 split.
+*
+ IF( A( HERE+2, HERE+1 ).EQ.ZERO )
+ $ NBNEXT = 1
+ IF( NBNEXT.EQ.2 ) THEN
+*
+* 2-by-2 block did not split.
+*
+ CALL STGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ,
+ $ Z, LDZ, HERE, 1, NBNEXT, WORK, LWORK,
+ $ INFO )
+ IF( INFO.NE.0 ) THEN
+ ILST = HERE
+ RETURN
+ END IF
+ HERE = HERE + 2
+ ELSE
+*
+* 2-by-2 block did split.
+*
+ CALL STGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ,
+ $ Z, LDZ, HERE, 1, 1, WORK, LWORK, INFO )
+ IF( INFO.NE.0 ) THEN
+ ILST = HERE
+ RETURN
+ END IF
+ HERE = HERE + 1
+ CALL STGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ,
+ $ Z, LDZ, HERE, 1, 1, WORK, LWORK, INFO )
+ IF( INFO.NE.0 ) THEN
+ ILST = HERE
+ RETURN
+ END IF
+ HERE = HERE + 1
+ END IF
+*
+ END IF
+ END IF
+ IF( HERE.LT.ILST )
+ $ GO TO 10
+ ELSE
+ HERE = IFST
+*
+ 20 CONTINUE
+*
+* Swap with next one below.
+*
+ IF( NBF.EQ.1 .OR. NBF.EQ.2 ) THEN
+*
+* Current block either 1-by-1 or 2-by-2.
+*
+ NBNEXT = 1
+ IF( HERE.GE.3 ) THEN
+ IF( A( HERE-1, HERE-2 ).NE.ZERO )
+ $ NBNEXT = 2
+ END IF
+ CALL STGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z,
+ $ LDZ, HERE-NBNEXT, NBNEXT, NBF, WORK, LWORK,
+ $ INFO )
+ IF( INFO.NE.0 ) THEN
+ ILST = HERE
+ RETURN
+ END IF
+ HERE = HERE - NBNEXT
+*
+* Test if 2-by-2 block breaks into two 1-by-1 blocks.
+*
+ IF( NBF.EQ.2 ) THEN
+ IF( A( HERE+1, HERE ).EQ.ZERO )
+ $ NBF = 3
+ END IF
+*
+ ELSE
+*
+* Current block consists of two 1-by-1 blocks, each of which
+* must be swapped individually.
+*
+ NBNEXT = 1
+ IF( HERE.GE.3 ) THEN
+ IF( A( HERE-1, HERE-2 ).NE.ZERO )
+ $ NBNEXT = 2
+ END IF
+ CALL STGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z,
+ $ LDZ, HERE-NBNEXT, NBNEXT, 1, WORK, LWORK,
+ $ INFO )
+ IF( INFO.NE.0 ) THEN
+ ILST = HERE
+ RETURN
+ END IF
+ IF( NBNEXT.EQ.1 ) THEN
+*
+* Swap two 1-by-1 blocks.
+*
+ CALL STGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z,
+ $ LDZ, HERE, NBNEXT, 1, WORK, LWORK, INFO )
+ IF( INFO.NE.0 ) THEN
+ ILST = HERE
+ RETURN
+ END IF
+ HERE = HERE - 1
+ ELSE
+*
+* Recompute NBNEXT in case of 2-by-2 split.
+*
+ IF( A( HERE, HERE-1 ).EQ.ZERO )
+ $ NBNEXT = 1
+ IF( NBNEXT.EQ.2 ) THEN
+*
+* 2-by-2 block did not split.
+*
+ CALL STGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ,
+ $ Z, LDZ, HERE-1, 2, 1, WORK, LWORK, INFO )
+ IF( INFO.NE.0 ) THEN
+ ILST = HERE
+ RETURN
+ END IF
+ HERE = HERE - 2
+ ELSE
+*
+* 2-by-2 block did split.
+*
+ CALL STGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ,
+ $ Z, LDZ, HERE, 1, 1, WORK, LWORK, INFO )
+ IF( INFO.NE.0 ) THEN
+ ILST = HERE
+ RETURN
+ END IF
+ HERE = HERE - 1
+ CALL STGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ,
+ $ Z, LDZ, HERE, 1, 1, WORK, LWORK, INFO )
+ IF( INFO.NE.0 ) THEN
+ ILST = HERE
+ RETURN
+ END IF
+ HERE = HERE - 1
+ END IF
+ END IF
+ END IF
+ IF( HERE.GT.ILST )
+ $ GO TO 20
+ END IF
+ ILST = HERE
+ WORK( 1 ) = LWMIN
+ RETURN
+*
+* End of STGEXC
+*
+ END
+ 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 )
+*
+* -- LAPACK routine (version 3.1.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* January 2007
+*
+* Modified to call SLACN2 in place of SLACON, 7 Feb 03, SJH.
+*
+* .. Scalar Arguments ..
+ LOGICAL WANTQ, WANTZ
+ INTEGER IJOB, INFO, LDA, LDB, LDQ, LDZ, LIWORK, LWORK,
+ $ M, N
+ REAL PL, PR
+* ..
+* .. Array Arguments ..
+ LOGICAL SELECT( * )
+ INTEGER IWORK( * )
+ REAL A( LDA, * ), ALPHAI( * ), ALPHAR( * ),
+ $ B( LDB, * ), BETA( * ), DIF( * ), Q( LDQ, * ),
+ $ WORK( * ), Z( LDZ, * )
+* ..
+*
+* Purpose
+* =======
+*
+* STGSEN reorders the generalized real Schur decomposition of a real
+* matrix pair (A, B) (in terms of an orthonormal equivalence trans-
+* formation Q' * (A, B) * Z), so that a selected cluster of eigenvalues
+* appears in the leading diagonal blocks of the upper quasi-triangular
+* matrix A and the upper triangular B. The leading columns of Q and
+* Z form orthonormal bases of the corresponding left and right eigen-
+* spaces (deflating subspaces). (A, B) must be in generalized real
+* Schur canonical form (as returned by SGGES), i.e. A is block upper
+* triangular with 1-by-1 and 2-by-2 diagonal blocks. B is upper
+* triangular.
+*
+* STGSEN also computes the generalized eigenvalues
+*
+* w(j) = (ALPHAR(j) + i*ALPHAI(j))/BETA(j)
+*
+* of the reordered matrix pair (A, B).
+*
+* Optionally, STGSEN computes the estimates of reciprocal condition
+* numbers for eigenvalues and eigenspaces. These are Difu[(A11,B11),
+* (A22,B22)] and Difl[(A11,B11), (A22,B22)], i.e. the separation(s)
+* between the matrix pairs (A11, B11) and (A22,B22) that correspond to
+* the selected cluster and the eigenvalues outside the cluster, resp.,
+* and norms of "projections" onto left and right eigenspaces w.r.t.
+* the selected cluster in the (1,1)-block.
+*
+* Arguments
+* =========
+*
+* IJOB (input) INTEGER
+* Specifies whether condition numbers are required for the
+* cluster of eigenvalues (PL and PR) or the deflating subspaces
+* (Difu and Difl):
+* =0: Only reorder w.r.t. SELECT. No extras.
+* =1: Reciprocal of norms of "projections" onto left and right
+* eigenspaces w.r.t. the selected cluster (PL and PR).
+* =2: Upper bounds on Difu and Difl. F-norm-based estimate
+* (DIF(1:2)).
+* =3: Estimate of Difu and Difl. 1-norm-based estimate
+* (DIF(1:2)).
+* About 5 times as expensive as IJOB = 2.
+* =4: Compute PL, PR and DIF (i.e. 0, 1 and 2 above): Economic
+* version to get it all.
+* =5: Compute PL, PR and DIF (i.e. 0, 1 and 3 above)
+*
+* WANTQ (input) LOGICAL
+* .TRUE. : update the left transformation matrix Q;
+* .FALSE.: do not update Q.
+*
+* WANTZ (input) LOGICAL
+* .TRUE. : update the right transformation matrix Z;
+* .FALSE.: do not update Z.
+*
+* SELECT (input) LOGICAL array, dimension (N)
+* SELECT specifies the eigenvalues in the selected cluster.
+* To select a real eigenvalue w(j), SELECT(j) must be set to
+* .TRUE.. To select a complex conjugate pair of eigenvalues
+* w(j) and w(j+1), corresponding to a 2-by-2 diagonal block,
+* either SELECT(j) or SELECT(j+1) or both must be set to
+* .TRUE.; a complex conjugate pair of eigenvalues must be
+* either both included in the cluster or both excluded.
+*
+* N (input) INTEGER
+* The order of the matrices A and B. N >= 0.
+*
+* A (input/output) REAL array, dimension(LDA,N)
+* On entry, the upper quasi-triangular matrix A, with (A, B) in
+* generalized real Schur canonical form.
+* On exit, A is overwritten by the reordered matrix A.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,N).
+*
+* B (input/output) REAL array, dimension(LDB,N)
+* On entry, the upper triangular matrix B, with (A, B) in
+* generalized real Schur canonical form.
+* On exit, B is overwritten by the reordered matrix B.
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. LDB >= max(1,N).
+*
+* ALPHAR (output) REAL array, dimension (N)
+* ALPHAI (output) REAL array, dimension (N)
+* BETA (output) REAL array, dimension (N)
+* On exit, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j), j=1,...,N, will
+* be the generalized eigenvalues. ALPHAR(j) + ALPHAI(j)*i
+* and BETA(j),j=1,...,N are the diagonals of the complex Schur
+* form (S,T) that would result if the 2-by-2 diagonal blocks of
+* the real generalized Schur form of (A,B) were further reduced
+* to triangular form using complex unitary transformations.
+* If ALPHAI(j) is zero, then the j-th eigenvalue is real; if
+* positive, then the j-th and (j+1)-st eigenvalues are a
+* complex conjugate pair, with ALPHAI(j+1) negative.
+*
+* Q (input/output) REAL array, dimension (LDQ,N)
+* On entry, if WANTQ = .TRUE., Q is an N-by-N matrix.
+* On exit, Q has been postmultiplied by the left orthogonal
+* transformation matrix which reorder (A, B); The leading M
+* columns of Q form orthonormal bases for the specified pair of
+* left eigenspaces (deflating subspaces).
+* If WANTQ = .FALSE., Q is not referenced.
+*
+* LDQ (input) INTEGER
+* The leading dimension of the array Q. LDQ >= 1;
+* and if WANTQ = .TRUE., LDQ >= N.
+*
+* Z (input/output) REAL array, dimension (LDZ,N)
+* On entry, if WANTZ = .TRUE., Z is an N-by-N matrix.
+* On exit, Z has been postmultiplied by the left orthogonal
+* transformation matrix which reorder (A, B); The leading M
+* columns of Z form orthonormal bases for the specified pair of
+* left eigenspaces (deflating subspaces).
+* If WANTZ = .FALSE., Z is not referenced.
+*
+* LDZ (input) INTEGER
+* The leading dimension of the array Z. LDZ >= 1;
+* If WANTZ = .TRUE., LDZ >= N.
+*
+* M (output) INTEGER
+* The dimension of the specified pair of left and right eigen-
+* spaces (deflating subspaces). 0 <= M <= N.
+*
+* PL (output) REAL
+* PR (output) REAL
+* If IJOB = 1, 4 or 5, PL, PR are lower bounds on the
+* reciprocal of the norm of "projections" onto left and right
+* eigenspaces with respect to the selected cluster.
+* 0 < PL, PR <= 1.
+* If M = 0 or M = N, PL = PR = 1.
+* If IJOB = 0, 2 or 3, PL and PR are not referenced.
+*
+* DIF (output) REAL array, dimension (2).
+* If IJOB >= 2, DIF(1:2) store the estimates of Difu and Difl.
+* If IJOB = 2 or 4, DIF(1:2) are F-norm-based upper bounds on
+* Difu and Difl. If IJOB = 3 or 5, DIF(1:2) are 1-norm-based
+* estimates of Difu and Difl.
+* If M = 0 or N, DIF(1:2) = F-norm([A, B]).
+* If IJOB = 0 or 1, DIF is not referenced.
+*
+* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))
+* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+* LWORK (input) INTEGER
+* The dimension of the array WORK. LWORK >= 4*N+16.
+* If IJOB = 1, 2 or 4, LWORK >= MAX(4*N+16, 2*M*(N-M)).
+* If IJOB = 3 or 5, LWORK >= MAX(4*N+16, 4*M*(N-M)).
+*
+* If LWORK = -1, then a workspace query is assumed; the routine
+* only calculates the optimal size of the WORK array, returns
+* this value as the first entry of the WORK array, and no error
+* message related to LWORK is issued by XERBLA.
+*
+* IWORK (workspace/output) INTEGER array, dimension (MAX(1,LIWORK))
+* IF IJOB = 0, IWORK is not referenced. Otherwise,
+* on exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
+*
+* LIWORK (input) INTEGER
+* The dimension of the array IWORK. LIWORK >= 1.
+* If IJOB = 1, 2 or 4, LIWORK >= N+6.
+* If IJOB = 3 or 5, LIWORK >= MAX(2*M*(N-M), N+6).
+*
+* If LIWORK = -1, then a workspace query is assumed; the
+* routine only calculates the optimal size of the IWORK array,
+* returns this value as the first entry of the IWORK array, and
+* no error message related to LIWORK is issued by XERBLA.
+*
+* INFO (output) INTEGER
+* =0: Successful exit.
+* <0: If INFO = -i, the i-th argument had an illegal value.
+* =1: Reordering of (A, B) failed because the transformed
+* matrix pair (A, B) would be too far from generalized
+* Schur form; the problem is very ill-conditioned.
+* (A, B) may have been partially reordered.
+* If requested, 0 is returned in DIF(*), PL and PR.
+*
+* Further Details
+* ===============
+*
+* STGSEN first collects the selected eigenvalues by computing
+* orthogonal U and W that move them to the top left corner of (A, B).
+* In other words, the selected eigenvalues are the eigenvalues of
+* (A11, B11) in:
+*
+* U'*(A, B)*W = (A11 A12) (B11 B12) n1
+* ( 0 A22),( 0 B22) n2
+* n1 n2 n1 n2
+*
+* where N = n1+n2 and U' means the transpose of U. The first n1 columns
+* of U and W span the specified pair of left and right eigenspaces
+* (deflating subspaces) of (A, B).
+*
+* If (A, B) has been obtained from the generalized real Schur
+* decomposition of a matrix pair (C, D) = Q*(A, B)*Z', then the
+* reordered generalized real Schur form of (C, D) is given by
+*
+* (C, D) = (Q*U)*(U'*(A, B)*W)*(Z*W)',
+*
+* and the first n1 columns of Q*U and Z*W span the corresponding
+* deflating subspaces of (C, D) (Q and Z store Q*U and Z*W, resp.).
+*
+* Note that if the selected eigenvalue is sufficiently ill-conditioned,
+* then its value may differ significantly from its value before
+* reordering.
+*
+* The reciprocal condition numbers of the left and right eigenspaces
+* spanned by the first n1 columns of U and W (or Q*U and Z*W) may
+* be returned in DIF(1:2), corresponding to Difu and Difl, resp.
+*
+* The Difu and Difl are defined as:
+*
+* Difu[(A11, B11), (A22, B22)] = sigma-min( Zu )
+* and
+* Difl[(A11, B11), (A22, B22)] = Difu[(A22, B22), (A11, B11)],
+*
+* where sigma-min(Zu) is the smallest singular value of the
+* (2*n1*n2)-by-(2*n1*n2) matrix
+*
+* Zu = [ kron(In2, A11) -kron(A22', In1) ]
+* [ kron(In2, B11) -kron(B22', In1) ].
+*
+* Here, Inx is the identity matrix of size nx and A22' is the
+* transpose of A22. kron(X, Y) is the Kronecker product between
+* the matrices X and Y.
+*
+* When DIF(2) is small, small changes in (A, B) can cause large changes
+* in the deflating subspace. An approximate (asymptotic) bound on the
+* maximum angular error in the computed deflating subspaces is
+*
+* EPS * norm((A, B)) / DIF(2),
+*
+* where EPS is the machine precision.
+*
+* The reciprocal norm of the projectors on the left and right
+* eigenspaces associated with (A11, B11) may be returned in PL and PR.
+* They are computed as follows. First we compute L and R so that
+* P*(A, B)*Q is block diagonal, where
+*
+* P = ( I -L ) n1 Q = ( I R ) n1
+* ( 0 I ) n2 and ( 0 I ) n2
+* n1 n2 n1 n2
+*
+* and (L, R) is the solution to the generalized Sylvester equation
+*
+* A11*R - L*A22 = -A12
+* B11*R - L*B22 = -B12
+*
+* Then PL = (F-norm(L)**2+1)**(-1/2) and PR = (F-norm(R)**2+1)**(-1/2).
+* An approximate (asymptotic) bound on the average absolute error of
+* the selected eigenvalues is
+*
+* EPS * norm((A, B)) / PL.
+*
+* There are also global error bounds which valid for perturbations up
+* to a certain restriction: A lower bound (x) on the smallest
+* F-norm(E,F) for which an eigenvalue of (A11, B11) may move and
+* coalesce with an eigenvalue of (A22, B22) under perturbation (E,F),
+* (i.e. (A + E, B + F), is
+*
+* x = min(Difu,Difl)/((1/(PL*PL)+1/(PR*PR))**(1/2)+2*max(1/PL,1/PR)).
+*
+* An approximate bound on x can be computed from DIF(1:2), PL and PR.
+*
+* If y = ( F-norm(E,F) / x) <= 1, the angles between the perturbed
+* (L', R') and unperturbed (L, R) left and right deflating subspaces
+* associated with the selected cluster in the (1,1)-blocks can be
+* bounded as
+*
+* max-angle(L, L') <= arctan( y * PL / (1 - y * (1 - PL * PL)**(1/2))
+* max-angle(R, R') <= arctan( y * PR / (1 - y * (1 - PR * PR)**(1/2))
+*
+* See LAPACK User's Guide section 4.11 or the following references
+* for more information.
+*
+* Note that if the default method for computing the Frobenius-norm-
+* based estimate DIF is not wanted (see SLATDF), then the parameter
+* IDIFJB (see below) should be changed from 3 to 4 (routine SLATDF
+* (IJOB = 2 will be used)). See STGSYL for more details.
+*
+* Based on contributions by
+* Bo Kagstrom and Peter Poromaa, Department of Computing Science,
+* Umea University, S-901 87 Umea, Sweden.
+*
+* References
+* ==========
+*
+* [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the
+* Generalized Real Schur Form of a Regular Matrix Pair (A, B), in
+* M.S. Moonen et al (eds), Linear Algebra for Large Scale and
+* Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218.
+*
+* [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified
+* Eigenvalues of a Regular Matrix Pair (A, B) and Condition
+* Estimation: Theory, Algorithms and Software,
+* Report UMINF - 94.04, Department of Computing Science, Umea
+* University, S-901 87 Umea, Sweden, 1994. Also as LAPACK Working
+* Note 87. To appear in Numerical Algorithms, 1996.
+*
+* [3] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software
+* for Solving the Generalized Sylvester Equation and Estimating the
+* Separation between Regular Matrix Pairs, Report UMINF - 93.23,
+* Department of Computing Science, Umea University, S-901 87 Umea,
+* Sweden, December 1993, Revised April 1994, Also as LAPACK Working
+* Note 75. To appear in ACM Trans. on Math. Software, Vol 22, No 1,
+* 1996.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ INTEGER IDIFJB
+ PARAMETER ( IDIFJB = 3 )
+ REAL ZERO, ONE
+ PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL LQUERY, PAIR, SWAP, WANTD, WANTD1, WANTD2,
+ $ WANTP
+ INTEGER I, IERR, IJB, K, KASE, KK, KS, LIWMIN, LWMIN,
+ $ MN2, N1, N2
+ REAL DSCALE, DSUM, EPS, RDSCAL, SMLNUM
+* ..
+* .. Local Arrays ..
+ INTEGER ISAVE( 3 )
+* ..
+* .. External Subroutines ..
+ EXTERNAL SLACN2, SLACPY, SLAG2, SLASSQ, STGEXC, STGSYL,
+ $ XERBLA
+* ..
+* .. External Functions ..
+ REAL SLAMCH
+ EXTERNAL SLAMCH
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, SIGN, SQRT
+* ..
+* .. Executable Statements ..
+*
+* Decode and test the input parameters
+*
+ INFO = 0
+ LQUERY = ( LWORK.EQ.-1 .OR. LIWORK.EQ.-1 )
+*
+ IF( IJOB.LT.0 .OR. IJOB.GT.5 ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -5
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -7
+ ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -9
+ ELSE IF( LDQ.LT.1 .OR. ( WANTQ .AND. LDQ.LT.N ) ) THEN
+ INFO = -14
+ ELSE IF( LDZ.LT.1 .OR. ( WANTZ .AND. LDZ.LT.N ) ) THEN
+ INFO = -16
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'STGSEN', -INFO )
+ RETURN
+ END IF
+*
+* Get machine constants
+*
+ EPS = SLAMCH( 'P' )
+ SMLNUM = SLAMCH( 'S' ) / EPS
+ IERR = 0
+*
+ WANTP = IJOB.EQ.1 .OR. IJOB.GE.4
+ WANTD1 = IJOB.EQ.2 .OR. IJOB.EQ.4
+ WANTD2 = IJOB.EQ.3 .OR. IJOB.EQ.5
+ WANTD = WANTD1 .OR. WANTD2
+*
+* Set M to the dimension of the specified pair of deflating
+* subspaces.
+*
+ M = 0
+ PAIR = .FALSE.
+ DO 10 K = 1, N
+ IF( PAIR ) THEN
+ PAIR = .FALSE.
+ ELSE
+ IF( K.LT.N ) THEN
+ IF( A( K+1, K ).EQ.ZERO ) THEN
+ IF( SELECT( K ) )
+ $ M = M + 1
+ ELSE
+ PAIR = .TRUE.
+ IF( SELECT( K ) .OR. SELECT( K+1 ) )
+ $ M = M + 2
+ END IF
+ ELSE
+ IF( SELECT( N ) )
+ $ M = M + 1
+ END IF
+ END IF
+ 10 CONTINUE
+*
+ IF( IJOB.EQ.1 .OR. IJOB.EQ.2 .OR. IJOB.EQ.4 ) THEN
+ LWMIN = MAX( 1, 4*N+16, 2*M*(N-M) )
+ LIWMIN = MAX( 1, N+6 )
+ ELSE IF( IJOB.EQ.3 .OR. IJOB.EQ.5 ) THEN
+ LWMIN = MAX( 1, 4*N+16, 4*M*(N-M) )
+ LIWMIN = MAX( 1, 2*M*(N-M), N+6 )
+ ELSE
+ LWMIN = MAX( 1, 4*N+16 )
+ LIWMIN = 1
+ END IF
+*
+ WORK( 1 ) = LWMIN
+ IWORK( 1 ) = LIWMIN
+*
+ IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
+ INFO = -22
+ ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN
+ INFO = -24
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'STGSEN', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible.
+*
+ IF( M.EQ.N .OR. M.EQ.0 ) THEN
+ IF( WANTP ) THEN
+ PL = ONE
+ PR = ONE
+ END IF
+ IF( WANTD ) THEN
+ DSCALE = ZERO
+ DSUM = ONE
+ DO 20 I = 1, N
+ CALL SLASSQ( N, A( 1, I ), 1, DSCALE, DSUM )
+ CALL SLASSQ( N, B( 1, I ), 1, DSCALE, DSUM )
+ 20 CONTINUE
+ DIF( 1 ) = DSCALE*SQRT( DSUM )
+ DIF( 2 ) = DIF( 1 )
+ END IF
+ GO TO 60
+ END IF
+*
+* Collect the selected blocks at the top-left corner of (A, B).
+*
+ KS = 0
+ PAIR = .FALSE.
+ DO 30 K = 1, N
+ IF( PAIR ) THEN
+ PAIR = .FALSE.
+ ELSE
+*
+ SWAP = SELECT( K )
+ IF( K.LT.N ) THEN
+ IF( A( K+1, K ).NE.ZERO ) THEN
+ PAIR = .TRUE.
+ SWAP = SWAP .OR. SELECT( K+1 )
+ END IF
+ END IF
+*
+ IF( SWAP ) THEN
+ KS = KS + 1
+*
+* Swap the K-th block to position KS.
+* Perform the reordering of diagonal blocks in (A, B)
+* by orthogonal transformation matrices and update
+* Q and Z accordingly (if requested):
+*
+ KK = K
+ IF( K.NE.KS )
+ $ CALL STGEXC( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ,
+ $ Z, LDZ, KK, KS, WORK, LWORK, IERR )
+*
+ IF( IERR.GT.0 ) THEN
+*
+* Swap is rejected: exit.
+*
+ INFO = 1
+ IF( WANTP ) THEN
+ PL = ZERO
+ PR = ZERO
+ END IF
+ IF( WANTD ) THEN
+ DIF( 1 ) = ZERO
+ DIF( 2 ) = ZERO
+ END IF
+ GO TO 60
+ END IF
+*
+ IF( PAIR )
+ $ KS = KS + 1
+ END IF
+ END IF
+ 30 CONTINUE
+ IF( WANTP ) THEN
+*
+* Solve generalized Sylvester equation for R and L
+* and compute PL and PR.
+*
+ N1 = M
+ N2 = N - M
+ I = N1 + 1
+ IJB = 0
+ CALL SLACPY( 'Full', N1, N2, A( 1, I ), LDA, WORK, N1 )
+ CALL SLACPY( 'Full', N1, N2, B( 1, I ), LDB, WORK( N1*N2+1 ),
+ $ N1 )
+ CALL STGSYL( 'N', IJB, N1, N2, A, LDA, A( I, I ), LDA, WORK,
+ $ N1, B, LDB, B( I, I ), LDB, WORK( N1*N2+1 ), N1,
+ $ DSCALE, DIF( 1 ), WORK( N1*N2*2+1 ),
+ $ LWORK-2*N1*N2, IWORK, IERR )
+*
+* Estimate the reciprocal of norms of "projections" onto left
+* and right eigenspaces.
+*
+ RDSCAL = ZERO
+ DSUM = ONE
+ CALL SLASSQ( N1*N2, WORK, 1, RDSCAL, DSUM )
+ PL = RDSCAL*SQRT( DSUM )
+ IF( PL.EQ.ZERO ) THEN
+ PL = ONE
+ ELSE
+ PL = DSCALE / ( SQRT( DSCALE*DSCALE / PL+PL )*SQRT( PL ) )
+ END IF
+ RDSCAL = ZERO
+ DSUM = ONE
+ CALL SLASSQ( N1*N2, WORK( N1*N2+1 ), 1, RDSCAL, DSUM )
+ PR = RDSCAL*SQRT( DSUM )
+ IF( PR.EQ.ZERO ) THEN
+ PR = ONE
+ ELSE
+ PR = DSCALE / ( SQRT( DSCALE*DSCALE / PR+PR )*SQRT( PR ) )
+ END IF
+ END IF
+*
+ IF( WANTD ) THEN
+*
+* Compute estimates of Difu and Difl.
+*
+ IF( WANTD1 ) THEN
+ N1 = M
+ N2 = N - M
+ I = N1 + 1
+ IJB = IDIFJB
+*
+* Frobenius norm-based Difu-estimate.
+*
+ CALL STGSYL( 'N', IJB, N1, N2, A, LDA, A( I, I ), LDA, WORK,
+ $ N1, B, LDB, B( I, I ), LDB, WORK( N1*N2+1 ),
+ $ N1, DSCALE, DIF( 1 ), WORK( 2*N1*N2+1 ),
+ $ LWORK-2*N1*N2, IWORK, IERR )
+*
+* Frobenius norm-based Difl-estimate.
+*
+ CALL STGSYL( 'N', IJB, N2, N1, A( I, I ), LDA, A, LDA, WORK,
+ $ N2, B( I, I ), LDB, B, LDB, WORK( N1*N2+1 ),
+ $ N2, DSCALE, DIF( 2 ), WORK( 2*N1*N2+1 ),
+ $ LWORK-2*N1*N2, IWORK, IERR )
+ ELSE
+*
+*
+* Compute 1-norm-based estimates of Difu and Difl using
+* reversed communication with SLACN2. In each step a
+* generalized Sylvester equation or a transposed variant
+* is solved.
+*
+ KASE = 0
+ N1 = M
+ N2 = N - M
+ I = N1 + 1
+ IJB = 0
+ MN2 = 2*N1*N2
+*
+* 1-norm-based estimate of Difu.
+*
+ 40 CONTINUE
+ CALL SLACN2( MN2, WORK( MN2+1 ), WORK, IWORK, DIF( 1 ),
+ $ KASE, ISAVE )
+ IF( KASE.NE.0 ) THEN
+ IF( KASE.EQ.1 ) THEN
+*
+* Solve generalized Sylvester equation.
+*
+ CALL STGSYL( 'N', IJB, N1, N2, A, LDA, A( I, I ), LDA,
+ $ WORK, N1, B, LDB, B( I, I ), LDB,
+ $ WORK( N1*N2+1 ), N1, DSCALE, DIF( 1 ),
+ $ WORK( 2*N1*N2+1 ), LWORK-2*N1*N2, IWORK,
+ $ IERR )
+ ELSE
+*
+* Solve the transposed variant.
+*
+ CALL STGSYL( 'T', IJB, N1, N2, A, LDA, A( I, I ), LDA,
+ $ WORK, N1, B, LDB, B( I, I ), LDB,
+ $ WORK( N1*N2+1 ), N1, DSCALE, DIF( 1 ),
+ $ WORK( 2*N1*N2+1 ), LWORK-2*N1*N2, IWORK,
+ $ IERR )
+ END IF
+ GO TO 40
+ END IF
+ DIF( 1 ) = DSCALE / DIF( 1 )
+*
+* 1-norm-based estimate of Difl.
+*
+ 50 CONTINUE
+ CALL SLACN2( MN2, WORK( MN2+1 ), WORK, IWORK, DIF( 2 ),
+ $ KASE, ISAVE )
+ IF( KASE.NE.0 ) THEN
+ IF( KASE.EQ.1 ) THEN
+*
+* Solve generalized Sylvester equation.
+*
+ CALL STGSYL( 'N', IJB, N2, N1, A( I, I ), LDA, A, LDA,
+ $ WORK, N2, B( I, I ), LDB, B, LDB,
+ $ WORK( N1*N2+1 ), N2, DSCALE, DIF( 2 ),
+ $ WORK( 2*N1*N2+1 ), LWORK-2*N1*N2, IWORK,
+ $ IERR )
+ ELSE
+*
+* Solve the transposed variant.
+*
+ CALL STGSYL( 'T', IJB, N2, N1, A( I, I ), LDA, A, LDA,
+ $ WORK, N2, B( I, I ), LDB, B, LDB,
+ $ WORK( N1*N2+1 ), N2, DSCALE, DIF( 2 ),
+ $ WORK( 2*N1*N2+1 ), LWORK-2*N1*N2, IWORK,
+ $ IERR )
+ END IF
+ GO TO 50
+ END IF
+ DIF( 2 ) = DSCALE / DIF( 2 )
+*
+ END IF
+ END IF
+*
+ 60 CONTINUE
+*
+* Compute generalized eigenvalues of reordered pair (A, B) and
+* normalize the generalized Schur form.
+*
+ PAIR = .FALSE.
+ DO 70 K = 1, N
+ IF( PAIR ) THEN
+ PAIR = .FALSE.
+ ELSE
+*
+ IF( K.LT.N ) THEN
+ IF( A( K+1, K ).NE.ZERO ) THEN
+ PAIR = .TRUE.
+ END IF
+ END IF
+*
+ IF( PAIR ) THEN
+*
+* Compute the eigenvalue(s) at position K.
+*
+ WORK( 1 ) = A( K, K )
+ WORK( 2 ) = A( K+1, K )
+ WORK( 3 ) = A( K, K+1 )
+ WORK( 4 ) = A( K+1, K+1 )
+ WORK( 5 ) = B( K, K )
+ WORK( 6 ) = B( K+1, K )
+ WORK( 7 ) = B( K, K+1 )
+ WORK( 8 ) = B( K+1, K+1 )
+ CALL SLAG2( WORK, 2, WORK( 5 ), 2, SMLNUM*EPS, BETA( K ),
+ $ BETA( K+1 ), ALPHAR( K ), ALPHAR( K+1 ),
+ $ ALPHAI( K ) )
+ ALPHAI( K+1 ) = -ALPHAI( K )
+*
+ ELSE
+*
+ IF( SIGN( ONE, B( K, K ) ).LT.ZERO ) THEN
+*
+* If B(K,K) is negative, make it positive
+*
+ DO 80 I = 1, N
+ A( K, I ) = -A( K, I )
+ B( K, I ) = -B( K, I )
+ Q( I, K ) = -Q( I, K )
+ 80 CONTINUE
+ END IF
+*
+ ALPHAR( K ) = A( K, K )
+ ALPHAI( K ) = ZERO
+ BETA( K ) = B( K, K )
+*
+ END IF
+ END IF
+ 70 CONTINUE
+*
+ WORK( 1 ) = LWMIN
+ IWORK( 1 ) = LIWMIN
+*
+ RETURN
+*
+* End of STGSEN
+*
+ END
+ 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 )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER JOBQ, JOBU, JOBV
+ INTEGER INFO, K, L, LDA, LDB, LDQ, LDU, LDV, M, N,
+ $ NCYCLE, P
+ REAL TOLA, TOLB
+* ..
+* .. Array Arguments ..
+ REAL A( LDA, * ), ALPHA( * ), B( LDB, * ),
+ $ BETA( * ), Q( LDQ, * ), U( LDU, * ),
+ $ V( LDV, * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* STGSJA computes the generalized singular value decomposition (GSVD)
+* of two real upper triangular (or trapezoidal) matrices A and B.
+*
+* On entry, it is assumed that matrices A and B have the following
+* forms, which may be obtained by the preprocessing subroutine SGGSVP
+* from a general M-by-N matrix A and P-by-N matrix B:
+*
+* N-K-L K L
+* A = K ( 0 A12 A13 ) if M-K-L >= 0;
+* L ( 0 0 A23 )
+* M-K-L ( 0 0 0 )
+*
+* N-K-L K L
+* A = K ( 0 A12 A13 ) if M-K-L < 0;
+* M-K ( 0 0 A23 )
+*
+* N-K-L K L
+* B = L ( 0 0 B13 )
+* P-L ( 0 0 0 )
+*
+* where the K-by-K matrix A12 and L-by-L matrix B13 are nonsingular
+* upper triangular; A23 is L-by-L upper triangular if M-K-L >= 0,
+* otherwise A23 is (M-K)-by-L upper trapezoidal.
+*
+* On exit,
+*
+* U'*A*Q = D1*( 0 R ), V'*B*Q = D2*( 0 R ),
+*
+* where U, V and Q are orthogonal matrices, Z' denotes the transpose
+* of Z, R is a nonsingular upper triangular matrix, and D1 and D2 are
+* ``diagonal'' matrices, which are of the following structures:
+*
+* If M-K-L >= 0,
+*
+* K L
+* D1 = K ( I 0 )
+* L ( 0 C )
+* M-K-L ( 0 0 )
+*
+* K L
+* D2 = L ( 0 S )
+* P-L ( 0 0 )
+*
+* N-K-L K L
+* ( 0 R ) = K ( 0 R11 R12 ) K
+* L ( 0 0 R22 ) L
+*
+* where
+*
+* C = diag( ALPHA(K+1), ... , ALPHA(K+L) ),
+* S = diag( BETA(K+1), ... , BETA(K+L) ),
+* C**2 + S**2 = I.
+*
+* R is stored in A(1:K+L,N-K-L+1:N) on exit.
+*
+* If M-K-L < 0,
+*
+* K M-K K+L-M
+* D1 = K ( I 0 0 )
+* M-K ( 0 C 0 )
+*
+* K M-K K+L-M
+* D2 = M-K ( 0 S 0 )
+* K+L-M ( 0 0 I )
+* P-L ( 0 0 0 )
+*
+* N-K-L K M-K K+L-M
+* ( 0 R ) = K ( 0 R11 R12 R13 )
+* M-K ( 0 0 R22 R23 )
+* K+L-M ( 0 0 0 R33 )
+*
+* where
+* C = diag( ALPHA(K+1), ... , ALPHA(M) ),
+* S = diag( BETA(K+1), ... , BETA(M) ),
+* C**2 + S**2 = I.
+*
+* R = ( R11 R12 R13 ) is stored in A(1:M, N-K-L+1:N) and R33 is stored
+* ( 0 R22 R23 )
+* in B(M-K+1:L,N+M-K-L+1:N) on exit.
+*
+* The computation of the orthogonal transformation matrices U, V or Q
+* is optional. These matrices may either be formed explicitly, or they
+* may be postmultiplied into input matrices U1, V1, or Q1.
+*
+* Arguments
+* =========
+*
+* JOBU (input) CHARACTER*1
+* = 'U': U must contain an orthogonal matrix U1 on entry, and
+* the product U1*U is returned;
+* = 'I': U is initialized to the unit matrix, and the
+* orthogonal matrix U is returned;
+* = 'N': U is not computed.
+*
+* JOBV (input) CHARACTER*1
+* = 'V': V must contain an orthogonal matrix V1 on entry, and
+* the product V1*V is returned;
+* = 'I': V is initialized to the unit matrix, and the
+* orthogonal matrix V is returned;
+* = 'N': V is not computed.
+*
+* JOBQ (input) CHARACTER*1
+* = 'Q': Q must contain an orthogonal matrix Q1 on entry, and
+* the product Q1*Q is returned;
+* = 'I': Q is initialized to the unit matrix, and the
+* orthogonal matrix Q is returned;
+* = 'N': Q is not computed.
+*
+* M (input) INTEGER
+* The number of rows of the matrix A. M >= 0.
+*
+* P (input) INTEGER
+* The number of rows of the matrix B. P >= 0.
+*
+* N (input) INTEGER
+* The number of columns of the matrices A and B. N >= 0.
+*
+* K (input) INTEGER
+* L (input) INTEGER
+* K and L specify the subblocks in the input matrices A and B:
+* A23 = A(K+1:MIN(K+L,M),N-L+1:N) and B13 = B(1:L,N-L+1:N)
+* of A and B, whose GSVD is going to be computed by STGSJA.
+* See Further details.
+*
+* A (input/output) REAL array, dimension (LDA,N)
+* On entry, the M-by-N matrix A.
+* On exit, A(N-K+1:N,1:MIN(K+L,M) ) contains the triangular
+* matrix R or part of R. See Purpose for details.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,M).
+*
+* B (input/output) REAL array, dimension (LDB,N)
+* On entry, the P-by-N matrix B.
+* On exit, if necessary, B(M-K+1:L,N+M-K-L+1:N) contains
+* a part of R. See Purpose for details.
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. LDB >= max(1,P).
+*
+* TOLA (input) REAL
+* TOLB (input) REAL
+* TOLA and TOLB are the convergence criteria for the Jacobi-
+* Kogbetliantz iteration procedure. Generally, they are the
+* same as used in the preprocessing step, say
+* TOLA = max(M,N)*norm(A)*MACHEPS,
+* TOLB = max(P,N)*norm(B)*MACHEPS.
+*
+* ALPHA (output) REAL array, dimension (N)
+* BETA (output) REAL array, dimension (N)
+* On exit, ALPHA and BETA contain the generalized singular
+* value pairs of A and B;
+* ALPHA(1:K) = 1,
+* BETA(1:K) = 0,
+* and if M-K-L >= 0,
+* ALPHA(K+1:K+L) = diag(C),
+* BETA(K+1:K+L) = diag(S),
+* or if M-K-L < 0,
+* ALPHA(K+1:M)= C, ALPHA(M+1:K+L)= 0
+* BETA(K+1:M) = S, BETA(M+1:K+L) = 1.
+* Furthermore, if K+L < N,
+* ALPHA(K+L+1:N) = 0 and
+* BETA(K+L+1:N) = 0.
+*
+* U (input/output) REAL array, dimension (LDU,M)
+* On entry, if JOBU = 'U', U must contain a matrix U1 (usually
+* the orthogonal matrix returned by SGGSVP).
+* On exit,
+* if JOBU = 'I', U contains the orthogonal matrix U;
+* if JOBU = 'U', U contains the product U1*U.
+* If JOBU = 'N', U is not referenced.
+*
+* LDU (input) INTEGER
+* The leading dimension of the array U. LDU >= max(1,M) if
+* JOBU = 'U'; LDU >= 1 otherwise.
+*
+* V (input/output) REAL array, dimension (LDV,P)
+* On entry, if JOBV = 'V', V must contain a matrix V1 (usually
+* the orthogonal matrix returned by SGGSVP).
+* On exit,
+* if JOBV = 'I', V contains the orthogonal matrix V;
+* if JOBV = 'V', V contains the product V1*V.
+* If JOBV = 'N', V is not referenced.
+*
+* LDV (input) INTEGER
+* The leading dimension of the array V. LDV >= max(1,P) if
+* JOBV = 'V'; LDV >= 1 otherwise.
+*
+* Q (input/output) REAL array, dimension (LDQ,N)
+* On entry, if JOBQ = 'Q', Q must contain a matrix Q1 (usually
+* the orthogonal matrix returned by SGGSVP).
+* On exit,
+* if JOBQ = 'I', Q contains the orthogonal matrix Q;
+* if JOBQ = 'Q', Q contains the product Q1*Q.
+* If JOBQ = 'N', Q is not referenced.
+*
+* LDQ (input) INTEGER
+* The leading dimension of the array Q. LDQ >= max(1,N) if
+* JOBQ = 'Q'; LDQ >= 1 otherwise.
+*
+* WORK (workspace) REAL array, dimension (2*N)
+*
+* NCYCLE (output) INTEGER
+* The number of cycles required for convergence.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value.
+* = 1: the procedure does not converge after MAXIT cycles.
+*
+* Internal Parameters
+* ===================
+*
+* MAXIT INTEGER
+* MAXIT specifies the total loops that the iterative procedure
+* may take. If after MAXIT cycles, the routine fails to
+* converge, we return INFO = 1.
+*
+* Further Details
+* ===============
+*
+* STGSJA essentially uses a variant of Kogbetliantz algorithm to reduce
+* min(L,M-K)-by-L triangular (or trapezoidal) matrix A23 and L-by-L
+* matrix B13 to the form:
+*
+* U1'*A13*Q1 = C1*R1; V1'*B13*Q1 = S1*R1,
+*
+* where U1, V1 and Q1 are orthogonal matrix, and Z' is the transpose
+* of Z. C1 and S1 are diagonal matrices satisfying
+*
+* C1**2 + S1**2 = I,
+*
+* and R1 is an L-by-L nonsingular upper triangular matrix.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ INTEGER MAXIT
+ PARAMETER ( MAXIT = 40 )
+ REAL ZERO, ONE
+ PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+* ..
+* .. Local Scalars ..
+*
+ LOGICAL INITQ, INITU, INITV, UPPER, WANTQ, WANTU, WANTV
+ INTEGER I, J, KCYCLE
+ REAL A1, A2, A3, B1, B2, B3, CSQ, CSU, CSV, ERROR,
+ $ GAMMA, RWK, SNQ, SNU, SNV, SSMIN
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL SCOPY, SLAGS2, SLAPLL, SLARTG, SLASET, SROT,
+ $ SSCAL, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+* Decode and test the input parameters
+*
+ INITU = LSAME( JOBU, 'I' )
+ WANTU = INITU .OR. LSAME( JOBU, 'U' )
+*
+ INITV = LSAME( JOBV, 'I' )
+ WANTV = INITV .OR. LSAME( JOBV, 'V' )
+*
+ INITQ = LSAME( JOBQ, 'I' )
+ WANTQ = INITQ .OR. LSAME( JOBQ, 'Q' )
+*
+ INFO = 0
+ IF( .NOT.( INITU .OR. WANTU .OR. LSAME( JOBU, 'N' ) ) ) THEN
+ INFO = -1
+ ELSE IF( .NOT.( INITV .OR. WANTV .OR. LSAME( JOBV, 'N' ) ) ) THEN
+ INFO = -2
+ ELSE IF( .NOT.( INITQ .OR. WANTQ .OR. LSAME( JOBQ, 'N' ) ) ) THEN
+ INFO = -3
+ ELSE IF( M.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( P.LT.0 ) THEN
+ INFO = -5
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -6
+ ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+ INFO = -10
+ ELSE IF( LDB.LT.MAX( 1, P ) ) THEN
+ INFO = -12
+ ELSE IF( LDU.LT.1 .OR. ( WANTU .AND. LDU.LT.M ) ) THEN
+ INFO = -18
+ ELSE IF( LDV.LT.1 .OR. ( WANTV .AND. LDV.LT.P ) ) THEN
+ INFO = -20
+ ELSE IF( LDQ.LT.1 .OR. ( WANTQ .AND. LDQ.LT.N ) ) THEN
+ INFO = -22
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'STGSJA', -INFO )
+ RETURN
+ END IF
+*
+* Initialize U, V and Q, if necessary
+*
+ IF( INITU )
+ $ CALL SLASET( 'Full', M, M, ZERO, ONE, U, LDU )
+ IF( INITV )
+ $ CALL SLASET( 'Full', P, P, ZERO, ONE, V, LDV )
+ IF( INITQ )
+ $ CALL SLASET( 'Full', N, N, ZERO, ONE, Q, LDQ )
+*
+* Loop until convergence
+*
+ UPPER = .FALSE.
+ DO 40 KCYCLE = 1, MAXIT
+*
+ UPPER = .NOT.UPPER
+*
+ DO 20 I = 1, L - 1
+ DO 10 J = I + 1, L
+*
+ A1 = ZERO
+ A2 = ZERO
+ A3 = ZERO
+ IF( K+I.LE.M )
+ $ A1 = A( K+I, N-L+I )
+ IF( K+J.LE.M )
+ $ A3 = A( K+J, N-L+J )
+*
+ B1 = B( I, N-L+I )
+ B3 = B( J, N-L+J )
+*
+ IF( UPPER ) THEN
+ IF( K+I.LE.M )
+ $ A2 = A( K+I, N-L+J )
+ B2 = B( I, N-L+J )
+ ELSE
+ IF( K+J.LE.M )
+ $ A2 = A( K+J, N-L+I )
+ B2 = B( J, N-L+I )
+ END IF
+*
+ CALL SLAGS2( UPPER, A1, A2, A3, B1, B2, B3, CSU, SNU,
+ $ CSV, SNV, CSQ, SNQ )
+*
+* Update (K+I)-th and (K+J)-th rows of matrix A: U'*A
+*
+ IF( K+J.LE.M )
+ $ CALL SROT( L, A( K+J, N-L+1 ), LDA, A( K+I, N-L+1 ),
+ $ LDA, CSU, SNU )
+*
+* Update I-th and J-th rows of matrix B: V'*B
+*
+ CALL SROT( L, B( J, N-L+1 ), LDB, B( I, N-L+1 ), LDB,
+ $ CSV, SNV )
+*
+* Update (N-L+I)-th and (N-L+J)-th columns of matrices
+* A and B: A*Q and B*Q
+*
+ CALL SROT( MIN( K+L, M ), A( 1, N-L+J ), 1,
+ $ A( 1, N-L+I ), 1, CSQ, SNQ )
+*
+ CALL SROT( L, B( 1, N-L+J ), 1, B( 1, N-L+I ), 1, CSQ,
+ $ SNQ )
+*
+ IF( UPPER ) THEN
+ IF( K+I.LE.M )
+ $ A( K+I, N-L+J ) = ZERO
+ B( I, N-L+J ) = ZERO
+ ELSE
+ IF( K+J.LE.M )
+ $ A( K+J, N-L+I ) = ZERO
+ B( J, N-L+I ) = ZERO
+ END IF
+*
+* Update orthogonal matrices U, V, Q, if desired.
+*
+ IF( WANTU .AND. K+J.LE.M )
+ $ CALL SROT( M, U( 1, K+J ), 1, U( 1, K+I ), 1, CSU,
+ $ SNU )
+*
+ IF( WANTV )
+ $ CALL SROT( P, V( 1, J ), 1, V( 1, I ), 1, CSV, SNV )
+*
+ IF( WANTQ )
+ $ CALL SROT( N, Q( 1, N-L+J ), 1, Q( 1, N-L+I ), 1, CSQ,
+ $ SNQ )
+*
+ 10 CONTINUE
+ 20 CONTINUE
+*
+ IF( .NOT.UPPER ) THEN
+*
+* The matrices A13 and B13 were lower triangular at the start
+* of the cycle, and are now upper triangular.
+*
+* Convergence test: test the parallelism of the corresponding
+* rows of A and B.
+*
+ ERROR = ZERO
+ DO 30 I = 1, MIN( L, M-K )
+ CALL SCOPY( L-I+1, A( K+I, N-L+I ), LDA, WORK, 1 )
+ CALL SCOPY( L-I+1, B( I, N-L+I ), LDB, WORK( L+1 ), 1 )
+ CALL SLAPLL( L-I+1, WORK, 1, WORK( L+1 ), 1, SSMIN )
+ ERROR = MAX( ERROR, SSMIN )
+ 30 CONTINUE
+*
+ IF( ABS( ERROR ).LE.MIN( TOLA, TOLB ) )
+ $ GO TO 50
+ END IF
+*
+* End of cycle loop
+*
+ 40 CONTINUE
+*
+* The algorithm has not converged after MAXIT cycles.
+*
+ INFO = 1
+ GO TO 100
+*
+ 50 CONTINUE
+*
+* If ERROR <= MIN(TOLA,TOLB), then the algorithm has converged.
+* Compute the generalized singular value pairs (ALPHA, BETA), and
+* set the triangular matrix R to array A.
+*
+ DO 60 I = 1, K
+ ALPHA( I ) = ONE
+ BETA( I ) = ZERO
+ 60 CONTINUE
+*
+ DO 70 I = 1, MIN( L, M-K )
+*
+ A1 = A( K+I, N-L+I )
+ B1 = B( I, N-L+I )
+*
+ IF( A1.NE.ZERO ) THEN
+ GAMMA = B1 / A1
+*
+* change sign if necessary
+*
+ IF( GAMMA.LT.ZERO ) THEN
+ CALL SSCAL( L-I+1, -ONE, B( I, N-L+I ), LDB )
+ IF( WANTV )
+ $ CALL SSCAL( P, -ONE, V( 1, I ), 1 )
+ END IF
+*
+ CALL SLARTG( ABS( GAMMA ), ONE, BETA( K+I ), ALPHA( K+I ),
+ $ RWK )
+*
+ IF( ALPHA( K+I ).GE.BETA( K+I ) ) THEN
+ CALL SSCAL( L-I+1, ONE / ALPHA( K+I ), A( K+I, N-L+I ),
+ $ LDA )
+ ELSE
+ CALL SSCAL( L-I+1, ONE / BETA( K+I ), B( I, N-L+I ),
+ $ LDB )
+ CALL SCOPY( L-I+1, B( I, N-L+I ), LDB, A( K+I, N-L+I ),
+ $ LDA )
+ END IF
+*
+ ELSE
+*
+ ALPHA( K+I ) = ZERO
+ BETA( K+I ) = ONE
+ CALL SCOPY( L-I+1, B( I, N-L+I ), LDB, A( K+I, N-L+I ),
+ $ LDA )
+*
+ END IF
+*
+ 70 CONTINUE
+*
+* Post-assignment
+*
+ DO 80 I = M + 1, K + L
+ ALPHA( I ) = ZERO
+ BETA( I ) = ONE
+ 80 CONTINUE
+*
+ IF( K+L.LT.N ) THEN
+ DO 90 I = K + L + 1, N
+ ALPHA( I ) = ZERO
+ BETA( I ) = ZERO
+ 90 CONTINUE
+ END IF
+*
+ 100 CONTINUE
+ NCYCLE = KCYCLE
+ RETURN
+*
+* End of STGSJA
+*
+ END
+ SUBROUTINE STGSNA( JOB, HOWMNY, SELECT, N, A, LDA, B, LDB, VL,
+ $ LDVL, VR, LDVR, S, DIF, MM, M, WORK, LWORK,
+ $ IWORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER HOWMNY, JOB
+ INTEGER INFO, LDA, LDB, LDVL, LDVR, LWORK, M, MM, N
+* ..
+* .. Array Arguments ..
+ LOGICAL SELECT( * )
+ INTEGER IWORK( * )
+ REAL A( LDA, * ), B( LDB, * ), DIF( * ), S( * ),
+ $ VL( LDVL, * ), VR( LDVR, * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* STGSNA estimates reciprocal condition numbers for specified
+* eigenvalues and/or eigenvectors of a matrix pair (A, B) in
+* generalized real Schur canonical form (or of any matrix pair
+* (Q*A*Z', Q*B*Z') with orthogonal matrices Q and Z, where
+* Z' denotes the transpose of Z.
+*
+* (A, B) must be in generalized real Schur form (as returned by SGGES),
+* i.e. A is block upper triangular with 1-by-1 and 2-by-2 diagonal
+* blocks. B is upper triangular.
+*
+*
+* Arguments
+* =========
+*
+* JOB (input) CHARACTER*1
+* Specifies whether condition numbers are required for
+* eigenvalues (S) or eigenvectors (DIF):
+* = 'E': for eigenvalues only (S);
+* = 'V': for eigenvectors only (DIF);
+* = 'B': for both eigenvalues and eigenvectors (S and DIF).
+*
+* HOWMNY (input) CHARACTER*1
+* = 'A': compute condition numbers for all eigenpairs;
+* = 'S': compute condition numbers for selected eigenpairs
+* specified by the array SELECT.
+*
+* SELECT (input) LOGICAL array, dimension (N)
+* If HOWMNY = 'S', SELECT specifies the eigenpairs for which
+* condition numbers are required. To select condition numbers
+* for the eigenpair corresponding to a real eigenvalue w(j),
+* SELECT(j) must be set to .TRUE.. To select condition numbers
+* corresponding to a complex conjugate pair of eigenvalues w(j)
+* and w(j+1), either SELECT(j) or SELECT(j+1) or both, must be
+* set to .TRUE..
+* If HOWMNY = 'A', SELECT is not referenced.
+*
+* N (input) INTEGER
+* The order of the square matrix pair (A, B). N >= 0.
+*
+* A (input) REAL array, dimension (LDA,N)
+* The upper quasi-triangular matrix A in the pair (A,B).
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,N).
+*
+* B (input) REAL array, dimension (LDB,N)
+* The upper triangular matrix B in the pair (A,B).
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. LDB >= max(1,N).
+*
+* VL (input) REAL array, dimension (LDVL,M)
+* If JOB = 'E' or 'B', VL must contain left eigenvectors of
+* (A, B), corresponding to the eigenpairs specified by HOWMNY
+* and SELECT. The eigenvectors must be stored in consecutive
+* columns of VL, as returned by STGEVC.
+* If JOB = 'V', VL is not referenced.
+*
+* LDVL (input) INTEGER
+* The leading dimension of the array VL. LDVL >= 1.
+* If JOB = 'E' or 'B', LDVL >= N.
+*
+* VR (input) REAL array, dimension (LDVR,M)
+* If JOB = 'E' or 'B', VR must contain right eigenvectors of
+* (A, B), corresponding to the eigenpairs specified by HOWMNY
+* and SELECT. The eigenvectors must be stored in consecutive
+* columns ov VR, as returned by STGEVC.
+* If JOB = 'V', VR is not referenced.
+*
+* LDVR (input) INTEGER
+* The leading dimension of the array VR. LDVR >= 1.
+* If JOB = 'E' or 'B', LDVR >= N.
+*
+* S (output) REAL array, dimension (MM)
+* If JOB = 'E' or 'B', the reciprocal condition numbers of the
+* selected eigenvalues, stored in consecutive elements of the
+* array. For a complex conjugate pair of eigenvalues two
+* consecutive elements of S are set to the same value. Thus
+* S(j), DIF(j), and the j-th columns of VL and VR all
+* correspond to the same eigenpair (but not in general the
+* j-th eigenpair, unless all eigenpairs are selected).
+* If JOB = 'V', S is not referenced.
+*
+* DIF (output) REAL array, dimension (MM)
+* If JOB = 'V' or 'B', the estimated reciprocal condition
+* numbers of the selected eigenvectors, stored in consecutive
+* elements of the array. For a complex eigenvector two
+* consecutive elements of DIF are set to the same value. If
+* the eigenvalues cannot be reordered to compute DIF(j), DIF(j)
+* is set to 0; this can only occur when the true value would be
+* very small anyway.
+* If JOB = 'E', DIF is not referenced.
+*
+* MM (input) INTEGER
+* The number of elements in the arrays S and DIF. MM >= M.
+*
+* M (output) INTEGER
+* The number of elements of the arrays S and DIF used to store
+* the specified condition numbers; for each selected real
+* eigenvalue one element is used, and for each selected complex
+* conjugate pair of eigenvalues, two elements are used.
+* If HOWMNY = 'A', M is set to N.
+*
+* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))
+* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+* LWORK (input) INTEGER
+* The dimension of the array WORK. LWORK >= max(1,N).
+* If JOB = 'V' or 'B' LWORK >= 2*N*(N+2)+16.
+*
+* If LWORK = -1, then a workspace query is assumed; the routine
+* only calculates the optimal size of the WORK array, returns
+* this value as the first entry of the WORK array, and no error
+* message related to LWORK is issued by XERBLA.
+*
+* IWORK (workspace) INTEGER array, dimension (N + 6)
+* If JOB = 'E', IWORK is not referenced.
+*
+* INFO (output) INTEGER
+* =0: Successful exit
+* <0: If INFO = -i, the i-th argument had an illegal value
+*
+*
+* Further Details
+* ===============
+*
+* The reciprocal of the condition number of a generalized eigenvalue
+* w = (a, b) is defined as
+*
+* S(w) = (|u'Av|**2 + |u'Bv|**2)**(1/2) / (norm(u)*norm(v))
+*
+* where u and v are the left and right eigenvectors of (A, B)
+* corresponding to w; |z| denotes the absolute value of the complex
+* number, and norm(u) denotes the 2-norm of the vector u.
+* The pair (a, b) corresponds to an eigenvalue w = a/b (= u'Av/u'Bv)
+* of the matrix pair (A, B). If both a and b equal zero, then (A B) is
+* singular and S(I) = -1 is returned.
+*
+* An approximate error bound on the chordal distance between the i-th
+* computed generalized eigenvalue w and the corresponding exact
+* eigenvalue lambda is
+*
+* chord(w, lambda) <= EPS * norm(A, B) / S(I)
+*
+* where EPS is the machine precision.
+*
+* The reciprocal of the condition number DIF(i) of right eigenvector u
+* and left eigenvector v corresponding to the generalized eigenvalue w
+* is defined as follows:
+*
+* a) If the i-th eigenvalue w = (a,b) is real
+*
+* Suppose U and V are orthogonal transformations such that
+*
+* U'*(A, B)*V = (S, T) = ( a * ) ( b * ) 1
+* ( 0 S22 ),( 0 T22 ) n-1
+* 1 n-1 1 n-1
+*
+* Then the reciprocal condition number DIF(i) is
+*
+* Difl((a, b), (S22, T22)) = sigma-min( Zl ),
+*
+* where sigma-min(Zl) denotes the smallest singular value of the
+* 2(n-1)-by-2(n-1) matrix
+*
+* Zl = [ kron(a, In-1) -kron(1, S22) ]
+* [ kron(b, In-1) -kron(1, T22) ] .
+*
+* Here In-1 is the identity matrix of size n-1. kron(X, Y) is the
+* Kronecker product between the matrices X and Y.
+*
+* Note that if the default method for computing DIF(i) is wanted
+* (see SLATDF), then the parameter DIFDRI (see below) should be
+* changed from 3 to 4 (routine SLATDF(IJOB = 2 will be used)).
+* See STGSYL for more details.
+*
+* b) If the i-th and (i+1)-th eigenvalues are complex conjugate pair,
+*
+* Suppose U and V are orthogonal transformations such that
+*
+* U'*(A, B)*V = (S, T) = ( S11 * ) ( T11 * ) 2
+* ( 0 S22 ),( 0 T22) n-2
+* 2 n-2 2 n-2
+*
+* and (S11, T11) corresponds to the complex conjugate eigenvalue
+* pair (w, conjg(w)). There exist unitary matrices U1 and V1 such
+* that
+*
+* U1'*S11*V1 = ( s11 s12 ) and U1'*T11*V1 = ( t11 t12 )
+* ( 0 s22 ) ( 0 t22 )
+*
+* where the generalized eigenvalues w = s11/t11 and
+* conjg(w) = s22/t22.
+*
+* Then the reciprocal condition number DIF(i) is bounded by
+*
+* min( d1, max( 1, |real(s11)/real(s22)| )*d2 )
+*
+* where, d1 = Difl((s11, t11), (s22, t22)) = sigma-min(Z1), where
+* Z1 is the complex 2-by-2 matrix
+*
+* Z1 = [ s11 -s22 ]
+* [ t11 -t22 ],
+*
+* This is done by computing (using real arithmetic) the
+* roots of the characteristical polynomial det(Z1' * Z1 - lambda I),
+* where Z1' denotes the conjugate transpose of Z1 and det(X) denotes
+* the determinant of X.
+*
+* and d2 is an upper bound on Difl((S11, T11), (S22, T22)), i.e. an
+* upper bound on sigma-min(Z2), where Z2 is (2n-2)-by-(2n-2)
+*
+* Z2 = [ kron(S11', In-2) -kron(I2, S22) ]
+* [ kron(T11', In-2) -kron(I2, T22) ]
+*
+* Note that if the default method for computing DIF is wanted (see
+* SLATDF), then the parameter DIFDRI (see below) should be changed
+* from 3 to 4 (routine SLATDF(IJOB = 2 will be used)). See STGSYL
+* for more details.
+*
+* For each eigenvalue/vector specified by SELECT, DIF stores a
+* Frobenius norm-based estimate of Difl.
+*
+* An approximate error bound for the i-th computed eigenvector VL(i) or
+* VR(i) is given by
+*
+* EPS * norm(A, B) / DIF(i).
+*
+* See ref. [2-3] for more details and further references.
+*
+* Based on contributions by
+* Bo Kagstrom and Peter Poromaa, Department of Computing Science,
+* Umea University, S-901 87 Umea, Sweden.
+*
+* References
+* ==========
+*
+* [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the
+* Generalized Real Schur Form of a Regular Matrix Pair (A, B), in
+* M.S. Moonen et al (eds), Linear Algebra for Large Scale and
+* Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218.
+*
+* [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified
+* Eigenvalues of a Regular Matrix Pair (A, B) and Condition
+* Estimation: Theory, Algorithms and Software,
+* Report UMINF - 94.04, Department of Computing Science, Umea
+* University, S-901 87 Umea, Sweden, 1994. Also as LAPACK Working
+* Note 87. To appear in Numerical Algorithms, 1996.
+*
+* [3] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software
+* for Solving the Generalized Sylvester Equation and Estimating the
+* Separation between Regular Matrix Pairs, Report UMINF - 93.23,
+* Department of Computing Science, Umea University, S-901 87 Umea,
+* Sweden, December 1993, Revised April 1994, Also as LAPACK Working
+* Note 75. To appear in ACM Trans. on Math. Software, Vol 22,
+* No 1, 1996.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ INTEGER DIFDRI
+ PARAMETER ( DIFDRI = 3 )
+ REAL ZERO, ONE, TWO, FOUR
+ PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0, TWO = 2.0E+0,
+ $ FOUR = 4.0E+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL LQUERY, PAIR, SOMCON, WANTBH, WANTDF, WANTS
+ INTEGER I, IERR, IFST, ILST, IZ, K, KS, LWMIN, N1, N2
+ REAL ALPHAI, ALPHAR, ALPRQT, BETA, C1, C2, COND,
+ $ EPS, LNRM, RNRM, ROOT1, ROOT2, SCALE, SMLNUM,
+ $ TMPII, TMPIR, TMPRI, TMPRR, UHAV, UHAVI, UHBV,
+ $ UHBVI
+* ..
+* .. Local Arrays ..
+ REAL DUMMY( 1 ), DUMMY1( 1 )
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ REAL SDOT, SLAMCH, SLAPY2, SNRM2
+ EXTERNAL LSAME, SDOT, SLAMCH, SLAPY2, SNRM2
+* ..
+* .. External Subroutines ..
+ EXTERNAL SGEMV, SLACPY, SLAG2, STGEXC, STGSYL, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN, SQRT
+* ..
+* .. Executable Statements ..
+*
+* Decode and test the input parameters
+*
+ WANTBH = LSAME( JOB, 'B' )
+ WANTS = LSAME( JOB, 'E' ) .OR. WANTBH
+ WANTDF = LSAME( JOB, 'V' ) .OR. WANTBH
+*
+ SOMCON = LSAME( HOWMNY, 'S' )
+*
+ INFO = 0
+ LQUERY = ( LWORK.EQ.-1 )
+*
+ IF( .NOT.WANTS .AND. .NOT.WANTDF ) THEN
+ INFO = -1
+ ELSE IF( .NOT.LSAME( HOWMNY, 'A' ) .AND. .NOT.SOMCON ) THEN
+ INFO = -2
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -6
+ ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -8
+ ELSE IF( WANTS .AND. LDVL.LT.N ) THEN
+ INFO = -10
+ ELSE IF( WANTS .AND. LDVR.LT.N ) THEN
+ INFO = -12
+ ELSE
+*
+* Set M to the number of eigenpairs for which condition numbers
+* are required, and test MM.
+*
+ IF( SOMCON ) THEN
+ M = 0
+ PAIR = .FALSE.
+ DO 10 K = 1, N
+ IF( PAIR ) THEN
+ PAIR = .FALSE.
+ ELSE
+ IF( K.LT.N ) THEN
+ IF( A( K+1, K ).EQ.ZERO ) THEN
+ IF( SELECT( K ) )
+ $ M = M + 1
+ ELSE
+ PAIR = .TRUE.
+ IF( SELECT( K ) .OR. SELECT( K+1 ) )
+ $ M = M + 2
+ END IF
+ ELSE
+ IF( SELECT( N ) )
+ $ M = M + 1
+ END IF
+ END IF
+ 10 CONTINUE
+ ELSE
+ M = N
+ END IF
+*
+ IF( N.EQ.0 ) THEN
+ LWMIN = 1
+ ELSE IF( LSAME( JOB, 'V' ) .OR. LSAME( JOB, 'B' ) ) THEN
+ LWMIN = 2*N*( N + 2 ) + 16
+ ELSE
+ LWMIN = N
+ END IF
+ WORK( 1 ) = LWMIN
+*
+ IF( MM.LT.M ) THEN
+ INFO = -15
+ ELSE IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
+ INFO = -18
+ END IF
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'STGSNA', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+* Get machine constants
+*
+ EPS = SLAMCH( 'P' )
+ SMLNUM = SLAMCH( 'S' ) / EPS
+ KS = 0
+ PAIR = .FALSE.
+*
+ DO 20 K = 1, N
+*
+* Determine whether A(k,k) begins a 1-by-1 or 2-by-2 block.
+*
+ IF( PAIR ) THEN
+ PAIR = .FALSE.
+ GO TO 20
+ ELSE
+ IF( K.LT.N )
+ $ PAIR = A( K+1, K ).NE.ZERO
+ END IF
+*
+* Determine whether condition numbers are required for the k-th
+* eigenpair.
+*
+ IF( SOMCON ) THEN
+ IF( PAIR ) THEN
+ IF( .NOT.SELECT( K ) .AND. .NOT.SELECT( K+1 ) )
+ $ GO TO 20
+ ELSE
+ IF( .NOT.SELECT( K ) )
+ $ GO TO 20
+ END IF
+ END IF
+*
+ KS = KS + 1
+*
+ IF( WANTS ) THEN
+*
+* Compute the reciprocal condition number of the k-th
+* eigenvalue.
+*
+ IF( PAIR ) THEN
+*
+* Complex eigenvalue pair.
+*
+ RNRM = SLAPY2( SNRM2( N, VR( 1, KS ), 1 ),
+ $ SNRM2( N, VR( 1, KS+1 ), 1 ) )
+ LNRM = SLAPY2( SNRM2( N, VL( 1, KS ), 1 ),
+ $ SNRM2( N, VL( 1, KS+1 ), 1 ) )
+ CALL SGEMV( 'N', N, N, ONE, A, LDA, VR( 1, KS ), 1, ZERO,
+ $ WORK, 1 )
+ TMPRR = SDOT( N, WORK, 1, VL( 1, KS ), 1 )
+ TMPRI = SDOT( N, WORK, 1, VL( 1, KS+1 ), 1 )
+ CALL SGEMV( 'N', N, N, ONE, A, LDA, VR( 1, KS+1 ), 1,
+ $ ZERO, WORK, 1 )
+ TMPII = SDOT( N, WORK, 1, VL( 1, KS+1 ), 1 )
+ TMPIR = SDOT( N, WORK, 1, VL( 1, KS ), 1 )
+ UHAV = TMPRR + TMPII
+ UHAVI = TMPIR - TMPRI
+ CALL SGEMV( 'N', N, N, ONE, B, LDB, VR( 1, KS ), 1, ZERO,
+ $ WORK, 1 )
+ TMPRR = SDOT( N, WORK, 1, VL( 1, KS ), 1 )
+ TMPRI = SDOT( N, WORK, 1, VL( 1, KS+1 ), 1 )
+ CALL SGEMV( 'N', N, N, ONE, B, LDB, VR( 1, KS+1 ), 1,
+ $ ZERO, WORK, 1 )
+ TMPII = SDOT( N, WORK, 1, VL( 1, KS+1 ), 1 )
+ TMPIR = SDOT( N, WORK, 1, VL( 1, KS ), 1 )
+ UHBV = TMPRR + TMPII
+ UHBVI = TMPIR - TMPRI
+ UHAV = SLAPY2( UHAV, UHAVI )
+ UHBV = SLAPY2( UHBV, UHBVI )
+ COND = SLAPY2( UHAV, UHBV )
+ S( KS ) = COND / ( RNRM*LNRM )
+ S( KS+1 ) = S( KS )
+*
+ ELSE
+*
+* Real eigenvalue.
+*
+ RNRM = SNRM2( N, VR( 1, KS ), 1 )
+ LNRM = SNRM2( N, VL( 1, KS ), 1 )
+ CALL SGEMV( 'N', N, N, ONE, A, LDA, VR( 1, KS ), 1, ZERO,
+ $ WORK, 1 )
+ UHAV = SDOT( N, WORK, 1, VL( 1, KS ), 1 )
+ CALL SGEMV( 'N', N, N, ONE, B, LDB, VR( 1, KS ), 1, ZERO,
+ $ WORK, 1 )
+ UHBV = SDOT( N, WORK, 1, VL( 1, KS ), 1 )
+ COND = SLAPY2( UHAV, UHBV )
+ IF( COND.EQ.ZERO ) THEN
+ S( KS ) = -ONE
+ ELSE
+ S( KS ) = COND / ( RNRM*LNRM )
+ END IF
+ END IF
+ END IF
+*
+ IF( WANTDF ) THEN
+ IF( N.EQ.1 ) THEN
+ DIF( KS ) = SLAPY2( A( 1, 1 ), B( 1, 1 ) )
+ GO TO 20
+ END IF
+*
+* Estimate the reciprocal condition number of the k-th
+* eigenvectors.
+ IF( PAIR ) THEN
+*
+* Copy the 2-by 2 pencil beginning at (A(k,k), B(k, k)).
+* Compute the eigenvalue(s) at position K.
+*
+ WORK( 1 ) = A( K, K )
+ WORK( 2 ) = A( K+1, K )
+ WORK( 3 ) = A( K, K+1 )
+ WORK( 4 ) = A( K+1, K+1 )
+ WORK( 5 ) = B( K, K )
+ WORK( 6 ) = B( K+1, K )
+ WORK( 7 ) = B( K, K+1 )
+ WORK( 8 ) = B( K+1, K+1 )
+ CALL SLAG2( WORK, 2, WORK( 5 ), 2, SMLNUM*EPS, BETA,
+ $ DUMMY1( 1 ), ALPHAR, DUMMY( 1 ), ALPHAI )
+ ALPRQT = ONE
+ C1 = TWO*( ALPHAR*ALPHAR+ALPHAI*ALPHAI+BETA*BETA )
+ C2 = FOUR*BETA*BETA*ALPHAI*ALPHAI
+ ROOT1 = C1 + SQRT( C1*C1-4.0*C2 )
+ ROOT2 = C2 / ROOT1
+ ROOT1 = ROOT1 / TWO
+ COND = MIN( SQRT( ROOT1 ), SQRT( ROOT2 ) )
+ END IF
+*
+* Copy the matrix (A, B) to the array WORK and swap the
+* diagonal block beginning at A(k,k) to the (1,1) position.
+*
+ CALL SLACPY( 'Full', N, N, A, LDA, WORK, N )
+ CALL SLACPY( 'Full', N, N, B, LDB, WORK( N*N+1 ), N )
+ IFST = K
+ ILST = 1
+*
+ CALL STGEXC( .FALSE., .FALSE., N, WORK, N, WORK( N*N+1 ), N,
+ $ DUMMY, 1, DUMMY1, 1, IFST, ILST,
+ $ WORK( N*N*2+1 ), LWORK-2*N*N, IERR )
+*
+ IF( IERR.GT.0 ) THEN
+*
+* Ill-conditioned problem - swap rejected.
+*
+ DIF( KS ) = ZERO
+ ELSE
+*
+* Reordering successful, solve generalized Sylvester
+* equation for R and L,
+* A22 * R - L * A11 = A12
+* B22 * R - L * B11 = B12,
+* and compute estimate of Difl((A11,B11), (A22, B22)).
+*
+ N1 = 1
+ IF( WORK( 2 ).NE.ZERO )
+ $ N1 = 2
+ N2 = N - N1
+ IF( N2.EQ.0 ) THEN
+ DIF( KS ) = COND
+ ELSE
+ I = N*N + 1
+ IZ = 2*N*N + 1
+ CALL STGSYL( 'N', DIFDRI, N2, N1, WORK( N*N1+N1+1 ),
+ $ N, WORK, N, WORK( N1+1 ), N,
+ $ WORK( N*N1+N1+I ), N, WORK( I ), N,
+ $ WORK( N1+I ), N, SCALE, DIF( KS ),
+ $ WORK( IZ+1 ), LWORK-2*N*N, IWORK, IERR )
+*
+ IF( PAIR )
+ $ DIF( KS ) = MIN( MAX( ONE, ALPRQT )*DIF( KS ),
+ $ COND )
+ END IF
+ END IF
+ IF( PAIR )
+ $ DIF( KS+1 ) = DIF( KS )
+ END IF
+ IF( PAIR )
+ $ KS = KS + 1
+*
+ 20 CONTINUE
+ WORK( 1 ) = LWMIN
+ RETURN
+*
+* End of STGSNA
+*
+ END
+ SUBROUTINE STGSY2( TRANS, IJOB, M, N, A, LDA, B, LDB, C, LDC, D,
+ $ LDD, E, LDE, F, LDF, SCALE, RDSUM, RDSCAL,
+ $ IWORK, PQ, INFO )
+*
+* -- LAPACK auxiliary routine (version 3.1.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* January 2007
+*
+* .. Scalar Arguments ..
+ CHARACTER TRANS
+ INTEGER IJOB, INFO, LDA, LDB, LDC, LDD, LDE, LDF, M, N,
+ $ PQ
+ REAL RDSCAL, RDSUM, SCALE
+* ..
+* .. Array Arguments ..
+ INTEGER IWORK( * )
+ REAL A( LDA, * ), B( LDB, * ), C( LDC, * ),
+ $ D( LDD, * ), E( LDE, * ), F( LDF, * )
+* ..
+*
+* Purpose
+* =======
+*
+* STGSY2 solves the generalized Sylvester equation:
+*
+* A * R - L * B = scale * C (1)
+* D * R - L * E = scale * F,
+*
+* using Level 1 and 2 BLAS. where R and L are unknown M-by-N matrices,
+* (A, D), (B, E) and (C, F) are given matrix pairs of size M-by-M,
+* N-by-N and M-by-N, respectively, with real entries. (A, D) and (B, E)
+* must be in generalized Schur canonical form, i.e. A, B are upper
+* quasi triangular and D, E are upper triangular. The solution (R, L)
+* overwrites (C, F). 0 <= SCALE <= 1 is an output scaling factor
+* chosen to avoid overflow.
+*
+* In matrix notation solving equation (1) corresponds to solve
+* Z*x = scale*b, where Z is defined as
+*
+* Z = [ kron(In, A) -kron(B', Im) ] (2)
+* [ kron(In, D) -kron(E', Im) ],
+*
+* Ik is the identity matrix of size k and X' is the transpose of X.
+* kron(X, Y) is the Kronecker product between the matrices X and Y.
+* In the process of solving (1), we solve a number of such systems
+* where Dim(In), Dim(In) = 1 or 2.
+*
+* If TRANS = 'T', solve the transposed system Z'*y = scale*b for y,
+* which is equivalent to solve for R and L in
+*
+* A' * R + D' * L = scale * C (3)
+* R * B' + L * E' = scale * -F
+*
+* This case is used to compute an estimate of Dif[(A, D), (B, E)] =
+* sigma_min(Z) using reverse communicaton with SLACON.
+*
+* STGSY2 also (IJOB >= 1) contributes to the computation in STGSYL
+* of an upper bound on the separation between to matrix pairs. Then
+* the input (A, D), (B, E) are sub-pencils of the matrix pair in
+* STGSYL. See STGSYL for details.
+*
+* Arguments
+* =========
+*
+* TRANS (input) CHARACTER*1
+* = 'N', solve the generalized Sylvester equation (1).
+* = 'T': solve the 'transposed' system (3).
+*
+* IJOB (input) INTEGER
+* Specifies what kind of functionality to be performed.
+* = 0: solve (1) only.
+* = 1: A contribution from this subsystem to a Frobenius
+* norm-based estimate of the separation between two matrix
+* pairs is computed. (look ahead strategy is used).
+* = 2: A contribution from this subsystem to a Frobenius
+* norm-based estimate of the separation between two matrix
+* pairs is computed. (SGECON on sub-systems is used.)
+* Not referenced if TRANS = 'T'.
+*
+* M (input) INTEGER
+* On entry, M specifies the order of A and D, and the row
+* dimension of C, F, R and L.
+*
+* N (input) INTEGER
+* On entry, N specifies the order of B and E, and the column
+* dimension of C, F, R and L.
+*
+* A (input) REAL array, dimension (LDA, M)
+* On entry, A contains an upper quasi triangular matrix.
+*
+* LDA (input) INTEGER
+* The leading dimension of the matrix A. LDA >= max(1, M).
+*
+* B (input) REAL array, dimension (LDB, N)
+* On entry, B contains an upper quasi triangular matrix.
+*
+* LDB (input) INTEGER
+* The leading dimension of the matrix B. LDB >= max(1, N).
+*
+* C (input/output) REAL array, dimension (LDC, N)
+* On entry, C contains the right-hand-side of the first matrix
+* equation in (1).
+* On exit, if IJOB = 0, C has been overwritten by the
+* solution R.
+*
+* LDC (input) INTEGER
+* The leading dimension of the matrix C. LDC >= max(1, M).
+*
+* D (input) REAL array, dimension (LDD, M)
+* On entry, D contains an upper triangular matrix.
+*
+* LDD (input) INTEGER
+* The leading dimension of the matrix D. LDD >= max(1, M).
+*
+* E (input) REAL array, dimension (LDE, N)
+* On entry, E contains an upper triangular matrix.
+*
+* LDE (input) INTEGER
+* The leading dimension of the matrix E. LDE >= max(1, N).
+*
+* F (input/output) REAL array, dimension (LDF, N)
+* On entry, F contains the right-hand-side of the second matrix
+* equation in (1).
+* On exit, if IJOB = 0, F has been overwritten by the
+* solution L.
+*
+* LDF (input) INTEGER
+* The leading dimension of the matrix F. LDF >= max(1, M).
+*
+* SCALE (output) REAL
+* On exit, 0 <= SCALE <= 1. If 0 < SCALE < 1, the solutions
+* R and L (C and F on entry) will hold the solutions to a
+* slightly perturbed system but the input matrices A, B, D and
+* E have not been changed. If SCALE = 0, R and L will hold the
+* solutions to the homogeneous system with C = F = 0. Normally,
+* SCALE = 1.
+*
+* RDSUM (input/output) REAL
+* On entry, the sum of squares of computed contributions to
+* the Dif-estimate under computation by STGSYL, where the
+* scaling factor RDSCAL (see below) has been factored out.
+* On exit, the corresponding sum of squares updated with the
+* contributions from the current sub-system.
+* If TRANS = 'T' RDSUM is not touched.
+* NOTE: RDSUM only makes sense when STGSY2 is called by STGSYL.
+*
+* RDSCAL (input/output) REAL
+* On entry, scaling factor used to prevent overflow in RDSUM.
+* On exit, RDSCAL is updated w.r.t. the current contributions
+* in RDSUM.
+* If TRANS = 'T', RDSCAL is not touched.
+* NOTE: RDSCAL only makes sense when STGSY2 is called by
+* STGSYL.
+*
+* IWORK (workspace) INTEGER array, dimension (M+N+2)
+*
+* PQ (output) INTEGER
+* On exit, the number of subsystems (of size 2-by-2, 4-by-4 and
+* 8-by-8) solved by this routine.
+*
+* INFO (output) INTEGER
+* On exit, if INFO is set to
+* =0: Successful exit
+* <0: If INFO = -i, the i-th argument had an illegal value.
+* >0: The matrix pairs (A, D) and (B, E) have common or very
+* close eigenvalues.
+*
+* Further Details
+* ===============
+*
+* Based on contributions by
+* Bo Kagstrom and Peter Poromaa, Department of Computing Science,
+* Umea University, S-901 87 Umea, Sweden.
+*
+* =====================================================================
+* Replaced various illegal calls to SCOPY by calls to SLASET.
+* Sven Hammarling, 27/5/02.
+*
+* .. Parameters ..
+ INTEGER LDZ
+ PARAMETER ( LDZ = 8 )
+ REAL ZERO, ONE
+ PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL NOTRAN
+ INTEGER I, IE, IERR, II, IS, ISP1, J, JE, JJ, JS, JSP1,
+ $ K, MB, NB, P, Q, ZDIM
+ REAL ALPHA, SCALOC
+* ..
+* .. Local Arrays ..
+ INTEGER IPIV( LDZ ), JPIV( LDZ )
+ REAL RHS( LDZ ), Z( LDZ, LDZ )
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL SAXPY, SCOPY, SGEMM, SGEMV, SGER, SGESC2,
+ $ SGETC2, SSCAL, SLASET, SLATDF, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+* Decode and test input parameters
+*
+ INFO = 0
+ IERR = 0
+ NOTRAN = LSAME( TRANS, 'N' )
+ IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN
+ INFO = -1
+ ELSE IF( NOTRAN ) THEN
+ IF( ( IJOB.LT.0 ) .OR. ( IJOB.GT.2 ) ) THEN
+ INFO = -2
+ END IF
+ END IF
+ IF( INFO.EQ.0 ) THEN
+ IF( M.LE.0 ) THEN
+ INFO = -3
+ ELSE IF( N.LE.0 ) THEN
+ INFO = -4
+ ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+ INFO = -5
+ ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -8
+ ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
+ INFO = -10
+ ELSE IF( LDD.LT.MAX( 1, M ) ) THEN
+ INFO = -12
+ ELSE IF( LDE.LT.MAX( 1, N ) ) THEN
+ INFO = -14
+ ELSE IF( LDF.LT.MAX( 1, M ) ) THEN
+ INFO = -16
+ END IF
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'STGSY2', -INFO )
+ RETURN
+ END IF
+*
+* Determine block structure of A
+*
+ PQ = 0
+ P = 0
+ I = 1
+ 10 CONTINUE
+ IF( I.GT.M )
+ $ GO TO 20
+ P = P + 1
+ IWORK( P ) = I
+ IF( I.EQ.M )
+ $ GO TO 20
+ IF( A( I+1, I ).NE.ZERO ) THEN
+ I = I + 2
+ ELSE
+ I = I + 1
+ END IF
+ GO TO 10
+ 20 CONTINUE
+ IWORK( P+1 ) = M + 1
+*
+* Determine block structure of B
+*
+ Q = P + 1
+ J = 1
+ 30 CONTINUE
+ IF( J.GT.N )
+ $ GO TO 40
+ Q = Q + 1
+ IWORK( Q ) = J
+ IF( J.EQ.N )
+ $ GO TO 40
+ IF( B( J+1, J ).NE.ZERO ) THEN
+ J = J + 2
+ ELSE
+ J = J + 1
+ END IF
+ GO TO 30
+ 40 CONTINUE
+ IWORK( Q+1 ) = N + 1
+ PQ = P*( Q-P-1 )
+*
+ IF( NOTRAN ) THEN
+*
+* Solve (I, J) - subsystem
+* A(I, I) * R(I, J) - L(I, J) * B(J, J) = C(I, J)
+* D(I, I) * R(I, J) - L(I, J) * E(J, J) = F(I, J)
+* for I = P, P - 1, ..., 1; J = 1, 2, ..., Q
+*
+ SCALE = ONE
+ SCALOC = ONE
+ DO 120 J = P + 2, Q
+ JS = IWORK( J )
+ JSP1 = JS + 1
+ JE = IWORK( J+1 ) - 1
+ NB = JE - JS + 1
+ DO 110 I = P, 1, -1
+*
+ IS = IWORK( I )
+ ISP1 = IS + 1
+ IE = IWORK( I+1 ) - 1
+ MB = IE - IS + 1
+ ZDIM = MB*NB*2
+*
+ IF( ( MB.EQ.1 ) .AND. ( NB.EQ.1 ) ) THEN
+*
+* Build a 2-by-2 system Z * x = RHS
+*
+ Z( 1, 1 ) = A( IS, IS )
+ Z( 2, 1 ) = D( IS, IS )
+ Z( 1, 2 ) = -B( JS, JS )
+ Z( 2, 2 ) = -E( JS, JS )
+*
+* Set up right hand side(s)
+*
+ RHS( 1 ) = C( IS, JS )
+ RHS( 2 ) = F( IS, JS )
+*
+* Solve Z * x = RHS
+*
+ CALL SGETC2( ZDIM, Z, LDZ, IPIV, JPIV, IERR )
+ IF( IERR.GT.0 )
+ $ INFO = IERR
+*
+ IF( IJOB.EQ.0 ) THEN
+ CALL SGESC2( ZDIM, Z, LDZ, RHS, IPIV, JPIV,
+ $ SCALOC )
+ IF( SCALOC.NE.ONE ) THEN
+ DO 50 K = 1, N
+ CALL SSCAL( M, SCALOC, C( 1, K ), 1 )
+ CALL SSCAL( M, SCALOC, F( 1, K ), 1 )
+ 50 CONTINUE
+ SCALE = SCALE*SCALOC
+ END IF
+ ELSE
+ CALL SLATDF( IJOB, ZDIM, Z, LDZ, RHS, RDSUM,
+ $ RDSCAL, IPIV, JPIV )
+ END IF
+*
+* Unpack solution vector(s)
+*
+ C( IS, JS ) = RHS( 1 )
+ F( IS, JS ) = RHS( 2 )
+*
+* Substitute R(I, J) and L(I, J) into remaining
+* equation.
+*
+ IF( I.GT.1 ) THEN
+ ALPHA = -RHS( 1 )
+ CALL SAXPY( IS-1, ALPHA, A( 1, IS ), 1, C( 1, JS ),
+ $ 1 )
+ CALL SAXPY( IS-1, ALPHA, D( 1, IS ), 1, F( 1, JS ),
+ $ 1 )
+ END IF
+ IF( J.LT.Q ) THEN
+ CALL SAXPY( N-JE, RHS( 2 ), B( JS, JE+1 ), LDB,
+ $ C( IS, JE+1 ), LDC )
+ CALL SAXPY( N-JE, RHS( 2 ), E( JS, JE+1 ), LDE,
+ $ F( IS, JE+1 ), LDF )
+ END IF
+*
+ ELSE IF( ( MB.EQ.1 ) .AND. ( NB.EQ.2 ) ) THEN
+*
+* Build a 4-by-4 system Z * x = RHS
+*
+ Z( 1, 1 ) = A( IS, IS )
+ Z( 2, 1 ) = ZERO
+ Z( 3, 1 ) = D( IS, IS )
+ Z( 4, 1 ) = ZERO
+*
+ Z( 1, 2 ) = ZERO
+ Z( 2, 2 ) = A( IS, IS )
+ Z( 3, 2 ) = ZERO
+ Z( 4, 2 ) = D( IS, IS )
+*
+ Z( 1, 3 ) = -B( JS, JS )
+ Z( 2, 3 ) = -B( JS, JSP1 )
+ Z( 3, 3 ) = -E( JS, JS )
+ Z( 4, 3 ) = -E( JS, JSP1 )
+*
+ Z( 1, 4 ) = -B( JSP1, JS )
+ Z( 2, 4 ) = -B( JSP1, JSP1 )
+ Z( 3, 4 ) = ZERO
+ Z( 4, 4 ) = -E( JSP1, JSP1 )
+*
+* Set up right hand side(s)
+*
+ RHS( 1 ) = C( IS, JS )
+ RHS( 2 ) = C( IS, JSP1 )
+ RHS( 3 ) = F( IS, JS )
+ RHS( 4 ) = F( IS, JSP1 )
+*
+* Solve Z * x = RHS
+*
+ CALL SGETC2( ZDIM, Z, LDZ, IPIV, JPIV, IERR )
+ IF( IERR.GT.0 )
+ $ INFO = IERR
+*
+ IF( IJOB.EQ.0 ) THEN
+ CALL SGESC2( ZDIM, Z, LDZ, RHS, IPIV, JPIV,
+ $ SCALOC )
+ IF( SCALOC.NE.ONE ) THEN
+ DO 60 K = 1, N
+ CALL SSCAL( M, SCALOC, C( 1, K ), 1 )
+ CALL SSCAL( M, SCALOC, F( 1, K ), 1 )
+ 60 CONTINUE
+ SCALE = SCALE*SCALOC
+ END IF
+ ELSE
+ CALL SLATDF( IJOB, ZDIM, Z, LDZ, RHS, RDSUM,
+ $ RDSCAL, IPIV, JPIV )
+ END IF
+*
+* Unpack solution vector(s)
+*
+ C( IS, JS ) = RHS( 1 )
+ C( IS, JSP1 ) = RHS( 2 )
+ F( IS, JS ) = RHS( 3 )
+ F( IS, JSP1 ) = RHS( 4 )
+*
+* Substitute R(I, J) and L(I, J) into remaining
+* equation.
+*
+ IF( I.GT.1 ) THEN
+ CALL SGER( IS-1, NB, -ONE, A( 1, IS ), 1, RHS( 1 ),
+ $ 1, C( 1, JS ), LDC )
+ CALL SGER( IS-1, NB, -ONE, D( 1, IS ), 1, RHS( 1 ),
+ $ 1, F( 1, JS ), LDF )
+ END IF
+ IF( J.LT.Q ) THEN
+ CALL SAXPY( N-JE, RHS( 3 ), B( JS, JE+1 ), LDB,
+ $ C( IS, JE+1 ), LDC )
+ CALL SAXPY( N-JE, RHS( 3 ), E( JS, JE+1 ), LDE,
+ $ F( IS, JE+1 ), LDF )
+ CALL SAXPY( N-JE, RHS( 4 ), B( JSP1, JE+1 ), LDB,
+ $ C( IS, JE+1 ), LDC )
+ CALL SAXPY( N-JE, RHS( 4 ), E( JSP1, JE+1 ), LDE,
+ $ F( IS, JE+1 ), LDF )
+ END IF
+*
+ ELSE IF( ( MB.EQ.2 ) .AND. ( NB.EQ.1 ) ) THEN
+*
+* Build a 4-by-4 system Z * x = RHS
+*
+ Z( 1, 1 ) = A( IS, IS )
+ Z( 2, 1 ) = A( ISP1, IS )
+ Z( 3, 1 ) = D( IS, IS )
+ Z( 4, 1 ) = ZERO
+*
+ Z( 1, 2 ) = A( IS, ISP1 )
+ Z( 2, 2 ) = A( ISP1, ISP1 )
+ Z( 3, 2 ) = D( IS, ISP1 )
+ Z( 4, 2 ) = D( ISP1, ISP1 )
+*
+ Z( 1, 3 ) = -B( JS, JS )
+ Z( 2, 3 ) = ZERO
+ Z( 3, 3 ) = -E( JS, JS )
+ Z( 4, 3 ) = ZERO
+*
+ Z( 1, 4 ) = ZERO
+ Z( 2, 4 ) = -B( JS, JS )
+ Z( 3, 4 ) = ZERO
+ Z( 4, 4 ) = -E( JS, JS )
+*
+* Set up right hand side(s)
+*
+ RHS( 1 ) = C( IS, JS )
+ RHS( 2 ) = C( ISP1, JS )
+ RHS( 3 ) = F( IS, JS )
+ RHS( 4 ) = F( ISP1, JS )
+*
+* Solve Z * x = RHS
+*
+ CALL SGETC2( ZDIM, Z, LDZ, IPIV, JPIV, IERR )
+ IF( IERR.GT.0 )
+ $ INFO = IERR
+ IF( IJOB.EQ.0 ) THEN
+ CALL SGESC2( ZDIM, Z, LDZ, RHS, IPIV, JPIV,
+ $ SCALOC )
+ IF( SCALOC.NE.ONE ) THEN
+ DO 70 K = 1, N
+ CALL SSCAL( M, SCALOC, C( 1, K ), 1 )
+ CALL SSCAL( M, SCALOC, F( 1, K ), 1 )
+ 70 CONTINUE
+ SCALE = SCALE*SCALOC
+ END IF
+ ELSE
+ CALL SLATDF( IJOB, ZDIM, Z, LDZ, RHS, RDSUM,
+ $ RDSCAL, IPIV, JPIV )
+ END IF
+*
+* Unpack solution vector(s)
+*
+ C( IS, JS ) = RHS( 1 )
+ C( ISP1, JS ) = RHS( 2 )
+ F( IS, JS ) = RHS( 3 )
+ F( ISP1, JS ) = RHS( 4 )
+*
+* Substitute R(I, J) and L(I, J) into remaining
+* equation.
+*
+ IF( I.GT.1 ) THEN
+ CALL SGEMV( 'N', IS-1, MB, -ONE, A( 1, IS ), LDA,
+ $ RHS( 1 ), 1, ONE, C( 1, JS ), 1 )
+ CALL SGEMV( 'N', IS-1, MB, -ONE, D( 1, IS ), LDD,
+ $ RHS( 1 ), 1, ONE, F( 1, JS ), 1 )
+ END IF
+ IF( J.LT.Q ) THEN
+ CALL SGER( MB, N-JE, ONE, RHS( 3 ), 1,
+ $ B( JS, JE+1 ), LDB, C( IS, JE+1 ), LDC )
+ CALL SGER( MB, N-JE, ONE, RHS( 3 ), 1,
+ $ E( JS, JE+1 ), LDE, F( IS, JE+1 ), LDF )
+ END IF
+*
+ ELSE IF( ( MB.EQ.2 ) .AND. ( NB.EQ.2 ) ) THEN
+*
+* Build an 8-by-8 system Z * x = RHS
+*
+ CALL SLASET( 'F', LDZ, LDZ, ZERO, ZERO, Z, LDZ )
+*
+ Z( 1, 1 ) = A( IS, IS )
+ Z( 2, 1 ) = A( ISP1, IS )
+ Z( 5, 1 ) = D( IS, IS )
+*
+ Z( 1, 2 ) = A( IS, ISP1 )
+ Z( 2, 2 ) = A( ISP1, ISP1 )
+ Z( 5, 2 ) = D( IS, ISP1 )
+ Z( 6, 2 ) = D( ISP1, ISP1 )
+*
+ Z( 3, 3 ) = A( IS, IS )
+ Z( 4, 3 ) = A( ISP1, IS )
+ Z( 7, 3 ) = D( IS, IS )
+*
+ Z( 3, 4 ) = A( IS, ISP1 )
+ Z( 4, 4 ) = A( ISP1, ISP1 )
+ Z( 7, 4 ) = D( IS, ISP1 )
+ Z( 8, 4 ) = D( ISP1, ISP1 )
+*
+ Z( 1, 5 ) = -B( JS, JS )
+ Z( 3, 5 ) = -B( JS, JSP1 )
+ Z( 5, 5 ) = -E( JS, JS )
+ Z( 7, 5 ) = -E( JS, JSP1 )
+*
+ Z( 2, 6 ) = -B( JS, JS )
+ Z( 4, 6 ) = -B( JS, JSP1 )
+ Z( 6, 6 ) = -E( JS, JS )
+ Z( 8, 6 ) = -E( JS, JSP1 )
+*
+ Z( 1, 7 ) = -B( JSP1, JS )
+ Z( 3, 7 ) = -B( JSP1, JSP1 )
+ Z( 7, 7 ) = -E( JSP1, JSP1 )
+*
+ Z( 2, 8 ) = -B( JSP1, JS )
+ Z( 4, 8 ) = -B( JSP1, JSP1 )
+ Z( 8, 8 ) = -E( JSP1, JSP1 )
+*
+* Set up right hand side(s)
+*
+ K = 1
+ II = MB*NB + 1
+ DO 80 JJ = 0, NB - 1
+ CALL SCOPY( MB, C( IS, JS+JJ ), 1, RHS( K ), 1 )
+ CALL SCOPY( MB, F( IS, JS+JJ ), 1, RHS( II ), 1 )
+ K = K + MB
+ II = II + MB
+ 80 CONTINUE
+*
+* Solve Z * x = RHS
+*
+ CALL SGETC2( ZDIM, Z, LDZ, IPIV, JPIV, IERR )
+ IF( IERR.GT.0 )
+ $ INFO = IERR
+ IF( IJOB.EQ.0 ) THEN
+ CALL SGESC2( ZDIM, Z, LDZ, RHS, IPIV, JPIV,
+ $ SCALOC )
+ IF( SCALOC.NE.ONE ) THEN
+ DO 90 K = 1, N
+ CALL SSCAL( M, SCALOC, C( 1, K ), 1 )
+ CALL SSCAL( M, SCALOC, F( 1, K ), 1 )
+ 90 CONTINUE
+ SCALE = SCALE*SCALOC
+ END IF
+ ELSE
+ CALL SLATDF( IJOB, ZDIM, Z, LDZ, RHS, RDSUM,
+ $ RDSCAL, IPIV, JPIV )
+ END IF
+*
+* Unpack solution vector(s)
+*
+ K = 1
+ II = MB*NB + 1
+ DO 100 JJ = 0, NB - 1
+ CALL SCOPY( MB, RHS( K ), 1, C( IS, JS+JJ ), 1 )
+ CALL SCOPY( MB, RHS( II ), 1, F( IS, JS+JJ ), 1 )
+ K = K + MB
+ II = II + MB
+ 100 CONTINUE
+*
+* Substitute R(I, J) and L(I, J) into remaining
+* equation.
+*
+ IF( I.GT.1 ) THEN
+ CALL SGEMM( 'N', 'N', IS-1, NB, MB, -ONE,
+ $ A( 1, IS ), LDA, RHS( 1 ), MB, ONE,
+ $ C( 1, JS ), LDC )
+ CALL SGEMM( 'N', 'N', IS-1, NB, MB, -ONE,
+ $ D( 1, IS ), LDD, RHS( 1 ), MB, ONE,
+ $ F( 1, JS ), LDF )
+ END IF
+ IF( J.LT.Q ) THEN
+ K = MB*NB + 1
+ CALL SGEMM( 'N', 'N', MB, N-JE, NB, ONE, RHS( K ),
+ $ MB, B( JS, JE+1 ), LDB, ONE,
+ $ C( IS, JE+1 ), LDC )
+ CALL SGEMM( 'N', 'N', MB, N-JE, NB, ONE, RHS( K ),
+ $ MB, E( JS, JE+1 ), LDE, ONE,
+ $ F( IS, JE+1 ), LDF )
+ END IF
+*
+ END IF
+*
+ 110 CONTINUE
+ 120 CONTINUE
+ ELSE
+*
+* Solve (I, J) - subsystem
+* A(I, I)' * R(I, J) + D(I, I)' * L(J, J) = C(I, J)
+* R(I, I) * B(J, J) + L(I, J) * E(J, J) = -F(I, J)
+* for I = 1, 2, ..., P, J = Q, Q - 1, ..., 1
+*
+ SCALE = ONE
+ SCALOC = ONE
+ DO 200 I = 1, P
+*
+ IS = IWORK( I )
+ ISP1 = IS + 1
+ IE = IWORK( I+1 ) - 1
+ MB = IE - IS + 1
+ DO 190 J = Q, P + 2, -1
+*
+ JS = IWORK( J )
+ JSP1 = JS + 1
+ JE = IWORK( J+1 ) - 1
+ NB = JE - JS + 1
+ ZDIM = MB*NB*2
+ IF( ( MB.EQ.1 ) .AND. ( NB.EQ.1 ) ) THEN
+*
+* Build a 2-by-2 system Z' * x = RHS
+*
+ Z( 1, 1 ) = A( IS, IS )
+ Z( 2, 1 ) = -B( JS, JS )
+ Z( 1, 2 ) = D( IS, IS )
+ Z( 2, 2 ) = -E( JS, JS )
+*
+* Set up right hand side(s)
+*
+ RHS( 1 ) = C( IS, JS )
+ RHS( 2 ) = F( IS, JS )
+*
+* Solve Z' * x = RHS
+*
+ CALL SGETC2( ZDIM, Z, LDZ, IPIV, JPIV, IERR )
+ IF( IERR.GT.0 )
+ $ INFO = IERR
+*
+ CALL SGESC2( ZDIM, Z, LDZ, RHS, IPIV, JPIV, SCALOC )
+ IF( SCALOC.NE.ONE ) THEN
+ DO 130 K = 1, N
+ CALL SSCAL( M, SCALOC, C( 1, K ), 1 )
+ CALL SSCAL( M, SCALOC, F( 1, K ), 1 )
+ 130 CONTINUE
+ SCALE = SCALE*SCALOC
+ END IF
+*
+* Unpack solution vector(s)
+*
+ C( IS, JS ) = RHS( 1 )
+ F( IS, JS ) = RHS( 2 )
+*
+* Substitute R(I, J) and L(I, J) into remaining
+* equation.
+*
+ IF( J.GT.P+2 ) THEN
+ ALPHA = RHS( 1 )
+ CALL SAXPY( JS-1, ALPHA, B( 1, JS ), 1, F( IS, 1 ),
+ $ LDF )
+ ALPHA = RHS( 2 )
+ CALL SAXPY( JS-1, ALPHA, E( 1, JS ), 1, F( IS, 1 ),
+ $ LDF )
+ END IF
+ IF( I.LT.P ) THEN
+ ALPHA = -RHS( 1 )
+ CALL SAXPY( M-IE, ALPHA, A( IS, IE+1 ), LDA,
+ $ C( IE+1, JS ), 1 )
+ ALPHA = -RHS( 2 )
+ CALL SAXPY( M-IE, ALPHA, D( IS, IE+1 ), LDD,
+ $ C( IE+1, JS ), 1 )
+ END IF
+*
+ ELSE IF( ( MB.EQ.1 ) .AND. ( NB.EQ.2 ) ) THEN
+*
+* Build a 4-by-4 system Z' * x = RHS
+*
+ Z( 1, 1 ) = A( IS, IS )
+ Z( 2, 1 ) = ZERO
+ Z( 3, 1 ) = -B( JS, JS )
+ Z( 4, 1 ) = -B( JSP1, JS )
+*
+ Z( 1, 2 ) = ZERO
+ Z( 2, 2 ) = A( IS, IS )
+ Z( 3, 2 ) = -B( JS, JSP1 )
+ Z( 4, 2 ) = -B( JSP1, JSP1 )
+*
+ Z( 1, 3 ) = D( IS, IS )
+ Z( 2, 3 ) = ZERO
+ Z( 3, 3 ) = -E( JS, JS )
+ Z( 4, 3 ) = ZERO
+*
+ Z( 1, 4 ) = ZERO
+ Z( 2, 4 ) = D( IS, IS )
+ Z( 3, 4 ) = -E( JS, JSP1 )
+ Z( 4, 4 ) = -E( JSP1, JSP1 )
+*
+* Set up right hand side(s)
+*
+ RHS( 1 ) = C( IS, JS )
+ RHS( 2 ) = C( IS, JSP1 )
+ RHS( 3 ) = F( IS, JS )
+ RHS( 4 ) = F( IS, JSP1 )
+*
+* Solve Z' * x = RHS
+*
+ CALL SGETC2( ZDIM, Z, LDZ, IPIV, JPIV, IERR )
+ IF( IERR.GT.0 )
+ $ INFO = IERR
+ CALL SGESC2( ZDIM, Z, LDZ, RHS, IPIV, JPIV, SCALOC )
+ IF( SCALOC.NE.ONE ) THEN
+ DO 140 K = 1, N
+ CALL SSCAL( M, SCALOC, C( 1, K ), 1 )
+ CALL SSCAL( M, SCALOC, F( 1, K ), 1 )
+ 140 CONTINUE
+ SCALE = SCALE*SCALOC
+ END IF
+*
+* Unpack solution vector(s)
+*
+ C( IS, JS ) = RHS( 1 )
+ C( IS, JSP1 ) = RHS( 2 )
+ F( IS, JS ) = RHS( 3 )
+ F( IS, JSP1 ) = RHS( 4 )
+*
+* Substitute R(I, J) and L(I, J) into remaining
+* equation.
+*
+ IF( J.GT.P+2 ) THEN
+ CALL SAXPY( JS-1, RHS( 1 ), B( 1, JS ), 1,
+ $ F( IS, 1 ), LDF )
+ CALL SAXPY( JS-1, RHS( 2 ), B( 1, JSP1 ), 1,
+ $ F( IS, 1 ), LDF )
+ CALL SAXPY( JS-1, RHS( 3 ), E( 1, JS ), 1,
+ $ F( IS, 1 ), LDF )
+ CALL SAXPY( JS-1, RHS( 4 ), E( 1, JSP1 ), 1,
+ $ F( IS, 1 ), LDF )
+ END IF
+ IF( I.LT.P ) THEN
+ CALL SGER( M-IE, NB, -ONE, A( IS, IE+1 ), LDA,
+ $ RHS( 1 ), 1, C( IE+1, JS ), LDC )
+ CALL SGER( M-IE, NB, -ONE, D( IS, IE+1 ), LDD,
+ $ RHS( 3 ), 1, C( IE+1, JS ), LDC )
+ END IF
+*
+ ELSE IF( ( MB.EQ.2 ) .AND. ( NB.EQ.1 ) ) THEN
+*
+* Build a 4-by-4 system Z' * x = RHS
+*
+ Z( 1, 1 ) = A( IS, IS )
+ Z( 2, 1 ) = A( IS, ISP1 )
+ Z( 3, 1 ) = -B( JS, JS )
+ Z( 4, 1 ) = ZERO
+*
+ Z( 1, 2 ) = A( ISP1, IS )
+ Z( 2, 2 ) = A( ISP1, ISP1 )
+ Z( 3, 2 ) = ZERO
+ Z( 4, 2 ) = -B( JS, JS )
+*
+ Z( 1, 3 ) = D( IS, IS )
+ Z( 2, 3 ) = D( IS, ISP1 )
+ Z( 3, 3 ) = -E( JS, JS )
+ Z( 4, 3 ) = ZERO
+*
+ Z( 1, 4 ) = ZERO
+ Z( 2, 4 ) = D( ISP1, ISP1 )
+ Z( 3, 4 ) = ZERO
+ Z( 4, 4 ) = -E( JS, JS )
+*
+* Set up right hand side(s)
+*
+ RHS( 1 ) = C( IS, JS )
+ RHS( 2 ) = C( ISP1, JS )
+ RHS( 3 ) = F( IS, JS )
+ RHS( 4 ) = F( ISP1, JS )
+*
+* Solve Z' * x = RHS
+*
+ CALL SGETC2( ZDIM, Z, LDZ, IPIV, JPIV, IERR )
+ IF( IERR.GT.0 )
+ $ INFO = IERR
+*
+ CALL SGESC2( ZDIM, Z, LDZ, RHS, IPIV, JPIV, SCALOC )
+ IF( SCALOC.NE.ONE ) THEN
+ DO 150 K = 1, N
+ CALL SSCAL( M, SCALOC, C( 1, K ), 1 )
+ CALL SSCAL( M, SCALOC, F( 1, K ), 1 )
+ 150 CONTINUE
+ SCALE = SCALE*SCALOC
+ END IF
+*
+* Unpack solution vector(s)
+*
+ C( IS, JS ) = RHS( 1 )
+ C( ISP1, JS ) = RHS( 2 )
+ F( IS, JS ) = RHS( 3 )
+ F( ISP1, JS ) = RHS( 4 )
+*
+* Substitute R(I, J) and L(I, J) into remaining
+* equation.
+*
+ IF( J.GT.P+2 ) THEN
+ CALL SGER( MB, JS-1, ONE, RHS( 1 ), 1, B( 1, JS ),
+ $ 1, F( IS, 1 ), LDF )
+ CALL SGER( MB, JS-1, ONE, RHS( 3 ), 1, E( 1, JS ),
+ $ 1, F( IS, 1 ), LDF )
+ END IF
+ IF( I.LT.P ) THEN
+ CALL SGEMV( 'T', MB, M-IE, -ONE, A( IS, IE+1 ),
+ $ LDA, RHS( 1 ), 1, ONE, C( IE+1, JS ),
+ $ 1 )
+ CALL SGEMV( 'T', MB, M-IE, -ONE, D( IS, IE+1 ),
+ $ LDD, RHS( 3 ), 1, ONE, C( IE+1, JS ),
+ $ 1 )
+ END IF
+*
+ ELSE IF( ( MB.EQ.2 ) .AND. ( NB.EQ.2 ) ) THEN
+*
+* Build an 8-by-8 system Z' * x = RHS
+*
+ CALL SLASET( 'F', LDZ, LDZ, ZERO, ZERO, Z, LDZ )
+*
+ Z( 1, 1 ) = A( IS, IS )
+ Z( 2, 1 ) = A( IS, ISP1 )
+ Z( 5, 1 ) = -B( JS, JS )
+ Z( 7, 1 ) = -B( JSP1, JS )
+*
+ Z( 1, 2 ) = A( ISP1, IS )
+ Z( 2, 2 ) = A( ISP1, ISP1 )
+ Z( 6, 2 ) = -B( JS, JS )
+ Z( 8, 2 ) = -B( JSP1, JS )
+*
+ Z( 3, 3 ) = A( IS, IS )
+ Z( 4, 3 ) = A( IS, ISP1 )
+ Z( 5, 3 ) = -B( JS, JSP1 )
+ Z( 7, 3 ) = -B( JSP1, JSP1 )
+*
+ Z( 3, 4 ) = A( ISP1, IS )
+ Z( 4, 4 ) = A( ISP1, ISP1 )
+ Z( 6, 4 ) = -B( JS, JSP1 )
+ Z( 8, 4 ) = -B( JSP1, JSP1 )
+*
+ Z( 1, 5 ) = D( IS, IS )
+ Z( 2, 5 ) = D( IS, ISP1 )
+ Z( 5, 5 ) = -E( JS, JS )
+*
+ Z( 2, 6 ) = D( ISP1, ISP1 )
+ Z( 6, 6 ) = -E( JS, JS )
+*
+ Z( 3, 7 ) = D( IS, IS )
+ Z( 4, 7 ) = D( IS, ISP1 )
+ Z( 5, 7 ) = -E( JS, JSP1 )
+ Z( 7, 7 ) = -E( JSP1, JSP1 )
+*
+ Z( 4, 8 ) = D( ISP1, ISP1 )
+ Z( 6, 8 ) = -E( JS, JSP1 )
+ Z( 8, 8 ) = -E( JSP1, JSP1 )
+*
+* Set up right hand side(s)
+*
+ K = 1
+ II = MB*NB + 1
+ DO 160 JJ = 0, NB - 1
+ CALL SCOPY( MB, C( IS, JS+JJ ), 1, RHS( K ), 1 )
+ CALL SCOPY( MB, F( IS, JS+JJ ), 1, RHS( II ), 1 )
+ K = K + MB
+ II = II + MB
+ 160 CONTINUE
+*
+*
+* Solve Z' * x = RHS
+*
+ CALL SGETC2( ZDIM, Z, LDZ, IPIV, JPIV, IERR )
+ IF( IERR.GT.0 )
+ $ INFO = IERR
+*
+ CALL SGESC2( ZDIM, Z, LDZ, RHS, IPIV, JPIV, SCALOC )
+ IF( SCALOC.NE.ONE ) THEN
+ DO 170 K = 1, N
+ CALL SSCAL( M, SCALOC, C( 1, K ), 1 )
+ CALL SSCAL( M, SCALOC, F( 1, K ), 1 )
+ 170 CONTINUE
+ SCALE = SCALE*SCALOC
+ END IF
+*
+* Unpack solution vector(s)
+*
+ K = 1
+ II = MB*NB + 1
+ DO 180 JJ = 0, NB - 1
+ CALL SCOPY( MB, RHS( K ), 1, C( IS, JS+JJ ), 1 )
+ CALL SCOPY( MB, RHS( II ), 1, F( IS, JS+JJ ), 1 )
+ K = K + MB
+ II = II + MB
+ 180 CONTINUE
+*
+* Substitute R(I, J) and L(I, J) into remaining
+* equation.
+*
+ IF( J.GT.P+2 ) THEN
+ CALL SGEMM( 'N', 'T', MB, JS-1, NB, ONE,
+ $ C( IS, JS ), LDC, B( 1, JS ), LDB, ONE,
+ $ F( IS, 1 ), LDF )
+ CALL SGEMM( 'N', 'T', MB, JS-1, NB, ONE,
+ $ F( IS, JS ), LDF, E( 1, JS ), LDE, ONE,
+ $ F( IS, 1 ), LDF )
+ END IF
+ IF( I.LT.P ) THEN
+ CALL SGEMM( 'T', 'N', M-IE, NB, MB, -ONE,
+ $ A( IS, IE+1 ), LDA, C( IS, JS ), LDC,
+ $ ONE, C( IE+1, JS ), LDC )
+ CALL SGEMM( 'T', 'N', M-IE, NB, MB, -ONE,
+ $ D( IS, IE+1 ), LDD, F( IS, JS ), LDF,
+ $ ONE, C( IE+1, JS ), LDC )
+ END IF
+*
+ END IF
+*
+ 190 CONTINUE
+ 200 CONTINUE
+*
+ END IF
+ RETURN
+*
+* End of STGSY2
+*
+ END
+ SUBROUTINE STGSYL( TRANS, IJOB, M, N, A, LDA, B, LDB, C, LDC, D,
+ $ LDD, E, LDE, F, LDF, SCALE, DIF, WORK, LWORK,
+ $ IWORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER TRANS
+ INTEGER IJOB, INFO, LDA, LDB, LDC, LDD, LDE, LDF,
+ $ LWORK, M, N
+ REAL DIF, SCALE
+* ..
+* .. Array Arguments ..
+ INTEGER IWORK( * )
+ REAL A( LDA, * ), B( LDB, * ), C( LDC, * ),
+ $ D( LDD, * ), E( LDE, * ), F( LDF, * ),
+ $ WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* STGSYL solves the generalized Sylvester equation:
+*
+* A * R - L * B = scale * C (1)
+* D * R - L * E = scale * F
+*
+* where R and L are unknown m-by-n matrices, (A, D), (B, E) and
+* (C, F) are given matrix pairs of size m-by-m, n-by-n and m-by-n,
+* respectively, with real entries. (A, D) and (B, E) must be in
+* generalized (real) Schur canonical form, i.e. A, B are upper quasi
+* triangular and D, E are upper triangular.
+*
+* The solution (R, L) overwrites (C, F). 0 <= SCALE <= 1 is an output
+* scaling factor chosen to avoid overflow.
+*
+* In matrix notation (1) is equivalent to solve Zx = scale b, where
+* Z is defined as
+*
+* Z = [ kron(In, A) -kron(B', Im) ] (2)
+* [ kron(In, D) -kron(E', Im) ].
+*
+* Here Ik is the identity matrix of size k and X' is the transpose of
+* X. kron(X, Y) is the Kronecker product between the matrices X and Y.
+*
+* If TRANS = 'T', STGSYL solves the transposed system Z'*y = scale*b,
+* which is equivalent to solve for R and L in
+*
+* A' * R + D' * L = scale * C (3)
+* R * B' + L * E' = scale * (-F)
+*
+* This case (TRANS = 'T') is used to compute an one-norm-based estimate
+* of Dif[(A,D), (B,E)], the separation between the matrix pairs (A,D)
+* and (B,E), using SLACON.
+*
+* If IJOB >= 1, STGSYL computes a Frobenius norm-based estimate
+* of Dif[(A,D),(B,E)]. That is, the reciprocal of a lower bound on the
+* reciprocal of the smallest singular value of Z. See [1-2] for more
+* information.
+*
+* This is a level 3 BLAS algorithm.
+*
+* Arguments
+* =========
+*
+* TRANS (input) CHARACTER*1
+* = 'N', solve the generalized Sylvester equation (1).
+* = 'T', solve the 'transposed' system (3).
+*
+* IJOB (input) INTEGER
+* Specifies what kind of functionality to be performed.
+* =0: solve (1) only.
+* =1: The functionality of 0 and 3.
+* =2: The functionality of 0 and 4.
+* =3: Only an estimate of Dif[(A,D), (B,E)] is computed.
+* (look ahead strategy IJOB = 1 is used).
+* =4: Only an estimate of Dif[(A,D), (B,E)] is computed.
+* ( SGECON on sub-systems is used ).
+* Not referenced if TRANS = 'T'.
+*
+* M (input) INTEGER
+* The order of the matrices A and D, and the row dimension of
+* the matrices C, F, R and L.
+*
+* N (input) INTEGER
+* The order of the matrices B and E, and the column dimension
+* of the matrices C, F, R and L.
+*
+* A (input) REAL array, dimension (LDA, M)
+* The upper quasi triangular matrix A.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1, M).
+*
+* B (input) REAL array, dimension (LDB, N)
+* The upper quasi triangular matrix B.
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. LDB >= max(1, N).
+*
+* C (input/output) REAL array, dimension (LDC, N)
+* On entry, C contains the right-hand-side of the first matrix
+* equation in (1) or (3).
+* On exit, if IJOB = 0, 1 or 2, C has been overwritten by
+* the solution R. If IJOB = 3 or 4 and TRANS = 'N', C holds R,
+* the solution achieved during the computation of the
+* Dif-estimate.
+*
+* LDC (input) INTEGER
+* The leading dimension of the array C. LDC >= max(1, M).
+*
+* D (input) REAL array, dimension (LDD, M)
+* The upper triangular matrix D.
+*
+* LDD (input) INTEGER
+* The leading dimension of the array D. LDD >= max(1, M).
+*
+* E (input) REAL array, dimension (LDE, N)
+* The upper triangular matrix E.
+*
+* LDE (input) INTEGER
+* The leading dimension of the array E. LDE >= max(1, N).
+*
+* F (input/output) REAL array, dimension (LDF, N)
+* On entry, F contains the right-hand-side of the second matrix
+* equation in (1) or (3).
+* On exit, if IJOB = 0, 1 or 2, F has been overwritten by
+* the solution L. If IJOB = 3 or 4 and TRANS = 'N', F holds L,
+* the solution achieved during the computation of the
+* Dif-estimate.
+*
+* LDF (input) INTEGER
+* The leading dimension of the array F. LDF >= max(1, M).
+*
+* DIF (output) REAL
+* On exit DIF is the reciprocal of a lower bound of the
+* reciprocal of the Dif-function, i.e. DIF is an upper bound of
+* Dif[(A,D), (B,E)] = sigma_min(Z), where Z as in (2).
+* IF IJOB = 0 or TRANS = 'T', DIF is not touched.
+*
+* SCALE (output) REAL
+* On exit SCALE is the scaling factor in (1) or (3).
+* If 0 < SCALE < 1, C and F hold the solutions R and L, resp.,
+* to a slightly perturbed system but the input matrices A, B, D
+* and E have not been changed. If SCALE = 0, C and F hold the
+* solutions R and L, respectively, to the homogeneous system
+* with C = F = 0. Normally, SCALE = 1.
+*
+* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))
+* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+* LWORK (input) INTEGER
+* The dimension of the array WORK. LWORK > = 1.
+* If IJOB = 1 or 2 and TRANS = 'N', LWORK >= max(1,2*M*N).
+*
+* If LWORK = -1, then a workspace query is assumed; the routine
+* only calculates the optimal size of the WORK array, returns
+* this value as the first entry of the WORK array, and no error
+* message related to LWORK is issued by XERBLA.
+*
+* IWORK (workspace) INTEGER array, dimension (M+N+6)
+*
+* INFO (output) INTEGER
+* =0: successful exit
+* <0: If INFO = -i, the i-th argument had an illegal value.
+* >0: (A, D) and (B, E) have common or close eigenvalues.
+*
+* Further Details
+* ===============
+*
+* Based on contributions by
+* Bo Kagstrom and Peter Poromaa, Department of Computing Science,
+* Umea University, S-901 87 Umea, Sweden.
+*
+* [1] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software
+* for Solving the Generalized Sylvester Equation and Estimating the
+* Separation between Regular Matrix Pairs, Report UMINF - 93.23,
+* Department of Computing Science, Umea University, S-901 87 Umea,
+* Sweden, December 1993, Revised April 1994, Also as LAPACK Working
+* Note 75. To appear in ACM Trans. on Math. Software, Vol 22,
+* No 1, 1996.
+*
+* [2] B. Kagstrom, A Perturbation Analysis of the Generalized Sylvester
+* Equation (AR - LB, DR - LE ) = (C, F), SIAM J. Matrix Anal.
+* Appl., 15(4):1045-1060, 1994
+*
+* [3] B. Kagstrom and L. Westin, Generalized Schur Methods with
+* Condition Estimators for Solving the Generalized Sylvester
+* Equation, IEEE Transactions on Automatic Control, Vol. 34, No. 7,
+* July 1989, pp 745-751.
+*
+* =====================================================================
+* Replaced various illegal calls to SCOPY by calls to SLASET.
+* Sven Hammarling, 1/5/02.
+*
+* .. Parameters ..
+ REAL ZERO, ONE
+ PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL LQUERY, NOTRAN
+ INTEGER I, IE, IFUNC, IROUND, IS, ISOLVE, J, JE, JS, K,
+ $ LINFO, LWMIN, MB, NB, P, PPQQ, PQ, Q
+ REAL DSCALE, DSUM, SCALE2, SCALOC
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ILAENV
+ EXTERNAL LSAME, ILAENV
+* ..
+* .. External Subroutines ..
+ EXTERNAL SGEMM, SLACPY, SLASET, SSCAL, STGSY2, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, REAL, SQRT
+* ..
+* .. Executable Statements ..
+*
+* Decode and test input parameters
+*
+ INFO = 0
+ NOTRAN = LSAME( TRANS, 'N' )
+ LQUERY = ( LWORK.EQ.-1 )
+*
+ IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN
+ INFO = -1
+ ELSE IF( NOTRAN ) THEN
+ IF( ( IJOB.LT.0 ) .OR. ( IJOB.GT.4 ) ) THEN
+ INFO = -2
+ END IF
+ END IF
+ IF( INFO.EQ.0 ) THEN
+ IF( M.LE.0 ) THEN
+ INFO = -3
+ ELSE IF( N.LE.0 ) THEN
+ INFO = -4
+ ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+ INFO = -6
+ ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -8
+ ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
+ INFO = -10
+ ELSE IF( LDD.LT.MAX( 1, M ) ) THEN
+ INFO = -12
+ ELSE IF( LDE.LT.MAX( 1, N ) ) THEN
+ INFO = -14
+ ELSE IF( LDF.LT.MAX( 1, M ) ) THEN
+ INFO = -16
+ END IF
+ END IF
+*
+ IF( INFO.EQ.0 ) THEN
+ IF( NOTRAN ) THEN
+ IF( IJOB.EQ.1 .OR. IJOB.EQ.2 ) THEN
+ LWMIN = MAX( 1, 2*M*N )
+ ELSE
+ LWMIN = 1
+ END IF
+ ELSE
+ LWMIN = 1
+ END IF
+ WORK( 1 ) = LWMIN
+*
+ IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
+ INFO = -20
+ END IF
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'STGSYL', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( M.EQ.0 .OR. N.EQ.0 ) THEN
+ SCALE = 1
+ IF( NOTRAN ) THEN
+ IF( IJOB.NE.0 ) THEN
+ DIF = 0
+ END IF
+ END IF
+ RETURN
+ END IF
+*
+* Determine optimal block sizes MB and NB
+*
+ MB = ILAENV( 2, 'STGSYL', TRANS, M, N, -1, -1 )
+ NB = ILAENV( 5, 'STGSYL', TRANS, M, N, -1, -1 )
+*
+ ISOLVE = 1
+ IFUNC = 0
+ IF( NOTRAN ) THEN
+ IF( IJOB.GE.3 ) THEN
+ IFUNC = IJOB - 2
+ CALL SLASET( 'F', M, N, ZERO, ZERO, C, LDC )
+ CALL SLASET( 'F', M, N, ZERO, ZERO, F, LDF )
+ ELSE IF( IJOB.GE.1 .AND. NOTRAN ) THEN
+ ISOLVE = 2
+ END IF
+ END IF
+*
+ IF( ( MB.LE.1 .AND. NB.LE.1 ) .OR. ( MB.GE.M .AND. NB.GE.N ) )
+ $ THEN
+*
+ DO 30 IROUND = 1, ISOLVE
+*
+* Use unblocked Level 2 solver
+*
+ DSCALE = ZERO
+ DSUM = ONE
+ PQ = 0
+ CALL STGSY2( TRANS, IFUNC, M, N, A, LDA, B, LDB, C, LDC, D,
+ $ LDD, E, LDE, F, LDF, SCALE, DSUM, DSCALE,
+ $ IWORK, PQ, INFO )
+ IF( DSCALE.NE.ZERO ) THEN
+ IF( IJOB.EQ.1 .OR. IJOB.EQ.3 ) THEN
+ DIF = SQRT( REAL( 2*M*N ) ) / ( DSCALE*SQRT( DSUM ) )
+ ELSE
+ DIF = SQRT( REAL( PQ ) ) / ( DSCALE*SQRT( DSUM ) )
+ END IF
+ END IF
+*
+ IF( ISOLVE.EQ.2 .AND. IROUND.EQ.1 ) THEN
+ IF( NOTRAN ) THEN
+ IFUNC = IJOB
+ END IF
+ SCALE2 = SCALE
+ CALL SLACPY( 'F', M, N, C, LDC, WORK, M )
+ CALL SLACPY( 'F', M, N, F, LDF, WORK( M*N+1 ), M )
+ CALL SLASET( 'F', M, N, ZERO, ZERO, C, LDC )
+ CALL SLASET( 'F', M, N, ZERO, ZERO, F, LDF )
+ ELSE IF( ISOLVE.EQ.2 .AND. IROUND.EQ.2 ) THEN
+ CALL SLACPY( 'F', M, N, WORK, M, C, LDC )
+ CALL SLACPY( 'F', M, N, WORK( M*N+1 ), M, F, LDF )
+ SCALE = SCALE2
+ END IF
+ 30 CONTINUE
+*
+ RETURN
+ END IF
+*
+* Determine block structure of A
+*
+ P = 0
+ I = 1
+ 40 CONTINUE
+ IF( I.GT.M )
+ $ GO TO 50
+ P = P + 1
+ IWORK( P ) = I
+ I = I + MB
+ IF( I.GE.M )
+ $ GO TO 50
+ IF( A( I, I-1 ).NE.ZERO )
+ $ I = I + 1
+ GO TO 40
+ 50 CONTINUE
+*
+ IWORK( P+1 ) = M + 1
+ IF( IWORK( P ).EQ.IWORK( P+1 ) )
+ $ P = P - 1
+*
+* Determine block structure of B
+*
+ Q = P + 1
+ J = 1
+ 60 CONTINUE
+ IF( J.GT.N )
+ $ GO TO 70
+ Q = Q + 1
+ IWORK( Q ) = J
+ J = J + NB
+ IF( J.GE.N )
+ $ GO TO 70
+ IF( B( J, J-1 ).NE.ZERO )
+ $ J = J + 1
+ GO TO 60
+ 70 CONTINUE
+*
+ IWORK( Q+1 ) = N + 1
+ IF( IWORK( Q ).EQ.IWORK( Q+1 ) )
+ $ Q = Q - 1
+*
+ IF( NOTRAN ) THEN
+*
+ DO 150 IROUND = 1, ISOLVE
+*
+* Solve (I, J)-subsystem
+* A(I, I) * R(I, J) - L(I, J) * B(J, J) = C(I, J)
+* D(I, I) * R(I, J) - L(I, J) * E(J, J) = F(I, J)
+* for I = P, P - 1,..., 1; J = 1, 2,..., Q
+*
+ DSCALE = ZERO
+ DSUM = ONE
+ PQ = 0
+ SCALE = ONE
+ DO 130 J = P + 2, Q
+ JS = IWORK( J )
+ JE = IWORK( J+1 ) - 1
+ NB = JE - JS + 1
+ DO 120 I = P, 1, -1
+ IS = IWORK( I )
+ IE = IWORK( I+1 ) - 1
+ MB = IE - IS + 1
+ PPQQ = 0
+ CALL STGSY2( TRANS, IFUNC, MB, NB, A( IS, IS ), LDA,
+ $ B( JS, JS ), LDB, C( IS, JS ), LDC,
+ $ D( IS, IS ), LDD, E( JS, JS ), LDE,
+ $ F( IS, JS ), LDF, SCALOC, DSUM, DSCALE,
+ $ IWORK( Q+2 ), PPQQ, LINFO )
+ IF( LINFO.GT.0 )
+ $ INFO = LINFO
+*
+ PQ = PQ + PPQQ
+ IF( SCALOC.NE.ONE ) THEN
+ DO 80 K = 1, JS - 1
+ CALL SSCAL( M, SCALOC, C( 1, K ), 1 )
+ CALL SSCAL( M, SCALOC, F( 1, K ), 1 )
+ 80 CONTINUE
+ DO 90 K = JS, JE
+ CALL SSCAL( IS-1, SCALOC, C( 1, K ), 1 )
+ CALL SSCAL( IS-1, SCALOC, F( 1, K ), 1 )
+ 90 CONTINUE
+ DO 100 K = JS, JE
+ CALL SSCAL( M-IE, SCALOC, C( IE+1, K ), 1 )
+ CALL SSCAL( M-IE, SCALOC, F( IE+1, K ), 1 )
+ 100 CONTINUE
+ DO 110 K = JE + 1, N
+ CALL SSCAL( M, SCALOC, C( 1, K ), 1 )
+ CALL SSCAL( M, SCALOC, F( 1, K ), 1 )
+ 110 CONTINUE
+ SCALE = SCALE*SCALOC
+ END IF
+*
+* Substitute R(I, J) and L(I, J) into remaining
+* equation.
+*
+ IF( I.GT.1 ) THEN
+ CALL SGEMM( 'N', 'N', IS-1, NB, MB, -ONE,
+ $ A( 1, IS ), LDA, C( IS, JS ), LDC, ONE,
+ $ C( 1, JS ), LDC )
+ CALL SGEMM( 'N', 'N', IS-1, NB, MB, -ONE,
+ $ D( 1, IS ), LDD, C( IS, JS ), LDC, ONE,
+ $ F( 1, JS ), LDF )
+ END IF
+ IF( J.LT.Q ) THEN
+ CALL SGEMM( 'N', 'N', MB, N-JE, NB, ONE,
+ $ F( IS, JS ), LDF, B( JS, JE+1 ), LDB,
+ $ ONE, C( IS, JE+1 ), LDC )
+ CALL SGEMM( 'N', 'N', MB, N-JE, NB, ONE,
+ $ F( IS, JS ), LDF, E( JS, JE+1 ), LDE,
+ $ ONE, F( IS, JE+1 ), LDF )
+ END IF
+ 120 CONTINUE
+ 130 CONTINUE
+ IF( DSCALE.NE.ZERO ) THEN
+ IF( IJOB.EQ.1 .OR. IJOB.EQ.3 ) THEN
+ DIF = SQRT( REAL( 2*M*N ) ) / ( DSCALE*SQRT( DSUM ) )
+ ELSE
+ DIF = SQRT( REAL( PQ ) ) / ( DSCALE*SQRT( DSUM ) )
+ END IF
+ END IF
+ IF( ISOLVE.EQ.2 .AND. IROUND.EQ.1 ) THEN
+ IF( NOTRAN ) THEN
+ IFUNC = IJOB
+ END IF
+ SCALE2 = SCALE
+ CALL SLACPY( 'F', M, N, C, LDC, WORK, M )
+ CALL SLACPY( 'F', M, N, F, LDF, WORK( M*N+1 ), M )
+ CALL SLASET( 'F', M, N, ZERO, ZERO, C, LDC )
+ CALL SLASET( 'F', M, N, ZERO, ZERO, F, LDF )
+ ELSE IF( ISOLVE.EQ.2 .AND. IROUND.EQ.2 ) THEN
+ CALL SLACPY( 'F', M, N, WORK, M, C, LDC )
+ CALL SLACPY( 'F', M, N, WORK( M*N+1 ), M, F, LDF )
+ SCALE = SCALE2
+ END IF
+ 150 CONTINUE
+*
+ ELSE
+*
+* Solve transposed (I, J)-subsystem
+* A(I, I)' * R(I, J) + D(I, I)' * L(I, J) = C(I, J)
+* R(I, J) * B(J, J)' + L(I, J) * E(J, J)' = -F(I, J)
+* for I = 1,2,..., P; J = Q, Q-1,..., 1
+*
+ SCALE = ONE
+ DO 210 I = 1, P
+ IS = IWORK( I )
+ IE = IWORK( I+1 ) - 1
+ MB = IE - IS + 1
+ DO 200 J = Q, P + 2, -1
+ JS = IWORK( J )
+ JE = IWORK( J+1 ) - 1
+ NB = JE - JS + 1
+ CALL STGSY2( TRANS, IFUNC, MB, NB, A( IS, IS ), LDA,
+ $ B( JS, JS ), LDB, C( IS, JS ), LDC,
+ $ D( IS, IS ), LDD, E( JS, JS ), LDE,
+ $ F( IS, JS ), LDF, SCALOC, DSUM, DSCALE,
+ $ IWORK( Q+2 ), PPQQ, LINFO )
+ IF( LINFO.GT.0 )
+ $ INFO = LINFO
+ IF( SCALOC.NE.ONE ) THEN
+ DO 160 K = 1, JS - 1
+ CALL SSCAL( M, SCALOC, C( 1, K ), 1 )
+ CALL SSCAL( M, SCALOC, F( 1, K ), 1 )
+ 160 CONTINUE
+ DO 170 K = JS, JE
+ CALL SSCAL( IS-1, SCALOC, C( 1, K ), 1 )
+ CALL SSCAL( IS-1, SCALOC, F( 1, K ), 1 )
+ 170 CONTINUE
+ DO 180 K = JS, JE
+ CALL SSCAL( M-IE, SCALOC, C( IE+1, K ), 1 )
+ CALL SSCAL( M-IE, SCALOC, F( IE+1, K ), 1 )
+ 180 CONTINUE
+ DO 190 K = JE + 1, N
+ CALL SSCAL( M, SCALOC, C( 1, K ), 1 )
+ CALL SSCAL( M, SCALOC, F( 1, K ), 1 )
+ 190 CONTINUE
+ SCALE = SCALE*SCALOC
+ END IF
+*
+* Substitute R(I, J) and L(I, J) into remaining equation.
+*
+ IF( J.GT.P+2 ) THEN
+ CALL SGEMM( 'N', 'T', MB, JS-1, NB, ONE, C( IS, JS ),
+ $ LDC, B( 1, JS ), LDB, ONE, F( IS, 1 ),
+ $ LDF )
+ CALL SGEMM( 'N', 'T', MB, JS-1, NB, ONE, F( IS, JS ),
+ $ LDF, E( 1, JS ), LDE, ONE, F( IS, 1 ),
+ $ LDF )
+ END IF
+ IF( I.LT.P ) THEN
+ CALL SGEMM( 'T', 'N', M-IE, NB, MB, -ONE,
+ $ A( IS, IE+1 ), LDA, C( IS, JS ), LDC, ONE,
+ $ C( IE+1, JS ), LDC )
+ CALL SGEMM( 'T', 'N', M-IE, NB, MB, -ONE,
+ $ D( IS, IE+1 ), LDD, F( IS, JS ), LDF, ONE,
+ $ C( IE+1, JS ), LDC )
+ END IF
+ 200 CONTINUE
+ 210 CONTINUE
+*
+ END IF
+*
+ WORK( 1 ) = LWMIN
+*
+ RETURN
+*
+* End of STGSYL
+*
+ END
+ SUBROUTINE STPCON( NORM, UPLO, DIAG, N, AP, RCOND, WORK, IWORK,
+ $ INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* Modified to call SLACN2 in place of SLACON, 7 Feb 03, SJH.
+*
+* .. Scalar Arguments ..
+ CHARACTER DIAG, NORM, UPLO
+ INTEGER INFO, N
+ REAL RCOND
+* ..
+* .. Array Arguments ..
+ INTEGER IWORK( * )
+ REAL AP( * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* STPCON estimates the reciprocal of the condition number of a packed
+* triangular matrix A, in either the 1-norm or the infinity-norm.
+*
+* The norm of A is computed and an estimate is obtained for
+* norm(inv(A)), then the reciprocal of the condition number is
+* computed as
+* RCOND = 1 / ( norm(A) * norm(inv(A)) ).
+*
+* Arguments
+* =========
+*
+* NORM (input) CHARACTER*1
+* Specifies whether the 1-norm condition number or the
+* infinity-norm condition number is required:
+* = '1' or 'O': 1-norm;
+* = 'I': Infinity-norm.
+*
+* UPLO (input) CHARACTER*1
+* = 'U': A is upper triangular;
+* = 'L': A is lower triangular.
+*
+* DIAG (input) CHARACTER*1
+* = 'N': A is non-unit triangular;
+* = 'U': A is unit triangular.
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* AP (input) REAL array, dimension (N*(N+1)/2)
+* The upper or lower triangular matrix A, packed columnwise in
+* a linear array. The j-th column of A is stored in the array
+* AP as follows:
+* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
+* if UPLO = 'L', AP(i + (j-1)*(2n-j)/2) = A(i,j) for j<=i<=n.
+* If DIAG = 'U', the diagonal elements of A are not referenced
+* and are assumed to be 1.
+*
+* RCOND (output) REAL
+* The reciprocal of the condition number of the matrix A,
+* computed as RCOND = 1/(norm(A) * norm(inv(A))).
+*
+* WORK (workspace) REAL array, dimension (3*N)
+*
+* IWORK (workspace) INTEGER array, dimension (N)
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ONE, ZERO
+ PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL NOUNIT, ONENRM, UPPER
+ CHARACTER NORMIN
+ INTEGER IX, KASE, KASE1
+ REAL AINVNM, ANORM, SCALE, SMLNUM, XNORM
+* ..
+* .. Local Arrays ..
+ INTEGER ISAVE( 3 )
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ISAMAX
+ REAL SLAMCH, SLANTP
+ EXTERNAL LSAME, ISAMAX, SLAMCH, SLANTP
+* ..
+* .. External Subroutines ..
+ EXTERNAL SLACN2, SLATPS, SRSCL, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, REAL
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ ONENRM = NORM.EQ.'1' .OR. LSAME( NORM, 'O' )
+ NOUNIT = LSAME( DIAG, 'N' )
+*
+ IF( .NOT.ONENRM .AND. .NOT.LSAME( NORM, 'I' ) ) THEN
+ INFO = -1
+ ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -2
+ ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
+ INFO = -3
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -4
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'STPCON', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 ) THEN
+ RCOND = ONE
+ RETURN
+ END IF
+*
+ RCOND = ZERO
+ SMLNUM = SLAMCH( 'Safe minimum' )*REAL( MAX( 1, N ) )
+*
+* Compute the norm of the triangular matrix A.
+*
+ ANORM = SLANTP( NORM, UPLO, DIAG, N, AP, WORK )
+*
+* Continue only if ANORM > 0.
+*
+ IF( ANORM.GT.ZERO ) THEN
+*
+* Estimate the norm of the inverse of A.
+*
+ AINVNM = ZERO
+ NORMIN = 'N'
+ IF( ONENRM ) THEN
+ KASE1 = 1
+ ELSE
+ KASE1 = 2
+ END IF
+ KASE = 0
+ 10 CONTINUE
+ CALL SLACN2( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE, ISAVE )
+ IF( KASE.NE.0 ) THEN
+ IF( KASE.EQ.KASE1 ) THEN
+*
+* Multiply by inv(A).
+*
+ CALL SLATPS( UPLO, 'No transpose', DIAG, NORMIN, N, AP,
+ $ WORK, SCALE, WORK( 2*N+1 ), INFO )
+ ELSE
+*
+* Multiply by inv(A').
+*
+ CALL SLATPS( UPLO, 'Transpose', DIAG, NORMIN, N, AP,
+ $ WORK, SCALE, WORK( 2*N+1 ), INFO )
+ END IF
+ NORMIN = 'Y'
+*
+* Multiply by 1/SCALE if doing so will not cause overflow.
+*
+ IF( SCALE.NE.ONE ) THEN
+ IX = ISAMAX( N, WORK, 1 )
+ XNORM = ABS( WORK( IX ) )
+ IF( SCALE.LT.XNORM*SMLNUM .OR. SCALE.EQ.ZERO )
+ $ GO TO 20
+ CALL SRSCL( N, SCALE, WORK, 1 )
+ END IF
+ GO TO 10
+ END IF
+*
+* Compute the estimate of the reciprocal condition number.
+*
+ IF( AINVNM.NE.ZERO )
+ $ RCOND = ( ONE / ANORM ) / AINVNM
+ END IF
+*
+ 20 CONTINUE
+ RETURN
+*
+* End of STPCON
+*
+ END
+ SUBROUTINE STPRFS( UPLO, TRANS, DIAG, N, NRHS, AP, B, LDB, X, LDX,
+ $ FERR, BERR, WORK, IWORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* Modified to call SLACN2 in place of SLACON, 7 Feb 03, SJH.
+*
+* .. Scalar Arguments ..
+ CHARACTER DIAG, TRANS, UPLO
+ INTEGER INFO, LDB, LDX, N, NRHS
+* ..
+* .. Array Arguments ..
+ INTEGER IWORK( * )
+ REAL AP( * ), B( LDB, * ), BERR( * ), FERR( * ),
+ $ WORK( * ), X( LDX, * )
+* ..
+*
+* Purpose
+* =======
+*
+* STPRFS provides error bounds and backward error estimates for the
+* solution to a system of linear equations with a triangular packed
+* coefficient matrix.
+*
+* The solution matrix X must be computed by STPTRS or some other
+* means before entering this routine. STPRFS does not do iterative
+* refinement because doing so cannot improve the backward error.
+*
+* Arguments
+* =========
+*
+* UPLO (input) CHARACTER*1
+* = 'U': A is upper triangular;
+* = 'L': A is lower triangular.
+*
+* TRANS (input) CHARACTER*1
+* Specifies the form of the system of equations:
+* = 'N': A * X = B (No transpose)
+* = 'T': A**T * X = B (Transpose)
+* = 'C': A**H * X = B (Conjugate transpose = Transpose)
+*
+* DIAG (input) CHARACTER*1
+* = 'N': A is non-unit triangular;
+* = 'U': A is unit triangular.
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* NRHS (input) INTEGER
+* The number of right hand sides, i.e., the number of columns
+* of the matrices B and X. NRHS >= 0.
+*
+* AP (input) REAL array, dimension (N*(N+1)/2)
+* The upper or lower triangular matrix A, packed columnwise in
+* a linear array. The j-th column of A is stored in the array
+* AP as follows:
+* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
+* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
+* If DIAG = 'U', the diagonal elements of A are not referenced
+* and are assumed to be 1.
+*
+* B (input) REAL array, dimension (LDB,NRHS)
+* The right hand side matrix B.
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. LDB >= max(1,N).
+*
+* X (input) REAL array, dimension (LDX,NRHS)
+* The solution matrix X.
+*
+* LDX (input) INTEGER
+* The leading dimension of the array X. LDX >= max(1,N).
+*
+* FERR (output) REAL array, dimension (NRHS)
+* The estimated forward error bound for each solution vector
+* X(j) (the j-th column of the solution matrix X).
+* If XTRUE is the true solution corresponding to X(j), FERR(j)
+* is an estimated upper bound for the magnitude of the largest
+* element in (X(j) - XTRUE) divided by the magnitude of the
+* largest element in X(j). The estimate is as reliable as
+* the estimate for RCOND, and is almost always a slight
+* overestimate of the true error.
+*
+* BERR (output) REAL array, dimension (NRHS)
+* The componentwise relative backward error of each solution
+* vector X(j) (i.e., the smallest relative change in
+* any element of A or B that makes X(j) an exact solution).
+*
+* WORK (workspace) REAL array, dimension (3*N)
+*
+* IWORK (workspace) INTEGER array, dimension (N)
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO
+ PARAMETER ( ZERO = 0.0E+0 )
+ REAL ONE
+ PARAMETER ( ONE = 1.0E+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL NOTRAN, NOUNIT, UPPER
+ CHARACTER TRANST
+ INTEGER I, J, K, KASE, KC, NZ
+ REAL EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK
+* ..
+* .. Local Arrays ..
+ INTEGER ISAVE( 3 )
+* ..
+* .. External Subroutines ..
+ EXTERNAL SAXPY, SCOPY, SLACN2, STPMV, STPSV, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ REAL SLAMCH
+ EXTERNAL LSAME, SLAMCH
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ NOTRAN = LSAME( TRANS, 'N' )
+ NOUNIT = LSAME( DIAG, 'N' )
+*
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT.
+ $ LSAME( TRANS, 'C' ) ) THEN
+ INFO = -2
+ ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
+ INFO = -3
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( NRHS.LT.0 ) THEN
+ INFO = -5
+ ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -8
+ ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
+ INFO = -10
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'STPRFS', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN
+ DO 10 J = 1, NRHS
+ FERR( J ) = ZERO
+ BERR( J ) = ZERO
+ 10 CONTINUE
+ RETURN
+ END IF
+*
+ IF( NOTRAN ) THEN
+ TRANST = 'T'
+ ELSE
+ TRANST = 'N'
+ END IF
+*
+* NZ = maximum number of nonzero elements in each row of A, plus 1
+*
+ NZ = N + 1
+ EPS = SLAMCH( 'Epsilon' )
+ SAFMIN = SLAMCH( 'Safe minimum' )
+ SAFE1 = NZ*SAFMIN
+ SAFE2 = SAFE1 / EPS
+*
+* Do for each right hand side
+*
+ DO 250 J = 1, NRHS
+*
+* Compute residual R = B - op(A) * X,
+* where op(A) = A or A', depending on TRANS.
+*
+ CALL SCOPY( N, X( 1, J ), 1, WORK( N+1 ), 1 )
+ CALL STPMV( UPLO, TRANS, DIAG, N, AP, WORK( N+1 ), 1 )
+ CALL SAXPY( N, -ONE, B( 1, J ), 1, WORK( N+1 ), 1 )
+*
+* Compute componentwise relative backward error from formula
+*
+* max(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) )
+*
+* where abs(Z) is the componentwise absolute value of the matrix
+* or vector Z. If the i-th component of the denominator is less
+* than SAFE2, then SAFE1 is added to the i-th components of the
+* numerator and denominator before dividing.
+*
+ DO 20 I = 1, N
+ WORK( I ) = ABS( B( I, J ) )
+ 20 CONTINUE
+*
+ IF( NOTRAN ) THEN
+*
+* Compute abs(A)*abs(X) + abs(B).
+*
+ IF( UPPER ) THEN
+ KC = 1
+ IF( NOUNIT ) THEN
+ DO 40 K = 1, N
+ XK = ABS( X( K, J ) )
+ DO 30 I = 1, K
+ WORK( I ) = WORK( I ) + ABS( AP( KC+I-1 ) )*XK
+ 30 CONTINUE
+ KC = KC + K
+ 40 CONTINUE
+ ELSE
+ DO 60 K = 1, N
+ XK = ABS( X( K, J ) )
+ DO 50 I = 1, K - 1
+ WORK( I ) = WORK( I ) + ABS( AP( KC+I-1 ) )*XK
+ 50 CONTINUE
+ WORK( K ) = WORK( K ) + XK
+ KC = KC + K
+ 60 CONTINUE
+ END IF
+ ELSE
+ KC = 1
+ IF( NOUNIT ) THEN
+ DO 80 K = 1, N
+ XK = ABS( X( K, J ) )
+ DO 70 I = K, N
+ WORK( I ) = WORK( I ) + ABS( AP( KC+I-K ) )*XK
+ 70 CONTINUE
+ KC = KC + N - K + 1
+ 80 CONTINUE
+ ELSE
+ DO 100 K = 1, N
+ XK = ABS( X( K, J ) )
+ DO 90 I = K + 1, N
+ WORK( I ) = WORK( I ) + ABS( AP( KC+I-K ) )*XK
+ 90 CONTINUE
+ WORK( K ) = WORK( K ) + XK
+ KC = KC + N - K + 1
+ 100 CONTINUE
+ END IF
+ END IF
+ ELSE
+*
+* Compute abs(A')*abs(X) + abs(B).
+*
+ IF( UPPER ) THEN
+ KC = 1
+ IF( NOUNIT ) THEN
+ DO 120 K = 1, N
+ S = ZERO
+ DO 110 I = 1, K
+ S = S + ABS( AP( KC+I-1 ) )*ABS( X( I, J ) )
+ 110 CONTINUE
+ WORK( K ) = WORK( K ) + S
+ KC = KC + K
+ 120 CONTINUE
+ ELSE
+ DO 140 K = 1, N
+ S = ABS( X( K, J ) )
+ DO 130 I = 1, K - 1
+ S = S + ABS( AP( KC+I-1 ) )*ABS( X( I, J ) )
+ 130 CONTINUE
+ WORK( K ) = WORK( K ) + S
+ KC = KC + K
+ 140 CONTINUE
+ END IF
+ ELSE
+ KC = 1
+ IF( NOUNIT ) THEN
+ DO 160 K = 1, N
+ S = ZERO
+ DO 150 I = K, N
+ S = S + ABS( AP( KC+I-K ) )*ABS( X( I, J ) )
+ 150 CONTINUE
+ WORK( K ) = WORK( K ) + S
+ KC = KC + N - K + 1
+ 160 CONTINUE
+ ELSE
+ DO 180 K = 1, N
+ S = ABS( X( K, J ) )
+ DO 170 I = K + 1, N
+ S = S + ABS( AP( KC+I-K ) )*ABS( X( I, J ) )
+ 170 CONTINUE
+ WORK( K ) = WORK( K ) + S
+ KC = KC + N - K + 1
+ 180 CONTINUE
+ END IF
+ END IF
+ END IF
+ S = ZERO
+ DO 190 I = 1, N
+ IF( WORK( I ).GT.SAFE2 ) THEN
+ S = MAX( S, ABS( WORK( N+I ) ) / WORK( I ) )
+ ELSE
+ S = MAX( S, ( ABS( WORK( N+I ) )+SAFE1 ) /
+ $ ( WORK( I )+SAFE1 ) )
+ END IF
+ 190 CONTINUE
+ BERR( J ) = S
+*
+* Bound error from formula
+*
+* norm(X - XTRUE) / norm(X) .le. FERR =
+* norm( abs(inv(op(A)))*
+* ( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X)
+*
+* where
+* norm(Z) is the magnitude of the largest component of Z
+* inv(op(A)) is the inverse of op(A)
+* abs(Z) is the componentwise absolute value of the matrix or
+* vector Z
+* NZ is the maximum number of nonzeros in any row of A, plus 1
+* EPS is machine epsilon
+*
+* The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B))
+* is incremented by SAFE1 if the i-th component of
+* abs(op(A))*abs(X) + abs(B) is less than SAFE2.
+*
+* Use SLACN2 to estimate the infinity-norm of the matrix
+* inv(op(A)) * diag(W),
+* where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) )))
+*
+ DO 200 I = 1, N
+ IF( WORK( I ).GT.SAFE2 ) THEN
+ WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I )
+ ELSE
+ WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I ) + SAFE1
+ END IF
+ 200 CONTINUE
+*
+ KASE = 0
+ 210 CONTINUE
+ CALL SLACN2( N, WORK( 2*N+1 ), WORK( N+1 ), IWORK, FERR( J ),
+ $ KASE, ISAVE )
+ IF( KASE.NE.0 ) THEN
+ IF( KASE.EQ.1 ) THEN
+*
+* Multiply by diag(W)*inv(op(A)').
+*
+ CALL STPSV( UPLO, TRANST, DIAG, N, AP, WORK( N+1 ), 1 )
+ DO 220 I = 1, N
+ WORK( N+I ) = WORK( I )*WORK( N+I )
+ 220 CONTINUE
+ ELSE
+*
+* Multiply by inv(op(A))*diag(W).
+*
+ DO 230 I = 1, N
+ WORK( N+I ) = WORK( I )*WORK( N+I )
+ 230 CONTINUE
+ CALL STPSV( UPLO, TRANS, DIAG, N, AP, WORK( N+1 ), 1 )
+ END IF
+ GO TO 210
+ END IF
+*
+* Normalize error.
+*
+ LSTRES = ZERO
+ DO 240 I = 1, N
+ LSTRES = MAX( LSTRES, ABS( X( I, J ) ) )
+ 240 CONTINUE
+ IF( LSTRES.NE.ZERO )
+ $ FERR( J ) = FERR( J ) / LSTRES
+*
+ 250 CONTINUE
+*
+ RETURN
+*
+* End of STPRFS
+*
+ END
+ SUBROUTINE STPTRI( UPLO, DIAG, N, AP, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER DIAG, UPLO
+ INTEGER INFO, N
+* ..
+* .. Array Arguments ..
+ REAL AP( * )
+* ..
+*
+* Purpose
+* =======
+*
+* STPTRI computes the inverse of a real upper or lower triangular
+* matrix A stored in packed format.
+*
+* Arguments
+* =========
+*
+* UPLO (input) CHARACTER*1
+* = 'U': A is upper triangular;
+* = 'L': A is lower triangular.
+*
+* DIAG (input) CHARACTER*1
+* = 'N': A is non-unit triangular;
+* = 'U': A is unit triangular.
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* AP (input/output) REAL array, dimension (N*(N+1)/2)
+* On entry, the upper or lower triangular matrix A, stored
+* columnwise in a linear array. The j-th column of A is stored
+* in the array AP as follows:
+* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
+* if UPLO = 'L', AP(i + (j-1)*((2*n-j)/2) = A(i,j) for j<=i<=n.
+* See below for further details.
+* On exit, the (triangular) inverse of the original matrix, in
+* the same packed storage format.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* > 0: if INFO = i, A(i,i) is exactly zero. The triangular
+* matrix is singular and its inverse can not be computed.
+*
+* Further Details
+* ===============
+*
+* A triangular matrix A can be transferred to packed storage using one
+* of the following program segments:
+*
+* UPLO = 'U': UPLO = 'L':
+*
+* JC = 1 JC = 1
+* DO 2 J = 1, N DO 2 J = 1, N
+* DO 1 I = 1, J DO 1 I = J, N
+* AP(JC+I-1) = A(I,J) AP(JC+I-J) = A(I,J)
+* 1 CONTINUE 1 CONTINUE
+* JC = JC + J JC = JC + N - J + 1
+* 2 CONTINUE 2 CONTINUE
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ONE, ZERO
+ PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL NOUNIT, UPPER
+ INTEGER J, JC, JCLAST, JJ
+ REAL AJJ
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL SSCAL, STPMV, XERBLA
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ NOUNIT = LSAME( DIAG, 'N' )
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
+ INFO = -2
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -3
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'STPTRI', -INFO )
+ RETURN
+ END IF
+*
+* Check for singularity if non-unit.
+*
+ IF( NOUNIT ) THEN
+ IF( UPPER ) THEN
+ JJ = 0
+ DO 10 INFO = 1, N
+ JJ = JJ + INFO
+ IF( AP( JJ ).EQ.ZERO )
+ $ RETURN
+ 10 CONTINUE
+ ELSE
+ JJ = 1
+ DO 20 INFO = 1, N
+ IF( AP( JJ ).EQ.ZERO )
+ $ RETURN
+ JJ = JJ + N - INFO + 1
+ 20 CONTINUE
+ END IF
+ INFO = 0
+ END IF
+*
+ IF( UPPER ) THEN
+*
+* Compute inverse of upper triangular matrix.
+*
+ JC = 1
+ DO 30 J = 1, N
+ IF( NOUNIT ) THEN
+ AP( JC+J-1 ) = ONE / AP( JC+J-1 )
+ AJJ = -AP( JC+J-1 )
+ ELSE
+ AJJ = -ONE
+ END IF
+*
+* Compute elements 1:j-1 of j-th column.
+*
+ CALL STPMV( 'Upper', 'No transpose', DIAG, J-1, AP,
+ $ AP( JC ), 1 )
+ CALL SSCAL( J-1, AJJ, AP( JC ), 1 )
+ JC = JC + J
+ 30 CONTINUE
+*
+ ELSE
+*
+* Compute inverse of lower triangular matrix.
+*
+ JC = N*( N+1 ) / 2
+ DO 40 J = N, 1, -1
+ IF( NOUNIT ) THEN
+ AP( JC ) = ONE / AP( JC )
+ AJJ = -AP( JC )
+ ELSE
+ AJJ = -ONE
+ END IF
+ IF( J.LT.N ) THEN
+*
+* Compute elements j+1:n of j-th column.
+*
+ CALL STPMV( 'Lower', 'No transpose', DIAG, N-J,
+ $ AP( JCLAST ), AP( JC+1 ), 1 )
+ CALL SSCAL( N-J, AJJ, AP( JC+1 ), 1 )
+ END IF
+ JCLAST = JC
+ JC = JC - N + J - 2
+ 40 CONTINUE
+ END IF
+*
+ RETURN
+*
+* End of STPTRI
+*
+ END
+ SUBROUTINE STPTRS( UPLO, TRANS, DIAG, N, NRHS, AP, B, LDB, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER DIAG, TRANS, UPLO
+ INTEGER INFO, LDB, N, NRHS
+* ..
+* .. Array Arguments ..
+ REAL AP( * ), B( LDB, * )
+* ..
+*
+* Purpose
+* =======
+*
+* STPTRS solves a triangular system of the form
+*
+* A * X = B or A**T * X = B,
+*
+* where A is a triangular matrix of order N stored in packed format,
+* and B is an N-by-NRHS matrix. A check is made to verify that A is
+* nonsingular.
+*
+* Arguments
+* =========
+*
+* UPLO (input) CHARACTER*1
+* = 'U': A is upper triangular;
+* = 'L': A is lower triangular.
+*
+* TRANS (input) CHARACTER*1
+* Specifies the form of the system of equations:
+* = 'N': A * X = B (No transpose)
+* = 'T': A**T * X = B (Transpose)
+* = 'C': A**H * X = B (Conjugate transpose = Transpose)
+*
+* DIAG (input) CHARACTER*1
+* = 'N': A is non-unit triangular;
+* = 'U': A is unit triangular.
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* NRHS (input) INTEGER
+* The number of right hand sides, i.e., the number of columns
+* of the matrix B. NRHS >= 0.
+*
+* AP (input) REAL array, dimension (N*(N+1)/2)
+* The upper or lower triangular matrix A, packed columnwise in
+* a linear array. The j-th column of A is stored in the array
+* AP as follows:
+* if UPLO = 'U', AP(i + (j-1)*j/2) = A(i,j) for 1<=i<=j;
+* if UPLO = 'L', AP(i + (j-1)*(2*n-j)/2) = A(i,j) for j<=i<=n.
+*
+* B (input/output) REAL array, dimension (LDB,NRHS)
+* On entry, the right hand side matrix B.
+* On exit, if INFO = 0, the solution matrix X.
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. LDB >= max(1,N).
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* > 0: if INFO = i, the i-th diagonal element of A is zero,
+* indicating that the matrix is singular and the
+* solutions X have not been computed.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO
+ PARAMETER ( ZERO = 0.0E+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL NOUNIT, UPPER
+ INTEGER J, JC
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL STPSV, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ NOUNIT = LSAME( DIAG, 'N' )
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( .NOT.LSAME( TRANS, 'N' ) .AND. .NOT.
+ $ LSAME( TRANS, 'T' ) .AND. .NOT.LSAME( TRANS, 'C' ) ) THEN
+ INFO = -2
+ ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
+ INFO = -3
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( NRHS.LT.0 ) THEN
+ INFO = -5
+ ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -8
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'STPTRS', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+* Check for singularity.
+*
+ IF( NOUNIT ) THEN
+ IF( UPPER ) THEN
+ JC = 1
+ DO 10 INFO = 1, N
+ IF( AP( JC+INFO-1 ).EQ.ZERO )
+ $ RETURN
+ JC = JC + INFO
+ 10 CONTINUE
+ ELSE
+ JC = 1
+ DO 20 INFO = 1, N
+ IF( AP( JC ).EQ.ZERO )
+ $ RETURN
+ JC = JC + N - INFO + 1
+ 20 CONTINUE
+ END IF
+ END IF
+ INFO = 0
+*
+* Solve A * x = b or A' * x = b.
+*
+ DO 30 J = 1, NRHS
+ CALL STPSV( UPLO, TRANS, DIAG, N, AP, B( 1, J ), 1 )
+ 30 CONTINUE
+*
+ RETURN
+*
+* End of STPTRS
+*
+ END
+ SUBROUTINE STRCON( NORM, UPLO, DIAG, N, A, LDA, RCOND, WORK,
+ $ IWORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* Modified to call SLACN2 in place of SLACON, 7 Feb 03, SJH.
+*
+* .. Scalar Arguments ..
+ CHARACTER DIAG, NORM, UPLO
+ INTEGER INFO, LDA, N
+ REAL RCOND
+* ..
+* .. Array Arguments ..
+ INTEGER IWORK( * )
+ REAL A( LDA, * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* STRCON estimates the reciprocal of the condition number of a
+* triangular matrix A, in either the 1-norm or the infinity-norm.
+*
+* The norm of A is computed and an estimate is obtained for
+* norm(inv(A)), then the reciprocal of the condition number is
+* computed as
+* RCOND = 1 / ( norm(A) * norm(inv(A)) ).
+*
+* Arguments
+* =========
+*
+* NORM (input) CHARACTER*1
+* Specifies whether the 1-norm condition number or the
+* infinity-norm condition number is required:
+* = '1' or 'O': 1-norm;
+* = 'I': Infinity-norm.
+*
+* UPLO (input) CHARACTER*1
+* = 'U': A is upper triangular;
+* = 'L': A is lower triangular.
+*
+* DIAG (input) CHARACTER*1
+* = 'N': A is non-unit triangular;
+* = 'U': A is unit triangular.
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* A (input) REAL array, dimension (LDA,N)
+* The triangular matrix A. If UPLO = 'U', the leading N-by-N
+* upper triangular part of the array A contains the upper
+* triangular matrix, and the strictly lower triangular part of
+* A is not referenced. If UPLO = 'L', the leading N-by-N lower
+* triangular part of the array A contains the lower triangular
+* matrix, and the strictly upper triangular part of A is not
+* referenced. If DIAG = 'U', the diagonal elements of A are
+* also not referenced and are assumed to be 1.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,N).
+*
+* RCOND (output) REAL
+* The reciprocal of the condition number of the matrix A,
+* computed as RCOND = 1/(norm(A) * norm(inv(A))).
+*
+* WORK (workspace) REAL array, dimension (3*N)
+*
+* IWORK (workspace) INTEGER array, dimension (N)
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ONE, ZERO
+ PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL NOUNIT, ONENRM, UPPER
+ CHARACTER NORMIN
+ INTEGER IX, KASE, KASE1
+ REAL AINVNM, ANORM, SCALE, SMLNUM, XNORM
+* ..
+* .. Local Arrays ..
+ INTEGER ISAVE( 3 )
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ISAMAX
+ REAL SLAMCH, SLANTR
+ EXTERNAL LSAME, ISAMAX, SLAMCH, SLANTR
+* ..
+* .. External Subroutines ..
+ EXTERNAL SLACN2, SLATRS, SRSCL, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, REAL
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ ONENRM = NORM.EQ.'1' .OR. LSAME( NORM, 'O' )
+ NOUNIT = LSAME( DIAG, 'N' )
+*
+ IF( .NOT.ONENRM .AND. .NOT.LSAME( NORM, 'I' ) ) THEN
+ INFO = -1
+ ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -2
+ ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
+ INFO = -3
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -6
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'STRCON', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 ) THEN
+ RCOND = ONE
+ RETURN
+ END IF
+*
+ RCOND = ZERO
+ SMLNUM = SLAMCH( 'Safe minimum' )*REAL( MAX( 1, N ) )
+*
+* Compute the norm of the triangular matrix A.
+*
+ ANORM = SLANTR( NORM, UPLO, DIAG, N, N, A, LDA, WORK )
+*
+* Continue only if ANORM > 0.
+*
+ IF( ANORM.GT.ZERO ) THEN
+*
+* Estimate the norm of the inverse of A.
+*
+ AINVNM = ZERO
+ NORMIN = 'N'
+ IF( ONENRM ) THEN
+ KASE1 = 1
+ ELSE
+ KASE1 = 2
+ END IF
+ KASE = 0
+ 10 CONTINUE
+ CALL SLACN2( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE, ISAVE )
+ IF( KASE.NE.0 ) THEN
+ IF( KASE.EQ.KASE1 ) THEN
+*
+* Multiply by inv(A).
+*
+ CALL SLATRS( UPLO, 'No transpose', DIAG, NORMIN, N, A,
+ $ LDA, WORK, SCALE, WORK( 2*N+1 ), INFO )
+ ELSE
+*
+* Multiply by inv(A').
+*
+ CALL SLATRS( UPLO, 'Transpose', DIAG, NORMIN, N, A, LDA,
+ $ WORK, SCALE, WORK( 2*N+1 ), INFO )
+ END IF
+ NORMIN = 'Y'
+*
+* Multiply by 1/SCALE if doing so will not cause overflow.
+*
+ IF( SCALE.NE.ONE ) THEN
+ IX = ISAMAX( N, WORK, 1 )
+ XNORM = ABS( WORK( IX ) )
+ IF( SCALE.LT.XNORM*SMLNUM .OR. SCALE.EQ.ZERO )
+ $ GO TO 20
+ CALL SRSCL( N, SCALE, WORK, 1 )
+ END IF
+ GO TO 10
+ END IF
+*
+* Compute the estimate of the reciprocal condition number.
+*
+ IF( AINVNM.NE.ZERO )
+ $ RCOND = ( ONE / ANORM ) / AINVNM
+ END IF
+*
+ 20 CONTINUE
+ RETURN
+*
+* End of STRCON
+*
+ END
+ SUBROUTINE STREVC( SIDE, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR,
+ $ LDVR, MM, M, WORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER HOWMNY, SIDE
+ INTEGER INFO, LDT, LDVL, LDVR, M, MM, N
+* ..
+* .. Array Arguments ..
+ LOGICAL SELECT( * )
+ REAL T( LDT, * ), VL( LDVL, * ), VR( LDVR, * ),
+ $ WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* STREVC computes some or all of the right and/or left eigenvectors of
+* a real upper quasi-triangular matrix T.
+* Matrices of this type are produced by the Schur factorization of
+* a real general matrix: A = Q*T*Q**T, as computed by SHSEQR.
+*
+* The right eigenvector x and the left eigenvector y of T corresponding
+* to an eigenvalue w are defined by:
+*
+* T*x = w*x, (y**H)*T = w*(y**H)
+*
+* where y**H denotes the conjugate transpose of y.
+* The eigenvalues are not input to this routine, but are read directly
+* from the diagonal blocks of T.
+*
+* This routine returns the matrices X and/or Y of right and left
+* eigenvectors of T, or the products Q*X and/or Q*Y, where Q is an
+* input matrix. If Q is the orthogonal factor that reduces a matrix
+* A to Schur form T, then Q*X and Q*Y are the matrices of right and
+* left eigenvectors of A.
+*
+* Arguments
+* =========
+*
+* SIDE (input) CHARACTER*1
+* = 'R': compute right eigenvectors only;
+* = 'L': compute left eigenvectors only;
+* = 'B': compute both right and left eigenvectors.
+*
+* HOWMNY (input) CHARACTER*1
+* = 'A': compute all right and/or left eigenvectors;
+* = 'B': compute all right and/or left eigenvectors,
+* backtransformed by the matrices in VR and/or VL;
+* = 'S': compute selected right and/or left eigenvectors,
+* as indicated by the logical array SELECT.
+*
+* SELECT (input/output) LOGICAL array, dimension (N)
+* If HOWMNY = 'S', SELECT specifies the eigenvectors to be
+* computed.
+* If w(j) is a real eigenvalue, the corresponding real
+* eigenvector is computed if SELECT(j) is .TRUE..
+* If w(j) and w(j+1) are the real and imaginary parts of a
+* complex eigenvalue, the corresponding complex eigenvector is
+* computed if either SELECT(j) or SELECT(j+1) is .TRUE., and
+* on exit SELECT(j) is set to .TRUE. and SELECT(j+1) is set to
+* .FALSE..
+* Not referenced if HOWMNY = 'A' or 'B'.
+*
+* N (input) INTEGER
+* The order of the matrix T. N >= 0.
+*
+* T (input) REAL array, dimension (LDT,N)
+* The upper quasi-triangular matrix T in Schur canonical form.
+*
+* LDT (input) INTEGER
+* The leading dimension of the array T. LDT >= max(1,N).
+*
+* VL (input/output) REAL array, dimension (LDVL,MM)
+* On entry, if SIDE = 'L' or 'B' and HOWMNY = 'B', VL must
+* contain an N-by-N matrix Q (usually the orthogonal matrix Q
+* of Schur vectors returned by SHSEQR).
+* On exit, if SIDE = 'L' or 'B', VL contains:
+* if HOWMNY = 'A', the matrix Y of left eigenvectors of T;
+* if HOWMNY = 'B', the matrix Q*Y;
+* if HOWMNY = 'S', the left eigenvectors of T specified by
+* SELECT, stored consecutively in the columns
+* of VL, in the same order as their
+* eigenvalues.
+* A complex eigenvector corresponding to a complex eigenvalue
+* is stored in two consecutive columns, the first holding the
+* real part, and the second the imaginary part.
+* Not referenced if SIDE = 'R'.
+*
+* LDVL (input) INTEGER
+* The leading dimension of the array VL. LDVL >= 1, and if
+* SIDE = 'L' or 'B', LDVL >= N.
+*
+* VR (input/output) REAL array, dimension (LDVR,MM)
+* On entry, if SIDE = 'R' or 'B' and HOWMNY = 'B', VR must
+* contain an N-by-N matrix Q (usually the orthogonal matrix Q
+* of Schur vectors returned by SHSEQR).
+* On exit, if SIDE = 'R' or 'B', VR contains:
+* if HOWMNY = 'A', the matrix X of right eigenvectors of T;
+* if HOWMNY = 'B', the matrix Q*X;
+* if HOWMNY = 'S', the right eigenvectors of T specified by
+* SELECT, stored consecutively in the columns
+* of VR, in the same order as their
+* eigenvalues.
+* A complex eigenvector corresponding to a complex eigenvalue
+* is stored in two consecutive columns, the first holding the
+* real part and the second the imaginary part.
+* Not referenced if SIDE = 'L'.
+*
+* LDVR (input) INTEGER
+* The leading dimension of the array VR. LDVR >= 1, and if
+* SIDE = 'R' or 'B', LDVR >= N.
+*
+* MM (input) INTEGER
+* The number of columns in the arrays VL and/or VR. MM >= M.
+*
+* M (output) INTEGER
+* The number of columns in the arrays VL and/or VR actually
+* used to store the eigenvectors.
+* If HOWMNY = 'A' or 'B', M is set to N.
+* Each selected real eigenvector occupies one column and each
+* selected complex eigenvector occupies two columns.
+*
+* WORK (workspace) REAL array, dimension (3*N)
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+*
+* Further Details
+* ===============
+*
+* The algorithm used in this program is basically backward (forward)
+* substitution, with scaling to make the the code robust against
+* possible overflow.
+*
+* Each eigenvector is normalized so that the element of largest
+* magnitude has magnitude 1; here the magnitude of a complex number
+* (x,y) is taken to be |x| + |y|.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO, ONE
+ PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL ALLV, BOTHV, LEFTV, OVER, PAIR, RIGHTV, SOMEV
+ INTEGER I, IERR, II, IP, IS, J, J1, J2, JNXT, K, KI, N2
+ REAL BETA, BIGNUM, EMAX, OVFL, REC, REMAX, SCALE,
+ $ SMIN, SMLNUM, ULP, UNFL, VCRIT, VMAX, WI, WR,
+ $ XNORM
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ISAMAX
+ REAL SDOT, SLAMCH
+ EXTERNAL LSAME, ISAMAX, SDOT, SLAMCH
+* ..
+* .. External Subroutines ..
+ EXTERNAL SAXPY, SCOPY, SGEMV, SLABAD, SLALN2, SSCAL,
+ $ XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, SQRT
+* ..
+* .. Local Arrays ..
+ REAL X( 2, 2 )
+* ..
+* .. Executable Statements ..
+*
+* Decode and test the input parameters
+*
+ BOTHV = LSAME( SIDE, 'B' )
+ RIGHTV = LSAME( SIDE, 'R' ) .OR. BOTHV
+ LEFTV = LSAME( SIDE, 'L' ) .OR. BOTHV
+*
+ ALLV = LSAME( HOWMNY, 'A' )
+ OVER = LSAME( HOWMNY, 'B' )
+ SOMEV = LSAME( HOWMNY, 'S' )
+*
+ INFO = 0
+ IF( .NOT.RIGHTV .AND. .NOT.LEFTV ) THEN
+ INFO = -1
+ ELSE IF( .NOT.ALLV .AND. .NOT.OVER .AND. .NOT.SOMEV ) THEN
+ INFO = -2
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( LDT.LT.MAX( 1, N ) ) THEN
+ INFO = -6
+ ELSE IF( LDVL.LT.1 .OR. ( LEFTV .AND. LDVL.LT.N ) ) THEN
+ INFO = -8
+ ELSE IF( LDVR.LT.1 .OR. ( RIGHTV .AND. LDVR.LT.N ) ) THEN
+ INFO = -10
+ ELSE
+*
+* Set M to the number of columns required to store the selected
+* eigenvectors, standardize the array SELECT if necessary, and
+* test MM.
+*
+ IF( SOMEV ) THEN
+ M = 0
+ PAIR = .FALSE.
+ DO 10 J = 1, N
+ IF( PAIR ) THEN
+ PAIR = .FALSE.
+ SELECT( J ) = .FALSE.
+ ELSE
+ IF( J.LT.N ) THEN
+ IF( T( J+1, J ).EQ.ZERO ) THEN
+ IF( SELECT( J ) )
+ $ M = M + 1
+ ELSE
+ PAIR = .TRUE.
+ IF( SELECT( J ) .OR. SELECT( J+1 ) ) THEN
+ SELECT( J ) = .TRUE.
+ M = M + 2
+ END IF
+ END IF
+ ELSE
+ IF( SELECT( N ) )
+ $ M = M + 1
+ END IF
+ END IF
+ 10 CONTINUE
+ ELSE
+ M = N
+ END IF
+*
+ IF( MM.LT.M ) THEN
+ INFO = -11
+ END IF
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'STREVC', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible.
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+* Set the constants to control overflow.
+*
+ UNFL = SLAMCH( 'Safe minimum' )
+ OVFL = ONE / UNFL
+ CALL SLABAD( UNFL, OVFL )
+ ULP = SLAMCH( 'Precision' )
+ SMLNUM = UNFL*( N / ULP )
+ BIGNUM = ( ONE-ULP ) / SMLNUM
+*
+* Compute 1-norm of each column of strictly upper triangular
+* part of T to control overflow in triangular solver.
+*
+ WORK( 1 ) = ZERO
+ DO 30 J = 2, N
+ WORK( J ) = ZERO
+ DO 20 I = 1, J - 1
+ WORK( J ) = WORK( J ) + ABS( T( I, J ) )
+ 20 CONTINUE
+ 30 CONTINUE
+*
+* Index IP is used to specify the real or complex eigenvalue:
+* IP = 0, real eigenvalue,
+* 1, first of conjugate complex pair: (wr,wi)
+* -1, second of conjugate complex pair: (wr,wi)
+*
+ N2 = 2*N
+*
+ IF( RIGHTV ) THEN
+*
+* Compute right eigenvectors.
+*
+ IP = 0
+ IS = M
+ DO 140 KI = N, 1, -1
+*
+ IF( IP.EQ.1 )
+ $ GO TO 130
+ IF( KI.EQ.1 )
+ $ GO TO 40
+ IF( T( KI, KI-1 ).EQ.ZERO )
+ $ GO TO 40
+ IP = -1
+*
+ 40 CONTINUE
+ IF( SOMEV ) THEN
+ IF( IP.EQ.0 ) THEN
+ IF( .NOT.SELECT( KI ) )
+ $ GO TO 130
+ ELSE
+ IF( .NOT.SELECT( KI-1 ) )
+ $ GO TO 130
+ END IF
+ END IF
+*
+* Compute the KI-th eigenvalue (WR,WI).
+*
+ WR = T( KI, KI )
+ WI = ZERO
+ IF( IP.NE.0 )
+ $ WI = SQRT( ABS( T( KI, KI-1 ) ) )*
+ $ SQRT( ABS( T( KI-1, KI ) ) )
+ SMIN = MAX( ULP*( ABS( WR )+ABS( WI ) ), SMLNUM )
+*
+ IF( IP.EQ.0 ) THEN
+*
+* Real right eigenvector
+*
+ WORK( KI+N ) = ONE
+*
+* Form right-hand side
+*
+ DO 50 K = 1, KI - 1
+ WORK( K+N ) = -T( K, KI )
+ 50 CONTINUE
+*
+* Solve the upper quasi-triangular system:
+* (T(1:KI-1,1:KI-1) - WR)*X = SCALE*WORK.
+*
+ JNXT = KI - 1
+ DO 60 J = KI - 1, 1, -1
+ IF( J.GT.JNXT )
+ $ GO TO 60
+ J1 = J
+ J2 = J
+ JNXT = J - 1
+ IF( J.GT.1 ) THEN
+ IF( T( J, J-1 ).NE.ZERO ) THEN
+ J1 = J - 1
+ JNXT = J - 2
+ END IF
+ END IF
+*
+ IF( J1.EQ.J2 ) THEN
+*
+* 1-by-1 diagonal block
+*
+ CALL SLALN2( .FALSE., 1, 1, SMIN, ONE, T( J, J ),
+ $ LDT, ONE, ONE, WORK( J+N ), N, WR,
+ $ ZERO, X, 2, SCALE, XNORM, IERR )
+*
+* Scale X(1,1) to avoid overflow when updating
+* the right-hand side.
+*
+ IF( XNORM.GT.ONE ) THEN
+ IF( WORK( J ).GT.BIGNUM / XNORM ) THEN
+ X( 1, 1 ) = X( 1, 1 ) / XNORM
+ SCALE = SCALE / XNORM
+ END IF
+ END IF
+*
+* Scale if necessary
+*
+ IF( SCALE.NE.ONE )
+ $ CALL SSCAL( KI, SCALE, WORK( 1+N ), 1 )
+ WORK( J+N ) = X( 1, 1 )
+*
+* Update right-hand side
+*
+ CALL SAXPY( J-1, -X( 1, 1 ), T( 1, J ), 1,
+ $ WORK( 1+N ), 1 )
+*
+ ELSE
+*
+* 2-by-2 diagonal block
+*
+ CALL SLALN2( .FALSE., 2, 1, SMIN, ONE,
+ $ T( J-1, J-1 ), LDT, ONE, ONE,
+ $ WORK( J-1+N ), N, WR, ZERO, X, 2,
+ $ SCALE, XNORM, IERR )
+*
+* Scale X(1,1) and X(2,1) to avoid overflow when
+* updating the right-hand side.
+*
+ IF( XNORM.GT.ONE ) THEN
+ BETA = MAX( WORK( J-1 ), WORK( J ) )
+ IF( BETA.GT.BIGNUM / XNORM ) THEN
+ X( 1, 1 ) = X( 1, 1 ) / XNORM
+ X( 2, 1 ) = X( 2, 1 ) / XNORM
+ SCALE = SCALE / XNORM
+ END IF
+ END IF
+*
+* Scale if necessary
+*
+ IF( SCALE.NE.ONE )
+ $ CALL SSCAL( KI, SCALE, WORK( 1+N ), 1 )
+ WORK( J-1+N ) = X( 1, 1 )
+ WORK( J+N ) = X( 2, 1 )
+*
+* Update right-hand side
+*
+ CALL SAXPY( J-2, -X( 1, 1 ), T( 1, J-1 ), 1,
+ $ WORK( 1+N ), 1 )
+ CALL SAXPY( J-2, -X( 2, 1 ), T( 1, J ), 1,
+ $ WORK( 1+N ), 1 )
+ END IF
+ 60 CONTINUE
+*
+* Copy the vector x or Q*x to VR and normalize.
+*
+ IF( .NOT.OVER ) THEN
+ CALL SCOPY( KI, WORK( 1+N ), 1, VR( 1, IS ), 1 )
+*
+ II = ISAMAX( KI, VR( 1, IS ), 1 )
+ REMAX = ONE / ABS( VR( II, IS ) )
+ CALL SSCAL( KI, REMAX, VR( 1, IS ), 1 )
+*
+ DO 70 K = KI + 1, N
+ VR( K, IS ) = ZERO
+ 70 CONTINUE
+ ELSE
+ IF( KI.GT.1 )
+ $ CALL SGEMV( 'N', N, KI-1, ONE, VR, LDVR,
+ $ WORK( 1+N ), 1, WORK( KI+N ),
+ $ VR( 1, KI ), 1 )
+*
+ II = ISAMAX( N, VR( 1, KI ), 1 )
+ REMAX = ONE / ABS( VR( II, KI ) )
+ CALL SSCAL( N, REMAX, VR( 1, KI ), 1 )
+ END IF
+*
+ ELSE
+*
+* Complex right eigenvector.
+*
+* Initial solve
+* [ (T(KI-1,KI-1) T(KI-1,KI) ) - (WR + I* WI)]*X = 0.
+* [ (T(KI,KI-1) T(KI,KI) ) ]
+*
+ IF( ABS( T( KI-1, KI ) ).GE.ABS( T( KI, KI-1 ) ) ) THEN
+ WORK( KI-1+N ) = ONE
+ WORK( KI+N2 ) = WI / T( KI-1, KI )
+ ELSE
+ WORK( KI-1+N ) = -WI / T( KI, KI-1 )
+ WORK( KI+N2 ) = ONE
+ END IF
+ WORK( KI+N ) = ZERO
+ WORK( KI-1+N2 ) = ZERO
+*
+* Form right-hand side
+*
+ DO 80 K = 1, KI - 2
+ WORK( K+N ) = -WORK( KI-1+N )*T( K, KI-1 )
+ WORK( K+N2 ) = -WORK( KI+N2 )*T( K, KI )
+ 80 CONTINUE
+*
+* Solve upper quasi-triangular system:
+* (T(1:KI-2,1:KI-2) - (WR+i*WI))*X = SCALE*(WORK+i*WORK2)
+*
+ JNXT = KI - 2
+ DO 90 J = KI - 2, 1, -1
+ IF( J.GT.JNXT )
+ $ GO TO 90
+ J1 = J
+ J2 = J
+ JNXT = J - 1
+ IF( J.GT.1 ) THEN
+ IF( T( J, J-1 ).NE.ZERO ) THEN
+ J1 = J - 1
+ JNXT = J - 2
+ END IF
+ END IF
+*
+ IF( J1.EQ.J2 ) THEN
+*
+* 1-by-1 diagonal block
+*
+ CALL SLALN2( .FALSE., 1, 2, SMIN, ONE, T( J, J ),
+ $ LDT, ONE, ONE, WORK( J+N ), N, WR, WI,
+ $ X, 2, SCALE, XNORM, IERR )
+*
+* Scale X(1,1) and X(1,2) to avoid overflow when
+* updating the right-hand side.
+*
+ IF( XNORM.GT.ONE ) THEN
+ IF( WORK( J ).GT.BIGNUM / XNORM ) THEN
+ X( 1, 1 ) = X( 1, 1 ) / XNORM
+ X( 1, 2 ) = X( 1, 2 ) / XNORM
+ SCALE = SCALE / XNORM
+ END IF
+ END IF
+*
+* Scale if necessary
+*
+ IF( SCALE.NE.ONE ) THEN
+ CALL SSCAL( KI, SCALE, WORK( 1+N ), 1 )
+ CALL SSCAL( KI, SCALE, WORK( 1+N2 ), 1 )
+ END IF
+ WORK( J+N ) = X( 1, 1 )
+ WORK( J+N2 ) = X( 1, 2 )
+*
+* Update the right-hand side
+*
+ CALL SAXPY( J-1, -X( 1, 1 ), T( 1, J ), 1,
+ $ WORK( 1+N ), 1 )
+ CALL SAXPY( J-1, -X( 1, 2 ), T( 1, J ), 1,
+ $ WORK( 1+N2 ), 1 )
+*
+ ELSE
+*
+* 2-by-2 diagonal block
+*
+ CALL SLALN2( .FALSE., 2, 2, SMIN, ONE,
+ $ T( J-1, J-1 ), LDT, ONE, ONE,
+ $ WORK( J-1+N ), N, WR, WI, X, 2, SCALE,
+ $ XNORM, IERR )
+*
+* Scale X to avoid overflow when updating
+* the right-hand side.
+*
+ IF( XNORM.GT.ONE ) THEN
+ BETA = MAX( WORK( J-1 ), WORK( J ) )
+ IF( BETA.GT.BIGNUM / XNORM ) THEN
+ REC = ONE / XNORM
+ X( 1, 1 ) = X( 1, 1 )*REC
+ X( 1, 2 ) = X( 1, 2 )*REC
+ X( 2, 1 ) = X( 2, 1 )*REC
+ X( 2, 2 ) = X( 2, 2 )*REC
+ SCALE = SCALE*REC
+ END IF
+ END IF
+*
+* Scale if necessary
+*
+ IF( SCALE.NE.ONE ) THEN
+ CALL SSCAL( KI, SCALE, WORK( 1+N ), 1 )
+ CALL SSCAL( KI, SCALE, WORK( 1+N2 ), 1 )
+ END IF
+ WORK( J-1+N ) = X( 1, 1 )
+ WORK( J+N ) = X( 2, 1 )
+ WORK( J-1+N2 ) = X( 1, 2 )
+ WORK( J+N2 ) = X( 2, 2 )
+*
+* Update the right-hand side
+*
+ CALL SAXPY( J-2, -X( 1, 1 ), T( 1, J-1 ), 1,
+ $ WORK( 1+N ), 1 )
+ CALL SAXPY( J-2, -X( 2, 1 ), T( 1, J ), 1,
+ $ WORK( 1+N ), 1 )
+ CALL SAXPY( J-2, -X( 1, 2 ), T( 1, J-1 ), 1,
+ $ WORK( 1+N2 ), 1 )
+ CALL SAXPY( J-2, -X( 2, 2 ), T( 1, J ), 1,
+ $ WORK( 1+N2 ), 1 )
+ END IF
+ 90 CONTINUE
+*
+* Copy the vector x or Q*x to VR and normalize.
+*
+ IF( .NOT.OVER ) THEN
+ CALL SCOPY( KI, WORK( 1+N ), 1, VR( 1, IS-1 ), 1 )
+ CALL SCOPY( KI, WORK( 1+N2 ), 1, VR( 1, IS ), 1 )
+*
+ EMAX = ZERO
+ DO 100 K = 1, KI
+ EMAX = MAX( EMAX, ABS( VR( K, IS-1 ) )+
+ $ ABS( VR( K, IS ) ) )
+ 100 CONTINUE
+*
+ REMAX = ONE / EMAX
+ CALL SSCAL( KI, REMAX, VR( 1, IS-1 ), 1 )
+ CALL SSCAL( KI, REMAX, VR( 1, IS ), 1 )
+*
+ DO 110 K = KI + 1, N
+ VR( K, IS-1 ) = ZERO
+ VR( K, IS ) = ZERO
+ 110 CONTINUE
+*
+ ELSE
+*
+ IF( KI.GT.2 ) THEN
+ CALL SGEMV( 'N', N, KI-2, ONE, VR, LDVR,
+ $ WORK( 1+N ), 1, WORK( KI-1+N ),
+ $ VR( 1, KI-1 ), 1 )
+ CALL SGEMV( 'N', N, KI-2, ONE, VR, LDVR,
+ $ WORK( 1+N2 ), 1, WORK( KI+N2 ),
+ $ VR( 1, KI ), 1 )
+ ELSE
+ CALL SSCAL( N, WORK( KI-1+N ), VR( 1, KI-1 ), 1 )
+ CALL SSCAL( N, WORK( KI+N2 ), VR( 1, KI ), 1 )
+ END IF
+*
+ EMAX = ZERO
+ DO 120 K = 1, N
+ EMAX = MAX( EMAX, ABS( VR( K, KI-1 ) )+
+ $ ABS( VR( K, KI ) ) )
+ 120 CONTINUE
+ REMAX = ONE / EMAX
+ CALL SSCAL( N, REMAX, VR( 1, KI-1 ), 1 )
+ CALL SSCAL( N, REMAX, VR( 1, KI ), 1 )
+ END IF
+ END IF
+*
+ IS = IS - 1
+ IF( IP.NE.0 )
+ $ IS = IS - 1
+ 130 CONTINUE
+ IF( IP.EQ.1 )
+ $ IP = 0
+ IF( IP.EQ.-1 )
+ $ IP = 1
+ 140 CONTINUE
+ END IF
+*
+ IF( LEFTV ) THEN
+*
+* Compute left eigenvectors.
+*
+ IP = 0
+ IS = 1
+ DO 260 KI = 1, N
+*
+ IF( IP.EQ.-1 )
+ $ GO TO 250
+ IF( KI.EQ.N )
+ $ GO TO 150
+ IF( T( KI+1, KI ).EQ.ZERO )
+ $ GO TO 150
+ IP = 1
+*
+ 150 CONTINUE
+ IF( SOMEV ) THEN
+ IF( .NOT.SELECT( KI ) )
+ $ GO TO 250
+ END IF
+*
+* Compute the KI-th eigenvalue (WR,WI).
+*
+ WR = T( KI, KI )
+ WI = ZERO
+ IF( IP.NE.0 )
+ $ WI = SQRT( ABS( T( KI, KI+1 ) ) )*
+ $ SQRT( ABS( T( KI+1, KI ) ) )
+ SMIN = MAX( ULP*( ABS( WR )+ABS( WI ) ), SMLNUM )
+*
+ IF( IP.EQ.0 ) THEN
+*
+* Real left eigenvector.
+*
+ WORK( KI+N ) = ONE
+*
+* Form right-hand side
+*
+ DO 160 K = KI + 1, N
+ WORK( K+N ) = -T( KI, K )
+ 160 CONTINUE
+*
+* Solve the quasi-triangular system:
+* (T(KI+1:N,KI+1:N) - WR)'*X = SCALE*WORK
+*
+ VMAX = ONE
+ VCRIT = BIGNUM
+*
+ JNXT = KI + 1
+ DO 170 J = KI + 1, N
+ IF( J.LT.JNXT )
+ $ GO TO 170
+ J1 = J
+ J2 = J
+ JNXT = J + 1
+ IF( J.LT.N ) THEN
+ IF( T( J+1, J ).NE.ZERO ) THEN
+ J2 = J + 1
+ JNXT = J + 2
+ END IF
+ END IF
+*
+ IF( J1.EQ.J2 ) THEN
+*
+* 1-by-1 diagonal block
+*
+* Scale if necessary to avoid overflow when forming
+* the right-hand side.
+*
+ IF( WORK( J ).GT.VCRIT ) THEN
+ REC = ONE / VMAX
+ CALL SSCAL( N-KI+1, REC, WORK( KI+N ), 1 )
+ VMAX = ONE
+ VCRIT = BIGNUM
+ END IF
+*
+ WORK( J+N ) = WORK( J+N ) -
+ $ SDOT( J-KI-1, T( KI+1, J ), 1,
+ $ WORK( KI+1+N ), 1 )
+*
+* Solve (T(J,J)-WR)'*X = WORK
+*
+ CALL SLALN2( .FALSE., 1, 1, SMIN, ONE, T( J, J ),
+ $ LDT, ONE, ONE, WORK( J+N ), N, WR,
+ $ ZERO, X, 2, SCALE, XNORM, IERR )
+*
+* Scale if necessary
+*
+ IF( SCALE.NE.ONE )
+ $ CALL SSCAL( N-KI+1, SCALE, WORK( KI+N ), 1 )
+ WORK( J+N ) = X( 1, 1 )
+ VMAX = MAX( ABS( WORK( J+N ) ), VMAX )
+ VCRIT = BIGNUM / VMAX
+*
+ ELSE
+*
+* 2-by-2 diagonal block
+*
+* Scale if necessary to avoid overflow when forming
+* the right-hand side.
+*
+ BETA = MAX( WORK( J ), WORK( J+1 ) )
+ IF( BETA.GT.VCRIT ) THEN
+ REC = ONE / VMAX
+ CALL SSCAL( N-KI+1, REC, WORK( KI+N ), 1 )
+ VMAX = ONE
+ VCRIT = BIGNUM
+ END IF
+*
+ WORK( J+N ) = WORK( J+N ) -
+ $ SDOT( J-KI-1, T( KI+1, J ), 1,
+ $ WORK( KI+1+N ), 1 )
+*
+ WORK( J+1+N ) = WORK( J+1+N ) -
+ $ SDOT( J-KI-1, T( KI+1, J+1 ), 1,
+ $ WORK( KI+1+N ), 1 )
+*
+* Solve
+* [T(J,J)-WR T(J,J+1) ]'* X = SCALE*( WORK1 )
+* [T(J+1,J) T(J+1,J+1)-WR] ( WORK2 )
+*
+ CALL SLALN2( .TRUE., 2, 1, SMIN, ONE, T( J, J ),
+ $ LDT, ONE, ONE, WORK( J+N ), N, WR,
+ $ ZERO, X, 2, SCALE, XNORM, IERR )
+*
+* Scale if necessary
+*
+ IF( SCALE.NE.ONE )
+ $ CALL SSCAL( N-KI+1, SCALE, WORK( KI+N ), 1 )
+ WORK( J+N ) = X( 1, 1 )
+ WORK( J+1+N ) = X( 2, 1 )
+*
+ VMAX = MAX( ABS( WORK( J+N ) ),
+ $ ABS( WORK( J+1+N ) ), VMAX )
+ VCRIT = BIGNUM / VMAX
+*
+ END IF
+ 170 CONTINUE
+*
+* Copy the vector x or Q*x to VL and normalize.
+*
+ IF( .NOT.OVER ) THEN
+ CALL SCOPY( N-KI+1, WORK( KI+N ), 1, VL( KI, IS ), 1 )
+*
+ II = ISAMAX( N-KI+1, VL( KI, IS ), 1 ) + KI - 1
+ REMAX = ONE / ABS( VL( II, IS ) )
+ CALL SSCAL( N-KI+1, REMAX, VL( KI, IS ), 1 )
+*
+ DO 180 K = 1, KI - 1
+ VL( K, IS ) = ZERO
+ 180 CONTINUE
+*
+ ELSE
+*
+ IF( KI.LT.N )
+ $ CALL SGEMV( 'N', N, N-KI, ONE, VL( 1, KI+1 ), LDVL,
+ $ WORK( KI+1+N ), 1, WORK( KI+N ),
+ $ VL( 1, KI ), 1 )
+*
+ II = ISAMAX( N, VL( 1, KI ), 1 )
+ REMAX = ONE / ABS( VL( II, KI ) )
+ CALL SSCAL( N, REMAX, VL( 1, KI ), 1 )
+*
+ END IF
+*
+ ELSE
+*
+* Complex left eigenvector.
+*
+* Initial solve:
+* ((T(KI,KI) T(KI,KI+1) )' - (WR - I* WI))*X = 0.
+* ((T(KI+1,KI) T(KI+1,KI+1)) )
+*
+ IF( ABS( T( KI, KI+1 ) ).GE.ABS( T( KI+1, KI ) ) ) THEN
+ WORK( KI+N ) = WI / T( KI, KI+1 )
+ WORK( KI+1+N2 ) = ONE
+ ELSE
+ WORK( KI+N ) = ONE
+ WORK( KI+1+N2 ) = -WI / T( KI+1, KI )
+ END IF
+ WORK( KI+1+N ) = ZERO
+ WORK( KI+N2 ) = ZERO
+*
+* Form right-hand side
+*
+ DO 190 K = KI + 2, N
+ WORK( K+N ) = -WORK( KI+N )*T( KI, K )
+ WORK( K+N2 ) = -WORK( KI+1+N2 )*T( KI+1, K )
+ 190 CONTINUE
+*
+* Solve complex quasi-triangular system:
+* ( T(KI+2,N:KI+2,N) - (WR-i*WI) )*X = WORK1+i*WORK2
+*
+ VMAX = ONE
+ VCRIT = BIGNUM
+*
+ JNXT = KI + 2
+ DO 200 J = KI + 2, N
+ IF( J.LT.JNXT )
+ $ GO TO 200
+ J1 = J
+ J2 = J
+ JNXT = J + 1
+ IF( J.LT.N ) THEN
+ IF( T( J+1, J ).NE.ZERO ) THEN
+ J2 = J + 1
+ JNXT = J + 2
+ END IF
+ END IF
+*
+ IF( J1.EQ.J2 ) THEN
+*
+* 1-by-1 diagonal block
+*
+* Scale if necessary to avoid overflow when
+* forming the right-hand side elements.
+*
+ IF( WORK( J ).GT.VCRIT ) THEN
+ REC = ONE / VMAX
+ CALL SSCAL( N-KI+1, REC, WORK( KI+N ), 1 )
+ CALL SSCAL( N-KI+1, REC, WORK( KI+N2 ), 1 )
+ VMAX = ONE
+ VCRIT = BIGNUM
+ END IF
+*
+ WORK( J+N ) = WORK( J+N ) -
+ $ SDOT( J-KI-2, T( KI+2, J ), 1,
+ $ WORK( KI+2+N ), 1 )
+ WORK( J+N2 ) = WORK( J+N2 ) -
+ $ SDOT( J-KI-2, T( KI+2, J ), 1,
+ $ WORK( KI+2+N2 ), 1 )
+*
+* Solve (T(J,J)-(WR-i*WI))*(X11+i*X12)= WK+I*WK2
+*
+ CALL SLALN2( .FALSE., 1, 2, SMIN, ONE, T( J, J ),
+ $ LDT, ONE, ONE, WORK( J+N ), N, WR,
+ $ -WI, X, 2, SCALE, XNORM, IERR )
+*
+* Scale if necessary
+*
+ IF( SCALE.NE.ONE ) THEN
+ CALL SSCAL( N-KI+1, SCALE, WORK( KI+N ), 1 )
+ CALL SSCAL( N-KI+1, SCALE, WORK( KI+N2 ), 1 )
+ END IF
+ WORK( J+N ) = X( 1, 1 )
+ WORK( J+N2 ) = X( 1, 2 )
+ VMAX = MAX( ABS( WORK( J+N ) ),
+ $ ABS( WORK( J+N2 ) ), VMAX )
+ VCRIT = BIGNUM / VMAX
+*
+ ELSE
+*
+* 2-by-2 diagonal block
+*
+* Scale if necessary to avoid overflow when forming
+* the right-hand side elements.
+*
+ BETA = MAX( WORK( J ), WORK( J+1 ) )
+ IF( BETA.GT.VCRIT ) THEN
+ REC = ONE / VMAX
+ CALL SSCAL( N-KI+1, REC, WORK( KI+N ), 1 )
+ CALL SSCAL( N-KI+1, REC, WORK( KI+N2 ), 1 )
+ VMAX = ONE
+ VCRIT = BIGNUM
+ END IF
+*
+ WORK( J+N ) = WORK( J+N ) -
+ $ SDOT( J-KI-2, T( KI+2, J ), 1,
+ $ WORK( KI+2+N ), 1 )
+*
+ WORK( J+N2 ) = WORK( J+N2 ) -
+ $ SDOT( J-KI-2, T( KI+2, J ), 1,
+ $ WORK( KI+2+N2 ), 1 )
+*
+ WORK( J+1+N ) = WORK( J+1+N ) -
+ $ SDOT( J-KI-2, T( KI+2, J+1 ), 1,
+ $ WORK( KI+2+N ), 1 )
+*
+ WORK( J+1+N2 ) = WORK( J+1+N2 ) -
+ $ SDOT( J-KI-2, T( KI+2, J+1 ), 1,
+ $ WORK( KI+2+N2 ), 1 )
+*
+* Solve 2-by-2 complex linear equation
+* ([T(j,j) T(j,j+1) ]'-(wr-i*wi)*I)*X = SCALE*B
+* ([T(j+1,j) T(j+1,j+1)] )
+*
+ CALL SLALN2( .TRUE., 2, 2, SMIN, ONE, T( J, J ),
+ $ LDT, ONE, ONE, WORK( J+N ), N, WR,
+ $ -WI, X, 2, SCALE, XNORM, IERR )
+*
+* Scale if necessary
+*
+ IF( SCALE.NE.ONE ) THEN
+ CALL SSCAL( N-KI+1, SCALE, WORK( KI+N ), 1 )
+ CALL SSCAL( N-KI+1, SCALE, WORK( KI+N2 ), 1 )
+ END IF
+ WORK( J+N ) = X( 1, 1 )
+ WORK( J+N2 ) = X( 1, 2 )
+ WORK( J+1+N ) = X( 2, 1 )
+ WORK( J+1+N2 ) = X( 2, 2 )
+ VMAX = MAX( ABS( X( 1, 1 ) ), ABS( X( 1, 2 ) ),
+ $ ABS( X( 2, 1 ) ), ABS( X( 2, 2 ) ), VMAX )
+ VCRIT = BIGNUM / VMAX
+*
+ END IF
+ 200 CONTINUE
+*
+* Copy the vector x or Q*x to VL and normalize.
+*
+ IF( .NOT.OVER ) THEN
+ CALL SCOPY( N-KI+1, WORK( KI+N ), 1, VL( KI, IS ), 1 )
+ CALL SCOPY( N-KI+1, WORK( KI+N2 ), 1, VL( KI, IS+1 ),
+ $ 1 )
+*
+ EMAX = ZERO
+ DO 220 K = KI, N
+ EMAX = MAX( EMAX, ABS( VL( K, IS ) )+
+ $ ABS( VL( K, IS+1 ) ) )
+ 220 CONTINUE
+ REMAX = ONE / EMAX
+ CALL SSCAL( N-KI+1, REMAX, VL( KI, IS ), 1 )
+ CALL SSCAL( N-KI+1, REMAX, VL( KI, IS+1 ), 1 )
+*
+ DO 230 K = 1, KI - 1
+ VL( K, IS ) = ZERO
+ VL( K, IS+1 ) = ZERO
+ 230 CONTINUE
+ ELSE
+ IF( KI.LT.N-1 ) THEN
+ CALL SGEMV( 'N', N, N-KI-1, ONE, VL( 1, KI+2 ),
+ $ LDVL, WORK( KI+2+N ), 1, WORK( KI+N ),
+ $ VL( 1, KI ), 1 )
+ CALL SGEMV( 'N', N, N-KI-1, ONE, VL( 1, KI+2 ),
+ $ LDVL, WORK( KI+2+N2 ), 1,
+ $ WORK( KI+1+N2 ), VL( 1, KI+1 ), 1 )
+ ELSE
+ CALL SSCAL( N, WORK( KI+N ), VL( 1, KI ), 1 )
+ CALL SSCAL( N, WORK( KI+1+N2 ), VL( 1, KI+1 ), 1 )
+ END IF
+*
+ EMAX = ZERO
+ DO 240 K = 1, N
+ EMAX = MAX( EMAX, ABS( VL( K, KI ) )+
+ $ ABS( VL( K, KI+1 ) ) )
+ 240 CONTINUE
+ REMAX = ONE / EMAX
+ CALL SSCAL( N, REMAX, VL( 1, KI ), 1 )
+ CALL SSCAL( N, REMAX, VL( 1, KI+1 ), 1 )
+*
+ END IF
+*
+ END IF
+*
+ IS = IS + 1
+ IF( IP.NE.0 )
+ $ IS = IS + 1
+ 250 CONTINUE
+ IF( IP.EQ.-1 )
+ $ IP = 0
+ IF( IP.EQ.1 )
+ $ IP = -1
+*
+ 260 CONTINUE
+*
+ END IF
+*
+ RETURN
+*
+* End of STREVC
+*
+ END
+ SUBROUTINE STREXC( COMPQ, N, T, LDT, Q, LDQ, IFST, ILST, WORK,
+ $ INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER COMPQ
+ INTEGER IFST, ILST, INFO, LDQ, LDT, N
+* ..
+* .. Array Arguments ..
+ REAL Q( LDQ, * ), T( LDT, * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* STREXC reorders the real Schur factorization of a real matrix
+* A = Q*T*Q**T, so that the diagonal block of T with row index IFST is
+* moved to row ILST.
+*
+* The real Schur form T is reordered by an orthogonal similarity
+* transformation Z**T*T*Z, and optionally the matrix Q of Schur vectors
+* is updated by postmultiplying it with Z.
+*
+* T must be in Schur canonical form (as returned by SHSEQR), that is,
+* block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; each
+* 2-by-2 diagonal block has its diagonal elements equal and its
+* off-diagonal elements of opposite sign.
+*
+* Arguments
+* =========
+*
+* COMPQ (input) CHARACTER*1
+* = 'V': update the matrix Q of Schur vectors;
+* = 'N': do not update Q.
+*
+* N (input) INTEGER
+* The order of the matrix T. N >= 0.
+*
+* T (input/output) REAL array, dimension (LDT,N)
+* On entry, the upper quasi-triangular matrix T, in Schur
+* Schur canonical form.
+* On exit, the reordered upper quasi-triangular matrix, again
+* in Schur canonical form.
+*
+* LDT (input) INTEGER
+* The leading dimension of the array T. LDT >= max(1,N).
+*
+* Q (input/output) REAL array, dimension (LDQ,N)
+* On entry, if COMPQ = 'V', the matrix Q of Schur vectors.
+* On exit, if COMPQ = 'V', Q has been postmultiplied by the
+* orthogonal transformation matrix Z which reorders T.
+* If COMPQ = 'N', Q is not referenced.
+*
+* LDQ (input) INTEGER
+* The leading dimension of the array Q. LDQ >= max(1,N).
+*
+* IFST (input/output) INTEGER
+* ILST (input/output) INTEGER
+* Specify the reordering of the diagonal blocks of T.
+* The block with row index IFST is moved to row ILST, by a
+* sequence of transpositions between adjacent blocks.
+* On exit, if IFST pointed on entry to the second row of a
+* 2-by-2 block, it is changed to point to the first row; ILST
+* always points to the first row of the block in its final
+* position (which may differ from its input value by +1 or -1).
+* 1 <= IFST <= N; 1 <= ILST <= N.
+*
+* WORK (workspace) REAL array, dimension (N)
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* = 1: two adjacent blocks were too close to swap (the problem
+* is very ill-conditioned); T may have been partially
+* reordered, and ILST points to the first row of the
+* current position of the block being moved.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO
+ PARAMETER ( ZERO = 0.0E+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL WANTQ
+ INTEGER HERE, NBF, NBL, NBNEXT
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL SLAEXC, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+* Decode and test the input arguments.
+*
+ INFO = 0
+ WANTQ = LSAME( COMPQ, 'V' )
+ IF( .NOT.WANTQ .AND. .NOT.LSAME( COMPQ, 'N' ) ) THEN
+ INFO = -1
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( LDT.LT.MAX( 1, N ) ) THEN
+ INFO = -4
+ ELSE IF( LDQ.LT.1 .OR. ( WANTQ .AND. LDQ.LT.MAX( 1, N ) ) ) THEN
+ INFO = -6
+ ELSE IF( IFST.LT.1 .OR. IFST.GT.N ) THEN
+ INFO = -7
+ ELSE IF( ILST.LT.1 .OR. ILST.GT.N ) THEN
+ INFO = -8
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'STREXC', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.LE.1 )
+ $ RETURN
+*
+* Determine the first row of specified block
+* and find out it is 1 by 1 or 2 by 2.
+*
+ IF( IFST.GT.1 ) THEN
+ IF( T( IFST, IFST-1 ).NE.ZERO )
+ $ IFST = IFST - 1
+ END IF
+ NBF = 1
+ IF( IFST.LT.N ) THEN
+ IF( T( IFST+1, IFST ).NE.ZERO )
+ $ NBF = 2
+ END IF
+*
+* Determine the first row of the final block
+* and find out it is 1 by 1 or 2 by 2.
+*
+ IF( ILST.GT.1 ) THEN
+ IF( T( ILST, ILST-1 ).NE.ZERO )
+ $ ILST = ILST - 1
+ END IF
+ NBL = 1
+ IF( ILST.LT.N ) THEN
+ IF( T( ILST+1, ILST ).NE.ZERO )
+ $ NBL = 2
+ END IF
+*
+ IF( IFST.EQ.ILST )
+ $ RETURN
+*
+ IF( IFST.LT.ILST ) THEN
+*
+* Update ILST
+*
+ IF( NBF.EQ.2 .AND. NBL.EQ.1 )
+ $ ILST = ILST - 1
+ IF( NBF.EQ.1 .AND. NBL.EQ.2 )
+ $ ILST = ILST + 1
+*
+ HERE = IFST
+*
+ 10 CONTINUE
+*
+* Swap block with next one below
+*
+ IF( NBF.EQ.1 .OR. NBF.EQ.2 ) THEN
+*
+* Current block either 1 by 1 or 2 by 2
+*
+ NBNEXT = 1
+ IF( HERE+NBF+1.LE.N ) THEN
+ IF( T( HERE+NBF+1, HERE+NBF ).NE.ZERO )
+ $ NBNEXT = 2
+ END IF
+ CALL SLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE, NBF, NBNEXT,
+ $ WORK, INFO )
+ IF( INFO.NE.0 ) THEN
+ ILST = HERE
+ RETURN
+ END IF
+ HERE = HERE + NBNEXT
+*
+* Test if 2 by 2 block breaks into two 1 by 1 blocks
+*
+ IF( NBF.EQ.2 ) THEN
+ IF( T( HERE+1, HERE ).EQ.ZERO )
+ $ NBF = 3
+ END IF
+*
+ ELSE
+*
+* Current block consists of two 1 by 1 blocks each of which
+* must be swapped individually
+*
+ NBNEXT = 1
+ IF( HERE+3.LE.N ) THEN
+ IF( T( HERE+3, HERE+2 ).NE.ZERO )
+ $ NBNEXT = 2
+ END IF
+ CALL SLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE+1, 1, NBNEXT,
+ $ WORK, INFO )
+ IF( INFO.NE.0 ) THEN
+ ILST = HERE
+ RETURN
+ END IF
+ IF( NBNEXT.EQ.1 ) THEN
+*
+* Swap two 1 by 1 blocks, no problems possible
+*
+ CALL SLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE, 1, NBNEXT,
+ $ WORK, INFO )
+ HERE = HERE + 1
+ ELSE
+*
+* Recompute NBNEXT in case 2 by 2 split
+*
+ IF( T( HERE+2, HERE+1 ).EQ.ZERO )
+ $ NBNEXT = 1
+ IF( NBNEXT.EQ.2 ) THEN
+*
+* 2 by 2 Block did not split
+*
+ CALL SLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE, 1,
+ $ NBNEXT, WORK, INFO )
+ IF( INFO.NE.0 ) THEN
+ ILST = HERE
+ RETURN
+ END IF
+ HERE = HERE + 2
+ ELSE
+*
+* 2 by 2 Block did split
+*
+ CALL SLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE, 1, 1,
+ $ WORK, INFO )
+ CALL SLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE+1, 1, 1,
+ $ WORK, INFO )
+ HERE = HERE + 2
+ END IF
+ END IF
+ END IF
+ IF( HERE.LT.ILST )
+ $ GO TO 10
+*
+ ELSE
+*
+ HERE = IFST
+ 20 CONTINUE
+*
+* Swap block with next one above
+*
+ IF( NBF.EQ.1 .OR. NBF.EQ.2 ) THEN
+*
+* Current block either 1 by 1 or 2 by 2
+*
+ NBNEXT = 1
+ IF( HERE.GE.3 ) THEN
+ IF( T( HERE-1, HERE-2 ).NE.ZERO )
+ $ NBNEXT = 2
+ END IF
+ CALL SLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE-NBNEXT, NBNEXT,
+ $ NBF, WORK, INFO )
+ IF( INFO.NE.0 ) THEN
+ ILST = HERE
+ RETURN
+ END IF
+ HERE = HERE - NBNEXT
+*
+* Test if 2 by 2 block breaks into two 1 by 1 blocks
+*
+ IF( NBF.EQ.2 ) THEN
+ IF( T( HERE+1, HERE ).EQ.ZERO )
+ $ NBF = 3
+ END IF
+*
+ ELSE
+*
+* Current block consists of two 1 by 1 blocks each of which
+* must be swapped individually
+*
+ NBNEXT = 1
+ IF( HERE.GE.3 ) THEN
+ IF( T( HERE-1, HERE-2 ).NE.ZERO )
+ $ NBNEXT = 2
+ END IF
+ CALL SLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE-NBNEXT, NBNEXT,
+ $ 1, WORK, INFO )
+ IF( INFO.NE.0 ) THEN
+ ILST = HERE
+ RETURN
+ END IF
+ IF( NBNEXT.EQ.1 ) THEN
+*
+* Swap two 1 by 1 blocks, no problems possible
+*
+ CALL SLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE, NBNEXT, 1,
+ $ WORK, INFO )
+ HERE = HERE - 1
+ ELSE
+*
+* Recompute NBNEXT in case 2 by 2 split
+*
+ IF( T( HERE, HERE-1 ).EQ.ZERO )
+ $ NBNEXT = 1
+ IF( NBNEXT.EQ.2 ) THEN
+*
+* 2 by 2 Block did not split
+*
+ CALL SLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE-1, 2, 1,
+ $ WORK, INFO )
+ IF( INFO.NE.0 ) THEN
+ ILST = HERE
+ RETURN
+ END IF
+ HERE = HERE - 2
+ ELSE
+*
+* 2 by 2 Block did split
+*
+ CALL SLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE, 1, 1,
+ $ WORK, INFO )
+ CALL SLAEXC( WANTQ, N, T, LDT, Q, LDQ, HERE-1, 1, 1,
+ $ WORK, INFO )
+ HERE = HERE - 2
+ END IF
+ END IF
+ END IF
+ IF( HERE.GT.ILST )
+ $ GO TO 20
+ END IF
+ ILST = HERE
+*
+ RETURN
+*
+* End of STREXC
+*
+ END
+ SUBROUTINE STRRFS( UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB, X,
+ $ LDX, FERR, BERR, WORK, IWORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* Modified to call SLACN2 in place of SLACON, 7 Feb 03, SJH.
+*
+* .. Scalar Arguments ..
+ CHARACTER DIAG, TRANS, UPLO
+ INTEGER INFO, LDA, LDB, LDX, N, NRHS
+* ..
+* .. Array Arguments ..
+ INTEGER IWORK( * )
+ REAL A( LDA, * ), B( LDB, * ), BERR( * ), FERR( * ),
+ $ WORK( * ), X( LDX, * )
+* ..
+*
+* Purpose
+* =======
+*
+* STRRFS provides error bounds and backward error estimates for the
+* solution to a system of linear equations with a triangular
+* coefficient matrix.
+*
+* The solution matrix X must be computed by STRTRS or some other
+* means before entering this routine. STRRFS does not do iterative
+* refinement because doing so cannot improve the backward error.
+*
+* Arguments
+* =========
+*
+* UPLO (input) CHARACTER*1
+* = 'U': A is upper triangular;
+* = 'L': A is lower triangular.
+*
+* TRANS (input) CHARACTER*1
+* Specifies the form of the system of equations:
+* = 'N': A * X = B (No transpose)
+* = 'T': A**T * X = B (Transpose)
+* = 'C': A**H * X = B (Conjugate transpose = Transpose)
+*
+* DIAG (input) CHARACTER*1
+* = 'N': A is non-unit triangular;
+* = 'U': A is unit triangular.
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* NRHS (input) INTEGER
+* The number of right hand sides, i.e., the number of columns
+* of the matrices B and X. NRHS >= 0.
+*
+* A (input) REAL array, dimension (LDA,N)
+* The triangular matrix A. If UPLO = 'U', the leading N-by-N
+* upper triangular part of the array A contains the upper
+* triangular matrix, and the strictly lower triangular part of
+* A is not referenced. If UPLO = 'L', the leading N-by-N lower
+* triangular part of the array A contains the lower triangular
+* matrix, and the strictly upper triangular part of A is not
+* referenced. If DIAG = 'U', the diagonal elements of A are
+* also not referenced and are assumed to be 1.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,N).
+*
+* B (input) REAL array, dimension (LDB,NRHS)
+* The right hand side matrix B.
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. LDB >= max(1,N).
+*
+* X (input) REAL array, dimension (LDX,NRHS)
+* The solution matrix X.
+*
+* LDX (input) INTEGER
+* The leading dimension of the array X. LDX >= max(1,N).
+*
+* FERR (output) REAL array, dimension (NRHS)
+* The estimated forward error bound for each solution vector
+* X(j) (the j-th column of the solution matrix X).
+* If XTRUE is the true solution corresponding to X(j), FERR(j)
+* is an estimated upper bound for the magnitude of the largest
+* element in (X(j) - XTRUE) divided by the magnitude of the
+* largest element in X(j). The estimate is as reliable as
+* the estimate for RCOND, and is almost always a slight
+* overestimate of the true error.
+*
+* BERR (output) REAL array, dimension (NRHS)
+* The componentwise relative backward error of each solution
+* vector X(j) (i.e., the smallest relative change in
+* any element of A or B that makes X(j) an exact solution).
+*
+* WORK (workspace) REAL array, dimension (3*N)
+*
+* IWORK (workspace) INTEGER array, dimension (N)
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO
+ PARAMETER ( ZERO = 0.0E+0 )
+ REAL ONE
+ PARAMETER ( ONE = 1.0E+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL NOTRAN, NOUNIT, UPPER
+ CHARACTER TRANST
+ INTEGER I, J, K, KASE, NZ
+ REAL EPS, LSTRES, S, SAFE1, SAFE2, SAFMIN, XK
+* ..
+* .. Local Arrays ..
+ INTEGER ISAVE( 3 )
+* ..
+* .. External Subroutines ..
+ EXTERNAL SAXPY, SCOPY, SLACN2, STRMV, STRSV, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ REAL SLAMCH
+ EXTERNAL LSAME, SLAMCH
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ NOTRAN = LSAME( TRANS, 'N' )
+ NOUNIT = LSAME( DIAG, 'N' )
+*
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT.
+ $ LSAME( TRANS, 'C' ) ) THEN
+ INFO = -2
+ ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
+ INFO = -3
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( NRHS.LT.0 ) THEN
+ INFO = -5
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -7
+ ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -9
+ ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
+ INFO = -11
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'STRRFS', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 .OR. NRHS.EQ.0 ) THEN
+ DO 10 J = 1, NRHS
+ FERR( J ) = ZERO
+ BERR( J ) = ZERO
+ 10 CONTINUE
+ RETURN
+ END IF
+*
+ IF( NOTRAN ) THEN
+ TRANST = 'T'
+ ELSE
+ TRANST = 'N'
+ END IF
+*
+* NZ = maximum number of nonzero elements in each row of A, plus 1
+*
+ NZ = N + 1
+ EPS = SLAMCH( 'Epsilon' )
+ SAFMIN = SLAMCH( 'Safe minimum' )
+ SAFE1 = NZ*SAFMIN
+ SAFE2 = SAFE1 / EPS
+*
+* Do for each right hand side
+*
+ DO 250 J = 1, NRHS
+*
+* Compute residual R = B - op(A) * X,
+* where op(A) = A or A', depending on TRANS.
+*
+ CALL SCOPY( N, X( 1, J ), 1, WORK( N+1 ), 1 )
+ CALL STRMV( UPLO, TRANS, DIAG, N, A, LDA, WORK( N+1 ), 1 )
+ CALL SAXPY( N, -ONE, B( 1, J ), 1, WORK( N+1 ), 1 )
+*
+* Compute componentwise relative backward error from formula
+*
+* max(i) ( abs(R(i)) / ( abs(op(A))*abs(X) + abs(B) )(i) )
+*
+* where abs(Z) is the componentwise absolute value of the matrix
+* or vector Z. If the i-th component of the denominator is less
+* than SAFE2, then SAFE1 is added to the i-th components of the
+* numerator and denominator before dividing.
+*
+ DO 20 I = 1, N
+ WORK( I ) = ABS( B( I, J ) )
+ 20 CONTINUE
+*
+ IF( NOTRAN ) THEN
+*
+* Compute abs(A)*abs(X) + abs(B).
+*
+ IF( UPPER ) THEN
+ IF( NOUNIT ) THEN
+ DO 40 K = 1, N
+ XK = ABS( X( K, J ) )
+ DO 30 I = 1, K
+ WORK( I ) = WORK( I ) + ABS( A( I, K ) )*XK
+ 30 CONTINUE
+ 40 CONTINUE
+ ELSE
+ DO 60 K = 1, N
+ XK = ABS( X( K, J ) )
+ DO 50 I = 1, K - 1
+ WORK( I ) = WORK( I ) + ABS( A( I, K ) )*XK
+ 50 CONTINUE
+ WORK( K ) = WORK( K ) + XK
+ 60 CONTINUE
+ END IF
+ ELSE
+ IF( NOUNIT ) THEN
+ DO 80 K = 1, N
+ XK = ABS( X( K, J ) )
+ DO 70 I = K, N
+ WORK( I ) = WORK( I ) + ABS( A( I, K ) )*XK
+ 70 CONTINUE
+ 80 CONTINUE
+ ELSE
+ DO 100 K = 1, N
+ XK = ABS( X( K, J ) )
+ DO 90 I = K + 1, N
+ WORK( I ) = WORK( I ) + ABS( A( I, K ) )*XK
+ 90 CONTINUE
+ WORK( K ) = WORK( K ) + XK
+ 100 CONTINUE
+ END IF
+ END IF
+ ELSE
+*
+* Compute abs(A')*abs(X) + abs(B).
+*
+ IF( UPPER ) THEN
+ IF( NOUNIT ) THEN
+ DO 120 K = 1, N
+ S = ZERO
+ DO 110 I = 1, K
+ S = S + ABS( A( I, K ) )*ABS( X( I, J ) )
+ 110 CONTINUE
+ WORK( K ) = WORK( K ) + S
+ 120 CONTINUE
+ ELSE
+ DO 140 K = 1, N
+ S = ABS( X( K, J ) )
+ DO 130 I = 1, K - 1
+ S = S + ABS( A( I, K ) )*ABS( X( I, J ) )
+ 130 CONTINUE
+ WORK( K ) = WORK( K ) + S
+ 140 CONTINUE
+ END IF
+ ELSE
+ IF( NOUNIT ) THEN
+ DO 160 K = 1, N
+ S = ZERO
+ DO 150 I = K, N
+ S = S + ABS( A( I, K ) )*ABS( X( I, J ) )
+ 150 CONTINUE
+ WORK( K ) = WORK( K ) + S
+ 160 CONTINUE
+ ELSE
+ DO 180 K = 1, N
+ S = ABS( X( K, J ) )
+ DO 170 I = K + 1, N
+ S = S + ABS( A( I, K ) )*ABS( X( I, J ) )
+ 170 CONTINUE
+ WORK( K ) = WORK( K ) + S
+ 180 CONTINUE
+ END IF
+ END IF
+ END IF
+ S = ZERO
+ DO 190 I = 1, N
+ IF( WORK( I ).GT.SAFE2 ) THEN
+ S = MAX( S, ABS( WORK( N+I ) ) / WORK( I ) )
+ ELSE
+ S = MAX( S, ( ABS( WORK( N+I ) )+SAFE1 ) /
+ $ ( WORK( I )+SAFE1 ) )
+ END IF
+ 190 CONTINUE
+ BERR( J ) = S
+*
+* Bound error from formula
+*
+* norm(X - XTRUE) / norm(X) .le. FERR =
+* norm( abs(inv(op(A)))*
+* ( abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) ))) / norm(X)
+*
+* where
+* norm(Z) is the magnitude of the largest component of Z
+* inv(op(A)) is the inverse of op(A)
+* abs(Z) is the componentwise absolute value of the matrix or
+* vector Z
+* NZ is the maximum number of nonzeros in any row of A, plus 1
+* EPS is machine epsilon
+*
+* The i-th component of abs(R)+NZ*EPS*(abs(op(A))*abs(X)+abs(B))
+* is incremented by SAFE1 if the i-th component of
+* abs(op(A))*abs(X) + abs(B) is less than SAFE2.
+*
+* Use SLACN2 to estimate the infinity-norm of the matrix
+* inv(op(A)) * diag(W),
+* where W = abs(R) + NZ*EPS*( abs(op(A))*abs(X)+abs(B) )))
+*
+ DO 200 I = 1, N
+ IF( WORK( I ).GT.SAFE2 ) THEN
+ WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I )
+ ELSE
+ WORK( I ) = ABS( WORK( N+I ) ) + NZ*EPS*WORK( I ) + SAFE1
+ END IF
+ 200 CONTINUE
+*
+ KASE = 0
+ 210 CONTINUE
+ CALL SLACN2( N, WORK( 2*N+1 ), WORK( N+1 ), IWORK, FERR( J ),
+ $ KASE, ISAVE )
+ IF( KASE.NE.0 ) THEN
+ IF( KASE.EQ.1 ) THEN
+*
+* Multiply by diag(W)*inv(op(A)').
+*
+ CALL STRSV( UPLO, TRANST, DIAG, N, A, LDA, WORK( N+1 ),
+ $ 1 )
+ DO 220 I = 1, N
+ WORK( N+I ) = WORK( I )*WORK( N+I )
+ 220 CONTINUE
+ ELSE
+*
+* Multiply by inv(op(A))*diag(W).
+*
+ DO 230 I = 1, N
+ WORK( N+I ) = WORK( I )*WORK( N+I )
+ 230 CONTINUE
+ CALL STRSV( UPLO, TRANS, DIAG, N, A, LDA, WORK( N+1 ),
+ $ 1 )
+ END IF
+ GO TO 210
+ END IF
+*
+* Normalize error.
+*
+ LSTRES = ZERO
+ DO 240 I = 1, N
+ LSTRES = MAX( LSTRES, ABS( X( I, J ) ) )
+ 240 CONTINUE
+ IF( LSTRES.NE.ZERO )
+ $ FERR( J ) = FERR( J ) / LSTRES
+*
+ 250 CONTINUE
+*
+ RETURN
+*
+* End of STRRFS
+*
+ END
+ SUBROUTINE STRSEN( JOB, COMPQ, SELECT, N, T, LDT, Q, LDQ, WR, WI,
+ $ M, S, SEP, WORK, LWORK, IWORK, LIWORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* Modified to call SLACN2 in place of SLACON, 7 Feb 03, SJH.
+*
+* .. Scalar Arguments ..
+ CHARACTER COMPQ, JOB
+ INTEGER INFO, LDQ, LDT, LIWORK, LWORK, M, N
+ REAL S, SEP
+* ..
+* .. Array Arguments ..
+ LOGICAL SELECT( * )
+ INTEGER IWORK( * )
+ REAL Q( LDQ, * ), T( LDT, * ), WI( * ), WORK( * ),
+ $ WR( * )
+* ..
+*
+* Purpose
+* =======
+*
+* STRSEN reorders the real Schur factorization of a real matrix
+* A = Q*T*Q**T, so that a selected cluster of eigenvalues appears in
+* the leading diagonal blocks of the upper quasi-triangular matrix T,
+* and the leading columns of Q form an orthonormal basis of the
+* corresponding right invariant subspace.
+*
+* Optionally the routine computes the reciprocal condition numbers of
+* the cluster of eigenvalues and/or the invariant subspace.
+*
+* T must be in Schur canonical form (as returned by SHSEQR), that is,
+* block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; each
+* 2-by-2 diagonal block has its diagonal elemnts equal and its
+* off-diagonal elements of opposite sign.
+*
+* Arguments
+* =========
+*
+* JOB (input) CHARACTER*1
+* Specifies whether condition numbers are required for the
+* cluster of eigenvalues (S) or the invariant subspace (SEP):
+* = 'N': none;
+* = 'E': for eigenvalues only (S);
+* = 'V': for invariant subspace only (SEP);
+* = 'B': for both eigenvalues and invariant subspace (S and
+* SEP).
+*
+* COMPQ (input) CHARACTER*1
+* = 'V': update the matrix Q of Schur vectors;
+* = 'N': do not update Q.
+*
+* SELECT (input) LOGICAL array, dimension (N)
+* SELECT specifies the eigenvalues in the selected cluster. To
+* select a real eigenvalue w(j), SELECT(j) must be set to
+* .TRUE.. To select a complex conjugate pair of eigenvalues
+* w(j) and w(j+1), corresponding to a 2-by-2 diagonal block,
+* either SELECT(j) or SELECT(j+1) or both must be set to
+* .TRUE.; a complex conjugate pair of eigenvalues must be
+* either both included in the cluster or both excluded.
+*
+* N (input) INTEGER
+* The order of the matrix T. N >= 0.
+*
+* T (input/output) REAL array, dimension (LDT,N)
+* On entry, the upper quasi-triangular matrix T, in Schur
+* canonical form.
+* On exit, T is overwritten by the reordered matrix T, again in
+* Schur canonical form, with the selected eigenvalues in the
+* leading diagonal blocks.
+*
+* LDT (input) INTEGER
+* The leading dimension of the array T. LDT >= max(1,N).
+*
+* Q (input/output) REAL array, dimension (LDQ,N)
+* On entry, if COMPQ = 'V', the matrix Q of Schur vectors.
+* On exit, if COMPQ = 'V', Q has been postmultiplied by the
+* orthogonal transformation matrix which reorders T; the
+* leading M columns of Q form an orthonormal basis for the
+* specified invariant subspace.
+* If COMPQ = 'N', Q is not referenced.
+*
+* LDQ (input) INTEGER
+* The leading dimension of the array Q.
+* LDQ >= 1; and if COMPQ = 'V', LDQ >= N.
+*
+* WR (output) REAL array, dimension (N)
+* WI (output) REAL array, dimension (N)
+* The real and imaginary parts, respectively, of the reordered
+* eigenvalues of T. The eigenvalues are stored in the same
+* order as on the diagonal of T, with WR(i) = T(i,i) and, if
+* T(i:i+1,i:i+1) is a 2-by-2 diagonal block, WI(i) > 0 and
+* WI(i+1) = -WI(i). Note that if a complex eigenvalue is
+* sufficiently ill-conditioned, then its value may differ
+* significantly from its value before reordering.
+*
+* M (output) INTEGER
+* The dimension of the specified invariant subspace.
+* 0 < = M <= N.
+*
+* S (output) REAL
+* If JOB = 'E' or 'B', S is a lower bound on the reciprocal
+* condition number for the selected cluster of eigenvalues.
+* S cannot underestimate the true reciprocal condition number
+* by more than a factor of sqrt(N). If M = 0 or N, S = 1.
+* If JOB = 'N' or 'V', S is not referenced.
+*
+* SEP (output) REAL
+* If JOB = 'V' or 'B', SEP is the estimated reciprocal
+* condition number of the specified invariant subspace. If
+* M = 0 or N, SEP = norm(T).
+* If JOB = 'N' or 'E', SEP is not referenced.
+*
+* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))
+* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+* LWORK (input) INTEGER
+* The dimension of the array WORK.
+* If JOB = 'N', LWORK >= max(1,N);
+* if JOB = 'E', LWORK >= max(1,M*(N-M));
+* if JOB = 'V' or 'B', LWORK >= max(1,2*M*(N-M)).
+*
+* If LWORK = -1, then a workspace query is assumed; the routine
+* only calculates the optimal size of the WORK array, returns
+* this value as the first entry of the WORK array, and no error
+* message related to LWORK is issued by XERBLA.
+*
+* IWORK (workspace) INTEGER array, dimension (MAX(1,LIWORK))
+* On exit, if INFO = 0, IWORK(1) returns the optimal LIWORK.
+*
+* LIWORK (input) INTEGER
+* The dimension of the array IWORK.
+* If JOB = 'N' or 'E', LIWORK >= 1;
+* if JOB = 'V' or 'B', LIWORK >= max(1,M*(N-M)).
+*
+* If LIWORK = -1, then a workspace query is assumed; the
+* routine only calculates the optimal size of the IWORK array,
+* returns this value as the first entry of the IWORK array, and
+* no error message related to LIWORK is issued by XERBLA.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* = 1: reordering of T failed because some eigenvalues are too
+* close to separate (the problem is very ill-conditioned);
+* T may have been partially reordered, and WR and WI
+* contain the eigenvalues in the same order as in T; S and
+* SEP (if requested) are set to zero.
+*
+* Further Details
+* ===============
+*
+* STRSEN first collects the selected eigenvalues by computing an
+* orthogonal transformation Z to move them to the top left corner of T.
+* In other words, the selected eigenvalues are the eigenvalues of T11
+* in:
+*
+* Z'*T*Z = ( T11 T12 ) n1
+* ( 0 T22 ) n2
+* n1 n2
+*
+* where N = n1+n2 and Z' means the transpose of Z. The first n1 columns
+* of Z span the specified invariant subspace of T.
+*
+* If T has been obtained from the real Schur factorization of a matrix
+* A = Q*T*Q', then the reordered real Schur factorization of A is given
+* by A = (Q*Z)*(Z'*T*Z)*(Q*Z)', and the first n1 columns of Q*Z span
+* the corresponding invariant subspace of A.
+*
+* The reciprocal condition number of the average of the eigenvalues of
+* T11 may be returned in S. S lies between 0 (very badly conditioned)
+* and 1 (very well conditioned). It is computed as follows. First we
+* compute R so that
+*
+* P = ( I R ) n1
+* ( 0 0 ) n2
+* n1 n2
+*
+* is the projector on the invariant subspace associated with T11.
+* R is the solution of the Sylvester equation:
+*
+* T11*R - R*T22 = T12.
+*
+* Let F-norm(M) denote the Frobenius-norm of M and 2-norm(M) denote
+* the two-norm of M. Then S is computed as the lower bound
+*
+* (1 + F-norm(R)**2)**(-1/2)
+*
+* on the reciprocal of 2-norm(P), the true reciprocal condition number.
+* S cannot underestimate 1 / 2-norm(P) by more than a factor of
+* sqrt(N).
+*
+* An approximate error bound for the computed average of the
+* eigenvalues of T11 is
+*
+* EPS * norm(T) / S
+*
+* where EPS is the machine precision.
+*
+* The reciprocal condition number of the right invariant subspace
+* spanned by the first n1 columns of Z (or of Q*Z) is returned in SEP.
+* SEP is defined as the separation of T11 and T22:
+*
+* sep( T11, T22 ) = sigma-min( C )
+*
+* where sigma-min(C) is the smallest singular value of the
+* n1*n2-by-n1*n2 matrix
+*
+* C = kprod( I(n2), T11 ) - kprod( transpose(T22), I(n1) )
+*
+* I(m) is an m by m identity matrix, and kprod denotes the Kronecker
+* product. We estimate sigma-min(C) by the reciprocal of an estimate of
+* the 1-norm of inverse(C). The true reciprocal 1-norm of inverse(C)
+* cannot differ from sigma-min(C) by more than a factor of sqrt(n1*n2).
+*
+* When SEP is small, small changes in T can cause large changes in
+* the invariant subspace. An approximate bound on the maximum angular
+* error in the computed right invariant subspace is
+*
+* EPS * norm(T) / SEP
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO, ONE
+ PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL LQUERY, PAIR, SWAP, WANTBH, WANTQ, WANTS,
+ $ WANTSP
+ INTEGER IERR, K, KASE, KK, KS, LIWMIN, LWMIN, N1, N2,
+ $ NN
+ REAL EST, RNORM, SCALE
+* ..
+* .. Local Arrays ..
+ INTEGER ISAVE( 3 )
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ REAL SLANGE
+ EXTERNAL LSAME, SLANGE
+* ..
+* .. External Subroutines ..
+ EXTERNAL SLACN2, SLACPY, STREXC, STRSYL, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, SQRT
+* ..
+* .. Executable Statements ..
+*
+* Decode and test the input parameters
+*
+ WANTBH = LSAME( JOB, 'B' )
+ WANTS = LSAME( JOB, 'E' ) .OR. WANTBH
+ WANTSP = LSAME( JOB, 'V' ) .OR. WANTBH
+ WANTQ = LSAME( COMPQ, 'V' )
+*
+ INFO = 0
+ LQUERY = ( LWORK.EQ.-1 )
+ IF( .NOT.LSAME( JOB, 'N' ) .AND. .NOT.WANTS .AND. .NOT.WANTSP )
+ $ THEN
+ INFO = -1
+ ELSE IF( .NOT.LSAME( COMPQ, 'N' ) .AND. .NOT.WANTQ ) THEN
+ INFO = -2
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( LDT.LT.MAX( 1, N ) ) THEN
+ INFO = -6
+ ELSE IF( LDQ.LT.1 .OR. ( WANTQ .AND. LDQ.LT.N ) ) THEN
+ INFO = -8
+ ELSE
+*
+* Set M to the dimension of the specified invariant subspace,
+* and test LWORK and LIWORK.
+*
+ M = 0
+ PAIR = .FALSE.
+ DO 10 K = 1, N
+ IF( PAIR ) THEN
+ PAIR = .FALSE.
+ ELSE
+ IF( K.LT.N ) THEN
+ IF( T( K+1, K ).EQ.ZERO ) THEN
+ IF( SELECT( K ) )
+ $ M = M + 1
+ ELSE
+ PAIR = .TRUE.
+ IF( SELECT( K ) .OR. SELECT( K+1 ) )
+ $ M = M + 2
+ END IF
+ ELSE
+ IF( SELECT( N ) )
+ $ M = M + 1
+ END IF
+ END IF
+ 10 CONTINUE
+*
+ N1 = M
+ N2 = N - M
+ NN = N1*N2
+*
+ IF( WANTSP ) THEN
+ LWMIN = MAX( 1, 2*NN )
+ LIWMIN = MAX( 1, NN )
+ ELSE IF( LSAME( JOB, 'N' ) ) THEN
+ LWMIN = MAX( 1, N )
+ LIWMIN = 1
+ ELSE IF( LSAME( JOB, 'E' ) ) THEN
+ LWMIN = MAX( 1, NN )
+ LIWMIN = 1
+ END IF
+*
+ IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
+ INFO = -15
+ ELSE IF( LIWORK.LT.LIWMIN .AND. .NOT.LQUERY ) THEN
+ INFO = -17
+ END IF
+ END IF
+*
+ IF( INFO.EQ.0 ) THEN
+ WORK( 1 ) = LWMIN
+ IWORK( 1 ) = LIWMIN
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'STRSEN', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible.
+*
+ IF( M.EQ.N .OR. M.EQ.0 ) THEN
+ IF( WANTS )
+ $ S = ONE
+ IF( WANTSP )
+ $ SEP = SLANGE( '1', N, N, T, LDT, WORK )
+ GO TO 40
+ END IF
+*
+* Collect the selected blocks at the top-left corner of T.
+*
+ KS = 0
+ PAIR = .FALSE.
+ DO 20 K = 1, N
+ IF( PAIR ) THEN
+ PAIR = .FALSE.
+ ELSE
+ SWAP = SELECT( K )
+ IF( K.LT.N ) THEN
+ IF( T( K+1, K ).NE.ZERO ) THEN
+ PAIR = .TRUE.
+ SWAP = SWAP .OR. SELECT( K+1 )
+ END IF
+ END IF
+ IF( SWAP ) THEN
+ KS = KS + 1
+*
+* Swap the K-th block to position KS.
+*
+ IERR = 0
+ KK = K
+ IF( K.NE.KS )
+ $ CALL STREXC( COMPQ, N, T, LDT, Q, LDQ, KK, KS, WORK,
+ $ IERR )
+ IF( IERR.EQ.1 .OR. IERR.EQ.2 ) THEN
+*
+* Blocks too close to swap: exit.
+*
+ INFO = 1
+ IF( WANTS )
+ $ S = ZERO
+ IF( WANTSP )
+ $ SEP = ZERO
+ GO TO 40
+ END IF
+ IF( PAIR )
+ $ KS = KS + 1
+ END IF
+ END IF
+ 20 CONTINUE
+*
+ IF( WANTS ) THEN
+*
+* Solve Sylvester equation for R:
+*
+* T11*R - R*T22 = scale*T12
+*
+ CALL SLACPY( 'F', N1, N2, T( 1, N1+1 ), LDT, WORK, N1 )
+ CALL STRSYL( 'N', 'N', -1, N1, N2, T, LDT, T( N1+1, N1+1 ),
+ $ LDT, WORK, N1, SCALE, IERR )
+*
+* Estimate the reciprocal of the condition number of the cluster
+* of eigenvalues.
+*
+ RNORM = SLANGE( 'F', N1, N2, WORK, N1, WORK )
+ IF( RNORM.EQ.ZERO ) THEN
+ S = ONE
+ ELSE
+ S = SCALE / ( SQRT( SCALE*SCALE / RNORM+RNORM )*
+ $ SQRT( RNORM ) )
+ END IF
+ END IF
+*
+ IF( WANTSP ) THEN
+*
+* Estimate sep(T11,T22).
+*
+ EST = ZERO
+ KASE = 0
+ 30 CONTINUE
+ CALL SLACN2( NN, WORK( NN+1 ), WORK, IWORK, EST, KASE, ISAVE )
+ IF( KASE.NE.0 ) THEN
+ IF( KASE.EQ.1 ) THEN
+*
+* Solve T11*R - R*T22 = scale*X.
+*
+ CALL STRSYL( 'N', 'N', -1, N1, N2, T, LDT,
+ $ T( N1+1, N1+1 ), LDT, WORK, N1, SCALE,
+ $ IERR )
+ ELSE
+*
+* Solve T11'*R - R*T22' = scale*X.
+*
+ CALL STRSYL( 'T', 'T', -1, N1, N2, T, LDT,
+ $ T( N1+1, N1+1 ), LDT, WORK, N1, SCALE,
+ $ IERR )
+ END IF
+ GO TO 30
+ END IF
+*
+ SEP = SCALE / EST
+ END IF
+*
+ 40 CONTINUE
+*
+* Store the output eigenvalues in WR and WI.
+*
+ DO 50 K = 1, N
+ WR( K ) = T( K, K )
+ WI( K ) = ZERO
+ 50 CONTINUE
+ DO 60 K = 1, N - 1
+ IF( T( K+1, K ).NE.ZERO ) THEN
+ WI( K ) = SQRT( ABS( T( K, K+1 ) ) )*
+ $ SQRT( ABS( T( K+1, K ) ) )
+ WI( K+1 ) = -WI( K )
+ END IF
+ 60 CONTINUE
+*
+ WORK( 1 ) = LWMIN
+ IWORK( 1 ) = LIWMIN
+*
+ RETURN
+*
+* End of STRSEN
+*
+ END
+ SUBROUTINE STRSNA( JOB, HOWMNY, SELECT, N, T, LDT, VL, LDVL, VR,
+ $ LDVR, S, SEP, MM, M, WORK, LDWORK, IWORK,
+ $ INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* Modified to call SLACN2 in place of SLACON, 7 Feb 03, SJH.
+*
+* .. Scalar Arguments ..
+ CHARACTER HOWMNY, JOB
+ INTEGER INFO, LDT, LDVL, LDVR, LDWORK, M, MM, N
+* ..
+* .. Array Arguments ..
+ LOGICAL SELECT( * )
+ INTEGER IWORK( * )
+ REAL S( * ), SEP( * ), T( LDT, * ), VL( LDVL, * ),
+ $ VR( LDVR, * ), WORK( LDWORK, * )
+* ..
+*
+* Purpose
+* =======
+*
+* STRSNA estimates reciprocal condition numbers for specified
+* eigenvalues and/or right eigenvectors of a real upper
+* quasi-triangular matrix T (or of any matrix Q*T*Q**T with Q
+* orthogonal).
+*
+* T must be in Schur canonical form (as returned by SHSEQR), that is,
+* block upper triangular with 1-by-1 and 2-by-2 diagonal blocks; each
+* 2-by-2 diagonal block has its diagonal elements equal and its
+* off-diagonal elements of opposite sign.
+*
+* Arguments
+* =========
+*
+* JOB (input) CHARACTER*1
+* Specifies whether condition numbers are required for
+* eigenvalues (S) or eigenvectors (SEP):
+* = 'E': for eigenvalues only (S);
+* = 'V': for eigenvectors only (SEP);
+* = 'B': for both eigenvalues and eigenvectors (S and SEP).
+*
+* HOWMNY (input) CHARACTER*1
+* = 'A': compute condition numbers for all eigenpairs;
+* = 'S': compute condition numbers for selected eigenpairs
+* specified by the array SELECT.
+*
+* SELECT (input) LOGICAL array, dimension (N)
+* If HOWMNY = 'S', SELECT specifies the eigenpairs for which
+* condition numbers are required. To select condition numbers
+* for the eigenpair corresponding to a real eigenvalue w(j),
+* SELECT(j) must be set to .TRUE.. To select condition numbers
+* corresponding to a complex conjugate pair of eigenvalues w(j)
+* and w(j+1), either SELECT(j) or SELECT(j+1) or both, must be
+* set to .TRUE..
+* If HOWMNY = 'A', SELECT is not referenced.
+*
+* N (input) INTEGER
+* The order of the matrix T. N >= 0.
+*
+* T (input) REAL array, dimension (LDT,N)
+* The upper quasi-triangular matrix T, in Schur canonical form.
+*
+* LDT (input) INTEGER
+* The leading dimension of the array T. LDT >= max(1,N).
+*
+* VL (input) REAL array, dimension (LDVL,M)
+* If JOB = 'E' or 'B', VL must contain left eigenvectors of T
+* (or of any Q*T*Q**T with Q orthogonal), corresponding to the
+* eigenpairs specified by HOWMNY and SELECT. The eigenvectors
+* must be stored in consecutive columns of VL, as returned by
+* SHSEIN or STREVC.
+* If JOB = 'V', VL is not referenced.
+*
+* LDVL (input) INTEGER
+* The leading dimension of the array VL.
+* LDVL >= 1; and if JOB = 'E' or 'B', LDVL >= N.
+*
+* VR (input) REAL array, dimension (LDVR,M)
+* If JOB = 'E' or 'B', VR must contain right eigenvectors of T
+* (or of any Q*T*Q**T with Q orthogonal), corresponding to the
+* eigenpairs specified by HOWMNY and SELECT. The eigenvectors
+* must be stored in consecutive columns of VR, as returned by
+* SHSEIN or STREVC.
+* If JOB = 'V', VR is not referenced.
+*
+* LDVR (input) INTEGER
+* The leading dimension of the array VR.
+* LDVR >= 1; and if JOB = 'E' or 'B', LDVR >= N.
+*
+* S (output) REAL array, dimension (MM)
+* If JOB = 'E' or 'B', the reciprocal condition numbers of the
+* selected eigenvalues, stored in consecutive elements of the
+* array. For a complex conjugate pair of eigenvalues two
+* consecutive elements of S are set to the same value. Thus
+* S(j), SEP(j), and the j-th columns of VL and VR all
+* correspond to the same eigenpair (but not in general the
+* j-th eigenpair, unless all eigenpairs are selected).
+* If JOB = 'V', S is not referenced.
+*
+* SEP (output) REAL array, dimension (MM)
+* If JOB = 'V' or 'B', the estimated reciprocal condition
+* numbers of the selected eigenvectors, stored in consecutive
+* elements of the array. For a complex eigenvector two
+* consecutive elements of SEP are set to the same value. If
+* the eigenvalues cannot be reordered to compute SEP(j), SEP(j)
+* is set to 0; this can only occur when the true value would be
+* very small anyway.
+* If JOB = 'E', SEP is not referenced.
+*
+* MM (input) INTEGER
+* The number of elements in the arrays S (if JOB = 'E' or 'B')
+* and/or SEP (if JOB = 'V' or 'B'). MM >= M.
+*
+* M (output) INTEGER
+* The number of elements of the arrays S and/or SEP actually
+* used to store the estimated condition numbers.
+* If HOWMNY = 'A', M is set to N.
+*
+* WORK (workspace) REAL array, dimension (LDWORK,N+6)
+* If JOB = 'E', WORK is not referenced.
+*
+* LDWORK (input) INTEGER
+* The leading dimension of the array WORK.
+* LDWORK >= 1; and if JOB = 'V' or 'B', LDWORK >= N.
+*
+* IWORK (workspace) INTEGER array, dimension (2*(N-1))
+* If JOB = 'E', IWORK is not referenced.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+*
+* Further Details
+* ===============
+*
+* The reciprocal of the condition number of an eigenvalue lambda is
+* defined as
+*
+* S(lambda) = |v'*u| / (norm(u)*norm(v))
+*
+* where u and v are the right and left eigenvectors of T corresponding
+* to lambda; v' denotes the conjugate-transpose of v, and norm(u)
+* denotes the Euclidean norm. These reciprocal condition numbers always
+* lie between zero (very badly conditioned) and one (very well
+* conditioned). If n = 1, S(lambda) is defined to be 1.
+*
+* An approximate error bound for a computed eigenvalue W(i) is given by
+*
+* EPS * norm(T) / S(i)
+*
+* where EPS is the machine precision.
+*
+* The reciprocal of the condition number of the right eigenvector u
+* corresponding to lambda is defined as follows. Suppose
+*
+* T = ( lambda c )
+* ( 0 T22 )
+*
+* Then the reciprocal condition number is
+*
+* SEP( lambda, T22 ) = sigma-min( T22 - lambda*I )
+*
+* where sigma-min denotes the smallest singular value. We approximate
+* the smallest singular value by the reciprocal of an estimate of the
+* one-norm of the inverse of T22 - lambda*I. If n = 1, SEP(1) is
+* defined to be abs(T(1,1)).
+*
+* An approximate error bound for a computed right eigenvector VR(i)
+* is given by
+*
+* EPS * norm(T) / SEP(i)
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO, ONE, TWO
+ PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0, TWO = 2.0E+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL PAIR, SOMCON, WANTBH, WANTS, WANTSP
+ INTEGER I, IERR, IFST, ILST, J, K, KASE, KS, N2, NN
+ REAL BIGNUM, COND, CS, DELTA, DUMM, EPS, EST, LNRM,
+ $ MU, PROD, PROD1, PROD2, RNRM, SCALE, SMLNUM, SN
+* ..
+* .. Local Arrays ..
+ INTEGER ISAVE( 3 )
+ REAL DUMMY( 1 )
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ REAL SDOT, SLAMCH, SLAPY2, SNRM2
+ EXTERNAL LSAME, SDOT, SLAMCH, SLAPY2, SNRM2
+* ..
+* .. External Subroutines ..
+ EXTERNAL SLABAD, SLACN2, SLACPY, SLAQTR, STREXC, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, SQRT
+* ..
+* .. Executable Statements ..
+*
+* Decode and test the input parameters
+*
+ WANTBH = LSAME( JOB, 'B' )
+ WANTS = LSAME( JOB, 'E' ) .OR. WANTBH
+ WANTSP = LSAME( JOB, 'V' ) .OR. WANTBH
+*
+ SOMCON = LSAME( HOWMNY, 'S' )
+*
+ INFO = 0
+ IF( .NOT.WANTS .AND. .NOT.WANTSP ) THEN
+ INFO = -1
+ ELSE IF( .NOT.LSAME( HOWMNY, 'A' ) .AND. .NOT.SOMCON ) THEN
+ INFO = -2
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( LDT.LT.MAX( 1, N ) ) THEN
+ INFO = -6
+ ELSE IF( LDVL.LT.1 .OR. ( WANTS .AND. LDVL.LT.N ) ) THEN
+ INFO = -8
+ ELSE IF( LDVR.LT.1 .OR. ( WANTS .AND. LDVR.LT.N ) ) THEN
+ INFO = -10
+ ELSE
+*
+* Set M to the number of eigenpairs for which condition numbers
+* are required, and test MM.
+*
+ IF( SOMCON ) THEN
+ M = 0
+ PAIR = .FALSE.
+ DO 10 K = 1, N
+ IF( PAIR ) THEN
+ PAIR = .FALSE.
+ ELSE
+ IF( K.LT.N ) THEN
+ IF( T( K+1, K ).EQ.ZERO ) THEN
+ IF( SELECT( K ) )
+ $ M = M + 1
+ ELSE
+ PAIR = .TRUE.
+ IF( SELECT( K ) .OR. SELECT( K+1 ) )
+ $ M = M + 2
+ END IF
+ ELSE
+ IF( SELECT( N ) )
+ $ M = M + 1
+ END IF
+ END IF
+ 10 CONTINUE
+ ELSE
+ M = N
+ END IF
+*
+ IF( MM.LT.M ) THEN
+ INFO = -13
+ ELSE IF( LDWORK.LT.1 .OR. ( WANTSP .AND. LDWORK.LT.N ) ) THEN
+ INFO = -16
+ END IF
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'STRSNA', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+ IF( N.EQ.1 ) THEN
+ IF( SOMCON ) THEN
+ IF( .NOT.SELECT( 1 ) )
+ $ RETURN
+ END IF
+ IF( WANTS )
+ $ S( 1 ) = ONE
+ IF( WANTSP )
+ $ SEP( 1 ) = ABS( T( 1, 1 ) )
+ RETURN
+ END IF
+*
+* Get machine constants
+*
+ EPS = SLAMCH( 'P' )
+ SMLNUM = SLAMCH( 'S' ) / EPS
+ BIGNUM = ONE / SMLNUM
+ CALL SLABAD( SMLNUM, BIGNUM )
+*
+ KS = 0
+ PAIR = .FALSE.
+ DO 60 K = 1, N
+*
+* Determine whether T(k,k) begins a 1-by-1 or 2-by-2 block.
+*
+ IF( PAIR ) THEN
+ PAIR = .FALSE.
+ GO TO 60
+ ELSE
+ IF( K.LT.N )
+ $ PAIR = T( K+1, K ).NE.ZERO
+ END IF
+*
+* Determine whether condition numbers are required for the k-th
+* eigenpair.
+*
+ IF( SOMCON ) THEN
+ IF( PAIR ) THEN
+ IF( .NOT.SELECT( K ) .AND. .NOT.SELECT( K+1 ) )
+ $ GO TO 60
+ ELSE
+ IF( .NOT.SELECT( K ) )
+ $ GO TO 60
+ END IF
+ END IF
+*
+ KS = KS + 1
+*
+ IF( WANTS ) THEN
+*
+* Compute the reciprocal condition number of the k-th
+* eigenvalue.
+*
+ IF( .NOT.PAIR ) THEN
+*
+* Real eigenvalue.
+*
+ PROD = SDOT( N, VR( 1, KS ), 1, VL( 1, KS ), 1 )
+ RNRM = SNRM2( N, VR( 1, KS ), 1 )
+ LNRM = SNRM2( N, VL( 1, KS ), 1 )
+ S( KS ) = ABS( PROD ) / ( RNRM*LNRM )
+ ELSE
+*
+* Complex eigenvalue.
+*
+ PROD1 = SDOT( N, VR( 1, KS ), 1, VL( 1, KS ), 1 )
+ PROD1 = PROD1 + SDOT( N, VR( 1, KS+1 ), 1, VL( 1, KS+1 ),
+ $ 1 )
+ PROD2 = SDOT( N, VL( 1, KS ), 1, VR( 1, KS+1 ), 1 )
+ PROD2 = PROD2 - SDOT( N, VL( 1, KS+1 ), 1, VR( 1, KS ),
+ $ 1 )
+ RNRM = SLAPY2( SNRM2( N, VR( 1, KS ), 1 ),
+ $ SNRM2( N, VR( 1, KS+1 ), 1 ) )
+ LNRM = SLAPY2( SNRM2( N, VL( 1, KS ), 1 ),
+ $ SNRM2( N, VL( 1, KS+1 ), 1 ) )
+ COND = SLAPY2( PROD1, PROD2 ) / ( RNRM*LNRM )
+ S( KS ) = COND
+ S( KS+1 ) = COND
+ END IF
+ END IF
+*
+ IF( WANTSP ) THEN
+*
+* Estimate the reciprocal condition number of the k-th
+* eigenvector.
+*
+* Copy the matrix T to the array WORK and swap the diagonal
+* block beginning at T(k,k) to the (1,1) position.
+*
+ CALL SLACPY( 'Full', N, N, T, LDT, WORK, LDWORK )
+ IFST = K
+ ILST = 1
+ CALL STREXC( 'No Q', N, WORK, LDWORK, DUMMY, 1, IFST, ILST,
+ $ WORK( 1, N+1 ), IERR )
+*
+ IF( IERR.EQ.1 .OR. IERR.EQ.2 ) THEN
+*
+* Could not swap because blocks not well separated
+*
+ SCALE = ONE
+ EST = BIGNUM
+ ELSE
+*
+* Reordering successful
+*
+ IF( WORK( 2, 1 ).EQ.ZERO ) THEN
+*
+* Form C = T22 - lambda*I in WORK(2:N,2:N).
+*
+ DO 20 I = 2, N
+ WORK( I, I ) = WORK( I, I ) - WORK( 1, 1 )
+ 20 CONTINUE
+ N2 = 1
+ NN = N - 1
+ ELSE
+*
+* Triangularize the 2 by 2 block by unitary
+* transformation U = [ cs i*ss ]
+* [ i*ss cs ].
+* such that the (1,1) position of WORK is complex
+* eigenvalue lambda with positive imaginary part. (2,2)
+* position of WORK is the complex eigenvalue lambda
+* with negative imaginary part.
+*
+ MU = SQRT( ABS( WORK( 1, 2 ) ) )*
+ $ SQRT( ABS( WORK( 2, 1 ) ) )
+ DELTA = SLAPY2( MU, WORK( 2, 1 ) )
+ CS = MU / DELTA
+ SN = -WORK( 2, 1 ) / DELTA
+*
+* Form
+*
+* C' = WORK(2:N,2:N) + i*[rwork(1) ..... rwork(n-1) ]
+* [ mu ]
+* [ .. ]
+* [ .. ]
+* [ mu ]
+* where C' is conjugate transpose of complex matrix C,
+* and RWORK is stored starting in the N+1-st column of
+* WORK.
+*
+ DO 30 J = 3, N
+ WORK( 2, J ) = CS*WORK( 2, J )
+ WORK( J, J ) = WORK( J, J ) - WORK( 1, 1 )
+ 30 CONTINUE
+ WORK( 2, 2 ) = ZERO
+*
+ WORK( 1, N+1 ) = TWO*MU
+ DO 40 I = 2, N - 1
+ WORK( I, N+1 ) = SN*WORK( 1, I+1 )
+ 40 CONTINUE
+ N2 = 2
+ NN = 2*( N-1 )
+ END IF
+*
+* Estimate norm(inv(C'))
+*
+ EST = ZERO
+ KASE = 0
+ 50 CONTINUE
+ CALL SLACN2( NN, WORK( 1, N+2 ), WORK( 1, N+4 ), IWORK,
+ $ EST, KASE, ISAVE )
+ IF( KASE.NE.0 ) THEN
+ IF( KASE.EQ.1 ) THEN
+ IF( N2.EQ.1 ) THEN
+*
+* Real eigenvalue: solve C'*x = scale*c.
+*
+ CALL SLAQTR( .TRUE., .TRUE., N-1, WORK( 2, 2 ),
+ $ LDWORK, DUMMY, DUMM, SCALE,
+ $ WORK( 1, N+4 ), WORK( 1, N+6 ),
+ $ IERR )
+ ELSE
+*
+* Complex eigenvalue: solve
+* C'*(p+iq) = scale*(c+id) in real arithmetic.
+*
+ CALL SLAQTR( .TRUE., .FALSE., N-1, WORK( 2, 2 ),
+ $ LDWORK, WORK( 1, N+1 ), MU, SCALE,
+ $ WORK( 1, N+4 ), WORK( 1, N+6 ),
+ $ IERR )
+ END IF
+ ELSE
+ IF( N2.EQ.1 ) THEN
+*
+* Real eigenvalue: solve C*x = scale*c.
+*
+ CALL SLAQTR( .FALSE., .TRUE., N-1, WORK( 2, 2 ),
+ $ LDWORK, DUMMY, DUMM, SCALE,
+ $ WORK( 1, N+4 ), WORK( 1, N+6 ),
+ $ IERR )
+ ELSE
+*
+* Complex eigenvalue: solve
+* C*(p+iq) = scale*(c+id) in real arithmetic.
+*
+ CALL SLAQTR( .FALSE., .FALSE., N-1,
+ $ WORK( 2, 2 ), LDWORK,
+ $ WORK( 1, N+1 ), MU, SCALE,
+ $ WORK( 1, N+4 ), WORK( 1, N+6 ),
+ $ IERR )
+*
+ END IF
+ END IF
+*
+ GO TO 50
+ END IF
+ END IF
+*
+ SEP( KS ) = SCALE / MAX( EST, SMLNUM )
+ IF( PAIR )
+ $ SEP( KS+1 ) = SEP( KS )
+ END IF
+*
+ IF( PAIR )
+ $ KS = KS + 1
+*
+ 60 CONTINUE
+ RETURN
+*
+* End of STRSNA
+*
+ END
+ SUBROUTINE STRSYL( TRANA, TRANB, ISGN, M, N, A, LDA, B, LDB, C,
+ $ LDC, SCALE, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER TRANA, TRANB
+ INTEGER INFO, ISGN, LDA, LDB, LDC, M, N
+ REAL SCALE
+* ..
+* .. Array Arguments ..
+ REAL A( LDA, * ), B( LDB, * ), C( LDC, * )
+* ..
+*
+* Purpose
+* =======
+*
+* STRSYL solves the real Sylvester matrix equation:
+*
+* op(A)*X + X*op(B) = scale*C or
+* op(A)*X - X*op(B) = scale*C,
+*
+* where op(A) = A or A**T, and A and B are both upper quasi-
+* triangular. A is M-by-M and B is N-by-N; the right hand side C and
+* the solution X are M-by-N; and scale is an output scale factor, set
+* <= 1 to avoid overflow in X.
+*
+* A and B must be in Schur canonical form (as returned by SHSEQR), that
+* is, block upper triangular with 1-by-1 and 2-by-2 diagonal blocks;
+* each 2-by-2 diagonal block has its diagonal elements equal and its
+* off-diagonal elements of opposite sign.
+*
+* Arguments
+* =========
+*
+* TRANA (input) CHARACTER*1
+* Specifies the option op(A):
+* = 'N': op(A) = A (No transpose)
+* = 'T': op(A) = A**T (Transpose)
+* = 'C': op(A) = A**H (Conjugate transpose = Transpose)
+*
+* TRANB (input) CHARACTER*1
+* Specifies the option op(B):
+* = 'N': op(B) = B (No transpose)
+* = 'T': op(B) = B**T (Transpose)
+* = 'C': op(B) = B**H (Conjugate transpose = Transpose)
+*
+* ISGN (input) INTEGER
+* Specifies the sign in the equation:
+* = +1: solve op(A)*X + X*op(B) = scale*C
+* = -1: solve op(A)*X - X*op(B) = scale*C
+*
+* M (input) INTEGER
+* The order of the matrix A, and the number of rows in the
+* matrices X and C. M >= 0.
+*
+* N (input) INTEGER
+* The order of the matrix B, and the number of columns in the
+* matrices X and C. N >= 0.
+*
+* A (input) REAL array, dimension (LDA,M)
+* The upper quasi-triangular matrix A, in Schur canonical form.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,M).
+*
+* B (input) REAL array, dimension (LDB,N)
+* The upper quasi-triangular matrix B, in Schur canonical form.
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. LDB >= max(1,N).
+*
+* C (input/output) REAL array, dimension (LDC,N)
+* On entry, the M-by-N right hand side matrix C.
+* On exit, C is overwritten by the solution matrix X.
+*
+* LDC (input) INTEGER
+* The leading dimension of the array C. LDC >= max(1,M)
+*
+* SCALE (output) REAL
+* The scale factor, scale, set <= 1 to avoid overflow in X.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* = 1: A and B have common or very close eigenvalues; perturbed
+* values were used to solve the equation (but the matrices
+* A and B are unchanged).
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO, ONE
+ PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL NOTRNA, NOTRNB
+ INTEGER IERR, J, K, K1, K2, KNEXT, L, L1, L2, LNEXT
+ REAL A11, BIGNUM, DA11, DB, EPS, SCALOC, SGN, SMIN,
+ $ SMLNUM, SUML, SUMR, XNORM
+* ..
+* .. Local Arrays ..
+ REAL DUM( 1 ), VEC( 2, 2 ), X( 2, 2 )
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ REAL SDOT, SLAMCH, SLANGE
+ EXTERNAL LSAME, SDOT, SLAMCH, SLANGE
+* ..
+* .. External Subroutines ..
+ EXTERNAL SLABAD, SLALN2, SLASY2, SSCAL, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, MIN, REAL
+* ..
+* .. Executable Statements ..
+*
+* Decode and Test input parameters
+*
+ NOTRNA = LSAME( TRANA, 'N' )
+ NOTRNB = LSAME( TRANB, 'N' )
+*
+ INFO = 0
+ IF( .NOT.NOTRNA .AND. .NOT.LSAME( TRANA, 'T' ) .AND. .NOT.
+ $ LSAME( TRANA, 'C' ) ) THEN
+ INFO = -1
+ ELSE IF( .NOT.NOTRNB .AND. .NOT.LSAME( TRANB, 'T' ) .AND. .NOT.
+ $ LSAME( TRANB, 'C' ) ) THEN
+ INFO = -2
+ ELSE IF( ISGN.NE.1 .AND. ISGN.NE.-1 ) THEN
+ INFO = -3
+ ELSE IF( M.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -5
+ ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+ INFO = -7
+ ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -9
+ ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
+ INFO = -11
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'STRSYL', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( M.EQ.0 .OR. N.EQ.0 )
+ $ RETURN
+*
+* Set constants to control overflow
+*
+ EPS = SLAMCH( 'P' )
+ SMLNUM = SLAMCH( 'S' )
+ BIGNUM = ONE / SMLNUM
+ CALL SLABAD( SMLNUM, BIGNUM )
+ SMLNUM = SMLNUM*REAL( M*N ) / EPS
+ BIGNUM = ONE / SMLNUM
+*
+ SMIN = MAX( SMLNUM, EPS*SLANGE( 'M', M, M, A, LDA, DUM ),
+ $ EPS*SLANGE( 'M', N, N, B, LDB, DUM ) )
+*
+ SCALE = ONE
+ SGN = ISGN
+*
+ IF( NOTRNA .AND. NOTRNB ) THEN
+*
+* Solve A*X + ISGN*X*B = scale*C.
+*
+* The (K,L)th block of X is determined starting from
+* bottom-left corner column by column by
+*
+* A(K,K)*X(K,L) + ISGN*X(K,L)*B(L,L) = C(K,L) - R(K,L)
+*
+* Where
+* M L-1
+* R(K,L) = SUM [A(K,I)*X(I,L)] + ISGN*SUM [X(K,J)*B(J,L)].
+* I=K+1 J=1
+*
+* Start column loop (index = L)
+* L1 (L2) : column index of the first (first) row of X(K,L).
+*
+ LNEXT = 1
+ DO 70 L = 1, N
+ IF( L.LT.LNEXT )
+ $ GO TO 70
+ IF( L.EQ.N ) THEN
+ L1 = L
+ L2 = L
+ ELSE
+ IF( B( L+1, L ).NE.ZERO ) THEN
+ L1 = L
+ L2 = L + 1
+ LNEXT = L + 2
+ ELSE
+ L1 = L
+ L2 = L
+ LNEXT = L + 1
+ END IF
+ END IF
+*
+* Start row loop (index = K)
+* K1 (K2): row index of the first (last) row of X(K,L).
+*
+ KNEXT = M
+ DO 60 K = M, 1, -1
+ IF( K.GT.KNEXT )
+ $ GO TO 60
+ IF( K.EQ.1 ) THEN
+ K1 = K
+ K2 = K
+ ELSE
+ IF( A( K, K-1 ).NE.ZERO ) THEN
+ K1 = K - 1
+ K2 = K
+ KNEXT = K - 2
+ ELSE
+ K1 = K
+ K2 = K
+ KNEXT = K - 1
+ END IF
+ END IF
+*
+ IF( L1.EQ.L2 .AND. K1.EQ.K2 ) THEN
+ SUML = SDOT( M-K1, A( K1, MIN( K1+1, M ) ), LDA,
+ $ C( MIN( K1+1, M ), L1 ), 1 )
+ SUMR = SDOT( L1-1, C( K1, 1 ), LDC, B( 1, L1 ), 1 )
+ VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR )
+ SCALOC = ONE
+*
+ A11 = A( K1, K1 ) + SGN*B( L1, L1 )
+ DA11 = ABS( A11 )
+ IF( DA11.LE.SMIN ) THEN
+ A11 = SMIN
+ DA11 = SMIN
+ INFO = 1
+ END IF
+ DB = ABS( VEC( 1, 1 ) )
+ IF( DA11.LT.ONE .AND. DB.GT.ONE ) THEN
+ IF( DB.GT.BIGNUM*DA11 )
+ $ SCALOC = ONE / DB
+ END IF
+ X( 1, 1 ) = ( VEC( 1, 1 )*SCALOC ) / A11
+*
+ IF( SCALOC.NE.ONE ) THEN
+ DO 10 J = 1, N
+ CALL SSCAL( M, SCALOC, C( 1, J ), 1 )
+ 10 CONTINUE
+ SCALE = SCALE*SCALOC
+ END IF
+ C( K1, L1 ) = X( 1, 1 )
+*
+ ELSE IF( L1.EQ.L2 .AND. K1.NE.K2 ) THEN
+*
+ SUML = SDOT( M-K2, A( K1, MIN( K2+1, M ) ), LDA,
+ $ C( MIN( K2+1, M ), L1 ), 1 )
+ SUMR = SDOT( L1-1, C( K1, 1 ), LDC, B( 1, L1 ), 1 )
+ VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR )
+*
+ SUML = SDOT( M-K2, A( K2, MIN( K2+1, M ) ), LDA,
+ $ C( MIN( K2+1, M ), L1 ), 1 )
+ SUMR = SDOT( L1-1, C( K2, 1 ), LDC, B( 1, L1 ), 1 )
+ VEC( 2, 1 ) = C( K2, L1 ) - ( SUML+SGN*SUMR )
+*
+ CALL SLALN2( .FALSE., 2, 1, SMIN, ONE, A( K1, K1 ),
+ $ LDA, ONE, ONE, VEC, 2, -SGN*B( L1, L1 ),
+ $ ZERO, X, 2, SCALOC, XNORM, IERR )
+ IF( IERR.NE.0 )
+ $ INFO = 1
+*
+ IF( SCALOC.NE.ONE ) THEN
+ DO 20 J = 1, N
+ CALL SSCAL( M, SCALOC, C( 1, J ), 1 )
+ 20 CONTINUE
+ SCALE = SCALE*SCALOC
+ END IF
+ C( K1, L1 ) = X( 1, 1 )
+ C( K2, L1 ) = X( 2, 1 )
+*
+ ELSE IF( L1.NE.L2 .AND. K1.EQ.K2 ) THEN
+*
+ SUML = SDOT( M-K1, A( K1, MIN( K1+1, M ) ), LDA,
+ $ C( MIN( K1+1, M ), L1 ), 1 )
+ SUMR = SDOT( L1-1, C( K1, 1 ), LDC, B( 1, L1 ), 1 )
+ VEC( 1, 1 ) = SGN*( C( K1, L1 )-( SUML+SGN*SUMR ) )
+*
+ SUML = SDOT( M-K1, A( K1, MIN( K1+1, M ) ), LDA,
+ $ C( MIN( K1+1, M ), L2 ), 1 )
+ SUMR = SDOT( L1-1, C( K1, 1 ), LDC, B( 1, L2 ), 1 )
+ VEC( 2, 1 ) = SGN*( C( K1, L2 )-( SUML+SGN*SUMR ) )
+*
+ CALL SLALN2( .TRUE., 2, 1, SMIN, ONE, B( L1, L1 ),
+ $ LDB, ONE, ONE, VEC, 2, -SGN*A( K1, K1 ),
+ $ ZERO, X, 2, SCALOC, XNORM, IERR )
+ IF( IERR.NE.0 )
+ $ INFO = 1
+*
+ IF( SCALOC.NE.ONE ) THEN
+ DO 40 J = 1, N
+ CALL SSCAL( M, SCALOC, C( 1, J ), 1 )
+ 40 CONTINUE
+ SCALE = SCALE*SCALOC
+ END IF
+ C( K1, L1 ) = X( 1, 1 )
+ C( K1, L2 ) = X( 2, 1 )
+*
+ ELSE IF( L1.NE.L2 .AND. K1.NE.K2 ) THEN
+*
+ SUML = SDOT( M-K2, A( K1, MIN( K2+1, M ) ), LDA,
+ $ C( MIN( K2+1, M ), L1 ), 1 )
+ SUMR = SDOT( L1-1, C( K1, 1 ), LDC, B( 1, L1 ), 1 )
+ VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR )
+*
+ SUML = SDOT( M-K2, A( K1, MIN( K2+1, M ) ), LDA,
+ $ C( MIN( K2+1, M ), L2 ), 1 )
+ SUMR = SDOT( L1-1, C( K1, 1 ), LDC, B( 1, L2 ), 1 )
+ VEC( 1, 2 ) = C( K1, L2 ) - ( SUML+SGN*SUMR )
+*
+ SUML = SDOT( M-K2, A( K2, MIN( K2+1, M ) ), LDA,
+ $ C( MIN( K2+1, M ), L1 ), 1 )
+ SUMR = SDOT( L1-1, C( K2, 1 ), LDC, B( 1, L1 ), 1 )
+ VEC( 2, 1 ) = C( K2, L1 ) - ( SUML+SGN*SUMR )
+*
+ SUML = SDOT( M-K2, A( K2, MIN( K2+1, M ) ), LDA,
+ $ C( MIN( K2+1, M ), L2 ), 1 )
+ SUMR = SDOT( L1-1, C( K2, 1 ), LDC, B( 1, L2 ), 1 )
+ VEC( 2, 2 ) = C( K2, L2 ) - ( SUML+SGN*SUMR )
+*
+ CALL SLASY2( .FALSE., .FALSE., ISGN, 2, 2,
+ $ A( K1, K1 ), LDA, B( L1, L1 ), LDB, VEC,
+ $ 2, SCALOC, X, 2, XNORM, IERR )
+ IF( IERR.NE.0 )
+ $ INFO = 1
+*
+ IF( SCALOC.NE.ONE ) THEN
+ DO 50 J = 1, N
+ CALL SSCAL( M, SCALOC, C( 1, J ), 1 )
+ 50 CONTINUE
+ SCALE = SCALE*SCALOC
+ END IF
+ C( K1, L1 ) = X( 1, 1 )
+ C( K1, L2 ) = X( 1, 2 )
+ C( K2, L1 ) = X( 2, 1 )
+ C( K2, L2 ) = X( 2, 2 )
+ END IF
+*
+ 60 CONTINUE
+*
+ 70 CONTINUE
+*
+ ELSE IF( .NOT.NOTRNA .AND. NOTRNB ) THEN
+*
+* Solve A' *X + ISGN*X*B = scale*C.
+*
+* The (K,L)th block of X is determined starting from
+* upper-left corner column by column by
+*
+* A(K,K)'*X(K,L) + ISGN*X(K,L)*B(L,L) = C(K,L) - R(K,L)
+*
+* Where
+* K-1 L-1
+* R(K,L) = SUM [A(I,K)'*X(I,L)] +ISGN*SUM [X(K,J)*B(J,L)]
+* I=1 J=1
+*
+* Start column loop (index = L)
+* L1 (L2): column index of the first (last) row of X(K,L)
+*
+ LNEXT = 1
+ DO 130 L = 1, N
+ IF( L.LT.LNEXT )
+ $ GO TO 130
+ IF( L.EQ.N ) THEN
+ L1 = L
+ L2 = L
+ ELSE
+ IF( B( L+1, L ).NE.ZERO ) THEN
+ L1 = L
+ L2 = L + 1
+ LNEXT = L + 2
+ ELSE
+ L1 = L
+ L2 = L
+ LNEXT = L + 1
+ END IF
+ END IF
+*
+* Start row loop (index = K)
+* K1 (K2): row index of the first (last) row of X(K,L)
+*
+ KNEXT = 1
+ DO 120 K = 1, M
+ IF( K.LT.KNEXT )
+ $ GO TO 120
+ IF( K.EQ.M ) THEN
+ K1 = K
+ K2 = K
+ ELSE
+ IF( A( K+1, K ).NE.ZERO ) THEN
+ K1 = K
+ K2 = K + 1
+ KNEXT = K + 2
+ ELSE
+ K1 = K
+ K2 = K
+ KNEXT = K + 1
+ END IF
+ END IF
+*
+ IF( L1.EQ.L2 .AND. K1.EQ.K2 ) THEN
+ SUML = SDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 )
+ SUMR = SDOT( L1-1, C( K1, 1 ), LDC, B( 1, L1 ), 1 )
+ VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR )
+ SCALOC = ONE
+*
+ A11 = A( K1, K1 ) + SGN*B( L1, L1 )
+ DA11 = ABS( A11 )
+ IF( DA11.LE.SMIN ) THEN
+ A11 = SMIN
+ DA11 = SMIN
+ INFO = 1
+ END IF
+ DB = ABS( VEC( 1, 1 ) )
+ IF( DA11.LT.ONE .AND. DB.GT.ONE ) THEN
+ IF( DB.GT.BIGNUM*DA11 )
+ $ SCALOC = ONE / DB
+ END IF
+ X( 1, 1 ) = ( VEC( 1, 1 )*SCALOC ) / A11
+*
+ IF( SCALOC.NE.ONE ) THEN
+ DO 80 J = 1, N
+ CALL SSCAL( M, SCALOC, C( 1, J ), 1 )
+ 80 CONTINUE
+ SCALE = SCALE*SCALOC
+ END IF
+ C( K1, L1 ) = X( 1, 1 )
+*
+ ELSE IF( L1.EQ.L2 .AND. K1.NE.K2 ) THEN
+*
+ SUML = SDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 )
+ SUMR = SDOT( L1-1, C( K1, 1 ), LDC, B( 1, L1 ), 1 )
+ VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR )
+*
+ SUML = SDOT( K1-1, A( 1, K2 ), 1, C( 1, L1 ), 1 )
+ SUMR = SDOT( L1-1, C( K2, 1 ), LDC, B( 1, L1 ), 1 )
+ VEC( 2, 1 ) = C( K2, L1 ) - ( SUML+SGN*SUMR )
+*
+ CALL SLALN2( .TRUE., 2, 1, SMIN, ONE, A( K1, K1 ),
+ $ LDA, ONE, ONE, VEC, 2, -SGN*B( L1, L1 ),
+ $ ZERO, X, 2, SCALOC, XNORM, IERR )
+ IF( IERR.NE.0 )
+ $ INFO = 1
+*
+ IF( SCALOC.NE.ONE ) THEN
+ DO 90 J = 1, N
+ CALL SSCAL( M, SCALOC, C( 1, J ), 1 )
+ 90 CONTINUE
+ SCALE = SCALE*SCALOC
+ END IF
+ C( K1, L1 ) = X( 1, 1 )
+ C( K2, L1 ) = X( 2, 1 )
+*
+ ELSE IF( L1.NE.L2 .AND. K1.EQ.K2 ) THEN
+*
+ SUML = SDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 )
+ SUMR = SDOT( L1-1, C( K1, 1 ), LDC, B( 1, L1 ), 1 )
+ VEC( 1, 1 ) = SGN*( C( K1, L1 )-( SUML+SGN*SUMR ) )
+*
+ SUML = SDOT( K1-1, A( 1, K1 ), 1, C( 1, L2 ), 1 )
+ SUMR = SDOT( L1-1, C( K1, 1 ), LDC, B( 1, L2 ), 1 )
+ VEC( 2, 1 ) = SGN*( C( K1, L2 )-( SUML+SGN*SUMR ) )
+*
+ CALL SLALN2( .TRUE., 2, 1, SMIN, ONE, B( L1, L1 ),
+ $ LDB, ONE, ONE, VEC, 2, -SGN*A( K1, K1 ),
+ $ ZERO, X, 2, SCALOC, XNORM, IERR )
+ IF( IERR.NE.0 )
+ $ INFO = 1
+*
+ IF( SCALOC.NE.ONE ) THEN
+ DO 100 J = 1, N
+ CALL SSCAL( M, SCALOC, C( 1, J ), 1 )
+ 100 CONTINUE
+ SCALE = SCALE*SCALOC
+ END IF
+ C( K1, L1 ) = X( 1, 1 )
+ C( K1, L2 ) = X( 2, 1 )
+*
+ ELSE IF( L1.NE.L2 .AND. K1.NE.K2 ) THEN
+*
+ SUML = SDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 )
+ SUMR = SDOT( L1-1, C( K1, 1 ), LDC, B( 1, L1 ), 1 )
+ VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR )
+*
+ SUML = SDOT( K1-1, A( 1, K1 ), 1, C( 1, L2 ), 1 )
+ SUMR = SDOT( L1-1, C( K1, 1 ), LDC, B( 1, L2 ), 1 )
+ VEC( 1, 2 ) = C( K1, L2 ) - ( SUML+SGN*SUMR )
+*
+ SUML = SDOT( K1-1, A( 1, K2 ), 1, C( 1, L1 ), 1 )
+ SUMR = SDOT( L1-1, C( K2, 1 ), LDC, B( 1, L1 ), 1 )
+ VEC( 2, 1 ) = C( K2, L1 ) - ( SUML+SGN*SUMR )
+*
+ SUML = SDOT( K1-1, A( 1, K2 ), 1, C( 1, L2 ), 1 )
+ SUMR = SDOT( L1-1, C( K2, 1 ), LDC, B( 1, L2 ), 1 )
+ VEC( 2, 2 ) = C( K2, L2 ) - ( SUML+SGN*SUMR )
+*
+ CALL SLASY2( .TRUE., .FALSE., ISGN, 2, 2, A( K1, K1 ),
+ $ LDA, B( L1, L1 ), LDB, VEC, 2, SCALOC, X,
+ $ 2, XNORM, IERR )
+ IF( IERR.NE.0 )
+ $ INFO = 1
+*
+ IF( SCALOC.NE.ONE ) THEN
+ DO 110 J = 1, N
+ CALL SSCAL( M, SCALOC, C( 1, J ), 1 )
+ 110 CONTINUE
+ SCALE = SCALE*SCALOC
+ END IF
+ C( K1, L1 ) = X( 1, 1 )
+ C( K1, L2 ) = X( 1, 2 )
+ C( K2, L1 ) = X( 2, 1 )
+ C( K2, L2 ) = X( 2, 2 )
+ END IF
+*
+ 120 CONTINUE
+ 130 CONTINUE
+*
+ ELSE IF( .NOT.NOTRNA .AND. .NOT.NOTRNB ) THEN
+*
+* Solve A'*X + ISGN*X*B' = scale*C.
+*
+* The (K,L)th block of X is determined starting from
+* top-right corner column by column by
+*
+* A(K,K)'*X(K,L) + ISGN*X(K,L)*B(L,L)' = C(K,L) - R(K,L)
+*
+* Where
+* K-1 N
+* R(K,L) = SUM [A(I,K)'*X(I,L)] + ISGN*SUM [X(K,J)*B(L,J)'].
+* I=1 J=L+1
+*
+* Start column loop (index = L)
+* L1 (L2): column index of the first (last) row of X(K,L)
+*
+ LNEXT = N
+ DO 190 L = N, 1, -1
+ IF( L.GT.LNEXT )
+ $ GO TO 190
+ IF( L.EQ.1 ) THEN
+ L1 = L
+ L2 = L
+ ELSE
+ IF( B( L, L-1 ).NE.ZERO ) THEN
+ L1 = L - 1
+ L2 = L
+ LNEXT = L - 2
+ ELSE
+ L1 = L
+ L2 = L
+ LNEXT = L - 1
+ END IF
+ END IF
+*
+* Start row loop (index = K)
+* K1 (K2): row index of the first (last) row of X(K,L)
+*
+ KNEXT = 1
+ DO 180 K = 1, M
+ IF( K.LT.KNEXT )
+ $ GO TO 180
+ IF( K.EQ.M ) THEN
+ K1 = K
+ K2 = K
+ ELSE
+ IF( A( K+1, K ).NE.ZERO ) THEN
+ K1 = K
+ K2 = K + 1
+ KNEXT = K + 2
+ ELSE
+ K1 = K
+ K2 = K
+ KNEXT = K + 1
+ END IF
+ END IF
+*
+ IF( L1.EQ.L2 .AND. K1.EQ.K2 ) THEN
+ SUML = SDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 )
+ SUMR = SDOT( N-L1, C( K1, MIN( L1+1, N ) ), LDC,
+ $ B( L1, MIN( L1+1, N ) ), LDB )
+ VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR )
+ SCALOC = ONE
+*
+ A11 = A( K1, K1 ) + SGN*B( L1, L1 )
+ DA11 = ABS( A11 )
+ IF( DA11.LE.SMIN ) THEN
+ A11 = SMIN
+ DA11 = SMIN
+ INFO = 1
+ END IF
+ DB = ABS( VEC( 1, 1 ) )
+ IF( DA11.LT.ONE .AND. DB.GT.ONE ) THEN
+ IF( DB.GT.BIGNUM*DA11 )
+ $ SCALOC = ONE / DB
+ END IF
+ X( 1, 1 ) = ( VEC( 1, 1 )*SCALOC ) / A11
+*
+ IF( SCALOC.NE.ONE ) THEN
+ DO 140 J = 1, N
+ CALL SSCAL( M, SCALOC, C( 1, J ), 1 )
+ 140 CONTINUE
+ SCALE = SCALE*SCALOC
+ END IF
+ C( K1, L1 ) = X( 1, 1 )
+*
+ ELSE IF( L1.EQ.L2 .AND. K1.NE.K2 ) THEN
+*
+ SUML = SDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 )
+ SUMR = SDOT( N-L2, C( K1, MIN( L2+1, N ) ), LDC,
+ $ B( L1, MIN( L2+1, N ) ), LDB )
+ VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR )
+*
+ SUML = SDOT( K1-1, A( 1, K2 ), 1, C( 1, L1 ), 1 )
+ SUMR = SDOT( N-L2, C( K2, MIN( L2+1, N ) ), LDC,
+ $ B( L1, MIN( L2+1, N ) ), LDB )
+ VEC( 2, 1 ) = C( K2, L1 ) - ( SUML+SGN*SUMR )
+*
+ CALL SLALN2( .TRUE., 2, 1, SMIN, ONE, A( K1, K1 ),
+ $ LDA, ONE, ONE, VEC, 2, -SGN*B( L1, L1 ),
+ $ ZERO, X, 2, SCALOC, XNORM, IERR )
+ IF( IERR.NE.0 )
+ $ INFO = 1
+*
+ IF( SCALOC.NE.ONE ) THEN
+ DO 150 J = 1, N
+ CALL SSCAL( M, SCALOC, C( 1, J ), 1 )
+ 150 CONTINUE
+ SCALE = SCALE*SCALOC
+ END IF
+ C( K1, L1 ) = X( 1, 1 )
+ C( K2, L1 ) = X( 2, 1 )
+*
+ ELSE IF( L1.NE.L2 .AND. K1.EQ.K2 ) THEN
+*
+ SUML = SDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 )
+ SUMR = SDOT( N-L2, C( K1, MIN( L2+1, N ) ), LDC,
+ $ B( L1, MIN( L2+1, N ) ), LDB )
+ VEC( 1, 1 ) = SGN*( C( K1, L1 )-( SUML+SGN*SUMR ) )
+*
+ SUML = SDOT( K1-1, A( 1, K1 ), 1, C( 1, L2 ), 1 )
+ SUMR = SDOT( N-L2, C( K1, MIN( L2+1, N ) ), LDC,
+ $ B( L2, MIN( L2+1, N ) ), LDB )
+ VEC( 2, 1 ) = SGN*( C( K1, L2 )-( SUML+SGN*SUMR ) )
+*
+ CALL SLALN2( .FALSE., 2, 1, SMIN, ONE, B( L1, L1 ),
+ $ LDB, ONE, ONE, VEC, 2, -SGN*A( K1, K1 ),
+ $ ZERO, X, 2, SCALOC, XNORM, IERR )
+ IF( IERR.NE.0 )
+ $ INFO = 1
+*
+ IF( SCALOC.NE.ONE ) THEN
+ DO 160 J = 1, N
+ CALL SSCAL( M, SCALOC, C( 1, J ), 1 )
+ 160 CONTINUE
+ SCALE = SCALE*SCALOC
+ END IF
+ C( K1, L1 ) = X( 1, 1 )
+ C( K1, L2 ) = X( 2, 1 )
+*
+ ELSE IF( L1.NE.L2 .AND. K1.NE.K2 ) THEN
+*
+ SUML = SDOT( K1-1, A( 1, K1 ), 1, C( 1, L1 ), 1 )
+ SUMR = SDOT( N-L2, C( K1, MIN( L2+1, N ) ), LDC,
+ $ B( L1, MIN( L2+1, N ) ), LDB )
+ VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR )
+*
+ SUML = SDOT( K1-1, A( 1, K1 ), 1, C( 1, L2 ), 1 )
+ SUMR = SDOT( N-L2, C( K1, MIN( L2+1, N ) ), LDC,
+ $ B( L2, MIN( L2+1, N ) ), LDB )
+ VEC( 1, 2 ) = C( K1, L2 ) - ( SUML+SGN*SUMR )
+*
+ SUML = SDOT( K1-1, A( 1, K2 ), 1, C( 1, L1 ), 1 )
+ SUMR = SDOT( N-L2, C( K2, MIN( L2+1, N ) ), LDC,
+ $ B( L1, MIN( L2+1, N ) ), LDB )
+ VEC( 2, 1 ) = C( K2, L1 ) - ( SUML+SGN*SUMR )
+*
+ SUML = SDOT( K1-1, A( 1, K2 ), 1, C( 1, L2 ), 1 )
+ SUMR = SDOT( N-L2, C( K2, MIN( L2+1, N ) ), LDC,
+ $ B( L2, MIN(L2+1, N ) ), LDB )
+ VEC( 2, 2 ) = C( K2, L2 ) - ( SUML+SGN*SUMR )
+*
+ CALL SLASY2( .TRUE., .TRUE., ISGN, 2, 2, A( K1, K1 ),
+ $ LDA, B( L1, L1 ), LDB, VEC, 2, SCALOC, X,
+ $ 2, XNORM, IERR )
+ IF( IERR.NE.0 )
+ $ INFO = 1
+*
+ IF( SCALOC.NE.ONE ) THEN
+ DO 170 J = 1, N
+ CALL SSCAL( M, SCALOC, C( 1, J ), 1 )
+ 170 CONTINUE
+ SCALE = SCALE*SCALOC
+ END IF
+ C( K1, L1 ) = X( 1, 1 )
+ C( K1, L2 ) = X( 1, 2 )
+ C( K2, L1 ) = X( 2, 1 )
+ C( K2, L2 ) = X( 2, 2 )
+ END IF
+*
+ 180 CONTINUE
+ 190 CONTINUE
+*
+ ELSE IF( NOTRNA .AND. .NOT.NOTRNB ) THEN
+*
+* Solve A*X + ISGN*X*B' = scale*C.
+*
+* The (K,L)th block of X is determined starting from
+* bottom-right corner column by column by
+*
+* A(K,K)*X(K,L) + ISGN*X(K,L)*B(L,L)' = C(K,L) - R(K,L)
+*
+* Where
+* M N
+* R(K,L) = SUM [A(K,I)*X(I,L)] + ISGN*SUM [X(K,J)*B(L,J)'].
+* I=K+1 J=L+1
+*
+* Start column loop (index = L)
+* L1 (L2): column index of the first (last) row of X(K,L)
+*
+ LNEXT = N
+ DO 250 L = N, 1, -1
+ IF( L.GT.LNEXT )
+ $ GO TO 250
+ IF( L.EQ.1 ) THEN
+ L1 = L
+ L2 = L
+ ELSE
+ IF( B( L, L-1 ).NE.ZERO ) THEN
+ L1 = L - 1
+ L2 = L
+ LNEXT = L - 2
+ ELSE
+ L1 = L
+ L2 = L
+ LNEXT = L - 1
+ END IF
+ END IF
+*
+* Start row loop (index = K)
+* K1 (K2): row index of the first (last) row of X(K,L)
+*
+ KNEXT = M
+ DO 240 K = M, 1, -1
+ IF( K.GT.KNEXT )
+ $ GO TO 240
+ IF( K.EQ.1 ) THEN
+ K1 = K
+ K2 = K
+ ELSE
+ IF( A( K, K-1 ).NE.ZERO ) THEN
+ K1 = K - 1
+ K2 = K
+ KNEXT = K - 2
+ ELSE
+ K1 = K
+ K2 = K
+ KNEXT = K - 1
+ END IF
+ END IF
+*
+ IF( L1.EQ.L2 .AND. K1.EQ.K2 ) THEN
+ SUML = SDOT( M-K1, A( K1, MIN(K1+1, M ) ), LDA,
+ $ C( MIN( K1+1, M ), L1 ), 1 )
+ SUMR = SDOT( N-L1, C( K1, MIN( L1+1, N ) ), LDC,
+ $ B( L1, MIN( L1+1, N ) ), LDB )
+ VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR )
+ SCALOC = ONE
+*
+ A11 = A( K1, K1 ) + SGN*B( L1, L1 )
+ DA11 = ABS( A11 )
+ IF( DA11.LE.SMIN ) THEN
+ A11 = SMIN
+ DA11 = SMIN
+ INFO = 1
+ END IF
+ DB = ABS( VEC( 1, 1 ) )
+ IF( DA11.LT.ONE .AND. DB.GT.ONE ) THEN
+ IF( DB.GT.BIGNUM*DA11 )
+ $ SCALOC = ONE / DB
+ END IF
+ X( 1, 1 ) = ( VEC( 1, 1 )*SCALOC ) / A11
+*
+ IF( SCALOC.NE.ONE ) THEN
+ DO 200 J = 1, N
+ CALL SSCAL( M, SCALOC, C( 1, J ), 1 )
+ 200 CONTINUE
+ SCALE = SCALE*SCALOC
+ END IF
+ C( K1, L1 ) = X( 1, 1 )
+*
+ ELSE IF( L1.EQ.L2 .AND. K1.NE.K2 ) THEN
+*
+ SUML = SDOT( M-K2, A( K1, MIN( K2+1, M ) ), LDA,
+ $ C( MIN( K2+1, M ), L1 ), 1 )
+ SUMR = SDOT( N-L2, C( K1, MIN( L2+1, N ) ), LDC,
+ $ B( L1, MIN( L2+1, N ) ), LDB )
+ VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR )
+*
+ SUML = SDOT( M-K2, A( K2, MIN( K2+1, M ) ), LDA,
+ $ C( MIN( K2+1, M ), L1 ), 1 )
+ SUMR = SDOT( N-L2, C( K2, MIN( L2+1, N ) ), LDC,
+ $ B( L1, MIN( L2+1, N ) ), LDB )
+ VEC( 2, 1 ) = C( K2, L1 ) - ( SUML+SGN*SUMR )
+*
+ CALL SLALN2( .FALSE., 2, 1, SMIN, ONE, A( K1, K1 ),
+ $ LDA, ONE, ONE, VEC, 2, -SGN*B( L1, L1 ),
+ $ ZERO, X, 2, SCALOC, XNORM, IERR )
+ IF( IERR.NE.0 )
+ $ INFO = 1
+*
+ IF( SCALOC.NE.ONE ) THEN
+ DO 210 J = 1, N
+ CALL SSCAL( M, SCALOC, C( 1, J ), 1 )
+ 210 CONTINUE
+ SCALE = SCALE*SCALOC
+ END IF
+ C( K1, L1 ) = X( 1, 1 )
+ C( K2, L1 ) = X( 2, 1 )
+*
+ ELSE IF( L1.NE.L2 .AND. K1.EQ.K2 ) THEN
+*
+ SUML = SDOT( M-K1, A( K1, MIN( K1+1, M ) ), LDA,
+ $ C( MIN( K1+1, M ), L1 ), 1 )
+ SUMR = SDOT( N-L2, C( K1, MIN( L2+1, N ) ), LDC,
+ $ B( L1, MIN( L2+1, N ) ), LDB )
+ VEC( 1, 1 ) = SGN*( C( K1, L1 )-( SUML+SGN*SUMR ) )
+*
+ SUML = SDOT( M-K1, A( K1, MIN( K1+1, M ) ), LDA,
+ $ C( MIN( K1+1, M ), L2 ), 1 )
+ SUMR = SDOT( N-L2, C( K1, MIN( L2+1, N ) ), LDC,
+ $ B( L2, MIN( L2+1, N ) ), LDB )
+ VEC( 2, 1 ) = SGN*( C( K1, L2 )-( SUML+SGN*SUMR ) )
+*
+ CALL SLALN2( .FALSE., 2, 1, SMIN, ONE, B( L1, L1 ),
+ $ LDB, ONE, ONE, VEC, 2, -SGN*A( K1, K1 ),
+ $ ZERO, X, 2, SCALOC, XNORM, IERR )
+ IF( IERR.NE.0 )
+ $ INFO = 1
+*
+ IF( SCALOC.NE.ONE ) THEN
+ DO 220 J = 1, N
+ CALL SSCAL( M, SCALOC, C( 1, J ), 1 )
+ 220 CONTINUE
+ SCALE = SCALE*SCALOC
+ END IF
+ C( K1, L1 ) = X( 1, 1 )
+ C( K1, L2 ) = X( 2, 1 )
+*
+ ELSE IF( L1.NE.L2 .AND. K1.NE.K2 ) THEN
+*
+ SUML = SDOT( M-K2, A( K1, MIN( K2+1, M ) ), LDA,
+ $ C( MIN( K2+1, M ), L1 ), 1 )
+ SUMR = SDOT( N-L2, C( K1, MIN( L2+1, N ) ), LDC,
+ $ B( L1, MIN( L2+1, N ) ), LDB )
+ VEC( 1, 1 ) = C( K1, L1 ) - ( SUML+SGN*SUMR )
+*
+ SUML = SDOT( M-K2, A( K1, MIN( K2+1, M ) ), LDA,
+ $ C( MIN( K2+1, M ), L2 ), 1 )
+ SUMR = SDOT( N-L2, C( K1, MIN( L2+1, N ) ), LDC,
+ $ B( L2, MIN( L2+1, N ) ), LDB )
+ VEC( 1, 2 ) = C( K1, L2 ) - ( SUML+SGN*SUMR )
+*
+ SUML = SDOT( M-K2, A( K2, MIN( K2+1, M ) ), LDA,
+ $ C( MIN( K2+1, M ), L1 ), 1 )
+ SUMR = SDOT( N-L2, C( K2, MIN( L2+1, N ) ), LDC,
+ $ B( L1, MIN( L2+1, N ) ), LDB )
+ VEC( 2, 1 ) = C( K2, L1 ) - ( SUML+SGN*SUMR )
+*
+ SUML = SDOT( M-K2, A( K2, MIN( K2+1, M ) ), LDA,
+ $ C( MIN( K2+1, M ), L2 ), 1 )
+ SUMR = SDOT( N-L2, C( K2, MIN( L2+1, N ) ), LDC,
+ $ B( L2, MIN( L2+1, N ) ), LDB )
+ VEC( 2, 2 ) = C( K2, L2 ) - ( SUML+SGN*SUMR )
+*
+ CALL SLASY2( .FALSE., .TRUE., ISGN, 2, 2, A( K1, K1 ),
+ $ LDA, B( L1, L1 ), LDB, VEC, 2, SCALOC, X,
+ $ 2, XNORM, IERR )
+ IF( IERR.NE.0 )
+ $ INFO = 1
+*
+ IF( SCALOC.NE.ONE ) THEN
+ DO 230 J = 1, N
+ CALL SSCAL( M, SCALOC, C( 1, J ), 1 )
+ 230 CONTINUE
+ SCALE = SCALE*SCALOC
+ END IF
+ C( K1, L1 ) = X( 1, 1 )
+ C( K1, L2 ) = X( 1, 2 )
+ C( K2, L1 ) = X( 2, 1 )
+ C( K2, L2 ) = X( 2, 2 )
+ END IF
+*
+ 240 CONTINUE
+ 250 CONTINUE
+*
+ END IF
+*
+ RETURN
+*
+* End of STRSYL
+*
+ END
+ SUBROUTINE STRTI2( UPLO, DIAG, N, A, LDA, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER DIAG, UPLO
+ INTEGER INFO, LDA, N
+* ..
+* .. Array Arguments ..
+ REAL A( LDA, * )
+* ..
+*
+* Purpose
+* =======
+*
+* STRTI2 computes the inverse of a real upper or lower triangular
+* matrix.
+*
+* This is the Level 2 BLAS version of the algorithm.
+*
+* Arguments
+* =========
+*
+* UPLO (input) CHARACTER*1
+* Specifies whether the matrix A is upper or lower triangular.
+* = 'U': Upper triangular
+* = 'L': Lower triangular
+*
+* DIAG (input) CHARACTER*1
+* Specifies whether or not the matrix A is unit triangular.
+* = 'N': Non-unit triangular
+* = 'U': Unit triangular
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* A (input/output) REAL array, dimension (LDA,N)
+* On entry, the triangular matrix A. If UPLO = 'U', the
+* leading n by n upper triangular part of the array A contains
+* the upper triangular matrix, and the strictly lower
+* triangular part of A is not referenced. If UPLO = 'L', the
+* leading n by n lower triangular part of the array A contains
+* the lower triangular matrix, and the strictly upper
+* triangular part of A is not referenced. If DIAG = 'U', the
+* diagonal elements of A are also not referenced and are
+* assumed to be 1.
+*
+* On exit, the (triangular) inverse of the original matrix, in
+* the same storage format.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,N).
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -k, the k-th argument had an illegal value
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ONE
+ PARAMETER ( ONE = 1.0E+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL NOUNIT, UPPER
+ INTEGER J
+ REAL AJJ
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL SSCAL, STRMV, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ NOUNIT = LSAME( DIAG, 'N' )
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
+ INFO = -2
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -5
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'STRTI2', -INFO )
+ RETURN
+ END IF
+*
+ IF( UPPER ) THEN
+*
+* Compute inverse of upper triangular matrix.
+*
+ DO 10 J = 1, N
+ IF( NOUNIT ) THEN
+ A( J, J ) = ONE / A( J, J )
+ AJJ = -A( J, J )
+ ELSE
+ AJJ = -ONE
+ END IF
+*
+* Compute elements 1:j-1 of j-th column.
+*
+ CALL STRMV( 'Upper', 'No transpose', DIAG, J-1, A, LDA,
+ $ A( 1, J ), 1 )
+ CALL SSCAL( J-1, AJJ, A( 1, J ), 1 )
+ 10 CONTINUE
+ ELSE
+*
+* Compute inverse of lower triangular matrix.
+*
+ DO 20 J = N, 1, -1
+ IF( NOUNIT ) THEN
+ A( J, J ) = ONE / A( J, J )
+ AJJ = -A( J, J )
+ ELSE
+ AJJ = -ONE
+ END IF
+ IF( J.LT.N ) THEN
+*
+* Compute elements j+1:n of j-th column.
+*
+ CALL STRMV( 'Lower', 'No transpose', DIAG, N-J,
+ $ A( J+1, J+1 ), LDA, A( J+1, J ), 1 )
+ CALL SSCAL( N-J, AJJ, A( J+1, J ), 1 )
+ END IF
+ 20 CONTINUE
+ END IF
+*
+ RETURN
+*
+* End of STRTI2
+*
+ END
+ SUBROUTINE STRTRI( UPLO, DIAG, N, A, LDA, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER DIAG, UPLO
+ INTEGER INFO, LDA, N
+* ..
+* .. Array Arguments ..
+ REAL A( LDA, * )
+* ..
+*
+* Purpose
+* =======
+*
+* STRTRI computes the inverse of a real upper or lower triangular
+* matrix A.
+*
+* This is the Level 3 BLAS version of the algorithm.
+*
+* Arguments
+* =========
+*
+* UPLO (input) CHARACTER*1
+* = 'U': A is upper triangular;
+* = 'L': A is lower triangular.
+*
+* DIAG (input) CHARACTER*1
+* = 'N': A is non-unit triangular;
+* = 'U': A is unit triangular.
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* A (input/output) REAL array, dimension (LDA,N)
+* On entry, the triangular matrix A. If UPLO = 'U', the
+* leading N-by-N upper triangular part of the array A contains
+* the upper triangular matrix, and the strictly lower
+* triangular part of A is not referenced. If UPLO = 'L', the
+* leading N-by-N lower triangular part of the array A contains
+* the lower triangular matrix, and the strictly upper
+* triangular part of A is not referenced. If DIAG = 'U', the
+* diagonal elements of A are also not referenced and are
+* assumed to be 1.
+* On exit, the (triangular) inverse of the original matrix, in
+* the same storage format.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,N).
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* > 0: if INFO = i, A(i,i) is exactly zero. The triangular
+* matrix is singular and its inverse can not be computed.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ONE, ZERO
+ PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL NOUNIT, UPPER
+ INTEGER J, JB, NB, NN
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER ILAENV
+ EXTERNAL LSAME, ILAENV
+* ..
+* .. External Subroutines ..
+ EXTERNAL STRMM, STRSM, STRTI2, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ UPPER = LSAME( UPLO, 'U' )
+ NOUNIT = LSAME( DIAG, 'N' )
+ IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
+ INFO = -2
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -5
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'STRTRI', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+* Check for singularity if non-unit.
+*
+ IF( NOUNIT ) THEN
+ DO 10 INFO = 1, N
+ IF( A( INFO, INFO ).EQ.ZERO )
+ $ RETURN
+ 10 CONTINUE
+ INFO = 0
+ END IF
+*
+* Determine the block size for this environment.
+*
+ NB = ILAENV( 1, 'STRTRI', UPLO // DIAG, N, -1, -1, -1 )
+ IF( NB.LE.1 .OR. NB.GE.N ) THEN
+*
+* Use unblocked code
+*
+ CALL STRTI2( UPLO, DIAG, N, A, LDA, INFO )
+ ELSE
+*
+* Use blocked code
+*
+ IF( UPPER ) THEN
+*
+* Compute inverse of upper triangular matrix
+*
+ DO 20 J = 1, N, NB
+ JB = MIN( NB, N-J+1 )
+*
+* Compute rows 1:j-1 of current block column
+*
+ CALL STRMM( 'Left', 'Upper', 'No transpose', DIAG, J-1,
+ $ JB, ONE, A, LDA, A( 1, J ), LDA )
+ CALL STRSM( 'Right', 'Upper', 'No transpose', DIAG, J-1,
+ $ JB, -ONE, A( J, J ), LDA, A( 1, J ), LDA )
+*
+* Compute inverse of current diagonal block
+*
+ CALL STRTI2( 'Upper', DIAG, JB, A( J, J ), LDA, INFO )
+ 20 CONTINUE
+ ELSE
+*
+* Compute inverse of lower triangular matrix
+*
+ NN = ( ( N-1 ) / NB )*NB + 1
+ DO 30 J = NN, 1, -NB
+ JB = MIN( NB, N-J+1 )
+ IF( J+JB.LE.N ) THEN
+*
+* Compute rows j+jb:n of current block column
+*
+ CALL STRMM( 'Left', 'Lower', 'No transpose', DIAG,
+ $ N-J-JB+1, JB, ONE, A( J+JB, J+JB ), LDA,
+ $ A( J+JB, J ), LDA )
+ CALL STRSM( 'Right', 'Lower', 'No transpose', DIAG,
+ $ N-J-JB+1, JB, -ONE, A( J, J ), LDA,
+ $ A( J+JB, J ), LDA )
+ END IF
+*
+* Compute inverse of current diagonal block
+*
+ CALL STRTI2( 'Lower', DIAG, JB, A( J, J ), LDA, INFO )
+ 30 CONTINUE
+ END IF
+ END IF
+*
+ RETURN
+*
+* End of STRTRI
+*
+ END
+ SUBROUTINE STRTRS( UPLO, TRANS, DIAG, N, NRHS, A, LDA, B, LDB,
+ $ INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER DIAG, TRANS, UPLO
+ INTEGER INFO, LDA, LDB, N, NRHS
+* ..
+* .. Array Arguments ..
+ REAL A( LDA, * ), B( LDB, * )
+* ..
+*
+* Purpose
+* =======
+*
+* STRTRS solves a triangular system of the form
+*
+* A * X = B or A**T * X = B,
+*
+* where A is a triangular matrix of order N, and B is an N-by-NRHS
+* matrix. A check is made to verify that A is nonsingular.
+*
+* Arguments
+* =========
+*
+* UPLO (input) CHARACTER*1
+* = 'U': A is upper triangular;
+* = 'L': A is lower triangular.
+*
+* TRANS (input) CHARACTER*1
+* Specifies the form of the system of equations:
+* = 'N': A * X = B (No transpose)
+* = 'T': A**T * X = B (Transpose)
+* = 'C': A**H * X = B (Conjugate transpose = Transpose)
+*
+* DIAG (input) CHARACTER*1
+* = 'N': A is non-unit triangular;
+* = 'U': A is unit triangular.
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* NRHS (input) INTEGER
+* The number of right hand sides, i.e., the number of columns
+* of the matrix B. NRHS >= 0.
+*
+* A (input) REAL array, dimension (LDA,N)
+* The triangular matrix A. If UPLO = 'U', the leading N-by-N
+* upper triangular part of the array A contains the upper
+* triangular matrix, and the strictly lower triangular part of
+* A is not referenced. If UPLO = 'L', the leading N-by-N lower
+* triangular part of the array A contains the lower triangular
+* matrix, and the strictly upper triangular part of A is not
+* referenced. If DIAG = 'U', the diagonal elements of A are
+* also not referenced and are assumed to be 1.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,N).
+*
+* B (input/output) REAL array, dimension (LDB,NRHS)
+* On entry, the right hand side matrix B.
+* On exit, if INFO = 0, the solution matrix X.
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. LDB >= max(1,N).
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* > 0: if INFO = i, the i-th diagonal element of A is zero,
+* indicating that the matrix is singular and the solutions
+* X have not been computed.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO, ONE
+ PARAMETER ( ZERO = 0.0E+0, ONE = 1.0E+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL NOUNIT
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL STRSM, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ NOUNIT = LSAME( DIAG, 'N' )
+ IF( .NOT.LSAME( UPLO, 'U' ) .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
+ INFO = -1
+ ELSE IF( .NOT.LSAME( TRANS, 'N' ) .AND. .NOT.
+ $ LSAME( TRANS, 'T' ) .AND. .NOT.LSAME( TRANS, 'C' ) ) THEN
+ INFO = -2
+ ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
+ INFO = -3
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( NRHS.LT.0 ) THEN
+ INFO = -5
+ ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
+ INFO = -7
+ ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
+ INFO = -9
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'STRTRS', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+* Check for singularity.
+*
+ IF( NOUNIT ) THEN
+ DO 10 INFO = 1, N
+ IF( A( INFO, INFO ).EQ.ZERO )
+ $ RETURN
+ 10 CONTINUE
+ END IF
+ INFO = 0
+*
+* Solve A * x = b or A' * x = b.
+*
+ CALL STRSM( 'Left', UPLO, TRANS, DIAG, N, NRHS, ONE, A, LDA, B,
+ $ LDB )
+*
+ RETURN
+*
+* End of STRTRS
+*
+ END
+ SUBROUTINE STZRQF( M, N, A, LDA, TAU, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LDA, M, N
+* ..
+* .. Array Arguments ..
+ REAL A( LDA, * ), TAU( * )
+* ..
+*
+* Purpose
+* =======
+*
+* This routine is deprecated and has been replaced by routine STZRZF.
+*
+* STZRQF reduces the M-by-N ( M<=N ) real upper trapezoidal matrix A
+* to upper triangular form by means of orthogonal transformations.
+*
+* The upper trapezoidal matrix A is factored as
+*
+* A = ( R 0 ) * Z,
+*
+* where Z is an N-by-N orthogonal matrix and R is an M-by-M upper
+* triangular matrix.
+*
+* Arguments
+* =========
+*
+* M (input) INTEGER
+* The number of rows of the matrix A. M >= 0.
+*
+* N (input) INTEGER
+* The number of columns of the matrix A. N >= M.
+*
+* A (input/output) REAL array, dimension (LDA,N)
+* On entry, the leading M-by-N upper trapezoidal part of the
+* array A must contain the matrix to be factorized.
+* On exit, the leading M-by-M upper triangular part of A
+* contains the upper triangular matrix R, and elements M+1 to
+* N of the first M rows of A, with the array TAU, represent the
+* orthogonal matrix Z as a product of M elementary reflectors.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,M).
+*
+* TAU (output) REAL array, dimension (M)
+* The scalar factors of the elementary reflectors.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+*
+* Further Details
+* ===============
+*
+* The factorization is obtained by Householder's method. The kth
+* transformation matrix, Z( k ), which is used to introduce zeros into
+* the ( m - k + 1 )th row of A, is given in the form
+*
+* Z( k ) = ( I 0 ),
+* ( 0 T( k ) )
+*
+* where
+*
+* T( k ) = I - tau*u( k )*u( k )', u( k ) = ( 1 ),
+* ( 0 )
+* ( z( k ) )
+*
+* tau is a scalar and z( k ) is an ( n - m ) element vector.
+* tau and z( k ) are chosen to annihilate the elements of the kth row
+* of X.
+*
+* The scalar tau is returned in the kth element of TAU and the vector
+* u( k ) in the kth row of A, such that the elements of z( k ) are
+* in a( k, m + 1 ), ..., a( k, n ). The elements of R are returned in
+* the upper triangular part of A.
+*
+* Z is given by
+*
+* Z = Z( 1 ) * Z( 2 ) * ... * Z( m ).
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ONE, ZERO
+ PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, K, M1
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN
+* ..
+* .. External Subroutines ..
+ EXTERNAL SAXPY, SCOPY, SGEMV, SGER, SLARFG, XERBLA
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ IF( M.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( N.LT.M ) THEN
+ INFO = -2
+ ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+ INFO = -4
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'STZRQF', -INFO )
+ RETURN
+ END IF
+*
+* Perform the factorization.
+*
+ IF( M.EQ.0 )
+ $ RETURN
+ IF( M.EQ.N ) THEN
+ DO 10 I = 1, N
+ TAU( I ) = ZERO
+ 10 CONTINUE
+ ELSE
+ M1 = MIN( M+1, N )
+ DO 20 K = M, 1, -1
+*
+* Use a Householder reflection to zero the kth row of A.
+* First set up the reflection.
+*
+ CALL SLARFG( N-M+1, A( K, K ), A( K, M1 ), LDA, TAU( K ) )
+*
+ IF( ( TAU( K ).NE.ZERO ) .AND. ( K.GT.1 ) ) THEN
+*
+* We now perform the operation A := A*P( k ).
+*
+* Use the first ( k - 1 ) elements of TAU to store a( k ),
+* where a( k ) consists of the first ( k - 1 ) elements of
+* the kth column of A. Also let B denote the first
+* ( k - 1 ) rows of the last ( n - m ) columns of A.
+*
+ CALL SCOPY( K-1, A( 1, K ), 1, TAU, 1 )
+*
+* Form w = a( k ) + B*z( k ) in TAU.
+*
+ CALL SGEMV( 'No transpose', K-1, N-M, ONE, A( 1, M1 ),
+ $ LDA, A( K, M1 ), LDA, ONE, TAU, 1 )
+*
+* Now form a( k ) := a( k ) - tau*w
+* and B := B - tau*w*z( k )'.
+*
+ CALL SAXPY( K-1, -TAU( K ), TAU, 1, A( 1, K ), 1 )
+ CALL SGER( K-1, N-M, -TAU( K ), TAU, 1, A( K, M1 ), LDA,
+ $ A( 1, M1 ), LDA )
+ END IF
+ 20 CONTINUE
+ END IF
+*
+ RETURN
+*
+* End of STZRQF
+*
+ END
+ SUBROUTINE STZRZF( M, N, A, LDA, TAU, WORK, LWORK, INFO )
+*
+* -- LAPACK routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LDA, LWORK, M, N
+* ..
+* .. Array Arguments ..
+ REAL A( LDA, * ), TAU( * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* STZRZF reduces the M-by-N ( M<=N ) real upper trapezoidal matrix A
+* to upper triangular form by means of orthogonal transformations.
+*
+* The upper trapezoidal matrix A is factored as
+*
+* A = ( R 0 ) * Z,
+*
+* where Z is an N-by-N orthogonal matrix and R is an M-by-M upper
+* triangular matrix.
+*
+* Arguments
+* =========
+*
+* M (input) INTEGER
+* The number of rows of the matrix A. M >= 0.
+*
+* N (input) INTEGER
+* The number of columns of the matrix A. N >= M.
+*
+* A (input/output) REAL array, dimension (LDA,N)
+* On entry, the leading M-by-N upper trapezoidal part of the
+* array A must contain the matrix to be factorized.
+* On exit, the leading M-by-M upper triangular part of A
+* contains the upper triangular matrix R, and elements M+1 to
+* N of the first M rows of A, with the array TAU, represent the
+* orthogonal matrix Z as a product of M elementary reflectors.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,M).
+*
+* TAU (output) REAL array, dimension (M)
+* The scalar factors of the elementary reflectors.
+*
+* WORK (workspace/output) REAL array, dimension (MAX(1,LWORK))
+* On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
+*
+* LWORK (input) INTEGER
+* The dimension of the array WORK. LWORK >= max(1,M).
+* For optimum performance LWORK >= M*NB, where NB is
+* the optimal blocksize.
+*
+* If LWORK = -1, then a workspace query is assumed; the routine
+* only calculates the optimal size of the WORK array, returns
+* this value as the first entry of the WORK array, and no error
+* message related to LWORK is issued by XERBLA.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+*
+* Further Details
+* ===============
+*
+* Based on contributions by
+* A. Petitet, Computer Science Dept., Univ. of Tenn., Knoxville, USA
+*
+* The factorization is obtained by Householder's method. The kth
+* transformation matrix, Z( k ), which is used to introduce zeros into
+* the ( m - k + 1 )th row of A, is given in the form
+*
+* Z( k ) = ( I 0 ),
+* ( 0 T( k ) )
+*
+* where
+*
+* T( k ) = I - tau*u( k )*u( k )', u( k ) = ( 1 ),
+* ( 0 )
+* ( z( k ) )
+*
+* tau is a scalar and z( k ) is an ( n - m ) element vector.
+* tau and z( k ) are chosen to annihilate the elements of the kth row
+* of X.
+*
+* The scalar tau is returned in the kth element of TAU and the vector
+* u( k ) in the kth row of A, such that the elements of z( k ) are
+* in a( k, m + 1 ), ..., a( k, n ). The elements of R are returned in
+* the upper triangular part of A.
+*
+* Z is given by
+*
+* Z = Z( 1 ) * Z( 2 ) * ... * Z( m ).
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO
+ PARAMETER ( ZERO = 0.0E+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL LQUERY
+ INTEGER I, IB, IWS, KI, KK, LDWORK, LWKOPT, M1, MU, NB,
+ $ NBMIN, NX
+* ..
+* .. External Subroutines ..
+ EXTERNAL SLARZB, SLARZT, SLATRZ, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN
+* ..
+* .. External Functions ..
+ INTEGER ILAENV
+ EXTERNAL ILAENV
+* ..
+* .. Executable Statements ..
+*
+* Test the input arguments
+*
+ INFO = 0
+ LQUERY = ( LWORK.EQ.-1 )
+ IF( M.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( N.LT.M ) THEN
+ INFO = -2
+ ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
+ INFO = -4
+ END IF
+*
+ IF( INFO.EQ.0 ) THEN
+ IF( M.EQ.0 .OR. M.EQ.N ) THEN
+ LWKOPT = 1
+ ELSE
+*
+* Determine the block size.
+*
+ NB = ILAENV( 1, 'SGERQF', ' ', M, N, -1, -1 )
+ LWKOPT = M*NB
+ END IF
+ WORK( 1 ) = LWKOPT
+*
+ IF( LWORK.LT.MAX( 1, M ) .AND. .NOT.LQUERY ) THEN
+ INFO = -7
+ END IF
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'STZRZF', -INFO )
+ RETURN
+ ELSE IF( LQUERY ) THEN
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( M.EQ.0 ) THEN
+ RETURN
+ ELSE IF( M.EQ.N ) THEN
+ DO 10 I = 1, N
+ TAU( I ) = ZERO
+ 10 CONTINUE
+ RETURN
+ END IF
+*
+ NBMIN = 2
+ NX = 1
+ IWS = M
+ IF( NB.GT.1 .AND. NB.LT.M ) THEN
+*
+* Determine when to cross over from blocked to unblocked code.
+*
+ NX = MAX( 0, ILAENV( 3, 'SGERQF', ' ', M, N, -1, -1 ) )
+ IF( NX.LT.M ) THEN
+*
+* Determine if workspace is large enough for blocked code.
+*
+ LDWORK = M
+ IWS = LDWORK*NB
+ IF( LWORK.LT.IWS ) THEN
+*
+* Not enough workspace to use optimal NB: reduce NB and
+* determine the minimum value of NB.
+*
+ NB = LWORK / LDWORK
+ NBMIN = MAX( 2, ILAENV( 2, 'SGERQF', ' ', M, N, -1,
+ $ -1 ) )
+ END IF
+ END IF
+ END IF
+*
+ IF( NB.GE.NBMIN .AND. NB.LT.M .AND. NX.LT.M ) THEN
+*
+* Use blocked code initially.
+* The last kk rows are handled by the block method.
+*
+ M1 = MIN( M+1, N )
+ KI = ( ( M-NX-1 ) / NB )*NB
+ KK = MIN( M, KI+NB )
+*
+ DO 20 I = M - KK + KI + 1, M - KK + 1, -NB
+ IB = MIN( M-I+1, NB )
+*
+* Compute the TZ factorization of the current block
+* A(i:i+ib-1,i:n)
+*
+ CALL SLATRZ( IB, N-I+1, N-M, A( I, I ), LDA, TAU( I ),
+ $ WORK )
+ IF( I.GT.1 ) THEN
+*
+* Form the triangular factor of the block reflector
+* H = H(i+ib-1) . . . H(i+1) H(i)
+*
+ CALL SLARZT( 'Backward', 'Rowwise', N-M, IB, A( I, M1 ),
+ $ LDA, TAU( I ), WORK, LDWORK )
+*
+* Apply H to A(1:i-1,i:n) from the right
+*
+ CALL SLARZB( 'Right', 'No transpose', 'Backward',
+ $ 'Rowwise', I-1, N-I+1, IB, N-M, A( I, M1 ),
+ $ LDA, WORK, LDWORK, A( 1, I ), LDA,
+ $ WORK( IB+1 ), LDWORK )
+ END IF
+ 20 CONTINUE
+ MU = I + NB - 1
+ ELSE
+ MU = M
+ END IF
+*
+* Use unblocked code to factor the last or only block
+*
+ IF( MU.GT.0 )
+ $ CALL SLATRZ( MU, N, N-M, A, LDA, TAU, WORK )
+*
+ WORK( 1 ) = LWKOPT
+*
+ RETURN
+*
+* End of STZRZF
+*
+ END
+ DOUBLE PRECISION FUNCTION DLAMCH( CMACH )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER CMACH
+* ..
+*
+* Purpose
+* =======
+*
+* DLAMCH determines double precision machine parameters.
+*
+* Arguments
+* =========
+*
+* CMACH (input) CHARACTER*1
+* Specifies the value to be returned by DLAMCH:
+* = 'E' or 'e', DLAMCH := eps
+* = 'S' or 's , DLAMCH := sfmin
+* = 'B' or 'b', DLAMCH := base
+* = 'P' or 'p', DLAMCH := eps*base
+* = 'N' or 'n', DLAMCH := t
+* = 'R' or 'r', DLAMCH := rnd
+* = 'M' or 'm', DLAMCH := emin
+* = 'U' or 'u', DLAMCH := rmin
+* = 'L' or 'l', DLAMCH := emax
+* = 'O' or 'o', DLAMCH := rmax
+*
+* where
+*
+* eps = relative machine precision
+* sfmin = safe minimum, such that 1/sfmin does not overflow
+* base = base of the machine
+* prec = eps*base
+* t = number of (base) digits in the mantissa
+* rnd = 1.0 when rounding occurs in addition, 0.0 otherwise
+* emin = minimum exponent before (gradual) underflow
+* rmin = underflow threshold - base**(emin-1)
+* emax = largest exponent before overflow
+* rmax = overflow threshold - (base**emax)*(1-eps)
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE, ZERO
+ PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL FIRST, LRND
+ INTEGER BETA, IMAX, IMIN, IT
+ DOUBLE PRECISION BASE, EMAX, EMIN, EPS, PREC, RMACH, RMAX, RMIN,
+ $ RND, SFMIN, SMALL, T
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL DLAMC2
+* ..
+* .. Save statement ..
+ SAVE FIRST, EPS, SFMIN, BASE, T, RND, EMIN, RMIN,
+ $ EMAX, RMAX, PREC
+* ..
+* .. Data statements ..
+ DATA FIRST / .TRUE. /
+* ..
+* .. Executable Statements ..
+*
+ IF( FIRST ) THEN
+ CALL DLAMC2( BETA, IT, LRND, EPS, IMIN, RMIN, IMAX, RMAX )
+ BASE = BETA
+ T = IT
+ IF( LRND ) THEN
+ RND = ONE
+ EPS = ( BASE**( 1-IT ) ) / 2
+ ELSE
+ RND = ZERO
+ EPS = BASE**( 1-IT )
+ END IF
+ PREC = EPS*BASE
+ EMIN = IMIN
+ EMAX = IMAX
+ SFMIN = RMIN
+ SMALL = ONE / RMAX
+ IF( SMALL.GE.SFMIN ) THEN
+*
+* Use SMALL plus a bit, to avoid the possibility of rounding
+* causing overflow when computing 1/sfmin.
+*
+ SFMIN = SMALL*( ONE+EPS )
+ END IF
+ END IF
+*
+ IF( LSAME( CMACH, 'E' ) ) THEN
+ RMACH = EPS
+ ELSE IF( LSAME( CMACH, 'S' ) ) THEN
+ RMACH = SFMIN
+ ELSE IF( LSAME( CMACH, 'B' ) ) THEN
+ RMACH = BASE
+ ELSE IF( LSAME( CMACH, 'P' ) ) THEN
+ RMACH = PREC
+ ELSE IF( LSAME( CMACH, 'N' ) ) THEN
+ RMACH = T
+ ELSE IF( LSAME( CMACH, 'R' ) ) THEN
+ RMACH = RND
+ ELSE IF( LSAME( CMACH, 'M' ) ) THEN
+ RMACH = EMIN
+ ELSE IF( LSAME( CMACH, 'U' ) ) THEN
+ RMACH = RMIN
+ ELSE IF( LSAME( CMACH, 'L' ) ) THEN
+ RMACH = EMAX
+ ELSE IF( LSAME( CMACH, 'O' ) ) THEN
+ RMACH = RMAX
+ END IF
+*
+ DLAMCH = RMACH
+ FIRST = .FALSE.
+ RETURN
+*
+* End of DLAMCH
+*
+ END
+*
+************************************************************************
+*
+ SUBROUTINE DLAMC1( BETA, T, RND, IEEE1 )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ LOGICAL IEEE1, RND
+ INTEGER BETA, T
+* ..
+*
+* Purpose
+* =======
+*
+* DLAMC1 determines the machine parameters given by BETA, T, RND, and
+* IEEE1.
+*
+* Arguments
+* =========
+*
+* BETA (output) INTEGER
+* The base of the machine.
+*
+* T (output) INTEGER
+* The number of ( BETA ) digits in the mantissa.
+*
+* RND (output) LOGICAL
+* Specifies whether proper rounding ( RND = .TRUE. ) or
+* chopping ( RND = .FALSE. ) occurs in addition. This may not
+* be a reliable guide to the way in which the machine performs
+* its arithmetic.
+*
+* IEEE1 (output) LOGICAL
+* Specifies whether rounding appears to be done in the IEEE
+* 'round to nearest' style.
+*
+* Further Details
+* ===============
+*
+* The routine is based on the routine ENVRON by Malcolm and
+* incorporates suggestions by Gentleman and Marovich. See
+*
+* Malcolm M. A. (1972) Algorithms to reveal properties of
+* floating-point arithmetic. Comms. of the ACM, 15, 949-951.
+*
+* Gentleman W. M. and Marovich S. B. (1974) More on algorithms
+* that reveal properties of floating point arithmetic units.
+* Comms. of the ACM, 17, 276-277.
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ LOGICAL FIRST, LIEEE1, LRND
+ INTEGER LBETA, LT
+ DOUBLE PRECISION A, B, C, F, ONE, QTR, SAVEC, T1, T2
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DLAMC3
+ EXTERNAL DLAMC3
+* ..
+* .. Save statement ..
+ SAVE FIRST, LIEEE1, LBETA, LRND, LT
+* ..
+* .. Data statements ..
+ DATA FIRST / .TRUE. /
+* ..
+* .. Executable Statements ..
+*
+ IF( FIRST ) THEN
+ ONE = 1
+*
+* LBETA, LIEEE1, LT and LRND are the local values of BETA,
+* IEEE1, T and RND.
+*
+* Throughout this routine we use the function DLAMC3 to ensure
+* that relevant values are stored and not held in registers, or
+* are not affected by optimizers.
+*
+* Compute a = 2.0**m with the smallest positive integer m such
+* that
+*
+* fl( a + 1.0 ) = a.
+*
+ A = 1
+ C = 1
+*
+*+ WHILE( C.EQ.ONE )LOOP
+ 10 CONTINUE
+ IF( C.EQ.ONE ) THEN
+ A = 2*A
+ C = DLAMC3( A, ONE )
+ C = DLAMC3( C, -A )
+ GO TO 10
+ END IF
+*+ END WHILE
+*
+* Now compute b = 2.0**m with the smallest positive integer m
+* such that
+*
+* fl( a + b ) .gt. a.
+*
+ B = 1
+ C = DLAMC3( A, B )
+*
+*+ WHILE( C.EQ.A )LOOP
+ 20 CONTINUE
+ IF( C.EQ.A ) THEN
+ B = 2*B
+ C = DLAMC3( A, B )
+ GO TO 20
+ END IF
+*+ END WHILE
+*
+* Now compute the base. a and c are neighbouring floating point
+* numbers in the interval ( beta**t, beta**( t + 1 ) ) and so
+* their difference is beta. Adding 0.25 to c is to ensure that it
+* is truncated to beta and not ( beta - 1 ).
+*
+ QTR = ONE / 4
+ SAVEC = C
+ C = DLAMC3( C, -A )
+ LBETA = C + QTR
+*
+* Now determine whether rounding or chopping occurs, by adding a
+* bit less than beta/2 and a bit more than beta/2 to a.
+*
+ B = LBETA
+ F = DLAMC3( B / 2, -B / 100 )
+ C = DLAMC3( F, A )
+ IF( C.EQ.A ) THEN
+ LRND = .TRUE.
+ ELSE
+ LRND = .FALSE.
+ END IF
+ F = DLAMC3( B / 2, B / 100 )
+ C = DLAMC3( F, A )
+ IF( ( LRND ) .AND. ( C.EQ.A ) )
+ $ LRND = .FALSE.
+*
+* Try and decide whether rounding is done in the IEEE 'round to
+* nearest' style. B/2 is half a unit in the last place of the two
+* numbers A and SAVEC. Furthermore, A is even, i.e. has last bit
+* zero, and SAVEC is odd. Thus adding B/2 to A should not change
+* A, but adding B/2 to SAVEC should change SAVEC.
+*
+ T1 = DLAMC3( B / 2, A )
+ T2 = DLAMC3( B / 2, SAVEC )
+ LIEEE1 = ( T1.EQ.A ) .AND. ( T2.GT.SAVEC ) .AND. LRND
+*
+* Now find the mantissa, t. It should be the integer part of
+* log to the base beta of a, however it is safer to determine t
+* by powering. So we find t as the smallest positive integer for
+* which
+*
+* fl( beta**t + 1.0 ) = 1.0.
+*
+ LT = 0
+ A = 1
+ C = 1
+*
+*+ WHILE( C.EQ.ONE )LOOP
+ 30 CONTINUE
+ IF( C.EQ.ONE ) THEN
+ LT = LT + 1
+ A = A*LBETA
+ C = DLAMC3( A, ONE )
+ C = DLAMC3( C, -A )
+ GO TO 30
+ END IF
+*+ END WHILE
+*
+ END IF
+*
+ BETA = LBETA
+ T = LT
+ RND = LRND
+ IEEE1 = LIEEE1
+ FIRST = .FALSE.
+ RETURN
+*
+* End of DLAMC1
+*
+ END
+*
+************************************************************************
+*
+ SUBROUTINE DLAMC2( BETA, T, RND, EPS, EMIN, RMIN, EMAX, RMAX )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ LOGICAL RND
+ INTEGER BETA, EMAX, EMIN, T
+ DOUBLE PRECISION EPS, RMAX, RMIN
+* ..
+*
+* Purpose
+* =======
+*
+* DLAMC2 determines the machine parameters specified in its argument
+* list.
+*
+* Arguments
+* =========
+*
+* BETA (output) INTEGER
+* The base of the machine.
+*
+* T (output) INTEGER
+* The number of ( BETA ) digits in the mantissa.
+*
+* RND (output) LOGICAL
+* Specifies whether proper rounding ( RND = .TRUE. ) or
+* chopping ( RND = .FALSE. ) occurs in addition. This may not
+* be a reliable guide to the way in which the machine performs
+* its arithmetic.
+*
+* EPS (output) DOUBLE PRECISION
+* The smallest positive number such that
+*
+* fl( 1.0 - EPS ) .LT. 1.0,
+*
+* where fl denotes the computed value.
+*
+* EMIN (output) INTEGER
+* The minimum exponent before (gradual) underflow occurs.
+*
+* RMIN (output) DOUBLE PRECISION
+* The smallest normalized number for the machine, given by
+* BASE**( EMIN - 1 ), where BASE is the floating point value
+* of BETA.
+*
+* EMAX (output) INTEGER
+* The maximum exponent before overflow occurs.
+*
+* RMAX (output) DOUBLE PRECISION
+* The largest positive number for the machine, given by
+* BASE**EMAX * ( 1 - EPS ), where BASE is the floating point
+* value of BETA.
+*
+* Further Details
+* ===============
+*
+* The computation of EPS is based on a routine PARANOIA by
+* W. Kahan of the University of California at Berkeley.
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ LOGICAL FIRST, IEEE, IWARN, LIEEE1, LRND
+ INTEGER GNMIN, GPMIN, I, LBETA, LEMAX, LEMIN, LT,
+ $ NGNMIN, NGPMIN
+ DOUBLE PRECISION A, B, C, HALF, LEPS, LRMAX, LRMIN, ONE, RBASE,
+ $ SIXTH, SMALL, THIRD, TWO, ZERO
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DLAMC3
+ EXTERNAL DLAMC3
+* ..
+* .. External Subroutines ..
+ EXTERNAL DLAMC1, DLAMC4, DLAMC5
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, MIN
+* ..
+* .. Save statement ..
+ SAVE FIRST, IWARN, LBETA, LEMAX, LEMIN, LEPS, LRMAX,
+ $ LRMIN, LT
+* ..
+* .. Data statements ..
+ DATA FIRST / .TRUE. / , IWARN / .FALSE. /
+* ..
+* .. Executable Statements ..
+*
+ IF( FIRST ) THEN
+ ZERO = 0
+ ONE = 1
+ TWO = 2
+*
+* LBETA, LT, LRND, LEPS, LEMIN and LRMIN are the local values of
+* BETA, T, RND, EPS, EMIN and RMIN.
+*
+* Throughout this routine we use the function DLAMC3 to ensure
+* that relevant values are stored and not held in registers, or
+* are not affected by optimizers.
+*
+* DLAMC1 returns the parameters LBETA, LT, LRND and LIEEE1.
+*
+ CALL DLAMC1( LBETA, LT, LRND, LIEEE1 )
+*
+* Start to find EPS.
+*
+ B = LBETA
+ A = B**( -LT )
+ LEPS = A
+*
+* Try some tricks to see whether or not this is the correct EPS.
+*
+ B = TWO / 3
+ HALF = ONE / 2
+ SIXTH = DLAMC3( B, -HALF )
+ THIRD = DLAMC3( SIXTH, SIXTH )
+ B = DLAMC3( THIRD, -HALF )
+ B = DLAMC3( B, SIXTH )
+ B = ABS( B )
+ IF( B.LT.LEPS )
+ $ B = LEPS
+*
+ LEPS = 1
+*
+*+ WHILE( ( LEPS.GT.B ).AND.( B.GT.ZERO ) )LOOP
+ 10 CONTINUE
+ IF( ( LEPS.GT.B ) .AND. ( B.GT.ZERO ) ) THEN
+ LEPS = B
+ C = DLAMC3( HALF*LEPS, ( TWO**5 )*( LEPS**2 ) )
+ C = DLAMC3( HALF, -C )
+ B = DLAMC3( HALF, C )
+ C = DLAMC3( HALF, -B )
+ B = DLAMC3( HALF, C )
+ GO TO 10
+ END IF
+*+ END WHILE
+*
+ IF( A.LT.LEPS )
+ $ LEPS = A
+*
+* Computation of EPS complete.
+*
+* Now find EMIN. Let A = + or - 1, and + or - (1 + BASE**(-3)).
+* Keep dividing A by BETA until (gradual) underflow occurs. This
+* is detected when we cannot recover the previous A.
+*
+ RBASE = ONE / LBETA
+ SMALL = ONE
+ DO 20 I = 1, 3
+ SMALL = DLAMC3( SMALL*RBASE, ZERO )
+ 20 CONTINUE
+ A = DLAMC3( ONE, SMALL )
+ CALL DLAMC4( NGPMIN, ONE, LBETA )
+ CALL DLAMC4( NGNMIN, -ONE, LBETA )
+ CALL DLAMC4( GPMIN, A, LBETA )
+ CALL DLAMC4( GNMIN, -A, LBETA )
+ IEEE = .FALSE.
+*
+ IF( ( NGPMIN.EQ.NGNMIN ) .AND. ( GPMIN.EQ.GNMIN ) ) THEN
+ IF( NGPMIN.EQ.GPMIN ) THEN
+ LEMIN = NGPMIN
+* ( Non twos-complement machines, no gradual underflow;
+* e.g., VAX )
+ ELSE IF( ( GPMIN-NGPMIN ).EQ.3 ) THEN
+ LEMIN = NGPMIN - 1 + LT
+ IEEE = .TRUE.
+* ( Non twos-complement machines, with gradual underflow;
+* e.g., IEEE standard followers )
+ ELSE
+ LEMIN = MIN( NGPMIN, GPMIN )
+* ( A guess; no known machine )
+ IWARN = .TRUE.
+ END IF
+*
+ ELSE IF( ( NGPMIN.EQ.GPMIN ) .AND. ( NGNMIN.EQ.GNMIN ) ) THEN
+ IF( ABS( NGPMIN-NGNMIN ).EQ.1 ) THEN
+ LEMIN = MAX( NGPMIN, NGNMIN )
+* ( Twos-complement machines, no gradual underflow;
+* e.g., CYBER 205 )
+ ELSE
+ LEMIN = MIN( NGPMIN, NGNMIN )
+* ( A guess; no known machine )
+ IWARN = .TRUE.
+ END IF
+*
+ ELSE IF( ( ABS( NGPMIN-NGNMIN ).EQ.1 ) .AND.
+ $ ( GPMIN.EQ.GNMIN ) ) THEN
+ IF( ( GPMIN-MIN( NGPMIN, NGNMIN ) ).EQ.3 ) THEN
+ LEMIN = MAX( NGPMIN, NGNMIN ) - 1 + LT
+* ( Twos-complement machines with gradual underflow;
+* no known machine )
+ ELSE
+ LEMIN = MIN( NGPMIN, NGNMIN )
+* ( A guess; no known machine )
+ IWARN = .TRUE.
+ END IF
+*
+ ELSE
+ LEMIN = MIN( NGPMIN, NGNMIN, GPMIN, GNMIN )
+* ( A guess; no known machine )
+ IWARN = .TRUE.
+ END IF
+ FIRST = .FALSE.
+***
+* Comment out this if block if EMIN is ok
+ IF( IWARN ) THEN
+ FIRST = .TRUE.
+ WRITE( 6, FMT = 9999 )LEMIN
+ END IF
+***
+*
+* Assume IEEE arithmetic if we found denormalised numbers above,
+* or if arithmetic seems to round in the IEEE style, determined
+* in routine DLAMC1. A true IEEE machine should have both things
+* true; however, faulty machines may have one or the other.
+*
+ IEEE = IEEE .OR. LIEEE1
+*
+* Compute RMIN by successive division by BETA. We could compute
+* RMIN as BASE**( EMIN - 1 ), but some machines underflow during
+* this computation.
+*
+ LRMIN = 1
+ DO 30 I = 1, 1 - LEMIN
+ LRMIN = DLAMC3( LRMIN*RBASE, ZERO )
+ 30 CONTINUE
+*
+* Finally, call DLAMC5 to compute EMAX and RMAX.
+*
+ CALL DLAMC5( LBETA, LT, LEMIN, IEEE, LEMAX, LRMAX )
+ END IF
+*
+ BETA = LBETA
+ T = LT
+ RND = LRND
+ EPS = LEPS
+ EMIN = LEMIN
+ RMIN = LRMIN
+ EMAX = LEMAX
+ RMAX = LRMAX
+*
+ RETURN
+*
+ 9999 FORMAT( / / ' WARNING. The value EMIN may be incorrect:-',
+ $ ' EMIN = ', I8, /
+ $ ' If, after inspection, the value EMIN looks',
+ $ ' acceptable please comment out ',
+ $ / ' the IF block as marked within the code of routine',
+ $ ' DLAMC2,', / ' otherwise supply EMIN explicitly.', / )
+*
+* End of DLAMC2
+*
+ END
+*
+************************************************************************
+*
+ DOUBLE PRECISION FUNCTION DLAMC3( A, B )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ DOUBLE PRECISION A, B
+* ..
+*
+* Purpose
+* =======
+*
+* DLAMC3 is intended to force A and B to be stored prior to doing
+* the addition of A and B , for use in situations where optimizers
+* might hold one of these in a register.
+*
+* Arguments
+* =========
+*
+* A (input) DOUBLE PRECISION
+* B (input) DOUBLE PRECISION
+* The values A and B.
+*
+* =====================================================================
+*
+* .. Executable Statements ..
+*
+ DLAMC3 = A + B
+*
+ RETURN
+*
+* End of DLAMC3
+*
+ END
+*
+************************************************************************
+*
+ SUBROUTINE DLAMC4( EMIN, START, BASE )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER BASE, EMIN
+ DOUBLE PRECISION START
+* ..
+*
+* Purpose
+* =======
+*
+* DLAMC4 is a service routine for DLAMC2.
+*
+* Arguments
+* =========
+*
+* EMIN (output) INTEGER
+* The minimum exponent before (gradual) underflow, computed by
+* setting A = START and dividing by BASE until the previous A
+* can not be recovered.
+*
+* START (input) DOUBLE PRECISION
+* The starting point for determining EMIN.
+*
+* BASE (input) INTEGER
+* The base of the machine.
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ INTEGER I
+ DOUBLE PRECISION A, B1, B2, C1, C2, D1, D2, ONE, RBASE, ZERO
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DLAMC3
+ EXTERNAL DLAMC3
+* ..
+* .. Executable Statements ..
+*
+ A = START
+ ONE = 1
+ RBASE = ONE / BASE
+ ZERO = 0
+ EMIN = 1
+ B1 = DLAMC3( A*RBASE, ZERO )
+ C1 = A
+ C2 = A
+ D1 = A
+ D2 = A
+*+ WHILE( ( C1.EQ.A ).AND.( C2.EQ.A ).AND.
+* $ ( D1.EQ.A ).AND.( D2.EQ.A ) )LOOP
+ 10 CONTINUE
+ IF( ( C1.EQ.A ) .AND. ( C2.EQ.A ) .AND. ( D1.EQ.A ) .AND.
+ $ ( D2.EQ.A ) ) THEN
+ EMIN = EMIN - 1
+ A = B1
+ B1 = DLAMC3( A / BASE, ZERO )
+ C1 = DLAMC3( B1*BASE, ZERO )
+ D1 = ZERO
+ DO 20 I = 1, BASE
+ D1 = D1 + B1
+ 20 CONTINUE
+ B2 = DLAMC3( A*RBASE, ZERO )
+ C2 = DLAMC3( B2 / RBASE, ZERO )
+ D2 = ZERO
+ DO 30 I = 1, BASE
+ D2 = D2 + B2
+ 30 CONTINUE
+ GO TO 10
+ END IF
+*+ END WHILE
+*
+ RETURN
+*
+* End of DLAMC4
+*
+ END
+*
+************************************************************************
+*
+ SUBROUTINE DLAMC5( BETA, P, EMIN, IEEE, EMAX, RMAX )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ LOGICAL IEEE
+ INTEGER BETA, EMAX, EMIN, P
+ DOUBLE PRECISION RMAX
+* ..
+*
+* Purpose
+* =======
+*
+* DLAMC5 attempts to compute RMAX, the largest machine floating-point
+* number, without overflow. It assumes that EMAX + abs(EMIN) sum
+* approximately to a power of 2. It will fail on machines where this
+* assumption does not hold, for example, the Cyber 205 (EMIN = -28625,
+* EMAX = 28718). It will also fail if the value supplied for EMIN is
+* too large (i.e. too close to zero), probably with overflow.
+*
+* Arguments
+* =========
+*
+* BETA (input) INTEGER
+* The base of floating-point arithmetic.
+*
+* P (input) INTEGER
+* The number of base BETA digits in the mantissa of a
+* floating-point value.
+*
+* EMIN (input) INTEGER
+* The minimum exponent before (gradual) underflow.
+*
+* IEEE (input) LOGICAL
+* A logical flag specifying whether or not the arithmetic
+* system is thought to comply with the IEEE standard.
+*
+* EMAX (output) INTEGER
+* The largest exponent before overflow
+*
+* RMAX (output) DOUBLE PRECISION
+* The largest machine floating-point number.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
+* ..
+* .. Local Scalars ..
+ INTEGER EXBITS, EXPSUM, I, LEXP, NBITS, TRY, UEXP
+ DOUBLE PRECISION OLDY, RECBAS, Y, Z
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DLAMC3
+ EXTERNAL DLAMC3
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MOD
+* ..
+* .. Executable Statements ..
+*
+* First compute LEXP and UEXP, two powers of 2 that bound
+* abs(EMIN). We then assume that EMAX + abs(EMIN) will sum
+* approximately to the bound that is closest to abs(EMIN).
+* (EMAX is the exponent of the required number RMAX).
+*
+ LEXP = 1
+ EXBITS = 1
+ 10 CONTINUE
+ TRY = LEXP*2
+ IF( TRY.LE.( -EMIN ) ) THEN
+ LEXP = TRY
+ EXBITS = EXBITS + 1
+ GO TO 10
+ END IF
+ IF( LEXP.EQ.-EMIN ) THEN
+ UEXP = LEXP
+ ELSE
+ UEXP = TRY
+ EXBITS = EXBITS + 1
+ END IF
+*
+* Now -LEXP is less than or equal to EMIN, and -UEXP is greater
+* than or equal to EMIN. EXBITS is the number of bits needed to
+* store the exponent.
+*
+ IF( ( UEXP+EMIN ).GT.( -LEXP-EMIN ) ) THEN
+ EXPSUM = 2*LEXP
+ ELSE
+ EXPSUM = 2*UEXP
+ END IF
+*
+* EXPSUM is the exponent range, approximately equal to
+* EMAX - EMIN + 1 .
+*
+ EMAX = EXPSUM + EMIN - 1
+ NBITS = 1 + EXBITS + P
+*
+* NBITS is the total number of bits needed to store a
+* floating-point number.
+*
+ IF( ( MOD( NBITS, 2 ).EQ.1 ) .AND. ( BETA.EQ.2 ) ) THEN
+*
+* Either there are an odd number of bits used to store a
+* floating-point number, which is unlikely, or some bits are
+* not used in the representation of numbers, which is possible,
+* (e.g. Cray machines) or the mantissa has an implicit bit,
+* (e.g. IEEE machines, Dec Vax machines), which is perhaps the
+* most likely. We have to assume the last alternative.
+* If this is true, then we need to reduce EMAX by one because
+* there must be some way of representing zero in an implicit-bit
+* system. On machines like Cray, we are reducing EMAX by one
+* unnecessarily.
+*
+ EMAX = EMAX - 1
+ END IF
+*
+ IF( IEEE ) THEN
+*
+* Assume we are on an IEEE machine which reserves one exponent
+* for infinity and NaN.
+*
+ EMAX = EMAX - 1
+ END IF
+*
+* Now create RMAX, the largest machine number, which should
+* be equal to (1.0 - BETA**(-P)) * BETA**EMAX .
+*
+* First compute 1.0 - BETA**(-P), being careful that the
+* result is less than 1.0 .
+*
+ RECBAS = ONE / BETA
+ Z = BETA - ONE
+ Y = ZERO
+ DO 20 I = 1, P
+ Z = Z*RECBAS
+ IF( Y.LT.ONE )
+ $ OLDY = Y
+ Y = DLAMC3( Y, Z )
+ 20 CONTINUE
+ IF( Y.GE.ONE )
+ $ Y = OLDY
+*
+* Now multiply by BETA**EMAX to get RMAX.
+*
+ DO 30 I = 1, EMAX
+ Y = DLAMC3( Y*BETA, ZERO )
+ 30 CONTINUE
+*
+ RMAX = Y
+ RETURN
+*
+* End of DLAMC5
+*
+ END
+ DOUBLE PRECISION FUNCTION DSECND( )
+*
+* -- LAPACK auxiliary routine (version 3.1.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* February 2007
+*
+* Purpose
+* =======
+*
+* DSECND returns the user time for a process in seconds.
+* This version gets the time from the EXTERNAL system function ETIME.
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ REAL T1
+* ..
+* .. Local Arrays ..
+ REAL TARRAY( 2 )
+* ..
+* .. External Functions ..
+ REAL ETIME
+ EXTERNAL ETIME
+* ..
+* .. Executable Statements ..
+*
+ T1 = ETIME( TARRAY )
+ DSECND = TARRAY( 1 )
+ RETURN
+*
+* End of DSECND
+*
+ END
+ LOGICAL FUNCTION LSAME( CA, CB )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER CA, CB
+* ..
+*
+* Purpose
+* =======
+*
+* LSAME returns .TRUE. if CA is the same letter as CB regardless of
+* case.
+*
+* Arguments
+* =========
+*
+* CA (input) CHARACTER*1
+* CB (input) CHARACTER*1
+* CA and CB specify the single characters to be compared.
+*
+* =====================================================================
+*
+* .. Intrinsic Functions ..
+ INTRINSIC ICHAR
+* ..
+* .. Local Scalars ..
+ INTEGER INTA, INTB, ZCODE
+* ..
+* .. Executable Statements ..
+*
+* Test if the characters are equal
+*
+ LSAME = CA.EQ.CB
+ IF( LSAME )
+ $ RETURN
+*
+* Now test for equivalence if both characters are alphabetic.
+*
+ ZCODE = ICHAR( 'Z' )
+*
+* Use 'Z' rather than 'A' so that ASCII can be detected on Prime
+* machines, on which ICHAR returns a value with bit 8 set.
+* ICHAR('A') on Prime machines returns 193 which is the same as
+* ICHAR('A') on an EBCDIC machine.
+*
+ INTA = ICHAR( CA )
+ INTB = ICHAR( CB )
+*
+ IF( ZCODE.EQ.90 .OR. ZCODE.EQ.122 ) THEN
+*
+* ASCII is assumed - ZCODE is the ASCII code of either lower or
+* upper case 'Z'.
+*
+ IF( INTA.GE.97 .AND. INTA.LE.122 ) INTA = INTA - 32
+ IF( INTB.GE.97 .AND. INTB.LE.122 ) INTB = INTB - 32
+*
+ ELSE IF( ZCODE.EQ.233 .OR. ZCODE.EQ.169 ) THEN
+*
+* EBCDIC is assumed - ZCODE is the EBCDIC code of either lower or
+* upper case 'Z'.
+*
+ IF( INTA.GE.129 .AND. INTA.LE.137 .OR.
+ $ INTA.GE.145 .AND. INTA.LE.153 .OR.
+ $ INTA.GE.162 .AND. INTA.LE.169 ) INTA = INTA + 64
+ IF( INTB.GE.129 .AND. INTB.LE.137 .OR.
+ $ INTB.GE.145 .AND. INTB.LE.153 .OR.
+ $ INTB.GE.162 .AND. INTB.LE.169 ) INTB = INTB + 64
+*
+ ELSE IF( ZCODE.EQ.218 .OR. ZCODE.EQ.250 ) THEN
+*
+* ASCII is assumed, on Prime machines - ZCODE is the ASCII code
+* plus 128 of either lower or upper case 'Z'.
+*
+ IF( INTA.GE.225 .AND. INTA.LE.250 ) INTA = INTA - 32
+ IF( INTB.GE.225 .AND. INTB.LE.250 ) INTB = INTB - 32
+ END IF
+ LSAME = INTA.EQ.INTB
+*
+* RETURN
+*
+* End of LSAME
+*
+ END
+ REAL FUNCTION SECOND( )
+*
+* -- LAPACK auxiliary routine (version 3.1.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* February 2007
+*
+* Purpose
+* =======
+*
+* SECOND returns the user time for a process in seconds.
+* This version gets the time from the EXTERNAL system function ETIME.
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ REAL T1
+* ..
+* .. Local Arrays ..
+ REAL TARRAY( 2 )
+* ..
+* .. External Functions ..
+ REAL ETIME
+ EXTERNAL ETIME
+* ..
+* .. Executable Statements ..
+*
+ T1 = ETIME( TARRAY )
+ SECOND = TARRAY( 1 )
+ RETURN
+*
+* End of SECOND
+*
+ END
+ REAL FUNCTION SLAMCH( CMACH )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER CMACH
+* ..
+*
+* Purpose
+* =======
+*
+* SLAMCH determines single precision machine parameters.
+*
+* Arguments
+* =========
+*
+* CMACH (input) CHARACTER*1
+* Specifies the value to be returned by SLAMCH:
+* = 'E' or 'e', SLAMCH := eps
+* = 'S' or 's , SLAMCH := sfmin
+* = 'B' or 'b', SLAMCH := base
+* = 'P' or 'p', SLAMCH := eps*base
+* = 'N' or 'n', SLAMCH := t
+* = 'R' or 'r', SLAMCH := rnd
+* = 'M' or 'm', SLAMCH := emin
+* = 'U' or 'u', SLAMCH := rmin
+* = 'L' or 'l', SLAMCH := emax
+* = 'O' or 'o', SLAMCH := rmax
+*
+* where
+*
+* eps = relative machine precision
+* sfmin = safe minimum, such that 1/sfmin does not overflow
+* base = base of the machine
+* prec = eps*base
+* t = number of (base) digits in the mantissa
+* rnd = 1.0 when rounding occurs in addition, 0.0 otherwise
+* emin = minimum exponent before (gradual) underflow
+* rmin = underflow threshold - base**(emin-1)
+* emax = largest exponent before overflow
+* rmax = overflow threshold - (base**emax)*(1-eps)
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ONE, ZERO
+ PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL FIRST, LRND
+ INTEGER BETA, IMAX, IMIN, IT
+ REAL BASE, EMAX, EMIN, EPS, PREC, RMACH, RMAX, RMIN,
+ $ RND, SFMIN, SMALL, T
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+ EXTERNAL SLAMC2
+* ..
+* .. Save statement ..
+ SAVE FIRST, EPS, SFMIN, BASE, T, RND, EMIN, RMIN,
+ $ EMAX, RMAX, PREC
+* ..
+* .. Data statements ..
+ DATA FIRST / .TRUE. /
+* ..
+* .. Executable Statements ..
+*
+ IF( FIRST ) THEN
+ CALL SLAMC2( BETA, IT, LRND, EPS, IMIN, RMIN, IMAX, RMAX )
+ BASE = BETA
+ T = IT
+ IF( LRND ) THEN
+ RND = ONE
+ EPS = ( BASE**( 1-IT ) ) / 2
+ ELSE
+ RND = ZERO
+ EPS = BASE**( 1-IT )
+ END IF
+ PREC = EPS*BASE
+ EMIN = IMIN
+ EMAX = IMAX
+ SFMIN = RMIN
+ SMALL = ONE / RMAX
+ IF( SMALL.GE.SFMIN ) THEN
+*
+* Use SMALL plus a bit, to avoid the possibility of rounding
+* causing overflow when computing 1/sfmin.
+*
+ SFMIN = SMALL*( ONE+EPS )
+ END IF
+ END IF
+*
+ IF( LSAME( CMACH, 'E' ) ) THEN
+ RMACH = EPS
+ ELSE IF( LSAME( CMACH, 'S' ) ) THEN
+ RMACH = SFMIN
+ ELSE IF( LSAME( CMACH, 'B' ) ) THEN
+ RMACH = BASE
+ ELSE IF( LSAME( CMACH, 'P' ) ) THEN
+ RMACH = PREC
+ ELSE IF( LSAME( CMACH, 'N' ) ) THEN
+ RMACH = T
+ ELSE IF( LSAME( CMACH, 'R' ) ) THEN
+ RMACH = RND
+ ELSE IF( LSAME( CMACH, 'M' ) ) THEN
+ RMACH = EMIN
+ ELSE IF( LSAME( CMACH, 'U' ) ) THEN
+ RMACH = RMIN
+ ELSE IF( LSAME( CMACH, 'L' ) ) THEN
+ RMACH = EMAX
+ ELSE IF( LSAME( CMACH, 'O' ) ) THEN
+ RMACH = RMAX
+ END IF
+*
+ SLAMCH = RMACH
+ FIRST = .FALSE.
+ RETURN
+*
+* End of SLAMCH
+*
+ END
+*
+************************************************************************
+*
+ SUBROUTINE SLAMC1( BETA, T, RND, IEEE1 )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ LOGICAL IEEE1, RND
+ INTEGER BETA, T
+* ..
+*
+* Purpose
+* =======
+*
+* SLAMC1 determines the machine parameters given by BETA, T, RND, and
+* IEEE1.
+*
+* Arguments
+* =========
+*
+* BETA (output) INTEGER
+* The base of the machine.
+*
+* T (output) INTEGER
+* The number of ( BETA ) digits in the mantissa.
+*
+* RND (output) LOGICAL
+* Specifies whether proper rounding ( RND = .TRUE. ) or
+* chopping ( RND = .FALSE. ) occurs in addition. This may not
+* be a reliable guide to the way in which the machine performs
+* its arithmetic.
+*
+* IEEE1 (output) LOGICAL
+* Specifies whether rounding appears to be done in the IEEE
+* 'round to nearest' style.
+*
+* Further Details
+* ===============
+*
+* The routine is based on the routine ENVRON by Malcolm and
+* incorporates suggestions by Gentleman and Marovich. See
+*
+* Malcolm M. A. (1972) Algorithms to reveal properties of
+* floating-point arithmetic. Comms. of the ACM, 15, 949-951.
+*
+* Gentleman W. M. and Marovich S. B. (1974) More on algorithms
+* that reveal properties of floating point arithmetic units.
+* Comms. of the ACM, 17, 276-277.
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ LOGICAL FIRST, LIEEE1, LRND
+ INTEGER LBETA, LT
+ REAL A, B, C, F, ONE, QTR, SAVEC, T1, T2
+* ..
+* .. External Functions ..
+ REAL SLAMC3
+ EXTERNAL SLAMC3
+* ..
+* .. Save statement ..
+ SAVE FIRST, LIEEE1, LBETA, LRND, LT
+* ..
+* .. Data statements ..
+ DATA FIRST / .TRUE. /
+* ..
+* .. Executable Statements ..
+*
+ IF( FIRST ) THEN
+ ONE = 1
+*
+* LBETA, LIEEE1, LT and LRND are the local values of BETA,
+* IEEE1, T and RND.
+*
+* Throughout this routine we use the function SLAMC3 to ensure
+* that relevant values are stored and not held in registers, or
+* are not affected by optimizers.
+*
+* Compute a = 2.0**m with the smallest positive integer m such
+* that
+*
+* fl( a + 1.0 ) = a.
+*
+ A = 1
+ C = 1
+*
+*+ WHILE( C.EQ.ONE )LOOP
+ 10 CONTINUE
+ IF( C.EQ.ONE ) THEN
+ A = 2*A
+ C = SLAMC3( A, ONE )
+ C = SLAMC3( C, -A )
+ GO TO 10
+ END IF
+*+ END WHILE
+*
+* Now compute b = 2.0**m with the smallest positive integer m
+* such that
+*
+* fl( a + b ) .gt. a.
+*
+ B = 1
+ C = SLAMC3( A, B )
+*
+*+ WHILE( C.EQ.A )LOOP
+ 20 CONTINUE
+ IF( C.EQ.A ) THEN
+ B = 2*B
+ C = SLAMC3( A, B )
+ GO TO 20
+ END IF
+*+ END WHILE
+*
+* Now compute the base. a and c are neighbouring floating point
+* numbers in the interval ( beta**t, beta**( t + 1 ) ) and so
+* their difference is beta. Adding 0.25 to c is to ensure that it
+* is truncated to beta and not ( beta - 1 ).
+*
+ QTR = ONE / 4
+ SAVEC = C
+ C = SLAMC3( C, -A )
+ LBETA = C + QTR
+*
+* Now determine whether rounding or chopping occurs, by adding a
+* bit less than beta/2 and a bit more than beta/2 to a.
+*
+ B = LBETA
+ F = SLAMC3( B / 2, -B / 100 )
+ C = SLAMC3( F, A )
+ IF( C.EQ.A ) THEN
+ LRND = .TRUE.
+ ELSE
+ LRND = .FALSE.
+ END IF
+ F = SLAMC3( B / 2, B / 100 )
+ C = SLAMC3( F, A )
+ IF( ( LRND ) .AND. ( C.EQ.A ) )
+ $ LRND = .FALSE.
+*
+* Try and decide whether rounding is done in the IEEE 'round to
+* nearest' style. B/2 is half a unit in the last place of the two
+* numbers A and SAVEC. Furthermore, A is even, i.e. has last bit
+* zero, and SAVEC is odd. Thus adding B/2 to A should not change
+* A, but adding B/2 to SAVEC should change SAVEC.
+*
+ T1 = SLAMC3( B / 2, A )
+ T2 = SLAMC3( B / 2, SAVEC )
+ LIEEE1 = ( T1.EQ.A ) .AND. ( T2.GT.SAVEC ) .AND. LRND
+*
+* Now find the mantissa, t. It should be the integer part of
+* log to the base beta of a, however it is safer to determine t
+* by powering. So we find t as the smallest positive integer for
+* which
+*
+* fl( beta**t + 1.0 ) = 1.0.
+*
+ LT = 0
+ A = 1
+ C = 1
+*
+*+ WHILE( C.EQ.ONE )LOOP
+ 30 CONTINUE
+ IF( C.EQ.ONE ) THEN
+ LT = LT + 1
+ A = A*LBETA
+ C = SLAMC3( A, ONE )
+ C = SLAMC3( C, -A )
+ GO TO 30
+ END IF
+*+ END WHILE
+*
+ END IF
+*
+ BETA = LBETA
+ T = LT
+ RND = LRND
+ IEEE1 = LIEEE1
+ FIRST = .FALSE.
+ RETURN
+*
+* End of SLAMC1
+*
+ END
+*
+************************************************************************
+*
+ SUBROUTINE SLAMC2( BETA, T, RND, EPS, EMIN, RMIN, EMAX, RMAX )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ LOGICAL RND
+ INTEGER BETA, EMAX, EMIN, T
+ REAL EPS, RMAX, RMIN
+* ..
+*
+* Purpose
+* =======
+*
+* SLAMC2 determines the machine parameters specified in its argument
+* list.
+*
+* Arguments
+* =========
+*
+* BETA (output) INTEGER
+* The base of the machine.
+*
+* T (output) INTEGER
+* The number of ( BETA ) digits in the mantissa.
+*
+* RND (output) LOGICAL
+* Specifies whether proper rounding ( RND = .TRUE. ) or
+* chopping ( RND = .FALSE. ) occurs in addition. This may not
+* be a reliable guide to the way in which the machine performs
+* its arithmetic.
+*
+* EPS (output) REAL
+* The smallest positive number such that
+*
+* fl( 1.0 - EPS ) .LT. 1.0,
+*
+* where fl denotes the computed value.
+*
+* EMIN (output) INTEGER
+* The minimum exponent before (gradual) underflow occurs.
+*
+* RMIN (output) REAL
+* The smallest normalized number for the machine, given by
+* BASE**( EMIN - 1 ), where BASE is the floating point value
+* of BETA.
+*
+* EMAX (output) INTEGER
+* The maximum exponent before overflow occurs.
+*
+* RMAX (output) REAL
+* The largest positive number for the machine, given by
+* BASE**EMAX * ( 1 - EPS ), where BASE is the floating point
+* value of BETA.
+*
+* Further Details
+* ===============
+*
+* The computation of EPS is based on a routine PARANOIA by
+* W. Kahan of the University of California at Berkeley.
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ LOGICAL FIRST, IEEE, IWARN, LIEEE1, LRND
+ INTEGER GNMIN, GPMIN, I, LBETA, LEMAX, LEMIN, LT,
+ $ NGNMIN, NGPMIN
+ REAL A, B, C, HALF, LEPS, LRMAX, LRMIN, ONE, RBASE,
+ $ SIXTH, SMALL, THIRD, TWO, ZERO
+* ..
+* .. External Functions ..
+ REAL SLAMC3
+ EXTERNAL SLAMC3
+* ..
+* .. External Subroutines ..
+ EXTERNAL SLAMC1, SLAMC4, SLAMC5
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, MIN
+* ..
+* .. Save statement ..
+ SAVE FIRST, IWARN, LBETA, LEMAX, LEMIN, LEPS, LRMAX,
+ $ LRMIN, LT
+* ..
+* .. Data statements ..
+ DATA FIRST / .TRUE. / , IWARN / .FALSE. /
+* ..
+* .. Executable Statements ..
+*
+ IF( FIRST ) THEN
+ ZERO = 0
+ ONE = 1
+ TWO = 2
+*
+* LBETA, LT, LRND, LEPS, LEMIN and LRMIN are the local values of
+* BETA, T, RND, EPS, EMIN and RMIN.
+*
+* Throughout this routine we use the function SLAMC3 to ensure
+* that relevant values are stored and not held in registers, or
+* are not affected by optimizers.
+*
+* SLAMC1 returns the parameters LBETA, LT, LRND and LIEEE1.
+*
+ CALL SLAMC1( LBETA, LT, LRND, LIEEE1 )
+*
+* Start to find EPS.
+*
+ B = LBETA
+ A = B**( -LT )
+ LEPS = A
+*
+* Try some tricks to see whether or not this is the correct EPS.
+*
+ B = TWO / 3
+ HALF = ONE / 2
+ SIXTH = SLAMC3( B, -HALF )
+ THIRD = SLAMC3( SIXTH, SIXTH )
+ B = SLAMC3( THIRD, -HALF )
+ B = SLAMC3( B, SIXTH )
+ B = ABS( B )
+ IF( B.LT.LEPS )
+ $ B = LEPS
+*
+ LEPS = 1
+*
+*+ WHILE( ( LEPS.GT.B ).AND.( B.GT.ZERO ) )LOOP
+ 10 CONTINUE
+ IF( ( LEPS.GT.B ) .AND. ( B.GT.ZERO ) ) THEN
+ LEPS = B
+ C = SLAMC3( HALF*LEPS, ( TWO**5 )*( LEPS**2 ) )
+ C = SLAMC3( HALF, -C )
+ B = SLAMC3( HALF, C )
+ C = SLAMC3( HALF, -B )
+ B = SLAMC3( HALF, C )
+ GO TO 10
+ END IF
+*+ END WHILE
+*
+ IF( A.LT.LEPS )
+ $ LEPS = A
+*
+* Computation of EPS complete.
+*
+* Now find EMIN. Let A = + or - 1, and + or - (1 + BASE**(-3)).
+* Keep dividing A by BETA until (gradual) underflow occurs. This
+* is detected when we cannot recover the previous A.
+*
+ RBASE = ONE / LBETA
+ SMALL = ONE
+ DO 20 I = 1, 3
+ SMALL = SLAMC3( SMALL*RBASE, ZERO )
+ 20 CONTINUE
+ A = SLAMC3( ONE, SMALL )
+ CALL SLAMC4( NGPMIN, ONE, LBETA )
+ CALL SLAMC4( NGNMIN, -ONE, LBETA )
+ CALL SLAMC4( GPMIN, A, LBETA )
+ CALL SLAMC4( GNMIN, -A, LBETA )
+ IEEE = .FALSE.
+*
+ IF( ( NGPMIN.EQ.NGNMIN ) .AND. ( GPMIN.EQ.GNMIN ) ) THEN
+ IF( NGPMIN.EQ.GPMIN ) THEN
+ LEMIN = NGPMIN
+* ( Non twos-complement machines, no gradual underflow;
+* e.g., VAX )
+ ELSE IF( ( GPMIN-NGPMIN ).EQ.3 ) THEN
+ LEMIN = NGPMIN - 1 + LT
+ IEEE = .TRUE.
+* ( Non twos-complement machines, with gradual underflow;
+* e.g., IEEE standard followers )
+ ELSE
+ LEMIN = MIN( NGPMIN, GPMIN )
+* ( A guess; no known machine )
+ IWARN = .TRUE.
+ END IF
+*
+ ELSE IF( ( NGPMIN.EQ.GPMIN ) .AND. ( NGNMIN.EQ.GNMIN ) ) THEN
+ IF( ABS( NGPMIN-NGNMIN ).EQ.1 ) THEN
+ LEMIN = MAX( NGPMIN, NGNMIN )
+* ( Twos-complement machines, no gradual underflow;
+* e.g., CYBER 205 )
+ ELSE
+ LEMIN = MIN( NGPMIN, NGNMIN )
+* ( A guess; no known machine )
+ IWARN = .TRUE.
+ END IF
+*
+ ELSE IF( ( ABS( NGPMIN-NGNMIN ).EQ.1 ) .AND.
+ $ ( GPMIN.EQ.GNMIN ) ) THEN
+ IF( ( GPMIN-MIN( NGPMIN, NGNMIN ) ).EQ.3 ) THEN
+ LEMIN = MAX( NGPMIN, NGNMIN ) - 1 + LT
+* ( Twos-complement machines with gradual underflow;
+* no known machine )
+ ELSE
+ LEMIN = MIN( NGPMIN, NGNMIN )
+* ( A guess; no known machine )
+ IWARN = .TRUE.
+ END IF
+*
+ ELSE
+ LEMIN = MIN( NGPMIN, NGNMIN, GPMIN, GNMIN )
+* ( A guess; no known machine )
+ IWARN = .TRUE.
+ END IF
+ FIRST = .FALSE.
+***
+* Comment out this if block if EMIN is ok
+ IF( IWARN ) THEN
+ FIRST = .TRUE.
+ WRITE( 6, FMT = 9999 )LEMIN
+ END IF
+***
+*
+* Assume IEEE arithmetic if we found denormalised numbers above,
+* or if arithmetic seems to round in the IEEE style, determined
+* in routine SLAMC1. A true IEEE machine should have both things
+* true; however, faulty machines may have one or the other.
+*
+ IEEE = IEEE .OR. LIEEE1
+*
+* Compute RMIN by successive division by BETA. We could compute
+* RMIN as BASE**( EMIN - 1 ), but some machines underflow during
+* this computation.
+*
+ LRMIN = 1
+ DO 30 I = 1, 1 - LEMIN
+ LRMIN = SLAMC3( LRMIN*RBASE, ZERO )
+ 30 CONTINUE
+*
+* Finally, call SLAMC5 to compute EMAX and RMAX.
+*
+ CALL SLAMC5( LBETA, LT, LEMIN, IEEE, LEMAX, LRMAX )
+ END IF
+*
+ BETA = LBETA
+ T = LT
+ RND = LRND
+ EPS = LEPS
+ EMIN = LEMIN
+ RMIN = LRMIN
+ EMAX = LEMAX
+ RMAX = LRMAX
+*
+ RETURN
+*
+ 9999 FORMAT( / / ' WARNING. The value EMIN may be incorrect:-',
+ $ ' EMIN = ', I8, /
+ $ ' If, after inspection, the value EMIN looks',
+ $ ' acceptable please comment out ',
+ $ / ' the IF block as marked within the code of routine',
+ $ ' SLAMC2,', / ' otherwise supply EMIN explicitly.', / )
+*
+* End of SLAMC2
+*
+ END
+*
+************************************************************************
+*
+ REAL FUNCTION SLAMC3( A, B )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ REAL A, B
+* ..
+*
+* Purpose
+* =======
+*
+* SLAMC3 is intended to force A and B to be stored prior to doing
+* the addition of A and B , for use in situations where optimizers
+* might hold one of these in a register.
+*
+* Arguments
+* =========
+*
+* A (input) REAL
+* B (input) REAL
+* The values A and B.
+*
+* =====================================================================
+*
+* .. Executable Statements ..
+*
+ SLAMC3 = A + B
+*
+ RETURN
+*
+* End of SLAMC3
+*
+ END
+*
+************************************************************************
+*
+ SUBROUTINE SLAMC4( EMIN, START, BASE )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER BASE
+ INTEGER EMIN
+ REAL START
+* ..
+*
+* Purpose
+* =======
+*
+* SLAMC4 is a service routine for SLAMC2.
+*
+* Arguments
+* =========
+*
+* EMIN (output) INTEGER
+* The minimum exponent before (gradual) underflow, computed by
+* setting A = START and dividing by BASE until the previous A
+* can not be recovered.
+*
+* START (input) REAL
+* The starting point for determining EMIN.
+*
+* BASE (input) INTEGER
+* The base of the machine.
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ INTEGER I
+ REAL A, B1, B2, C1, C2, D1, D2, ONE, RBASE, ZERO
+* ..
+* .. External Functions ..
+ REAL SLAMC3
+ EXTERNAL SLAMC3
+* ..
+* .. Executable Statements ..
+*
+ A = START
+ ONE = 1
+ RBASE = ONE / BASE
+ ZERO = 0
+ EMIN = 1
+ B1 = SLAMC3( A*RBASE, ZERO )
+ C1 = A
+ C2 = A
+ D1 = A
+ D2 = A
+*+ WHILE( ( C1.EQ.A ).AND.( C2.EQ.A ).AND.
+* $ ( D1.EQ.A ).AND.( D2.EQ.A ) )LOOP
+ 10 CONTINUE
+ IF( ( C1.EQ.A ) .AND. ( C2.EQ.A ) .AND. ( D1.EQ.A ) .AND.
+ $ ( D2.EQ.A ) ) THEN
+ EMIN = EMIN - 1
+ A = B1
+ B1 = SLAMC3( A / BASE, ZERO )
+ C1 = SLAMC3( B1*BASE, ZERO )
+ D1 = ZERO
+ DO 20 I = 1, BASE
+ D1 = D1 + B1
+ 20 CONTINUE
+ B2 = SLAMC3( A*RBASE, ZERO )
+ C2 = SLAMC3( B2 / RBASE, ZERO )
+ D2 = ZERO
+ DO 30 I = 1, BASE
+ D2 = D2 + B2
+ 30 CONTINUE
+ GO TO 10
+ END IF
+*+ END WHILE
+*
+ RETURN
+*
+* End of SLAMC4
+*
+ END
+*
+************************************************************************
+*
+ SUBROUTINE SLAMC5( BETA, P, EMIN, IEEE, EMAX, RMAX )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ LOGICAL IEEE
+ INTEGER BETA, EMAX, EMIN, P
+ REAL RMAX
+* ..
+*
+* Purpose
+* =======
+*
+* SLAMC5 attempts to compute RMAX, the largest machine floating-point
+* number, without overflow. It assumes that EMAX + abs(EMIN) sum
+* approximately to a power of 2. It will fail on machines where this
+* assumption does not hold, for example, the Cyber 205 (EMIN = -28625,
+* EMAX = 28718). It will also fail if the value supplied for EMIN is
+* too large (i.e. too close to zero), probably with overflow.
+*
+* Arguments
+* =========
+*
+* BETA (input) INTEGER
+* The base of floating-point arithmetic.
+*
+* P (input) INTEGER
+* The number of base BETA digits in the mantissa of a
+* floating-point value.
+*
+* EMIN (input) INTEGER
+* The minimum exponent before (gradual) underflow.
+*
+* IEEE (input) LOGICAL
+* A logical flag specifying whether or not the arithmetic
+* system is thought to comply with the IEEE standard.
+*
+* EMAX (output) INTEGER
+* The largest exponent before overflow
+*
+* RMAX (output) REAL
+* The largest machine floating-point number.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ REAL ZERO, ONE
+ PARAMETER ( ZERO = 0.0E0, ONE = 1.0E0 )
+* ..
+* .. Local Scalars ..
+ INTEGER EXBITS, EXPSUM, I, LEXP, NBITS, TRY, UEXP
+ REAL OLDY, RECBAS, Y, Z
+* ..
+* .. External Functions ..
+ REAL SLAMC3
+ EXTERNAL SLAMC3
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MOD
+* ..
+* .. Executable Statements ..
+*
+* First compute LEXP and UEXP, two powers of 2 that bound
+* abs(EMIN). We then assume that EMAX + abs(EMIN) will sum
+* approximately to the bound that is closest to abs(EMIN).
+* (EMAX is the exponent of the required number RMAX).
+*
+ LEXP = 1
+ EXBITS = 1
+ 10 CONTINUE
+ TRY = LEXP*2
+ IF( TRY.LE.( -EMIN ) ) THEN
+ LEXP = TRY
+ EXBITS = EXBITS + 1
+ GO TO 10
+ END IF
+ IF( LEXP.EQ.-EMIN ) THEN
+ UEXP = LEXP
+ ELSE
+ UEXP = TRY
+ EXBITS = EXBITS + 1
+ END IF
+*
+* Now -LEXP is less than or equal to EMIN, and -UEXP is greater
+* than or equal to EMIN. EXBITS is the number of bits needed to
+* store the exponent.
+*
+ IF( ( UEXP+EMIN ).GT.( -LEXP-EMIN ) ) THEN
+ EXPSUM = 2*LEXP
+ ELSE
+ EXPSUM = 2*UEXP
+ END IF
+*
+* EXPSUM is the exponent range, approximately equal to
+* EMAX - EMIN + 1 .
+*
+ EMAX = EXPSUM + EMIN - 1
+ NBITS = 1 + EXBITS + P
+*
+* NBITS is the total number of bits needed to store a
+* floating-point number.
+*
+ IF( ( MOD( NBITS, 2 ).EQ.1 ) .AND. ( BETA.EQ.2 ) ) THEN
+*
+* Either there are an odd number of bits used to store a
+* floating-point number, which is unlikely, or some bits are
+* not used in the representation of numbers, which is possible,
+* (e.g. Cray machines) or the mantissa has an implicit bit,
+* (e.g. IEEE machines, Dec Vax machines), which is perhaps the
+* most likely. We have to assume the last alternative.
+* If this is true, then we need to reduce EMAX by one because
+* there must be some way of representing zero in an implicit-bit
+* system. On machines like Cray, we are reducing EMAX by one
+* unnecessarily.
+*
+ EMAX = EMAX - 1
+ END IF
+*
+ IF( IEEE ) THEN
+*
+* Assume we are on an IEEE machine which reserves one exponent
+* for infinity and NaN.
+*
+ EMAX = EMAX - 1
+ END IF
+*
+* Now create RMAX, the largest machine number, which should
+* be equal to (1.0 - BETA**(-P)) * BETA**EMAX .
+*
+* First compute 1.0 - BETA**(-P), being careful that the
+* result is less than 1.0 .
+*
+ RECBAS = ONE / BETA
+ Z = BETA - ONE
+ Y = ZERO
+ DO 20 I = 1, P
+ Z = Z*RECBAS
+ IF( Y.LT.ONE )
+ $ OLDY = Y
+ Y = SLAMC3( Y, Z )
+ 20 CONTINUE
+ IF( Y.GE.ONE )
+ $ Y = OLDY
+*
+* Now multiply by BETA**EMAX to get RMAX.
+*
+ DO 30 I = 1, EMAX
+ Y = SLAMC3( Y*BETA, ZERO )
+ 30 CONTINUE
+*
+ RMAX = Y
+ RETURN
+*
+* End of SLAMC5
+*
+ END
diff --git a/jlapack-3.1.1/src/lapack/verify_all.csh b/jlapack-3.1.1/src/lapack/verify_all.csh
new file mode 100755
index 0000000..6eea0f2
--- /dev/null
+++ b/jlapack-3.1.1/src/lapack/verify_all.csh
@@ -0,0 +1,7 @@
+#!/bin/csh
+
+setenv CPTMP $CLASSPATH":../../blas/blas.jar:../../error_reporting/xerbla.jar"
+cd obj
+foreach file(org/netlib/lapack/*.class)
+ java -classpath $CPTMP de.fub.bytecode.verifier.Verifier $file
+end
diff --git a/jlapack-3.1.1/src/testing/Makefile b/jlapack-3.1.1/src/testing/Makefile
new file mode 100644
index 0000000..3564084
--- /dev/null
+++ b/jlapack-3.1.1/src/testing/Makefile
@@ -0,0 +1,80 @@
+.PHONY: blas1 blas2 blas3 runtests clean sblas1 sblas2 sblas3 eig lin seig slin
+
+ROOT=../..
+
+include $(ROOT)/make.def
+
+testers: blas1 blas2 blas3 eig lin sblas1 sblas2 sblas3 seig slin
+
+blas1: $(ROOT)/$(BLAS1TEST_IDX)
+blas2: $(ROOT)/$(BLAS2TEST_IDX)
+blas3: $(ROOT)/$(BLAS3TEST_IDX)
+eig: $(ROOT)/$(EIGTEST_IDX)
+lin: $(ROOT)/$(LINTEST_IDX)
+
+sblas1: $(ROOT)/$(SBLAS1TEST_IDX)
+sblas2: $(ROOT)/$(SBLAS2TEST_IDX)
+sblas3: $(ROOT)/$(SBLAS3TEST_IDX)
+seig: $(ROOT)/$(SEIGTEST_IDX)
+slin: $(ROOT)/$(SLINTEST_IDX)
+
+
+$(ROOT)/$(BLAS1TEST_IDX):
+ cd blas1;$(MAKE)
+$(ROOT)/$(BLAS2TEST_IDX):
+ cd blas2;$(MAKE)
+$(ROOT)/$(BLAS3TEST_IDX):
+ cd blas3;$(MAKE)
+$(ROOT)/$(EIGTEST_IDX):
+ cd eig;$(MAKE)
+$(ROOT)/$(LINTEST_IDX):
+ cd lin;$(MAKE)
+
+$(ROOT)/$(SBLAS1TEST_IDX):
+ cd sblas1;$(MAKE)
+$(ROOT)/$(SBLAS2TEST_IDX):
+ cd sblas2;$(MAKE)
+$(ROOT)/$(SBLAS3TEST_IDX):
+ cd sblas3;$(MAKE)
+$(ROOT)/$(SEIGTEST_IDX):
+ cd seig;$(MAKE)
+$(ROOT)/$(SLINTEST_IDX):
+ cd slin;$(MAKE)
+
+runtests: blastest lintest eigtest sblastest slintest seigtest
+
+blastest:
+ cd blas1;$(MAKE) runtest
+ cd blas2;$(MAKE) runtest
+ cd blas3;$(MAKE) runtest
+
+sblastest:
+ cd sblas1;$(MAKE) runtest
+ cd sblas2;$(MAKE) runtest
+ cd sblas3;$(MAKE) runtest
+
+eigtest:
+ cd eig;$(MAKE) runtest
+
+seigtest:
+ cd seig;$(MAKE) runtest
+
+lintest:
+ cd lin;$(MAKE) runtest
+
+slintest:
+ cd slin;$(MAKE) runtest
+
+clean:
+ cd blas1;$(MAKE) clean
+ cd blas2;$(MAKE) clean
+ cd blas3;$(MAKE) clean
+ cd sblas1;$(MAKE) clean
+ cd sblas2;$(MAKE) clean
+ cd sblas3;$(MAKE) clean
+ cd eig;$(MAKE) clean
+ cd seig;$(MAKE) clean
+ cd lin;$(MAKE) clean
+ cd slin;$(MAKE) clean
+ cd matgen;$(MAKE) clean
+ cd smatgen;$(MAKE) clean
diff --git a/jlapack-3.1.1/src/testing/Makefile_javasrc b/jlapack-3.1.1/src/testing/Makefile_javasrc
new file mode 100644
index 0000000..c039490
--- /dev/null
+++ b/jlapack-3.1.1/src/testing/Makefile_javasrc
@@ -0,0 +1,79 @@
+.PHONY: blas1 blas2 blas3 runtests clean sblas1 sblas2 sblas3 eig lin seig slin
+
+ROOT=../..
+
+include $(ROOT)/make.def
+
+testers: blas1 blas2 blas3 eig lin sblas1 sblas2 sblas3 slin seig
+
+blas1: $(ROOT)/$(BLAS1TEST_IDX)
+blas2: $(ROOT)/$(BLAS2TEST_IDX)
+blas3: $(ROOT)/$(BLAS3TEST_IDX)
+eig: $(ROOT)/$(EIGTEST_IDX)
+lin: $(ROOT)/$(LINTEST_IDX)
+
+sblas1: $(ROOT)/$(SBLAS1TEST_IDX)
+sblas2: $(ROOT)/$(SBLAS2TEST_IDX)
+sblas3: $(ROOT)/$(SBLAS3TEST_IDX)
+seig: $(ROOT)/$(SEIGTEST_IDX)
+slin: $(ROOT)/$(SLINTEST_IDX)
+
+$(ROOT)/$(BLAS1TEST_IDX):
+ cd blas1;$(MAKE) -f Makefile_javasrc
+$(ROOT)/$(BLAS2TEST_IDX):
+ cd blas2;$(MAKE) -f Makefile_javasrc
+$(ROOT)/$(BLAS3TEST_IDX):
+ cd blas3;$(MAKE) -f Makefile_javasrc
+$(ROOT)/$(EIGTEST_IDX):
+ cd eig;$(MAKE) -f Makefile_javasrc
+$(ROOT)/$(LINTEST_IDX):
+ cd lin;$(MAKE) -f Makefile_javasrc
+
+$(ROOT)/$(SBLAS1TEST_IDX):
+ cd sblas1;$(MAKE) -f Makefile_javasrc
+$(ROOT)/$(SBLAS2TEST_IDX):
+ cd sblas2;$(MAKE) -f Makefile_javasrc
+$(ROOT)/$(SBLAS3TEST_IDX):
+ cd sblas3;$(MAKE) -f Makefile_javasrc
+$(ROOT)/$(SEIGTEST_IDX):
+ cd seig;$(MAKE) -f Makefile_javasrc
+$(ROOT)/$(SLINTEST_IDX):
+ cd slin;$(MAKE) -f Makefile_javasrc
+
+runtests: blastest lintest eigtest sblastest slintest seigtest
+
+blastest:
+ cd blas1;$(MAKE) -f Makefile_javasrc runtest
+ cd blas2;$(MAKE) -f Makefile_javasrc runtest
+ cd blas3;$(MAKE) -f Makefile_javasrc runtest
+
+sblastest:
+ cd sblas1;$(MAKE) -f Makefile_javasrc runtest
+ cd sblas2;$(MAKE) -f Makefile_javasrc runtest
+ cd sblas3;$(MAKE) -f Makefile_javasrc runtest
+
+eigtest:
+ cd eig;$(MAKE) -f Makefile_javasrc runtest
+
+seigtest:
+ cd seig;$(MAKE) -f Makefile_javasrc runtest
+
+lintest:
+ cd lin;$(MAKE) -f Makefile_javasrc runtest
+
+slintest:
+ cd slin;$(MAKE) -f Makefile_javasrc runtest
+
+clean:
+ cd blas1;$(MAKE) -f Makefile_javasrc clean
+ cd blas2;$(MAKE) -f Makefile_javasrc clean
+ cd blas3;$(MAKE) -f Makefile_javasrc clean
+ cd sblas1;$(MAKE) -f Makefile_javasrc clean
+ cd sblas2;$(MAKE) -f Makefile_javasrc clean
+ cd sblas3;$(MAKE) -f Makefile_javasrc clean
+ cd eig;$(MAKE) -f Makefile_javasrc clean
+ cd seig;$(MAKE) -f Makefile_javasrc clean
+ cd lin;$(MAKE) -f Makefile_javasrc clean
+ cd slin;$(MAKE) -f Makefile_javasrc clean
+ cd matgen;$(MAKE) -f Makefile_javasrc clean
+ cd smatgen;$(MAKE) -f Makefile_javasrc clean
diff --git a/jlapack-3.1.1/src/testing/blas1/Makefile b/jlapack-3.1.1/src/testing/blas1/Makefile
new file mode 100644
index 0000000..e14c03f
--- /dev/null
+++ b/jlapack-3.1.1/src/testing/blas1/Makefile
@@ -0,0 +1,35 @@
+.SUFFIXES: .f .java
+
+ROOT=../../..
+
+include $(ROOT)/make.def
+
+F2JFLAGS=-c .:$(ROOT)/$(BLAS_OBJ) -p $(BLASTEST_PACKAGE) -o $(OUTDIR) $(STATIC)
+
+tester: $(ROOT)/$(BLAS_DIR)/$(BLAS_JAR) $(ROOT)/$(BLAS1TEST_IDX) $(ROOT)/$(UTIL_DIR)/$(UTIL_JAR)
+ /bin/rm -f $(BLAS1TEST_JAR)
+ cd $(OUTDIR); $(JAR) cvf ../$(BLAS1TEST_JAR) `find . -name "*.class"`
+
+nojar: $(ROOT)/$(BLAS_DIR)/$(BLAS_JAR) $(ROOT)/$(BLAS1TEST_IDX) $(ROOT)/$(UTIL_DIR)/$(UTIL_JAR)
+
+$(ROOT)/$(BLAS1TEST_IDX): dblat1.f
+ $(F2J) $(F2JFLAGS) $< > /dev/null
+
+$(ROOT)/$(BLAS_DIR)/$(BLAS_JAR):
+ cd $(ROOT)/$(BLAS_DIR); $(MAKE)
+
+$(ROOT)/$(UTIL_DIR)/$(UTIL_JAR):
+ cd $(ROOT)/$(UTIL_DIR); $(MAKE)
+
+runtest: tester
+ $(JAVA) $(JFLAGS) -cp .:$(BLAS1TEST_JAR):$(ROOT)/$(BLAS_DIR)/$(BLAS_JAR):$(ROOT)/$(UTIL_DIR)/$(UTIL_JAR):$(ROOT)/$(ERR_DIR)/$(ERR_JAR) $(BLASTEST_PACKAGE).Dblat1
+
+srctest:
+ $(MAKE) -f Makefile_javasrc runtest
+
+verify: $(ROOT)/$(BLAS1TEST_IDX)
+ cd $(OUTDIR); $(JAVA) $(MORE_MEM_FLAG) -classpath .:$(JUSTICE):$(BCEL):$(ROOT)/../$(UTIL_DIR)/$(UTIL_JAR):$(ROOT)/../$(ERR_DIR)/$(ERR_JAR):$(ROOT)/../$(BLAS_DIR)/$(BLAS_JAR) $(VERIFY) $(BLASTEST_PDIR)/*.class
+
+
+clean:
+ /bin/rm -rf *.java *.class *.f2j $(OUTDIR) $(JAVASRC_OUTDIR) $(BLAS1TEST_JAR)
diff --git a/jlapack-3.1.1/src/testing/blas1/Makefile_javasrc b/jlapack-3.1.1/src/testing/blas1/Makefile_javasrc
new file mode 100644
index 0000000..baa26ce
--- /dev/null
+++ b/jlapack-3.1.1/src/testing/blas1/Makefile_javasrc
@@ -0,0 +1,32 @@
+.SUFFIXES: .f .java
+
+ROOT=../../..
+
+include $(ROOT)/make.def
+
+tester: $(ROOT)/$(BLAS_DIR)/$(BLAS_JAR) $(ROOT)/$(BLAS1TEST_IDX) $(ROOT)/$(UTIL_DIR)/$(UTIL_JAR)
+ /bin/rm -f `find . -name "*.class"`
+ mkdir -p $(JAVASRC_OUTDIR)
+ $(JAVAC) -classpath $(JAVASRC_OUTDIR):$(ROOT)/$(UTIL_DIR)/$(UTIL_JAR):$(ROOT)/$(ERR_DIR)/$(ERR_JAR):$(ROOT)/$(BLAS_DIR)/$(BLAS_JAR) -d $(JAVASRC_OUTDIR) $(OUTDIR)/$(BLASTEST_PDIR)/*.java
+ /bin/rm -f $(JAVASRC_OUTDIR)/$(BLASTEST_PDIR)/*.old
+ $(JAVAB) $(JAVASRC_OUTDIR)/$(BLASTEST_PDIR)/*.class
+ /bin/rm -f $(BLAS1TEST_JAR)
+ cd $(JAVASRC_OUTDIR); $(JAR) cvf ../$(BLAS1TEST_JAR) `find . -name "*.class"`
+
+$(ROOT)/$(BLAS1TEST_IDX): dblat1.f
+ $(MAKE) nojar
+
+$(ROOT)/$(BLAS_DIR)/$(BLAS_JAR):
+ cd $(ROOT)/$(BLAS_DIR); $(MAKE) -f Makefile_javasrc
+
+$(ROOT)/$(UTIL_DIR)/$(UTIL_JAR):
+ cd $(ROOT)/$(UTIL_DIR); $(MAKE)
+
+runtest: tester
+ $(JAVA) $(JFLAGS) -cp .:$(BLAS1TEST_JAR):$(ROOT)/$(BLAS_DIR)/$(BLAS_JAR):$(ROOT)/$(UTIL_DIR)/$(UTIL_JAR):$(ROOT)/$(ERR_DIR)/$(ERR_JAR) $(BLASTEST_PACKAGE).Dblat1
+
+verify: $(ROOT)/$(BLAS1TEST_IDX)
+ cd $(JAVASRC_OUTDIR); $(JAVA) $(MORE_MEM_FLAG) -classpath .:$(JUSTICE):$(BCEL):$(ROOT)/../$(UTIL_DIR)/$(UTIL_JAR):$(ROOT)/../$(ERR_DIR)/$(ERR_JAR):$(ROOT)/../$(BLAS_DIR)/$(BLAS_JAR) $(VERIFY) $(BLASTEST_PDIR)/*.class
+
+clean:
+ /bin/rm -rf *.java *.class *.f2j $(OUTDIR) $(JAVASRC_OUTDIR) $(BLAS1TEST_JAR)
diff --git a/jlapack-3.1.1/src/testing/blas1/dblat1.f b/jlapack-3.1.1/src/testing/blas1/dblat1.f
new file mode 100644
index 0000000..9c1c62e
--- /dev/null
+++ b/jlapack-3.1.1/src/testing/blas1/dblat1.f
@@ -0,0 +1,769 @@
+ PROGRAM DBLAT1
+* Test program for the DOUBLE PRECISION Level 1 BLAS.
+* Based upon the original BLAS test routine together with:
+* F06EAF Example Program Text
+* .. Parameters ..
+ INTEGER NOUT
+ PARAMETER (NOUT=6)
+* .. Scalars in Common ..
+ INTEGER ICASE, INCX, INCY, MODE, N
+ LOGICAL PASS
+* .. Local Scalars ..
+ DOUBLE PRECISION SFAC
+ INTEGER IC
+* .. External Subroutines ..
+ EXTERNAL CHECK0, CHECK1, CHECK2, CHECK3, HEADER
+* .. Common blocks ..
+ COMMON /COMBLA/ICASE, N, INCX, INCY, MODE, PASS
+* .. Data statements ..
+ DATA SFAC/9.765625D-4/
+* .. Executable Statements ..
+ WRITE (NOUT,99999)
+ DO 20 IC = 1, 10
+ ICASE = IC
+ CALL HEADER
+*
+* .. Initialize PASS, INCX, INCY, and MODE for a new case. ..
+* .. the value 9999 for INCX, INCY or MODE will appear in the ..
+* .. detailed output, if any, for cases that do not involve ..
+* .. these parameters ..
+*
+ PASS = .TRUE.
+ INCX = 9999
+ INCY = 9999
+ MODE = 9999
+ IF (ICASE.EQ.3) THEN
+ CALL CHECK0(SFAC)
+ ELSE IF (ICASE.EQ.7 .OR. ICASE.EQ.8 .OR. ICASE.EQ.9 .OR.
+ + ICASE.EQ.10) THEN
+ CALL CHECK1(SFAC)
+ ELSE IF (ICASE.EQ.1 .OR. ICASE.EQ.2 .OR. ICASE.EQ.5 .OR.
+ + ICASE.EQ.6) THEN
+ CALL CHECK2(SFAC)
+ ELSE IF (ICASE.EQ.4) THEN
+ CALL CHECK3(SFAC)
+ END IF
+* -- Print
+ IF (PASS) WRITE (NOUT,99998)
+ 20 CONTINUE
+ STOP
+*
+99999 FORMAT (' Real BLAS Test Program Results',/1X)
+99998 FORMAT (' ----- PASS -----')
+ END
+ SUBROUTINE HEADER
+* .. Parameters ..
+ INTEGER NOUT
+ PARAMETER (NOUT=6)
+* .. Scalars in Common ..
+ INTEGER ICASE, INCX, INCY, MODE, N
+ LOGICAL PASS
+* .. Local Arrays ..
+ CHARACTER*6 L(10)
+* .. Common blocks ..
+ COMMON /COMBLA/ICASE, N, INCX, INCY, MODE, PASS
+* .. Data statements ..
+ DATA L(1)/' DDOT '/
+ DATA L(2)/'DAXPY '/
+ DATA L(3)/'DROTG '/
+ DATA L(4)/' DROT '/
+ DATA L(5)/'DCOPY '/
+ DATA L(6)/'DSWAP '/
+ DATA L(7)/'DNRM2 '/
+ DATA L(8)/'DASUM '/
+ DATA L(9)/'DSCAL '/
+ DATA L(10)/'IDAMAX'/
+* .. Executable Statements ..
+ WRITE (NOUT,99999) ICASE, L(ICASE)
+ RETURN
+*
+99999 FORMAT (/' Test of subprogram number',I3,12X,A6)
+ END
+ SUBROUTINE CHECK0(SFAC)
+* .. Parameters ..
+ INTEGER NOUT
+ PARAMETER (NOUT=6)
+* .. Scalar Arguments ..
+ DOUBLE PRECISION SFAC
+* .. Scalars in Common ..
+ INTEGER ICASE, INCX, INCY, MODE, N
+ LOGICAL PASS
+* .. Local Scalars ..
+ DOUBLE PRECISION D12, SA, SB, SC, SS
+ INTEGER K
+* .. Local Arrays ..
+ DOUBLE PRECISION DA1(8), DATRUE(8), DB1(8), DBTRUE(8), DC1(8),
+ + DS1(8)
+* .. External Subroutines ..
+ EXTERNAL DROTG, STEST1
+* .. Common blocks ..
+ COMMON /COMBLA/ICASE, N, INCX, INCY, MODE, PASS
+* .. Data statements ..
+ DATA DA1/0.3D0, 0.4D0, -0.3D0, -0.4D0, -0.3D0, 0.0D0,
+ + 0.0D0, 1.0D0/
+ DATA DB1/0.4D0, 0.3D0, 0.4D0, 0.3D0, -0.4D0, 0.0D0,
+ + 1.0D0, 0.0D0/
+ DATA DC1/0.6D0, 0.8D0, -0.6D0, 0.8D0, 0.6D0, 1.0D0,
+ + 0.0D0, 1.0D0/
+ DATA DS1/0.8D0, 0.6D0, 0.8D0, -0.6D0, 0.8D0, 0.0D0,
+ + 1.0D0, 0.0D0/
+ DATA DATRUE/0.5D0, 0.5D0, 0.5D0, -0.5D0, -0.5D0,
+ + 0.0D0, 1.0D0, 1.0D0/
+ DATA DBTRUE/0.0D0, 0.6D0, 0.0D0, -0.6D0, 0.0D0,
+ + 0.0D0, 1.0D0, 0.0D0/
+ DATA D12/4096.0D0/
+* .. Executable Statements ..
+*
+* Compute true values which cannot be prestored
+* in decimal notation
+*
+ DBTRUE(1) = 1.0D0/0.6D0
+ DBTRUE(3) = -1.0D0/0.6D0
+ DBTRUE(5) = 1.0D0/0.6D0
+*
+ DO 20 K = 1, 8
+* .. Set N=K for identification in output if any ..
+ N = K
+ IF (ICASE.EQ.3) THEN
+* .. DROTG ..
+ IF (K.GT.8) GO TO 40
+ SA = DA1(K)
+ SB = DB1(K)
+ CALL DROTG(SA,SB,SC,SS)
+ CALL STEST1(SA,DATRUE(K),DATRUE(K),SFAC)
+ CALL STEST1(SB,DBTRUE(K),DBTRUE(K),SFAC)
+ CALL STEST1(SC,DC1(K),DC1(K),SFAC)
+ CALL STEST1(SS,DS1(K),DS1(K),SFAC)
+ ELSE
+ WRITE (NOUT,*) ' Shouldn''t be here in CHECK0'
+ STOP
+ END IF
+ 20 CONTINUE
+ 40 RETURN
+ END
+ SUBROUTINE CHECK1(SFAC)
+* .. Parameters ..
+ INTEGER NOUT
+ PARAMETER (NOUT=6)
+* .. Scalar Arguments ..
+ DOUBLE PRECISION SFAC
+* .. Scalars in Common ..
+ INTEGER ICASE, INCX, INCY, MODE, N
+ LOGICAL PASS
+* .. Local Scalars ..
+ INTEGER I, LEN, NP1
+* .. Local Arrays ..
+ DOUBLE PRECISION DTRUE1(5), DTRUE3(5), DTRUE5(8,5,2), DV(8,5,2),
+ + SA(10), STEMP(1), STRUE(8), SX(8)
+ INTEGER ITRUE2(5)
+* .. External Functions ..
+ DOUBLE PRECISION DASUM, DNRM2
+ INTEGER IDAMAX
+ EXTERNAL DASUM, DNRM2, IDAMAX
+* .. External Subroutines ..
+ EXTERNAL ITEST1, DSCAL, STEST, STEST1
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* .. Common blocks ..
+ COMMON /COMBLA/ICASE, N, INCX, INCY, MODE, PASS
+* .. Data statements ..
+ DATA SA/0.3D0, -1.0D0, 0.0D0, 1.0D0, 0.3D0, 0.3D0,
+ + 0.3D0, 0.3D0, 0.3D0, 0.3D0/
+ DATA DV/0.1D0, 2.0D0, 2.0D0, 2.0D0, 2.0D0, 2.0D0,
+ + 2.0D0, 2.0D0, 0.3D0, 3.0D0, 3.0D0, 3.0D0, 3.0D0,
+ + 3.0D0, 3.0D0, 3.0D0, 0.3D0, -0.4D0, 4.0D0,
+ + 4.0D0, 4.0D0, 4.0D0, 4.0D0, 4.0D0, 0.2D0,
+ + -0.6D0, 0.3D0, 5.0D0, 5.0D0, 5.0D0, 5.0D0,
+ + 5.0D0, 0.1D0, -0.3D0, 0.5D0, -0.1D0, 6.0D0,
+ + 6.0D0, 6.0D0, 6.0D0, 0.1D0, 8.0D0, 8.0D0, 8.0D0,
+ + 8.0D0, 8.0D0, 8.0D0, 8.0D0, 0.3D0, 9.0D0, 9.0D0,
+ + 9.0D0, 9.0D0, 9.0D0, 9.0D0, 9.0D0, 0.3D0, 2.0D0,
+ + -0.4D0, 2.0D0, 2.0D0, 2.0D0, 2.0D0, 2.0D0,
+ + 0.2D0, 3.0D0, -0.6D0, 5.0D0, 0.3D0, 2.0D0,
+ + 2.0D0, 2.0D0, 0.1D0, 4.0D0, -0.3D0, 6.0D0,
+ + -0.5D0, 7.0D0, -0.1D0, 3.0D0/
+ DATA DTRUE1/0.0D0, 0.3D0, 0.5D0, 0.7D0, 0.6D0/
+ DATA DTRUE3/0.0D0, 0.3D0, 0.7D0, 1.1D0, 1.0D0/
+ DATA DTRUE5/0.10D0, 2.0D0, 2.0D0, 2.0D0, 2.0D0,
+ + 2.0D0, 2.0D0, 2.0D0, -0.3D0, 3.0D0, 3.0D0,
+ + 3.0D0, 3.0D0, 3.0D0, 3.0D0, 3.0D0, 0.0D0, 0.0D0,
+ + 4.0D0, 4.0D0, 4.0D0, 4.0D0, 4.0D0, 4.0D0,
+ + 0.20D0, -0.60D0, 0.30D0, 5.0D0, 5.0D0, 5.0D0,
+ + 5.0D0, 5.0D0, 0.03D0, -0.09D0, 0.15D0, -0.03D0,
+ + 6.0D0, 6.0D0, 6.0D0, 6.0D0, 0.10D0, 8.0D0,
+ + 8.0D0, 8.0D0, 8.0D0, 8.0D0, 8.0D0, 8.0D0,
+ + 0.09D0, 9.0D0, 9.0D0, 9.0D0, 9.0D0, 9.0D0,
+ + 9.0D0, 9.0D0, 0.09D0, 2.0D0, -0.12D0, 2.0D0,
+ + 2.0D0, 2.0D0, 2.0D0, 2.0D0, 0.06D0, 3.0D0,
+ + -0.18D0, 5.0D0, 0.09D0, 2.0D0, 2.0D0, 2.0D0,
+ + 0.03D0, 4.0D0, -0.09D0, 6.0D0, -0.15D0, 7.0D0,
+ + -0.03D0, 3.0D0/
+ DATA ITRUE2/0, 1, 2, 2, 3/
+* .. Executable Statements ..
+ DO 80 INCX = 1, 2
+ DO 60 NP1 = 1, 5
+ N = NP1 - 1
+ LEN = 2*MAX(N,1)
+* .. Set vector arguments ..
+ DO 20 I = 1, LEN
+ SX(I) = DV(I,NP1,INCX)
+ 20 CONTINUE
+*
+ IF (ICASE.EQ.7) THEN
+* .. DNRM2 ..
+ STEMP(1) = DTRUE1(NP1)
+ CALL STEST1(DNRM2(N,SX,INCX),STEMP(1),STEMP,SFAC)
+ ELSE IF (ICASE.EQ.8) THEN
+* .. DASUM ..
+ STEMP(1) = DTRUE3(NP1)
+ CALL STEST1(DASUM(N,SX,INCX),STEMP(1),STEMP,SFAC)
+ ELSE IF (ICASE.EQ.9) THEN
+* .. DSCAL ..
+ CALL DSCAL(N,SA((INCX-1)*5+NP1),SX,INCX)
+ DO 40 I = 1, LEN
+ STRUE(I) = DTRUE5(I,NP1,INCX)
+ 40 CONTINUE
+ CALL STEST(LEN,SX,STRUE,STRUE,SFAC)
+ ELSE IF (ICASE.EQ.10) THEN
+* .. IDAMAX ..
+ CALL ITEST1(IDAMAX(N,SX,INCX),ITRUE2(NP1))
+ ELSE
+ WRITE (NOUT,*) ' Shouldn''t be here in CHECK1'
+ STOP
+ END IF
+ 60 CONTINUE
+ 80 CONTINUE
+ RETURN
+ END
+ SUBROUTINE CHECK2(SFAC)
+* .. Parameters ..
+ INTEGER NOUT
+ PARAMETER (NOUT=6)
+* .. Scalar Arguments ..
+ DOUBLE PRECISION SFAC
+* .. Scalars in Common ..
+ INTEGER ICASE, INCX, INCY, MODE, N
+ LOGICAL PASS
+* .. Local Scalars ..
+ DOUBLE PRECISION SA, SC, SS
+ INTEGER I, J, KI, KN, KSIZE, LENX, LENY, MX, MY
+* .. Local Arrays ..
+ DOUBLE PRECISION DT10X(7,4,4), DT10Y(7,4,4), DT7(4,4),
+ + DT8(7,4,4), DT9X(7,4,4), DT9Y(7,4,4), DX1(7),
+ + DY1(7), SSIZE1(4), SSIZE2(14,2), STX(7), STY(7),
+ + SX(7), SY(7)
+ INTEGER INCXS(4), INCYS(4), LENS(4,2), NS(4)
+* .. External Functions ..
+ DOUBLE PRECISION DDOT
+ EXTERNAL DDOT
+* .. External Subroutines ..
+ EXTERNAL DAXPY, DCOPY, DSWAP, STEST, STEST1
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MIN
+* .. Common blocks ..
+ COMMON /COMBLA/ICASE, N, INCX, INCY, MODE, PASS
+* .. Data statements ..
+ DATA SA/0.3D0/
+ DATA INCXS/1, 2, -2, -1/
+ DATA INCYS/1, -2, 1, -2/
+ DATA LENS/1, 1, 2, 4, 1, 1, 3, 7/
+ DATA NS/0, 1, 2, 4/
+ DATA DX1/0.6D0, 0.1D0, -0.5D0, 0.8D0, 0.9D0, -0.3D0,
+ + -0.4D0/
+ DATA DY1/0.5D0, -0.9D0, 0.3D0, 0.7D0, -0.6D0, 0.2D0,
+ + 0.8D0/
+ DATA SC, SS/0.8D0, 0.6D0/
+ DATA DT7/0.0D0, 0.30D0, 0.21D0, 0.62D0, 0.0D0,
+ + 0.30D0, -0.07D0, 0.85D0, 0.0D0, 0.30D0, -0.79D0,
+ + -0.74D0, 0.0D0, 0.30D0, 0.33D0, 1.27D0/
+ DATA DT8/0.5D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
+ + 0.0D0, 0.68D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
+ + 0.0D0, 0.0D0, 0.68D0, -0.87D0, 0.0D0, 0.0D0,
+ + 0.0D0, 0.0D0, 0.0D0, 0.68D0, -0.87D0, 0.15D0,
+ + 0.94D0, 0.0D0, 0.0D0, 0.0D0, 0.5D0, 0.0D0,
+ + 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.68D0,
+ + 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
+ + 0.35D0, -0.9D0, 0.48D0, 0.0D0, 0.0D0, 0.0D0,
+ + 0.0D0, 0.38D0, -0.9D0, 0.57D0, 0.7D0, -0.75D0,
+ + 0.2D0, 0.98D0, 0.5D0, 0.0D0, 0.0D0, 0.0D0,
+ + 0.0D0, 0.0D0, 0.0D0, 0.68D0, 0.0D0, 0.0D0,
+ + 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.35D0, -0.72D0,
+ + 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.38D0,
+ + -0.63D0, 0.15D0, 0.88D0, 0.0D0, 0.0D0, 0.0D0,
+ + 0.5D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
+ + 0.68D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
+ + 0.0D0, 0.68D0, -0.9D0, 0.33D0, 0.0D0, 0.0D0,
+ + 0.0D0, 0.0D0, 0.68D0, -0.9D0, 0.33D0, 0.7D0,
+ + -0.75D0, 0.2D0, 1.04D0/
+ DATA DT9X/0.6D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
+ + 0.0D0, 0.78D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
+ + 0.0D0, 0.0D0, 0.78D0, -0.46D0, 0.0D0, 0.0D0,
+ + 0.0D0, 0.0D0, 0.0D0, 0.78D0, -0.46D0, -0.22D0,
+ + 1.06D0, 0.0D0, 0.0D0, 0.0D0, 0.6D0, 0.0D0,
+ + 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.78D0,
+ + 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
+ + 0.66D0, 0.1D0, -0.1D0, 0.0D0, 0.0D0, 0.0D0,
+ + 0.0D0, 0.96D0, 0.1D0, -0.76D0, 0.8D0, 0.90D0,
+ + -0.3D0, -0.02D0, 0.6D0, 0.0D0, 0.0D0, 0.0D0,
+ + 0.0D0, 0.0D0, 0.0D0, 0.78D0, 0.0D0, 0.0D0,
+ + 0.0D0, 0.0D0, 0.0D0, 0.0D0, -0.06D0, 0.1D0,
+ + -0.1D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.90D0,
+ + 0.1D0, -0.22D0, 0.8D0, 0.18D0, -0.3D0, -0.02D0,
+ + 0.6D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
+ + 0.78D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
+ + 0.0D0, 0.78D0, 0.26D0, 0.0D0, 0.0D0, 0.0D0,
+ + 0.0D0, 0.0D0, 0.78D0, 0.26D0, -0.76D0, 1.12D0,
+ + 0.0D0, 0.0D0, 0.0D0/
+ DATA DT9Y/0.5D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
+ + 0.0D0, 0.04D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
+ + 0.0D0, 0.0D0, 0.04D0, -0.78D0, 0.0D0, 0.0D0,
+ + 0.0D0, 0.0D0, 0.0D0, 0.04D0, -0.78D0, 0.54D0,
+ + 0.08D0, 0.0D0, 0.0D0, 0.0D0, 0.5D0, 0.0D0,
+ + 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.04D0,
+ + 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.7D0,
+ + -0.9D0, -0.12D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
+ + 0.64D0, -0.9D0, -0.30D0, 0.7D0, -0.18D0, 0.2D0,
+ + 0.28D0, 0.5D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
+ + 0.0D0, 0.0D0, 0.04D0, 0.0D0, 0.0D0, 0.0D0,
+ + 0.0D0, 0.0D0, 0.0D0, 0.7D0, -1.08D0, 0.0D0,
+ + 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.64D0, -1.26D0,
+ + 0.54D0, 0.20D0, 0.0D0, 0.0D0, 0.0D0, 0.5D0,
+ + 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
+ + 0.04D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
+ + 0.0D0, 0.04D0, -0.9D0, 0.18D0, 0.0D0, 0.0D0,
+ + 0.0D0, 0.0D0, 0.04D0, -0.9D0, 0.18D0, 0.7D0,
+ + -0.18D0, 0.2D0, 0.16D0/
+ DATA DT10X/0.6D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
+ + 0.0D0, 0.5D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
+ + 0.0D0, 0.5D0, -0.9D0, 0.0D0, 0.0D0, 0.0D0,
+ + 0.0D0, 0.0D0, 0.5D0, -0.9D0, 0.3D0, 0.7D0,
+ + 0.0D0, 0.0D0, 0.0D0, 0.6D0, 0.0D0, 0.0D0, 0.0D0,
+ + 0.0D0, 0.0D0, 0.0D0, 0.5D0, 0.0D0, 0.0D0, 0.0D0,
+ + 0.0D0, 0.0D0, 0.0D0, 0.3D0, 0.1D0, 0.5D0, 0.0D0,
+ + 0.0D0, 0.0D0, 0.0D0, 0.8D0, 0.1D0, -0.6D0,
+ + 0.8D0, 0.3D0, -0.3D0, 0.5D0, 0.6D0, 0.0D0,
+ + 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.5D0, 0.0D0,
+ + 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, -0.9D0,
+ + 0.1D0, 0.5D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.7D0,
+ + 0.1D0, 0.3D0, 0.8D0, -0.9D0, -0.3D0, 0.5D0,
+ + 0.6D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
+ + 0.5D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
+ + 0.5D0, 0.3D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
+ + 0.5D0, 0.3D0, -0.6D0, 0.8D0, 0.0D0, 0.0D0,
+ + 0.0D0/
+ DATA DT10Y/0.5D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
+ + 0.0D0, 0.6D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
+ + 0.0D0, 0.6D0, 0.1D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
+ + 0.0D0, 0.6D0, 0.1D0, -0.5D0, 0.8D0, 0.0D0,
+ + 0.0D0, 0.0D0, 0.5D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
+ + 0.0D0, 0.0D0, 0.6D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
+ + 0.0D0, 0.0D0, -0.5D0, -0.9D0, 0.6D0, 0.0D0,
+ + 0.0D0, 0.0D0, 0.0D0, -0.4D0, -0.9D0, 0.9D0,
+ + 0.7D0, -0.5D0, 0.2D0, 0.6D0, 0.5D0, 0.0D0,
+ + 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.6D0, 0.0D0,
+ + 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, -0.5D0,
+ + 0.6D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
+ + -0.4D0, 0.9D0, -0.5D0, 0.6D0, 0.0D0, 0.0D0,
+ + 0.0D0, 0.5D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
+ + 0.0D0, 0.6D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
+ + 0.0D0, 0.6D0, -0.9D0, 0.1D0, 0.0D0, 0.0D0,
+ + 0.0D0, 0.0D0, 0.6D0, -0.9D0, 0.1D0, 0.7D0,
+ + -0.5D0, 0.2D0, 0.8D0/
+ DATA SSIZE1/0.0D0, 0.3D0, 1.6D0, 3.2D0/
+ DATA SSIZE2/0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
+ + 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
+ + 0.0D0, 1.17D0, 1.17D0, 1.17D0, 1.17D0, 1.17D0,
+ + 1.17D0, 1.17D0, 1.17D0, 1.17D0, 1.17D0, 1.17D0,
+ + 1.17D0, 1.17D0, 1.17D0/
+* .. Executable Statements ..
+*
+ DO 120 KI = 1, 4
+ INCX = INCXS(KI)
+ INCY = INCYS(KI)
+ MX = ABS(INCX)
+ MY = ABS(INCY)
+*
+ DO 100 KN = 1, 4
+ N = NS(KN)
+ KSIZE = MIN(2,KN)
+ LENX = LENS(KN,MX)
+ LENY = LENS(KN,MY)
+* .. Initialize all argument arrays ..
+ DO 20 I = 1, 7
+ SX(I) = DX1(I)
+ SY(I) = DY1(I)
+ 20 CONTINUE
+*
+ IF (ICASE.EQ.1) THEN
+* .. DDOT ..
+ CALL STEST1(DDOT(N,SX,INCX,SY,INCY),DT7(KN,KI),SSIZE1(KN)
+ + ,SFAC)
+ ELSE IF (ICASE.EQ.2) THEN
+* .. DAXPY ..
+ CALL DAXPY(N,SA,SX,INCX,SY,INCY)
+ DO 40 J = 1, LENY
+ STY(J) = DT8(J,KN,KI)
+ 40 CONTINUE
+ CALL STEST(LENY,SY,STY,SSIZE2(1,KSIZE),SFAC)
+ ELSE IF (ICASE.EQ.5) THEN
+* .. DCOPY ..
+ DO 60 I = 1, 7
+ STY(I) = DT10Y(I,KN,KI)
+ 60 CONTINUE
+ CALL DCOPY(N,SX,INCX,SY,INCY)
+ CALL STEST(LENY,SY,STY,SSIZE2(1,1),1.0D0)
+ ELSE IF (ICASE.EQ.6) THEN
+* .. DSWAP ..
+ CALL DSWAP(N,SX,INCX,SY,INCY)
+ DO 80 I = 1, 7
+ STX(I) = DT10X(I,KN,KI)
+ STY(I) = DT10Y(I,KN,KI)
+ 80 CONTINUE
+ CALL STEST(LENX,SX,STX,SSIZE2(1,1),1.0D0)
+ CALL STEST(LENY,SY,STY,SSIZE2(1,1),1.0D0)
+ ELSE
+ WRITE (NOUT,*) ' Shouldn''t be here in CHECK2'
+ STOP
+ END IF
+ 100 CONTINUE
+ 120 CONTINUE
+ RETURN
+ END
+ SUBROUTINE CHECK3(SFAC)
+* .. Parameters ..
+ INTEGER NOUT
+ PARAMETER (NOUT=6)
+* .. Scalar Arguments ..
+ DOUBLE PRECISION SFAC
+* .. Scalars in Common ..
+ INTEGER ICASE, INCX, INCY, MODE, N
+ LOGICAL PASS
+* .. Local Scalars ..
+ DOUBLE PRECISION SA, SC, SS
+ INTEGER I, K, KI, KN, KSIZE, LENX, LENY, MX, MY
+* .. Local Arrays ..
+ DOUBLE PRECISION COPYX(5), COPYY(5), DT9X(7,4,4), DT9Y(7,4,4),
+ + DX1(7), DY1(7), MWPC(11), MWPS(11), MWPSTX(5),
+ + MWPSTY(5), MWPTX(11,5), MWPTY(11,5), MWPX(5),
+ + MWPY(5), SSIZE2(14,2), STX(7), STY(7), SX(7),
+ + SY(7)
+ INTEGER INCXS(4), INCYS(4), LENS(4,2), MWPINX(11),
+ + MWPINY(11), MWPN(11), NS(4)
+* .. External Subroutines ..
+ EXTERNAL DROT, STEST
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MIN
+* .. Common blocks ..
+ COMMON /COMBLA/ICASE, N, INCX, INCY, MODE, PASS
+* .. Data statements ..
+ DATA SA/0.3D0/
+ DATA INCXS/1, 2, -2, -1/
+ DATA INCYS/1, -2, 1, -2/
+ DATA LENS/1, 1, 2, 4, 1, 1, 3, 7/
+ DATA NS/0, 1, 2, 4/
+ DATA DX1/0.6D0, 0.1D0, -0.5D0, 0.8D0, 0.9D0, -0.3D0,
+ + -0.4D0/
+ DATA DY1/0.5D0, -0.9D0, 0.3D0, 0.7D0, -0.6D0, 0.2D0,
+ + 0.8D0/
+ DATA SC, SS/0.8D0, 0.6D0/
+ DATA DT9X/0.6D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
+ + 0.0D0, 0.78D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
+ + 0.0D0, 0.0D0, 0.78D0, -0.46D0, 0.0D0, 0.0D0,
+ + 0.0D0, 0.0D0, 0.0D0, 0.78D0, -0.46D0, -0.22D0,
+ + 1.06D0, 0.0D0, 0.0D0, 0.0D0, 0.6D0, 0.0D0,
+ + 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.78D0,
+ + 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
+ + 0.66D0, 0.1D0, -0.1D0, 0.0D0, 0.0D0, 0.0D0,
+ + 0.0D0, 0.96D0, 0.1D0, -0.76D0, 0.8D0, 0.90D0,
+ + -0.3D0, -0.02D0, 0.6D0, 0.0D0, 0.0D0, 0.0D0,
+ + 0.0D0, 0.0D0, 0.0D0, 0.78D0, 0.0D0, 0.0D0,
+ + 0.0D0, 0.0D0, 0.0D0, 0.0D0, -0.06D0, 0.1D0,
+ + -0.1D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.90D0,
+ + 0.1D0, -0.22D0, 0.8D0, 0.18D0, -0.3D0, -0.02D0,
+ + 0.6D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
+ + 0.78D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
+ + 0.0D0, 0.78D0, 0.26D0, 0.0D0, 0.0D0, 0.0D0,
+ + 0.0D0, 0.0D0, 0.78D0, 0.26D0, -0.76D0, 1.12D0,
+ + 0.0D0, 0.0D0, 0.0D0/
+ DATA DT9Y/0.5D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
+ + 0.0D0, 0.04D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
+ + 0.0D0, 0.0D0, 0.04D0, -0.78D0, 0.0D0, 0.0D0,
+ + 0.0D0, 0.0D0, 0.0D0, 0.04D0, -0.78D0, 0.54D0,
+ + 0.08D0, 0.0D0, 0.0D0, 0.0D0, 0.5D0, 0.0D0,
+ + 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.04D0,
+ + 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.7D0,
+ + -0.9D0, -0.12D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
+ + 0.64D0, -0.9D0, -0.30D0, 0.7D0, -0.18D0, 0.2D0,
+ + 0.28D0, 0.5D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
+ + 0.0D0, 0.0D0, 0.04D0, 0.0D0, 0.0D0, 0.0D0,
+ + 0.0D0, 0.0D0, 0.0D0, 0.7D0, -1.08D0, 0.0D0,
+ + 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.64D0, -1.26D0,
+ + 0.54D0, 0.20D0, 0.0D0, 0.0D0, 0.0D0, 0.5D0,
+ + 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
+ + 0.04D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
+ + 0.0D0, 0.04D0, -0.9D0, 0.18D0, 0.0D0, 0.0D0,
+ + 0.0D0, 0.0D0, 0.04D0, -0.9D0, 0.18D0, 0.7D0,
+ + -0.18D0, 0.2D0, 0.16D0/
+ DATA SSIZE2/0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
+ + 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0, 0.0D0,
+ + 0.0D0, 1.17D0, 1.17D0, 1.17D0, 1.17D0, 1.17D0,
+ + 1.17D0, 1.17D0, 1.17D0, 1.17D0, 1.17D0, 1.17D0,
+ + 1.17D0, 1.17D0, 1.17D0/
+* .. Executable Statements ..
+*
+ DO 60 KI = 1, 4
+ INCX = INCXS(KI)
+ INCY = INCYS(KI)
+ MX = ABS(INCX)
+ MY = ABS(INCY)
+*
+ DO 40 KN = 1, 4
+ N = NS(KN)
+ KSIZE = MIN(2,KN)
+ LENX = LENS(KN,MX)
+ LENY = LENS(KN,MY)
+*
+ IF (ICASE.EQ.4) THEN
+* .. DROT ..
+ DO 20 I = 1, 7
+ SX(I) = DX1(I)
+ SY(I) = DY1(I)
+ STX(I) = DT9X(I,KN,KI)
+ STY(I) = DT9Y(I,KN,KI)
+ 20 CONTINUE
+ CALL DROT(N,SX,INCX,SY,INCY,SC,SS)
+ CALL STEST(LENX,SX,STX,SSIZE2(1,KSIZE),SFAC)
+ CALL STEST(LENY,SY,STY,SSIZE2(1,KSIZE),SFAC)
+ ELSE
+ WRITE (NOUT,*) ' Shouldn''t be here in CHECK3'
+ STOP
+ END IF
+ 40 CONTINUE
+ 60 CONTINUE
+*
+ MWPC(1) = 1
+ DO 80 I = 2, 11
+ MWPC(I) = 0
+ 80 CONTINUE
+ MWPS(1) = 0
+ DO 100 I = 2, 6
+ MWPS(I) = 1
+ 100 CONTINUE
+ DO 120 I = 7, 11
+ MWPS(I) = -1
+ 120 CONTINUE
+ MWPINX(1) = 1
+ MWPINX(2) = 1
+ MWPINX(3) = 1
+ MWPINX(4) = -1
+ MWPINX(5) = 1
+ MWPINX(6) = -1
+ MWPINX(7) = 1
+ MWPINX(8) = 1
+ MWPINX(9) = -1
+ MWPINX(10) = 1
+ MWPINX(11) = -1
+ MWPINY(1) = 1
+ MWPINY(2) = 1
+ MWPINY(3) = -1
+ MWPINY(4) = -1
+ MWPINY(5) = 2
+ MWPINY(6) = 1
+ MWPINY(7) = 1
+ MWPINY(8) = -1
+ MWPINY(9) = -1
+ MWPINY(10) = 2
+ MWPINY(11) = 1
+ DO 140 I = 1, 11
+ MWPN(I) = 5
+ 140 CONTINUE
+ MWPN(5) = 3
+ MWPN(10) = 3
+ DO 160 I = 1, 5
+ MWPX(I) = I
+ MWPY(I) = I
+ MWPTX(1,I) = I
+ MWPTY(1,I) = I
+ MWPTX(2,I) = I
+ MWPTY(2,I) = -I
+ MWPTX(3,I) = 6 - I
+ MWPTY(3,I) = I - 6
+ MWPTX(4,I) = I
+ MWPTY(4,I) = -I
+ MWPTX(6,I) = 6 - I
+ MWPTY(6,I) = I - 6
+ MWPTX(7,I) = -I
+ MWPTY(7,I) = I
+ MWPTX(8,I) = I - 6
+ MWPTY(8,I) = 6 - I
+ MWPTX(9,I) = -I
+ MWPTY(9,I) = I
+ MWPTX(11,I) = I - 6
+ MWPTY(11,I) = 6 - I
+ 160 CONTINUE
+ MWPTX(5,1) = 1
+ MWPTX(5,2) = 3
+ MWPTX(5,3) = 5
+ MWPTX(5,4) = 4
+ MWPTX(5,5) = 5
+ MWPTY(5,1) = -1
+ MWPTY(5,2) = 2
+ MWPTY(5,3) = -2
+ MWPTY(5,4) = 4
+ MWPTY(5,5) = -3
+ MWPTX(10,1) = -1
+ MWPTX(10,2) = -3
+ MWPTX(10,3) = -5
+ MWPTX(10,4) = 4
+ MWPTX(10,5) = 5
+ MWPTY(10,1) = 1
+ MWPTY(10,2) = 2
+ MWPTY(10,3) = 2
+ MWPTY(10,4) = 4
+ MWPTY(10,5) = 3
+ DO 200 I = 1, 11
+ INCX = MWPINX(I)
+ INCY = MWPINY(I)
+ DO 180 K = 1, 5
+ COPYX(K) = MWPX(K)
+ COPYY(K) = MWPY(K)
+ MWPSTX(K) = MWPTX(I,K)
+ MWPSTY(K) = MWPTY(I,K)
+ 180 CONTINUE
+ CALL DROT(MWPN(I),COPYX,INCX,COPYY,INCY,MWPC(I),MWPS(I))
+ CALL STEST(5,COPYX,MWPSTX,MWPSTX,SFAC)
+ CALL STEST(5,COPYY,MWPSTY,MWPSTY,SFAC)
+ 200 CONTINUE
+ RETURN
+ END
+ SUBROUTINE STEST(LEN,SCOMP,STRUE,SSIZE,SFAC)
+* ********************************* STEST **************************
+*
+* THIS SUBR COMPARES ARRAYS SCOMP() AND STRUE() OF LENGTH LEN TO
+* SEE IF THE TERM BY TERM DIFFERENCES, MULTIPLIED BY SFAC, ARE
+* NEGLIGIBLE.
+*
+* C. L. LAWSON, JPL, 1974 DEC 10
+*
+* .. Parameters ..
+ INTEGER NOUT
+ PARAMETER (NOUT=6)
+* .. Scalar Arguments ..
+ DOUBLE PRECISION SFAC
+ INTEGER LEN
+* .. Array Arguments ..
+ DOUBLE PRECISION SCOMP(LEN), SSIZE(LEN), STRUE(LEN)
+* .. Scalars in Common ..
+ INTEGER ICASE, INCX, INCY, MODE, N
+ LOGICAL PASS
+* .. Local Scalars ..
+ DOUBLE PRECISION SD
+ INTEGER I
+* .. External Functions ..
+ DOUBLE PRECISION SDIFF
+ EXTERNAL SDIFF
+* .. Intrinsic Functions ..
+ INTRINSIC ABS
+* .. Common blocks ..
+ COMMON /COMBLA/ICASE, N, INCX, INCY, MODE, PASS
+* .. Executable Statements ..
+*
+ DO 40 I = 1, LEN
+ SD = SCOMP(I) - STRUE(I)
+ IF (SDIFF(ABS(SSIZE(I))+ABS(SFAC*SD),ABS(SSIZE(I))).EQ.0.0D0)
+ + GO TO 40
+*
+* HERE SCOMP(I) IS NOT CLOSE TO STRUE(I).
+*
+ IF ( .NOT. PASS) GO TO 20
+* PRINT FAIL MESSAGE AND HEADER.
+ PASS = .FALSE.
+ WRITE (NOUT,99999)
+ WRITE (NOUT,99998)
+ 20 WRITE (NOUT,99997) ICASE, N, INCX, INCY, MODE, I, SCOMP(I),
+ + STRUE(I), SD, SSIZE(I)
+ 40 CONTINUE
+ RETURN
+*
+99999 FORMAT (' FAIL')
+99998 FORMAT (/' CASE N INCX INCY MODE I ',
+ + ' COMP(I) TRUE(I) DIFFERENCE',
+ + ' SIZE(I)',/1X)
+99997 FORMAT (1X,I4,I3,3I5,I3,2D36.8,2D12.4)
+ END
+ SUBROUTINE STEST1(SCOMP1,STRUE1,SSIZE,SFAC)
+* ************************* STEST1 *****************************
+*
+* THIS IS AN INTERFACE SUBROUTINE TO ACCOMODATE THE FORTRAN
+* REQUIREMENT THAT WHEN A DUMMY ARGUMENT IS AN ARRAY, THE
+* ACTUAL ARGUMENT MUST ALSO BE AN ARRAY OR AN ARRAY ELEMENT.
+*
+* C.L. LAWSON, JPL, 1978 DEC 6
+*
+* .. Scalar Arguments ..
+ DOUBLE PRECISION SCOMP1, SFAC, STRUE1
+* .. Array Arguments ..
+ DOUBLE PRECISION SSIZE(*)
+* .. Local Arrays ..
+ DOUBLE PRECISION SCOMP(1), STRUE(1)
+* .. External Subroutines ..
+ EXTERNAL STEST
+* .. Executable Statements ..
+*
+ SCOMP(1) = SCOMP1
+ STRUE(1) = STRUE1
+ CALL STEST(1,SCOMP,STRUE,SSIZE,SFAC)
+*
+ RETURN
+ END
+ DOUBLE PRECISION FUNCTION SDIFF(SA,SB)
+* ********************************* SDIFF **************************
+* COMPUTES DIFFERENCE OF TWO NUMBERS. C. L. LAWSON, JPL 1974 FEB 15
+*
+* .. Scalar Arguments ..
+ DOUBLE PRECISION SA, SB
+* .. Executable Statements ..
+ SDIFF = SA - SB
+ RETURN
+ END
+ SUBROUTINE ITEST1(ICOMP,ITRUE)
+* ********************************* ITEST1 *************************
+*
+* THIS SUBROUTINE COMPARES THE VARIABLES ICOMP AND ITRUE FOR
+* EQUALITY.
+* C. L. LAWSON, JPL, 1974 DEC 10
+*
+* .. Parameters ..
+ INTEGER NOUT
+ PARAMETER (NOUT=6)
+* .. Scalar Arguments ..
+ INTEGER ICOMP, ITRUE
+* .. Scalars in Common ..
+ INTEGER ICASE, INCX, INCY, MODE, N
+ LOGICAL PASS
+* .. Local Scalars ..
+ INTEGER ID
+* .. Common blocks ..
+ COMMON /COMBLA/ICASE, N, INCX, INCY, MODE, PASS
+* .. Executable Statements ..
+*
+ IF (ICOMP.EQ.ITRUE) GO TO 40
+*
+* HERE ICOMP IS NOT EQUAL TO ITRUE.
+*
+ IF ( .NOT. PASS) GO TO 20
+* PRINT FAIL MESSAGE AND HEADER.
+ PASS = .FALSE.
+ WRITE (NOUT,99999)
+ WRITE (NOUT,99998)
+ 20 ID = ICOMP - ITRUE
+ WRITE (NOUT,99997) ICASE, N, INCX, INCY, MODE, ICOMP, ITRUE, ID
+ 40 CONTINUE
+ RETURN
+*
+99999 FORMAT (' FAIL')
+99998 FORMAT (/' CASE N INCX INCY MODE ',
+ + ' COMP TRUE DIFFERENCE',
+ + /1X)
+99997 FORMAT (1X,I4,I3,3I5,2I36,I12)
+ END
diff --git a/jlapack-3.1.1/src/testing/blas2/Makefile b/jlapack-3.1.1/src/testing/blas2/Makefile
new file mode 100644
index 0000000..362f8da
--- /dev/null
+++ b/jlapack-3.1.1/src/testing/blas2/Makefile
@@ -0,0 +1,37 @@
+.SUFFIXES: .f .java
+
+ROOT=../../..
+
+include $(ROOT)/make.def
+
+XERBLAFLAGS= -c .:$(ROOT)/$(BLAS_OBJ) -p $(ERR_PACKAGE)
+F2JFLAGS=-c .:$(ROOT)/$(BLAS_OBJ) -p $(BLASTEST_PACKAGE) -o $(OUTDIR) $(STATIC)
+
+tester: $(ROOT)/$(BLAS_DIR)/$(BLAS_JAR) $(ROOT)/$(BLAS2TEST_IDX) $(ROOT)/$(UTIL_DIR)/$(UTIL_JAR)
+ /bin/rm -f $(BLAS2TEST_JAR)
+ cd $(OUTDIR); $(JAR) cvf0 ../$(BLAS2TEST_JAR) `find . -name "*.class"`
+ $(JAR) uvf0 $(BLAS2TEST_JAR) `find org -name "*.class"`
+
+nojar: $(ROOT)/$(BLAS_DIR)/$(BLAS_JAR) $(ROOT)/$(BLAS2TEST_IDX) $(ROOT)/$(UTIL_DIR)/$(UTIL_JAR)
+
+$(ROOT)/$(BLAS2TEST_IDX): dblat2.f
+ $(F2J) $(XERBLAFLAGS) xerbla.f > /dev/null
+ $(F2J) $(F2JFLAGS) $< > /dev/null
+
+$(ROOT)/$(BLAS_DIR)/$(BLAS_JAR):
+ cd $(ROOT)/$(BLAS_DIR); $(MAKE)
+
+$(ROOT)/$(UTIL_DIR)/$(UTIL_JAR):
+ cd $(ROOT)/$(UTIL_DIR); $(MAKE)
+
+runtest: tester
+ $(JAVA) $(JFLAGS) -cp .:$(BLAS2TEST_JAR):$(ROOT)/$(BLAS_DIR)/$(BLAS_JAR):$(ROOT)/$(UTIL_DIR)/$(UTIL_JAR):$(ROOT)/$(ERR_DIR)/$(ERR_JAR) $(BLASTEST_PACKAGE).Dblat2 < dblat2.in
+
+srctest:
+ $(MAKE) -f Makefile_javasrc
+
+verify: $(ROOT)/$(BLAS2TEST_IDX)
+ cd $(OUTDIR); $(JAVA) $(MORE_MEM_FLAG) -classpath .:..:$(JUSTICE):$(BCEL):$(ROOT)/../$(UTIL_DIR)/$(UTIL_JAR):$(ROOT)/../$(ERR_DIR)/$(ERR_JAR):$(ROOT)/../$(BLAS_DIR)/$(BLAS_JAR) $(VERIFY) $(BLASTEST_PDIR)/*.class
+
+clean:
+ /bin/rm -rf *.java *.class *.f2j org $(OUTDIR) $(JAVASRC_OUTDIR) $(BLAS2TEST_JAR)
diff --git a/jlapack-3.1.1/src/testing/blas2/Makefile_javasrc b/jlapack-3.1.1/src/testing/blas2/Makefile_javasrc
new file mode 100644
index 0000000..01b9204
--- /dev/null
+++ b/jlapack-3.1.1/src/testing/blas2/Makefile_javasrc
@@ -0,0 +1,33 @@
+.SUFFIXES: .f .java
+
+ROOT=../../..
+
+include $(ROOT)/make.def
+
+tester: $(ROOT)/$(BLAS_DIR)/$(BLAS_JAR) $(ROOT)/$(BLAS2TEST_IDX) $(ROOT)/$(UTIL_DIR)/$(UTIL_JAR)
+ /bin/rm -f `find $(OUTDIR) -name "*.class"`
+ mkdir -p $(JAVASRC_OUTDIR)
+ $(JAVAC) -classpath .:$(JAVASRC_OUTDIR):$(ROOT)/$(UTIL_DIR)/$(UTIL_JAR):$(ROOT)/$(ERR_DIR)/$(ERR_JAR):$(ROOT)/$(BLAS_DIR)/$(BLAS_JAR) -d $(JAVASRC_OUTDIR) $(OUTDIR)/$(BLASTEST_PDIR)/*.java
+ /bin/rm -f $(JAVASRC_OUTDIR)/$(BLASTEST_PDIR)/*.old
+ $(JAVAB) $(JAVASRC_OUTDIR)/$(BLASTEST_PDIR)/*.class
+ /bin/rm -f $(BLAS2TEST_JAR)
+ cd $(JAVASRC_OUTDIR); $(JAR) cvf ../$(BLAS2TEST_JAR) `find . -name "*.class"`
+ $(JAR) uvf $(BLAS2TEST_JAR) `find org -name "*.class"`
+
+$(ROOT)/$(BLAS2TEST_IDX): dblat2.f
+ $(MAKE) nojar
+
+$(ROOT)/$(BLAS_DIR)/$(BLAS_JAR):
+ cd $(ROOT)/$(BLAS_DIR); $(MAKE) -f Makefile_javasrc
+
+$(ROOT)/$(UTIL_DIR)/$(UTIL_JAR):
+ cd $(ROOT)/$(UTIL_DIR); $(MAKE)
+
+runtest: tester
+ $(JAVA) $(JFLAGS) -cp .:$(BLAS2TEST_JAR):$(ROOT)/$(BLAS_DIR)/$(BLAS_JAR):$(ROOT)/$(UTIL_DIR)/$(UTIL_JAR):$(ROOT)/$(ERR_DIR)/$(ERR_JAR) $(BLASTEST_PACKAGE).Dblat2 < dblat2.in
+
+verify: $(ROOT)/$(BLAS2TEST_IDX)
+ cd $(JAVASRC_OUTDIR); $(JAVA) $(MORE_MEM_FLAG) -classpath .:..:$(JUSTICE):$(BCEL):$(ROOT)/../$(UTIL_DIR)/$(UTIL_JAR):$(ROOT)/../$(ERR_DIR)/$(ERR_JAR):$(ROOT)/../$(BLAS_DIR)/$(BLAS_JAR) $(VERIFY) $(BLASTEST_PDIR)/*.class
+
+clean:
+ /bin/rm -rf *.java *.class *.f2j org $(OUTDIR) $(JAVASRC_OUTDIR) $(BLAS2TEST_JAR)
diff --git a/jlapack-3.1.1/src/testing/blas2/dblat2.f b/jlapack-3.1.1/src/testing/blas2/dblat2.f
new file mode 100644
index 0000000..8ae855a
--- /dev/null
+++ b/jlapack-3.1.1/src/testing/blas2/dblat2.f
@@ -0,0 +1,3088 @@
+ PROGRAM DBLAT2
+*
+* Test program for the DOUBLE PRECISION Level 2 Blas.
+*
+* The program must be driven by a short data file. The first 18 records
+* of the file are read using list-directed input, the last 16 records
+* are read using the format ( A6, L2 ). An annotated example of a data
+* file can be obtained by deleting the first 3 characters from the
+* following 34 lines:
+* 'dblat2.out' NAME OF SUMMARY OUTPUT FILE
+* 6 UNIT NUMBER OF SUMMARY FILE
+* 'DBLAT2.SNAP' NAME OF SNAPSHOT OUTPUT FILE
+* -1 UNIT NUMBER OF SNAPSHOT FILE (NOT USED IF .LT. 0)
+* F LOGICAL FLAG, T TO REWIND SNAPSHOT FILE AFTER EACH RECORD.
+* F LOGICAL FLAG, T TO STOP ON FAILURES.
+* T LOGICAL FLAG, T TO TEST ERROR EXITS.
+* 16.0 THRESHOLD VALUE OF TEST RATIO
+* 6 NUMBER OF VALUES OF N
+* 0 1 2 3 5 9 VALUES OF N
+* 4 NUMBER OF VALUES OF K
+* 0 1 2 4 VALUES OF K
+* 4 NUMBER OF VALUES OF INCX AND INCY
+* 1 2 -1 -2 VALUES OF INCX AND INCY
+* 3 NUMBER OF VALUES OF ALPHA
+* 0.0 1.0 0.7 VALUES OF ALPHA
+* 3 NUMBER OF VALUES OF BETA
+* 0.0 1.0 0.9 VALUES OF BETAC
+* DGEMV T PUT F FOR NO TEST. SAME COLUMNS.
+* DGBMV T PUT F FOR NO TEST. SAME COLUMNS.
+* DSYMV T PUT F FOR NO TEST. SAME COLUMNS.
+* DSBMV T PUT F FOR NO TEST. SAME COLUMNS.
+* DSPMV T PUT F FOR NO TEST. SAME COLUMNS.
+* DTRMV T PUT F FOR NO TEST. SAME COLUMNS.
+* DTBMV T PUT F FOR NO TEST. SAME COLUMNS.
+* DTPMV T PUT F FOR NO TEST. SAME COLUMNS.
+* DTRSV T PUT F FOR NO TEST. SAME COLUMNS.
+* DTBSV T PUT F FOR NO TEST. SAME COLUMNS.
+* DTPSV T PUT F FOR NO TEST. SAME COLUMNS.
+* DGER T PUT F FOR NO TEST. SAME COLUMNS.
+* DSYR T PUT F FOR NO TEST. SAME COLUMNS.
+* DSPR T PUT F FOR NO TEST. SAME COLUMNS.
+* DSYR2 T PUT F FOR NO TEST. SAME COLUMNS.
+* DSPR2 T PUT F FOR NO TEST. SAME COLUMNS.
+*
+* See:
+*
+* Dongarra J. J., Du Croz J. J., Hammarling S. and Hanson R. J..
+* An extended set of Fortran Basic Linear Algebra Subprograms.
+*
+* Technical Memoranda Nos. 41 (revision 3) and 81, Mathematics
+* and Computer Science Division, Argonne National Laboratory,
+* 9700 South Cass Avenue, Argonne, Illinois 60439, US.
+*
+* Or
+*
+* NAG Technical Reports TR3/87 and TR4/87, Numerical Algorithms
+* Group Ltd., NAG Central Office, 256 Banbury Road, Oxford
+* OX2 7DE, UK, and Numerical Algorithms Group Inc., 1101 31st
+* Street, Suite 100, Downers Grove, Illinois 60515-1263, USA.
+*
+*
+* -- Written on 10-August-1987.
+* Richard Hanson, Sandia National Labs.
+* Jeremy Du Croz, NAG Central Office.
+*
+* 10-9-00: Change STATUS='NEW' to 'UNKNOWN' so that the testers
+* can be run multiple times without deleting generated
+* output files (susan)
+*
+* .. Parameters ..
+ INTEGER NIN
+ PARAMETER ( NIN = 5 )
+ INTEGER NSUBS
+ PARAMETER ( NSUBS = 16 )
+ DOUBLE PRECISION ZERO, HALF, ONE
+ PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0 )
+ INTEGER NMAX, INCMAX
+ PARAMETER ( NMAX = 65, INCMAX = 2 )
+ INTEGER NINMAX, NIDMAX, NKBMAX, NALMAX, NBEMAX
+ PARAMETER ( NINMAX = 7, NIDMAX = 9, NKBMAX = 7,
+ $ NALMAX = 7, NBEMAX = 7 )
+* .. Local Scalars ..
+ DOUBLE PRECISION EPS, ERR, THRESH
+ INTEGER I, ISNUM, J, N, NALF, NBET, NIDIM, NINC, NKB,
+ $ NOUT, NTRA
+ LOGICAL FATAL, LTESTT, REWI, SAME, SFATAL, TRACE,
+ $ TSTERR
+ CHARACTER*1 TRANS
+ CHARACTER*6 SNAMET
+ CHARACTER*32 SNAPS, SUMMRY
+* .. Local Arrays ..
+ DOUBLE PRECISION A( NMAX, NMAX ), AA( NMAX*NMAX ),
+ $ ALF( NALMAX ), AS( NMAX*NMAX ), BET( NBEMAX ),
+ $ G( NMAX ), X( NMAX ), XS( NMAX*INCMAX ),
+ $ XX( NMAX*INCMAX ), Y( NMAX ),
+ $ YS( NMAX*INCMAX ), YT( NMAX ),
+ $ YY( NMAX*INCMAX ), Z( 2*NMAX )
+ INTEGER IDIM( NIDMAX ), INC( NINMAX ), KB( NKBMAX )
+ LOGICAL LTEST( NSUBS )
+ CHARACTER*6 SNAMES( NSUBS )
+* .. External Functions ..
+ DOUBLE PRECISION DDIFF
+ LOGICAL LDE
+ EXTERNAL DDIFF, LDE
+* .. External Subroutines ..
+ EXTERNAL DCHK1, DCHK2, DCHK3, DCHK4, DCHK5, DCHK6,
+ $ DCHKE, DMVCH
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, MIN
+* .. Scalars in Common ..
+ INTEGER INFOT, NOUTC
+ LOGICAL LERR, OK
+ CHARACTER*6 SRNAMT
+* .. Common blocks ..
+ COMMON /INFOC/INFOT, NOUTC, OK, LERR
+ COMMON /SRNAMC/SRNAMT
+* .. Data statements ..
+ DATA SNAMES/'DGEMV ', 'DGBMV ', 'DSYMV ', 'DSBMV ',
+ $ 'DSPMV ', 'DTRMV ', 'DTBMV ', 'DTPMV ',
+ $ 'DTRSV ', 'DTBSV ', 'DTPSV ', 'DGER ',
+ $ 'DSYR ', 'DSPR ', 'DSYR2 ', 'DSPR2 '/
+* .. Executable Statements ..
+*
+* Read name and unit number for summary output file and open file.
+*
+ READ( NIN, FMT = * )SUMMRY
+ READ( NIN, FMT = * )NOUT
+ OPEN( NOUT, FILE = SUMMRY, STATUS = 'UNKNOWN' )
+ NOUTC = NOUT
+*
+* Read name and unit number for snapshot output file and open file.
+*
+ READ( NIN, FMT = * )SNAPS
+ READ( NIN, FMT = * )NTRA
+ TRACE = NTRA.GE.0
+ IF( TRACE )THEN
+ OPEN( NTRA, FILE = SNAPS, STATUS = 'UNKNOWN' )
+ END IF
+* Read the flag that directs rewinding of the snapshot file.
+ READ( NIN, FMT = * )REWI
+ REWI = REWI.AND.TRACE
+* Read the flag that directs stopping on any failure.
+ READ( NIN, FMT = * )SFATAL
+* Read the flag that indicates whether error exits are to be tested.
+ READ( NIN, FMT = * )TSTERR
+* Read the threshold value of the test ratio
+ READ( NIN, FMT = * )THRESH
+*
+* Read and check the parameter values for the tests.
+*
+* Values of N
+ READ( NIN, FMT = * )NIDIM
+ IF( NIDIM.LT.1.OR.NIDIM.GT.NIDMAX )THEN
+ WRITE( NOUT, FMT = 9997 )'N', NIDMAX
+ GO TO 230
+ END IF
+ READ( NIN, FMT = * )( IDIM( I ), I = 1, NIDIM )
+ DO 10 I = 1, NIDIM
+ IF( IDIM( I ).LT.0.OR.IDIM( I ).GT.NMAX )THEN
+ WRITE( NOUT, FMT = 9996 )NMAX
+ GO TO 230
+ END IF
+ 10 CONTINUE
+* Values of K
+ READ( NIN, FMT = * )NKB
+ IF( NKB.LT.1.OR.NKB.GT.NKBMAX )THEN
+ WRITE( NOUT, FMT = 9997 )'K', NKBMAX
+ GO TO 230
+ END IF
+ READ( NIN, FMT = * )( KB( I ), I = 1, NKB )
+ DO 20 I = 1, NKB
+ IF( KB( I ).LT.0 )THEN
+ WRITE( NOUT, FMT = 9995 )
+ GO TO 230
+ END IF
+ 20 CONTINUE
+* Values of INCX and INCY
+ READ( NIN, FMT = * )NINC
+ IF( NINC.LT.1.OR.NINC.GT.NINMAX )THEN
+ WRITE( NOUT, FMT = 9997 )'INCX AND INCY', NINMAX
+ GO TO 230
+ END IF
+ READ( NIN, FMT = * )( INC( I ), I = 1, NINC )
+ DO 30 I = 1, NINC
+ IF( INC( I ).EQ.0.OR.ABS( INC( I ) ).GT.INCMAX )THEN
+ WRITE( NOUT, FMT = 9994 )INCMAX
+ GO TO 230
+ END IF
+ 30 CONTINUE
+* Values of ALPHA
+ READ( NIN, FMT = * )NALF
+ IF( NALF.LT.1.OR.NALF.GT.NALMAX )THEN
+ WRITE( NOUT, FMT = 9997 )'ALPHA', NALMAX
+ GO TO 230
+ END IF
+ READ( NIN, FMT = * )( ALF( I ), I = 1, NALF )
+* Values of BETA
+ READ( NIN, FMT = * )NBET
+ IF( NBET.LT.1.OR.NBET.GT.NBEMAX )THEN
+ WRITE( NOUT, FMT = 9997 )'BETA', NBEMAX
+ GO TO 230
+ END IF
+ READ( NIN, FMT = * )( BET( I ), I = 1, NBET )
+*
+* Report values of parameters.
+*
+ WRITE( NOUT, FMT = 9993 )
+ WRITE( NOUT, FMT = 9992 )( IDIM( I ), I = 1, NIDIM )
+ WRITE( NOUT, FMT = 9991 )( KB( I ), I = 1, NKB )
+ WRITE( NOUT, FMT = 9990 )( INC( I ), I = 1, NINC )
+ WRITE( NOUT, FMT = 9989 )( ALF( I ), I = 1, NALF )
+ WRITE( NOUT, FMT = 9988 )( BET( I ), I = 1, NBET )
+ IF( .NOT.TSTERR )THEN
+ WRITE( NOUT, FMT = * )
+ WRITE( NOUT, FMT = 9980 )
+ END IF
+ WRITE( NOUT, FMT = * )
+ WRITE( NOUT, FMT = 9999 )THRESH
+ WRITE( NOUT, FMT = * )
+*
+* Read names of subroutines and flags which indicate
+* whether they are to be tested.
+*
+ DO 40 I = 1, NSUBS
+ LTEST( I ) = .FALSE.
+ 40 CONTINUE
+ 50 READ( NIN, FMT = 9984, END = 80 )SNAMET, LTESTT
+ DO 60 I = 1, NSUBS
+ IF( SNAMET.EQ.SNAMES( I ) )
+ $ GO TO 70
+ 60 CONTINUE
+ WRITE( NOUT, FMT = 9986 )SNAMET
+ STOP
+ 70 LTEST( I ) = LTESTT
+ GO TO 50
+*
+ 80 CONTINUE
+ CLOSE ( NIN )
+*
+* Compute EPS (the machine precision).
+*
+ EPS = ONE
+ 90 CONTINUE
+ IF( DDIFF( ONE + EPS, ONE ).EQ.ZERO )
+ $ GO TO 100
+ EPS = HALF*EPS
+ GO TO 90
+ 100 CONTINUE
+ EPS = EPS + EPS
+ WRITE( NOUT, FMT = 9998 )EPS
+*
+* Check the reliability of DMVCH using exact data.
+*
+ N = MIN( 32, NMAX )
+ DO 120 J = 1, N
+ DO 110 I = 1, N
+ A( I, J ) = MAX( I - J + 1, 0 )
+ 110 CONTINUE
+ X( J ) = J
+ Y( J ) = ZERO
+ 120 CONTINUE
+ DO 130 J = 1, N
+ YY( J ) = J*( ( J + 1 )*J )/2 - ( ( J + 1 )*J*( J - 1 ) )/3
+ 130 CONTINUE
+* YY holds the exact result. On exit from DMVCH YT holds
+* the result computed by DMVCH.
+ TRANS = 'N'
+ CALL DMVCH( TRANS, N, N, ONE, A, NMAX, X, 1, ZERO, Y, 1, YT, G,
+ $ YY, EPS, ERR, FATAL, NOUT, .TRUE. )
+ SAME = LDE( YY, YT, N )
+ IF( .NOT.SAME.OR.ERR.NE.ZERO )THEN
+ WRITE( NOUT, FMT = 9985 )TRANS, SAME, ERR
+ STOP
+ END IF
+ TRANS = 'T'
+ CALL DMVCH( TRANS, N, N, ONE, A, NMAX, X, -1, ZERO, Y, -1, YT, G,
+ $ YY, EPS, ERR, FATAL, NOUT, .TRUE. )
+ SAME = LDE( YY, YT, N )
+ IF( .NOT.SAME.OR.ERR.NE.ZERO )THEN
+ WRITE( NOUT, FMT = 9985 )TRANS, SAME, ERR
+ STOP
+ END IF
+*
+* Test each subroutine in turn.
+*
+ DO 210 ISNUM = 1, NSUBS
+ WRITE( NOUT, FMT = * )
+ IF( .NOT.LTEST( ISNUM ) )THEN
+* Subprogram is not to be tested.
+ WRITE( NOUT, FMT = 9983 )SNAMES( ISNUM )
+ ELSE
+ SRNAMT = SNAMES( ISNUM )
+* Test error exits.
+ IF( TSTERR )THEN
+ CALL DCHKE( ISNUM, SNAMES( ISNUM ), NOUT )
+ WRITE( NOUT, FMT = * )
+ END IF
+* Test computations.
+ INFOT = 0
+ OK = .TRUE.
+ FATAL = .FALSE.
+ GO TO ( 140, 140, 150, 150, 150, 160, 160,
+ $ 160, 160, 160, 160, 170, 180, 180,
+ $ 190, 190 )ISNUM
+* Test DGEMV, 01, and DGBMV, 02.
+ 140 CALL DCHK1( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
+ $ REWI, FATAL, NIDIM, IDIM, NKB, KB, NALF, ALF,
+ $ NBET, BET, NINC, INC, NMAX, INCMAX, A, AA, AS,
+ $ X, XX, XS, Y, YY, YS, YT, G )
+ GO TO 200
+* Test DSYMV, 03, DSBMV, 04, and DSPMV, 05.
+ 150 CALL DCHK2( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
+ $ REWI, FATAL, NIDIM, IDIM, NKB, KB, NALF, ALF,
+ $ NBET, BET, NINC, INC, NMAX, INCMAX, A, AA, AS,
+ $ X, XX, XS, Y, YY, YS, YT, G )
+ GO TO 200
+* Test DTRMV, 06, DTBMV, 07, DTPMV, 08,
+* DTRSV, 09, DTBSV, 10, and DTPSV, 11.
+ 160 CALL DCHK3( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
+ $ REWI, FATAL, NIDIM, IDIM, NKB, KB, NINC, INC,
+ $ NMAX, INCMAX, A, AA, AS, Y, YY, YS, YT, G, Z )
+ GO TO 200
+* Test DGER, 12.
+ 170 CALL DCHK4( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
+ $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC,
+ $ NMAX, INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS,
+ $ YT, G, Z )
+ GO TO 200
+* Test DSYR, 13, and DSPR, 14.
+ 180 CALL DCHK5( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
+ $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC,
+ $ NMAX, INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS,
+ $ YT, G, Z )
+ GO TO 200
+* Test DSYR2, 15, and DSPR2, 16.
+ 190 CALL DCHK6( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
+ $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC,
+ $ NMAX, INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS,
+ $ YT, G, Z )
+*
+ 200 IF( FATAL.AND.SFATAL )
+ $ GO TO 220
+ END IF
+ 210 CONTINUE
+ WRITE( NOUT, FMT = 9982 )
+ GO TO 240
+*
+ 220 CONTINUE
+ WRITE( NOUT, FMT = 9981 )
+ GO TO 240
+*
+ 230 CONTINUE
+ WRITE( NOUT, FMT = 9987 )
+*
+ 240 CONTINUE
+ IF( TRACE )
+ $ CLOSE ( NTRA )
+ CLOSE ( NOUT )
+ STOP
+*
+ 9999 FORMAT( ' ROUTINES PASS COMPUTATIONAL TESTS IF TEST RATIO IS LES',
+ $ 'S THAN', F8.2 )
+ 9998 FORMAT( ' RELATIVE MACHINE PRECISION IS TAKEN TO BE', 1P, D9.1 )
+ 9997 FORMAT( ' NUMBER OF VALUES OF ', A, ' IS LESS THAN 1 OR GREATER ',
+ $ 'THAN ', I2 )
+ 9996 FORMAT( ' VALUE OF N IS LESS THAN 0 OR GREATER THAN ', I2 )
+ 9995 FORMAT( ' VALUE OF K IS LESS THAN 0' )
+ 9994 FORMAT( ' ABSOLUTE VALUE OF INCX OR INCY IS 0 OR GREATER THAN ',
+ $ I2 )
+ 9993 FORMAT( ' TESTS OF THE DOUBLE PRECISION LEVEL 2 BLAS', //' THE F',
+ $ 'OLLOWING PARAMETER VALUES WILL BE USED:' )
+ 9992 FORMAT( ' FOR N ', 9I6 )
+ 9991 FORMAT( ' FOR K ', 7I6 )
+ 9990 FORMAT( ' FOR INCX AND INCY ', 7I6 )
+ 9989 FORMAT( ' FOR ALPHA ', 7F6.1 )
+ 9988 FORMAT( ' FOR BETA ', 7F6.1 )
+ 9987 FORMAT( ' AMEND DATA FILE OR INCREASE ARRAY SIZES IN PROGRAM',
+ $ /' ******* TESTS ABANDONED *******' )
+ 9986 FORMAT( ' SUBPROGRAM NAME ', A6, ' NOT RECOGNIZED', /' ******* T',
+ $ 'ESTS ABANDONED *******' )
+ 9985 FORMAT( ' ERROR IN DMVCH - IN-LINE DOT PRODUCTS ARE BEING EVALU',
+ $ 'ATED WRONGLY.', /' DMVCH WAS CALLED WITH TRANS = ', A1,
+ $ ' AND RETURNED SAME = ', L1, ' AND ERR = ', F12.3, '.', /
+ $ ' THIS MAY BE DUE TO FAULTS IN THE ARITHMETIC OR THE COMPILER.'
+ $ , /' ******* TESTS ABANDONED *******' )
+ 9984 FORMAT( A6, L2 )
+ 9983 FORMAT( 1X, A6, ' WAS NOT TESTED' )
+ 9982 FORMAT( /' END OF TESTS' )
+ 9981 FORMAT( /' ******* FATAL ERROR - TESTS ABANDONED *******' )
+ 9980 FORMAT( ' ERROR-EXITS WILL NOT BE TESTED' )
+*
+* End of DBLAT2.
+*
+ END
+ SUBROUTINE DCHK1( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
+ $ FATAL, NIDIM, IDIM, NKB, KB, NALF, ALF, NBET,
+ $ BET, NINC, INC, NMAX, INCMAX, A, AA, AS, X, XX,
+ $ XS, Y, YY, YS, YT, G )
+*
+* Tests DGEMV and DGBMV.
+*
+* Auxiliary routine for test program for Level 2 Blas.
+*
+* -- Written on 10-August-1987.
+* Richard Hanson, Sandia National Labs.
+* Jeremy Du Croz, NAG Central Office.
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, HALF
+ PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0 )
+* .. Scalar Arguments ..
+ DOUBLE PRECISION EPS, THRESH
+ INTEGER INCMAX, NALF, NBET, NIDIM, NINC, NKB, NMAX,
+ $ NOUT, NTRA
+ LOGICAL FATAL, REWI, TRACE
+ CHARACTER*6 SNAME
+* .. Array Arguments ..
+ DOUBLE PRECISION A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
+ $ AS( NMAX*NMAX ), BET( NBET ), G( NMAX ),
+ $ X( NMAX ), XS( NMAX*INCMAX ),
+ $ XX( NMAX*INCMAX ), Y( NMAX ),
+ $ YS( NMAX*INCMAX ), YT( NMAX ),
+ $ YY( NMAX*INCMAX )
+ INTEGER IDIM( NIDIM ), INC( NINC ), KB( NKB )
+* .. Local Scalars ..
+ DOUBLE PRECISION ALPHA, ALS, BETA, BLS, ERR, ERRMAX, TRANSL
+ INTEGER I, IA, IB, IC, IKU, IM, IN, INCX, INCXS, INCY,
+ $ INCYS, IX, IY, KL, KLS, KU, KUS, LAA, LDA,
+ $ LDAS, LX, LY, M, ML, MS, N, NARGS, NC, ND, NK,
+ $ NL, NS
+ LOGICAL BANDED, FULL, NULL, RESET, SAME, TRAN
+ CHARACTER*1 TRANS, TRANSS
+ CHARACTER*3 ICH
+* .. Local Arrays ..
+ LOGICAL ISAME( 13 )
+* .. External Functions ..
+ LOGICAL LDE, LDERES
+ EXTERNAL LDE, LDERES
+* .. External Subroutines ..
+ EXTERNAL DGBMV, DGEMV, DMAKE, DMVCH
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, MIN
+* .. Scalars in Common ..
+ INTEGER INFOT, NOUTC
+ LOGICAL LERR, OK
+* .. Common blocks ..
+ COMMON /INFOC/INFOT, NOUTC, OK, LERR
+* .. Data statements ..
+ DATA ICH/'NTC'/
+* .. Executable Statements ..
+ FULL = SNAME( 3: 3 ).EQ.'E'
+ BANDED = SNAME( 3: 3 ).EQ.'B'
+* Define the number of arguments.
+ IF( FULL )THEN
+ NARGS = 11
+ ELSE IF( BANDED )THEN
+ NARGS = 13
+ END IF
+*
+ NC = 0
+ RESET = .TRUE.
+ ERRMAX = ZERO
+*
+ DO 120 IN = 1, NIDIM
+ N = IDIM( IN )
+ ND = N/2 + 1
+*
+ DO 110 IM = 1, 2
+ IF( IM.EQ.1 )
+ $ M = MAX( N - ND, 0 )
+ IF( IM.EQ.2 )
+ $ M = MIN( N + ND, NMAX )
+*
+ IF( BANDED )THEN
+ NK = NKB
+ ELSE
+ NK = 1
+ END IF
+ DO 100 IKU = 1, NK
+ IF( BANDED )THEN
+ KU = KB( IKU )
+ KL = MAX( KU - 1, 0 )
+ ELSE
+ KU = N - 1
+ KL = M - 1
+ END IF
+* Set LDA to 1 more than minimum value if room.
+ IF( BANDED )THEN
+ LDA = KL + KU + 1
+ ELSE
+ LDA = M
+ END IF
+ IF( LDA.LT.NMAX )
+ $ LDA = LDA + 1
+* Skip tests if not enough room.
+ IF( LDA.GT.NMAX )
+ $ GO TO 100
+ LAA = LDA*N
+ NULL = N.LE.0.OR.M.LE.0
+*
+* Generate the matrix A.
+*
+ TRANSL = ZERO
+ CALL DMAKE( SNAME( 2: 3 ), ' ', ' ', M, N, A, NMAX, AA,
+ $ LDA, KL, KU, RESET, TRANSL )
+*
+ DO 90 IC = 1, 3
+ TRANS = ICH( IC: IC )
+ TRAN = TRANS.EQ.'T'.OR.TRANS.EQ.'C'
+*
+ IF( TRAN )THEN
+ ML = N
+ NL = M
+ ELSE
+ ML = M
+ NL = N
+ END IF
+*
+ DO 80 IX = 1, NINC
+ INCX = INC( IX )
+ LX = ABS( INCX )*NL
+*
+* Generate the vector X.
+*
+ TRANSL = HALF
+ CALL DMAKE( 'GE', ' ', ' ', 1, NL, X, 1, XX,
+ $ ABS( INCX ), 0, NL - 1, RESET, TRANSL )
+ IF( NL.GT.1 )THEN
+ X( NL/2 ) = ZERO
+ XX( 1 + ABS( INCX )*( NL/2 - 1 ) ) = ZERO
+ END IF
+*
+ DO 70 IY = 1, NINC
+ INCY = INC( IY )
+ LY = ABS( INCY )*ML
+*
+ DO 60 IA = 1, NALF
+ ALPHA = ALF( IA )
+*
+ DO 50 IB = 1, NBET
+ BETA = BET( IB )
+*
+* Generate the vector Y.
+*
+ TRANSL = ZERO
+ CALL DMAKE( 'GE', ' ', ' ', 1, ML, Y, 1,
+ $ YY, ABS( INCY ), 0, ML - 1,
+ $ RESET, TRANSL )
+*
+ NC = NC + 1
+*
+* Save every datum before calling the
+* subroutine.
+*
+ TRANSS = TRANS
+ MS = M
+ NS = N
+ KLS = KL
+ KUS = KU
+ ALS = ALPHA
+ DO 10 I = 1, LAA
+ AS( I ) = AA( I )
+ 10 CONTINUE
+ LDAS = LDA
+ DO 20 I = 1, LX
+ XS( I ) = XX( I )
+ 20 CONTINUE
+ INCXS = INCX
+ BLS = BETA
+ DO 30 I = 1, LY
+ YS( I ) = YY( I )
+ 30 CONTINUE
+ INCYS = INCY
+*
+* Call the subroutine.
+*
+ IF( FULL )THEN
+ IF( TRACE )
+ $ WRITE( NTRA, FMT = 9994 )NC, SNAME,
+ $ TRANS, M, N, ALPHA, LDA, INCX, BETA,
+ $ INCY
+ IF( REWI )
+ $ REWIND NTRA
+ CALL DGEMV( TRANS, M, N, ALPHA, AA,
+ $ LDA, XX, INCX, BETA, YY,
+ $ INCY )
+ ELSE IF( BANDED )THEN
+ IF( TRACE )
+ $ WRITE( NTRA, FMT = 9995 )NC, SNAME,
+ $ TRANS, M, N, KL, KU, ALPHA, LDA,
+ $ INCX, BETA, INCY
+ IF( REWI )
+ $ REWIND NTRA
+ CALL DGBMV( TRANS, M, N, KL, KU, ALPHA,
+ $ AA, LDA, XX, INCX, BETA,
+ $ YY, INCY )
+ END IF
+*
+* Check if error-exit was taken incorrectly.
+*
+ IF( .NOT.OK )THEN
+ WRITE( NOUT, FMT = 9993 )
+ FATAL = .TRUE.
+ GO TO 130
+ END IF
+*
+* See what data changed inside subroutines.
+*
+ ISAME( 1 ) = TRANS.EQ.TRANSS
+ ISAME( 2 ) = MS.EQ.M
+ ISAME( 3 ) = NS.EQ.N
+ IF( FULL )THEN
+ ISAME( 4 ) = ALS.EQ.ALPHA
+ ISAME( 5 ) = LDE( AS, AA, LAA )
+ ISAME( 6 ) = LDAS.EQ.LDA
+ ISAME( 7 ) = LDE( XS, XX, LX )
+ ISAME( 8 ) = INCXS.EQ.INCX
+ ISAME( 9 ) = BLS.EQ.BETA
+ IF( NULL )THEN
+ ISAME( 10 ) = LDE( YS, YY, LY )
+ ELSE
+ ISAME( 10 ) = LDERES( 'GE', ' ', 1,
+ $ ML, YS, YY,
+ $ ABS( INCY ) )
+ END IF
+ ISAME( 11 ) = INCYS.EQ.INCY
+ ELSE IF( BANDED )THEN
+ ISAME( 4 ) = KLS.EQ.KL
+ ISAME( 5 ) = KUS.EQ.KU
+ ISAME( 6 ) = ALS.EQ.ALPHA
+ ISAME( 7 ) = LDE( AS, AA, LAA )
+ ISAME( 8 ) = LDAS.EQ.LDA
+ ISAME( 9 ) = LDE( XS, XX, LX )
+ ISAME( 10 ) = INCXS.EQ.INCX
+ ISAME( 11 ) = BLS.EQ.BETA
+ IF( NULL )THEN
+ ISAME( 12 ) = LDE( YS, YY, LY )
+ ELSE
+ ISAME( 12 ) = LDERES( 'GE', ' ', 1,
+ $ ML, YS, YY,
+ $ ABS( INCY ) )
+ END IF
+ ISAME( 13 ) = INCYS.EQ.INCY
+ END IF
+*
+* If data was incorrectly changed, report
+* and return.
+*
+ SAME = .TRUE.
+ DO 40 I = 1, NARGS
+ SAME = SAME.AND.ISAME( I )
+ IF( .NOT.ISAME( I ) )
+ $ WRITE( NOUT, FMT = 9998 )I
+ 40 CONTINUE
+ IF( .NOT.SAME )THEN
+ FATAL = .TRUE.
+ GO TO 130
+ END IF
+*
+ IF( .NOT.NULL )THEN
+*
+* Check the result.
+*
+ CALL DMVCH( TRANS, M, N, ALPHA, A,
+ $ NMAX, X, INCX, BETA, Y,
+ $ INCY, YT, G, YY, EPS, ERR,
+ $ FATAL, NOUT, .TRUE. )
+ ERRMAX = MAX( ERRMAX, ERR )
+* If got really bad answer, report and
+* return.
+ IF( FATAL )
+ $ GO TO 130
+ ELSE
+* Avoid repeating tests with M.le.0 or
+* N.le.0.
+ GO TO 110
+ END IF
+*
+ 50 CONTINUE
+*
+ 60 CONTINUE
+*
+ 70 CONTINUE
+*
+ 80 CONTINUE
+*
+ 90 CONTINUE
+*
+ 100 CONTINUE
+*
+ 110 CONTINUE
+*
+ 120 CONTINUE
+*
+* Report result.
+*
+ IF( ERRMAX.LT.THRESH )THEN
+ WRITE( NOUT, FMT = 9999 )SNAME, NC
+ ELSE
+ WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX
+ END IF
+ GO TO 140
+*
+ 130 CONTINUE
+ WRITE( NOUT, FMT = 9996 )SNAME
+ IF( FULL )THEN
+ WRITE( NOUT, FMT = 9994 )NC, SNAME, TRANS, M, N, ALPHA, LDA,
+ $ INCX, BETA, INCY
+ ELSE IF( BANDED )THEN
+ WRITE( NOUT, FMT = 9995 )NC, SNAME, TRANS, M, N, KL, KU,
+ $ ALPHA, LDA, INCX, BETA, INCY
+ END IF
+*
+ 140 CONTINUE
+ RETURN
+*
+ 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL',
+ $ 'S)' )
+ 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
+ $ 'ANGED INCORRECTLY *******' )
+ 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C',
+ $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2,
+ $ ' - SUSPECT *******' )
+ 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' )
+ 9995 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', 4( I3, ',' ), F4.1,
+ $ ', A,', I3, ', X,', I2, ',', F4.1, ', Y,', I2, ') .' )
+ 9994 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', 2( I3, ',' ), F4.1,
+ $ ', A,', I3, ', X,', I2, ',', F4.1, ', Y,', I2,
+ $ ') .' )
+ 9993 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
+ $ '******' )
+*
+* End of DCHK1.
+*
+ END
+ SUBROUTINE DCHK2( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
+ $ FATAL, NIDIM, IDIM, NKB, KB, NALF, ALF, NBET,
+ $ BET, NINC, INC, NMAX, INCMAX, A, AA, AS, X, XX,
+ $ XS, Y, YY, YS, YT, G )
+*
+* Tests DSYMV, DSBMV and DSPMV.
+*
+* Auxiliary routine for test program for Level 2 Blas.
+*
+* -- Written on 10-August-1987.
+* Richard Hanson, Sandia National Labs.
+* Jeremy Du Croz, NAG Central Office.
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, HALF
+ PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0 )
+* .. Scalar Arguments ..
+ DOUBLE PRECISION EPS, THRESH
+ INTEGER INCMAX, NALF, NBET, NIDIM, NINC, NKB, NMAX,
+ $ NOUT, NTRA
+ LOGICAL FATAL, REWI, TRACE
+ CHARACTER*6 SNAME
+* .. Array Arguments ..
+ DOUBLE PRECISION A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
+ $ AS( NMAX*NMAX ), BET( NBET ), G( NMAX ),
+ $ X( NMAX ), XS( NMAX*INCMAX ),
+ $ XX( NMAX*INCMAX ), Y( NMAX ),
+ $ YS( NMAX*INCMAX ), YT( NMAX ),
+ $ YY( NMAX*INCMAX )
+ INTEGER IDIM( NIDIM ), INC( NINC ), KB( NKB )
+* .. Local Scalars ..
+ DOUBLE PRECISION ALPHA, ALS, BETA, BLS, ERR, ERRMAX, TRANSL
+ INTEGER I, IA, IB, IC, IK, IN, INCX, INCXS, INCY,
+ $ INCYS, IX, IY, K, KS, LAA, LDA, LDAS, LX, LY,
+ $ N, NARGS, NC, NK, NS
+ LOGICAL BANDED, FULL, NULL, PACKED, RESET, SAME
+ CHARACTER*1 UPLO, UPLOS
+ CHARACTER*2 ICH
+* .. Local Arrays ..
+ LOGICAL ISAME( 13 )
+* .. External Functions ..
+ LOGICAL LDE, LDERES
+ EXTERNAL LDE, LDERES
+* .. External Subroutines ..
+ EXTERNAL DMAKE, DMVCH, DSBMV, DSPMV, DSYMV
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX
+* .. Scalars in Common ..
+ INTEGER INFOT, NOUTC
+ LOGICAL LERR, OK
+* .. Common blocks ..
+ COMMON /INFOC/INFOT, NOUTC, OK, LERR
+* .. Data statements ..
+ DATA ICH/'UL'/
+* .. Executable Statements ..
+ FULL = SNAME( 3: 3 ).EQ.'Y'
+ BANDED = SNAME( 3: 3 ).EQ.'B'
+ PACKED = SNAME( 3: 3 ).EQ.'P'
+* Define the number of arguments.
+ IF( FULL )THEN
+ NARGS = 10
+ ELSE IF( BANDED )THEN
+ NARGS = 11
+ ELSE IF( PACKED )THEN
+ NARGS = 9
+ END IF
+*
+ NC = 0
+ RESET = .TRUE.
+ ERRMAX = ZERO
+*
+ DO 110 IN = 1, NIDIM
+ N = IDIM( IN )
+*
+ IF( BANDED )THEN
+ NK = NKB
+ ELSE
+ NK = 1
+ END IF
+ DO 100 IK = 1, NK
+ IF( BANDED )THEN
+ K = KB( IK )
+ ELSE
+ K = N - 1
+ END IF
+* Set LDA to 1 more than minimum value if room.
+ IF( BANDED )THEN
+ LDA = K + 1
+ ELSE
+ LDA = N
+ END IF
+ IF( LDA.LT.NMAX )
+ $ LDA = LDA + 1
+* Skip tests if not enough room.
+ IF( LDA.GT.NMAX )
+ $ GO TO 100
+ IF( PACKED )THEN
+ LAA = ( N*( N + 1 ) )/2
+ ELSE
+ LAA = LDA*N
+ END IF
+ NULL = N.LE.0
+*
+ DO 90 IC = 1, 2
+ UPLO = ICH( IC: IC )
+*
+* Generate the matrix A.
+*
+ TRANSL = ZERO
+ CALL DMAKE( SNAME( 2: 3 ), UPLO, ' ', N, N, A, NMAX, AA,
+ $ LDA, K, K, RESET, TRANSL )
+*
+ DO 80 IX = 1, NINC
+ INCX = INC( IX )
+ LX = ABS( INCX )*N
+*
+* Generate the vector X.
+*
+ TRANSL = HALF
+ CALL DMAKE( 'GE', ' ', ' ', 1, N, X, 1, XX,
+ $ ABS( INCX ), 0, N - 1, RESET, TRANSL )
+ IF( N.GT.1 )THEN
+ X( N/2 ) = ZERO
+ XX( 1 + ABS( INCX )*( N/2 - 1 ) ) = ZERO
+ END IF
+*
+ DO 70 IY = 1, NINC
+ INCY = INC( IY )
+ LY = ABS( INCY )*N
+*
+ DO 60 IA = 1, NALF
+ ALPHA = ALF( IA )
+*
+ DO 50 IB = 1, NBET
+ BETA = BET( IB )
+*
+* Generate the vector Y.
+*
+ TRANSL = ZERO
+ CALL DMAKE( 'GE', ' ', ' ', 1, N, Y, 1, YY,
+ $ ABS( INCY ), 0, N - 1, RESET,
+ $ TRANSL )
+*
+ NC = NC + 1
+*
+* Save every datum before calling the
+* subroutine.
+*
+ UPLOS = UPLO
+ NS = N
+ KS = K
+ ALS = ALPHA
+ DO 10 I = 1, LAA
+ AS( I ) = AA( I )
+ 10 CONTINUE
+ LDAS = LDA
+ DO 20 I = 1, LX
+ XS( I ) = XX( I )
+ 20 CONTINUE
+ INCXS = INCX
+ BLS = BETA
+ DO 30 I = 1, LY
+ YS( I ) = YY( I )
+ 30 CONTINUE
+ INCYS = INCY
+*
+* Call the subroutine.
+*
+ IF( FULL )THEN
+ IF( TRACE )
+ $ WRITE( NTRA, FMT = 9993 )NC, SNAME,
+ $ UPLO, N, ALPHA, LDA, INCX, BETA, INCY
+ IF( REWI )
+ $ REWIND NTRA
+ CALL DSYMV( UPLO, N, ALPHA, AA, LDA, XX,
+ $ INCX, BETA, YY, INCY )
+ ELSE IF( BANDED )THEN
+ IF( TRACE )
+ $ WRITE( NTRA, FMT = 9994 )NC, SNAME,
+ $ UPLO, N, K, ALPHA, LDA, INCX, BETA,
+ $ INCY
+ IF( REWI )
+ $ REWIND NTRA
+ CALL DSBMV( UPLO, N, K, ALPHA, AA, LDA,
+ $ XX, INCX, BETA, YY, INCY )
+ ELSE IF( PACKED )THEN
+ IF( TRACE )
+ $ WRITE( NTRA, FMT = 9995 )NC, SNAME,
+ $ UPLO, N, ALPHA, INCX, BETA, INCY
+ IF( REWI )
+ $ REWIND NTRA
+ CALL DSPMV( UPLO, N, ALPHA, AA, XX, INCX,
+ $ BETA, YY, INCY )
+ END IF
+*
+* Check if error-exit was taken incorrectly.
+*
+ IF( .NOT.OK )THEN
+ WRITE( NOUT, FMT = 9992 )
+ FATAL = .TRUE.
+ GO TO 120
+ END IF
+*
+* See what data changed inside subroutines.
+*
+ ISAME( 1 ) = UPLO.EQ.UPLOS
+ ISAME( 2 ) = NS.EQ.N
+ IF( FULL )THEN
+ ISAME( 3 ) = ALS.EQ.ALPHA
+ ISAME( 4 ) = LDE( AS, AA, LAA )
+ ISAME( 5 ) = LDAS.EQ.LDA
+ ISAME( 6 ) = LDE( XS, XX, LX )
+ ISAME( 7 ) = INCXS.EQ.INCX
+ ISAME( 8 ) = BLS.EQ.BETA
+ IF( NULL )THEN
+ ISAME( 9 ) = LDE( YS, YY, LY )
+ ELSE
+ ISAME( 9 ) = LDERES( 'GE', ' ', 1, N,
+ $ YS, YY, ABS( INCY ) )
+ END IF
+ ISAME( 10 ) = INCYS.EQ.INCY
+ ELSE IF( BANDED )THEN
+ ISAME( 3 ) = KS.EQ.K
+ ISAME( 4 ) = ALS.EQ.ALPHA
+ ISAME( 5 ) = LDE( AS, AA, LAA )
+ ISAME( 6 ) = LDAS.EQ.LDA
+ ISAME( 7 ) = LDE( XS, XX, LX )
+ ISAME( 8 ) = INCXS.EQ.INCX
+ ISAME( 9 ) = BLS.EQ.BETA
+ IF( NULL )THEN
+ ISAME( 10 ) = LDE( YS, YY, LY )
+ ELSE
+ ISAME( 10 ) = LDERES( 'GE', ' ', 1, N,
+ $ YS, YY, ABS( INCY ) )
+ END IF
+ ISAME( 11 ) = INCYS.EQ.INCY
+ ELSE IF( PACKED )THEN
+ ISAME( 3 ) = ALS.EQ.ALPHA
+ ISAME( 4 ) = LDE( AS, AA, LAA )
+ ISAME( 5 ) = LDE( XS, XX, LX )
+ ISAME( 6 ) = INCXS.EQ.INCX
+ ISAME( 7 ) = BLS.EQ.BETA
+ IF( NULL )THEN
+ ISAME( 8 ) = LDE( YS, YY, LY )
+ ELSE
+ ISAME( 8 ) = LDERES( 'GE', ' ', 1, N,
+ $ YS, YY, ABS( INCY ) )
+ END IF
+ ISAME( 9 ) = INCYS.EQ.INCY
+ END IF
+*
+* If data was incorrectly changed, report and
+* return.
+*
+ SAME = .TRUE.
+ DO 40 I = 1, NARGS
+ SAME = SAME.AND.ISAME( I )
+ IF( .NOT.ISAME( I ) )
+ $ WRITE( NOUT, FMT = 9998 )I
+ 40 CONTINUE
+ IF( .NOT.SAME )THEN
+ FATAL = .TRUE.
+ GO TO 120
+ END IF
+*
+ IF( .NOT.NULL )THEN
+*
+* Check the result.
+*
+ CALL DMVCH( 'N', N, N, ALPHA, A, NMAX, X,
+ $ INCX, BETA, Y, INCY, YT, G,
+ $ YY, EPS, ERR, FATAL, NOUT,
+ $ .TRUE. )
+ ERRMAX = MAX( ERRMAX, ERR )
+* If got really bad answer, report and
+* return.
+ IF( FATAL )
+ $ GO TO 120
+ ELSE
+* Avoid repeating tests with N.le.0
+ GO TO 110
+ END IF
+*
+ 50 CONTINUE
+*
+ 60 CONTINUE
+*
+ 70 CONTINUE
+*
+ 80 CONTINUE
+*
+ 90 CONTINUE
+*
+ 100 CONTINUE
+*
+ 110 CONTINUE
+*
+* Report result.
+*
+ IF( ERRMAX.LT.THRESH )THEN
+ WRITE( NOUT, FMT = 9999 )SNAME, NC
+ ELSE
+ WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX
+ END IF
+ GO TO 130
+*
+ 120 CONTINUE
+ WRITE( NOUT, FMT = 9996 )SNAME
+ IF( FULL )THEN
+ WRITE( NOUT, FMT = 9993 )NC, SNAME, UPLO, N, ALPHA, LDA, INCX,
+ $ BETA, INCY
+ ELSE IF( BANDED )THEN
+ WRITE( NOUT, FMT = 9994 )NC, SNAME, UPLO, N, K, ALPHA, LDA,
+ $ INCX, BETA, INCY
+ ELSE IF( PACKED )THEN
+ WRITE( NOUT, FMT = 9995 )NC, SNAME, UPLO, N, ALPHA, INCX,
+ $ BETA, INCY
+ END IF
+*
+ 130 CONTINUE
+ RETURN
+*
+ 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL',
+ $ 'S)' )
+ 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
+ $ 'ANGED INCORRECTLY *******' )
+ 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C',
+ $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2,
+ $ ' - SUSPECT *******' )
+ 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' )
+ 9995 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', I3, ',', F4.1, ', AP',
+ $ ', X,', I2, ',', F4.1, ', Y,', I2, ') .' )
+ 9994 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', 2( I3, ',' ), F4.1,
+ $ ', A,', I3, ', X,', I2, ',', F4.1, ', Y,', I2,
+ $ ') .' )
+ 9993 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', I3, ',', F4.1, ', A,',
+ $ I3, ', X,', I2, ',', F4.1, ', Y,', I2, ') .' )
+ 9992 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
+ $ '******' )
+*
+* End of DCHK2.
+*
+ END
+ SUBROUTINE DCHK3( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
+ $ FATAL, NIDIM, IDIM, NKB, KB, NINC, INC, NMAX,
+ $ INCMAX, A, AA, AS, X, XX, XS, XT, G, Z )
+*
+* Tests DTRMV, DTBMV, DTPMV, DTRSV, DTBSV and DTPSV.
+*
+* Auxiliary routine for test program for Level 2 Blas.
+*
+* -- Written on 10-August-1987.
+* Richard Hanson, Sandia National Labs.
+* Jeremy Du Croz, NAG Central Office.
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, HALF, ONE
+ PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0 )
+* .. Scalar Arguments ..
+ DOUBLE PRECISION EPS, THRESH
+ INTEGER INCMAX, NIDIM, NINC, NKB, NMAX, NOUT, NTRA
+ LOGICAL FATAL, REWI, TRACE
+ CHARACTER*6 SNAME
+* .. Array Arguments ..
+ DOUBLE PRECISION A( NMAX, NMAX ), AA( NMAX*NMAX ),
+ $ AS( NMAX*NMAX ), G( NMAX ), X( NMAX ),
+ $ XS( NMAX*INCMAX ), XT( NMAX ),
+ $ XX( NMAX*INCMAX ), Z( NMAX )
+ INTEGER IDIM( NIDIM ), INC( NINC ), KB( NKB )
+* .. Local Scalars ..
+ DOUBLE PRECISION ERR, ERRMAX, TRANSL
+ INTEGER I, ICD, ICT, ICU, IK, IN, INCX, INCXS, IX, K,
+ $ KS, LAA, LDA, LDAS, LX, N, NARGS, NC, NK, NS
+ LOGICAL BANDED, FULL, NULL, PACKED, RESET, SAME
+ CHARACTER*1 DIAG, DIAGS, TRANS, TRANSS, UPLO, UPLOS
+ CHARACTER*2 ICHD, ICHU
+ CHARACTER*3 ICHT
+* .. Local Arrays ..
+ LOGICAL ISAME( 13 )
+* .. External Functions ..
+ LOGICAL LDE, LDERES
+ EXTERNAL LDE, LDERES
+* .. External Subroutines ..
+ EXTERNAL DMAKE, DMVCH, DTBMV, DTBSV, DTPMV, DTPSV,
+ $ DTRMV, DTRSV
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX
+* .. Scalars in Common ..
+ INTEGER INFOT, NOUTC
+ LOGICAL LERR, OK
+* .. Common blocks ..
+ COMMON /INFOC/INFOT, NOUTC, OK, LERR
+* .. Data statements ..
+ DATA ICHU/'UL'/, ICHT/'NTC'/, ICHD/'UN'/
+* .. Executable Statements ..
+ FULL = SNAME( 3: 3 ).EQ.'R'
+ BANDED = SNAME( 3: 3 ).EQ.'B'
+ PACKED = SNAME( 3: 3 ).EQ.'P'
+* Define the number of arguments.
+ IF( FULL )THEN
+ NARGS = 8
+ ELSE IF( BANDED )THEN
+ NARGS = 9
+ ELSE IF( PACKED )THEN
+ NARGS = 7
+ END IF
+*
+ NC = 0
+ RESET = .TRUE.
+ ERRMAX = ZERO
+* Set up zero vector for DMVCH.
+ DO 10 I = 1, NMAX
+ Z( I ) = ZERO
+ 10 CONTINUE
+*
+ DO 110 IN = 1, NIDIM
+ N = IDIM( IN )
+*
+ IF( BANDED )THEN
+ NK = NKB
+ ELSE
+ NK = 1
+ END IF
+ DO 100 IK = 1, NK
+ IF( BANDED )THEN
+ K = KB( IK )
+ ELSE
+ K = N - 1
+ END IF
+* Set LDA to 1 more than minimum value if room.
+ IF( BANDED )THEN
+ LDA = K + 1
+ ELSE
+ LDA = N
+ END IF
+ IF( LDA.LT.NMAX )
+ $ LDA = LDA + 1
+* Skip tests if not enough room.
+ IF( LDA.GT.NMAX )
+ $ GO TO 100
+ IF( PACKED )THEN
+ LAA = ( N*( N + 1 ) )/2
+ ELSE
+ LAA = LDA*N
+ END IF
+ NULL = N.LE.0
+*
+ DO 90 ICU = 1, 2
+ UPLO = ICHU( ICU: ICU )
+*
+ DO 80 ICT = 1, 3
+ TRANS = ICHT( ICT: ICT )
+*
+ DO 70 ICD = 1, 2
+ DIAG = ICHD( ICD: ICD )
+*
+* Generate the matrix A.
+*
+ TRANSL = ZERO
+ CALL DMAKE( SNAME( 2: 3 ), UPLO, DIAG, N, N, A,
+ $ NMAX, AA, LDA, K, K, RESET, TRANSL )
+*
+ DO 60 IX = 1, NINC
+ INCX = INC( IX )
+ LX = ABS( INCX )*N
+*
+* Generate the vector X.
+*
+ TRANSL = HALF
+ CALL DMAKE( 'GE', ' ', ' ', 1, N, X, 1, XX,
+ $ ABS( INCX ), 0, N - 1, RESET,
+ $ TRANSL )
+ IF( N.GT.1 )THEN
+ X( N/2 ) = ZERO
+ XX( 1 + ABS( INCX )*( N/2 - 1 ) ) = ZERO
+ END IF
+*
+ NC = NC + 1
+*
+* Save every datum before calling the subroutine.
+*
+ UPLOS = UPLO
+ TRANSS = TRANS
+ DIAGS = DIAG
+ NS = N
+ KS = K
+ DO 20 I = 1, LAA
+ AS( I ) = AA( I )
+ 20 CONTINUE
+ LDAS = LDA
+ DO 30 I = 1, LX
+ XS( I ) = XX( I )
+ 30 CONTINUE
+ INCXS = INCX
+*
+* Call the subroutine.
+*
+ IF( SNAME( 4: 5 ).EQ.'MV' )THEN
+ IF( FULL )THEN
+ IF( TRACE )
+ $ WRITE( NTRA, FMT = 9993 )NC, SNAME,
+ $ UPLO, TRANS, DIAG, N, LDA, INCX
+ IF( REWI )
+ $ REWIND NTRA
+ CALL DTRMV( UPLO, TRANS, DIAG, N, AA, LDA,
+ $ XX, INCX )
+ ELSE IF( BANDED )THEN
+ IF( TRACE )
+ $ WRITE( NTRA, FMT = 9994 )NC, SNAME,
+ $ UPLO, TRANS, DIAG, N, K, LDA, INCX
+ IF( REWI )
+ $ REWIND NTRA
+ CALL DTBMV( UPLO, TRANS, DIAG, N, K, AA,
+ $ LDA, XX, INCX )
+ ELSE IF( PACKED )THEN
+ IF( TRACE )
+ $ WRITE( NTRA, FMT = 9995 )NC, SNAME,
+ $ UPLO, TRANS, DIAG, N, INCX
+ IF( REWI )
+ $ REWIND NTRA
+ CALL DTPMV( UPLO, TRANS, DIAG, N, AA, XX,
+ $ INCX )
+ END IF
+ ELSE IF( SNAME( 4: 5 ).EQ.'SV' )THEN
+ IF( FULL )THEN
+ IF( TRACE )
+ $ WRITE( NTRA, FMT = 9993 )NC, SNAME,
+ $ UPLO, TRANS, DIAG, N, LDA, INCX
+ IF( REWI )
+ $ REWIND NTRA
+ CALL DTRSV( UPLO, TRANS, DIAG, N, AA, LDA,
+ $ XX, INCX )
+ ELSE IF( BANDED )THEN
+ IF( TRACE )
+ $ WRITE( NTRA, FMT = 9994 )NC, SNAME,
+ $ UPLO, TRANS, DIAG, N, K, LDA, INCX
+ IF( REWI )
+ $ REWIND NTRA
+ CALL DTBSV( UPLO, TRANS, DIAG, N, K, AA,
+ $ LDA, XX, INCX )
+ ELSE IF( PACKED )THEN
+ IF( TRACE )
+ $ WRITE( NTRA, FMT = 9995 )NC, SNAME,
+ $ UPLO, TRANS, DIAG, N, INCX
+ IF( REWI )
+ $ REWIND NTRA
+ CALL DTPSV( UPLO, TRANS, DIAG, N, AA, XX,
+ $ INCX )
+ END IF
+ END IF
+*
+* Check if error-exit was taken incorrectly.
+*
+ IF( .NOT.OK )THEN
+ WRITE( NOUT, FMT = 9992 )
+ FATAL = .TRUE.
+ GO TO 120
+ END IF
+*
+* See what data changed inside subroutines.
+*
+ ISAME( 1 ) = UPLO.EQ.UPLOS
+ ISAME( 2 ) = TRANS.EQ.TRANSS
+ ISAME( 3 ) = DIAG.EQ.DIAGS
+ ISAME( 4 ) = NS.EQ.N
+ IF( FULL )THEN
+ ISAME( 5 ) = LDE( AS, AA, LAA )
+ ISAME( 6 ) = LDAS.EQ.LDA
+ IF( NULL )THEN
+ ISAME( 7 ) = LDE( XS, XX, LX )
+ ELSE
+ ISAME( 7 ) = LDERES( 'GE', ' ', 1, N, XS,
+ $ XX, ABS( INCX ) )
+ END IF
+ ISAME( 8 ) = INCXS.EQ.INCX
+ ELSE IF( BANDED )THEN
+ ISAME( 5 ) = KS.EQ.K
+ ISAME( 6 ) = LDE( AS, AA, LAA )
+ ISAME( 7 ) = LDAS.EQ.LDA
+ IF( NULL )THEN
+ ISAME( 8 ) = LDE( XS, XX, LX )
+ ELSE
+ ISAME( 8 ) = LDERES( 'GE', ' ', 1, N, XS,
+ $ XX, ABS( INCX ) )
+ END IF
+ ISAME( 9 ) = INCXS.EQ.INCX
+ ELSE IF( PACKED )THEN
+ ISAME( 5 ) = LDE( AS, AA, LAA )
+ IF( NULL )THEN
+ ISAME( 6 ) = LDE( XS, XX, LX )
+ ELSE
+ ISAME( 6 ) = LDERES( 'GE', ' ', 1, N, XS,
+ $ XX, ABS( INCX ) )
+ END IF
+ ISAME( 7 ) = INCXS.EQ.INCX
+ END IF
+*
+* If data was incorrectly changed, report and
+* return.
+*
+ SAME = .TRUE.
+ DO 40 I = 1, NARGS
+ SAME = SAME.AND.ISAME( I )
+ IF( .NOT.ISAME( I ) )
+ $ WRITE( NOUT, FMT = 9998 )I
+ 40 CONTINUE
+ IF( .NOT.SAME )THEN
+ FATAL = .TRUE.
+ GO TO 120
+ END IF
+*
+ IF( .NOT.NULL )THEN
+ IF( SNAME( 4: 5 ).EQ.'MV' )THEN
+*
+* Check the result.
+*
+ CALL DMVCH( TRANS, N, N, ONE, A, NMAX, X,
+ $ INCX, ZERO, Z, INCX, XT, G,
+ $ XX, EPS, ERR, FATAL, NOUT,
+ $ .TRUE. )
+ ELSE IF( SNAME( 4: 5 ).EQ.'SV' )THEN
+*
+* Compute approximation to original vector.
+*
+ DO 50 I = 1, N
+ Z( I ) = XX( 1 + ( I - 1 )*
+ $ ABS( INCX ) )
+ XX( 1 + ( I - 1 )*ABS( INCX ) )
+ $ = X( I )
+ 50 CONTINUE
+ CALL DMVCH( TRANS, N, N, ONE, A, NMAX, Z,
+ $ INCX, ZERO, X, INCX, XT, G,
+ $ XX, EPS, ERR, FATAL, NOUT,
+ $ .FALSE. )
+ END IF
+ ERRMAX = MAX( ERRMAX, ERR )
+* If got really bad answer, report and return.
+ IF( FATAL )
+ $ GO TO 120
+ ELSE
+* Avoid repeating tests with N.le.0.
+ GO TO 110
+ END IF
+*
+ 60 CONTINUE
+*
+ 70 CONTINUE
+*
+ 80 CONTINUE
+*
+ 90 CONTINUE
+*
+ 100 CONTINUE
+*
+ 110 CONTINUE
+*
+* Report result.
+*
+ IF( ERRMAX.LT.THRESH )THEN
+ WRITE( NOUT, FMT = 9999 )SNAME, NC
+ ELSE
+ WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX
+ END IF
+ GO TO 130
+*
+ 120 CONTINUE
+ WRITE( NOUT, FMT = 9996 )SNAME
+ IF( FULL )THEN
+ WRITE( NOUT, FMT = 9993 )NC, SNAME, UPLO, TRANS, DIAG, N, LDA,
+ $ INCX
+ ELSE IF( BANDED )THEN
+ WRITE( NOUT, FMT = 9994 )NC, SNAME, UPLO, TRANS, DIAG, N, K,
+ $ LDA, INCX
+ ELSE IF( PACKED )THEN
+ WRITE( NOUT, FMT = 9995 )NC, SNAME, UPLO, TRANS, DIAG, N, INCX
+ END IF
+*
+ 130 CONTINUE
+ RETURN
+*
+ 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL',
+ $ 'S)' )
+ 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
+ $ 'ANGED INCORRECTLY *******' )
+ 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C',
+ $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2,
+ $ ' - SUSPECT *******' )
+ 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' )
+ 9995 FORMAT( 1X, I6, ': ', A6, '(', 3( '''', A1, ''',' ), I3, ', AP, ',
+ $ 'X,', I2, ') .' )
+ 9994 FORMAT( 1X, I6, ': ', A6, '(', 3( '''', A1, ''',' ), 2( I3, ',' ),
+ $ ' A,', I3, ', X,', I2, ') .' )
+ 9993 FORMAT( 1X, I6, ': ', A6, '(', 3( '''', A1, ''',' ), I3, ', A,',
+ $ I3, ', X,', I2, ') .' )
+ 9992 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
+ $ '******' )
+*
+* End of DCHK3.
+*
+ END
+ SUBROUTINE DCHK4( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
+ $ FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC, NMAX,
+ $ INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, YT, G,
+ $ Z )
+*
+* Tests DGER.
+*
+* Auxiliary routine for test program for Level 2 Blas.
+*
+* -- Written on 10-August-1987.
+* Richard Hanson, Sandia National Labs.
+* Jeremy Du Croz, NAG Central Office.
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, HALF, ONE
+ PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0 )
+* .. Scalar Arguments ..
+ DOUBLE PRECISION EPS, THRESH
+ INTEGER INCMAX, NALF, NIDIM, NINC, NMAX, NOUT, NTRA
+ LOGICAL FATAL, REWI, TRACE
+ CHARACTER*6 SNAME
+* .. Array Arguments ..
+ DOUBLE PRECISION A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
+ $ AS( NMAX*NMAX ), G( NMAX ), X( NMAX ),
+ $ XS( NMAX*INCMAX ), XX( NMAX*INCMAX ),
+ $ Y( NMAX ), YS( NMAX*INCMAX ), YT( NMAX ),
+ $ YY( NMAX*INCMAX ), Z( NMAX )
+ INTEGER IDIM( NIDIM ), INC( NINC )
+* .. Local Scalars ..
+ DOUBLE PRECISION ALPHA, ALS, ERR, ERRMAX, TRANSL
+ INTEGER I, IA, IM, IN, INCX, INCXS, INCY, INCYS, IX,
+ $ IY, J, LAA, LDA, LDAS, LX, LY, M, MS, N, NARGS,
+ $ NC, ND, NS
+ LOGICAL NULL, RESET, SAME
+* .. Local Arrays ..
+ DOUBLE PRECISION W( 1 )
+ LOGICAL ISAME( 13 )
+* .. External Functions ..
+ LOGICAL LDE, LDERES
+ EXTERNAL LDE, LDERES
+* .. External Subroutines ..
+ EXTERNAL DGER, DMAKE, DMVCH
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, MIN
+* .. Scalars in Common ..
+ INTEGER INFOT, NOUTC
+ LOGICAL LERR, OK
+* .. Common blocks ..
+ COMMON /INFOC/INFOT, NOUTC, OK, LERR
+* .. Executable Statements ..
+* Define the number of arguments.
+ NARGS = 9
+*
+ NC = 0
+ RESET = .TRUE.
+ ERRMAX = ZERO
+*
+ DO 120 IN = 1, NIDIM
+ N = IDIM( IN )
+ ND = N/2 + 1
+*
+ DO 110 IM = 1, 2
+ IF( IM.EQ.1 )
+ $ M = MAX( N - ND, 0 )
+ IF( IM.EQ.2 )
+ $ M = MIN( N + ND, NMAX )
+*
+* Set LDA to 1 more than minimum value if room.
+ LDA = M
+ IF( LDA.LT.NMAX )
+ $ LDA = LDA + 1
+* Skip tests if not enough room.
+ IF( LDA.GT.NMAX )
+ $ GO TO 110
+ LAA = LDA*N
+ NULL = N.LE.0.OR.M.LE.0
+*
+ DO 100 IX = 1, NINC
+ INCX = INC( IX )
+ LX = ABS( INCX )*M
+*
+* Generate the vector X.
+*
+ TRANSL = HALF
+ CALL DMAKE( 'GE', ' ', ' ', 1, M, X, 1, XX, ABS( INCX ),
+ $ 0, M - 1, RESET, TRANSL )
+ IF( M.GT.1 )THEN
+ X( M/2 ) = ZERO
+ XX( 1 + ABS( INCX )*( M/2 - 1 ) ) = ZERO
+ END IF
+*
+ DO 90 IY = 1, NINC
+ INCY = INC( IY )
+ LY = ABS( INCY )*N
+*
+* Generate the vector Y.
+*
+ TRANSL = ZERO
+ CALL DMAKE( 'GE', ' ', ' ', 1, N, Y, 1, YY,
+ $ ABS( INCY ), 0, N - 1, RESET, TRANSL )
+ IF( N.GT.1 )THEN
+ Y( N/2 ) = ZERO
+ YY( 1 + ABS( INCY )*( N/2 - 1 ) ) = ZERO
+ END IF
+*
+ DO 80 IA = 1, NALF
+ ALPHA = ALF( IA )
+*
+* Generate the matrix A.
+*
+ TRANSL = ZERO
+ CALL DMAKE( SNAME( 2: 3 ), ' ', ' ', M, N, A, NMAX,
+ $ AA, LDA, M - 1, N - 1, RESET, TRANSL )
+*
+ NC = NC + 1
+*
+* Save every datum before calling the subroutine.
+*
+ MS = M
+ NS = N
+ ALS = ALPHA
+ DO 10 I = 1, LAA
+ AS( I ) = AA( I )
+ 10 CONTINUE
+ LDAS = LDA
+ DO 20 I = 1, LX
+ XS( I ) = XX( I )
+ 20 CONTINUE
+ INCXS = INCX
+ DO 30 I = 1, LY
+ YS( I ) = YY( I )
+ 30 CONTINUE
+ INCYS = INCY
+*
+* Call the subroutine.
+*
+ IF( TRACE )
+ $ WRITE( NTRA, FMT = 9994 )NC, SNAME, M, N,
+ $ ALPHA, INCX, INCY, LDA
+ IF( REWI )
+ $ REWIND NTRA
+ CALL DGER( M, N, ALPHA, XX, INCX, YY, INCY, AA,
+ $ LDA )
+*
+* Check if error-exit was taken incorrectly.
+*
+ IF( .NOT.OK )THEN
+ WRITE( NOUT, FMT = 9993 )
+ FATAL = .TRUE.
+ GO TO 140
+ END IF
+*
+* See what data changed inside subroutine.
+*
+ ISAME( 1 ) = MS.EQ.M
+ ISAME( 2 ) = NS.EQ.N
+ ISAME( 3 ) = ALS.EQ.ALPHA
+ ISAME( 4 ) = LDE( XS, XX, LX )
+ ISAME( 5 ) = INCXS.EQ.INCX
+ ISAME( 6 ) = LDE( YS, YY, LY )
+ ISAME( 7 ) = INCYS.EQ.INCY
+ IF( NULL )THEN
+ ISAME( 8 ) = LDE( AS, AA, LAA )
+ ELSE
+ ISAME( 8 ) = LDERES( 'GE', ' ', M, N, AS, AA,
+ $ LDA )
+ END IF
+ ISAME( 9 ) = LDAS.EQ.LDA
+*
+* If data was incorrectly changed, report and return.
+*
+ SAME = .TRUE.
+ DO 40 I = 1, NARGS
+ SAME = SAME.AND.ISAME( I )
+ IF( .NOT.ISAME( I ) )
+ $ WRITE( NOUT, FMT = 9998 )I
+ 40 CONTINUE
+ IF( .NOT.SAME )THEN
+ FATAL = .TRUE.
+ GO TO 140
+ END IF
+*
+ IF( .NOT.NULL )THEN
+*
+* Check the result column by column.
+*
+ IF( INCX.GT.0 )THEN
+ DO 50 I = 1, M
+ Z( I ) = X( I )
+ 50 CONTINUE
+ ELSE
+ DO 60 I = 1, M
+ Z( I ) = X( M - I + 1 )
+ 60 CONTINUE
+ END IF
+ DO 70 J = 1, N
+ IF( INCY.GT.0 )THEN
+ W( 1 ) = Y( J )
+ ELSE
+ W( 1 ) = Y( N - J + 1 )
+ END IF
+ CALL DMVCH( 'N', M, 1, ALPHA, Z, NMAX, W, 1,
+ $ ONE, A( 1, J ), 1, YT, G,
+ $ AA( 1 + ( J - 1 )*LDA ), EPS,
+ $ ERR, FATAL, NOUT, .TRUE. )
+ ERRMAX = MAX( ERRMAX, ERR )
+* If got really bad answer, report and return.
+ IF( FATAL )
+ $ GO TO 130
+ 70 CONTINUE
+ ELSE
+* Avoid repeating tests with M.le.0 or N.le.0.
+ GO TO 110
+ END IF
+*
+ 80 CONTINUE
+*
+ 90 CONTINUE
+*
+ 100 CONTINUE
+*
+ 110 CONTINUE
+*
+ 120 CONTINUE
+*
+* Report result.
+*
+ IF( ERRMAX.LT.THRESH )THEN
+ WRITE( NOUT, FMT = 9999 )SNAME, NC
+ ELSE
+ WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX
+ END IF
+ GO TO 150
+*
+ 130 CONTINUE
+ WRITE( NOUT, FMT = 9995 )J
+*
+ 140 CONTINUE
+ WRITE( NOUT, FMT = 9996 )SNAME
+ WRITE( NOUT, FMT = 9994 )NC, SNAME, M, N, ALPHA, INCX, INCY, LDA
+*
+ 150 CONTINUE
+ RETURN
+*
+ 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL',
+ $ 'S)' )
+ 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
+ $ 'ANGED INCORRECTLY *******' )
+ 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C',
+ $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2,
+ $ ' - SUSPECT *******' )
+ 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' )
+ 9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 )
+ 9994 FORMAT( 1X, I6, ': ', A6, '(', 2( I3, ',' ), F4.1, ', X,', I2,
+ $ ', Y,', I2, ', A,', I3, ') .' )
+ 9993 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
+ $ '******' )
+*
+* End of DCHK4.
+*
+ END
+ SUBROUTINE DCHK5( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
+ $ FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC, NMAX,
+ $ INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, YT, G,
+ $ Z )
+*
+* Tests DSYR and DSPR.
+*
+* Auxiliary routine for test program for Level 2 Blas.
+*
+* -- Written on 10-August-1987.
+* Richard Hanson, Sandia National Labs.
+* Jeremy Du Croz, NAG Central Office.
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, HALF, ONE
+ PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0 )
+* .. Scalar Arguments ..
+ DOUBLE PRECISION EPS, THRESH
+ INTEGER INCMAX, NALF, NIDIM, NINC, NMAX, NOUT, NTRA
+ LOGICAL FATAL, REWI, TRACE
+ CHARACTER*6 SNAME
+* .. Array Arguments ..
+ DOUBLE PRECISION A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
+ $ AS( NMAX*NMAX ), G( NMAX ), X( NMAX ),
+ $ XS( NMAX*INCMAX ), XX( NMAX*INCMAX ),
+ $ Y( NMAX ), YS( NMAX*INCMAX ), YT( NMAX ),
+ $ YY( NMAX*INCMAX ), Z( NMAX )
+ INTEGER IDIM( NIDIM ), INC( NINC )
+* .. Local Scalars ..
+ DOUBLE PRECISION ALPHA, ALS, ERR, ERRMAX, TRANSL
+ INTEGER I, IA, IC, IN, INCX, INCXS, IX, J, JA, JJ, LAA,
+ $ LDA, LDAS, LJ, LX, N, NARGS, NC, NS
+ LOGICAL FULL, NULL, PACKED, RESET, SAME, UPPER
+ CHARACTER*1 UPLO, UPLOS
+ CHARACTER*2 ICH
+* .. Local Arrays ..
+ DOUBLE PRECISION W( 1 )
+ LOGICAL ISAME( 13 )
+* .. External Functions ..
+ LOGICAL LDE, LDERES
+ EXTERNAL LDE, LDERES
+* .. External Subroutines ..
+ EXTERNAL DMAKE, DMVCH, DSPR, DSYR
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX
+* .. Scalars in Common ..
+ INTEGER INFOT, NOUTC
+ LOGICAL LERR, OK
+* .. Common blocks ..
+ COMMON /INFOC/INFOT, NOUTC, OK, LERR
+* .. Data statements ..
+ DATA ICH/'UL'/
+* .. Executable Statements ..
+ FULL = SNAME( 3: 3 ).EQ.'Y'
+ PACKED = SNAME( 3: 3 ).EQ.'P'
+* Define the number of arguments.
+ IF( FULL )THEN
+ NARGS = 7
+ ELSE IF( PACKED )THEN
+ NARGS = 6
+ END IF
+*
+ NC = 0
+ RESET = .TRUE.
+ ERRMAX = ZERO
+*
+ DO 100 IN = 1, NIDIM
+ N = IDIM( IN )
+* Set LDA to 1 more than minimum value if room.
+ LDA = N
+ IF( LDA.LT.NMAX )
+ $ LDA = LDA + 1
+* Skip tests if not enough room.
+ IF( LDA.GT.NMAX )
+ $ GO TO 100
+ IF( PACKED )THEN
+ LAA = ( N*( N + 1 ) )/2
+ ELSE
+ LAA = LDA*N
+ END IF
+*
+ DO 90 IC = 1, 2
+ UPLO = ICH( IC: IC )
+ UPPER = UPLO.EQ.'U'
+*
+ DO 80 IX = 1, NINC
+ INCX = INC( IX )
+ LX = ABS( INCX )*N
+*
+* Generate the vector X.
+*
+ TRANSL = HALF
+ CALL DMAKE( 'GE', ' ', ' ', 1, N, X, 1, XX, ABS( INCX ),
+ $ 0, N - 1, RESET, TRANSL )
+ IF( N.GT.1 )THEN
+ X( N/2 ) = ZERO
+ XX( 1 + ABS( INCX )*( N/2 - 1 ) ) = ZERO
+ END IF
+*
+ DO 70 IA = 1, NALF
+ ALPHA = ALF( IA )
+ NULL = N.LE.0.OR.ALPHA.EQ.ZERO
+*
+* Generate the matrix A.
+*
+ TRANSL = ZERO
+ CALL DMAKE( SNAME( 2: 3 ), UPLO, ' ', N, N, A, NMAX,
+ $ AA, LDA, N - 1, N - 1, RESET, TRANSL )
+*
+ NC = NC + 1
+*
+* Save every datum before calling the subroutine.
+*
+ UPLOS = UPLO
+ NS = N
+ ALS = ALPHA
+ DO 10 I = 1, LAA
+ AS( I ) = AA( I )
+ 10 CONTINUE
+ LDAS = LDA
+ DO 20 I = 1, LX
+ XS( I ) = XX( I )
+ 20 CONTINUE
+ INCXS = INCX
+*
+* Call the subroutine.
+*
+ IF( FULL )THEN
+ IF( TRACE )
+ $ WRITE( NTRA, FMT = 9993 )NC, SNAME, UPLO, N,
+ $ ALPHA, INCX, LDA
+ IF( REWI )
+ $ REWIND NTRA
+ CALL DSYR( UPLO, N, ALPHA, XX, INCX, AA, LDA )
+ ELSE IF( PACKED )THEN
+ IF( TRACE )
+ $ WRITE( NTRA, FMT = 9994 )NC, SNAME, UPLO, N,
+ $ ALPHA, INCX
+ IF( REWI )
+ $ REWIND NTRA
+ CALL DSPR( UPLO, N, ALPHA, XX, INCX, AA )
+ END IF
+*
+* Check if error-exit was taken incorrectly.
+*
+ IF( .NOT.OK )THEN
+ WRITE( NOUT, FMT = 9992 )
+ FATAL = .TRUE.
+ GO TO 120
+ END IF
+*
+* See what data changed inside subroutines.
+*
+ ISAME( 1 ) = UPLO.EQ.UPLOS
+ ISAME( 2 ) = NS.EQ.N
+ ISAME( 3 ) = ALS.EQ.ALPHA
+ ISAME( 4 ) = LDE( XS, XX, LX )
+ ISAME( 5 ) = INCXS.EQ.INCX
+ IF( NULL )THEN
+ ISAME( 6 ) = LDE( AS, AA, LAA )
+ ELSE
+ ISAME( 6 ) = LDERES( SNAME( 2: 3 ), UPLO, N, N, AS,
+ $ AA, LDA )
+ END IF
+ IF( .NOT.PACKED )THEN
+ ISAME( 7 ) = LDAS.EQ.LDA
+ END IF
+*
+* If data was incorrectly changed, report and return.
+*
+ SAME = .TRUE.
+ DO 30 I = 1, NARGS
+ SAME = SAME.AND.ISAME( I )
+ IF( .NOT.ISAME( I ) )
+ $ WRITE( NOUT, FMT = 9998 )I
+ 30 CONTINUE
+ IF( .NOT.SAME )THEN
+ FATAL = .TRUE.
+ GO TO 120
+ END IF
+*
+ IF( .NOT.NULL )THEN
+*
+* Check the result column by column.
+*
+ IF( INCX.GT.0 )THEN
+ DO 40 I = 1, N
+ Z( I ) = X( I )
+ 40 CONTINUE
+ ELSE
+ DO 50 I = 1, N
+ Z( I ) = X( N - I + 1 )
+ 50 CONTINUE
+ END IF
+ JA = 1
+ DO 60 J = 1, N
+ W( 1 ) = Z( J )
+ IF( UPPER )THEN
+ JJ = 1
+ LJ = J
+ ELSE
+ JJ = J
+ LJ = N - J + 1
+ END IF
+ CALL DMVCH( 'N', LJ, 1, ALPHA, Z( JJ ), LJ, W,
+ $ 1, ONE, A( JJ, J ), 1, YT, G,
+ $ AA( JA ), EPS, ERR, FATAL, NOUT,
+ $ .TRUE. )
+ IF( FULL )THEN
+ IF( UPPER )THEN
+ JA = JA + LDA
+ ELSE
+ JA = JA + LDA + 1
+ END IF
+ ELSE
+ JA = JA + LJ
+ END IF
+ ERRMAX = MAX( ERRMAX, ERR )
+* If got really bad answer, report and return.
+ IF( FATAL )
+ $ GO TO 110
+ 60 CONTINUE
+ ELSE
+* Avoid repeating tests if N.le.0.
+ IF( N.LE.0 )
+ $ GO TO 100
+ END IF
+*
+ 70 CONTINUE
+*
+ 80 CONTINUE
+*
+ 90 CONTINUE
+*
+ 100 CONTINUE
+*
+* Report result.
+*
+ IF( ERRMAX.LT.THRESH )THEN
+ WRITE( NOUT, FMT = 9999 )SNAME, NC
+ ELSE
+ WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX
+ END IF
+ GO TO 130
+*
+ 110 CONTINUE
+ WRITE( NOUT, FMT = 9995 )J
+*
+ 120 CONTINUE
+ WRITE( NOUT, FMT = 9996 )SNAME
+ IF( FULL )THEN
+ WRITE( NOUT, FMT = 9993 )NC, SNAME, UPLO, N, ALPHA, INCX, LDA
+ ELSE IF( PACKED )THEN
+ WRITE( NOUT, FMT = 9994 )NC, SNAME, UPLO, N, ALPHA, INCX
+ END IF
+*
+ 130 CONTINUE
+ RETURN
+*
+ 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL',
+ $ 'S)' )
+ 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
+ $ 'ANGED INCORRECTLY *******' )
+ 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C',
+ $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2,
+ $ ' - SUSPECT *******' )
+ 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' )
+ 9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 )
+ 9994 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', I3, ',', F4.1, ', X,',
+ $ I2, ', AP) .' )
+ 9993 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', I3, ',', F4.1, ', X,',
+ $ I2, ', A,', I3, ') .' )
+ 9992 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
+ $ '******' )
+*
+* End of DCHK5.
+*
+ END
+ SUBROUTINE DCHK6( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
+ $ FATAL, NIDIM, IDIM, NALF, ALF, NINC, INC, NMAX,
+ $ INCMAX, A, AA, AS, X, XX, XS, Y, YY, YS, YT, G,
+ $ Z )
+*
+* Tests DSYR2 and DSPR2.
+*
+* Auxiliary routine for test program for Level 2 Blas.
+*
+* -- Written on 10-August-1987.
+* Richard Hanson, Sandia National Labs.
+* Jeremy Du Croz, NAG Central Office.
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, HALF, ONE
+ PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0 )
+* .. Scalar Arguments ..
+ DOUBLE PRECISION EPS, THRESH
+ INTEGER INCMAX, NALF, NIDIM, NINC, NMAX, NOUT, NTRA
+ LOGICAL FATAL, REWI, TRACE
+ CHARACTER*6 SNAME
+* .. Array Arguments ..
+ DOUBLE PRECISION A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
+ $ AS( NMAX*NMAX ), G( NMAX ), X( NMAX ),
+ $ XS( NMAX*INCMAX ), XX( NMAX*INCMAX ),
+ $ Y( NMAX ), YS( NMAX*INCMAX ), YT( NMAX ),
+ $ YY( NMAX*INCMAX ), Z( NMAX, 2 )
+ INTEGER IDIM( NIDIM ), INC( NINC )
+* .. Local Scalars ..
+ DOUBLE PRECISION ALPHA, ALS, ERR, ERRMAX, TRANSL
+ INTEGER I, IA, IC, IN, INCX, INCXS, INCY, INCYS, IX,
+ $ IY, J, JA, JJ, LAA, LDA, LDAS, LJ, LX, LY, N,
+ $ NARGS, NC, NS
+ LOGICAL FULL, NULL, PACKED, RESET, SAME, UPPER
+ CHARACTER*1 UPLO, UPLOS
+ CHARACTER*2 ICH
+* .. Local Arrays ..
+ DOUBLE PRECISION W( 2 )
+ LOGICAL ISAME( 13 )
+* .. External Functions ..
+ LOGICAL LDE, LDERES
+ EXTERNAL LDE, LDERES
+* .. External Subroutines ..
+ EXTERNAL DMAKE, DMVCH, DSPR2, DSYR2
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX
+* .. Scalars in Common ..
+ INTEGER INFOT, NOUTC
+ LOGICAL LERR, OK
+* .. Common blocks ..
+ COMMON /INFOC/INFOT, NOUTC, OK, LERR
+* .. Data statements ..
+ DATA ICH/'UL'/
+* .. Executable Statements ..
+ FULL = SNAME( 3: 3 ).EQ.'Y'
+ PACKED = SNAME( 3: 3 ).EQ.'P'
+* Define the number of arguments.
+ IF( FULL )THEN
+ NARGS = 9
+ ELSE IF( PACKED )THEN
+ NARGS = 8
+ END IF
+*
+ NC = 0
+ RESET = .TRUE.
+ ERRMAX = ZERO
+*
+ DO 140 IN = 1, NIDIM
+ N = IDIM( IN )
+* Set LDA to 1 more than minimum value if room.
+ LDA = N
+ IF( LDA.LT.NMAX )
+ $ LDA = LDA + 1
+* Skip tests if not enough room.
+ IF( LDA.GT.NMAX )
+ $ GO TO 140
+ IF( PACKED )THEN
+ LAA = ( N*( N + 1 ) )/2
+ ELSE
+ LAA = LDA*N
+ END IF
+*
+ DO 130 IC = 1, 2
+ UPLO = ICH( IC: IC )
+ UPPER = UPLO.EQ.'U'
+*
+ DO 120 IX = 1, NINC
+ INCX = INC( IX )
+ LX = ABS( INCX )*N
+*
+* Generate the vector X.
+*
+ TRANSL = HALF
+ CALL DMAKE( 'GE', ' ', ' ', 1, N, X, 1, XX, ABS( INCX ),
+ $ 0, N - 1, RESET, TRANSL )
+ IF( N.GT.1 )THEN
+ X( N/2 ) = ZERO
+ XX( 1 + ABS( INCX )*( N/2 - 1 ) ) = ZERO
+ END IF
+*
+ DO 110 IY = 1, NINC
+ INCY = INC( IY )
+ LY = ABS( INCY )*N
+*
+* Generate the vector Y.
+*
+ TRANSL = ZERO
+ CALL DMAKE( 'GE', ' ', ' ', 1, N, Y, 1, YY,
+ $ ABS( INCY ), 0, N - 1, RESET, TRANSL )
+ IF( N.GT.1 )THEN
+ Y( N/2 ) = ZERO
+ YY( 1 + ABS( INCY )*( N/2 - 1 ) ) = ZERO
+ END IF
+*
+ DO 100 IA = 1, NALF
+ ALPHA = ALF( IA )
+ NULL = N.LE.0.OR.ALPHA.EQ.ZERO
+*
+* Generate the matrix A.
+*
+ TRANSL = ZERO
+ CALL DMAKE( SNAME( 2: 3 ), UPLO, ' ', N, N, A,
+ $ NMAX, AA, LDA, N - 1, N - 1, RESET,
+ $ TRANSL )
+*
+ NC = NC + 1
+*
+* Save every datum before calling the subroutine.
+*
+ UPLOS = UPLO
+ NS = N
+ ALS = ALPHA
+ DO 10 I = 1, LAA
+ AS( I ) = AA( I )
+ 10 CONTINUE
+ LDAS = LDA
+ DO 20 I = 1, LX
+ XS( I ) = XX( I )
+ 20 CONTINUE
+ INCXS = INCX
+ DO 30 I = 1, LY
+ YS( I ) = YY( I )
+ 30 CONTINUE
+ INCYS = INCY
+*
+* Call the subroutine.
+*
+ IF( FULL )THEN
+ IF( TRACE )
+ $ WRITE( NTRA, FMT = 9993 )NC, SNAME, UPLO, N,
+ $ ALPHA, INCX, INCY, LDA
+ IF( REWI )
+ $ REWIND NTRA
+ CALL DSYR2( UPLO, N, ALPHA, XX, INCX, YY, INCY,
+ $ AA, LDA )
+ ELSE IF( PACKED )THEN
+ IF( TRACE )
+ $ WRITE( NTRA, FMT = 9994 )NC, SNAME, UPLO, N,
+ $ ALPHA, INCX, INCY
+ IF( REWI )
+ $ REWIND NTRA
+ CALL DSPR2( UPLO, N, ALPHA, XX, INCX, YY, INCY,
+ $ AA )
+ END IF
+*
+* Check if error-exit was taken incorrectly.
+*
+ IF( .NOT.OK )THEN
+ WRITE( NOUT, FMT = 9992 )
+ FATAL = .TRUE.
+ GO TO 160
+ END IF
+*
+* See what data changed inside subroutines.
+*
+ ISAME( 1 ) = UPLO.EQ.UPLOS
+ ISAME( 2 ) = NS.EQ.N
+ ISAME( 3 ) = ALS.EQ.ALPHA
+ ISAME( 4 ) = LDE( XS, XX, LX )
+ ISAME( 5 ) = INCXS.EQ.INCX
+ ISAME( 6 ) = LDE( YS, YY, LY )
+ ISAME( 7 ) = INCYS.EQ.INCY
+ IF( NULL )THEN
+ ISAME( 8 ) = LDE( AS, AA, LAA )
+ ELSE
+ ISAME( 8 ) = LDERES( SNAME( 2: 3 ), UPLO, N, N,
+ $ AS, AA, LDA )
+ END IF
+ IF( .NOT.PACKED )THEN
+ ISAME( 9 ) = LDAS.EQ.LDA
+ END IF
+*
+* If data was incorrectly changed, report and return.
+*
+ SAME = .TRUE.
+ DO 40 I = 1, NARGS
+ SAME = SAME.AND.ISAME( I )
+ IF( .NOT.ISAME( I ) )
+ $ WRITE( NOUT, FMT = 9998 )I
+ 40 CONTINUE
+ IF( .NOT.SAME )THEN
+ FATAL = .TRUE.
+ GO TO 160
+ END IF
+*
+ IF( .NOT.NULL )THEN
+*
+* Check the result column by column.
+*
+ IF( INCX.GT.0 )THEN
+ DO 50 I = 1, N
+ Z( I, 1 ) = X( I )
+ 50 CONTINUE
+ ELSE
+ DO 60 I = 1, N
+ Z( I, 1 ) = X( N - I + 1 )
+ 60 CONTINUE
+ END IF
+ IF( INCY.GT.0 )THEN
+ DO 70 I = 1, N
+ Z( I, 2 ) = Y( I )
+ 70 CONTINUE
+ ELSE
+ DO 80 I = 1, N
+ Z( I, 2 ) = Y( N - I + 1 )
+ 80 CONTINUE
+ END IF
+ JA = 1
+ DO 90 J = 1, N
+ W( 1 ) = Z( J, 2 )
+ W( 2 ) = Z( J, 1 )
+ IF( UPPER )THEN
+ JJ = 1
+ LJ = J
+ ELSE
+ JJ = J
+ LJ = N - J + 1
+ END IF
+ CALL DMVCH( 'N', LJ, 2, ALPHA, Z( JJ, 1 ),
+ $ NMAX, W, 1, ONE, A( JJ, J ), 1,
+ $ YT, G, AA( JA ), EPS, ERR, FATAL,
+ $ NOUT, .TRUE. )
+ IF( FULL )THEN
+ IF( UPPER )THEN
+ JA = JA + LDA
+ ELSE
+ JA = JA + LDA + 1
+ END IF
+ ELSE
+ JA = JA + LJ
+ END IF
+ ERRMAX = MAX( ERRMAX, ERR )
+* If got really bad answer, report and return.
+ IF( FATAL )
+ $ GO TO 150
+ 90 CONTINUE
+ ELSE
+* Avoid repeating tests with N.le.0.
+ IF( N.LE.0 )
+ $ GO TO 140
+ END IF
+*
+ 100 CONTINUE
+*
+ 110 CONTINUE
+*
+ 120 CONTINUE
+*
+ 130 CONTINUE
+*
+ 140 CONTINUE
+*
+* Report result.
+*
+ IF( ERRMAX.LT.THRESH )THEN
+ WRITE( NOUT, FMT = 9999 )SNAME, NC
+ ELSE
+ WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX
+ END IF
+ GO TO 170
+*
+ 150 CONTINUE
+ WRITE( NOUT, FMT = 9995 )J
+*
+ 160 CONTINUE
+ WRITE( NOUT, FMT = 9996 )SNAME
+ IF( FULL )THEN
+ WRITE( NOUT, FMT = 9993 )NC, SNAME, UPLO, N, ALPHA, INCX,
+ $ INCY, LDA
+ ELSE IF( PACKED )THEN
+ WRITE( NOUT, FMT = 9994 )NC, SNAME, UPLO, N, ALPHA, INCX, INCY
+ END IF
+*
+ 170 CONTINUE
+ RETURN
+*
+ 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL',
+ $ 'S)' )
+ 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
+ $ 'ANGED INCORRECTLY *******' )
+ 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C',
+ $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2,
+ $ ' - SUSPECT *******' )
+ 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' )
+ 9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 )
+ 9994 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', I3, ',', F4.1, ', X,',
+ $ I2, ', Y,', I2, ', AP) .' )
+ 9993 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',', I3, ',', F4.1, ', X,',
+ $ I2, ', Y,', I2, ', A,', I3, ') .' )
+ 9992 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
+ $ '******' )
+*
+* End of DCHK6.
+*
+ END
+ SUBROUTINE DCHKE( ISNUM, SRNAMT, NOUT )
+*
+* Tests the error exits from the Level 2 Blas.
+* Requires a special version of the error-handling routine XERBLA.
+* ALPHA, BETA, A, X and Y should not need to be defined.
+*
+* Auxiliary routine for test program for Level 2 Blas.
+*
+* -- Written on 10-August-1987.
+* Richard Hanson, Sandia National Labs.
+* Jeremy Du Croz, NAG Central Office.
+*
+* .. Scalar Arguments ..
+ INTEGER ISNUM, NOUT
+ CHARACTER*6 SRNAMT
+* .. Scalars in Common ..
+ INTEGER INFOT, NOUTC
+ LOGICAL LERR, OK
+* .. Local Scalars ..
+ DOUBLE PRECISION ALPHA, BETA
+* .. Local Arrays ..
+ DOUBLE PRECISION A( 1, 1 ), X( 1 ), Y( 1 )
+* .. External Subroutines ..
+ EXTERNAL CHKXER, DGBMV, DGEMV, DGER, DSBMV, DSPMV, DSPR,
+ $ DSPR2, DSYMV, DSYR, DSYR2, DTBMV, DTBSV, DTPMV,
+ $ DTPSV, DTRMV, DTRSV
+* .. Common blocks ..
+ COMMON /INFOC/INFOT, NOUTC, OK, LERR
+* .. Executable Statements ..
+* OK is set to .FALSE. by the special version of XERBLA or by CHKXER
+* if anything is wrong.
+ OK = .TRUE.
+* LERR is set to .TRUE. by the special version of XERBLA each time
+* it is called, and is then tested and re-set by CHKXER.
+ LERR = .FALSE.
+ GO TO ( 10, 20, 30, 40, 50, 60, 70, 80,
+ $ 90, 100, 110, 120, 130, 140, 150,
+ $ 160 )ISNUM
+ 10 INFOT = 1
+ CALL DGEMV( '/', 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL DGEMV( 'N', -1, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL DGEMV( 'N', 0, -1, ALPHA, A, 1, X, 1, BETA, Y, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 6
+ CALL DGEMV( 'N', 2, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 8
+ CALL DGEMV( 'N', 0, 0, ALPHA, A, 1, X, 0, BETA, Y, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 11
+ CALL DGEMV( 'N', 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 0 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ GO TO 170
+ 20 INFOT = 1
+ CALL DGBMV( '/', 0, 0, 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL DGBMV( 'N', -1, 0, 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL DGBMV( 'N', 0, -1, 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL DGBMV( 'N', 0, 0, -1, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 5
+ CALL DGBMV( 'N', 2, 0, 0, -1, ALPHA, A, 1, X, 1, BETA, Y, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 8
+ CALL DGBMV( 'N', 0, 0, 1, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 10
+ CALL DGBMV( 'N', 0, 0, 0, 0, ALPHA, A, 1, X, 0, BETA, Y, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 13
+ CALL DGBMV( 'N', 0, 0, 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 0 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ GO TO 170
+ 30 INFOT = 1
+ CALL DSYMV( '/', 0, ALPHA, A, 1, X, 1, BETA, Y, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL DSYMV( 'U', -1, ALPHA, A, 1, X, 1, BETA, Y, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 5
+ CALL DSYMV( 'U', 2, ALPHA, A, 1, X, 1, BETA, Y, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 7
+ CALL DSYMV( 'U', 0, ALPHA, A, 1, X, 0, BETA, Y, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 10
+ CALL DSYMV( 'U', 0, ALPHA, A, 1, X, 1, BETA, Y, 0 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ GO TO 170
+ 40 INFOT = 1
+ CALL DSBMV( '/', 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL DSBMV( 'U', -1, 0, ALPHA, A, 1, X, 1, BETA, Y, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL DSBMV( 'U', 0, -1, ALPHA, A, 1, X, 1, BETA, Y, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 6
+ CALL DSBMV( 'U', 0, 1, ALPHA, A, 1, X, 1, BETA, Y, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 8
+ CALL DSBMV( 'U', 0, 0, ALPHA, A, 1, X, 0, BETA, Y, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 11
+ CALL DSBMV( 'U', 0, 0, ALPHA, A, 1, X, 1, BETA, Y, 0 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ GO TO 170
+ 50 INFOT = 1
+ CALL DSPMV( '/', 0, ALPHA, A, X, 1, BETA, Y, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL DSPMV( 'U', -1, ALPHA, A, X, 1, BETA, Y, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 6
+ CALL DSPMV( 'U', 0, ALPHA, A, X, 0, BETA, Y, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 9
+ CALL DSPMV( 'U', 0, ALPHA, A, X, 1, BETA, Y, 0 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ GO TO 170
+ 60 INFOT = 1
+ CALL DTRMV( '/', 'N', 'N', 0, A, 1, X, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL DTRMV( 'U', '/', 'N', 0, A, 1, X, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL DTRMV( 'U', 'N', '/', 0, A, 1, X, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL DTRMV( 'U', 'N', 'N', -1, A, 1, X, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 6
+ CALL DTRMV( 'U', 'N', 'N', 2, A, 1, X, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 8
+ CALL DTRMV( 'U', 'N', 'N', 0, A, 1, X, 0 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ GO TO 170
+ 70 INFOT = 1
+ CALL DTBMV( '/', 'N', 'N', 0, 0, A, 1, X, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL DTBMV( 'U', '/', 'N', 0, 0, A, 1, X, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL DTBMV( 'U', 'N', '/', 0, 0, A, 1, X, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL DTBMV( 'U', 'N', 'N', -1, 0, A, 1, X, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 5
+ CALL DTBMV( 'U', 'N', 'N', 0, -1, A, 1, X, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 7
+ CALL DTBMV( 'U', 'N', 'N', 0, 1, A, 1, X, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 9
+ CALL DTBMV( 'U', 'N', 'N', 0, 0, A, 1, X, 0 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ GO TO 170
+ 80 INFOT = 1
+ CALL DTPMV( '/', 'N', 'N', 0, A, X, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL DTPMV( 'U', '/', 'N', 0, A, X, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL DTPMV( 'U', 'N', '/', 0, A, X, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL DTPMV( 'U', 'N', 'N', -1, A, X, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 7
+ CALL DTPMV( 'U', 'N', 'N', 0, A, X, 0 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ GO TO 170
+ 90 INFOT = 1
+ CALL DTRSV( '/', 'N', 'N', 0, A, 1, X, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL DTRSV( 'U', '/', 'N', 0, A, 1, X, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL DTRSV( 'U', 'N', '/', 0, A, 1, X, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL DTRSV( 'U', 'N', 'N', -1, A, 1, X, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 6
+ CALL DTRSV( 'U', 'N', 'N', 2, A, 1, X, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 8
+ CALL DTRSV( 'U', 'N', 'N', 0, A, 1, X, 0 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ GO TO 170
+ 100 INFOT = 1
+ CALL DTBSV( '/', 'N', 'N', 0, 0, A, 1, X, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL DTBSV( 'U', '/', 'N', 0, 0, A, 1, X, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL DTBSV( 'U', 'N', '/', 0, 0, A, 1, X, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL DTBSV( 'U', 'N', 'N', -1, 0, A, 1, X, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 5
+ CALL DTBSV( 'U', 'N', 'N', 0, -1, A, 1, X, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 7
+ CALL DTBSV( 'U', 'N', 'N', 0, 1, A, 1, X, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 9
+ CALL DTBSV( 'U', 'N', 'N', 0, 0, A, 1, X, 0 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ GO TO 170
+ 110 INFOT = 1
+ CALL DTPSV( '/', 'N', 'N', 0, A, X, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL DTPSV( 'U', '/', 'N', 0, A, X, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL DTPSV( 'U', 'N', '/', 0, A, X, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL DTPSV( 'U', 'N', 'N', -1, A, X, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 7
+ CALL DTPSV( 'U', 'N', 'N', 0, A, X, 0 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ GO TO 170
+ 120 INFOT = 1
+ CALL DGER( -1, 0, ALPHA, X, 1, Y, 1, A, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL DGER( 0, -1, ALPHA, X, 1, Y, 1, A, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 5
+ CALL DGER( 0, 0, ALPHA, X, 0, Y, 1, A, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 7
+ CALL DGER( 0, 0, ALPHA, X, 1, Y, 0, A, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 9
+ CALL DGER( 2, 0, ALPHA, X, 1, Y, 1, A, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ GO TO 170
+ 130 INFOT = 1
+ CALL DSYR( '/', 0, ALPHA, X, 1, A, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL DSYR( 'U', -1, ALPHA, X, 1, A, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 5
+ CALL DSYR( 'U', 0, ALPHA, X, 0, A, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 7
+ CALL DSYR( 'U', 2, ALPHA, X, 1, A, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ GO TO 170
+ 140 INFOT = 1
+ CALL DSPR( '/', 0, ALPHA, X, 1, A )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL DSPR( 'U', -1, ALPHA, X, 1, A )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 5
+ CALL DSPR( 'U', 0, ALPHA, X, 0, A )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ GO TO 170
+ 150 INFOT = 1
+ CALL DSYR2( '/', 0, ALPHA, X, 1, Y, 1, A, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL DSYR2( 'U', -1, ALPHA, X, 1, Y, 1, A, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 5
+ CALL DSYR2( 'U', 0, ALPHA, X, 0, Y, 1, A, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 7
+ CALL DSYR2( 'U', 0, ALPHA, X, 1, Y, 0, A, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 9
+ CALL DSYR2( 'U', 2, ALPHA, X, 1, Y, 1, A, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ GO TO 170
+ 160 INFOT = 1
+ CALL DSPR2( '/', 0, ALPHA, X, 1, Y, 1, A )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL DSPR2( 'U', -1, ALPHA, X, 1, Y, 1, A )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 5
+ CALL DSPR2( 'U', 0, ALPHA, X, 0, Y, 1, A )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 7
+ CALL DSPR2( 'U', 0, ALPHA, X, 1, Y, 0, A )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+*
+ 170 IF( OK )THEN
+ WRITE( NOUT, FMT = 9999 )SRNAMT
+ ELSE
+ WRITE( NOUT, FMT = 9998 )SRNAMT
+ END IF
+ RETURN
+*
+ 9999 FORMAT( ' ', A6, ' PASSED THE TESTS OF ERROR-EXITS' )
+ 9998 FORMAT( ' ******* ', A6, ' FAILED THE TESTS OF ERROR-EXITS *****',
+ $ '**' )
+*
+* End of DCHKE.
+*
+ END
+ SUBROUTINE DMAKE( TYPE, UPLO, DIAG, M, N, A, NMAX, AA, LDA, KL,
+ $ KU, RESET, TRANSL )
+*
+* Generates values for an M by N matrix A within the bandwidth
+* defined by KL and KU.
+* Stores the values in the array AA in the data structure required
+* by the routine, with unwanted elements set to rogue value.
+*
+* TYPE is 'GE', 'GB', 'SY', 'SB', 'SP', 'TR', 'TB' OR 'TP'.
+*
+* Auxiliary routine for test program for Level 2 Blas.
+*
+* -- Written on 10-August-1987.
+* Richard Hanson, Sandia National Labs.
+* Jeremy Du Croz, NAG Central Office.
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
+ DOUBLE PRECISION ROGUE
+ PARAMETER ( ROGUE = -1.0D10 )
+* .. Scalar Arguments ..
+ DOUBLE PRECISION TRANSL
+ INTEGER KL, KU, LDA, M, N, NMAX
+ LOGICAL RESET
+ CHARACTER*1 DIAG, UPLO
+ CHARACTER*2 TYPE
+* .. Array Arguments ..
+ DOUBLE PRECISION A( NMAX, * ), AA( * )
+* .. Local Scalars ..
+ INTEGER I, I1, I2, I3, IBEG, IEND, IOFF, J, KK
+ LOGICAL GEN, LOWER, SYM, TRI, UNIT, UPPER
+* .. External Functions ..
+ DOUBLE PRECISION DBEG
+ EXTERNAL DBEG
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN
+* .. Executable Statements ..
+ GEN = TYPE( 1: 1 ).EQ.'G'
+ SYM = TYPE( 1: 1 ).EQ.'S'
+ TRI = TYPE( 1: 1 ).EQ.'T'
+ UPPER = ( SYM.OR.TRI ).AND.UPLO.EQ.'U'
+ LOWER = ( SYM.OR.TRI ).AND.UPLO.EQ.'L'
+ UNIT = TRI.AND.DIAG.EQ.'U'
+*
+* Generate data in array A.
+*
+ DO 20 J = 1, N
+ DO 10 I = 1, M
+ IF( GEN.OR.( UPPER.AND.I.LE.J ).OR.( LOWER.AND.I.GE.J ) )
+ $ THEN
+ IF( ( I.LE.J.AND.J - I.LE.KU ).OR.
+ $ ( I.GE.J.AND.I - J.LE.KL ) )THEN
+ A( I, J ) = DBEG( RESET ) + TRANSL
+ ELSE
+ A( I, J ) = ZERO
+ END IF
+ IF( I.NE.J )THEN
+ IF( SYM )THEN
+ A( J, I ) = A( I, J )
+ ELSE IF( TRI )THEN
+ A( J, I ) = ZERO
+ END IF
+ END IF
+ END IF
+ 10 CONTINUE
+ IF( TRI )
+ $ A( J, J ) = A( J, J ) + ONE
+ IF( UNIT )
+ $ A( J, J ) = ONE
+ 20 CONTINUE
+*
+* Store elements in array AS in data structure required by routine.
+*
+ IF( TYPE.EQ.'GE' )THEN
+ DO 50 J = 1, N
+ DO 30 I = 1, M
+ AA( I + ( J - 1 )*LDA ) = A( I, J )
+ 30 CONTINUE
+ DO 40 I = M + 1, LDA
+ AA( I + ( J - 1 )*LDA ) = ROGUE
+ 40 CONTINUE
+ 50 CONTINUE
+ ELSE IF( TYPE.EQ.'GB' )THEN
+ DO 90 J = 1, N
+ DO 60 I1 = 1, KU + 1 - J
+ AA( I1 + ( J - 1 )*LDA ) = ROGUE
+ 60 CONTINUE
+ DO 70 I2 = I1, MIN( KL + KU + 1, KU + 1 + M - J )
+ AA( I2 + ( J - 1 )*LDA ) = A( I2 + J - KU - 1, J )
+ 70 CONTINUE
+ DO 80 I3 = I2, LDA
+ AA( I3 + ( J - 1 )*LDA ) = ROGUE
+ 80 CONTINUE
+ 90 CONTINUE
+ ELSE IF( TYPE.EQ.'SY'.OR.TYPE.EQ.'TR' )THEN
+ DO 130 J = 1, N
+ IF( UPPER )THEN
+ IBEG = 1
+ IF( UNIT )THEN
+ IEND = J - 1
+ ELSE
+ IEND = J
+ END IF
+ ELSE
+ IF( UNIT )THEN
+ IBEG = J + 1
+ ELSE
+ IBEG = J
+ END IF
+ IEND = N
+ END IF
+ DO 100 I = 1, IBEG - 1
+ AA( I + ( J - 1 )*LDA ) = ROGUE
+ 100 CONTINUE
+ DO 110 I = IBEG, IEND
+ AA( I + ( J - 1 )*LDA ) = A( I, J )
+ 110 CONTINUE
+ DO 120 I = IEND + 1, LDA
+ AA( I + ( J - 1 )*LDA ) = ROGUE
+ 120 CONTINUE
+ 130 CONTINUE
+ ELSE IF( TYPE.EQ.'SB'.OR.TYPE.EQ.'TB' )THEN
+ DO 170 J = 1, N
+ IF( UPPER )THEN
+ KK = KL + 1
+ IBEG = MAX( 1, KL + 2 - J )
+ IF( UNIT )THEN
+ IEND = KL
+ ELSE
+ IEND = KL + 1
+ END IF
+ ELSE
+ KK = 1
+ IF( UNIT )THEN
+ IBEG = 2
+ ELSE
+ IBEG = 1
+ END IF
+ IEND = MIN( KL + 1, 1 + M - J )
+ END IF
+ DO 140 I = 1, IBEG - 1
+ AA( I + ( J - 1 )*LDA ) = ROGUE
+ 140 CONTINUE
+ DO 150 I = IBEG, IEND
+ AA( I + ( J - 1 )*LDA ) = A( I + J - KK, J )
+ 150 CONTINUE
+ DO 160 I = IEND + 1, LDA
+ AA( I + ( J - 1 )*LDA ) = ROGUE
+ 160 CONTINUE
+ 170 CONTINUE
+ ELSE IF( TYPE.EQ.'SP'.OR.TYPE.EQ.'TP' )THEN
+ IOFF = 0
+ DO 190 J = 1, N
+ IF( UPPER )THEN
+ IBEG = 1
+ IEND = J
+ ELSE
+ IBEG = J
+ IEND = N
+ END IF
+ DO 180 I = IBEG, IEND
+ IOFF = IOFF + 1
+ AA( IOFF ) = A( I, J )
+ IF( I.EQ.J )THEN
+ IF( UNIT )
+ $ AA( IOFF ) = ROGUE
+ END IF
+ 180 CONTINUE
+ 190 CONTINUE
+ END IF
+ RETURN
+*
+* End of DMAKE.
+*
+ END
+ SUBROUTINE DMVCH( TRANS, M, N, ALPHA, A, NMAX, X, INCX, BETA, Y,
+ $ INCY, YT, G, YY, EPS, ERR, FATAL, NOUT, MV )
+*
+* Checks the results of the computational tests.
+*
+* Auxiliary routine for test program for Level 2 Blas.
+*
+* -- Written on 10-August-1987.
+* Richard Hanson, Sandia National Labs.
+* Jeremy Du Croz, NAG Central Office.
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
+* .. Scalar Arguments ..
+ DOUBLE PRECISION ALPHA, BETA, EPS, ERR
+ INTEGER INCX, INCY, M, N, NMAX, NOUT
+ LOGICAL FATAL, MV
+ CHARACTER*1 TRANS
+* .. Array Arguments ..
+ DOUBLE PRECISION A( NMAX, * ), G( * ), X( * ), Y( * ), YT( * ),
+ $ YY( * )
+* .. Local Scalars ..
+ DOUBLE PRECISION ERRI
+ INTEGER I, INCXL, INCYL, IY, J, JX, KX, KY, ML, NL
+ LOGICAL TRAN
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, SQRT
+* .. Executable Statements ..
+ TRAN = TRANS.EQ.'T'.OR.TRANS.EQ.'C'
+ IF( TRAN )THEN
+ ML = N
+ NL = M
+ ELSE
+ ML = M
+ NL = N
+ END IF
+ IF( INCX.LT.0 )THEN
+ KX = NL
+ INCXL = -1
+ ELSE
+ KX = 1
+ INCXL = 1
+ END IF
+ IF( INCY.LT.0 )THEN
+ KY = ML
+ INCYL = -1
+ ELSE
+ KY = 1
+ INCYL = 1
+ END IF
+*
+* Compute expected result in YT using data in A, X and Y.
+* Compute gauges in G.
+*
+ IY = KY
+ DO 30 I = 1, ML
+ YT( IY ) = ZERO
+ G( IY ) = ZERO
+ JX = KX
+ IF( TRAN )THEN
+ DO 10 J = 1, NL
+ YT( IY ) = YT( IY ) + A( J, I )*X( JX )
+ G( IY ) = G( IY ) + ABS( A( J, I )*X( JX ) )
+ JX = JX + INCXL
+ 10 CONTINUE
+ ELSE
+ DO 20 J = 1, NL
+ YT( IY ) = YT( IY ) + A( I, J )*X( JX )
+ G( IY ) = G( IY ) + ABS( A( I, J )*X( JX ) )
+ JX = JX + INCXL
+ 20 CONTINUE
+ END IF
+ YT( IY ) = ALPHA*YT( IY ) + BETA*Y( IY )
+ G( IY ) = ABS( ALPHA )*G( IY ) + ABS( BETA*Y( IY ) )
+ IY = IY + INCYL
+ 30 CONTINUE
+*
+* Compute the error ratio for this result.
+*
+ ERR = ZERO
+ DO 40 I = 1, ML
+ ERRI = ABS( YT( I ) - YY( 1 + ( I - 1 )*ABS( INCY ) ) )/EPS
+ IF( G( I ).NE.ZERO )
+ $ ERRI = ERRI/G( I )
+ ERR = MAX( ERR, ERRI )
+ IF( ERR*SQRT( EPS ).GE.ONE )
+ $ GO TO 50
+ 40 CONTINUE
+* If the loop completes, all results are at least half accurate.
+ GO TO 70
+*
+* Report fatal error.
+*
+ 50 FATAL = .TRUE.
+ WRITE( NOUT, FMT = 9999 )
+ DO 60 I = 1, ML
+ IF( MV )THEN
+ WRITE( NOUT, FMT = 9998 )I, YT( I ),
+ $ YY( 1 + ( I - 1 )*ABS( INCY ) )
+ ELSE
+ WRITE( NOUT, FMT = 9998 )I,
+ $ YY( 1 + ( I - 1 )*ABS( INCY ) ), YT( I )
+ END IF
+ 60 CONTINUE
+*
+ 70 CONTINUE
+ RETURN
+*
+ 9999 FORMAT( ' ******* FATAL ERROR - COMPUTED RESULT IS LESS THAN HAL',
+ $ 'F ACCURATE *******', /' EXPECTED RESULT COMPU',
+ $ 'TED RESULT' )
+ 9998 FORMAT( 1X, I7, 2G18.6 )
+*
+* End of DMVCH.
+*
+ END
+ LOGICAL FUNCTION LDE( RI, RJ, LR )
+*
+* Tests if two arrays are identical.
+*
+* Auxiliary routine for test program for Level 2 Blas.
+*
+* -- Written on 10-August-1987.
+* Richard Hanson, Sandia National Labs.
+* Jeremy Du Croz, NAG Central Office.
+*
+* .. Scalar Arguments ..
+ INTEGER LR
+* .. Array Arguments ..
+ DOUBLE PRECISION RI( * ), RJ( * )
+* .. Local Scalars ..
+ INTEGER I
+* .. Executable Statements ..
+ DO 10 I = 1, LR
+ IF( RI( I ).NE.RJ( I ) )
+ $ GO TO 20
+ 10 CONTINUE
+ LDE = .TRUE.
+ GO TO 30
+ 20 CONTINUE
+ LDE = .FALSE.
+ 30 RETURN
+*
+* End of LDE.
+*
+ END
+ LOGICAL FUNCTION LDERES( TYPE, UPLO, M, N, AA, AS, LDA )
+*
+* Tests if selected elements in two arrays are equal.
+*
+* TYPE is 'GE', 'SY' or 'SP'.
+*
+* Auxiliary routine for test program for Level 2 Blas.
+*
+* -- Written on 10-August-1987.
+* Richard Hanson, Sandia National Labs.
+* Jeremy Du Croz, NAG Central Office.
+*
+* .. Scalar Arguments ..
+ INTEGER LDA, M, N
+ CHARACTER*1 UPLO
+ CHARACTER*2 TYPE
+* .. Array Arguments ..
+ DOUBLE PRECISION AA( LDA, * ), AS( LDA, * )
+* .. Local Scalars ..
+ INTEGER I, IBEG, IEND, J
+ LOGICAL UPPER
+* .. Executable Statements ..
+ UPPER = UPLO.EQ.'U'
+ IF( TYPE.EQ.'GE' )THEN
+ DO 20 J = 1, N
+ DO 10 I = M + 1, LDA
+ IF( AA( I, J ).NE.AS( I, J ) )
+ $ GO TO 70
+ 10 CONTINUE
+ 20 CONTINUE
+ ELSE IF( TYPE.EQ.'SY' )THEN
+ DO 50 J = 1, N
+ IF( UPPER )THEN
+ IBEG = 1
+ IEND = J
+ ELSE
+ IBEG = J
+ IEND = N
+ END IF
+ DO 30 I = 1, IBEG - 1
+ IF( AA( I, J ).NE.AS( I, J ) )
+ $ GO TO 70
+ 30 CONTINUE
+ DO 40 I = IEND + 1, LDA
+ IF( AA( I, J ).NE.AS( I, J ) )
+ $ GO TO 70
+ 40 CONTINUE
+ 50 CONTINUE
+ END IF
+*
+ 60 CONTINUE
+ LDERES = .TRUE.
+ GO TO 80
+ 70 CONTINUE
+ LDERES = .FALSE.
+ 80 RETURN
+*
+* End of LDERES.
+*
+ END
+ DOUBLE PRECISION FUNCTION DBEG( RESET )
+*
+* Generates random numbers uniformly distributed between -0.5 and 0.5.
+*
+* Auxiliary routine for test program for Level 2 Blas.
+*
+* -- Written on 10-August-1987.
+* Richard Hanson, Sandia National Labs.
+* Jeremy Du Croz, NAG Central Office.
+*
+* .. Scalar Arguments ..
+ LOGICAL RESET
+* .. Local Scalars ..
+ INTEGER I, IC, MI
+* .. Save statement ..
+ SAVE I, IC, MI
+* .. Intrinsic Functions ..
+ INTRINSIC DBLE
+* .. Executable Statements ..
+ IF( RESET )THEN
+* Initialize local variables.
+ MI = 891
+ I = 7
+ IC = 0
+ RESET = .FALSE.
+ END IF
+*
+* The sequence of values of I is bounded between 1 and 999.
+* If initial I = 1,2,3,6,7 or 9, the period will be 50.
+* If initial I = 4 or 8, the period will be 25.
+* If initial I = 5, the period will be 10.
+* IC is used to break up the period by skipping 1 value of I in 6.
+*
+ IC = IC + 1
+ 10 I = I*MI
+ I = I - 1000*( I/1000 )
+ IF( IC.GE.5 )THEN
+ IC = 0
+ GO TO 10
+ END IF
+ DBEG = DBLE( I - 500 )/1001.0D0
+ RETURN
+*
+* End of DBEG.
+*
+ END
+ DOUBLE PRECISION FUNCTION DDIFF( X, Y )
+*
+* Auxiliary routine for test program for Level 2 Blas.
+*
+* -- Written on 10-August-1987.
+* Richard Hanson, Sandia National Labs.
+*
+* .. Scalar Arguments ..
+ DOUBLE PRECISION X, Y
+* .. Executable Statements ..
+ DDIFF = X - Y
+ RETURN
+*
+* End of DDIFF.
+*
+ END
+ SUBROUTINE CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+*
+* Tests whether XERBLA has detected an error when it should.
+*
+* Auxiliary routine for test program for Level 2 Blas.
+*
+* -- Written on 10-August-1987.
+* Richard Hanson, Sandia National Labs.
+* Jeremy Du Croz, NAG Central Office.
+*
+* .. Scalar Arguments ..
+ INTEGER INFOT, NOUT
+ LOGICAL LERR, OK
+ CHARACTER*6 SRNAMT
+* .. Executable Statements ..
+ IF( .NOT.LERR )THEN
+ WRITE( NOUT, FMT = 9999 )INFOT, SRNAMT
+ OK = .FALSE.
+ END IF
+ LERR = .FALSE.
+ RETURN
+*
+ 9999 FORMAT( ' ***** ILLEGAL VALUE OF PARAMETER NUMBER ', I2, ' NOT D',
+ $ 'ETECTED BY ', A6, ' *****' )
+*
+* End of CHKXER.
+*
+ END
diff --git a/jlapack-3.1.1/src/testing/blas2/dblat2.in b/jlapack-3.1.1/src/testing/blas2/dblat2.in
new file mode 100644
index 0000000..d436350
--- /dev/null
+++ b/jlapack-3.1.1/src/testing/blas2/dblat2.in
@@ -0,0 +1,34 @@
+'dblat2.out' NAME OF SUMMARY OUTPUT FILE
+6 UNIT NUMBER OF SUMMARY FILE
+'DBLAT2.SNAP' NAME OF SNAPSHOT OUTPUT FILE
+-1 UNIT NUMBER OF SNAPSHOT FILE (NOT USED IF .LT. 0)
+F LOGICAL FLAG, T TO REWIND SNAPSHOT FILE AFTER EACH RECORD.
+F LOGICAL FLAG, T TO STOP ON FAILURES.
+T LOGICAL FLAG, T TO TEST ERROR EXITS.
+16.0 THRESHOLD VALUE OF TEST RATIO
+6 NUMBER OF VALUES OF N
+0 1 2 3 5 9 VALUES OF N
+4 NUMBER OF VALUES OF K
+0 1 2 4 VALUES OF K
+4 NUMBER OF VALUES OF INCX AND INCY
+1 2 -1 -2 VALUES OF INCX AND INCY
+3 NUMBER OF VALUES OF ALPHA
+0.0 1.0 0.7 VALUES OF ALPHA
+3 NUMBER OF VALUES OF BETA
+0.0 1.0 0.9 VALUES OF BETA
+DGEMV T PUT F FOR NO TEST. SAME COLUMNS.
+DGBMV T PUT F FOR NO TEST. SAME COLUMNS.
+DSYMV T PUT F FOR NO TEST. SAME COLUMNS.
+DSBMV T PUT F FOR NO TEST. SAME COLUMNS.
+DSPMV T PUT F FOR NO TEST. SAME COLUMNS.
+DTRMV T PUT F FOR NO TEST. SAME COLUMNS.
+DTBMV T PUT F FOR NO TEST. SAME COLUMNS.
+DTPMV T PUT F FOR NO TEST. SAME COLUMNS.
+DTRSV T PUT F FOR NO TEST. SAME COLUMNS.
+DTBSV T PUT F FOR NO TEST. SAME COLUMNS.
+DTPSV T PUT F FOR NO TEST. SAME COLUMNS.
+DGER T PUT F FOR NO TEST. SAME COLUMNS.
+DSYR T PUT F FOR NO TEST. SAME COLUMNS.
+DSPR T PUT F FOR NO TEST. SAME COLUMNS.
+DSYR2 T PUT F FOR NO TEST. SAME COLUMNS.
+DSPR2 T PUT F FOR NO TEST. SAME COLUMNS.
diff --git a/jlapack-3.1.1/src/testing/blas2/xerbla.f b/jlapack-3.1.1/src/testing/blas2/xerbla.f
new file mode 100644
index 0000000..40ac23f
--- /dev/null
+++ b/jlapack-3.1.1/src/testing/blas2/xerbla.f
@@ -0,0 +1,58 @@
+ SUBROUTINE XERBLA( SRNAME, INFO )
+*
+* f2j NOTE: this is compiled separately from dblat2.f because
+* it needs to be in package org.netlib.err while the rest of
+* dblat2.f routines should be in org.netlib.blas.testing.
+*
+* This is a special version of XERBLA to be used only as part of
+* the test program for testing error exits from the Level 2 BLAS
+* routines.
+*
+* XERBLA is an error handler for the Level 2 BLAS routines.
+*
+* It is called by the Level 2 BLAS routines if an input parameter is
+* invalid.
+*
+* Auxiliary routine for test program for Level 2 Blas.
+*
+* -- Written on 10-August-1987.
+* Richard Hanson, Sandia National Labs.
+* Jeremy Du Croz, NAG Central Office.
+*
+* .. Scalar Arguments ..
+ INTEGER INFO
+ CHARACTER*6 SRNAME
+* .. Scalars in Common ..
+ INTEGER INFOT, NOUT
+ LOGICAL LERR, OK
+ CHARACTER*6 SRNAMT
+* .. Common blocks ..
+ COMMON /INFOC/INFOT, NOUT, OK, LERR
+ COMMON /SRNAMC/SRNAMT
+* .. Executable Statements ..
+ LERR = .TRUE.
+ IF( INFO.NE.INFOT )THEN
+ IF( INFOT.NE.0 )THEN
+ WRITE( NOUT, FMT = 9999 )INFO, INFOT
+ ELSE
+ WRITE( NOUT, FMT = 9997 )INFO
+ END IF
+ OK = .FALSE.
+ END IF
+ IF( SRNAME.NE.SRNAMT )THEN
+ WRITE( NOUT, FMT = 9998 )SRNAME, SRNAMT
+ OK = .FALSE.
+ END IF
+ RETURN
+*
+ 9999 FORMAT( ' ******* XERBLA WAS CALLED WITH INFO = ', I6, ' INSTEAD',
+ $ ' OF ', I2, ' *******' )
+ 9998 FORMAT( ' ******* XERBLA WAS CALLED WITH SRNAME = ', A6, ' INSTE',
+ $ 'AD OF ', A6, ' *******' )
+ 9997 FORMAT( ' ******* XERBLA WAS CALLED WITH INFO = ', I6,
+ $ ' *******' )
+*
+* End of XERBLA
+*
+ END
+
diff --git a/jlapack-3.1.1/src/testing/blas3/Makefile b/jlapack-3.1.1/src/testing/blas3/Makefile
new file mode 100644
index 0000000..77c0bf1
--- /dev/null
+++ b/jlapack-3.1.1/src/testing/blas3/Makefile
@@ -0,0 +1,37 @@
+.SUFFIXES: .f .java
+
+ROOT=../../..
+
+include $(ROOT)/make.def
+
+XERBLAFLAGS= -c .:$(ROOT)/$(BLAS_OBJ) -p $(ERR_PACKAGE)
+F2JFLAGS=-c .:$(ROOT)/$(BLAS_OBJ) -p $(BLASTEST_PACKAGE) -o $(OUTDIR) $(STATIC)
+
+tester: $(ROOT)/$(BLAS_DIR)/$(BLAS_JAR) $(ROOT)/$(BLAS3TEST_IDX) $(ROOT)/$(UTIL_DIR)/$(UTIL_JAR)
+ /bin/rm -f $(BLAS3TEST_JAR)
+ cd $(OUTDIR); $(JAR) cvf ../$(BLAS3TEST_JAR) `find . -name "*.class"`
+ $(JAR) uvf $(BLAS3TEST_JAR) `find org -name "*.class"`
+
+nojar: $(ROOT)/$(BLAS_DIR)/$(BLAS_JAR) $(ROOT)/$(BLAS3TEST_IDX) $(ROOT)/$(UTIL_DIR)/$(UTIL_JAR)
+
+$(ROOT)/$(BLAS3TEST_IDX): dblat3.f
+ $(F2J) $(XERBLAFLAGS) xerbla.f > /dev/null
+ $(F2J) $(F2JFLAGS) $< > /dev/null
+
+$(ROOT)/$(BLAS_DIR)/$(BLAS_JAR):
+ cd $(ROOT)/$(BLAS_DIR); $(MAKE)
+
+$(ROOT)/$(UTIL_DIR)/$(UTIL_JAR):
+ cd $(ROOT)/$(UTIL_DIR); $(MAKE)
+
+runtest: tester
+ $(JAVA) $(JFLAGS) -cp .:$(BLAS3TEST_JAR):$(ROOT)/$(BLAS_DIR)/$(BLAS_JAR):$(ROOT)/$(UTIL_DIR)/$(UTIL_JAR):$(ROOT)/$(ERR_DIR)/$(ERR_JAR) $(BLASTEST_PACKAGE).Dblat3 < dblat3.in
+
+srctest:
+ $(MAKE) -f Makefile_javasrc
+
+verify: $(ROOT)/$(BLAS3TEST_IDX)
+ cd $(OUTDIR); $(JAVA) $(MORE_MEM_FLAG) -classpath .:..:$(JUSTICE):$(BCEL):$(ROOT)/../$(UTIL_DIR)/$(UTIL_JAR):$(ROOT)/../$(ERR_DIR)/$(ERR_JAR):$(ROOT)/../$(BLAS_DIR)/$(BLAS_JAR) $(VERIFY) $(BLASTEST_PDIR)/*.class
+
+clean:
+ /bin/rm -rf *.java *.class *.f2j org $(OUTDIR) $(JAVASRC_OUTDIR) $(BLAS3TEST_JAR)
diff --git a/jlapack-3.1.1/src/testing/blas3/Makefile_javasrc b/jlapack-3.1.1/src/testing/blas3/Makefile_javasrc
new file mode 100644
index 0000000..e20f55f
--- /dev/null
+++ b/jlapack-3.1.1/src/testing/blas3/Makefile_javasrc
@@ -0,0 +1,34 @@
+.SUFFIXES: .f .java
+
+ROOT=../../..
+
+include $(ROOT)/make.def
+
+tester: $(ROOT)/$(BLAS_DIR)/$(BLAS_JAR) $(ROOT)/$(BLAS3TEST_IDX) $(ROOT)/$(UTIL_DIR)/$(UTIL_JAR)
+ /bin/rm -f `find $(OUTDIR) -name "*.class"`
+ mkdir -p $(JAVASRC_OUTDIR)
+ $(JAVAC) -classpath .:$(JAVASRC_OUTDIR):$(ROOT)/$(UTIL_DIR)/$(UTIL_JAR):$(ROOT)/$(ERR_DIR)/$(ERR_JAR):$(ROOT)/$(BLAS_DIR)/$(BLAS_JAR) -d $(JAVASRC_OUTDIR) $(OUTDIR)/$(BLASTEST_PDIR)/*.java
+ /bin/rm -f $(JAVASRC_OUTDIR)/$(BLASTEST_PDIR)/*.old
+ $(JAVAB) $(JAVASRC_OUTDIR)/$(BLASTEST_PDIR)/*.class
+ /bin/rm -f $(BLAS3TEST_JAR)
+ cd $(JAVASRC_OUTDIR); $(JAR) cvf ../$(BLAS3TEST_JAR) `find . -name "*.class"`
+ $(JAR) uvf $(BLAS3TEST_JAR) `find org -name "*.class"`
+
+
+$(ROOT)/$(BLAS3TEST_IDX): dblat3.f
+ $(MAKE) nojar
+
+$(ROOT)/$(BLAS_DIR)/$(BLAS_JAR):
+ cd $(ROOT)/$(BLAS_DIR); $(MAKE) -f Makefile_javasrc
+
+$(ROOT)/$(UTIL_DIR)/$(UTIL_JAR):
+ cd $(ROOT)/$(UTIL_DIR); $(MAKE)
+
+runtest: tester
+ $(JAVA) $(JFLAGS) -cp .:$(BLAS3TEST_JAR):$(ROOT)/$(BLAS_DIR)/$(BLAS_JAR):$(ROOT)/$(UTIL_DIR)/$(UTIL_JAR):$(ROOT)/$(ERR_DIR)/$(ERR_JAR) $(BLASTEST_PACKAGE).Dblat3 < dblat3.in
+
+verify: $(ROOT)/$(BLAS3TEST_IDX)
+ cd $(JAVASRC_OUTDIR); $(JAVA) $(MORE_MEM_FLAG) -classpath .:..:$(JUSTICE):$(BCEL):$(ROOT)/../$(UTIL_DIR)/$(UTIL_JAR):$(ROOT)/../$(ERR_DIR)/$(ERR_JAR):$(ROOT)/../$(BLAS_DIR)/$(BLAS_JAR) $(VERIFY) $(BLASTEST_PDIR)/*.class
+
+clean:
+ /bin/rm -rf *.java *.class *.f2j org $(OUTDIR) $(JAVASRC_OUTDIR) $(BLAS3TEST_JAR)
diff --git a/jlapack-3.1.1/src/testing/blas3/dblat3.f b/jlapack-3.1.1/src/testing/blas3/dblat3.f
new file mode 100644
index 0000000..3689ec5
--- /dev/null
+++ b/jlapack-3.1.1/src/testing/blas3/dblat3.f
@@ -0,0 +1,2783 @@
+ PROGRAM DBLAT3
+*
+* Test program for the DOUBLE PRECISION Level 3 Blas.
+*
+* The program must be driven by a short data file. The first 14 records
+* of the file are read using list-directed input, the last 6 records
+* are read using the format ( A6, L2 ). An annotated example of a data
+* file can be obtained by deleting the first 3 characters from the
+* following 20 lines:
+* 'dblat3.out' NAME OF SUMMARY OUTPUT FILE
+* 6 UNIT NUMBER OF SUMMARY FILE
+* 'DBLAT3.SNAP' NAME OF SNAPSHOT OUTPUT FILE
+* -1 UNIT NUMBER OF SNAPSHOT FILE (NOT USED IF .LT. 0)
+* F LOGICAL FLAG, T TO REWIND SNAPSHOT FILE AFTER EACH RECORD.
+* F LOGICAL FLAG, T TO STOP ON FAILURES.
+* T LOGICAL FLAG, T TO TEST ERROR EXITS.
+* 16.0 THRESHOLD VALUE OF TEST RATIO
+* 6 NUMBER OF VALUES OF N
+* 0 1 2 3 5 9 VALUES OF N
+* 3 NUMBER OF VALUES OF ALPHA
+* 0.0 1.0 0.7 VALUES OF ALPHA
+* 3 NUMBER OF VALUES OF BETA
+* 0.0 1.0 1.3 VALUES OF BETA
+* DGEMM T PUT F FOR NO TEST. SAME COLUMNS.
+* DSYMM T PUT F FOR NO TEST. SAME COLUMNS.
+* DTRMM T PUT F FOR NO TEST. SAME COLUMNS.
+* DTRSM T PUT F FOR NO TEST. SAME COLUMNS.
+* DSYRK T PUT F FOR NO TEST. SAME COLUMNS.
+* DSYR2K T PUT F FOR NO TEST. SAME COLUMNS.
+*
+* See:
+*
+* Dongarra J. J., Du Croz J. J., Duff I. S. and Hammarling S.
+* A Set of Level 3 Basic Linear Algebra Subprograms.
+*
+* Technical Memorandum No.88 (Revision 1), Mathematics and
+* Computer Science Division, Argonne National Laboratory, 9700
+* South Cass Avenue, Argonne, Illinois 60439, US.
+*
+* -- Written on 8-February-1989.
+* Jack Dongarra, Argonne National Laboratory.
+* Iain Duff, AERE Harwell.
+* Jeremy Du Croz, Numerical Algorithms Group Ltd.
+* Sven Hammarling, Numerical Algorithms Group Ltd.
+*
+* 10-9-00: Change STATUS='NEW' to 'UNKNOWN' so that the testers
+* can be run multiple times without deleting generated
+* output files (susan)
+*
+* .. Parameters ..
+ INTEGER NIN
+ PARAMETER ( NIN = 5 )
+ INTEGER NSUBS
+ PARAMETER ( NSUBS = 6 )
+ DOUBLE PRECISION ZERO, HALF, ONE
+ PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0 )
+ INTEGER NMAX
+ PARAMETER ( NMAX = 65 )
+ INTEGER NIDMAX, NALMAX, NBEMAX
+ PARAMETER ( NIDMAX = 9, NALMAX = 7, NBEMAX = 7 )
+* .. Local Scalars ..
+ DOUBLE PRECISION EPS, ERR, THRESH
+ INTEGER I, ISNUM, J, N, NALF, NBET, NIDIM, NOUT, NTRA
+ LOGICAL FATAL, LTESTT, REWI, SAME, SFATAL, TRACE,
+ $ TSTERR
+ CHARACTER*1 TRANSA, TRANSB
+ CHARACTER*6 SNAMET
+ CHARACTER*32 SNAPS, SUMMRY
+* .. Local Arrays ..
+ DOUBLE PRECISION AA( NMAX*NMAX ), AB( NMAX, 2*NMAX ),
+ $ ALF( NALMAX ), AS( NMAX*NMAX ),
+ $ BB( NMAX*NMAX ), BET( NBEMAX ),
+ $ BS( NMAX*NMAX ), C( NMAX, NMAX ),
+ $ CC( NMAX*NMAX ), CS( NMAX*NMAX ), CT( NMAX ),
+ $ G( NMAX ), W( 2*NMAX )
+ INTEGER IDIM( NIDMAX )
+ LOGICAL LTEST( NSUBS )
+ CHARACTER*6 SNAMES( NSUBS )
+* .. External Functions ..
+ DOUBLE PRECISION DDIFF
+ LOGICAL LDE
+ EXTERNAL DDIFF, LDE
+* .. External Subroutines ..
+ EXTERNAL DCHK1, DCHK2, DCHK3, DCHK4, DCHK5, DCHKE, DMMCH
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN
+* .. Scalars in Common ..
+ INTEGER INFOT, NOUTC
+ LOGICAL LERR, OK
+ CHARACTER*6 SRNAMT
+* .. Common blocks ..
+ COMMON /INFOC/INFOT, NOUTC, OK, LERR
+ COMMON /SRNAMC/SRNAMT
+* .. Data statements ..
+ DATA SNAMES/'DGEMM ', 'DSYMM ', 'DTRMM ', 'DTRSM ',
+ $ 'DSYRK ', 'DSYR2K'/
+* .. Executable Statements ..
+*
+* Read name and unit number for summary output file and open file.
+*
+ READ( NIN, FMT = * )SUMMRY
+ READ( NIN, FMT = * )NOUT
+ OPEN( NOUT, FILE = SUMMRY, STATUS = 'UNKNOWN' )
+ NOUTC = NOUT
+*
+* Read name and unit number for snapshot output file and open file.
+*
+ READ( NIN, FMT = * )SNAPS
+ READ( NIN, FMT = * )NTRA
+ TRACE = NTRA.GE.0
+ IF( TRACE )THEN
+ OPEN( NTRA, FILE = SNAPS, STATUS = 'UNKNOWN' )
+ END IF
+* Read the flag that directs rewinding of the snapshot file.
+ READ( NIN, FMT = * )REWI
+ REWI = REWI.AND.TRACE
+* Read the flag that directs stopping on any failure.
+ READ( NIN, FMT = * )SFATAL
+* Read the flag that indicates whether error exits are to be tested.
+ READ( NIN, FMT = * )TSTERR
+* Read the threshold value of the test ratio
+ READ( NIN, FMT = * )THRESH
+*
+* Read and check the parameter values for the tests.
+*
+* Values of N
+ READ( NIN, FMT = * )NIDIM
+ IF( NIDIM.LT.1.OR.NIDIM.GT.NIDMAX )THEN
+ WRITE( NOUT, FMT = 9997 )'N', NIDMAX
+ GO TO 220
+ END IF
+ READ( NIN, FMT = * )( IDIM( I ), I = 1, NIDIM )
+ DO 10 I = 1, NIDIM
+ IF( IDIM( I ).LT.0.OR.IDIM( I ).GT.NMAX )THEN
+ WRITE( NOUT, FMT = 9996 )NMAX
+ GO TO 220
+ END IF
+ 10 CONTINUE
+* Values of ALPHA
+ READ( NIN, FMT = * )NALF
+ IF( NALF.LT.1.OR.NALF.GT.NALMAX )THEN
+ WRITE( NOUT, FMT = 9997 )'ALPHA', NALMAX
+ GO TO 220
+ END IF
+ READ( NIN, FMT = * )( ALF( I ), I = 1, NALF )
+* Values of BETA
+ READ( NIN, FMT = * )NBET
+ IF( NBET.LT.1.OR.NBET.GT.NBEMAX )THEN
+ WRITE( NOUT, FMT = 9997 )'BETA', NBEMAX
+ GO TO 220
+ END IF
+ READ( NIN, FMT = * )( BET( I ), I = 1, NBET )
+*
+* Report values of parameters.
+*
+ WRITE( NOUT, FMT = 9995 )
+ WRITE( NOUT, FMT = 9994 )( IDIM( I ), I = 1, NIDIM )
+ WRITE( NOUT, FMT = 9993 )( ALF( I ), I = 1, NALF )
+ WRITE( NOUT, FMT = 9992 )( BET( I ), I = 1, NBET )
+ IF( .NOT.TSTERR )THEN
+ WRITE( NOUT, FMT = * )
+ WRITE( NOUT, FMT = 9984 )
+ END IF
+ WRITE( NOUT, FMT = * )
+ WRITE( NOUT, FMT = 9999 )THRESH
+ WRITE( NOUT, FMT = * )
+*
+* Read names of subroutines and flags which indicate
+* whether they are to be tested.
+*
+ DO 20 I = 1, NSUBS
+ LTEST( I ) = .FALSE.
+ 20 CONTINUE
+ 30 READ( NIN, FMT = 9988, END = 60 )SNAMET, LTESTT
+ DO 40 I = 1, NSUBS
+ IF( SNAMET.EQ.SNAMES( I ) )
+ $ GO TO 50
+ 40 CONTINUE
+ WRITE( NOUT, FMT = 9990 )SNAMET
+ STOP
+ 50 LTEST( I ) = LTESTT
+ GO TO 30
+*
+ 60 CONTINUE
+ CLOSE ( NIN )
+*
+* Compute EPS (the machine precision).
+*
+ EPS = ONE
+ 70 CONTINUE
+ IF( DDIFF( ONE + EPS, ONE ).EQ.ZERO )
+ $ GO TO 80
+ EPS = HALF*EPS
+ GO TO 70
+ 80 CONTINUE
+ EPS = EPS + EPS
+ WRITE( NOUT, FMT = 9998 )EPS
+*
+* Check the reliability of DMMCH using exact data.
+*
+ N = MIN( 32, NMAX )
+ DO 100 J = 1, N
+ DO 90 I = 1, N
+ AB( I, J ) = MAX( I - J + 1, 0 )
+ 90 CONTINUE
+ AB( J, NMAX + 1 ) = J
+ AB( 1, NMAX + J ) = J
+ C( J, 1 ) = ZERO
+ 100 CONTINUE
+ DO 110 J = 1, N
+ CC( J ) = J*( ( J + 1 )*J )/2 - ( ( J + 1 )*J*( J - 1 ) )/3
+ 110 CONTINUE
+* CC holds the exact result. On exit from DMMCH CT holds
+* the result computed by DMMCH.
+ TRANSA = 'N'
+ TRANSB = 'N'
+ CALL DMMCH( TRANSA, TRANSB, N, 1, N, ONE, AB, NMAX,
+ $ AB( 1, NMAX + 1 ), NMAX, ZERO, C, NMAX, CT, G, CC,
+ $ NMAX, EPS, ERR, FATAL, NOUT, .TRUE. )
+ SAME = LDE( CC, CT, N )
+ IF( .NOT.SAME.OR.ERR.NE.ZERO )THEN
+ WRITE( NOUT, FMT = 9989 )TRANSA, TRANSB, SAME, ERR
+ STOP
+ END IF
+ TRANSB = 'T'
+ CALL DMMCH( TRANSA, TRANSB, N, 1, N, ONE, AB, NMAX,
+ $ AB( 1, NMAX + 1 ), NMAX, ZERO, C, NMAX, CT, G, CC,
+ $ NMAX, EPS, ERR, FATAL, NOUT, .TRUE. )
+ SAME = LDE( CC, CT, N )
+ IF( .NOT.SAME.OR.ERR.NE.ZERO )THEN
+ WRITE( NOUT, FMT = 9989 )TRANSA, TRANSB, SAME, ERR
+ STOP
+ END IF
+ DO 120 J = 1, N
+ AB( J, NMAX + 1 ) = N - J + 1
+ AB( 1, NMAX + J ) = N - J + 1
+ 120 CONTINUE
+ DO 130 J = 1, N
+ CC( N - J + 1 ) = J*( ( J + 1 )*J )/2 -
+ $ ( ( J + 1 )*J*( J - 1 ) )/3
+ 130 CONTINUE
+ TRANSA = 'T'
+ TRANSB = 'N'
+ CALL DMMCH( TRANSA, TRANSB, N, 1, N, ONE, AB, NMAX,
+ $ AB( 1, NMAX + 1 ), NMAX, ZERO, C, NMAX, CT, G, CC,
+ $ NMAX, EPS, ERR, FATAL, NOUT, .TRUE. )
+ SAME = LDE( CC, CT, N )
+ IF( .NOT.SAME.OR.ERR.NE.ZERO )THEN
+ WRITE( NOUT, FMT = 9989 )TRANSA, TRANSB, SAME, ERR
+ STOP
+ END IF
+ TRANSB = 'T'
+ CALL DMMCH( TRANSA, TRANSB, N, 1, N, ONE, AB, NMAX,
+ $ AB( 1, NMAX + 1 ), NMAX, ZERO, C, NMAX, CT, G, CC,
+ $ NMAX, EPS, ERR, FATAL, NOUT, .TRUE. )
+ SAME = LDE( CC, CT, N )
+ IF( .NOT.SAME.OR.ERR.NE.ZERO )THEN
+ WRITE( NOUT, FMT = 9989 )TRANSA, TRANSB, SAME, ERR
+ STOP
+ END IF
+*
+* Test each subroutine in turn.
+*
+ DO 200 ISNUM = 1, NSUBS
+ WRITE( NOUT, FMT = * )
+ IF( .NOT.LTEST( ISNUM ) )THEN
+* Subprogram is not to be tested.
+ WRITE( NOUT, FMT = 9987 )SNAMES( ISNUM )
+ ELSE
+ SRNAMT = SNAMES( ISNUM )
+* Test error exits.
+ IF( TSTERR )THEN
+ CALL DCHKE( ISNUM, SNAMES( ISNUM ), NOUT )
+ WRITE( NOUT, FMT = * )
+ END IF
+* Test computations.
+ INFOT = 0
+ OK = .TRUE.
+ FATAL = .FALSE.
+ GO TO ( 140, 150, 160, 160, 170, 180 )ISNUM
+* Test DGEMM, 01.
+ 140 CALL DCHK1( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
+ $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET,
+ $ NMAX, AB, AA, AS, AB( 1, NMAX + 1 ), BB, BS, C,
+ $ CC, CS, CT, G )
+ GO TO 190
+* Test DSYMM, 02.
+ 150 CALL DCHK2( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
+ $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET,
+ $ NMAX, AB, AA, AS, AB( 1, NMAX + 1 ), BB, BS, C,
+ $ CC, CS, CT, G )
+ GO TO 190
+* Test DTRMM, 03, DTRSM, 04.
+ 160 CALL DCHK3( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
+ $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NMAX, AB,
+ $ AA, AS, AB( 1, NMAX + 1 ), BB, BS, CT, G, C )
+ GO TO 190
+* Test DSYRK, 05.
+ 170 CALL DCHK4( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
+ $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET,
+ $ NMAX, AB, AA, AS, AB( 1, NMAX + 1 ), BB, BS, C,
+ $ CC, CS, CT, G )
+ GO TO 190
+* Test DSYR2K, 06.
+ 180 CALL DCHK5( SNAMES( ISNUM ), EPS, THRESH, NOUT, NTRA, TRACE,
+ $ REWI, FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET,
+ $ NMAX, AB, AA, AS, BB, BS, C, CC, CS, CT, G, W )
+ GO TO 190
+*
+ 190 IF( FATAL.AND.SFATAL )
+ $ GO TO 210
+ END IF
+ 200 CONTINUE
+ WRITE( NOUT, FMT = 9986 )
+ GO TO 230
+*
+ 210 CONTINUE
+ WRITE( NOUT, FMT = 9985 )
+ GO TO 230
+*
+ 220 CONTINUE
+ WRITE( NOUT, FMT = 9991 )
+*
+ 230 CONTINUE
+ IF( TRACE )
+ $ CLOSE ( NTRA )
+ CLOSE ( NOUT )
+ STOP
+*
+ 9999 FORMAT( ' ROUTINES PASS COMPUTATIONAL TESTS IF TEST RATIO IS LES',
+ $ 'S THAN', F8.2 )
+ 9998 FORMAT( ' RELATIVE MACHINE PRECISION IS TAKEN TO BE', 1P, D9.1 )
+ 9997 FORMAT( ' NUMBER OF VALUES OF ', A, ' IS LESS THAN 1 OR GREATER ',
+ $ 'THAN ', I2 )
+ 9996 FORMAT( ' VALUE OF N IS LESS THAN 0 OR GREATER THAN ', I2 )
+ 9995 FORMAT( ' TESTS OF THE DOUBLE PRECISION LEVEL 3 BLAS', //' THE F',
+ $ 'OLLOWING PARAMETER VALUES WILL BE USED:' )
+ 9994 FORMAT( ' FOR N ', 9I6 )
+ 9993 FORMAT( ' FOR ALPHA ', 7F6.1 )
+ 9992 FORMAT( ' FOR BETA ', 7F6.1 )
+ 9991 FORMAT( ' AMEND DATA FILE OR INCREASE ARRAY SIZES IN PROGRAM',
+ $ /' ******* TESTS ABANDONED *******' )
+ 9990 FORMAT( ' SUBPROGRAM NAME ', A6, ' NOT RECOGNIZED', /' ******* T',
+ $ 'ESTS ABANDONED *******' )
+ 9989 FORMAT( ' ERROR IN DMMCH - IN-LINE DOT PRODUCTS ARE BEING EVALU',
+ $ 'ATED WRONGLY.', /' DMMCH WAS CALLED WITH TRANSA = ', A1,
+ $ ' AND TRANSB = ', A1, /' AND RETURNED SAME = ', L1, ' AND ',
+ $ 'ERR = ', F12.3, '.', /' THIS MAY BE DUE TO FAULTS IN THE ',
+ $ 'ARITHMETIC OR THE COMPILER.', /' ******* TESTS ABANDONED ',
+ $ '*******' )
+ 9988 FORMAT( A6, L2 )
+ 9987 FORMAT( 1X, A6, ' WAS NOT TESTED' )
+ 9986 FORMAT( /' END OF TESTS' )
+ 9985 FORMAT( /' ******* FATAL ERROR - TESTS ABANDONED *******' )
+ 9984 FORMAT( ' ERROR-EXITS WILL NOT BE TESTED' )
+*
+* End of DBLAT3.
+*
+ END
+ SUBROUTINE DCHK1( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
+ $ FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, NMAX,
+ $ A, AA, AS, B, BB, BS, C, CC, CS, CT, G )
+*
+* Tests DGEMM.
+*
+* Auxiliary routine for test program for Level 3 Blas.
+*
+* -- Written on 8-February-1989.
+* Jack Dongarra, Argonne National Laboratory.
+* Iain Duff, AERE Harwell.
+* Jeremy Du Croz, Numerical Algorithms Group Ltd.
+* Sven Hammarling, Numerical Algorithms Group Ltd.
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO
+ PARAMETER ( ZERO = 0.0D0 )
+* .. Scalar Arguments ..
+ DOUBLE PRECISION EPS, THRESH
+ INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA
+ LOGICAL FATAL, REWI, TRACE
+ CHARACTER*6 SNAME
+* .. Array Arguments ..
+ DOUBLE PRECISION A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
+ $ AS( NMAX*NMAX ), B( NMAX, NMAX ),
+ $ BB( NMAX*NMAX ), BET( NBET ), BS( NMAX*NMAX ),
+ $ C( NMAX, NMAX ), CC( NMAX*NMAX ),
+ $ CS( NMAX*NMAX ), CT( NMAX ), G( NMAX )
+ INTEGER IDIM( NIDIM )
+* .. Local Scalars ..
+ DOUBLE PRECISION ALPHA, ALS, BETA, BLS, ERR, ERRMAX
+ INTEGER I, IA, IB, ICA, ICB, IK, IM, IN, K, KS, LAA,
+ $ LBB, LCC, LDA, LDAS, LDB, LDBS, LDC, LDCS, M,
+ $ MA, MB, MS, N, NA, NARGS, NB, NC, NS
+ LOGICAL NULL, RESET, SAME, TRANA, TRANB
+ CHARACTER*1 TRANAS, TRANBS, TRANSA, TRANSB
+ CHARACTER*3 ICH
+* .. Local Arrays ..
+ LOGICAL ISAME( 13 )
+* .. External Functions ..
+ LOGICAL LDE, LDERES
+ EXTERNAL LDE, LDERES
+* .. External Subroutines ..
+ EXTERNAL DGEMM, DMAKE, DMMCH
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* .. Scalars in Common ..
+ INTEGER INFOT, NOUTC
+ LOGICAL LERR, OK
+* .. Common blocks ..
+ COMMON /INFOC/INFOT, NOUTC, OK, LERR
+* .. Data statements ..
+ DATA ICH/'NTC'/
+* .. Executable Statements ..
+*
+ NARGS = 13
+ NC = 0
+ RESET = .TRUE.
+ ERRMAX = ZERO
+*
+ DO 110 IM = 1, NIDIM
+ M = IDIM( IM )
+*
+ DO 100 IN = 1, NIDIM
+ N = IDIM( IN )
+* Set LDC to 1 more than minimum value if room.
+ LDC = M
+ IF( LDC.LT.NMAX )
+ $ LDC = LDC + 1
+* Skip tests if not enough room.
+ IF( LDC.GT.NMAX )
+ $ GO TO 100
+ LCC = LDC*N
+ NULL = N.LE.0.OR.M.LE.0
+*
+ DO 90 IK = 1, NIDIM
+ K = IDIM( IK )
+*
+ DO 80 ICA = 1, 3
+ TRANSA = ICH( ICA: ICA )
+ TRANA = TRANSA.EQ.'T'.OR.TRANSA.EQ.'C'
+*
+ IF( TRANA )THEN
+ MA = K
+ NA = M
+ ELSE
+ MA = M
+ NA = K
+ END IF
+* Set LDA to 1 more than minimum value if room.
+ LDA = MA
+ IF( LDA.LT.NMAX )
+ $ LDA = LDA + 1
+* Skip tests if not enough room.
+ IF( LDA.GT.NMAX )
+ $ GO TO 80
+ LAA = LDA*NA
+*
+* Generate the matrix A.
+*
+ CALL DMAKE( 'GE', ' ', ' ', MA, NA, A, NMAX, AA, LDA,
+ $ RESET, ZERO )
+*
+ DO 70 ICB = 1, 3
+ TRANSB = ICH( ICB: ICB )
+ TRANB = TRANSB.EQ.'T'.OR.TRANSB.EQ.'C'
+*
+ IF( TRANB )THEN
+ MB = N
+ NB = K
+ ELSE
+ MB = K
+ NB = N
+ END IF
+* Set LDB to 1 more than minimum value if room.
+ LDB = MB
+ IF( LDB.LT.NMAX )
+ $ LDB = LDB + 1
+* Skip tests if not enough room.
+ IF( LDB.GT.NMAX )
+ $ GO TO 70
+ LBB = LDB*NB
+*
+* Generate the matrix B.
+*
+ CALL DMAKE( 'GE', ' ', ' ', MB, NB, B, NMAX, BB,
+ $ LDB, RESET, ZERO )
+*
+ DO 60 IA = 1, NALF
+ ALPHA = ALF( IA )
+*
+ DO 50 IB = 1, NBET
+ BETA = BET( IB )
+*
+* Generate the matrix C.
+*
+ CALL DMAKE( 'GE', ' ', ' ', M, N, C, NMAX,
+ $ CC, LDC, RESET, ZERO )
+*
+ NC = NC + 1
+*
+* Save every datum before calling the
+* subroutine.
+*
+ TRANAS = TRANSA
+ TRANBS = TRANSB
+ MS = M
+ NS = N
+ KS = K
+ ALS = ALPHA
+ DO 10 I = 1, LAA
+ AS( I ) = AA( I )
+ 10 CONTINUE
+ LDAS = LDA
+ DO 20 I = 1, LBB
+ BS( I ) = BB( I )
+ 20 CONTINUE
+ LDBS = LDB
+ BLS = BETA
+ DO 30 I = 1, LCC
+ CS( I ) = CC( I )
+ 30 CONTINUE
+ LDCS = LDC
+*
+* Call the subroutine.
+*
+ IF( TRACE )
+ $ WRITE( NTRA, FMT = 9995 )NC, SNAME,
+ $ TRANSA, TRANSB, M, N, K, ALPHA, LDA, LDB,
+ $ BETA, LDC
+ IF( REWI )
+ $ REWIND NTRA
+ CALL DGEMM( TRANSA, TRANSB, M, N, K, ALPHA,
+ $ AA, LDA, BB, LDB, BETA, CC, LDC )
+*
+* Check if error-exit was taken incorrectly.
+*
+ IF( .NOT.OK )THEN
+ WRITE( NOUT, FMT = 9994 )
+ FATAL = .TRUE.
+ GO TO 120
+ END IF
+*
+* See what data changed inside subroutines.
+*
+ ISAME( 1 ) = TRANSA.EQ.TRANAS
+ ISAME( 2 ) = TRANSB.EQ.TRANBS
+ ISAME( 3 ) = MS.EQ.M
+ ISAME( 4 ) = NS.EQ.N
+ ISAME( 5 ) = KS.EQ.K
+ ISAME( 6 ) = ALS.EQ.ALPHA
+ ISAME( 7 ) = LDE( AS, AA, LAA )
+ ISAME( 8 ) = LDAS.EQ.LDA
+ ISAME( 9 ) = LDE( BS, BB, LBB )
+ ISAME( 10 ) = LDBS.EQ.LDB
+ ISAME( 11 ) = BLS.EQ.BETA
+ IF( NULL )THEN
+ ISAME( 12 ) = LDE( CS, CC, LCC )
+ ELSE
+ ISAME( 12 ) = LDERES( 'GE', ' ', M, N, CS,
+ $ CC, LDC )
+ END IF
+ ISAME( 13 ) = LDCS.EQ.LDC
+*
+* If data was incorrectly changed, report
+* and return.
+*
+ SAME = .TRUE.
+ DO 40 I = 1, NARGS
+ SAME = SAME.AND.ISAME( I )
+ IF( .NOT.ISAME( I ) )
+ $ WRITE( NOUT, FMT = 9998 )I
+ 40 CONTINUE
+ IF( .NOT.SAME )THEN
+ FATAL = .TRUE.
+ GO TO 120
+ END IF
+*
+ IF( .NOT.NULL )THEN
+*
+* Check the result.
+*
+ CALL DMMCH( TRANSA, TRANSB, M, N, K,
+ $ ALPHA, A, NMAX, B, NMAX, BETA,
+ $ C, NMAX, CT, G, CC, LDC, EPS,
+ $ ERR, FATAL, NOUT, .TRUE. )
+ ERRMAX = MAX( ERRMAX, ERR )
+* If got really bad answer, report and
+* return.
+ IF( FATAL )
+ $ GO TO 120
+ END IF
+*
+ 50 CONTINUE
+*
+ 60 CONTINUE
+*
+ 70 CONTINUE
+*
+ 80 CONTINUE
+*
+ 90 CONTINUE
+*
+ 100 CONTINUE
+*
+ 110 CONTINUE
+*
+* Report result.
+*
+ IF( ERRMAX.LT.THRESH )THEN
+ WRITE( NOUT, FMT = 9999 )SNAME, NC
+ ELSE
+ WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX
+ END IF
+ GO TO 130
+*
+ 120 CONTINUE
+ WRITE( NOUT, FMT = 9996 )SNAME
+ WRITE( NOUT, FMT = 9995 )NC, SNAME, TRANSA, TRANSB, M, N, K,
+ $ ALPHA, LDA, LDB, BETA, LDC
+*
+ 130 CONTINUE
+ RETURN
+*
+ 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL',
+ $ 'S)' )
+ 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
+ $ 'ANGED INCORRECTLY *******' )
+ 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C',
+ $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2,
+ $ ' - SUSPECT *******' )
+ 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' )
+ 9995 FORMAT( 1X, I6, ': ', A6, '(''', A1, ''',''', A1, ''',',
+ $ 3( I3, ',' ), F4.1, ', A,', I3, ', B,', I3, ',', F4.1, ', ',
+ $ 'C,', I3, ').' )
+ 9994 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
+ $ '******' )
+*
+* End of DCHK1.
+*
+ END
+ SUBROUTINE DCHK2( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
+ $ FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, NMAX,
+ $ A, AA, AS, B, BB, BS, C, CC, CS, CT, G )
+*
+* Tests DSYMM.
+*
+* Auxiliary routine for test program for Level 3 Blas.
+*
+* -- Written on 8-February-1989.
+* Jack Dongarra, Argonne National Laboratory.
+* Iain Duff, AERE Harwell.
+* Jeremy Du Croz, Numerical Algorithms Group Ltd.
+* Sven Hammarling, Numerical Algorithms Group Ltd.
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO
+ PARAMETER ( ZERO = 0.0D0 )
+* .. Scalar Arguments ..
+ DOUBLE PRECISION EPS, THRESH
+ INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA
+ LOGICAL FATAL, REWI, TRACE
+ CHARACTER*6 SNAME
+* .. Array Arguments ..
+ DOUBLE PRECISION A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
+ $ AS( NMAX*NMAX ), B( NMAX, NMAX ),
+ $ BB( NMAX*NMAX ), BET( NBET ), BS( NMAX*NMAX ),
+ $ C( NMAX, NMAX ), CC( NMAX*NMAX ),
+ $ CS( NMAX*NMAX ), CT( NMAX ), G( NMAX )
+ INTEGER IDIM( NIDIM )
+* .. Local Scalars ..
+ DOUBLE PRECISION ALPHA, ALS, BETA, BLS, ERR, ERRMAX
+ INTEGER I, IA, IB, ICS, ICU, IM, IN, LAA, LBB, LCC,
+ $ LDA, LDAS, LDB, LDBS, LDC, LDCS, M, MS, N, NA,
+ $ NARGS, NC, NS
+ LOGICAL LEFT, NULL, RESET, SAME
+ CHARACTER*1 SIDE, SIDES, UPLO, UPLOS
+ CHARACTER*2 ICHS, ICHU
+* .. Local Arrays ..
+ LOGICAL ISAME( 13 )
+* .. External Functions ..
+ LOGICAL LDE, LDERES
+ EXTERNAL LDE, LDERES
+* .. External Subroutines ..
+ EXTERNAL DMAKE, DMMCH, DSYMM
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* .. Scalars in Common ..
+ INTEGER INFOT, NOUTC
+ LOGICAL LERR, OK
+* .. Common blocks ..
+ COMMON /INFOC/INFOT, NOUTC, OK, LERR
+* .. Data statements ..
+ DATA ICHS/'LR'/, ICHU/'UL'/
+* .. Executable Statements ..
+*
+ NARGS = 12
+ NC = 0
+ RESET = .TRUE.
+ ERRMAX = ZERO
+*
+ DO 100 IM = 1, NIDIM
+ M = IDIM( IM )
+*
+ DO 90 IN = 1, NIDIM
+ N = IDIM( IN )
+* Set LDC to 1 more than minimum value if room.
+ LDC = M
+ IF( LDC.LT.NMAX )
+ $ LDC = LDC + 1
+* Skip tests if not enough room.
+ IF( LDC.GT.NMAX )
+ $ GO TO 90
+ LCC = LDC*N
+ NULL = N.LE.0.OR.M.LE.0
+*
+* Set LDB to 1 more than minimum value if room.
+ LDB = M
+ IF( LDB.LT.NMAX )
+ $ LDB = LDB + 1
+* Skip tests if not enough room.
+ IF( LDB.GT.NMAX )
+ $ GO TO 90
+ LBB = LDB*N
+*
+* Generate the matrix B.
+*
+ CALL DMAKE( 'GE', ' ', ' ', M, N, B, NMAX, BB, LDB, RESET,
+ $ ZERO )
+*
+ DO 80 ICS = 1, 2
+ SIDE = ICHS( ICS: ICS )
+ LEFT = SIDE.EQ.'L'
+*
+ IF( LEFT )THEN
+ NA = M
+ ELSE
+ NA = N
+ END IF
+* Set LDA to 1 more than minimum value if room.
+ LDA = NA
+ IF( LDA.LT.NMAX )
+ $ LDA = LDA + 1
+* Skip tests if not enough room.
+ IF( LDA.GT.NMAX )
+ $ GO TO 80
+ LAA = LDA*NA
+*
+ DO 70 ICU = 1, 2
+ UPLO = ICHU( ICU: ICU )
+*
+* Generate the symmetric matrix A.
+*
+ CALL DMAKE( 'SY', UPLO, ' ', NA, NA, A, NMAX, AA, LDA,
+ $ RESET, ZERO )
+*
+ DO 60 IA = 1, NALF
+ ALPHA = ALF( IA )
+*
+ DO 50 IB = 1, NBET
+ BETA = BET( IB )
+*
+* Generate the matrix C.
+*
+ CALL DMAKE( 'GE', ' ', ' ', M, N, C, NMAX, CC,
+ $ LDC, RESET, ZERO )
+*
+ NC = NC + 1
+*
+* Save every datum before calling the
+* subroutine.
+*
+ SIDES = SIDE
+ UPLOS = UPLO
+ MS = M
+ NS = N
+ ALS = ALPHA
+ DO 10 I = 1, LAA
+ AS( I ) = AA( I )
+ 10 CONTINUE
+ LDAS = LDA
+ DO 20 I = 1, LBB
+ BS( I ) = BB( I )
+ 20 CONTINUE
+ LDBS = LDB
+ BLS = BETA
+ DO 30 I = 1, LCC
+ CS( I ) = CC( I )
+ 30 CONTINUE
+ LDCS = LDC
+*
+* Call the subroutine.
+*
+ IF( TRACE )
+ $ WRITE( NTRA, FMT = 9995 )NC, SNAME, SIDE,
+ $ UPLO, M, N, ALPHA, LDA, LDB, BETA, LDC
+ IF( REWI )
+ $ REWIND NTRA
+ CALL DSYMM( SIDE, UPLO, M, N, ALPHA, AA, LDA,
+ $ BB, LDB, BETA, CC, LDC )
+*
+* Check if error-exit was taken incorrectly.
+*
+ IF( .NOT.OK )THEN
+ WRITE( NOUT, FMT = 9994 )
+ FATAL = .TRUE.
+ GO TO 110
+ END IF
+*
+* See what data changed inside subroutines.
+*
+ ISAME( 1 ) = SIDES.EQ.SIDE
+ ISAME( 2 ) = UPLOS.EQ.UPLO
+ ISAME( 3 ) = MS.EQ.M
+ ISAME( 4 ) = NS.EQ.N
+ ISAME( 5 ) = ALS.EQ.ALPHA
+ ISAME( 6 ) = LDE( AS, AA, LAA )
+ ISAME( 7 ) = LDAS.EQ.LDA
+ ISAME( 8 ) = LDE( BS, BB, LBB )
+ ISAME( 9 ) = LDBS.EQ.LDB
+ ISAME( 10 ) = BLS.EQ.BETA
+ IF( NULL )THEN
+ ISAME( 11 ) = LDE( CS, CC, LCC )
+ ELSE
+ ISAME( 11 ) = LDERES( 'GE', ' ', M, N, CS,
+ $ CC, LDC )
+ END IF
+ ISAME( 12 ) = LDCS.EQ.LDC
+*
+* If data was incorrectly changed, report and
+* return.
+*
+ SAME = .TRUE.
+ DO 40 I = 1, NARGS
+ SAME = SAME.AND.ISAME( I )
+ IF( .NOT.ISAME( I ) )
+ $ WRITE( NOUT, FMT = 9998 )I
+ 40 CONTINUE
+ IF( .NOT.SAME )THEN
+ FATAL = .TRUE.
+ GO TO 110
+ END IF
+*
+ IF( .NOT.NULL )THEN
+*
+* Check the result.
+*
+ IF( LEFT )THEN
+ CALL DMMCH( 'N', 'N', M, N, M, ALPHA, A,
+ $ NMAX, B, NMAX, BETA, C, NMAX,
+ $ CT, G, CC, LDC, EPS, ERR,
+ $ FATAL, NOUT, .TRUE. )
+ ELSE
+ CALL DMMCH( 'N', 'N', M, N, N, ALPHA, B,
+ $ NMAX, A, NMAX, BETA, C, NMAX,
+ $ CT, G, CC, LDC, EPS, ERR,
+ $ FATAL, NOUT, .TRUE. )
+ END IF
+ ERRMAX = MAX( ERRMAX, ERR )
+* If got really bad answer, report and
+* return.
+ IF( FATAL )
+ $ GO TO 110
+ END IF
+*
+ 50 CONTINUE
+*
+ 60 CONTINUE
+*
+ 70 CONTINUE
+*
+ 80 CONTINUE
+*
+ 90 CONTINUE
+*
+ 100 CONTINUE
+*
+* Report result.
+*
+ IF( ERRMAX.LT.THRESH )THEN
+ WRITE( NOUT, FMT = 9999 )SNAME, NC
+ ELSE
+ WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX
+ END IF
+ GO TO 120
+*
+ 110 CONTINUE
+ WRITE( NOUT, FMT = 9996 )SNAME
+ WRITE( NOUT, FMT = 9995 )NC, SNAME, SIDE, UPLO, M, N, ALPHA, LDA,
+ $ LDB, BETA, LDC
+*
+ 120 CONTINUE
+ RETURN
+*
+ 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL',
+ $ 'S)' )
+ 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
+ $ 'ANGED INCORRECTLY *******' )
+ 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C',
+ $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2,
+ $ ' - SUSPECT *******' )
+ 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' )
+ 9995 FORMAT( 1X, I6, ': ', A6, '(', 2( '''', A1, ''',' ), 2( I3, ',' ),
+ $ F4.1, ', A,', I3, ', B,', I3, ',', F4.1, ', C,', I3, ') ',
+ $ ' .' )
+ 9994 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
+ $ '******' )
+*
+* End of DCHK2.
+*
+ END
+ SUBROUTINE DCHK3( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
+ $ FATAL, NIDIM, IDIM, NALF, ALF, NMAX, A, AA, AS,
+ $ B, BB, BS, CT, G, C )
+*
+* Tests DTRMM and DTRSM.
+*
+* Auxiliary routine for test program for Level 3 Blas.
+*
+* -- Written on 8-February-1989.
+* Jack Dongarra, Argonne National Laboratory.
+* Iain Duff, AERE Harwell.
+* Jeremy Du Croz, Numerical Algorithms Group Ltd.
+* Sven Hammarling, Numerical Algorithms Group Ltd.
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
+* .. Scalar Arguments ..
+ DOUBLE PRECISION EPS, THRESH
+ INTEGER NALF, NIDIM, NMAX, NOUT, NTRA
+ LOGICAL FATAL, REWI, TRACE
+ CHARACTER*6 SNAME
+* .. Array Arguments ..
+ DOUBLE PRECISION A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
+ $ AS( NMAX*NMAX ), B( NMAX, NMAX ),
+ $ BB( NMAX*NMAX ), BS( NMAX*NMAX ),
+ $ C( NMAX, NMAX ), CT( NMAX ), G( NMAX )
+ INTEGER IDIM( NIDIM )
+* .. Local Scalars ..
+ DOUBLE PRECISION ALPHA, ALS, ERR, ERRMAX
+ INTEGER I, IA, ICD, ICS, ICT, ICU, IM, IN, J, LAA, LBB,
+ $ LDA, LDAS, LDB, LDBS, M, MS, N, NA, NARGS, NC,
+ $ NS
+ LOGICAL LEFT, NULL, RESET, SAME
+ CHARACTER*1 DIAG, DIAGS, SIDE, SIDES, TRANAS, TRANSA, UPLO,
+ $ UPLOS
+ CHARACTER*2 ICHD, ICHS, ICHU
+ CHARACTER*3 ICHT
+* .. Local Arrays ..
+ LOGICAL ISAME( 13 )
+* .. External Functions ..
+ LOGICAL LDE, LDERES
+ EXTERNAL LDE, LDERES
+* .. External Subroutines ..
+ EXTERNAL DMAKE, DMMCH, DTRMM, DTRSM
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* .. Scalars in Common ..
+ INTEGER INFOT, NOUTC
+ LOGICAL LERR, OK
+* .. Common blocks ..
+ COMMON /INFOC/INFOT, NOUTC, OK, LERR
+* .. Data statements ..
+ DATA ICHU/'UL'/, ICHT/'NTC'/, ICHD/'UN'/, ICHS/'LR'/
+* .. Executable Statements ..
+*
+ NARGS = 11
+ NC = 0
+ RESET = .TRUE.
+ ERRMAX = ZERO
+* Set up zero matrix for DMMCH.
+ DO 20 J = 1, NMAX
+ DO 10 I = 1, NMAX
+ C( I, J ) = ZERO
+ 10 CONTINUE
+ 20 CONTINUE
+*
+ DO 140 IM = 1, NIDIM
+ M = IDIM( IM )
+*
+ DO 130 IN = 1, NIDIM
+ N = IDIM( IN )
+* Set LDB to 1 more than minimum value if room.
+ LDB = M
+ IF( LDB.LT.NMAX )
+ $ LDB = LDB + 1
+* Skip tests if not enough room.
+ IF( LDB.GT.NMAX )
+ $ GO TO 130
+ LBB = LDB*N
+ NULL = M.LE.0.OR.N.LE.0
+*
+ DO 120 ICS = 1, 2
+ SIDE = ICHS( ICS: ICS )
+ LEFT = SIDE.EQ.'L'
+ IF( LEFT )THEN
+ NA = M
+ ELSE
+ NA = N
+ END IF
+* Set LDA to 1 more than minimum value if room.
+ LDA = NA
+ IF( LDA.LT.NMAX )
+ $ LDA = LDA + 1
+* Skip tests if not enough room.
+ IF( LDA.GT.NMAX )
+ $ GO TO 130
+ LAA = LDA*NA
+*
+ DO 110 ICU = 1, 2
+ UPLO = ICHU( ICU: ICU )
+*
+ DO 100 ICT = 1, 3
+ TRANSA = ICHT( ICT: ICT )
+*
+ DO 90 ICD = 1, 2
+ DIAG = ICHD( ICD: ICD )
+*
+ DO 80 IA = 1, NALF
+ ALPHA = ALF( IA )
+*
+* Generate the matrix A.
+*
+ CALL DMAKE( 'TR', UPLO, DIAG, NA, NA, A,
+ $ NMAX, AA, LDA, RESET, ZERO )
+*
+* Generate the matrix B.
+*
+ CALL DMAKE( 'GE', ' ', ' ', M, N, B, NMAX,
+ $ BB, LDB, RESET, ZERO )
+*
+ NC = NC + 1
+*
+* Save every datum before calling the
+* subroutine.
+*
+ SIDES = SIDE
+ UPLOS = UPLO
+ TRANAS = TRANSA
+ DIAGS = DIAG
+ MS = M
+ NS = N
+ ALS = ALPHA
+ DO 30 I = 1, LAA
+ AS( I ) = AA( I )
+ 30 CONTINUE
+ LDAS = LDA
+ DO 40 I = 1, LBB
+ BS( I ) = BB( I )
+ 40 CONTINUE
+ LDBS = LDB
+*
+* Call the subroutine.
+*
+ IF( SNAME( 4: 5 ).EQ.'MM' )THEN
+ IF( TRACE )
+ $ WRITE( NTRA, FMT = 9995 )NC, SNAME,
+ $ SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA,
+ $ LDA, LDB
+ IF( REWI )
+ $ REWIND NTRA
+ CALL DTRMM( SIDE, UPLO, TRANSA, DIAG, M,
+ $ N, ALPHA, AA, LDA, BB, LDB )
+ ELSE IF( SNAME( 4: 5 ).EQ.'SM' )THEN
+ IF( TRACE )
+ $ WRITE( NTRA, FMT = 9995 )NC, SNAME,
+ $ SIDE, UPLO, TRANSA, DIAG, M, N, ALPHA,
+ $ LDA, LDB
+ IF( REWI )
+ $ REWIND NTRA
+ CALL DTRSM( SIDE, UPLO, TRANSA, DIAG, M,
+ $ N, ALPHA, AA, LDA, BB, LDB )
+ END IF
+*
+* Check if error-exit was taken incorrectly.
+*
+ IF( .NOT.OK )THEN
+ WRITE( NOUT, FMT = 9994 )
+ FATAL = .TRUE.
+ GO TO 150
+ END IF
+*
+* See what data changed inside subroutines.
+*
+ ISAME( 1 ) = SIDES.EQ.SIDE
+ ISAME( 2 ) = UPLOS.EQ.UPLO
+ ISAME( 3 ) = TRANAS.EQ.TRANSA
+ ISAME( 4 ) = DIAGS.EQ.DIAG
+ ISAME( 5 ) = MS.EQ.M
+ ISAME( 6 ) = NS.EQ.N
+ ISAME( 7 ) = ALS.EQ.ALPHA
+ ISAME( 8 ) = LDE( AS, AA, LAA )
+ ISAME( 9 ) = LDAS.EQ.LDA
+ IF( NULL )THEN
+ ISAME( 10 ) = LDE( BS, BB, LBB )
+ ELSE
+ ISAME( 10 ) = LDERES( 'GE', ' ', M, N, BS,
+ $ BB, LDB )
+ END IF
+ ISAME( 11 ) = LDBS.EQ.LDB
+*
+* If data was incorrectly changed, report and
+* return.
+*
+ SAME = .TRUE.
+ DO 50 I = 1, NARGS
+ SAME = SAME.AND.ISAME( I )
+ IF( .NOT.ISAME( I ) )
+ $ WRITE( NOUT, FMT = 9998 )I
+ 50 CONTINUE
+ IF( .NOT.SAME )THEN
+ FATAL = .TRUE.
+ GO TO 150
+ END IF
+*
+ IF( .NOT.NULL )THEN
+ IF( SNAME( 4: 5 ).EQ.'MM' )THEN
+*
+* Check the result.
+*
+ IF( LEFT )THEN
+ CALL DMMCH( TRANSA, 'N', M, N, M,
+ $ ALPHA, A, NMAX, B, NMAX,
+ $ ZERO, C, NMAX, CT, G,
+ $ BB, LDB, EPS, ERR,
+ $ FATAL, NOUT, .TRUE. )
+ ELSE
+ CALL DMMCH( 'N', TRANSA, M, N, N,
+ $ ALPHA, B, NMAX, A, NMAX,
+ $ ZERO, C, NMAX, CT, G,
+ $ BB, LDB, EPS, ERR,
+ $ FATAL, NOUT, .TRUE. )
+ END IF
+ ELSE IF( SNAME( 4: 5 ).EQ.'SM' )THEN
+*
+* Compute approximation to original
+* matrix.
+*
+ DO 70 J = 1, N
+ DO 60 I = 1, M
+ C( I, J ) = BB( I + ( J - 1 )*
+ $ LDB )
+ BB( I + ( J - 1 )*LDB ) = ALPHA*
+ $ B( I, J )
+ 60 CONTINUE
+ 70 CONTINUE
+*
+ IF( LEFT )THEN
+ CALL DMMCH( TRANSA, 'N', M, N, M,
+ $ ONE, A, NMAX, C, NMAX,
+ $ ZERO, B, NMAX, CT, G,
+ $ BB, LDB, EPS, ERR,
+ $ FATAL, NOUT, .FALSE. )
+ ELSE
+ CALL DMMCH( 'N', TRANSA, M, N, N,
+ $ ONE, C, NMAX, A, NMAX,
+ $ ZERO, B, NMAX, CT, G,
+ $ BB, LDB, EPS, ERR,
+ $ FATAL, NOUT, .FALSE. )
+ END IF
+ END IF
+ ERRMAX = MAX( ERRMAX, ERR )
+* If got really bad answer, report and
+* return.
+ IF( FATAL )
+ $ GO TO 150
+ END IF
+*
+ 80 CONTINUE
+*
+ 90 CONTINUE
+*
+ 100 CONTINUE
+*
+ 110 CONTINUE
+*
+ 120 CONTINUE
+*
+ 130 CONTINUE
+*
+ 140 CONTINUE
+*
+* Report result.
+*
+ IF( ERRMAX.LT.THRESH )THEN
+ WRITE( NOUT, FMT = 9999 )SNAME, NC
+ ELSE
+ WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX
+ END IF
+ GO TO 160
+*
+ 150 CONTINUE
+ WRITE( NOUT, FMT = 9996 )SNAME
+ WRITE( NOUT, FMT = 9995 )NC, SNAME, SIDE, UPLO, TRANSA, DIAG, M,
+ $ N, ALPHA, LDA, LDB
+*
+ 160 CONTINUE
+ RETURN
+*
+ 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL',
+ $ 'S)' )
+ 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
+ $ 'ANGED INCORRECTLY *******' )
+ 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C',
+ $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2,
+ $ ' - SUSPECT *******' )
+ 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' )
+ 9995 FORMAT( 1X, I6, ': ', A6, '(', 4( '''', A1, ''',' ), 2( I3, ',' ),
+ $ F4.1, ', A,', I3, ', B,', I3, ') .' )
+ 9994 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
+ $ '******' )
+*
+* End of DCHK3.
+*
+ END
+ SUBROUTINE DCHK4( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
+ $ FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, NMAX,
+ $ A, AA, AS, B, BB, BS, C, CC, CS, CT, G )
+*
+* Tests DSYRK.
+*
+* Auxiliary routine for test program for Level 3 Blas.
+*
+* -- Written on 8-February-1989.
+* Jack Dongarra, Argonne National Laboratory.
+* Iain Duff, AERE Harwell.
+* Jeremy Du Croz, Numerical Algorithms Group Ltd.
+* Sven Hammarling, Numerical Algorithms Group Ltd.
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO
+ PARAMETER ( ZERO = 0.0D0 )
+* .. Scalar Arguments ..
+ DOUBLE PRECISION EPS, THRESH
+ INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA
+ LOGICAL FATAL, REWI, TRACE
+ CHARACTER*6 SNAME
+* .. Array Arguments ..
+ DOUBLE PRECISION A( NMAX, NMAX ), AA( NMAX*NMAX ), ALF( NALF ),
+ $ AS( NMAX*NMAX ), B( NMAX, NMAX ),
+ $ BB( NMAX*NMAX ), BET( NBET ), BS( NMAX*NMAX ),
+ $ C( NMAX, NMAX ), CC( NMAX*NMAX ),
+ $ CS( NMAX*NMAX ), CT( NMAX ), G( NMAX )
+ INTEGER IDIM( NIDIM )
+* .. Local Scalars ..
+ DOUBLE PRECISION ALPHA, ALS, BETA, BETS, ERR, ERRMAX
+ INTEGER I, IA, IB, ICT, ICU, IK, IN, J, JC, JJ, K, KS,
+ $ LAA, LCC, LDA, LDAS, LDC, LDCS, LJ, MA, N, NA,
+ $ NARGS, NC, NS
+ LOGICAL NULL, RESET, SAME, TRAN, UPPER
+ CHARACTER*1 TRANS, TRANSS, UPLO, UPLOS
+ CHARACTER*2 ICHU
+ CHARACTER*3 ICHT
+* .. Local Arrays ..
+ LOGICAL ISAME( 13 )
+* .. External Functions ..
+ LOGICAL LDE, LDERES
+ EXTERNAL LDE, LDERES
+* .. External Subroutines ..
+ EXTERNAL DMAKE, DMMCH, DSYRK
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* .. Scalars in Common ..
+ INTEGER INFOT, NOUTC
+ LOGICAL LERR, OK
+* .. Common blocks ..
+ COMMON /INFOC/INFOT, NOUTC, OK, LERR
+* .. Data statements ..
+ DATA ICHT/'NTC'/, ICHU/'UL'/
+* .. Executable Statements ..
+*
+ NARGS = 10
+ NC = 0
+ RESET = .TRUE.
+ ERRMAX = ZERO
+*
+ DO 100 IN = 1, NIDIM
+ N = IDIM( IN )
+* Set LDC to 1 more than minimum value if room.
+ LDC = N
+ IF( LDC.LT.NMAX )
+ $ LDC = LDC + 1
+* Skip tests if not enough room.
+ IF( LDC.GT.NMAX )
+ $ GO TO 100
+ LCC = LDC*N
+ NULL = N.LE.0
+*
+ DO 90 IK = 1, NIDIM
+ K = IDIM( IK )
+*
+ DO 80 ICT = 1, 3
+ TRANS = ICHT( ICT: ICT )
+ TRAN = TRANS.EQ.'T'.OR.TRANS.EQ.'C'
+ IF( TRAN )THEN
+ MA = K
+ NA = N
+ ELSE
+ MA = N
+ NA = K
+ END IF
+* Set LDA to 1 more than minimum value if room.
+ LDA = MA
+ IF( LDA.LT.NMAX )
+ $ LDA = LDA + 1
+* Skip tests if not enough room.
+ IF( LDA.GT.NMAX )
+ $ GO TO 80
+ LAA = LDA*NA
+*
+* Generate the matrix A.
+*
+ CALL DMAKE( 'GE', ' ', ' ', MA, NA, A, NMAX, AA, LDA,
+ $ RESET, ZERO )
+*
+ DO 70 ICU = 1, 2
+ UPLO = ICHU( ICU: ICU )
+ UPPER = UPLO.EQ.'U'
+*
+ DO 60 IA = 1, NALF
+ ALPHA = ALF( IA )
+*
+ DO 50 IB = 1, NBET
+ BETA = BET( IB )
+*
+* Generate the matrix C.
+*
+ CALL DMAKE( 'SY', UPLO, ' ', N, N, C, NMAX, CC,
+ $ LDC, RESET, ZERO )
+*
+ NC = NC + 1
+*
+* Save every datum before calling the subroutine.
+*
+ UPLOS = UPLO
+ TRANSS = TRANS
+ NS = N
+ KS = K
+ ALS = ALPHA
+ DO 10 I = 1, LAA
+ AS( I ) = AA( I )
+ 10 CONTINUE
+ LDAS = LDA
+ BETS = BETA
+ DO 20 I = 1, LCC
+ CS( I ) = CC( I )
+ 20 CONTINUE
+ LDCS = LDC
+*
+* Call the subroutine.
+*
+ IF( TRACE )
+ $ WRITE( NTRA, FMT = 9994 )NC, SNAME, UPLO,
+ $ TRANS, N, K, ALPHA, LDA, BETA, LDC
+ IF( REWI )
+ $ REWIND NTRA
+ CALL DSYRK( UPLO, TRANS, N, K, ALPHA, AA, LDA,
+ $ BETA, CC, LDC )
+*
+* Check if error-exit was taken incorrectly.
+*
+ IF( .NOT.OK )THEN
+ WRITE( NOUT, FMT = 9993 )
+ FATAL = .TRUE.
+ GO TO 120
+ END IF
+*
+* See what data changed inside subroutines.
+*
+ ISAME( 1 ) = UPLOS.EQ.UPLO
+ ISAME( 2 ) = TRANSS.EQ.TRANS
+ ISAME( 3 ) = NS.EQ.N
+ ISAME( 4 ) = KS.EQ.K
+ ISAME( 5 ) = ALS.EQ.ALPHA
+ ISAME( 6 ) = LDE( AS, AA, LAA )
+ ISAME( 7 ) = LDAS.EQ.LDA
+ ISAME( 8 ) = BETS.EQ.BETA
+ IF( NULL )THEN
+ ISAME( 9 ) = LDE( CS, CC, LCC )
+ ELSE
+ ISAME( 9 ) = LDERES( 'SY', UPLO, N, N, CS,
+ $ CC, LDC )
+ END IF
+ ISAME( 10 ) = LDCS.EQ.LDC
+*
+* If data was incorrectly changed, report and
+* return.
+*
+ SAME = .TRUE.
+ DO 30 I = 1, NARGS
+ SAME = SAME.AND.ISAME( I )
+ IF( .NOT.ISAME( I ) )
+ $ WRITE( NOUT, FMT = 9998 )I
+ 30 CONTINUE
+ IF( .NOT.SAME )THEN
+ FATAL = .TRUE.
+ GO TO 120
+ END IF
+*
+ IF( .NOT.NULL )THEN
+*
+* Check the result column by column.
+*
+ JC = 1
+ DO 40 J = 1, N
+ IF( UPPER )THEN
+ JJ = 1
+ LJ = J
+ ELSE
+ JJ = J
+ LJ = N - J + 1
+ END IF
+ IF( TRAN )THEN
+ CALL DMMCH( 'T', 'N', LJ, 1, K, ALPHA,
+ $ A( 1, JJ ), NMAX,
+ $ A( 1, J ), NMAX, BETA,
+ $ C( JJ, J ), NMAX, CT, G,
+ $ CC( JC ), LDC, EPS, ERR,
+ $ FATAL, NOUT, .TRUE. )
+ ELSE
+ CALL DMMCH( 'N', 'T', LJ, 1, K, ALPHA,
+ $ A( JJ, 1 ), NMAX,
+ $ A( J, 1 ), NMAX, BETA,
+ $ C( JJ, J ), NMAX, CT, G,
+ $ CC( JC ), LDC, EPS, ERR,
+ $ FATAL, NOUT, .TRUE. )
+ END IF
+ IF( UPPER )THEN
+ JC = JC + LDC
+ ELSE
+ JC = JC + LDC + 1
+ END IF
+ ERRMAX = MAX( ERRMAX, ERR )
+* If got really bad answer, report and
+* return.
+ IF( FATAL )
+ $ GO TO 110
+ 40 CONTINUE
+ END IF
+*
+ 50 CONTINUE
+*
+ 60 CONTINUE
+*
+ 70 CONTINUE
+*
+ 80 CONTINUE
+*
+ 90 CONTINUE
+*
+ 100 CONTINUE
+*
+* Report result.
+*
+ IF( ERRMAX.LT.THRESH )THEN
+ WRITE( NOUT, FMT = 9999 )SNAME, NC
+ ELSE
+ WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX
+ END IF
+ GO TO 130
+*
+ 110 CONTINUE
+ IF( N.GT.1 )
+ $ WRITE( NOUT, FMT = 9995 )J
+*
+ 120 CONTINUE
+ WRITE( NOUT, FMT = 9996 )SNAME
+ WRITE( NOUT, FMT = 9994 )NC, SNAME, UPLO, TRANS, N, K, ALPHA,
+ $ LDA, BETA, LDC
+*
+ 130 CONTINUE
+ RETURN
+*
+ 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL',
+ $ 'S)' )
+ 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
+ $ 'ANGED INCORRECTLY *******' )
+ 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C',
+ $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2,
+ $ ' - SUSPECT *******' )
+ 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' )
+ 9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 )
+ 9994 FORMAT( 1X, I6, ': ', A6, '(', 2( '''', A1, ''',' ), 2( I3, ',' ),
+ $ F4.1, ', A,', I3, ',', F4.1, ', C,', I3, ') .' )
+ 9993 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
+ $ '******' )
+*
+* End of DCHK4.
+*
+ END
+ SUBROUTINE DCHK5( SNAME, EPS, THRESH, NOUT, NTRA, TRACE, REWI,
+ $ FATAL, NIDIM, IDIM, NALF, ALF, NBET, BET, NMAX,
+ $ AB, AA, AS, BB, BS, C, CC, CS, CT, G, W )
+*
+* Tests DSYR2K.
+*
+* Auxiliary routine for test program for Level 3 Blas.
+*
+* -- Written on 8-February-1989.
+* Jack Dongarra, Argonne National Laboratory.
+* Iain Duff, AERE Harwell.
+* Jeremy Du Croz, Numerical Algorithms Group Ltd.
+* Sven Hammarling, Numerical Algorithms Group Ltd.
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO
+ PARAMETER ( ZERO = 0.0D0 )
+* .. Scalar Arguments ..
+ DOUBLE PRECISION EPS, THRESH
+ INTEGER NALF, NBET, NIDIM, NMAX, NOUT, NTRA
+ LOGICAL FATAL, REWI, TRACE
+ CHARACTER*6 SNAME
+* .. Array Arguments ..
+ DOUBLE PRECISION AA( NMAX*NMAX ), AB( 2*NMAX*NMAX ),
+ $ ALF( NALF ), AS( NMAX*NMAX ), BB( NMAX*NMAX ),
+ $ BET( NBET ), BS( NMAX*NMAX ), C( NMAX, NMAX ),
+ $ CC( NMAX*NMAX ), CS( NMAX*NMAX ), CT( NMAX ),
+ $ G( NMAX ), W( 2*NMAX )
+ INTEGER IDIM( NIDIM )
+* .. Local Scalars ..
+ DOUBLE PRECISION ALPHA, ALS, BETA, BETS, ERR, ERRMAX
+ INTEGER I, IA, IB, ICT, ICU, IK, IN, J, JC, JJ, JJAB,
+ $ K, KS, LAA, LBB, LCC, LDA, LDAS, LDB, LDBS,
+ $ LDC, LDCS, LJ, MA, N, NA, NARGS, NC, NS
+ LOGICAL NULL, RESET, SAME, TRAN, UPPER
+ CHARACTER*1 TRANS, TRANSS, UPLO, UPLOS
+ CHARACTER*2 ICHU
+ CHARACTER*3 ICHT
+* .. Local Arrays ..
+ LOGICAL ISAME( 13 )
+* .. External Functions ..
+ LOGICAL LDE, LDERES
+ EXTERNAL LDE, LDERES
+* .. External Subroutines ..
+ EXTERNAL DMAKE, DMMCH, DSYR2K
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* .. Scalars in Common ..
+ INTEGER INFOT, NOUTC
+ LOGICAL LERR, OK
+* .. Common blocks ..
+ COMMON /INFOC/INFOT, NOUTC, OK, LERR
+* .. Data statements ..
+ DATA ICHT/'NTC'/, ICHU/'UL'/
+* .. Executable Statements ..
+*
+ NARGS = 12
+ NC = 0
+ RESET = .TRUE.
+ ERRMAX = ZERO
+*
+ DO 130 IN = 1, NIDIM
+ N = IDIM( IN )
+* Set LDC to 1 more than minimum value if room.
+ LDC = N
+ IF( LDC.LT.NMAX )
+ $ LDC = LDC + 1
+* Skip tests if not enough room.
+ IF( LDC.GT.NMAX )
+ $ GO TO 130
+ LCC = LDC*N
+ NULL = N.LE.0
+*
+ DO 120 IK = 1, NIDIM
+ K = IDIM( IK )
+*
+ DO 110 ICT = 1, 3
+ TRANS = ICHT( ICT: ICT )
+ TRAN = TRANS.EQ.'T'.OR.TRANS.EQ.'C'
+ IF( TRAN )THEN
+ MA = K
+ NA = N
+ ELSE
+ MA = N
+ NA = K
+ END IF
+* Set LDA to 1 more than minimum value if room.
+ LDA = MA
+ IF( LDA.LT.NMAX )
+ $ LDA = LDA + 1
+* Skip tests if not enough room.
+ IF( LDA.GT.NMAX )
+ $ GO TO 110
+ LAA = LDA*NA
+*
+* Generate the matrix A.
+*
+ IF( TRAN )THEN
+ CALL DMAKE( 'GE', ' ', ' ', MA, NA, AB, 2*NMAX, AA,
+ $ LDA, RESET, ZERO )
+ ELSE
+ CALL DMAKE( 'GE', ' ', ' ', MA, NA, AB, NMAX, AA, LDA,
+ $ RESET, ZERO )
+ END IF
+*
+* Generate the matrix B.
+*
+ LDB = LDA
+ LBB = LAA
+ IF( TRAN )THEN
+ CALL DMAKE( 'GE', ' ', ' ', MA, NA, AB( K + 1 ),
+ $ 2*NMAX, BB, LDB, RESET, ZERO )
+ ELSE
+ CALL DMAKE( 'GE', ' ', ' ', MA, NA, AB( K*NMAX + 1 ),
+ $ NMAX, BB, LDB, RESET, ZERO )
+ END IF
+*
+ DO 100 ICU = 1, 2
+ UPLO = ICHU( ICU: ICU )
+ UPPER = UPLO.EQ.'U'
+*
+ DO 90 IA = 1, NALF
+ ALPHA = ALF( IA )
+*
+ DO 80 IB = 1, NBET
+ BETA = BET( IB )
+*
+* Generate the matrix C.
+*
+ CALL DMAKE( 'SY', UPLO, ' ', N, N, C, NMAX, CC,
+ $ LDC, RESET, ZERO )
+*
+ NC = NC + 1
+*
+* Save every datum before calling the subroutine.
+*
+ UPLOS = UPLO
+ TRANSS = TRANS
+ NS = N
+ KS = K
+ ALS = ALPHA
+ DO 10 I = 1, LAA
+ AS( I ) = AA( I )
+ 10 CONTINUE
+ LDAS = LDA
+ DO 20 I = 1, LBB
+ BS( I ) = BB( I )
+ 20 CONTINUE
+ LDBS = LDB
+ BETS = BETA
+ DO 30 I = 1, LCC
+ CS( I ) = CC( I )
+ 30 CONTINUE
+ LDCS = LDC
+*
+* Call the subroutine.
+*
+ IF( TRACE )
+ $ WRITE( NTRA, FMT = 9994 )NC, SNAME, UPLO,
+ $ TRANS, N, K, ALPHA, LDA, LDB, BETA, LDC
+ IF( REWI )
+ $ REWIND NTRA
+ CALL DSYR2K( UPLO, TRANS, N, K, ALPHA, AA, LDA,
+ $ BB, LDB, BETA, CC, LDC )
+*
+* Check if error-exit was taken incorrectly.
+*
+ IF( .NOT.OK )THEN
+ WRITE( NOUT, FMT = 9993 )
+ FATAL = .TRUE.
+ GO TO 150
+ END IF
+*
+* See what data changed inside subroutines.
+*
+ ISAME( 1 ) = UPLOS.EQ.UPLO
+ ISAME( 2 ) = TRANSS.EQ.TRANS
+ ISAME( 3 ) = NS.EQ.N
+ ISAME( 4 ) = KS.EQ.K
+ ISAME( 5 ) = ALS.EQ.ALPHA
+ ISAME( 6 ) = LDE( AS, AA, LAA )
+ ISAME( 7 ) = LDAS.EQ.LDA
+ ISAME( 8 ) = LDE( BS, BB, LBB )
+ ISAME( 9 ) = LDBS.EQ.LDB
+ ISAME( 10 ) = BETS.EQ.BETA
+ IF( NULL )THEN
+ ISAME( 11 ) = LDE( CS, CC, LCC )
+ ELSE
+ ISAME( 11 ) = LDERES( 'SY', UPLO, N, N, CS,
+ $ CC, LDC )
+ END IF
+ ISAME( 12 ) = LDCS.EQ.LDC
+*
+* If data was incorrectly changed, report and
+* return.
+*
+ SAME = .TRUE.
+ DO 40 I = 1, NARGS
+ SAME = SAME.AND.ISAME( I )
+ IF( .NOT.ISAME( I ) )
+ $ WRITE( NOUT, FMT = 9998 )I
+ 40 CONTINUE
+ IF( .NOT.SAME )THEN
+ FATAL = .TRUE.
+ GO TO 150
+ END IF
+*
+ IF( .NOT.NULL )THEN
+*
+* Check the result column by column.
+*
+ JJAB = 1
+ JC = 1
+ DO 70 J = 1, N
+ IF( UPPER )THEN
+ JJ = 1
+ LJ = J
+ ELSE
+ JJ = J
+ LJ = N - J + 1
+ END IF
+ IF( TRAN )THEN
+ DO 50 I = 1, K
+ W( I ) = AB( ( J - 1 )*2*NMAX + K +
+ $ I )
+ W( K + I ) = AB( ( J - 1 )*2*NMAX +
+ $ I )
+ 50 CONTINUE
+ CALL DMMCH( 'T', 'N', LJ, 1, 2*K,
+ $ ALPHA, AB( JJAB ), 2*NMAX,
+ $ W, 2*NMAX, BETA,
+ $ C( JJ, J ), NMAX, CT, G,
+ $ CC( JC ), LDC, EPS, ERR,
+ $ FATAL, NOUT, .TRUE. )
+ ELSE
+ DO 60 I = 1, K
+ W( I ) = AB( ( K + I - 1 )*NMAX +
+ $ J )
+ W( K + I ) = AB( ( I - 1 )*NMAX +
+ $ J )
+ 60 CONTINUE
+ CALL DMMCH( 'N', 'N', LJ, 1, 2*K,
+ $ ALPHA, AB( JJ ), NMAX, W,
+ $ 2*NMAX, BETA, C( JJ, J ),
+ $ NMAX, CT, G, CC( JC ), LDC,
+ $ EPS, ERR, FATAL, NOUT,
+ $ .TRUE. )
+ END IF
+ IF( UPPER )THEN
+ JC = JC + LDC
+ ELSE
+ JC = JC + LDC + 1
+ IF( TRAN )
+ $ JJAB = JJAB + 2*NMAX
+ END IF
+ ERRMAX = MAX( ERRMAX, ERR )
+* If got really bad answer, report and
+* return.
+ IF( FATAL )
+ $ GO TO 140
+ 70 CONTINUE
+ END IF
+*
+ 80 CONTINUE
+*
+ 90 CONTINUE
+*
+ 100 CONTINUE
+*
+ 110 CONTINUE
+*
+ 120 CONTINUE
+*
+ 130 CONTINUE
+*
+* Report result.
+*
+ IF( ERRMAX.LT.THRESH )THEN
+ WRITE( NOUT, FMT = 9999 )SNAME, NC
+ ELSE
+ WRITE( NOUT, FMT = 9997 )SNAME, NC, ERRMAX
+ END IF
+ GO TO 160
+*
+ 140 CONTINUE
+ IF( N.GT.1 )
+ $ WRITE( NOUT, FMT = 9995 )J
+*
+ 150 CONTINUE
+ WRITE( NOUT, FMT = 9996 )SNAME
+ WRITE( NOUT, FMT = 9994 )NC, SNAME, UPLO, TRANS, N, K, ALPHA,
+ $ LDA, LDB, BETA, LDC
+*
+ 160 CONTINUE
+ RETURN
+*
+ 9999 FORMAT( ' ', A6, ' PASSED THE COMPUTATIONAL TESTS (', I6, ' CALL',
+ $ 'S)' )
+ 9998 FORMAT( ' ******* FATAL ERROR - PARAMETER NUMBER ', I2, ' WAS CH',
+ $ 'ANGED INCORRECTLY *******' )
+ 9997 FORMAT( ' ', A6, ' COMPLETED THE COMPUTATIONAL TESTS (', I6, ' C',
+ $ 'ALLS)', /' ******* BUT WITH MAXIMUM TEST RATIO', F8.2,
+ $ ' - SUSPECT *******' )
+ 9996 FORMAT( ' ******* ', A6, ' FAILED ON CALL NUMBER:' )
+ 9995 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 )
+ 9994 FORMAT( 1X, I6, ': ', A6, '(', 2( '''', A1, ''',' ), 2( I3, ',' ),
+ $ F4.1, ', A,', I3, ', B,', I3, ',', F4.1, ', C,', I3, ') ',
+ $ ' .' )
+ 9993 FORMAT( ' ******* FATAL ERROR - ERROR-EXIT TAKEN ON VALID CALL *',
+ $ '******' )
+*
+* End of DCHK5.
+*
+ END
+ SUBROUTINE DCHKE( ISNUM, SRNAMT, NOUT )
+*
+* Tests the error exits from the Level 3 Blas.
+* Requires a special version of the error-handling routine XERBLA.
+* A, B and C should not need to be defined.
+*
+* Auxiliary routine for test program for Level 3 Blas.
+*
+* -- Written on 8-February-1989.
+* Jack Dongarra, Argonne National Laboratory.
+* Iain Duff, AERE Harwell.
+* Jeremy Du Croz, Numerical Algorithms Group Ltd.
+* Sven Hammarling, Numerical Algorithms Group Ltd.
+*
+* 3-19-92: Initialize ALPHA and BETA (eca)
+* 3-19-92: Fix argument 12 in calls to SSYMM with INFOT = 9 (eca)
+*
+* .. Scalar Arguments ..
+ INTEGER ISNUM, NOUT
+ CHARACTER*6 SRNAMT
+* .. Scalars in Common ..
+ INTEGER INFOT, NOUTC
+ LOGICAL LERR, OK
+* .. Parameters ..
+ DOUBLE PRECISION ONE, TWO
+ PARAMETER ( ONE = 1.0D0, TWO = 2.0D0 )
+* .. Local Scalars ..
+ DOUBLE PRECISION ALPHA, BETA
+* .. Local Arrays ..
+ DOUBLE PRECISION A( 2, 1 ), B( 2, 1 ), C( 2, 1 )
+* .. External Subroutines ..
+ EXTERNAL CHKXER, DGEMM, DSYMM, DSYR2K, DSYRK, DTRMM,
+ $ DTRSM
+* .. Common blocks ..
+ COMMON /INFOC/INFOT, NOUTC, OK, LERR
+* .. Executable Statements ..
+* OK is set to .FALSE. by the special version of XERBLA or by CHKXER
+* if anything is wrong.
+ OK = .TRUE.
+* LERR is set to .TRUE. by the special version of XERBLA each time
+* it is called, and is then tested and re-set by CHKXER.
+ LERR = .FALSE.
+*
+* Initialize ALPHA and BETA.
+*
+ ALPHA = ONE
+ BETA = TWO
+*
+ GO TO ( 10, 20, 30, 40, 50, 60 )ISNUM
+ 10 INFOT = 1
+ CALL DGEMM( '/', 'N', 0, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 1
+ CALL DGEMM( '/', 'T', 0, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL DGEMM( 'N', '/', 0, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL DGEMM( 'T', '/', 0, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL DGEMM( 'N', 'N', -1, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL DGEMM( 'N', 'T', -1, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL DGEMM( 'T', 'N', -1, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL DGEMM( 'T', 'T', -1, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL DGEMM( 'N', 'N', 0, -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL DGEMM( 'N', 'T', 0, -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL DGEMM( 'T', 'N', 0, -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL DGEMM( 'T', 'T', 0, -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 5
+ CALL DGEMM( 'N', 'N', 0, 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 5
+ CALL DGEMM( 'N', 'T', 0, 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 5
+ CALL DGEMM( 'T', 'N', 0, 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 5
+ CALL DGEMM( 'T', 'T', 0, 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 8
+ CALL DGEMM( 'N', 'N', 2, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 2 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 8
+ CALL DGEMM( 'N', 'T', 2, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 2 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 8
+ CALL DGEMM( 'T', 'N', 0, 0, 2, ALPHA, A, 1, B, 2, BETA, C, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 8
+ CALL DGEMM( 'T', 'T', 0, 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 10
+ CALL DGEMM( 'N', 'N', 0, 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 10
+ CALL DGEMM( 'T', 'N', 0, 0, 2, ALPHA, A, 2, B, 1, BETA, C, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 10
+ CALL DGEMM( 'N', 'T', 0, 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 10
+ CALL DGEMM( 'T', 'T', 0, 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 13
+ CALL DGEMM( 'N', 'N', 2, 0, 0, ALPHA, A, 2, B, 1, BETA, C, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 13
+ CALL DGEMM( 'N', 'T', 2, 0, 0, ALPHA, A, 2, B, 1, BETA, C, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 13
+ CALL DGEMM( 'T', 'N', 2, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 13
+ CALL DGEMM( 'T', 'T', 2, 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ GO TO 70
+ 20 INFOT = 1
+ CALL DSYMM( '/', 'U', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL DSYMM( 'L', '/', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL DSYMM( 'L', 'U', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL DSYMM( 'R', 'U', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL DSYMM( 'L', 'L', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL DSYMM( 'R', 'L', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL DSYMM( 'L', 'U', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL DSYMM( 'R', 'U', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL DSYMM( 'L', 'L', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL DSYMM( 'R', 'L', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 7
+ CALL DSYMM( 'L', 'U', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 2 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 7
+ CALL DSYMM( 'R', 'U', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 7
+ CALL DSYMM( 'L', 'L', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 2 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 7
+ CALL DSYMM( 'R', 'L', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 9
+ CALL DSYMM( 'L', 'U', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 2 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 9
+ CALL DSYMM( 'R', 'U', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 2 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 9
+ CALL DSYMM( 'L', 'L', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 2 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 9
+ CALL DSYMM( 'R', 'L', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 2 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 12
+ CALL DSYMM( 'L', 'U', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 12
+ CALL DSYMM( 'R', 'U', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 12
+ CALL DSYMM( 'L', 'L', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 12
+ CALL DSYMM( 'R', 'L', 2, 0, ALPHA, A, 1, B, 2, BETA, C, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ GO TO 70
+ 30 INFOT = 1
+ CALL DTRMM( '/', 'U', 'N', 'N', 0, 0, ALPHA, A, 1, B, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL DTRMM( 'L', '/', 'N', 'N', 0, 0, ALPHA, A, 1, B, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL DTRMM( 'L', 'U', '/', 'N', 0, 0, ALPHA, A, 1, B, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL DTRMM( 'L', 'U', 'N', '/', 0, 0, ALPHA, A, 1, B, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 5
+ CALL DTRMM( 'L', 'U', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 5
+ CALL DTRMM( 'L', 'U', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 5
+ CALL DTRMM( 'R', 'U', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 5
+ CALL DTRMM( 'R', 'U', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 5
+ CALL DTRMM( 'L', 'L', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 5
+ CALL DTRMM( 'L', 'L', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 5
+ CALL DTRMM( 'R', 'L', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 5
+ CALL DTRMM( 'R', 'L', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 6
+ CALL DTRMM( 'L', 'U', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 6
+ CALL DTRMM( 'L', 'U', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 6
+ CALL DTRMM( 'R', 'U', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 6
+ CALL DTRMM( 'R', 'U', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 6
+ CALL DTRMM( 'L', 'L', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 6
+ CALL DTRMM( 'L', 'L', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 6
+ CALL DTRMM( 'R', 'L', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 6
+ CALL DTRMM( 'R', 'L', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 9
+ CALL DTRMM( 'L', 'U', 'N', 'N', 2, 0, ALPHA, A, 1, B, 2 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 9
+ CALL DTRMM( 'L', 'U', 'T', 'N', 2, 0, ALPHA, A, 1, B, 2 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 9
+ CALL DTRMM( 'R', 'U', 'N', 'N', 0, 2, ALPHA, A, 1, B, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 9
+ CALL DTRMM( 'R', 'U', 'T', 'N', 0, 2, ALPHA, A, 1, B, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 9
+ CALL DTRMM( 'L', 'L', 'N', 'N', 2, 0, ALPHA, A, 1, B, 2 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 9
+ CALL DTRMM( 'L', 'L', 'T', 'N', 2, 0, ALPHA, A, 1, B, 2 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 9
+ CALL DTRMM( 'R', 'L', 'N', 'N', 0, 2, ALPHA, A, 1, B, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 9
+ CALL DTRMM( 'R', 'L', 'T', 'N', 0, 2, ALPHA, A, 1, B, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 11
+ CALL DTRMM( 'L', 'U', 'N', 'N', 2, 0, ALPHA, A, 2, B, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 11
+ CALL DTRMM( 'L', 'U', 'T', 'N', 2, 0, ALPHA, A, 2, B, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 11
+ CALL DTRMM( 'R', 'U', 'N', 'N', 2, 0, ALPHA, A, 1, B, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 11
+ CALL DTRMM( 'R', 'U', 'T', 'N', 2, 0, ALPHA, A, 1, B, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 11
+ CALL DTRMM( 'L', 'L', 'N', 'N', 2, 0, ALPHA, A, 2, B, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 11
+ CALL DTRMM( 'L', 'L', 'T', 'N', 2, 0, ALPHA, A, 2, B, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 11
+ CALL DTRMM( 'R', 'L', 'N', 'N', 2, 0, ALPHA, A, 1, B, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 11
+ CALL DTRMM( 'R', 'L', 'T', 'N', 2, 0, ALPHA, A, 1, B, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ GO TO 70
+ 40 INFOT = 1
+ CALL DTRSM( '/', 'U', 'N', 'N', 0, 0, ALPHA, A, 1, B, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL DTRSM( 'L', '/', 'N', 'N', 0, 0, ALPHA, A, 1, B, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL DTRSM( 'L', 'U', '/', 'N', 0, 0, ALPHA, A, 1, B, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL DTRSM( 'L', 'U', 'N', '/', 0, 0, ALPHA, A, 1, B, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 5
+ CALL DTRSM( 'L', 'U', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 5
+ CALL DTRSM( 'L', 'U', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 5
+ CALL DTRSM( 'R', 'U', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 5
+ CALL DTRSM( 'R', 'U', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 5
+ CALL DTRSM( 'L', 'L', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 5
+ CALL DTRSM( 'L', 'L', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 5
+ CALL DTRSM( 'R', 'L', 'N', 'N', -1, 0, ALPHA, A, 1, B, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 5
+ CALL DTRSM( 'R', 'L', 'T', 'N', -1, 0, ALPHA, A, 1, B, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 6
+ CALL DTRSM( 'L', 'U', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 6
+ CALL DTRSM( 'L', 'U', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 6
+ CALL DTRSM( 'R', 'U', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 6
+ CALL DTRSM( 'R', 'U', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 6
+ CALL DTRSM( 'L', 'L', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 6
+ CALL DTRSM( 'L', 'L', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 6
+ CALL DTRSM( 'R', 'L', 'N', 'N', 0, -1, ALPHA, A, 1, B, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 6
+ CALL DTRSM( 'R', 'L', 'T', 'N', 0, -1, ALPHA, A, 1, B, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 9
+ CALL DTRSM( 'L', 'U', 'N', 'N', 2, 0, ALPHA, A, 1, B, 2 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 9
+ CALL DTRSM( 'L', 'U', 'T', 'N', 2, 0, ALPHA, A, 1, B, 2 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 9
+ CALL DTRSM( 'R', 'U', 'N', 'N', 0, 2, ALPHA, A, 1, B, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 9
+ CALL DTRSM( 'R', 'U', 'T', 'N', 0, 2, ALPHA, A, 1, B, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 9
+ CALL DTRSM( 'L', 'L', 'N', 'N', 2, 0, ALPHA, A, 1, B, 2 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 9
+ CALL DTRSM( 'L', 'L', 'T', 'N', 2, 0, ALPHA, A, 1, B, 2 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 9
+ CALL DTRSM( 'R', 'L', 'N', 'N', 0, 2, ALPHA, A, 1, B, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 9
+ CALL DTRSM( 'R', 'L', 'T', 'N', 0, 2, ALPHA, A, 1, B, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 11
+ CALL DTRSM( 'L', 'U', 'N', 'N', 2, 0, ALPHA, A, 2, B, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 11
+ CALL DTRSM( 'L', 'U', 'T', 'N', 2, 0, ALPHA, A, 2, B, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 11
+ CALL DTRSM( 'R', 'U', 'N', 'N', 2, 0, ALPHA, A, 1, B, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 11
+ CALL DTRSM( 'R', 'U', 'T', 'N', 2, 0, ALPHA, A, 1, B, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 11
+ CALL DTRSM( 'L', 'L', 'N', 'N', 2, 0, ALPHA, A, 2, B, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 11
+ CALL DTRSM( 'L', 'L', 'T', 'N', 2, 0, ALPHA, A, 2, B, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 11
+ CALL DTRSM( 'R', 'L', 'N', 'N', 2, 0, ALPHA, A, 1, B, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 11
+ CALL DTRSM( 'R', 'L', 'T', 'N', 2, 0, ALPHA, A, 1, B, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ GO TO 70
+ 50 INFOT = 1
+ CALL DSYRK( '/', 'N', 0, 0, ALPHA, A, 1, BETA, C, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL DSYRK( 'U', '/', 0, 0, ALPHA, A, 1, BETA, C, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL DSYRK( 'U', 'N', -1, 0, ALPHA, A, 1, BETA, C, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL DSYRK( 'U', 'T', -1, 0, ALPHA, A, 1, BETA, C, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL DSYRK( 'L', 'N', -1, 0, ALPHA, A, 1, BETA, C, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL DSYRK( 'L', 'T', -1, 0, ALPHA, A, 1, BETA, C, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL DSYRK( 'U', 'N', 0, -1, ALPHA, A, 1, BETA, C, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL DSYRK( 'U', 'T', 0, -1, ALPHA, A, 1, BETA, C, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL DSYRK( 'L', 'N', 0, -1, ALPHA, A, 1, BETA, C, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL DSYRK( 'L', 'T', 0, -1, ALPHA, A, 1, BETA, C, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 7
+ CALL DSYRK( 'U', 'N', 2, 0, ALPHA, A, 1, BETA, C, 2 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 7
+ CALL DSYRK( 'U', 'T', 0, 2, ALPHA, A, 1, BETA, C, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 7
+ CALL DSYRK( 'L', 'N', 2, 0, ALPHA, A, 1, BETA, C, 2 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 7
+ CALL DSYRK( 'L', 'T', 0, 2, ALPHA, A, 1, BETA, C, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 10
+ CALL DSYRK( 'U', 'N', 2, 0, ALPHA, A, 2, BETA, C, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 10
+ CALL DSYRK( 'U', 'T', 2, 0, ALPHA, A, 1, BETA, C, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 10
+ CALL DSYRK( 'L', 'N', 2, 0, ALPHA, A, 2, BETA, C, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 10
+ CALL DSYRK( 'L', 'T', 2, 0, ALPHA, A, 1, BETA, C, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ GO TO 70
+ 60 INFOT = 1
+ CALL DSYR2K( '/', 'N', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL DSYR2K( 'U', '/', 0, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL DSYR2K( 'U', 'N', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL DSYR2K( 'U', 'T', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL DSYR2K( 'L', 'N', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL DSYR2K( 'L', 'T', -1, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL DSYR2K( 'U', 'N', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL DSYR2K( 'U', 'T', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL DSYR2K( 'L', 'N', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL DSYR2K( 'L', 'T', 0, -1, ALPHA, A, 1, B, 1, BETA, C, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 7
+ CALL DSYR2K( 'U', 'N', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 2 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 7
+ CALL DSYR2K( 'U', 'T', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 7
+ CALL DSYR2K( 'L', 'N', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 2 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 7
+ CALL DSYR2K( 'L', 'T', 0, 2, ALPHA, A, 1, B, 1, BETA, C, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 9
+ CALL DSYR2K( 'U', 'N', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 2 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 9
+ CALL DSYR2K( 'U', 'T', 0, 2, ALPHA, A, 2, B, 1, BETA, C, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 9
+ CALL DSYR2K( 'L', 'N', 2, 0, ALPHA, A, 2, B, 1, BETA, C, 2 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 9
+ CALL DSYR2K( 'L', 'T', 0, 2, ALPHA, A, 2, B, 1, BETA, C, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 12
+ CALL DSYR2K( 'U', 'N', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 12
+ CALL DSYR2K( 'U', 'T', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 12
+ CALL DSYR2K( 'L', 'N', 2, 0, ALPHA, A, 2, B, 2, BETA, C, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+ INFOT = 12
+ CALL DSYR2K( 'L', 'T', 2, 0, ALPHA, A, 1, B, 1, BETA, C, 1 )
+ CALL CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+*
+ 70 IF( OK )THEN
+ WRITE( NOUT, FMT = 9999 )SRNAMT
+ ELSE
+ WRITE( NOUT, FMT = 9998 )SRNAMT
+ END IF
+ RETURN
+*
+ 9999 FORMAT( ' ', A6, ' PASSED THE TESTS OF ERROR-EXITS' )
+ 9998 FORMAT( ' ******* ', A6, ' FAILED THE TESTS OF ERROR-EXITS *****',
+ $ '**' )
+*
+* End of DCHKE.
+*
+ END
+ SUBROUTINE DMAKE( TYPE, UPLO, DIAG, M, N, A, NMAX, AA, LDA, RESET,
+ $ TRANSL )
+*
+* Generates values for an M by N matrix A.
+* Stores the values in the array AA in the data structure required
+* by the routine, with unwanted elements set to rogue value.
+*
+* TYPE is 'GE', 'SY' or 'TR'.
+*
+* Auxiliary routine for test program for Level 3 Blas.
+*
+* -- Written on 8-February-1989.
+* Jack Dongarra, Argonne National Laboratory.
+* Iain Duff, AERE Harwell.
+* Jeremy Du Croz, Numerical Algorithms Group Ltd.
+* Sven Hammarling, Numerical Algorithms Group Ltd.
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
+ DOUBLE PRECISION ROGUE
+ PARAMETER ( ROGUE = -1.0D10 )
+* .. Scalar Arguments ..
+ DOUBLE PRECISION TRANSL
+ INTEGER LDA, M, N, NMAX
+ LOGICAL RESET
+ CHARACTER*1 DIAG, UPLO
+ CHARACTER*2 TYPE
+* .. Array Arguments ..
+ DOUBLE PRECISION A( NMAX, * ), AA( * )
+* .. Local Scalars ..
+ INTEGER I, IBEG, IEND, J
+ LOGICAL GEN, LOWER, SYM, TRI, UNIT, UPPER
+* .. External Functions ..
+ DOUBLE PRECISION DBEG
+ EXTERNAL DBEG
+* .. Executable Statements ..
+ GEN = TYPE.EQ.'GE'
+ SYM = TYPE.EQ.'SY'
+ TRI = TYPE.EQ.'TR'
+ UPPER = ( SYM.OR.TRI ).AND.UPLO.EQ.'U'
+ LOWER = ( SYM.OR.TRI ).AND.UPLO.EQ.'L'
+ UNIT = TRI.AND.DIAG.EQ.'U'
+*
+* Generate data in array A.
+*
+ DO 20 J = 1, N
+ DO 10 I = 1, M
+ IF( GEN.OR.( UPPER.AND.I.LE.J ).OR.( LOWER.AND.I.GE.J ) )
+ $ THEN
+ A( I, J ) = DBEG( RESET ) + TRANSL
+ IF( I.NE.J )THEN
+* Set some elements to zero
+ IF( N.GT.3.AND.J.EQ.N/2 )
+ $ A( I, J ) = ZERO
+ IF( SYM )THEN
+ A( J, I ) = A( I, J )
+ ELSE IF( TRI )THEN
+ A( J, I ) = ZERO
+ END IF
+ END IF
+ END IF
+ 10 CONTINUE
+ IF( TRI )
+ $ A( J, J ) = A( J, J ) + ONE
+ IF( UNIT )
+ $ A( J, J ) = ONE
+ 20 CONTINUE
+*
+* Store elements in array AS in data structure required by routine.
+*
+ IF( TYPE.EQ.'GE' )THEN
+ DO 50 J = 1, N
+ DO 30 I = 1, M
+ AA( I + ( J - 1 )*LDA ) = A( I, J )
+ 30 CONTINUE
+ DO 40 I = M + 1, LDA
+ AA( I + ( J - 1 )*LDA ) = ROGUE
+ 40 CONTINUE
+ 50 CONTINUE
+ ELSE IF( TYPE.EQ.'SY'.OR.TYPE.EQ.'TR' )THEN
+ DO 90 J = 1, N
+ IF( UPPER )THEN
+ IBEG = 1
+ IF( UNIT )THEN
+ IEND = J - 1
+ ELSE
+ IEND = J
+ END IF
+ ELSE
+ IF( UNIT )THEN
+ IBEG = J + 1
+ ELSE
+ IBEG = J
+ END IF
+ IEND = N
+ END IF
+ DO 60 I = 1, IBEG - 1
+ AA( I + ( J - 1 )*LDA ) = ROGUE
+ 60 CONTINUE
+ DO 70 I = IBEG, IEND
+ AA( I + ( J - 1 )*LDA ) = A( I, J )
+ 70 CONTINUE
+ DO 80 I = IEND + 1, LDA
+ AA( I + ( J - 1 )*LDA ) = ROGUE
+ 80 CONTINUE
+ 90 CONTINUE
+ END IF
+ RETURN
+*
+* End of DMAKE.
+*
+ END
+ SUBROUTINE DMMCH( TRANSA, TRANSB, M, N, KK, ALPHA, A, LDA, B, LDB,
+ $ BETA, C, LDC, CT, G, CC, LDCC, EPS, ERR, FATAL,
+ $ NOUT, MV )
+*
+* Checks the results of the computational tests.
+*
+* Auxiliary routine for test program for Level 3 Blas.
+*
+* -- Written on 8-February-1989.
+* Jack Dongarra, Argonne National Laboratory.
+* Iain Duff, AERE Harwell.
+* Jeremy Du Croz, Numerical Algorithms Group Ltd.
+* Sven Hammarling, Numerical Algorithms Group Ltd.
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
+* .. Scalar Arguments ..
+ DOUBLE PRECISION ALPHA, BETA, EPS, ERR
+ INTEGER KK, LDA, LDB, LDC, LDCC, M, N, NOUT
+ LOGICAL FATAL, MV
+ CHARACTER*1 TRANSA, TRANSB
+* .. Array Arguments ..
+ DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ),
+ $ CC( LDCC, * ), CT( * ), G( * )
+* .. Local Scalars ..
+ DOUBLE PRECISION ERRI
+ INTEGER I, J, K
+ LOGICAL TRANA, TRANB
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, SQRT
+* .. Executable Statements ..
+ TRANA = TRANSA.EQ.'T'.OR.TRANSA.EQ.'C'
+ TRANB = TRANSB.EQ.'T'.OR.TRANSB.EQ.'C'
+*
+* Compute expected result, one column at a time, in CT using data
+* in A, B and C.
+* Compute gauges in G.
+*
+ DO 120 J = 1, N
+*
+ DO 10 I = 1, M
+ CT( I ) = ZERO
+ G( I ) = ZERO
+ 10 CONTINUE
+ IF( .NOT.TRANA.AND..NOT.TRANB )THEN
+ DO 30 K = 1, KK
+ DO 20 I = 1, M
+ CT( I ) = CT( I ) + A( I, K )*B( K, J )
+ G( I ) = G( I ) + ABS( A( I, K ) )*ABS( B( K, J ) )
+ 20 CONTINUE
+ 30 CONTINUE
+ ELSE IF( TRANA.AND..NOT.TRANB )THEN
+ DO 50 K = 1, KK
+ DO 40 I = 1, M
+ CT( I ) = CT( I ) + A( K, I )*B( K, J )
+ G( I ) = G( I ) + ABS( A( K, I ) )*ABS( B( K, J ) )
+ 40 CONTINUE
+ 50 CONTINUE
+ ELSE IF( .NOT.TRANA.AND.TRANB )THEN
+ DO 70 K = 1, KK
+ DO 60 I = 1, M
+ CT( I ) = CT( I ) + A( I, K )*B( J, K )
+ G( I ) = G( I ) + ABS( A( I, K ) )*ABS( B( J, K ) )
+ 60 CONTINUE
+ 70 CONTINUE
+ ELSE IF( TRANA.AND.TRANB )THEN
+ DO 90 K = 1, KK
+ DO 80 I = 1, M
+ CT( I ) = CT( I ) + A( K, I )*B( J, K )
+ G( I ) = G( I ) + ABS( A( K, I ) )*ABS( B( J, K ) )
+ 80 CONTINUE
+ 90 CONTINUE
+ END IF
+ DO 100 I = 1, M
+ CT( I ) = ALPHA*CT( I ) + BETA*C( I, J )
+ G( I ) = ABS( ALPHA )*G( I ) + ABS( BETA )*ABS( C( I, J ) )
+ 100 CONTINUE
+*
+* Compute the error ratio for this result.
+*
+ ERR = ZERO
+ DO 110 I = 1, M
+ ERRI = ABS( CT( I ) - CC( I, J ) )/EPS
+ IF( G( I ).NE.ZERO )
+ $ ERRI = ERRI/G( I )
+ ERR = MAX( ERR, ERRI )
+ IF( ERR*SQRT( EPS ).GE.ONE )
+ $ GO TO 130
+ 110 CONTINUE
+*
+ 120 CONTINUE
+*
+* If the loop completes, all results are at least half accurate.
+ GO TO 150
+*
+* Report fatal error.
+*
+ 130 FATAL = .TRUE.
+ WRITE( NOUT, FMT = 9999 )
+ DO 140 I = 1, M
+ IF( MV )THEN
+ WRITE( NOUT, FMT = 9998 )I, CT( I ), CC( I, J )
+ ELSE
+ WRITE( NOUT, FMT = 9998 )I, CC( I, J ), CT( I )
+ END IF
+ 140 CONTINUE
+ IF( N.GT.1 )
+ $ WRITE( NOUT, FMT = 9997 )J
+*
+ 150 CONTINUE
+ RETURN
+*
+ 9999 FORMAT( ' ******* FATAL ERROR - COMPUTED RESULT IS LESS THAN HAL',
+ $ 'F ACCURATE *******', /' EXPECTED RESULT COMPU',
+ $ 'TED RESULT' )
+ 9998 FORMAT( 1X, I7, 2G18.6 )
+ 9997 FORMAT( ' THESE ARE THE RESULTS FOR COLUMN ', I3 )
+*
+* End of DMMCH.
+*
+ END
+ LOGICAL FUNCTION LDE( RI, RJ, LR )
+*
+* Tests if two arrays are identical.
+*
+* Auxiliary routine for test program for Level 3 Blas.
+*
+* -- Written on 8-February-1989.
+* Jack Dongarra, Argonne National Laboratory.
+* Iain Duff, AERE Harwell.
+* Jeremy Du Croz, Numerical Algorithms Group Ltd.
+* Sven Hammarling, Numerical Algorithms Group Ltd.
+*
+* .. Scalar Arguments ..
+ INTEGER LR
+* .. Array Arguments ..
+ DOUBLE PRECISION RI( * ), RJ( * )
+* .. Local Scalars ..
+ INTEGER I
+* .. Executable Statements ..
+ DO 10 I = 1, LR
+ IF( RI( I ).NE.RJ( I ) )
+ $ GO TO 20
+ 10 CONTINUE
+ LDE = .TRUE.
+ GO TO 30
+ 20 CONTINUE
+ LDE = .FALSE.
+ 30 RETURN
+*
+* End of LDE.
+*
+ END
+ LOGICAL FUNCTION LDERES( TYPE, UPLO, M, N, AA, AS, LDA )
+*
+* Tests if selected elements in two arrays are equal.
+*
+* TYPE is 'GE' or 'SY'.
+*
+* Auxiliary routine for test program for Level 3 Blas.
+*
+* -- Written on 8-February-1989.
+* Jack Dongarra, Argonne National Laboratory.
+* Iain Duff, AERE Harwell.
+* Jeremy Du Croz, Numerical Algorithms Group Ltd.
+* Sven Hammarling, Numerical Algorithms Group Ltd.
+*
+* .. Scalar Arguments ..
+ INTEGER LDA, M, N
+ CHARACTER*1 UPLO
+ CHARACTER*2 TYPE
+* .. Array Arguments ..
+ DOUBLE PRECISION AA( LDA, * ), AS( LDA, * )
+* .. Local Scalars ..
+ INTEGER I, IBEG, IEND, J
+ LOGICAL UPPER
+* .. Executable Statements ..
+ UPPER = UPLO.EQ.'U'
+ IF( TYPE.EQ.'GE' )THEN
+ DO 20 J = 1, N
+ DO 10 I = M + 1, LDA
+ IF( AA( I, J ).NE.AS( I, J ) )
+ $ GO TO 70
+ 10 CONTINUE
+ 20 CONTINUE
+ ELSE IF( TYPE.EQ.'SY' )THEN
+ DO 50 J = 1, N
+ IF( UPPER )THEN
+ IBEG = 1
+ IEND = J
+ ELSE
+ IBEG = J
+ IEND = N
+ END IF
+ DO 30 I = 1, IBEG - 1
+ IF( AA( I, J ).NE.AS( I, J ) )
+ $ GO TO 70
+ 30 CONTINUE
+ DO 40 I = IEND + 1, LDA
+ IF( AA( I, J ).NE.AS( I, J ) )
+ $ GO TO 70
+ 40 CONTINUE
+ 50 CONTINUE
+ END IF
+*
+ 60 CONTINUE
+ LDERES = .TRUE.
+ GO TO 80
+ 70 CONTINUE
+ LDERES = .FALSE.
+ 80 RETURN
+*
+* End of LDERES.
+*
+ END
+ DOUBLE PRECISION FUNCTION DBEG( RESET )
+*
+* Generates random numbers uniformly distributed between -0.5 and 0.5.
+*
+* Auxiliary routine for test program for Level 3 Blas.
+*
+* -- Written on 8-February-1989.
+* Jack Dongarra, Argonne National Laboratory.
+* Iain Duff, AERE Harwell.
+* Jeremy Du Croz, Numerical Algorithms Group Ltd.
+* Sven Hammarling, Numerical Algorithms Group Ltd.
+*
+* .. Scalar Arguments ..
+ LOGICAL RESET
+* .. Local Scalars ..
+ INTEGER I, IC, MI
+* .. Save statement ..
+ SAVE I, IC, MI
+* .. Executable Statements ..
+ IF( RESET )THEN
+* Initialize local variables.
+ MI = 891
+ I = 7
+ IC = 0
+ RESET = .FALSE.
+ END IF
+*
+* The sequence of values of I is bounded between 1 and 999.
+* If initial I = 1,2,3,6,7 or 9, the period will be 50.
+* If initial I = 4 or 8, the period will be 25.
+* If initial I = 5, the period will be 10.
+* IC is used to break up the period by skipping 1 value of I in 6.
+*
+ IC = IC + 1
+ 10 I = I*MI
+ I = I - 1000*( I/1000 )
+ IF( IC.GE.5 )THEN
+ IC = 0
+ GO TO 10
+ END IF
+ DBEG = ( I - 500 )/1001.0D0
+ RETURN
+*
+* End of DBEG.
+*
+ END
+ DOUBLE PRECISION FUNCTION DDIFF( X, Y )
+*
+* Auxiliary routine for test program for Level 3 Blas.
+*
+* -- Written on 8-February-1989.
+* Jack Dongarra, Argonne National Laboratory.
+* Iain Duff, AERE Harwell.
+* Jeremy Du Croz, Numerical Algorithms Group Ltd.
+* Sven Hammarling, Numerical Algorithms Group Ltd.
+*
+* .. Scalar Arguments ..
+ DOUBLE PRECISION X, Y
+* .. Executable Statements ..
+ DDIFF = X - Y
+ RETURN
+*
+* End of DDIFF.
+*
+ END
+ SUBROUTINE CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+*
+* Tests whether XERBLA has detected an error when it should.
+*
+* Auxiliary routine for test program for Level 3 Blas.
+*
+* -- Written on 8-February-1989.
+* Jack Dongarra, Argonne National Laboratory.
+* Iain Duff, AERE Harwell.
+* Jeremy Du Croz, Numerical Algorithms Group Ltd.
+* Sven Hammarling, Numerical Algorithms Group Ltd.
+*
+* .. Scalar Arguments ..
+ INTEGER INFOT, NOUT
+ LOGICAL LERR, OK
+ CHARACTER*6 SRNAMT
+* .. Executable Statements ..
+ IF( .NOT.LERR )THEN
+ WRITE( NOUT, FMT = 9999 )INFOT, SRNAMT
+ OK = .FALSE.
+ END IF
+ LERR = .FALSE.
+ RETURN
+*
+ 9999 FORMAT( ' ***** ILLEGAL VALUE OF PARAMETER NUMBER ', I2, ' NOT D',
+ $ 'ETECTED BY ', A6, ' *****' )
+*
+* End of CHKXER.
+*
+ END
diff --git a/jlapack-3.1.1/src/testing/blas3/dblat3.in b/jlapack-3.1.1/src/testing/blas3/dblat3.in
new file mode 100644
index 0000000..0098f3e
--- /dev/null
+++ b/jlapack-3.1.1/src/testing/blas3/dblat3.in
@@ -0,0 +1,20 @@
+'dblat3.out' NAME OF SUMMARY OUTPUT FILE
+6 UNIT NUMBER OF SUMMARY FILE
+'DBLAT3.SNAP' NAME OF SNAPSHOT OUTPUT FILE
+-1 UNIT NUMBER OF SNAPSHOT FILE (NOT USED IF .LT. 0)
+F LOGICAL FLAG, T TO REWIND SNAPSHOT FILE AFTER EACH RECORD.
+F LOGICAL FLAG, T TO STOP ON FAILURES.
+T LOGICAL FLAG, T TO TEST ERROR EXITS.
+16.0 THRESHOLD VALUE OF TEST RATIO
+6 NUMBER OF VALUES OF N
+0 1 2 3 5 9 VALUES OF N
+3 NUMBER OF VALUES OF ALPHA
+0.0 1.0 0.7 VALUES OF ALPHA
+3 NUMBER OF VALUES OF BETA
+0.0 1.0 1.3 VALUES OF BETA
+DGEMM T PUT F FOR NO TEST. SAME COLUMNS.
+DSYMM T PUT F FOR NO TEST. SAME COLUMNS.
+DTRMM T PUT F FOR NO TEST. SAME COLUMNS.
+DTRSM T PUT F FOR NO TEST. SAME COLUMNS.
+DSYRK T PUT F FOR NO TEST. SAME COLUMNS.
+DSYR2K T PUT F FOR NO TEST. SAME COLUMNS.
diff --git a/jlapack-3.1.1/src/testing/blas3/xerbla.f b/jlapack-3.1.1/src/testing/blas3/xerbla.f
new file mode 100644
index 0000000..a46b3e9
--- /dev/null
+++ b/jlapack-3.1.1/src/testing/blas3/xerbla.f
@@ -0,0 +1,60 @@
+ SUBROUTINE XERBLA( SRNAME, INFO )
+*
+* f2j NOTE: this is compiled separately from dblat2.f because
+* it needs to be in package org.netlib.err while the rest of
+* dblat2.f routines should be in org.netlib.blas.testing.
+*
+* This is a special version of XERBLA to be used only as part of
+* the test program for testing error exits from the Level 3 BLAS
+* routines.
+*
+* XERBLA is an error handler for the Level 3 BLAS routines.
+*
+* It is called by the Level 3 BLAS routines if an input parameter is
+* invalid.
+*
+* Auxiliary routine for test program for Level 3 Blas.
+*
+* -- Written on 8-February-1989.
+* Jack Dongarra, Argonne National Laboratory.
+* Iain Duff, AERE Harwell.
+* Jeremy Du Croz, Numerical Algorithms Group Ltd.
+* Sven Hammarling, Numerical Algorithms Group Ltd.
+*
+* .. Scalar Arguments ..
+ INTEGER INFO
+ CHARACTER*6 SRNAME
+* .. Scalars in Common ..
+ INTEGER INFOT, NOUT
+ LOGICAL LERR, OK
+ CHARACTER*6 SRNAMT
+* .. Common blocks ..
+ COMMON /INFOC/INFOT, NOUT, OK, LERR
+ COMMON /SRNAMC/SRNAMT
+* .. Executable Statements ..
+ LERR = .TRUE.
+ IF( INFO.NE.INFOT )THEN
+ IF( INFOT.NE.0 )THEN
+ WRITE( NOUT, FMT = 9999 )INFO, INFOT
+ ELSE
+ WRITE( NOUT, FMT = 9997 )INFO
+ END IF
+ OK = .FALSE.
+ END IF
+ IF( SRNAME.NE.SRNAMT )THEN
+ WRITE( NOUT, FMT = 9998 )SRNAME, SRNAMT
+ OK = .FALSE.
+ END IF
+ RETURN
+*
+ 9999 FORMAT( ' ******* XERBLA WAS CALLED WITH INFO = ', I6, ' INSTEAD',
+ $ ' OF ', I2, ' *******' )
+ 9998 FORMAT( ' ******* XERBLA WAS CALLED WITH SRNAME = ', A6, ' INSTE',
+ $ 'AD OF ', A6, ' *******' )
+ 9997 FORMAT( ' ******* XERBLA WAS CALLED WITH INFO = ', I6,
+ $ ' *******' )
+*
+* End of XERBLA
+*
+ END
+
diff --git a/jlapack-3.1.1/src/testing/eig/Makefile b/jlapack-3.1.1/src/testing/eig/Makefile
new file mode 100644
index 0000000..b2f8351
--- /dev/null
+++ b/jlapack-3.1.1/src/testing/eig/Makefile
@@ -0,0 +1,50 @@
+.PHONY: DUMMY
+.SUFFIXES: .f .java
+
+ROOT=../../..
+include $(ROOT)/make.def
+
+BLAS=$(ROOT)/$(BLAS_DIR)/$(BLAS_JAR)
+LAPACK=$(ROOT)/$(LAPACK_DIR)/$(LAPACK_JAR)
+MATGEN=$(ROOT)/$(MATGEN_DIR)/$(MATGEN_JAR)
+
+XERBLAFLAGS= -c .:$(ROOT)/$(BLAS_OBJ) -p $(ERR_PACKAGE)
+F2JFLAGS=-c .:$(ROOT)/$(BLAS_OBJ):$(ROOT)/$(LAPACK_OBJ):$(ROOT)/$(MATGEN_OBJ) -p $(EIGTEST_PACKAGE) -o $(OUTDIR) $(STATIC)
+
+tester: $(BLAS) $(LAPACK) $(MATGEN) $(OUTDIR)/Eigtest.f2j util
+ /bin/rm -f $(EIGTEST_JAR)
+ cd $(OUTDIR); $(JAR) cvf ../$(EIGTEST_JAR) `find . -name "*.class"`
+ $(JAR) uvf $(EIGTEST_JAR) `find org -name "*.class"`
+
+nojar: $(BLAS) $(LAPACK) $(MATGEN) $(OUTDIR)/Eigtest.f2j util
+
+$(OUTDIR)/Eigtest.f2j: eigtest.f
+ $(F2J) $(XERBLAFLAGS) xerbla.f > /dev/null
+ $(F2J) $(F2JFLAGS) $< > /dev/null
+
+$(BLAS):
+ cd $(ROOT)/$(BLAS_DIR); $(MAKE)
+
+$(LAPACK):
+ cd $(ROOT)/$(LAPACK_DIR); $(MAKE)
+
+$(MATGEN):
+ cd $(ROOT)/$(MATGEN_DIR); $(MAKE)
+
+util:
+ cd $(ROOT)/$(UTIL_DIR); $(MAKE)
+
+runtest: tester *.in
+
+srctest:
+ $(MAKE) -f Makefile_javasrc runtest
+
+verify: $(ROOT)/$(EIGTEST_IDX)
+ cd $(OUTDIR); $(JAVA) $(MORE_MEM_FLAG) -classpath .:..:$(JUSTICE):$(BCEL):$(ROOT)/../$(UTIL_DIR)/$(UTIL_JAR):$(ROOT)/../$(ERR_DIR)/$(ERR_JAR):$(ROOT)/../$(MATGEN_DIR)/$(MATGEN_JAR):$(ROOT)/../$(BLAS_DIR)/$(BLAS_JAR):$(ROOT)/../$(LAPACK_DIR)/$(LAPACK_JAR) $(VERIFY) $(EIGTEST_PDIR)/*.class
+
+
+*.in: DUMMY
+ $(JAVA) $(JFLAGS) -cp .:$(EIGTEST_JAR):$(MATGEN):$(ROOT)/$(BLAS_DIR)/$(BLAS_JAR):$(ROOT)/$(LAPACK_DIR)/$(LAPACK_JAR):$(ROOT)/$(UTIL_DIR)/$(UTIL_JAR) $(EIGTEST_PACKAGE).Dchkee < $@
+
+clean:
+ /bin/rm -rf *.java *.class *.f2j org $(JAVASRC_OUTDIR) $(OUTDIR) $(EIGTEST_JAR)
diff --git a/jlapack-3.1.1/src/testing/eig/Makefile_javasrc b/jlapack-3.1.1/src/testing/eig/Makefile_javasrc
new file mode 100644
index 0000000..980368b
--- /dev/null
+++ b/jlapack-3.1.1/src/testing/eig/Makefile_javasrc
@@ -0,0 +1,45 @@
+.PHONY: DUMMY
+.SUFFIXES: .f .java
+
+ROOT=../../..
+include $(ROOT)/make.def
+
+BLAS=$(ROOT)/$(BLAS_DIR)/$(BLAS_JAR)
+LAPACK=$(ROOT)/$(LAPACK_DIR)/$(LAPACK_JAR)
+MATGEN=$(ROOT)/$(MATGEN_DIR)/$(MATGEN_JAR)
+
+tester: $(BLAS) $(LAPACK) $(MATGEN) $(OUTDIR)/Eigtest.f2j util
+ /bin/rm -f `find $(OUTDIR) -name "*.class"`
+ mkdir -p $(JAVASRC_OUTDIR)
+ $(JAVAC) -classpath .:$(JAVASRC_OUTDIR):$(ROOT)/$(UTIL_DIR)/$(UTIL_JAR):$(MATGEN):$(ROOT)/$(BLAS_DIR)/$(BLAS_JAR):$(ROOT)/$(LAPACK_DIR)/$(LAPACK_JAR) -d $(JAVASRC_OUTDIR) $(OUTDIR)/$(EIGTEST_PDIR)/*.java
+ /bin/rm -f $(JAVASRC_OUTDIR)/$(EIGTEST_PDIR)/*.old
+ $(JAVAB) $(JAVASRC_OUTDIR)/$(EIGTEST_PDIR)/*.class
+ /bin/rm -f $(EIGTEST_JAR)
+ cd $(JAVASRC_OUTDIR); $(JAR) cvf ../$(EIGTEST_JAR) `find . -name "*.class"`
+ $(JAR) uvf $(EIGTEST_JAR) `find org -name "*.class"`
+
+$(OUTDIR)/Eigtest.f2j: eigtest.f
+ $(MAKE) nojar
+
+$(BLAS):
+ cd $(ROOT)/$(BLAS_DIR); $(MAKE) -f Makefile_javasrc
+
+$(LAPACK):
+ cd $(ROOT)/$(LAPACK_DIR); $(MAKE) -f Makefile_javasrc
+
+$(MATGEN):
+ cd $(ROOT)/$(MATGEN_DIR); $(MAKE) -f Makefile_javasrc
+
+util:
+ cd $(ROOT)/$(UTIL_DIR); $(MAKE)
+
+runtest: tester *.in
+
+*.in: DUMMY
+ $(JAVA) $(JFLAGS) -cp .:$(EIGTEST_JAR):$(MATGEN):$(BLAS):$(LAPACK):$(ROOT)/$(UTIL_DIR)/$(UTIL_JAR) $(EIGTEST_PACKAGE).Dchkee < $@
+
+verify: $(ROOT)/$(EIGTEST_IDX)
+ cd $(JAVASRC_OUTDIR); $(JAVA) $(MORE_MEM_FLAG) -classpath .:..:$(JUSTICE):$(BCEL):$(ROOT)/../$(UTIL_DIR)/$(UTIL_JAR):$(ROOT)/../$(ERR_DIR)/$(ERR_JAR):$(ROOT)/../$(MATGEN_DIR)/$(MATGEN_JAR):$(ROOT)/../$(BLAS_DIR)/$(BLAS_JAR):$(ROOT)/../$(LAPACK_DIR)/$(LAPACK_JAR) $(VERIFY) $(EIGTEST_PDIR)/*.class
+
+clean:
+ /bin/rm -rf *.java *.class *.f2j org $(JAVASRC_OUTDIR) $(OUTDIR) $(EIGTEST_JAR)
diff --git a/jlapack-3.1.1/src/testing/eig/dbak.in b/jlapack-3.1.1/src/testing/eig/dbak.in
new file mode 100644
index 0000000..cb69cb3
--- /dev/null
+++ b/jlapack-3.1.1/src/testing/eig/dbak.in
@@ -0,0 +1,130 @@
+DBK: Tests DGEBAK
+ 5 1 1
+ 0.1000D+01 0.2000D+01 0.3000D+01 0.4000D+01 0.5000D+01
+
+ 0.1000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.1000D+01 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.1000D+01 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.1000D+01 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.1000D+01
+
+ 0.1000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.1000D+01 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.1000D+01 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.1000D+01 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.1000D+01
+
+ 5 1 1
+ 0.1000D+01 0.2000D+01 0.3000D+01 0.2000D+01 0.1000D+01
+
+ 0.1000D+01 0.1000D+01 0.1000D+01 -0.6667D+00 -0.4167D-01
+ 0.0000D+00 -0.2500D+00 -0.6667D+00 0.1000D+01 0.1667D+00
+ 0.0000D+00 0.0000D+00 0.2222D+00 -0.1000D+01 -0.5000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.5000D+00 0.1000D+01
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 -0.1000D+01
+
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 -0.1000D+01
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.5000D+00 0.1000D+01
+ 0.0000D+00 0.0000D+00 0.2222D+00 -0.1000D+01 -0.5000D+00
+ 0.0000D+00 -0.2500D+00 -0.6667D+00 0.1000D+01 0.1667D+00
+ 0.1000D+01 0.1000D+01 0.1000D+01 -0.6667D+00 -0.4167D-01
+
+ 5 1 1
+ 0.1000D+01 0.2000D+01 0.3000D+01 0.2000D+01 0.1000D+01
+
+ 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01
+ 0.0000D+00 -0.6000D-17 -0.6000D-17 -0.6000D-17 -0.6000D-17
+ 0.0000D+00 0.0000D+00 0.3600D-34 0.3600D-34 0.3600D-34
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.3600D-34 0.3600D-34 0.3600D-34
+ 0.0000D+00 -0.6000D-17 -0.6000D-17 -0.6000D-17 -0.6000D-17
+ 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01
+
+ 6 4 6
+ 0.4000D+01 0.3000D+01 0.5000D+01 0.1000D+03 0.1000D+00 0.1000D+01
+
+ 0.1000D+01 0.1336D-05 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01
+ 0.0000D+00 0.1000D+01 0.0000D+00 -0.3001D-10 -0.3252D-04 0.1305D-01
+ 0.0000D+00 0.0000D+00 -0.8330D-02 0.8929D-09 -0.6712D-04 0.6687D-04
+ 0.0000D+00 0.0000D+00 0.0000D+00 -0.4455D-05 -0.3355D-02 0.3345D-02
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.4455D-06 -0.3356D-01 0.3344D-01
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.4411D-09 0.1011D+00 0.1008D+00
+
+ 0.0000D+00 0.0000D+00 0.0000D+00 -0.4455D-03 -0.3355D+00 0.3345D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.4455D-07 -0.3356D-02 0.3344D-02
+ 0.0000D+00 0.1000D+01 0.0000D+00 -0.3001D-10 -0.3252D-04 0.1305D-01
+ 0.1000D+01 0.1336D-05 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01
+ 0.0000D+00 0.0000D+00 -0.8330D-02 0.8929D-09 -0.6712D-04 0.6687D-04
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.4411D-09 0.1011D+00 0.1008D+00
+
+ 5 1 5
+ 0.1000D+03 0.1000D+00 0.1000D-01 0.1000D+01 0.1000D+02
+
+ 0.1366D-03 -0.6829D-04 0.1252D-03 0.1000D+01 0.1950D-14
+ 0.1000D+01 0.1000D+01 -0.2776D-16 0.3601D-05 -0.6073D-17
+ 0.2736D+00 -0.1363D+00 0.2503D+00 -0.3322D-05 -0.2000D-02
+ 0.6909D-02 -0.3443D-02 0.6196D-02 0.1666D-01 0.1000D+01
+ 0.3899D+00 -0.2033D+00 -0.3420D+00 -0.1000D-02 0.6000D-14
+
+ 0.1366D-01 -0.6829D-02 0.1252D-01 0.1000D+03 0.1950D-12
+ 0.1000D+00 0.1000D+00 -0.2776D-17 0.3601D-06 -0.6073D-18
+ 0.2736D-02 -0.1363D-02 0.2503D-02 -0.3322D-07 -0.2000D-04
+ 0.6909D-02 -0.3443D-02 0.6196D-02 0.1666D-01 0.1000D+01
+ 0.3899D+01 -0.2033D+01 -0.3420D+01 -0.1000D-01 0.6000D-13
+
+ 6 2 5
+ 0.3000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.4000D+01
+
+ 0.1000D+01 0.1000D+01 0.2776D-15 -0.2405D-16 0.0000D+00 0.1000D+01
+ 0.0000D+00 0.7500D+00 0.1000D+01 0.8520D-01 0.0000D+00 -0.1520D-16
+ 0.0000D+00 0.7500D+00 -0.8093D+00 0.1000D+01 0.0000D+00 -0.1520D-16
+ 0.0000D+00 0.7500D+00 -0.9533D-01 -0.5426D+00 0.1000D+01 -0.1520D-16
+ 0.0000D+00 0.7500D+00 -0.9533D-01 -0.5426D+00 -0.1000D+01 -0.1520D-16
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.4559D-16
+
+ 0.0000D+00 0.7500D+00 -0.8093D+00 0.1000D+01 0.0000D+00 -0.1520D-16
+ 0.0000D+00 0.7500D+00 0.1000D+01 0.8520D-01 0.0000D+00 -0.1520D-16
+ 0.1000D+01 0.1000D+01 0.2776D-15 -0.2405D-16 0.0000D+00 0.1000D+01
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.4559D-16
+ 0.0000D+00 0.7500D+00 -0.9533D-01 -0.5426D+00 -0.1000D+01 -0.1520D-16
+ 0.0000D+00 0.7500D+00 -0.9533D-01 -0.5426D+00 0.1000D+01 -0.1520D-16
+
+ 7 2 5
+ 0.3000D+01 0.1000D-02 0.1000D-01 0.1000D+02 0.1000D+00 0.1000D+01
+ 0.6000D+01
+
+ 0.1000D+01 -0.1105D-01 0.3794D-01 -0.9378D-01 -0.3481D-01 0.4465D+00
+ -0.3602D-01
+ 0.0000D+00 -0.4556D+00 -0.4545D+00 0.1000D+01 0.4639D+00 -0.6512D+00
+ 0.4781D+00
+ 0.0000D+00 -0.2734D+00 -0.7946D+00 0.6303D+00 0.1000D+01 -0.6279D+00
+ 0.1000D+01
+ 0.0000D+00 0.1000D+01 -0.6939D-17 0.4259D-01 -0.6495D+00 -0.5581D+00
+ -0.6452D+00
+ 0.0000D+00 -0.3904D+00 -0.4029D+00 -0.1685D+00 -0.9429D+00 0.1000D+01
+ -0.9371D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 -0.2558D+00
+ 0.3308D-03
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ -0.1985D-02
+
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 -0.2558D+00
+ 0.3308D-03
+ 0.0000D+00 -0.4556D-03 -0.4545D-03 0.1000D-02 0.4639D-03 -0.6512D-03
+ 0.4781D-03
+ 0.1000D+01 -0.1105D-01 0.3794D-01 -0.9378D-01 -0.3481D-01 0.4465D+00
+ -0.3602D-01
+ 0.0000D+00 0.1000D+02 -0.6939D-16 0.4259D+00 -0.6495D+01 -0.5581D+01
+ -0.6452D+01
+ 0.0000D+00 -0.3904D-01 -0.4029D-01 -0.1685D-01 -0.9429D-01 0.1000D+00
+ -0.9371D-01
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ -0.1985D-02
+ 0.0000D+00 -0.2734D-02 -0.7946D-02 0.6303D-02 0.1000D-01 -0.6279D-02
+ 0.1000D-01
+
+ 0 0 0
diff --git a/jlapack-3.1.1/src/testing/eig/dbal.in b/jlapack-3.1.1/src/testing/eig/dbal.in
new file mode 100644
index 0000000..103d090
--- /dev/null
+++ b/jlapack-3.1.1/src/testing/eig/dbal.in
@@ -0,0 +1,215 @@
+DBL: Tests DGEBAL
+ 5
+ 0.1000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.2000D+01 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.3000D+01 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.4000D+01 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.5000D+01
+
+ 1 1
+ 0.1000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.2000D+01 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.3000D+01 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.4000D+01 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.5000D+01
+
+ 0.1000D+01 0.2000D+01 0.3000D+01 0.4000D+01 0.5000D+01
+
+ 5
+ 0.1000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.1000D+01 0.2000D+01 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.1000D+01 0.2000D+01 0.3000D+01 0.0000D+00 0.0000D+00
+ 0.1000D+01 0.2000D+01 0.3000D+01 0.4000D+01 0.0000D+00
+ 0.1000D+01 0.2000D+01 0.3000D+01 0.4000D+01 0.5000D+01
+
+ 1 1
+ 0.5000D+01 0.4000D+01 0.3000D+01 0.2000D+01 0.1000D+01
+ 0.0000D+00 0.4000D+01 0.3000D+01 0.2000D+01 0.1000D+01
+ 0.0000D+00 0.0000D+00 0.3000D+01 0.2000D+01 0.1000D+01
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.2000D+01 0.1000D+01
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.1000D+01
+
+ 0.1000D+01 0.2000D+01 0.3000D+01 0.2000D+01 0.1000D+01
+
+ 5
+ 0.1000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.1000D+01 0.1000D+01 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.1000D+01 0.1000D+01 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.1000D+01 0.1000D+01 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.1000D+01 0.1000D+01
+
+ 1 1
+ 0.1000D+01 0.1000D+01 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.1000D+01 0.1000D+01 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.1000D+01 0.1000D+01 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.1000D+01 0.1000D+01
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.1000D+01
+
+ 0.1000D+01 0.2000D+01 0.3000D+01 0.2000D+01 0.1000D+01
+
+ 4
+ 0.0000D+00 0.2000D+01 0.1000D+00 0.0000D+00
+ 0.2000D+01 0.0000D+00 0.0000D+00 0.1000D+00
+ 0.1000D+03 0.0000D+00 0.0000D+00 0.2000D+01
+ 0.0000D+00 0.1000D+03 0.2000D+01 0.0000D+00
+
+ 1 4
+ 0.0000D-03 2.0000D+00 3.2000D+00 0.0000D-03
+ 2.0000D+00 0.0000D-03 0.0000D-03 3.2000D+00
+ 3.1250D+00 0.0000D-03 0.0000D-03 2.0000D+00
+ 0.0000D-03 3.1250D+00 2.0000D+00 0.0000D-03
+
+ 62.5000D-03 62.5000D-03 2.0000D+00 2.0000D+00
+
+ 6
+ 0.2000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.1024D+04
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.1280D+03
+ 0.0000D+00 0.2000D+01 0.3000D+04 0.0000D+00 0.0000D+00 0.2000D+01
+ 0.1280D+03 0.4000D+01 0.4000D-02 0.5000D+01 0.6000D+03 0.8000D+01
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.2000D-02 0.2000D+01
+ 0.8000D+01 0.8192D+04 0.0000D+00 0.0000D+00 0.0000D+00 0.2000D+01
+
+ 4 6
+ 0.5000D+01 0.4000D-02 0.6000D+03 0.1024D+04 0.5000D+00 0.8000D+01
+ 0.0000D+00 0.3000D+04 0.0000D+00 0.0000D+00 0.2500D+00 0.2000D+01
+ 0.0000D+00 0.0000D+00 0.2000D-02 0.0000D+00 0.0000D+00 0.2000D+01
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.2000D+01 0.0000D+00 0.1280D+03
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.1024D+04
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.6400D+02 0.1024D+04 0.2000D+01
+
+ 0.4000D+01 0.3000D+01 0.5000D+01 0.8000D+01 0.1250D+00 0.1000D+01
+
+ 5
+ 0.1000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.8000D+01
+ 0.0000D+00 0.2000D+01 0.8192D+04 0.2000D+01 0.4000D+01
+ 0.2500D-03 0.1250D-03 0.4000D+01 0.0000D+00 0.6400D+02
+ 0.0000D+00 0.2000D+01 0.1024D+04 0.4000D+01 0.8000D+01
+ 0.0000D+00 0.8192D+04 0.0000D+00 0.0000D+00 0.8000D+01
+
+ 1 5
+ 1.0000D+00 0.0000D-03 0.0000D-03 0.0000D-03 250.0000D-03
+ 0.0000D-03 2.0000D+00 1.0240D+03 16.0000D+00 16.0000D+00
+ 256.0000D-03 1.0000D-03 4.0000D+00 0.0000D-03 2.0480D+03
+ 0.0000D-03 250.0000D-03 16.0000D+00 4.0000D+00 4.0000D+00
+ 0.0000D-03 2.0480D+03 0.0000D-03 0.0000D-03 8.0000D+00
+
+ 64.0000D+00 500.0000D-03 62.5000D-03 4.0000D+00 2.0000D+00
+
+ 4
+ 0.1000D+01 0.1000D+07 0.1000D+07 0.1000D+07
+ -0.2000D+07 0.3000D+01 0.2000D-05 0.3000D-05
+ -0.3000D+07 0.0000D+00 0.1000D-05 0.2000D+01
+ 0.1000D+07 0.0000D+00 0.3000D-05 0.4000D+07
+
+ 1 4
+ 1.0000D+00 1.0000D+06 2.0000D+06 1.0000D+06
+ -2.0000D+06 3.0000D+00 4.0000D-06 3.0000D-06
+ -1.5000D+06 0.0000D-03 1.0000D-06 1.0000D+00
+ 1.0000D+06 0.0000D-03 6.0000D-06 4.0000D+06
+
+ 1.0000D+00 1.0000D+00 2.0000D+00 1.0000D+00
+
+ 4
+ 0.1000D+01 0.1000D+05 0.1000D+05 0.1000D+05
+ -0.2000D+05 0.3000D+01 0.2000D-02 0.3000D-02
+ 0.0000D+00 0.2000D+01 0.0000D+00 -0.3000D+05
+ 0.0000D+00 0.0000D+00 0.1000D+05 0.0000D+00
+
+ 1 4
+ 1.0000D+00 10.0000D+03 10.0000D+03 5.0000D+03
+ -20.0000D+03 3.0000D+00 2.0000D-03 1.5000D-03
+ 0.0000D-03 2.0000D+00 0.0000D-03 -15.0000D+03
+ 0.0000D-03 0.0000D-03 20.0000D+03 0.0000D-03
+
+ 1.0000D+00 1.0000D+00 1.0000D+00 500.0000D-03
+
+ 5
+ 0.1000D+01 0.5120D+03 0.4096D+04 3.2768D+04 2.62144D+05
+ 0.8000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.8000D+01 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.8000D+01 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.8000D+01 0.0000D+00
+
+ 1 5
+ 1.0000D+00 32.0000D+00 32.0000D+00 32.0000D+000 32.0000D+00
+ 128.0000D+00 0.0000D-03 0.0000D-03 0.0000D-003 0.0000D-03
+ 0.0000D-03 64.0000D+00 0.0000D-03 0.0000D-003 0.0000D-03
+ 0.0000D-03 0.0000D-03 64.0000D+00 0.0000D-003 0.0000D-03
+ 0.0000D-03 0.0000D-03 0.0000D-03 64.0000D+000 0.0000D-03
+
+ 256.0000D+00 16.0000D+00 2.0000D+00 250.0000D-03 31.2500D-03
+
+ 6
+ 0.1000D+01 0.1000D+01 0.0000D+00 0.1000D+01 0.1000D+01 0.1000D+01
+ 0.1000D+01 0.1000D+01 0.0000D+00 0.1000D+01 0.1000D+01 0.1000D+01
+ 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.1000D+01 0.0000D+00 0.0000D+00
+ 0.1000D+01 0.1000D+01 0.0000D+00 0.1000D+01 0.1000D+01 0.1000D+01
+ 0.1000D+01 0.1000D+01 0.0000D+00 0.1000D+01 0.1000D+01 0.1000D+01
+
+ 2 5
+ 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01
+ 0.0000D+00 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01
+ 0.0000D+00 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01
+ 0.0000D+00 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01
+ 0.0000D+00 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.1000D+01
+
+ 0.3000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.4000D+01
+
+ 7
+ 0.6000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.1000D+01 0.0000D+00
+ 0.0000D+00 0.4000D+01 0.0000D+00 0.2500D-03 0.1250D-01 0.2000D-01 0.1250D+00
+ 0.1000D+01 0.1280D+03 0.6400D+02 0.0000D+00 0.0000D+00 -0.2000D+01 0.1600D+02
+ 0.0000D+00 1.6384D+04 0.0000D+00 0.1000D+01 -0.4000D+03 0.2560D+03 -0.4000D+04
+ -0.2000D+01 -0.2560D+03 0.0000D+00 0.1250D-01 0.2000D+01 0.2000D+01 0.3200D+02
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.8000D+01 0.0000D+00 0.4000D-02 0.1250D+00 -0.2000D+00 0.3000D+01
+
+ 2 5
+ 6.4000D+01 2.5000D-01 5.00000D-01 0.0000D+00 0.0000D+00 1.0000D+00 -2.0000D+00
+ 0.0000D+00 4.0000D+00 2.00000D+00 4.0960D+00 1.6000D+00 0.0000D+00 1.0240D+01
+ 0.0000D+00 5.0000D-01 3.00000D+00 4.0960D+00 1.0000D+00 0.0000D+00 -6.4000D+00
+ 0.0000D+00 1.0000D+00 -3.90625D+00 1.0000D+00 -3.1250D+00 0.0000D+00 8.0000D+00
+ 0.0000D+00 -2.0000D+00 4.00000D+00 1.6000D+00 2.0000D+00 -8.0000D+00 8.0000D+00
+ 0.0000D+00 0.0000D+00 0.00000D+00 0.0000D+00 0.0000D+00 6.0000D+00 1.0000D+00
+ 0.0000D+00 0.0000D+00 0.00000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+
+ 3.0000D+00 1.953125D-03 3.1250D-02 3.2000D+01 2.5000D-01 1.0000D+00 6.0000D+00
+
+ 5
+ 0.1000D+04 0.2000D+01 0.3000D+01 0.4000D+01 0.5000D+06
+ 0.9000D+01 0.0000D+00 0.2000D-03 0.1000D+01 0.3000D+01
+ 0.0000D+00 -0.3000D+03 0.2000D+01 0.1000D+01 0.1000D+01
+ 0.9000D+01 0.2000D-02 0.1000D+01 0.1000D+01 -0.1000D+04
+ 0.6000D+01 0.2000D+03 0.1000D+01 0.6000D+03 0.3000D+01
+
+ 1 5
+ 1.0000D+03 3.1250D-02 3.7500D-01 6.2500D-02 3.90625D+03
+ 5.7600D+02 0.0000D+00 1.6000D-03 1.0000D+00 1.5000D+00
+ 0.0000D+00 -3.7500D+01 2.0000D+00 1.2500D-01 6.2500D-02
+ 5.7600D+02 2.0000D-03 8.0000D+00 1.0000D+00 -5.0000D+02
+ 7.6800D+02 4.0000D+02 1.6000D+01 1.2000D+03 3.0000D+00
+
+ 1.2800D+02 2.0000D+00 1.6000D+01 2.0000D+00 1.0000D+00
+
+ 6
+ 1.0000D+00 1.0000D+120 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 1.0000D-120 1.0000D+00 1.0000D+120 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 1.0000D-120 1.0000D+00 1.0000D+120 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 1.0000D-120 1.0000D+00 1.0000D+120 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 1.0000D-120 1.0000D+00 1.0000D+120
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 1.0000D-120 1.0000D+00
+
+ 1 6
+ 1.000000000000000000D+00 6.344854593289122931D+03 0.000000000000000000D+00 0.000000000000000000D+00 0.000000000000000000D+00 0.000000000000000000D+00
+ 1.576080247855779135D-04 1.000000000000000000D+00 6.344854593289122931D+03 0.000000000000000000D+00 0.000000000000000000D+00 0.000000000000000000D+00
+ 0.000000000000000000D+00 1.576080247855779135D-04 1.000000000000000000D+00 3.172427296644561466D+03 0.000000000000000000D+00 0.000000000000000000D+00
+ 0.000000000000000000D+00 0.000000000000000000D+00 3.152160495711558270D-04 1.000000000000000000D+00 1.586213648322280733D+03 0.000000000000000000D+00
+ 0.000000000000000000D+00 0.000000000000000000D+00 0.000000000000000000D+00 6.304320991423116539D-04 1.000000000000000000D+00 1.586213648322280733D+03
+ 0.000000000000000000D+00 0.000000000000000000D+00 0.000000000000000000D+00 0.000000000000000000D+00 6.304320991423116539D-04 1.000000000000000000D+00
+
+ 2.494800386918399765D+291 1.582914569427869018D+175 1.004336277661868922D+59 3.186183822264904554D-58 5.053968264940243633D-175 8.016673440035891112D-292
+
+
+0
diff --git a/jlapack-3.1.1/src/testing/eig/dbb.in b/jlapack-3.1.1/src/testing/eig/dbb.in
new file mode 100644
index 0000000..3303274
--- /dev/null
+++ b/jlapack-3.1.1/src/testing/eig/dbb.in
@@ -0,0 +1,12 @@
+DBB: Data file for testing banded Singular Value Decomposition routines
+20 Number of values of M
+0 0 0 0 1 1 1 1 2 2 2 2 3 3 3 3 10 10 16 16 Values of M
+0 1 2 3 0 1 2 3 0 1 2 3 0 1 2 3 10 16 10 16 Values of N
+5 Number of values of K
+0 1 2 3 16 Values of K (band width)
+2 Number of values of NRHS
+1 2 Values of NRHS
+20.0 Threshold value
+F Put T to test the error exits
+1 Code to interpret the seed
+DBB 15
diff --git a/jlapack-3.1.1/src/testing/eig/dec.in b/jlapack-3.1.1/src/testing/eig/dec.in
new file mode 100644
index 0000000..50837a1
--- /dev/null
+++ b/jlapack-3.1.1/src/testing/eig/dec.in
@@ -0,0 +1,950 @@
+DEC Key indicating type of input
+20.0 Threshold value for test ratios
+ 8 2 7
+ 1.0D+00 1.0D+00 1.1D+00 1.3D+00 2.0D+00 3.0D+00 -4.7D+00 3.3D+00
+ -1.0D+00 1.0D+00 3.7D+00 7.9D+00 4.0D+00 5.3D+00 3.3D+00 -9.0D-01
+ 0.0D+00 0.0D+00 2.0D+00 -3.0D+00 3.4D+00 6.5D+00 5.2D+00 1.8D+00
+ 0.0D+00 0.0D+00 4.0D+00 2.0D+00 -5.3D+00 -8.9D+00 -2.0D-01 -5.0D-01
+ 0.0D+00 0.0D+00 0.0D+00 0.0D+00 4.2D+00 2.0D+00 3.3D+00 2.3D+00
+ 0.0D+00 0.0D+00 0.0D+00 0.0D+00 -3.7D+00 4.2D+00 9.9D+00 8.8D+00
+ 0.0D+00 0.0D+00 0.0D+00 0.0D+00 0.0D+00 0.0D+00 9.9D+00 8.8D+00
+ 0.0D+00 0.0D+00 0.0D+00 0.0D+00 0.0D+00 0.0D+00 -9.9D+00 9.9D+00
+ 8 7 2
+ 1.0D+00 1.0D+00 1.1D+00 1.3D+00 2.0D+00 3.0D+00 -4.7D+00 3.3D+00
+ -1.0D+00 1.0D+00 3.7D+00 7.9D+00 4.0D+00 5.3D+00 3.3D+00 -9.0D-01
+ 0.0D+00 0.0D+00 2.0D+00 -3.0D+00 3.4D+00 6.5D+00 5.2D+00 1.8D+00
+ 0.0D+00 0.0D+00 4.0D+00 2.0D+00 -5.3D+00 -8.9D+00 -2.0D-01 -5.0D-01
+ 0.0D+00 0.0D+00 0.0D+00 0.0D+00 4.2D+00 2.0D+00 3.3D+00 2.3D+00
+ 0.0D+00 0.0D+00 0.0D+00 0.0D+00 -3.7D+00 4.2D+00 9.9D+00 8.8D+00
+ 0.0D+00 0.0D+00 0.0D+00 0.0D+00 0.0D+00 0.0D+00 9.9D+00 8.8D+00
+ 0.0D+00 0.0D+00 0.0D+00 0.0D+00 0.0D+00 0.0D+00 -9.9D+00 9.9D+00
+ 8 1 7
+ 1.0D+00 1.0D+00 1.1D+00 1.3D+00 2.0D+00 3.0D+00 -4.7D+00 3.3D+00
+ 0.0D+00 1.0D+00 3.7D+00 7.9D+00 4.0D+00 5.3D+00 3.3D+00 -9.0D-01
+ 0.0D+00 0.0D+00 2.0D+00 -3.0D+00 3.4D+00 6.5D+00 5.2D+00 1.8D+00
+ 0.0D+00 0.0D+00 4.0D+00 2.0D+00 -5.3D+00 -8.9D+00 -2.0D-01 -5.0D-01
+ 0.0D+00 0.0D+00 0.0D+00 0.0D+00 4.2D+00 2.0D+00 3.3D+00 2.3D+00
+ 0.0D+00 0.0D+00 0.0D+00 0.0D+00 0.0D+00 4.2D+00 9.9D+00 8.8D+00
+ 0.0D+00 0.0D+00 0.0D+00 0.0D+00 0.0D+00 0.0D+00 9.9D+00 8.8D+00
+ 0.0D+00 0.0D+00 0.0D+00 0.0D+00 0.0D+00 0.0D+00 -9.9D+00 9.9D+00
+ 8 8 2
+ 1.0D+00 1.0D+00 1.1D+00 1.3D+00 2.0D+00 3.0D+00 -4.7D+00 3.3D+00
+ -1.1D+00 1.0D+00 3.7D+00 7.9D+00 4.0D+00 5.3D+00 3.3D+00 -9.0D-01
+ 0.0D+00 0.0D+00 2.0D+00 -3.0D+00 3.4D+00 6.5D+00 5.2D+00 1.8D+00
+ 0.0D+00 0.0D+00 0.0D+00 2.0D+00 -5.3D+00 -8.9D+00 -2.0D-01 -5.0D-01
+ 0.0D+00 0.0D+00 0.0D+00 0.0D+00 4.2D+00 2.0D+00 3.3D+00 2.3D+00
+ 0.0D+00 0.0D+00 0.0D+00 0.0D+00 -3.7D+00 4.2D+00 9.9D+00 8.8D+00
+ 0.0D+00 0.0D+00 0.0D+00 0.0D+00 0.0D+00 0.0D+00 9.9D+00 8.8D+00
+ 0.0D+00 0.0D+00 0.0D+00 0.0D+00 0.0D+00 0.0D+00 0.0D+00 9.9D+00
+ 7 2 7
+ 1.1D+00 1.0D-16 2.7D+00 3.3D+00 2.3D+00 3.4D+00 5.6D+00
+ -1.0D-16 1.1D+00 4.2D+00 5.1D+00 -1.0D-01 -2.0D-01 -3.0D-01
+ 0.0D+00 0.0D+00 2.3D+00 1.0D+00 1.0D+02 1.0D+03 1.0D+02
+ 0.0D+00 0.0D+00 0.0D+00 3.9D+00 3.2D+00 6.5D+00 3.2D+00
+ 0.0D+00 0.0D+00 0.0D+00 -9.0D-01 3.9D+00 6.3D+00 3.0D+00
+ 0.0D+00 0.0D+00 0.0D+00 0.0D+00 0.0D+00 6.3D+00 3.0D+00
+ 0.0D+00 0.0D+00 0.0D+00 0.0D+00 0.0D+00 -9.0D-01 6.3D+00
+ 7 2 7
+ 1.1D+00 1.0D-16 2.7D+00 3.3D+00 2.3D+00 3.4D+00 5.6D+00
+ -1.0D-16 1.1D+00 4.2D+00 5.1D+00 -1.0D-01 -2.0D-01 -3.0D-01
+ 0.0D+00 0.0D+00 2.3D+00 1.0D+00 1.0D+02 1.0D+03 1.0D+02
+ 0.0D+00 0.0D+00 0.0D+00 3.9D+00 3.2D-15 6.5D+00 3.2D+00
+ 0.0D+00 0.0D+00 0.0D+00 -9.0D-16 3.9D+00 6.3D+00 3.0D+00
+ 0.0D+00 0.0D+00 0.0D+00 0.0D+00 0.0D+00 6.3D+00 3.0D+00
+ 0.0D+00 0.0D+00 0.0D+00 0.0D+00 0.0D+00 0.0D+00 6.4D+00
+ 7 2 7
+ 1.1D+00 1.0D-16 2.7D+00 3.3D+00 2.3D+00 3.4D+00 5.6D+00
+ -1.0D-16 1.1D+00 4.2D+00 5.1D+00 -1.0D-01 -2.0D-01 -3.0D-01
+ 0.0D+00 0.0D+00 2.3D+00 1.0D+00 1.0D+02 1.0D+03 1.0D+02
+ 0.0D+00 0.0D+00 0.0D+00 3.9D+00 3.2D-15 6.5D+00 3.2D+00
+ 0.0D+00 0.0D+00 0.0D+00 -9.0D-16 3.9D+00 6.3D+00 3.0D+00
+ 0.0D+00 0.0D+00 0.0D+00 0.0D+00 0.0D+00 6.3D+00 3.0D+00
+ 0.0D+00 0.0D+00 0.0D+00 0.0D+00 0.0D+00 -9.0D-21 6.3D+00
+ 7 1 7
+ 1.1D+00 1.0D-16 2.7D+00 3.3D+00 2.3D+00 3.4D+00 5.6D+00
+ 0.0D+00 1.1D+00 4.2D+00 5.1D+00 -1.0D-01 -2.0D-01 -3.0D-01
+ 0.0D+00 0.0D+00 2.3D+00 1.0D+00 1.0D+02 1.0D+03 1.0D+02
+ 0.0D+00 0.0D+00 0.0D+00 3.9D+00 3.2D-15 6.5D+00 3.2D+00
+ 0.0D+00 0.0D+00 0.0D+00 -9.0D-16 3.9D+00 6.3D+00 3.0D+00
+ 0.0D+00 0.0D+00 0.0D+00 0.0D+00 0.0D+00 6.3D+00 3.0D+00
+ 0.0D+00 0.0D+00 0.0D+00 0.0D+00 0.0D+00 -9.0D-21 6.3D+00
+ 7 1 7
+ 1.1D+00 -1.1D+00 2.7D+00 3.3D+00 2.3D+00 3.4D+00 5.6D+00
+ 2.3D+00 1.1D+00 4.2D+00 5.1D+00 -1.0D-01 -2.0D-01 -3.0D-01
+ 0.0D+00 0.0D+00 2.3D+00 1.0D+00 1.0D+02 1.0D+03 1.0D+02
+ 0.0D+00 0.0D+00 0.0D+00 3.9D+00 3.2D+00 6.5D+00 3.2D+00
+ 0.0D+00 0.0D+00 0.0D+00 -9.0D-21 3.9D+00 6.3D+00 3.0D+00
+ 0.0D+00 0.0D+00 0.0D+00 0.0D+00 0.0D+00 6.3D+00 3.0D-20
+ 0.0D+00 0.0D+00 0.0D+00 0.0D+00 0.0D+00 -9.0D-21 6.3D+00
+ 7 7 2
+ 6.3D+00 3.0D+00 2.7D+00 3.3D+00 2.3D+00 3.4D+00 5.6D+00
+ -9.0D-01 6.3D+00 4.2D+00 5.1D+00 -1.0D-01 -2.0D-01 -3.0D-01
+ 0.0D+00 0.0D+00 2.3D+00 1.0D+00 1.0D+02 1.0D+03 1.0D+02
+ 0.0D+00 0.0D+00 0.0D+00 3.9D+00 3.2D+00 6.5D+00 3.2D+00
+ 0.0D+00 0.0D+00 0.0D+00 0.0D+00 3.8D+00 6.3D+00 3.0D+00
+ 0.0D+00 0.0D+00 0.0D+00 0.0D+00 0.0D+00 1.1D+00 1.4D-20
+ 0.0D+00 0.0D+00 0.0D+00 0.0D+00 0.0D+00 -1.6D-20 1.1D+00
+ 7 7 2
+ 6.3D+00 3.0D+00 2.7D+00 3.3D+00 2.3D+00 3.4D+00 5.6D+00
+ -9.0D-01 6.3D+00 4.2D+00 5.1D+00 -1.0D-01 -2.0D-01 -3.0D-01
+ 0.0D+00 0.0D+00 2.3D+00 1.0D+00 1.0D+02 1.0D+03 1.0D+02
+ 0.0D+00 0.0D+00 0.0D+00 3.9D+00 3.2D+00 6.5D+00 3.2D+00
+ 0.0D+00 0.0D+00 0.0D+00 -9.0D-01 3.9D+00 6.3D+00 3.0D+00
+ 0.0D+00 0.0D+00 0.0D+00 0.0D+00 0.0D+00 1.1D+00 1.4D-20
+ 0.0D+00 0.0D+00 0.0D+00 0.0D+00 0.0D+00 -1.6D-20 1.1D+00
+ 7 7 2
+ 1.1D+00 1.0D-16 2.7D+00 3.3D+00 2.3D+00 3.4D+00 5.6D+00
+ -1.0D-16 1.1D+00 4.2D+00 5.1D+00 -1.0D-01 -2.0D-01 -3.0D-01
+ 0.0D+00 0.0D+00 2.3D+00 1.0D+00 1.0D+02 1.0D+03 1.0D+02
+ 0.0D+00 0.0D+00 0.0D+00 3.9D+00 3.2D-15 6.5D+00 3.2D+00
+ 0.0D+00 0.0D+00 0.0D+00 -9.0D-16 3.9D+00 6.3D+00 3.0D+00
+ 0.0D+00 0.0D+00 0.0D+00 0.0D+00 0.0D+00 6.3D+00 3.0D+00
+ 0.0D+00 0.0D+00 0.0D+00 0.0D+00 0.0D+00 -9.0D-21 6.3D+00
+ 7 7 1
+ 1.1D+00 1.0D-16 2.7D+06 3.3D+00 2.3D+00 3.4D+00 5.6D+00
+ 0.0D+00 1.1D+00 4.2D+06 5.1D+00 -1.0D-01 -2.0D-01 -3.0D-01
+ 0.0D+00 0.0D+00 2.3D+00 1.0D+07 1.0D+08 1.0D+03 1.0D+02
+ 0.0D+00 0.0D+00 0.0D+00 3.9D+00 3.2D-15 6.5D+04 3.2D+00
+ 0.0D+00 0.0D+00 0.0D+00 -9.0D-16 3.9D+00 6.3D+03 3.0D+05
+ 0.0D+00 0.0D+00 0.0D+00 0.0D+00 0.0D+00 6.3D+00 3.0D+00
+ 0.0D+00 0.0D+00 0.0D+00 0.0D+00 0.0D+00 -9.0D-21 6.3D+00
+ 8 8 1
+ 1.1D+00 -1.0D-16 2.7D+06 2.3D+04 3.3D+00 2.3D+00 3.4D+00 5.6D+00
+ 1.0D-16 1.1D+00 4.2D+06 -1.0D-01 5.1D+00 -1.0D-01 -2.0D-01 -3.0D-01
+ 0.0D+00 0.0D+00 2.3D+00 1.1D-16 1.0D+07 1.0D+08 1.0D+03 1.0D+02
+ 0.0D+00 0.0D+00 -1.1D-13 2.3D+00 1.0D+07 1.0D+08 1.0D+03 1.0D+02
+ 0.0D+00 0.0D+00 0.0D+00 0.0D+00 3.9D+00 3.2D-15 6.5D+04 3.2D+00
+ 0.0D+00 0.0D+00 0.0D+00 0.0D+00 -9.0D-16 3.9D+00 6.3D+03 3.0D+05
+ 0.0D+00 0.0D+00 0.0D+00 0.0D+00 0.0D+00 0.0D+00 6.3D+00 3.0D-20
+ 0.0D+00 0.0D+00 0.0D+00 0.0D+00 0.0D+00 0.0D+00 -9.0D-21 6.3D+00
+ 0 0 0
+ 1
+ 0.0000D+00
+ 0.0000D+00 0.0000D+00 1.0000D+00 0.0000D+00
+ 1
+ 1.0000D+00
+ 1.0000D+00 0.0000D+00 1.0000D+00 1.0000D+00
+ 2
+ 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 1.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 1.0000D+00 0.0000D+00
+ 2
+ 3.0000D+00 2.0000D+00
+ 2.0000D+00 3.0000D+00
+ 1.0000D+00 0.0000D+00 1.0000D+00 4.0000D+00
+ 5.0000D+00 0.0000D+00 1.0000D+00 4.0000D+00
+ 2
+ 3.0000D+00 -2.0000D+00
+ 2.0000D+00 3.0000D+00
+ 3.0000D+00 2.0000D+00 1.0000D+00 4.0000D+00
+ 3.0000D+00 -2.0000D+00 1.0000D+00 4.0000D+00
+ 6
+ 1.0000D-07 -1.0000D-07 1.0000D+00 1.1000D+00 2.3000D+00 3.7000D+00
+ 3.0000D-07 1.0000D-07 1.0000D+00 1.0000D+00 -1.3000D+00 -7.7000D+00
+ 0.0000D+00 0.0000D+00 3.0000D-07 1.0000D-07 2.2000D+00 3.3000D+00
+ 0.0000D+00 0.0000D+00 -1.0000D-07 3.0000D-07 1.8000D+00 1.6000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 4.0000D-06 5.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 3.0000D+00 4.0000D-06
+ -3.8730D+00 0.0000D+00 6.9855D-01 2.2823D+00
+ 1.0000D-07 1.7321D-07 9.7611D-08 5.0060D-14
+ 1.0000D-07 -1.7321D-07 9.7611D-08 5.0060D-14
+ 3.0000D-07 1.0000D-07 1.0000D-07 9.4094D-14
+ 3.0000D-07 -1.0000D-07 1.0000D-07 9.4094D-14
+ 3.8730D+00 0.0000D+00 4.0659D-01 1.5283D+00
+ 4
+ 7.0000D+00 1.0000D+00 1.0000D+00 1.0000D+00
+ -1.0000D+00 1.0000D+00 1.0000D+00 1.0000D+00
+ -1.0000D+00 1.0000D+00 5.0000D+00 -3.0000D+00
+ 1.0000D+00 -1.0000D+00 3.0000D+00 3.0000D+00
+ 3.9603D+00 4.0425D-02 1.1244D-05 3.1179D-05
+ 3.9603D+00 -4.0425D-02 1.1244D-05 3.1179D-05
+ 4.0397D+00 3.8854D-02 1.0807D-05 2.9981D-05
+ 4.0397D+00 -3.8854D-02 1.0807D-05 2.9981D-05
+ 5
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 1.0000D+00 1.9722D-31
+ 0.0000D+00 0.0000D+00 1.0000D+00 1.9722D-31
+ 0.0000D+00 0.0000D+00 1.0000D+00 1.9722D-31
+ 0.0000D+00 0.0000D+00 1.0000D+00 1.9722D-31
+ 0.0000D+00 0.0000D+00 1.0000D+00 1.9722D-31
+ 5
+ 1.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 1.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 1.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 1.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 1.0000D+00
+ 1.0000D+00 0.0000D+00 1.0000D+00 1.9722D-31
+ 1.0000D+00 0.0000D+00 1.0000D+00 1.9722D-31
+ 1.0000D+00 0.0000D+00 1.0000D+00 1.9722D-31
+ 1.0000D+00 0.0000D+00 1.0000D+00 1.9722D-31
+ 1.0000D+00 0.0000D+00 1.0000D+00 1.9722D-31
+ 6
+ 1.0000D+00 1.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 1.0000D+00 1.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 1.0000D+00 1.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 1.0000D+00 1.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 1.0000D+00 1.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 1.0000D+00
+ 1.0000D+00 0.0000D+00 2.4074D-35 2.4074D-35
+ 1.0000D+00 0.0000D+00 2.4074D-35 2.4074D-35
+ 1.0000D+00 0.0000D+00 2.4074D-35 2.4074D-35
+ 1.0000D+00 0.0000D+00 2.4074D-35 2.4074D-35
+ 1.0000D+00 0.0000D+00 2.4074D-35 2.4074D-35
+ 1.0000D+00 0.0000D+00 2.4074D-35 2.4074D-35
+ 6
+ 1.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 1.0000D+00 1.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 1.0000D+00 1.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 1.0000D+00 1.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 1.0000D+00 1.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 1.0000D+00 1.0000D+00
+ 1.0000D+00 0.0000D+00 2.4074D-35 2.4074D-35
+ 1.0000D+00 0.0000D+00 2.4074D-35 2.4074D-35
+ 1.0000D+00 0.0000D+00 2.4074D-35 2.4074D-35
+ 1.0000D+00 0.0000D+00 2.4074D-35 2.4074D-35
+ 1.0000D+00 0.0000D+00 2.4074D-35 2.4074D-35
+ 1.0000D+00 0.0000D+00 2.4074D-35 2.4074D-35
+ 6
+ 1.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 2.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 3.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 4.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 5.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 6.0000D+00
+ 1.0000D+00 0.0000D+00 1.0000D+00 1.0000D+00
+ 2.0000D+00 0.0000D+00 1.0000D+00 1.0000D+00
+ 3.0000D+00 0.0000D+00 1.0000D+00 1.0000D+00
+ 4.0000D+00 0.0000D+00 1.0000D+00 1.0000D+00
+ 5.0000D+00 0.0000D+00 1.0000D+00 1.0000D+00
+ 6.0000D+00 0.0000D+00 1.0000D+00 1.0000D+00
+ 4
+ 9.4480D-01 6.7670D-01 6.9080D-01 5.9650D-01
+ 5.8760D-01 8.6420D-01 6.7690D-01 7.2600D-02
+ 7.2560D-01 1.9430D-01 9.6870D-01 2.8310D-01
+ 2.8490D-01 5.8000D-02 4.8450D-01 7.3610D-01
+ 2.4326D-01 2.1409D-01 8.7105D-01 3.5073D-01
+ 2.4326D-01 -2.1409D-01 8.7105D-01 3.5073D-01
+ 7.4091D-01 0.0000D+00 9.8194D-01 4.6989D-01
+ 2.2864D+00 0.0000D+00 9.7723D-01 1.5455D+00
+ 6
+ 5.0410D-01 6.6520D-01 7.7190D-01 6.3870D-01 5.9550D-01 6.1310D-01
+ 1.5740D-01 3.7340D-01 5.9840D-01 1.5470D-01 9.4270D-01 6.5900D-02
+ 4.4170D-01 7.2300D-02 1.5440D-01 5.4920D-01 8.7000D-03 3.0040D-01
+ 2.0080D-01 6.0800D-01 3.0340D-01 8.4390D-01 2.3900D-01 5.7680D-01
+ 9.3610D-01 7.4130D-01 1.4440D-01 1.7860D-01 1.4280D-01 7.2630D-01
+ 5.5990D-01 9.3360D-01 7.8000D-02 4.0930D-01 6.7140D-01 5.6170D-01
+ -5.2278D-01 0.0000D+00 2.7888D-01 1.1793D-01
+ -3.5380D-01 0.0000D+00 3.5427D-01 6.8911D-02
+ -8.0876D-03 0.0000D+00 3.4558D-01 1.3489D-01
+ 3.4760D-01 3.0525D-01 5.4661D-01 1.7729D-01
+ 3.4760D-01 -3.0525D-01 5.4661D-01 1.7729D-01
+ 2.7698D+00 0.0000D+00 9.6635D-01 1.8270D+00
+ 5
+ 2.0000D-03 1.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 1.0000D-03 1.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 -1.0000D-03 1.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 -2.0000D-03 1.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ -2.0000D-03 0.0000D+00 2.4000D-11 2.3952D-11
+ -1.0000D-03 0.0000D+00 6.0000D-12 5.9940D-12
+ 0.0000D+00 0.0000D+00 4.0000D-12 3.9920D-12
+ 1.0000D-03 0.0000D+00 6.0000D-12 5.9940D-12
+ 2.0000D-03 0.0000D+00 2.4000D-11 2.3952D-11
+ 10
+ 4.8630D-01 9.1260D-01 2.1900D-02 6.0110D-01 1.4050D-01 2.0840D-01
+ 8.2640D-01 8.4410D-01 3.1420D-01 8.6750D-01
+ 7.1500D-01 2.6480D-01 8.8510D-01 2.6150D-01 5.9520D-01 4.7800D-01
+ 7.6730D-01 4.6110D-01 5.7320D-01 7.7000D-03
+ 2.1210D-01 5.5080D-01 5.2350D-01 3.0810D-01 6.6020D-01 2.8900D-01
+ 2.3140D-01 2.2790D-01 9.6600D-02 1.0910D-01
+ 7.1510D-01 8.5790D-01 5.7710D-01 5.1140D-01 1.9010D-01 9.0810D-01
+ 6.0090D-01 7.1980D-01 1.0640D-01 8.6840D-01
+ 5.6800D-01 2.8100D-02 4.0140D-01 6.3150D-01 1.1480D-01 7.5800D-02
+ 9.4230D-01 7.2030D-01 3.6850D-01 1.7430D-01
+ 7.7210D-01 3.0280D-01 5.5640D-01 9.9980D-01 3.6520D-01 5.2580D-01
+ 3.7030D-01 6.7790D-01 9.9350D-01 5.0270D-01
+ 7.3960D-01 4.5600D-02 7.4740D-01 9.2880D-01 2.2000D-03 8.2600D-02
+ 3.6340D-01 4.9120D-01 9.4050D-01 3.8910D-01
+ 5.6370D-01 8.5540D-01 3.2100D-02 2.6380D-01 3.6090D-01 6.4970D-01
+ 8.4690D-01 9.3500D-01 3.7000D-02 2.9170D-01
+ 8.6560D-01 6.3270D-01 3.5620D-01 6.3560D-01 2.7360D-01 6.5120D-01
+ 1.0220D-01 2.8880D-01 5.7620D-01 4.0790D-01
+ 5.3320D-01 4.1210D-01 7.2870D-01 2.3110D-01 6.8300D-01 7.3860D-01
+ 8.1800D-01 9.8150D-01 8.0550D-01 2.5660D-01
+ -4.6121D-01 7.2657D-01 4.7781D-01 1.5842D-01
+ -4.6121D-01 -7.2657D-01 4.7781D-01 1.5842D-01
+ -4.5164D-01 0.0000D+00 4.6034D-01 1.9931D-01
+ -1.4922D-01 4.8255D-01 4.7500D-01 9.1686D-02
+ -1.4922D-01 -4.8255D-01 4.7500D-01 9.1686D-02
+ 3.3062D-02 0.0000D+00 2.9729D-01 8.2469D-02
+ 3.0849D-01 1.1953D-01 4.2947D-01 3.9688D-02
+ 3.0849D-01 -1.1953D-01 4.2947D-01 3.9688D-02
+ 5.4509D-01 0.0000D+00 7.0777D-01 1.5033D-01
+ 5.0352D+00 0.0000D+00 9.7257D-01 3.5548D+00
+ 4
+ -3.8730D-01 3.6560D-01 3.1200D-02 -5.8340D-01
+ 5.5230D-01 -1.1854D+00 9.8330D-01 7.6670D-01
+ 1.6746D+00 -1.9900D-02 -1.8293D+00 5.7180D-01
+ -5.2500D-01 3.5340D-01 -2.7210D-01 -8.8300D-02
+ -1.8952D+00 7.5059D-01 8.1913D-01 7.7090D-01
+ -1.8952D+00 -7.5059D-01 8.1913D-01 7.7090D-01
+ -9.5162D-02 0.0000D+00 8.0499D-01 4.9037D-01
+ 3.9520D-01 0.0000D+00 9.8222D-01 4.9037D-01
+ 6
+ -1.0777D+00 1.7027D+00 2.6510D-01 8.5160D-01 1.0121D+00 2.5710D-01
+ -1.3400D-02 3.9030D-01 -1.2680D+00 2.7530D-01 -3.2350D-01 -1.3844D+00
+ 1.5230D-01 3.0680D-01 8.7330D-01 -3.3410D-01 -4.8310D-01 -1.5416D+00
+ 1.4470D-01 -6.0570D-01 3.1900D-02 -1.0905D+00 -8.3700D-02 6.2410D-01
+ -7.6510D-01 -1.7889D+00 -1.5069D+00 -6.0210D-01 5.2170D-01 6.4700D-01
+ 8.1940D-01 2.1100D-01 5.4320D-01 7.5610D-01 1.7130D-01 5.5400D-01
+ -1.7029D+00 0.0000D+00 6.7909D-01 6.7220D-01
+ -1.0307D+00 0.0000D+00 7.2671D-01 2.0436D-01
+ 2.8487D-01 1.2101D+00 3.9757D-01 4.9797D-01
+ 2.8487D-01 -1.2101D+00 3.9757D-01 4.9797D-01
+ 1.1675D+00 4.6631D-01 4.2334D-01 1.9048D-01
+ 1.1675D+00 -4.6631D-01 4.2334D-01 1.9048D-01
+ 10
+ -1.0639D+00 1.6120D-01 1.5620D-01 3.4360D-01 -6.7480D-01 1.6598D+00
+ 6.4650D-01 -7.8630D-01 -2.6100D-01 7.0190D-01
+ -8.4400D-01 -2.2439D+00 1.8800D+00 -1.0005D+00 7.4500D-02 -1.6156D+00
+ 2.8220D-01 8.5600D-01 1.3497D+00 -1.5883D+00
+ 1.5988D+00 1.1758D+00 1.2398D+00 1.1173D+00 2.1500D-01 4.3140D-01
+ 1.8500D-01 7.9470D-01 6.6260D-01 8.6460D-01
+ -2.2960D-01 1.2442D+00 2.3242D+00 -5.0690D-01 -7.5160D-01 -5.4370D-01
+ -2.5990D-01 1.2830D+00 -1.1067D+00 -1.1150D-01
+ -3.6040D-01 4.0420D-01 6.1240D-01 -1.2164D+00 -9.4650D-01 -3.1460D-01
+ 1.8310D-01 7.3710D-01 1.4278D+00 2.9220D-01
+ 4.6150D-01 3.8740D-01 -4.2900D-02 -9.3600D-01 7.1160D-01 -8.2590D-01
+ -1.7640D+00 -9.4660D-01 1.8202D+00 -2.5480D-01
+ 1.2934D+00 -9.7550D-01 6.7480D-01 -1.0481D+00 -1.8442D+00 -5.4600D-02
+ 7.4050D-01 6.1000D-03 1.2430D+00 -1.8490D-01
+ -3.4710D-01 -9.5800D-01 1.6530D-01 9.1300D-02 -5.2010D-01 -1.1832D+00
+ 8.5410D-01 -2.3200D-01 -1.6155D+00 5.5180D-01
+ 1.0190D+00 -6.8240D-01 8.0850D-01 2.5950D-01 -3.7580D-01 -1.8825D+00
+ 1.6473D+00 -6.5920D-01 8.0250D-01 -4.9000D-03
+ 1.2670D+00 -4.2400D-02 8.9570D-01 -1.6770D-01 1.4620D-01 9.8800D-01
+ -2.3170D-01 -1.4483D+00 -5.8200D-02 1.9700D-02
+ -2.6992D+00 9.0387D-01 6.4005D-01 4.1615D-01
+ -2.6992D+00 -9.0387D-01 6.4005D-01 4.1615D-01
+ -2.4366D+00 0.0000D+00 6.9083D-01 2.5476D-01
+ -1.2882D+00 8.8930D-01 5.3435D-01 6.0878D-01
+ -1.2882D+00 -8.8930D-01 5.3435D-01 6.0878D-01
+ 9.0275D-01 0.0000D+00 2.9802D-01 4.7530D-01
+ 9.0442D-01 2.5661D+00 7.3193D-01 6.2016D-01
+ 9.0442D-01 -2.5661D+00 7.3193D-01 6.2016D-01
+ 1.6774D+00 0.0000D+00 3.0743D-01 4.1726D-01
+ 3.0060D+00 0.0000D+00 8.5623D-01 4.3175D-01
+ 4
+ -1.2298D+00 -2.3142D+00 -6.9800D-02 1.0523D+00
+ 2.0390D-01 -1.2298D+00 8.0500D-02 9.7860D-01
+ 0.0000D+00 0.0000D+00 2.5600D-01 -8.9100D-01
+ 0.0000D+00 0.0000D+00 2.7480D-01 2.5600D-01
+ -1.2298D+00 6.8692D-01 4.7136D-01 7.1772D-01
+ -1.2298D+00 -6.8692D-01 4.7136D-01 7.1772D-01
+ 2.5600D-01 4.9482D-01 8.0960D-01 5.1408D-01
+ 2.5600D-01 -4.9482D-01 8.0960D-01 5.1408D-01
+ 6
+ 5.9930D-01 1.9372D+00 -1.6160D-01 -1.4602D+00 6.0180D-01 2.7120D+00
+ -2.2049D+00 5.9930D-01 -1.0679D+00 1.9405D+00 -1.4400D+00 -2.2110D-01
+ 0.0000D+00 0.0000D+00 -2.4567D+00 -6.8650D-01 -1.9101D+00 6.4960D-01
+ 0.0000D+00 0.0000D+00 0.0000D+00 7.3620D-01 3.9700D-01 -1.5190D-01
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 -1.0034D+00 1.1954D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 -1.3400D-01 -1.0034D+00
+ -2.4567D+00 0.0000D+00 4.7091D-01 8.5788D-01
+ -1.0034D+00 4.0023D-01 3.6889D-01 1.8909D-01
+ -1.0034D+00 -4.0023D-01 3.6889D-01 1.8909D-01
+ 5.9930D-01 2.0667D+00 5.8849D-01 1.3299D+00
+ 5.9930D-01 -2.0667D+00 5.8849D-01 1.3299D+00
+ 7.3620D-01 0.0000D+00 6.0845D-01 9.6725D-01
+ 4
+ 1.0000D-04 1.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 -1.0000D-04 1.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 1.0000D-02 1.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 -5.0000D-03
+ -5.0000D-03 0.0000D+00 3.7485D-07 3.6932D-07
+ -1.0000D-04 0.0000D+00 9.8979D-09 9.8493D-09
+ 1.0000D-04 0.0000D+00 1.0098D-08 1.0046D-08
+ 1.0000D-02 0.0000D+00 1.4996D-06 1.4773D-06
+ 3
+ 2.0000D-06 1.0000D+00 -2.0000D+00
+ 1.0000D-06 -2.0000D+00 4.0000D+00
+ 0.0000D+00 1.0000D+00 -2.0000D+00
+ -4.0000D+00 0.0000D+00 7.3030D-01 4.0000D+00
+ 0.0000D+00 0.0000D+00 7.2801D-01 1.3726D-06
+ 2.2096D-06 0.0000D+00 8.2763D-01 2.2096D-06
+ 6
+ 2.4080D-01 6.5530D-01 9.1660D-01 5.0300D-02 2.8490D-01 2.4080D-01
+ 6.9070D-01 9.7000D-01 1.4020D-01 5.7820D-01 6.7670D-01 6.9070D-01
+ 1.0620D-01 3.8000D-02 7.0540D-01 2.4320D-01 8.6420D-01 1.0620D-01
+ 2.6400D-01 9.8800D-02 1.7800D-02 9.4480D-01 1.9430D-01 2.6400D-01
+ 7.0340D-01 2.5600D-01 2.6110D-01 5.8760D-01 5.8000D-02 7.0340D-01
+ 4.0210D-01 5.5980D-01 1.3580D-01 7.2560D-01 6.9080D-01 4.0210D-01
+ -3.4008D-01 3.2133D-01 5.7839D-01 2.0310D-01
+ -3.4008D-01 -3.2133D-01 5.7839D-01 2.0310D-01
+ -1.6998D-07 0.0000D+00 4.9641D-01 2.1574D-01
+ 7.2311D-01 5.9389D-02 7.0039D-01 4.1945D-02
+ 7.2311D-01 -5.9389D-02 7.0039D-01 4.1945D-02
+ 2.5551D+00 0.0000D+00 9.2518D-01 1.7390D+00
+ 6
+ 3.4800D+00 -2.9900D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ -4.9000D-01 2.4800D+00 -1.9900D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 -4.9000D-01 1.4800D+00 -9.9000D-01 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 -9.9000D-01 1.4800D+00 -4.9000D-01 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 -1.9900D+00 2.4800D+00 -4.9000D-01
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 -2.9900D+00 3.4800D+00
+ 1.3034D-02 0.0000D+00 7.5301D-01 6.0533D-01
+ 1.1294D+00 0.0000D+00 6.0479D-01 2.8613D-01
+ 2.0644D+00 0.0000D+00 5.4665D-01 1.7376D-01
+ 2.8388D+00 0.0000D+00 4.2771D-01 3.0915D-01
+ 4.3726D+00 0.0000D+00 6.6370D-01 7.6443D-02
+ 4.4618D+00 0.0000D+00 5.7388D-01 8.9227D-02
+ 6
+ 0.0000D+00 1.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 1.0000D+00
+ 1.0000D+00 0.0000D+00 1.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 1.0000D+00 0.0000D+00 1.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 1.0000D+00 0.0000D+00 1.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 1.0000D+00 0.0000D+00 1.0000D+00
+ -1.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 1.0000D+00 0.0000D+00
+ -1.7321D+00 0.0000D+00 8.6603D-01 7.2597D-01
+ -1.0000D+00 0.0000D+00 5.0000D-01 2.6417D-01
+ 0.0000D+00 0.0000D+00 2.9582D-31 1.4600D-07
+ 0.0000D+00 0.0000D+00 2.9582D-31 6.2446D-08
+ 1.0000D+00 0.0000D+00 5.0000D-01 2.6417D-01
+ 1.7321D+00 0.0000D+00 8.6603D-01 3.7896D-01
+ 6
+ 3.5345D-01 9.3023D-01 7.4679D-02 -1.0059D-02 4.6698D-02 -4.3480D-02
+ 9.3545D-01 -3.5147D-01 -2.8216D-02 3.8008D-03 -1.7644D-02 1.6428D-02
+ 0.0000D+00 -1.0555D-01 7.5211D-01 -1.0131D-01 4.7030D-01 -4.3789D-01
+ 0.0000D+00 0.0000D+00 6.5419D-01 1.1779D-01 -5.4678D-01 5.0911D-01
+ 0.0000D+00 0.0000D+00 0.0000D+00 -9.8780D-01 -1.1398D-01 1.0612D-01
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 6.8144D-01 7.3187D-01
+ -9.9980D-01 1.9645D-02 1.0000D+00 3.9290D-02
+ -9.9980D-01 -1.9645D-02 1.0000D+00 3.9290D-02
+ 7.4539D-01 6.6663D-01 1.0000D+00 5.2120D-01
+ 7.4539D-01 -6.6663D-01 1.0000D+00 5.2120D-01
+ 9.9929D-01 3.7545D-02 1.0000D+00 7.5089D-02
+ 9.9929D-01 -3.7545D-02 1.0000D+00 7.5089D-02
+ 6
+ 1.0000D+00 1.0000D+00 1.0000D+00 1.0000D+00 1.0000D+00 1.0000D+00
+ 5.0000D-01 3.3330D-01 2.5000D-01 2.0000D-01 1.6670D-01 1.4290D-01
+ 3.3330D-01 2.5000D-01 2.0000D-01 1.6670D-01 1.4290D-01 1.2500D-01
+ 2.5000D-01 2.0000D-01 1.6670D-01 1.4290D-01 1.2500D-01 1.1110D-01
+ 2.0000D-01 1.6670D-01 1.4290D-01 1.2500D-01 1.1110D-01 1.0000D-01
+ 1.6670D-01 1.4290D-01 1.2500D-01 1.1110D-01 1.0000D-01 9.0900D-02
+ -2.2135D-01 0.0000D+00 4.0841D-01 1.6605D-01
+ -3.1956D-02 0.0000D+00 3.7927D-01 3.0531D-02
+ -8.5031D-04 0.0000D+00 6.2793D-01 7.8195D-04
+ -5.8584D-05 0.0000D+00 8.1156D-01 7.2478D-05
+ 1.3895D-05 0.0000D+00 9.7087D-01 7.2478D-05
+ 2.1324D+00 0.0000D+00 8.4325D-01 1.8048D+00
+ 12
+ 1.2000D+01 1.1000D+01 1.0000D+01 9.0000D+00 8.0000D+00 7.0000D+00
+ 6.0000D+00 5.0000D+00 4.0000D+00 3.0000D+00 2.0000D+00 1.0000D+00
+ 1.1000D+01 1.1000D+01 1.0000D+01 9.0000D+00 8.0000D+00 7.0000D+00
+ 6.0000D+00 5.0000D+00 4.0000D+00 3.0000D+00 2.0000D+00 1.0000D+00
+ 0.0000D+00 1.0000D+01 1.0000D+01 9.0000D+00 8.0000D+00 7.0000D+00
+ 6.0000D+00 5.0000D+00 4.0000D+00 3.0000D+00 2.0000D+00 1.0000D+00
+ 0.0000D+00 0.0000D+00 9.0000D+00 9.0000D+00 8.0000D+00 7.0000D+00
+ 6.0000D+00 5.0000D+00 4.0000D+00 3.0000D+00 2.0000D+00 1.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 8.0000D+00 8.0000D+00 7.0000D+00
+ 6.0000D+00 5.0000D+00 4.0000D+00 3.0000D+00 2.0000D+00 1.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 7.0000D+00 7.0000D+00
+ 6.0000D+00 5.0000D+00 4.0000D+00 3.0000D+00 2.0000D+00 1.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 6.0000D+00
+ 6.0000D+00 5.0000D+00 4.0000D+00 3.0000D+00 2.0000D+00 1.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 5.0000D+00 5.0000D+00 4.0000D+00 3.0000D+00 2.0000D+00 1.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 4.0000D+00 4.0000D+00 3.0000D+00 2.0000D+00 1.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 3.0000D+00 3.0000D+00 2.0000D+00 1.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 2.0000D+00 2.0000D+00 1.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 1.0000D+00 1.0000D+00
+ -2.8234D-02 0.0000D+00 2.8690D-06 3.2094D-06
+ 7.2587D-02 9.0746D-02 1.5885D-06 9.9934D-07
+ 7.2587D-02 -9.0746D-02 1.5885D-06 9.9934D-07
+ 1.8533D-01 0.0000D+00 6.5757D-07 7.8673D-07
+ 2.8828D-01 0.0000D+00 1.8324D-06 2.0796D-06
+ 6.4315D-01 0.0000D+00 6.8640D-05 6.1058D-05
+ 1.5539D+00 0.0000D+00 4.6255D-03 6.4028D-03
+ 3.5119D+00 0.0000D+00 1.4447D-01 1.9470D-01
+ 6.9615D+00 0.0000D+00 5.8447D-01 1.2016D+00
+ 1.2311D+01 0.0000D+00 3.1823D-01 1.4273D+00
+ 2.0199D+01 0.0000D+00 2.0079D-01 2.4358D+00
+ 3.2229D+01 0.0000D+00 3.0424D-01 5.6865D+00
+ 6
+ 0.0000D+00 1.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 5.0000D+00 0.0000D+00 2.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 4.0000D+00 0.0000D+00 3.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 3.0000D+00 0.0000D+00 4.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 2.0000D+00 0.0000D+00 5.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 1.0000D+00 0.0000D+00
+ -5.0000D+00 0.0000D+00 8.2295D-01 1.2318D+00
+ -3.0000D+00 0.0000D+00 7.2281D-01 7.5970D-01
+ -1.0000D+00 0.0000D+00 6.2854D-01 6.9666D-01
+ 1.0000D+00 0.0000D+00 6.2854D-01 6.9666D-01
+ 3.0000D+00 0.0000D+00 7.2281D-01 7.5970D-01
+ 5.0000D+00 0.0000D+00 8.2295D-01 1.2318D+00
+ 6
+ 1.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 1.0000D+00
+ -1.0000D+00 1.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 1.0000D+00
+ -1.0000D+00 -1.0000D+00 1.0000D+00 0.0000D+00 0.0000D+00 1.0000D+00
+ -1.0000D+00 -1.0000D+00 -1.0000D+00 1.0000D+00 0.0000D+00 1.0000D+00
+ -1.0000D+00 -1.0000D+00 -1.0000D+00 -1.0000D+00 1.0000D+00 1.0000D+00
+ -1.0000D+00 -1.0000D+00 -1.0000D+00 -1.0000D+00 -1.0000D+00 1.0000D+00
+ 8.0298D-02 2.4187D+00 8.9968D-01 1.5236D+00
+ 8.0298D-02 -2.4187D+00 8.9968D-01 1.5236D+00
+ 1.4415D+00 6.2850D-01 9.6734D-01 4.2793D-01
+ 1.4415D+00 -6.2850D-01 9.6734D-01 4.2793D-01
+ 1.4782D+00 1.5638D-01 9.7605D-01 2.2005D-01
+ 1.4782D+00 -1.5638D-01 9.7605D-01 2.2005D-01
+ 6
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 1.0000D+00
+ 1.0000D+00 1.0000D+00 0.0000D+00 0.0000D+00 1.0000D+00 1.0000D+00
+ 0.0000D+00 1.0000D+00 1.0000D+00 1.0000D+00 0.0000D+00 1.0000D+00
+ 1.0000D+00 0.0000D+00 1.0000D+00 1.0000D+00 1.0000D+00 1.0000D+00
+ 1.0000D+00 0.0000D+00 1.0000D+00 1.0000D+00 1.0000D+00 0.0000D+00
+ 0.0000D+00 1.0000D+00 0.0000D+00 1.0000D+00 1.0000D+00 1.0000D+00
+ -3.5343D-02 7.4812D-01 3.9345D-01 1.8415D-01
+ -3.5343D-02 -7.4812D-01 3.9345D-01 1.8415D-01
+ 5.8440D-07 0.0000D+00 2.8868D-01 1.7003D-01
+ 6.4087D-01 7.2822D-01 4.5013D-01 2.9425D-01
+ 6.4087D-01 -7.2822D-01 4.5013D-01 2.9425D-01
+ 3.7889D+00 0.0000D+00 9.6305D-01 2.2469D+00
+ 6
+ 1.0000D+00 4.0112D+00 1.2750D+01 4.0213D+01 1.2656D+02 3.9788D+02
+ 1.0000D+00 3.2616D+00 1.0629D+01 3.3342D+01 1.0479D+02 3.2936D+02
+ 1.0000D+00 3.1500D+00 9.8006D+00 3.0630D+01 9.6164D+01 3.0215D+02
+ 1.0000D+00 3.2755D+00 1.0420D+01 3.2957D+01 1.0374D+02 3.2616D+02
+ 1.0000D+00 2.8214D+00 8.4558D+00 2.6296D+01 8.2443D+01 2.5893D+02
+ 1.0000D+00 2.6406D+00 8.3565D+00 2.6558D+01 8.3558D+01 2.6268D+02
+ -5.3220D-01 0.0000D+00 5.3287D-01 3.8557D-01
+ -1.0118D-01 0.0000D+00 7.2342D-01 9.1303D-02
+ -9.8749D-03 0.0000D+00 7.3708D-01 1.1032D-02
+ 2.9861D-03 0.0000D+00 4.4610D-01 1.2861D-02
+ 1.8075D-01 0.0000D+00 4.2881D-01 1.7378D-01
+ 3.9260D+02 0.0000D+00 4.8057D-01 3.9201D+02
+ 8
+ 0.0000D+00 4.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00
+ 1.0000D+00 0.0000D+00 4.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00
+ 0.0000D+00 1.0000D+00 0.0000D+00 4.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 1.0000D+00 0.0000D+00 4.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 1.0000D+00 0.0000D+00 4.0000D+00
+ 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 1.0000D+00 0.0000D+00
+ 4.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 1.0000D+00
+ 0.0000D+00 4.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 1.0000D+00 0.0000D+00
+ -3.7588D+00 0.0000D+00 1.2253D-01 1.2978D-01
+ -3.0642D+00 0.0000D+00 4.9811D-02 8.0162D-02
+ -2.0000D+00 0.0000D+00 3.6914D-02 8.2942D-02
+ -6.9459D-01 0.0000D+00 3.3328D-02 1.3738D-01
+ 6.9459D-01 0.0000D+00 3.3328D-02 1.1171D-01
+ 2.0000D+00 0.0000D+00 3.6914D-02 7.2156D-02
+ 3.0642D+00 0.0000D+00 4.9811D-02 6.8352D-02
+ 3.7588D+00 0.0000D+00 1.2253D-01 1.1527D-01
+ 6
+ 8.5000D+00 -1.0472D+01 2.8944D+00 -1.5279D+00 1.1056D+00 -5.0000D-01
+ 2.6180D+00 -1.1708D+00 -2.0000D+00 8.9440D-01 -6.1800D-01 2.7640D-01
+ -7.2360D-01 2.0000D+00 -1.7080D-01 -1.6180D+00 8.9440D-01 -3.8200D-01
+ 3.8200D-01 -8.9440D-01 1.6180D+00 1.7080D-01 -2.0000D+00 7.2360D-01
+ -2.7640D-01 6.1800D-01 -8.9440D-01 2.0000D+00 1.1708D+00 -2.6180D+00
+ 5.0000D-01 -1.1056D+00 1.5279D+00 -2.8944D+00 1.0472D+01 -8.5000D+00
+ -5.8930D-01 0.0000D+00 1.7357D-04 2.8157D-04
+ -2.7627D-01 4.9852D-01 1.7486D-04 1.6704D-04
+ -2.7627D-01 -4.9852D-01 1.7486D-04 1.6704D-04
+ 2.7509D-01 5.0059D-01 1.7635D-04 1.6828D-04
+ 2.7509D-01 -5.0059D-01 1.7635D-04 1.6828D-04
+ 5.9167D-01 0.0000D+00 1.7623D-04 3.0778D-04
+ 4
+ 4.0000D+00 -5.0000D+00 0.0000D+00 3.0000D+00
+ 0.0000D+00 4.0000D+00 -3.0000D+00 -5.0000D+00
+ 5.0000D+00 -3.0000D+00 4.0000D+00 0.0000D+00
+ 3.0000D+00 0.0000D+00 5.0000D+00 4.0000D+00
+ 1.0000D+00 5.0000D+00 1.0000D+00 4.3333D+00
+ 1.0000D+00 -5.0000D+00 1.0000D+00 4.3333D+00
+ 2.0000D+00 0.0000D+00 1.0000D+00 4.3333D+00
+ 1.2000D+01 0.0000D+00 1.0000D+00 9.1250D+00
+ 5
+ 1.5000D+01 1.1000D+01 6.0000D+00 -9.0000D+00 -1.5000D+01
+ 1.0000D+00 3.0000D+00 9.0000D+00 -3.0000D+00 -8.0000D+00
+ 7.0000D+00 6.0000D+00 6.0000D+00 -3.0000D+00 -1.1000D+01
+ 7.0000D+00 7.0000D+00 5.0000D+00 -3.0000D+00 -1.1000D+01
+ 1.7000D+01 1.2000D+01 5.0000D+00 -1.0000D+01 -1.6000D+01
+ -9.9999D-01 0.0000D+00 2.1768D-01 5.2263D-01
+ 1.4980D+00 3.5752D+00 3.9966D-04 6.0947D-03
+ 1.4980D+00 -3.5752D+00 3.9966D-04 6.0947D-03
+ 1.5020D+00 3.5662D+00 3.9976D-04 6.0960D-03
+ 1.5020D+00 -3.5662D+00 3.9976D-04 6.0960D-03
+ 6
+ -9.0000D+00 2.1000D+01 -1.5000D+01 4.0000D+00 2.0000D+00 0.0000D+00
+ -1.0000D+01 2.1000D+01 -1.4000D+01 4.0000D+00 2.0000D+00 0.0000D+00
+ -8.0000D+00 1.6000D+01 -1.1000D+01 4.0000D+00 2.0000D+00 0.0000D+00
+ -6.0000D+00 1.2000D+01 -9.0000D+00 3.0000D+00 3.0000D+00 0.0000D+00
+ -4.0000D+00 8.0000D+00 -6.0000D+00 0.0000D+00 5.0000D+00 0.0000D+00
+ -2.0000D+00 4.0000D+00 -3.0000D+00 0.0000D+00 1.0000D+00 3.0000D+00
+ 1.0000D+00 6.2559D-04 6.4875D-05 5.0367D-04
+ 1.0000D+00 -6.2559D-04 6.4875D-05 5.0367D-04
+ 2.0000D+00 1.0001D+00 5.4076D-02 2.3507D-01
+ 2.0000D+00 -1.0001D+00 5.4076D-02 2.3507D-01
+ 3.0000D+00 0.0000D+00 8.6149D-01 5.4838D-07
+ 3.0000D+00 0.0000D+00 1.2425D-01 1.2770D-06
+ 10
+ 1.0000D+00 1.0000D+00 1.0000D+00 -2.0000D+00 1.0000D+00 -1.0000D+00
+ 2.0000D+00 -2.0000D+00 4.0000D+00 -3.0000D+00
+ -1.0000D+00 2.0000D+00 3.0000D+00 -4.0000D+00 2.0000D+00 -2.0000D+00
+ 4.0000D+00 -4.0000D+00 8.0000D+00 -6.0000D+00
+ -1.0000D+00 0.0000D+00 5.0000D+00 -5.0000D+00 3.0000D+00 -3.0000D+00
+ 6.0000D+00 -6.0000D+00 1.2000D+01 -9.0000D+00
+ -1.0000D+00 0.0000D+00 3.0000D+00 -4.0000D+00 4.0000D+00 -4.0000D+00
+ 8.0000D+00 -8.0000D+00 1.6000D+01 -1.2000D+01
+ -1.0000D+00 0.0000D+00 3.0000D+00 -6.0000D+00 5.0000D+00 -4.0000D+00
+ 1.0000D+01 -1.0000D+01 2.0000D+01 -1.5000D+01
+ -1.0000D+00 0.0000D+00 3.0000D+00 -6.0000D+00 2.0000D+00 -2.0000D+00
+ 1.2000D+01 -1.2000D+01 2.4000D+01 -1.8000D+01
+ -1.0000D+00 0.0000D+00 3.0000D+00 -6.0000D+00 2.0000D+00 -5.0000D+00
+ 1.5000D+01 -1.3000D+01 2.8000D+01 -2.1000D+01
+ -1.0000D+00 0.0000D+00 3.0000D+00 -6.0000D+00 2.0000D+00 -5.0000D+00
+ 1.2000D+01 -1.1000D+01 3.2000D+01 -2.4000D+01
+ -1.0000D+00 0.0000D+00 3.0000D+00 -6.0000D+00 2.0000D+00 -5.0000D+00
+ 1.2000D+01 -1.4000D+01 3.7000D+01 -2.6000D+01
+ -1.0000D+00 0.0000D+00 3.0000D+00 -6.0000D+00 2.0000D+00 -5.0000D+00
+ 1.2000D+01 -1.4000D+01 3.6000D+01 -2.5000D+01
+ 1.0000D+00 0.0000D+00 3.6037D-02 7.9613D-02
+ 1.9867D+00 0.0000D+00 7.4283D-05 7.4025D-06
+ 2.0000D+00 2.5052D-03 1.4346D-04 6.7839D-07
+ 2.0000D+00 -2.5052D-03 1.4346D-04 6.7839D-07
+ 2.0067D+00 1.1763D-02 6.7873D-05 5.7496D-06
+ 2.0067D+00 -1.1763D-02 6.7873D-05 5.7496D-06
+ 2.9970D+00 0.0000D+00 9.2779D-05 2.6519D-06
+ 3.0000D+00 8.7028D-04 2.7358D-04 1.9407D-07
+ 3.0000D+00 -8.7028D-04 2.7358D-04 1.9407D-07
+ 3.0030D+00 0.0000D+00 9.2696D-05 2.6477D-06
+ 0
+ 1 1
+ 1
+ 0.00000D+00
+ 1.00000D+00 0.00000D+00
+ 1 1
+ 1
+ 1.00000D+00
+ 1.00000D+00 1.00000D+00
+ 6 3
+ 4 5 6
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 1.00000D+00 4.43734D-31
+ 6 3
+ 4 5 6
+ 1.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 1.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 1.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+00
+ 1.00000D+00 1.19209D-07
+ 6 3
+ 4 5 6
+ 1.00000D+00 1.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 1.00000D+00 1.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 1.00000D+00 1.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+00 1.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+00 1.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+00
+ 4.01235D-36 3.20988D-36
+ 6 3
+ 4 5 6
+ 1.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 1.00000D+00 1.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 1.00000D+00 1.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 1.00000D+00 1.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+00 1.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+00 1.00000D+00
+ 4.01235D-36 3.20988D-36
+ 6 3
+ 4 5 6
+ 1.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 2.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 3.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 4.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 5.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 6.00000D+00
+ 1.00000D+00 1.00000D+00
+ 2 1
+ 1
+ 1.00000D+00 2.00000D+00
+ 0.00000D+00 3.00000D+00
+ 7.07107D-01 2.00000D+00
+ 4 2
+ 1 2
+ 8.52400D-01 5.61100D-01 7.04300D-01 9.54000D-01
+ 2.79800D-01 7.21600D-01 9.61300D-01 3.58200D-01
+ 7.08100D-01 4.09400D-01 2.25000D-01 9.51800D-01
+ 5.54300D-01 5.22000D-01 6.86000D-01 3.07000D-02
+ 7.22196D-01 4.63943D-01
+ 7 6
+ 1 2 3 4 5 6
+ 7.81800D-01 5.65700D-01 7.62100D-01 7.43600D-01 2.55300D-01 4.10000D-01
+ 1.34000D-02
+ 6.45800D-01 2.66600D-01 5.51000D-01 8.31800D-01 9.27100D-01 6.20900D-01
+ 7.83900D-01
+ 1.31600D-01 4.91400D-01 1.77100D-01 1.96400D-01 1.08500D-01 9.27000D-01
+ 2.24700D-01
+ 6.41000D-01 4.68900D-01 9.65900D-01 8.88400D-01 3.76900D-01 9.67300D-01
+ 6.18300D-01
+ 8.38200D-01 8.74300D-01 4.50700D-01 9.44200D-01 7.75500D-01 9.67600D-01
+ 7.83100D-01
+ 3.25900D-01 7.38900D-01 8.30200D-01 4.52100D-01 3.01500D-01 2.13300D-01
+ 8.43400D-01
+ 5.24400D-01 5.01600D-01 7.52900D-01 3.83800D-01 8.47900D-01 9.12800D-01
+ 5.77000D-01
+ 9.43220D-01 3.20530D+00
+ 4 2
+ 2 3
+ -9.85900D-01 1.47840D+00 -1.33600D-01 -2.95970D+00
+ -4.33700D-01 -6.54000D-01 -7.15500D-01 1.23760D+00
+ -7.36300D-01 -1.97680D+00 -1.95100D-01 3.43200D-01
+ 6.41400D-01 -1.40880D+00 6.39400D-01 8.58000D-02
+ 5.22869D-01 5.45530D-01
+ 7 5
+ 1 2 3 4 5
+ 2.72840D+00 2.15200D-01 -1.05200D+00 -2.44600D-01 -6.53000D-02 3.90500D-01
+ 1.40980D+00
+ 9.75300D-01 6.51500D-01 -4.76200D-01 5.42100D-01 6.20900D-01 4.75900D-01
+ -1.44930D+00
+ -9.05200D-01 1.79000D-01 -7.08600D-01 4.62100D-01 1.05800D+00 2.24260D+00
+ 1.58260D+00
+ -7.17900D-01 -2.53400D-01 -4.73900D-01 -1.08100D+00 4.13800D-01 -9.50000D-02
+ 1.45300D-01
+ -1.37990D+00 -1.06490D+00 1.25580D+00 7.80100D-01 -6.40500D-01 -8.61000D-02
+ 8.30000D-02
+ 2.84900D-01 -1.29900D-01 4.80000D-02 -2.58600D-01 4.18900D-01 1.37680D+00
+ 8.20800D-01
+ -5.44200D-01 9.74900D-01 9.55800D-01 1.23700D-01 1.09020D+00 -1.40600D-01
+ 1.90960D+00
+ 6.04729D-01 9.00391D-01
+ 6 4
+ 3 4 5 6
+ 0.00000D+00 1.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 1.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+00 0.00000D+00
+ 1.00000D-06 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 5.00000D-01
+ 4.89525D-05 4.56492D-05
+ 8 4
+ 1 2 3 4
+ 1.00000D+00 -1.00000D+00 0.00000D+00 0.00000D+00 1.00000D+01 0.00000D+00
+ 1.00000D+01 0.00000D+00
+ 0.00000D+00 1.00000D+00 -1.00000D+00 0.00000D+00 0.00000D+00 1.00000D+01
+ 1.00000D+01 0.00000D+00
+ 0.00000D+00 0.00000D+00 1.00000D+00 -1.00000D+00 0.00000D+00 1.00000D+01
+ 1.00000D+01 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+00 0.00000D+00 1.00000D+01
+ 0.00000D+00 1.00000D+01
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 5.00000D-01 1.00000D+00
+ 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 5.00000D-01
+ 1.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 5.00000D-01 1.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 5.00000D-01
+ 9.56158D-05 4.14317D-05
+ 9 3
+ 1 2 3
+ 1.00000D+00 -1.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 1.00000D+00 -1.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 1.00000D+00 -1.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+00 -1.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+00 -1.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 7.50000D-01 1.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 7.50000D-01 1.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 7.50000D-01
+ 1.00000D+00 5.55801D-07
+ 10 4
+ 1 2 3 4
+ 1.00000D+00 -1.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 1.00000D+00 -1.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 1.00000D+00 -1.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+00 -1.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+00 -1.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 8.75000D-01 1.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 8.75000D-01 1.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 8.75000D-01 1.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 8.75000D-01
+ 1.00000D+00 1.16972D-10
+ 12 6
+ 1 2 3 4 5 6
+ 1.00000D+00 -1.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 1.00000D+01 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 1.00000D+00 -1.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 1.00000D+01 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 1.00000D+00 -1.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 1.00000D+01 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+00 -1.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+01 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+00 -1.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+01 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+01
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 9.37500D-01 1.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 9.37500D-01 1.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 9.37500D-01 1.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 9.37500D-01 1.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 9.37500D-01 1.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 9.37500D-01
+ 1.85655D-10 2.20147D-16
+ 12 7
+ 6 7 8 9 10 11 12
+ 1.20000D+01 1.10000D+01 1.00000D+01 9.00000D+00 8.00000D+00 7.00000D+00
+ 6.00000D+00 5.00000D+00 4.00000D+00 3.00000D+00 2.00000D+00 1.00000D+00
+ 1.10000D+01 1.10000D+01 1.00000D+01 9.00000D+00 8.00000D+00 7.00000D+00
+ 6.00000D+00 5.00000D+00 4.00000D+00 3.00000D+00 2.00000D+00 1.00000D+00
+ 0.00000D+00 1.00000D+01 1.00000D+01 9.00000D+00 8.00000D+00 7.00000D+00
+ 6.00000D+00 5.00000D+00 4.00000D+00 3.00000D+00 2.00000D+00 1.00000D+00
+ 0.00000D+00 0.00000D+00 9.00000D+00 9.00000D+00 8.00000D+00 7.00000D+00
+ 6.00000D+00 5.00000D+00 4.00000D+00 3.00000D+00 2.00000D+00 1.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 8.00000D+00 8.00000D+00 7.00000D+00
+ 6.00000D+00 5.00000D+00 4.00000D+00 3.00000D+00 2.00000D+00 1.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 7.00000D+00 7.00000D+00
+ 6.00000D+00 5.00000D+00 4.00000D+00 3.00000D+00 2.00000D+00 1.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 6.00000D+00
+ 6.00000D+00 5.00000D+00 4.00000D+00 3.00000D+00 2.00000D+00 1.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 5.00000D+00 5.00000D+00 4.00000D+00 3.00000D+00 2.00000D+00 1.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 4.00000D+00 4.00000D+00 3.00000D+00 2.00000D+00 1.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 3.00000D+00 3.00000D+00 2.00000D+00 1.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 2.00000D+00 2.00000D+00 1.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+00 1.00000D+00
+ 6.92558D-05 5.52606D-05
+ 3 1
+ 1
+ 2.00000D-06 1.00000D+00 -2.00000D+00
+ 1.00000D-06 -2.00000D+00 4.00000D+00
+ 0.00000D+00 1.00000D+00 -2.00000D+00
+ 7.30297D-01 4.00000D+00
+ 5 1
+ 3
+ 2.00000D-03 1.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 1.00000D-03 1.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 -1.00000D-03 1.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 -2.00000D-03 1.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 3.99999D-12 3.99201D-12
+ 6 4
+ 1 2 3 5
+ 1.00000D+00 1.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 1.00000D+00 1.00000D+00 1.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 1.00000D+00 1.00000D+00 1.00000D+00 1.00000D+00 0.00000D+00 0.00000D+00
+ 1.00000D+00 1.00000D+00 1.00000D+00 1.00000D+00 1.00000D+00 0.00000D+00
+ 1.00000D+00 1.00000D+00 1.00000D+00 1.00000D+00 1.00000D+00 1.00000D+00
+ 1.00000D+00 1.00000D+00 1.00000D+00 1.00000D+00 1.00000D+00 1.00000D+00
+ 2.93294D-01 1.63448D-01
+ 6 2
+ 3 4
+ 0.00000D+00 1.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+00
+ 1.00000D+00 0.00000D+00 1.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 1.00000D+00 0.00000D+00 1.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 1.00000D+00 0.00000D+00 1.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+00 0.00000D+00 1.00000D+00
+ -1.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+00 0.00000D+00
+ 3.97360D-01 3.58295D-01
+ 6 3
+ 3 4 5
+ 1.00000D+00 1.00000D+00 1.00000D+00 1.00000D+00 1.00000D+00 1.00000D+00
+ 5.00000D-01 3.33300D-01 2.50000D-01 2.00000D-01 1.66700D-01 1.42900D-01
+ 3.33300D-01 2.50000D-01 2.00000D-01 1.66700D-01 1.42900D-01 1.25000D-01
+ 2.50000D-01 2.00000D-01 1.66700D-01 1.42900D-01 1.25000D-01 1.11100D-01
+ 2.00000D-01 1.66700D-01 1.42900D-01 1.25000D-01 1.11100D-01 1.00000D-01
+ 1.66700D-01 1.42900D-01 1.25000D-01 1.11100D-01 1.00000D-01 9.09000D-02
+ 7.28934D-01 1.24624D-02
+ 5 1
+ 1
+ 1.50000D+01 1.10000D+01 6.00000D+00 -9.00000D+00 -1.50000D+01
+ 1.00000D+00 3.00000D+00 9.00000D+00 -3.00000D+00 -8.00000D+00
+ 7.00000D+00 6.00000D+00 6.00000D+00 -3.00000D+00 -1.10000D+01
+ 7.00000D+00 7.00000D+00 5.00000D+00 -3.00000D+00 -1.10000D+01
+ 1.70000D+01 1.20000D+01 5.00000D+00 -1.00000D+01 -1.60000D+01
+ 2.17680D-01 5.22626D-01
+ 6 2
+ 1 2
+ -9.00000D+00 2.10000D+01 -1.50000D+01 4.00000D+00 2.00000D+00 0.00000D+00
+ -1.00000D+01 2.10000D+01 -1.40000D+01 4.00000D+00 2.00000D+00 0.00000D+00
+ -8.00000D+00 1.60000D+01 -1.10000D+01 4.00000D+00 2.00000D+00 0.00000D+00
+ -6.00000D+00 1.20000D+01 -9.00000D+00 3.00000D+00 3.00000D+00 0.00000D+00
+ -4.00000D+00 8.00000D+00 -6.00000D+00 0.00000D+00 5.00000D+00 0.00000D+00
+ -2.00000D+00 4.00000D+00 -3.00000D+00 0.00000D+00 1.00000D+00 3.00000D+00
+ 6.78904D-02 4.22005D-02
+ 10 1
+ 1
+ 1.00000D+00 1.00000D+00 1.00000D+00 -2.00000D+00 1.00000D+00 -1.00000D+00
+ 2.00000D+00 -2.00000D+00 4.00000D+00 -3.00000D+00
+ -1.00000D+00 2.00000D+00 3.00000D+00 -4.00000D+00 2.00000D+00 -2.00000D+00
+ 4.00000D+00 -4.00000D+00 8.00000D+00 -6.00000D+00
+ -1.00000D+00 0.00000D+00 5.00000D+00 -5.00000D+00 3.00000D+00 -3.00000D+00
+ 6.00000D+00 -6.00000D+00 1.20000D+01 -9.00000D+00
+ -1.00000D+00 0.00000D+00 3.00000D+00 -4.00000D+00 4.00000D+00 -4.00000D+00
+ 8.00000D+00 -8.00000D+00 1.60000D+01 -1.20000D+01
+ -1.00000D+00 0.00000D+00 3.00000D+00 -6.00000D+00 5.00000D+00 -4.00000D+00
+ 1.00000D+01 -1.00000D+01 2.00000D+01 -1.50000D+01
+ -1.00000D+00 0.00000D+00 3.00000D+00 -6.00000D+00 2.00000D+00 -2.00000D+00
+ 1.20000D+01 -1.20000D+01 2.40000D+01 -1.80000D+01
+ -1.00000D+00 0.00000D+00 3.00000D+00 -6.00000D+00 2.00000D+00 -5.00000D+00
+ 1.50000D+01 -1.30000D+01 2.80000D+01 -2.10000D+01
+ -1.00000D+00 0.00000D+00 3.00000D+00 -6.00000D+00 2.00000D+00 -5.00000D+00
+ 1.20000D+01 -1.10000D+01 3.20000D+01 -2.40000D+01
+ -1.00000D+00 0.00000D+00 3.00000D+00 -6.00000D+00 2.00000D+00 -5.00000D+00
+ 1.20000D+01 -1.40000D+01 3.70000D+01 -2.60000D+01
+ -1.00000D+00 0.00000D+00 3.00000D+00 -6.00000D+00 2.00000D+00 -5.00000D+00
+ 1.20000D+01 -1.40000D+01 3.60000D+01 -2.50000D+01
+ 3.60372D-02 7.96134D-02
+ 0 0
diff --git a/jlapack-3.1.1/src/testing/eig/ded.in b/jlapack-3.1.1/src/testing/eig/ded.in
new file mode 100644
index 0000000..09f698e
--- /dev/null
+++ b/jlapack-3.1.1/src/testing/eig/ded.in
@@ -0,0 +1,865 @@
+DEV Data file for Real Nonsymmetric Eigenvalue Driver
+6 Number of matrix dimensions
+0 1 2 3 5 10 20 Matrix dimensions
+3 3 1 11 4 8 2 0 Parameters NB, NBMIN, NXOVER, INMIN, INWIN, INIBL, ISHFTS, IACC22
+20.0 Threshold for test ratios
+T
+2 Read another line with random number generator seed
+2518 3899 995 397 Seed for random number generator
+DEV 21 Use all matrix types
+DES Data file for Real Nonsymmetric Schur Form Driver
+6 Number of matrix dimensions
+0 1 2 3 5 10 20 Matrix dimensions
+3 3 1 11 4 8 2 0 Parameters NB, NBMIN, NXOVER, INMIN, INWIN, INIBL, ISHFTS, IACC22
+20.0 Threshold for test ratios
+T
+2 Read another line with random number generator seed
+2518 3899 995 397 Seed for random number generator
+DES 21 Use all matrix types
+DVX Data file for Real Nonsymmetric Eigenvalue Expert Driver
+6 Number of matrix dimensions
+0 1 2 3 5 10 20 Matrix dimensions
+3 3 1 11 4 8 2 0 Parameters NB, NBMIN, NXOVER, INMIN, INWIN, INIBL, ISHFTS, IACC22
+20.0 Threshold for test ratios
+T
+2 Read another line with random number generator seed
+2518 3899 995 397 Seed for random number generator
+DVX 21 Use all matrix types
+ 1
+ 0.0000D+00
+ 0.0000D+00 0.0000D+00 1.0000D+00 0.0000D+00
+ 1
+ 1.0000D+00
+ 1.0000D+00 0.0000D+00 1.0000D+00 1.0000D+00
+ 2
+ 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 1.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 1.0000D+00 0.0000D+00
+ 2
+ 3.0000D+00 2.0000D+00
+ 2.0000D+00 3.0000D+00
+ 1.0000D+00 0.0000D+00 1.0000D+00 4.0000D+00
+ 5.0000D+00 0.0000D+00 1.0000D+00 4.0000D+00
+ 2
+ 3.0000D+00 -2.0000D+00
+ 2.0000D+00 3.0000D+00
+ 3.0000D+00 2.0000D+00 1.0000D+00 4.0000D+00
+ 3.0000D+00 -2.0000D+00 1.0000D+00 4.0000D+00
+ 6
+ 1.0000D-07 -1.0000D-07 1.0000D+00 1.1000D+00 2.3000D+00 3.7000D+00
+ 3.0000D-07 1.0000D-07 1.0000D+00 1.0000D+00 -1.3000D+00 -7.7000D+00
+ 0.0000D+00 0.0000D+00 3.0000D-07 1.0000D-07 2.2000D+00 3.3000D+00
+ 0.0000D+00 0.0000D+00 -1.0000D-07 3.0000D-07 1.8000D+00 1.6000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 4.0000D-06 5.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 3.0000D+00 4.0000D-06
+ -3.8730D+00 0.0000D+00 6.9855D-01 2.2823D+00
+ 1.0000D-07 1.7321D-07 9.7611D-08 5.0060D-14
+ 1.0000D-07 -1.7321D-07 9.7611D-08 5.0060D-14
+ 3.0000D-07 1.0000D-07 1.0000D-07 9.4094D-14
+ 3.0000D-07 -1.0000D-07 1.0000D-07 9.4094D-14
+ 3.8730D+00 0.0000D+00 4.0659D-01 1.5283D+00
+ 4
+ 7.0000D+00 1.0000D+00 1.0000D+00 1.0000D+00
+ -1.0000D+00 1.0000D+00 1.0000D+00 1.0000D+00
+ -1.0000D+00 1.0000D+00 5.0000D+00 -3.0000D+00
+ 1.0000D+00 -1.0000D+00 3.0000D+00 3.0000D+00
+ 3.9603D+00 4.0425D-02 1.1244D-05 3.1179D-05
+ 3.9603D+00 -4.0425D-02 1.1244D-05 3.1179D-05
+ 4.0397D+00 3.8854D-02 1.0807D-05 2.9981D-05
+ 4.0397D+00 -3.8854D-02 1.0807D-05 2.9981D-05
+ 5
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 1.0000D+00 1.9722D-31
+ 0.0000D+00 0.0000D+00 1.0000D+00 1.9722D-31
+ 0.0000D+00 0.0000D+00 1.0000D+00 1.9722D-31
+ 0.0000D+00 0.0000D+00 1.0000D+00 1.9722D-31
+ 0.0000D+00 0.0000D+00 1.0000D+00 1.9722D-31
+ 5
+ 1.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 1.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 1.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 1.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 1.0000D+00
+ 1.0000D+00 0.0000D+00 1.0000D+00 1.9722D-31
+ 1.0000D+00 0.0000D+00 1.0000D+00 1.9722D-31
+ 1.0000D+00 0.0000D+00 1.0000D+00 1.9722D-31
+ 1.0000D+00 0.0000D+00 1.0000D+00 1.9722D-31
+ 1.0000D+00 0.0000D+00 1.0000D+00 1.9722D-31
+ 6
+ 1.0000D+00 1.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 1.0000D+00 1.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 1.0000D+00 1.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 1.0000D+00 1.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 1.0000D+00 1.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 1.0000D+00
+ 1.0000D+00 0.0000D+00 2.4074D-35 2.4074D-35
+ 1.0000D+00 0.0000D+00 2.4074D-35 2.4074D-35
+ 1.0000D+00 0.0000D+00 2.4074D-35 2.4074D-35
+ 1.0000D+00 0.0000D+00 2.4074D-35 2.4074D-35
+ 1.0000D+00 0.0000D+00 2.4074D-35 2.4074D-35
+ 1.0000D+00 0.0000D+00 2.4074D-35 2.4074D-35
+ 6
+ 1.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 1.0000D+00 1.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 1.0000D+00 1.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 1.0000D+00 1.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 1.0000D+00 1.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 1.0000D+00 1.0000D+00
+ 1.0000D+00 0.0000D+00 2.4074D-35 2.4074D-35
+ 1.0000D+00 0.0000D+00 2.4074D-35 2.4074D-35
+ 1.0000D+00 0.0000D+00 2.4074D-35 2.4074D-35
+ 1.0000D+00 0.0000D+00 2.4074D-35 2.4074D-35
+ 1.0000D+00 0.0000D+00 2.4074D-35 2.4074D-35
+ 1.0000D+00 0.0000D+00 2.4074D-35 2.4074D-35
+ 6
+ 1.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 2.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 3.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 4.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 5.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 6.0000D+00
+ 1.0000D+00 0.0000D+00 1.0000D+00 1.0000D+00
+ 2.0000D+00 0.0000D+00 1.0000D+00 1.0000D+00
+ 3.0000D+00 0.0000D+00 1.0000D+00 1.0000D+00
+ 4.0000D+00 0.0000D+00 1.0000D+00 1.0000D+00
+ 5.0000D+00 0.0000D+00 1.0000D+00 1.0000D+00
+ 6.0000D+00 0.0000D+00 1.0000D+00 1.0000D+00
+ 4
+ 9.4480D-01 6.7670D-01 6.9080D-01 5.9650D-01
+ 5.8760D-01 8.6420D-01 6.7690D-01 7.2600D-02
+ 7.2560D-01 1.9430D-01 9.6870D-01 2.8310D-01
+ 2.8490D-01 5.8000D-02 4.8450D-01 7.3610D-01
+ 2.4326D-01 2.1409D-01 8.7105D-01 3.5073D-01
+ 2.4326D-01 -2.1409D-01 8.7105D-01 3.5073D-01
+ 7.4091D-01 0.0000D+00 9.8194D-01 4.6989D-01
+ 2.2864D+00 0.0000D+00 9.7723D-01 1.5455D+00
+ 6
+ 5.0410D-01 6.6520D-01 7.7190D-01 6.3870D-01 5.9550D-01 6.1310D-01
+ 1.5740D-01 3.7340D-01 5.9840D-01 1.5470D-01 9.4270D-01 6.5900D-02
+ 4.4170D-01 7.2300D-02 1.5440D-01 5.4920D-01 8.7000D-03 3.0040D-01
+ 2.0080D-01 6.0800D-01 3.0340D-01 8.4390D-01 2.3900D-01 5.7680D-01
+ 9.3610D-01 7.4130D-01 1.4440D-01 1.7860D-01 1.4280D-01 7.2630D-01
+ 5.5990D-01 9.3360D-01 7.8000D-02 4.0930D-01 6.7140D-01 5.6170D-01
+ -5.2278D-01 0.0000D+00 2.7888D-01 1.1793D-01
+ -3.5380D-01 0.0000D+00 3.5427D-01 6.8911D-02
+ -8.0876D-03 0.0000D+00 3.4558D-01 1.3489D-01
+ 3.4760D-01 3.0525D-01 5.4661D-01 1.7729D-01
+ 3.4760D-01 -3.0525D-01 5.4661D-01 1.7729D-01
+ 2.7698D+00 0.0000D+00 9.6635D-01 1.8270D+00
+ 5
+ 2.0000D-03 1.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 1.0000D-03 1.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 -1.0000D-03 1.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 -2.0000D-03 1.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ -2.0000D-03 0.0000D+00 2.4000D-11 2.3952D-11
+ -1.0000D-03 0.0000D+00 6.0000D-12 5.9940D-12
+ 0.0000D+00 0.0000D+00 4.0000D-12 3.9920D-12
+ 1.0000D-03 0.0000D+00 6.0000D-12 5.9940D-12
+ 2.0000D-03 0.0000D+00 2.4000D-11 2.3952D-11
+ 10
+ 4.8630D-01 9.1260D-01 2.1900D-02 6.0110D-01 1.4050D-01 2.0840D-01
+ 8.2640D-01 8.4410D-01 3.1420D-01 8.6750D-01
+ 7.1500D-01 2.6480D-01 8.8510D-01 2.6150D-01 5.9520D-01 4.7800D-01
+ 7.6730D-01 4.6110D-01 5.7320D-01 7.7000D-03
+ 2.1210D-01 5.5080D-01 5.2350D-01 3.0810D-01 6.6020D-01 2.8900D-01
+ 2.3140D-01 2.2790D-01 9.6600D-02 1.0910D-01
+ 7.1510D-01 8.5790D-01 5.7710D-01 5.1140D-01 1.9010D-01 9.0810D-01
+ 6.0090D-01 7.1980D-01 1.0640D-01 8.6840D-01
+ 5.6800D-01 2.8100D-02 4.0140D-01 6.3150D-01 1.1480D-01 7.5800D-02
+ 9.4230D-01 7.2030D-01 3.6850D-01 1.7430D-01
+ 7.7210D-01 3.0280D-01 5.5640D-01 9.9980D-01 3.6520D-01 5.2580D-01
+ 3.7030D-01 6.7790D-01 9.9350D-01 5.0270D-01
+ 7.3960D-01 4.5600D-02 7.4740D-01 9.2880D-01 2.2000D-03 8.2600D-02
+ 3.6340D-01 4.9120D-01 9.4050D-01 3.8910D-01
+ 5.6370D-01 8.5540D-01 3.2100D-02 2.6380D-01 3.6090D-01 6.4970D-01
+ 8.4690D-01 9.3500D-01 3.7000D-02 2.9170D-01
+ 8.6560D-01 6.3270D-01 3.5620D-01 6.3560D-01 2.7360D-01 6.5120D-01
+ 1.0220D-01 2.8880D-01 5.7620D-01 4.0790D-01
+ 5.3320D-01 4.1210D-01 7.2870D-01 2.3110D-01 6.8300D-01 7.3860D-01
+ 8.1800D-01 9.8150D-01 8.0550D-01 2.5660D-01
+ -4.6121D-01 7.2657D-01 4.7781D-01 1.5842D-01
+ -4.6121D-01 -7.2657D-01 4.7781D-01 1.5842D-01
+ -4.5164D-01 0.0000D+00 4.6034D-01 1.9931D-01
+ -1.4922D-01 4.8255D-01 4.7500D-01 9.1686D-02
+ -1.4922D-01 -4.8255D-01 4.7500D-01 9.1686D-02
+ 3.3062D-02 0.0000D+00 2.9729D-01 8.2469D-02
+ 3.0849D-01 1.1953D-01 4.2947D-01 3.9688D-02
+ 3.0849D-01 -1.1953D-01 4.2947D-01 3.9688D-02
+ 5.4509D-01 0.0000D+00 7.0777D-01 1.5033D-01
+ 5.0352D+00 0.0000D+00 9.7257D-01 3.5548D+00
+ 4
+ -3.8730D-01 3.6560D-01 3.1200D-02 -5.8340D-01
+ 5.5230D-01 -1.1854D+00 9.8330D-01 7.6670D-01
+ 1.6746D+00 -1.9900D-02 -1.8293D+00 5.7180D-01
+ -5.2500D-01 3.5340D-01 -2.7210D-01 -8.8300D-02
+ -1.8952D+00 7.5059D-01 8.1913D-01 7.7090D-01
+ -1.8952D+00 -7.5059D-01 8.1913D-01 7.7090D-01
+ -9.5162D-02 0.0000D+00 8.0499D-01 4.9037D-01
+ 3.9520D-01 0.0000D+00 9.8222D-01 4.9037D-01
+ 6
+ -1.0777D+00 1.7027D+00 2.6510D-01 8.5160D-01 1.0121D+00 2.5710D-01
+ -1.3400D-02 3.9030D-01 -1.2680D+00 2.7530D-01 -3.2350D-01 -1.3844D+00
+ 1.5230D-01 3.0680D-01 8.7330D-01 -3.3410D-01 -4.8310D-01 -1.5416D+00
+ 1.4470D-01 -6.0570D-01 3.1900D-02 -1.0905D+00 -8.3700D-02 6.2410D-01
+ -7.6510D-01 -1.7889D+00 -1.5069D+00 -6.0210D-01 5.2170D-01 6.4700D-01
+ 8.1940D-01 2.1100D-01 5.4320D-01 7.5610D-01 1.7130D-01 5.5400D-01
+ -1.7029D+00 0.0000D+00 6.7909D-01 6.7220D-01
+ -1.0307D+00 0.0000D+00 7.2671D-01 2.0436D-01
+ 2.8487D-01 1.2101D+00 3.9757D-01 4.9797D-01
+ 2.8487D-01 -1.2101D+00 3.9757D-01 4.9797D-01
+ 1.1675D+00 4.6631D-01 4.2334D-01 1.9048D-01
+ 1.1675D+00 -4.6631D-01 4.2334D-01 1.9048D-01
+ 10
+ -1.0639D+00 1.6120D-01 1.5620D-01 3.4360D-01 -6.7480D-01 1.6598D+00
+ 6.4650D-01 -7.8630D-01 -2.6100D-01 7.0190D-01
+ -8.4400D-01 -2.2439D+00 1.8800D+00 -1.0005D+00 7.4500D-02 -1.6156D+00
+ 2.8220D-01 8.5600D-01 1.3497D+00 -1.5883D+00
+ 1.5988D+00 1.1758D+00 1.2398D+00 1.1173D+00 2.1500D-01 4.3140D-01
+ 1.8500D-01 7.9470D-01 6.6260D-01 8.6460D-01
+ -2.2960D-01 1.2442D+00 2.3242D+00 -5.0690D-01 -7.5160D-01 -5.4370D-01
+ -2.5990D-01 1.2830D+00 -1.1067D+00 -1.1150D-01
+ -3.6040D-01 4.0420D-01 6.1240D-01 -1.2164D+00 -9.4650D-01 -3.1460D-01
+ 1.8310D-01 7.3710D-01 1.4278D+00 2.9220D-01
+ 4.6150D-01 3.8740D-01 -4.2900D-02 -9.3600D-01 7.1160D-01 -8.2590D-01
+ -1.7640D+00 -9.4660D-01 1.8202D+00 -2.5480D-01
+ 1.2934D+00 -9.7550D-01 6.7480D-01 -1.0481D+00 -1.8442D+00 -5.4600D-02
+ 7.4050D-01 6.1000D-03 1.2430D+00 -1.8490D-01
+ -3.4710D-01 -9.5800D-01 1.6530D-01 9.1300D-02 -5.2010D-01 -1.1832D+00
+ 8.5410D-01 -2.3200D-01 -1.6155D+00 5.5180D-01
+ 1.0190D+00 -6.8240D-01 8.0850D-01 2.5950D-01 -3.7580D-01 -1.8825D+00
+ 1.6473D+00 -6.5920D-01 8.0250D-01 -4.9000D-03
+ 1.2670D+00 -4.2400D-02 8.9570D-01 -1.6770D-01 1.4620D-01 9.8800D-01
+ -2.3170D-01 -1.4483D+00 -5.8200D-02 1.9700D-02
+ -2.6992D+00 9.0387D-01 6.4005D-01 4.1615D-01
+ -2.6992D+00 -9.0387D-01 6.4005D-01 4.1615D-01
+ -2.4366D+00 0.0000D+00 6.9083D-01 2.5476D-01
+ -1.2882D+00 8.8930D-01 5.3435D-01 6.0878D-01
+ -1.2882D+00 -8.8930D-01 5.3435D-01 6.0878D-01
+ 9.0275D-01 0.0000D+00 2.9802D-01 4.7530D-01
+ 9.0442D-01 2.5661D+00 7.3193D-01 6.2016D-01
+ 9.0442D-01 -2.5661D+00 7.3193D-01 6.2016D-01
+ 1.6774D+00 0.0000D+00 3.0743D-01 4.1726D-01
+ 3.0060D+00 0.0000D+00 8.5623D-01 4.3175D-01
+ 4
+ -1.2298D+00 -2.3142D+00 -6.9800D-02 1.0523D+00
+ 2.0390D-01 -1.2298D+00 8.0500D-02 9.7860D-01
+ 0.0000D+00 0.0000D+00 2.5600D-01 -8.9100D-01
+ 0.0000D+00 0.0000D+00 2.7480D-01 2.5600D-01
+ -1.2298D+00 6.8692D-01 4.7136D-01 7.1772D-01
+ -1.2298D+00 -6.8692D-01 4.7136D-01 7.1772D-01
+ 2.5600D-01 4.9482D-01 8.0960D-01 5.1408D-01
+ 2.5600D-01 -4.9482D-01 8.0960D-01 5.1408D-01
+ 6
+ 5.9930D-01 1.9372D+00 -1.6160D-01 -1.4602D+00 6.0180D-01 2.7120D+00
+ -2.2049D+00 5.9930D-01 -1.0679D+00 1.9405D+00 -1.4400D+00 -2.2110D-01
+ 0.0000D+00 0.0000D+00 -2.4567D+00 -6.8650D-01 -1.9101D+00 6.4960D-01
+ 0.0000D+00 0.0000D+00 0.0000D+00 7.3620D-01 3.9700D-01 -1.5190D-01
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 -1.0034D+00 1.1954D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 -1.3400D-01 -1.0034D+00
+ -2.4567D+00 0.0000D+00 4.7091D-01 8.5788D-01
+ -1.0034D+00 4.0023D-01 3.6889D-01 1.8909D-01
+ -1.0034D+00 -4.0023D-01 3.6889D-01 1.8909D-01
+ 5.9930D-01 2.0667D+00 5.8849D-01 1.3299D+00
+ 5.9930D-01 -2.0667D+00 5.8849D-01 1.3299D+00
+ 7.3620D-01 0.0000D+00 6.0845D-01 9.6725D-01
+ 4
+ 1.0000D-04 1.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 -1.0000D-04 1.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 1.0000D-02 1.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 -5.0000D-03
+ -5.0000D-03 0.0000D+00 3.7485D-07 3.6932D-07
+ -1.0000D-04 0.0000D+00 9.8979D-09 9.8493D-09
+ 1.0000D-04 0.0000D+00 1.0098D-08 1.0046D-08
+ 1.0000D-02 0.0000D+00 1.4996D-06 1.4773D-06
+ 3
+ 2.0000D-06 1.0000D+00 -2.0000D+00
+ 1.0000D-06 -2.0000D+00 4.0000D+00
+ 0.0000D+00 1.0000D+00 -2.0000D+00
+ -4.0000D+00 0.0000D+00 7.3030D-01 4.0000D+00
+ 0.0000D+00 0.0000D+00 7.2801D-01 1.3726D-06
+ 2.2096D-06 0.0000D+00 8.2763D-01 2.2096D-06
+ 6
+ 2.4080D-01 6.5530D-01 9.1660D-01 5.0300D-02 2.8490D-01 2.4080D-01
+ 6.9070D-01 9.7000D-01 1.4020D-01 5.7820D-01 6.7670D-01 6.9070D-01
+ 1.0620D-01 3.8000D-02 7.0540D-01 2.4320D-01 8.6420D-01 1.0620D-01
+ 2.6400D-01 9.8800D-02 1.7800D-02 9.4480D-01 1.9430D-01 2.6400D-01
+ 7.0340D-01 2.5600D-01 2.6110D-01 5.8760D-01 5.8000D-02 7.0340D-01
+ 4.0210D-01 5.5980D-01 1.3580D-01 7.2560D-01 6.9080D-01 4.0210D-01
+ -3.4008D-01 3.2133D-01 5.7839D-01 2.0310D-01
+ -3.4008D-01 -3.2133D-01 5.7839D-01 2.0310D-01
+ -1.6998D-07 0.0000D+00 4.9641D-01 2.1574D-01
+ 7.2311D-01 5.9389D-02 7.0039D-01 4.1945D-02
+ 7.2311D-01 -5.9389D-02 7.0039D-01 4.1945D-02
+ 2.5551D+00 0.0000D+00 9.2518D-01 1.7390D+00
+ 6
+ 3.4800D+00 -2.9900D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ -4.9000D-01 2.4800D+00 -1.9900D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 -4.9000D-01 1.4800D+00 -9.9000D-01 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 -9.9000D-01 1.4800D+00 -4.9000D-01 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 -1.9900D+00 2.4800D+00 -4.9000D-01
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 -2.9900D+00 3.4800D+00
+ 1.3034D-02 0.0000D+00 7.5301D-01 6.0533D-01
+ 1.1294D+00 0.0000D+00 6.0479D-01 2.8613D-01
+ 2.0644D+00 0.0000D+00 5.4665D-01 1.7376D-01
+ 2.8388D+00 0.0000D+00 4.2771D-01 3.0915D-01
+ 4.3726D+00 0.0000D+00 6.6370D-01 7.6443D-02
+ 4.4618D+00 0.0000D+00 5.7388D-01 8.9227D-02
+ 6
+ 0.0000D+00 1.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 1.0000D+00
+ 1.0000D+00 0.0000D+00 1.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 1.0000D+00 0.0000D+00 1.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 1.0000D+00 0.0000D+00 1.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 1.0000D+00 0.0000D+00 1.0000D+00
+ -1.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 1.0000D+00 0.0000D+00
+ -1.7321D+00 0.0000D+00 8.6603D-01 7.2597D-01
+ -1.0000D+00 0.0000D+00 5.0000D-01 2.6417D-01
+ 0.0000D+00 0.0000D+00 2.9582D-31 1.4600D-07
+ 0.0000D+00 0.0000D+00 2.9582D-31 6.2446D-08
+ 1.0000D+00 0.0000D+00 5.0000D-01 2.6417D-01
+ 1.7321D+00 0.0000D+00 8.6603D-01 3.7896D-01
+ 6
+ 3.5345D-01 9.3023D-01 7.4679D-02 -1.0059D-02 4.6698D-02 -4.3480D-02
+ 9.3545D-01 -3.5147D-01 -2.8216D-02 3.8008D-03 -1.7644D-02 1.6428D-02
+ 0.0000D+00 -1.0555D-01 7.5211D-01 -1.0131D-01 4.7030D-01 -4.3789D-01
+ 0.0000D+00 0.0000D+00 6.5419D-01 1.1779D-01 -5.4678D-01 5.0911D-01
+ 0.0000D+00 0.0000D+00 0.0000D+00 -9.8780D-01 -1.1398D-01 1.0612D-01
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 6.8144D-01 7.3187D-01
+ -9.9980D-01 1.9645D-02 1.0000D+00 3.9290D-02
+ -9.9980D-01 -1.9645D-02 1.0000D+00 3.9290D-02
+ 7.4539D-01 6.6663D-01 1.0000D+00 5.2120D-01
+ 7.4539D-01 -6.6663D-01 1.0000D+00 5.2120D-01
+ 9.9929D-01 3.7545D-02 1.0000D+00 7.5089D-02
+ 9.9929D-01 -3.7545D-02 1.0000D+00 7.5089D-02
+ 6
+ 1.0000D+00 1.0000D+00 1.0000D+00 1.0000D+00 1.0000D+00 1.0000D+00
+ 5.0000D-01 3.3330D-01 2.5000D-01 2.0000D-01 1.6670D-01 1.4290D-01
+ 3.3330D-01 2.5000D-01 2.0000D-01 1.6670D-01 1.4290D-01 1.2500D-01
+ 2.5000D-01 2.0000D-01 1.6670D-01 1.4290D-01 1.2500D-01 1.1110D-01
+ 2.0000D-01 1.6670D-01 1.4290D-01 1.2500D-01 1.1110D-01 1.0000D-01
+ 1.6670D-01 1.4290D-01 1.2500D-01 1.1110D-01 1.0000D-01 9.0900D-02
+ -2.2135D-01 0.0000D+00 4.0841D-01 1.6605D-01
+ -3.1956D-02 0.0000D+00 3.7927D-01 3.0531D-02
+ -8.5031D-04 0.0000D+00 6.2793D-01 7.8195D-04
+ -5.8584D-05 0.0000D+00 8.1156D-01 7.2478D-05
+ 1.3895D-05 0.0000D+00 9.7087D-01 7.2478D-05
+ 2.1324D+00 0.0000D+00 8.4325D-01 1.8048D+00
+ 12
+ 1.2000D+01 1.1000D+01 1.0000D+01 9.0000D+00 8.0000D+00 7.0000D+00
+ 6.0000D+00 5.0000D+00 4.0000D+00 3.0000D+00 2.0000D+00 1.0000D+00
+ 1.1000D+01 1.1000D+01 1.0000D+01 9.0000D+00 8.0000D+00 7.0000D+00
+ 6.0000D+00 5.0000D+00 4.0000D+00 3.0000D+00 2.0000D+00 1.0000D+00
+ 0.0000D+00 1.0000D+01 1.0000D+01 9.0000D+00 8.0000D+00 7.0000D+00
+ 6.0000D+00 5.0000D+00 4.0000D+00 3.0000D+00 2.0000D+00 1.0000D+00
+ 0.0000D+00 0.0000D+00 9.0000D+00 9.0000D+00 8.0000D+00 7.0000D+00
+ 6.0000D+00 5.0000D+00 4.0000D+00 3.0000D+00 2.0000D+00 1.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 8.0000D+00 8.0000D+00 7.0000D+00
+ 6.0000D+00 5.0000D+00 4.0000D+00 3.0000D+00 2.0000D+00 1.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 7.0000D+00 7.0000D+00
+ 6.0000D+00 5.0000D+00 4.0000D+00 3.0000D+00 2.0000D+00 1.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 6.0000D+00
+ 6.0000D+00 5.0000D+00 4.0000D+00 3.0000D+00 2.0000D+00 1.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 5.0000D+00 5.0000D+00 4.0000D+00 3.0000D+00 2.0000D+00 1.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 4.0000D+00 4.0000D+00 3.0000D+00 2.0000D+00 1.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 3.0000D+00 3.0000D+00 2.0000D+00 1.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 2.0000D+00 2.0000D+00 1.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 1.0000D+00 1.0000D+00
+ -2.8234D-02 0.0000D+00 2.8690D-06 3.2094D-06
+ 7.2587D-02 9.0746D-02 1.5885D-06 9.9934D-07
+ 7.2587D-02 -9.0746D-02 1.5885D-06 9.9934D-07
+ 1.8533D-01 0.0000D+00 6.5757D-07 7.8673D-07
+ 2.8828D-01 0.0000D+00 1.8324D-06 2.0796D-06
+ 6.4315D-01 0.0000D+00 6.8640D-05 6.1058D-05
+ 1.5539D+00 0.0000D+00 4.6255D-03 6.4028D-03
+ 3.5119D+00 0.0000D+00 1.4447D-01 1.9470D-01
+ 6.9615D+00 0.0000D+00 5.8447D-01 1.2016D+00
+ 1.2311D+01 0.0000D+00 3.1823D-01 1.4273D+00
+ 2.0199D+01 0.0000D+00 2.0079D-01 2.4358D+00
+ 3.2229D+01 0.0000D+00 3.0424D-01 5.6865D+00
+ 6
+ 0.0000D+00 1.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 5.0000D+00 0.0000D+00 2.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 4.0000D+00 0.0000D+00 3.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 3.0000D+00 0.0000D+00 4.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 2.0000D+00 0.0000D+00 5.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 1.0000D+00 0.0000D+00
+ -5.0000D+00 0.0000D+00 8.2295D-01 1.2318D+00
+ -3.0000D+00 0.0000D+00 7.2281D-01 7.5970D-01
+ -1.0000D+00 0.0000D+00 6.2854D-01 6.9666D-01
+ 1.0000D+00 0.0000D+00 6.2854D-01 6.9666D-01
+ 3.0000D+00 0.0000D+00 7.2281D-01 7.5970D-01
+ 5.0000D+00 0.0000D+00 8.2295D-01 1.2318D+00
+ 6
+ 1.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 1.0000D+00
+ -1.0000D+00 1.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 1.0000D+00
+ -1.0000D+00 -1.0000D+00 1.0000D+00 0.0000D+00 0.0000D+00 1.0000D+00
+ -1.0000D+00 -1.0000D+00 -1.0000D+00 1.0000D+00 0.0000D+00 1.0000D+00
+ -1.0000D+00 -1.0000D+00 -1.0000D+00 -1.0000D+00 1.0000D+00 1.0000D+00
+ -1.0000D+00 -1.0000D+00 -1.0000D+00 -1.0000D+00 -1.0000D+00 1.0000D+00
+ 8.0298D-02 2.4187D+00 8.9968D-01 1.5236D+00
+ 8.0298D-02 -2.4187D+00 8.9968D-01 1.5236D+00
+ 1.4415D+00 6.2850D-01 9.6734D-01 4.2793D-01
+ 1.4415D+00 -6.2850D-01 9.6734D-01 4.2793D-01
+ 1.4782D+00 1.5638D-01 9.7605D-01 2.2005D-01
+ 1.4782D+00 -1.5638D-01 9.7605D-01 2.2005D-01
+ 6
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 1.0000D+00
+ 1.0000D+00 1.0000D+00 0.0000D+00 0.0000D+00 1.0000D+00 1.0000D+00
+ 0.0000D+00 1.0000D+00 1.0000D+00 1.0000D+00 0.0000D+00 1.0000D+00
+ 1.0000D+00 0.0000D+00 1.0000D+00 1.0000D+00 1.0000D+00 1.0000D+00
+ 1.0000D+00 0.0000D+00 1.0000D+00 1.0000D+00 1.0000D+00 0.0000D+00
+ 0.0000D+00 1.0000D+00 0.0000D+00 1.0000D+00 1.0000D+00 1.0000D+00
+ -3.5343D-02 7.4812D-01 3.9345D-01 1.8415D-01
+ -3.5343D-02 -7.4812D-01 3.9345D-01 1.8415D-01
+ 5.8440D-07 0.0000D+00 2.8868D-01 1.7003D-01
+ 6.4087D-01 7.2822D-01 4.5013D-01 2.9425D-01
+ 6.4087D-01 -7.2822D-01 4.5013D-01 2.9425D-01
+ 3.7889D+00 0.0000D+00 9.6305D-01 2.2469D+00
+ 6
+ 1.0000D+00 4.0112D+00 1.2750D+01 4.0213D+01 1.2656D+02 3.9788D+02
+ 1.0000D+00 3.2616D+00 1.0629D+01 3.3342D+01 1.0479D+02 3.2936D+02
+ 1.0000D+00 3.1500D+00 9.8006D+00 3.0630D+01 9.6164D+01 3.0215D+02
+ 1.0000D+00 3.2755D+00 1.0420D+01 3.2957D+01 1.0374D+02 3.2616D+02
+ 1.0000D+00 2.8214D+00 8.4558D+00 2.6296D+01 8.2443D+01 2.5893D+02
+ 1.0000D+00 2.6406D+00 8.3565D+00 2.6558D+01 8.3558D+01 2.6268D+02
+ -5.3220D-01 0.0000D+00 5.3287D-01 3.8557D-01
+ -1.0118D-01 0.0000D+00 7.2342D-01 9.1303D-02
+ -9.8749D-03 0.0000D+00 7.3708D-01 1.1032D-02
+ 2.9861D-03 0.0000D+00 4.4610D-01 1.2861D-02
+ 1.8075D-01 0.0000D+00 4.2881D-01 1.7378D-01
+ 3.9260D+02 0.0000D+00 4.8057D-01 3.9201D+02
+ 8
+ 0.0000D+00 4.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00
+ 1.0000D+00 0.0000D+00 4.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00
+ 0.0000D+00 1.0000D+00 0.0000D+00 4.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 1.0000D+00 0.0000D+00 4.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 1.0000D+00 0.0000D+00 4.0000D+00
+ 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 1.0000D+00 0.0000D+00
+ 4.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 1.0000D+00
+ 0.0000D+00 4.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 1.0000D+00 0.0000D+00
+ -3.7588D+00 0.0000D+00 1.2253D-01 1.2978D-01
+ -3.0642D+00 0.0000D+00 4.9811D-02 8.0162D-02
+ -2.0000D+00 0.0000D+00 3.6914D-02 8.2942D-02
+ -6.9459D-01 0.0000D+00 3.3328D-02 1.3738D-01
+ 6.9459D-01 0.0000D+00 3.3328D-02 1.1171D-01
+ 2.0000D+00 0.0000D+00 3.6914D-02 7.2156D-02
+ 3.0642D+00 0.0000D+00 4.9811D-02 6.8352D-02
+ 3.7588D+00 0.0000D+00 1.2253D-01 1.1527D-01
+ 6
+ 8.5000D+00 -1.0472D+01 2.8944D+00 -1.5279D+00 1.1056D+00 -5.0000D-01
+ 2.6180D+00 -1.1708D+00 -2.0000D+00 8.9440D-01 -6.1800D-01 2.7640D-01
+ -7.2360D-01 2.0000D+00 -1.7080D-01 -1.6180D+00 8.9440D-01 -3.8200D-01
+ 3.8200D-01 -8.9440D-01 1.6180D+00 1.7080D-01 -2.0000D+00 7.2360D-01
+ -2.7640D-01 6.1800D-01 -8.9440D-01 2.0000D+00 1.1708D+00 -2.6180D+00
+ 5.0000D-01 -1.1056D+00 1.5279D+00 -2.8944D+00 1.0472D+01 -8.5000D+00
+ -5.8930D-01 0.0000D+00 1.7357D-04 2.8157D-04
+ -2.7627D-01 4.9852D-01 1.7486D-04 1.6704D-04
+ -2.7627D-01 -4.9852D-01 1.7486D-04 1.6704D-04
+ 2.7509D-01 5.0059D-01 1.7635D-04 1.6828D-04
+ 2.7509D-01 -5.0059D-01 1.7635D-04 1.6828D-04
+ 5.9167D-01 0.0000D+00 1.7623D-04 3.0778D-04
+ 4
+ 4.0000D+00 -5.0000D+00 0.0000D+00 3.0000D+00
+ 0.0000D+00 4.0000D+00 -3.0000D+00 -5.0000D+00
+ 5.0000D+00 -3.0000D+00 4.0000D+00 0.0000D+00
+ 3.0000D+00 0.0000D+00 5.0000D+00 4.0000D+00
+ 1.0000D+00 5.0000D+00 1.0000D+00 4.3333D+00
+ 1.0000D+00 -5.0000D+00 1.0000D+00 4.3333D+00
+ 2.0000D+00 0.0000D+00 1.0000D+00 4.3333D+00
+ 1.2000D+01 0.0000D+00 1.0000D+00 9.1250D+00
+ 5
+ 1.5000D+01 1.1000D+01 6.0000D+00 -9.0000D+00 -1.5000D+01
+ 1.0000D+00 3.0000D+00 9.0000D+00 -3.0000D+00 -8.0000D+00
+ 7.0000D+00 6.0000D+00 6.0000D+00 -3.0000D+00 -1.1000D+01
+ 7.0000D+00 7.0000D+00 5.0000D+00 -3.0000D+00 -1.1000D+01
+ 1.7000D+01 1.2000D+01 5.0000D+00 -1.0000D+01 -1.6000D+01
+ -9.9999D-01 0.0000D+00 2.1768D-01 5.2263D-01
+ 1.4980D+00 3.5752D+00 3.9966D-04 6.0947D-03
+ 1.4980D+00 -3.5752D+00 3.9966D-04 6.0947D-03
+ 1.5020D+00 3.5662D+00 3.9976D-04 6.0960D-03
+ 1.5020D+00 -3.5662D+00 3.9976D-04 6.0960D-03
+ 6
+ -9.0000D+00 2.1000D+01 -1.5000D+01 4.0000D+00 2.0000D+00 0.0000D+00
+ -1.0000D+01 2.1000D+01 -1.4000D+01 4.0000D+00 2.0000D+00 0.0000D+00
+ -8.0000D+00 1.6000D+01 -1.1000D+01 4.0000D+00 2.0000D+00 0.0000D+00
+ -6.0000D+00 1.2000D+01 -9.0000D+00 3.0000D+00 3.0000D+00 0.0000D+00
+ -4.0000D+00 8.0000D+00 -6.0000D+00 0.0000D+00 5.0000D+00 0.0000D+00
+ -2.0000D+00 4.0000D+00 -3.0000D+00 0.0000D+00 1.0000D+00 3.0000D+00
+ 1.0000D+00 6.2559D-04 6.4875D-05 5.0367D-04
+ 1.0000D+00 -6.2559D-04 6.4875D-05 5.0367D-04
+ 2.0000D+00 1.0001D+00 5.4076D-02 2.3507D-01
+ 2.0000D+00 -1.0001D+00 5.4076D-02 2.3507D-01
+ 3.0000D+00 0.0000D+00 8.6149D-01 5.4838D-07
+ 3.0000D+00 0.0000D+00 1.2425D-01 1.2770D-06
+ 10
+ 1.0000D+00 1.0000D+00 1.0000D+00 -2.0000D+00 1.0000D+00 -1.0000D+00
+ 2.0000D+00 -2.0000D+00 4.0000D+00 -3.0000D+00
+ -1.0000D+00 2.0000D+00 3.0000D+00 -4.0000D+00 2.0000D+00 -2.0000D+00
+ 4.0000D+00 -4.0000D+00 8.0000D+00 -6.0000D+00
+ -1.0000D+00 0.0000D+00 5.0000D+00 -5.0000D+00 3.0000D+00 -3.0000D+00
+ 6.0000D+00 -6.0000D+00 1.2000D+01 -9.0000D+00
+ -1.0000D+00 0.0000D+00 3.0000D+00 -4.0000D+00 4.0000D+00 -4.0000D+00
+ 8.0000D+00 -8.0000D+00 1.6000D+01 -1.2000D+01
+ -1.0000D+00 0.0000D+00 3.0000D+00 -6.0000D+00 5.0000D+00 -4.0000D+00
+ 1.0000D+01 -1.0000D+01 2.0000D+01 -1.5000D+01
+ -1.0000D+00 0.0000D+00 3.0000D+00 -6.0000D+00 2.0000D+00 -2.0000D+00
+ 1.2000D+01 -1.2000D+01 2.4000D+01 -1.8000D+01
+ -1.0000D+00 0.0000D+00 3.0000D+00 -6.0000D+00 2.0000D+00 -5.0000D+00
+ 1.5000D+01 -1.3000D+01 2.8000D+01 -2.1000D+01
+ -1.0000D+00 0.0000D+00 3.0000D+00 -6.0000D+00 2.0000D+00 -5.0000D+00
+ 1.2000D+01 -1.1000D+01 3.2000D+01 -2.4000D+01
+ -1.0000D+00 0.0000D+00 3.0000D+00 -6.0000D+00 2.0000D+00 -5.0000D+00
+ 1.2000D+01 -1.4000D+01 3.7000D+01 -2.6000D+01
+ -1.0000D+00 0.0000D+00 3.0000D+00 -6.0000D+00 2.0000D+00 -5.0000D+00
+ 1.2000D+01 -1.4000D+01 3.6000D+01 -2.5000D+01
+ 1.0000D+00 0.0000D+00 3.6037D-02 7.9613D-02
+ 1.9867D+00 0.0000D+00 7.4283D-05 7.4025D-06
+ 2.0000D+00 2.5052D-03 1.4346D-04 6.7839D-07
+ 2.0000D+00 -2.5052D-03 1.4346D-04 6.7839D-07
+ 2.0067D+00 1.1763D-02 6.7873D-05 5.7496D-06
+ 2.0067D+00 -1.1763D-02 6.7873D-05 5.7496D-06
+ 2.9970D+00 0.0000D+00 9.2779D-05 2.6519D-06
+ 3.0000D+00 8.7028D-04 2.7358D-04 1.9407D-07
+ 3.0000D+00 -8.7028D-04 2.7358D-04 1.9407D-07
+ 3.0030D+00 0.0000D+00 9.2696D-05 2.6477D-06
+ 0
+DSX Data file for Real Nonsymmetric Schur Form Expert Driver
+6 Number of matrix dimensions
+0 1 2 3 5 10 20 Matrix dimensions
+3 3 1 11 4 8 2 0 Parameters NB, NBMIN, NXOVER, INMIN, INWIN, INIBL, ISHFTS, IACC22
+20.0 Threshold for test ratios
+T
+2 Read another line with random number generator seed
+2518 3899 995 397 Seed for random number generator
+DSX 21 Use all matrix types
+ 1 1
+ 1
+ 0.00000D+00
+ 1.00000D+00 0.00000D+00
+ 1 1
+ 1
+ 1.00000D+00
+ 1.00000D+00 1.00000D+00
+ 6 6
+ 1 2 3 4 5 6
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 1.00000D+00 4.43734D-31
+ 6 0
+ 1.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 1.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 1.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+00
+ 1.00000D+00 1.00000D+00
+ 6 6
+ 1 2 3 4 5 6
+ 1.00000D+00 1.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 1.00000D+00 1.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 1.00000D+00 1.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+00 1.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+00 1.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+00
+ 1.00000D+00 2.00000D+00
+ 6 1
+ 1
+ 1.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 1.00000D+00 1.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 1.00000D+00 1.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 1.00000D+00 1.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+00 1.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+00 1.00000D+00
+ 1.00000D+00 2.00000D+00
+ 6 3
+ 4 5 6
+ 1.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 2.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 3.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 4.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 5.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 6.00000D+00
+ 1.00000D+00 1.00000D+00
+ 2 1
+ 1
+ 1.00000D+00 2.00000D+00
+ 0.00000D+00 3.00000D+00
+ 7.07107D-01 2.00000D+00
+ 4 2
+ 1 2
+ 8.52400D-01 5.61100D-01 7.04300D-01 9.54000D-01
+ 2.79800D-01 7.21600D-01 9.61300D-01 3.58200D-01
+ 7.08100D-01 4.09400D-01 2.25000D-01 9.51800D-01
+ 5.54300D-01 5.22000D-01 6.86000D-01 3.07000D-02
+ 7.22196D-01 4.63943D-01
+ 7 6
+ 1 2 3 4 5 6
+ 7.81800D-01 5.65700D-01 7.62100D-01 7.43600D-01 2.55300D-01 4.10000D-01
+ 1.34000D-02
+ 6.45800D-01 2.66600D-01 5.51000D-01 8.31800D-01 9.27100D-01 6.20900D-01
+ 7.83900D-01
+ 1.31600D-01 4.91400D-01 1.77100D-01 1.96400D-01 1.08500D-01 9.27000D-01
+ 2.24700D-01
+ 6.41000D-01 4.68900D-01 9.65900D-01 8.88400D-01 3.76900D-01 9.67300D-01
+ 6.18300D-01
+ 8.38200D-01 8.74300D-01 4.50700D-01 9.44200D-01 7.75500D-01 9.67600D-01
+ 7.83100D-01
+ 3.25900D-01 7.38900D-01 8.30200D-01 4.52100D-01 3.01500D-01 2.13300D-01
+ 8.43400D-01
+ 5.24400D-01 5.01600D-01 7.52900D-01 3.83800D-01 8.47900D-01 9.12800D-01
+ 5.77000D-01
+ 9.43220D-01 3.20530D+00
+ 4 2
+ 2 3
+ -9.85900D-01 1.47840D+00 -1.33600D-01 -2.95970D+00
+ -4.33700D-01 -6.54000D-01 -7.15500D-01 1.23760D+00
+ -7.36300D-01 -1.97680D+00 -1.95100D-01 3.43200D-01
+ 6.41400D-01 -1.40880D+00 6.39400D-01 8.58000D-02
+ 5.22869D-01 5.45530D-01
+ 7 5
+ 1 2 3 4 5
+ 2.72840D+00 2.15200D-01 -1.05200D+00 -2.44600D-01 -6.53000D-02 3.90500D-01
+ 1.40980D+00
+ 9.75300D-01 6.51500D-01 -4.76200D-01 5.42100D-01 6.20900D-01 4.75900D-01
+ -1.44930D+00
+ -9.05200D-01 1.79000D-01 -7.08600D-01 4.62100D-01 1.05800D+00 2.24260D+00
+ 1.58260D+00
+ -7.17900D-01 -2.53400D-01 -4.73900D-01 -1.08100D+00 4.13800D-01 -9.50000D-02
+ 1.45300D-01
+ -1.37990D+00 -1.06490D+00 1.25580D+00 7.80100D-01 -6.40500D-01 -8.61000D-02
+ 8.30000D-02
+ 2.84900D-01 -1.29900D-01 4.80000D-02 -2.58600D-01 4.18900D-01 1.37680D+00
+ 8.20800D-01
+ -5.44200D-01 9.74900D-01 9.55800D-01 1.23700D-01 1.09020D+00 -1.40600D-01
+ 1.90960D+00
+ 6.04729D-01 9.00391D-01
+ 6 4
+ 3 4 5 6
+ 0.00000D+00 1.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 1.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+00 0.00000D+00
+ 1.00000D-06 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 5.00000D-01
+ 4.89525D-05 4.56492D-05
+ 8 4
+ 1 2 3 4
+ 1.00000D+00 -1.00000D+00 0.00000D+00 0.00000D+00 1.00000D+01 0.00000D+00
+ 1.00000D+01 0.00000D+00
+ 0.00000D+00 1.00000D+00 -1.00000D+00 0.00000D+00 0.00000D+00 1.00000D+01
+ 1.00000D+01 0.00000D+00
+ 0.00000D+00 0.00000D+00 1.00000D+00 -1.00000D+00 0.00000D+00 1.00000D+01
+ 1.00000D+01 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+00 0.00000D+00 1.00000D+01
+ 0.00000D+00 1.00000D+01
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 5.00000D-01 1.00000D+00
+ 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 5.00000D-01
+ 1.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 5.00000D-01 1.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 5.00000D-01
+ 9.56158D-05 4.14317D-05
+ 9 3
+ 1 2 3
+ 1.00000D+00 -1.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 1.00000D+00 -1.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 1.00000D+00 -1.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+00 -1.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+00 -1.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 7.50000D-01 1.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 7.50000D-01 1.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 7.50000D-01
+ 1.00000D+00 5.55801D-07
+ 10 4
+ 1 2 3 4
+ 1.00000D+00 -1.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 1.00000D+00 -1.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 1.00000D+00 -1.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+00 -1.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+00 -1.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 8.75000D-01 1.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 8.75000D-01 1.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 8.75000D-01 1.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 8.75000D-01
+ 1.00000D+00 1.16972D-10
+ 12 6
+ 1 2 3 4 5 6
+ 1.00000D+00 -1.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 1.00000D+01 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 1.00000D+00 -1.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 1.00000D+01 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 1.00000D+00 -1.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 1.00000D+01 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+00 -1.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+01 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+00 -1.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+01 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+01
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 9.37500D-01 1.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 9.37500D-01 1.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 9.37500D-01 1.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 9.37500D-01 1.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 9.37500D-01 1.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 9.37500D-01
+ 1.85655D-10 2.20147D-16
+ 12 7
+ 6 7 8 9 10 11 12
+ 1.20000D+01 1.10000D+01 1.00000D+01 9.00000D+00 8.00000D+00 7.00000D+00
+ 6.00000D+00 5.00000D+00 4.00000D+00 3.00000D+00 2.00000D+00 1.00000D+00
+ 1.10000D+01 1.10000D+01 1.00000D+01 9.00000D+00 8.00000D+00 7.00000D+00
+ 6.00000D+00 5.00000D+00 4.00000D+00 3.00000D+00 2.00000D+00 1.00000D+00
+ 0.00000D+00 1.00000D+01 1.00000D+01 9.00000D+00 8.00000D+00 7.00000D+00
+ 6.00000D+00 5.00000D+00 4.00000D+00 3.00000D+00 2.00000D+00 1.00000D+00
+ 0.00000D+00 0.00000D+00 9.00000D+00 9.00000D+00 8.00000D+00 7.00000D+00
+ 6.00000D+00 5.00000D+00 4.00000D+00 3.00000D+00 2.00000D+00 1.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 8.00000D+00 8.00000D+00 7.00000D+00
+ 6.00000D+00 5.00000D+00 4.00000D+00 3.00000D+00 2.00000D+00 1.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 7.00000D+00 7.00000D+00
+ 6.00000D+00 5.00000D+00 4.00000D+00 3.00000D+00 2.00000D+00 1.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 6.00000D+00
+ 6.00000D+00 5.00000D+00 4.00000D+00 3.00000D+00 2.00000D+00 1.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 5.00000D+00 5.00000D+00 4.00000D+00 3.00000D+00 2.00000D+00 1.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 4.00000D+00 4.00000D+00 3.00000D+00 2.00000D+00 1.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 3.00000D+00 3.00000D+00 2.00000D+00 1.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 2.00000D+00 2.00000D+00 1.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+00 1.00000D+00
+ 6.92558D-05 5.52606D-05
+ 3 1
+ 1
+ 2.00000D-06 1.00000D+00 -2.00000D+00
+ 1.00000D-06 -2.00000D+00 4.00000D+00
+ 0.00000D+00 1.00000D+00 -2.00000D+00
+ 7.30297D-01 4.00000D+00
+ 5 1
+ 3
+ 2.00000D-03 1.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 1.00000D-03 1.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 -1.00000D-03 1.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 -2.00000D-03 1.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 3.99999D-12 3.99201D-12
+ 6 4
+ 1 2 3 5
+ 1.00000D+00 1.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 1.00000D+00 1.00000D+00 1.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 1.00000D+00 1.00000D+00 1.00000D+00 1.00000D+00 0.00000D+00 0.00000D+00
+ 1.00000D+00 1.00000D+00 1.00000D+00 1.00000D+00 1.00000D+00 0.00000D+00
+ 1.00000D+00 1.00000D+00 1.00000D+00 1.00000D+00 1.00000D+00 1.00000D+00
+ 1.00000D+00 1.00000D+00 1.00000D+00 1.00000D+00 1.00000D+00 1.00000D+00
+ 2.93294D-01 1.63448D-01
+ 6 2
+ 3 4
+ 0.00000D+00 1.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+00
+ 1.00000D+00 0.00000D+00 1.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 1.00000D+00 0.00000D+00 1.00000D+00 0.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 1.00000D+00 0.00000D+00 1.00000D+00 0.00000D+00
+ 0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+00 0.00000D+00 1.00000D+00
+ -1.00000D+00 0.00000D+00 0.00000D+00 0.00000D+00 1.00000D+00 0.00000D+00
+ 3.97360D-01 3.58295D-01
+ 6 3
+ 3 4 5
+ 1.00000D+00 1.00000D+00 1.00000D+00 1.00000D+00 1.00000D+00 1.00000D+00
+ 5.00000D-01 3.33300D-01 2.50000D-01 2.00000D-01 1.66700D-01 1.42900D-01
+ 3.33300D-01 2.50000D-01 2.00000D-01 1.66700D-01 1.42900D-01 1.25000D-01
+ 2.50000D-01 2.00000D-01 1.66700D-01 1.42900D-01 1.25000D-01 1.11100D-01
+ 2.00000D-01 1.66700D-01 1.42900D-01 1.25000D-01 1.11100D-01 1.00000D-01
+ 1.66700D-01 1.42900D-01 1.25000D-01 1.11100D-01 1.00000D-01 9.09000D-02
+ 7.28934D-01 1.24624D-02
+ 5 1
+ 1
+ 1.50000D+01 1.10000D+01 6.00000D+00 -9.00000D+00 -1.50000D+01
+ 1.00000D+00 3.00000D+00 9.00000D+00 -3.00000D+00 -8.00000D+00
+ 7.00000D+00 6.00000D+00 6.00000D+00 -3.00000D+00 -1.10000D+01
+ 7.00000D+00 7.00000D+00 5.00000D+00 -3.00000D+00 -1.10000D+01
+ 1.70000D+01 1.20000D+01 5.00000D+00 -1.00000D+01 -1.60000D+01
+ 2.17680D-01 5.22626D-01
+ 6 2
+ 1 2
+ -9.00000D+00 2.10000D+01 -1.50000D+01 4.00000D+00 2.00000D+00 0.00000D+00
+ -1.00000D+01 2.10000D+01 -1.40000D+01 4.00000D+00 2.00000D+00 0.00000D+00
+ -8.00000D+00 1.60000D+01 -1.10000D+01 4.00000D+00 2.00000D+00 0.00000D+00
+ -6.00000D+00 1.20000D+01 -9.00000D+00 3.00000D+00 3.00000D+00 0.00000D+00
+ -4.00000D+00 8.00000D+00 -6.00000D+00 0.00000D+00 5.00000D+00 0.00000D+00
+ -2.00000D+00 4.00000D+00 -3.00000D+00 0.00000D+00 1.00000D+00 3.00000D+00
+ 6.78904D-02 4.22005D-02
+ 10 1
+ 1
+ 1.00000D+00 1.00000D+00 1.00000D+00 -2.00000D+00 1.00000D+00 -1.00000D+00
+ 2.00000D+00 -2.00000D+00 4.00000D+00 -3.00000D+00
+ -1.00000D+00 2.00000D+00 3.00000D+00 -4.00000D+00 2.00000D+00 -2.00000D+00
+ 4.00000D+00 -4.00000D+00 8.00000D+00 -6.00000D+00
+ -1.00000D+00 0.00000D+00 5.00000D+00 -5.00000D+00 3.00000D+00 -3.00000D+00
+ 6.00000D+00 -6.00000D+00 1.20000D+01 -9.00000D+00
+ -1.00000D+00 0.00000D+00 3.00000D+00 -4.00000D+00 4.00000D+00 -4.00000D+00
+ 8.00000D+00 -8.00000D+00 1.60000D+01 -1.20000D+01
+ -1.00000D+00 0.00000D+00 3.00000D+00 -6.00000D+00 5.00000D+00 -4.00000D+00
+ 1.00000D+01 -1.00000D+01 2.00000D+01 -1.50000D+01
+ -1.00000D+00 0.00000D+00 3.00000D+00 -6.00000D+00 2.00000D+00 -2.00000D+00
+ 1.20000D+01 -1.20000D+01 2.40000D+01 -1.80000D+01
+ -1.00000D+00 0.00000D+00 3.00000D+00 -6.00000D+00 2.00000D+00 -5.00000D+00
+ 1.50000D+01 -1.30000D+01 2.80000D+01 -2.10000D+01
+ -1.00000D+00 0.00000D+00 3.00000D+00 -6.00000D+00 2.00000D+00 -5.00000D+00
+ 1.20000D+01 -1.10000D+01 3.20000D+01 -2.40000D+01
+ -1.00000D+00 0.00000D+00 3.00000D+00 -6.00000D+00 2.00000D+00 -5.00000D+00
+ 1.20000D+01 -1.40000D+01 3.70000D+01 -2.60000D+01
+ -1.00000D+00 0.00000D+00 3.00000D+00 -6.00000D+00 2.00000D+00 -5.00000D+00
+ 1.20000D+01 -1.40000D+01 3.60000D+01 -2.50000D+01
+ 3.60372D-02 7.96134D-02
+ 0 0
diff --git a/jlapack-3.1.1/src/testing/eig/dgbak.in b/jlapack-3.1.1/src/testing/eig/dgbak.in
new file mode 100644
index 0000000..633ec77
--- /dev/null
+++ b/jlapack-3.1.1/src/testing/eig/dgbak.in
@@ -0,0 +1,266 @@
+DGK: Tests DGGBAK
+ 6 3
+ 0.1000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.2000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.3000D+01 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.4000D+01 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.5000D+01 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.6000D+01
+
+ 0.6000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.5000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.4000D+01 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.3000D+01 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.2000D+01 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.1000D+01
+
+ 0.1000D+01 0.1000D+01 0.1000D+01
+ 0.2000D+01 0.2000D+01 0.2000D+01
+ 0.3000D+01 0.3000D+01 0.3000D+01
+ 0.4000D+01 0.4000D+01 0.4000D+01
+ 0.5000D+01 0.5000D+01 0.5000D+01
+ 0.6000D+01 0.6000D+01 0.6000D+01
+
+ -0.1000D+01 -0.1000D+01 -0.1000D+01
+ -0.2000D+01 -0.2000D+01 -0.2000D+01
+ -0.3000D+01 -0.3000D+01 -0.3000D+01
+ -0.4000D+01 -0.4000D+01 -0.4000D+01
+ -0.5000D+01 -0.5000D+01 -0.5000D+01
+ -0.6000D+01 -0.6000D+01 -0.6000D+01
+
+ 6 3
+ 0.1000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.2000D+01 0.2100D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.3000D+01 0.3100D+01 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.4000D+01 0.4100D+01 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.5000D+01 0.5100D+01 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.6000D+01 0.6100D+01
+
+ 0.1000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.2000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.3000D+01 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.4000D+01 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.5000D+01 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.6000D+01
+
+ 0.1000D+01 0.1000D+01 0.1000D+01
+ 0.2000D+01 0.2000D+01 0.2000D+01
+ 0.3000D+01 0.3000D+01 0.3000D+01
+ 0.4000D+01 0.4000D+01 0.4000D+01
+ 0.5000D+01 0.5000D+01 0.5000D+01
+ 0.6000D+01 0.6000D+01 0.6000D+01
+
+ -0.1000D+01 -0.1000D+01 -0.1000D+01
+ -0.2000D+01 -0.2000D+01 -0.2000D+01
+ -0.3000D+01 -0.3000D+01 -0.3000D+01
+ -0.4000D+01 -0.4000D+01 -0.4000D+01
+ -0.5000D+01 -0.5000D+01 -0.5000D+01
+ -0.6000D+01 -0.6000D+01 -0.6000D+01
+
+ 5 5
+ 0.1000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.1000D+01 0.2000D+01 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.1000D+01 0.2000D+01 0.3000D+01 0.0000D+00 0.0000D+00
+ 0.1000D+01 0.2000D+01 0.3000D+01 0.4000D+01 0.0000D+00
+ 0.1000D+01 0.2000D+01 0.3000D+01 0.4000D+01 0.5000D+01
+
+ 0.1000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.1000D+01 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.1000D+01 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.1000D+01 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.1000D+01
+
+ 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01
+ 0.2000D+01 0.2000D+01 0.2000D+01 0.2000D+01 0.2000D+01
+ 0.3000D+01 0.3000D+01 0.3000D+01 0.3000D+01 0.3000D+01
+ 0.4000D+01 0.4000D+01 0.4000D+01 0.4000D+01 0.4000D+01
+ 0.5000D+01 0.5000D+01 0.5000D+01 0.5000D+01 0.5000D+01
+
+ 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01
+ 0.2000D+01 0.2000D+01 0.2000D+01 0.2000D+01 0.2000D+01
+ 0.3000D+01 0.3000D+01 0.3000D+01 0.3000D+01 0.3000D+01
+ 0.4000D+01 0.4000D+01 0.4000D+01 0.4000D+01 0.4000D+01
+ 0.5000D+01 0.5000D+01 0.5000D+01 0.5000D+01 0.5000D+01
+
+ 6 5
+ 0.1000D+01 0.1000D+11 0.1000D+11 0.1000D+11 0.1000D+11 0.1000D+11
+ 0.1000D+01 0.1000D+01 0.1000D+11 0.1000D+11 0.1000D+11 0.1000D+11
+ 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+11 0.1000D+11 0.1000D+11
+ 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+11 0.1000D+11
+ 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+11
+ 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01
+
+ 0.1000D+01 0.1000D+11 0.1000D+11 0.1000D+11 0.1000D+11 0.1000D+11
+ 0.1000D+01 0.1000D+01 0.1000D+11 0.1000D+11 0.1000D+11 0.1000D+11
+ 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+11 0.1000D+11 0.1000D+11
+ 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+11 0.1000D+11
+ 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+11
+ 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01
+
+ 0.1000D+01 0.2000D+01 -0.3000D+01 0.4000D+01 0.5000D+01
+ 0.8000D+01 0.9000D+01 0.0000D+00 0.9000D+01 0.2000D+01
+ 0.0000D+00 -0.9000D+01 0.2000D+01 0.1000D+01 0.1000D+01
+ 0.8000D+01 0.2000D+01 0.1000D+01 0.0000D+00 0.2000D+01
+ 0.0000D+00 0.3000D+01 0.2000D+01 0.1000D+01 0.1000D+01
+ 0.2000D+01 0.1000D+01 0.9000D+01 0.0000D+00 0.1000D+01
+
+ 0.1000D+01 -0.2000D+01 0.3000D+01 0.4000D+01 0.5000D+01
+ -0.8000D+01 0.9000D+01 0.0000D+00 0.9000D+01 0.2000D+01
+ 0.0000D+00 0.9000D+01 0.2000D+01 0.1000D+01 0.1000D+01
+ 0.8000D+01 0.2000D+01 0.1000D+01 0.0000D+00 0.2000D+01
+ 0.0000D+00 0.3000D+01 0.2000D+01 0.1000D+01 0.1000D+01
+ 0.2000D+01 0.8000D+01 0.9000D+01 0.0000D+00 0.1000D+01
+
+ 6 2
+ 0.1000D+01 0.0000D+00 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01
+ 0.1000D+01 0.0000D+00 0.0000D+00 0.1000D+01 0.1000D+01 0.1000D+01
+ 0.1000D+07 0.0000D+00 0.0000D+00 0.0000D+00 0.1000D-05 0.1000D+07
+ 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01
+ 0.1000D+07 0.0000D+00 0.0000D+00 0.0000D+00 0.1000D-05 0.1000D-05
+ 0.1000D+07 0.0000D+00 0.0000D+00 0.0000D+00 0.1000D+07 0.1000D+07
+
+ 0.1000D+01 0.0000D+00 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01
+ 0.1000D+01 0.0000D+00 0.0000D+00 0.1000D+01 0.1000D+01 0.1000D+01
+ 0.1000D+07 0.0000D+00 0.0000D+00 0.0000D+00 0.1000D-05 0.1000D+07
+ 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01
+ 0.1000D+07 0.0000D+00 0.0000D+00 0.0000D+00 0.1000D-05 0.1000D-05
+ 0.1000D+07 0.0000D+00 0.0000D+00 0.0000D+00 0.1000D+07 0.1000D+07
+
+ 0.1000D+01 0.1000D+01
+ 0.2000D+01 0.2000D+01
+ 0.3000D+01 0.3000D+01
+ 0.4000D+01 0.4000D+01
+ 0.5000D+01 0.5000D+01
+ 0.6000D+01 0.6000D+01
+
+ 0.1100D+01 0.1100D+01
+ 0.2200D+01 0.2200D+01
+ 0.3300D+01 0.3300D+01
+ 0.4400D+01 0.4400D+01
+ 0.5500D+01 0.5500D+01
+ 0.6600D+01 0.6600D+01
+
+ 7 3
+ 0.0000D+00 0.1000D+01 0.0000D+00 0.1000D+01 0.1000D+01 0.1000D+01
+ 0.1000D+01
+ 0.0000D+00 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01
+ 0.1000D+01
+ 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01
+ 0.1000D+01
+ 0.0000D+00 0.1000D+01 0.0000D+00 0.1000D+01 0.1000D+01 0.1000D+01
+ 0.1000D+01
+ 0.0000D+00 0.1000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00
+ 0.0000D+00 0.1000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.1000D+01
+ 0.0000D+00 0.1000D+01 0.0000D+00 0.1000D+01 0.1000D+01 0.1000D+01
+ 0.1000D+01
+
+ 0.0000D+00 0.1000D+01 0.0000D+00 0.1000D+01 0.1000D+01 0.1000D+01
+ 0.1000D+01
+ 0.0000D+00 0.1000D+01 0.0000D+00 0.1000D+01 0.1000D+01 0.1000D+01
+ 0.1000D+01
+ 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01
+ 0.1000D+01
+ 0.0000D+00 0.1000D+01 0.0000D+00 0.1000D+01 0.1000D+01 0.1000D+01
+ 0.1000D+01
+ 0.0000D+00 0.1000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00
+ 0.0000D+00 0.1000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.1000D+01
+ 0.0000D+00 0.1000D+01 0.0000D+00 0.1000D+01 0.1000D+01 0.1000D+01
+ 0.1000D+01
+
+ 0.1000D+01 0.1000D+01 0.1000D+01
+ 0.2000D+01 0.2000D+01 0.2000D+01
+ 0.3000D+01 0.3000D+01 0.3000D+01
+ 0.4000D+01 0.4000D+01 0.4000D+01
+ 0.5000D+01 0.5000D+01 0.5000D+01
+ 0.6000D+01 0.6000D+01 0.6000D+01
+ 0.7000D+01 0.7000D+01 0.7000D+01
+
+ -0.1000D+01 -0.1000D+01 -0.1000D+01
+ -0.2000D+01 -0.2000D+01 -0.2000D+01
+ -0.3000D+01 -0.3000D+01 -0.3000D+01
+ -0.4000D+01 -0.4000D+01 -0.4000D+01
+ -0.5000D+01 -0.5000D+01 -0.5000D+01
+ -0.6000D+01 -0.6000D+01 -0.6000D+01
+ -0.7000D+01 -0.7000D+01 -0.7000D+01
+
+ 7 3
+ 0.0000D+00 0.1000D+04 0.0000D+00 0.1000D+04 0.1000D+04 0.1000D+04
+ 0.1000D-04
+ 0.0000D+00 0.1000D-04 0.1000D+04 0.1000D-04 0.1000D-04 0.1000D+04
+ 0.1000D+04
+ 0.1000D+04 0.1000D+04 0.1000D-04 0.1000D+04 0.1000D+04 0.1000D+04
+ 0.1000D+04
+ 0.0000D+00 0.1000D-04 0.0000D+00 0.1000D+00 0.1000D+04 0.1000D-04
+ 0.1000D+04
+ 0.0000D+00 0.1000D+04 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00
+ 0.0000D+00 0.4000D-04 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.1000D-04
+ 0.0000D+00 0.1000D+04 0.0000D+00 0.1000D+04 0.1000D+04 0.1000D-04
+ 0.1000D+04
+
+ 0.0000D+00 0.1000D-01 0.0000D+00 0.1000D+04 0.1000D-04 0.1000D+04
+ 0.1000D+04
+ 0.0000D+00 0.1000D+04 0.1000D+04 0.1000D+04 0.1000D+04 0.1000D+00
+ 0.1000D+04
+ 0.1000D+04 0.1000D+04 0.1000D+04 0.1000D+04 0.1000D-04 0.1000D+04
+ 0.1000D+04
+ 0.0000D+00 0.4000D-01 0.0000D+00 0.1000D+04 0.1000D+01 0.1000D+04
+ 0.1000D+04
+ 0.0000D+00 0.1000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00
+ 0.0000D+00 0.1000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.1000D+01
+ 0.0000D+00 0.1000D-04 0.0000D+00 0.1000D+04 0.1000D+01 0.1000D+01
+ 0.1000D-04
+
+ 0.1000D+01 0.1000D+01 0.1000D+01
+ 0.2000D+01 0.2000D+01 0.2000D+01
+ 0.3000D+01 0.3000D+01 0.3000D+01
+ 0.4000D+01 0.4000D+01 0.4000D+01
+ 0.5000D+01 0.5000D+01 0.5000D+01
+ 0.6000D+01 0.6000D+01 0.6000D+01
+ 0.7000D+01 0.7000D+01 0.7000D+01
+
+ 0.1000D+01 0.1000D+01 0.1000D+01
+ 0.2000D+01 0.2000D+01 0.2000D+01
+ 0.3000D+01 0.3000D+01 0.3000D+01
+ 0.4000D+01 0.4000D+01 0.4000D+01
+ 0.5000D+01 0.5000D+01 0.5000D+01
+ 0.6000D+01 0.6000D+01 0.6000D+01
+ 0.7000D+01 0.7000D+01 0.7000D+01
+
+ 6 2
+ -0.2000D+02 -0.1000D+05 -0.2000D+01 -0.1000D+07 -0.1000D+02 -0.2000D+06
+ 0.6000D-02 0.4000D+01 0.6000D-03 0.2000D+03 0.3000D-02 0.3000D+02
+ -0.2000D+00 -0.3000D+03 -0.4000D-01 -0.1000D+05 0.0000D+00 0.3000D+04
+ 0.6000D-04 0.4000D-01 0.9000D-05 0.9000D+01 0.3000D-04 0.5000D+00
+ 0.6000D-01 0.5000D+02 0.8000D-02 -0.4000D+04 0.8000D-01 0.0000D+00
+ 0.0000D+00 0.1000D+04 0.7000D+00 -0.2000D+06 0.1300D+02 -0.6000D+05
+
+ -0.2000D+02 -0.1000D+05 0.2000D+01 -0.2000D+07 0.1000D+02 -0.1000D+06
+ 0.5000D-02 0.3000D+01 -0.2000D-03 0.4000D+03 -0.1000D-02 0.3000D+02
+ 0.0000D+00 -0.1000D+03 -0.8000D-01 0.2000D+05 -0.4000D+00 0.0000D+00
+ 0.5000D-04 0.3000D-01 0.2000D-05 0.4000D+01 0.2000D-04 0.1000D+00
+ 0.4000D-01 0.3000D+02 -0.1000D-02 0.3000D+04 -0.1000D-01 0.6000D+03
+ -0.1000D+01 0.0000D+00 0.4000D+00 -0.1000D+06 0.4000D+01 0.2000D+05
+
+ 0.1000D+01 0.1000D+01
+ 0.2000D+01 0.2000D+01
+ 0.3000D+01 0.3000D+01
+ 0.4000D+01 0.4000D+01
+ 0.5000D+01 0.5000D+01
+ 0.6000D+01 0.6000D+01
+
+ 0.1000D+02 0.1000D+02
+ 0.2000D+02 0.2000D+02
+ 0.3000D+02 0.3000D+02
+ 0.4000D+02 0.4000D+02
+ 0.5000D+02 0.5000D+02
+ 0.6000D+02 0.6000D+02
+
+0 0
diff --git a/jlapack-3.1.1/src/testing/eig/dgbal.in b/jlapack-3.1.1/src/testing/eig/dgbal.in
new file mode 100644
index 0000000..f2f7cc5
--- /dev/null
+++ b/jlapack-3.1.1/src/testing/eig/dgbal.in
@@ -0,0 +1,304 @@
+DGL: Tests DGGBAL
+ 6
+ 0.1000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.2000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.3000D+01 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.4000D+01 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.5000D+01 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.6000D+01
+
+ 0.6000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.5000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.4000D+01 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.3000D+01 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.2000D+01 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.1000D+01
+
+ 1 1
+ 0.1000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.2000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.3000D+01 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.4000D+01 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.5000D+01 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.6000D+01
+
+ 0.6000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.5000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.4000D+01 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.3000D+01 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.2000D+01 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.1000D+01
+
+ 0.1000D+01 0.2000D+01 0.3000D+01 0.4000D+01 0.5000D+01 0.6000D+01
+
+ 0.1000D+01 0.2000D+01 0.3000D+01 0.4000D+01 0.5000D+01 0.6000D+01
+
+ 6
+ 0.1000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.1000D+01 0.1000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.1000D+01 0.1000D+01 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.1000D+01 0.1000D+01 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.1000D+01 0.1000D+01 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.1000D+01 0.1000D+01
+
+ 0.1000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.1000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.1000D+01 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.1000D+01 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.1000D+01 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.1000D+01
+
+ 1 1
+ 0.1000D+01 0.1000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.1000D+01 0.1000D+01 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.1000D+01 0.1000D+01 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.1000D+01 0.1000D+01 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.1000D+01 0.1000D+01
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.1000D+01
+
+ 0.1000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.1000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.1000D+01 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.1000D+01 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.1000D+01 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.1000D+01
+
+ 0.1000D+01 0.2000D+01 0.3000D+01 0.3000D+01 0.2000D+01 0.1000D+01
+
+ 0.1000D+01 0.2000D+01 0.3000D+01 0.3000D+01 0.2000D+01 0.1000D+01
+
+ 6
+ 0.1000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.1000D+01 0.2000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.1000D+01 0.2000D+01 0.3000D+01 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.1000D+01 0.2000D+01 0.3000D+01 0.4000D+01 0.0000D+00 0.0000D+00
+ 0.1000D+01 0.2000D+01 0.3000D+01 0.4000D+01 0.5000D+01 0.0000D+00
+ 0.1000D+01 0.2000D+01 0.3000D+01 0.4000D+01 0.5000D+01 0.6000D+01
+
+ 0.1000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.1000D+01 0.2000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.1000D+01 0.2000D+01 0.3000D+01 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.1000D+01 0.2000D+01 0.3000D+01 0.4000D+01 0.0000D+00 0.0000D+00
+ 0.1000D+01 0.2000D+01 0.3000D+01 0.4000D+01 0.5000D+01 0.0000D+00
+ 0.1000D+01 0.2000D+01 0.3000D+01 0.4000D+01 0.5000D+01 0.6000D+01
+
+ 1 1
+ 0.6000D+01 0.5000D+01 0.4000D+01 0.3000D+01 0.2000D+01 0.1000D+01
+ 0.0000D+00 0.5000D+01 0.4000D+01 0.3000D+01 0.2000D+01 0.1000D+01
+ 0.0000D+00 0.0000D+00 0.4000D+01 0.3000D+01 0.2000D+01 0.1000D+01
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.3000D+01 0.2000D+01 0.1000D+01
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.2000D+01 0.1000D+01
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.1000D+01
+
+ 0.6000D+01 0.5000D+01 0.4000D+01 0.3000D+01 0.2000D+01 0.1000D+01
+ 0.0000D+00 0.5000D+01 0.4000D+01 0.3000D+01 0.2000D+01 0.1000D+01
+ 0.0000D+00 0.0000D+00 0.4000D+01 0.3000D+01 0.2000D+01 0.1000D+01
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.3000D+01 0.2000D+01 0.1000D+01
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.2000D+01 0.1000D+01
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.1000D+01
+
+ 0.1000D+01 0.2000D+01 0.3000D+01 0.3000D+01 0.2000D+01 0.1000D+01
+
+ 0.1000D+01 0.2000D+01 0.3000D+01 0.3000D+01 0.2000D+01 0.1000D+01
+
+ 5
+ 0.1000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.1000D+01 0.2000D+01 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.1000D+01 0.2000D+01 0.3000D+01 0.0000D+00 0.0000D+00
+ 0.1000D+01 0.2000D+01 0.3000D+01 0.4000D+01 0.0000D+00
+ 0.1000D+01 0.2000D+01 0.3000D+01 0.4000D+01 0.5000D+01
+
+ 0.1000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.1000D+01 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.1000D+01 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.1000D+01 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.1000D+01
+
+ 1 1
+ 0.5000D+01 0.4000D+01 0.3000D+01 0.2000D+01 0.1000D+01
+ 0.0000D+00 0.4000D+01 0.3000D+01 0.2000D+01 0.1000D+01
+ 0.0000D+00 0.0000D+00 0.3000D+01 0.2000D+01 0.1000D+01
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.2000D+01 0.1000D+01
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.1000D+01
+
+ 0.1000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.1000D+01 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.1000D+01 0.0000D+00 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.1000D+01 0.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.1000D+01
+
+ 0.1000D+01 0.2000D+01 0.3000D+01 0.2000D+01 0.1000D+01
+
+ 0.1000D+01 0.2000D+01 0.3000D+01 0.2000D+01 0.1000D+01
+
+ 6
+ 0.1000D+01 0.1000D+11 0.1000D+11 0.1000D+11 0.1000D+11 0.1000D+11
+ 0.1000D+01 0.1000D+01 0.1000D+11 0.1000D+11 0.1000D+11 0.1000D+11
+ 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+11 0.1000D+11 0.1000D+11
+ 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+11 0.1000D+11
+ 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+11
+ 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01
+
+ 0.1000D+01 0.1000D+11 0.1000D+11 0.1000D+11 0.1000D+11 0.1000D+11
+ 0.1000D+01 0.1000D+01 0.1000D+11 0.1000D+11 0.1000D+11 0.1000D+11
+ 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+11 0.1000D+11 0.1000D+11
+ 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+11 0.1000D+11
+ 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+11
+ 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01
+
+ 1 6
+ 0.1000D-03 0.1000D+05 0.1000D+04 0.1000D+02 0.1000D+00 0.1000D-01
+ 0.1000D-02 0.1000D-04 0.1000D+05 0.1000D+03 0.1000D+01 0.1000D+00
+ 0.1000D+00 0.1000D-02 0.1000D-03 0.1000D+05 0.1000D+03 0.1000D+02
+ 0.1000D+02 0.1000D+00 0.1000D-01 0.1000D-03 0.1000D+05 0.1000D+04
+ 0.1000D+03 0.1000D+01 0.1000D+00 0.1000D-02 0.1000D-04 0.1000D+05
+ 0.1000D+05 0.1000D+03 0.1000D+02 0.1000D+00 0.1000D-02 0.1000D-03
+
+ 0.1000D-03 0.1000D+05 0.1000D+04 0.1000D+02 0.1000D+00 0.1000D-01
+ 0.1000D-02 0.1000D-04 0.1000D+05 0.1000D+03 0.1000D+01 0.1000D+00
+ 0.1000D+00 0.1000D-02 0.1000D-03 0.1000D+05 0.1000D+03 0.1000D+02
+ 0.1000D+02 0.1000D+00 0.1000D-01 0.1000D-03 0.1000D+05 0.1000D+04
+ 0.1000D+03 0.1000D+01 0.1000D+00 0.1000D-02 0.1000D-04 0.1000D+05
+ 0.1000D+05 0.1000D+03 0.1000D+02 0.1000D+00 0.1000D-02 0.1000D-03
+
+ 0.1000D-05 0.1000D-04 0.1000D-02 0.1000D+00 0.1000D+01 0.1000D+03
+
+ 0.1000D+03 0.1000D+01 0.1000D+00 0.1000D-02 0.1000D-04 0.1000D-05
+
+ 6
+ 0.1000D+01 0.0000D+00 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01
+ 0.1000D+01 0.0000D+00 0.0000D+00 0.1000D+01 0.1000D+01 0.1000D+01
+ 0.1000D+07 0.0000D+00 0.0000D+00 0.0000D+00 0.1000D-05 0.1000D+07
+ 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01
+ 0.1000D+07 0.0000D+00 0.0000D+00 0.0000D+00 0.1000D-05 0.1000D-05
+ 0.1000D+07 0.0000D+00 0.0000D+00 0.0000D+00 0.1000D+07 0.1000D+07
+
+ 0.1000D+01 0.0000D+00 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01
+ 0.1000D+01 0.0000D+00 0.0000D+00 0.1000D+01 0.1000D+01 0.1000D+01
+ 0.1000D+07 0.0000D+00 0.0000D+00 0.0000D+00 0.1000D-05 0.1000D+07
+ 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01
+ 0.1000D+07 0.0000D+00 0.0000D+00 0.0000D+00 0.1000D-05 0.1000D-05
+ 0.1000D+07 0.0000D+00 0.0000D+00 0.0000D+00 0.1000D+07 0.1000D+07
+
+ 4 6
+ 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D-04 0.1000D+04 0.1000D+00
+ 0.0000D+00 0.1000D+01 0.1000D+01 0.1000D-04 0.1000D+04 0.1000D+00
+ 0.0000D+00 0.0000D+00 0.1000D+01 0.1000D-04 0.1000D+04 0.1000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.1000D+01 0.1000D-03 0.1000D+05
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.1000D+05 0.1000D+01 0.1000D-03
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.1000D-03 0.1000D+05 0.1000D+01
+
+ 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D-04 0.1000D+04 0.1000D+00
+ 0.0000D+00 0.1000D+01 0.1000D+01 0.1000D-04 0.1000D+04 0.1000D+00
+ 0.0000D+00 0.0000D+00 0.1000D+01 0.1000D-04 0.1000D+04 0.1000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.1000D+01 0.1000D-03 0.1000D+05
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.1000D+05 0.1000D+01 0.1000D-03
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.1000D-03 0.1000D+05 0.1000D+01
+
+ 0.4000D+01 0.4000D+01 0.4000D+01 0.1000D+00 0.1000D+04 0.1000D-04
+
+ 0.2000D+01 0.3000D+01 0.4000D+01 0.1000D-04 0.1000D+04 0.1000D+00
+
+ 7
+ 0.0000D+00 0.1000D+01 0.0000D+00 0.1000D+01 0.1000D+01 0.1000D+01
+ 0.1000D+01
+ 0.0000D+00 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01
+ 0.1000D+01
+ 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01
+ 0.1000D+01
+ 0.0000D+00 0.1000D+01 0.0000D+00 0.1000D+01 0.1000D+01 0.1000D+01
+ 0.1000D+01
+ 0.0000D+00 0.1000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00
+ 0.0000D+00 0.1000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.1000D+01
+ 0.0000D+00 0.1000D+01 0.0000D+00 0.1000D+01 0.1000D+01 0.1000D+01
+ 0.1000D+01
+
+ 0.0000D+00 0.1000D+01 0.0000D+00 0.1000D+01 0.1000D+01 0.1000D+01
+ 0.1000D+01
+ 0.0000D+00 0.1000D+01 0.0000D+00 0.1000D+01 0.1000D+01 0.1000D+01
+ 0.1000D+01
+ 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01
+ 0.1000D+01
+ 0.0000D+00 0.1000D+01 0.0000D+00 0.1000D+01 0.1000D+01 0.1000D+01
+ 0.1000D+01
+ 0.0000D+00 0.1000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.0000D+00
+ 0.0000D+00 0.1000D+01 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.1000D+01
+ 0.0000D+00 0.1000D+01 0.0000D+00 0.1000D+01 0.1000D+01 0.1000D+01
+ 0.1000D+01
+
+ 3 5
+ 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01
+ 0.1000D+01
+ 0.0000D+00 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01
+ 0.1000D+01
+ 0.0000D+00 0.0000D+00 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01
+ 0.1000D+01
+ 0.0000D+00 0.0000D+00 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01
+ 0.1000D+01
+ 0.0000D+00 0.0000D+00 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01
+ 0.1000D+01
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.1000D+01
+ 0.1000D+01
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.1000D+01
+
+ 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01
+ 0.1000D+01
+ 0.0000D+00 0.0000D+00 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01
+ 0.1000D+01
+ 0.0000D+00 0.0000D+00 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01
+ 0.1000D+01
+ 0.0000D+00 0.0000D+00 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01
+ 0.1000D+01
+ 0.0000D+00 0.0000D+00 0.1000D+01 0.1000D+01 0.1000D+01 0.1000D+01
+ 0.1000D+01
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.1000D+01
+ 0.1000D+01
+ 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00 0.0000D+00
+ 0.1000D+01
+
+ 0.3000D+01 0.2000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.6000D+01
+ 0.5000D+01
+
+ 0.1000D+01 0.3000D+01 0.1000D+01 0.1000D+01 0.1000D+01 0.2000D+01
+ 0.2000D+01
+
+ 6
+ -0.2000D+02 -0.1000D+05 -0.2000D+01 -0.1000D+07 -0.1000D+02 -0.2000D+06
+ 0.6000D-02 0.4000D+01 0.6000D-03 0.2000D+03 0.3000D-02 0.3000D+02
+ -0.2000D+00 -0.3000D+03 -0.4000D-01 -0.1000D+05 0.0000D+00 0.3000D+04
+ 0.6000D-04 0.4000D-01 0.9000D-05 0.9000D+01 0.3000D-04 0.5000D+00
+ 0.6000D-01 0.5000D+02 0.8000D-02 -0.4000D+04 0.8000D-01 0.0000D+00
+ 0.0000D+00 0.1000D+04 0.7000D+00 -0.2000D+06 0.1300D+02 -0.6000D+05
+
+ -0.2000D+02 -0.1000D+05 0.2000D+01 -0.2000D+07 0.1000D+02 -0.1000D+06
+ 0.5000D-02 0.3000D+01 -0.2000D-03 0.4000D+03 -0.1000D-02 0.3000D+02
+ 0.0000D+00 -0.1000D+03 -0.8000D-01 0.2000D+05 -0.4000D+00 0.0000D+00
+ 0.5000D-04 0.3000D-01 0.2000D-05 0.4000D+01 0.2000D-04 0.1000D+00
+ 0.4000D-01 0.3000D+02 -0.1000D-02 0.3000D+04 -0.1000D-01 0.6000D+03
+ -0.1000D+01 0.0000D+00 0.4000D+00 -0.1000D+06 0.4000D+01 0.2000D+05
+
+ 1 6
+ -0.2000D+00 -0.1000D+01 -0.2000D+00 -0.1000D+01 -0.1000D+01 -0.2000D+01
+ 0.6000D+00 0.4000D+01 0.6000D+00 0.2000D+01 0.3000D+01 0.3000D+01
+ -0.2000D+00 -0.3000D+01 -0.4000D+00 -0.1000D+01 0.0000D+00 0.3000D+01
+ 0.6000D+00 0.4000D+01 0.9000D+00 0.9000D+01 0.3000D+01 0.5000D+01
+ 0.6000D+00 0.5000D+01 0.8000D+00 -0.4000D+01 0.8000D+01 0.0000D+00
+ 0.0000D+00 0.1000D+01 0.7000D+00 -0.2000D+01 0.1300D+02 -0.6000D+01
+
+ -0.2000D+00 -0.1000D+01 0.2000D+00 -0.2000D+01 0.1000D+01 -0.1000D+01
+ 0.5000D+00 0.3000D+01 -0.2000D+00 0.4000D+01 -0.1000D+01 0.3000D+01
+ 0.0000D+00 -0.1000D+01 -0.8000D+00 0.2000D+01 -0.4000D+01 0.0000D+00
+ 0.5000D+00 0.3000D+01 0.2000D+00 0.4000D+01 0.2000D+01 0.1000D+01
+ 0.4000D+00 0.3000D+01 -0.1000D+00 0.3000D+01 -0.1000D+01 0.6000D+01
+ -0.1000D+00 0.0000D+00 0.4000D+00 -0.1000D+01 0.4000D+01 0.2000D+01
+
+ 0.1000D-02 0.1000D+02 0.1000D+00 0.1000D+04 0.1000D+01 0.1000D-01
+
+ 0.1000D+02 0.1000D+00 0.1000D+03 0.1000D-02 0.1000D+03 0.1000D-01
+
+0
diff --git a/jlapack-3.1.1/src/testing/eig/dgd.in b/jlapack-3.1.1/src/testing/eig/dgd.in
new file mode 100644
index 0000000..42ff716
--- /dev/null
+++ b/jlapack-3.1.1/src/testing/eig/dgd.in
@@ -0,0 +1,86 @@
+DGS Data for the Real Nonsymmetric Schur Form Driver
+5 Number of matrix dimensions
+2 6 10 12 20 30 Matrix dimensions
+1 1 1 2 1 Parameters NB, NBMIN, NXOVER, NS, NBCOL
+10 Threshold for test ratios
+.TRUE. Put T to test the error exits
+0 Code to interpret the seed
+DGS 26 Test all 26 matrix types
+DGV Data for the Real Nonsymmetric Eigenvalue Problem Driver
+6 Number of matrix dimensions
+2 6 8 10 15 20 Matrix dimensions
+1 1 1 2 1 Parameters NB, NBMIN, NXOVER, NS, NBCOL
+10 Threshold value
+.TRUE. Put T to test the error exits
+0 Code to interpret the seed
+DGV 26 Test all 26 matrix types
+DGX Data for the Real Nonsymmetric Schur Form Expert Driver
+2 Largest matrix dimension (0 <= NSIZE <= 5)
+1 1 1 2 1 Parameters NB, NBMIN, NXOVER, NS, NBCOL
+10 Threshold for test ratios
+.TRUE. Put T to test the error exits
+0 Code to interpret the seed
+DGX Data for the Real Nonsymmetric Schur Form Expert Driver
+0 Largest matrix dimension
+1 1 1 2 1 Parameters NB, NBMIN, NXOVER, NS, NBCOL
+10 Threshold for test ratios
+.TRUE. Put T to test the error exits
+0 Code to interpret the seed
+ 4
+ 2
+ 8.0000D+00 4.0000D+00 -1.3000D+01 4.0000D+00 Input matrix A
+ 0.0000D+00 7.0000D+00 -2.4000D+01 -3.0000D+00
+ 0.0000D+00 0.0000D+00 3.0000D+00 -5.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 1.6000D+01
+ 9.0000D+00 -1.0000D+00 1.0000D+00 -6.0000D+00 Input matrix B
+ 0.0000D+00 4.0000D+00 1.6000D+01 -2.4000D+01
+ 0.0000D+00 0.0000D+00 -1.1000D+01 6.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 4.0000D+00
+ 2.5901D-01 1.7592D+00 Condition #'s for cluster selected from lower 2x2
+ 4
+ 2
+ 1.0000D+00 2.0000D+00 3.0000D+00 4.0000D+00 Input matrix A
+ 0.0000D+00 5.0000D+00 6.0000D+00 7.0000D+00
+ 0.0000D+00 0.0000D+00 8.0000D+00 9.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 1.0000D+01
+ -1.0000D+00 -1.0000D+00 -1.0000D+00 -1.0000D+00 Input matrix B
+ 0.0000D+00 -1.0000D+00 -1.0000D+00 -1.0000D+00
+ 0.0000D+00 0.0000D+00 1.0000D+00 -1.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 1.0000D+00
+ 9.8173D-01 6.3649D-01 Condition #'s for cluster selected from lower 2x2
+0
+DXV Data for the Real Nonsymmetric Eigenvalue Expert Driver
+5 Largest matrix dimension
+1 1 1 2 1 Parameters NB, NBMIN, NXOVER, NS, NBCOL
+10 Threshold for test ratios
+.TRUE. Put T to test the error exits
+0 Code to interpret the seed
+DXV Data for the Real Nonsymmetric Eigenvalue Expert Driver
+0 Largest matrix dimension
+1 1 1 2 1 Parameters NB, NBMIN, NXOVER, NS, NBCOL
+10 Threshold for test ratios
+.TRUE. Put T to test the error exits
+0 Code to interpret the seed
+ 4
+ 8.0000D+00 4.0000D+00 -1.3000D+01 4.0000D+00 Input matrix A
+ 0.0000D+00 7.0000D+00 -2.4000D+01 -3.0000D+00
+ 0.0000D+00 0.0000D+00 3.0000D+00 -5.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 1.6000D+01
+ 9.0000D+00 -1.0000D+00 1.0000D+00 -6.0000D+00 Input matrix B
+ 0.0000D+00 4.0000D+00 1.6000D+01 -2.4000D+01
+ 0.0000D+00 0.0000D+00 -1.1000D+01 6.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 4.0000D+00
+ 3.1476D+00 2.5286D+00 4.2241D+00 3.4160D+00 eigenvalue condition #'s
+ 6.7340D-01 1.1380D+00 3.5424D+00 9.5917D-01 eigenvector condition #'s
+ 4
+ 1.0000D+00 2.0000D+00 3.0000D+00 4.0000D+00 Input matrix A
+ 0.0000D+00 5.0000D+00 6.0000D+00 7.0000D+00
+ 0.0000D+00 0.0000D+00 8.0000D+00 9.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 1.0000D+01
+ -1.0000D+00 -1.0000D+00 -1.0000D+00 -1.0000D+00 Input matrix B
+ 0.0000D+00 -1.0000D+00 -1.0000D+00 -1.0000D+00
+ 0.0000D+00 0.0000D+00 1.0000D+00 -1.0000D+00
+ 0.0000D+00 0.0000D+00 0.0000D+00 1.0000D+00
+ 1.3639D+00 4.0417D+00 6.4089D-01 6.8030D-01 eigenvalue condition #'s
+ 7.6064D-01 8.4964D-01 1.1222D-01 1.1499D-01 eigenvector condition #'s
+0
diff --git a/jlapack-3.1.1/src/testing/eig/dgg.in b/jlapack-3.1.1/src/testing/eig/dgg.in
new file mode 100644
index 0000000..fb83aac
--- /dev/null
+++ b/jlapack-3.1.1/src/testing/eig/dgg.in
@@ -0,0 +1,15 @@
+DGG: Data file for testing Nonsymmetric Eigenvalue Problem routines
+7 Number of values of N
+0 1 2 3 5 10 16 Values of N (dimension)
+4 Number of parameter values
+1 1 2 2 Values of NB (blocksize)
+40 40 2 2 Values of NBMIN (minimum blocksize)
+2 4 2 4 Values of NSHIFT (no. of shifts)
+40 40 2 2 Values of MAXB (multishift crossover pt)
+40 40 2 2 Values of NBCOL (minimum col. dimension)
+20.0 Threshold value
+T Put T to test the LAPACK routines
+T Put T to test the driver routines
+T Put T to test the error exits
+1 Code to interpret the seed
+DGG 26
diff --git a/jlapack-3.1.1/src/testing/eig/dsb.in b/jlapack-3.1.1/src/testing/eig/dsb.in
new file mode 100644
index 0000000..76fe2de
--- /dev/null
+++ b/jlapack-3.1.1/src/testing/eig/dsb.in
@@ -0,0 +1,9 @@
+DSB: Data file for testing Symmetric Eigenvalue Problem routines
+2 Number of values of N
+5 20 Values of N (dimension)
+5 Number of values of K
+0 1 2 5 16 Values of K (band width)
+20.0 Threshold value
+T Put T to test the error exits
+1 Code to interpret the seed
+DSB 15
diff --git a/jlapack-3.1.1/src/testing/eig/dsg.in b/jlapack-3.1.1/src/testing/eig/dsg.in
new file mode 100644
index 0000000..7819a83
--- /dev/null
+++ b/jlapack-3.1.1/src/testing/eig/dsg.in
@@ -0,0 +1,13 @@
+DSG: Data file for testing Generalized Symmetric Eigenvalue Problem routines
+7 Number of values of N
+0 1 2 3 5 10 16 Values of N (dimension)
+3 Number of values of NB
+1 3 20 Values of NB (blocksize)
+2 2 2 Values of NBMIN (minimum blocksize)
+1 1 1 Values of NX (crossover point)
+20.0 Threshold value
+T Put T to test the LAPACK routines
+T Put T to test the driver routines
+T Put T to test the error exits
+1 Code to interpret the seed
+DSG 21
diff --git a/jlapack-3.1.1/src/testing/eig/eigtest.f b/jlapack-3.1.1/src/testing/eig/eigtest.f
new file mode 100644
index 0000000..125da36
--- /dev/null
+++ b/jlapack-3.1.1/src/testing/eig/eigtest.f
@@ -0,0 +1,38907 @@
+ SUBROUTINE ALAHDG( IOUNIT, PATH )
+*
+* -- LAPACK test routine (version 3.1.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER*3 PATH
+ INTEGER IOUNIT
+* ..
+*
+* Purpose
+* =======
+*
+* ALAHDG prints header information for the different test paths.
+*
+* Arguments
+* =========
+*
+* IOUNIT (input) INTEGER
+* The unit number to which the header information should be
+* printed.
+*
+* PATH (input) CHARACTER*3
+* The name of the path for which the header information is to
+* be printed. Current paths are
+* GQR: GQR (general matrices)
+* GRQ: GRQ (general matrices)
+* LSE: LSE Problem
+* GLM: GLM Problem
+* GSV: Generalized Singular Value Decomposition
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ CHARACTER*3 C2
+ INTEGER ITYPE
+* ..
+* .. External Functions ..
+ LOGICAL LSAMEN
+ EXTERNAL LSAMEN
+* ..
+* .. Executable Statements ..
+*
+ IF( IOUNIT.LE.0 )
+ $ RETURN
+ C2 = PATH( 1: 3 )
+*
+* First line describing matrices in this path
+*
+ IF( LSAMEN( 3, C2, 'GQR' ) ) THEN
+ ITYPE = 1
+ WRITE( IOUNIT, FMT = 9991 )PATH
+ ELSE IF( LSAMEN( 3, C2, 'GRQ' ) ) THEN
+ ITYPE = 2
+ WRITE( IOUNIT, FMT = 9992 )PATH
+ ELSE IF( LSAMEN( 3, C2, 'LSE' ) ) THEN
+ ITYPE = 3
+ WRITE( IOUNIT, FMT = 9993 )PATH
+ ELSE IF( LSAMEN( 3, C2, 'GLM' ) ) THEN
+ ITYPE = 4
+ WRITE( IOUNIT, FMT = 9994 )PATH
+ ELSE IF( LSAMEN( 3, C2, 'GSV' ) ) THEN
+ ITYPE = 5
+ WRITE( IOUNIT, FMT = 9995 )PATH
+ END IF
+*
+* Matrix types
+*
+ WRITE( IOUNIT, FMT = 9999 )'Matrix types: '
+*
+ IF( ITYPE.EQ.1 )THEN
+ WRITE( IOUNIT, FMT = 9950 )1
+ WRITE( IOUNIT, FMT = 9952 )2
+ WRITE( IOUNIT, FMT = 9954 )3
+ WRITE( IOUNIT, FMT = 9955 )4
+ WRITE( IOUNIT, FMT = 9956 )5
+ WRITE( IOUNIT, FMT = 9957 )6
+ WRITE( IOUNIT, FMT = 9961 )7
+ WRITE( IOUNIT, FMT = 9962 )8
+ ELSE IF( ITYPE.EQ.2 )THEN
+ WRITE( IOUNIT, FMT = 9951 )1
+ WRITE( IOUNIT, FMT = 9953 )2
+ WRITE( IOUNIT, FMT = 9954 )3
+ WRITE( IOUNIT, FMT = 9955 )4
+ WRITE( IOUNIT, FMT = 9956 )5
+ WRITE( IOUNIT, FMT = 9957 )6
+ WRITE( IOUNIT, FMT = 9961 )7
+ WRITE( IOUNIT, FMT = 9962 )8
+ ELSE IF( ITYPE.EQ.3 )THEN
+ WRITE( IOUNIT, FMT = 9950 )1
+ WRITE( IOUNIT, FMT = 9952 )2
+ WRITE( IOUNIT, FMT = 9954 )3
+ WRITE( IOUNIT, FMT = 9955 )4
+ WRITE( IOUNIT, FMT = 9955 )5
+ WRITE( IOUNIT, FMT = 9955 )6
+ WRITE( IOUNIT, FMT = 9955 )7
+ WRITE( IOUNIT, FMT = 9955 )8
+ ELSE IF( ITYPE.EQ.4 )THEN
+ WRITE( IOUNIT, FMT = 9951 )1
+ WRITE( IOUNIT, FMT = 9953 )2
+ WRITE( IOUNIT, FMT = 9954 )3
+ WRITE( IOUNIT, FMT = 9955 )4
+ WRITE( IOUNIT, FMT = 9955 )5
+ WRITE( IOUNIT, FMT = 9955 )6
+ WRITE( IOUNIT, FMT = 9955 )7
+ WRITE( IOUNIT, FMT = 9955 )8
+ ELSE IF( ITYPE.EQ.5 )THEN
+ WRITE( IOUNIT, FMT = 9950 )1
+ WRITE( IOUNIT, FMT = 9952 )2
+ WRITE( IOUNIT, FMT = 9954 )3
+ WRITE( IOUNIT, FMT = 9955 )4
+ WRITE( IOUNIT, FMT = 9956 )5
+ WRITE( IOUNIT, FMT = 9957 )6
+ WRITE( IOUNIT, FMT = 9959 )7
+ WRITE( IOUNIT, FMT = 9960 )8
+ END IF
+*
+* Tests performed
+*
+ WRITE( IOUNIT, FMT = 9999 )'Test ratios: '
+*
+ IF( ITYPE.EQ.1 ) THEN
+*
+* GQR decomposition of rectangular matrices
+*
+ WRITE( IOUNIT, FMT = 9930 )1
+ WRITE( IOUNIT, FMT = 9931 )2
+ WRITE( IOUNIT, FMT = 9932 )3
+ WRITE( IOUNIT, FMT = 9933 )4
+ ELSE IF( ITYPE.EQ.2 ) THEN
+*
+* GRQ decomposition of rectangular matrices
+*
+ WRITE( IOUNIT, FMT = 9934 )1
+ WRITE( IOUNIT, FMT = 9935 )2
+ WRITE( IOUNIT, FMT = 9932 )3
+ WRITE( IOUNIT, FMT = 9933 )4
+ ELSE IF( ITYPE.EQ.3 ) THEN
+*
+* LSE Problem
+*
+ WRITE( IOUNIT, FMT = 9937 )1
+ WRITE( IOUNIT, FMT = 9938 )2
+ ELSE IF( ITYPE.EQ.4 ) THEN
+*
+* GLM Problem
+*
+ WRITE( IOUNIT, FMT = 9939 )1
+ ELSE IF( ITYPE.EQ.5 ) THEN
+*
+* GSVD
+*
+ WRITE( IOUNIT, FMT = 9940 )1
+ WRITE( IOUNIT, FMT = 9941 )2
+ WRITE( IOUNIT, FMT = 9942 )3
+ WRITE( IOUNIT, FMT = 9943 )4
+ WRITE( IOUNIT, FMT = 9944 )5
+ END IF
+*
+ 9999 FORMAT( 1X, A )
+ 9991 FORMAT( / 1X, A3, ': GQR factorization of general matrices' )
+ 9992 FORMAT( / 1X, A3, ': GRQ factorization of general matrices' )
+ 9993 FORMAT( / 1X, A3, ': LSE Problem' )
+ 9994 FORMAT( / 1X, A3, ': GLM Problem' )
+ 9995 FORMAT( / 1X, A3, ': Generalized Singular Value Decomposition' )
+*
+ 9950 FORMAT( 3X, I2, ': A-diagonal matrix B-upper triangular' )
+ 9951 FORMAT( 3X, I2, ': A-diagonal matrix B-lower triangular' )
+ 9952 FORMAT( 3X, I2, ': A-upper triangular B-upper triangular' )
+ 9953 FORMAT( 3X, I2, ': A-lower triangular B-diagonal triangular' )
+ 9954 FORMAT( 3X, I2, ': A-lower triangular B-upper triangular' )
+*
+ 9955 FORMAT( 3X, I2, ': Random matrices cond(A)=100, cond(B)=10,' )
+*
+ 9956 FORMAT( 3X, I2, ': Random matrices cond(A)= sqrt( 0.1/EPS ) ',
+ $ 'cond(B)= sqrt( 0.1/EPS )' )
+ 9957 FORMAT( 3X, I2, ': Random matrices cond(A)= 0.1/EPS ',
+ $ 'cond(B)= 0.1/EPS' )
+ 9959 FORMAT( 3X, I2, ': Random matrices cond(A)= sqrt( 0.1/EPS ) ',
+ $ 'cond(B)= 0.1/EPS ' )
+ 9960 FORMAT( 3X, I2, ': Random matrices cond(A)= 0.1/EPS ',
+ $ 'cond(B)= sqrt( 0.1/EPS )' )
+*
+ 9961 FORMAT( 3X, I2, ': Matrix scaled near underflow limit' )
+ 9962 FORMAT( 3X, I2, ': Matrix scaled near overflow limit' )
+*
+*
+* GQR test ratio
+*
+ 9930 FORMAT( 3X, I2, ': norm( R - Q'' * A ) / ( min( N, M )*norm( A )',
+ $ '* EPS )' )
+ 9931 FORMAT( 3X, I2, ': norm( T * Z - Q'' * B ) / ( min(P,N)*norm(B)',
+ $ '* EPS )' )
+ 9932 FORMAT( 3X, I2, ': norm( I - Q''*Q ) / ( N * EPS )' )
+ 9933 FORMAT( 3X, I2, ': norm( I - Z''*Z ) / ( P * EPS )' )
+*
+* GRQ test ratio
+*
+ 9934 FORMAT( 3X, I2, ': norm( R - A * Q'' ) / ( min( N,M )*norm(A) * ',
+ $ 'EPS )' )
+ 9935 FORMAT( 3X, I2, ': norm( T * Q - Z'' * B ) / ( min( P,N ) * nor',
+ $ 'm(B)*EPS )' )
+*
+* LSE test ratio
+*
+ 9937 FORMAT( 3X, I2, ': norm( A*x - c ) / ( norm(A)*norm(x) * EPS )' )
+ 9938 FORMAT( 3X, I2, ': norm( B*x - d ) / ( norm(B)*norm(x) * EPS )' )
+*
+* GLM test ratio
+*
+ 9939 FORMAT( 3X, I2, ': norm( d - A*x - B*y ) / ( (norm(A)+norm(B) )*',
+ $ '(norm(x)+norm(y))*EPS )' )
+*
+* GSVD test ratio
+*
+ 9940 FORMAT( 3X, I2, ': norm( U'' * A * Q - D1 * R ) / ( min( M, N )*',
+ $ 'norm( A ) * EPS )' )
+ 9941 FORMAT( 3X, I2, ': norm( V'' * B * Q - D2 * R ) / ( min( P, N )*',
+ $ 'norm( B ) * EPS )' )
+ 9942 FORMAT( 3X, I2, ': norm( I - U''*U ) / ( M * EPS )' )
+ 9943 FORMAT( 3X, I2, ': norm( I - V''*V ) / ( P * EPS )' )
+ 9944 FORMAT( 3X, I2, ': norm( I - Q''*Q ) / ( N * EPS )' )
+ RETURN
+*
+* End of ALAHDG
+*
+ END
+ SUBROUTINE ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT )
+*
+* -- LAPACK test routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER*3 PATH
+ INTEGER NIN, NMATS, NOUT, NTYPES
+* ..
+* .. Array Arguments ..
+ LOGICAL DOTYPE( * )
+* ..
+*
+* Purpose
+* =======
+*
+* ALAREQ handles input for the LAPACK test program. It is called
+* to evaluate the input line which requested NMATS matrix types for
+* PATH. The flow of control is as follows:
+*
+* If NMATS = NTYPES then
+* DOTYPE(1:NTYPES) = .TRUE.
+* else
+* Read the next input line for NMATS matrix types
+* Set DOTYPE(I) = .TRUE. for each valid type I
+* endif
+*
+* Arguments
+* =========
+*
+* PATH (input) CHARACTER*3
+* An LAPACK path name for testing.
+*
+* NMATS (input) INTEGER
+* The number of matrix types to be used in testing this path.
+*
+* DOTYPE (output) LOGICAL array, dimension (NTYPES)
+* The vector of flags indicating if each type will be tested.
+*
+* NTYPES (input) INTEGER
+* The maximum number of matrix types for this path.
+*
+* NIN (input) INTEGER
+* The unit number for input. NIN >= 1.
+*
+* NOUT (input) INTEGER
+* The unit number for output. NOUT >= 1.
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ LOGICAL FIRSTT
+ CHARACTER C1
+ CHARACTER*10 INTSTR
+ CHARACTER*80 LINE
+ INTEGER I, I1, IC, J, K, LENP, NT
+* ..
+* .. Local Arrays ..
+ INTEGER NREQ( 100 )
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC LEN
+* ..
+* .. Data statements ..
+ DATA INTSTR / '0123456789' /
+* ..
+* .. Executable Statements ..
+*
+ IF( NMATS.GE.NTYPES ) THEN
+*
+* Test everything if NMATS >= NTYPES.
+*
+ DO 10 I = 1, NTYPES
+ DOTYPE( I ) = .TRUE.
+ 10 CONTINUE
+ ELSE
+ DO 20 I = 1, NTYPES
+ DOTYPE( I ) = .FALSE.
+ 20 CONTINUE
+ FIRSTT = .TRUE.
+*
+* Read a line of matrix types if 0 < NMATS < NTYPES.
+*
+ IF( NMATS.GT.0 ) THEN
+ READ( NIN, FMT = '(A80)', END = 90 )LINE
+ LENP = LEN( LINE )
+ I = 0
+ DO 60 J = 1, NMATS
+ NREQ( J ) = 0
+ I1 = 0
+ 30 CONTINUE
+ I = I + 1
+ IF( I.GT.LENP ) THEN
+ IF( J.EQ.NMATS .AND. I1.GT.0 ) THEN
+ GO TO 60
+ ELSE
+ WRITE( NOUT, FMT = 9995 )LINE
+ WRITE( NOUT, FMT = 9994 )NMATS
+ GO TO 80
+ END IF
+ END IF
+ IF( LINE( I: I ).NE.' ' .AND. LINE( I: I ).NE.',' ) THEN
+ I1 = I
+ C1 = LINE( I1: I1 )
+*
+* Check that a valid integer was read
+*
+ DO 40 K = 1, 10
+ IF( C1.EQ.INTSTR( K: K ) ) THEN
+ IC = K - 1
+ GO TO 50
+ END IF
+ 40 CONTINUE
+ WRITE( NOUT, FMT = 9996 )I, LINE
+ WRITE( NOUT, FMT = 9994 )NMATS
+ GO TO 80
+ 50 CONTINUE
+ NREQ( J ) = 10*NREQ( J ) + IC
+ GO TO 30
+ ELSE IF( I1.GT.0 ) THEN
+ GO TO 60
+ ELSE
+ GO TO 30
+ END IF
+ 60 CONTINUE
+ END IF
+ DO 70 I = 1, NMATS
+ NT = NREQ( I )
+ IF( NT.GT.0 .AND. NT.LE.NTYPES ) THEN
+ IF( DOTYPE( NT ) ) THEN
+ IF( FIRSTT )
+ $ WRITE( NOUT, FMT = * )
+ FIRSTT = .FALSE.
+ WRITE( NOUT, FMT = 9997 )NT, PATH
+ END IF
+ DOTYPE( NT ) = .TRUE.
+ ELSE
+ WRITE( NOUT, FMT = 9999 )PATH, NT, NTYPES
+ 9999 FORMAT( ' *** Invalid type request for ', A3, ', type ',
+ $ I4, ': must satisfy 1 <= type <= ', I2 )
+ END IF
+ 70 CONTINUE
+ 80 CONTINUE
+ END IF
+ RETURN
+*
+ 90 CONTINUE
+ WRITE( NOUT, FMT = 9998 )PATH
+ 9998 FORMAT( /' *** End of file reached when trying to read matrix ',
+ $ 'types for ', A3, /' *** Check that you are requesting the',
+ $ ' right number of types for each path', / )
+ 9997 FORMAT( ' *** Warning: duplicate request of matrix type ', I2,
+ $ ' for ', A3 )
+ 9996 FORMAT( //' *** Invalid integer value in column ', I2,
+ $ ' of input', ' line:', /A79 )
+ 9995 FORMAT( //' *** Not enough matrix types on input line', /A79 )
+ 9994 FORMAT( ' ==> Specify ', I4, ' matrix types on this line or ',
+ $ 'adjust NTYPES on previous line' )
+ WRITE( NOUT, FMT = * )
+ STOP
+*
+* End of ALAREQ
+*
+ END
+ SUBROUTINE ALASUM( TYPE, NOUT, NFAIL, NRUN, NERRS )
+*
+* -- LAPACK test routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER*3 TYPE
+ INTEGER NFAIL, NOUT, NRUN, NERRS
+* ..
+*
+* Purpose
+* =======
+*
+* ALASUM prints a summary of results from one of the -CHK- routines.
+*
+* Arguments
+* =========
+*
+* TYPE (input) CHARACTER*3
+* The LAPACK path name.
+*
+* NOUT (input) INTEGER
+* The unit number on which results are to be printed.
+* NOUT >= 0.
+*
+* NFAIL (input) INTEGER
+* The number of tests which did not pass the threshold ratio.
+*
+* NRUN (input) INTEGER
+* The total number of tests.
+*
+* NERRS (input) INTEGER
+* The number of error messages recorded.
+*
+* =====================================================================
+*
+* .. Executable Statements ..
+*
+ IF( NFAIL.GT.0 ) THEN
+ WRITE( NOUT, FMT = 9999 )TYPE, NFAIL, NRUN
+ ELSE
+ WRITE( NOUT, FMT = 9998 )TYPE, NRUN
+ END IF
+ IF( NERRS.GT.0 ) THEN
+ WRITE( NOUT, FMT = 9997 )NERRS
+ END IF
+*
+ 9999 FORMAT( 1X, A3, ': ', I6, ' out of ', I6,
+ $ ' tests failed to pass the threshold' )
+ 9998 FORMAT( /1X, 'All tests for ', A3,
+ $ ' routines passed the threshold (', I6, ' tests run)' )
+ 9997 FORMAT( 6X, I6, ' error messages recorded' )
+ RETURN
+*
+* End of ALASUM
+*
+ END
+ SUBROUTINE ALASVM( TYPE, NOUT, NFAIL, NRUN, NERRS )
+*
+* -- LAPACK test routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER*3 TYPE
+ INTEGER NFAIL, NOUT, NRUN, NERRS
+* ..
+*
+* Purpose
+* =======
+*
+* ALASVM prints a summary of results from one of the -DRV- routines.
+*
+* Arguments
+* =========
+*
+* TYPE (input) CHARACTER*3
+* The LAPACK path name.
+*
+* NOUT (input) INTEGER
+* The unit number on which results are to be printed.
+* NOUT >= 0.
+*
+* NFAIL (input) INTEGER
+* The number of tests which did not pass the threshold ratio.
+*
+* NRUN (input) INTEGER
+* The total number of tests.
+*
+* NERRS (input) INTEGER
+* The number of error messages recorded.
+*
+* =====================================================================
+*
+* .. Executable Statements ..
+*
+ IF( NFAIL.GT.0 ) THEN
+ WRITE( NOUT, FMT = 9999 )TYPE, NFAIL, NRUN
+ ELSE
+ WRITE( NOUT, FMT = 9998 )TYPE, NRUN
+ END IF
+ IF( NERRS.GT.0 ) THEN
+ WRITE( NOUT, FMT = 9997 )NERRS
+ END IF
+*
+ 9999 FORMAT( 1X, A3, ' drivers: ', I6, ' out of ', I6,
+ $ ' tests failed to pass the threshold' )
+ 9998 FORMAT( /1X, 'All tests for ', A3, ' drivers passed the ',
+ $ 'threshold (', I6, ' tests run)' )
+ 9997 FORMAT( 14X, I6, ' error messages recorded' )
+ RETURN
+*
+* End of ALASVM
+*
+ END
+ SUBROUTINE CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+*
+* Tests whether XERBLA has detected an error when it should.
+*
+* Auxiliary routine for test program for Level 2 Blas.
+*
+* -- Written on 10-August-1987.
+* Richard Hanson, Sandia National Labs.
+* Jeremy Du Croz, NAG Central Office.
+*
+* .. Scalar Arguments ..
+ LOGICAL LERR, OK
+ CHARACTER*6 SRNAMT
+ INTEGER INFOT, NOUT
+* ..
+* .. Executable Statements ..
+ IF( .NOT.LERR ) THEN
+ WRITE( NOUT, FMT = 9999 )INFOT, SRNAMT
+ OK = .FALSE.
+ END IF
+ LERR = .FALSE.
+ RETURN
+*
+ 9999 FORMAT( ' *** Illegal value of parameter number ', I2,
+ $ ' not detected by ', A6, ' ***' )
+*
+* End of CHKXER.
+*
+ END
+ SUBROUTINE DBDT01( M, N, KD, A, LDA, Q, LDQ, D, E, PT, LDPT, WORK,
+ $ RESID )
+*
+* -- LAPACK test routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER KD, LDA, LDPT, LDQ, M, N
+ DOUBLE PRECISION RESID
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION A( LDA, * ), D( * ), E( * ), PT( LDPT, * ),
+ $ Q( LDQ, * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DBDT01 reconstructs a general matrix A from its bidiagonal form
+* A = Q * B * P'
+* where Q (m by min(m,n)) and P' (min(m,n) by n) are orthogonal
+* matrices and B is bidiagonal.
+*
+* The test ratio to test the reduction is
+* RESID = norm( A - Q * B * PT ) / ( n * norm(A) * EPS )
+* where PT = P' and EPS is the machine precision.
+*
+* Arguments
+* =========
+*
+* M (input) INTEGER
+* The number of rows of the matrices A and Q.
+*
+* N (input) INTEGER
+* The number of columns of the matrices A and P'.
+*
+* KD (input) INTEGER
+* If KD = 0, B is diagonal and the array E is not referenced.
+* If KD = 1, the reduction was performed by xGEBRD; B is upper
+* bidiagonal if M >= N, and lower bidiagonal if M < N.
+* If KD = -1, the reduction was performed by xGBBRD; B is
+* always upper bidiagonal.
+*
+* A (input) DOUBLE PRECISION array, dimension (LDA,N)
+* The m by n matrix A.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,M).
+*
+* Q (input) DOUBLE PRECISION array, dimension (LDQ,N)
+* The m by min(m,n) orthogonal matrix Q in the reduction
+* A = Q * B * P'.
+*
+* LDQ (input) INTEGER
+* The leading dimension of the array Q. LDQ >= max(1,M).
+*
+* D (input) DOUBLE PRECISION array, dimension (min(M,N))
+* The diagonal elements of the bidiagonal matrix B.
+*
+* E (input) DOUBLE PRECISION array, dimension (min(M,N)-1)
+* The superdiagonal elements of the bidiagonal matrix B if
+* m >= n, or the subdiagonal elements of B if m < n.
+*
+* PT (input) DOUBLE PRECISION array, dimension (LDPT,N)
+* The min(m,n) by n orthogonal matrix P' in the reduction
+* A = Q * B * P'.
+*
+* LDPT (input) INTEGER
+* The leading dimension of the array PT.
+* LDPT >= max(1,min(M,N)).
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (M+N)
+*
+* RESID (output) DOUBLE PRECISION
+* The test ratio: norm(A - Q * B * P') / ( n * norm(A) * EPS )
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, J
+ DOUBLE PRECISION ANORM, EPS
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DASUM, DLAMCH, DLANGE
+ EXTERNAL DASUM, DLAMCH, DLANGE
+* ..
+* .. External Subroutines ..
+ EXTERNAL DCOPY, DGEMV
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC DBLE, MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+* Quick return if possible
+*
+ IF( M.LE.0 .OR. N.LE.0 ) THEN
+ RESID = ZERO
+ RETURN
+ END IF
+*
+* Compute A - Q * B * P' one column at a time.
+*
+ RESID = ZERO
+ IF( KD.NE.0 ) THEN
+*
+* B is bidiagonal.
+*
+ IF( KD.NE.0 .AND. M.GE.N ) THEN
+*
+* B is upper bidiagonal and M >= N.
+*
+ DO 20 J = 1, N
+ CALL DCOPY( M, A( 1, J ), 1, WORK, 1 )
+ DO 10 I = 1, N - 1
+ WORK( M+I ) = D( I )*PT( I, J ) + E( I )*PT( I+1, J )
+ 10 CONTINUE
+ WORK( M+N ) = D( N )*PT( N, J )
+ CALL DGEMV( 'No transpose', M, N, -ONE, Q, LDQ,
+ $ WORK( M+1 ), 1, ONE, WORK, 1 )
+ RESID = MAX( RESID, DASUM( M, WORK, 1 ) )
+ 20 CONTINUE
+ ELSE IF( KD.LT.0 ) THEN
+*
+* B is upper bidiagonal and M < N.
+*
+ DO 40 J = 1, N
+ CALL DCOPY( M, A( 1, J ), 1, WORK, 1 )
+ DO 30 I = 1, M - 1
+ WORK( M+I ) = D( I )*PT( I, J ) + E( I )*PT( I+1, J )
+ 30 CONTINUE
+ WORK( M+M ) = D( M )*PT( M, J )
+ CALL DGEMV( 'No transpose', M, M, -ONE, Q, LDQ,
+ $ WORK( M+1 ), 1, ONE, WORK, 1 )
+ RESID = MAX( RESID, DASUM( M, WORK, 1 ) )
+ 40 CONTINUE
+ ELSE
+*
+* B is lower bidiagonal.
+*
+ DO 60 J = 1, N
+ CALL DCOPY( M, A( 1, J ), 1, WORK, 1 )
+ WORK( M+1 ) = D( 1 )*PT( 1, J )
+ DO 50 I = 2, M
+ WORK( M+I ) = E( I-1 )*PT( I-1, J ) +
+ $ D( I )*PT( I, J )
+ 50 CONTINUE
+ CALL DGEMV( 'No transpose', M, M, -ONE, Q, LDQ,
+ $ WORK( M+1 ), 1, ONE, WORK, 1 )
+ RESID = MAX( RESID, DASUM( M, WORK, 1 ) )
+ 60 CONTINUE
+ END IF
+ ELSE
+*
+* B is diagonal.
+*
+ IF( M.GE.N ) THEN
+ DO 80 J = 1, N
+ CALL DCOPY( M, A( 1, J ), 1, WORK, 1 )
+ DO 70 I = 1, N
+ WORK( M+I ) = D( I )*PT( I, J )
+ 70 CONTINUE
+ CALL DGEMV( 'No transpose', M, N, -ONE, Q, LDQ,
+ $ WORK( M+1 ), 1, ONE, WORK, 1 )
+ RESID = MAX( RESID, DASUM( M, WORK, 1 ) )
+ 80 CONTINUE
+ ELSE
+ DO 100 J = 1, N
+ CALL DCOPY( M, A( 1, J ), 1, WORK, 1 )
+ DO 90 I = 1, M
+ WORK( M+I ) = D( I )*PT( I, J )
+ 90 CONTINUE
+ CALL DGEMV( 'No transpose', M, M, -ONE, Q, LDQ,
+ $ WORK( M+1 ), 1, ONE, WORK, 1 )
+ RESID = MAX( RESID, DASUM( M, WORK, 1 ) )
+ 100 CONTINUE
+ END IF
+ END IF
+*
+* Compute norm(A - Q * B * P') / ( n * norm(A) * EPS )
+*
+ ANORM = DLANGE( '1', M, N, A, LDA, WORK )
+ EPS = DLAMCH( 'Precision' )
+*
+ IF( ANORM.LE.ZERO ) THEN
+ IF( RESID.NE.ZERO )
+ $ RESID = ONE / EPS
+ ELSE
+ IF( ANORM.GE.RESID ) THEN
+ RESID = ( RESID / ANORM ) / ( DBLE( N )*EPS )
+ ELSE
+ IF( ANORM.LT.ONE ) THEN
+ RESID = ( MIN( RESID, DBLE( N )*ANORM ) / ANORM ) /
+ $ ( DBLE( N )*EPS )
+ ELSE
+ RESID = MIN( RESID / ANORM, DBLE( N ) ) /
+ $ ( DBLE( N )*EPS )
+ END IF
+ END IF
+ END IF
+*
+ RETURN
+*
+* End of DBDT01
+*
+ END
+ SUBROUTINE DBDT02( M, N, B, LDB, C, LDC, U, LDU, WORK, RESID )
+*
+* -- LAPACK test routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER LDB, LDC, LDU, M, N
+ DOUBLE PRECISION RESID
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION B( LDB, * ), C( LDC, * ), U( LDU, * ),
+ $ WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DBDT02 tests the change of basis C = U' * B by computing the residual
+*
+* RESID = norm( B - U * C ) / ( max(m,n) * norm(B) * EPS ),
+*
+* where B and C are M by N matrices, U is an M by M orthogonal matrix,
+* and EPS is the machine precision.
+*
+* Arguments
+* =========
+*
+* M (input) INTEGER
+* The number of rows of the matrices B and C and the order of
+* the matrix Q.
+*
+* N (input) INTEGER
+* The number of columns of the matrices B and C.
+*
+* B (input) DOUBLE PRECISION array, dimension (LDB,N)
+* The m by n matrix B.
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. LDB >= max(1,M).
+*
+* C (input) DOUBLE PRECISION array, dimension (LDC,N)
+* The m by n matrix C, assumed to contain U' * B.
+*
+* LDC (input) INTEGER
+* The leading dimension of the array C. LDC >= max(1,M).
+*
+* U (input) DOUBLE PRECISION array, dimension (LDU,M)
+* The m by m orthogonal matrix U.
+*
+* LDU (input) INTEGER
+* The leading dimension of the array U. LDU >= max(1,M).
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (M)
+*
+* RESID (output) DOUBLE PRECISION
+* RESID = norm( B - U * C ) / ( max(m,n) * norm(B) * EPS ),
+*
+* ======================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER J
+ DOUBLE PRECISION BNORM, EPS, REALMN
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DASUM, DLAMCH, DLANGE
+ EXTERNAL DASUM, DLAMCH, DLANGE
+* ..
+* .. External Subroutines ..
+ EXTERNAL DCOPY, DGEMV
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC DBLE, MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+* Quick return if possible
+*
+ RESID = ZERO
+ IF( M.LE.0 .OR. N.LE.0 )
+ $ RETURN
+ REALMN = DBLE( MAX( M, N ) )
+ EPS = DLAMCH( 'Precision' )
+*
+* Compute norm( B - U * C )
+*
+ DO 10 J = 1, N
+ CALL DCOPY( M, B( 1, J ), 1, WORK, 1 )
+ CALL DGEMV( 'No transpose', M, M, -ONE, U, LDU, C( 1, J ), 1,
+ $ ONE, WORK, 1 )
+ RESID = MAX( RESID, DASUM( M, WORK, 1 ) )
+ 10 CONTINUE
+*
+* Compute norm of B.
+*
+ BNORM = DLANGE( '1', M, N, B, LDB, WORK )
+*
+ IF( BNORM.LE.ZERO ) THEN
+ IF( RESID.NE.ZERO )
+ $ RESID = ONE / EPS
+ ELSE
+ IF( BNORM.GE.RESID ) THEN
+ RESID = ( RESID / BNORM ) / ( REALMN*EPS )
+ ELSE
+ IF( BNORM.LT.ONE ) THEN
+ RESID = ( MIN( RESID, REALMN*BNORM ) / BNORM ) /
+ $ ( REALMN*EPS )
+ ELSE
+ RESID = MIN( RESID / BNORM, REALMN ) / ( REALMN*EPS )
+ END IF
+ END IF
+ END IF
+ RETURN
+*
+* End of DBDT02
+*
+ END
+ SUBROUTINE DBDT03( UPLO, N, KD, D, E, U, LDU, S, VT, LDVT, WORK,
+ $ RESID )
+*
+* -- LAPACK test routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER KD, LDU, LDVT, N
+ DOUBLE PRECISION RESID
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION D( * ), E( * ), S( * ), U( LDU, * ),
+ $ VT( LDVT, * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DBDT03 reconstructs a bidiagonal matrix B from its SVD:
+* S = U' * B * V
+* where U and V are orthogonal matrices and S is diagonal.
+*
+* The test ratio to test the singular value decomposition is
+* RESID = norm( B - U * S * VT ) / ( n * norm(B) * EPS )
+* where VT = V' and EPS is the machine precision.
+*
+* Arguments
+* =========
+*
+* UPLO (input) CHARACTER*1
+* Specifies whether the matrix B is upper or lower bidiagonal.
+* = 'U': Upper bidiagonal
+* = 'L': Lower bidiagonal
+*
+* N (input) INTEGER
+* The order of the matrix B.
+*
+* KD (input) INTEGER
+* The bandwidth of the bidiagonal matrix B. If KD = 1, the
+* matrix B is bidiagonal, and if KD = 0, B is diagonal and E is
+* not referenced. If KD is greater than 1, it is assumed to be
+* 1, and if KD is less than 0, it is assumed to be 0.
+*
+* D (input) DOUBLE PRECISION array, dimension (N)
+* The n diagonal elements of the bidiagonal matrix B.
+*
+* E (input) DOUBLE PRECISION array, dimension (N-1)
+* The (n-1) superdiagonal elements of the bidiagonal matrix B
+* if UPLO = 'U', or the (n-1) subdiagonal elements of B if
+* UPLO = 'L'.
+*
+* U (input) DOUBLE PRECISION array, dimension (LDU,N)
+* The n by n orthogonal matrix U in the reduction B = U'*A*P.
+*
+* LDU (input) INTEGER
+* The leading dimension of the array U. LDU >= max(1,N)
+*
+* S (input) DOUBLE PRECISION array, dimension (N)
+* The singular values from the SVD of B, sorted in decreasing
+* order.
+*
+* VT (input) DOUBLE PRECISION array, dimension (LDVT,N)
+* The n by n orthogonal matrix V' in the reduction
+* B = U * S * V'.
+*
+* LDVT (input) INTEGER
+* The leading dimension of the array VT.
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (2*N)
+*
+* RESID (output) DOUBLE PRECISION
+* The test ratio: norm(B - U * S * V') / ( n * norm(A) * EPS )
+*
+* ======================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, J
+ DOUBLE PRECISION BNORM, EPS
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER IDAMAX
+ DOUBLE PRECISION DASUM, DLAMCH
+ EXTERNAL LSAME, IDAMAX, DASUM, DLAMCH
+* ..
+* .. External Subroutines ..
+ EXTERNAL DGEMV
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, DBLE, MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+* Quick return if possible
+*
+ RESID = ZERO
+ IF( N.LE.0 )
+ $ RETURN
+*
+* Compute B - U * S * V' one column at a time.
+*
+ BNORM = ZERO
+ IF( KD.GE.1 ) THEN
+*
+* B is bidiagonal.
+*
+ IF( LSAME( UPLO, 'U' ) ) THEN
+*
+* B is upper bidiagonal.
+*
+ DO 20 J = 1, N
+ DO 10 I = 1, N
+ WORK( N+I ) = S( I )*VT( I, J )
+ 10 CONTINUE
+ CALL DGEMV( 'No transpose', N, N, -ONE, U, LDU,
+ $ WORK( N+1 ), 1, ZERO, WORK, 1 )
+ WORK( J ) = WORK( J ) + D( J )
+ IF( J.GT.1 ) THEN
+ WORK( J-1 ) = WORK( J-1 ) + E( J-1 )
+ BNORM = MAX( BNORM, ABS( D( J ) )+ABS( E( J-1 ) ) )
+ ELSE
+ BNORM = MAX( BNORM, ABS( D( J ) ) )
+ END IF
+ RESID = MAX( RESID, DASUM( N, WORK, 1 ) )
+ 20 CONTINUE
+ ELSE
+*
+* B is lower bidiagonal.
+*
+ DO 40 J = 1, N
+ DO 30 I = 1, N
+ WORK( N+I ) = S( I )*VT( I, J )
+ 30 CONTINUE
+ CALL DGEMV( 'No transpose', N, N, -ONE, U, LDU,
+ $ WORK( N+1 ), 1, ZERO, WORK, 1 )
+ WORK( J ) = WORK( J ) + D( J )
+ IF( J.LT.N ) THEN
+ WORK( J+1 ) = WORK( J+1 ) + E( J )
+ BNORM = MAX( BNORM, ABS( D( J ) )+ABS( E( J ) ) )
+ ELSE
+ BNORM = MAX( BNORM, ABS( D( J ) ) )
+ END IF
+ RESID = MAX( RESID, DASUM( N, WORK, 1 ) )
+ 40 CONTINUE
+ END IF
+ ELSE
+*
+* B is diagonal.
+*
+ DO 60 J = 1, N
+ DO 50 I = 1, N
+ WORK( N+I ) = S( I )*VT( I, J )
+ 50 CONTINUE
+ CALL DGEMV( 'No transpose', N, N, -ONE, U, LDU, WORK( N+1 ),
+ $ 1, ZERO, WORK, 1 )
+ WORK( J ) = WORK( J ) + D( J )
+ RESID = MAX( RESID, DASUM( N, WORK, 1 ) )
+ 60 CONTINUE
+ J = IDAMAX( N, D, 1 )
+ BNORM = ABS( D( J ) )
+ END IF
+*
+* Compute norm(B - U * S * V') / ( n * norm(B) * EPS )
+*
+ EPS = DLAMCH( 'Precision' )
+*
+ IF( BNORM.LE.ZERO ) THEN
+ IF( RESID.NE.ZERO )
+ $ RESID = ONE / EPS
+ ELSE
+ IF( BNORM.GE.RESID ) THEN
+ RESID = ( RESID / BNORM ) / ( DBLE( N )*EPS )
+ ELSE
+ IF( BNORM.LT.ONE ) THEN
+ RESID = ( MIN( RESID, DBLE( N )*BNORM ) / BNORM ) /
+ $ ( DBLE( N )*EPS )
+ ELSE
+ RESID = MIN( RESID / BNORM, DBLE( N ) ) /
+ $ ( DBLE( N )*EPS )
+ END IF
+ END IF
+ END IF
+*
+ RETURN
+*
+* End of DBDT03
+*
+ END
+ SUBROUTINE DCHKBB( NSIZES, MVAL, NVAL, NWDTHS, KK, NTYPES, DOTYPE,
+ $ NRHS, ISEED, THRESH, NOUNIT, A, LDA, AB, LDAB,
+ $ BD, BE, Q, LDQ, P, LDP, C, LDC, CC, WORK,
+ $ LWORK, RESULT, INFO )
+*
+* -- LAPACK test routine (release 2.0) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LDA, LDAB, LDC, LDP, LDQ, LWORK, NOUNIT,
+ $ NRHS, NSIZES, NTYPES, NWDTHS
+ DOUBLE PRECISION THRESH
+* ..
+* .. Array Arguments ..
+ LOGICAL DOTYPE( * )
+ INTEGER ISEED( 4 ), KK( * ), MVAL( * ), NVAL( * )
+ DOUBLE PRECISION A( LDA, * ), AB( LDAB, * ), BD( * ), BE( * ),
+ $ C( LDC, * ), CC( LDC, * ), P( LDP, * ),
+ $ Q( LDQ, * ), RESULT( * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DCHKBB tests the reduction of a general real rectangular band
+* matrix to bidiagonal form.
+*
+* DGBBRD factors a general band matrix A as Q B P* , where * means
+* transpose, B is upper bidiagonal, and Q and P are orthogonal;
+* DGBBRD can also overwrite a given matrix C with Q* C .
+*
+* For each pair of matrix dimensions (M,N) and each selected matrix
+* type, an M by N matrix A and an M by NRHS matrix C are generated.
+* The problem dimensions are as follows
+* A: M x N
+* Q: M x M
+* P: N x N
+* B: min(M,N) x min(M,N)
+* C: M x NRHS
+*
+* For each generated matrix, 4 tests are performed:
+*
+* (1) | A - Q B PT | / ( |A| max(M,N) ulp ), PT = P'
+*
+* (2) | I - Q' Q | / ( M ulp )
+*
+* (3) | I - PT PT' | / ( N ulp )
+*
+* (4) | Y - Q' C | / ( |Y| max(M,NRHS) ulp ), where Y = Q' C.
+*
+* The "types" are specified by a logical array DOTYPE( 1:NTYPES );
+* if DOTYPE(j) is .TRUE., then matrix type "j" will be generated.
+* Currently, the list of possible types is:
+*
+* The possible matrix types are
+*
+* (1) The zero matrix.
+* (2) The identity matrix.
+*
+* (3) A diagonal matrix with evenly spaced entries
+* 1, ..., ULP and random signs.
+* (ULP = (first number larger than 1) - 1 )
+* (4) A diagonal matrix with geometrically spaced entries
+* 1, ..., ULP and random signs.
+* (5) A diagonal matrix with "clustered" entries 1, ULP, ..., ULP
+* and random signs.
+*
+* (6) Same as (3), but multiplied by SQRT( overflow threshold )
+* (7) Same as (3), but multiplied by SQRT( underflow threshold )
+*
+* (8) A matrix of the form U D V, where U and V are orthogonal and
+* D has evenly spaced entries 1, ..., ULP with random signs
+* on the diagonal.
+*
+* (9) A matrix of the form U D V, where U and V are orthogonal and
+* D has geometrically spaced entries 1, ..., ULP with random
+* signs on the diagonal.
+*
+* (10) A matrix of the form U D V, where U and V are orthogonal and
+* D has "clustered" entries 1, ULP,..., ULP with random
+* signs on the diagonal.
+*
+* (11) Same as (8), but multiplied by SQRT( overflow threshold )
+* (12) Same as (8), but multiplied by SQRT( underflow threshold )
+*
+* (13) Rectangular matrix with random entries chosen from (-1,1).
+* (14) Same as (13), but multiplied by SQRT( overflow threshold )
+* (15) Same as (13), but multiplied by SQRT( underflow threshold )
+*
+* Arguments
+* =========
+*
+* NSIZES (input) INTEGER
+* The number of values of M and N contained in the vectors
+* MVAL and NVAL. The matrix sizes are used in pairs (M,N).
+* If NSIZES is zero, DCHKBB does nothing. NSIZES must be at
+* least zero.
+*
+* MVAL (input) INTEGER array, dimension (NSIZES)
+* The values of the matrix row dimension M.
+*
+* NVAL (input) INTEGER array, dimension (NSIZES)
+* The values of the matrix column dimension N.
+*
+* NWDTHS (input) INTEGER
+* The number of bandwidths to use. If it is zero,
+* DCHKBB does nothing. It must be at least zero.
+*
+* KK (input) INTEGER array, dimension (NWDTHS)
+* An array containing the bandwidths to be used for the band
+* matrices. The values must be at least zero.
+*
+* NTYPES (input) INTEGER
+* The number of elements in DOTYPE. If it is zero, DCHKBB
+* does nothing. It must be at least zero. If it is MAXTYP+1
+* and NSIZES is 1, then an additional type, MAXTYP+1 is
+* defined, which is to use whatever matrix is in A. This
+* is only useful if DOTYPE(1:MAXTYP) is .FALSE. and
+* DOTYPE(MAXTYP+1) is .TRUE. .
+*
+* DOTYPE (input) LOGICAL array, dimension (NTYPES)
+* If DOTYPE(j) is .TRUE., then for each size in NN a
+* matrix of that size and of type j will be generated.
+* If NTYPES is smaller than the maximum number of types
+* defined (PARAMETER MAXTYP), then types NTYPES+1 through
+* MAXTYP will not be generated. If NTYPES is larger
+* than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES)
+* will be ignored.
+*
+* NRHS (input) INTEGER
+* The number of columns in the "right-hand side" matrix C.
+* If NRHS = 0, then the operations on the right-hand side will
+* not be tested. NRHS must be at least 0.
+*
+* ISEED (input/output) INTEGER array, dimension (4)
+* On entry ISEED specifies the seed of the random number
+* generator. The array elements should be between 0 and 4095;
+* if not they will be reduced mod 4096. Also, ISEED(4) must
+* be odd. The random number generator uses a linear
+* congruential sequence limited to small integers, and so
+* should produce machine independent random numbers. The
+* values of ISEED are changed on exit, and can be used in the
+* next call to DCHKBB to continue the same random number
+* sequence.
+*
+* THRESH (input) DOUBLE PRECISION
+* A test will count as "failed" if the "error", computed as
+* described above, exceeds THRESH. Note that the error
+* is scaled to be O(1), so THRESH should be a reasonably
+* small multiple of 1, e.g., 10 or 100. In particular,
+* it should not depend on the precision (single vs. double)
+* or the size of the matrix. It must be at least zero.
+*
+* NOUNIT (input) INTEGER
+* The FORTRAN unit number for printing out error messages
+* (e.g., if a routine returns IINFO not equal to 0.)
+*
+* A (input/workspace) DOUBLE PRECISION array, dimension
+* (LDA, max(NN))
+* Used to hold the matrix A.
+*
+* LDA (input) INTEGER
+* The leading dimension of A. It must be at least 1
+* and at least max( NN ).
+*
+* AB (workspace) DOUBLE PRECISION array, dimension (LDAB, max(NN))
+* Used to hold A in band storage format.
+*
+* LDAB (input) INTEGER
+* The leading dimension of AB. It must be at least 2 (not 1!)
+* and at least max( KK )+1.
+*
+* BD (workspace) DOUBLE PRECISION array, dimension (max(NN))
+* Used to hold the diagonal of the bidiagonal matrix computed
+* by DGBBRD.
+*
+* BE (workspace) DOUBLE PRECISION array, dimension (max(NN))
+* Used to hold the off-diagonal of the bidiagonal matrix
+* computed by DGBBRD.
+*
+* Q (workspace) DOUBLE PRECISION array, dimension (LDQ, max(NN))
+* Used to hold the orthogonal matrix Q computed by DGBBRD.
+*
+* LDQ (input) INTEGER
+* The leading dimension of Q. It must be at least 1
+* and at least max( NN ).
+*
+* P (workspace) DOUBLE PRECISION array, dimension (LDP, max(NN))
+* Used to hold the orthogonal matrix P computed by DGBBRD.
+*
+* LDP (input) INTEGER
+* The leading dimension of P. It must be at least 1
+* and at least max( NN ).
+*
+* C (workspace) DOUBLE PRECISION array, dimension (LDC, max(NN))
+* Used to hold the matrix C updated by DGBBRD.
+*
+* LDC (input) INTEGER
+* The leading dimension of U. It must be at least 1
+* and at least max( NN ).
+*
+* CC (workspace) DOUBLE PRECISION array, dimension (LDC, max(NN))
+* Used to hold a copy of the matrix C.
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK)
+*
+* LWORK (input) INTEGER
+* The number of entries in WORK. This must be at least
+* max( LDA+1, max(NN)+1 )*max(NN).
+*
+* RESULT (output) DOUBLE PRECISION array, dimension (4)
+* The values computed by the tests described above.
+* The values are currently limited to 1/ulp, to avoid
+* overflow.
+*
+* INFO (output) INTEGER
+* If 0, then everything ran OK.
+*
+*-----------------------------------------------------------------------
+*
+* Some Local Variables and Parameters:
+* ---- ----- --------- --- ----------
+* ZERO, ONE Real 0 and 1.
+* MAXTYP The number of types defined.
+* NTEST The number of tests performed, or which can
+* be performed so far, for the current matrix.
+* NTESTT The total number of tests performed so far.
+* NMAX Largest value in NN.
+* NMATS The number of matrices generated so far.
+* NERRS The number of tests which have exceeded THRESH
+* so far.
+* COND, IMODE Values to be passed to the matrix generators.
+* ANORM Norm of A; passed to matrix generators.
+*
+* OVFL, UNFL Overflow and underflow thresholds.
+* ULP, ULPINV Finest relative precision and its inverse.
+* RTOVFL, RTUNFL Square roots of the previous 2 values.
+* The following four arrays decode JTYPE:
+* KTYPE(j) The general type (1-10) for type "j".
+* KMODE(j) The MODE value to be passed to the matrix
+* generator for type "j".
+* KMAGN(j) The order of magnitude ( O(1),
+* O(overflow^(1/2) ), O(underflow^(1/2) )
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
+ INTEGER MAXTYP
+ PARAMETER ( MAXTYP = 15 )
+* ..
+* .. Local Scalars ..
+ LOGICAL BADMM, BADNN, BADNNB
+ INTEGER I, IINFO, IMODE, ITYPE, J, JCOL, JR, JSIZE,
+ $ JTYPE, JWIDTH, K, KL, KMAX, KU, M, MMAX, MNMAX,
+ $ MNMIN, MTYPES, N, NERRS, NMATS, NMAX, NTEST,
+ $ NTESTT
+ DOUBLE PRECISION AMNINV, ANORM, COND, OVFL, RTOVFL, RTUNFL, ULP,
+ $ ULPINV, UNFL
+* ..
+* .. Local Arrays ..
+ INTEGER IDUMMA( 1 ), IOLDSD( 4 ), KMAGN( MAXTYP ),
+ $ KMODE( MAXTYP ), KTYPE( MAXTYP )
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DLAMCH
+ EXTERNAL DLAMCH
+* ..
+* .. External Subroutines ..
+ EXTERNAL DBDT01, DBDT02, DGBBRD, DLACPY, DLAHD2, DLASET,
+ $ DLASUM, DLATMR, DLATMS, DORT01, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, DBLE, MAX, MIN, SQRT
+* ..
+* .. Data statements ..
+ DATA KTYPE / 1, 2, 5*4, 5*6, 3*9 /
+ DATA KMAGN / 2*1, 3*1, 2, 3, 3*1, 2, 3, 1, 2, 3 /
+ DATA KMODE / 2*0, 4, 3, 1, 4, 4, 4, 3, 1, 4, 4, 0,
+ $ 0, 0 /
+* ..
+* .. Executable Statements ..
+*
+* Check for errors
+*
+ NTESTT = 0
+ INFO = 0
+*
+* Important constants
+*
+ BADMM = .FALSE.
+ BADNN = .FALSE.
+ MMAX = 1
+ NMAX = 1
+ MNMAX = 1
+ DO 10 J = 1, NSIZES
+ MMAX = MAX( MMAX, MVAL( J ) )
+ IF( MVAL( J ).LT.0 )
+ $ BADMM = .TRUE.
+ NMAX = MAX( NMAX, NVAL( J ) )
+ IF( NVAL( J ).LT.0 )
+ $ BADNN = .TRUE.
+ MNMAX = MAX( MNMAX, MIN( MVAL( J ), NVAL( J ) ) )
+ 10 CONTINUE
+*
+ BADNNB = .FALSE.
+ KMAX = 0
+ DO 20 J = 1, NWDTHS
+ KMAX = MAX( KMAX, KK( J ) )
+ IF( KK( J ).LT.0 )
+ $ BADNNB = .TRUE.
+ 20 CONTINUE
+*
+* Check for errors
+*
+ IF( NSIZES.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( BADMM ) THEN
+ INFO = -2
+ ELSE IF( BADNN ) THEN
+ INFO = -3
+ ELSE IF( NWDTHS.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( BADNNB ) THEN
+ INFO = -5
+ ELSE IF( NTYPES.LT.0 ) THEN
+ INFO = -6
+ ELSE IF( NRHS.LT.0 ) THEN
+ INFO = -8
+ ELSE IF( LDA.LT.NMAX ) THEN
+ INFO = -13
+ ELSE IF( LDAB.LT.2*KMAX+1 ) THEN
+ INFO = -15
+ ELSE IF( LDQ.LT.NMAX ) THEN
+ INFO = -19
+ ELSE IF( LDP.LT.NMAX ) THEN
+ INFO = -21
+ ELSE IF( LDC.LT.NMAX ) THEN
+ INFO = -23
+ ELSE IF( ( MAX( LDA, NMAX )+1 )*NMAX.GT.LWORK ) THEN
+ INFO = -26
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DCHKBB', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( NSIZES.EQ.0 .OR. NTYPES.EQ.0 .OR. NWDTHS.EQ.0 )
+ $ RETURN
+*
+* More Important constants
+*
+ UNFL = DLAMCH( 'Safe minimum' )
+ OVFL = ONE / UNFL
+ ULP = DLAMCH( 'Epsilon' )*DLAMCH( 'Base' )
+ ULPINV = ONE / ULP
+ RTUNFL = SQRT( UNFL )
+ RTOVFL = SQRT( OVFL )
+*
+* Loop over sizes, widths, types
+*
+ NERRS = 0
+ NMATS = 0
+*
+ DO 160 JSIZE = 1, NSIZES
+ M = MVAL( JSIZE )
+ N = NVAL( JSIZE )
+ MNMIN = MIN( M, N )
+ AMNINV = ONE / DBLE( MAX( 1, M, N ) )
+*
+ DO 150 JWIDTH = 1, NWDTHS
+ K = KK( JWIDTH )
+ IF( K.GE.M .AND. K.GE.N )
+ $ GO TO 150
+ KL = MAX( 0, MIN( M-1, K ) )
+ KU = MAX( 0, MIN( N-1, K ) )
+*
+ IF( NSIZES.NE.1 ) THEN
+ MTYPES = MIN( MAXTYP, NTYPES )
+ ELSE
+ MTYPES = MIN( MAXTYP+1, NTYPES )
+ END IF
+*
+ DO 140 JTYPE = 1, MTYPES
+ IF( .NOT.DOTYPE( JTYPE ) )
+ $ GO TO 140
+ NMATS = NMATS + 1
+ NTEST = 0
+*
+ DO 30 J = 1, 4
+ IOLDSD( J ) = ISEED( J )
+ 30 CONTINUE
+*
+* Compute "A".
+*
+* Control parameters:
+*
+* KMAGN KMODE KTYPE
+* =1 O(1) clustered 1 zero
+* =2 large clustered 2 identity
+* =3 small exponential (none)
+* =4 arithmetic diagonal, (w/ singular values)
+* =5 random log (none)
+* =6 random nonhermitian, w/ singular values
+* =7 (none)
+* =8 (none)
+* =9 random nonhermitian
+*
+ IF( MTYPES.GT.MAXTYP )
+ $ GO TO 90
+*
+ ITYPE = KTYPE( JTYPE )
+ IMODE = KMODE( JTYPE )
+*
+* Compute norm
+*
+ GO TO ( 40, 50, 60 )KMAGN( JTYPE )
+*
+ 40 CONTINUE
+ ANORM = ONE
+ GO TO 70
+*
+ 50 CONTINUE
+ ANORM = ( RTOVFL*ULP )*AMNINV
+ GO TO 70
+*
+ 60 CONTINUE
+ ANORM = RTUNFL*MAX( M, N )*ULPINV
+ GO TO 70
+*
+ 70 CONTINUE
+*
+ CALL DLASET( 'Full', LDA, N, ZERO, ZERO, A, LDA )
+ CALL DLASET( 'Full', LDAB, N, ZERO, ZERO, AB, LDAB )
+ IINFO = 0
+ COND = ULPINV
+*
+* Special Matrices -- Identity & Jordan block
+*
+* Zero
+*
+ IF( ITYPE.EQ.1 ) THEN
+ IINFO = 0
+*
+ ELSE IF( ITYPE.EQ.2 ) THEN
+*
+* Identity
+*
+ DO 80 JCOL = 1, N
+ A( JCOL, JCOL ) = ANORM
+ 80 CONTINUE
+*
+ ELSE IF( ITYPE.EQ.4 ) THEN
+*
+* Diagonal Matrix, singular values specified
+*
+ CALL DLATMS( M, N, 'S', ISEED, 'N', WORK, IMODE, COND,
+ $ ANORM, 0, 0, 'N', A, LDA, WORK( M+1 ),
+ $ IINFO )
+*
+ ELSE IF( ITYPE.EQ.6 ) THEN
+*
+* Nonhermitian, singular values specified
+*
+ CALL DLATMS( M, N, 'S', ISEED, 'N', WORK, IMODE, COND,
+ $ ANORM, KL, KU, 'N', A, LDA, WORK( M+1 ),
+ $ IINFO )
+*
+ ELSE IF( ITYPE.EQ.9 ) THEN
+*
+* Nonhermitian, random entries
+*
+ CALL DLATMR( M, N, 'S', ISEED, 'N', WORK, 6, ONE, ONE,
+ $ 'T', 'N', WORK( N+1 ), 1, ONE,
+ $ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, KL,
+ $ KU, ZERO, ANORM, 'N', A, LDA, IDUMMA,
+ $ IINFO )
+*
+ ELSE
+*
+ IINFO = 1
+ END IF
+*
+* Generate Right-Hand Side
+*
+ CALL DLATMR( M, NRHS, 'S', ISEED, 'N', WORK, 6, ONE, ONE,
+ $ 'T', 'N', WORK( M+1 ), 1, ONE,
+ $ WORK( 2*M+1 ), 1, ONE, 'N', IDUMMA, M, NRHS,
+ $ ZERO, ONE, 'NO', C, LDC, IDUMMA, IINFO )
+*
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUNIT, FMT = 9999 )'Generator', IINFO, N,
+ $ JTYPE, IOLDSD
+ INFO = ABS( IINFO )
+ RETURN
+ END IF
+*
+ 90 CONTINUE
+*
+* Copy A to band storage.
+*
+ DO 110 J = 1, N
+ DO 100 I = MAX( 1, J-KU ), MIN( M, J+KL )
+ AB( KU+1+I-J, J ) = A( I, J )
+ 100 CONTINUE
+ 110 CONTINUE
+*
+* Copy C
+*
+ CALL DLACPY( 'Full', M, NRHS, C, LDC, CC, LDC )
+*
+* Call DGBBRD to compute B, Q and P, and to update C.
+*
+ CALL DGBBRD( 'B', M, N, NRHS, KL, KU, AB, LDAB, BD, BE,
+ $ Q, LDQ, P, LDP, CC, LDC, WORK, IINFO )
+*
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUNIT, FMT = 9999 )'DGBBRD', IINFO, N, JTYPE,
+ $ IOLDSD
+ INFO = ABS( IINFO )
+ IF( IINFO.LT.0 ) THEN
+ RETURN
+ ELSE
+ RESULT( 1 ) = ULPINV
+ GO TO 120
+ END IF
+ END IF
+*
+* Test 1: Check the decomposition A := Q * B * P'
+* 2: Check the orthogonality of Q
+* 3: Check the orthogonality of P
+* 4: Check the computation of Q' * C
+*
+ CALL DBDT01( M, N, -1, A, LDA, Q, LDQ, BD, BE, P, LDP,
+ $ WORK, RESULT( 1 ) )
+ CALL DORT01( 'Columns', M, M, Q, LDQ, WORK, LWORK,
+ $ RESULT( 2 ) )
+ CALL DORT01( 'Rows', N, N, P, LDP, WORK, LWORK,
+ $ RESULT( 3 ) )
+ CALL DBDT02( M, NRHS, C, LDC, CC, LDC, Q, LDQ, WORK,
+ $ RESULT( 4 ) )
+*
+* End of Loop -- Check for RESULT(j) > THRESH
+*
+ NTEST = 4
+ 120 CONTINUE
+ NTESTT = NTESTT + NTEST
+*
+* Print out tests which fail.
+*
+ DO 130 JR = 1, NTEST
+ IF( RESULT( JR ).GE.THRESH ) THEN
+ IF( NERRS.EQ.0 )
+ $ CALL DLAHD2( NOUNIT, 'DBB' )
+ NERRS = NERRS + 1
+ WRITE( NOUNIT, FMT = 9998 )M, N, K, IOLDSD, JTYPE,
+ $ JR, RESULT( JR )
+ END IF
+ 130 CONTINUE
+*
+ 140 CONTINUE
+ 150 CONTINUE
+ 160 CONTINUE
+*
+* Summary
+*
+ CALL DLASUM( 'DBB', NOUNIT, NERRS, NTESTT )
+ RETURN
+*
+ 9999 FORMAT( ' DCHKBB: ', A, ' returned INFO=', I5, '.', / 9X, 'M=',
+ $ I5, ' N=', I5, ' K=', I5, ', JTYPE=', I5, ', ISEED=(',
+ $ 3( I5, ',' ), I5, ')' )
+ 9998 FORMAT( ' M =', I4, ' N=', I4, ', K=', I3, ', seed=',
+ $ 4( I4, ',' ), ' type ', I2, ', test(', I2, ')=', G10.3 )
+*
+* End of DCHKBB
+*
+ END
+ SUBROUTINE DCHKBD( NSIZES, MVAL, NVAL, NTYPES, DOTYPE, NRHS,
+ $ ISEED, THRESH, A, LDA, BD, BE, S1, S2, X, LDX,
+ $ Y, Z, Q, LDQ, PT, LDPT, U, VT, WORK, LWORK,
+ $ IWORK, NOUT, INFO )
+*
+* -- LAPACK test routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LDA, LDPT, LDQ, LDX, LWORK, NOUT, NRHS,
+ $ NSIZES, NTYPES
+ DOUBLE PRECISION THRESH
+* ..
+* .. Array Arguments ..
+ LOGICAL DOTYPE( * )
+ INTEGER ISEED( 4 ), IWORK( * ), MVAL( * ), NVAL( * )
+ DOUBLE PRECISION A( LDA, * ), BD( * ), BE( * ), PT( LDPT, * ),
+ $ Q( LDQ, * ), S1( * ), S2( * ), U( LDPT, * ),
+ $ VT( LDPT, * ), WORK( * ), X( LDX, * ),
+ $ Y( LDX, * ), Z( LDX, * )
+* ..
+*
+* Purpose
+* =======
+*
+* DCHKBD checks the singular value decomposition (SVD) routines.
+*
+* DGEBRD reduces a real general m by n matrix A to upper or lower
+* bidiagonal form B by an orthogonal transformation: Q' * A * P = B
+* (or A = Q * B * P'). The matrix B is upper bidiagonal if m >= n
+* and lower bidiagonal if m < n.
+*
+* DORGBR generates the orthogonal matrices Q and P' from DGEBRD.
+* Note that Q and P are not necessarily square.
+*
+* DBDSQR computes the singular value decomposition of the bidiagonal
+* matrix B as B = U S V'. It is called three times to compute
+* 1) B = U S1 V', where S1 is the diagonal matrix of singular
+* values and the columns of the matrices U and V are the left
+* and right singular vectors, respectively, of B.
+* 2) Same as 1), but the singular values are stored in S2 and the
+* singular vectors are not computed.
+* 3) A = (UQ) S (P'V'), the SVD of the original matrix A.
+* In addition, DBDSQR has an option to apply the left orthogonal matrix
+* U to a matrix X, useful in least squares applications.
+*
+* DBDSDC computes the singular value decomposition of the bidiagonal
+* matrix B as B = U S V' using divide-and-conquer. It is called twice
+* to compute
+* 1) B = U S1 V', where S1 is the diagonal matrix of singular
+* values and the columns of the matrices U and V are the left
+* and right singular vectors, respectively, of B.
+* 2) Same as 1), but the singular values are stored in S2 and the
+* singular vectors are not computed.
+*
+* For each pair of matrix dimensions (M,N) and each selected matrix
+* type, an M by N matrix A and an M by NRHS matrix X are generated.
+* The problem dimensions are as follows
+* A: M x N
+* Q: M x min(M,N) (but M x M if NRHS > 0)
+* P: min(M,N) x N
+* B: min(M,N) x min(M,N)
+* U, V: min(M,N) x min(M,N)
+* S1, S2 diagonal, order min(M,N)
+* X: M x NRHS
+*
+* For each generated matrix, 14 tests are performed:
+*
+* Test DGEBRD and DORGBR
+*
+* (1) | A - Q B PT | / ( |A| max(M,N) ulp ), PT = P'
+*
+* (2) | I - Q' Q | / ( M ulp )
+*
+* (3) | I - PT PT' | / ( N ulp )
+*
+* Test DBDSQR on bidiagonal matrix B
+*
+* (4) | B - U S1 VT | / ( |B| min(M,N) ulp ), VT = V'
+*
+* (5) | Y - U Z | / ( |Y| max(min(M,N),k) ulp ), where Y = Q' X
+* and Z = U' Y.
+* (6) | I - U' U | / ( min(M,N) ulp )
+*
+* (7) | I - VT VT' | / ( min(M,N) ulp )
+*
+* (8) S1 contains min(M,N) nonnegative values in decreasing order.
+* (Return 0 if true, 1/ULP if false.)
+*
+* (9) | S1 - S2 | / ( |S1| ulp ), where S2 is computed without
+* computing U and V.
+*
+* (10) 0 if the true singular values of B are within THRESH of
+* those in S1. 2*THRESH if they are not. (Tested using
+* DSVDCH)
+*
+* Test DBDSQR on matrix A
+*
+* (11) | A - (QU) S (VT PT) | / ( |A| max(M,N) ulp )
+*
+* (12) | X - (QU) Z | / ( |X| max(M,k) ulp )
+*
+* (13) | I - (QU)'(QU) | / ( M ulp )
+*
+* (14) | I - (VT PT) (PT'VT') | / ( N ulp )
+*
+* Test DBDSDC on bidiagonal matrix B
+*
+* (15) | B - U S1 VT | / ( |B| min(M,N) ulp ), VT = V'
+*
+* (16) | I - U' U | / ( min(M,N) ulp )
+*
+* (17) | I - VT VT' | / ( min(M,N) ulp )
+*
+* (18) S1 contains min(M,N) nonnegative values in decreasing order.
+* (Return 0 if true, 1/ULP if false.)
+*
+* (19) | S1 - S2 | / ( |S1| ulp ), where S2 is computed without
+* computing U and V.
+* The possible matrix types are
+*
+* (1) The zero matrix.
+* (2) The identity matrix.
+*
+* (3) A diagonal matrix with evenly spaced entries
+* 1, ..., ULP and random signs.
+* (ULP = (first number larger than 1) - 1 )
+* (4) A diagonal matrix with geometrically spaced entries
+* 1, ..., ULP and random signs.
+* (5) A diagonal matrix with "clustered" entries 1, ULP, ..., ULP
+* and random signs.
+*
+* (6) Same as (3), but multiplied by SQRT( overflow threshold )
+* (7) Same as (3), but multiplied by SQRT( underflow threshold )
+*
+* (8) A matrix of the form U D V, where U and V are orthogonal and
+* D has evenly spaced entries 1, ..., ULP with random signs
+* on the diagonal.
+*
+* (9) A matrix of the form U D V, where U and V are orthogonal and
+* D has geometrically spaced entries 1, ..., ULP with random
+* signs on the diagonal.
+*
+* (10) A matrix of the form U D V, where U and V are orthogonal and
+* D has "clustered" entries 1, ULP,..., ULP with random
+* signs on the diagonal.
+*
+* (11) Same as (8), but multiplied by SQRT( overflow threshold )
+* (12) Same as (8), but multiplied by SQRT( underflow threshold )
+*
+* (13) Rectangular matrix with random entries chosen from (-1,1).
+* (14) Same as (13), but multiplied by SQRT( overflow threshold )
+* (15) Same as (13), but multiplied by SQRT( underflow threshold )
+*
+* Special case:
+* (16) A bidiagonal matrix with random entries chosen from a
+* logarithmic distribution on [ulp^2,ulp^(-2)] (I.e., each
+* entry is e^x, where x is chosen uniformly on
+* [ 2 log(ulp), -2 log(ulp) ] .) For *this* type:
+* (a) DGEBRD is not called to reduce it to bidiagonal form.
+* (b) the bidiagonal is min(M,N) x min(M,N); if M<N, the
+* matrix will be lower bidiagonal, otherwise upper.
+* (c) only tests 5--8 and 14 are performed.
+*
+* A subset of the full set of matrix types may be selected through
+* the logical array DOTYPE.
+*
+* Arguments
+* ==========
+*
+* NSIZES (input) INTEGER
+* The number of values of M and N contained in the vectors
+* MVAL and NVAL. The matrix sizes are used in pairs (M,N).
+*
+* MVAL (input) INTEGER array, dimension (NM)
+* The values of the matrix row dimension M.
+*
+* NVAL (input) INTEGER array, dimension (NM)
+* The values of the matrix column dimension N.
+*
+* NTYPES (input) INTEGER
+* The number of elements in DOTYPE. If it is zero, DCHKBD
+* does nothing. It must be at least zero. If it is MAXTYP+1
+* and NSIZES is 1, then an additional type, MAXTYP+1 is
+* defined, which is to use whatever matrices are in A and B.
+* This is only useful if DOTYPE(1:MAXTYP) is .FALSE. and
+* DOTYPE(MAXTYP+1) is .TRUE. .
+*
+* DOTYPE (input) LOGICAL array, dimension (NTYPES)
+* If DOTYPE(j) is .TRUE., then for each size (m,n), a matrix
+* of type j will be generated. If NTYPES is smaller than the
+* maximum number of types defined (PARAMETER MAXTYP), then
+* types NTYPES+1 through MAXTYP will not be generated. If
+* NTYPES is larger than MAXTYP, DOTYPE(MAXTYP+1) through
+* DOTYPE(NTYPES) will be ignored.
+*
+* NRHS (input) INTEGER
+* The number of columns in the "right-hand side" matrices X, Y,
+* and Z, used in testing DBDSQR. If NRHS = 0, then the
+* operations on the right-hand side will not be tested.
+* NRHS must be at least 0.
+*
+* ISEED (input/output) INTEGER array, dimension (4)
+* On entry ISEED specifies the seed of the random number
+* generator. The array elements should be between 0 and 4095;
+* if not they will be reduced mod 4096. Also, ISEED(4) must
+* be odd. The values of ISEED are changed on exit, and can be
+* used in the next call to DCHKBD to continue the same random
+* number sequence.
+*
+* THRESH (input) DOUBLE PRECISION
+* The threshold value for the test ratios. A result is
+* included in the output file if RESULT >= THRESH. To have
+* every test ratio printed, use THRESH = 0. Note that the
+* expected value of the test ratios is O(1), so THRESH should
+* be a reasonably small multiple of 1, e.g., 10 or 100.
+*
+* A (workspace) DOUBLE PRECISION array, dimension (LDA,NMAX)
+* where NMAX is the maximum value of N in NVAL.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,MMAX),
+* where MMAX is the maximum value of M in MVAL.
+*
+* BD (workspace) DOUBLE PRECISION array, dimension
+* (max(min(MVAL(j),NVAL(j))))
+*
+* BE (workspace) DOUBLE PRECISION array, dimension
+* (max(min(MVAL(j),NVAL(j))))
+*
+* S1 (workspace) DOUBLE PRECISION array, dimension
+* (max(min(MVAL(j),NVAL(j))))
+*
+* S2 (workspace) DOUBLE PRECISION array, dimension
+* (max(min(MVAL(j),NVAL(j))))
+*
+* X (workspace) DOUBLE PRECISION array, dimension (LDX,NRHS)
+*
+* LDX (input) INTEGER
+* The leading dimension of the arrays X, Y, and Z.
+* LDX >= max(1,MMAX)
+*
+* Y (workspace) DOUBLE PRECISION array, dimension (LDX,NRHS)
+*
+* Z (workspace) DOUBLE PRECISION array, dimension (LDX,NRHS)
+*
+* Q (workspace) DOUBLE PRECISION array, dimension (LDQ,MMAX)
+*
+* LDQ (input) INTEGER
+* The leading dimension of the array Q. LDQ >= max(1,MMAX).
+*
+* PT (workspace) DOUBLE PRECISION array, dimension (LDPT,NMAX)
+*
+* LDPT (input) INTEGER
+* The leading dimension of the arrays PT, U, and V.
+* LDPT >= max(1, max(min(MVAL(j),NVAL(j)))).
+*
+* U (workspace) DOUBLE PRECISION array, dimension
+* (LDPT,max(min(MVAL(j),NVAL(j))))
+*
+* V (workspace) DOUBLE PRECISION array, dimension
+* (LDPT,max(min(MVAL(j),NVAL(j))))
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK)
+*
+* LWORK (input) INTEGER
+* The number of entries in WORK. This must be at least
+* 3(M+N) and M(M + max(M,N,k) + 1) + N*min(M,N) for all
+* pairs (M,N)=(MM(j),NN(j))
+*
+* IWORK (workspace) INTEGER array, dimension at least 8*min(M,N)
+*
+* NOUT (input) INTEGER
+* The FORTRAN unit number for printing out error messages
+* (e.g., if a routine returns IINFO not equal to 0.)
+*
+* INFO (output) INTEGER
+* If 0, then everything ran OK.
+* -1: NSIZES < 0
+* -2: Some MM(j) < 0
+* -3: Some NN(j) < 0
+* -4: NTYPES < 0
+* -6: NRHS < 0
+* -8: THRESH < 0
+* -11: LDA < 1 or LDA < MMAX, where MMAX is max( MM(j) ).
+* -17: LDB < 1 or LDB < MMAX.
+* -21: LDQ < 1 or LDQ < MMAX.
+* -23: LDPT< 1 or LDPT< MNMAX.
+* -27: LWORK too small.
+* If DLATMR, SLATMS, DGEBRD, DORGBR, or DBDSQR,
+* returns an error code, the
+* absolute value of it is returned.
+*
+*-----------------------------------------------------------------------
+*
+* Some Local Variables and Parameters:
+* ---- ----- --------- --- ----------
+*
+* ZERO, ONE Real 0 and 1.
+* MAXTYP The number of types defined.
+* NTEST The number of tests performed, or which can
+* be performed so far, for the current matrix.
+* MMAX Largest value in NN.
+* NMAX Largest value in NN.
+* MNMIN min(MM(j), NN(j)) (the dimension of the bidiagonal
+* matrix.)
+* MNMAX The maximum value of MNMIN for j=1,...,NSIZES.
+* NFAIL The number of tests which have exceeded THRESH
+* COND, IMODE Values to be passed to the matrix generators.
+* ANORM Norm of A; passed to matrix generators.
+*
+* OVFL, UNFL Overflow and underflow thresholds.
+* RTOVFL, RTUNFL Square roots of the previous 2 values.
+* ULP, ULPINV Finest relative precision and its inverse.
+*
+* The following four arrays decode JTYPE:
+* KTYPE(j) The general type (1-10) for type "j".
+* KMODE(j) The MODE value to be passed to the matrix
+* generator for type "j".
+* KMAGN(j) The order of magnitude ( O(1),
+* O(overflow^(1/2) ), O(underflow^(1/2) )
+*
+* ======================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE, TWO, HALF
+ PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0,
+ $ HALF = 0.5D0 )
+ INTEGER MAXTYP
+ PARAMETER ( MAXTYP = 16 )
+* ..
+* .. Local Scalars ..
+ LOGICAL BADMM, BADNN, BIDIAG
+ CHARACTER UPLO
+ CHARACTER*3 PATH
+ INTEGER I, IINFO, IMODE, ITYPE, J, JCOL, JSIZE, JTYPE,
+ $ LOG2UI, M, MINWRK, MMAX, MNMAX, MNMIN, MQ,
+ $ MTYPES, N, NFAIL, NMAX, NTEST
+ DOUBLE PRECISION AMNINV, ANORM, COND, OVFL, RTOVFL, RTUNFL,
+ $ TEMP1, TEMP2, ULP, ULPINV, UNFL
+* ..
+* .. Local Arrays ..
+ INTEGER IDUM( 1 ), IOLDSD( 4 ), KMAGN( MAXTYP ),
+ $ KMODE( MAXTYP ), KTYPE( MAXTYP )
+ DOUBLE PRECISION DUM( 1 ), DUMMA( 1 ), RESULT( 19 )
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DLAMCH, DLARND
+ EXTERNAL DLAMCH, DLARND
+* ..
+* .. External Subroutines ..
+ EXTERNAL ALASUM, DBDSDC, DBDSQR, DBDT01, DBDT02, DBDT03,
+ $ DCOPY, DGEBRD, DGEMM, DLABAD, DLACPY, DLAHD2,
+ $ DLASET, DLATMR, DLATMS, DORGBR, DORT01, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, EXP, INT, LOG, MAX, MIN, SQRT
+* ..
+* .. Scalars in Common ..
+ LOGICAL LERR, OK
+ CHARACTER*6 SRNAMT
+ INTEGER INFOT, NUNIT
+* ..
+* .. Common blocks ..
+ COMMON / INFOC / INFOT, NUNIT, OK, LERR
+ COMMON / SRNAMC / SRNAMT
+* ..
+* .. Data statements ..
+ DATA KTYPE / 1, 2, 5*4, 5*6, 3*9, 10 /
+ DATA KMAGN / 2*1, 3*1, 2, 3, 3*1, 2, 3, 1, 2, 3, 0 /
+ DATA KMODE / 2*0, 4, 3, 1, 4, 4, 4, 3, 1, 4, 4, 0,
+ $ 0, 0, 0 /
+* ..
+* .. Executable Statements ..
+*
+* Check for errors
+*
+ INFO = 0
+*
+ BADMM = .FALSE.
+ BADNN = .FALSE.
+ MMAX = 1
+ NMAX = 1
+ MNMAX = 1
+ MINWRK = 1
+ DO 10 J = 1, NSIZES
+ MMAX = MAX( MMAX, MVAL( J ) )
+ IF( MVAL( J ).LT.0 )
+ $ BADMM = .TRUE.
+ NMAX = MAX( NMAX, NVAL( J ) )
+ IF( NVAL( J ).LT.0 )
+ $ BADNN = .TRUE.
+ MNMAX = MAX( MNMAX, MIN( MVAL( J ), NVAL( J ) ) )
+ MINWRK = MAX( MINWRK, 3*( MVAL( J )+NVAL( J ) ),
+ $ MVAL( J )*( MVAL( J )+MAX( MVAL( J ), NVAL( J ),
+ $ NRHS )+1 )+NVAL( J )*MIN( NVAL( J ), MVAL( J ) ) )
+ 10 CONTINUE
+*
+* Check for errors
+*
+ IF( NSIZES.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( BADMM ) THEN
+ INFO = -2
+ ELSE IF( BADNN ) THEN
+ INFO = -3
+ ELSE IF( NTYPES.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( NRHS.LT.0 ) THEN
+ INFO = -6
+ ELSE IF( LDA.LT.MMAX ) THEN
+ INFO = -11
+ ELSE IF( LDX.LT.MMAX ) THEN
+ INFO = -17
+ ELSE IF( LDQ.LT.MMAX ) THEN
+ INFO = -21
+ ELSE IF( LDPT.LT.MNMAX ) THEN
+ INFO = -23
+ ELSE IF( MINWRK.GT.LWORK ) THEN
+ INFO = -27
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DCHKBD', -INFO )
+ RETURN
+ END IF
+*
+* Initialize constants
+*
+ PATH( 1: 1 ) = 'Double precision'
+ PATH( 2: 3 ) = 'BD'
+ NFAIL = 0
+ NTEST = 0
+ UNFL = DLAMCH( 'Safe minimum' )
+ OVFL = DLAMCH( 'Overflow' )
+ CALL DLABAD( UNFL, OVFL )
+ ULP = DLAMCH( 'Precision' )
+ ULPINV = ONE / ULP
+ LOG2UI = INT( LOG( ULPINV ) / LOG( TWO ) )
+ RTUNFL = SQRT( UNFL )
+ RTOVFL = SQRT( OVFL )
+ INFOT = 0
+*
+* Loop over sizes, types
+*
+ DO 200 JSIZE = 1, NSIZES
+ M = MVAL( JSIZE )
+ N = NVAL( JSIZE )
+ MNMIN = MIN( M, N )
+ AMNINV = ONE / MAX( M, N, 1 )
+*
+ IF( NSIZES.NE.1 ) THEN
+ MTYPES = MIN( MAXTYP, NTYPES )
+ ELSE
+ MTYPES = MIN( MAXTYP+1, NTYPES )
+ END IF
+*
+ DO 190 JTYPE = 1, MTYPES
+ IF( .NOT.DOTYPE( JTYPE ) )
+ $ GO TO 190
+*
+ DO 20 J = 1, 4
+ IOLDSD( J ) = ISEED( J )
+ 20 CONTINUE
+*
+ DO 30 J = 1, 14
+ RESULT( J ) = -ONE
+ 30 CONTINUE
+*
+ UPLO = ' '
+*
+* Compute "A"
+*
+* Control parameters:
+*
+* KMAGN KMODE KTYPE
+* =1 O(1) clustered 1 zero
+* =2 large clustered 2 identity
+* =3 small exponential (none)
+* =4 arithmetic diagonal, (w/ eigenvalues)
+* =5 random symmetric, w/ eigenvalues
+* =6 nonsymmetric, w/ singular values
+* =7 random diagonal
+* =8 random symmetric
+* =9 random nonsymmetric
+* =10 random bidiagonal (log. distrib.)
+*
+ IF( MTYPES.GT.MAXTYP )
+ $ GO TO 100
+*
+ ITYPE = KTYPE( JTYPE )
+ IMODE = KMODE( JTYPE )
+*
+* Compute norm
+*
+ GO TO ( 40, 50, 60 )KMAGN( JTYPE )
+*
+ 40 CONTINUE
+ ANORM = ONE
+ GO TO 70
+*
+ 50 CONTINUE
+ ANORM = ( RTOVFL*ULP )*AMNINV
+ GO TO 70
+*
+ 60 CONTINUE
+ ANORM = RTUNFL*MAX( M, N )*ULPINV
+ GO TO 70
+*
+ 70 CONTINUE
+*
+ CALL DLASET( 'Full', LDA, N, ZERO, ZERO, A, LDA )
+ IINFO = 0
+ COND = ULPINV
+*
+ BIDIAG = .FALSE.
+ IF( ITYPE.EQ.1 ) THEN
+*
+* Zero matrix
+*
+ IINFO = 0
+*
+ ELSE IF( ITYPE.EQ.2 ) THEN
+*
+* Identity
+*
+ DO 80 JCOL = 1, MNMIN
+ A( JCOL, JCOL ) = ANORM
+ 80 CONTINUE
+*
+ ELSE IF( ITYPE.EQ.4 ) THEN
+*
+* Diagonal Matrix, [Eigen]values Specified
+*
+ CALL DLATMS( MNMIN, MNMIN, 'S', ISEED, 'N', WORK, IMODE,
+ $ COND, ANORM, 0, 0, 'N', A, LDA,
+ $ WORK( MNMIN+1 ), IINFO )
+*
+ ELSE IF( ITYPE.EQ.5 ) THEN
+*
+* Symmetric, eigenvalues specified
+*
+ CALL DLATMS( MNMIN, MNMIN, 'S', ISEED, 'S', WORK, IMODE,
+ $ COND, ANORM, M, N, 'N', A, LDA,
+ $ WORK( MNMIN+1 ), IINFO )
+*
+ ELSE IF( ITYPE.EQ.6 ) THEN
+*
+* Nonsymmetric, singular values specified
+*
+ CALL DLATMS( M, N, 'S', ISEED, 'N', WORK, IMODE, COND,
+ $ ANORM, M, N, 'N', A, LDA, WORK( MNMIN+1 ),
+ $ IINFO )
+*
+ ELSE IF( ITYPE.EQ.7 ) THEN
+*
+* Diagonal, random entries
+*
+ CALL DLATMR( MNMIN, MNMIN, 'S', ISEED, 'N', WORK, 6, ONE,
+ $ ONE, 'T', 'N', WORK( MNMIN+1 ), 1, ONE,
+ $ WORK( 2*MNMIN+1 ), 1, ONE, 'N', IWORK, 0, 0,
+ $ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO )
+*
+ ELSE IF( ITYPE.EQ.8 ) THEN
+*
+* Symmetric, random entries
+*
+ CALL DLATMR( MNMIN, MNMIN, 'S', ISEED, 'S', WORK, 6, ONE,
+ $ ONE, 'T', 'N', WORK( MNMIN+1 ), 1, ONE,
+ $ WORK( M+MNMIN+1 ), 1, ONE, 'N', IWORK, M, N,
+ $ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO )
+*
+ ELSE IF( ITYPE.EQ.9 ) THEN
+*
+* Nonsymmetric, random entries
+*
+ CALL DLATMR( M, N, 'S', ISEED, 'N', WORK, 6, ONE, ONE,
+ $ 'T', 'N', WORK( MNMIN+1 ), 1, ONE,
+ $ WORK( M+MNMIN+1 ), 1, ONE, 'N', IWORK, M, N,
+ $ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO )
+*
+ ELSE IF( ITYPE.EQ.10 ) THEN
+*
+* Bidiagonal, random entries
+*
+ TEMP1 = -TWO*LOG( ULP )
+ DO 90 J = 1, MNMIN
+ BD( J ) = EXP( TEMP1*DLARND( 2, ISEED ) )
+ IF( J.LT.MNMIN )
+ $ BE( J ) = EXP( TEMP1*DLARND( 2, ISEED ) )
+ 90 CONTINUE
+*
+ IINFO = 0
+ BIDIAG = .TRUE.
+ IF( M.GE.N ) THEN
+ UPLO = 'U'
+ ELSE
+ UPLO = 'L'
+ END IF
+ ELSE
+ IINFO = 1
+ END IF
+*
+ IF( IINFO.EQ.0 ) THEN
+*
+* Generate Right-Hand Side
+*
+ IF( BIDIAG ) THEN
+ CALL DLATMR( MNMIN, NRHS, 'S', ISEED, 'N', WORK, 6,
+ $ ONE, ONE, 'T', 'N', WORK( MNMIN+1 ), 1,
+ $ ONE, WORK( 2*MNMIN+1 ), 1, ONE, 'N',
+ $ IWORK, MNMIN, NRHS, ZERO, ONE, 'NO', Y,
+ $ LDX, IWORK, IINFO )
+ ELSE
+ CALL DLATMR( M, NRHS, 'S', ISEED, 'N', WORK, 6, ONE,
+ $ ONE, 'T', 'N', WORK( M+1 ), 1, ONE,
+ $ WORK( 2*M+1 ), 1, ONE, 'N', IWORK, M,
+ $ NRHS, ZERO, ONE, 'NO', X, LDX, IWORK,
+ $ IINFO )
+ END IF
+ END IF
+*
+* Error Exit
+*
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUT, FMT = 9998 )'Generator', IINFO, M, N,
+ $ JTYPE, IOLDSD
+ INFO = ABS( IINFO )
+ RETURN
+ END IF
+*
+ 100 CONTINUE
+*
+* Call DGEBRD and DORGBR to compute B, Q, and P, do tests.
+*
+ IF( .NOT.BIDIAG ) THEN
+*
+* Compute transformations to reduce A to bidiagonal form:
+* B := Q' * A * P.
+*
+ CALL DLACPY( ' ', M, N, A, LDA, Q, LDQ )
+ CALL DGEBRD( M, N, Q, LDQ, BD, BE, WORK, WORK( MNMIN+1 ),
+ $ WORK( 2*MNMIN+1 ), LWORK-2*MNMIN, IINFO )
+*
+* Check error code from DGEBRD.
+*
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUT, FMT = 9998 )'DGEBRD', IINFO, M, N,
+ $ JTYPE, IOLDSD
+ INFO = ABS( IINFO )
+ RETURN
+ END IF
+*
+ CALL DLACPY( ' ', M, N, Q, LDQ, PT, LDPT )
+ IF( M.GE.N ) THEN
+ UPLO = 'U'
+ ELSE
+ UPLO = 'L'
+ END IF
+*
+* Generate Q
+*
+ MQ = M
+ IF( NRHS.LE.0 )
+ $ MQ = MNMIN
+ CALL DORGBR( 'Q', M, MQ, N, Q, LDQ, WORK,
+ $ WORK( 2*MNMIN+1 ), LWORK-2*MNMIN, IINFO )
+*
+* Check error code from DORGBR.
+*
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUT, FMT = 9998 )'DORGBR(Q)', IINFO, M, N,
+ $ JTYPE, IOLDSD
+ INFO = ABS( IINFO )
+ RETURN
+ END IF
+*
+* Generate P'
+*
+ CALL DORGBR( 'P', MNMIN, N, M, PT, LDPT, WORK( MNMIN+1 ),
+ $ WORK( 2*MNMIN+1 ), LWORK-2*MNMIN, IINFO )
+*
+* Check error code from DORGBR.
+*
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUT, FMT = 9998 )'DORGBR(P)', IINFO, M, N,
+ $ JTYPE, IOLDSD
+ INFO = ABS( IINFO )
+ RETURN
+ END IF
+*
+* Apply Q' to an M by NRHS matrix X: Y := Q' * X.
+*
+ CALL DGEMM( 'Transpose', 'No transpose', M, NRHS, M, ONE,
+ $ Q, LDQ, X, LDX, ZERO, Y, LDX )
+*
+* Test 1: Check the decomposition A := Q * B * PT
+* 2: Check the orthogonality of Q
+* 3: Check the orthogonality of PT
+*
+ CALL DBDT01( M, N, 1, A, LDA, Q, LDQ, BD, BE, PT, LDPT,
+ $ WORK, RESULT( 1 ) )
+ CALL DORT01( 'Columns', M, MQ, Q, LDQ, WORK, LWORK,
+ $ RESULT( 2 ) )
+ CALL DORT01( 'Rows', MNMIN, N, PT, LDPT, WORK, LWORK,
+ $ RESULT( 3 ) )
+ END IF
+*
+* Use DBDSQR to form the SVD of the bidiagonal matrix B:
+* B := U * S1 * VT, and compute Z = U' * Y.
+*
+ CALL DCOPY( MNMIN, BD, 1, S1, 1 )
+ IF( MNMIN.GT.0 )
+ $ CALL DCOPY( MNMIN-1, BE, 1, WORK, 1 )
+ CALL DLACPY( ' ', M, NRHS, Y, LDX, Z, LDX )
+ CALL DLASET( 'Full', MNMIN, MNMIN, ZERO, ONE, U, LDPT )
+ CALL DLASET( 'Full', MNMIN, MNMIN, ZERO, ONE, VT, LDPT )
+*
+ CALL DBDSQR( UPLO, MNMIN, MNMIN, MNMIN, NRHS, S1, WORK, VT,
+ $ LDPT, U, LDPT, Z, LDX, WORK( MNMIN+1 ), IINFO )
+*
+* Check error code from DBDSQR.
+*
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUT, FMT = 9998 )'DBDSQR(vects)', IINFO, M, N,
+ $ JTYPE, IOLDSD
+ INFO = ABS( IINFO )
+ IF( IINFO.LT.0 ) THEN
+ RETURN
+ ELSE
+ RESULT( 4 ) = ULPINV
+ GO TO 170
+ END IF
+ END IF
+*
+* Use DBDSQR to compute only the singular values of the
+* bidiagonal matrix B; U, VT, and Z should not be modified.
+*
+ CALL DCOPY( MNMIN, BD, 1, S2, 1 )
+ IF( MNMIN.GT.0 )
+ $ CALL DCOPY( MNMIN-1, BE, 1, WORK, 1 )
+*
+ CALL DBDSQR( UPLO, MNMIN, 0, 0, 0, S2, WORK, VT, LDPT, U,
+ $ LDPT, Z, LDX, WORK( MNMIN+1 ), IINFO )
+*
+* Check error code from DBDSQR.
+*
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUT, FMT = 9998 )'DBDSQR(values)', IINFO, M, N,
+ $ JTYPE, IOLDSD
+ INFO = ABS( IINFO )
+ IF( IINFO.LT.0 ) THEN
+ RETURN
+ ELSE
+ RESULT( 9 ) = ULPINV
+ GO TO 170
+ END IF
+ END IF
+*
+* Test 4: Check the decomposition B := U * S1 * VT
+* 5: Check the computation Z := U' * Y
+* 6: Check the orthogonality of U
+* 7: Check the orthogonality of VT
+*
+ CALL DBDT03( UPLO, MNMIN, 1, BD, BE, U, LDPT, S1, VT, LDPT,
+ $ WORK, RESULT( 4 ) )
+ CALL DBDT02( MNMIN, NRHS, Y, LDX, Z, LDX, U, LDPT, WORK,
+ $ RESULT( 5 ) )
+ CALL DORT01( 'Columns', MNMIN, MNMIN, U, LDPT, WORK, LWORK,
+ $ RESULT( 6 ) )
+ CALL DORT01( 'Rows', MNMIN, MNMIN, VT, LDPT, WORK, LWORK,
+ $ RESULT( 7 ) )
+*
+* Test 8: Check that the singular values are sorted in
+* non-increasing order and are non-negative
+*
+ RESULT( 8 ) = ZERO
+ DO 110 I = 1, MNMIN - 1
+ IF( S1( I ).LT.S1( I+1 ) )
+ $ RESULT( 8 ) = ULPINV
+ IF( S1( I ).LT.ZERO )
+ $ RESULT( 8 ) = ULPINV
+ 110 CONTINUE
+ IF( MNMIN.GE.1 ) THEN
+ IF( S1( MNMIN ).LT.ZERO )
+ $ RESULT( 8 ) = ULPINV
+ END IF
+*
+* Test 9: Compare DBDSQR with and without singular vectors
+*
+ TEMP2 = ZERO
+*
+ DO 120 J = 1, MNMIN
+ TEMP1 = ABS( S1( J )-S2( J ) ) /
+ $ MAX( SQRT( UNFL )*MAX( S1( 1 ), ONE ),
+ $ ULP*MAX( ABS( S1( J ) ), ABS( S2( J ) ) ) )
+ TEMP2 = MAX( TEMP1, TEMP2 )
+ 120 CONTINUE
+*
+ RESULT( 9 ) = TEMP2
+*
+* Test 10: Sturm sequence test of singular values
+* Go up by factors of two until it succeeds
+*
+ TEMP1 = THRESH*( HALF-ULP )
+*
+ DO 130 J = 0, LOG2UI
+* CALL DSVDCH( MNMIN, BD, BE, S1, TEMP1, IINFO )
+ IF( IINFO.EQ.0 )
+ $ GO TO 140
+ TEMP1 = TEMP1*TWO
+ 130 CONTINUE
+*
+ 140 CONTINUE
+ RESULT( 10 ) = TEMP1
+*
+* Use DBDSQR to form the decomposition A := (QU) S (VT PT)
+* from the bidiagonal form A := Q B PT.
+*
+ IF( .NOT.BIDIAG ) THEN
+ CALL DCOPY( MNMIN, BD, 1, S2, 1 )
+ IF( MNMIN.GT.0 )
+ $ CALL DCOPY( MNMIN-1, BE, 1, WORK, 1 )
+*
+ CALL DBDSQR( UPLO, MNMIN, N, M, NRHS, S2, WORK, PT, LDPT,
+ $ Q, LDQ, Y, LDX, WORK( MNMIN+1 ), IINFO )
+*
+* Test 11: Check the decomposition A := Q*U * S2 * VT*PT
+* 12: Check the computation Z := U' * Q' * X
+* 13: Check the orthogonality of Q*U
+* 14: Check the orthogonality of VT*PT
+*
+ CALL DBDT01( M, N, 0, A, LDA, Q, LDQ, S2, DUMMA, PT,
+ $ LDPT, WORK, RESULT( 11 ) )
+ CALL DBDT02( M, NRHS, X, LDX, Y, LDX, Q, LDQ, WORK,
+ $ RESULT( 12 ) )
+ CALL DORT01( 'Columns', M, MQ, Q, LDQ, WORK, LWORK,
+ $ RESULT( 13 ) )
+ CALL DORT01( 'Rows', MNMIN, N, PT, LDPT, WORK, LWORK,
+ $ RESULT( 14 ) )
+ END IF
+*
+* Use DBDSDC to form the SVD of the bidiagonal matrix B:
+* B := U * S1 * VT
+*
+ CALL DCOPY( MNMIN, BD, 1, S1, 1 )
+ IF( MNMIN.GT.0 )
+ $ CALL DCOPY( MNMIN-1, BE, 1, WORK, 1 )
+ CALL DLASET( 'Full', MNMIN, MNMIN, ZERO, ONE, U, LDPT )
+ CALL DLASET( 'Full', MNMIN, MNMIN, ZERO, ONE, VT, LDPT )
+*
+ CALL DBDSDC( UPLO, 'I', MNMIN, S1, WORK, U, LDPT, VT, LDPT,
+ $ DUM, IDUM, WORK( MNMIN+1 ), IWORK, IINFO )
+*
+* Check error code from DBDSDC.
+*
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUT, FMT = 9998 )'DBDSDC(vects)', IINFO, M, N,
+ $ JTYPE, IOLDSD
+ INFO = ABS( IINFO )
+ IF( IINFO.LT.0 ) THEN
+ RETURN
+ ELSE
+ RESULT( 15 ) = ULPINV
+ GO TO 170
+ END IF
+ END IF
+*
+* Use DBDSDC to compute only the singular values of the
+* bidiagonal matrix B; U and VT should not be modified.
+*
+ CALL DCOPY( MNMIN, BD, 1, S2, 1 )
+ IF( MNMIN.GT.0 )
+ $ CALL DCOPY( MNMIN-1, BE, 1, WORK, 1 )
+*
+ CALL DBDSDC( UPLO, 'N', MNMIN, S2, WORK, DUM, 1, DUM, 1,
+ $ DUM, IDUM, WORK( MNMIN+1 ), IWORK, IINFO )
+*
+* Check error code from DBDSDC.
+*
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUT, FMT = 9998 )'DBDSDC(values)', IINFO, M, N,
+ $ JTYPE, IOLDSD
+ INFO = ABS( IINFO )
+ IF( IINFO.LT.0 ) THEN
+ RETURN
+ ELSE
+ RESULT( 18 ) = ULPINV
+ GO TO 170
+ END IF
+ END IF
+*
+* Test 15: Check the decomposition B := U * S1 * VT
+* 16: Check the orthogonality of U
+* 17: Check the orthogonality of VT
+*
+ CALL DBDT03( UPLO, MNMIN, 1, BD, BE, U, LDPT, S1, VT, LDPT,
+ $ WORK, RESULT( 15 ) )
+ CALL DORT01( 'Columns', MNMIN, MNMIN, U, LDPT, WORK, LWORK,
+ $ RESULT( 16 ) )
+ CALL DORT01( 'Rows', MNMIN, MNMIN, VT, LDPT, WORK, LWORK,
+ $ RESULT( 17 ) )
+*
+* Test 18: Check that the singular values are sorted in
+* non-increasing order and are non-negative
+*
+ RESULT( 18 ) = ZERO
+ DO 150 I = 1, MNMIN - 1
+ IF( S1( I ).LT.S1( I+1 ) )
+ $ RESULT( 18 ) = ULPINV
+ IF( S1( I ).LT.ZERO )
+ $ RESULT( 18 ) = ULPINV
+ 150 CONTINUE
+ IF( MNMIN.GE.1 ) THEN
+ IF( S1( MNMIN ).LT.ZERO )
+ $ RESULT( 18 ) = ULPINV
+ END IF
+*
+* Test 19: Compare DBDSQR with and without singular vectors
+*
+ TEMP2 = ZERO
+*
+ DO 160 J = 1, MNMIN
+ TEMP1 = ABS( S1( J )-S2( J ) ) /
+ $ MAX( SQRT( UNFL )*MAX( S1( 1 ), ONE ),
+ $ ULP*MAX( ABS( S1( 1 ) ), ABS( S2( 1 ) ) ) )
+ TEMP2 = MAX( TEMP1, TEMP2 )
+ 160 CONTINUE
+*
+ RESULT( 19 ) = TEMP2
+*
+* End of Loop -- Check for RESULT(j) > THRESH
+*
+ 170 CONTINUE
+ DO 180 J = 1, 19
+ IF( RESULT( J ).GE.THRESH ) THEN
+ IF( NFAIL.EQ.0 )
+ $ CALL DLAHD2( NOUT, PATH )
+ WRITE( NOUT, FMT = 9999 )M, N, JTYPE, IOLDSD, J,
+ $ RESULT( J )
+ NFAIL = NFAIL + 1
+ END IF
+ 180 CONTINUE
+ IF( .NOT.BIDIAG ) THEN
+ NTEST = NTEST + 19
+ ELSE
+ NTEST = NTEST + 5
+ END IF
+*
+ 190 CONTINUE
+ 200 CONTINUE
+*
+* Summary
+*
+ CALL ALASUM( PATH, NOUT, NFAIL, NTEST, 0 )
+*
+ RETURN
+*
+* End of DCHKBD
+*
+ 9999 FORMAT( ' M=', I5, ', N=', I5, ', type ', I2, ', seed=',
+ $ 4( I4, ',' ), ' test(', I2, ')=', G11.4 )
+ 9998 FORMAT( ' DCHKBD: ', A, ' returned INFO=', I6, '.', / 9X, 'M=',
+ $ I6, ', N=', I6, ', JTYPE=', I6, ', ISEED=(', 3( I5, ',' ),
+ $ I5, ')' )
+*
+ END
+ SUBROUTINE DCHKBK( NIN, NOUT )
+*
+* -- LAPACK test routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER NIN, NOUT
+* ..
+*
+* Purpose
+* =======
+*
+* DCHKBK tests DGEBAK, a routine for backward transformation of
+* the computed right or left eigenvectors if the orginal matrix
+* was preprocessed by balance subroutine DGEBAL.
+*
+* Arguments
+* =========
+*
+* NIN (input) INTEGER
+* The logical unit number for input. NIN > 0.
+*
+* NOUT (input) INTEGER
+* The logical unit number for output. NOUT > 0.
+*
+* ======================================================================
+*
+* .. Parameters ..
+ INTEGER LDE
+ PARAMETER ( LDE = 20 )
+ DOUBLE PRECISION ZERO
+ PARAMETER ( ZERO = 0.0D0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, IHI, ILO, INFO, J, KNT, N, NINFO
+ DOUBLE PRECISION EPS, RMAX, SAFMIN, VMAX, X
+* ..
+* .. Local Arrays ..
+ INTEGER LMAX( 2 )
+ DOUBLE PRECISION E( LDE, LDE ), EIN( LDE, LDE ), SCALE( LDE )
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DLAMCH
+ EXTERNAL DLAMCH
+* ..
+* .. External Subroutines ..
+ EXTERNAL DGEBAK
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX
+* ..
+* .. Executable Statements ..
+*
+ LMAX( 1 ) = 0
+ LMAX( 2 ) = 0
+ NINFO = 0
+ KNT = 0
+ RMAX = ZERO
+ EPS = DLAMCH( 'E' )
+ SAFMIN = DLAMCH( 'S' )
+*
+ 10 CONTINUE
+*
+ READ( NIN, FMT = * )N, ILO, IHI
+ IF( N.EQ.0 )
+ $ GO TO 60
+*
+ READ( NIN, FMT = * )( SCALE( I ), I = 1, N )
+ DO 20 I = 1, N
+ READ( NIN, FMT = * )( E( I, J ), J = 1, N )
+ 20 CONTINUE
+*
+ DO 30 I = 1, N
+ READ( NIN, FMT = * )( EIN( I, J ), J = 1, N )
+ 30 CONTINUE
+*
+ KNT = KNT + 1
+ CALL DGEBAK( 'B', 'R', N, ILO, IHI, SCALE, N, E, LDE, INFO )
+*
+ IF( INFO.NE.0 ) THEN
+ NINFO = NINFO + 1
+ LMAX( 1 ) = KNT
+ END IF
+*
+ VMAX = ZERO
+ DO 50 I = 1, N
+ DO 40 J = 1, N
+ X = ABS( E( I, J )-EIN( I, J ) ) / EPS
+ IF( ABS( E( I, J ) ).GT.SAFMIN )
+ $ X = X / ABS( E( I, J ) )
+ VMAX = MAX( VMAX, X )
+ 40 CONTINUE
+ 50 CONTINUE
+*
+ IF( VMAX.GT.RMAX ) THEN
+ LMAX( 2 ) = KNT
+ RMAX = VMAX
+ END IF
+*
+ GO TO 10
+*
+ 60 CONTINUE
+*
+ WRITE( NOUT, FMT = 9999 )
+ 9999 FORMAT( 1X, '.. test output of DGEBAK .. ' )
+*
+ WRITE( NOUT, FMT = 9998 )RMAX
+ 9998 FORMAT( 1X, 'value of largest test error = ', D12.3 )
+ WRITE( NOUT, FMT = 9997 )LMAX( 1 )
+ 9997 FORMAT( 1X, 'example number where info is not zero = ', I4 )
+ WRITE( NOUT, FMT = 9996 )LMAX( 2 )
+ 9996 FORMAT( 1X, 'example number having largest error = ', I4 )
+ WRITE( NOUT, FMT = 9995 )NINFO
+ 9995 FORMAT( 1X, 'number of examples where info is not 0 = ', I4 )
+ WRITE( NOUT, FMT = 9994 )KNT
+ 9994 FORMAT( 1X, 'total number of examples tested = ', I4 )
+*
+ RETURN
+*
+* End of DCHKBK
+*
+ END
+ SUBROUTINE DCHKBL( NIN, NOUT )
+*
+* -- LAPACK test routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER NIN, NOUT
+* ..
+*
+* Purpose
+* =======
+*
+* DCHKBL tests DGEBAL, a routine for balancing a general real
+* matrix and isolating some of its eigenvalues.
+*
+* Arguments
+* =========
+*
+* NIN (input) INTEGER
+* The logical unit number for input. NIN > 0.
+*
+* NOUT (input) INTEGER
+* The logical unit number for output. NOUT > 0.
+*
+* ======================================================================
+*
+* .. Parameters ..
+ INTEGER LDA
+ PARAMETER ( LDA = 20 )
+ DOUBLE PRECISION ZERO
+ PARAMETER ( ZERO = 0.0D+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, IHI, IHIIN, ILO, ILOIN, INFO, J, KNT, N,
+ $ NINFO
+ DOUBLE PRECISION ANORM, MEPS, RMAX, SFMIN, TEMP, VMAX
+* ..
+* .. Local Arrays ..
+ INTEGER LMAX( 3 )
+ DOUBLE PRECISION A( LDA, LDA ), AIN( LDA, LDA ), DUMMY( 1 ),
+ $ SCALE( LDA ), SCALIN( LDA )
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DLAMCH, DLANGE
+ EXTERNAL DLAMCH, DLANGE
+* ..
+* .. External Subroutines ..
+ EXTERNAL DGEBAL
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX
+* ..
+* .. Executable Statements ..
+*
+ LMAX( 1 ) = 0
+ LMAX( 2 ) = 0
+ LMAX( 3 ) = 0
+ NINFO = 0
+ KNT = 0
+ RMAX = ZERO
+ VMAX = ZERO
+ SFMIN = DLAMCH( 'S' )
+ MEPS = DLAMCH( 'E' )
+*
+ 10 CONTINUE
+*
+ READ( NIN, FMT = * )N
+ IF( N.EQ.0 )
+ $ GO TO 70
+ DO 20 I = 1, N
+ READ( NIN, FMT = * )( A( I, J ), J = 1, N )
+ 20 CONTINUE
+*
+ READ( NIN, FMT = * )ILOIN, IHIIN
+ DO 30 I = 1, N
+ READ( NIN, FMT = * )( AIN( I, J ), J = 1, N )
+ 30 CONTINUE
+ READ( NIN, FMT = * )( SCALIN( I ), I = 1, N )
+*
+ ANORM = DLANGE( 'M', N, N, A, LDA, DUMMY )
+ KNT = KNT + 1
+*
+ CALL DGEBAL( 'B', N, A, LDA, ILO, IHI, SCALE, INFO )
+*
+ IF( INFO.NE.0 ) THEN
+ NINFO = NINFO + 1
+ LMAX( 1 ) = KNT
+ END IF
+*
+ IF( ILO.NE.ILOIN .OR. IHI.NE.IHIIN ) THEN
+ NINFO = NINFO + 1
+ LMAX( 2 ) = KNT
+ END IF
+*
+ DO 50 I = 1, N
+ DO 40 J = 1, N
+ TEMP = MAX( A( I, J ), AIN( I, J ) )
+ TEMP = MAX( TEMP, SFMIN )
+ VMAX = MAX( VMAX, ABS( A( I, J )-AIN( I, J ) ) / TEMP )
+ 40 CONTINUE
+ 50 CONTINUE
+*
+ DO 60 I = 1, N
+ TEMP = MAX( SCALE( I ), SCALIN( I ) )
+ TEMP = MAX( TEMP, SFMIN )
+ VMAX = MAX( VMAX, ABS( SCALE( I )-SCALIN( I ) ) / TEMP )
+ 60 CONTINUE
+*
+*
+ IF( VMAX.GT.RMAX ) THEN
+ LMAX( 3 ) = KNT
+ RMAX = VMAX
+ END IF
+*
+ GO TO 10
+*
+ 70 CONTINUE
+*
+ WRITE( NOUT, FMT = 9999 )
+ 9999 FORMAT( 1X, '.. test output of DGEBAL .. ' )
+*
+ WRITE( NOUT, FMT = 9998 )RMAX
+ 9998 FORMAT( 1X, 'value of largest test error = ', D12.3 )
+ WRITE( NOUT, FMT = 9997 )LMAX( 1 )
+ 9997 FORMAT( 1X, 'example number where info is not zero = ', I4 )
+ WRITE( NOUT, FMT = 9996 )LMAX( 2 )
+ 9996 FORMAT( 1X, 'example number where ILO or IHI wrong = ', I4 )
+ WRITE( NOUT, FMT = 9995 )LMAX( 3 )
+ 9995 FORMAT( 1X, 'example number having largest error = ', I4 )
+ WRITE( NOUT, FMT = 9994 )NINFO
+ 9994 FORMAT( 1X, 'number of examples where info is not 0 = ', I4 )
+ WRITE( NOUT, FMT = 9993 )KNT
+ 9993 FORMAT( 1X, 'total number of examples tested = ', I4 )
+*
+ RETURN
+*
+* End of DCHKBL
+*
+ END
+ SUBROUTINE DCHKEC( THRESH, TSTERR, NIN, NOUT )
+*
+* -- LAPACK test routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ LOGICAL TSTERR
+ INTEGER NIN, NOUT
+ DOUBLE PRECISION THRESH
+* ..
+*
+* Purpose
+* =======
+*
+* DCHKEC tests eigen- condition estimation routines
+* DLALN2, DLASY2, DLANV2, DLAQTR, DLAEXC,
+* DTRSYL, DTREXC, DTRSNA, DTRSEN
+*
+* In all cases, the routine runs through a fixed set of numerical
+* examples, subjects them to various tests, and compares the test
+* results to a threshold THRESH. In addition, DTREXC, DTRSNA and DTRSEN
+* are tested by reading in precomputed examples from a file (on input
+* unit NIN). Output is written to output unit NOUT.
+*
+* Arguments
+* =========
+*
+* THRESH (input) DOUBLE PRECISION
+* Threshold for residual tests. A computed test ratio passes
+* the threshold if it is less than THRESH.
+*
+* TSTERR (input) LOGICAL
+* Flag that indicates whether error exits are to be tested.
+*
+* NIN (input) INTEGER
+* The logical unit number for input.
+*
+* NOUT (input) INTEGER
+* The logical unit number for output.
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ LOGICAL OK
+ CHARACTER*3 PATH
+ INTEGER KLAEXC, KLALN2, KLANV2, KLAQTR, KLASY2, KTREXC,
+ $ KTRSEN, KTRSNA, KTRSYL, LLAEXC, LLALN2, LLANV2,
+ $ LLAQTR, LLASY2, LTREXC, LTRSYL, NLANV2, NLAQTR,
+ $ NLASY2, NTESTS, NTRSYL
+ DOUBLE PRECISION EPS, RLAEXC, RLALN2, RLANV2, RLAQTR, RLASY2,
+ $ RTREXC, RTRSYL, SFMIN
+* ..
+* .. Local Arrays ..
+ INTEGER LTRSEN( 3 ), LTRSNA( 3 ), NLAEXC( 2 ),
+ $ NLALN2( 2 ), NTREXC( 3 ), NTRSEN( 3 ),
+ $ NTRSNA( 3 )
+ DOUBLE PRECISION RTRSEN( 3 ), RTRSNA( 3 )
+* ..
+* .. External Subroutines ..
+ EXTERNAL DERREC, DGET31, DGET32, DGET33, DGET34, DGET35,
+ $ DGET36, DGET37, DGET38, DGET39
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DLAMCH
+ EXTERNAL DLAMCH
+* ..
+* .. Executable Statements ..
+*
+ PATH( 1: 1 ) = 'Double precision'
+ PATH( 2: 3 ) = 'EC'
+ EPS = DLAMCH( 'P' )
+ SFMIN = DLAMCH( 'S' )
+*
+* Print header information
+*
+ WRITE( NOUT, FMT = 9989 )
+ WRITE( NOUT, FMT = 9988 )EPS, SFMIN
+ WRITE( NOUT, FMT = 9987 )THRESH
+*
+* Test error exits if TSTERR is .TRUE.
+*
+ IF( TSTERR )
+ $ CALL DERREC( PATH, NOUT )
+*
+ OK = .TRUE.
+ CALL DGET31( RLALN2, LLALN2, NLALN2, KLALN2 )
+ IF( RLALN2.GT.THRESH .OR. NLALN2( 1 ).NE.0 ) THEN
+ OK = .FALSE.
+ WRITE( NOUT, FMT = 9999 )RLALN2, LLALN2, NLALN2, KLALN2
+ END IF
+*
+ CALL DGET32( RLASY2, LLASY2, NLASY2, KLASY2 )
+ IF( RLASY2.GT.THRESH ) THEN
+ OK = .FALSE.
+ WRITE( NOUT, FMT = 9998 )RLASY2, LLASY2, NLASY2, KLASY2
+ END IF
+*
+ CALL DGET33( RLANV2, LLANV2, NLANV2, KLANV2 )
+ IF( RLANV2.GT.THRESH .OR. NLANV2.NE.0 ) THEN
+ OK = .FALSE.
+ WRITE( NOUT, FMT = 9997 )RLANV2, LLANV2, NLANV2, KLANV2
+ END IF
+*
+ CALL DGET34( RLAEXC, LLAEXC, NLAEXC, KLAEXC )
+ IF( RLAEXC.GT.THRESH .OR. NLAEXC( 2 ).NE.0 ) THEN
+ OK = .FALSE.
+ WRITE( NOUT, FMT = 9996 )RLAEXC, LLAEXC, NLAEXC, KLAEXC
+ END IF
+*
+ CALL DGET35( RTRSYL, LTRSYL, NTRSYL, KTRSYL )
+ IF( RTRSYL.GT.THRESH ) THEN
+ OK = .FALSE.
+ WRITE( NOUT, FMT = 9995 )RTRSYL, LTRSYL, NTRSYL, KTRSYL
+ END IF
+*
+ CALL DGET36( RTREXC, LTREXC, NTREXC, KTREXC, NIN )
+ IF( RTREXC.GT.THRESH .OR. NTREXC( 3 ).GT.0 ) THEN
+ OK = .FALSE.
+ WRITE( NOUT, FMT = 9994 )RTREXC, LTREXC, NTREXC, KTREXC
+ END IF
+*
+ CALL DGET37( RTRSNA, LTRSNA, NTRSNA, KTRSNA, NIN )
+ IF( RTRSNA( 1 ).GT.THRESH .OR. RTRSNA( 2 ).GT.THRESH .OR.
+ $ NTRSNA( 1 ).NE.0 .OR. NTRSNA( 2 ).NE.0 .OR. NTRSNA( 3 ).NE.0 )
+ $ THEN
+ OK = .FALSE.
+ WRITE( NOUT, FMT = 9993 )RTRSNA, LTRSNA, NTRSNA, KTRSNA
+ END IF
+*
+ CALL DGET38( RTRSEN, LTRSEN, NTRSEN, KTRSEN, NIN )
+ IF( RTRSEN( 1 ).GT.THRESH .OR. RTRSEN( 2 ).GT.THRESH .OR.
+ $ NTRSEN( 1 ).NE.0 .OR. NTRSEN( 2 ).NE.0 .OR. NTRSEN( 3 ).NE.0 )
+ $ THEN
+ OK = .FALSE.
+ WRITE( NOUT, FMT = 9992 )RTRSEN, LTRSEN, NTRSEN, KTRSEN
+ END IF
+*
+ CALL DGET39( RLAQTR, LLAQTR, NLAQTR, KLAQTR )
+ IF( RLAQTR.GT.THRESH ) THEN
+ OK = .FALSE.
+ WRITE( NOUT, FMT = 9991 )RLAQTR, LLAQTR, NLAQTR, KLAQTR
+ END IF
+*
+ NTESTS = KLALN2 + KLASY2 + KLANV2 + KLAEXC + KTRSYL + KTREXC +
+ $ KTRSNA + KTRSEN + KLAQTR
+ IF( OK )
+ $ WRITE( NOUT, FMT = 9990 )PATH, NTESTS
+*
+ RETURN
+ 9999 FORMAT( ' Error in DLALN2: RMAX =', D12.3, / ' LMAX = ', I8, ' N',
+ $ 'INFO=', 2I8, ' KNT=', I8 )
+ 9998 FORMAT( ' Error in DLASY2: RMAX =', D12.3, / ' LMAX = ', I8, ' N',
+ $ 'INFO=', I8, ' KNT=', I8 )
+ 9997 FORMAT( ' Error in DLANV2: RMAX =', D12.3, / ' LMAX = ', I8, ' N',
+ $ 'INFO=', I8, ' KNT=', I8 )
+ 9996 FORMAT( ' Error in DLAEXC: RMAX =', D12.3, / ' LMAX = ', I8, ' N',
+ $ 'INFO=', 2I8, ' KNT=', I8 )
+ 9995 FORMAT( ' Error in DTRSYL: RMAX =', D12.3, / ' LMAX = ', I8, ' N',
+ $ 'INFO=', I8, ' KNT=', I8 )
+ 9994 FORMAT( ' Error in DTREXC: RMAX =', D12.3, / ' LMAX = ', I8, ' N',
+ $ 'INFO=', 3I8, ' KNT=', I8 )
+ 9993 FORMAT( ' Error in DTRSNA: RMAX =', 3D12.3, / ' LMAX = ', 3I8,
+ $ ' NINFO=', 3I8, ' KNT=', I8 )
+ 9992 FORMAT( ' Error in DTRSEN: RMAX =', 3D12.3, / ' LMAX = ', 3I8,
+ $ ' NINFO=', 3I8, ' KNT=', I8 )
+ 9991 FORMAT( ' Error in DLAQTR: RMAX =', D12.3, / ' LMAX = ', I8, ' N',
+ $ 'INFO=', I8, ' KNT=', I8 )
+ 9990 FORMAT( / 1X, 'All tests for ', A3, ' routines passed the thresh',
+ $ 'old (', I6, ' tests run)' )
+ 9989 FORMAT( ' Tests of the Nonsymmetric eigenproblem condition estim',
+ $ 'ation routines', / ' DLALN2, DLASY2, DLANV2, DLAEXC, DTRS',
+ $ 'YL, DTREXC, DTRSNA, DTRSEN, DLAQTR', / )
+ 9988 FORMAT( ' Relative machine precision (EPS) = ', D16.6, / ' Safe ',
+ $ 'minimum (SFMIN) = ', D16.6, / )
+ 9987 FORMAT( ' Routines pass computational tests if test ratio is les',
+ $ 's than', F8.2, / / )
+*
+* End of DCHKEC
+*
+ END
+ PROGRAM DCHKEE
+*
+* -- LAPACK test routine (version 3.1.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* January 2007
+*
+* Purpose
+* =======
+*
+* DCHKEE tests the DOUBLE PRECISION LAPACK subroutines for the matrix
+* eigenvalue problem. The test paths in this version are
+*
+* NEP (Nonsymmetric Eigenvalue Problem):
+* Test DGEHRD, DORGHR, DHSEQR, DTREVC, DHSEIN, and DORMHR
+*
+* SEP (Symmetric Eigenvalue Problem):
+* Test DSYTRD, DORGTR, DSTEQR, DSTERF, DSTEIN, DSTEDC,
+* and drivers DSYEV(X), DSBEV(X), DSPEV(X), DSTEV(X),
+* DSYEVD, DSBEVD, DSPEVD, DSTEVD
+*
+* SVD (Singular Value Decomposition):
+* Test DGEBRD, DORGBR, DBDSQR, DBDSDC
+* and the drivers DGESVD, DGESDD
+*
+* DEV (Nonsymmetric Eigenvalue/eigenvector Driver):
+* Test DGEEV
+*
+* DES (Nonsymmetric Schur form Driver):
+* Test DGEES
+*
+* DVX (Nonsymmetric Eigenvalue/eigenvector Expert Driver):
+* Test DGEEVX
+*
+* DSX (Nonsymmetric Schur form Expert Driver):
+* Test DGEESX
+*
+* DGG (Generalized Nonsymmetric Eigenvalue Problem):
+* Test DGGHRD, DGGBAL, DGGBAK, DHGEQZ, and DTGEVC
+* and the driver routines DGEGS and DGEGV
+*
+* DGS (Generalized Nonsymmetric Schur form Driver):
+* Test DGGES
+*
+* DGV (Generalized Nonsymmetric Eigenvalue/eigenvector Driver):
+* Test DGGEV
+*
+* DGX (Generalized Nonsymmetric Schur form Expert Driver):
+* Test DGGESX
+*
+* DXV (Generalized Nonsymmetric Eigenvalue/eigenvector Expert Driver):
+* Test DGGEVX
+*
+* DSG (Symmetric Generalized Eigenvalue Problem):
+* Test DSYGST, DSYGV, DSYGVD, DSYGVX, DSPGST, DSPGV, DSPGVD,
+* DSPGVX, DSBGST, DSBGV, DSBGVD, and DSBGVX
+*
+* DSB (Symmetric Band Eigenvalue Problem):
+* Test DSBTRD
+*
+* DBB (Band Singular Value Decomposition):
+* Test DGBBRD
+*
+* DEC (Eigencondition estimation):
+* Test DLALN2, DLASY2, DLAEQU, DLAEXC, DTRSYL, DTREXC, DTRSNA,
+* DTRSEN, and DLAQTR
+*
+* DBL (Balancing a general matrix)
+* Test DGEBAL
+*
+* DBK (Back transformation on a balanced matrix)
+* Test DGEBAK
+*
+* DGL (Balancing a matrix pair)
+* Test DGGBAL
+*
+* DGK (Back transformation on a matrix pair)
+* Test DGGBAK
+*
+* GLM (Generalized Linear Regression Model):
+* Tests DGGGLM
+*
+* GQR (Generalized QR and RQ factorizations):
+* Tests DGGQRF and DGGRQF
+*
+* GSV (Generalized Singular Value Decomposition):
+* Tests DGGSVD, DGGSVP, DTGSJA, DLAGS2, DLAPLL, and DLAPMT
+*
+* LSE (Constrained Linear Least Squares):
+* Tests DGGLSE
+*
+* Each test path has a different set of inputs, but the data sets for
+* the driver routines xEV, xES, xVX, and xSX can be concatenated in a
+* single input file. The first line of input should contain one of the
+* 3-character path names in columns 1-3. The number of remaining lines
+* depends on what is found on the first line.
+*
+* The number of matrix types used in testing is often controllable from
+* the input file. The number of matrix types for each path, and the
+* test routine that describes them, is as follows:
+*
+* Path name(s) Types Test routine
+*
+* DHS or NEP 21 DCHKHS
+* DST or SEP 21 DCHKST (routines)
+* 18 DDRVST (drivers)
+* DBD or SVD 16 DCHKBD (routines)
+* 5 DDRVBD (drivers)
+* DEV 21 DDRVEV
+* DES 21 DDRVES
+* DVX 21 DDRVVX
+* DSX 21 DDRVSX
+* DGG 26 DCHKGG (routines)
+* 26 DDRVGG (drivers)
+* DGS 26 DDRGES
+* DGX 5 DDRGSX
+* DGV 26 DDRGEV
+* DXV 2 DDRGVX
+* DSG 21 DDRVSG
+* DSB 15 DCHKSB
+* DBB 15 DCHKBB
+* DEC - DCHKEC
+* DBL - DCHKBL
+* DBK - DCHKBK
+* DGL - DCHKGL
+* DGK - DCHKGK
+* GLM 8 DCKGLM
+* GQR 8 DCKGQR
+* GSV 8 DCKGSV
+* LSE 8 DCKLSE
+*
+*-----------------------------------------------------------------------
+*
+* NEP input file:
+*
+* line 2: NN, INTEGER
+* Number of values of N.
+*
+* line 3: NVAL, INTEGER array, dimension (NN)
+* The values for the matrix dimension N.
+*
+* line 4: NPARMS, INTEGER
+* Number of values of the parameters NB, NBMIN, NX, NS, and
+* MAXB.
+*
+* line 5: NBVAL, INTEGER array, dimension (NPARMS)
+* The values for the blocksize NB.
+*
+* line 6: NBMIN, INTEGER array, dimension (NPARMS)
+* The values for the minimum blocksize NBMIN.
+*
+* line 7: NXVAL, INTEGER array, dimension (NPARMS)
+* The values for the crossover point NX.
+*
+* line 8: INMIN, INTEGER array, dimension (NPARMS)
+* LAHQR vs TTQRE crossover point, >= 11
+*
+* line 9: INWIN, INTEGER array, dimension (NPARMS)
+* recommended deflation window size
+*
+* line 10: INIBL, INTEGER array, dimension (NPARMS)
+* nibble crossover point
+*
+* line 11: ISHFTS, INTEGER array, dimension (NPARMS)
+* number of simultaneous shifts)
+*
+* line 12: IACC22, INTEGER array, dimension (NPARMS)
+* select structured matrix multiply: 0, 1 or 2)
+*
+* line 13: THRESH
+* Threshold value for the test ratios. Information will be
+* printed about each test for which the test ratio is greater
+* than or equal to the threshold. To have all of the test
+* ratios printed, use THRESH = 0.0 .
+*
+* line 14: NEWSD, INTEGER
+* A code indicating how to set the random number seed.
+* = 0: Set the seed to a default value before each run
+* = 1: Initialize the seed to a default value only before the
+* first run
+* = 2: Like 1, but use the seed values on the next line
+*
+* If line 14 was 2:
+*
+* line 15: INTEGER array, dimension (4)
+* Four integer values for the random number seed.
+*
+* lines 15-EOF: The remaining lines occur in sets of 1 or 2 and allow
+* the user to specify the matrix types. Each line contains
+* a 3-character path name in columns 1-3, and the number
+* of matrix types must be the first nonblank item in columns
+* 4-80. If the number of matrix types is at least 1 but is
+* less than the maximum number of possible types, a second
+* line will be read to get the numbers of the matrix types to
+* be used. For example,
+* NEP 21
+* requests all of the matrix types for the nonsymmetric
+* eigenvalue problem, while
+* NEP 4
+* 9 10 11 12
+* requests only matrices of type 9, 10, 11, and 12.
+*
+* The valid 3-character path names are 'NEP' or 'SHS' for the
+* nonsymmetric eigenvalue routines.
+*
+*-----------------------------------------------------------------------
+*
+* SEP or DSG input file:
+*
+* line 2: NN, INTEGER
+* Number of values of N.
+*
+* line 3: NVAL, INTEGER array, dimension (NN)
+* The values for the matrix dimension N.
+*
+* line 4: NPARMS, INTEGER
+* Number of values of the parameters NB, NBMIN, and NX.
+*
+* line 5: NBVAL, INTEGER array, dimension (NPARMS)
+* The values for the blocksize NB.
+*
+* line 6: NBMIN, INTEGER array, dimension (NPARMS)
+* The values for the minimum blocksize NBMIN.
+*
+* line 7: NXVAL, INTEGER array, dimension (NPARMS)
+* The values for the crossover point NX.
+*
+* line 8: THRESH
+* Threshold value for the test ratios. Information will be
+* printed about each test for which the test ratio is greater
+* than or equal to the threshold.
+*
+* line 9: TSTCHK, LOGICAL
+* Flag indicating whether or not to test the LAPACK routines.
+*
+* line 10: TSTDRV, LOGICAL
+* Flag indicating whether or not to test the driver routines.
+*
+* line 11: TSTERR, LOGICAL
+* Flag indicating whether or not to test the error exits for
+* the LAPACK routines and driver routines.
+*
+* line 12: NEWSD, INTEGER
+* A code indicating how to set the random number seed.
+* = 0: Set the seed to a default value before each run
+* = 1: Initialize the seed to a default value only before the
+* first run
+* = 2: Like 1, but use the seed values on the next line
+*
+* If line 12 was 2:
+*
+* line 13: INTEGER array, dimension (4)
+* Four integer values for the random number seed.
+*
+* lines 13-EOF: Lines specifying matrix types, as for NEP.
+* The 3-character path names are 'SEP' or 'SST' for the
+* symmetric eigenvalue routines and driver routines, and
+* 'DSG' for the routines for the symmetric generalized
+* eigenvalue problem.
+*
+*-----------------------------------------------------------------------
+*
+* SVD input file:
+*
+* line 2: NN, INTEGER
+* Number of values of M and N.
+*
+* line 3: MVAL, INTEGER array, dimension (NN)
+* The values for the matrix row dimension M.
+*
+* line 4: NVAL, INTEGER array, dimension (NN)
+* The values for the matrix column dimension N.
+*
+* line 5: NPARMS, INTEGER
+* Number of values of the parameter NB, NBMIN, NX, and NRHS.
+*
+* line 6: NBVAL, INTEGER array, dimension (NPARMS)
+* The values for the blocksize NB.
+*
+* line 7: NBMIN, INTEGER array, dimension (NPARMS)
+* The values for the minimum blocksize NBMIN.
+*
+* line 8: NXVAL, INTEGER array, dimension (NPARMS)
+* The values for the crossover point NX.
+*
+* line 9: NSVAL, INTEGER array, dimension (NPARMS)
+* The values for the number of right hand sides NRHS.
+*
+* line 10: THRESH
+* Threshold value for the test ratios. Information will be
+* printed about each test for which the test ratio is greater
+* than or equal to the threshold.
+*
+* line 11: TSTCHK, LOGICAL
+* Flag indicating whether or not to test the LAPACK routines.
+*
+* line 12: TSTDRV, LOGICAL
+* Flag indicating whether or not to test the driver routines.
+*
+* line 13: TSTERR, LOGICAL
+* Flag indicating whether or not to test the error exits for
+* the LAPACK routines and driver routines.
+*
+* line 14: NEWSD, INTEGER
+* A code indicating how to set the random number seed.
+* = 0: Set the seed to a default value before each run
+* = 1: Initialize the seed to a default value only before the
+* first run
+* = 2: Like 1, but use the seed values on the next line
+*
+* If line 14 was 2:
+*
+* line 15: INTEGER array, dimension (4)
+* Four integer values for the random number seed.
+*
+* lines 15-EOF: Lines specifying matrix types, as for NEP.
+* The 3-character path names are 'SVD' or 'SBD' for both the
+* SVD routines and the SVD driver routines.
+*
+*-----------------------------------------------------------------------
+*
+* DEV and DES data files:
+*
+* line 1: 'DEV' or 'DES' in columns 1 to 3.
+*
+* line 2: NSIZES, INTEGER
+* Number of sizes of matrices to use. Should be at least 0
+* and at most 20. If NSIZES = 0, no testing is done
+* (although the remaining 3 lines are still read).
+*
+* line 3: NN, INTEGER array, dimension(NSIZES)
+* Dimensions of matrices to be tested.
+*
+* line 4: NB, NBMIN, NX, NS, NBCOL, INTEGERs
+* These integer parameters determine how blocking is done
+* (see ILAENV for details)
+* NB : block size
+* NBMIN : minimum block size
+* NX : minimum dimension for blocking
+* NS : number of shifts in xHSEQR
+* NBCOL : minimum column dimension for blocking
+*
+* line 5: THRESH, REAL
+* The test threshold against which computed residuals are
+* compared. Should generally be in the range from 10. to 20.
+* If it is 0., all test case data will be printed.
+*
+* line 6: TSTERR, LOGICAL
+* Flag indicating whether or not to test the error exits.
+*
+* line 7: NEWSD, INTEGER
+* A code indicating how to set the random number seed.
+* = 0: Set the seed to a default value before each run
+* = 1: Initialize the seed to a default value only before the
+* first run
+* = 2: Like 1, but use the seed values on the next line
+*
+* If line 7 was 2:
+*
+* line 8: INTEGER array, dimension (4)
+* Four integer values for the random number seed.
+*
+* lines 9 and following: Lines specifying matrix types, as for NEP.
+* The 3-character path name is 'DEV' to test SGEEV, or
+* 'DES' to test SGEES.
+*
+*-----------------------------------------------------------------------
+*
+* The DVX data has two parts. The first part is identical to DEV,
+* and the second part consists of test matrices with precomputed
+* solutions.
+*
+* line 1: 'DVX' in columns 1-3.
+*
+* line 2: NSIZES, INTEGER
+* If NSIZES = 0, no testing of randomly generated examples
+* is done, but any precomputed examples are tested.
+*
+* line 3: NN, INTEGER array, dimension(NSIZES)
+*
+* line 4: NB, NBMIN, NX, NS, NBCOL, INTEGERs
+*
+* line 5: THRESH, REAL
+*
+* line 6: TSTERR, LOGICAL
+*
+* line 7: NEWSD, INTEGER
+*
+* If line 7 was 2:
+*
+* line 8: INTEGER array, dimension (4)
+*
+* lines 9 and following: The first line contains 'DVX' in columns 1-3
+* followed by the number of matrix types, possibly with
+* a second line to specify certain matrix types.
+* If the number of matrix types = 0, no testing of randomly
+* generated examples is done, but any precomputed examples
+* are tested.
+*
+* remaining lines : Each matrix is stored on 1+2*N lines, where N is
+* its dimension. The first line contains the dimension (a
+* single integer). The next N lines contain the matrix, one
+* row per line. The last N lines correspond to each
+* eigenvalue. Each of these last N lines contains 4 real
+* values: the real part of the eigenvalue, the imaginary
+* part of the eigenvalue, the reciprocal condition number of
+* the eigenvalues, and the reciprocal condition number of the
+* eigenvector. The end of data is indicated by dimension N=0.
+* Even if no data is to be tested, there must be at least one
+* line containing N=0.
+*
+*-----------------------------------------------------------------------
+*
+* The DSX data is like DVX. The first part is identical to DEV, and the
+* second part consists of test matrices with precomputed solutions.
+*
+* line 1: 'DSX' in columns 1-3.
+*
+* line 2: NSIZES, INTEGER
+* If NSIZES = 0, no testing of randomly generated examples
+* is done, but any precomputed examples are tested.
+*
+* line 3: NN, INTEGER array, dimension(NSIZES)
+*
+* line 4: NB, NBMIN, NX, NS, NBCOL, INTEGERs
+*
+* line 5: THRESH, REAL
+*
+* line 6: TSTERR, LOGICAL
+*
+* line 7: NEWSD, INTEGER
+*
+* If line 7 was 2:
+*
+* line 8: INTEGER array, dimension (4)
+*
+* lines 9 and following: The first line contains 'DSX' in columns 1-3
+* followed by the number of matrix types, possibly with
+* a second line to specify certain matrix types.
+* If the number of matrix types = 0, no testing of randomly
+* generated examples is done, but any precomputed examples
+* are tested.
+*
+* remaining lines : Each matrix is stored on 3+N lines, where N is its
+* dimension. The first line contains the dimension N and the
+* dimension M of an invariant subspace. The second line
+* contains M integers, identifying the eigenvalues in the
+* invariant subspace (by their position in a list of
+* eigenvalues ordered by increasing real part). The next N
+* lines contain the matrix. The last line contains the
+* reciprocal condition number for the average of the selected
+* eigenvalues, and the reciprocal condition number for the
+* corresponding right invariant subspace. The end of data is
+* indicated by a line containing N=0 and M=0. Even if no data
+* is to be tested, there must be at least one line containing
+* N=0 and M=0.
+*
+*-----------------------------------------------------------------------
+*
+* DGG input file:
+*
+* line 2: NN, INTEGER
+* Number of values of N.
+*
+* line 3: NVAL, INTEGER array, dimension (NN)
+* The values for the matrix dimension N.
+*
+* line 4: NPARMS, INTEGER
+* Number of values of the parameters NB, NBMIN, NS, MAXB, and
+* NBCOL.
+*
+* line 5: NBVAL, INTEGER array, dimension (NPARMS)
+* The values for the blocksize NB.
+*
+* line 6: NBMIN, INTEGER array, dimension (NPARMS)
+* The values for NBMIN, the minimum row dimension for blocks.
+*
+* line 7: NSVAL, INTEGER array, dimension (NPARMS)
+* The values for the number of shifts.
+*
+* line 8: MXBVAL, INTEGER array, dimension (NPARMS)
+* The values for MAXB, used in determining minimum blocksize.
+*
+* line 9: NBCOL, INTEGER array, dimension (NPARMS)
+* The values for NBCOL, the minimum column dimension for
+* blocks.
+*
+* line 10: THRESH
+* Threshold value for the test ratios. Information will be
+* printed about each test for which the test ratio is greater
+* than or equal to the threshold.
+*
+* line 11: TSTCHK, LOGICAL
+* Flag indicating whether or not to test the LAPACK routines.
+*
+* line 12: TSTDRV, LOGICAL
+* Flag indicating whether or not to test the driver routines.
+*
+* line 13: TSTERR, LOGICAL
+* Flag indicating whether or not to test the error exits for
+* the LAPACK routines and driver routines.
+*
+* line 14: NEWSD, INTEGER
+* A code indicating how to set the random number seed.
+* = 0: Set the seed to a default value before each run
+* = 1: Initialize the seed to a default value only before the
+* first run
+* = 2: Like 1, but use the seed values on the next line
+*
+* If line 14 was 2:
+*
+* line 15: INTEGER array, dimension (4)
+* Four integer values for the random number seed.
+*
+* lines 15-EOF: Lines specifying matrix types, as for NEP.
+* The 3-character path name is 'DGG' for the generalized
+* eigenvalue problem routines and driver routines.
+*
+*-----------------------------------------------------------------------
+*
+* DGS and DGV input files:
+*
+* line 1: 'DGS' or 'DGV' in columns 1 to 3.
+*
+* line 2: NN, INTEGER
+* Number of values of N.
+*
+* line 3: NVAL, INTEGER array, dimension(NN)
+* Dimensions of matrices to be tested.
+*
+* line 4: NB, NBMIN, NX, NS, NBCOL, INTEGERs
+* These integer parameters determine how blocking is done
+* (see ILAENV for details)
+* NB : block size
+* NBMIN : minimum block size
+* NX : minimum dimension for blocking
+* NS : number of shifts in xHGEQR
+* NBCOL : minimum column dimension for blocking
+*
+* line 5: THRESH, REAL
+* The test threshold against which computed residuals are
+* compared. Should generally be in the range from 10. to 20.
+* If it is 0., all test case data will be printed.
+*
+* line 6: TSTERR, LOGICAL
+* Flag indicating whether or not to test the error exits.
+*
+* line 7: NEWSD, INTEGER
+* A code indicating how to set the random number seed.
+* = 0: Set the seed to a default value before each run
+* = 1: Initialize the seed to a default value only before the
+* first run
+* = 2: Like 1, but use the seed values on the next line
+*
+* If line 17 was 2:
+*
+* line 7: INTEGER array, dimension (4)
+* Four integer values for the random number seed.
+*
+* lines 7-EOF: Lines specifying matrix types, as for NEP.
+* The 3-character path name is 'DGS' for the generalized
+* eigenvalue problem routines and driver routines.
+*
+*-----------------------------------------------------------------------
+*
+* DXV input files:
+*
+* line 1: 'DXV' in columns 1 to 3.
+*
+* line 2: N, INTEGER
+* Value of N.
+*
+* line 3: NB, NBMIN, NX, NS, NBCOL, INTEGERs
+* These integer parameters determine how blocking is done
+* (see ILAENV for details)
+* NB : block size
+* NBMIN : minimum block size
+* NX : minimum dimension for blocking
+* NS : number of shifts in xHGEQR
+* NBCOL : minimum column dimension for blocking
+*
+* line 4: THRESH, REAL
+* The test threshold against which computed residuals are
+* compared. Should generally be in the range from 10. to 20.
+* Information will be printed about each test for which the
+* test ratio is greater than or equal to the threshold.
+*
+* line 5: TSTERR, LOGICAL
+* Flag indicating whether or not to test the error exits for
+* the LAPACK routines and driver routines.
+*
+* line 6: NEWSD, INTEGER
+* A code indicating how to set the random number seed.
+* = 0: Set the seed to a default value before each run
+* = 1: Initialize the seed to a default value only before the
+* first run
+* = 2: Like 1, but use the seed values on the next line
+*
+* If line 6 was 2:
+*
+* line 7: INTEGER array, dimension (4)
+* Four integer values for the random number seed.
+*
+* If line 2 was 0:
+*
+* line 7-EOF: Precomputed examples are tested.
+*
+* remaining lines : Each example is stored on 3+2*N lines, where N is
+* its dimension. The first line contains the dimension (a
+* single integer). The next N lines contain the matrix A, one
+* row per line. The next N lines contain the matrix B. The
+* next line contains the reciprocals of the eigenvalue
+* condition numbers. The last line contains the reciprocals of
+* the eigenvector condition numbers. The end of data is
+* indicated by dimension N=0. Even if no data is to be tested,
+* there must be at least one line containing N=0.
+*
+*-----------------------------------------------------------------------
+*
+* DGX input files:
+*
+* line 1: 'DGX' in columns 1 to 3.
+*
+* line 2: N, INTEGER
+* Value of N.
+*
+* line 3: NB, NBMIN, NX, NS, NBCOL, INTEGERs
+* These integer parameters determine how blocking is done
+* (see ILAENV for details)
+* NB : block size
+* NBMIN : minimum block size
+* NX : minimum dimension for blocking
+* NS : number of shifts in xHGEQR
+* NBCOL : minimum column dimension for blocking
+*
+* line 4: THRESH, REAL
+* The test threshold against which computed residuals are
+* compared. Should generally be in the range from 10. to 20.
+* Information will be printed about each test for which the
+* test ratio is greater than or equal to the threshold.
+*
+* line 5: TSTERR, LOGICAL
+* Flag indicating whether or not to test the error exits for
+* the LAPACK routines and driver routines.
+*
+* line 6: NEWSD, INTEGER
+* A code indicating how to set the random number seed.
+* = 0: Set the seed to a default value before each run
+* = 1: Initialize the seed to a default value only before the
+* first run
+* = 2: Like 1, but use the seed values on the next line
+*
+* If line 6 was 2:
+*
+* line 7: INTEGER array, dimension (4)
+* Four integer values for the random number seed.
+*
+* If line 2 was 0:
+*
+* line 7-EOF: Precomputed examples are tested.
+*
+* remaining lines : Each example is stored on 3+2*N lines, where N is
+* its dimension. The first line contains the dimension (a
+* single integer). The next line contains an integer k such
+* that only the last k eigenvalues will be selected and appear
+* in the leading diagonal blocks of $A$ and $B$. The next N
+* lines contain the matrix A, one row per line. The next N
+* lines contain the matrix B. The last line contains the
+* reciprocal of the eigenvalue cluster condition number and the
+* reciprocal of the deflating subspace (associated with the
+* selected eigencluster) condition number. The end of data is
+* indicated by dimension N=0. Even if no data is to be tested,
+* there must be at least one line containing N=0.
+*
+*-----------------------------------------------------------------------
+*
+* DSB input file:
+*
+* line 2: NN, INTEGER
+* Number of values of N.
+*
+* line 3: NVAL, INTEGER array, dimension (NN)
+* The values for the matrix dimension N.
+*
+* line 4: NK, INTEGER
+* Number of values of K.
+*
+* line 5: KVAL, INTEGER array, dimension (NK)
+* The values for the matrix dimension K.
+*
+* line 6: THRESH
+* Threshold value for the test ratios. Information will be
+* printed about each test for which the test ratio is greater
+* than or equal to the threshold.
+*
+* line 7: NEWSD, INTEGER
+* A code indicating how to set the random number seed.
+* = 0: Set the seed to a default value before each run
+* = 1: Initialize the seed to a default value only before the
+* first run
+* = 2: Like 1, but use the seed values on the next line
+*
+* If line 7 was 2:
+*
+* line 8: INTEGER array, dimension (4)
+* Four integer values for the random number seed.
+*
+* lines 8-EOF: Lines specifying matrix types, as for NEP.
+* The 3-character path name is 'DSB'.
+*
+*-----------------------------------------------------------------------
+*
+* DBB input file:
+*
+* line 2: NN, INTEGER
+* Number of values of M and N.
+*
+* line 3: MVAL, INTEGER array, dimension (NN)
+* The values for the matrix row dimension M.
+*
+* line 4: NVAL, INTEGER array, dimension (NN)
+* The values for the matrix column dimension N.
+*
+* line 4: NK, INTEGER
+* Number of values of K.
+*
+* line 5: KVAL, INTEGER array, dimension (NK)
+* The values for the matrix bandwidth K.
+*
+* line 6: NPARMS, INTEGER
+* Number of values of the parameter NRHS
+*
+* line 7: NSVAL, INTEGER array, dimension (NPARMS)
+* The values for the number of right hand sides NRHS.
+*
+* line 8: THRESH
+* Threshold value for the test ratios. Information will be
+* printed about each test for which the test ratio is greater
+* than or equal to the threshold.
+*
+* line 9: NEWSD, INTEGER
+* A code indicating how to set the random number seed.
+* = 0: Set the seed to a default value before each run
+* = 1: Initialize the seed to a default value only before the
+* first run
+* = 2: Like 1, but use the seed values on the next line
+*
+* If line 9 was 2:
+*
+* line 10: INTEGER array, dimension (4)
+* Four integer values for the random number seed.
+*
+* lines 10-EOF: Lines specifying matrix types, as for SVD.
+* The 3-character path name is 'DBB'.
+*
+*-----------------------------------------------------------------------
+*
+* DEC input file:
+*
+* line 2: THRESH, REAL
+* Threshold value for the test ratios. Information will be
+* printed about each test for which the test ratio is greater
+* than or equal to the threshold.
+*
+* lines 3-EOF:
+*
+* Input for testing the eigencondition routines consists of a set of
+* specially constructed test cases and their solutions. The data
+* format is not intended to be modified by the user.
+*
+*-----------------------------------------------------------------------
+*
+* DBL and DBK input files:
+*
+* line 1: 'DBL' in columns 1-3 to test SGEBAL, or 'DBK' in
+* columns 1-3 to test SGEBAK.
+*
+* The remaining lines consist of specially constructed test cases.
+*
+*-----------------------------------------------------------------------
+*
+* DGL and DGK input files:
+*
+* line 1: 'DGL' in columns 1-3 to test DGGBAL, or 'DGK' in
+* columns 1-3 to test DGGBAK.
+*
+* The remaining lines consist of specially constructed test cases.
+*
+*-----------------------------------------------------------------------
+*
+* GLM data file:
+*
+* line 1: 'GLM' in columns 1 to 3.
+*
+* line 2: NN, INTEGER
+* Number of values of M, P, and N.
+*
+* line 3: MVAL, INTEGER array, dimension(NN)
+* Values of M (row dimension).
+*
+* line 4: PVAL, INTEGER array, dimension(NN)
+* Values of P (row dimension).
+*
+* line 5: NVAL, INTEGER array, dimension(NN)
+* Values of N (column dimension), note M <= N <= M+P.
+*
+* line 6: THRESH, REAL
+* Threshold value for the test ratios. Information will be
+* printed about each test for which the test ratio is greater
+* than or equal to the threshold.
+*
+* line 7: TSTERR, LOGICAL
+* Flag indicating whether or not to test the error exits for
+* the LAPACK routines and driver routines.
+*
+* line 8: NEWSD, INTEGER
+* A code indicating how to set the random number seed.
+* = 0: Set the seed to a default value before each run
+* = 1: Initialize the seed to a default value only before the
+* first run
+* = 2: Like 1, but use the seed values on the next line
+*
+* If line 8 was 2:
+*
+* line 9: INTEGER array, dimension (4)
+* Four integer values for the random number seed.
+*
+* lines 9-EOF: Lines specifying matrix types, as for NEP.
+* The 3-character path name is 'GLM' for the generalized
+* linear regression model routines.
+*
+*-----------------------------------------------------------------------
+*
+* GQR data file:
+*
+* line 1: 'GQR' in columns 1 to 3.
+*
+* line 2: NN, INTEGER
+* Number of values of M, P, and N.
+*
+* line 3: MVAL, INTEGER array, dimension(NN)
+* Values of M.
+*
+* line 4: PVAL, INTEGER array, dimension(NN)
+* Values of P.
+*
+* line 5: NVAL, INTEGER array, dimension(NN)
+* Values of N.
+*
+* line 6: THRESH, REAL
+* Threshold value for the test ratios. Information will be
+* printed about each test for which the test ratio is greater
+* than or equal to the threshold.
+*
+* line 7: TSTERR, LOGICAL
+* Flag indicating whether or not to test the error exits for
+* the LAPACK routines and driver routines.
+*
+* line 8: NEWSD, INTEGER
+* A code indicating how to set the random number seed.
+* = 0: Set the seed to a default value before each run
+* = 1: Initialize the seed to a default value only before the
+* first run
+* = 2: Like 1, but use the seed values on the next line
+*
+* If line 8 was 2:
+*
+* line 9: INTEGER array, dimension (4)
+* Four integer values for the random number seed.
+*
+* lines 9-EOF: Lines specifying matrix types, as for NEP.
+* The 3-character path name is 'GQR' for the generalized
+* QR and RQ routines.
+*
+*-----------------------------------------------------------------------
+*
+* GSV data file:
+*
+* line 1: 'GSV' in columns 1 to 3.
+*
+* line 2: NN, INTEGER
+* Number of values of M, P, and N.
+*
+* line 3: MVAL, INTEGER array, dimension(NN)
+* Values of M (row dimension).
+*
+* line 4: PVAL, INTEGER array, dimension(NN)
+* Values of P (row dimension).
+*
+* line 5: NVAL, INTEGER array, dimension(NN)
+* Values of N (column dimension).
+*
+* line 6: THRESH, REAL
+* Threshold value for the test ratios. Information will be
+* printed about each test for which the test ratio is greater
+* than or equal to the threshold.
+*
+* line 7: TSTERR, LOGICAL
+* Flag indicating whether or not to test the error exits for
+* the LAPACK routines and driver routines.
+*
+* line 8: NEWSD, INTEGER
+* A code indicating how to set the random number seed.
+* = 0: Set the seed to a default value before each run
+* = 1: Initialize the seed to a default value only before the
+* first run
+* = 2: Like 1, but use the seed values on the next line
+*
+* If line 8 was 2:
+*
+* line 9: INTEGER array, dimension (4)
+* Four integer values for the random number seed.
+*
+* lines 9-EOF: Lines specifying matrix types, as for NEP.
+* The 3-character path name is 'GSV' for the generalized
+* SVD routines.
+*
+*-----------------------------------------------------------------------
+*
+* LSE data file:
+*
+* line 1: 'LSE' in columns 1 to 3.
+*
+* line 2: NN, INTEGER
+* Number of values of M, P, and N.
+*
+* line 3: MVAL, INTEGER array, dimension(NN)
+* Values of M.
+*
+* line 4: PVAL, INTEGER array, dimension(NN)
+* Values of P.
+*
+* line 5: NVAL, INTEGER array, dimension(NN)
+* Values of N, note P <= N <= P+M.
+*
+* line 6: THRESH, REAL
+* Threshold value for the test ratios. Information will be
+* printed about each test for which the test ratio is greater
+* than or equal to the threshold.
+*
+* line 7: TSTERR, LOGICAL
+* Flag indicating whether or not to test the error exits for
+* the LAPACK routines and driver routines.
+*
+* line 8: NEWSD, INTEGER
+* A code indicating how to set the random number seed.
+* = 0: Set the seed to a default value before each run
+* = 1: Initialize the seed to a default value only before the
+* first run
+* = 2: Like 1, but use the seed values on the next line
+*
+* If line 8 was 2:
+*
+* line 9: INTEGER array, dimension (4)
+* Four integer values for the random number seed.
+*
+* lines 9-EOF: Lines specifying matrix types, as for NEP.
+* The 3-character path name is 'GSV' for the generalized
+* SVD routines.
+*
+*-----------------------------------------------------------------------
+*
+* NMAX is currently set to 132 and must be at least 12 for some of the
+* precomputed examples, and LWORK = NMAX*(5*NMAX+5)+1 in the parameter
+* statements below. For SVD, we assume NRHS may be as big as N. The
+* parameter NEED is set to 14 to allow for 14 N-by-N matrices for DGG.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ INTEGER NMAX
+ PARAMETER ( NMAX = 132 )
+ INTEGER NCMAX
+ PARAMETER ( NCMAX = 20 )
+ INTEGER NEED
+ PARAMETER ( NEED = 14 )
+ INTEGER LWORK
+ PARAMETER ( LWORK = NMAX*( 5*NMAX+5 )+1 )
+ INTEGER LIWORK
+ PARAMETER ( LIWORK = NMAX*( 5*NMAX+20 ) )
+ INTEGER MAXIN
+ PARAMETER ( MAXIN = 20 )
+ INTEGER MAXT
+ PARAMETER ( MAXT = 30 )
+ INTEGER NIN, NOUT
+ PARAMETER ( NIN = 5, NOUT = 6 )
+* ..
+* .. Local Scalars ..
+ LOGICAL DBB, DGG, DSB, FATAL, GLM, GQR, GSV, LSE, NEP,
+ $ DBK, DBL, SEP, DES, DEV, DGK, DGL, DGS, DGV,
+ $ DGX, DSX, SVD, DVX, DXV, TSTCHK, TSTDIF,
+ $ TSTDRV, TSTERR
+ CHARACTER C1
+ CHARACTER*3 C3, PATH
+ CHARACTER*6 VNAME
+ CHARACTER*10 INTSTR
+ CHARACTER*80 LINE
+ INTEGER I, I1, IC, INFO, ITMP, K, LENP, MAXTYP, NEWSD,
+ $ NK, NN, NPARMS, NRHS, NTYPES,
+ $ VERS_MAJOR, VERS_MINOR, VERS_PATCH
+ DOUBLE PRECISION EPS, S1, S2, THRESH, THRSHN
+* ..
+* .. Local Arrays ..
+ LOGICAL DOTYPE( MAXT ), LOGWRK( NMAX )
+ INTEGER IOLDSD( 4 ), ISEED( 4 ), IWORK( LIWORK ),
+ $ KVAL( MAXIN ), MVAL( MAXIN ), MXBVAL( MAXIN ),
+ $ NBCOL( MAXIN ), NBMIN( MAXIN ), NBVAL( MAXIN ),
+ $ NSVAL( MAXIN ), NVAL( MAXIN ), NXVAL( MAXIN ),
+ $ PVAL( MAXIN )
+ INTEGER INMIN( MAXIN ), INWIN( MAXIN ), INIBL( MAXIN ),
+ $ ISHFTS( MAXIN ), IACC22( MAXIN )
+ DOUBLE PRECISION A( NMAX*NMAX, NEED ), B( NMAX*NMAX, 5 ),
+ $ C( NCMAX*NCMAX, NCMAX*NCMAX ), D( NMAX, 12 ),
+ $ RESULT( 500 ), TAUA( NMAX ), TAUB( NMAX ),
+ $ WORK( LWORK ), X( 5*NMAX )
+* ..
+* .. External Functions ..
+ LOGICAL LSAMEN
+ DOUBLE PRECISION DLAMCH, DSECND
+ EXTERNAL LSAMEN, DLAMCH, DSECND
+* ..
+* .. External Subroutines ..
+ EXTERNAL ALAREQ, DCHKBB, DCHKBD, DCHKBK, DCHKBL, DCHKEC,
+ $ DCHKGG, DCHKGK, DCHKGL, DCHKHS, DCHKSB, DCHKST,
+ $ DCKGLM, DCKGQR, DCKGSV, DCKLSE, DDRGES, DDRGEV,
+ $ DDRGSX, DDRGVX, DDRVBD, DDRVES, DDRVEV, DDRVGG,
+ $ DDRVSG, DDRVST, DDRVSX, DDRVVX, DERRBD, DERRED,
+ $ DERRGG, DERRHS, DERRST, ILAVER, XLAENV
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC LEN, MIN
+* ..
+* .. Scalars in Common ..
+ LOGICAL LERR, OK
+ CHARACTER*6 SRNAMT
+ INTEGER INFOT, MAXB, NPROC, NSHIFT, NUNIT, SELDIM,
+ $ SELOPT
+* ..
+* .. Arrays in Common ..
+ LOGICAL SELVAL( 20 )
+ INTEGER IPARMS( 100 )
+ DOUBLE PRECISION SELWI( 20 ), SELWR( 20 )
+* ..
+* .. Common blocks ..
+ COMMON / CENVIR / NPROC, NSHIFT, MAXB
+ COMMON / INFOC / INFOT, NUNIT, OK, LERR
+ COMMON / SRNAMC / SRNAMT
+ COMMON / SSLCT / SELOPT, SELDIM, SELVAL, SELWR, SELWI
+ COMMON / ZLAENV / IPARMS
+* ..
+* .. Data statements ..
+ DATA INTSTR / '0123456789' /
+ DATA IOLDSD / 0, 0, 0, 1 /
+* ..
+* .. Executable Statements ..
+*
+ S1 = DSECND( )
+ FATAL = .FALSE.
+ NUNIT = NOUT
+*
+* Return to here to read multiple sets of data
+*
+ 10 CONTINUE
+*
+* Read the first line and set the 3-character test path
+*
+ READ( NIN, FMT = '(A80)', END = 380 )LINE
+ PATH = LINE( 1: 3 )
+ NEP = LSAMEN( 3, PATH, 'NEP' ) .OR. LSAMEN( 3, PATH, 'DHS' )
+ SEP = LSAMEN( 3, PATH, 'SEP' ) .OR. LSAMEN( 3, PATH, 'DST' ) .OR.
+ $ LSAMEN( 3, PATH, 'DSG' )
+ SVD = LSAMEN( 3, PATH, 'SVD' ) .OR. LSAMEN( 3, PATH, 'DBD' )
+ DEV = LSAMEN( 3, PATH, 'DEV' )
+ DES = LSAMEN( 3, PATH, 'DES' )
+ DVX = LSAMEN( 3, PATH, 'DVX' )
+ DSX = LSAMEN( 3, PATH, 'DSX' )
+ DGG = LSAMEN( 3, PATH, 'DGG' )
+ DGS = LSAMEN( 3, PATH, 'DGS' )
+ DGX = LSAMEN( 3, PATH, 'DGX' )
+ DGV = LSAMEN( 3, PATH, 'DGV' )
+ DXV = LSAMEN( 3, PATH, 'DXV' )
+ DSB = LSAMEN( 3, PATH, 'DSB' )
+ DBB = LSAMEN( 3, PATH, 'DBB' )
+ GLM = LSAMEN( 3, PATH, 'GLM' )
+ GQR = LSAMEN( 3, PATH, 'GQR' ) .OR. LSAMEN( 3, PATH, 'GRQ' )
+ GSV = LSAMEN( 3, PATH, 'GSV' )
+ LSE = LSAMEN( 3, PATH, 'LSE' )
+ DBL = LSAMEN( 3, PATH, 'DBL' )
+ DBK = LSAMEN( 3, PATH, 'DBK' )
+ DGL = LSAMEN( 3, PATH, 'DGL' )
+ DGK = LSAMEN( 3, PATH, 'DGK' )
+*
+* Report values of parameters.
+*
+ IF( PATH.EQ.' ' ) THEN
+ GO TO 10
+ ELSE IF( NEP ) THEN
+ WRITE( NOUT, FMT = 9987 )
+ ELSE IF( SEP ) THEN
+ WRITE( NOUT, FMT = 9986 )
+ ELSE IF( SVD ) THEN
+ WRITE( NOUT, FMT = 9985 )
+ ELSE IF( DEV ) THEN
+ WRITE( NOUT, FMT = 9979 )
+ ELSE IF( DES ) THEN
+ WRITE( NOUT, FMT = 9978 )
+ ELSE IF( DVX ) THEN
+ WRITE( NOUT, FMT = 9977 )
+ ELSE IF( DSX ) THEN
+ WRITE( NOUT, FMT = 9976 )
+ ELSE IF( DGG ) THEN
+ WRITE( NOUT, FMT = 9975 )
+ ELSE IF( DGS ) THEN
+ WRITE( NOUT, FMT = 9964 )
+ ELSE IF( DGX ) THEN
+ WRITE( NOUT, FMT = 9965 )
+ ELSE IF( DGV ) THEN
+ WRITE( NOUT, FMT = 9963 )
+ ELSE IF( DXV ) THEN
+ WRITE( NOUT, FMT = 9962 )
+ ELSE IF( DSB ) THEN
+ WRITE( NOUT, FMT = 9974 )
+ ELSE IF( DBB ) THEN
+ WRITE( NOUT, FMT = 9967 )
+ ELSE IF( GLM ) THEN
+ WRITE( NOUT, FMT = 9971 )
+ ELSE IF( GQR ) THEN
+ WRITE( NOUT, FMT = 9970 )
+ ELSE IF( GSV ) THEN
+ WRITE( NOUT, FMT = 9969 )
+ ELSE IF( LSE ) THEN
+ WRITE( NOUT, FMT = 9968 )
+ ELSE IF( DBL ) THEN
+*
+* DGEBAL: Balancing
+*
+ CALL DCHKBL( NIN, NOUT )
+ GO TO 10
+ ELSE IF( DBK ) THEN
+*
+* DGEBAK: Back transformation
+*
+ CALL DCHKBK( NIN, NOUT )
+ GO TO 10
+ ELSE IF( DGL ) THEN
+*
+* DGGBAL: Balancing
+*
+ CALL DCHKGL( NIN, NOUT )
+ GO TO 10
+ ELSE IF( DGK ) THEN
+*
+* DGGBAK: Back transformation
+*
+ CALL DCHKGK( NIN, NOUT )
+ GO TO 10
+ ELSE IF( LSAMEN( 3, PATH, 'DEC' ) ) THEN
+*
+* DEC: Eigencondition estimation
+*
+ READ( NIN, FMT = * )THRESH
+ CALL XLAENV( 1, 1 )
+ CALL XLAENV( 12, 11 )
+ CALL XLAENV( 13, 2 )
+ CALL XLAENV( 14, 0 )
+ CALL XLAENV( 15, 2 )
+ CALL XLAENV( 16, 2 )
+ TSTERR = .TRUE.
+ CALL DCHKEC( THRESH, TSTERR, NIN, NOUT )
+ GO TO 10
+ ELSE
+ WRITE( NOUT, FMT = 9992 )PATH
+ GO TO 10
+ END IF
+ CALL ILAVER( VERS_MAJOR, VERS_MINOR, VERS_PATCH )
+ WRITE( NOUT, FMT = 9972 ) VERS_MAJOR, VERS_MINOR, VERS_PATCH
+ WRITE( NOUT, FMT = 9984 )
+*
+* Read the number of values of M, P, and N.
+*
+ READ( NIN, FMT = * )NN
+ IF( NN.LT.0 ) THEN
+ WRITE( NOUT, FMT = 9989 )' NN ', NN, 1
+ NN = 0
+ FATAL = .TRUE.
+ ELSE IF( NN.GT.MAXIN ) THEN
+ WRITE( NOUT, FMT = 9988 )' NN ', NN, MAXIN
+ NN = 0
+ FATAL = .TRUE.
+ END IF
+*
+* Read the values of M
+*
+ IF( .NOT.( DGX .OR. DXV ) ) THEN
+ READ( NIN, FMT = * )( MVAL( I ), I = 1, NN )
+ IF( SVD ) THEN
+ VNAME = ' M '
+ ELSE
+ VNAME = ' N '
+ END IF
+ DO 20 I = 1, NN
+ IF( MVAL( I ).LT.0 ) THEN
+ WRITE( NOUT, FMT = 9989 )VNAME, MVAL( I ), 0
+ FATAL = .TRUE.
+ ELSE IF( MVAL( I ).GT.NMAX ) THEN
+ WRITE( NOUT, FMT = 9988 )VNAME, MVAL( I ), NMAX
+ FATAL = .TRUE.
+ END IF
+ 20 CONTINUE
+ WRITE( NOUT, FMT = 9983 )'M: ', ( MVAL( I ), I = 1, NN )
+ END IF
+*
+* Read the values of P
+*
+ IF( GLM .OR. GQR .OR. GSV .OR. LSE ) THEN
+ READ( NIN, FMT = * )( PVAL( I ), I = 1, NN )
+ DO 30 I = 1, NN
+ IF( PVAL( I ).LT.0 ) THEN
+ WRITE( NOUT, FMT = 9989 )' P ', PVAL( I ), 0
+ FATAL = .TRUE.
+ ELSE IF( PVAL( I ).GT.NMAX ) THEN
+ WRITE( NOUT, FMT = 9988 )' P ', PVAL( I ), NMAX
+ FATAL = .TRUE.
+ END IF
+ 30 CONTINUE
+ WRITE( NOUT, FMT = 9983 )'P: ', ( PVAL( I ), I = 1, NN )
+ END IF
+*
+* Read the values of N
+*
+ IF( SVD .OR. DBB .OR. GLM .OR. GQR .OR. GSV .OR. LSE ) THEN
+ READ( NIN, FMT = * )( NVAL( I ), I = 1, NN )
+ DO 40 I = 1, NN
+ IF( NVAL( I ).LT.0 ) THEN
+ WRITE( NOUT, FMT = 9989 )' N ', NVAL( I ), 0
+ FATAL = .TRUE.
+ ELSE IF( NVAL( I ).GT.NMAX ) THEN
+ WRITE( NOUT, FMT = 9988 )' N ', NVAL( I ), NMAX
+ FATAL = .TRUE.
+ END IF
+ 40 CONTINUE
+ ELSE
+ DO 50 I = 1, NN
+ NVAL( I ) = MVAL( I )
+ 50 CONTINUE
+ END IF
+ IF( .NOT.( DGX .OR. DXV ) ) THEN
+ WRITE( NOUT, FMT = 9983 )'N: ', ( NVAL( I ), I = 1, NN )
+ ELSE
+ WRITE( NOUT, FMT = 9983 )'N: ', NN
+ END IF
+*
+* Read the number of values of K, followed by the values of K
+*
+ IF( DSB .OR. DBB ) THEN
+ READ( NIN, FMT = * )NK
+ READ( NIN, FMT = * )( KVAL( I ), I = 1, NK )
+ DO 60 I = 1, NK
+ IF( KVAL( I ).LT.0 ) THEN
+ WRITE( NOUT, FMT = 9989 )' K ', KVAL( I ), 0
+ FATAL = .TRUE.
+ ELSE IF( KVAL( I ).GT.NMAX ) THEN
+ WRITE( NOUT, FMT = 9988 )' K ', KVAL( I ), NMAX
+ FATAL = .TRUE.
+ END IF
+ 60 CONTINUE
+ WRITE( NOUT, FMT = 9983 )'K: ', ( KVAL( I ), I = 1, NK )
+ END IF
+*
+ IF( DEV .OR. DES .OR. DVX .OR. DSX ) THEN
+*
+* For the nonsymmetric QR driver routines, only one set of
+* parameters is allowed.
+*
+ READ( NIN, FMT = * )NBVAL( 1 ), NBMIN( 1 ), NXVAL( 1 ),
+ $ INMIN( 1 ), INWIN( 1 ), INIBL(1), ISHFTS(1), IACC22(1)
+ IF( NBVAL( 1 ).LT.1 ) THEN
+ WRITE( NOUT, FMT = 9989 )' NB ', NBVAL( 1 ), 1
+ FATAL = .TRUE.
+ ELSE IF( NBMIN( 1 ).LT.1 ) THEN
+ WRITE( NOUT, FMT = 9989 )'NBMIN ', NBMIN( 1 ), 1
+ FATAL = .TRUE.
+ ELSE IF( NXVAL( 1 ).LT.1 ) THEN
+ WRITE( NOUT, FMT = 9989 )' NX ', NXVAL( 1 ), 1
+ FATAL = .TRUE.
+ ELSE IF( INMIN( 1 ).LT.1 ) THEN
+ WRITE( NOUT, FMT = 9989 )' INMIN ', INMIN( 1 ), 1
+ FATAL = .TRUE.
+ ELSE IF( INWIN( 1 ).LT.1 ) THEN
+ WRITE( NOUT, FMT = 9989 )' INWIN ', INWIN( 1 ), 1
+ FATAL = .TRUE.
+ ELSE IF( INIBL( 1 ).LT.1 ) THEN
+ WRITE( NOUT, FMT = 9989 )' INIBL ', INIBL( 1 ), 1
+ FATAL = .TRUE.
+ ELSE IF( ISHFTS( 1 ).LT.1 ) THEN
+ WRITE( NOUT, FMT = 9989 )' ISHFTS ', ISHFTS( 1 ), 1
+ FATAL = .TRUE.
+ ELSE IF( IACC22( 1 ).LT.0 ) THEN
+ WRITE( NOUT, FMT = 9989 )' IACC22 ', IACC22( 1 ), 0
+ FATAL = .TRUE.
+ END IF
+ CALL XLAENV( 1, NBVAL( 1 ) )
+ CALL XLAENV( 2, NBMIN( 1 ) )
+ CALL XLAENV( 3, NXVAL( 1 ) )
+ CALL XLAENV(12, MAX( 11, INMIN( 1 ) ) )
+ CALL XLAENV(13, INWIN( 1 ) )
+ CALL XLAENV(14, INIBL( 1 ) )
+ CALL XLAENV(15, ISHFTS( 1 ) )
+ CALL XLAENV(16, IACC22( 1 ) )
+ WRITE( NOUT, FMT = 9983 )'NB: ', NBVAL( 1 )
+ WRITE( NOUT, FMT = 9983 )'NBMIN:', NBMIN( 1 )
+ WRITE( NOUT, FMT = 9983 )'NX: ', NXVAL( 1 )
+ WRITE( NOUT, FMT = 9983 )'INMIN: ', INMIN( 1 )
+ WRITE( NOUT, FMT = 9983 )'INWIN: ', INWIN( 1 )
+ WRITE( NOUT, FMT = 9983 )'INIBL: ', INIBL( 1 )
+ WRITE( NOUT, FMT = 9983 )'ISHFTS: ', ISHFTS( 1 )
+ WRITE( NOUT, FMT = 9983 )'IACC22: ', IACC22( 1 )
+*
+ ELSEIF( DGS .OR. DGX .OR. DGV .OR. DXV ) THEN
+*
+* For the nonsymmetric generalized driver routines, only one set
+* of parameters is allowed.
+*
+ READ( NIN, FMT = * )NBVAL( 1 ), NBMIN( 1 ), NXVAL( 1 ),
+ $ NSVAL( 1 ), MXBVAL( 1 )
+ IF( NBVAL( 1 ).LT.1 ) THEN
+ WRITE( NOUT, FMT = 9989 )' NB ', NBVAL( 1 ), 1
+ FATAL = .TRUE.
+ ELSE IF( NBMIN( 1 ).LT.1 ) THEN
+ WRITE( NOUT, FMT = 9989 )'NBMIN ', NBMIN( 1 ), 1
+ FATAL = .TRUE.
+ ELSE IF( NXVAL( 1 ).LT.1 ) THEN
+ WRITE( NOUT, FMT = 9989 )' NX ', NXVAL( 1 ), 1
+ FATAL = .TRUE.
+ ELSE IF( NSVAL( 1 ).LT.2 ) THEN
+ WRITE( NOUT, FMT = 9989 )' NS ', NSVAL( 1 ), 2
+ FATAL = .TRUE.
+ ELSE IF( MXBVAL( 1 ).LT.1 ) THEN
+ WRITE( NOUT, FMT = 9989 )' MAXB ', MXBVAL( 1 ), 1
+ FATAL = .TRUE.
+ END IF
+ CALL XLAENV( 1, NBVAL( 1 ) )
+ CALL XLAENV( 2, NBMIN( 1 ) )
+ CALL XLAENV( 3, NXVAL( 1 ) )
+ CALL XLAENV( 4, NSVAL( 1 ) )
+ CALL XLAENV( 8, MXBVAL( 1 ) )
+ WRITE( NOUT, FMT = 9983 )'NB: ', NBVAL( 1 )
+ WRITE( NOUT, FMT = 9983 )'NBMIN:', NBMIN( 1 )
+ WRITE( NOUT, FMT = 9983 )'NX: ', NXVAL( 1 )
+ WRITE( NOUT, FMT = 9983 )'NS: ', NSVAL( 1 )
+ WRITE( NOUT, FMT = 9983 )'MAXB: ', MXBVAL( 1 )
+*
+ ELSE IF( .NOT.DSB .AND. .NOT.GLM .AND. .NOT.GQR .AND. .NOT.
+ $ GSV .AND. .NOT.LSE ) THEN
+*
+* For the other paths, the number of parameters can be varied
+* from the input file. Read the number of parameter values.
+*
+ READ( NIN, FMT = * )NPARMS
+ IF( NPARMS.LT.1 ) THEN
+ WRITE( NOUT, FMT = 9989 )'NPARMS', NPARMS, 1
+ NPARMS = 0
+ FATAL = .TRUE.
+ ELSE IF( NPARMS.GT.MAXIN ) THEN
+ WRITE( NOUT, FMT = 9988 )'NPARMS', NPARMS, MAXIN
+ NPARMS = 0
+ FATAL = .TRUE.
+ END IF
+*
+* Read the values of NB
+*
+ IF( .NOT.DBB ) THEN
+ READ( NIN, FMT = * )( NBVAL( I ), I = 1, NPARMS )
+ DO 70 I = 1, NPARMS
+ IF( NBVAL( I ).LT.0 ) THEN
+ WRITE( NOUT, FMT = 9989 )' NB ', NBVAL( I ), 0
+ FATAL = .TRUE.
+ ELSE IF( NBVAL( I ).GT.NMAX ) THEN
+ WRITE( NOUT, FMT = 9988 )' NB ', NBVAL( I ), NMAX
+ FATAL = .TRUE.
+ END IF
+ 70 CONTINUE
+ WRITE( NOUT, FMT = 9983 )'NB: ',
+ $ ( NBVAL( I ), I = 1, NPARMS )
+ END IF
+*
+* Read the values of NBMIN
+*
+ IF( NEP .OR. SEP .OR. SVD .OR. DGG ) THEN
+ READ( NIN, FMT = * )( NBMIN( I ), I = 1, NPARMS )
+ DO 80 I = 1, NPARMS
+ IF( NBMIN( I ).LT.0 ) THEN
+ WRITE( NOUT, FMT = 9989 )'NBMIN ', NBMIN( I ), 0
+ FATAL = .TRUE.
+ ELSE IF( NBMIN( I ).GT.NMAX ) THEN
+ WRITE( NOUT, FMT = 9988 )'NBMIN ', NBMIN( I ), NMAX
+ FATAL = .TRUE.
+ END IF
+ 80 CONTINUE
+ WRITE( NOUT, FMT = 9983 )'NBMIN:',
+ $ ( NBMIN( I ), I = 1, NPARMS )
+ ELSE
+ DO 90 I = 1, NPARMS
+ NBMIN( I ) = 1
+ 90 CONTINUE
+ END IF
+*
+* Read the values of NX
+*
+ IF( NEP .OR. SEP .OR. SVD ) THEN
+ READ( NIN, FMT = * )( NXVAL( I ), I = 1, NPARMS )
+ DO 100 I = 1, NPARMS
+ IF( NXVAL( I ).LT.0 ) THEN
+ WRITE( NOUT, FMT = 9989 )' NX ', NXVAL( I ), 0
+ FATAL = .TRUE.
+ ELSE IF( NXVAL( I ).GT.NMAX ) THEN
+ WRITE( NOUT, FMT = 9988 )' NX ', NXVAL( I ), NMAX
+ FATAL = .TRUE.
+ END IF
+ 100 CONTINUE
+ WRITE( NOUT, FMT = 9983 )'NX: ',
+ $ ( NXVAL( I ), I = 1, NPARMS )
+ ELSE
+ DO 110 I = 1, NPARMS
+ NXVAL( I ) = 1
+ 110 CONTINUE
+ END IF
+*
+* Read the values of NSHIFT (if DGG) or NRHS (if SVD
+* or DBB).
+*
+ IF( SVD .OR. DBB .OR. DGG ) THEN
+ READ( NIN, FMT = * )( NSVAL( I ), I = 1, NPARMS )
+ DO 120 I = 1, NPARMS
+ IF( NSVAL( I ).LT.0 ) THEN
+ WRITE( NOUT, FMT = 9989 )' NS ', NSVAL( I ), 0
+ FATAL = .TRUE.
+ ELSE IF( NSVAL( I ).GT.NMAX ) THEN
+ WRITE( NOUT, FMT = 9988 )' NS ', NSVAL( I ), NMAX
+ FATAL = .TRUE.
+ END IF
+ 120 CONTINUE
+ WRITE( NOUT, FMT = 9983 )'NS: ',
+ $ ( NSVAL( I ), I = 1, NPARMS )
+ ELSE
+ DO 130 I = 1, NPARMS
+ NSVAL( I ) = 1
+ 130 CONTINUE
+ END IF
+*
+* Read the values for MAXB.
+*
+ IF( DGG ) THEN
+ READ( NIN, FMT = * )( MXBVAL( I ), I = 1, NPARMS )
+ DO 140 I = 1, NPARMS
+ IF( MXBVAL( I ).LT.0 ) THEN
+ WRITE( NOUT, FMT = 9989 )' MAXB ', MXBVAL( I ), 0
+ FATAL = .TRUE.
+ ELSE IF( MXBVAL( I ).GT.NMAX ) THEN
+ WRITE( NOUT, FMT = 9988 )' MAXB ', MXBVAL( I ), NMAX
+ FATAL = .TRUE.
+ END IF
+ 140 CONTINUE
+ WRITE( NOUT, FMT = 9983 )'MAXB: ',
+ $ ( MXBVAL( I ), I = 1, NPARMS )
+ ELSE
+ DO 150 I = 1, NPARMS
+ MXBVAL( I ) = 1
+ 150 CONTINUE
+ END IF
+*
+* Read the values for INMIN.
+*
+ IF( NEP ) THEN
+ READ( NIN, FMT = * )( INMIN( I ), I = 1, NPARMS )
+ DO 540 I = 1, NPARMS
+ IF( INMIN( I ).LT.0 ) THEN
+ WRITE( NOUT, FMT = 9989 )' INMIN ', INMIN( I ), 0
+ FATAL = .TRUE.
+ END IF
+ 540 CONTINUE
+ WRITE( NOUT, FMT = 9983 )'INMIN: ',
+ $ ( INMIN( I ), I = 1, NPARMS )
+ ELSE
+ DO 550 I = 1, NPARMS
+ INMIN( I ) = 1
+ 550 CONTINUE
+ END IF
+*
+* Read the values for INWIN.
+*
+ IF( NEP ) THEN
+ READ( NIN, FMT = * )( INWIN( I ), I = 1, NPARMS )
+ DO 560 I = 1, NPARMS
+ IF( INWIN( I ).LT.0 ) THEN
+ WRITE( NOUT, FMT = 9989 )' INWIN ', INWIN( I ), 0
+ FATAL = .TRUE.
+ END IF
+ 560 CONTINUE
+ WRITE( NOUT, FMT = 9983 )'INWIN: ',
+ $ ( INWIN( I ), I = 1, NPARMS )
+ ELSE
+ DO 570 I = 1, NPARMS
+ INWIN( I ) = 1
+ 570 CONTINUE
+ END IF
+*
+* Read the values for INIBL.
+*
+ IF( NEP ) THEN
+ READ( NIN, FMT = * )( INIBL( I ), I = 1, NPARMS )
+ DO 580 I = 1, NPARMS
+ IF( INIBL( I ).LT.0 ) THEN
+ WRITE( NOUT, FMT = 9989 )' INIBL ', INIBL( I ), 0
+ FATAL = .TRUE.
+ END IF
+ 580 CONTINUE
+ WRITE( NOUT, FMT = 9983 )'INIBL: ',
+ $ ( INIBL( I ), I = 1, NPARMS )
+ ELSE
+ DO 590 I = 1, NPARMS
+ INIBL( I ) = 1
+ 590 CONTINUE
+ END IF
+*
+* Read the values for ISHFTS.
+*
+ IF( NEP ) THEN
+ READ( NIN, FMT = * )( ISHFTS( I ), I = 1, NPARMS )
+ DO 600 I = 1, NPARMS
+ IF( ISHFTS( I ).LT.0 ) THEN
+ WRITE( NOUT, FMT = 9989 )' ISHFTS ', ISHFTS( I ), 0
+ FATAL = .TRUE.
+ END IF
+ 600 CONTINUE
+ WRITE( NOUT, FMT = 9983 )'ISHFTS: ',
+ $ ( ISHFTS( I ), I = 1, NPARMS )
+ ELSE
+ DO 610 I = 1, NPARMS
+ ISHFTS( I ) = 1
+ 610 CONTINUE
+ END IF
+*
+* Read the values for IACC22.
+*
+ IF( NEP ) THEN
+ READ( NIN, FMT = * )( IACC22( I ), I = 1, NPARMS )
+ DO 620 I = 1, NPARMS
+ IF( IACC22( I ).LT.0 ) THEN
+ WRITE( NOUT, FMT = 9989 )' IACC22 ', IACC22( I ), 0
+ FATAL = .TRUE.
+ END IF
+ 620 CONTINUE
+ WRITE( NOUT, FMT = 9983 )'IACC22: ',
+ $ ( IACC22( I ), I = 1, NPARMS )
+ ELSE
+ DO 630 I = 1, NPARMS
+ IACC22( I ) = 1
+ 630 CONTINUE
+ END IF
+*
+* Read the values for NBCOL.
+*
+ IF( DGG ) THEN
+ READ( NIN, FMT = * )( NBCOL( I ), I = 1, NPARMS )
+ DO 160 I = 1, NPARMS
+ IF( NBCOL( I ).LT.0 ) THEN
+ WRITE( NOUT, FMT = 9989 )'NBCOL ', NBCOL( I ), 0
+ FATAL = .TRUE.
+ ELSE IF( NBCOL( I ).GT.NMAX ) THEN
+ WRITE( NOUT, FMT = 9988 )'NBCOL ', NBCOL( I ), NMAX
+ FATAL = .TRUE.
+ END IF
+ 160 CONTINUE
+ WRITE( NOUT, FMT = 9983 )'NBCOL:',
+ $ ( NBCOL( I ), I = 1, NPARMS )
+ ELSE
+ DO 170 I = 1, NPARMS
+ NBCOL( I ) = 1
+ 170 CONTINUE
+ END IF
+ END IF
+*
+* Calculate and print the machine dependent constants.
+*
+ WRITE( NOUT, FMT = * )
+ EPS = DLAMCH( 'Underflow threshold' )
+ WRITE( NOUT, FMT = 9981 )'underflow', EPS
+ EPS = DLAMCH( 'Overflow threshold' )
+ WRITE( NOUT, FMT = 9981 )'overflow ', EPS
+ EPS = DLAMCH( 'Epsilon' )
+ WRITE( NOUT, FMT = 9981 )'precision', EPS
+*
+* Read the threshold value for the test ratios.
+*
+ READ( NIN, FMT = * )THRESH
+ WRITE( NOUT, FMT = 9982 )THRESH
+ IF( SEP .OR. SVD .OR. DGG ) THEN
+*
+* Read the flag that indicates whether to test LAPACK routines.
+*
+ READ( NIN, FMT = * )TSTCHK
+*
+* Read the flag that indicates whether to test driver routines.
+*
+ READ( NIN, FMT = * )TSTDRV
+ END IF
+*
+* Read the flag that indicates whether to test the error exits.
+*
+ READ( NIN, FMT = * )TSTERR
+*
+* Read the code describing how to set the random number seed.
+*
+ READ( NIN, FMT = * )NEWSD
+*
+* If NEWSD = 2, read another line with 4 integers for the seed.
+*
+ IF( NEWSD.EQ.2 )
+ $ READ( NIN, FMT = * )( IOLDSD( I ), I = 1, 4 )
+*
+ DO 180 I = 1, 4
+ ISEED( I ) = IOLDSD( I )
+ 180 CONTINUE
+*
+ IF( FATAL ) THEN
+ WRITE( NOUT, FMT = 9999 )
+ STOP
+ END IF
+*
+* Read the input lines indicating the test path and its parameters.
+* The first three characters indicate the test path, and the number
+* of test matrix types must be the first nonblank item in columns
+* 4-80.
+*
+ 190 CONTINUE
+*
+ IF( .NOT.( DGX .OR. DXV ) ) THEN
+*
+ 200 CONTINUE
+ READ( NIN, FMT = '(A80)', END = 380 )LINE
+ C3 = LINE( 1: 3 )
+ LENP = LEN( LINE )
+ I = 3
+ ITMP = 0
+ I1 = 0
+ 210 CONTINUE
+ I = I + 1
+ IF( I.GT.LENP ) THEN
+ IF( I1.GT.0 ) THEN
+ GO TO 240
+ ELSE
+ NTYPES = MAXT
+ GO TO 240
+ END IF
+ END IF
+ IF( LINE( I: I ).NE.' ' .AND. LINE( I: I ).NE.',' ) THEN
+ I1 = I
+ C1 = LINE( I1: I1 )
+*
+* Check that a valid integer was read
+*
+ DO 220 K = 1, 10
+ IF( C1.EQ.INTSTR( K: K ) ) THEN
+ IC = K - 1
+ GO TO 230
+ END IF
+ 220 CONTINUE
+ WRITE( NOUT, FMT = 9991 )I, LINE
+ GO TO 200
+ 230 CONTINUE
+ ITMP = 10*ITMP + IC
+ GO TO 210
+ ELSE IF( I1.GT.0 ) THEN
+ GO TO 240
+ ELSE
+ GO TO 210
+ END IF
+ 240 CONTINUE
+ NTYPES = ITMP
+*
+* Skip the tests if NTYPES is <= 0.
+*
+ IF( .NOT.( DEV .OR. DES .OR. DVX .OR. DSX .OR. DGV .OR.
+ $ DGS ) .AND. NTYPES.LE.0 ) THEN
+ WRITE( NOUT, FMT = 9990 )C3
+ GO TO 200
+ END IF
+*
+ ELSE
+ IF( DXV )
+ $ C3 = 'DXV'
+ IF( DGX )
+ $ C3 = 'DGX'
+ END IF
+*
+* Reset the random number seed.
+*
+ IF( NEWSD.EQ.0 ) THEN
+ DO 250 K = 1, 4
+ ISEED( K ) = IOLDSD( K )
+ 250 CONTINUE
+ END IF
+*
+ IF( LSAMEN( 3, C3, 'DHS' ) .OR. LSAMEN( 3, C3, 'NEP' ) ) THEN
+*
+* -------------------------------------
+* NEP: Nonsymmetric Eigenvalue Problem
+* -------------------------------------
+* Vary the parameters
+* NB = block size
+* NBMIN = minimum block size
+* NX = crossover point
+* NS = number of shifts
+* MAXB = minimum submatrix size
+*
+ MAXTYP = 21
+ NTYPES = MIN( MAXTYP, NTYPES )
+ CALL ALAREQ( C3, NTYPES, DOTYPE, MAXTYP, NIN, NOUT )
+ CALL XLAENV( 1, 1 )
+ IF( TSTERR )
+ $ CALL DERRHS( 'DHSEQR', NOUT )
+ DO 270 I = 1, NPARMS
+ CALL XLAENV( 1, NBVAL( I ) )
+ CALL XLAENV( 2, NBMIN( I ) )
+ CALL XLAENV( 3, NXVAL( I ) )
+ CALL XLAENV(12, MAX( 11, INMIN( I ) ) )
+ CALL XLAENV(13, INWIN( I ) )
+ CALL XLAENV(14, INIBL( I ) )
+ CALL XLAENV(15, ISHFTS( I ) )
+ CALL XLAENV(16, IACC22( I ) )
+*
+ IF( NEWSD.EQ.0 ) THEN
+ DO 260 K = 1, 4
+ ISEED( K ) = IOLDSD( K )
+ 260 CONTINUE
+ END IF
+ WRITE( NOUT, FMT = 9961 )C3, NBVAL( I ), NBMIN( I ),
+ $ NXVAL( I ), MAX( 11, INMIN(I)),
+ $ INWIN( I ), INIBL( I ), ISHFTS( I ), IACC22( I )
+ CALL DCHKHS( NN, NVAL, MAXTYP, DOTYPE, ISEED, THRESH, NOUT,
+ $ A( 1, 1 ), NMAX, A( 1, 2 ), A( 1, 3 ),
+ $ A( 1, 4 ), A( 1, 5 ), NMAX, A( 1, 6 ),
+ $ A( 1, 7 ), D( 1, 1 ), D( 1, 2 ), D( 1, 3 ),
+ $ D( 1, 4 ), A( 1, 8 ), A( 1, 9 ), A( 1, 10 ),
+ $ A( 1, 11 ), A( 1, 12 ), D( 1, 5 ), WORK, LWORK,
+ $ IWORK, LOGWRK, RESULT, INFO )
+ IF( INFO.NE.0 )
+ $ WRITE( NOUT, FMT = 9980 )'DCHKHS', INFO
+ 270 CONTINUE
+*
+ ELSE IF( LSAMEN( 3, C3, 'DST' ) .OR. LSAMEN( 3, C3, 'SEP' ) ) THEN
+*
+* ----------------------------------
+* SEP: Symmetric Eigenvalue Problem
+* ----------------------------------
+* Vary the parameters
+* NB = block size
+* NBMIN = minimum block size
+* NX = crossover point
+*
+ MAXTYP = 21
+ NTYPES = MIN( MAXTYP, NTYPES )
+ CALL ALAREQ( C3, NTYPES, DOTYPE, MAXTYP, NIN, NOUT )
+ CALL XLAENV( 1, 1 )
+ CALL XLAENV( 9, 25 )
+ IF( TSTERR )
+ $ CALL DERRST( 'DST', NOUT )
+ DO 290 I = 1, NPARMS
+ CALL XLAENV( 1, NBVAL( I ) )
+ CALL XLAENV( 2, NBMIN( I ) )
+ CALL XLAENV( 3, NXVAL( I ) )
+*
+ IF( NEWSD.EQ.0 ) THEN
+ DO 280 K = 1, 4
+ ISEED( K ) = IOLDSD( K )
+ 280 CONTINUE
+ END IF
+ WRITE( NOUT, FMT = 9997 )C3, NBVAL( I ), NBMIN( I ),
+ $ NXVAL( I )
+ IF( TSTCHK ) THEN
+ CALL DCHKST( NN, NVAL, MAXTYP, DOTYPE, ISEED, THRESH,
+ $ NOUT, A( 1, 1 ), NMAX, A( 1, 2 ), D( 1, 1 ),
+ $ D( 1, 2 ), D( 1, 3 ), D( 1, 4 ), D( 1, 5 ),
+ $ D( 1, 6 ), D( 1, 7 ), D( 1, 8 ), D( 1, 9 ),
+ $ D( 1, 10 ), D( 1, 11 ), A( 1, 3 ), NMAX,
+ $ A( 1, 4 ), A( 1, 5 ), D( 1, 12 ), A( 1, 6 ),
+ $ WORK, LWORK, IWORK, LIWORK, RESULT, INFO )
+ IF( INFO.NE.0 )
+ $ WRITE( NOUT, FMT = 9980 )'DCHKST', INFO
+ END IF
+ IF( TSTDRV ) THEN
+ CALL DDRVST( NN, NVAL, 18, DOTYPE, ISEED, THRESH, NOUT,
+ $ A( 1, 1 ), NMAX, D( 1, 3 ), D( 1, 4 ),
+ $ D( 1, 5 ), D( 1, 6 ), D( 1, 8 ), D( 1, 9 ),
+ $ D( 1, 10 ), D( 1, 11 ), A( 1, 2 ), NMAX,
+ $ A( 1, 3 ), D( 1, 12 ), A( 1, 4 ), WORK,
+ $ LWORK, IWORK, LIWORK, RESULT, INFO )
+ IF( INFO.NE.0 )
+ $ WRITE( NOUT, FMT = 9980 )'DDRVST', INFO
+ END IF
+ 290 CONTINUE
+*
+ ELSE IF( LSAMEN( 3, C3, 'DSG' ) ) THEN
+*
+* ----------------------------------------------
+* DSG: Symmetric Generalized Eigenvalue Problem
+* ----------------------------------------------
+* Vary the parameters
+* NB = block size
+* NBMIN = minimum block size
+* NX = crossover point
+*
+ MAXTYP = 21
+ NTYPES = MIN( MAXTYP, NTYPES )
+ CALL ALAREQ( C3, NTYPES, DOTYPE, MAXTYP, NIN, NOUT )
+ CALL XLAENV( 9, 25 )
+ DO 310 I = 1, NPARMS
+ CALL XLAENV( 1, NBVAL( I ) )
+ CALL XLAENV( 2, NBMIN( I ) )
+ CALL XLAENV( 3, NXVAL( I ) )
+*
+ IF( NEWSD.EQ.0 ) THEN
+ DO 300 K = 1, 4
+ ISEED( K ) = IOLDSD( K )
+ 300 CONTINUE
+ END IF
+ WRITE( NOUT, FMT = 9997 )C3, NBVAL( I ), NBMIN( I ),
+ $ NXVAL( I )
+ IF( TSTCHK ) THEN
+ CALL DDRVSG( NN, NVAL, MAXTYP, DOTYPE, ISEED, THRESH,
+ $ NOUT, A( 1, 1 ), NMAX, A( 1, 2 ), NMAX,
+ $ D( 1, 3 ), A( 1, 3 ), NMAX, A( 1, 4 ),
+ $ A( 1, 5 ), A( 1, 6 ), A( 1, 7 ), WORK,
+ $ LWORK, IWORK, LIWORK, RESULT, INFO )
+ IF( INFO.NE.0 )
+ $ WRITE( NOUT, FMT = 9980 )'DDRVSG', INFO
+ END IF
+ 310 CONTINUE
+*
+ ELSE IF( LSAMEN( 3, C3, 'DBD' ) .OR. LSAMEN( 3, C3, 'SVD' ) ) THEN
+*
+* ----------------------------------
+* SVD: Singular Value Decomposition
+* ----------------------------------
+* Vary the parameters
+* NB = block size
+* NBMIN = minimum block size
+* NX = crossover point
+* NRHS = number of right hand sides
+*
+ MAXTYP = 16
+ NTYPES = MIN( MAXTYP, NTYPES )
+ CALL ALAREQ( C3, NTYPES, DOTYPE, MAXTYP, NIN, NOUT )
+ CALL XLAENV( 1, 1 )
+ CALL XLAENV( 9, 25 )
+*
+* Test the error exits
+*
+ IF( TSTERR .AND. TSTCHK )
+ $ CALL DERRBD( 'DBD', NOUT )
+ IF( TSTERR .AND. TSTDRV )
+ $ CALL DERRED( 'DBD', NOUT )
+*
+ DO 330 I = 1, NPARMS
+ NRHS = NSVAL( I )
+ CALL XLAENV( 1, NBVAL( I ) )
+ CALL XLAENV( 2, NBMIN( I ) )
+ CALL XLAENV( 3, NXVAL( I ) )
+ IF( NEWSD.EQ.0 ) THEN
+ DO 320 K = 1, 4
+ ISEED( K ) = IOLDSD( K )
+ 320 CONTINUE
+ END IF
+ WRITE( NOUT, FMT = 9995 )C3, NBVAL( I ), NBMIN( I ),
+ $ NXVAL( I ), NRHS
+ IF( TSTCHK ) THEN
+ CALL DCHKBD( NN, MVAL, NVAL, MAXTYP, DOTYPE, NRHS, ISEED,
+ $ THRESH, A( 1, 1 ), NMAX, D( 1, 1 ),
+ $ D( 1, 2 ), D( 1, 3 ), D( 1, 4 ), A( 1, 2 ),
+ $ NMAX, A( 1, 3 ), A( 1, 4 ), A( 1, 5 ), NMAX,
+ $ A( 1, 6 ), NMAX, A( 1, 7 ), A( 1, 8 ), WORK,
+ $ LWORK, IWORK, NOUT, INFO )
+ IF( INFO.NE.0 )
+ $ WRITE( NOUT, FMT = 9980 )'DCHKBD', INFO
+ END IF
+ IF( TSTDRV )
+ $ CALL DDRVBD( NN, MVAL, NVAL, MAXTYP, DOTYPE, ISEED,
+ $ THRESH, A( 1, 1 ), NMAX, A( 1, 2 ), NMAX,
+ $ A( 1, 3 ), NMAX, A( 1, 4 ), A( 1, 5 ),
+ $ A( 1, 6 ), D( 1, 1 ), D( 1, 2 ), D( 1, 3 ),
+ $ WORK, LWORK, IWORK, NOUT, INFO )
+ 330 CONTINUE
+*
+ ELSE IF( LSAMEN( 3, C3, 'DEV' ) ) THEN
+*
+* --------------------------------------------
+* DEV: Nonsymmetric Eigenvalue Problem Driver
+* DGEEV (eigenvalues and eigenvectors)
+* --------------------------------------------
+*
+ MAXTYP = 21
+ NTYPES = MIN( MAXTYP, NTYPES )
+ IF( NTYPES.LE.0 ) THEN
+ WRITE( NOUT, FMT = 9990 )C3
+ ELSE
+ IF( TSTERR )
+ $ CALL DERRED( C3, NOUT )
+ CALL ALAREQ( C3, NTYPES, DOTYPE, MAXTYP, NIN, NOUT )
+ CALL DDRVEV( NN, NVAL, NTYPES, DOTYPE, ISEED, THRESH, NOUT,
+ $ A( 1, 1 ), NMAX, A( 1, 2 ), D( 1, 1 ),
+ $ D( 1, 2 ), D( 1, 3 ), D( 1, 4 ), A( 1, 3 ),
+ $ NMAX, A( 1, 4 ), NMAX, A( 1, 5 ), NMAX, RESULT,
+ $ WORK, LWORK, IWORK, INFO )
+ IF( INFO.NE.0 )
+ $ WRITE( NOUT, FMT = 9980 )'DGEEV', INFO
+ END IF
+ WRITE( NOUT, FMT = 9973 )
+ GO TO 10
+*
+ ELSE IF( LSAMEN( 3, C3, 'DES' ) ) THEN
+*
+* --------------------------------------------
+* DES: Nonsymmetric Eigenvalue Problem Driver
+* DGEES (Schur form)
+* --------------------------------------------
+*
+ MAXTYP = 21
+ NTYPES = MIN( MAXTYP, NTYPES )
+ IF( NTYPES.LE.0 ) THEN
+ WRITE( NOUT, FMT = 9990 )C3
+ ELSE
+ IF( TSTERR )
+ $ CALL DERRED( C3, NOUT )
+ CALL ALAREQ( C3, NTYPES, DOTYPE, MAXTYP, NIN, NOUT )
+ CALL DDRVES( NN, NVAL, NTYPES, DOTYPE, ISEED, THRESH, NOUT,
+ $ A( 1, 1 ), NMAX, A( 1, 2 ), A( 1, 3 ),
+ $ D( 1, 1 ), D( 1, 2 ), D( 1, 3 ), D( 1, 4 ),
+ $ A( 1, 4 ), NMAX, RESULT, WORK, LWORK, IWORK,
+ $ LOGWRK, INFO )
+ IF( INFO.NE.0 )
+ $ WRITE( NOUT, FMT = 9980 )'DGEES', INFO
+ END IF
+ WRITE( NOUT, FMT = 9973 )
+ GO TO 10
+*
+ ELSE IF( LSAMEN( 3, C3, 'DVX' ) ) THEN
+*
+* --------------------------------------------------------------
+* DVX: Nonsymmetric Eigenvalue Problem Expert Driver
+* DGEEVX (eigenvalues, eigenvectors and condition numbers)
+* --------------------------------------------------------------
+*
+ MAXTYP = 21
+ NTYPES = MIN( MAXTYP, NTYPES )
+ IF( NTYPES.LT.0 ) THEN
+ WRITE( NOUT, FMT = 9990 )C3
+ ELSE
+ IF( TSTERR )
+ $ CALL DERRED( C3, NOUT )
+ CALL ALAREQ( C3, NTYPES, DOTYPE, MAXTYP, NIN, NOUT )
+ CALL DDRVVX( NN, NVAL, NTYPES, DOTYPE, ISEED, THRESH, NIN,
+ $ NOUT, A( 1, 1 ), NMAX, A( 1, 2 ), D( 1, 1 ),
+ $ D( 1, 2 ), D( 1, 3 ), D( 1, 4 ), A( 1, 3 ),
+ $ NMAX, A( 1, 4 ), NMAX, A( 1, 5 ), NMAX,
+ $ D( 1, 5 ), D( 1, 6 ), D( 1, 7 ), D( 1, 8 ),
+ $ D( 1, 9 ), D( 1, 10 ), D( 1, 11 ), D( 1, 12 ),
+ $ RESULT, WORK, LWORK, IWORK, INFO )
+ IF( INFO.NE.0 )
+ $ WRITE( NOUT, FMT = 9980 )'DGEEVX', INFO
+ END IF
+ WRITE( NOUT, FMT = 9973 )
+ GO TO 10
+*
+ ELSE IF( LSAMEN( 3, C3, 'DSX' ) ) THEN
+*
+* ---------------------------------------------------
+* DSX: Nonsymmetric Eigenvalue Problem Expert Driver
+* DGEESX (Schur form and condition numbers)
+* ---------------------------------------------------
+*
+ MAXTYP = 21
+ NTYPES = MIN( MAXTYP, NTYPES )
+ IF( NTYPES.LT.0 ) THEN
+ WRITE( NOUT, FMT = 9990 )C3
+ ELSE
+ IF( TSTERR )
+ $ CALL DERRED( C3, NOUT )
+ CALL ALAREQ( C3, NTYPES, DOTYPE, MAXTYP, NIN, NOUT )
+ CALL DDRVSX( NN, NVAL, NTYPES, DOTYPE, ISEED, THRESH, NIN,
+ $ NOUT, A( 1, 1 ), NMAX, A( 1, 2 ), A( 1, 3 ),
+ $ D( 1, 1 ), D( 1, 2 ), D( 1, 3 ), D( 1, 4 ),
+ $ D( 1, 5 ), D( 1, 6 ), A( 1, 4 ), NMAX,
+ $ A( 1, 5 ), RESULT, WORK, LWORK, IWORK, LOGWRK,
+ $ INFO )
+ IF( INFO.NE.0 )
+ $ WRITE( NOUT, FMT = 9980 )'DGEESX', INFO
+ END IF
+ WRITE( NOUT, FMT = 9973 )
+ GO TO 10
+*
+ ELSE IF( LSAMEN( 3, C3, 'DGG' ) ) THEN
+*
+* -------------------------------------------------
+* DGG: Generalized Nonsymmetric Eigenvalue Problem
+* -------------------------------------------------
+* Vary the parameters
+* NB = block size
+* NBMIN = minimum block size
+* NS = number of shifts
+* MAXB = minimum submatrix size
+* NBCOL = minimum column dimension for blocks
+*
+ MAXTYP = 26
+ NTYPES = MIN( MAXTYP, NTYPES )
+ CALL ALAREQ( C3, NTYPES, DOTYPE, MAXTYP, NIN, NOUT )
+ IF( TSTCHK .AND. TSTERR )
+ $ CALL DERRGG( C3, NOUT )
+ DO 350 I = 1, NPARMS
+ CALL XLAENV( 1, NBVAL( I ) )
+ CALL XLAENV( 2, NBMIN( I ) )
+ CALL XLAENV( 4, NSVAL( I ) )
+ CALL XLAENV( 8, MXBVAL( I ) )
+ CALL XLAENV( 5, NBCOL( I ) )
+*
+ IF( NEWSD.EQ.0 ) THEN
+ DO 340 K = 1, 4
+ ISEED( K ) = IOLDSD( K )
+ 340 CONTINUE
+ END IF
+ WRITE( NOUT, FMT = 9996 )C3, NBVAL( I ), NBMIN( I ),
+ $ NSVAL( I ), MXBVAL( I ), NBCOL( I )
+ TSTDIF = .FALSE.
+ THRSHN = 10.D0
+ IF( TSTCHK ) THEN
+ CALL DCHKGG( NN, NVAL, MAXTYP, DOTYPE, ISEED, THRESH,
+ $ TSTDIF, THRSHN, NOUT, A( 1, 1 ), NMAX,
+ $ A( 1, 2 ), A( 1, 3 ), A( 1, 4 ), A( 1, 5 ),
+ $ A( 1, 6 ), A( 1, 7 ), A( 1, 8 ), A( 1, 9 ),
+ $ NMAX, A( 1, 10 ), A( 1, 11 ), A( 1, 12 ),
+ $ D( 1, 1 ), D( 1, 2 ), D( 1, 3 ), D( 1, 4 ),
+ $ D( 1, 5 ), D( 1, 6 ), A( 1, 13 ),
+ $ A( 1, 14 ), WORK, LWORK, LOGWRK, RESULT,
+ $ INFO )
+ IF( INFO.NE.0 )
+ $ WRITE( NOUT, FMT = 9980 )'DCHKGG', INFO
+ END IF
+ CALL XLAENV( 1, 1 )
+ IF( TSTDRV ) THEN
+ CALL DDRVGG( NN, NVAL, MAXTYP, DOTYPE, ISEED, THRESH,
+ $ THRSHN, NOUT, A( 1, 1 ), NMAX, A( 1, 2 ),
+ $ A( 1, 3 ), A( 1, 4 ), A( 1, 5 ), A( 1, 6 ),
+ $ A( 1, 7 ), NMAX, A( 1, 8 ), D( 1, 1 ),
+ $ D( 1, 2 ), D( 1, 3 ), D( 1, 4 ), D( 1, 5 ),
+ $ D( 1, 6 ), A( 1, 13 ), A( 1, 14 ), WORK,
+ $ LWORK, RESULT, INFO )
+ IF( INFO.NE.0 )
+ $ WRITE( NOUT, FMT = 9980 )'DDRVGG', INFO
+ END IF
+ 350 CONTINUE
+*
+ ELSE IF( LSAMEN( 3, C3, 'DGS' ) ) THEN
+*
+* -------------------------------------------------
+* DGS: Generalized Nonsymmetric Eigenvalue Problem
+* DGGES (Schur form)
+* -------------------------------------------------
+*
+ MAXTYP = 26
+ NTYPES = MIN( MAXTYP, NTYPES )
+ IF( NTYPES.LE.0 ) THEN
+ WRITE( NOUT, FMT = 9990 )C3
+ ELSE
+ IF( TSTERR )
+ $ CALL DERRGG( C3, NOUT )
+ CALL ALAREQ( C3, NTYPES, DOTYPE, MAXTYP, NIN, NOUT )
+ CALL DDRGES( NN, NVAL, MAXTYP, DOTYPE, ISEED, THRESH, NOUT,
+ $ A( 1, 1 ), NMAX, A( 1, 2 ), A( 1, 3 ),
+ $ A( 1, 4 ), A( 1, 7 ), NMAX, A( 1, 8 ),
+ $ D( 1, 1 ), D( 1, 2 ), D( 1, 3 ), WORK, LWORK,
+ $ RESULT, LOGWRK, INFO )
+*
+ IF( INFO.NE.0 )
+ $ WRITE( NOUT, FMT = 9980 )'DDRGES', INFO
+ END IF
+ WRITE( NOUT, FMT = 9973 )
+ GO TO 10
+*
+ ELSE IF( DGX ) THEN
+*
+* -------------------------------------------------
+* DGX: Generalized Nonsymmetric Eigenvalue Problem
+* DGGESX (Schur form and condition numbers)
+* -------------------------------------------------
+*
+ MAXTYP = 5
+ NTYPES = MAXTYP
+ IF( NN.LT.0 ) THEN
+ WRITE( NOUT, FMT = 9990 )C3
+ ELSE
+ IF( TSTERR )
+ $ CALL DERRGG( C3, NOUT )
+ CALL ALAREQ( C3, NTYPES, DOTYPE, MAXTYP, NIN, NOUT )
+ CALL XLAENV( 5, 2 )
+ CALL DDRGSX( NN, NCMAX, THRESH, NIN, NOUT, A( 1, 1 ), NMAX,
+ $ A( 1, 2 ), A( 1, 3 ), A( 1, 4 ), A( 1, 5 ),
+ $ A( 1, 6 ), D( 1, 1 ), D( 1, 2 ), D( 1, 3 ),
+ $ C( 1, 1 ), NCMAX*NCMAX, A( 1, 12 ), WORK,
+ $ LWORK, IWORK, LIWORK, LOGWRK, INFO )
+ IF( INFO.NE.0 )
+ $ WRITE( NOUT, FMT = 9980 )'DDRGSX', INFO
+ END IF
+ WRITE( NOUT, FMT = 9973 )
+ GO TO 10
+*
+ ELSE IF( LSAMEN( 3, C3, 'DGV' ) ) THEN
+*
+* -------------------------------------------------
+* DGV: Generalized Nonsymmetric Eigenvalue Problem
+* DGGEV (Eigenvalue/vector form)
+* -------------------------------------------------
+*
+ MAXTYP = 26
+ NTYPES = MIN( MAXTYP, NTYPES )
+ IF( NTYPES.LE.0 ) THEN
+ WRITE( NOUT, FMT = 9990 )C3
+ ELSE
+ IF( TSTERR )
+ $ CALL DERRGG( C3, NOUT )
+ CALL ALAREQ( C3, NTYPES, DOTYPE, MAXTYP, NIN, NOUT )
+ CALL DDRGEV( NN, NVAL, MAXTYP, DOTYPE, ISEED, THRESH, NOUT,
+ $ A( 1, 1 ), NMAX, A( 1, 2 ), A( 1, 3 ),
+ $ A( 1, 4 ), A( 1, 7 ), NMAX, A( 1, 8 ),
+ $ A( 1, 9 ), NMAX, D( 1, 1 ), D( 1, 2 ),
+ $ D( 1, 3 ), D( 1, 4 ), D( 1, 5 ), D( 1, 6 ),
+ $ WORK, LWORK, RESULT, INFO )
+ IF( INFO.NE.0 )
+ $ WRITE( NOUT, FMT = 9980 )'DDRGEV', INFO
+ END IF
+ WRITE( NOUT, FMT = 9973 )
+ GO TO 10
+*
+ ELSE IF( DXV ) THEN
+*
+* -------------------------------------------------
+* DXV: Generalized Nonsymmetric Eigenvalue Problem
+* DGGEVX (eigenvalue/vector with condition numbers)
+* -------------------------------------------------
+*
+ MAXTYP = 2
+ NTYPES = MAXTYP
+ IF( NN.LT.0 ) THEN
+ WRITE( NOUT, FMT = 9990 )C3
+ ELSE
+ IF( TSTERR )
+ $ CALL DERRGG( C3, NOUT )
+ CALL ALAREQ( C3, NTYPES, DOTYPE, MAXTYP, NIN, NOUT )
+ CALL DDRGVX( NN, THRESH, NIN, NOUT, A( 1, 1 ), NMAX,
+ $ A( 1, 2 ), A( 1, 3 ), A( 1, 4 ), D( 1, 1 ),
+ $ D( 1, 2 ), D( 1, 3 ), A( 1, 5 ), A( 1, 6 ),
+ $ IWORK( 1 ), IWORK( 2 ), D( 1, 4 ), D( 1, 5 ),
+ $ D( 1, 6 ), D( 1, 7 ), D( 1, 8 ), D( 1, 9 ),
+ $ WORK, LWORK, IWORK( 3 ), LIWORK-2, RESULT,
+ $ LOGWRK, INFO )
+*
+ IF( INFO.NE.0 )
+ $ WRITE( NOUT, FMT = 9980 )'DDRGVX', INFO
+ END IF
+ WRITE( NOUT, FMT = 9973 )
+ GO TO 10
+*
+ ELSE IF( LSAMEN( 3, C3, 'DSB' ) ) THEN
+*
+* ------------------------------
+* DSB: Symmetric Band Reduction
+* ------------------------------
+*
+ MAXTYP = 15
+ NTYPES = MIN( MAXTYP, NTYPES )
+ CALL ALAREQ( C3, NTYPES, DOTYPE, MAXTYP, NIN, NOUT )
+ IF( TSTERR )
+ $ CALL DERRST( 'DSB', NOUT )
+ CALL DCHKSB( NN, NVAL, NK, KVAL, MAXTYP, DOTYPE, ISEED, THRESH,
+ $ NOUT, A( 1, 1 ), NMAX, D( 1, 1 ), D( 1, 2 ),
+ $ A( 1, 2 ), NMAX, WORK, LWORK, RESULT, INFO )
+ IF( INFO.NE.0 )
+ $ WRITE( NOUT, FMT = 9980 )'DCHKSB', INFO
+*
+ ELSE IF( LSAMEN( 3, C3, 'DBB' ) ) THEN
+*
+* ------------------------------
+* DBB: General Band Reduction
+* ------------------------------
+*
+ MAXTYP = 15
+ NTYPES = MIN( MAXTYP, NTYPES )
+ CALL ALAREQ( C3, NTYPES, DOTYPE, MAXTYP, NIN, NOUT )
+ DO 370 I = 1, NPARMS
+ NRHS = NSVAL( I )
+*
+ IF( NEWSD.EQ.0 ) THEN
+ DO 360 K = 1, 4
+ ISEED( K ) = IOLDSD( K )
+ 360 CONTINUE
+ END IF
+ WRITE( NOUT, FMT = 9966 )C3, NRHS
+ CALL DCHKBB( NN, MVAL, NVAL, NK, KVAL, MAXTYP, DOTYPE, NRHS,
+ $ ISEED, THRESH, NOUT, A( 1, 1 ), NMAX,
+ $ A( 1, 2 ), 2*NMAX, D( 1, 1 ), D( 1, 2 ),
+ $ A( 1, 4 ), NMAX, A( 1, 5 ), NMAX, A( 1, 6 ),
+ $ NMAX, A( 1, 7 ), WORK, LWORK, RESULT, INFO )
+ IF( INFO.NE.0 )
+ $ WRITE( NOUT, FMT = 9980 )'DCHKBB', INFO
+ 370 CONTINUE
+*
+ ELSE IF( LSAMEN( 3, C3, 'GLM' ) ) THEN
+*
+* -----------------------------------------
+* GLM: Generalized Linear Regression Model
+* -----------------------------------------
+*
+ CALL XLAENV( 1, 1 )
+ IF( TSTERR )
+ $ CALL DERRGG( 'GLM', NOUT )
+ CALL DCKGLM( NN, MVAL, PVAL, NVAL, NTYPES, ISEED, THRESH, NMAX,
+ $ A( 1, 1 ), A( 1, 2 ), B( 1, 1 ), B( 1, 2 ), X,
+ $ WORK, D( 1, 1 ), NIN, NOUT, INFO )
+ IF( INFO.NE.0 )
+ $ WRITE( NOUT, FMT = 9980 )'DCKGLM', INFO
+*
+ ELSE IF( LSAMEN( 3, C3, 'GQR' ) ) THEN
+*
+* ------------------------------------------
+* GQR: Generalized QR and RQ factorizations
+* ------------------------------------------
+*
+ CALL XLAENV( 1, 1 )
+ IF( TSTERR )
+ $ CALL DERRGG( 'GQR', NOUT )
+ CALL DCKGQR( NN, MVAL, NN, PVAL, NN, NVAL, NTYPES, ISEED,
+ $ THRESH, NMAX, A( 1, 1 ), A( 1, 2 ), A( 1, 3 ),
+ $ A( 1, 4 ), TAUA, B( 1, 1 ), B( 1, 2 ), B( 1, 3 ),
+ $ B( 1, 4 ), B( 1, 5 ), TAUB, WORK, D( 1, 1 ), NIN,
+ $ NOUT, INFO )
+ IF( INFO.NE.0 )
+ $ WRITE( NOUT, FMT = 9980 )'DCKGQR', INFO
+*
+ ELSE IF( LSAMEN( 3, C3, 'GSV' ) ) THEN
+*
+* ----------------------------------------------
+* GSV: Generalized Singular Value Decomposition
+* ----------------------------------------------
+*
+ IF( TSTERR )
+ $ CALL DERRGG( 'GSV', NOUT )
+ CALL DCKGSV( NN, MVAL, PVAL, NVAL, NTYPES, ISEED, THRESH, NMAX,
+ $ A( 1, 1 ), A( 1, 2 ), B( 1, 1 ), B( 1, 2 ),
+ $ A( 1, 3 ), B( 1, 3 ), A( 1, 4 ), TAUA, TAUB,
+ $ B( 1, 4 ), IWORK, WORK, D( 1, 1 ), NIN, NOUT,
+ $ INFO )
+ IF( INFO.NE.0 )
+ $ WRITE( NOUT, FMT = 9980 )'DCKGSV', INFO
+*
+ ELSE IF( LSAMEN( 3, C3, 'LSE' ) ) THEN
+*
+* --------------------------------------
+* LSE: Constrained Linear Least Squares
+* --------------------------------------
+*
+ CALL XLAENV( 1, 1 )
+ IF( TSTERR )
+ $ CALL DERRGG( 'LSE', NOUT )
+ CALL DCKLSE( NN, MVAL, PVAL, NVAL, NTYPES, ISEED, THRESH, NMAX,
+ $ A( 1, 1 ), A( 1, 2 ), B( 1, 1 ), B( 1, 2 ), X,
+ $ WORK, D( 1, 1 ), NIN, NOUT, INFO )
+ IF( INFO.NE.0 )
+ $ WRITE( NOUT, FMT = 9980 )'DCKLSE', INFO
+*
+ ELSE
+ WRITE( NOUT, FMT = * )
+ WRITE( NOUT, FMT = * )
+ WRITE( NOUT, FMT = 9992 )C3
+ END IF
+ IF( .NOT.( DGX .OR. DXV ) )
+ $ GO TO 190
+ 380 CONTINUE
+ WRITE( NOUT, FMT = 9994 )
+ S2 = DSECND( )
+ WRITE( NOUT, FMT = 9993 )S2 - S1
+*
+ 9999 FORMAT( / ' Execution not attempted due to input errors' )
+ 9998 FORMAT( / / 1X, A3, ': NB =', I4, ', NBMIN =', I4, ', NX =', I4,
+ $ ', NS =', I4, ', MAXB =', I4 )
+ 9997 FORMAT( / / 1X, A3, ': NB =', I4, ', NBMIN =', I4, ', NX =', I4 )
+ 9996 FORMAT( / / 1X, A3, ': NB =', I4, ', NBMIN =', I4, ', NS =', I4,
+ $ ', MAXB =', I4, ', NBCOL =', I4 )
+ 9995 FORMAT( / / 1X, A3, ': NB =', I4, ', NBMIN =', I4, ', NX =', I4,
+ $ ', NRHS =', I4 )
+ 9994 FORMAT( / / ' End of tests' )
+ 9993 FORMAT( ' Total time used = ', F12.2, ' seconds', / )
+ 9992 FORMAT( 1X, A3, ': Unrecognized path name' )
+ 9991 FORMAT( / / ' *** Invalid integer value in column ', I2,
+ $ ' of input', ' line:', / A79 )
+ 9990 FORMAT( / / 1X, A3, ' routines were not tested' )
+ 9989 FORMAT( ' Invalid input value: ', A6, '=', I6, '; must be >=',
+ $ I6 )
+ 9988 FORMAT( ' Invalid input value: ', A6, '=', I6, '; must be <=',
+ $ I6 )
+ 9987 FORMAT( ' Tests of the Nonsymmetric Eigenvalue Problem routines' )
+ 9986 FORMAT( ' Tests of the Symmetric Eigenvalue Problem routines' )
+ 9985 FORMAT( ' Tests of the Singular Value Decomposition routines' )
+ 9984 FORMAT( / ' The following parameter values will be used:' )
+ 9983 FORMAT( 4X, A6, 10I6, / 10X, 10I6 )
+ 9982 FORMAT( / ' Routines pass computational tests if test ratio is ',
+ $ 'less than', F8.2, / )
+ 9981 FORMAT( ' Relative machine ', A, ' is taken to be', D16.6 )
+ 9980 FORMAT( ' *** Error code from ', A6, ' = ', I4 )
+ 9979 FORMAT( / ' Tests of the Nonsymmetric Eigenvalue Problem Driver',
+ $ / ' DGEEV (eigenvalues and eigevectors)' )
+ 9978 FORMAT( / ' Tests of the Nonsymmetric Eigenvalue Problem Driver',
+ $ / ' DGEES (Schur form)' )
+ 9977 FORMAT( / ' Tests of the Nonsymmetric Eigenvalue Problem Expert',
+ $ ' Driver', / ' DGEEVX (eigenvalues, eigenvectors and',
+ $ ' condition numbers)' )
+ 9976 FORMAT( / ' Tests of the Nonsymmetric Eigenvalue Problem Expert',
+ $ ' Driver', / ' DGEESX (Schur form and condition',
+ $ ' numbers)' )
+ 9975 FORMAT( / ' Tests of the Generalized Nonsymmetric Eigenvalue ',
+ $ 'Problem routines' )
+ 9974 FORMAT( ' Tests of DSBTRD', / ' (reduction of a symmetric band ',
+ $ 'matrix to tridiagonal form)' )
+ 9973 FORMAT( / 1X, 71( '-' ) )
+ 9972 FORMAT( / ' LAPACK VERSION ', I1, '.', I1, '.', I1 )
+ 9971 FORMAT( / ' Tests of the Generalized Linear Regression Model ',
+ $ 'routines' )
+ 9970 FORMAT( / ' Tests of the Generalized QR and RQ routines' )
+ 9969 FORMAT( / ' Tests of the Generalized Singular Value',
+ $ ' Decomposition routines' )
+ 9968 FORMAT( / ' Tests of the Linear Least Squares routines' )
+ 9967 FORMAT( ' Tests of DGBBRD', / ' (reduction of a general band ',
+ $ 'matrix to real bidiagonal form)' )
+ 9966 FORMAT( / / 1X, A3, ': NRHS =', I4 )
+ 9965 FORMAT( / ' Tests of the Generalized Nonsymmetric Eigenvalue ',
+ $ 'Problem Expert Driver DGGESX' )
+ 9964 FORMAT( / ' Tests of the Generalized Nonsymmetric Eigenvalue ',
+ $ 'Problem Driver DGGES' )
+ 9963 FORMAT( / ' Tests of the Generalized Nonsymmetric Eigenvalue ',
+ $ 'Problem Driver DGGEV' )
+ 9962 FORMAT( / ' Tests of the Generalized Nonsymmetric Eigenvalue ',
+ $ 'Problem Expert Driver DGGEVX' )
+ 9961 FORMAT( / / 1X, A3, ': NB =', I4, ', NBMIN =', I4, ', NX =', I4,
+ $ ', INMIN=', I4,
+ $ ', INWIN =', I4, ', INIBL =', I4, ', ISHFTS =', I4,
+ $ ', IACC22 =', I4)
+*
+* End of DCHKEE
+*
+ END
+ SUBROUTINE DCHKGG( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH,
+ $ TSTDIF, THRSHN, NOUNIT, A, LDA, B, H, T, S1,
+ $ S2, P1, P2, U, LDU, V, Q, Z, ALPHR1, ALPHI1,
+ $ BETA1, ALPHR3, ALPHI3, BETA3, EVECTL, EVECTR,
+ $ WORK, LWORK, LLWORK, RESULT, INFO )
+*
+* -- LAPACK test routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ LOGICAL TSTDIF
+ INTEGER INFO, LDA, LDU, LWORK, NOUNIT, NSIZES, NTYPES
+ DOUBLE PRECISION THRESH, THRSHN
+* ..
+* .. Array Arguments ..
+ LOGICAL DOTYPE( * ), LLWORK( * )
+ INTEGER ISEED( 4 ), NN( * )
+ DOUBLE PRECISION A( LDA, * ), ALPHI1( * ), ALPHI3( * ),
+ $ ALPHR1( * ), ALPHR3( * ), B( LDA, * ),
+ $ BETA1( * ), BETA3( * ), EVECTL( LDU, * ),
+ $ EVECTR( LDU, * ), H( LDA, * ), P1( LDA, * ),
+ $ P2( LDA, * ), Q( LDU, * ), RESULT( 15 ),
+ $ S1( LDA, * ), S2( LDA, * ), T( LDA, * ),
+ $ U( LDU, * ), V( LDU, * ), WORK( * ),
+ $ Z( LDU, * )
+* ..
+*
+* Purpose
+* =======
+*
+* DCHKGG checks the nonsymmetric generalized eigenvalue problem
+* routines.
+* T T T
+* DGGHRD factors A and B as U H V and U T V , where means
+* transpose, H is hessenberg, T is triangular and U and V are
+* orthogonal.
+* T T
+* DHGEQZ factors H and T as Q S Z and Q P Z , where P is upper
+* triangular, S is in generalized Schur form (block upper triangular,
+* with 1x1 and 2x2 blocks on the diagonal, the 2x2 blocks
+* corresponding to complex conjugate pairs of generalized
+* eigenvalues), and Q and Z are orthogonal. It also computes the
+* generalized eigenvalues (alpha(1),beta(1)),...,(alpha(n),beta(n)),
+* where alpha(j)=S(j,j) and beta(j)=P(j,j) -- thus,
+* w(j) = alpha(j)/beta(j) is a root of the generalized eigenvalue
+* problem
+*
+* det( A - w(j) B ) = 0
+*
+* and m(j) = beta(j)/alpha(j) is a root of the essentially equivalent
+* problem
+*
+* det( m(j) A - B ) = 0
+*
+* DTGEVC computes the matrix L of left eigenvectors and the matrix R
+* of right eigenvectors for the matrix pair ( S, P ). In the
+* description below, l and r are left and right eigenvectors
+* corresponding to the generalized eigenvalues (alpha,beta).
+*
+* When DCHKGG is called, a number of matrix "sizes" ("n's") and a
+* number of matrix "types" are specified. For each size ("n")
+* and each type of matrix, one matrix will be generated and used
+* to test the nonsymmetric eigenroutines. For each matrix, 15
+* tests will be performed. The first twelve "test ratios" should be
+* small -- O(1). They will be compared with the threshhold THRESH:
+*
+* T
+* (1) | A - U H V | / ( |A| n ulp )
+*
+* T
+* (2) | B - U T V | / ( |B| n ulp )
+*
+* T
+* (3) | I - UU | / ( n ulp )
+*
+* T
+* (4) | I - VV | / ( n ulp )
+*
+* T
+* (5) | H - Q S Z | / ( |H| n ulp )
+*
+* T
+* (6) | T - Q P Z | / ( |T| n ulp )
+*
+* T
+* (7) | I - QQ | / ( n ulp )
+*
+* T
+* (8) | I - ZZ | / ( n ulp )
+*
+* (9) max over all left eigenvalue/-vector pairs (beta/alpha,l) of
+*
+* | l**H * (beta S - alpha P) | / ( ulp max( |beta S|, |alpha P| ) )
+*
+* (10) max over all left eigenvalue/-vector pairs (beta/alpha,l') of
+* T
+* | l'**H * (beta H - alpha T) | / ( ulp max( |beta H|, |alpha T| ) )
+*
+* where the eigenvectors l' are the result of passing Q to
+* DTGEVC and back transforming (HOWMNY='B').
+*
+* (11) max over all right eigenvalue/-vector pairs (beta/alpha,r) of
+*
+* | (beta S - alpha T) r | / ( ulp max( |beta S|, |alpha T| ) )
+*
+* (12) max over all right eigenvalue/-vector pairs (beta/alpha,r') of
+*
+* | (beta H - alpha T) r' | / ( ulp max( |beta H|, |alpha T| ) )
+*
+* where the eigenvectors r' are the result of passing Z to
+* DTGEVC and back transforming (HOWMNY='B').
+*
+* The last three test ratios will usually be small, but there is no
+* mathematical requirement that they be so. They are therefore
+* compared with THRESH only if TSTDIF is .TRUE.
+*
+* (13) | S(Q,Z computed) - S(Q,Z not computed) | / ( |S| ulp )
+*
+* (14) | P(Q,Z computed) - P(Q,Z not computed) | / ( |P| ulp )
+*
+* (15) max( |alpha(Q,Z computed) - alpha(Q,Z not computed)|/|S| ,
+* |beta(Q,Z computed) - beta(Q,Z not computed)|/|P| ) / ulp
+*
+* In addition, the normalization of L and R are checked, and compared
+* with the threshhold THRSHN.
+*
+* Test Matrices
+* ---- --------
+*
+* The sizes of the test matrices are specified by an array
+* NN(1:NSIZES); the value of each element NN(j) specifies one size.
+* The "types" are specified by a logical array DOTYPE( 1:NTYPES ); if
+* DOTYPE(j) is .TRUE., then matrix type "j" will be generated.
+* Currently, the list of possible types is:
+*
+* (1) ( 0, 0 ) (a pair of zero matrices)
+*
+* (2) ( I, 0 ) (an identity and a zero matrix)
+*
+* (3) ( 0, I ) (an identity and a zero matrix)
+*
+* (4) ( I, I ) (a pair of identity matrices)
+*
+* t t
+* (5) ( J , J ) (a pair of transposed Jordan blocks)
+*
+* t ( I 0 )
+* (6) ( X, Y ) where X = ( J 0 ) and Y = ( t )
+* ( 0 I ) ( 0 J )
+* and I is a k x k identity and J a (k+1)x(k+1)
+* Jordan block; k=(N-1)/2
+*
+* (7) ( D, I ) where D is diag( 0, 1,..., N-1 ) (a diagonal
+* matrix with those diagonal entries.)
+* (8) ( I, D )
+*
+* (9) ( big*D, small*I ) where "big" is near overflow and small=1/big
+*
+* (10) ( small*D, big*I )
+*
+* (11) ( big*I, small*D )
+*
+* (12) ( small*I, big*D )
+*
+* (13) ( big*D, big*I )
+*
+* (14) ( small*D, small*I )
+*
+* (15) ( D1, D2 ) where D1 is diag( 0, 0, 1, ..., N-3, 0 ) and
+* D2 is diag( 0, N-3, N-4,..., 1, 0, 0 )
+* t t
+* (16) U ( J , J ) V where U and V are random orthogonal matrices.
+*
+* (17) U ( T1, T2 ) V where T1 and T2 are upper triangular matrices
+* with random O(1) entries above the diagonal
+* and diagonal entries diag(T1) =
+* ( 0, 0, 1, ..., N-3, 0 ) and diag(T2) =
+* ( 0, N-3, N-4,..., 1, 0, 0 )
+*
+* (18) U ( T1, T2 ) V diag(T1) = ( 0, 0, 1, 1, s, ..., s, 0 )
+* diag(T2) = ( 0, 1, 0, 1,..., 1, 0 )
+* s = machine precision.
+*
+* (19) U ( T1, T2 ) V diag(T1)=( 0,0,1,1, 1-d, ..., 1-(N-5)*d=s, 0 )
+* diag(T2) = ( 0, 1, 0, 1, ..., 1, 0 )
+*
+* N-5
+* (20) U ( T1, T2 ) V diag(T1)=( 0, 0, 1, 1, a, ..., a =s, 0 )
+* diag(T2) = ( 0, 1, 0, 1, ..., 1, 0, 0 )
+*
+* (21) U ( T1, T2 ) V diag(T1)=( 0, 0, 1, r1, r2, ..., r(N-4), 0 )
+* diag(T2) = ( 0, 1, 0, 1, ..., 1, 0, 0 )
+* where r1,..., r(N-4) are random.
+*
+* (22) U ( big*T1, small*T2 ) V diag(T1) = ( 0, 0, 1, ..., N-3, 0 )
+* diag(T2) = ( 0, 1, ..., 1, 0, 0 )
+*
+* (23) U ( small*T1, big*T2 ) V diag(T1) = ( 0, 0, 1, ..., N-3, 0 )
+* diag(T2) = ( 0, 1, ..., 1, 0, 0 )
+*
+* (24) U ( small*T1, small*T2 ) V diag(T1) = ( 0, 0, 1, ..., N-3, 0 )
+* diag(T2) = ( 0, 1, ..., 1, 0, 0 )
+*
+* (25) U ( big*T1, big*T2 ) V diag(T1) = ( 0, 0, 1, ..., N-3, 0 )
+* diag(T2) = ( 0, 1, ..., 1, 0, 0 )
+*
+* (26) U ( T1, T2 ) V where T1 and T2 are random upper-triangular
+* matrices.
+*
+* Arguments
+* =========
+*
+* NSIZES (input) INTEGER
+* The number of sizes of matrices to use. If it is zero,
+* DCHKGG does nothing. It must be at least zero.
+*
+* NN (input) INTEGER array, dimension (NSIZES)
+* An array containing the sizes to be used for the matrices.
+* Zero values will be skipped. The values must be at least
+* zero.
+*
+* NTYPES (input) INTEGER
+* The number of elements in DOTYPE. If it is zero, DCHKGG
+* does nothing. It must be at least zero. If it is MAXTYP+1
+* and NSIZES is 1, then an additional type, MAXTYP+1 is
+* defined, which is to use whatever matrix is in A. This
+* is only useful if DOTYPE(1:MAXTYP) is .FALSE. and
+* DOTYPE(MAXTYP+1) is .TRUE. .
+*
+* DOTYPE (input) LOGICAL array, dimension (NTYPES)
+* If DOTYPE(j) is .TRUE., then for each size in NN a
+* matrix of that size and of type j will be generated.
+* If NTYPES is smaller than the maximum number of types
+* defined (PARAMETER MAXTYP), then types NTYPES+1 through
+* MAXTYP will not be generated. If NTYPES is larger
+* than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES)
+* will be ignored.
+*
+* ISEED (input/output) INTEGER array, dimension (4)
+* On entry ISEED specifies the seed of the random number
+* generator. The array elements should be between 0 and 4095;
+* if not they will be reduced mod 4096. Also, ISEED(4) must
+* be odd. The random number generator uses a linear
+* congruential sequence limited to small integers, and so
+* should produce machine independent random numbers. The
+* values of ISEED are changed on exit, and can be used in the
+* next call to DCHKGG to continue the same random number
+* sequence.
+*
+* THRESH (input) DOUBLE PRECISION
+* A test will count as "failed" if the "error", computed as
+* described above, exceeds THRESH. Note that the error is
+* scaled to be O(1), so THRESH should be a reasonably small
+* multiple of 1, e.g., 10 or 100. In particular, it should
+* not depend on the precision (single vs. double) or the size
+* of the matrix. It must be at least zero.
+*
+* TSTDIF (input) LOGICAL
+* Specifies whether test ratios 13-15 will be computed and
+* compared with THRESH.
+* = .FALSE.: Only test ratios 1-12 will be computed and tested.
+* Ratios 13-15 will be set to zero.
+* = .TRUE.: All the test ratios 1-15 will be computed and
+* tested.
+*
+* THRSHN (input) DOUBLE PRECISION
+* Threshhold for reporting eigenvector normalization error.
+* If the normalization of any eigenvector differs from 1 by
+* more than THRSHN*ulp, then a special error message will be
+* printed. (This is handled separately from the other tests,
+* since only a compiler or programming error should cause an
+* error message, at least if THRSHN is at least 5--10.)
+*
+* NOUNIT (input) INTEGER
+* The FORTRAN unit number for printing out error messages
+* (e.g., if a routine returns IINFO not equal to 0.)
+*
+* A (input/workspace) DOUBLE PRECISION array, dimension
+* (LDA, max(NN))
+* Used to hold the original A matrix. Used as input only
+* if NTYPES=MAXTYP+1, DOTYPE(1:MAXTYP)=.FALSE., and
+* DOTYPE(MAXTYP+1)=.TRUE.
+*
+* LDA (input) INTEGER
+* The leading dimension of A, B, H, T, S1, P1, S2, and P2.
+* It must be at least 1 and at least max( NN ).
+*
+* B (input/workspace) DOUBLE PRECISION array, dimension
+* (LDA, max(NN))
+* Used to hold the original B matrix. Used as input only
+* if NTYPES=MAXTYP+1, DOTYPE(1:MAXTYP)=.FALSE., and
+* DOTYPE(MAXTYP+1)=.TRUE.
+*
+* H (workspace) DOUBLE PRECISION array, dimension (LDA, max(NN))
+* The upper Hessenberg matrix computed from A by DGGHRD.
+*
+* T (workspace) DOUBLE PRECISION array, dimension (LDA, max(NN))
+* The upper triangular matrix computed from B by DGGHRD.
+*
+* S1 (workspace) DOUBLE PRECISION array, dimension (LDA, max(NN))
+* The Schur (block upper triangular) matrix computed from H by
+* DHGEQZ when Q and Z are also computed.
+*
+* S2 (workspace) DOUBLE PRECISION array, dimension (LDA, max(NN))
+* The Schur (block upper triangular) matrix computed from H by
+* DHGEQZ when Q and Z are not computed.
+*
+* P1 (workspace) DOUBLE PRECISION array, dimension (LDA, max(NN))
+* The upper triangular matrix computed from T by DHGEQZ
+* when Q and Z are also computed.
+*
+* P2 (workspace) DOUBLE PRECISION array, dimension (LDA, max(NN))
+* The upper triangular matrix computed from T by DHGEQZ
+* when Q and Z are not computed.
+*
+* U (workspace) DOUBLE PRECISION array, dimension (LDU, max(NN))
+* The (left) orthogonal matrix computed by DGGHRD.
+*
+* LDU (input) INTEGER
+* The leading dimension of U, V, Q, Z, EVECTL, and EVEZTR. It
+* must be at least 1 and at least max( NN ).
+*
+* V (workspace) DOUBLE PRECISION array, dimension (LDU, max(NN))
+* The (right) orthogonal matrix computed by DGGHRD.
+*
+* Q (workspace) DOUBLE PRECISION array, dimension (LDU, max(NN))
+* The (left) orthogonal matrix computed by DHGEQZ.
+*
+* Z (workspace) DOUBLE PRECISION array, dimension (LDU, max(NN))
+* The (left) orthogonal matrix computed by DHGEQZ.
+*
+* ALPHR1 (workspace) DOUBLE PRECISION array, dimension (max(NN))
+* ALPHI1 (workspace) DOUBLE PRECISION array, dimension (max(NN))
+* BETA1 (workspace) DOUBLE PRECISION array, dimension (max(NN))
+*
+* The generalized eigenvalues of (A,B) computed by DHGEQZ
+* when Q, Z, and the full Schur matrices are computed.
+* On exit, ( ALPHR1(k)+ALPHI1(k)*i ) / BETA1(k) is the k-th
+* generalized eigenvalue of the matrices in A and B.
+*
+* ALPHR3 (workspace) DOUBLE PRECISION array, dimension (max(NN))
+* ALPHI3 (workspace) DOUBLE PRECISION array, dimension (max(NN))
+* BETA3 (workspace) DOUBLE PRECISION array, dimension (max(NN))
+*
+* EVECTL (workspace) DOUBLE PRECISION array, dimension (LDU, max(NN))
+* The (block lower triangular) left eigenvector matrix for
+* the matrices in S1 and P1. (See DTGEVC for the format.)
+*
+* EVEZTR (workspace) DOUBLE PRECISION array, dimension (LDU, max(NN))
+* The (block upper triangular) right eigenvector matrix for
+* the matrices in S1 and P1. (See DTGEVC for the format.)
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK)
+*
+* LWORK (input) INTEGER
+* The number of entries in WORK. This must be at least
+* max( 2 * N**2, 6*N, 1 ), for all N=NN(j).
+*
+* LLWORK (workspace) LOGICAL array, dimension (max(NN))
+*
+* RESULT (output) DOUBLE PRECISION array, dimension (15)
+* The values computed by the tests described above.
+* The values are currently limited to 1/ulp, to avoid
+* overflow.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+* > 0: A routine returned an error code. INFO is the
+* absolute value of the INFO value returned.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
+ INTEGER MAXTYP
+ PARAMETER ( MAXTYP = 26 )
+* ..
+* .. Local Scalars ..
+ LOGICAL BADNN
+ INTEGER I1, IADD, IINFO, IN, J, JC, JR, JSIZE, JTYPE,
+ $ LWKOPT, MTYPES, N, N1, NERRS, NMATS, NMAX,
+ $ NTEST, NTESTT
+ DOUBLE PRECISION ANORM, BNORM, SAFMAX, SAFMIN, TEMP1, TEMP2,
+ $ ULP, ULPINV
+* ..
+* .. Local Arrays ..
+ INTEGER IASIGN( MAXTYP ), IBSIGN( MAXTYP ),
+ $ IOLDSD( 4 ), KADD( 6 ), KAMAGN( MAXTYP ),
+ $ KATYPE( MAXTYP ), KAZERO( MAXTYP ),
+ $ KBMAGN( MAXTYP ), KBTYPE( MAXTYP ),
+ $ KBZERO( MAXTYP ), KCLASS( MAXTYP ),
+ $ KTRIAN( MAXTYP ), KZ1( 6 ), KZ2( 6 )
+ DOUBLE PRECISION DUMMA( 4 ), RMAGN( 0: 3 )
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DLAMCH, DLANGE, DLARND
+ EXTERNAL DLAMCH, DLANGE, DLARND
+* ..
+* .. External Subroutines ..
+ EXTERNAL DGEQR2, DGET51, DGET52, DGGHRD, DHGEQZ, DLABAD,
+ $ DLACPY, DLARFG, DLASET, DLASUM, DLATM4, DORM2R,
+ $ DTGEVC, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, DBLE, MAX, MIN, SIGN
+* ..
+* .. Data statements ..
+ DATA KCLASS / 15*1, 10*2, 1*3 /
+ DATA KZ1 / 0, 1, 2, 1, 3, 3 /
+ DATA KZ2 / 0, 0, 1, 2, 1, 1 /
+ DATA KADD / 0, 0, 0, 0, 3, 2 /
+ DATA KATYPE / 0, 1, 0, 1, 2, 3, 4, 1, 4, 4, 1, 1, 4,
+ $ 4, 4, 2, 4, 5, 8, 7, 9, 4*4, 0 /
+ DATA KBTYPE / 0, 0, 1, 1, 2, -3, 1, 4, 1, 1, 4, 4,
+ $ 1, 1, -4, 2, -4, 8*8, 0 /
+ DATA KAZERO / 6*1, 2, 1, 2*2, 2*1, 2*2, 3, 1, 3,
+ $ 4*5, 4*3, 1 /
+ DATA KBZERO / 6*1, 1, 2, 2*1, 2*2, 2*1, 4, 1, 4,
+ $ 4*6, 4*4, 1 /
+ DATA KAMAGN / 8*1, 2, 3, 2, 3, 2, 3, 7*1, 2, 3, 3,
+ $ 2, 1 /
+ DATA KBMAGN / 8*1, 3, 2, 3, 2, 2, 3, 7*1, 3, 2, 3,
+ $ 2, 1 /
+ DATA KTRIAN / 16*0, 10*1 /
+ DATA IASIGN / 6*0, 2, 0, 2*2, 2*0, 3*2, 0, 2, 3*0,
+ $ 5*2, 0 /
+ DATA IBSIGN / 7*0, 2, 2*0, 2*2, 2*0, 2, 0, 2, 9*0 /
+* ..
+* .. Executable Statements ..
+*
+* Check for errors
+*
+ INFO = 0
+*
+ BADNN = .FALSE.
+ NMAX = 1
+ DO 10 J = 1, NSIZES
+ NMAX = MAX( NMAX, NN( J ) )
+ IF( NN( J ).LT.0 )
+ $ BADNN = .TRUE.
+ 10 CONTINUE
+*
+* Maximum blocksize and shift -- we assume that blocksize and number
+* of shifts are monotone increasing functions of N.
+*
+ LWKOPT = MAX( 6*NMAX, 2*NMAX*NMAX, 1 )
+*
+* Check for errors
+*
+ IF( NSIZES.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( BADNN ) THEN
+ INFO = -2
+ ELSE IF( NTYPES.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( THRESH.LT.ZERO ) THEN
+ INFO = -6
+ ELSE IF( LDA.LE.1 .OR. LDA.LT.NMAX ) THEN
+ INFO = -10
+ ELSE IF( LDU.LE.1 .OR. LDU.LT.NMAX ) THEN
+ INFO = -19
+ ELSE IF( LWKOPT.GT.LWORK ) THEN
+ INFO = -30
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DCHKGG', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( NSIZES.EQ.0 .OR. NTYPES.EQ.0 )
+ $ RETURN
+*
+ SAFMIN = DLAMCH( 'Safe minimum' )
+ ULP = DLAMCH( 'Epsilon' )*DLAMCH( 'Base' )
+ SAFMIN = SAFMIN / ULP
+ SAFMAX = ONE / SAFMIN
+ CALL DLABAD( SAFMIN, SAFMAX )
+ ULPINV = ONE / ULP
+*
+* The values RMAGN(2:3) depend on N, see below.
+*
+ RMAGN( 0 ) = ZERO
+ RMAGN( 1 ) = ONE
+*
+* Loop over sizes, types
+*
+ NTESTT = 0
+ NERRS = 0
+ NMATS = 0
+*
+ DO 240 JSIZE = 1, NSIZES
+ N = NN( JSIZE )
+ N1 = MAX( 1, N )
+ RMAGN( 2 ) = SAFMAX*ULP / DBLE( N1 )
+ RMAGN( 3 ) = SAFMIN*ULPINV*N1
+*
+ IF( NSIZES.NE.1 ) THEN
+ MTYPES = MIN( MAXTYP, NTYPES )
+ ELSE
+ MTYPES = MIN( MAXTYP+1, NTYPES )
+ END IF
+*
+ DO 230 JTYPE = 1, MTYPES
+ IF( .NOT.DOTYPE( JTYPE ) )
+ $ GO TO 230
+ NMATS = NMATS + 1
+ NTEST = 0
+*
+* Save ISEED in case of an error.
+*
+ DO 20 J = 1, 4
+ IOLDSD( J ) = ISEED( J )
+ 20 CONTINUE
+*
+* Initialize RESULT
+*
+ DO 30 J = 1, 15
+ RESULT( J ) = ZERO
+ 30 CONTINUE
+*
+* Compute A and B
+*
+* Description of control parameters:
+*
+* KZLASS: =1 means w/o rotation, =2 means w/ rotation,
+* =3 means random.
+* KATYPE: the "type" to be passed to DLATM4 for computing A.
+* KAZERO: the pattern of zeros on the diagonal for A:
+* =1: ( xxx ), =2: (0, xxx ) =3: ( 0, 0, xxx, 0 ),
+* =4: ( 0, xxx, 0, 0 ), =5: ( 0, 0, 1, xxx, 0 ),
+* =6: ( 0, 1, 0, xxx, 0 ). (xxx means a string of
+* non-zero entries.)
+* KAMAGN: the magnitude of the matrix: =0: zero, =1: O(1),
+* =2: large, =3: small.
+* IASIGN: 1 if the diagonal elements of A are to be
+* multiplied by a random magnitude 1 number, =2 if
+* randomly chosen diagonal blocks are to be rotated
+* to form 2x2 blocks.
+* KBTYPE, KBZERO, KBMAGN, IBSIGN: the same, but for B.
+* KTRIAN: =0: don't fill in the upper triangle, =1: do.
+* KZ1, KZ2, KADD: used to implement KAZERO and KBZERO.
+* RMAGN: used to implement KAMAGN and KBMAGN.
+*
+ IF( MTYPES.GT.MAXTYP )
+ $ GO TO 110
+ IINFO = 0
+ IF( KCLASS( JTYPE ).LT.3 ) THEN
+*
+* Generate A (w/o rotation)
+*
+ IF( ABS( KATYPE( JTYPE ) ).EQ.3 ) THEN
+ IN = 2*( ( N-1 ) / 2 ) + 1
+ IF( IN.NE.N )
+ $ CALL DLASET( 'Full', N, N, ZERO, ZERO, A, LDA )
+ ELSE
+ IN = N
+ END IF
+ CALL DLATM4( KATYPE( JTYPE ), IN, KZ1( KAZERO( JTYPE ) ),
+ $ KZ2( KAZERO( JTYPE ) ), IASIGN( JTYPE ),
+ $ RMAGN( KAMAGN( JTYPE ) ), ULP,
+ $ RMAGN( KTRIAN( JTYPE )*KAMAGN( JTYPE ) ), 2,
+ $ ISEED, A, LDA )
+ IADD = KADD( KAZERO( JTYPE ) )
+ IF( IADD.GT.0 .AND. IADD.LE.N )
+ $ A( IADD, IADD ) = RMAGN( KAMAGN( JTYPE ) )
+*
+* Generate B (w/o rotation)
+*
+ IF( ABS( KBTYPE( JTYPE ) ).EQ.3 ) THEN
+ IN = 2*( ( N-1 ) / 2 ) + 1
+ IF( IN.NE.N )
+ $ CALL DLASET( 'Full', N, N, ZERO, ZERO, B, LDA )
+ ELSE
+ IN = N
+ END IF
+ CALL DLATM4( KBTYPE( JTYPE ), IN, KZ1( KBZERO( JTYPE ) ),
+ $ KZ2( KBZERO( JTYPE ) ), IBSIGN( JTYPE ),
+ $ RMAGN( KBMAGN( JTYPE ) ), ONE,
+ $ RMAGN( KTRIAN( JTYPE )*KBMAGN( JTYPE ) ), 2,
+ $ ISEED, B, LDA )
+ IADD = KADD( KBZERO( JTYPE ) )
+ IF( IADD.NE.0 .AND. IADD.LE.N )
+ $ B( IADD, IADD ) = RMAGN( KBMAGN( JTYPE ) )
+*
+ IF( KCLASS( JTYPE ).EQ.2 .AND. N.GT.0 ) THEN
+*
+* Include rotations
+*
+* Generate U, V as Householder transformations times
+* a diagonal matrix.
+*
+ DO 50 JC = 1, N - 1
+ DO 40 JR = JC, N
+ U( JR, JC ) = DLARND( 3, ISEED )
+ V( JR, JC ) = DLARND( 3, ISEED )
+ 40 CONTINUE
+ CALL DLARFG( N+1-JC, U( JC, JC ), U( JC+1, JC ), 1,
+ $ WORK( JC ) )
+ WORK( 2*N+JC ) = SIGN( ONE, U( JC, JC ) )
+ U( JC, JC ) = ONE
+ CALL DLARFG( N+1-JC, V( JC, JC ), V( JC+1, JC ), 1,
+ $ WORK( N+JC ) )
+ WORK( 3*N+JC ) = SIGN( ONE, V( JC, JC ) )
+ V( JC, JC ) = ONE
+ 50 CONTINUE
+ U( N, N ) = ONE
+ WORK( N ) = ZERO
+ WORK( 3*N ) = SIGN( ONE, DLARND( 2, ISEED ) )
+ V( N, N ) = ONE
+ WORK( 2*N ) = ZERO
+ WORK( 4*N ) = SIGN( ONE, DLARND( 2, ISEED ) )
+*
+* Apply the diagonal matrices
+*
+ DO 70 JC = 1, N
+ DO 60 JR = 1, N
+ A( JR, JC ) = WORK( 2*N+JR )*WORK( 3*N+JC )*
+ $ A( JR, JC )
+ B( JR, JC ) = WORK( 2*N+JR )*WORK( 3*N+JC )*
+ $ B( JR, JC )
+ 60 CONTINUE
+ 70 CONTINUE
+ CALL DORM2R( 'L', 'N', N, N, N-1, U, LDU, WORK, A,
+ $ LDA, WORK( 2*N+1 ), IINFO )
+ IF( IINFO.NE.0 )
+ $ GO TO 100
+ CALL DORM2R( 'R', 'T', N, N, N-1, V, LDU, WORK( N+1 ),
+ $ A, LDA, WORK( 2*N+1 ), IINFO )
+ IF( IINFO.NE.0 )
+ $ GO TO 100
+ CALL DORM2R( 'L', 'N', N, N, N-1, U, LDU, WORK, B,
+ $ LDA, WORK( 2*N+1 ), IINFO )
+ IF( IINFO.NE.0 )
+ $ GO TO 100
+ CALL DORM2R( 'R', 'T', N, N, N-1, V, LDU, WORK( N+1 ),
+ $ B, LDA, WORK( 2*N+1 ), IINFO )
+ IF( IINFO.NE.0 )
+ $ GO TO 100
+ END IF
+ ELSE
+*
+* Random matrices
+*
+ DO 90 JC = 1, N
+ DO 80 JR = 1, N
+ A( JR, JC ) = RMAGN( KAMAGN( JTYPE ) )*
+ $ DLARND( 2, ISEED )
+ B( JR, JC ) = RMAGN( KBMAGN( JTYPE ) )*
+ $ DLARND( 2, ISEED )
+ 80 CONTINUE
+ 90 CONTINUE
+ END IF
+*
+ ANORM = DLANGE( '1', N, N, A, LDA, WORK )
+ BNORM = DLANGE( '1', N, N, B, LDA, WORK )
+*
+ 100 CONTINUE
+*
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUNIT, FMT = 9999 )'Generator', IINFO, N, JTYPE,
+ $ IOLDSD
+ INFO = ABS( IINFO )
+ RETURN
+ END IF
+*
+ 110 CONTINUE
+*
+* Call DGEQR2, DORM2R, and DGGHRD to compute H, T, U, and V
+*
+ CALL DLACPY( ' ', N, N, A, LDA, H, LDA )
+ CALL DLACPY( ' ', N, N, B, LDA, T, LDA )
+ NTEST = 1
+ RESULT( 1 ) = ULPINV
+*
+ CALL DGEQR2( N, N, T, LDA, WORK, WORK( N+1 ), IINFO )
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUNIT, FMT = 9999 )'DGEQR2', IINFO, N, JTYPE,
+ $ IOLDSD
+ INFO = ABS( IINFO )
+ GO TO 210
+ END IF
+*
+ CALL DORM2R( 'L', 'T', N, N, N, T, LDA, WORK, H, LDA,
+ $ WORK( N+1 ), IINFO )
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUNIT, FMT = 9999 )'DORM2R', IINFO, N, JTYPE,
+ $ IOLDSD
+ INFO = ABS( IINFO )
+ GO TO 210
+ END IF
+*
+ CALL DLASET( 'Full', N, N, ZERO, ONE, U, LDU )
+ CALL DORM2R( 'R', 'N', N, N, N, T, LDA, WORK, U, LDU,
+ $ WORK( N+1 ), IINFO )
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUNIT, FMT = 9999 )'DORM2R', IINFO, N, JTYPE,
+ $ IOLDSD
+ INFO = ABS( IINFO )
+ GO TO 210
+ END IF
+*
+ CALL DGGHRD( 'V', 'I', N, 1, N, H, LDA, T, LDA, U, LDU, V,
+ $ LDU, IINFO )
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUNIT, FMT = 9999 )'DGGHRD', IINFO, N, JTYPE,
+ $ IOLDSD
+ INFO = ABS( IINFO )
+ GO TO 210
+ END IF
+ NTEST = 4
+*
+* Do tests 1--4
+*
+ CALL DGET51( 1, N, A, LDA, H, LDA, U, LDU, V, LDU, WORK,
+ $ RESULT( 1 ) )
+ CALL DGET51( 1, N, B, LDA, T, LDA, U, LDU, V, LDU, WORK,
+ $ RESULT( 2 ) )
+ CALL DGET51( 3, N, B, LDA, T, LDA, U, LDU, U, LDU, WORK,
+ $ RESULT( 3 ) )
+ CALL DGET51( 3, N, B, LDA, T, LDA, V, LDU, V, LDU, WORK,
+ $ RESULT( 4 ) )
+*
+* Call DHGEQZ to compute S1, P1, S2, P2, Q, and Z, do tests.
+*
+* Compute T1 and UZ
+*
+* Eigenvalues only
+*
+ CALL DLACPY( ' ', N, N, H, LDA, S2, LDA )
+ CALL DLACPY( ' ', N, N, T, LDA, P2, LDA )
+ NTEST = 5
+ RESULT( 5 ) = ULPINV
+*
+ CALL DHGEQZ( 'E', 'N', 'N', N, 1, N, S2, LDA, P2, LDA,
+ $ ALPHR3, ALPHI3, BETA3, Q, LDU, Z, LDU, WORK,
+ $ LWORK, IINFO )
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUNIT, FMT = 9999 )'DHGEQZ(E)', IINFO, N, JTYPE,
+ $ IOLDSD
+ INFO = ABS( IINFO )
+ GO TO 210
+ END IF
+*
+* Eigenvalues and Full Schur Form
+*
+ CALL DLACPY( ' ', N, N, H, LDA, S2, LDA )
+ CALL DLACPY( ' ', N, N, T, LDA, P2, LDA )
+*
+ CALL DHGEQZ( 'S', 'N', 'N', N, 1, N, S2, LDA, P2, LDA,
+ $ ALPHR1, ALPHI1, BETA1, Q, LDU, Z, LDU, WORK,
+ $ LWORK, IINFO )
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUNIT, FMT = 9999 )'DHGEQZ(S)', IINFO, N, JTYPE,
+ $ IOLDSD
+ INFO = ABS( IINFO )
+ GO TO 210
+ END IF
+*
+* Eigenvalues, Schur Form, and Schur Vectors
+*
+ CALL DLACPY( ' ', N, N, H, LDA, S1, LDA )
+ CALL DLACPY( ' ', N, N, T, LDA, P1, LDA )
+*
+ CALL DHGEQZ( 'S', 'I', 'I', N, 1, N, S1, LDA, P1, LDA,
+ $ ALPHR1, ALPHI1, BETA1, Q, LDU, Z, LDU, WORK,
+ $ LWORK, IINFO )
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUNIT, FMT = 9999 )'DHGEQZ(V)', IINFO, N, JTYPE,
+ $ IOLDSD
+ INFO = ABS( IINFO )
+ GO TO 210
+ END IF
+*
+ NTEST = 8
+*
+* Do Tests 5--8
+*
+ CALL DGET51( 1, N, H, LDA, S1, LDA, Q, LDU, Z, LDU, WORK,
+ $ RESULT( 5 ) )
+ CALL DGET51( 1, N, T, LDA, P1, LDA, Q, LDU, Z, LDU, WORK,
+ $ RESULT( 6 ) )
+ CALL DGET51( 3, N, T, LDA, P1, LDA, Q, LDU, Q, LDU, WORK,
+ $ RESULT( 7 ) )
+ CALL DGET51( 3, N, T, LDA, P1, LDA, Z, LDU, Z, LDU, WORK,
+ $ RESULT( 8 ) )
+*
+* Compute the Left and Right Eigenvectors of (S1,P1)
+*
+* 9: Compute the left eigenvector Matrix without
+* back transforming:
+*
+ NTEST = 9
+ RESULT( 9 ) = ULPINV
+*
+* To test "SELECT" option, compute half of the eigenvectors
+* in one call, and half in another
+*
+ I1 = N / 2
+ DO 120 J = 1, I1
+ LLWORK( J ) = .TRUE.
+ 120 CONTINUE
+ DO 130 J = I1 + 1, N
+ LLWORK( J ) = .FALSE.
+ 130 CONTINUE
+*
+ CALL DTGEVC( 'L', 'S', LLWORK, N, S1, LDA, P1, LDA, EVECTL,
+ $ LDU, DUMMA, LDU, N, IN, WORK, IINFO )
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUNIT, FMT = 9999 )'DTGEVC(L,S1)', IINFO, N,
+ $ JTYPE, IOLDSD
+ INFO = ABS( IINFO )
+ GO TO 210
+ END IF
+*
+ I1 = IN
+ DO 140 J = 1, I1
+ LLWORK( J ) = .FALSE.
+ 140 CONTINUE
+ DO 150 J = I1 + 1, N
+ LLWORK( J ) = .TRUE.
+ 150 CONTINUE
+*
+ CALL DTGEVC( 'L', 'S', LLWORK, N, S1, LDA, P1, LDA,
+ $ EVECTL( 1, I1+1 ), LDU, DUMMA, LDU, N, IN,
+ $ WORK, IINFO )
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUNIT, FMT = 9999 )'DTGEVC(L,S2)', IINFO, N,
+ $ JTYPE, IOLDSD
+ INFO = ABS( IINFO )
+ GO TO 210
+ END IF
+*
+ CALL DGET52( .TRUE., N, S1, LDA, P1, LDA, EVECTL, LDU,
+ $ ALPHR1, ALPHI1, BETA1, WORK, DUMMA( 1 ) )
+ RESULT( 9 ) = DUMMA( 1 )
+ IF( DUMMA( 2 ).GT.THRSHN ) THEN
+ WRITE( NOUNIT, FMT = 9998 )'Left', 'DTGEVC(HOWMNY=S)',
+ $ DUMMA( 2 ), N, JTYPE, IOLDSD
+ END IF
+*
+* 10: Compute the left eigenvector Matrix with
+* back transforming:
+*
+ NTEST = 10
+ RESULT( 10 ) = ULPINV
+ CALL DLACPY( 'F', N, N, Q, LDU, EVECTL, LDU )
+ CALL DTGEVC( 'L', 'B', LLWORK, N, S1, LDA, P1, LDA, EVECTL,
+ $ LDU, DUMMA, LDU, N, IN, WORK, IINFO )
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUNIT, FMT = 9999 )'DTGEVC(L,B)', IINFO, N,
+ $ JTYPE, IOLDSD
+ INFO = ABS( IINFO )
+ GO TO 210
+ END IF
+*
+ CALL DGET52( .TRUE., N, H, LDA, T, LDA, EVECTL, LDU, ALPHR1,
+ $ ALPHI1, BETA1, WORK, DUMMA( 1 ) )
+ RESULT( 10 ) = DUMMA( 1 )
+ IF( DUMMA( 2 ).GT.THRSHN ) THEN
+ WRITE( NOUNIT, FMT = 9998 )'Left', 'DTGEVC(HOWMNY=B)',
+ $ DUMMA( 2 ), N, JTYPE, IOLDSD
+ END IF
+*
+* 11: Compute the right eigenvector Matrix without
+* back transforming:
+*
+ NTEST = 11
+ RESULT( 11 ) = ULPINV
+*
+* To test "SELECT" option, compute half of the eigenvectors
+* in one call, and half in another
+*
+ I1 = N / 2
+ DO 160 J = 1, I1
+ LLWORK( J ) = .TRUE.
+ 160 CONTINUE
+ DO 170 J = I1 + 1, N
+ LLWORK( J ) = .FALSE.
+ 170 CONTINUE
+*
+ CALL DTGEVC( 'R', 'S', LLWORK, N, S1, LDA, P1, LDA, DUMMA,
+ $ LDU, EVECTR, LDU, N, IN, WORK, IINFO )
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUNIT, FMT = 9999 )'DTGEVC(R,S1)', IINFO, N,
+ $ JTYPE, IOLDSD
+ INFO = ABS( IINFO )
+ GO TO 210
+ END IF
+*
+ I1 = IN
+ DO 180 J = 1, I1
+ LLWORK( J ) = .FALSE.
+ 180 CONTINUE
+ DO 190 J = I1 + 1, N
+ LLWORK( J ) = .TRUE.
+ 190 CONTINUE
+*
+ CALL DTGEVC( 'R', 'S', LLWORK, N, S1, LDA, P1, LDA, DUMMA,
+ $ LDU, EVECTR( 1, I1+1 ), LDU, N, IN, WORK,
+ $ IINFO )
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUNIT, FMT = 9999 )'DTGEVC(R,S2)', IINFO, N,
+ $ JTYPE, IOLDSD
+ INFO = ABS( IINFO )
+ GO TO 210
+ END IF
+*
+ CALL DGET52( .FALSE., N, S1, LDA, P1, LDA, EVECTR, LDU,
+ $ ALPHR1, ALPHI1, BETA1, WORK, DUMMA( 1 ) )
+ RESULT( 11 ) = DUMMA( 1 )
+ IF( DUMMA( 2 ).GT.THRESH ) THEN
+ WRITE( NOUNIT, FMT = 9998 )'Right', 'DTGEVC(HOWMNY=S)',
+ $ DUMMA( 2 ), N, JTYPE, IOLDSD
+ END IF
+*
+* 12: Compute the right eigenvector Matrix with
+* back transforming:
+*
+ NTEST = 12
+ RESULT( 12 ) = ULPINV
+ CALL DLACPY( 'F', N, N, Z, LDU, EVECTR, LDU )
+ CALL DTGEVC( 'R', 'B', LLWORK, N, S1, LDA, P1, LDA, DUMMA,
+ $ LDU, EVECTR, LDU, N, IN, WORK, IINFO )
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUNIT, FMT = 9999 )'DTGEVC(R,B)', IINFO, N,
+ $ JTYPE, IOLDSD
+ INFO = ABS( IINFO )
+ GO TO 210
+ END IF
+*
+ CALL DGET52( .FALSE., N, H, LDA, T, LDA, EVECTR, LDU,
+ $ ALPHR1, ALPHI1, BETA1, WORK, DUMMA( 1 ) )
+ RESULT( 12 ) = DUMMA( 1 )
+ IF( DUMMA( 2 ).GT.THRESH ) THEN
+ WRITE( NOUNIT, FMT = 9998 )'Right', 'DTGEVC(HOWMNY=B)',
+ $ DUMMA( 2 ), N, JTYPE, IOLDSD
+ END IF
+*
+* Tests 13--15 are done only on request
+*
+ IF( TSTDIF ) THEN
+*
+* Do Tests 13--14
+*
+ CALL DGET51( 2, N, S1, LDA, S2, LDA, Q, LDU, Z, LDU,
+ $ WORK, RESULT( 13 ) )
+ CALL DGET51( 2, N, P1, LDA, P2, LDA, Q, LDU, Z, LDU,
+ $ WORK, RESULT( 14 ) )
+*
+* Do Test 15
+*
+ TEMP1 = ZERO
+ TEMP2 = ZERO
+ DO 200 J = 1, N
+ TEMP1 = MAX( TEMP1, ABS( ALPHR1( J )-ALPHR3( J ) )+
+ $ ABS( ALPHI1( J )-ALPHI3( J ) ) )
+ TEMP2 = MAX( TEMP2, ABS( BETA1( J )-BETA3( J ) ) )
+ 200 CONTINUE
+*
+ TEMP1 = TEMP1 / MAX( SAFMIN, ULP*MAX( TEMP1, ANORM ) )
+ TEMP2 = TEMP2 / MAX( SAFMIN, ULP*MAX( TEMP2, BNORM ) )
+ RESULT( 15 ) = MAX( TEMP1, TEMP2 )
+ NTEST = 15
+ ELSE
+ RESULT( 13 ) = ZERO
+ RESULT( 14 ) = ZERO
+ RESULT( 15 ) = ZERO
+ NTEST = 12
+ END IF
+*
+* End of Loop -- Check for RESULT(j) > THRESH
+*
+ 210 CONTINUE
+*
+ NTESTT = NTESTT + NTEST
+*
+* Print out tests which fail.
+*
+ DO 220 JR = 1, NTEST
+ IF( RESULT( JR ).GE.THRESH ) THEN
+*
+* If this is the first test to fail,
+* print a header to the data file.
+*
+ IF( NERRS.EQ.0 ) THEN
+ WRITE( NOUNIT, FMT = 9997 )'DGG'
+*
+* Matrix types
+*
+ WRITE( NOUNIT, FMT = 9996 )
+ WRITE( NOUNIT, FMT = 9995 )
+ WRITE( NOUNIT, FMT = 9994 )'Orthogonal'
+*
+* Tests performed
+*
+ WRITE( NOUNIT, FMT = 9993 )'orthogonal', '''',
+ $ 'transpose', ( '''', J = 1, 10 )
+*
+ END IF
+ NERRS = NERRS + 1
+ IF( RESULT( JR ).LT.10000.0D0 ) THEN
+ WRITE( NOUNIT, FMT = 9992 )N, JTYPE, IOLDSD, JR,
+ $ RESULT( JR )
+ ELSE
+ WRITE( NOUNIT, FMT = 9991 )N, JTYPE, IOLDSD, JR,
+ $ RESULT( JR )
+ END IF
+ END IF
+ 220 CONTINUE
+*
+ 230 CONTINUE
+ 240 CONTINUE
+*
+* Summary
+*
+ CALL DLASUM( 'DGG', NOUNIT, NERRS, NTESTT )
+ RETURN
+*
+ 9999 FORMAT( ' DCHKGG: ', A, ' returned INFO=', I6, '.', / 9X, 'N=',
+ $ I6, ', JTYPE=', I6, ', ISEED=(', 3( I5, ',' ), I5, ')' )
+*
+ 9998 FORMAT( ' DCHKGG: ', A, ' Eigenvectors from ', A, ' incorrectly ',
+ $ 'normalized.', / ' Bits of error=', 0P, G10.3, ',', 9X,
+ $ 'N=', I6, ', JTYPE=', I6, ', ISEED=(', 3( I5, ',' ), I5,
+ $ ')' )
+*
+ 9997 FORMAT( / 1X, A3, ' -- Real Generalized eigenvalue problem' )
+*
+ 9996 FORMAT( ' Matrix types (see DCHKGG for details): ' )
+*
+ 9995 FORMAT( ' Special Matrices:', 23X,
+ $ '(J''=transposed Jordan block)',
+ $ / ' 1=(0,0) 2=(I,0) 3=(0,I) 4=(I,I) 5=(J'',J'') ',
+ $ '6=(diag(J'',I), diag(I,J''))', / ' Diagonal Matrices: ( ',
+ $ 'D=diag(0,1,2,...) )', / ' 7=(D,I) 9=(large*D, small*I',
+ $ ') 11=(large*I, small*D) 13=(large*D, large*I)', /
+ $ ' 8=(I,D) 10=(small*D, large*I) 12=(small*I, large*D) ',
+ $ ' 14=(small*D, small*I)', / ' 15=(D, reversed D)' )
+ 9994 FORMAT( ' Matrices Rotated by Random ', A, ' Matrices U, V:',
+ $ / ' 16=Transposed Jordan Blocks 19=geometric ',
+ $ 'alpha, beta=0,1', / ' 17=arithm. alpha&beta ',
+ $ ' 20=arithmetic alpha, beta=0,1', / ' 18=clustered ',
+ $ 'alpha, beta=0,1 21=random alpha, beta=0,1',
+ $ / ' Large & Small Matrices:', / ' 22=(large, small) ',
+ $ '23=(small,large) 24=(small,small) 25=(large,large)',
+ $ / ' 26=random O(1) matrices.' )
+*
+ 9993 FORMAT( / ' Tests performed: (H is Hessenberg, S is Schur, B, ',
+ $ 'T, P are triangular,', / 20X, 'U, V, Q, and Z are ', A,
+ $ ', l and r are the', / 20X,
+ $ 'appropriate left and right eigenvectors, resp., a is',
+ $ / 20X, 'alpha, b is beta, and ', A, ' means ', A, '.)',
+ $ / ' 1 = | A - U H V', A,
+ $ ' | / ( |A| n ulp ) 2 = | B - U T V', A,
+ $ ' | / ( |B| n ulp )', / ' 3 = | I - UU', A,
+ $ ' | / ( n ulp ) 4 = | I - VV', A,
+ $ ' | / ( n ulp )', / ' 5 = | H - Q S Z', A,
+ $ ' | / ( |H| n ulp )', 6X, '6 = | T - Q P Z', A,
+ $ ' | / ( |T| n ulp )', / ' 7 = | I - QQ', A,
+ $ ' | / ( n ulp ) 8 = | I - ZZ', A,
+ $ ' | / ( n ulp )', / ' 9 = max | ( b S - a P )', A,
+ $ ' l | / const. 10 = max | ( b H - a T )', A,
+ $ ' l | / const.', /
+ $ ' 11= max | ( b S - a P ) r | / const. 12 = max | ( b H',
+ $ ' - a T ) r | / const.', / 1X )
+*
+ 9992 FORMAT( ' Matrix order=', I5, ', type=', I2, ', seed=',
+ $ 4( I4, ',' ), ' result ', I2, ' is', 0P, F8.2 )
+ 9991 FORMAT( ' Matrix order=', I5, ', type=', I2, ', seed=',
+ $ 4( I4, ',' ), ' result ', I2, ' is', 1P, D10.3 )
+*
+* End of DCHKGG
+*
+ END
+ SUBROUTINE DCHKGK( NIN, NOUT )
+*
+* -- LAPACK test routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER NIN, NOUT
+* ..
+*
+* Purpose
+* =======
+*
+* DCHKGK tests DGGBAK, a routine for backward balancing of
+* a matrix pair (A, B).
+*
+* Arguments
+* =========
+*
+* NIN (input) INTEGER
+* The logical unit number for input. NIN > 0.
+*
+* NOUT (input) INTEGER
+* The logical unit number for output. NOUT > 0.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ INTEGER LDA, LDB, LDVL, LDVR
+ PARAMETER ( LDA = 50, LDB = 50, LDVL = 50, LDVR = 50 )
+ INTEGER LDE, LDF, LDWORK
+ PARAMETER ( LDE = 50, LDF = 50, LDWORK = 50 )
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, IHI, ILO, INFO, J, KNT, M, N, NINFO
+ DOUBLE PRECISION ANORM, BNORM, EPS, RMAX, VMAX
+* ..
+* .. Local Arrays ..
+ INTEGER LMAX( 4 )
+ DOUBLE PRECISION A( LDA, LDA ), AF( LDA, LDA ), B( LDB, LDB ),
+ $ BF( LDB, LDB ), E( LDE, LDE ), F( LDF, LDF ),
+ $ LSCALE( LDA ), RSCALE( LDA ), VL( LDVL, LDVL ),
+ $ VLF( LDVL, LDVL ), VR( LDVR, LDVR ),
+ $ VRF( LDVR, LDVR ), WORK( LDWORK, LDWORK )
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DLAMCH, DLANGE
+ EXTERNAL DLAMCH, DLANGE
+* ..
+* .. External Subroutines ..
+ EXTERNAL DGEMM, DGGBAK, DGGBAL, DLACPY
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX
+* ..
+* .. Executable Statements ..
+*
+* Initialization
+*
+ LMAX( 1 ) = 0
+ LMAX( 2 ) = 0
+ LMAX( 3 ) = 0
+ LMAX( 4 ) = 0
+ NINFO = 0
+ KNT = 0
+ RMAX = ZERO
+*
+ EPS = DLAMCH( 'Precision' )
+*
+ 10 CONTINUE
+ READ( NIN, FMT = * )N, M
+ IF( N.EQ.0 )
+ $ GO TO 100
+*
+ DO 20 I = 1, N
+ READ( NIN, FMT = * )( A( I, J ), J = 1, N )
+ 20 CONTINUE
+*
+ DO 30 I = 1, N
+ READ( NIN, FMT = * )( B( I, J ), J = 1, N )
+ 30 CONTINUE
+*
+ DO 40 I = 1, N
+ READ( NIN, FMT = * )( VL( I, J ), J = 1, M )
+ 40 CONTINUE
+*
+ DO 50 I = 1, N
+ READ( NIN, FMT = * )( VR( I, J ), J = 1, M )
+ 50 CONTINUE
+*
+ KNT = KNT + 1
+*
+ ANORM = DLANGE( 'M', N, N, A, LDA, WORK )
+ BNORM = DLANGE( 'M', N, N, B, LDB, WORK )
+*
+ CALL DLACPY( 'FULL', N, N, A, LDA, AF, LDA )
+ CALL DLACPY( 'FULL', N, N, B, LDB, BF, LDB )
+*
+ CALL DGGBAL( 'B', N, A, LDA, B, LDB, ILO, IHI, LSCALE, RSCALE,
+ $ WORK, INFO )
+ IF( INFO.NE.0 ) THEN
+ NINFO = NINFO + 1
+ LMAX( 1 ) = KNT
+ END IF
+*
+ CALL DLACPY( 'FULL', N, M, VL, LDVL, VLF, LDVL )
+ CALL DLACPY( 'FULL', N, M, VR, LDVR, VRF, LDVR )
+*
+ CALL DGGBAK( 'B', 'L', N, ILO, IHI, LSCALE, RSCALE, M, VL, LDVL,
+ $ INFO )
+ IF( INFO.NE.0 ) THEN
+ NINFO = NINFO + 1
+ LMAX( 2 ) = KNT
+ END IF
+*
+ CALL DGGBAK( 'B', 'R', N, ILO, IHI, LSCALE, RSCALE, M, VR, LDVR,
+ $ INFO )
+ IF( INFO.NE.0 ) THEN
+ NINFO = NINFO + 1
+ LMAX( 3 ) = KNT
+ END IF
+*
+* Test of DGGBAK
+*
+* Check tilde(VL)'*A*tilde(VR) - VL'*tilde(A)*VR
+* where tilde(A) denotes the transformed matrix.
+*
+ CALL DGEMM( 'N', 'N', N, M, N, ONE, AF, LDA, VR, LDVR, ZERO, WORK,
+ $ LDWORK )
+ CALL DGEMM( 'T', 'N', M, M, N, ONE, VL, LDVL, WORK, LDWORK, ZERO,
+ $ E, LDE )
+*
+ CALL DGEMM( 'N', 'N', N, M, N, ONE, A, LDA, VRF, LDVR, ZERO, WORK,
+ $ LDWORK )
+ CALL DGEMM( 'T', 'N', M, M, N, ONE, VLF, LDVL, WORK, LDWORK, ZERO,
+ $ F, LDF )
+*
+ VMAX = ZERO
+ DO 70 J = 1, M
+ DO 60 I = 1, M
+ VMAX = MAX( VMAX, ABS( E( I, J )-F( I, J ) ) )
+ 60 CONTINUE
+ 70 CONTINUE
+ VMAX = VMAX / ( EPS*MAX( ANORM, BNORM ) )
+ IF( VMAX.GT.RMAX ) THEN
+ LMAX( 4 ) = KNT
+ RMAX = VMAX
+ END IF
+*
+* Check tilde(VL)'*B*tilde(VR) - VL'*tilde(B)*VR
+*
+ CALL DGEMM( 'N', 'N', N, M, N, ONE, BF, LDB, VR, LDVR, ZERO, WORK,
+ $ LDWORK )
+ CALL DGEMM( 'T', 'N', M, M, N, ONE, VL, LDVL, WORK, LDWORK, ZERO,
+ $ E, LDE )
+*
+ CALL DGEMM( 'N', 'N', N, M, N, ONE, B, LDB, VRF, LDVR, ZERO, WORK,
+ $ LDWORK )
+ CALL DGEMM( 'T', 'N', M, M, N, ONE, VLF, LDVL, WORK, LDWORK, ZERO,
+ $ F, LDF )
+*
+ VMAX = ZERO
+ DO 90 J = 1, M
+ DO 80 I = 1, M
+ VMAX = MAX( VMAX, ABS( E( I, J )-F( I, J ) ) )
+ 80 CONTINUE
+ 90 CONTINUE
+ VMAX = VMAX / ( EPS*MAX( ANORM, BNORM ) )
+ IF( VMAX.GT.RMAX ) THEN
+ LMAX( 4 ) = KNT
+ RMAX = VMAX
+ END IF
+*
+ GO TO 10
+*
+ 100 CONTINUE
+*
+ WRITE( NOUT, FMT = 9999 )
+ 9999 FORMAT( 1X, '.. test output of DGGBAK .. ' )
+*
+ WRITE( NOUT, FMT = 9998 )RMAX
+ 9998 FORMAT( ' value of largest test error =', D12.3 )
+ WRITE( NOUT, FMT = 9997 )LMAX( 1 )
+ 9997 FORMAT( ' example number where DGGBAL info is not 0 =', I4 )
+ WRITE( NOUT, FMT = 9996 )LMAX( 2 )
+ 9996 FORMAT( ' example number where DGGBAK(L) info is not 0 =', I4 )
+ WRITE( NOUT, FMT = 9995 )LMAX( 3 )
+ 9995 FORMAT( ' example number where DGGBAK(R) info is not 0 =', I4 )
+ WRITE( NOUT, FMT = 9994 )LMAX( 4 )
+ 9994 FORMAT( ' example number having largest error =', I4 )
+ WRITE( NOUT, FMT = 9993 )NINFO
+ 9993 FORMAT( ' number of examples where info is not 0 =', I4 )
+ WRITE( NOUT, FMT = 9992 )KNT
+ 9992 FORMAT( ' total number of examples tested =', I4 )
+*
+ RETURN
+*
+* End of DCHKGK
+*
+ END
+ SUBROUTINE DCHKGL( NIN, NOUT )
+*
+* -- LAPACK test routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER NIN, NOUT
+* ..
+*
+* Purpose
+* =======
+*
+* DCHKGL tests DGGBAL, a routine for balancing a matrix pair (A, B).
+*
+* Arguments
+* =========
+*
+* NIN (input) INTEGER
+* The logical unit number for input. NIN > 0.
+*
+* NOUT (input) INTEGER
+* The logical unit number for output. NOUT > 0.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ INTEGER LDA, LDB, LWORK
+ PARAMETER ( LDA = 20, LDB = 20, LWORK = 6*LDA )
+ DOUBLE PRECISION ZERO
+ PARAMETER ( ZERO = 0.0D+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, IHI, IHIIN, ILO, ILOIN, INFO, J, KNT, N,
+ $ NINFO
+ DOUBLE PRECISION ANORM, BNORM, EPS, RMAX, VMAX
+* ..
+* .. Local Arrays ..
+ INTEGER LMAX( 5 )
+ DOUBLE PRECISION A( LDA, LDA ), AIN( LDA, LDA ), B( LDB, LDB ),
+ $ BIN( LDB, LDB ), LSCALE( LDA ), LSCLIN( LDA ),
+ $ RSCALE( LDA ), RSCLIN( LDA ), WORK( LWORK )
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DLAMCH, DLANGE
+ EXTERNAL DLAMCH, DLANGE
+* ..
+* .. External Subroutines ..
+ EXTERNAL DGGBAL
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX
+* ..
+* .. Executable Statements ..
+*
+ LMAX( 1 ) = 0
+ LMAX( 2 ) = 0
+ LMAX( 3 ) = 0
+ NINFO = 0
+ KNT = 0
+ RMAX = ZERO
+*
+ EPS = DLAMCH( 'Precision' )
+*
+ 10 CONTINUE
+*
+ READ( NIN, FMT = * )N
+ IF( N.EQ.0 )
+ $ GO TO 90
+ DO 20 I = 1, N
+ READ( NIN, FMT = * )( A( I, J ), J = 1, N )
+ 20 CONTINUE
+*
+ DO 30 I = 1, N
+ READ( NIN, FMT = * )( B( I, J ), J = 1, N )
+ 30 CONTINUE
+*
+ READ( NIN, FMT = * )ILOIN, IHIIN
+ DO 40 I = 1, N
+ READ( NIN, FMT = * )( AIN( I, J ), J = 1, N )
+ 40 CONTINUE
+ DO 50 I = 1, N
+ READ( NIN, FMT = * )( BIN( I, J ), J = 1, N )
+ 50 CONTINUE
+*
+ READ( NIN, FMT = * )( LSCLIN( I ), I = 1, N )
+ READ( NIN, FMT = * )( RSCLIN( I ), I = 1, N )
+*
+ ANORM = DLANGE( 'M', N, N, A, LDA, WORK )
+ BNORM = DLANGE( 'M', N, N, B, LDB, WORK )
+*
+ KNT = KNT + 1
+*
+ CALL DGGBAL( 'B', N, A, LDA, B, LDB, ILO, IHI, LSCALE, RSCALE,
+ $ WORK, INFO )
+*
+ IF( INFO.NE.0 ) THEN
+ NINFO = NINFO + 1
+ LMAX( 1 ) = KNT
+ END IF
+*
+ IF( ILO.NE.ILOIN .OR. IHI.NE.IHIIN ) THEN
+ NINFO = NINFO + 1
+ LMAX( 2 ) = KNT
+ END IF
+*
+ VMAX = ZERO
+ DO 70 I = 1, N
+ DO 60 J = 1, N
+ VMAX = MAX( VMAX, ABS( A( I, J )-AIN( I, J ) ) )
+ VMAX = MAX( VMAX, ABS( B( I, J )-BIN( I, J ) ) )
+ 60 CONTINUE
+ 70 CONTINUE
+*
+ DO 80 I = 1, N
+ VMAX = MAX( VMAX, ABS( LSCALE( I )-LSCLIN( I ) ) )
+ VMAX = MAX( VMAX, ABS( RSCALE( I )-RSCLIN( I ) ) )
+ 80 CONTINUE
+*
+ VMAX = VMAX / ( EPS*MAX( ANORM, BNORM ) )
+*
+ IF( VMAX.GT.RMAX ) THEN
+ LMAX( 3 ) = KNT
+ RMAX = VMAX
+ END IF
+*
+ GO TO 10
+*
+ 90 CONTINUE
+*
+ WRITE( NOUT, FMT = 9999 )
+ 9999 FORMAT( 1X, '.. test output of DGGBAL .. ' )
+*
+ WRITE( NOUT, FMT = 9998 )RMAX
+ 9998 FORMAT( 1X, 'value of largest test error = ', D12.3 )
+ WRITE( NOUT, FMT = 9997 )LMAX( 1 )
+ 9997 FORMAT( 1X, 'example number where info is not zero = ', I4 )
+ WRITE( NOUT, FMT = 9996 )LMAX( 2 )
+ 9996 FORMAT( 1X, 'example number where ILO or IHI wrong = ', I4 )
+ WRITE( NOUT, FMT = 9995 )LMAX( 3 )
+ 9995 FORMAT( 1X, 'example number having largest error = ', I4 )
+ WRITE( NOUT, FMT = 9994 )NINFO
+ 9994 FORMAT( 1X, 'number of examples where info is not 0 = ', I4 )
+ WRITE( NOUT, FMT = 9993 )KNT
+ 9993 FORMAT( 1X, 'total number of examples tested = ', I4 )
+*
+ RETURN
+*
+* End of DCHKGL
+*
+ END
+ SUBROUTINE DCHKHS( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH,
+ $ NOUNIT, A, LDA, H, T1, T2, U, LDU, Z, UZ, WR1,
+ $ WI1, WR3, WI3, EVECTL, EVECTR, EVECTY, EVECTX,
+ $ UU, TAU, WORK, NWORK, IWORK, SELECT, RESULT,
+ $ INFO )
+*
+* -- LAPACK test routine (version 3.1.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* February 2007
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LDA, LDU, NOUNIT, NSIZES, NTYPES, NWORK
+ DOUBLE PRECISION THRESH
+* ..
+* .. Array Arguments ..
+ LOGICAL DOTYPE( * ), SELECT( * )
+ INTEGER ISEED( 4 ), IWORK( * ), NN( * )
+ DOUBLE PRECISION A( LDA, * ), EVECTL( LDU, * ),
+ $ EVECTR( LDU, * ), EVECTX( LDU, * ),
+ $ EVECTY( LDU, * ), H( LDA, * ), RESULT( 14 ),
+ $ T1( LDA, * ), T2( LDA, * ), TAU( * ),
+ $ U( LDU, * ), UU( LDU, * ), UZ( LDU, * ),
+ $ WI1( * ), WI3( * ), WORK( * ), WR1( * ),
+ $ WR3( * ), Z( LDU, * )
+* ..
+*
+* Purpose
+* =======
+*
+* DCHKHS checks the nonsymmetric eigenvalue problem routines.
+*
+* DGEHRD factors A as U H U' , where ' means transpose,
+* H is hessenberg, and U is an orthogonal matrix.
+*
+* DORGHR generates the orthogonal matrix U.
+*
+* DORMHR multiplies a matrix by the orthogonal matrix U.
+*
+* DHSEQR factors H as Z T Z' , where Z is orthogonal and
+* T is "quasi-triangular", and the eigenvalue vector W.
+*
+* DTREVC computes the left and right eigenvector matrices
+* L and R for T.
+*
+* DHSEIN computes the left and right eigenvector matrices
+* Y and X for H, using inverse iteration.
+*
+* When DCHKHS is called, a number of matrix "sizes" ("n's") and a
+* number of matrix "types" are specified. For each size ("n")
+* and each type of matrix, one matrix will be generated and used
+* to test the nonsymmetric eigenroutines. For each matrix, 14
+* tests will be performed:
+*
+* (1) | A - U H U**T | / ( |A| n ulp )
+*
+* (2) | I - UU**T | / ( n ulp )
+*
+* (3) | H - Z T Z**T | / ( |H| n ulp )
+*
+* (4) | I - ZZ**T | / ( n ulp )
+*
+* (5) | A - UZ H (UZ)**T | / ( |A| n ulp )
+*
+* (6) | I - UZ (UZ)**T | / ( n ulp )
+*
+* (7) | T(Z computed) - T(Z not computed) | / ( |T| ulp )
+*
+* (8) | W(Z computed) - W(Z not computed) | / ( |W| ulp )
+*
+* (9) | TR - RW | / ( |T| |R| ulp )
+*
+* (10) | L**H T - W**H L | / ( |T| |L| ulp )
+*
+* (11) | HX - XW | / ( |H| |X| ulp )
+*
+* (12) | Y**H H - W**H Y | / ( |H| |Y| ulp )
+*
+* (13) | AX - XW | / ( |A| |X| ulp )
+*
+* (14) | Y**H A - W**H Y | / ( |A| |Y| ulp )
+*
+* The "sizes" are specified by an array NN(1:NSIZES); the value of
+* each element NN(j) specifies one size.
+* The "types" are specified by a logical array DOTYPE( 1:NTYPES );
+* if DOTYPE(j) is .TRUE., then matrix type "j" will be generated.
+* Currently, the list of possible types is:
+*
+* (1) The zero matrix.
+* (2) The identity matrix.
+* (3) A (transposed) Jordan block, with 1's on the diagonal.
+*
+* (4) A diagonal matrix with evenly spaced entries
+* 1, ..., ULP and random signs.
+* (ULP = (first number larger than 1) - 1 )
+* (5) A diagonal matrix with geometrically spaced entries
+* 1, ..., ULP and random signs.
+* (6) A diagonal matrix with "clustered" entries 1, ULP, ..., ULP
+* and random signs.
+*
+* (7) Same as (4), but multiplied by SQRT( overflow threshold )
+* (8) Same as (4), but multiplied by SQRT( underflow threshold )
+*
+* (9) A matrix of the form U' T U, where U is orthogonal and
+* T has evenly spaced entries 1, ..., ULP with random signs
+* on the diagonal and random O(1) entries in the upper
+* triangle.
+*
+* (10) A matrix of the form U' T U, where U is orthogonal and
+* T has geometrically spaced entries 1, ..., ULP with random
+* signs on the diagonal and random O(1) entries in the upper
+* triangle.
+*
+* (11) A matrix of the form U' T U, where U is orthogonal and
+* T has "clustered" entries 1, ULP,..., ULP with random
+* signs on the diagonal and random O(1) entries in the upper
+* triangle.
+*
+* (12) A matrix of the form U' T U, where U is orthogonal and
+* T has real or complex conjugate paired eigenvalues randomly
+* chosen from ( ULP, 1 ) and random O(1) entries in the upper
+* triangle.
+*
+* (13) A matrix of the form X' T X, where X has condition
+* SQRT( ULP ) and T has evenly spaced entries 1, ..., ULP
+* with random signs on the diagonal and random O(1) entries
+* in the upper triangle.
+*
+* (14) A matrix of the form X' T X, where X has condition
+* SQRT( ULP ) and T has geometrically spaced entries
+* 1, ..., ULP with random signs on the diagonal and random
+* O(1) entries in the upper triangle.
+*
+* (15) A matrix of the form X' T X, where X has condition
+* SQRT( ULP ) and T has "clustered" entries 1, ULP,..., ULP
+* with random signs on the diagonal and random O(1) entries
+* in the upper triangle.
+*
+* (16) A matrix of the form X' T X, where X has condition
+* SQRT( ULP ) and T has real or complex conjugate paired
+* eigenvalues randomly chosen from ( ULP, 1 ) and random
+* O(1) entries in the upper triangle.
+*
+* (17) Same as (16), but multiplied by SQRT( overflow threshold )
+* (18) Same as (16), but multiplied by SQRT( underflow threshold )
+*
+* (19) Nonsymmetric matrix with random entries chosen from (-1,1).
+* (20) Same as (19), but multiplied by SQRT( overflow threshold )
+* (21) Same as (19), but multiplied by SQRT( underflow threshold )
+*
+* Arguments
+* ==========
+*
+* NSIZES - INTEGER
+* The number of sizes of matrices to use. If it is zero,
+* DCHKHS does nothing. It must be at least zero.
+* Not modified.
+*
+* NN - INTEGER array, dimension (NSIZES)
+* An array containing the sizes to be used for the matrices.
+* Zero values will be skipped. The values must be at least
+* zero.
+* Not modified.
+*
+* NTYPES - INTEGER
+* The number of elements in DOTYPE. If it is zero, DCHKHS
+* does nothing. It must be at least zero. If it is MAXTYP+1
+* and NSIZES is 1, then an additional type, MAXTYP+1 is
+* defined, which is to use whatever matrix is in A. This
+* is only useful if DOTYPE(1:MAXTYP) is .FALSE. and
+* DOTYPE(MAXTYP+1) is .TRUE. .
+* Not modified.
+*
+* DOTYPE - LOGICAL array, dimension (NTYPES)
+* If DOTYPE(j) is .TRUE., then for each size in NN a
+* matrix of that size and of type j will be generated.
+* If NTYPES is smaller than the maximum number of types
+* defined (PARAMETER MAXTYP), then types NTYPES+1 through
+* MAXTYP will not be generated. If NTYPES is larger
+* than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES)
+* will be ignored.
+* Not modified.
+*
+* ISEED - INTEGER array, dimension (4)
+* On entry ISEED specifies the seed of the random number
+* generator. The array elements should be between 0 and 4095;
+* if not they will be reduced mod 4096. Also, ISEED(4) must
+* be odd. The random number generator uses a linear
+* congruential sequence limited to small integers, and so
+* should produce machine independent random numbers. The
+* values of ISEED are changed on exit, and can be used in the
+* next call to DCHKHS to continue the same random number
+* sequence.
+* Modified.
+*
+* THRESH - DOUBLE PRECISION
+* A test will count as "failed" if the "error", computed as
+* described above, exceeds THRESH. Note that the error
+* is scaled to be O(1), so THRESH should be a reasonably
+* small multiple of 1, e.g., 10 or 100. In particular,
+* it should not depend on the precision (single vs. double)
+* or the size of the matrix. It must be at least zero.
+* Not modified.
+*
+* NOUNIT - INTEGER
+* The FORTRAN unit number for printing out error messages
+* (e.g., if a routine returns IINFO not equal to 0.)
+* Not modified.
+*
+* A - DOUBLE PRECISION array, dimension (LDA,max(NN))
+* Used to hold the matrix whose eigenvalues are to be
+* computed. On exit, A contains the last matrix actually
+* used.
+* Modified.
+*
+* LDA - INTEGER
+* The leading dimension of A, H, T1 and T2. It must be at
+* least 1 and at least max( NN ).
+* Not modified.
+*
+* H - DOUBLE PRECISION array, dimension (LDA,max(NN))
+* The upper hessenberg matrix computed by DGEHRD. On exit,
+* H contains the Hessenberg form of the matrix in A.
+* Modified.
+*
+* T1 - DOUBLE PRECISION array, dimension (LDA,max(NN))
+* The Schur (="quasi-triangular") matrix computed by DHSEQR
+* if Z is computed. On exit, T1 contains the Schur form of
+* the matrix in A.
+* Modified.
+*
+* T2 - DOUBLE PRECISION array, dimension (LDA,max(NN))
+* The Schur matrix computed by DHSEQR when Z is not computed.
+* This should be identical to T1.
+* Modified.
+*
+* LDU - INTEGER
+* The leading dimension of U, Z, UZ and UU. It must be at
+* least 1 and at least max( NN ).
+* Not modified.
+*
+* U - DOUBLE PRECISION array, dimension (LDU,max(NN))
+* The orthogonal matrix computed by DGEHRD.
+* Modified.
+*
+* Z - DOUBLE PRECISION array, dimension (LDU,max(NN))
+* The orthogonal matrix computed by DHSEQR.
+* Modified.
+*
+* UZ - DOUBLE PRECISION array, dimension (LDU,max(NN))
+* The product of U times Z.
+* Modified.
+*
+* WR1 - DOUBLE PRECISION array, dimension (max(NN))
+* WI1 - DOUBLE PRECISION array, dimension (max(NN))
+* The real and imaginary parts of the eigenvalues of A,
+* as computed when Z is computed.
+* On exit, WR1 + WI1*i are the eigenvalues of the matrix in A.
+* Modified.
+*
+* WR3 - DOUBLE PRECISION array, dimension (max(NN))
+* WI3 - DOUBLE PRECISION array, dimension (max(NN))
+* Like WR1, WI1, these arrays contain the eigenvalues of A,
+* but those computed when DHSEQR only computes the
+* eigenvalues, i.e., not the Schur vectors and no more of the
+* Schur form than is necessary for computing the
+* eigenvalues.
+* Modified.
+*
+* EVECTL - DOUBLE PRECISION array, dimension (LDU,max(NN))
+* The (upper triangular) left eigenvector matrix for the
+* matrix in T1. For complex conjugate pairs, the real part
+* is stored in one row and the imaginary part in the next.
+* Modified.
+*
+* EVEZTR - DOUBLE PRECISION array, dimension (LDU,max(NN))
+* The (upper triangular) right eigenvector matrix for the
+* matrix in T1. For complex conjugate pairs, the real part
+* is stored in one column and the imaginary part in the next.
+* Modified.
+*
+* EVECTY - DOUBLE PRECISION array, dimension (LDU,max(NN))
+* The left eigenvector matrix for the
+* matrix in H. For complex conjugate pairs, the real part
+* is stored in one row and the imaginary part in the next.
+* Modified.
+*
+* EVECTX - DOUBLE PRECISION array, dimension (LDU,max(NN))
+* The right eigenvector matrix for the
+* matrix in H. For complex conjugate pairs, the real part
+* is stored in one column and the imaginary part in the next.
+* Modified.
+*
+* UU - DOUBLE PRECISION array, dimension (LDU,max(NN))
+* Details of the orthogonal matrix computed by DGEHRD.
+* Modified.
+*
+* TAU - DOUBLE PRECISION array, dimension(max(NN))
+* Further details of the orthogonal matrix computed by DGEHRD.
+* Modified.
+*
+* WORK - DOUBLE PRECISION array, dimension (NWORK)
+* Workspace.
+* Modified.
+*
+* NWORK - INTEGER
+* The number of entries in WORK. NWORK >= 4*NN(j)*NN(j) + 2.
+*
+* IWORK - INTEGER array, dimension (max(NN))
+* Workspace.
+* Modified.
+*
+* SELECT - LOGICAL array, dimension (max(NN))
+* Workspace.
+* Modified.
+*
+* RESULT - DOUBLE PRECISION array, dimension (14)
+* The values computed by the fourteen tests described above.
+* The values are currently limited to 1/ulp, to avoid
+* overflow.
+* Modified.
+*
+* INFO - INTEGER
+* If 0, then everything ran OK.
+* -1: NSIZES < 0
+* -2: Some NN(j) < 0
+* -3: NTYPES < 0
+* -6: THRESH < 0
+* -9: LDA < 1 or LDA < NMAX, where NMAX is max( NN(j) ).
+* -14: LDU < 1 or LDU < NMAX.
+* -28: NWORK too small.
+* If DLATMR, SLATMS, or SLATME returns an error code, the
+* absolute value of it is returned.
+* If 1, then DHSEQR could not find all the shifts.
+* If 2, then the EISPACK code (for small blocks) failed.
+* If >2, then 30*N iterations were not enough to find an
+* eigenvalue or to decompose the problem.
+* Modified.
+*
+*-----------------------------------------------------------------------
+*
+* Some Local Variables and Parameters:
+* ---- ----- --------- --- ----------
+*
+* ZERO, ONE Real 0 and 1.
+* MAXTYP The number of types defined.
+* MTEST The number of tests defined: care must be taken
+* that (1) the size of RESULT, (2) the number of
+* tests actually performed, and (3) MTEST agree.
+* NTEST The number of tests performed on this matrix
+* so far. This should be less than MTEST, and
+* equal to it by the last test. It will be less
+* if any of the routines being tested indicates
+* that it could not compute the matrices that
+* would be tested.
+* NMAX Largest value in NN.
+* NMATS The number of matrices generated so far.
+* NERRS The number of tests which have exceeded THRESH
+* so far (computed by DLAFTS).
+* COND, CONDS,
+* IMODE Values to be passed to the matrix generators.
+* ANORM Norm of A; passed to matrix generators.
+*
+* OVFL, UNFL Overflow and underflow thresholds.
+* ULP, ULPINV Finest relative precision and its inverse.
+* RTOVFL, RTUNFL,
+* RTULP, RTULPI Square roots of the previous 4 values.
+*
+* The following four arrays decode JTYPE:
+* KTYPE(j) The general type (1-10) for type "j".
+* KMODE(j) The MODE value to be passed to the matrix
+* generator for type "j".
+* KMAGN(j) The order of magnitude ( O(1),
+* O(overflow^(1/2) ), O(underflow^(1/2) )
+* KCONDS(j) Selects whether CONDS is to be 1 or
+* 1/sqrt(ulp). (0 means irrelevant.)
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
+ INTEGER MAXTYP
+ PARAMETER ( MAXTYP = 21 )
+* ..
+* .. Local Scalars ..
+ LOGICAL BADNN, MATCH
+ INTEGER I, IHI, IINFO, ILO, IMODE, IN, ITYPE, J, JCOL,
+ $ JJ, JSIZE, JTYPE, K, MTYPES, N, N1, NERRS,
+ $ NMATS, NMAX, NSELC, NSELR, NTEST, NTESTT
+ DOUBLE PRECISION ANINV, ANORM, COND, CONDS, OVFL, RTOVFL, RTULP,
+ $ RTULPI, RTUNFL, TEMP1, TEMP2, ULP, ULPINV, UNFL
+* ..
+* .. Local Arrays ..
+ CHARACTER ADUMMA( 1 )
+ INTEGER IDUMMA( 1 ), IOLDSD( 4 ), KCONDS( MAXTYP ),
+ $ KMAGN( MAXTYP ), KMODE( MAXTYP ),
+ $ KTYPE( MAXTYP )
+ DOUBLE PRECISION DUMMA( 6 )
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DLAMCH
+ EXTERNAL DLAMCH
+* ..
+* .. External Subroutines ..
+ EXTERNAL DCOPY, DGEHRD, DGEMM, DGET10, DGET22, DHSEIN,
+ $ DHSEQR, DHST01, DLABAD, DLACPY, DLAFTS, DLASET,
+ $ DLASUM, DLATME, DLATMR, DLATMS, DORGHR, DORMHR,
+ $ DTREVC, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, DBLE, MAX, MIN, SQRT
+* ..
+* .. Data statements ..
+ DATA KTYPE / 1, 2, 3, 5*4, 4*6, 6*6, 3*9 /
+ DATA KMAGN / 3*1, 1, 1, 1, 2, 3, 4*1, 1, 1, 1, 1, 2,
+ $ 3, 1, 2, 3 /
+ DATA KMODE / 3*0, 4, 3, 1, 4, 4, 4, 3, 1, 5, 4, 3,
+ $ 1, 5, 5, 5, 4, 3, 1 /
+ DATA KCONDS / 3*0, 5*0, 4*1, 6*2, 3*0 /
+* ..
+* .. Executable Statements ..
+*
+* Check for errors
+*
+ NTESTT = 0
+ INFO = 0
+*
+ BADNN = .FALSE.
+ NMAX = 0
+ DO 10 J = 1, NSIZES
+ NMAX = MAX( NMAX, NN( J ) )
+ IF( NN( J ).LT.0 )
+ $ BADNN = .TRUE.
+ 10 CONTINUE
+*
+* Check for errors
+*
+ IF( NSIZES.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( BADNN ) THEN
+ INFO = -2
+ ELSE IF( NTYPES.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( THRESH.LT.ZERO ) THEN
+ INFO = -6
+ ELSE IF( LDA.LE.1 .OR. LDA.LT.NMAX ) THEN
+ INFO = -9
+ ELSE IF( LDU.LE.1 .OR. LDU.LT.NMAX ) THEN
+ INFO = -14
+ ELSE IF( 4*NMAX*NMAX+2.GT.NWORK ) THEN
+ INFO = -28
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DCHKHS', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( NSIZES.EQ.0 .OR. NTYPES.EQ.0 )
+ $ RETURN
+*
+* More important constants
+*
+ UNFL = DLAMCH( 'Safe minimum' )
+ OVFL = DLAMCH( 'Overflow' )
+ CALL DLABAD( UNFL, OVFL )
+ ULP = DLAMCH( 'Epsilon' )*DLAMCH( 'Base' )
+ ULPINV = ONE / ULP
+ RTUNFL = SQRT( UNFL )
+ RTOVFL = SQRT( OVFL )
+ RTULP = SQRT( ULP )
+ RTULPI = ONE / RTULP
+*
+* Loop over sizes, types
+*
+ NERRS = 0
+ NMATS = 0
+*
+ DO 270 JSIZE = 1, NSIZES
+ N = NN( JSIZE )
+ IF( N.EQ.0 )
+ $ GO TO 270
+ N1 = MAX( 1, N )
+ ANINV = ONE / DBLE( N1 )
+*
+ IF( NSIZES.NE.1 ) THEN
+ MTYPES = MIN( MAXTYP, NTYPES )
+ ELSE
+ MTYPES = MIN( MAXTYP+1, NTYPES )
+ END IF
+*
+ DO 260 JTYPE = 1, MTYPES
+ IF( .NOT.DOTYPE( JTYPE ) )
+ $ GO TO 260
+ NMATS = NMATS + 1
+ NTEST = 0
+*
+* Save ISEED in case of an error.
+*
+ DO 20 J = 1, 4
+ IOLDSD( J ) = ISEED( J )
+ 20 CONTINUE
+*
+* Initialize RESULT
+*
+ DO 30 J = 1, 14
+ RESULT( J ) = ZERO
+ 30 CONTINUE
+*
+* Compute "A"
+*
+* Control parameters:
+*
+* KMAGN KCONDS KMODE KTYPE
+* =1 O(1) 1 clustered 1 zero
+* =2 large large clustered 2 identity
+* =3 small exponential Jordan
+* =4 arithmetic diagonal, (w/ eigenvalues)
+* =5 random log symmetric, w/ eigenvalues
+* =6 random general, w/ eigenvalues
+* =7 random diagonal
+* =8 random symmetric
+* =9 random general
+* =10 random triangular
+*
+ IF( MTYPES.GT.MAXTYP )
+ $ GO TO 100
+*
+ ITYPE = KTYPE( JTYPE )
+ IMODE = KMODE( JTYPE )
+*
+* Compute norm
+*
+ GO TO ( 40, 50, 60 )KMAGN( JTYPE )
+*
+ 40 CONTINUE
+ ANORM = ONE
+ GO TO 70
+*
+ 50 CONTINUE
+ ANORM = ( RTOVFL*ULP )*ANINV
+ GO TO 70
+*
+ 60 CONTINUE
+ ANORM = RTUNFL*N*ULPINV
+ GO TO 70
+*
+ 70 CONTINUE
+*
+ CALL DLASET( 'Full', LDA, N, ZERO, ZERO, A, LDA )
+ IINFO = 0
+ COND = ULPINV
+*
+* Special Matrices
+*
+ IF( ITYPE.EQ.1 ) THEN
+*
+* Zero
+*
+ IINFO = 0
+*
+ ELSE IF( ITYPE.EQ.2 ) THEN
+*
+* Identity
+*
+ DO 80 JCOL = 1, N
+ A( JCOL, JCOL ) = ANORM
+ 80 CONTINUE
+*
+ ELSE IF( ITYPE.EQ.3 ) THEN
+*
+* Jordan Block
+*
+ DO 90 JCOL = 1, N
+ A( JCOL, JCOL ) = ANORM
+ IF( JCOL.GT.1 )
+ $ A( JCOL, JCOL-1 ) = ONE
+ 90 CONTINUE
+*
+ ELSE IF( ITYPE.EQ.4 ) THEN
+*
+* Diagonal Matrix, [Eigen]values Specified
+*
+ CALL DLATMS( N, N, 'S', ISEED, 'S', WORK, IMODE, COND,
+ $ ANORM, 0, 0, 'N', A, LDA, WORK( N+1 ),
+ $ IINFO )
+*
+ ELSE IF( ITYPE.EQ.5 ) THEN
+*
+* Symmetric, eigenvalues specified
+*
+ CALL DLATMS( N, N, 'S', ISEED, 'S', WORK, IMODE, COND,
+ $ ANORM, N, N, 'N', A, LDA, WORK( N+1 ),
+ $ IINFO )
+*
+ ELSE IF( ITYPE.EQ.6 ) THEN
+*
+* General, eigenvalues specified
+*
+ IF( KCONDS( JTYPE ).EQ.1 ) THEN
+ CONDS = ONE
+ ELSE IF( KCONDS( JTYPE ).EQ.2 ) THEN
+ CONDS = RTULPI
+ ELSE
+ CONDS = ZERO
+ END IF
+*
+ ADUMMA( 1 ) = ' '
+ CALL DLATME( N, 'S', ISEED, WORK, IMODE, COND, ONE,
+ $ ADUMMA, 'T', 'T', 'T', WORK( N+1 ), 4,
+ $ CONDS, N, N, ANORM, A, LDA, WORK( 2*N+1 ),
+ $ IINFO )
+*
+ ELSE IF( ITYPE.EQ.7 ) THEN
+*
+* Diagonal, random eigenvalues
+*
+ CALL DLATMR( N, N, 'S', ISEED, 'S', WORK, 6, ONE, ONE,
+ $ 'T', 'N', WORK( N+1 ), 1, ONE,
+ $ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, 0, 0,
+ $ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO )
+*
+ ELSE IF( ITYPE.EQ.8 ) THEN
+*
+* Symmetric, random eigenvalues
+*
+ CALL DLATMR( N, N, 'S', ISEED, 'S', WORK, 6, ONE, ONE,
+ $ 'T', 'N', WORK( N+1 ), 1, ONE,
+ $ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, N, N,
+ $ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO )
+*
+ ELSE IF( ITYPE.EQ.9 ) THEN
+*
+* General, random eigenvalues
+*
+ CALL DLATMR( N, N, 'S', ISEED, 'N', WORK, 6, ONE, ONE,
+ $ 'T', 'N', WORK( N+1 ), 1, ONE,
+ $ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, N, N,
+ $ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO )
+*
+ ELSE IF( ITYPE.EQ.10 ) THEN
+*
+* Triangular, random eigenvalues
+*
+ CALL DLATMR( N, N, 'S', ISEED, 'N', WORK, 6, ONE, ONE,
+ $ 'T', 'N', WORK( N+1 ), 1, ONE,
+ $ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, N, 0,
+ $ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO )
+*
+ ELSE
+*
+ IINFO = 1
+ END IF
+*
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUNIT, FMT = 9999 )'Generator', IINFO, N, JTYPE,
+ $ IOLDSD
+ INFO = ABS( IINFO )
+ RETURN
+ END IF
+*
+ 100 CONTINUE
+*
+* Call DGEHRD to compute H and U, do tests.
+*
+ CALL DLACPY( ' ', N, N, A, LDA, H, LDA )
+*
+ NTEST = 1
+*
+ ILO = 1
+ IHI = N
+*
+ CALL DGEHRD( N, ILO, IHI, H, LDA, WORK, WORK( N+1 ),
+ $ NWORK-N, IINFO )
+*
+ IF( IINFO.NE.0 ) THEN
+ RESULT( 1 ) = ULPINV
+ WRITE( NOUNIT, FMT = 9999 )'DGEHRD', IINFO, N, JTYPE,
+ $ IOLDSD
+ INFO = ABS( IINFO )
+ GO TO 250
+ END IF
+*
+ DO 120 J = 1, N - 1
+ UU( J+1, J ) = ZERO
+ DO 110 I = J + 2, N
+ U( I, J ) = H( I, J )
+ UU( I, J ) = H( I, J )
+ H( I, J ) = ZERO
+ 110 CONTINUE
+ 120 CONTINUE
+ CALL DCOPY( N-1, WORK, 1, TAU, 1 )
+ CALL DORGHR( N, ILO, IHI, U, LDU, WORK, WORK( N+1 ),
+ $ NWORK-N, IINFO )
+ NTEST = 2
+*
+ CALL DHST01( N, ILO, IHI, A, LDA, H, LDA, U, LDU, WORK,
+ $ NWORK, RESULT( 1 ) )
+*
+* Call DHSEQR to compute T1, T2 and Z, do tests.
+*
+* Eigenvalues only (WR3,WI3)
+*
+ CALL DLACPY( ' ', N, N, H, LDA, T2, LDA )
+ NTEST = 3
+ RESULT( 3 ) = ULPINV
+*
+ CALL DHSEQR( 'E', 'N', N, ILO, IHI, T2, LDA, WR3, WI3, UZ,
+ $ LDU, WORK, NWORK, IINFO )
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUNIT, FMT = 9999 )'DHSEQR(E)', IINFO, N, JTYPE,
+ $ IOLDSD
+ IF( IINFO.LE.N+2 ) THEN
+ INFO = ABS( IINFO )
+ GO TO 250
+ END IF
+ END IF
+*
+* Eigenvalues (WR1,WI1) and Full Schur Form (T2)
+*
+ CALL DLACPY( ' ', N, N, H, LDA, T2, LDA )
+*
+ CALL DHSEQR( 'S', 'N', N, ILO, IHI, T2, LDA, WR1, WI1, UZ,
+ $ LDU, WORK, NWORK, IINFO )
+ IF( IINFO.NE.0 .AND. IINFO.LE.N+2 ) THEN
+ WRITE( NOUNIT, FMT = 9999 )'DHSEQR(S)', IINFO, N, JTYPE,
+ $ IOLDSD
+ INFO = ABS( IINFO )
+ GO TO 250
+ END IF
+*
+* Eigenvalues (WR1,WI1), Schur Form (T1), and Schur vectors
+* (UZ)
+*
+ CALL DLACPY( ' ', N, N, H, LDA, T1, LDA )
+ CALL DLACPY( ' ', N, N, U, LDU, UZ, LDA )
+*
+ CALL DHSEQR( 'S', 'V', N, ILO, IHI, T1, LDA, WR1, WI1, UZ,
+ $ LDU, WORK, NWORK, IINFO )
+ IF( IINFO.NE.0 .AND. IINFO.LE.N+2 ) THEN
+ WRITE( NOUNIT, FMT = 9999 )'DHSEQR(V)', IINFO, N, JTYPE,
+ $ IOLDSD
+ INFO = ABS( IINFO )
+ GO TO 250
+ END IF
+*
+* Compute Z = U' UZ
+*
+ CALL DGEMM( 'T', 'N', N, N, N, ONE, U, LDU, UZ, LDU, ZERO,
+ $ Z, LDU )
+ NTEST = 8
+*
+* Do Tests 3: | H - Z T Z' | / ( |H| n ulp )
+* and 4: | I - Z Z' | / ( n ulp )
+*
+ CALL DHST01( N, ILO, IHI, H, LDA, T1, LDA, Z, LDU, WORK,
+ $ NWORK, RESULT( 3 ) )
+*
+* Do Tests 5: | A - UZ T (UZ)' | / ( |A| n ulp )
+* and 6: | I - UZ (UZ)' | / ( n ulp )
+*
+ CALL DHST01( N, ILO, IHI, A, LDA, T1, LDA, UZ, LDU, WORK,
+ $ NWORK, RESULT( 5 ) )
+*
+* Do Test 7: | T2 - T1 | / ( |T| n ulp )
+*
+ CALL DGET10( N, N, T2, LDA, T1, LDA, WORK, RESULT( 7 ) )
+*
+* Do Test 8: | W3 - W1 | / ( max(|W1|,|W3|) ulp )
+*
+ TEMP1 = ZERO
+ TEMP2 = ZERO
+ DO 130 J = 1, N
+ TEMP1 = MAX( TEMP1, ABS( WR1( J ) )+ABS( WI1( J ) ),
+ $ ABS( WR3( J ) )+ABS( WI3( J ) ) )
+ TEMP2 = MAX( TEMP2, ABS( WR1( J )-WR3( J ) )+
+ $ ABS( WR1( J )-WR3( J ) ) )
+ 130 CONTINUE
+*
+ RESULT( 8 ) = TEMP2 / MAX( UNFL, ULP*MAX( TEMP1, TEMP2 ) )
+*
+* Compute the Left and Right Eigenvectors of T
+*
+* Compute the Right eigenvector Matrix:
+*
+ NTEST = 9
+ RESULT( 9 ) = ULPINV
+*
+* Select last max(N/4,1) real, max(N/4,1) complex eigenvectors
+*
+ NSELC = 0
+ NSELR = 0
+ J = N
+ 140 CONTINUE
+ IF( WI1( J ).EQ.ZERO ) THEN
+ IF( NSELR.LT.MAX( N / 4, 1 ) ) THEN
+ NSELR = NSELR + 1
+ SELECT( J ) = .TRUE.
+ ELSE
+ SELECT( J ) = .FALSE.
+ END IF
+ J = J - 1
+ ELSE
+ IF( NSELC.LT.MAX( N / 4, 1 ) ) THEN
+ NSELC = NSELC + 1
+ SELECT( J ) = .TRUE.
+ SELECT( J-1 ) = .FALSE.
+ ELSE
+ SELECT( J ) = .FALSE.
+ SELECT( J-1 ) = .FALSE.
+ END IF
+ J = J - 2
+ END IF
+ IF( J.GT.0 )
+ $ GO TO 140
+*
+ CALL DTREVC( 'Right', 'All', SELECT, N, T1, LDA, DUMMA, LDU,
+ $ EVECTR, LDU, N, IN, WORK, IINFO )
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUNIT, FMT = 9999 )'DTREVC(R,A)', IINFO, N,
+ $ JTYPE, IOLDSD
+ INFO = ABS( IINFO )
+ GO TO 250
+ END IF
+*
+* Test 9: | TR - RW | / ( |T| |R| ulp )
+*
+ CALL DGET22( 'N', 'N', 'N', N, T1, LDA, EVECTR, LDU, WR1,
+ $ WI1, WORK, DUMMA( 1 ) )
+ RESULT( 9 ) = DUMMA( 1 )
+ IF( DUMMA( 2 ).GT.THRESH ) THEN
+ WRITE( NOUNIT, FMT = 9998 )'Right', 'DTREVC',
+ $ DUMMA( 2 ), N, JTYPE, IOLDSD
+ END IF
+*
+* Compute selected right eigenvectors and confirm that
+* they agree with previous right eigenvectors
+*
+ CALL DTREVC( 'Right', 'Some', SELECT, N, T1, LDA, DUMMA,
+ $ LDU, EVECTL, LDU, N, IN, WORK, IINFO )
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUNIT, FMT = 9999 )'DTREVC(R,S)', IINFO, N,
+ $ JTYPE, IOLDSD
+ INFO = ABS( IINFO )
+ GO TO 250
+ END IF
+*
+ K = 1
+ MATCH = .TRUE.
+ DO 170 J = 1, N
+ IF( SELECT( J ) .AND. WI1( J ).EQ.ZERO ) THEN
+ DO 150 JJ = 1, N
+ IF( EVECTR( JJ, J ).NE.EVECTL( JJ, K ) ) THEN
+ MATCH = .FALSE.
+ GO TO 180
+ END IF
+ 150 CONTINUE
+ K = K + 1
+ ELSE IF( SELECT( J ) .AND. WI1( J ).NE.ZERO ) THEN
+ DO 160 JJ = 1, N
+ IF( EVECTR( JJ, J ).NE.EVECTL( JJ, K ) .OR.
+ $ EVECTR( JJ, J+1 ).NE.EVECTL( JJ, K+1 ) ) THEN
+ MATCH = .FALSE.
+ GO TO 180
+ END IF
+ 160 CONTINUE
+ K = K + 2
+ END IF
+ 170 CONTINUE
+ 180 CONTINUE
+ IF( .NOT.MATCH )
+ $ WRITE( NOUNIT, FMT = 9997 )'Right', 'DTREVC', N, JTYPE,
+ $ IOLDSD
+*
+* Compute the Left eigenvector Matrix:
+*
+ NTEST = 10
+ RESULT( 10 ) = ULPINV
+ CALL DTREVC( 'Left', 'All', SELECT, N, T1, LDA, EVECTL, LDU,
+ $ DUMMA, LDU, N, IN, WORK, IINFO )
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUNIT, FMT = 9999 )'DTREVC(L,A)', IINFO, N,
+ $ JTYPE, IOLDSD
+ INFO = ABS( IINFO )
+ GO TO 250
+ END IF
+*
+* Test 10: | LT - WL | / ( |T| |L| ulp )
+*
+ CALL DGET22( 'Trans', 'N', 'Conj', N, T1, LDA, EVECTL, LDU,
+ $ WR1, WI1, WORK, DUMMA( 3 ) )
+ RESULT( 10 ) = DUMMA( 3 )
+ IF( DUMMA( 4 ).GT.THRESH ) THEN
+ WRITE( NOUNIT, FMT = 9998 )'Left', 'DTREVC', DUMMA( 4 ),
+ $ N, JTYPE, IOLDSD
+ END IF
+*
+* Compute selected left eigenvectors and confirm that
+* they agree with previous left eigenvectors
+*
+ CALL DTREVC( 'Left', 'Some', SELECT, N, T1, LDA, EVECTR,
+ $ LDU, DUMMA, LDU, N, IN, WORK, IINFO )
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUNIT, FMT = 9999 )'DTREVC(L,S)', IINFO, N,
+ $ JTYPE, IOLDSD
+ INFO = ABS( IINFO )
+ GO TO 250
+ END IF
+*
+ K = 1
+ MATCH = .TRUE.
+ DO 210 J = 1, N
+ IF( SELECT( J ) .AND. WI1( J ).EQ.ZERO ) THEN
+ DO 190 JJ = 1, N
+ IF( EVECTL( JJ, J ).NE.EVECTR( JJ, K ) ) THEN
+ MATCH = .FALSE.
+ GO TO 220
+ END IF
+ 190 CONTINUE
+ K = K + 1
+ ELSE IF( SELECT( J ) .AND. WI1( J ).NE.ZERO ) THEN
+ DO 200 JJ = 1, N
+ IF( EVECTL( JJ, J ).NE.EVECTR( JJ, K ) .OR.
+ $ EVECTL( JJ, J+1 ).NE.EVECTR( JJ, K+1 ) ) THEN
+ MATCH = .FALSE.
+ GO TO 220
+ END IF
+ 200 CONTINUE
+ K = K + 2
+ END IF
+ 210 CONTINUE
+ 220 CONTINUE
+ IF( .NOT.MATCH )
+ $ WRITE( NOUNIT, FMT = 9997 )'Left', 'DTREVC', N, JTYPE,
+ $ IOLDSD
+*
+* Call DHSEIN for Right eigenvectors of H, do test 11
+*
+ NTEST = 11
+ RESULT( 11 ) = ULPINV
+ DO 230 J = 1, N
+ SELECT( J ) = .TRUE.
+ 230 CONTINUE
+*
+ CALL DHSEIN( 'Right', 'Qr', 'Ninitv', SELECT, N, H, LDA,
+ $ WR3, WI3, DUMMA, LDU, EVECTX, LDU, N1, IN,
+ $ WORK, IWORK, IWORK, IINFO )
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUNIT, FMT = 9999 )'DHSEIN(R)', IINFO, N, JTYPE,
+ $ IOLDSD
+ INFO = ABS( IINFO )
+ IF( IINFO.LT.0 )
+ $ GO TO 250
+ ELSE
+*
+* Test 11: | HX - XW | / ( |H| |X| ulp )
+*
+* (from inverse iteration)
+*
+ CALL DGET22( 'N', 'N', 'N', N, H, LDA, EVECTX, LDU, WR3,
+ $ WI3, WORK, DUMMA( 1 ) )
+ IF( DUMMA( 1 ).LT.ULPINV )
+ $ RESULT( 11 ) = DUMMA( 1 )*ANINV
+ IF( DUMMA( 2 ).GT.THRESH ) THEN
+ WRITE( NOUNIT, FMT = 9998 )'Right', 'DHSEIN',
+ $ DUMMA( 2 ), N, JTYPE, IOLDSD
+ END IF
+ END IF
+*
+* Call DHSEIN for Left eigenvectors of H, do test 12
+*
+ NTEST = 12
+ RESULT( 12 ) = ULPINV
+ DO 240 J = 1, N
+ SELECT( J ) = .TRUE.
+ 240 CONTINUE
+*
+ CALL DHSEIN( 'Left', 'Qr', 'Ninitv', SELECT, N, H, LDA, WR3,
+ $ WI3, EVECTY, LDU, DUMMA, LDU, N1, IN, WORK,
+ $ IWORK, IWORK, IINFO )
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUNIT, FMT = 9999 )'DHSEIN(L)', IINFO, N, JTYPE,
+ $ IOLDSD
+ INFO = ABS( IINFO )
+ IF( IINFO.LT.0 )
+ $ GO TO 250
+ ELSE
+*
+* Test 12: | YH - WY | / ( |H| |Y| ulp )
+*
+* (from inverse iteration)
+*
+ CALL DGET22( 'C', 'N', 'C', N, H, LDA, EVECTY, LDU, WR3,
+ $ WI3, WORK, DUMMA( 3 ) )
+ IF( DUMMA( 3 ).LT.ULPINV )
+ $ RESULT( 12 ) = DUMMA( 3 )*ANINV
+ IF( DUMMA( 4 ).GT.THRESH ) THEN
+ WRITE( NOUNIT, FMT = 9998 )'Left', 'DHSEIN',
+ $ DUMMA( 4 ), N, JTYPE, IOLDSD
+ END IF
+ END IF
+*
+* Call DORMHR for Right eigenvectors of A, do test 13
+*
+ NTEST = 13
+ RESULT( 13 ) = ULPINV
+*
+ CALL DORMHR( 'Left', 'No transpose', N, N, ILO, IHI, UU,
+ $ LDU, TAU, EVECTX, LDU, WORK, NWORK, IINFO )
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUNIT, FMT = 9999 )'DORMHR(R)', IINFO, N, JTYPE,
+ $ IOLDSD
+ INFO = ABS( IINFO )
+ IF( IINFO.LT.0 )
+ $ GO TO 250
+ ELSE
+*
+* Test 13: | AX - XW | / ( |A| |X| ulp )
+*
+* (from inverse iteration)
+*
+ CALL DGET22( 'N', 'N', 'N', N, A, LDA, EVECTX, LDU, WR3,
+ $ WI3, WORK, DUMMA( 1 ) )
+ IF( DUMMA( 1 ).LT.ULPINV )
+ $ RESULT( 13 ) = DUMMA( 1 )*ANINV
+ END IF
+*
+* Call DORMHR for Left eigenvectors of A, do test 14
+*
+ NTEST = 14
+ RESULT( 14 ) = ULPINV
+*
+ CALL DORMHR( 'Left', 'No transpose', N, N, ILO, IHI, UU,
+ $ LDU, TAU, EVECTY, LDU, WORK, NWORK, IINFO )
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUNIT, FMT = 9999 )'DORMHR(L)', IINFO, N, JTYPE,
+ $ IOLDSD
+ INFO = ABS( IINFO )
+ IF( IINFO.LT.0 )
+ $ GO TO 250
+ ELSE
+*
+* Test 14: | YA - WY | / ( |A| |Y| ulp )
+*
+* (from inverse iteration)
+*
+ CALL DGET22( 'C', 'N', 'C', N, A, LDA, EVECTY, LDU, WR3,
+ $ WI3, WORK, DUMMA( 3 ) )
+ IF( DUMMA( 3 ).LT.ULPINV )
+ $ RESULT( 14 ) = DUMMA( 3 )*ANINV
+ END IF
+*
+* End of Loop -- Check for RESULT(j) > THRESH
+*
+ 250 CONTINUE
+*
+ NTESTT = NTESTT + NTEST
+ CALL DLAFTS( 'DHS', N, N, JTYPE, NTEST, RESULT, IOLDSD,
+ $ THRESH, NOUNIT, NERRS )
+*
+ 260 CONTINUE
+ 270 CONTINUE
+*
+* Summary
+*
+ CALL DLASUM( 'DHS', NOUNIT, NERRS, NTESTT )
+*
+ RETURN
+*
+ 9999 FORMAT( ' DCHKHS: ', A, ' returned INFO=', I6, '.', / 9X, 'N=',
+ $ I6, ', JTYPE=', I6, ', ISEED=(', 3( I5, ',' ), I5, ')' )
+ 9998 FORMAT( ' DCHKHS: ', A, ' Eigenvectors from ', A, ' incorrectly ',
+ $ 'normalized.', / ' Bits of error=', 0P, G10.3, ',', 9X,
+ $ 'N=', I6, ', JTYPE=', I6, ', ISEED=(', 3( I5, ',' ), I5,
+ $ ')' )
+ 9997 FORMAT( ' DCHKHS: Selected ', A, ' Eigenvectors from ', A,
+ $ ' do not match other eigenvectors ', 9X, 'N=', I6,
+ $ ', JTYPE=', I6, ', ISEED=(', 3( I5, ',' ), I5, ')' )
+*
+* End of DCHKHS
+*
+ END
+ SUBROUTINE DCHKSB( NSIZES, NN, NWDTHS, KK, NTYPES, DOTYPE, ISEED,
+ $ THRESH, NOUNIT, A, LDA, SD, SE, U, LDU, WORK,
+ $ LWORK, RESULT, INFO )
+*
+* -- LAPACK test routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LDA, LDU, LWORK, NOUNIT, NSIZES, NTYPES,
+ $ NWDTHS
+ DOUBLE PRECISION THRESH
+* ..
+* .. Array Arguments ..
+ LOGICAL DOTYPE( * )
+ INTEGER ISEED( 4 ), KK( * ), NN( * )
+ DOUBLE PRECISION A( LDA, * ), RESULT( * ), SD( * ), SE( * ),
+ $ U( LDU, * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DCHKSB tests the reduction of a symmetric band matrix to tridiagonal
+* form, used with the symmetric eigenvalue problem.
+*
+* DSBTRD factors a symmetric band matrix A as U S U' , where ' means
+* transpose, S is symmetric tridiagonal, and U is orthogonal.
+* DSBTRD can use either just the lower or just the upper triangle
+* of A; DCHKSB checks both cases.
+*
+* When DCHKSB is called, a number of matrix "sizes" ("n's"), a number
+* of bandwidths ("k's"), and a number of matrix "types" are
+* specified. For each size ("n"), each bandwidth ("k") less than or
+* equal to "n", and each type of matrix, one matrix will be generated
+* and used to test the symmetric banded reduction routine. For each
+* matrix, a number of tests will be performed:
+*
+* (1) | A - V S V' | / ( |A| n ulp ) computed by DSBTRD with
+* UPLO='U'
+*
+* (2) | I - UU' | / ( n ulp )
+*
+* (3) | A - V S V' | / ( |A| n ulp ) computed by DSBTRD with
+* UPLO='L'
+*
+* (4) | I - UU' | / ( n ulp )
+*
+* The "sizes" are specified by an array NN(1:NSIZES); the value of
+* each element NN(j) specifies one size.
+* The "types" are specified by a logical array DOTYPE( 1:NTYPES );
+* if DOTYPE(j) is .TRUE., then matrix type "j" will be generated.
+* Currently, the list of possible types is:
+*
+* (1) The zero matrix.
+* (2) The identity matrix.
+*
+* (3) A diagonal matrix with evenly spaced entries
+* 1, ..., ULP and random signs.
+* (ULP = (first number larger than 1) - 1 )
+* (4) A diagonal matrix with geometrically spaced entries
+* 1, ..., ULP and random signs.
+* (5) A diagonal matrix with "clustered" entries 1, ULP, ..., ULP
+* and random signs.
+*
+* (6) Same as (4), but multiplied by SQRT( overflow threshold )
+* (7) Same as (4), but multiplied by SQRT( underflow threshold )
+*
+* (8) A matrix of the form U' D U, where U is orthogonal and
+* D has evenly spaced entries 1, ..., ULP with random signs
+* on the diagonal.
+*
+* (9) A matrix of the form U' D U, where U is orthogonal and
+* D has geometrically spaced entries 1, ..., ULP with random
+* signs on the diagonal.
+*
+* (10) A matrix of the form U' D U, where U is orthogonal and
+* D has "clustered" entries 1, ULP,..., ULP with random
+* signs on the diagonal.
+*
+* (11) Same as (8), but multiplied by SQRT( overflow threshold )
+* (12) Same as (8), but multiplied by SQRT( underflow threshold )
+*
+* (13) Symmetric matrix with random entries chosen from (-1,1).
+* (14) Same as (13), but multiplied by SQRT( overflow threshold )
+* (15) Same as (13), but multiplied by SQRT( underflow threshold )
+*
+* Arguments
+* =========
+*
+* NSIZES (input) INTEGER
+* The number of sizes of matrices to use. If it is zero,
+* DCHKSB does nothing. It must be at least zero.
+*
+* NN (input) INTEGER array, dimension (NSIZES)
+* An array containing the sizes to be used for the matrices.
+* Zero values will be skipped. The values must be at least
+* zero.
+*
+* NWDTHS (input) INTEGER
+* The number of bandwidths to use. If it is zero,
+* DCHKSB does nothing. It must be at least zero.
+*
+* KK (input) INTEGER array, dimension (NWDTHS)
+* An array containing the bandwidths to be used for the band
+* matrices. The values must be at least zero.
+*
+* NTYPES (input) INTEGER
+* The number of elements in DOTYPE. If it is zero, DCHKSB
+* does nothing. It must be at least zero. If it is MAXTYP+1
+* and NSIZES is 1, then an additional type, MAXTYP+1 is
+* defined, which is to use whatever matrix is in A. This
+* is only useful if DOTYPE(1:MAXTYP) is .FALSE. and
+* DOTYPE(MAXTYP+1) is .TRUE. .
+*
+* DOTYPE (input) LOGICAL array, dimension (NTYPES)
+* If DOTYPE(j) is .TRUE., then for each size in NN a
+* matrix of that size and of type j will be generated.
+* If NTYPES is smaller than the maximum number of types
+* defined (PARAMETER MAXTYP), then types NTYPES+1 through
+* MAXTYP will not be generated. If NTYPES is larger
+* than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES)
+* will be ignored.
+*
+* ISEED (input/output) INTEGER array, dimension (4)
+* On entry ISEED specifies the seed of the random number
+* generator. The array elements should be between 0 and 4095;
+* if not they will be reduced mod 4096. Also, ISEED(4) must
+* be odd. The random number generator uses a linear
+* congruential sequence limited to small integers, and so
+* should produce machine independent random numbers. The
+* values of ISEED are changed on exit, and can be used in the
+* next call to DCHKSB to continue the same random number
+* sequence.
+*
+* THRESH (input) DOUBLE PRECISION
+* A test will count as "failed" if the "error", computed as
+* described above, exceeds THRESH. Note that the error
+* is scaled to be O(1), so THRESH should be a reasonably
+* small multiple of 1, e.g., 10 or 100. In particular,
+* it should not depend on the precision (single vs. double)
+* or the size of the matrix. It must be at least zero.
+*
+* NOUNIT (input) INTEGER
+* The FORTRAN unit number for printing out error messages
+* (e.g., if a routine returns IINFO not equal to 0.)
+*
+* A (input/workspace) DOUBLE PRECISION array, dimension
+* (LDA, max(NN))
+* Used to hold the matrix whose eigenvalues are to be
+* computed.
+*
+* LDA (input) INTEGER
+* The leading dimension of A. It must be at least 2 (not 1!)
+* and at least max( KK )+1.
+*
+* SD (workspace) DOUBLE PRECISION array, dimension (max(NN))
+* Used to hold the diagonal of the tridiagonal matrix computed
+* by DSBTRD.
+*
+* SE (workspace) DOUBLE PRECISION array, dimension (max(NN))
+* Used to hold the off-diagonal of the tridiagonal matrix
+* computed by DSBTRD.
+*
+* U (workspace) DOUBLE PRECISION array, dimension (LDU, max(NN))
+* Used to hold the orthogonal matrix computed by DSBTRD.
+*
+* LDU (input) INTEGER
+* The leading dimension of U. It must be at least 1
+* and at least max( NN ).
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK)
+*
+* LWORK (input) INTEGER
+* The number of entries in WORK. This must be at least
+* max( LDA+1, max(NN)+1 )*max(NN).
+*
+* RESULT (output) DOUBLE PRECISION array, dimension (4)
+* The values computed by the tests described above.
+* The values are currently limited to 1/ulp, to avoid
+* overflow.
+*
+* INFO (output) INTEGER
+* If 0, then everything ran OK.
+*
+*-----------------------------------------------------------------------
+*
+* Some Local Variables and Parameters:
+* ---- ----- --------- --- ----------
+* ZERO, ONE Real 0 and 1.
+* MAXTYP The number of types defined.
+* NTEST The number of tests performed, or which can
+* be performed so far, for the current matrix.
+* NTESTT The total number of tests performed so far.
+* NMAX Largest value in NN.
+* NMATS The number of matrices generated so far.
+* NERRS The number of tests which have exceeded THRESH
+* so far.
+* COND, IMODE Values to be passed to the matrix generators.
+* ANORM Norm of A; passed to matrix generators.
+*
+* OVFL, UNFL Overflow and underflow thresholds.
+* ULP, ULPINV Finest relative precision and its inverse.
+* RTOVFL, RTUNFL Square roots of the previous 2 values.
+* The following four arrays decode JTYPE:
+* KTYPE(j) The general type (1-10) for type "j".
+* KMODE(j) The MODE value to be passed to the matrix
+* generator for type "j".
+* KMAGN(j) The order of magnitude ( O(1),
+* O(overflow^(1/2) ), O(underflow^(1/2) )
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE, TWO, TEN
+ PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0,
+ $ TEN = 10.0D0 )
+ DOUBLE PRECISION HALF
+ PARAMETER ( HALF = ONE / TWO )
+ INTEGER MAXTYP
+ PARAMETER ( MAXTYP = 15 )
+* ..
+* .. Local Scalars ..
+ LOGICAL BADNN, BADNNB
+ INTEGER I, IINFO, IMODE, ITYPE, J, JC, JCOL, JR, JSIZE,
+ $ JTYPE, JWIDTH, K, KMAX, MTYPES, N, NERRS,
+ $ NMATS, NMAX, NTEST, NTESTT
+ DOUBLE PRECISION ANINV, ANORM, COND, OVFL, RTOVFL, RTUNFL,
+ $ TEMP1, ULP, ULPINV, UNFL
+* ..
+* .. Local Arrays ..
+ INTEGER IDUMMA( 1 ), IOLDSD( 4 ), KMAGN( MAXTYP ),
+ $ KMODE( MAXTYP ), KTYPE( MAXTYP )
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DLAMCH
+ EXTERNAL DLAMCH
+* ..
+* .. External Subroutines ..
+ EXTERNAL DLACPY, DLASET, DLASUM, DLATMR, DLATMS, DSBT21,
+ $ DSBTRD, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, DBLE, MAX, MIN, SQRT
+* ..
+* .. Data statements ..
+ DATA KTYPE / 1, 2, 5*4, 5*5, 3*8 /
+ DATA KMAGN / 2*1, 1, 1, 1, 2, 3, 1, 1, 1, 2, 3, 1,
+ $ 2, 3 /
+ DATA KMODE / 2*0, 4, 3, 1, 4, 4, 4, 3, 1, 4, 4, 0,
+ $ 0, 0 /
+* ..
+* .. Executable Statements ..
+*
+* Check for errors
+*
+ NTESTT = 0
+ INFO = 0
+*
+* Important constants
+*
+ BADNN = .FALSE.
+ NMAX = 1
+ DO 10 J = 1, NSIZES
+ NMAX = MAX( NMAX, NN( J ) )
+ IF( NN( J ).LT.0 )
+ $ BADNN = .TRUE.
+ 10 CONTINUE
+*
+ BADNNB = .FALSE.
+ KMAX = 0
+ DO 20 J = 1, NSIZES
+ KMAX = MAX( KMAX, KK( J ) )
+ IF( KK( J ).LT.0 )
+ $ BADNNB = .TRUE.
+ 20 CONTINUE
+ KMAX = MIN( NMAX-1, KMAX )
+*
+* Check for errors
+*
+ IF( NSIZES.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( BADNN ) THEN
+ INFO = -2
+ ELSE IF( NWDTHS.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( BADNNB ) THEN
+ INFO = -4
+ ELSE IF( NTYPES.LT.0 ) THEN
+ INFO = -5
+ ELSE IF( LDA.LT.KMAX+1 ) THEN
+ INFO = -11
+ ELSE IF( LDU.LT.NMAX ) THEN
+ INFO = -15
+ ELSE IF( ( MAX( LDA, NMAX )+1 )*NMAX.GT.LWORK ) THEN
+ INFO = -17
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DCHKSB', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( NSIZES.EQ.0 .OR. NTYPES.EQ.0 .OR. NWDTHS.EQ.0 )
+ $ RETURN
+*
+* More Important constants
+*
+ UNFL = DLAMCH( 'Safe minimum' )
+ OVFL = ONE / UNFL
+ ULP = DLAMCH( 'Epsilon' )*DLAMCH( 'Base' )
+ ULPINV = ONE / ULP
+ RTUNFL = SQRT( UNFL )
+ RTOVFL = SQRT( OVFL )
+*
+* Loop over sizes, types
+*
+ NERRS = 0
+ NMATS = 0
+*
+ DO 190 JSIZE = 1, NSIZES
+ N = NN( JSIZE )
+ ANINV = ONE / DBLE( MAX( 1, N ) )
+*
+ DO 180 JWIDTH = 1, NWDTHS
+ K = KK( JWIDTH )
+ IF( K.GT.N )
+ $ GO TO 180
+ K = MAX( 0, MIN( N-1, K ) )
+*
+ IF( NSIZES.NE.1 ) THEN
+ MTYPES = MIN( MAXTYP, NTYPES )
+ ELSE
+ MTYPES = MIN( MAXTYP+1, NTYPES )
+ END IF
+*
+ DO 170 JTYPE = 1, MTYPES
+ IF( .NOT.DOTYPE( JTYPE ) )
+ $ GO TO 170
+ NMATS = NMATS + 1
+ NTEST = 0
+*
+ DO 30 J = 1, 4
+ IOLDSD( J ) = ISEED( J )
+ 30 CONTINUE
+*
+* Compute "A".
+* Store as "Upper"; later, we will copy to other format.
+*
+* Control parameters:
+*
+* KMAGN KMODE KTYPE
+* =1 O(1) clustered 1 zero
+* =2 large clustered 2 identity
+* =3 small exponential (none)
+* =4 arithmetic diagonal, (w/ eigenvalues)
+* =5 random log symmetric, w/ eigenvalues
+* =6 random (none)
+* =7 random diagonal
+* =8 random symmetric
+* =9 positive definite
+* =10 diagonally dominant tridiagonal
+*
+ IF( MTYPES.GT.MAXTYP )
+ $ GO TO 100
+*
+ ITYPE = KTYPE( JTYPE )
+ IMODE = KMODE( JTYPE )
+*
+* Compute norm
+*
+ GO TO ( 40, 50, 60 )KMAGN( JTYPE )
+*
+ 40 CONTINUE
+ ANORM = ONE
+ GO TO 70
+*
+ 50 CONTINUE
+ ANORM = ( RTOVFL*ULP )*ANINV
+ GO TO 70
+*
+ 60 CONTINUE
+ ANORM = RTUNFL*N*ULPINV
+ GO TO 70
+*
+ 70 CONTINUE
+*
+ CALL DLASET( 'Full', LDA, N, ZERO, ZERO, A, LDA )
+ IINFO = 0
+ IF( JTYPE.LE.15 ) THEN
+ COND = ULPINV
+ ELSE
+ COND = ULPINV*ANINV / TEN
+ END IF
+*
+* Special Matrices -- Identity & Jordan block
+*
+* Zero
+*
+ IF( ITYPE.EQ.1 ) THEN
+ IINFO = 0
+*
+ ELSE IF( ITYPE.EQ.2 ) THEN
+*
+* Identity
+*
+ DO 80 JCOL = 1, N
+ A( K+1, JCOL ) = ANORM
+ 80 CONTINUE
+*
+ ELSE IF( ITYPE.EQ.4 ) THEN
+*
+* Diagonal Matrix, [Eigen]values Specified
+*
+ CALL DLATMS( N, N, 'S', ISEED, 'S', WORK, IMODE, COND,
+ $ ANORM, 0, 0, 'Q', A( K+1, 1 ), LDA,
+ $ WORK( N+1 ), IINFO )
+*
+ ELSE IF( ITYPE.EQ.5 ) THEN
+*
+* Symmetric, eigenvalues specified
+*
+ CALL DLATMS( N, N, 'S', ISEED, 'S', WORK, IMODE, COND,
+ $ ANORM, K, K, 'Q', A, LDA, WORK( N+1 ),
+ $ IINFO )
+*
+ ELSE IF( ITYPE.EQ.7 ) THEN
+*
+* Diagonal, random eigenvalues
+*
+ CALL DLATMR( N, N, 'S', ISEED, 'S', WORK, 6, ONE, ONE,
+ $ 'T', 'N', WORK( N+1 ), 1, ONE,
+ $ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, 0, 0,
+ $ ZERO, ANORM, 'Q', A( K+1, 1 ), LDA,
+ $ IDUMMA, IINFO )
+*
+ ELSE IF( ITYPE.EQ.8 ) THEN
+*
+* Symmetric, random eigenvalues
+*
+ CALL DLATMR( N, N, 'S', ISEED, 'S', WORK, 6, ONE, ONE,
+ $ 'T', 'N', WORK( N+1 ), 1, ONE,
+ $ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, K, K,
+ $ ZERO, ANORM, 'Q', A, LDA, IDUMMA, IINFO )
+*
+ ELSE IF( ITYPE.EQ.9 ) THEN
+*
+* Positive definite, eigenvalues specified.
+*
+ CALL DLATMS( N, N, 'S', ISEED, 'P', WORK, IMODE, COND,
+ $ ANORM, K, K, 'Q', A, LDA, WORK( N+1 ),
+ $ IINFO )
+*
+ ELSE IF( ITYPE.EQ.10 ) THEN
+*
+* Positive definite tridiagonal, eigenvalues specified.
+*
+ IF( N.GT.1 )
+ $ K = MAX( 1, K )
+ CALL DLATMS( N, N, 'S', ISEED, 'P', WORK, IMODE, COND,
+ $ ANORM, 1, 1, 'Q', A( K, 1 ), LDA,
+ $ WORK( N+1 ), IINFO )
+ DO 90 I = 2, N
+ TEMP1 = ABS( A( K, I ) ) /
+ $ SQRT( ABS( A( K+1, I-1 )*A( K+1, I ) ) )
+ IF( TEMP1.GT.HALF ) THEN
+ A( K, I ) = HALF*SQRT( ABS( A( K+1,
+ $ I-1 )*A( K+1, I ) ) )
+ END IF
+ 90 CONTINUE
+*
+ ELSE
+*
+ IINFO = 1
+ END IF
+*
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUNIT, FMT = 9999 )'Generator', IINFO, N,
+ $ JTYPE, IOLDSD
+ INFO = ABS( IINFO )
+ RETURN
+ END IF
+*
+ 100 CONTINUE
+*
+* Call DSBTRD to compute S and U from upper triangle.
+*
+ CALL DLACPY( ' ', K+1, N, A, LDA, WORK, LDA )
+*
+ NTEST = 1
+ CALL DSBTRD( 'V', 'U', N, K, WORK, LDA, SD, SE, U, LDU,
+ $ WORK( LDA*N+1 ), IINFO )
+*
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUNIT, FMT = 9999 )'DSBTRD(U)', IINFO, N,
+ $ JTYPE, IOLDSD
+ INFO = ABS( IINFO )
+ IF( IINFO.LT.0 ) THEN
+ RETURN
+ ELSE
+ RESULT( 1 ) = ULPINV
+ GO TO 150
+ END IF
+ END IF
+*
+* Do tests 1 and 2
+*
+ CALL DSBT21( 'Upper', N, K, 1, A, LDA, SD, SE, U, LDU,
+ $ WORK, RESULT( 1 ) )
+*
+* Convert A from Upper-Triangle-Only storage to
+* Lower-Triangle-Only storage.
+*
+ DO 120 JC = 1, N
+ DO 110 JR = 0, MIN( K, N-JC )
+ A( JR+1, JC ) = A( K+1-JR, JC+JR )
+ 110 CONTINUE
+ 120 CONTINUE
+ DO 140 JC = N + 1 - K, N
+ DO 130 JR = MIN( K, N-JC ) + 1, K
+ A( JR+1, JC ) = ZERO
+ 130 CONTINUE
+ 140 CONTINUE
+*
+* Call DSBTRD to compute S and U from lower triangle
+*
+ CALL DLACPY( ' ', K+1, N, A, LDA, WORK, LDA )
+*
+ NTEST = 3
+ CALL DSBTRD( 'V', 'L', N, K, WORK, LDA, SD, SE, U, LDU,
+ $ WORK( LDA*N+1 ), IINFO )
+*
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUNIT, FMT = 9999 )'DSBTRD(L)', IINFO, N,
+ $ JTYPE, IOLDSD
+ INFO = ABS( IINFO )
+ IF( IINFO.LT.0 ) THEN
+ RETURN
+ ELSE
+ RESULT( 3 ) = ULPINV
+ GO TO 150
+ END IF
+ END IF
+ NTEST = 4
+*
+* Do tests 3 and 4
+*
+ CALL DSBT21( 'Lower', N, K, 1, A, LDA, SD, SE, U, LDU,
+ $ WORK, RESULT( 3 ) )
+*
+* End of Loop -- Check for RESULT(j) > THRESH
+*
+ 150 CONTINUE
+ NTESTT = NTESTT + NTEST
+*
+* Print out tests which fail.
+*
+ DO 160 JR = 1, NTEST
+ IF( RESULT( JR ).GE.THRESH ) THEN
+*
+* If this is the first test to fail,
+* print a header to the data file.
+*
+ IF( NERRS.EQ.0 ) THEN
+ WRITE( NOUNIT, FMT = 9998 )'DSB'
+ WRITE( NOUNIT, FMT = 9997 )
+ WRITE( NOUNIT, FMT = 9996 )
+ WRITE( NOUNIT, FMT = 9995 )'Symmetric'
+ WRITE( NOUNIT, FMT = 9994 )'orthogonal', '''',
+ $ 'transpose', ( '''', J = 1, 4 )
+ END IF
+ NERRS = NERRS + 1
+ WRITE( NOUNIT, FMT = 9993 )N, K, IOLDSD, JTYPE,
+ $ JR, RESULT( JR )
+ END IF
+ 160 CONTINUE
+*
+ 170 CONTINUE
+ 180 CONTINUE
+ 190 CONTINUE
+*
+* Summary
+*
+ CALL DLASUM( 'DSB', NOUNIT, NERRS, NTESTT )
+ RETURN
+*
+ 9999 FORMAT( ' DCHKSB: ', A, ' returned INFO=', I6, '.', / 9X, 'N=',
+ $ I6, ', JTYPE=', I6, ', ISEED=(', 3( I5, ',' ), I5, ')' )
+*
+ 9998 FORMAT( / 1X, A3,
+ $ ' -- Real Symmetric Banded Tridiagonal Reduction Routines' )
+ 9997 FORMAT( ' Matrix types (see DCHKSB for details): ' )
+*
+ 9996 FORMAT( / ' Special Matrices:',
+ $ / ' 1=Zero matrix. ',
+ $ ' 5=Diagonal: clustered entries.',
+ $ / ' 2=Identity matrix. ',
+ $ ' 6=Diagonal: large, evenly spaced.',
+ $ / ' 3=Diagonal: evenly spaced entries. ',
+ $ ' 7=Diagonal: small, evenly spaced.',
+ $ / ' 4=Diagonal: geometr. spaced entries.' )
+ 9995 FORMAT( ' Dense ', A, ' Banded Matrices:',
+ $ / ' 8=Evenly spaced eigenvals. ',
+ $ ' 12=Small, evenly spaced eigenvals.',
+ $ / ' 9=Geometrically spaced eigenvals. ',
+ $ ' 13=Matrix with random O(1) entries.',
+ $ / ' 10=Clustered eigenvalues. ',
+ $ ' 14=Matrix with large random entries.',
+ $ / ' 11=Large, evenly spaced eigenvals. ',
+ $ ' 15=Matrix with small random entries.' )
+*
+ 9994 FORMAT( / ' Tests performed: (S is Tridiag, U is ', A, ',',
+ $ / 20X, A, ' means ', A, '.', / ' UPLO=''U'':',
+ $ / ' 1= | A - U S U', A1, ' | / ( |A| n ulp ) ',
+ $ ' 2= | I - U U', A1, ' | / ( n ulp )', / ' UPLO=''L'':',
+ $ / ' 3= | A - U S U', A1, ' | / ( |A| n ulp ) ',
+ $ ' 4= | I - U U', A1, ' | / ( n ulp )' )
+ 9993 FORMAT( ' N=', I5, ', K=', I4, ', seed=', 4( I4, ',' ), ' type ',
+ $ I2, ', test(', I2, ')=', G10.3 )
+*
+* End of DCHKSB
+*
+ END
+ SUBROUTINE DCHKST( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH,
+ $ NOUNIT, A, LDA, AP, SD, SE, D1, D2, D3, D4, D5,
+ $ WA1, WA2, WA3, WR, U, LDU, V, VP, TAU, Z, WORK,
+ $ LWORK, IWORK, LIWORK, RESULT, INFO )
+ IMPLICIT NONE
+*
+* -- LAPACK test routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LDA, LDU, LIWORK, LWORK, NOUNIT, NSIZES,
+ $ NTYPES
+ DOUBLE PRECISION THRESH
+* ..
+* .. Array Arguments ..
+ LOGICAL DOTYPE( * )
+ INTEGER ISEED( 4 ), IWORK( * ), NN( * )
+ DOUBLE PRECISION A( LDA, * ), AP( * ), D1( * ), D2( * ),
+ $ D3( * ), D4( * ), D5( * ), RESULT( * ),
+ $ SD( * ), SE( * ), TAU( * ), U( LDU, * ),
+ $ V( LDU, * ), VP( * ), WA1( * ), WA2( * ),
+ $ WA3( * ), WORK( * ), WR( * ), Z( LDU, * )
+* ..
+*
+* Purpose
+* =======
+*
+* DCHKST checks the symmetric eigenvalue problem routines.
+*
+* DSYTRD factors A as U S U' , where ' means transpose,
+* S is symmetric tridiagonal, and U is orthogonal.
+* DSYTRD can use either just the lower or just the upper triangle
+* of A; DCHKST checks both cases.
+* U is represented as a product of Householder
+* transformations, whose vectors are stored in the first
+* n-1 columns of V, and whose scale factors are in TAU.
+*
+* DSPTRD does the same as DSYTRD, except that A and V are stored
+* in "packed" format.
+*
+* DORGTR constructs the matrix U from the contents of V and TAU.
+*
+* DOPGTR constructs the matrix U from the contents of VP and TAU.
+*
+* DSTEQR factors S as Z D1 Z' , where Z is the orthogonal
+* matrix of eigenvectors and D1 is a diagonal matrix with
+* the eigenvalues on the diagonal. D2 is the matrix of
+* eigenvalues computed when Z is not computed.
+*
+* DSTERF computes D3, the matrix of eigenvalues, by the
+* PWK method, which does not yield eigenvectors.
+*
+* DPTEQR factors S as Z4 D4 Z4' , for a
+* symmetric positive definite tridiagonal matrix.
+* D5 is the matrix of eigenvalues computed when Z is not
+* computed.
+*
+* DSTEBZ computes selected eigenvalues. WA1, WA2, and
+* WA3 will denote eigenvalues computed to high
+* absolute accuracy, with different range options.
+* WR will denote eigenvalues computed to high relative
+* accuracy.
+*
+* DSTEIN computes Y, the eigenvectors of S, given the
+* eigenvalues.
+*
+* DSTEDC factors S as Z D1 Z' , where Z is the orthogonal
+* matrix of eigenvectors and D1 is a diagonal matrix with
+* the eigenvalues on the diagonal ('I' option). It may also
+* update an input orthogonal matrix, usually the output
+* from DSYTRD/DORGTR or DSPTRD/DOPGTR ('V' option). It may
+* also just compute eigenvalues ('N' option).
+*
+* DSTEMR factors S as Z D1 Z' , where Z is the orthogonal
+* matrix of eigenvectors and D1 is a diagonal matrix with
+* the eigenvalues on the diagonal ('I' option). DSTEMR
+* uses the Relatively Robust Representation whenever possible.
+*
+* When DCHKST is called, a number of matrix "sizes" ("n's") and a
+* number of matrix "types" are specified. For each size ("n")
+* and each type of matrix, one matrix will be generated and used
+* to test the symmetric eigenroutines. For each matrix, a number
+* of tests will be performed:
+*
+* (1) | A - V S V' | / ( |A| n ulp ) DSYTRD( UPLO='U', ... )
+*
+* (2) | I - UV' | / ( n ulp ) DORGTR( UPLO='U', ... )
+*
+* (3) | A - V S V' | / ( |A| n ulp ) DSYTRD( UPLO='L', ... )
+*
+* (4) | I - UV' | / ( n ulp ) DORGTR( UPLO='L', ... )
+*
+* (5-8) Same as 1-4, but for DSPTRD and DOPGTR.
+*
+* (9) | S - Z D Z' | / ( |S| n ulp ) DSTEQR('V',...)
+*
+* (10) | I - ZZ' | / ( n ulp ) DSTEQR('V',...)
+*
+* (11) | D1 - D2 | / ( |D1| ulp ) DSTEQR('N',...)
+*
+* (12) | D1 - D3 | / ( |D1| ulp ) DSTERF
+*
+* (13) 0 if the true eigenvalues (computed by sturm count)
+* of S are within THRESH of
+* those in D1. 2*THRESH if they are not. (Tested using
+* DSTECH)
+*
+* For S positive definite,
+*
+* (14) | S - Z4 D4 Z4' | / ( |S| n ulp ) DPTEQR('V',...)
+*
+* (15) | I - Z4 Z4' | / ( n ulp ) DPTEQR('V',...)
+*
+* (16) | D4 - D5 | / ( 100 |D4| ulp ) DPTEQR('N',...)
+*
+* When S is also diagonally dominant by the factor gamma < 1,
+*
+* (17) max | D4(i) - WR(i) | / ( |D4(i)| omega ) ,
+* i
+* omega = 2 (2n-1) ULP (1 + 8 gamma**2) / (1 - gamma)**4
+* DSTEBZ( 'A', 'E', ...)
+*
+* (18) | WA1 - D3 | / ( |D3| ulp ) DSTEBZ( 'A', 'E', ...)
+*
+* (19) ( max { min | WA2(i)-WA3(j) | } +
+* i j
+* max { min | WA3(i)-WA2(j) | } ) / ( |D3| ulp )
+* i j
+* DSTEBZ( 'I', 'E', ...)
+*
+* (20) | S - Y WA1 Y' | / ( |S| n ulp ) DSTEBZ, SSTEIN
+*
+* (21) | I - Y Y' | / ( n ulp ) DSTEBZ, SSTEIN
+*
+* (22) | S - Z D Z' | / ( |S| n ulp ) DSTEDC('I')
+*
+* (23) | I - ZZ' | / ( n ulp ) DSTEDC('I')
+*
+* (24) | S - Z D Z' | / ( |S| n ulp ) DSTEDC('V')
+*
+* (25) | I - ZZ' | / ( n ulp ) DSTEDC('V')
+*
+* (26) | D1 - D2 | / ( |D1| ulp ) DSTEDC('V') and
+* DSTEDC('N')
+*
+* Test 27 is disabled at the moment because DSTEMR does not
+* guarantee high relatvie accuracy.
+*
+* (27) max | D6(i) - WR(i) | / ( |D6(i)| omega ) ,
+* i
+* omega = 2 (2n-1) ULP (1 + 8 gamma**2) / (1 - gamma)**4
+* DSTEMR('V', 'A')
+*
+* (28) max | D6(i) - WR(i) | / ( |D6(i)| omega ) ,
+* i
+* omega = 2 (2n-1) ULP (1 + 8 gamma**2) / (1 - gamma)**4
+* DSTEMR('V', 'I')
+*
+* Tests 29 through 34 are disable at present because DSTEMR
+* does not handle partial specturm requests.
+*
+* (29) | S - Z D Z' | / ( |S| n ulp ) DSTEMR('V', 'I')
+*
+* (30) | I - ZZ' | / ( n ulp ) DSTEMR('V', 'I')
+*
+* (31) ( max { min | WA2(i)-WA3(j) | } +
+* i j
+* max { min | WA3(i)-WA2(j) | } ) / ( |D3| ulp )
+* i j
+* DSTEMR('N', 'I') vs. SSTEMR('V', 'I')
+*
+* (32) | S - Z D Z' | / ( |S| n ulp ) DSTEMR('V', 'V')
+*
+* (33) | I - ZZ' | / ( n ulp ) DSTEMR('V', 'V')
+*
+* (34) ( max { min | WA2(i)-WA3(j) | } +
+* i j
+* max { min | WA3(i)-WA2(j) | } ) / ( |D3| ulp )
+* i j
+* DSTEMR('N', 'V') vs. SSTEMR('V', 'V')
+*
+* (35) | S - Z D Z' | / ( |S| n ulp ) DSTEMR('V', 'A')
+*
+* (36) | I - ZZ' | / ( n ulp ) DSTEMR('V', 'A')
+*
+* (37) ( max { min | WA2(i)-WA3(j) | } +
+* i j
+* max { min | WA3(i)-WA2(j) | } ) / ( |D3| ulp )
+* i j
+* DSTEMR('N', 'A') vs. SSTEMR('V', 'A')
+*
+* The "sizes" are specified by an array NN(1:NSIZES); the value of
+* each element NN(j) specifies one size.
+* The "types" are specified by a logical array DOTYPE( 1:NTYPES );
+* if DOTYPE(j) is .TRUE., then matrix type "j" will be generated.
+* Currently, the list of possible types is:
+*
+* (1) The zero matrix.
+* (2) The identity matrix.
+*
+* (3) A diagonal matrix with evenly spaced entries
+* 1, ..., ULP and random signs.
+* (ULP = (first number larger than 1) - 1 )
+* (4) A diagonal matrix with geometrically spaced entries
+* 1, ..., ULP and random signs.
+* (5) A diagonal matrix with "clustered" entries 1, ULP, ..., ULP
+* and random signs.
+*
+* (6) Same as (4), but multiplied by SQRT( overflow threshold )
+* (7) Same as (4), but multiplied by SQRT( underflow threshold )
+*
+* (8) A matrix of the form U' D U, where U is orthogonal and
+* D has evenly spaced entries 1, ..., ULP with random signs
+* on the diagonal.
+*
+* (9) A matrix of the form U' D U, where U is orthogonal and
+* D has geometrically spaced entries 1, ..., ULP with random
+* signs on the diagonal.
+*
+* (10) A matrix of the form U' D U, where U is orthogonal and
+* D has "clustered" entries 1, ULP,..., ULP with random
+* signs on the diagonal.
+*
+* (11) Same as (8), but multiplied by SQRT( overflow threshold )
+* (12) Same as (8), but multiplied by SQRT( underflow threshold )
+*
+* (13) Symmetric matrix with random entries chosen from (-1,1).
+* (14) Same as (13), but multiplied by SQRT( overflow threshold )
+* (15) Same as (13), but multiplied by SQRT( underflow threshold )
+* (16) Same as (8), but diagonal elements are all positive.
+* (17) Same as (9), but diagonal elements are all positive.
+* (18) Same as (10), but diagonal elements are all positive.
+* (19) Same as (16), but multiplied by SQRT( overflow threshold )
+* (20) Same as (16), but multiplied by SQRT( underflow threshold )
+* (21) A diagonally dominant tridiagonal matrix with geometrically
+* spaced diagonal entries 1, ..., ULP.
+*
+* Arguments
+* =========
+*
+* NSIZES (input) INTEGER
+* The number of sizes of matrices to use. If it is zero,
+* DCHKST does nothing. It must be at least zero.
+*
+* NN (input) INTEGER array, dimension (NSIZES)
+* An array containing the sizes to be used for the matrices.
+* Zero values will be skipped. The values must be at least
+* zero.
+*
+* NTYPES (input) INTEGER
+* The number of elements in DOTYPE. If it is zero, DCHKST
+* does nothing. It must be at least zero. If it is MAXTYP+1
+* and NSIZES is 1, then an additional type, MAXTYP+1 is
+* defined, which is to use whatever matrix is in A. This
+* is only useful if DOTYPE(1:MAXTYP) is .FALSE. and
+* DOTYPE(MAXTYP+1) is .TRUE. .
+*
+* DOTYPE (input) LOGICAL array, dimension (NTYPES)
+* If DOTYPE(j) is .TRUE., then for each size in NN a
+* matrix of that size and of type j will be generated.
+* If NTYPES is smaller than the maximum number of types
+* defined (PARAMETER MAXTYP), then types NTYPES+1 through
+* MAXTYP will not be generated. If NTYPES is larger
+* than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES)
+* will be ignored.
+*
+* ISEED (input/output) INTEGER array, dimension (4)
+* On entry ISEED specifies the seed of the random number
+* generator. The array elements should be between 0 and 4095;
+* if not they will be reduced mod 4096. Also, ISEED(4) must
+* be odd. The random number generator uses a linear
+* congruential sequence limited to small integers, and so
+* should produce machine independent random numbers. The
+* values of ISEED are changed on exit, and can be used in the
+* next call to DCHKST to continue the same random number
+* sequence.
+*
+* THRESH (input) DOUBLE PRECISION
+* A test will count as "failed" if the "error", computed as
+* described above, exceeds THRESH. Note that the error
+* is scaled to be O(1), so THRESH should be a reasonably
+* small multiple of 1, e.g., 10 or 100. In particular,
+* it should not depend on the precision (single vs. double)
+* or the size of the matrix. It must be at least zero.
+*
+* NOUNIT (input) INTEGER
+* The FORTRAN unit number for printing out error messages
+* (e.g., if a routine returns IINFO not equal to 0.)
+*
+* A (input/workspace/output) DOUBLE PRECISION array of
+* dimension ( LDA , max(NN) )
+* Used to hold the matrix whose eigenvalues are to be
+* computed. On exit, A contains the last matrix actually
+* used.
+*
+* LDA (input) INTEGER
+* The leading dimension of A. It must be at
+* least 1 and at least max( NN ).
+*
+* AP (workspace) DOUBLE PRECISION array of
+* dimension( max(NN)*max(NN+1)/2 )
+* The matrix A stored in packed format.
+*
+* SD (workspace/output) DOUBLE PRECISION array of
+* dimension( max(NN) )
+* The diagonal of the tridiagonal matrix computed by DSYTRD.
+* On exit, SD and SE contain the tridiagonal form of the
+* matrix in A.
+*
+* SE (workspace/output) DOUBLE PRECISION array of
+* dimension( max(NN) )
+* The off-diagonal of the tridiagonal matrix computed by
+* DSYTRD. On exit, SD and SE contain the tridiagonal form of
+* the matrix in A.
+*
+* D1 (workspace/output) DOUBLE PRECISION array of
+* dimension( max(NN) )
+* The eigenvalues of A, as computed by DSTEQR simlutaneously
+* with Z. On exit, the eigenvalues in D1 correspond with the
+* matrix in A.
+*
+* D2 (workspace/output) DOUBLE PRECISION array of
+* dimension( max(NN) )
+* The eigenvalues of A, as computed by DSTEQR if Z is not
+* computed. On exit, the eigenvalues in D2 correspond with
+* the matrix in A.
+*
+* D3 (workspace/output) DOUBLE PRECISION array of
+* dimension( max(NN) )
+* The eigenvalues of A, as computed by DSTERF. On exit, the
+* eigenvalues in D3 correspond with the matrix in A.
+*
+* U (workspace/output) DOUBLE PRECISION array of
+* dimension( LDU, max(NN) ).
+* The orthogonal matrix computed by DSYTRD + DORGTR.
+*
+* LDU (input) INTEGER
+* The leading dimension of U, Z, and V. It must be at least 1
+* and at least max( NN ).
+*
+* V (workspace/output) DOUBLE PRECISION array of
+* dimension( LDU, max(NN) ).
+* The Housholder vectors computed by DSYTRD in reducing A to
+* tridiagonal form. The vectors computed with UPLO='U' are
+* in the upper triangle, and the vectors computed with UPLO='L'
+* are in the lower triangle. (As described in DSYTRD, the
+* sub- and superdiagonal are not set to 1, although the
+* true Householder vector has a 1 in that position. The
+* routines that use V, such as DORGTR, set those entries to
+* 1 before using them, and then restore them later.)
+*
+* VP (workspace) DOUBLE PRECISION array of
+* dimension( max(NN)*max(NN+1)/2 )
+* The matrix V stored in packed format.
+*
+* TAU (workspace/output) DOUBLE PRECISION array of
+* dimension( max(NN) )
+* The Householder factors computed by DSYTRD in reducing A
+* to tridiagonal form.
+*
+* Z (workspace/output) DOUBLE PRECISION array of
+* dimension( LDU, max(NN) ).
+* The orthogonal matrix of eigenvectors computed by DSTEQR,
+* DPTEQR, and DSTEIN.
+*
+* WORK (workspace/output) DOUBLE PRECISION array of
+* dimension( LWORK )
+*
+* LWORK (input) INTEGER
+* The number of entries in WORK. This must be at least
+* 1 + 4 * Nmax + 2 * Nmax * lg Nmax + 3 * Nmax**2
+* where Nmax = max( NN(j), 2 ) and lg = log base 2.
+*
+* IWORK (workspace/output) INTEGER array,
+* dimension (6 + 6*Nmax + 5 * Nmax * lg Nmax )
+* where Nmax = max( NN(j), 2 ) and lg = log base 2.
+* Workspace.
+*
+* RESULT (output) DOUBLE PRECISION array, dimension (26)
+* The values computed by the tests described above.
+* The values are currently limited to 1/ulp, to avoid
+* overflow.
+*
+* INFO (output) INTEGER
+* If 0, then everything ran OK.
+* -1: NSIZES < 0
+* -2: Some NN(j) < 0
+* -3: NTYPES < 0
+* -5: THRESH < 0
+* -9: LDA < 1 or LDA < NMAX, where NMAX is max( NN(j) ).
+* -23: LDU < 1 or LDU < NMAX.
+* -29: LWORK too small.
+* If DLATMR, SLATMS, DSYTRD, DORGTR, DSTEQR, SSTERF,
+* or DORMC2 returns an error code, the
+* absolute value of it is returned.
+*
+*-----------------------------------------------------------------------
+*
+* Some Local Variables and Parameters:
+* ---- ----- --------- --- ----------
+* ZERO, ONE Real 0 and 1.
+* MAXTYP The number of types defined.
+* NTEST The number of tests performed, or which can
+* be performed so far, for the current matrix.
+* NTESTT The total number of tests performed so far.
+* NBLOCK Blocksize as returned by ENVIR.
+* NMAX Largest value in NN.
+* NMATS The number of matrices generated so far.
+* NERRS The number of tests which have exceeded THRESH
+* so far.
+* COND, IMODE Values to be passed to the matrix generators.
+* ANORM Norm of A; passed to matrix generators.
+*
+* OVFL, UNFL Overflow and underflow thresholds.
+* ULP, ULPINV Finest relative precision and its inverse.
+* RTOVFL, RTUNFL Square roots of the previous 2 values.
+* The following four arrays decode JTYPE:
+* KTYPE(j) The general type (1-10) for type "j".
+* KMODE(j) The MODE value to be passed to the matrix
+* generator for type "j".
+* KMAGN(j) The order of magnitude ( O(1),
+* O(overflow^(1/2) ), O(underflow^(1/2) )
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE, TWO, EIGHT, TEN, HUN
+ PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0,
+ $ EIGHT = 8.0D0, TEN = 10.0D0, HUN = 100.0D0 )
+ DOUBLE PRECISION HALF
+ PARAMETER ( HALF = ONE / TWO )
+ INTEGER MAXTYP
+ PARAMETER ( MAXTYP = 21 )
+ LOGICAL SRANGE
+ PARAMETER ( SRANGE = .FALSE. )
+ LOGICAL SREL
+ PARAMETER ( SREL = .FALSE. )
+* ..
+* .. Local Scalars ..
+ LOGICAL BADNN, TRYRAC
+ INTEGER I, IINFO, IL, IMODE, ITEMP, ITYPE, IU, J, JC,
+ $ JR, JSIZE, JTYPE, LGN, LIWEDC, LOG2UI, LWEDC,
+ $ M, M2, M3, MTYPES, N, NAP, NBLOCK, NERRS,
+ $ NMATS, NMAX, NSPLIT, NTEST, NTESTT
+ DOUBLE PRECISION ABSTOL, ANINV, ANORM, COND, OVFL, RTOVFL,
+ $ RTUNFL, TEMP1, TEMP2, TEMP3, TEMP4, ULP,
+ $ ULPINV, UNFL, VL, VU
+* ..
+* .. Local Arrays ..
+ INTEGER IDUMMA( 1 ), IOLDSD( 4 ), ISEED2( 4 ),
+ $ KMAGN( MAXTYP ), KMODE( MAXTYP ),
+ $ KTYPE( MAXTYP )
+ DOUBLE PRECISION DUMMA( 1 )
+* ..
+* .. External Functions ..
+ INTEGER ILAENV
+ DOUBLE PRECISION DLAMCH, DLARND, DSXT1
+ EXTERNAL ILAENV, DLAMCH, DLARND, DSXT1
+* ..
+* .. External Subroutines ..
+ EXTERNAL DCOPY, DLABAD, DLACPY, DLASET, DLASUM, DLATMR,
+ $ DLATMS, DOPGTR, DORGTR, DPTEQR, DSPT21, DSPTRD,
+ $ DSTEBZ, DSTECH, DSTEDC, DSTEMR, DSTEIN, DSTEQR,
+ $ DSTERF, DSTT21, DSTT22, DSYT21, DSYTRD, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, DBLE, INT, LOG, MAX, MIN, SQRT
+* ..
+* .. Data statements ..
+ DATA KTYPE / 1, 2, 4, 4, 4, 4, 4, 5, 5, 5, 5, 5, 8,
+ $ 8, 8, 9, 9, 9, 9, 9, 10 /
+ DATA KMAGN / 1, 1, 1, 1, 1, 2, 3, 1, 1, 1, 2, 3, 1,
+ $ 2, 3, 1, 1, 1, 2, 3, 1 /
+ DATA KMODE / 0, 0, 4, 3, 1, 4, 4, 4, 3, 1, 4, 4, 0,
+ $ 0, 0, 4, 3, 1, 4, 4, 3 /
+* ..
+* .. Executable Statements ..
+*
+* Keep ftnchek happy
+ IDUMMA( 1 ) = 1
+*
+* Check for errors
+*
+ NTESTT = 0
+ INFO = 0
+*
+* Important constants
+*
+ BADNN = .FALSE.
+ TRYRAC = .TRUE.
+ NMAX = 1
+ DO 10 J = 1, NSIZES
+ NMAX = MAX( NMAX, NN( J ) )
+ IF( NN( J ).LT.0 )
+ $ BADNN = .TRUE.
+ 10 CONTINUE
+*
+ NBLOCK = ILAENV( 1, 'DSYTRD', 'L', NMAX, -1, -1, -1 )
+ NBLOCK = MIN( NMAX, MAX( 1, NBLOCK ) )
+*
+* Check for errors
+*
+ IF( NSIZES.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( BADNN ) THEN
+ INFO = -2
+ ELSE IF( NTYPES.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( LDA.LT.NMAX ) THEN
+ INFO = -9
+ ELSE IF( LDU.LT.NMAX ) THEN
+ INFO = -23
+ ELSE IF( 2*MAX( 2, NMAX )**2.GT.LWORK ) THEN
+ INFO = -29
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DCHKST', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( NSIZES.EQ.0 .OR. NTYPES.EQ.0 )
+ $ RETURN
+*
+* More Important constants
+*
+ UNFL = DLAMCH( 'Safe minimum' )
+ OVFL = ONE / UNFL
+ CALL DLABAD( UNFL, OVFL )
+ ULP = DLAMCH( 'Epsilon' )*DLAMCH( 'Base' )
+ ULPINV = ONE / ULP
+ LOG2UI = INT( LOG( ULPINV ) / LOG( TWO ) )
+ RTUNFL = SQRT( UNFL )
+ RTOVFL = SQRT( OVFL )
+*
+* Loop over sizes, types
+*
+ DO 20 I = 1, 4
+ ISEED2( I ) = ISEED( I )
+ 20 CONTINUE
+ NERRS = 0
+ NMATS = 0
+*
+ DO 310 JSIZE = 1, NSIZES
+ N = NN( JSIZE )
+ IF( N.GT.0 ) THEN
+ LGN = INT( LOG( DBLE( N ) ) / LOG( TWO ) )
+ IF( 2**LGN.LT.N )
+ $ LGN = LGN + 1
+ IF( 2**LGN.LT.N )
+ $ LGN = LGN + 1
+ LWEDC = 1 + 4*N + 2*N*LGN + 3*N**2
+ LIWEDC = 6 + 6*N + 5*N*LGN
+ ELSE
+ LWEDC = 8
+ LIWEDC = 12
+ END IF
+ NAP = ( N*( N+1 ) ) / 2
+ ANINV = ONE / DBLE( MAX( 1, N ) )
+*
+ IF( NSIZES.NE.1 ) THEN
+ MTYPES = MIN( MAXTYP, NTYPES )
+ ELSE
+ MTYPES = MIN( MAXTYP+1, NTYPES )
+ END IF
+*
+ DO 300 JTYPE = 1, MTYPES
+ IF( .NOT.DOTYPE( JTYPE ) )
+ $ GO TO 300
+ NMATS = NMATS + 1
+ NTEST = 0
+*
+ DO 30 J = 1, 4
+ IOLDSD( J ) = ISEED( J )
+ 30 CONTINUE
+*
+* Compute "A"
+*
+* Control parameters:
+*
+* KMAGN KMODE KTYPE
+* =1 O(1) clustered 1 zero
+* =2 large clustered 2 identity
+* =3 small exponential (none)
+* =4 arithmetic diagonal, (w/ eigenvalues)
+* =5 random log symmetric, w/ eigenvalues
+* =6 random (none)
+* =7 random diagonal
+* =8 random symmetric
+* =9 positive definite
+* =10 diagonally dominant tridiagonal
+*
+ IF( MTYPES.GT.MAXTYP )
+ $ GO TO 100
+*
+ ITYPE = KTYPE( JTYPE )
+ IMODE = KMODE( JTYPE )
+*
+* Compute norm
+*
+ GO TO ( 40, 50, 60 )KMAGN( JTYPE )
+*
+ 40 CONTINUE
+ ANORM = ONE
+ GO TO 70
+*
+ 50 CONTINUE
+ ANORM = ( RTOVFL*ULP )*ANINV
+ GO TO 70
+*
+ 60 CONTINUE
+ ANORM = RTUNFL*N*ULPINV
+ GO TO 70
+*
+ 70 CONTINUE
+*
+ CALL DLASET( 'Full', LDA, N, ZERO, ZERO, A, LDA )
+ IINFO = 0
+ IF( JTYPE.LE.15 ) THEN
+ COND = ULPINV
+ ELSE
+ COND = ULPINV*ANINV / TEN
+ END IF
+*
+* Special Matrices -- Identity & Jordan block
+*
+* Zero
+*
+ IF( ITYPE.EQ.1 ) THEN
+ IINFO = 0
+*
+ ELSE IF( ITYPE.EQ.2 ) THEN
+*
+* Identity
+*
+ DO 80 JC = 1, N
+ A( JC, JC ) = ANORM
+ 80 CONTINUE
+*
+ ELSE IF( ITYPE.EQ.4 ) THEN
+*
+* Diagonal Matrix, [Eigen]values Specified
+*
+ CALL DLATMS( N, N, 'S', ISEED, 'S', WORK, IMODE, COND,
+ $ ANORM, 0, 0, 'N', A, LDA, WORK( N+1 ),
+ $ IINFO )
+*
+*
+ ELSE IF( ITYPE.EQ.5 ) THEN
+*
+* Symmetric, eigenvalues specified
+*
+ CALL DLATMS( N, N, 'S', ISEED, 'S', WORK, IMODE, COND,
+ $ ANORM, N, N, 'N', A, LDA, WORK( N+1 ),
+ $ IINFO )
+*
+ ELSE IF( ITYPE.EQ.7 ) THEN
+*
+* Diagonal, random eigenvalues
+*
+ CALL DLATMR( N, N, 'S', ISEED, 'S', WORK, 6, ONE, ONE,
+ $ 'T', 'N', WORK( N+1 ), 1, ONE,
+ $ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, 0, 0,
+ $ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO )
+*
+ ELSE IF( ITYPE.EQ.8 ) THEN
+*
+* Symmetric, random eigenvalues
+*
+ CALL DLATMR( N, N, 'S', ISEED, 'S', WORK, 6, ONE, ONE,
+ $ 'T', 'N', WORK( N+1 ), 1, ONE,
+ $ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, N, N,
+ $ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO )
+*
+ ELSE IF( ITYPE.EQ.9 ) THEN
+*
+* Positive definite, eigenvalues specified.
+*
+ CALL DLATMS( N, N, 'S', ISEED, 'P', WORK, IMODE, COND,
+ $ ANORM, N, N, 'N', A, LDA, WORK( N+1 ),
+ $ IINFO )
+*
+ ELSE IF( ITYPE.EQ.10 ) THEN
+*
+* Positive definite tridiagonal, eigenvalues specified.
+*
+ CALL DLATMS( N, N, 'S', ISEED, 'P', WORK, IMODE, COND,
+ $ ANORM, 1, 1, 'N', A, LDA, WORK( N+1 ),
+ $ IINFO )
+ DO 90 I = 2, N
+ TEMP1 = ABS( A( I-1, I ) ) /
+ $ SQRT( ABS( A( I-1, I-1 )*A( I, I ) ) )
+ IF( TEMP1.GT.HALF ) THEN
+ A( I-1, I ) = HALF*SQRT( ABS( A( I-1, I-1 )*A( I,
+ $ I ) ) )
+ A( I, I-1 ) = A( I-1, I )
+ END IF
+ 90 CONTINUE
+*
+ ELSE
+*
+ IINFO = 1
+ END IF
+*
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUNIT, FMT = 9999 )'Generator', IINFO, N, JTYPE,
+ $ IOLDSD
+ INFO = ABS( IINFO )
+ RETURN
+ END IF
+*
+ 100 CONTINUE
+*
+* Call DSYTRD and DORGTR to compute S and U from
+* upper triangle.
+*
+ CALL DLACPY( 'U', N, N, A, LDA, V, LDU )
+*
+ NTEST = 1
+ CALL DSYTRD( 'U', N, V, LDU, SD, SE, TAU, WORK, LWORK,
+ $ IINFO )
+*
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUNIT, FMT = 9999 )'DSYTRD(U)', IINFO, N, JTYPE,
+ $ IOLDSD
+ INFO = ABS( IINFO )
+ IF( IINFO.LT.0 ) THEN
+ RETURN
+ ELSE
+ RESULT( 1 ) = ULPINV
+ GO TO 280
+ END IF
+ END IF
+*
+ CALL DLACPY( 'U', N, N, V, LDU, U, LDU )
+*
+ NTEST = 2
+ CALL DORGTR( 'U', N, U, LDU, TAU, WORK, LWORK, IINFO )
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUNIT, FMT = 9999 )'DORGTR(U)', IINFO, N, JTYPE,
+ $ IOLDSD
+ INFO = ABS( IINFO )
+ IF( IINFO.LT.0 ) THEN
+ RETURN
+ ELSE
+ RESULT( 2 ) = ULPINV
+ GO TO 280
+ END IF
+ END IF
+*
+* Do tests 1 and 2
+*
+ CALL DSYT21( 2, 'Upper', N, 1, A, LDA, SD, SE, U, LDU, V,
+ $ LDU, TAU, WORK, RESULT( 1 ) )
+ CALL DSYT21( 3, 'Upper', N, 1, A, LDA, SD, SE, U, LDU, V,
+ $ LDU, TAU, WORK, RESULT( 2 ) )
+*
+* Call DSYTRD and DORGTR to compute S and U from
+* lower triangle, do tests.
+*
+ CALL DLACPY( 'L', N, N, A, LDA, V, LDU )
+*
+ NTEST = 3
+ CALL DSYTRD( 'L', N, V, LDU, SD, SE, TAU, WORK, LWORK,
+ $ IINFO )
+*
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUNIT, FMT = 9999 )'DSYTRD(L)', IINFO, N, JTYPE,
+ $ IOLDSD
+ INFO = ABS( IINFO )
+ IF( IINFO.LT.0 ) THEN
+ RETURN
+ ELSE
+ RESULT( 3 ) = ULPINV
+ GO TO 280
+ END IF
+ END IF
+*
+ CALL DLACPY( 'L', N, N, V, LDU, U, LDU )
+*
+ NTEST = 4
+ CALL DORGTR( 'L', N, U, LDU, TAU, WORK, LWORK, IINFO )
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUNIT, FMT = 9999 )'DORGTR(L)', IINFO, N, JTYPE,
+ $ IOLDSD
+ INFO = ABS( IINFO )
+ IF( IINFO.LT.0 ) THEN
+ RETURN
+ ELSE
+ RESULT( 4 ) = ULPINV
+ GO TO 280
+ END IF
+ END IF
+*
+ CALL DSYT21( 2, 'Lower', N, 1, A, LDA, SD, SE, U, LDU, V,
+ $ LDU, TAU, WORK, RESULT( 3 ) )
+ CALL DSYT21( 3, 'Lower', N, 1, A, LDA, SD, SE, U, LDU, V,
+ $ LDU, TAU, WORK, RESULT( 4 ) )
+*
+* Store the upper triangle of A in AP
+*
+ I = 0
+ DO 120 JC = 1, N
+ DO 110 JR = 1, JC
+ I = I + 1
+ AP( I ) = A( JR, JC )
+ 110 CONTINUE
+ 120 CONTINUE
+*
+* Call DSPTRD and DOPGTR to compute S and U from AP
+*
+ CALL DCOPY( NAP, AP, 1, VP, 1 )
+*
+ NTEST = 5
+ CALL DSPTRD( 'U', N, VP, SD, SE, TAU, IINFO )
+*
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUNIT, FMT = 9999 )'DSPTRD(U)', IINFO, N, JTYPE,
+ $ IOLDSD
+ INFO = ABS( IINFO )
+ IF( IINFO.LT.0 ) THEN
+ RETURN
+ ELSE
+ RESULT( 5 ) = ULPINV
+ GO TO 280
+ END IF
+ END IF
+*
+ NTEST = 6
+ CALL DOPGTR( 'U', N, VP, TAU, U, LDU, WORK, IINFO )
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUNIT, FMT = 9999 )'DOPGTR(U)', IINFO, N, JTYPE,
+ $ IOLDSD
+ INFO = ABS( IINFO )
+ IF( IINFO.LT.0 ) THEN
+ RETURN
+ ELSE
+ RESULT( 6 ) = ULPINV
+ GO TO 280
+ END IF
+ END IF
+*
+* Do tests 5 and 6
+*
+ CALL DSPT21( 2, 'Upper', N, 1, AP, SD, SE, U, LDU, VP, TAU,
+ $ WORK, RESULT( 5 ) )
+ CALL DSPT21( 3, 'Upper', N, 1, AP, SD, SE, U, LDU, VP, TAU,
+ $ WORK, RESULT( 6 ) )
+*
+* Store the lower triangle of A in AP
+*
+ I = 0
+ DO 140 JC = 1, N
+ DO 130 JR = JC, N
+ I = I + 1
+ AP( I ) = A( JR, JC )
+ 130 CONTINUE
+ 140 CONTINUE
+*
+* Call DSPTRD and DOPGTR to compute S and U from AP
+*
+ CALL DCOPY( NAP, AP, 1, VP, 1 )
+*
+ NTEST = 7
+ CALL DSPTRD( 'L', N, VP, SD, SE, TAU, IINFO )
+*
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUNIT, FMT = 9999 )'DSPTRD(L)', IINFO, N, JTYPE,
+ $ IOLDSD
+ INFO = ABS( IINFO )
+ IF( IINFO.LT.0 ) THEN
+ RETURN
+ ELSE
+ RESULT( 7 ) = ULPINV
+ GO TO 280
+ END IF
+ END IF
+*
+ NTEST = 8
+ CALL DOPGTR( 'L', N, VP, TAU, U, LDU, WORK, IINFO )
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUNIT, FMT = 9999 )'DOPGTR(L)', IINFO, N, JTYPE,
+ $ IOLDSD
+ INFO = ABS( IINFO )
+ IF( IINFO.LT.0 ) THEN
+ RETURN
+ ELSE
+ RESULT( 8 ) = ULPINV
+ GO TO 280
+ END IF
+ END IF
+*
+ CALL DSPT21( 2, 'Lower', N, 1, AP, SD, SE, U, LDU, VP, TAU,
+ $ WORK, RESULT( 7 ) )
+ CALL DSPT21( 3, 'Lower', N, 1, AP, SD, SE, U, LDU, VP, TAU,
+ $ WORK, RESULT( 8 ) )
+*
+* Call DSTEQR to compute D1, D2, and Z, do tests.
+*
+* Compute D1 and Z
+*
+ CALL DCOPY( N, SD, 1, D1, 1 )
+ IF( N.GT.0 )
+ $ CALL DCOPY( N-1, SE, 1, WORK, 1 )
+ CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDU )
+*
+ NTEST = 9
+ CALL DSTEQR( 'V', N, D1, WORK, Z, LDU, WORK( N+1 ), IINFO )
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUNIT, FMT = 9999 )'DSTEQR(V)', IINFO, N, JTYPE,
+ $ IOLDSD
+ INFO = ABS( IINFO )
+ IF( IINFO.LT.0 ) THEN
+ RETURN
+ ELSE
+ RESULT( 9 ) = ULPINV
+ GO TO 280
+ END IF
+ END IF
+*
+* Compute D2
+*
+ CALL DCOPY( N, SD, 1, D2, 1 )
+ IF( N.GT.0 )
+ $ CALL DCOPY( N-1, SE, 1, WORK, 1 )
+*
+ NTEST = 11
+ CALL DSTEQR( 'N', N, D2, WORK, WORK( N+1 ), LDU,
+ $ WORK( N+1 ), IINFO )
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUNIT, FMT = 9999 )'DSTEQR(N)', IINFO, N, JTYPE,
+ $ IOLDSD
+ INFO = ABS( IINFO )
+ IF( IINFO.LT.0 ) THEN
+ RETURN
+ ELSE
+ RESULT( 11 ) = ULPINV
+ GO TO 280
+ END IF
+ END IF
+*
+* Compute D3 (using PWK method)
+*
+ CALL DCOPY( N, SD, 1, D3, 1 )
+ IF( N.GT.0 )
+ $ CALL DCOPY( N-1, SE, 1, WORK, 1 )
+*
+ NTEST = 12
+ CALL DSTERF( N, D3, WORK, IINFO )
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUNIT, FMT = 9999 )'DSTERF', IINFO, N, JTYPE,
+ $ IOLDSD
+ INFO = ABS( IINFO )
+ IF( IINFO.LT.0 ) THEN
+ RETURN
+ ELSE
+ RESULT( 12 ) = ULPINV
+ GO TO 280
+ END IF
+ END IF
+*
+* Do Tests 9 and 10
+*
+ CALL DSTT21( N, 0, SD, SE, D1, DUMMA, Z, LDU, WORK,
+ $ RESULT( 9 ) )
+*
+* Do Tests 11 and 12
+*
+ TEMP1 = ZERO
+ TEMP2 = ZERO
+ TEMP3 = ZERO
+ TEMP4 = ZERO
+*
+ DO 150 J = 1, N
+ TEMP1 = MAX( TEMP1, ABS( D1( J ) ), ABS( D2( J ) ) )
+ TEMP2 = MAX( TEMP2, ABS( D1( J )-D2( J ) ) )
+ TEMP3 = MAX( TEMP3, ABS( D1( J ) ), ABS( D3( J ) ) )
+ TEMP4 = MAX( TEMP4, ABS( D1( J )-D3( J ) ) )
+ 150 CONTINUE
+*
+ RESULT( 11 ) = TEMP2 / MAX( UNFL, ULP*MAX( TEMP1, TEMP2 ) )
+ RESULT( 12 ) = TEMP4 / MAX( UNFL, ULP*MAX( TEMP3, TEMP4 ) )
+*
+* Do Test 13 -- Sturm Sequence Test of Eigenvalues
+* Go up by factors of two until it succeeds
+*
+ NTEST = 13
+ TEMP1 = THRESH*( HALF-ULP )
+*
+ DO 160 J = 0, LOG2UI
+ CALL DSTECH( N, SD, SE, D1, TEMP1, WORK, IINFO )
+ IF( IINFO.EQ.0 )
+ $ GO TO 170
+ TEMP1 = TEMP1*TWO
+ 160 CONTINUE
+*
+ 170 CONTINUE
+ RESULT( 13 ) = TEMP1
+*
+* For positive definite matrices ( JTYPE.GT.15 ) call DPTEQR
+* and do tests 14, 15, and 16 .
+*
+ IF( JTYPE.GT.15 ) THEN
+*
+* Compute D4 and Z4
+*
+ CALL DCOPY( N, SD, 1, D4, 1 )
+ IF( N.GT.0 )
+ $ CALL DCOPY( N-1, SE, 1, WORK, 1 )
+ CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDU )
+*
+ NTEST = 14
+ CALL DPTEQR( 'V', N, D4, WORK, Z, LDU, WORK( N+1 ),
+ $ IINFO )
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUNIT, FMT = 9999 )'DPTEQR(V)', IINFO, N,
+ $ JTYPE, IOLDSD
+ INFO = ABS( IINFO )
+ IF( IINFO.LT.0 ) THEN
+ RETURN
+ ELSE
+ RESULT( 14 ) = ULPINV
+ GO TO 280
+ END IF
+ END IF
+*
+* Do Tests 14 and 15
+*
+ CALL DSTT21( N, 0, SD, SE, D4, DUMMA, Z, LDU, WORK,
+ $ RESULT( 14 ) )
+*
+* Compute D5
+*
+ CALL DCOPY( N, SD, 1, D5, 1 )
+ IF( N.GT.0 )
+ $ CALL DCOPY( N-1, SE, 1, WORK, 1 )
+*
+ NTEST = 16
+ CALL DPTEQR( 'N', N, D5, WORK, Z, LDU, WORK( N+1 ),
+ $ IINFO )
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUNIT, FMT = 9999 )'DPTEQR(N)', IINFO, N,
+ $ JTYPE, IOLDSD
+ INFO = ABS( IINFO )
+ IF( IINFO.LT.0 ) THEN
+ RETURN
+ ELSE
+ RESULT( 16 ) = ULPINV
+ GO TO 280
+ END IF
+ END IF
+*
+* Do Test 16
+*
+ TEMP1 = ZERO
+ TEMP2 = ZERO
+ DO 180 J = 1, N
+ TEMP1 = MAX( TEMP1, ABS( D4( J ) ), ABS( D5( J ) ) )
+ TEMP2 = MAX( TEMP2, ABS( D4( J )-D5( J ) ) )
+ 180 CONTINUE
+*
+ RESULT( 16 ) = TEMP2 / MAX( UNFL,
+ $ HUN*ULP*MAX( TEMP1, TEMP2 ) )
+ ELSE
+ RESULT( 14 ) = ZERO
+ RESULT( 15 ) = ZERO
+ RESULT( 16 ) = ZERO
+ END IF
+*
+* Call DSTEBZ with different options and do tests 17-18.
+*
+* If S is positive definite and diagonally dominant,
+* ask for all eigenvalues with high relative accuracy.
+*
+ VL = ZERO
+ VU = ZERO
+ IL = 0
+ IU = 0
+ IF( JTYPE.EQ.21 ) THEN
+ NTEST = 17
+ ABSTOL = UNFL + UNFL
+ CALL DSTEBZ( 'A', 'E', N, VL, VU, IL, IU, ABSTOL, SD, SE,
+ $ M, NSPLIT, WR, IWORK( 1 ), IWORK( N+1 ),
+ $ WORK, IWORK( 2*N+1 ), IINFO )
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUNIT, FMT = 9999 )'DSTEBZ(A,rel)', IINFO, N,
+ $ JTYPE, IOLDSD
+ INFO = ABS( IINFO )
+ IF( IINFO.LT.0 ) THEN
+ RETURN
+ ELSE
+ RESULT( 17 ) = ULPINV
+ GO TO 280
+ END IF
+ END IF
+*
+* Do test 17
+*
+ TEMP2 = TWO*( TWO*N-ONE )*ULP*( ONE+EIGHT*HALF**2 ) /
+ $ ( ONE-HALF )**4
+*
+ TEMP1 = ZERO
+ DO 190 J = 1, N
+ TEMP1 = MAX( TEMP1, ABS( D4( J )-WR( N-J+1 ) ) /
+ $ ( ABSTOL+ABS( D4( J ) ) ) )
+ 190 CONTINUE
+*
+ RESULT( 17 ) = TEMP1 / TEMP2
+ ELSE
+ RESULT( 17 ) = ZERO
+ END IF
+*
+* Now ask for all eigenvalues with high absolute accuracy.
+*
+ NTEST = 18
+ ABSTOL = UNFL + UNFL
+ CALL DSTEBZ( 'A', 'E', N, VL, VU, IL, IU, ABSTOL, SD, SE, M,
+ $ NSPLIT, WA1, IWORK( 1 ), IWORK( N+1 ), WORK,
+ $ IWORK( 2*N+1 ), IINFO )
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUNIT, FMT = 9999 )'DSTEBZ(A)', IINFO, N, JTYPE,
+ $ IOLDSD
+ INFO = ABS( IINFO )
+ IF( IINFO.LT.0 ) THEN
+ RETURN
+ ELSE
+ RESULT( 18 ) = ULPINV
+ GO TO 280
+ END IF
+ END IF
+*
+* Do test 18
+*
+ TEMP1 = ZERO
+ TEMP2 = ZERO
+ DO 200 J = 1, N
+ TEMP1 = MAX( TEMP1, ABS( D3( J ) ), ABS( WA1( J ) ) )
+ TEMP2 = MAX( TEMP2, ABS( D3( J )-WA1( J ) ) )
+ 200 CONTINUE
+*
+ RESULT( 18 ) = TEMP2 / MAX( UNFL, ULP*MAX( TEMP1, TEMP2 ) )
+*
+* Choose random values for IL and IU, and ask for the
+* IL-th through IU-th eigenvalues.
+*
+ NTEST = 19
+ IF( N.LE.1 ) THEN
+ IL = 1
+ IU = N
+ ELSE
+ IL = 1 + ( N-1 )*INT( DLARND( 1, ISEED2 ) )
+ IU = 1 + ( N-1 )*INT( DLARND( 1, ISEED2 ) )
+ IF( IU.LT.IL ) THEN
+ ITEMP = IU
+ IU = IL
+ IL = ITEMP
+ END IF
+ END IF
+*
+ CALL DSTEBZ( 'I', 'E', N, VL, VU, IL, IU, ABSTOL, SD, SE,
+ $ M2, NSPLIT, WA2, IWORK( 1 ), IWORK( N+1 ),
+ $ WORK, IWORK( 2*N+1 ), IINFO )
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUNIT, FMT = 9999 )'DSTEBZ(I)', IINFO, N, JTYPE,
+ $ IOLDSD
+ INFO = ABS( IINFO )
+ IF( IINFO.LT.0 ) THEN
+ RETURN
+ ELSE
+ RESULT( 19 ) = ULPINV
+ GO TO 280
+ END IF
+ END IF
+*
+* Determine the values VL and VU of the IL-th and IU-th
+* eigenvalues and ask for all eigenvalues in this range.
+*
+ IF( N.GT.0 ) THEN
+ IF( IL.NE.1 ) THEN
+ VL = WA1( IL ) - MAX( HALF*( WA1( IL )-WA1( IL-1 ) ),
+ $ ULP*ANORM, TWO*RTUNFL )
+ ELSE
+ VL = WA1( 1 ) - MAX( HALF*( WA1( N )-WA1( 1 ) ),
+ $ ULP*ANORM, TWO*RTUNFL )
+ END IF
+ IF( IU.NE.N ) THEN
+ VU = WA1( IU ) + MAX( HALF*( WA1( IU+1 )-WA1( IU ) ),
+ $ ULP*ANORM, TWO*RTUNFL )
+ ELSE
+ VU = WA1( N ) + MAX( HALF*( WA1( N )-WA1( 1 ) ),
+ $ ULP*ANORM, TWO*RTUNFL )
+ END IF
+ ELSE
+ VL = ZERO
+ VU = ONE
+ END IF
+*
+ CALL DSTEBZ( 'V', 'E', N, VL, VU, IL, IU, ABSTOL, SD, SE,
+ $ M3, NSPLIT, WA3, IWORK( 1 ), IWORK( N+1 ),
+ $ WORK, IWORK( 2*N+1 ), IINFO )
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUNIT, FMT = 9999 )'DSTEBZ(V)', IINFO, N, JTYPE,
+ $ IOLDSD
+ INFO = ABS( IINFO )
+ IF( IINFO.LT.0 ) THEN
+ RETURN
+ ELSE
+ RESULT( 19 ) = ULPINV
+ GO TO 280
+ END IF
+ END IF
+*
+ IF( M3.EQ.0 .AND. N.NE.0 ) THEN
+ RESULT( 19 ) = ULPINV
+ GO TO 280
+ END IF
+*
+* Do test 19
+*
+ TEMP1 = DSXT1( 1, WA2, M2, WA3, M3, ABSTOL, ULP, UNFL )
+ TEMP2 = DSXT1( 1, WA3, M3, WA2, M2, ABSTOL, ULP, UNFL )
+ IF( N.GT.0 ) THEN
+ TEMP3 = MAX( ABS( WA1( N ) ), ABS( WA1( 1 ) ) )
+ ELSE
+ TEMP3 = ZERO
+ END IF
+*
+ RESULT( 19 ) = ( TEMP1+TEMP2 ) / MAX( UNFL, TEMP3*ULP )
+*
+* Call DSTEIN to compute eigenvectors corresponding to
+* eigenvalues in WA1. (First call DSTEBZ again, to make sure
+* it returns these eigenvalues in the correct order.)
+*
+ NTEST = 21
+ CALL DSTEBZ( 'A', 'B', N, VL, VU, IL, IU, ABSTOL, SD, SE, M,
+ $ NSPLIT, WA1, IWORK( 1 ), IWORK( N+1 ), WORK,
+ $ IWORK( 2*N+1 ), IINFO )
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUNIT, FMT = 9999 )'DSTEBZ(A,B)', IINFO, N,
+ $ JTYPE, IOLDSD
+ INFO = ABS( IINFO )
+ IF( IINFO.LT.0 ) THEN
+ RETURN
+ ELSE
+ RESULT( 20 ) = ULPINV
+ RESULT( 21 ) = ULPINV
+ GO TO 280
+ END IF
+ END IF
+*
+ CALL DSTEIN( N, SD, SE, M, WA1, IWORK( 1 ), IWORK( N+1 ), Z,
+ $ LDU, WORK, IWORK( 2*N+1 ), IWORK( 3*N+1 ),
+ $ IINFO )
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUNIT, FMT = 9999 )'DSTEIN', IINFO, N, JTYPE,
+ $ IOLDSD
+ INFO = ABS( IINFO )
+ IF( IINFO.LT.0 ) THEN
+ RETURN
+ ELSE
+ RESULT( 20 ) = ULPINV
+ RESULT( 21 ) = ULPINV
+ GO TO 280
+ END IF
+ END IF
+*
+* Do tests 20 and 21
+*
+ CALL DSTT21( N, 0, SD, SE, WA1, DUMMA, Z, LDU, WORK,
+ $ RESULT( 20 ) )
+*
+* Call DSTEDC(I) to compute D1 and Z, do tests.
+*
+* Compute D1 and Z
+*
+ CALL DCOPY( N, SD, 1, D1, 1 )
+ IF( N.GT.0 )
+ $ CALL DCOPY( N-1, SE, 1, WORK, 1 )
+ CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDU )
+*
+ NTEST = 22
+ CALL DSTEDC( 'I', N, D1, WORK, Z, LDU, WORK( N+1 ), LWEDC-N,
+ $ IWORK, LIWEDC, IINFO )
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUNIT, FMT = 9999 )'DSTEDC(I)', IINFO, N, JTYPE,
+ $ IOLDSD
+ INFO = ABS( IINFO )
+ IF( IINFO.LT.0 ) THEN
+ RETURN
+ ELSE
+ RESULT( 22 ) = ULPINV
+ GO TO 280
+ END IF
+ END IF
+*
+* Do Tests 22 and 23
+*
+ CALL DSTT21( N, 0, SD, SE, D1, DUMMA, Z, LDU, WORK,
+ $ RESULT( 22 ) )
+*
+* Call DSTEDC(V) to compute D1 and Z, do tests.
+*
+* Compute D1 and Z
+*
+ CALL DCOPY( N, SD, 1, D1, 1 )
+ IF( N.GT.0 )
+ $ CALL DCOPY( N-1, SE, 1, WORK, 1 )
+ CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDU )
+*
+ NTEST = 24
+ CALL DSTEDC( 'V', N, D1, WORK, Z, LDU, WORK( N+1 ), LWEDC-N,
+ $ IWORK, LIWEDC, IINFO )
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUNIT, FMT = 9999 )'DSTEDC(V)', IINFO, N, JTYPE,
+ $ IOLDSD
+ INFO = ABS( IINFO )
+ IF( IINFO.LT.0 ) THEN
+ RETURN
+ ELSE
+ RESULT( 24 ) = ULPINV
+ GO TO 280
+ END IF
+ END IF
+*
+* Do Tests 24 and 25
+*
+ CALL DSTT21( N, 0, SD, SE, D1, DUMMA, Z, LDU, WORK,
+ $ RESULT( 24 ) )
+*
+* Call DSTEDC(N) to compute D2, do tests.
+*
+* Compute D2
+*
+ CALL DCOPY( N, SD, 1, D2, 1 )
+ IF( N.GT.0 )
+ $ CALL DCOPY( N-1, SE, 1, WORK, 1 )
+ CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDU )
+*
+ NTEST = 26
+ CALL DSTEDC( 'N', N, D2, WORK, Z, LDU, WORK( N+1 ), LWEDC-N,
+ $ IWORK, LIWEDC, IINFO )
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUNIT, FMT = 9999 )'DSTEDC(N)', IINFO, N, JTYPE,
+ $ IOLDSD
+ INFO = ABS( IINFO )
+ IF( IINFO.LT.0 ) THEN
+ RETURN
+ ELSE
+ RESULT( 26 ) = ULPINV
+ GO TO 280
+ END IF
+ END IF
+*
+* Do Test 26
+*
+ TEMP1 = ZERO
+ TEMP2 = ZERO
+*
+ DO 210 J = 1, N
+ TEMP1 = MAX( TEMP1, ABS( D1( J ) ), ABS( D2( J ) ) )
+ TEMP2 = MAX( TEMP2, ABS( D1( J )-D2( J ) ) )
+ 210 CONTINUE
+*
+ RESULT( 26 ) = TEMP2 / MAX( UNFL, ULP*MAX( TEMP1, TEMP2 ) )
+*
+* Only test DSTEMR if IEEE compliant
+*
+ IF( ILAENV( 10, 'DSTEMR', 'VA', 1, 0, 0, 0 ).EQ.1 .AND.
+ $ ILAENV( 11, 'DSTEMR', 'VA', 1, 0, 0, 0 ).EQ.1 ) THEN
+*
+* Call DSTEMR, do test 27 (relative eigenvalue accuracy)
+*
+* If S is positive definite and diagonally dominant,
+* ask for all eigenvalues with high relative accuracy.
+*
+ VL = ZERO
+ VU = ZERO
+ IL = 0
+ IU = 0
+ IF( JTYPE.EQ.21 .AND. SREL ) THEN
+ NTEST = 27
+ ABSTOL = UNFL + UNFL
+ CALL DSTEMR( 'V', 'A', N, SD, SE, VL, VU, IL, IU,
+ $ M, WR, Z, LDU, N, IWORK( 1 ), TRYRAC,
+ $ WORK, LWORK, IWORK( 2*N+1 ), LWORK-2*N,
+ $ IINFO )
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUNIT, FMT = 9999 )'DSTEMR(V,A,rel)',
+ $ IINFO, N, JTYPE, IOLDSD
+ INFO = ABS( IINFO )
+ IF( IINFO.LT.0 ) THEN
+ RETURN
+ ELSE
+ RESULT( 27 ) = ULPINV
+ GO TO 270
+ END IF
+ END IF
+*
+* Do test 27
+*
+ TEMP2 = TWO*( TWO*N-ONE )*ULP*( ONE+EIGHT*HALF**2 ) /
+ $ ( ONE-HALF )**4
+*
+ TEMP1 = ZERO
+ DO 220 J = 1, N
+ TEMP1 = MAX( TEMP1, ABS( D4( J )-WR( N-J+1 ) ) /
+ $ ( ABSTOL+ABS( D4( J ) ) ) )
+ 220 CONTINUE
+*
+ RESULT( 27 ) = TEMP1 / TEMP2
+*
+ IL = 1 + ( N-1 )*INT( DLARND( 1, ISEED2 ) )
+ IU = 1 + ( N-1 )*INT( DLARND( 1, ISEED2 ) )
+ IF( IU.LT.IL ) THEN
+ ITEMP = IU
+ IU = IL
+ IL = ITEMP
+ END IF
+*
+ IF( SRANGE ) THEN
+ NTEST = 28
+ ABSTOL = UNFL + UNFL
+ CALL DSTEMR( 'V', 'I', N, SD, SE, VL, VU, IL, IU,
+ $ M, WR, Z, LDU, N, IWORK( 1 ), TRYRAC,
+ $ WORK, LWORK, IWORK( 2*N+1 ),
+ $ LWORK-2*N, IINFO )
+*
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUNIT, FMT = 9999 )'DSTEMR(V,I,rel)',
+ $ IINFO, N, JTYPE, IOLDSD
+ INFO = ABS( IINFO )
+ IF( IINFO.LT.0 ) THEN
+ RETURN
+ ELSE
+ RESULT( 28 ) = ULPINV
+ GO TO 270
+ END IF
+ END IF
+*
+*
+* Do test 28
+*
+ TEMP2 = TWO*( TWO*N-ONE )*ULP*
+ $ ( ONE+EIGHT*HALF**2 ) / ( ONE-HALF )**4
+*
+ TEMP1 = ZERO
+ DO 230 J = IL, IU
+ TEMP1 = MAX( TEMP1, ABS( WR( J-IL+1 )-D4( N-J+
+ $ 1 ) ) / ( ABSTOL+ABS( WR( J-IL+1 ) ) ) )
+ 230 CONTINUE
+*
+ RESULT( 28 ) = TEMP1 / TEMP2
+ ELSE
+ RESULT( 28 ) = ZERO
+ END IF
+ ELSE
+ RESULT( 27 ) = ZERO
+ RESULT( 28 ) = ZERO
+ END IF
+*
+* Call DSTEMR(V,I) to compute D1 and Z, do tests.
+*
+* Compute D1 and Z
+*
+ CALL DCOPY( N, SD, 1, D5, 1 )
+ IF( N.GT.0 )
+ $ CALL DCOPY( N-1, SE, 1, WORK, 1 )
+ CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDU )
+*
+ IF( SRANGE ) THEN
+ NTEST = 29
+ IL = 1 + ( N-1 )*INT( DLARND( 1, ISEED2 ) )
+ IU = 1 + ( N-1 )*INT( DLARND( 1, ISEED2 ) )
+ IF( IU.LT.IL ) THEN
+ ITEMP = IU
+ IU = IL
+ IL = ITEMP
+ END IF
+ CALL DSTEMR( 'V', 'I', N, D5, WORK, VL, VU, IL, IU,
+ $ M, D1, Z, LDU, N, IWORK( 1 ), TRYRAC,
+ $ WORK( N+1 ), LWORK-N, IWORK( 2*N+1 ),
+ $ LIWORK-2*N, IINFO )
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUNIT, FMT = 9999 )'DSTEMR(V,I)', IINFO,
+ $ N, JTYPE, IOLDSD
+ INFO = ABS( IINFO )
+ IF( IINFO.LT.0 ) THEN
+ RETURN
+ ELSE
+ RESULT( 29 ) = ULPINV
+ GO TO 280
+ END IF
+ END IF
+*
+* Do Tests 29 and 30
+*
+ CALL DSTT22( N, M, 0, SD, SE, D1, DUMMA, Z, LDU, WORK,
+ $ M, RESULT( 29 ) )
+*
+* Call DSTEMR to compute D2, do tests.
+*
+* Compute D2
+*
+ CALL DCOPY( N, SD, 1, D5, 1 )
+ IF( N.GT.0 )
+ $ CALL DCOPY( N-1, SE, 1, WORK, 1 )
+*
+ NTEST = 31
+ CALL DSTEMR( 'N', 'I', N, D5, WORK, VL, VU, IL, IU,
+ $ M, D2, Z, LDU, N, IWORK( 1 ), TRYRAC,
+ $ WORK( N+1 ), LWORK-N, IWORK( 2*N+1 ),
+ $ LIWORK-2*N, IINFO )
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUNIT, FMT = 9999 )'DSTEMR(N,I)', IINFO,
+ $ N, JTYPE, IOLDSD
+ INFO = ABS( IINFO )
+ IF( IINFO.LT.0 ) THEN
+ RETURN
+ ELSE
+ RESULT( 31 ) = ULPINV
+ GO TO 280
+ END IF
+ END IF
+*
+* Do Test 31
+*
+ TEMP1 = ZERO
+ TEMP2 = ZERO
+*
+ DO 240 J = 1, IU - IL + 1
+ TEMP1 = MAX( TEMP1, ABS( D1( J ) ),
+ $ ABS( D2( J ) ) )
+ TEMP2 = MAX( TEMP2, ABS( D1( J )-D2( J ) ) )
+ 240 CONTINUE
+*
+ RESULT( 31 ) = TEMP2 / MAX( UNFL,
+ $ ULP*MAX( TEMP1, TEMP2 ) )
+*
+*
+* Call DSTEMR(V,V) to compute D1 and Z, do tests.
+*
+* Compute D1 and Z
+*
+ CALL DCOPY( N, SD, 1, D5, 1 )
+ IF( N.GT.0 )
+ $ CALL DCOPY( N-1, SE, 1, WORK, 1 )
+ CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDU )
+*
+ NTEST = 32
+*
+ IF( N.GT.0 ) THEN
+ IF( IL.NE.1 ) THEN
+ VL = D2( IL ) - MAX( HALF*
+ $ ( D2( IL )-D2( IL-1 ) ), ULP*ANORM,
+ $ TWO*RTUNFL )
+ ELSE
+ VL = D2( 1 ) - MAX( HALF*( D2( N )-D2( 1 ) ),
+ $ ULP*ANORM, TWO*RTUNFL )
+ END IF
+ IF( IU.NE.N ) THEN
+ VU = D2( IU ) + MAX( HALF*
+ $ ( D2( IU+1 )-D2( IU ) ), ULP*ANORM,
+ $ TWO*RTUNFL )
+ ELSE
+ VU = D2( N ) + MAX( HALF*( D2( N )-D2( 1 ) ),
+ $ ULP*ANORM, TWO*RTUNFL )
+ END IF
+ ELSE
+ VL = ZERO
+ VU = ONE
+ END IF
+*
+ CALL DSTEMR( 'V', 'V', N, D5, WORK, VL, VU, IL, IU,
+ $ M, D1, Z, LDU, N, IWORK( 1 ), TRYRAC,
+ $ WORK( N+1 ), LWORK-N, IWORK( 2*N+1 ),
+ $ LIWORK-2*N, IINFO )
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUNIT, FMT = 9999 )'DSTEMR(V,V)', IINFO,
+ $ N, JTYPE, IOLDSD
+ INFO = ABS( IINFO )
+ IF( IINFO.LT.0 ) THEN
+ RETURN
+ ELSE
+ RESULT( 32 ) = ULPINV
+ GO TO 280
+ END IF
+ END IF
+*
+* Do Tests 32 and 33
+*
+ CALL DSTT22( N, M, 0, SD, SE, D1, DUMMA, Z, LDU, WORK,
+ $ M, RESULT( 32 ) )
+*
+* Call DSTEMR to compute D2, do tests.
+*
+* Compute D2
+*
+ CALL DCOPY( N, SD, 1, D5, 1 )
+ IF( N.GT.0 )
+ $ CALL DCOPY( N-1, SE, 1, WORK, 1 )
+*
+ NTEST = 34
+ CALL DSTEMR( 'N', 'V', N, D5, WORK, VL, VU, IL, IU,
+ $ M, D2, Z, LDU, N, IWORK( 1 ), TRYRAC,
+ $ WORK( N+1 ), LWORK-N, IWORK( 2*N+1 ),
+ $ LIWORK-2*N, IINFO )
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUNIT, FMT = 9999 )'DSTEMR(N,V)', IINFO,
+ $ N, JTYPE, IOLDSD
+ INFO = ABS( IINFO )
+ IF( IINFO.LT.0 ) THEN
+ RETURN
+ ELSE
+ RESULT( 34 ) = ULPINV
+ GO TO 280
+ END IF
+ END IF
+*
+* Do Test 34
+*
+ TEMP1 = ZERO
+ TEMP2 = ZERO
+*
+ DO 250 J = 1, IU - IL + 1
+ TEMP1 = MAX( TEMP1, ABS( D1( J ) ),
+ $ ABS( D2( J ) ) )
+ TEMP2 = MAX( TEMP2, ABS( D1( J )-D2( J ) ) )
+ 250 CONTINUE
+*
+ RESULT( 34 ) = TEMP2 / MAX( UNFL,
+ $ ULP*MAX( TEMP1, TEMP2 ) )
+ ELSE
+ RESULT( 29 ) = ZERO
+ RESULT( 30 ) = ZERO
+ RESULT( 31 ) = ZERO
+ RESULT( 32 ) = ZERO
+ RESULT( 33 ) = ZERO
+ RESULT( 34 ) = ZERO
+ END IF
+*
+*
+* Call DSTEMR(V,A) to compute D1 and Z, do tests.
+*
+* Compute D1 and Z
+*
+ CALL DCOPY( N, SD, 1, D5, 1 )
+ IF( N.GT.0 )
+ $ CALL DCOPY( N-1, SE, 1, WORK, 1 )
+*
+ NTEST = 35
+*
+ CALL DSTEMR( 'V', 'A', N, D5, WORK, VL, VU, IL, IU,
+ $ M, D1, Z, LDU, N, IWORK( 1 ), TRYRAC,
+ $ WORK( N+1 ), LWORK-N, IWORK( 2*N+1 ),
+ $ LIWORK-2*N, IINFO )
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUNIT, FMT = 9999 )'DSTEMR(V,A)', IINFO, N,
+ $ JTYPE, IOLDSD
+ INFO = ABS( IINFO )
+ IF( IINFO.LT.0 ) THEN
+ RETURN
+ ELSE
+ RESULT( 35 ) = ULPINV
+ GO TO 280
+ END IF
+ END IF
+*
+* Do Tests 35 and 36
+*
+ CALL DSTT22( N, M, 0, SD, SE, D1, DUMMA, Z, LDU, WORK, M,
+ $ RESULT( 35 ) )
+*
+* Call DSTEMR to compute D2, do tests.
+*
+* Compute D2
+*
+ CALL DCOPY( N, SD, 1, D5, 1 )
+ IF( N.GT.0 )
+ $ CALL DCOPY( N-1, SE, 1, WORK, 1 )
+*
+ NTEST = 37
+ CALL DSTEMR( 'N', 'A', N, D5, WORK, VL, VU, IL, IU,
+ $ M, D2, Z, LDU, N, IWORK( 1 ), TRYRAC,
+ $ WORK( N+1 ), LWORK-N, IWORK( 2*N+1 ),
+ $ LIWORK-2*N, IINFO )
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUNIT, FMT = 9999 )'DSTEMR(N,A)', IINFO, N,
+ $ JTYPE, IOLDSD
+ INFO = ABS( IINFO )
+ IF( IINFO.LT.0 ) THEN
+ RETURN
+ ELSE
+ RESULT( 37 ) = ULPINV
+ GO TO 280
+ END IF
+ END IF
+*
+* Do Test 34
+*
+ TEMP1 = ZERO
+ TEMP2 = ZERO
+*
+ DO 260 J = 1, N
+ TEMP1 = MAX( TEMP1, ABS( D1( J ) ), ABS( D2( J ) ) )
+ TEMP2 = MAX( TEMP2, ABS( D1( J )-D2( J ) ) )
+ 260 CONTINUE
+*
+ RESULT( 37 ) = TEMP2 / MAX( UNFL,
+ $ ULP*MAX( TEMP1, TEMP2 ) )
+ END IF
+ 270 CONTINUE
+ 280 CONTINUE
+ NTESTT = NTESTT + NTEST
+*
+* End of Loop -- Check for RESULT(j) > THRESH
+*
+*
+* Print out tests which fail.
+*
+ DO 290 JR = 1, NTEST
+ IF( RESULT( JR ).GE.THRESH ) THEN
+*
+* If this is the first test to fail,
+* print a header to the data file.
+*
+ IF( NERRS.EQ.0 ) THEN
+ WRITE( NOUNIT, FMT = 9998 )'DST'
+ WRITE( NOUNIT, FMT = 9997 )
+ WRITE( NOUNIT, FMT = 9996 )
+ WRITE( NOUNIT, FMT = 9995 )'Symmetric'
+ WRITE( NOUNIT, FMT = 9994 )
+*
+* Tests performed
+*
+ WRITE( NOUNIT, FMT = 9988 )
+ END IF
+ NERRS = NERRS + 1
+ WRITE( NOUNIT, FMT = 9990 )N, IOLDSD, JTYPE, JR,
+ $ RESULT( JR )
+ END IF
+ 290 CONTINUE
+ 300 CONTINUE
+ 310 CONTINUE
+*
+* Summary
+*
+ CALL DLASUM( 'DST', NOUNIT, NERRS, NTESTT )
+ RETURN
+*
+ 9999 FORMAT( ' DCHKST: ', A, ' returned INFO=', I6, '.', / 9X, 'N=',
+ $ I6, ', JTYPE=', I6, ', ISEED=(', 3( I5, ',' ), I5, ')' )
+*
+ 9998 FORMAT( / 1X, A3, ' -- Real Symmetric eigenvalue problem' )
+ 9997 FORMAT( ' Matrix types (see DCHKST for details): ' )
+*
+ 9996 FORMAT( / ' Special Matrices:',
+ $ / ' 1=Zero matrix. ',
+ $ ' 5=Diagonal: clustered entries.',
+ $ / ' 2=Identity matrix. ',
+ $ ' 6=Diagonal: large, evenly spaced.',
+ $ / ' 3=Diagonal: evenly spaced entries. ',
+ $ ' 7=Diagonal: small, evenly spaced.',
+ $ / ' 4=Diagonal: geometr. spaced entries.' )
+ 9995 FORMAT( ' Dense ', A, ' Matrices:',
+ $ / ' 8=Evenly spaced eigenvals. ',
+ $ ' 12=Small, evenly spaced eigenvals.',
+ $ / ' 9=Geometrically spaced eigenvals. ',
+ $ ' 13=Matrix with random O(1) entries.',
+ $ / ' 10=Clustered eigenvalues. ',
+ $ ' 14=Matrix with large random entries.',
+ $ / ' 11=Large, evenly spaced eigenvals. ',
+ $ ' 15=Matrix with small random entries.' )
+ 9994 FORMAT( ' 16=Positive definite, evenly spaced eigenvalues',
+ $ / ' 17=Positive definite, geometrically spaced eigenvlaues',
+ $ / ' 18=Positive definite, clustered eigenvalues',
+ $ / ' 19=Positive definite, small evenly spaced eigenvalues',
+ $ / ' 20=Positive definite, large evenly spaced eigenvalues',
+ $ / ' 21=Diagonally dominant tridiagonal, geometrically',
+ $ ' spaced eigenvalues' )
+*
+ 9993 FORMAT( / ' Tests performed: ',
+ $ '(S is Tridiag, D is diagonal, U and Z are ', A, ',', / 20X,
+ $ A, ', W is a diagonal matrix of eigenvalues,', / 20X,
+ $ ' V is U represented by Householder vectors, and', / 20X,
+ $ ' Y is a matrix of eigenvectors of S.)',
+ $ / ' DSYTRD, UPLO=''U'':', / ' 1= | A - V S V', A1,
+ $ ' | / ( |A| n ulp ) ', ' 2= | I - U V', A1,
+ $ ' | / ( n ulp )', / ' DSYTRD, UPLO=''L'':',
+ $ / ' 3= | A - V S V', A1, ' | / ( |A| n ulp ) ',
+ $ ' 4= | I - U V', A1, ' | / ( n ulp )' )
+ 9992 FORMAT( ' DSPTRD, UPLO=''U'':', / ' 5= | A - V S V', A1,
+ $ ' | / ( |A| n ulp ) ', ' 6= | I - U V', A1,
+ $ ' | / ( n ulp )', / ' DSPTRD, UPLO=''L'':',
+ $ / ' 7= | A - V S V', A1, ' | / ( |A| n ulp ) ',
+ $ ' 8= | I - U V', A1, ' | / ( n ulp )',
+ $ / ' 9= | S - Z D Z', A1, ' | / ( |S| n ulp ) ',
+ $ ' 10= | I - Z Z', A1, ' | / ( n ulp )',
+ $ / ' 11= |D(with Z) - D(w/o Z)| / (|D| ulp) ',
+ $ ' 12= | D(PWK) - D(QR) | / (|D| ulp)',
+ $ / ' 13= Sturm sequence test on W ' )
+ 9991 FORMAT( ' 14= | S - Z4 D4 Z4', A1, ' | / (|S| n ulp)',
+ $ / ' 15= | I - Z4 Z4', A1, ' | / (n ulp ) ',
+ $ ' 16= | D4 - D5 | / ( 100 |D4| ulp ) ',
+ $ / ' 17= max | D4(i) - WR(i) | / ( |D4(i)| (2n-1) ulp )',
+ $ / ' 18= | WA1 - D3 | / ( |D3| ulp )',
+ $ / ' 19= max | WA2(i) - WA3(ii) | / ( |D3| ulp )',
+ $ / ' 20= | S - Y WA1 Y', A1, ' | / ( |S| n ulp )',
+ $ / ' 21= | I - Y Y', A1, ' | / ( n ulp )' )
+ 9990 FORMAT( ' N=', I5, ', seed=', 4( I4, ',' ), ' type ', I2,
+ $ ', test(', I2, ')=', G10.3 )
+ 9989 FORMAT( ' 22= | S - Z D Z', A1, '| / ( |S| n ulp ) for DSTEDC(I)',
+ $ / ' 23= | I - Z Z', A1, '| / ( n ulp ) for DSTEDC(I)',
+ $ / ' 24= | S - Z D Z', A1, '| / ( |S| n ulp ) for DSTEDC(V)',
+ $ / ' 25= | I - Z Z', A1, '| / ( n ulp ) for DSTEDC(V)',
+ $ / ' 26= | D1(DSTEDC(V)) - D2(SSTEDC(N)) | / ( |D1| ulp )' )
+*
+ 9988 FORMAT( / 'Test performed: see DCHKST for details.', / )
+* End of DCHKST
+*
+ END
+ SUBROUTINE DCKGLM( NN, MVAL, PVAL, NVAL, NMATS, ISEED, THRESH,
+ $ NMAX, A, AF, B, BF, X, WORK, RWORK, NIN, NOUT,
+ $ INFO )
+*
+* -- LAPACK test routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, NIN, NMATS, NMAX, NN, NOUT
+ DOUBLE PRECISION THRESH
+* ..
+* .. Array Arguments ..
+ INTEGER ISEED( 4 ), MVAL( * ), NVAL( * ), PVAL( * )
+ DOUBLE PRECISION A( * ), AF( * ), B( * ), BF( * ), RWORK( * ),
+ $ WORK( * ), X( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DCKGLM tests DGGGLM - subroutine for solving generalized linear
+* model problem.
+*
+* Arguments
+* =========
+*
+* NN (input) INTEGER
+* The number of values of N, M and P contained in the vectors
+* NVAL, MVAL and PVAL.
+*
+* MVAL (input) INTEGER array, dimension (NN)
+* The values of the matrix column dimension M.
+*
+* PVAL (input) INTEGER array, dimension (NN)
+* The values of the matrix column dimension P.
+*
+* NVAL (input) INTEGER array, dimension (NN)
+* The values of the matrix row dimension N.
+*
+* NMATS (input) INTEGER
+* The number of matrix types to be tested for each combination
+* of matrix dimensions. If NMATS >= NTYPES (the maximum
+* number of matrix types), then all the different types are
+* generated for testing. If NMATS < NTYPES, another input line
+* is read to get the numbers of the matrix types to be used.
+*
+* ISEED (input/output) INTEGER array, dimension (4)
+* On entry, the seed of the random number generator. The array
+* elements should be between 0 and 4095, otherwise they will be
+* reduced mod 4096, and ISEED(4) must be odd.
+* On exit, the next seed in the random number sequence after
+* all the test matrices have been generated.
+*
+* THRESH (input) DOUBLE PRECISION
+* The threshold value for the test ratios. A result is
+* included in the output file if RESID >= THRESH. To have
+* every test ratio printed, use THRESH = 0.
+*
+* NMAX (input) INTEGER
+* The maximum value permitted for M or N, used in dimensioning
+* the work arrays.
+*
+* A (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
+*
+* AF (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
+*
+* B (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
+*
+* BF (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
+*
+* X (workspace) DOUBLE PRECISION array, dimension (4*NMAX)
+*
+* RWORK (workspace) DOUBLE PRECISION array, dimension (NMAX)
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
+*
+* NIN (input) INTEGER
+* The unit number for input.
+*
+* NOUT (input) INTEGER
+* The unit number for output.
+*
+* INFO (output) INTEGER
+* = 0 : successful exit
+* > 0 : If DLATMS returns an error code, the absolute value
+* of it is returned.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ INTEGER NTYPES
+ PARAMETER ( NTYPES = 8 )
+* ..
+* .. Local Scalars ..
+ LOGICAL FIRSTT
+ CHARACTER DISTA, DISTB, TYPE
+ CHARACTER*3 PATH
+ INTEGER I, IINFO, IK, IMAT, KLA, KLB, KUA, KUB, LDA,
+ $ LDB, LWORK, M, MODEA, MODEB, N, NFAIL, NRUN, P
+ DOUBLE PRECISION ANORM, BNORM, CNDNMA, CNDNMB, RESID
+* ..
+* .. Local Arrays ..
+ LOGICAL DOTYPE( NTYPES )
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DLARND
+ EXTERNAL DLARND
+* ..
+* .. External Subroutines ..
+ EXTERNAL ALAHDG, ALAREQ, ALASUM, DGLMTS, DLATB9, DLATMS
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS
+* ..
+* .. Executable Statements ..
+*
+* Initialize constants.
+*
+ PATH( 1: 3 ) = 'GLM'
+ INFO = 0
+ NRUN = 0
+ NFAIL = 0
+ FIRSTT = .TRUE.
+ CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT )
+ LDA = NMAX
+ LDB = NMAX
+ LWORK = NMAX*NMAX
+*
+* Check for valid input values.
+*
+ DO 10 IK = 1, NN
+ M = MVAL( IK )
+ P = PVAL( IK )
+ N = NVAL( IK )
+ IF( M.GT.N .OR. N.GT.M+P ) THEN
+ IF( FIRSTT ) THEN
+ WRITE( NOUT, FMT = * )
+ FIRSTT = .FALSE.
+ END IF
+ WRITE( NOUT, FMT = 9997 )M, P, N
+ END IF
+ 10 CONTINUE
+ FIRSTT = .TRUE.
+*
+* Do for each value of M in MVAL.
+*
+ DO 40 IK = 1, NN
+ M = MVAL( IK )
+ P = PVAL( IK )
+ N = NVAL( IK )
+ IF( M.GT.N .OR. N.GT.M+P )
+ $ GO TO 40
+*
+ DO 30 IMAT = 1, NTYPES
+*
+* Do the tests only if DOTYPE( IMAT ) is true.
+*
+ IF( .NOT.DOTYPE( IMAT ) )
+ $ GO TO 30
+*
+* Set up parameters with DLATB9 and generate test
+* matrices A and B with DLATMS.
+*
+ CALL DLATB9( PATH, IMAT, M, P, N, TYPE, KLA, KUA, KLB, KUB,
+ $ ANORM, BNORM, MODEA, MODEB, CNDNMA, CNDNMB,
+ $ DISTA, DISTB )
+*
+ CALL DLATMS( N, M, DISTA, ISEED, TYPE, RWORK, MODEA, CNDNMA,
+ $ ANORM, KLA, KUA, 'No packing', A, LDA, WORK,
+ $ IINFO )
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUT, FMT = 9999 )IINFO
+ INFO = ABS( IINFO )
+ GO TO 30
+ END IF
+*
+ CALL DLATMS( N, P, DISTB, ISEED, TYPE, RWORK, MODEB, CNDNMB,
+ $ BNORM, KLB, KUB, 'No packing', B, LDB, WORK,
+ $ IINFO )
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUT, FMT = 9999 )IINFO
+ INFO = ABS( IINFO )
+ GO TO 30
+ END IF
+*
+* Generate random left hand side vector of GLM
+*
+ DO 20 I = 1, N
+ X( I ) = DLARND( 2, ISEED )
+ 20 CONTINUE
+*
+ CALL DGLMTS( N, M, P, A, AF, LDA, B, BF, LDB, X,
+ $ X( NMAX+1 ), X( 2*NMAX+1 ), X( 3*NMAX+1 ),
+ $ WORK, LWORK, RWORK, RESID )
+*
+* Print information about the tests that did not
+* pass the threshold.
+*
+ IF( RESID.GE.THRESH ) THEN
+ IF( NFAIL.EQ.0 .AND. FIRSTT ) THEN
+ FIRSTT = .FALSE.
+ CALL ALAHDG( NOUT, PATH )
+ END IF
+ WRITE( NOUT, FMT = 9998 )N, M, P, IMAT, 1, RESID
+ NFAIL = NFAIL + 1
+ END IF
+ NRUN = NRUN + 1
+*
+ 30 CONTINUE
+ 40 CONTINUE
+*
+* Print a summary of the results.
+*
+ CALL ALASUM( PATH, NOUT, NFAIL, NRUN, 0 )
+*
+ 9999 FORMAT( ' DLATMS in DCKGLM INFO = ', I5 )
+ 9998 FORMAT( ' N=', I4, ' M=', I4, ', P=', I4, ', type ', I2,
+ $ ', test ', I2, ', ratio=', G13.6 )
+ 9997 FORMAT( ' *** Invalid input for GLM: M = ', I6, ', P = ', I6,
+ $ ', N = ', I6, ';', / ' must satisfy M <= N <= M+P ',
+ $ '(this set of values will be skipped)' )
+ RETURN
+*
+* End of DCKGLM
+*
+ END
+ SUBROUTINE DCKGQR( NM, MVAL, NP, PVAL, NN, NVAL, NMATS, ISEED,
+ $ THRESH, NMAX, A, AF, AQ, AR, TAUA, B, BF, BZ,
+ $ BT, BWK, TAUB, WORK, RWORK, NIN, NOUT, INFO )
+*
+* -- LAPACK test routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, NIN, NM, NMATS, NMAX, NN, NOUT, NP
+ DOUBLE PRECISION THRESH
+* ..
+* .. Array Arguments ..
+ INTEGER ISEED( 4 ), MVAL( * ), NVAL( * ), PVAL( * )
+ DOUBLE PRECISION A( * ), AF( * ), AQ( * ), AR( * ), B( * ),
+ $ BF( * ), BT( * ), BWK( * ), BZ( * ),
+ $ RWORK( * ), TAUA( * ), TAUB( * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DCKGQR tests
+* DGGQRF: GQR factorization for N-by-M matrix A and N-by-P matrix B,
+* DGGRQF: GRQ factorization for M-by-N matrix A and P-by-N matrix B.
+*
+* Arguments
+* =========
+*
+* NM (input) INTEGER
+* The number of values of M contained in the vector MVAL.
+*
+* MVAL (input) INTEGER array, dimension (NM)
+* The values of the matrix row(column) dimension M.
+*
+* NP (input) INTEGER
+* The number of values of P contained in the vector PVAL.
+*
+* PVAL (input) INTEGER array, dimension (NP)
+* The values of the matrix row(column) dimension P.
+*
+* NN (input) INTEGER
+* The number of values of N contained in the vector NVAL.
+*
+* NVAL (input) INTEGER array, dimension (NN)
+* The values of the matrix column(row) dimension N.
+*
+* NMATS (input) INTEGER
+* The number of matrix types to be tested for each combination
+* of matrix dimensions. If NMATS >= NTYPES (the maximum
+* number of matrix types), then all the different types are
+* generated for testing. If NMATS < NTYPES, another input line
+* is read to get the numbers of the matrix types to be used.
+*
+* ISEED (input/output) INTEGER array, dimension (4)
+* On entry, the seed of the random number generator. The array
+* elements should be between 0 and 4095, otherwise they will be
+* reduced mod 4096, and ISEED(4) must be odd.
+* On exit, the next seed in the random number sequence after
+* all the test matrices have been generated.
+*
+* THRESH (input) DOUBLE PRECISION
+* The threshold value for the test ratios. A result is
+* included in the output file if RESULT >= THRESH. To have
+* every test ratio printed, use THRESH = 0.
+*
+* NMAX (input) INTEGER
+* The maximum value permitted for M or N, used in dimensioning
+* the work arrays.
+*
+* A (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
+*
+* AF (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
+*
+* AQ (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
+*
+* AR (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
+*
+* TAUA (workspace) DOUBLE PRECISION array, dimension (NMAX)
+*
+* B (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
+*
+* BF (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
+*
+* BZ (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
+*
+* BT (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
+*
+* BWK (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
+*
+* TAUB (workspace) DOUBLE PRECISION array, dimension (NMAX)
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
+*
+* RWORK (workspace) DOUBLE PRECISION array, dimension (NMAX)
+*
+* NIN (input) INTEGER
+* The unit number for input.
+*
+* NOUT (input) INTEGER
+* The unit number for output.
+*
+* INFO (output) INTEGER
+* = 0 : successful exit
+* > 0 : If DLATMS returns an error code, the absolute value
+* of it is returned.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ INTEGER NTESTS
+ PARAMETER ( NTESTS = 7 )
+ INTEGER NTYPES
+ PARAMETER ( NTYPES = 8 )
+* ..
+* .. Local Scalars ..
+ LOGICAL FIRSTT
+ CHARACTER DISTA, DISTB, TYPE
+ CHARACTER*3 PATH
+ INTEGER I, IINFO, IM, IMAT, IN, IP, KLA, KLB, KUA, KUB,
+ $ LDA, LDB, LWORK, M, MODEA, MODEB, N, NFAIL,
+ $ NRUN, NT, P
+ DOUBLE PRECISION ANORM, BNORM, CNDNMA, CNDNMB
+* ..
+* .. Local Arrays ..
+ LOGICAL DOTYPE( NTYPES )
+ DOUBLE PRECISION RESULT( NTESTS )
+* ..
+* .. External Subroutines ..
+ EXTERNAL ALAHDG, ALAREQ, ALASUM, DGQRTS, DGRQTS, DLATB9,
+ $ DLATMS
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS
+* ..
+* .. Executable Statements ..
+*
+* Initialize constants.
+*
+ PATH( 1: 3 ) = 'GQR'
+ INFO = 0
+ NRUN = 0
+ NFAIL = 0
+ FIRSTT = .TRUE.
+ CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT )
+ LDA = NMAX
+ LDB = NMAX
+ LWORK = NMAX*NMAX
+*
+* Do for each value of M in MVAL.
+*
+ DO 60 IM = 1, NM
+ M = MVAL( IM )
+*
+* Do for each value of P in PVAL.
+*
+ DO 50 IP = 1, NP
+ P = PVAL( IP )
+*
+* Do for each value of N in NVAL.
+*
+ DO 40 IN = 1, NN
+ N = NVAL( IN )
+*
+ DO 30 IMAT = 1, NTYPES
+*
+* Do the tests only if DOTYPE( IMAT ) is true.
+*
+ IF( .NOT.DOTYPE( IMAT ) )
+ $ GO TO 30
+*
+* Test DGGRQF
+*
+* Set up parameters with DLATB9 and generate test
+* matrices A and B with DLATMS.
+*
+ CALL DLATB9( 'GRQ', IMAT, M, P, N, TYPE, KLA, KUA,
+ $ KLB, KUB, ANORM, BNORM, MODEA, MODEB,
+ $ CNDNMA, CNDNMB, DISTA, DISTB )
+*
+* Generate M by N matrix A
+*
+ CALL DLATMS( M, N, DISTA, ISEED, TYPE, RWORK, MODEA,
+ $ CNDNMA, ANORM, KLA, KUA, 'No packing', A,
+ $ LDA, WORK, IINFO )
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUT, FMT = 9999 )IINFO
+ INFO = ABS( IINFO )
+ GO TO 30
+ END IF
+*
+* Generate P by N matrix B
+*
+ CALL DLATMS( P, N, DISTB, ISEED, TYPE, RWORK, MODEB,
+ $ CNDNMB, BNORM, KLB, KUB, 'No packing', B,
+ $ LDB, WORK, IINFO )
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUT, FMT = 9999 )IINFO
+ INFO = ABS( IINFO )
+ GO TO 30
+ END IF
+*
+ NT = 4
+*
+ CALL DGRQTS( M, P, N, A, AF, AQ, AR, LDA, TAUA, B, BF,
+ $ BZ, BT, BWK, LDB, TAUB, WORK, LWORK,
+ $ RWORK, RESULT )
+*
+* Print information about the tests that did not
+* pass the threshold.
+*
+ DO 10 I = 1, NT
+ IF( RESULT( I ).GE.THRESH ) THEN
+ IF( NFAIL.EQ.0 .AND. FIRSTT ) THEN
+ FIRSTT = .FALSE.
+ CALL ALAHDG( NOUT, 'GRQ' )
+ END IF
+ WRITE( NOUT, FMT = 9998 )M, P, N, IMAT, I,
+ $ RESULT( I )
+ NFAIL = NFAIL + 1
+ END IF
+ 10 CONTINUE
+ NRUN = NRUN + NT
+*
+* Test DGGQRF
+*
+* Set up parameters with DLATB9 and generate test
+* matrices A and B with DLATMS.
+*
+ CALL DLATB9( 'GQR', IMAT, M, P, N, TYPE, KLA, KUA,
+ $ KLB, KUB, ANORM, BNORM, MODEA, MODEB,
+ $ CNDNMA, CNDNMB, DISTA, DISTB )
+*
+* Generate N-by-M matrix A
+*
+ CALL DLATMS( N, M, DISTA, ISEED, TYPE, RWORK, MODEA,
+ $ CNDNMA, ANORM, KLA, KUA, 'No packing', A,
+ $ LDA, WORK, IINFO )
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUT, FMT = 9999 )IINFO
+ INFO = ABS( IINFO )
+ GO TO 30
+ END IF
+*
+* Generate N-by-P matrix B
+*
+ CALL DLATMS( N, P, DISTB, ISEED, TYPE, RWORK, MODEA,
+ $ CNDNMA, BNORM, KLB, KUB, 'No packing', B,
+ $ LDB, WORK, IINFO )
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUT, FMT = 9999 )IINFO
+ INFO = ABS( IINFO )
+ GO TO 30
+ END IF
+*
+ NT = 4
+*
+ CALL DGQRTS( N, M, P, A, AF, AQ, AR, LDA, TAUA, B, BF,
+ $ BZ, BT, BWK, LDB, TAUB, WORK, LWORK,
+ $ RWORK, RESULT )
+*
+* Print information about the tests that did not
+* pass the threshold.
+*
+ DO 20 I = 1, NT
+ IF( RESULT( I ).GE.THRESH ) THEN
+ IF( NFAIL.EQ.0 .AND. FIRSTT ) THEN
+ FIRSTT = .FALSE.
+ CALL ALAHDG( NOUT, PATH )
+ END IF
+ WRITE( NOUT, FMT = 9997 )N, M, P, IMAT, I,
+ $ RESULT( I )
+ NFAIL = NFAIL + 1
+ END IF
+ 20 CONTINUE
+ NRUN = NRUN + NT
+*
+ 30 CONTINUE
+ 40 CONTINUE
+ 50 CONTINUE
+ 60 CONTINUE
+*
+* Print a summary of the results.
+*
+ CALL ALASUM( PATH, NOUT, NFAIL, NRUN, 0 )
+*
+ 9999 FORMAT( ' DLATMS in DCKGQR: INFO = ', I5 )
+ 9998 FORMAT( ' M=', I4, ' P=', I4, ', N=', I4, ', type ', I2,
+ $ ', test ', I2, ', ratio=', G13.6 )
+ 9997 FORMAT( ' N=', I4, ' M=', I4, ', P=', I4, ', type ', I2,
+ $ ', test ', I2, ', ratio=', G13.6 )
+ RETURN
+*
+* End of DCKGQR
+*
+ END
+ SUBROUTINE DCKGSV( NM, MVAL, PVAL, NVAL, NMATS, ISEED, THRESH,
+ $ NMAX, A, AF, B, BF, U, V, Q, ALPHA, BETA, R,
+ $ IWORK, WORK, RWORK, NIN, NOUT, INFO )
+*
+* -- LAPACK test routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, NIN, NM, NMATS, NMAX, NOUT
+ DOUBLE PRECISION THRESH
+* ..
+* .. Array Arguments ..
+ INTEGER ISEED( 4 ), IWORK( * ), MVAL( * ), NVAL( * ),
+ $ PVAL( * )
+ DOUBLE PRECISION A( * ), AF( * ), ALPHA( * ), B( * ), BETA( * ),
+ $ BF( * ), Q( * ), R( * ), RWORK( * ), U( * ),
+ $ V( * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DCKGSV tests DGGSVD:
+* the GSVD for M-by-N matrix A and P-by-N matrix B.
+*
+* Arguments
+* =========
+*
+* NM (input) INTEGER
+* The number of values of M contained in the vector MVAL.
+*
+* MVAL (input) INTEGER array, dimension (NM)
+* The values of the matrix row dimension M.
+*
+* PVAL (input) INTEGER array, dimension (NP)
+* The values of the matrix row dimension P.
+*
+* NVAL (input) INTEGER array, dimension (NN)
+* The values of the matrix column dimension N.
+*
+* NMATS (input) INTEGER
+* The number of matrix types to be tested for each combination
+* of matrix dimensions. If NMATS >= NTYPES (the maximum
+* number of matrix types), then all the different types are
+* generated for testing. If NMATS < NTYPES, another input line
+* is read to get the numbers of the matrix types to be used.
+*
+* ISEED (input/output) INTEGER array, dimension (4)
+* On entry, the seed of the random number generator. The array
+* elements should be between 0 and 4095, otherwise they will be
+* reduced mod 4096, and ISEED(4) must be odd.
+* On exit, the next seed in the random number sequence after
+* all the test matrices have been generated.
+*
+* THRESH (input) DOUBLE PRECISION
+* The threshold value for the test ratios. A result is
+* included in the output file if RESULT >= THRESH. To have
+* every test ratio printed, use THRESH = 0.
+*
+* NMAX (input) INTEGER
+* The maximum value permitted for M or N, used in dimensioning
+* the work arrays.
+*
+* A (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
+*
+* AF (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
+*
+* B (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
+*
+* BF (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
+*
+* U (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
+*
+* V (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
+*
+* Q (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
+*
+* ALPHA (workspace) DOUBLE PRECISION array, dimension (NMAX)
+*
+* BETA (workspace) DOUBLE PRECISION array, dimension (NMAX)
+*
+* R (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
+*
+* IWORK (workspace) INTEGER array, dimension (NMAX)
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
+*
+* RWORK (workspace) DOUBLE PRECISION array, dimension (NMAX)
+*
+* NIN (input) INTEGER
+* The unit number for input.
+*
+* NOUT (input) INTEGER
+* The unit number for output.
+*
+* INFO (output) INTEGER
+* = 0 : successful exit
+* > 0 : If DLATMS returns an error code, the absolute value
+* of it is returned.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ INTEGER NTESTS
+ PARAMETER ( NTESTS = 7 )
+ INTEGER NTYPES
+ PARAMETER ( NTYPES = 8 )
+* ..
+* .. Local Scalars ..
+ LOGICAL FIRSTT
+ CHARACTER DISTA, DISTB, TYPE
+ CHARACTER*3 PATH
+ INTEGER I, IINFO, IM, IMAT, KLA, KLB, KUA, KUB, LDA,
+ $ LDB, LDQ, LDR, LDU, LDV, LWORK, M, MODEA,
+ $ MODEB, N, NFAIL, NRUN, NT, P
+ DOUBLE PRECISION ANORM, BNORM, CNDNMA, CNDNMB
+* ..
+* .. Local Arrays ..
+ LOGICAL DOTYPE( NTYPES )
+ DOUBLE PRECISION RESULT( NTESTS )
+* ..
+* .. External Subroutines ..
+ EXTERNAL ALAHDG, ALAREQ, ALASUM, DGSVTS, DLATB9, DLATMS
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS
+* ..
+* .. Executable Statements ..
+*
+* Initialize constants and the random number seed.
+*
+ PATH( 1: 3 ) = 'GSV'
+ INFO = 0
+ NRUN = 0
+ NFAIL = 0
+ FIRSTT = .TRUE.
+ CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT )
+ LDA = NMAX
+ LDB = NMAX
+ LDU = NMAX
+ LDV = NMAX
+ LDQ = NMAX
+ LDR = NMAX
+ LWORK = NMAX*NMAX
+*
+* Do for each value of M in MVAL.
+*
+ DO 30 IM = 1, NM
+ M = MVAL( IM )
+ P = PVAL( IM )
+ N = NVAL( IM )
+*
+ DO 20 IMAT = 1, NTYPES
+*
+* Do the tests only if DOTYPE( IMAT ) is true.
+*
+ IF( .NOT.DOTYPE( IMAT ) )
+ $ GO TO 20
+*
+* Set up parameters with DLATB9 and generate test
+* matrices A and B with DLATMS.
+*
+ CALL DLATB9( PATH, IMAT, M, P, N, TYPE, KLA, KUA, KLB, KUB,
+ $ ANORM, BNORM, MODEA, MODEB, CNDNMA, CNDNMB,
+ $ DISTA, DISTB )
+*
+* Generate M by N matrix A
+*
+ CALL DLATMS( M, N, DISTA, ISEED, TYPE, RWORK, MODEA, CNDNMA,
+ $ ANORM, KLA, KUA, 'No packing', A, LDA, WORK,
+ $ IINFO )
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUT, FMT = 9999 )IINFO
+ INFO = ABS( IINFO )
+ GO TO 20
+ END IF
+*
+ CALL DLATMS( P, N, DISTB, ISEED, TYPE, RWORK, MODEB, CNDNMB,
+ $ BNORM, KLB, KUB, 'No packing', B, LDB, WORK,
+ $ IINFO )
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUT, FMT = 9999 )IINFO
+ INFO = ABS( IINFO )
+ GO TO 20
+ END IF
+*
+ NT = 6
+*
+ CALL DGSVTS( M, P, N, A, AF, LDA, B, BF, LDB, U, LDU, V,
+ $ LDV, Q, LDQ, ALPHA, BETA, R, LDR, IWORK, WORK,
+ $ LWORK, RWORK, RESULT )
+*
+* Print information about the tests that did not
+* pass the threshold.
+*
+ DO 10 I = 1, NT
+ IF( RESULT( I ).GE.THRESH ) THEN
+ IF( NFAIL.EQ.0 .AND. FIRSTT ) THEN
+ FIRSTT = .FALSE.
+ CALL ALAHDG( NOUT, PATH )
+ END IF
+ WRITE( NOUT, FMT = 9998 )M, P, N, IMAT, I,
+ $ RESULT( I )
+ NFAIL = NFAIL + 1
+ END IF
+ 10 CONTINUE
+ NRUN = NRUN + NT
+ 20 CONTINUE
+ 30 CONTINUE
+*
+* Print a summary of the results.
+*
+ CALL ALASUM( PATH, NOUT, NFAIL, NRUN, 0 )
+*
+ 9999 FORMAT( ' DLATMS in DCKGSV INFO = ', I5 )
+ 9998 FORMAT( ' M=', I4, ' P=', I4, ', N=', I4, ', type ', I2,
+ $ ', test ', I2, ', ratio=', G13.6 )
+ RETURN
+*
+* End of DCKGSV
+*
+ END
+ SUBROUTINE DCKLSE( NN, MVAL, PVAL, NVAL, NMATS, ISEED, THRESH,
+ $ NMAX, A, AF, B, BF, X, WORK, RWORK, NIN, NOUT,
+ $ INFO )
+*
+* -- LAPACK test routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, NIN, NMATS, NMAX, NN, NOUT
+ DOUBLE PRECISION THRESH
+* ..
+* .. Array Arguments ..
+ INTEGER ISEED( 4 ), MVAL( * ), NVAL( * ), PVAL( * )
+ DOUBLE PRECISION A( * ), AF( * ), B( * ), BF( * ), RWORK( * ),
+ $ WORK( * ), X( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DCKLSE tests DGGLSE - a subroutine for solving linear equality
+* constrained least square problem (LSE).
+*
+* Arguments
+* =========
+*
+* NN (input) INTEGER
+* The number of values of (M,P,N) contained in the vectors
+* (MVAL, PVAL, NVAL).
+*
+* MVAL (input) INTEGER array, dimension (NN)
+* The values of the matrix row(column) dimension M.
+*
+* PVAL (input) INTEGER array, dimension (NN)
+* The values of the matrix row(column) dimension P.
+*
+* NVAL (input) INTEGER array, dimension (NN)
+* The values of the matrix column(row) dimension N.
+*
+* NMATS (input) INTEGER
+* The number of matrix types to be tested for each combination
+* of matrix dimensions. If NMATS >= NTYPES (the maximum
+* number of matrix types), then all the different types are
+* generated for testing. If NMATS < NTYPES, another input line
+* is read to get the numbers of the matrix types to be used.
+*
+* ISEED (input/output) INTEGER array, dimension (4)
+* On entry, the seed of the random number generator. The array
+* elements should be between 0 and 4095, otherwise they will be
+* reduced mod 4096, and ISEED(4) must be odd.
+* On exit, the next seed in the random number sequence after
+* all the test matrices have been generated.
+*
+* THRESH (input) DOUBLE PRECISION
+* The threshold value for the test ratios. A result is
+* included in the output file if RESULT >= THRESH. To have
+* every test ratio printed, use THRESH = 0.
+*
+* NMAX (input) INTEGER
+* The maximum value permitted for M or N, used in dimensioning
+* the work arrays.
+*
+* A (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
+*
+* AF (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
+*
+* B (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
+*
+* BF (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
+*
+* X (workspace) DOUBLE PRECISION array, dimension (5*NMAX)
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (NMAX*NMAX)
+*
+* RWORK (workspace) DOUBLE PRECISION array, dimension (NMAX)
+*
+* NIN (input) INTEGER
+* The unit number for input.
+*
+* NOUT (input) INTEGER
+* The unit number for output.
+*
+* INFO (output) INTEGER
+* = 0 : successful exit
+* > 0 : If DLATMS returns an error code, the absolute value
+* of it is returned.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ INTEGER NTESTS
+ PARAMETER ( NTESTS = 7 )
+ INTEGER NTYPES
+ PARAMETER ( NTYPES = 8 )
+* ..
+* .. Local Scalars ..
+ LOGICAL FIRSTT
+ CHARACTER DISTA, DISTB, TYPE
+ CHARACTER*3 PATH
+ INTEGER I, IINFO, IK, IMAT, KLA, KLB, KUA, KUB, LDA,
+ $ LDB, LWORK, M, MODEA, MODEB, N, NFAIL, NRUN,
+ $ NT, P
+ DOUBLE PRECISION ANORM, BNORM, CNDNMA, CNDNMB
+* ..
+* .. Local Arrays ..
+ LOGICAL DOTYPE( NTYPES )
+ DOUBLE PRECISION RESULT( NTESTS )
+* ..
+* .. External Subroutines ..
+ EXTERNAL ALAHDG, ALAREQ, ALASUM, DLARHS, DLATB9, DLATMS,
+ $ DLSETS
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX
+* ..
+* .. Executable Statements ..
+*
+* Initialize constants and the random number seed.
+*
+ PATH( 1: 3 ) = 'LSE'
+ INFO = 0
+ NRUN = 0
+ NFAIL = 0
+ FIRSTT = .TRUE.
+ CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT )
+ LDA = NMAX
+ LDB = NMAX
+ LWORK = NMAX*NMAX
+*
+* Check for valid input values.
+*
+ DO 10 IK = 1, NN
+ M = MVAL( IK )
+ P = PVAL( IK )
+ N = NVAL( IK )
+ IF( P.GT.N .OR. N.GT.M+P ) THEN
+ IF( FIRSTT ) THEN
+ WRITE( NOUT, FMT = * )
+ FIRSTT = .FALSE.
+ END IF
+ WRITE( NOUT, FMT = 9997 )M, P, N
+ END IF
+ 10 CONTINUE
+ FIRSTT = .TRUE.
+*
+* Do for each value of M in MVAL.
+*
+ DO 40 IK = 1, NN
+ M = MVAL( IK )
+ P = PVAL( IK )
+ N = NVAL( IK )
+ IF( P.GT.N .OR. N.GT.M+P )
+ $ GO TO 40
+*
+ DO 30 IMAT = 1, NTYPES
+*
+* Do the tests only if DOTYPE( IMAT ) is true.
+*
+ IF( .NOT.DOTYPE( IMAT ) )
+ $ GO TO 30
+*
+* Set up parameters with DLATB9 and generate test
+* matrices A and B with DLATMS.
+*
+ CALL DLATB9( PATH, IMAT, M, P, N, TYPE, KLA, KUA, KLB, KUB,
+ $ ANORM, BNORM, MODEA, MODEB, CNDNMA, CNDNMB,
+ $ DISTA, DISTB )
+*
+ CALL DLATMS( M, N, DISTA, ISEED, TYPE, RWORK, MODEA, CNDNMA,
+ $ ANORM, KLA, KUA, 'No packing', A, LDA, WORK,
+ $ IINFO )
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUT, FMT = 9999 )IINFO
+ INFO = ABS( IINFO )
+ GO TO 30
+ END IF
+*
+ CALL DLATMS( P, N, DISTB, ISEED, TYPE, RWORK, MODEB, CNDNMB,
+ $ BNORM, KLB, KUB, 'No packing', B, LDB, WORK,
+ $ IINFO )
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUT, FMT = 9999 )IINFO
+ INFO = ABS( IINFO )
+ GO TO 30
+ END IF
+*
+* Generate the right-hand sides C and D for the LSE.
+*
+ CALL DLARHS( 'DGE', 'New solution', 'Upper', 'N', M, N,
+ $ MAX( M-1, 0 ), MAX( N-1, 0 ), 1, A, LDA,
+ $ X( 4*NMAX+1 ), MAX( N, 1 ), X, MAX( M, 1 ),
+ $ ISEED, IINFO )
+*
+ CALL DLARHS( 'DGE', 'Computed', 'Upper', 'N', P, N,
+ $ MAX( P-1, 0 ), MAX( N-1, 0 ), 1, B, LDB,
+ $ X( 4*NMAX+1 ), MAX( N, 1 ), X( 2*NMAX+1 ),
+ $ MAX( P, 1 ), ISEED, IINFO )
+*
+ NT = 2
+*
+ CALL DLSETS( M, P, N, A, AF, LDA, B, BF, LDB, X,
+ $ X( NMAX+1 ), X( 2*NMAX+1 ), X( 3*NMAX+1 ),
+ $ X( 4*NMAX+1 ), WORK, LWORK, RWORK,
+ $ RESULT( 1 ) )
+*
+* Print information about the tests that did not
+* pass the threshold.
+*
+ DO 20 I = 1, NT
+ IF( RESULT( I ).GE.THRESH ) THEN
+ IF( NFAIL.EQ.0 .AND. FIRSTT ) THEN
+ FIRSTT = .FALSE.
+ CALL ALAHDG( NOUT, PATH )
+ END IF
+ WRITE( NOUT, FMT = 9998 )M, P, N, IMAT, I,
+ $ RESULT( I )
+ NFAIL = NFAIL + 1
+ END IF
+ 20 CONTINUE
+ NRUN = NRUN + NT
+*
+ 30 CONTINUE
+ 40 CONTINUE
+*
+* Print a summary of the results.
+*
+ CALL ALASUM( PATH, NOUT, NFAIL, NRUN, 0 )
+*
+ 9999 FORMAT( ' DLATMS in DCKLSE INFO = ', I5 )
+ 9998 FORMAT( ' M=', I4, ' P=', I4, ', N=', I4, ', type ', I2,
+ $ ', test ', I2, ', ratio=', G13.6 )
+ 9997 FORMAT( ' *** Invalid input for LSE: M = ', I6, ', P = ', I6,
+ $ ', N = ', I6, ';', / ' must satisfy P <= N <= P+M ',
+ $ '(this set of values will be skipped)' )
+ RETURN
+*
+* End of DCKLSE
+*
+ END
+ SUBROUTINE DDRGES( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH,
+ $ NOUNIT, A, LDA, B, S, T, Q, LDQ, Z, ALPHAR,
+ $ ALPHAI, BETA, WORK, LWORK, RESULT, BWORK,
+ $ INFO )
+*
+* -- LAPACK test routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LDA, LDQ, LWORK, NOUNIT, NSIZES, NTYPES
+ DOUBLE PRECISION THRESH
+* ..
+* .. Array Arguments ..
+ LOGICAL BWORK( * ), DOTYPE( * )
+ INTEGER ISEED( 4 ), NN( * )
+ DOUBLE PRECISION A( LDA, * ), ALPHAI( * ), ALPHAR( * ),
+ $ B( LDA, * ), BETA( * ), Q( LDQ, * ),
+ $ RESULT( 13 ), S( LDA, * ), T( LDA, * ),
+ $ WORK( * ), Z( LDQ, * )
+* ..
+*
+* Purpose
+* =======
+*
+* DDRGES checks the nonsymmetric generalized eigenvalue (Schur form)
+* problem driver DGGES.
+*
+* DGGES factors A and B as Q S Z' and Q T Z' , where ' means
+* transpose, T is upper triangular, S is in generalized Schur form
+* (block upper triangular, with 1x1 and 2x2 blocks on the diagonal,
+* the 2x2 blocks corresponding to complex conjugate pairs of
+* generalized eigenvalues), and Q and Z are orthogonal. It also
+* computes the generalized eigenvalues (alpha(j),beta(j)), j=1,...,n,
+* Thus, w(j) = alpha(j)/beta(j) is a root of the characteristic
+* equation
+* det( A - w(j) B ) = 0
+* Optionally it also reorder the eigenvalues so that a selected
+* cluster of eigenvalues appears in the leading diagonal block of the
+* Schur forms.
+*
+* When DDRGES is called, a number of matrix "sizes" ("N's") and a
+* number of matrix "TYPES" are specified. For each size ("N")
+* and each TYPE of matrix, a pair of matrices (A, B) will be generated
+* and used for testing. For each matrix pair, the following 13 tests
+* will be performed and compared with the threshhold THRESH except
+* the tests (5), (11) and (13).
+*
+*
+* (1) | A - Q S Z' | / ( |A| n ulp ) (no sorting of eigenvalues)
+*
+*
+* (2) | B - Q T Z' | / ( |B| n ulp ) (no sorting of eigenvalues)
+*
+*
+* (3) | I - QQ' | / ( n ulp ) (no sorting of eigenvalues)
+*
+*
+* (4) | I - ZZ' | / ( n ulp ) (no sorting of eigenvalues)
+*
+* (5) if A is in Schur form (i.e. quasi-triangular form)
+* (no sorting of eigenvalues)
+*
+* (6) if eigenvalues = diagonal blocks of the Schur form (S, T),
+* i.e., test the maximum over j of D(j) where:
+*
+* if alpha(j) is real:
+* |alpha(j) - S(j,j)| |beta(j) - T(j,j)|
+* D(j) = ------------------------ + -----------------------
+* max(|alpha(j)|,|S(j,j)|) max(|beta(j)|,|T(j,j)|)
+*
+* if alpha(j) is complex:
+* | det( s S - w T ) |
+* D(j) = ---------------------------------------------------
+* ulp max( s norm(S), |w| norm(T) )*norm( s S - w T )
+*
+* and S and T are here the 2 x 2 diagonal blocks of S and T
+* corresponding to the j-th and j+1-th eigenvalues.
+* (no sorting of eigenvalues)
+*
+* (7) | (A,B) - Q (S,T) Z' | / ( | (A,B) | n ulp )
+* (with sorting of eigenvalues).
+*
+* (8) | I - QQ' | / ( n ulp ) (with sorting of eigenvalues).
+*
+* (9) | I - ZZ' | / ( n ulp ) (with sorting of eigenvalues).
+*
+* (10) if A is in Schur form (i.e. quasi-triangular form)
+* (with sorting of eigenvalues).
+*
+* (11) if eigenvalues = diagonal blocks of the Schur form (S, T),
+* i.e. test the maximum over j of D(j) where:
+*
+* if alpha(j) is real:
+* |alpha(j) - S(j,j)| |beta(j) - T(j,j)|
+* D(j) = ------------------------ + -----------------------
+* max(|alpha(j)|,|S(j,j)|) max(|beta(j)|,|T(j,j)|)
+*
+* if alpha(j) is complex:
+* | det( s S - w T ) |
+* D(j) = ---------------------------------------------------
+* ulp max( s norm(S), |w| norm(T) )*norm( s S - w T )
+*
+* and S and T are here the 2 x 2 diagonal blocks of S and T
+* corresponding to the j-th and j+1-th eigenvalues.
+* (with sorting of eigenvalues).
+*
+* (12) if sorting worked and SDIM is the number of eigenvalues
+* which were SELECTed.
+*
+* Test Matrices
+* =============
+*
+* The sizes of the test matrices are specified by an array
+* NN(1:NSIZES); the value of each element NN(j) specifies one size.
+* The "types" are specified by a logical array DOTYPE( 1:NTYPES ); if
+* DOTYPE(j) is .TRUE., then matrix type "j" will be generated.
+* Currently, the list of possible types is:
+*
+* (1) ( 0, 0 ) (a pair of zero matrices)
+*
+* (2) ( I, 0 ) (an identity and a zero matrix)
+*
+* (3) ( 0, I ) (an identity and a zero matrix)
+*
+* (4) ( I, I ) (a pair of identity matrices)
+*
+* t t
+* (5) ( J , J ) (a pair of transposed Jordan blocks)
+*
+* t ( I 0 )
+* (6) ( X, Y ) where X = ( J 0 ) and Y = ( t )
+* ( 0 I ) ( 0 J )
+* and I is a k x k identity and J a (k+1)x(k+1)
+* Jordan block; k=(N-1)/2
+*
+* (7) ( D, I ) where D is diag( 0, 1,..., N-1 ) (a diagonal
+* matrix with those diagonal entries.)
+* (8) ( I, D )
+*
+* (9) ( big*D, small*I ) where "big" is near overflow and small=1/big
+*
+* (10) ( small*D, big*I )
+*
+* (11) ( big*I, small*D )
+*
+* (12) ( small*I, big*D )
+*
+* (13) ( big*D, big*I )
+*
+* (14) ( small*D, small*I )
+*
+* (15) ( D1, D2 ) where D1 is diag( 0, 0, 1, ..., N-3, 0 ) and
+* D2 is diag( 0, N-3, N-4,..., 1, 0, 0 )
+* t t
+* (16) Q ( J , J ) Z where Q and Z are random orthogonal matrices.
+*
+* (17) Q ( T1, T2 ) Z where T1 and T2 are upper triangular matrices
+* with random O(1) entries above the diagonal
+* and diagonal entries diag(T1) =
+* ( 0, 0, 1, ..., N-3, 0 ) and diag(T2) =
+* ( 0, N-3, N-4,..., 1, 0, 0 )
+*
+* (18) Q ( T1, T2 ) Z diag(T1) = ( 0, 0, 1, 1, s, ..., s, 0 )
+* diag(T2) = ( 0, 1, 0, 1,..., 1, 0 )
+* s = machine precision.
+*
+* (19) Q ( T1, T2 ) Z diag(T1)=( 0,0,1,1, 1-d, ..., 1-(N-5)*d=s, 0 )
+* diag(T2) = ( 0, 1, 0, 1, ..., 1, 0 )
+*
+* N-5
+* (20) Q ( T1, T2 ) Z diag(T1)=( 0, 0, 1, 1, a, ..., a =s, 0 )
+* diag(T2) = ( 0, 1, 0, 1, ..., 1, 0, 0 )
+*
+* (21) Q ( T1, T2 ) Z diag(T1)=( 0, 0, 1, r1, r2, ..., r(N-4), 0 )
+* diag(T2) = ( 0, 1, 0, 1, ..., 1, 0, 0 )
+* where r1,..., r(N-4) are random.
+*
+* (22) Q ( big*T1, small*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 )
+* diag(T2) = ( 0, 1, ..., 1, 0, 0 )
+*
+* (23) Q ( small*T1, big*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 )
+* diag(T2) = ( 0, 1, ..., 1, 0, 0 )
+*
+* (24) Q ( small*T1, small*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 )
+* diag(T2) = ( 0, 1, ..., 1, 0, 0 )
+*
+* (25) Q ( big*T1, big*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 )
+* diag(T2) = ( 0, 1, ..., 1, 0, 0 )
+*
+* (26) Q ( T1, T2 ) Z where T1 and T2 are random upper-triangular
+* matrices.
+*
+*
+* Arguments
+* =========
+*
+* NSIZES (input) INTEGER
+* The number of sizes of matrices to use. If it is zero,
+* DDRGES does nothing. NSIZES >= 0.
+*
+* NN (input) INTEGER array, dimension (NSIZES)
+* An array containing the sizes to be used for the matrices.
+* Zero values will be skipped. NN >= 0.
+*
+* NTYPES (input) INTEGER
+* The number of elements in DOTYPE. If it is zero, DDRGES
+* does nothing. It must be at least zero. If it is MAXTYP+1
+* and NSIZES is 1, then an additional type, MAXTYP+1 is
+* defined, which is to use whatever matrix is in A on input.
+* This is only useful if DOTYPE(1:MAXTYP) is .FALSE. and
+* DOTYPE(MAXTYP+1) is .TRUE. .
+*
+* DOTYPE (input) LOGICAL array, dimension (NTYPES)
+* If DOTYPE(j) is .TRUE., then for each size in NN a
+* matrix of that size and of type j will be generated.
+* If NTYPES is smaller than the maximum number of types
+* defined (PARAMETER MAXTYP), then types NTYPES+1 through
+* MAXTYP will not be generated. If NTYPES is larger
+* than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES)
+* will be ignored.
+*
+* ISEED (input/output) INTEGER array, dimension (4)
+* On entry ISEED specifies the seed of the random number
+* generator. The array elements should be between 0 and 4095;
+* if not they will be reduced mod 4096. Also, ISEED(4) must
+* be odd. The random number generator uses a linear
+* congruential sequence limited to small integers, and so
+* should produce machine independent random numbers. The
+* values of ISEED are changed on exit, and can be used in the
+* next call to DDRGES to continue the same random number
+* sequence.
+*
+* THRESH (input) DOUBLE PRECISION
+* A test will count as "failed" if the "error", computed as
+* described above, exceeds THRESH. Note that the error is
+* scaled to be O(1), so THRESH should be a reasonably small
+* multiple of 1, e.g., 10 or 100. In particular, it should
+* not depend on the precision (single vs. double) or the size
+* of the matrix. THRESH >= 0.
+*
+* NOUNIT (input) INTEGER
+* The FORTRAN unit number for printing out error messages
+* (e.g., if a routine returns IINFO not equal to 0.)
+*
+* A (input/workspace) DOUBLE PRECISION array,
+* dimension(LDA, max(NN))
+* Used to hold the original A matrix. Used as input only
+* if NTYPES=MAXTYP+1, DOTYPE(1:MAXTYP)=.FALSE., and
+* DOTYPE(MAXTYP+1)=.TRUE.
+*
+* LDA (input) INTEGER
+* The leading dimension of A, B, S, and T.
+* It must be at least 1 and at least max( NN ).
+*
+* B (input/workspace) DOUBLE PRECISION array,
+* dimension(LDA, max(NN))
+* Used to hold the original B matrix. Used as input only
+* if NTYPES=MAXTYP+1, DOTYPE(1:MAXTYP)=.FALSE., and
+* DOTYPE(MAXTYP+1)=.TRUE.
+*
+* S (workspace) DOUBLE PRECISION array, dimension (LDA, max(NN))
+* The Schur form matrix computed from A by DGGES. On exit, S
+* contains the Schur form matrix corresponding to the matrix
+* in A.
+*
+* T (workspace) DOUBLE PRECISION array, dimension (LDA, max(NN))
+* The upper triangular matrix computed from B by DGGES.
+*
+* Q (workspace) DOUBLE PRECISION array, dimension (LDQ, max(NN))
+* The (left) orthogonal matrix computed by DGGES.
+*
+* LDQ (input) INTEGER
+* The leading dimension of Q and Z. It must
+* be at least 1 and at least max( NN ).
+*
+* Z (workspace) DOUBLE PRECISION array, dimension( LDQ, max(NN) )
+* The (right) orthogonal matrix computed by DGGES.
+*
+* ALPHAR (workspace) DOUBLE PRECISION array, dimension (max(NN))
+* ALPHAI (workspace) DOUBLE PRECISION array, dimension (max(NN))
+* BETA (workspace) DOUBLE PRECISION array, dimension (max(NN))
+* The generalized eigenvalues of (A,B) computed by DGGES.
+* ( ALPHAR(k)+ALPHAI(k)*i ) / BETA(k) is the k-th
+* generalized eigenvalue of A and B.
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK)
+*
+* LWORK (input) INTEGER
+* The dimension of the array WORK.
+* LWORK >= MAX( 10*(N+1), 3*N*N ), where N is the largest
+* matrix dimension.
+*
+* RESULT (output) DOUBLE PRECISION array, dimension (15)
+* The values computed by the tests described above.
+* The values are currently limited to 1/ulp, to avoid overflow.
+*
+* BWORK (workspace) LOGICAL array, dimension (N)
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value.
+* > 0: A routine returned an error code. INFO is the
+* absolute value of the INFO value returned.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+ INTEGER MAXTYP
+ PARAMETER ( MAXTYP = 26 )
+* ..
+* .. Local Scalars ..
+ LOGICAL BADNN, ILABAD
+ CHARACTER SORT
+ INTEGER I, I1, IADD, IERR, IINFO, IN, ISORT, J, JC, JR,
+ $ JSIZE, JTYPE, KNTEIG, MAXWRK, MINWRK, MTYPES,
+ $ N, N1, NB, NERRS, NMATS, NMAX, NTEST, NTESTT,
+ $ RSUB, SDIM
+ DOUBLE PRECISION SAFMAX, SAFMIN, TEMP1, TEMP2, ULP, ULPINV
+* ..
+* .. Local Arrays ..
+ INTEGER IASIGN( MAXTYP ), IBSIGN( MAXTYP ),
+ $ IOLDSD( 4 ), KADD( 6 ), KAMAGN( MAXTYP ),
+ $ KATYPE( MAXTYP ), KAZERO( MAXTYP ),
+ $ KBMAGN( MAXTYP ), KBTYPE( MAXTYP ),
+ $ KBZERO( MAXTYP ), KCLASS( MAXTYP ),
+ $ KTRIAN( MAXTYP ), KZ1( 6 ), KZ2( 6 )
+ DOUBLE PRECISION RMAGN( 0: 3 )
+* ..
+* .. External Functions ..
+ LOGICAL DLCTES
+ INTEGER ILAENV
+ DOUBLE PRECISION DLAMCH, DLARND
+ EXTERNAL DLCTES, ILAENV, DLAMCH, DLARND
+* ..
+* .. External Subroutines ..
+ EXTERNAL ALASVM, DGET51, DGET53, DGET54, DGGES, DLABAD,
+ $ DLACPY, DLARFG, DLASET, DLATM4, DORM2R, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, DBLE, MAX, MIN, SIGN
+* ..
+* .. Data statements ..
+ DATA KCLASS / 15*1, 10*2, 1*3 /
+ DATA KZ1 / 0, 1, 2, 1, 3, 3 /
+ DATA KZ2 / 0, 0, 1, 2, 1, 1 /
+ DATA KADD / 0, 0, 0, 0, 3, 2 /
+ DATA KATYPE / 0, 1, 0, 1, 2, 3, 4, 1, 4, 4, 1, 1, 4,
+ $ 4, 4, 2, 4, 5, 8, 7, 9, 4*4, 0 /
+ DATA KBTYPE / 0, 0, 1, 1, 2, -3, 1, 4, 1, 1, 4, 4,
+ $ 1, 1, -4, 2, -4, 8*8, 0 /
+ DATA KAZERO / 6*1, 2, 1, 2*2, 2*1, 2*2, 3, 1, 3,
+ $ 4*5, 4*3, 1 /
+ DATA KBZERO / 6*1, 1, 2, 2*1, 2*2, 2*1, 4, 1, 4,
+ $ 4*6, 4*4, 1 /
+ DATA KAMAGN / 8*1, 2, 3, 2, 3, 2, 3, 7*1, 2, 3, 3,
+ $ 2, 1 /
+ DATA KBMAGN / 8*1, 3, 2, 3, 2, 2, 3, 7*1, 3, 2, 3,
+ $ 2, 1 /
+ DATA KTRIAN / 16*0, 10*1 /
+ DATA IASIGN / 6*0, 2, 0, 2*2, 2*0, 3*2, 0, 2, 3*0,
+ $ 5*2, 0 /
+ DATA IBSIGN / 7*0, 2, 2*0, 2*2, 2*0, 2, 0, 2, 9*0 /
+* ..
+* .. Executable Statements ..
+*
+* Check for errors
+*
+ INFO = 0
+*
+ BADNN = .FALSE.
+ NMAX = 1
+ DO 10 J = 1, NSIZES
+ NMAX = MAX( NMAX, NN( J ) )
+ IF( NN( J ).LT.0 )
+ $ BADNN = .TRUE.
+ 10 CONTINUE
+*
+ IF( NSIZES.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( BADNN ) THEN
+ INFO = -2
+ ELSE IF( NTYPES.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( THRESH.LT.ZERO ) THEN
+ INFO = -6
+ ELSE IF( LDA.LE.1 .OR. LDA.LT.NMAX ) THEN
+ INFO = -9
+ ELSE IF( LDQ.LE.1 .OR. LDQ.LT.NMAX ) THEN
+ INFO = -14
+ END IF
+*
+* Compute workspace
+* (Note: Comments in the code beginning "Workspace:" describe the
+* minimal amount of workspace needed at that point in the code,
+* as well as the preferred amount for good performance.
+* NB refers to the optimal block size for the immediately
+* following subroutine, as returned by ILAENV.
+*
+ MINWRK = 1
+ IF( INFO.EQ.0 .AND. LWORK.GE.1 ) THEN
+ MINWRK = MAX( 10*( NMAX+1 ), 3*NMAX*NMAX )
+ NB = MAX( 1, ILAENV( 1, 'DGEQRF', ' ', NMAX, NMAX, -1, -1 ),
+ $ ILAENV( 1, 'DORMQR', 'LT', NMAX, NMAX, NMAX, -1 ),
+ $ ILAENV( 1, 'DORGQR', ' ', NMAX, NMAX, NMAX, -1 ) )
+ MAXWRK = MAX( 10*( NMAX+1 ), 2*NMAX+NMAX*NB, 3*NMAX*NMAX )
+ WORK( 1 ) = MAXWRK
+ END IF
+*
+ IF( LWORK.LT.MINWRK )
+ $ INFO = -20
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DDRGES', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( NSIZES.EQ.0 .OR. NTYPES.EQ.0 )
+ $ RETURN
+*
+ SAFMIN = DLAMCH( 'Safe minimum' )
+ ULP = DLAMCH( 'Epsilon' )*DLAMCH( 'Base' )
+ SAFMIN = SAFMIN / ULP
+ SAFMAX = ONE / SAFMIN
+ CALL DLABAD( SAFMIN, SAFMAX )
+ ULPINV = ONE / ULP
+*
+* The values RMAGN(2:3) depend on N, see below.
+*
+ RMAGN( 0 ) = ZERO
+ RMAGN( 1 ) = ONE
+*
+* Loop over matrix sizes
+*
+ NTESTT = 0
+ NERRS = 0
+ NMATS = 0
+*
+ DO 190 JSIZE = 1, NSIZES
+ N = NN( JSIZE )
+ N1 = MAX( 1, N )
+ RMAGN( 2 ) = SAFMAX*ULP / DBLE( N1 )
+ RMAGN( 3 ) = SAFMIN*ULPINV*DBLE( N1 )
+*
+ IF( NSIZES.NE.1 ) THEN
+ MTYPES = MIN( MAXTYP, NTYPES )
+ ELSE
+ MTYPES = MIN( MAXTYP+1, NTYPES )
+ END IF
+*
+* Loop over matrix types
+*
+ DO 180 JTYPE = 1, MTYPES
+ IF( .NOT.DOTYPE( JTYPE ) )
+ $ GO TO 180
+ NMATS = NMATS + 1
+ NTEST = 0
+*
+* Save ISEED in case of an error.
+*
+ DO 20 J = 1, 4
+ IOLDSD( J ) = ISEED( J )
+ 20 CONTINUE
+*
+* Initialize RESULT
+*
+ DO 30 J = 1, 13
+ RESULT( J ) = ZERO
+ 30 CONTINUE
+*
+* Generate test matrices A and B
+*
+* Description of control parameters:
+*
+* KZLASS: =1 means w/o rotation, =2 means w/ rotation,
+* =3 means random.
+* KATYPE: the "type" to be passed to DLATM4 for computing A.
+* KAZERO: the pattern of zeros on the diagonal for A:
+* =1: ( xxx ), =2: (0, xxx ) =3: ( 0, 0, xxx, 0 ),
+* =4: ( 0, xxx, 0, 0 ), =5: ( 0, 0, 1, xxx, 0 ),
+* =6: ( 0, 1, 0, xxx, 0 ). (xxx means a string of
+* non-zero entries.)
+* KAMAGN: the magnitude of the matrix: =0: zero, =1: O(1),
+* =2: large, =3: small.
+* IASIGN: 1 if the diagonal elements of A are to be
+* multiplied by a random magnitude 1 number, =2 if
+* randomly chosen diagonal blocks are to be rotated
+* to form 2x2 blocks.
+* KBTYPE, KBZERO, KBMAGN, IBSIGN: the same, but for B.
+* KTRIAN: =0: don't fill in the upper triangle, =1: do.
+* KZ1, KZ2, KADD: used to implement KAZERO and KBZERO.
+* RMAGN: used to implement KAMAGN and KBMAGN.
+*
+ IF( MTYPES.GT.MAXTYP )
+ $ GO TO 110
+ IINFO = 0
+ IF( KCLASS( JTYPE ).LT.3 ) THEN
+*
+* Generate A (w/o rotation)
+*
+ IF( ABS( KATYPE( JTYPE ) ).EQ.3 ) THEN
+ IN = 2*( ( N-1 ) / 2 ) + 1
+ IF( IN.NE.N )
+ $ CALL DLASET( 'Full', N, N, ZERO, ZERO, A, LDA )
+ ELSE
+ IN = N
+ END IF
+ CALL DLATM4( KATYPE( JTYPE ), IN, KZ1( KAZERO( JTYPE ) ),
+ $ KZ2( KAZERO( JTYPE ) ), IASIGN( JTYPE ),
+ $ RMAGN( KAMAGN( JTYPE ) ), ULP,
+ $ RMAGN( KTRIAN( JTYPE )*KAMAGN( JTYPE ) ), 2,
+ $ ISEED, A, LDA )
+ IADD = KADD( KAZERO( JTYPE ) )
+ IF( IADD.GT.0 .AND. IADD.LE.N )
+ $ A( IADD, IADD ) = ONE
+*
+* Generate B (w/o rotation)
+*
+ IF( ABS( KBTYPE( JTYPE ) ).EQ.3 ) THEN
+ IN = 2*( ( N-1 ) / 2 ) + 1
+ IF( IN.NE.N )
+ $ CALL DLASET( 'Full', N, N, ZERO, ZERO, B, LDA )
+ ELSE
+ IN = N
+ END IF
+ CALL DLATM4( KBTYPE( JTYPE ), IN, KZ1( KBZERO( JTYPE ) ),
+ $ KZ2( KBZERO( JTYPE ) ), IBSIGN( JTYPE ),
+ $ RMAGN( KBMAGN( JTYPE ) ), ONE,
+ $ RMAGN( KTRIAN( JTYPE )*KBMAGN( JTYPE ) ), 2,
+ $ ISEED, B, LDA )
+ IADD = KADD( KBZERO( JTYPE ) )
+ IF( IADD.NE.0 .AND. IADD.LE.N )
+ $ B( IADD, IADD ) = ONE
+*
+ IF( KCLASS( JTYPE ).EQ.2 .AND. N.GT.0 ) THEN
+*
+* Include rotations
+*
+* Generate Q, Z as Householder transformations times
+* a diagonal matrix.
+*
+ DO 50 JC = 1, N - 1
+ DO 40 JR = JC, N
+ Q( JR, JC ) = DLARND( 3, ISEED )
+ Z( JR, JC ) = DLARND( 3, ISEED )
+ 40 CONTINUE
+ CALL DLARFG( N+1-JC, Q( JC, JC ), Q( JC+1, JC ), 1,
+ $ WORK( JC ) )
+ WORK( 2*N+JC ) = SIGN( ONE, Q( JC, JC ) )
+ Q( JC, JC ) = ONE
+ CALL DLARFG( N+1-JC, Z( JC, JC ), Z( JC+1, JC ), 1,
+ $ WORK( N+JC ) )
+ WORK( 3*N+JC ) = SIGN( ONE, Z( JC, JC ) )
+ Z( JC, JC ) = ONE
+ 50 CONTINUE
+ Q( N, N ) = ONE
+ WORK( N ) = ZERO
+ WORK( 3*N ) = SIGN( ONE, DLARND( 2, ISEED ) )
+ Z( N, N ) = ONE
+ WORK( 2*N ) = ZERO
+ WORK( 4*N ) = SIGN( ONE, DLARND( 2, ISEED ) )
+*
+* Apply the diagonal matrices
+*
+ DO 70 JC = 1, N
+ DO 60 JR = 1, N
+ A( JR, JC ) = WORK( 2*N+JR )*WORK( 3*N+JC )*
+ $ A( JR, JC )
+ B( JR, JC ) = WORK( 2*N+JR )*WORK( 3*N+JC )*
+ $ B( JR, JC )
+ 60 CONTINUE
+ 70 CONTINUE
+ CALL DORM2R( 'L', 'N', N, N, N-1, Q, LDQ, WORK, A,
+ $ LDA, WORK( 2*N+1 ), IINFO )
+ IF( IINFO.NE.0 )
+ $ GO TO 100
+ CALL DORM2R( 'R', 'T', N, N, N-1, Z, LDQ, WORK( N+1 ),
+ $ A, LDA, WORK( 2*N+1 ), IINFO )
+ IF( IINFO.NE.0 )
+ $ GO TO 100
+ CALL DORM2R( 'L', 'N', N, N, N-1, Q, LDQ, WORK, B,
+ $ LDA, WORK( 2*N+1 ), IINFO )
+ IF( IINFO.NE.0 )
+ $ GO TO 100
+ CALL DORM2R( 'R', 'T', N, N, N-1, Z, LDQ, WORK( N+1 ),
+ $ B, LDA, WORK( 2*N+1 ), IINFO )
+ IF( IINFO.NE.0 )
+ $ GO TO 100
+ END IF
+ ELSE
+*
+* Random matrices
+*
+ DO 90 JC = 1, N
+ DO 80 JR = 1, N
+ A( JR, JC ) = RMAGN( KAMAGN( JTYPE ) )*
+ $ DLARND( 2, ISEED )
+ B( JR, JC ) = RMAGN( KBMAGN( JTYPE ) )*
+ $ DLARND( 2, ISEED )
+ 80 CONTINUE
+ 90 CONTINUE
+ END IF
+*
+ 100 CONTINUE
+*
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUNIT, FMT = 9999 )'Generator', IINFO, N, JTYPE,
+ $ IOLDSD
+ INFO = ABS( IINFO )
+ RETURN
+ END IF
+*
+ 110 CONTINUE
+*
+ DO 120 I = 1, 13
+ RESULT( I ) = -ONE
+ 120 CONTINUE
+*
+* Test with and without sorting of eigenvalues
+*
+ DO 150 ISORT = 0, 1
+ IF( ISORT.EQ.0 ) THEN
+ SORT = 'N'
+ RSUB = 0
+ ELSE
+ SORT = 'S'
+ RSUB = 5
+ END IF
+*
+* Call DGGES to compute H, T, Q, Z, alpha, and beta.
+*
+ CALL DLACPY( 'Full', N, N, A, LDA, S, LDA )
+ CALL DLACPY( 'Full', N, N, B, LDA, T, LDA )
+ NTEST = 1 + RSUB + ISORT
+ RESULT( 1+RSUB+ISORT ) = ULPINV
+ CALL DGGES( 'V', 'V', SORT, DLCTES, N, S, LDA, T, LDA,
+ $ SDIM, ALPHAR, ALPHAI, BETA, Q, LDQ, Z, LDQ,
+ $ WORK, LWORK, BWORK, IINFO )
+ IF( IINFO.NE.0 .AND. IINFO.NE.N+2 ) THEN
+ RESULT( 1+RSUB+ISORT ) = ULPINV
+ WRITE( NOUNIT, FMT = 9999 )'DGGES', IINFO, N, JTYPE,
+ $ IOLDSD
+ INFO = ABS( IINFO )
+ GO TO 160
+ END IF
+*
+ NTEST = 4 + RSUB
+*
+* Do tests 1--4 (or tests 7--9 when reordering )
+*
+ IF( ISORT.EQ.0 ) THEN
+ CALL DGET51( 1, N, A, LDA, S, LDA, Q, LDQ, Z, LDQ,
+ $ WORK, RESULT( 1 ) )
+ CALL DGET51( 1, N, B, LDA, T, LDA, Q, LDQ, Z, LDQ,
+ $ WORK, RESULT( 2 ) )
+ ELSE
+ CALL DGET54( N, A, LDA, B, LDA, S, LDA, T, LDA, Q,
+ $ LDQ, Z, LDQ, WORK, RESULT( 7 ) )
+ END IF
+ CALL DGET51( 3, N, A, LDA, T, LDA, Q, LDQ, Q, LDQ, WORK,
+ $ RESULT( 3+RSUB ) )
+ CALL DGET51( 3, N, B, LDA, T, LDA, Z, LDQ, Z, LDQ, WORK,
+ $ RESULT( 4+RSUB ) )
+*
+* Do test 5 and 6 (or Tests 10 and 11 when reordering):
+* check Schur form of A and compare eigenvalues with
+* diagonals.
+*
+ NTEST = 6 + RSUB
+ TEMP1 = ZERO
+*
+ DO 130 J = 1, N
+ ILABAD = .FALSE.
+ IF( ALPHAI( J ).EQ.ZERO ) THEN
+ TEMP2 = ( ABS( ALPHAR( J )-S( J, J ) ) /
+ $ MAX( SAFMIN, ABS( ALPHAR( J ) ), ABS( S( J,
+ $ J ) ) )+ABS( BETA( J )-T( J, J ) ) /
+ $ MAX( SAFMIN, ABS( BETA( J ) ), ABS( T( J,
+ $ J ) ) ) ) / ULP
+*
+ IF( J.LT.N ) THEN
+ IF( S( J+1, J ).NE.ZERO ) THEN
+ ILABAD = .TRUE.
+ RESULT( 5+RSUB ) = ULPINV
+ END IF
+ END IF
+ IF( J.GT.1 ) THEN
+ IF( S( J, J-1 ).NE.ZERO ) THEN
+ ILABAD = .TRUE.
+ RESULT( 5+RSUB ) = ULPINV
+ END IF
+ END IF
+*
+ ELSE
+ IF( ALPHAI( J ).GT.ZERO ) THEN
+ I1 = J
+ ELSE
+ I1 = J - 1
+ END IF
+ IF( I1.LE.0 .OR. I1.GE.N ) THEN
+ ILABAD = .TRUE.
+ ELSE IF( I1.LT.N-1 ) THEN
+ IF( S( I1+2, I1+1 ).NE.ZERO ) THEN
+ ILABAD = .TRUE.
+ RESULT( 5+RSUB ) = ULPINV
+ END IF
+ ELSE IF( I1.GT.1 ) THEN
+ IF( S( I1, I1-1 ).NE.ZERO ) THEN
+ ILABAD = .TRUE.
+ RESULT( 5+RSUB ) = ULPINV
+ END IF
+ END IF
+ IF( .NOT.ILABAD ) THEN
+ CALL DGET53( S( I1, I1 ), LDA, T( I1, I1 ), LDA,
+ $ BETA( J ), ALPHAR( J ),
+ $ ALPHAI( J ), TEMP2, IERR )
+ IF( IERR.GE.3 ) THEN
+ WRITE( NOUNIT, FMT = 9998 )IERR, J, N,
+ $ JTYPE, IOLDSD
+ INFO = ABS( IERR )
+ END IF
+ ELSE
+ TEMP2 = ULPINV
+ END IF
+*
+ END IF
+ TEMP1 = MAX( TEMP1, TEMP2 )
+ IF( ILABAD ) THEN
+ WRITE( NOUNIT, FMT = 9997 )J, N, JTYPE, IOLDSD
+ END IF
+ 130 CONTINUE
+ RESULT( 6+RSUB ) = TEMP1
+*
+ IF( ISORT.GE.1 ) THEN
+*
+* Do test 12
+*
+ NTEST = 12
+ RESULT( 12 ) = ZERO
+ KNTEIG = 0
+ DO 140 I = 1, N
+ IF( DLCTES( ALPHAR( I ), ALPHAI( I ),
+ $ BETA( I ) ) .OR. DLCTES( ALPHAR( I ),
+ $ -ALPHAI( I ), BETA( I ) ) ) THEN
+ KNTEIG = KNTEIG + 1
+ END IF
+ IF( I.LT.N ) THEN
+ IF( ( DLCTES( ALPHAR( I+1 ), ALPHAI( I+1 ),
+ $ BETA( I+1 ) ) .OR. DLCTES( ALPHAR( I+1 ),
+ $ -ALPHAI( I+1 ), BETA( I+1 ) ) ) .AND.
+ $ ( .NOT.( DLCTES( ALPHAR( I ), ALPHAI( I ),
+ $ BETA( I ) ) .OR. DLCTES( ALPHAR( I ),
+ $ -ALPHAI( I ), BETA( I ) ) ) ) .AND.
+ $ IINFO.NE.N+2 ) THEN
+ RESULT( 12 ) = ULPINV
+ END IF
+ END IF
+ 140 CONTINUE
+ IF( SDIM.NE.KNTEIG ) THEN
+ RESULT( 12 ) = ULPINV
+ END IF
+ END IF
+*
+ 150 CONTINUE
+*
+* End of Loop -- Check for RESULT(j) > THRESH
+*
+ 160 CONTINUE
+*
+ NTESTT = NTESTT + NTEST
+*
+* Print out tests which fail.
+*
+ DO 170 JR = 1, NTEST
+ IF( RESULT( JR ).GE.THRESH ) THEN
+*
+* If this is the first test to fail,
+* print a header to the data file.
+*
+ IF( NERRS.EQ.0 ) THEN
+ WRITE( NOUNIT, FMT = 9996 )'DGS'
+*
+* Matrix types
+*
+ WRITE( NOUNIT, FMT = 9995 )
+ WRITE( NOUNIT, FMT = 9994 )
+ WRITE( NOUNIT, FMT = 9993 )'Orthogonal'
+*
+* Tests performed
+*
+ WRITE( NOUNIT, FMT = 9992 )'orthogonal', '''',
+ $ 'transpose', ( '''', J = 1, 8 )
+*
+ END IF
+ NERRS = NERRS + 1
+ IF( RESULT( JR ).LT.10000.0D0 ) THEN
+ WRITE( NOUNIT, FMT = 9991 )N, JTYPE, IOLDSD, JR,
+ $ RESULT( JR )
+ ELSE
+ WRITE( NOUNIT, FMT = 9990 )N, JTYPE, IOLDSD, JR,
+ $ RESULT( JR )
+ END IF
+ END IF
+ 170 CONTINUE
+*
+ 180 CONTINUE
+ 190 CONTINUE
+*
+* Summary
+*
+ CALL ALASVM( 'DGS', NOUNIT, NERRS, NTESTT, 0 )
+*
+ WORK( 1 ) = MAXWRK
+*
+ RETURN
+*
+ 9999 FORMAT( ' DDRGES: ', A, ' returned INFO=', I6, '.', / 9X, 'N=',
+ $ I6, ', JTYPE=', I6, ', ISEED=(', 4( I4, ',' ), I5, ')' )
+*
+ 9998 FORMAT( ' DDRGES: DGET53 returned INFO=', I1, ' for eigenvalue ',
+ $ I6, '.', / 9X, 'N=', I6, ', JTYPE=', I6, ', ISEED=(',
+ $ 4( I4, ',' ), I5, ')' )
+*
+ 9997 FORMAT( ' DDRGES: S not in Schur form at eigenvalue ', I6, '.',
+ $ / 9X, 'N=', I6, ', JTYPE=', I6, ', ISEED=(', 3( I5, ',' ),
+ $ I5, ')' )
+*
+ 9996 FORMAT( / 1X, A3, ' -- Real Generalized Schur form driver' )
+*
+ 9995 FORMAT( ' Matrix types (see DDRGES for details): ' )
+*
+ 9994 FORMAT( ' Special Matrices:', 23X,
+ $ '(J''=transposed Jordan block)',
+ $ / ' 1=(0,0) 2=(I,0) 3=(0,I) 4=(I,I) 5=(J'',J'') ',
+ $ '6=(diag(J'',I), diag(I,J''))', / ' Diagonal Matrices: ( ',
+ $ 'D=diag(0,1,2,...) )', / ' 7=(D,I) 9=(large*D, small*I',
+ $ ') 11=(large*I, small*D) 13=(large*D, large*I)', /
+ $ ' 8=(I,D) 10=(small*D, large*I) 12=(small*I, large*D) ',
+ $ ' 14=(small*D, small*I)', / ' 15=(D, reversed D)' )
+ 9993 FORMAT( ' Matrices Rotated by Random ', A, ' Matrices U, V:',
+ $ / ' 16=Transposed Jordan Blocks 19=geometric ',
+ $ 'alpha, beta=0,1', / ' 17=arithm. alpha&beta ',
+ $ ' 20=arithmetic alpha, beta=0,1', / ' 18=clustered ',
+ $ 'alpha, beta=0,1 21=random alpha, beta=0,1',
+ $ / ' Large & Small Matrices:', / ' 22=(large, small) ',
+ $ '23=(small,large) 24=(small,small) 25=(large,large)',
+ $ / ' 26=random O(1) matrices.' )
+*
+ 9992 FORMAT( / ' Tests performed: (S is Schur, T is triangular, ',
+ $ 'Q and Z are ', A, ',', / 19X,
+ $ 'l and r are the appropriate left and right', / 19X,
+ $ 'eigenvectors, resp., a is alpha, b is beta, and', / 19X, A,
+ $ ' means ', A, '.)', / ' Without ordering: ',
+ $ / ' 1 = | A - Q S Z', A,
+ $ ' | / ( |A| n ulp ) 2 = | B - Q T Z', A,
+ $ ' | / ( |B| n ulp )', / ' 3 = | I - QQ', A,
+ $ ' | / ( n ulp ) 4 = | I - ZZ', A,
+ $ ' | / ( n ulp )', / ' 5 = A is in Schur form S',
+ $ / ' 6 = difference between (alpha,beta)',
+ $ ' and diagonals of (S,T)', / ' With ordering: ',
+ $ / ' 7 = | (A,B) - Q (S,T) Z', A,
+ $ ' | / ( |(A,B)| n ulp ) ', / ' 8 = | I - QQ', A,
+ $ ' | / ( n ulp ) 9 = | I - ZZ', A,
+ $ ' | / ( n ulp )', / ' 10 = A is in Schur form S',
+ $ / ' 11 = difference between (alpha,beta) and diagonals',
+ $ ' of (S,T)', / ' 12 = SDIM is the correct number of ',
+ $ 'selected eigenvalues', / )
+ 9991 FORMAT( ' Matrix order=', I5, ', type=', I2, ', seed=',
+ $ 4( I4, ',' ), ' result ', I2, ' is', 0P, F8.2 )
+ 9990 FORMAT( ' Matrix order=', I5, ', type=', I2, ', seed=',
+ $ 4( I4, ',' ), ' result ', I2, ' is', 1P, D10.3 )
+*
+* End of DDRGES
+*
+ END
+ SUBROUTINE DDRGEV( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH,
+ $ NOUNIT, A, LDA, B, S, T, Q, LDQ, Z, QE, LDQE,
+ $ ALPHAR, ALPHAI, BETA, ALPHR1, ALPHI1, BETA1,
+ $ WORK, LWORK, RESULT, INFO )
+*
+* -- LAPACK test routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LDA, LDQ, LDQE, LWORK, NOUNIT, NSIZES,
+ $ NTYPES
+ DOUBLE PRECISION THRESH
+* ..
+* .. Array Arguments ..
+ LOGICAL DOTYPE( * )
+ INTEGER ISEED( 4 ), NN( * )
+ DOUBLE PRECISION A( LDA, * ), ALPHAI( * ), ALPHAR( * ),
+ $ ALPHI1( * ), ALPHR1( * ), B( LDA, * ),
+ $ BETA( * ), BETA1( * ), Q( LDQ, * ),
+ $ QE( LDQE, * ), RESULT( * ), S( LDA, * ),
+ $ T( LDA, * ), WORK( * ), Z( LDQ, * )
+* ..
+*
+* Purpose
+* =======
+*
+* DDRGEV checks the nonsymmetric generalized eigenvalue problem driver
+* routine DGGEV.
+*
+* DGGEV computes for a pair of n-by-n nonsymmetric matrices (A,B) the
+* generalized eigenvalues and, optionally, the left and right
+* eigenvectors.
+*
+* A generalized eigenvalue for a pair of matrices (A,B) is a scalar w
+* or a ratio alpha/beta = w, such that A - w*B is singular. It is
+* usually represented as the pair (alpha,beta), as there is reasonalbe
+* interpretation for beta=0, and even for both being zero.
+*
+* A right generalized eigenvector corresponding to a generalized
+* eigenvalue w for a pair of matrices (A,B) is a vector r such that
+* (A - wB) * r = 0. A left generalized eigenvector is a vector l such
+* that l**H * (A - wB) = 0, where l**H is the conjugate-transpose of l.
+*
+* When DDRGEV is called, a number of matrix "sizes" ("n's") and a
+* number of matrix "types" are specified. For each size ("n")
+* and each type of matrix, a pair of matrices (A, B) will be generated
+* and used for testing. For each matrix pair, the following tests
+* will be performed and compared with the threshhold THRESH.
+*
+* Results from DGGEV:
+*
+* (1) max over all left eigenvalue/-vector pairs (alpha/beta,l) of
+*
+* | VL**H * (beta A - alpha B) |/( ulp max(|beta A|, |alpha B|) )
+*
+* where VL**H is the conjugate-transpose of VL.
+*
+* (2) | |VL(i)| - 1 | / ulp and whether largest component real
+*
+* VL(i) denotes the i-th column of VL.
+*
+* (3) max over all left eigenvalue/-vector pairs (alpha/beta,r) of
+*
+* | (beta A - alpha B) * VR | / ( ulp max(|beta A|, |alpha B|) )
+*
+* (4) | |VR(i)| - 1 | / ulp and whether largest component real
+*
+* VR(i) denotes the i-th column of VR.
+*
+* (5) W(full) = W(partial)
+* W(full) denotes the eigenvalues computed when both l and r
+* are also computed, and W(partial) denotes the eigenvalues
+* computed when only W, only W and r, or only W and l are
+* computed.
+*
+* (6) VL(full) = VL(partial)
+* VL(full) denotes the left eigenvectors computed when both l
+* and r are computed, and VL(partial) denotes the result
+* when only l is computed.
+*
+* (7) VR(full) = VR(partial)
+* VR(full) denotes the right eigenvectors computed when both l
+* and r are also computed, and VR(partial) denotes the result
+* when only l is computed.
+*
+*
+* Test Matrices
+* ---- --------
+*
+* The sizes of the test matrices are specified by an array
+* NN(1:NSIZES); the value of each element NN(j) specifies one size.
+* The "types" are specified by a logical array DOTYPE( 1:NTYPES ); if
+* DOTYPE(j) is .TRUE., then matrix type "j" will be generated.
+* Currently, the list of possible types is:
+*
+* (1) ( 0, 0 ) (a pair of zero matrices)
+*
+* (2) ( I, 0 ) (an identity and a zero matrix)
+*
+* (3) ( 0, I ) (an identity and a zero matrix)
+*
+* (4) ( I, I ) (a pair of identity matrices)
+*
+* t t
+* (5) ( J , J ) (a pair of transposed Jordan blocks)
+*
+* t ( I 0 )
+* (6) ( X, Y ) where X = ( J 0 ) and Y = ( t )
+* ( 0 I ) ( 0 J )
+* and I is a k x k identity and J a (k+1)x(k+1)
+* Jordan block; k=(N-1)/2
+*
+* (7) ( D, I ) where D is diag( 0, 1,..., N-1 ) (a diagonal
+* matrix with those diagonal entries.)
+* (8) ( I, D )
+*
+* (9) ( big*D, small*I ) where "big" is near overflow and small=1/big
+*
+* (10) ( small*D, big*I )
+*
+* (11) ( big*I, small*D )
+*
+* (12) ( small*I, big*D )
+*
+* (13) ( big*D, big*I )
+*
+* (14) ( small*D, small*I )
+*
+* (15) ( D1, D2 ) where D1 is diag( 0, 0, 1, ..., N-3, 0 ) and
+* D2 is diag( 0, N-3, N-4,..., 1, 0, 0 )
+* t t
+* (16) Q ( J , J ) Z where Q and Z are random orthogonal matrices.
+*
+* (17) Q ( T1, T2 ) Z where T1 and T2 are upper triangular matrices
+* with random O(1) entries above the diagonal
+* and diagonal entries diag(T1) =
+* ( 0, 0, 1, ..., N-3, 0 ) and diag(T2) =
+* ( 0, N-3, N-4,..., 1, 0, 0 )
+*
+* (18) Q ( T1, T2 ) Z diag(T1) = ( 0, 0, 1, 1, s, ..., s, 0 )
+* diag(T2) = ( 0, 1, 0, 1,..., 1, 0 )
+* s = machine precision.
+*
+* (19) Q ( T1, T2 ) Z diag(T1)=( 0,0,1,1, 1-d, ..., 1-(N-5)*d=s, 0 )
+* diag(T2) = ( 0, 1, 0, 1, ..., 1, 0 )
+*
+* N-5
+* (20) Q ( T1, T2 ) Z diag(T1)=( 0, 0, 1, 1, a, ..., a =s, 0 )
+* diag(T2) = ( 0, 1, 0, 1, ..., 1, 0, 0 )
+*
+* (21) Q ( T1, T2 ) Z diag(T1)=( 0, 0, 1, r1, r2, ..., r(N-4), 0 )
+* diag(T2) = ( 0, 1, 0, 1, ..., 1, 0, 0 )
+* where r1,..., r(N-4) are random.
+*
+* (22) Q ( big*T1, small*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 )
+* diag(T2) = ( 0, 1, ..., 1, 0, 0 )
+*
+* (23) Q ( small*T1, big*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 )
+* diag(T2) = ( 0, 1, ..., 1, 0, 0 )
+*
+* (24) Q ( small*T1, small*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 )
+* diag(T2) = ( 0, 1, ..., 1, 0, 0 )
+*
+* (25) Q ( big*T1, big*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 )
+* diag(T2) = ( 0, 1, ..., 1, 0, 0 )
+*
+* (26) Q ( T1, T2 ) Z where T1 and T2 are random upper-triangular
+* matrices.
+*
+*
+* Arguments
+* =========
+*
+* NSIZES (input) INTEGER
+* The number of sizes of matrices to use. If it is zero,
+* DDRGES does nothing. NSIZES >= 0.
+*
+* NN (input) INTEGER array, dimension (NSIZES)
+* An array containing the sizes to be used for the matrices.
+* Zero values will be skipped. NN >= 0.
+*
+* NTYPES (input) INTEGER
+* The number of elements in DOTYPE. If it is zero, DDRGES
+* does nothing. It must be at least zero. If it is MAXTYP+1
+* and NSIZES is 1, then an additional type, MAXTYP+1 is
+* defined, which is to use whatever matrix is in A. This
+* is only useful if DOTYPE(1:MAXTYP) is .FALSE. and
+* DOTYPE(MAXTYP+1) is .TRUE. .
+*
+* DOTYPE (input) LOGICAL array, dimension (NTYPES)
+* If DOTYPE(j) is .TRUE., then for each size in NN a
+* matrix of that size and of type j will be generated.
+* If NTYPES is smaller than the maximum number of types
+* defined (PARAMETER MAXTYP), then types NTYPES+1 through
+* MAXTYP will not be generated. If NTYPES is larger
+* than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES)
+* will be ignored.
+*
+* ISEED (input/output) INTEGER array, dimension (4)
+* On entry ISEED specifies the seed of the random number
+* generator. The array elements should be between 0 and 4095;
+* if not they will be reduced mod 4096. Also, ISEED(4) must
+* be odd. The random number generator uses a linear
+* congruential sequence limited to small integers, and so
+* should produce machine independent random numbers. The
+* values of ISEED are changed on exit, and can be used in the
+* next call to DDRGES to continue the same random number
+* sequence.
+*
+* THRESH (input) DOUBLE PRECISION
+* A test will count as "failed" if the "error", computed as
+* described above, exceeds THRESH. Note that the error is
+* scaled to be O(1), so THRESH should be a reasonably small
+* multiple of 1, e.g., 10 or 100. In particular, it should
+* not depend on the precision (single vs. double) or the size
+* of the matrix. It must be at least zero.
+*
+* NOUNIT (input) INTEGER
+* The FORTRAN unit number for printing out error messages
+* (e.g., if a routine returns IERR not equal to 0.)
+*
+* A (input/workspace) DOUBLE PRECISION array,
+* dimension(LDA, max(NN))
+* Used to hold the original A matrix. Used as input only
+* if NTYPES=MAXTYP+1, DOTYPE(1:MAXTYP)=.FALSE., and
+* DOTYPE(MAXTYP+1)=.TRUE.
+*
+* LDA (input) INTEGER
+* The leading dimension of A, B, S, and T.
+* It must be at least 1 and at least max( NN ).
+*
+* B (input/workspace) DOUBLE PRECISION array,
+* dimension(LDA, max(NN))
+* Used to hold the original B matrix. Used as input only
+* if NTYPES=MAXTYP+1, DOTYPE(1:MAXTYP)=.FALSE., and
+* DOTYPE(MAXTYP+1)=.TRUE.
+*
+* S (workspace) DOUBLE PRECISION array,
+* dimension (LDA, max(NN))
+* The Schur form matrix computed from A by DGGES. On exit, S
+* contains the Schur form matrix corresponding to the matrix
+* in A.
+*
+* T (workspace) DOUBLE PRECISION array,
+* dimension (LDA, max(NN))
+* The upper triangular matrix computed from B by DGGES.
+*
+* Q (workspace) DOUBLE PRECISION array,
+* dimension (LDQ, max(NN))
+* The (left) eigenvectors matrix computed by DGGEV.
+*
+* LDQ (input) INTEGER
+* The leading dimension of Q and Z. It must
+* be at least 1 and at least max( NN ).
+*
+* Z (workspace) DOUBLE PRECISION array, dimension( LDQ, max(NN) )
+* The (right) orthogonal matrix computed by DGGES.
+*
+* QE (workspace) DOUBLE PRECISION array, dimension( LDQ, max(NN) )
+* QE holds the computed right or left eigenvectors.
+*
+* LDQE (input) INTEGER
+* The leading dimension of QE. LDQE >= max(1,max(NN)).
+*
+* ALPHAR (workspace) DOUBLE PRECISION array, dimension (max(NN))
+* ALPHAI (workspace) DOUBLE PRECISION array, dimension (max(NN))
+* BETA (workspace) DOUBLE PRECISION array, dimension (max(NN))
+* The generalized eigenvalues of (A,B) computed by DGGEV.
+* ( ALPHAR(k)+ALPHAI(k)*i ) / BETA(k) is the k-th
+* generalized eigenvalue of A and B.
+*
+* ALPHR1 (workspace) DOUBLE PRECISION array, dimension (max(NN))
+* ALPHI1 (workspace) DOUBLE PRECISION array, dimension (max(NN))
+* BETA1 (workspace) DOUBLE PRECISION array, dimension (max(NN))
+* Like ALPHAR, ALPHAI, BETA, these arrays contain the
+* eigenvalues of A and B, but those computed when DGGEV only
+* computes a partial eigendecomposition, i.e. not the
+* eigenvalues and left and right eigenvectors.
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK)
+*
+* LWORK (input) INTEGER
+* The number of entries in WORK. LWORK >= MAX( 8*N, N*(N+1) ).
+*
+* RESULT (output) DOUBLE PRECISION array, dimension (2)
+* The values computed by the tests described above.
+* The values are currently limited to 1/ulp, to avoid overflow.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value.
+* > 0: A routine returned an error code. INFO is the
+* absolute value of the INFO value returned.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+ INTEGER MAXTYP
+ PARAMETER ( MAXTYP = 26 )
+* ..
+* .. Local Scalars ..
+ LOGICAL BADNN
+ INTEGER I, IADD, IERR, IN, J, JC, JR, JSIZE, JTYPE,
+ $ MAXWRK, MINWRK, MTYPES, N, N1, NERRS, NMATS,
+ $ NMAX, NTESTT
+ DOUBLE PRECISION SAFMAX, SAFMIN, ULP, ULPINV
+* ..
+* .. Local Arrays ..
+ INTEGER IASIGN( MAXTYP ), IBSIGN( MAXTYP ),
+ $ IOLDSD( 4 ), KADD( 6 ), KAMAGN( MAXTYP ),
+ $ KATYPE( MAXTYP ), KAZERO( MAXTYP ),
+ $ KBMAGN( MAXTYP ), KBTYPE( MAXTYP ),
+ $ KBZERO( MAXTYP ), KCLASS( MAXTYP ),
+ $ KTRIAN( MAXTYP ), KZ1( 6 ), KZ2( 6 )
+ DOUBLE PRECISION RMAGN( 0: 3 )
+* ..
+* .. External Functions ..
+ INTEGER ILAENV
+ DOUBLE PRECISION DLAMCH, DLARND
+ EXTERNAL ILAENV, DLAMCH, DLARND
+* ..
+* .. External Subroutines ..
+ EXTERNAL ALASVM, DGET52, DGGEV, DLABAD, DLACPY, DLARFG,
+ $ DLASET, DLATM4, DORM2R, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, DBLE, MAX, MIN, SIGN
+* ..
+* .. Data statements ..
+ DATA KCLASS / 15*1, 10*2, 1*3 /
+ DATA KZ1 / 0, 1, 2, 1, 3, 3 /
+ DATA KZ2 / 0, 0, 1, 2, 1, 1 /
+ DATA KADD / 0, 0, 0, 0, 3, 2 /
+ DATA KATYPE / 0, 1, 0, 1, 2, 3, 4, 1, 4, 4, 1, 1, 4,
+ $ 4, 4, 2, 4, 5, 8, 7, 9, 4*4, 0 /
+ DATA KBTYPE / 0, 0, 1, 1, 2, -3, 1, 4, 1, 1, 4, 4,
+ $ 1, 1, -4, 2, -4, 8*8, 0 /
+ DATA KAZERO / 6*1, 2, 1, 2*2, 2*1, 2*2, 3, 1, 3,
+ $ 4*5, 4*3, 1 /
+ DATA KBZERO / 6*1, 1, 2, 2*1, 2*2, 2*1, 4, 1, 4,
+ $ 4*6, 4*4, 1 /
+ DATA KAMAGN / 8*1, 2, 3, 2, 3, 2, 3, 7*1, 2, 3, 3,
+ $ 2, 1 /
+ DATA KBMAGN / 8*1, 3, 2, 3, 2, 2, 3, 7*1, 3, 2, 3,
+ $ 2, 1 /
+ DATA KTRIAN / 16*0, 10*1 /
+ DATA IASIGN / 6*0, 2, 0, 2*2, 2*0, 3*2, 0, 2, 3*0,
+ $ 5*2, 0 /
+ DATA IBSIGN / 7*0, 2, 2*0, 2*2, 2*0, 2, 0, 2, 9*0 /
+* ..
+* .. Executable Statements ..
+*
+* Check for errors
+*
+ INFO = 0
+*
+ BADNN = .FALSE.
+ NMAX = 1
+ DO 10 J = 1, NSIZES
+ NMAX = MAX( NMAX, NN( J ) )
+ IF( NN( J ).LT.0 )
+ $ BADNN = .TRUE.
+ 10 CONTINUE
+*
+ IF( NSIZES.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( BADNN ) THEN
+ INFO = -2
+ ELSE IF( NTYPES.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( THRESH.LT.ZERO ) THEN
+ INFO = -6
+ ELSE IF( LDA.LE.1 .OR. LDA.LT.NMAX ) THEN
+ INFO = -9
+ ELSE IF( LDQ.LE.1 .OR. LDQ.LT.NMAX ) THEN
+ INFO = -14
+ ELSE IF( LDQE.LE.1 .OR. LDQE.LT.NMAX ) THEN
+ INFO = -17
+ END IF
+*
+* Compute workspace
+* (Note: Comments in the code beginning "Workspace:" describe the
+* minimal amount of workspace needed at that point in the code,
+* as well as the preferred amount for good performance.
+* NB refers to the optimal block size for the immediately
+* following subroutine, as returned by ILAENV.
+*
+ MINWRK = 1
+ IF( INFO.EQ.0 .AND. LWORK.GE.1 ) THEN
+ MINWRK = MAX( 1, 8*NMAX, NMAX*( NMAX+1 ) )
+ MAXWRK = 7*NMAX + NMAX*ILAENV( 1, 'DGEQRF', ' ', NMAX, 1, NMAX,
+ $ 0 )
+ MAXWRK = MAX( MAXWRK, NMAX*( NMAX+1 ) )
+ WORK( 1 ) = MAXWRK
+ END IF
+*
+ IF( LWORK.LT.MINWRK )
+ $ INFO = -25
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DDRGEV', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( NSIZES.EQ.0 .OR. NTYPES.EQ.0 )
+ $ RETURN
+*
+ SAFMIN = DLAMCH( 'Safe minimum' )
+ ULP = DLAMCH( 'Epsilon' )*DLAMCH( 'Base' )
+ SAFMIN = SAFMIN / ULP
+ SAFMAX = ONE / SAFMIN
+ CALL DLABAD( SAFMIN, SAFMAX )
+ ULPINV = ONE / ULP
+*
+* The values RMAGN(2:3) depend on N, see below.
+*
+ RMAGN( 0 ) = ZERO
+ RMAGN( 1 ) = ONE
+*
+* Loop over sizes, types
+*
+ NTESTT = 0
+ NERRS = 0
+ NMATS = 0
+*
+ DO 220 JSIZE = 1, NSIZES
+ N = NN( JSIZE )
+ N1 = MAX( 1, N )
+ RMAGN( 2 ) = SAFMAX*ULP / DBLE( N1 )
+ RMAGN( 3 ) = SAFMIN*ULPINV*N1
+*
+ IF( NSIZES.NE.1 ) THEN
+ MTYPES = MIN( MAXTYP, NTYPES )
+ ELSE
+ MTYPES = MIN( MAXTYP+1, NTYPES )
+ END IF
+*
+ DO 210 JTYPE = 1, MTYPES
+ IF( .NOT.DOTYPE( JTYPE ) )
+ $ GO TO 210
+ NMATS = NMATS + 1
+*
+* Save ISEED in case of an error.
+*
+ DO 20 J = 1, 4
+ IOLDSD( J ) = ISEED( J )
+ 20 CONTINUE
+*
+* Generate test matrices A and B
+*
+* Description of control parameters:
+*
+* KZLASS: =1 means w/o rotation, =2 means w/ rotation,
+* =3 means random.
+* KATYPE: the "type" to be passed to DLATM4 for computing A.
+* KAZERO: the pattern of zeros on the diagonal for A:
+* =1: ( xxx ), =2: (0, xxx ) =3: ( 0, 0, xxx, 0 ),
+* =4: ( 0, xxx, 0, 0 ), =5: ( 0, 0, 1, xxx, 0 ),
+* =6: ( 0, 1, 0, xxx, 0 ). (xxx means a string of
+* non-zero entries.)
+* KAMAGN: the magnitude of the matrix: =0: zero, =1: O(1),
+* =2: large, =3: small.
+* IASIGN: 1 if the diagonal elements of A are to be
+* multiplied by a random magnitude 1 number, =2 if
+* randomly chosen diagonal blocks are to be rotated
+* to form 2x2 blocks.
+* KBTYPE, KBZERO, KBMAGN, IBSIGN: the same, but for B.
+* KTRIAN: =0: don't fill in the upper triangle, =1: do.
+* KZ1, KZ2, KADD: used to implement KAZERO and KBZERO.
+* RMAGN: used to implement KAMAGN and KBMAGN.
+*
+ IF( MTYPES.GT.MAXTYP )
+ $ GO TO 100
+ IERR = 0
+ IF( KCLASS( JTYPE ).LT.3 ) THEN
+*
+* Generate A (w/o rotation)
+*
+ IF( ABS( KATYPE( JTYPE ) ).EQ.3 ) THEN
+ IN = 2*( ( N-1 ) / 2 ) + 1
+ IF( IN.NE.N )
+ $ CALL DLASET( 'Full', N, N, ZERO, ZERO, A, LDA )
+ ELSE
+ IN = N
+ END IF
+ CALL DLATM4( KATYPE( JTYPE ), IN, KZ1( KAZERO( JTYPE ) ),
+ $ KZ2( KAZERO( JTYPE ) ), IASIGN( JTYPE ),
+ $ RMAGN( KAMAGN( JTYPE ) ), ULP,
+ $ RMAGN( KTRIAN( JTYPE )*KAMAGN( JTYPE ) ), 2,
+ $ ISEED, A, LDA )
+ IADD = KADD( KAZERO( JTYPE ) )
+ IF( IADD.GT.0 .AND. IADD.LE.N )
+ $ A( IADD, IADD ) = ONE
+*
+* Generate B (w/o rotation)
+*
+ IF( ABS( KBTYPE( JTYPE ) ).EQ.3 ) THEN
+ IN = 2*( ( N-1 ) / 2 ) + 1
+ IF( IN.NE.N )
+ $ CALL DLASET( 'Full', N, N, ZERO, ZERO, B, LDA )
+ ELSE
+ IN = N
+ END IF
+ CALL DLATM4( KBTYPE( JTYPE ), IN, KZ1( KBZERO( JTYPE ) ),
+ $ KZ2( KBZERO( JTYPE ) ), IBSIGN( JTYPE ),
+ $ RMAGN( KBMAGN( JTYPE ) ), ONE,
+ $ RMAGN( KTRIAN( JTYPE )*KBMAGN( JTYPE ) ), 2,
+ $ ISEED, B, LDA )
+ IADD = KADD( KBZERO( JTYPE ) )
+ IF( IADD.NE.0 .AND. IADD.LE.N )
+ $ B( IADD, IADD ) = ONE
+*
+ IF( KCLASS( JTYPE ).EQ.2 .AND. N.GT.0 ) THEN
+*
+* Include rotations
+*
+* Generate Q, Z as Householder transformations times
+* a diagonal matrix.
+*
+ DO 40 JC = 1, N - 1
+ DO 30 JR = JC, N
+ Q( JR, JC ) = DLARND( 3, ISEED )
+ Z( JR, JC ) = DLARND( 3, ISEED )
+ 30 CONTINUE
+ CALL DLARFG( N+1-JC, Q( JC, JC ), Q( JC+1, JC ), 1,
+ $ WORK( JC ) )
+ WORK( 2*N+JC ) = SIGN( ONE, Q( JC, JC ) )
+ Q( JC, JC ) = ONE
+ CALL DLARFG( N+1-JC, Z( JC, JC ), Z( JC+1, JC ), 1,
+ $ WORK( N+JC ) )
+ WORK( 3*N+JC ) = SIGN( ONE, Z( JC, JC ) )
+ Z( JC, JC ) = ONE
+ 40 CONTINUE
+ Q( N, N ) = ONE
+ WORK( N ) = ZERO
+ WORK( 3*N ) = SIGN( ONE, DLARND( 2, ISEED ) )
+ Z( N, N ) = ONE
+ WORK( 2*N ) = ZERO
+ WORK( 4*N ) = SIGN( ONE, DLARND( 2, ISEED ) )
+*
+* Apply the diagonal matrices
+*
+ DO 60 JC = 1, N
+ DO 50 JR = 1, N
+ A( JR, JC ) = WORK( 2*N+JR )*WORK( 3*N+JC )*
+ $ A( JR, JC )
+ B( JR, JC ) = WORK( 2*N+JR )*WORK( 3*N+JC )*
+ $ B( JR, JC )
+ 50 CONTINUE
+ 60 CONTINUE
+ CALL DORM2R( 'L', 'N', N, N, N-1, Q, LDQ, WORK, A,
+ $ LDA, WORK( 2*N+1 ), IERR )
+ IF( IERR.NE.0 )
+ $ GO TO 90
+ CALL DORM2R( 'R', 'T', N, N, N-1, Z, LDQ, WORK( N+1 ),
+ $ A, LDA, WORK( 2*N+1 ), IERR )
+ IF( IERR.NE.0 )
+ $ GO TO 90
+ CALL DORM2R( 'L', 'N', N, N, N-1, Q, LDQ, WORK, B,
+ $ LDA, WORK( 2*N+1 ), IERR )
+ IF( IERR.NE.0 )
+ $ GO TO 90
+ CALL DORM2R( 'R', 'T', N, N, N-1, Z, LDQ, WORK( N+1 ),
+ $ B, LDA, WORK( 2*N+1 ), IERR )
+ IF( IERR.NE.0 )
+ $ GO TO 90
+ END IF
+ ELSE
+*
+* Random matrices
+*
+ DO 80 JC = 1, N
+ DO 70 JR = 1, N
+ A( JR, JC ) = RMAGN( KAMAGN( JTYPE ) )*
+ $ DLARND( 2, ISEED )
+ B( JR, JC ) = RMAGN( KBMAGN( JTYPE ) )*
+ $ DLARND( 2, ISEED )
+ 70 CONTINUE
+ 80 CONTINUE
+ END IF
+*
+ 90 CONTINUE
+*
+ IF( IERR.NE.0 ) THEN
+ WRITE( NOUNIT, FMT = 9999 )'Generator', IERR, N, JTYPE,
+ $ IOLDSD
+ INFO = ABS( IERR )
+ RETURN
+ END IF
+*
+ 100 CONTINUE
+*
+ DO 110 I = 1, 7
+ RESULT( I ) = -ONE
+ 110 CONTINUE
+*
+* Call DGGEV to compute eigenvalues and eigenvectors.
+*
+ CALL DLACPY( ' ', N, N, A, LDA, S, LDA )
+ CALL DLACPY( ' ', N, N, B, LDA, T, LDA )
+ CALL DGGEV( 'V', 'V', N, S, LDA, T, LDA, ALPHAR, ALPHAI,
+ $ BETA, Q, LDQ, Z, LDQ, WORK, LWORK, IERR )
+ IF( IERR.NE.0 .AND. IERR.NE.N+1 ) THEN
+ RESULT( 1 ) = ULPINV
+ WRITE( NOUNIT, FMT = 9999 )'DGGEV1', IERR, N, JTYPE,
+ $ IOLDSD
+ INFO = ABS( IERR )
+ GO TO 190
+ END IF
+*
+* Do the tests (1) and (2)
+*
+ CALL DGET52( .TRUE., N, A, LDA, B, LDA, Q, LDQ, ALPHAR,
+ $ ALPHAI, BETA, WORK, RESULT( 1 ) )
+ IF( RESULT( 2 ).GT.THRESH ) THEN
+ WRITE( NOUNIT, FMT = 9998 )'Left', 'DGGEV1',
+ $ RESULT( 2 ), N, JTYPE, IOLDSD
+ END IF
+*
+* Do the tests (3) and (4)
+*
+ CALL DGET52( .FALSE., N, A, LDA, B, LDA, Z, LDQ, ALPHAR,
+ $ ALPHAI, BETA, WORK, RESULT( 3 ) )
+ IF( RESULT( 4 ).GT.THRESH ) THEN
+ WRITE( NOUNIT, FMT = 9998 )'Right', 'DGGEV1',
+ $ RESULT( 4 ), N, JTYPE, IOLDSD
+ END IF
+*
+* Do the test (5)
+*
+ CALL DLACPY( ' ', N, N, A, LDA, S, LDA )
+ CALL DLACPY( ' ', N, N, B, LDA, T, LDA )
+ CALL DGGEV( 'N', 'N', N, S, LDA, T, LDA, ALPHR1, ALPHI1,
+ $ BETA1, Q, LDQ, Z, LDQ, WORK, LWORK, IERR )
+ IF( IERR.NE.0 .AND. IERR.NE.N+1 ) THEN
+ RESULT( 1 ) = ULPINV
+ WRITE( NOUNIT, FMT = 9999 )'DGGEV2', IERR, N, JTYPE,
+ $ IOLDSD
+ INFO = ABS( IERR )
+ GO TO 190
+ END IF
+*
+ DO 120 J = 1, N
+ IF( ALPHAR( J ).NE.ALPHR1( J ) .OR. ALPHAI( J ).NE.
+ $ ALPHI1( J ) .OR. BETA( J ).NE.BETA1( J ) )RESULT( 5 )
+ $ = ULPINV
+ 120 CONTINUE
+*
+* Do the test (6): Compute eigenvalues and left eigenvectors,
+* and test them
+*
+ CALL DLACPY( ' ', N, N, A, LDA, S, LDA )
+ CALL DLACPY( ' ', N, N, B, LDA, T, LDA )
+ CALL DGGEV( 'V', 'N', N, S, LDA, T, LDA, ALPHR1, ALPHI1,
+ $ BETA1, QE, LDQE, Z, LDQ, WORK, LWORK, IERR )
+ IF( IERR.NE.0 .AND. IERR.NE.N+1 ) THEN
+ RESULT( 1 ) = ULPINV
+ WRITE( NOUNIT, FMT = 9999 )'DGGEV3', IERR, N, JTYPE,
+ $ IOLDSD
+ INFO = ABS( IERR )
+ GO TO 190
+ END IF
+*
+ DO 130 J = 1, N
+ IF( ALPHAR( J ).NE.ALPHR1( J ) .OR. ALPHAI( J ).NE.
+ $ ALPHI1( J ) .OR. BETA( J ).NE.BETA1( J ) )RESULT( 6 )
+ $ = ULPINV
+ 130 CONTINUE
+*
+ DO 150 J = 1, N
+ DO 140 JC = 1, N
+ IF( Q( J, JC ).NE.QE( J, JC ) )
+ $ RESULT( 6 ) = ULPINV
+ 140 CONTINUE
+ 150 CONTINUE
+*
+* DO the test (7): Compute eigenvalues and right eigenvectors,
+* and test them
+*
+ CALL DLACPY( ' ', N, N, A, LDA, S, LDA )
+ CALL DLACPY( ' ', N, N, B, LDA, T, LDA )
+ CALL DGGEV( 'N', 'V', N, S, LDA, T, LDA, ALPHR1, ALPHI1,
+ $ BETA1, Q, LDQ, QE, LDQE, WORK, LWORK, IERR )
+ IF( IERR.NE.0 .AND. IERR.NE.N+1 ) THEN
+ RESULT( 1 ) = ULPINV
+ WRITE( NOUNIT, FMT = 9999 )'DGGEV4', IERR, N, JTYPE,
+ $ IOLDSD
+ INFO = ABS( IERR )
+ GO TO 190
+ END IF
+*
+ DO 160 J = 1, N
+ IF( ALPHAR( J ).NE.ALPHR1( J ) .OR. ALPHAI( J ).NE.
+ $ ALPHI1( J ) .OR. BETA( J ).NE.BETA1( J ) )RESULT( 7 )
+ $ = ULPINV
+ 160 CONTINUE
+*
+ DO 180 J = 1, N
+ DO 170 JC = 1, N
+ IF( Z( J, JC ).NE.QE( J, JC ) )
+ $ RESULT( 7 ) = ULPINV
+ 170 CONTINUE
+ 180 CONTINUE
+*
+* End of Loop -- Check for RESULT(j) > THRESH
+*
+ 190 CONTINUE
+*
+ NTESTT = NTESTT + 7
+*
+* Print out tests which fail.
+*
+ DO 200 JR = 1, 7
+ IF( RESULT( JR ).GE.THRESH ) THEN
+*
+* If this is the first test to fail,
+* print a header to the data file.
+*
+ IF( NERRS.EQ.0 ) THEN
+ WRITE( NOUNIT, FMT = 9997 )'DGV'
+*
+* Matrix types
+*
+ WRITE( NOUNIT, FMT = 9996 )
+ WRITE( NOUNIT, FMT = 9995 )
+ WRITE( NOUNIT, FMT = 9994 )'Orthogonal'
+*
+* Tests performed
+*
+ WRITE( NOUNIT, FMT = 9993 )
+*
+ END IF
+ NERRS = NERRS + 1
+ IF( RESULT( JR ).LT.10000.0D0 ) THEN
+ WRITE( NOUNIT, FMT = 9992 )N, JTYPE, IOLDSD, JR,
+ $ RESULT( JR )
+ ELSE
+ WRITE( NOUNIT, FMT = 9991 )N, JTYPE, IOLDSD, JR,
+ $ RESULT( JR )
+ END IF
+ END IF
+ 200 CONTINUE
+*
+ 210 CONTINUE
+ 220 CONTINUE
+*
+* Summary
+*
+ CALL ALASVM( 'DGV', NOUNIT, NERRS, NTESTT, 0 )
+*
+ WORK( 1 ) = MAXWRK
+*
+ RETURN
+*
+ 9999 FORMAT( ' DDRGEV: ', A, ' returned INFO=', I6, '.', / 3X, 'N=',
+ $ I6, ', JTYPE=', I6, ', ISEED=(', 4( I4, ',' ), I5, ')' )
+*
+ 9998 FORMAT( ' DDRGEV: ', A, ' Eigenvectors from ', A, ' incorrectly ',
+ $ 'normalized.', / ' Bits of error=', 0P, G10.3, ',', 3X,
+ $ 'N=', I4, ', JTYPE=', I3, ', ISEED=(', 4( I4, ',' ), I5,
+ $ ')' )
+*
+ 9997 FORMAT( / 1X, A3, ' -- Real Generalized eigenvalue problem driver'
+ $ )
+*
+ 9996 FORMAT( ' Matrix types (see DDRGEV for details): ' )
+*
+ 9995 FORMAT( ' Special Matrices:', 23X,
+ $ '(J''=transposed Jordan block)',
+ $ / ' 1=(0,0) 2=(I,0) 3=(0,I) 4=(I,I) 5=(J'',J'') ',
+ $ '6=(diag(J'',I), diag(I,J''))', / ' Diagonal Matrices: ( ',
+ $ 'D=diag(0,1,2,...) )', / ' 7=(D,I) 9=(large*D, small*I',
+ $ ') 11=(large*I, small*D) 13=(large*D, large*I)', /
+ $ ' 8=(I,D) 10=(small*D, large*I) 12=(small*I, large*D) ',
+ $ ' 14=(small*D, small*I)', / ' 15=(D, reversed D)' )
+ 9994 FORMAT( ' Matrices Rotated by Random ', A, ' Matrices U, V:',
+ $ / ' 16=Transposed Jordan Blocks 19=geometric ',
+ $ 'alpha, beta=0,1', / ' 17=arithm. alpha&beta ',
+ $ ' 20=arithmetic alpha, beta=0,1', / ' 18=clustered ',
+ $ 'alpha, beta=0,1 21=random alpha, beta=0,1',
+ $ / ' Large & Small Matrices:', / ' 22=(large, small) ',
+ $ '23=(small,large) 24=(small,small) 25=(large,large)',
+ $ / ' 26=random O(1) matrices.' )
+*
+ 9993 FORMAT( / ' Tests performed: ',
+ $ / ' 1 = max | ( b A - a B )''*l | / const.,',
+ $ / ' 2 = | |VR(i)| - 1 | / ulp,',
+ $ / ' 3 = max | ( b A - a B )*r | / const.',
+ $ / ' 4 = | |VL(i)| - 1 | / ulp,',
+ $ / ' 5 = 0 if W same no matter if r or l computed,',
+ $ / ' 6 = 0 if l same no matter if l computed,',
+ $ / ' 7 = 0 if r same no matter if r computed,', / 1X )
+ 9992 FORMAT( ' Matrix order=', I5, ', type=', I2, ', seed=',
+ $ 4( I4, ',' ), ' result ', I2, ' is', 0P, F8.2 )
+ 9991 FORMAT( ' Matrix order=', I5, ', type=', I2, ', seed=',
+ $ 4( I4, ',' ), ' result ', I2, ' is', 1P, D10.3 )
+*
+* End of DDRGEV
+*
+ END
+ SUBROUTINE DDRGSX( NSIZE, NCMAX, THRESH, NIN, NOUT, A, LDA, B, AI,
+ $ BI, Z, Q, ALPHAR, ALPHAI, BETA, C, LDC, S,
+ $ WORK, LWORK, IWORK, LIWORK, BWORK, INFO )
+*
+* -- LAPACK test routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LDA, LDC, LIWORK, LWORK, NCMAX, NIN,
+ $ NOUT, NSIZE
+ DOUBLE PRECISION THRESH
+* ..
+* .. Array Arguments ..
+ LOGICAL BWORK( * )
+ INTEGER IWORK( * )
+ DOUBLE PRECISION A( LDA, * ), AI( LDA, * ), ALPHAI( * ),
+ $ ALPHAR( * ), B( LDA, * ), BETA( * ),
+ $ BI( LDA, * ), C( LDC, * ), Q( LDA, * ), S( * ),
+ $ WORK( * ), Z( LDA, * )
+* ..
+*
+* Purpose
+* =======
+*
+* DDRGSX checks the nonsymmetric generalized eigenvalue (Schur form)
+* problem expert driver DGGESX.
+*
+* DGGESX factors A and B as Q S Z' and Q T Z', where ' means
+* transpose, T is upper triangular, S is in generalized Schur form
+* (block upper triangular, with 1x1 and 2x2 blocks on the diagonal,
+* the 2x2 blocks corresponding to complex conjugate pairs of
+* generalized eigenvalues), and Q and Z are orthogonal. It also
+* computes the generalized eigenvalues (alpha(1),beta(1)), ...,
+* (alpha(n),beta(n)). Thus, w(j) = alpha(j)/beta(j) is a root of the
+* characteristic equation
+*
+* det( A - w(j) B ) = 0
+*
+* Optionally it also reorders the eigenvalues so that a selected
+* cluster of eigenvalues appears in the leading diagonal block of the
+* Schur forms; computes a reciprocal condition number for the average
+* of the selected eigenvalues; and computes a reciprocal condition
+* number for the right and left deflating subspaces corresponding to
+* the selected eigenvalues.
+*
+* When DDRGSX is called with NSIZE > 0, five (5) types of built-in
+* matrix pairs are used to test the routine DGGESX.
+*
+* When DDRGSX is called with NSIZE = 0, it reads in test matrix data
+* to test DGGESX.
+*
+* For each matrix pair, the following tests will be performed and
+* compared with the threshhold THRESH except for the tests (7) and (9):
+*
+* (1) | A - Q S Z' | / ( |A| n ulp )
+*
+* (2) | B - Q T Z' | / ( |B| n ulp )
+*
+* (3) | I - QQ' | / ( n ulp )
+*
+* (4) | I - ZZ' | / ( n ulp )
+*
+* (5) if A is in Schur form (i.e. quasi-triangular form)
+*
+* (6) maximum over j of D(j) where:
+*
+* if alpha(j) is real:
+* |alpha(j) - S(j,j)| |beta(j) - T(j,j)|
+* D(j) = ------------------------ + -----------------------
+* max(|alpha(j)|,|S(j,j)|) max(|beta(j)|,|T(j,j)|)
+*
+* if alpha(j) is complex:
+* | det( s S - w T ) |
+* D(j) = ---------------------------------------------------
+* ulp max( s norm(S), |w| norm(T) )*norm( s S - w T )
+*
+* and S and T are here the 2 x 2 diagonal blocks of S and T
+* corresponding to the j-th and j+1-th eigenvalues.
+*
+* (7) if sorting worked and SDIM is the number of eigenvalues
+* which were selected.
+*
+* (8) the estimated value DIF does not differ from the true values of
+* Difu and Difl more than a factor 10*THRESH. If the estimate DIF
+* equals zero the corresponding true values of Difu and Difl
+* should be less than EPS*norm(A, B). If the true value of Difu
+* and Difl equal zero, the estimate DIF should be less than
+* EPS*norm(A, B).
+*
+* (9) If INFO = N+3 is returned by DGGESX, the reordering "failed"
+* and we check that DIF = PL = PR = 0 and that the true value of
+* Difu and Difl is < EPS*norm(A, B). We count the events when
+* INFO=N+3.
+*
+* For read-in test matrices, the above tests are run except that the
+* exact value for DIF (and PL) is input data. Additionally, there is
+* one more test run for read-in test matrices:
+*
+* (10) the estimated value PL does not differ from the true value of
+* PLTRU more than a factor THRESH. If the estimate PL equals
+* zero the corresponding true value of PLTRU should be less than
+* EPS*norm(A, B). If the true value of PLTRU equal zero, the
+* estimate PL should be less than EPS*norm(A, B).
+*
+* Note that for the built-in tests, a total of 10*NSIZE*(NSIZE-1)
+* matrix pairs are generated and tested. NSIZE should be kept small.
+*
+* SVD (routine DGESVD) is used for computing the true value of DIF_u
+* and DIF_l when testing the built-in test problems.
+*
+* Built-in Test Matrices
+* ======================
+*
+* All built-in test matrices are the 2 by 2 block of triangular
+* matrices
+*
+* A = [ A11 A12 ] and B = [ B11 B12 ]
+* [ A22 ] [ B22 ]
+*
+* where for different type of A11 and A22 are given as the following.
+* A12 and B12 are chosen so that the generalized Sylvester equation
+*
+* A11*R - L*A22 = -A12
+* B11*R - L*B22 = -B12
+*
+* have prescribed solution R and L.
+*
+* Type 1: A11 = J_m(1,-1) and A_22 = J_k(1-a,1).
+* B11 = I_m, B22 = I_k
+* where J_k(a,b) is the k-by-k Jordan block with ``a'' on
+* diagonal and ``b'' on superdiagonal.
+*
+* Type 2: A11 = (a_ij) = ( 2(.5-sin(i)) ) and
+* B11 = (b_ij) = ( 2(.5-sin(ij)) ) for i=1,...,m, j=i,...,m
+* A22 = (a_ij) = ( 2(.5-sin(i+j)) ) and
+* B22 = (b_ij) = ( 2(.5-sin(ij)) ) for i=m+1,...,k, j=i,...,k
+*
+* Type 3: A11, A22 and B11, B22 are chosen as for Type 2, but each
+* second diagonal block in A_11 and each third diagonal block
+* in A_22 are made as 2 by 2 blocks.
+*
+* Type 4: A11 = ( 20(.5 - sin(ij)) ) and B22 = ( 2(.5 - sin(i+j)) )
+* for i=1,...,m, j=1,...,m and
+* A22 = ( 20(.5 - sin(i+j)) ) and B22 = ( 2(.5 - sin(ij)) )
+* for i=m+1,...,k, j=m+1,...,k
+*
+* Type 5: (A,B) and have potentially close or common eigenvalues and
+* very large departure from block diagonality A_11 is chosen
+* as the m x m leading submatrix of A_1:
+* | 1 b |
+* | -b 1 |
+* | 1+d b |
+* | -b 1+d |
+* A_1 = | d 1 |
+* | -1 d |
+* | -d 1 |
+* | -1 -d |
+* | 1 |
+* and A_22 is chosen as the k x k leading submatrix of A_2:
+* | -1 b |
+* | -b -1 |
+* | 1-d b |
+* | -b 1-d |
+* A_2 = | d 1+b |
+* | -1-b d |
+* | -d 1+b |
+* | -1+b -d |
+* | 1-d |
+* and matrix B are chosen as identity matrices (see DLATM5).
+*
+*
+* Arguments
+* =========
+*
+* NSIZE (input) INTEGER
+* The maximum size of the matrices to use. NSIZE >= 0.
+* If NSIZE = 0, no built-in tests matrices are used, but
+* read-in test matrices are used to test DGGESX.
+*
+* NCMAX (input) INTEGER
+* Maximum allowable NMAX for generating Kroneker matrix
+* in call to DLAKF2
+*
+* THRESH (input) DOUBLE PRECISION
+* A test will count as "failed" if the "error", computed as
+* described above, exceeds THRESH. Note that the error
+* is scaled to be O(1), so THRESH should be a reasonably
+* small multiple of 1, e.g., 10 or 100. In particular,
+* it should not depend on the precision (single vs. double)
+* or the size of the matrix. THRESH >= 0.
+*
+* NIN (input) INTEGER
+* The FORTRAN unit number for reading in the data file of
+* problems to solve.
+*
+* NOUT (input) INTEGER
+* The FORTRAN unit number for printing out error messages
+* (e.g., if a routine returns IINFO not equal to 0.)
+*
+* A (workspace) DOUBLE PRECISION array, dimension (LDA, NSIZE)
+* Used to store the matrix whose eigenvalues are to be
+* computed. On exit, A contains the last matrix actually used.
+*
+* LDA (input) INTEGER
+* The leading dimension of A, B, AI, BI, Z and Q,
+* LDA >= max( 1, NSIZE ). For the read-in test,
+* LDA >= max( 1, N ), N is the size of the test matrices.
+*
+* B (workspace) DOUBLE PRECISION array, dimension (LDA, NSIZE)
+* Used to store the matrix whose eigenvalues are to be
+* computed. On exit, B contains the last matrix actually used.
+*
+* AI (workspace) DOUBLE PRECISION array, dimension (LDA, NSIZE)
+* Copy of A, modified by DGGESX.
+*
+* BI (workspace) DOUBLE PRECISION array, dimension (LDA, NSIZE)
+* Copy of B, modified by DGGESX.
+*
+* Z (workspace) DOUBLE PRECISION array, dimension (LDA, NSIZE)
+* Z holds the left Schur vectors computed by DGGESX.
+*
+* Q (workspace) DOUBLE PRECISION array, dimension (LDA, NSIZE)
+* Q holds the right Schur vectors computed by DGGESX.
+*
+* ALPHAR (workspace) DOUBLE PRECISION array, dimension (NSIZE)
+* ALPHAI (workspace) DOUBLE PRECISION array, dimension (NSIZE)
+* BETA (workspace) DOUBLE PRECISION array, dimension (NSIZE)
+* On exit, (ALPHAR + ALPHAI*i)/BETA are the eigenvalues.
+*
+* C (workspace) DOUBLE PRECISION array, dimension (LDC, LDC)
+* Store the matrix generated by subroutine DLAKF2, this is the
+* matrix formed by Kronecker products used for estimating
+* DIF.
+*
+* LDC (input) INTEGER
+* The leading dimension of C. LDC >= max(1, LDA*LDA/2 ).
+*
+* S (workspace) DOUBLE PRECISION array, dimension (LDC)
+* Singular values of C
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK)
+*
+* LWORK (input) INTEGER
+* The dimension of the array WORK.
+* LWORK >= MAX( 5*NSIZE*NSIZE/2 - 2, 10*(NSIZE+1) )
+*
+* IWORK (workspace) INTEGER array, dimension (LIWORK)
+*
+* LIWORK (input) INTEGER
+* The dimension of the array IWORK. LIWORK >= NSIZE + 6.
+*
+* BWORK (workspace) LOGICAL array, dimension (LDA)
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value.
+* > 0: A routine returned an error code.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE, TEN
+ PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TEN = 1.0D+1 )
+* ..
+* .. Local Scalars ..
+ LOGICAL ILABAD
+ CHARACTER SENSE
+ INTEGER BDSPAC, I, I1, IFUNC, IINFO, J, LINFO, MAXWRK,
+ $ MINWRK, MM, MN2, NERRS, NPTKNT, NTEST, NTESTT,
+ $ PRTYPE, QBA, QBB
+ DOUBLE PRECISION ABNRM, BIGNUM, DIFTRU, PLTRU, SMLNUM, TEMP1,
+ $ TEMP2, THRSH2, ULP, ULPINV, WEIGHT
+* ..
+* .. Local Arrays ..
+ DOUBLE PRECISION DIFEST( 2 ), PL( 2 ), RESULT( 10 )
+* ..
+* .. External Functions ..
+ LOGICAL DLCTSX
+ INTEGER ILAENV
+ DOUBLE PRECISION DLAMCH, DLANGE
+ EXTERNAL DLCTSX, ILAENV, DLAMCH, DLANGE
+* ..
+* .. External Subroutines ..
+ EXTERNAL ALASVM, DGESVD, DGET51, DGET53, DGGESX, DLABAD,
+ $ DLACPY, DLAKF2, DLASET, DLATM5, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, SQRT
+* ..
+* .. Scalars in Common ..
+ LOGICAL FS
+ INTEGER K, M, MPLUSN, N
+* ..
+* .. Common blocks ..
+ COMMON / MN / M, N, MPLUSN, K, FS
+* ..
+* .. Executable Statements ..
+*
+* Check for errors
+*
+ IF( NSIZE.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( THRESH.LT.ZERO ) THEN
+ INFO = -2
+ ELSE IF( NIN.LE.0 ) THEN
+ INFO = -3
+ ELSE IF( NOUT.LE.0 ) THEN
+ INFO = -4
+ ELSE IF( LDA.LT.1 .OR. LDA.LT.NSIZE ) THEN
+ INFO = -6
+ ELSE IF( LDC.LT.1 .OR. LDC.LT.NSIZE*NSIZE / 2 ) THEN
+ INFO = -17
+ ELSE IF( LIWORK.LT.NSIZE+6 ) THEN
+ INFO = -21
+ END IF
+*
+* Compute workspace
+* (Note: Comments in the code beginning "Workspace:" describe the
+* minimal amount of workspace needed at that point in the code,
+* as well as the preferred amount for good performance.
+* NB refers to the optimal block size for the immediately
+* following subroutine, as returned by ILAENV.)
+*
+ MINWRK = 1
+ IF( INFO.EQ.0 .AND. LWORK.GE.1 ) THEN
+ MINWRK = MAX( 10*( NSIZE+1 ), 5*NSIZE*NSIZE / 2 )
+*
+* workspace for sggesx
+*
+ MAXWRK = 9*( NSIZE+1 ) + NSIZE*
+ $ ILAENV( 1, 'DGEQRF', ' ', NSIZE, 1, NSIZE, 0 )
+ MAXWRK = MAX( MAXWRK, 9*( NSIZE+1 )+NSIZE*
+ $ ILAENV( 1, 'DORGQR', ' ', NSIZE, 1, NSIZE, -1 ) )
+*
+* workspace for dgesvd
+*
+ BDSPAC = 5*NSIZE*NSIZE / 2
+ MAXWRK = MAX( MAXWRK, 3*NSIZE*NSIZE / 2+NSIZE*NSIZE*
+ $ ILAENV( 1, 'DGEBRD', ' ', NSIZE*NSIZE / 2,
+ $ NSIZE*NSIZE / 2, -1, -1 ) )
+ MAXWRK = MAX( MAXWRK, BDSPAC )
+*
+ MAXWRK = MAX( MAXWRK, MINWRK )
+*
+ WORK( 1 ) = MAXWRK
+ END IF
+*
+ IF( LWORK.LT.MINWRK )
+ $ INFO = -19
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DDRGSX', -INFO )
+ RETURN
+ END IF
+*
+* Important constants
+*
+ ULP = DLAMCH( 'P' )
+ ULPINV = ONE / ULP
+ SMLNUM = DLAMCH( 'S' ) / ULP
+ BIGNUM = ONE / SMLNUM
+ CALL DLABAD( SMLNUM, BIGNUM )
+ THRSH2 = TEN*THRESH
+ NTESTT = 0
+ NERRS = 0
+*
+* Go to the tests for read-in matrix pairs
+*
+ IFUNC = 0
+ IF( NSIZE.EQ.0 )
+ $ GO TO 70
+*
+* Test the built-in matrix pairs.
+* Loop over different functions (IFUNC) of DGGESX, types (PRTYPE)
+* of test matrices, different size (M+N)
+*
+ PRTYPE = 0
+ QBA = 3
+ QBB = 4
+ WEIGHT = SQRT( ULP )
+*
+ DO 60 IFUNC = 0, 3
+ DO 50 PRTYPE = 1, 5
+ DO 40 M = 1, NSIZE - 1
+ DO 30 N = 1, NSIZE - M
+*
+ WEIGHT = ONE / WEIGHT
+ MPLUSN = M + N
+*
+* Generate test matrices
+*
+ FS = .TRUE.
+ K = 0
+*
+ CALL DLASET( 'Full', MPLUSN, MPLUSN, ZERO, ZERO, AI,
+ $ LDA )
+ CALL DLASET( 'Full', MPLUSN, MPLUSN, ZERO, ZERO, BI,
+ $ LDA )
+*
+ CALL DLATM5( PRTYPE, M, N, AI, LDA, AI( M+1, M+1 ),
+ $ LDA, AI( 1, M+1 ), LDA, BI, LDA,
+ $ BI( M+1, M+1 ), LDA, BI( 1, M+1 ), LDA,
+ $ Q, LDA, Z, LDA, WEIGHT, QBA, QBB )
+*
+* Compute the Schur factorization and swapping the
+* m-by-m (1,1)-blocks with n-by-n (2,2)-blocks.
+* Swapping is accomplished via the function DLCTSX
+* which is supplied below.
+*
+ IF( IFUNC.EQ.0 ) THEN
+ SENSE = 'N'
+ ELSE IF( IFUNC.EQ.1 ) THEN
+ SENSE = 'E'
+ ELSE IF( IFUNC.EQ.2 ) THEN
+ SENSE = 'V'
+ ELSE IF( IFUNC.EQ.3 ) THEN
+ SENSE = 'B'
+ END IF
+*
+ CALL DLACPY( 'Full', MPLUSN, MPLUSN, AI, LDA, A, LDA )
+ CALL DLACPY( 'Full', MPLUSN, MPLUSN, BI, LDA, B, LDA )
+*
+ CALL DGGESX( 'V', 'V', 'S', DLCTSX, SENSE, MPLUSN, AI,
+ $ LDA, BI, LDA, MM, ALPHAR, ALPHAI, BETA,
+ $ Q, LDA, Z, LDA, PL, DIFEST, WORK, LWORK,
+ $ IWORK, LIWORK, BWORK, LINFO )
+*
+ IF( LINFO.NE.0 .AND. LINFO.NE.MPLUSN+2 ) THEN
+ RESULT( 1 ) = ULPINV
+ WRITE( NOUT, FMT = 9999 )'DGGESX', LINFO, MPLUSN,
+ $ PRTYPE
+ INFO = LINFO
+ GO TO 30
+ END IF
+*
+* Compute the norm(A, B)
+*
+ CALL DLACPY( 'Full', MPLUSN, MPLUSN, AI, LDA, WORK,
+ $ MPLUSN )
+ CALL DLACPY( 'Full', MPLUSN, MPLUSN, BI, LDA,
+ $ WORK( MPLUSN*MPLUSN+1 ), MPLUSN )
+ ABNRM = DLANGE( 'Fro', MPLUSN, 2*MPLUSN, WORK, MPLUSN,
+ $ WORK )
+*
+* Do tests (1) to (4)
+*
+ CALL DGET51( 1, MPLUSN, A, LDA, AI, LDA, Q, LDA, Z,
+ $ LDA, WORK, RESULT( 1 ) )
+ CALL DGET51( 1, MPLUSN, B, LDA, BI, LDA, Q, LDA, Z,
+ $ LDA, WORK, RESULT( 2 ) )
+ CALL DGET51( 3, MPLUSN, B, LDA, BI, LDA, Q, LDA, Q,
+ $ LDA, WORK, RESULT( 3 ) )
+ CALL DGET51( 3, MPLUSN, B, LDA, BI, LDA, Z, LDA, Z,
+ $ LDA, WORK, RESULT( 4 ) )
+ NTEST = 4
+*
+* Do tests (5) and (6): check Schur form of A and
+* compare eigenvalues with diagonals.
+*
+ TEMP1 = ZERO
+ RESULT( 5 ) = ZERO
+ RESULT( 6 ) = ZERO
+*
+ DO 10 J = 1, MPLUSN
+ ILABAD = .FALSE.
+ IF( ALPHAI( J ).EQ.ZERO ) THEN
+ TEMP2 = ( ABS( ALPHAR( J )-AI( J, J ) ) /
+ $ MAX( SMLNUM, ABS( ALPHAR( J ) ),
+ $ ABS( AI( J, J ) ) )+
+ $ ABS( BETA( J )-BI( J, J ) ) /
+ $ MAX( SMLNUM, ABS( BETA( J ) ),
+ $ ABS( BI( J, J ) ) ) ) / ULP
+ IF( J.LT.MPLUSN ) THEN
+ IF( AI( J+1, J ).NE.ZERO ) THEN
+ ILABAD = .TRUE.
+ RESULT( 5 ) = ULPINV
+ END IF
+ END IF
+ IF( J.GT.1 ) THEN
+ IF( AI( J, J-1 ).NE.ZERO ) THEN
+ ILABAD = .TRUE.
+ RESULT( 5 ) = ULPINV
+ END IF
+ END IF
+ ELSE
+ IF( ALPHAI( J ).GT.ZERO ) THEN
+ I1 = J
+ ELSE
+ I1 = J - 1
+ END IF
+ IF( I1.LE.0 .OR. I1.GE.MPLUSN ) THEN
+ ILABAD = .TRUE.
+ ELSE IF( I1.LT.MPLUSN-1 ) THEN
+ IF( AI( I1+2, I1+1 ).NE.ZERO ) THEN
+ ILABAD = .TRUE.
+ RESULT( 5 ) = ULPINV
+ END IF
+ ELSE IF( I1.GT.1 ) THEN
+ IF( AI( I1, I1-1 ).NE.ZERO ) THEN
+ ILABAD = .TRUE.
+ RESULT( 5 ) = ULPINV
+ END IF
+ END IF
+ IF( .NOT.ILABAD ) THEN
+ CALL DGET53( AI( I1, I1 ), LDA, BI( I1, I1 ),
+ $ LDA, BETA( J ), ALPHAR( J ),
+ $ ALPHAI( J ), TEMP2, IINFO )
+ IF( IINFO.GE.3 ) THEN
+ WRITE( NOUT, FMT = 9997 )IINFO, J,
+ $ MPLUSN, PRTYPE
+ INFO = ABS( IINFO )
+ END IF
+ ELSE
+ TEMP2 = ULPINV
+ END IF
+ END IF
+ TEMP1 = MAX( TEMP1, TEMP2 )
+ IF( ILABAD ) THEN
+ WRITE( NOUT, FMT = 9996 )J, MPLUSN, PRTYPE
+ END IF
+ 10 CONTINUE
+ RESULT( 6 ) = TEMP1
+ NTEST = NTEST + 2
+*
+* Test (7) (if sorting worked)
+*
+ RESULT( 7 ) = ZERO
+ IF( LINFO.EQ.MPLUSN+3 ) THEN
+ RESULT( 7 ) = ULPINV
+ ELSE IF( MM.NE.N ) THEN
+ RESULT( 7 ) = ULPINV
+ END IF
+ NTEST = NTEST + 1
+*
+* Test (8): compare the estimated value DIF and its
+* value. first, compute the exact DIF.
+*
+ RESULT( 8 ) = ZERO
+ MN2 = MM*( MPLUSN-MM )*2
+ IF( IFUNC.GE.2 .AND. MN2.LE.NCMAX*NCMAX ) THEN
+*
+* Note: for either following two causes, there are
+* almost same number of test cases fail the test.
+*
+ CALL DLAKF2( MM, MPLUSN-MM, AI, LDA,
+ $ AI( MM+1, MM+1 ), BI,
+ $ BI( MM+1, MM+1 ), C, LDC )
+*
+ CALL DGESVD( 'N', 'N', MN2, MN2, C, LDC, S, WORK,
+ $ 1, WORK( 2 ), 1, WORK( 3 ), LWORK-2,
+ $ INFO )
+ DIFTRU = S( MN2 )
+*
+ IF( DIFEST( 2 ).EQ.ZERO ) THEN
+ IF( DIFTRU.GT.ABNRM*ULP )
+ $ RESULT( 8 ) = ULPINV
+ ELSE IF( DIFTRU.EQ.ZERO ) THEN
+ IF( DIFEST( 2 ).GT.ABNRM*ULP )
+ $ RESULT( 8 ) = ULPINV
+ ELSE IF( ( DIFTRU.GT.THRSH2*DIFEST( 2 ) ) .OR.
+ $ ( DIFTRU*THRSH2.LT.DIFEST( 2 ) ) ) THEN
+ RESULT( 8 ) = MAX( DIFTRU / DIFEST( 2 ),
+ $ DIFEST( 2 ) / DIFTRU )
+ END IF
+ NTEST = NTEST + 1
+ END IF
+*
+* Test (9)
+*
+ RESULT( 9 ) = ZERO
+ IF( LINFO.EQ.( MPLUSN+2 ) ) THEN
+ IF( DIFTRU.GT.ABNRM*ULP )
+ $ RESULT( 9 ) = ULPINV
+ IF( ( IFUNC.GT.1 ) .AND. ( DIFEST( 2 ).NE.ZERO ) )
+ $ RESULT( 9 ) = ULPINV
+ IF( ( IFUNC.EQ.1 ) .AND. ( PL( 1 ).NE.ZERO ) )
+ $ RESULT( 9 ) = ULPINV
+ NTEST = NTEST + 1
+ END IF
+*
+ NTESTT = NTESTT + NTEST
+*
+* Print out tests which fail.
+*
+ DO 20 J = 1, 9
+ IF( RESULT( J ).GE.THRESH ) THEN
+*
+* If this is the first test to fail,
+* print a header to the data file.
+*
+ IF( NERRS.EQ.0 ) THEN
+ WRITE( NOUT, FMT = 9995 )'SGX'
+*
+* Matrix types
+*
+ WRITE( NOUT, FMT = 9993 )
+*
+* Tests performed
+*
+ WRITE( NOUT, FMT = 9992 )'orthogonal', '''',
+ $ 'transpose', ( '''', I = 1, 4 )
+*
+ END IF
+ NERRS = NERRS + 1
+ IF( RESULT( J ).LT.10000.0D0 ) THEN
+ WRITE( NOUT, FMT = 9991 )MPLUSN, PRTYPE,
+ $ WEIGHT, M, J, RESULT( J )
+ ELSE
+ WRITE( NOUT, FMT = 9990 )MPLUSN, PRTYPE,
+ $ WEIGHT, M, J, RESULT( J )
+ END IF
+ END IF
+ 20 CONTINUE
+*
+ 30 CONTINUE
+ 40 CONTINUE
+ 50 CONTINUE
+ 60 CONTINUE
+*
+ GO TO 150
+*
+ 70 CONTINUE
+*
+* Read in data from file to check accuracy of condition estimation
+* Read input data until N=0
+*
+ NPTKNT = 0
+*
+ 80 CONTINUE
+ READ( NIN, FMT = *, END = 140 )MPLUSN
+ IF( MPLUSN.EQ.0 )
+ $ GO TO 140
+ READ( NIN, FMT = *, END = 140 )N
+ DO 90 I = 1, MPLUSN
+ READ( NIN, FMT = * )( AI( I, J ), J = 1, MPLUSN )
+ 90 CONTINUE
+ DO 100 I = 1, MPLUSN
+ READ( NIN, FMT = * )( BI( I, J ), J = 1, MPLUSN )
+ 100 CONTINUE
+ READ( NIN, FMT = * )PLTRU, DIFTRU
+*
+ NPTKNT = NPTKNT + 1
+ FS = .TRUE.
+ K = 0
+ M = MPLUSN - N
+*
+ CALL DLACPY( 'Full', MPLUSN, MPLUSN, AI, LDA, A, LDA )
+ CALL DLACPY( 'Full', MPLUSN, MPLUSN, BI, LDA, B, LDA )
+*
+* Compute the Schur factorization while swaping the
+* m-by-m (1,1)-blocks with n-by-n (2,2)-blocks.
+*
+ CALL DGGESX( 'V', 'V', 'S', DLCTSX, 'B', MPLUSN, AI, LDA, BI, LDA,
+ $ MM, ALPHAR, ALPHAI, BETA, Q, LDA, Z, LDA, PL, DIFEST,
+ $ WORK, LWORK, IWORK, LIWORK, BWORK, LINFO )
+*
+ IF( LINFO.NE.0 .AND. LINFO.NE.MPLUSN+2 ) THEN
+ RESULT( 1 ) = ULPINV
+ WRITE( NOUT, FMT = 9998 )'DGGESX', LINFO, MPLUSN, NPTKNT
+ GO TO 130
+ END IF
+*
+* Compute the norm(A, B)
+* (should this be norm of (A,B) or (AI,BI)?)
+*
+ CALL DLACPY( 'Full', MPLUSN, MPLUSN, AI, LDA, WORK, MPLUSN )
+ CALL DLACPY( 'Full', MPLUSN, MPLUSN, BI, LDA,
+ $ WORK( MPLUSN*MPLUSN+1 ), MPLUSN )
+ ABNRM = DLANGE( 'Fro', MPLUSN, 2*MPLUSN, WORK, MPLUSN, WORK )
+*
+* Do tests (1) to (4)
+*
+ CALL DGET51( 1, MPLUSN, A, LDA, AI, LDA, Q, LDA, Z, LDA, WORK,
+ $ RESULT( 1 ) )
+ CALL DGET51( 1, MPLUSN, B, LDA, BI, LDA, Q, LDA, Z, LDA, WORK,
+ $ RESULT( 2 ) )
+ CALL DGET51( 3, MPLUSN, B, LDA, BI, LDA, Q, LDA, Q, LDA, WORK,
+ $ RESULT( 3 ) )
+ CALL DGET51( 3, MPLUSN, B, LDA, BI, LDA, Z, LDA, Z, LDA, WORK,
+ $ RESULT( 4 ) )
+*
+* Do tests (5) and (6): check Schur form of A and compare
+* eigenvalues with diagonals.
+*
+ NTEST = 6
+ TEMP1 = ZERO
+ RESULT( 5 ) = ZERO
+ RESULT( 6 ) = ZERO
+*
+ DO 110 J = 1, MPLUSN
+ ILABAD = .FALSE.
+ IF( ALPHAI( J ).EQ.ZERO ) THEN
+ TEMP2 = ( ABS( ALPHAR( J )-AI( J, J ) ) /
+ $ MAX( SMLNUM, ABS( ALPHAR( J ) ), ABS( AI( J,
+ $ J ) ) )+ABS( BETA( J )-BI( J, J ) ) /
+ $ MAX( SMLNUM, ABS( BETA( J ) ), ABS( BI( J, J ) ) ) )
+ $ / ULP
+ IF( J.LT.MPLUSN ) THEN
+ IF( AI( J+1, J ).NE.ZERO ) THEN
+ ILABAD = .TRUE.
+ RESULT( 5 ) = ULPINV
+ END IF
+ END IF
+ IF( J.GT.1 ) THEN
+ IF( AI( J, J-1 ).NE.ZERO ) THEN
+ ILABAD = .TRUE.
+ RESULT( 5 ) = ULPINV
+ END IF
+ END IF
+ ELSE
+ IF( ALPHAI( J ).GT.ZERO ) THEN
+ I1 = J
+ ELSE
+ I1 = J - 1
+ END IF
+ IF( I1.LE.0 .OR. I1.GE.MPLUSN ) THEN
+ ILABAD = .TRUE.
+ ELSE IF( I1.LT.MPLUSN-1 ) THEN
+ IF( AI( I1+2, I1+1 ).NE.ZERO ) THEN
+ ILABAD = .TRUE.
+ RESULT( 5 ) = ULPINV
+ END IF
+ ELSE IF( I1.GT.1 ) THEN
+ IF( AI( I1, I1-1 ).NE.ZERO ) THEN
+ ILABAD = .TRUE.
+ RESULT( 5 ) = ULPINV
+ END IF
+ END IF
+ IF( .NOT.ILABAD ) THEN
+ CALL DGET53( AI( I1, I1 ), LDA, BI( I1, I1 ), LDA,
+ $ BETA( J ), ALPHAR( J ), ALPHAI( J ), TEMP2,
+ $ IINFO )
+ IF( IINFO.GE.3 ) THEN
+ WRITE( NOUT, FMT = 9997 )IINFO, J, MPLUSN, NPTKNT
+ INFO = ABS( IINFO )
+ END IF
+ ELSE
+ TEMP2 = ULPINV
+ END IF
+ END IF
+ TEMP1 = MAX( TEMP1, TEMP2 )
+ IF( ILABAD ) THEN
+ WRITE( NOUT, FMT = 9996 )J, MPLUSN, NPTKNT
+ END IF
+ 110 CONTINUE
+ RESULT( 6 ) = TEMP1
+*
+* Test (7) (if sorting worked) <--------- need to be checked.
+*
+ NTEST = 7
+ RESULT( 7 ) = ZERO
+ IF( LINFO.EQ.MPLUSN+3 )
+ $ RESULT( 7 ) = ULPINV
+*
+* Test (8): compare the estimated value of DIF and its true value.
+*
+ NTEST = 8
+ RESULT( 8 ) = ZERO
+ IF( DIFEST( 2 ).EQ.ZERO ) THEN
+ IF( DIFTRU.GT.ABNRM*ULP )
+ $ RESULT( 8 ) = ULPINV
+ ELSE IF( DIFTRU.EQ.ZERO ) THEN
+ IF( DIFEST( 2 ).GT.ABNRM*ULP )
+ $ RESULT( 8 ) = ULPINV
+ ELSE IF( ( DIFTRU.GT.THRSH2*DIFEST( 2 ) ) .OR.
+ $ ( DIFTRU*THRSH2.LT.DIFEST( 2 ) ) ) THEN
+ RESULT( 8 ) = MAX( DIFTRU / DIFEST( 2 ), DIFEST( 2 ) / DIFTRU )
+ END IF
+*
+* Test (9)
+*
+ NTEST = 9
+ RESULT( 9 ) = ZERO
+ IF( LINFO.EQ.( MPLUSN+2 ) ) THEN
+ IF( DIFTRU.GT.ABNRM*ULP )
+ $ RESULT( 9 ) = ULPINV
+ IF( ( IFUNC.GT.1 ) .AND. ( DIFEST( 2 ).NE.ZERO ) )
+ $ RESULT( 9 ) = ULPINV
+ IF( ( IFUNC.EQ.1 ) .AND. ( PL( 1 ).NE.ZERO ) )
+ $ RESULT( 9 ) = ULPINV
+ END IF
+*
+* Test (10): compare the estimated value of PL and it true value.
+*
+ NTEST = 10
+ RESULT( 10 ) = ZERO
+ IF( PL( 1 ).EQ.ZERO ) THEN
+ IF( PLTRU.GT.ABNRM*ULP )
+ $ RESULT( 10 ) = ULPINV
+ ELSE IF( PLTRU.EQ.ZERO ) THEN
+ IF( PL( 1 ).GT.ABNRM*ULP )
+ $ RESULT( 10 ) = ULPINV
+ ELSE IF( ( PLTRU.GT.THRESH*PL( 1 ) ) .OR.
+ $ ( PLTRU*THRESH.LT.PL( 1 ) ) ) THEN
+ RESULT( 10 ) = ULPINV
+ END IF
+*
+ NTESTT = NTESTT + NTEST
+*
+* Print out tests which fail.
+*
+ DO 120 J = 1, NTEST
+ IF( RESULT( J ).GE.THRESH ) THEN
+*
+* If this is the first test to fail,
+* print a header to the data file.
+*
+ IF( NERRS.EQ.0 ) THEN
+ WRITE( NOUT, FMT = 9995 )'SGX'
+*
+* Matrix types
+*
+ WRITE( NOUT, FMT = 9994 )
+*
+* Tests performed
+*
+ WRITE( NOUT, FMT = 9992 )'orthogonal', '''',
+ $ 'transpose', ( '''', I = 1, 4 )
+*
+ END IF
+ NERRS = NERRS + 1
+ IF( RESULT( J ).LT.10000.0D0 ) THEN
+ WRITE( NOUT, FMT = 9989 )NPTKNT, MPLUSN, J, RESULT( J )
+ ELSE
+ WRITE( NOUT, FMT = 9988 )NPTKNT, MPLUSN, J, RESULT( J )
+ END IF
+ END IF
+*
+ 120 CONTINUE
+*
+ 130 CONTINUE
+ GO TO 80
+ 140 CONTINUE
+*
+ 150 CONTINUE
+*
+* Summary
+*
+ CALL ALASVM( 'SGX', NOUT, NERRS, NTESTT, 0 )
+*
+ WORK( 1 ) = MAXWRK
+*
+ RETURN
+*
+ 9999 FORMAT( ' DDRGSX: ', A, ' returned INFO=', I6, '.', / 9X, 'N=',
+ $ I6, ', JTYPE=', I6, ')' )
+*
+ 9998 FORMAT( ' DDRGSX: ', A, ' returned INFO=', I6, '.', / 9X, 'N=',
+ $ I6, ', Input Example #', I2, ')' )
+*
+ 9997 FORMAT( ' DDRGSX: DGET53 returned INFO=', I1, ' for eigenvalue ',
+ $ I6, '.', / 9X, 'N=', I6, ', JTYPE=', I6, ')' )
+*
+ 9996 FORMAT( ' DDRGSX: S not in Schur form at eigenvalue ', I6, '.',
+ $ / 9X, 'N=', I6, ', JTYPE=', I6, ')' )
+*
+ 9995 FORMAT( / 1X, A3, ' -- Real Expert Generalized Schur form',
+ $ ' problem driver' )
+*
+ 9994 FORMAT( 'Input Example' )
+*
+ 9993 FORMAT( ' Matrix types: ', /
+ $ ' 1: A is a block diagonal matrix of Jordan blocks ',
+ $ 'and B is the identity ', / ' matrix, ',
+ $ / ' 2: A and B are upper triangular matrices, ',
+ $ / ' 3: A and B are as type 2, but each second diagonal ',
+ $ 'block in A_11 and ', /
+ $ ' each third diaongal block in A_22 are 2x2 blocks,',
+ $ / ' 4: A and B are block diagonal matrices, ',
+ $ / ' 5: (A,B) has potentially close or common ',
+ $ 'eigenvalues.', / )
+*
+ 9992 FORMAT( / ' Tests performed: (S is Schur, T is triangular, ',
+ $ 'Q and Z are ', A, ',', / 19X,
+ $ ' a is alpha, b is beta, and ', A, ' means ', A, '.)',
+ $ / ' 1 = | A - Q S Z', A,
+ $ ' | / ( |A| n ulp ) 2 = | B - Q T Z', A,
+ $ ' | / ( |B| n ulp )', / ' 3 = | I - QQ', A,
+ $ ' | / ( n ulp ) 4 = | I - ZZ', A,
+ $ ' | / ( n ulp )', / ' 5 = 1/ULP if A is not in ',
+ $ 'Schur form S', / ' 6 = difference between (alpha,beta)',
+ $ ' and diagonals of (S,T)', /
+ $ ' 7 = 1/ULP if SDIM is not the correct number of ',
+ $ 'selected eigenvalues', /
+ $ ' 8 = 1/ULP if DIFEST/DIFTRU > 10*THRESH or ',
+ $ 'DIFTRU/DIFEST > 10*THRESH',
+ $ / ' 9 = 1/ULP if DIFEST <> 0 or DIFTRU > ULP*norm(A,B) ',
+ $ 'when reordering fails', /
+ $ ' 10 = 1/ULP if PLEST/PLTRU > THRESH or ',
+ $ 'PLTRU/PLEST > THRESH', /
+ $ ' ( Test 10 is only for input examples )', / )
+ 9991 FORMAT( ' Matrix order=', I2, ', type=', I2, ', a=', D10.4,
+ $ ', order(A_11)=', I2, ', result ', I2, ' is ', 0P, F8.2 )
+ 9990 FORMAT( ' Matrix order=', I2, ', type=', I2, ', a=', D10.4,
+ $ ', order(A_11)=', I2, ', result ', I2, ' is ', 0P, D10.4 )
+ 9989 FORMAT( ' Input example #', I2, ', matrix order=', I4, ',',
+ $ ' result ', I2, ' is', 0P, F8.2 )
+ 9988 FORMAT( ' Input example #', I2, ', matrix order=', I4, ',',
+ $ ' result ', I2, ' is', 1P, D10.3 )
+*
+* End of DDRGSX
+*
+ END
+ SUBROUTINE DDRGVX( NSIZE, THRESH, NIN, NOUT, A, LDA, B, AI, BI,
+ $ ALPHAR, ALPHAI, BETA, VL, VR, ILO, IHI, LSCALE,
+ $ RSCALE, S, DTRU, DIF, DIFTRU, WORK, LWORK,
+ $ IWORK, LIWORK, RESULT, BWORK, INFO )
+*
+* -- LAPACK test routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER IHI, ILO, INFO, LDA, LIWORK, LWORK, NIN, NOUT,
+ $ NSIZE
+ DOUBLE PRECISION THRESH
+* ..
+* .. Array Arguments ..
+ LOGICAL BWORK( * )
+ INTEGER IWORK( * )
+ DOUBLE PRECISION A( LDA, * ), AI( LDA, * ), ALPHAI( * ),
+ $ ALPHAR( * ), B( LDA, * ), BETA( * ),
+ $ BI( LDA, * ), DIF( * ), DIFTRU( * ), DTRU( * ),
+ $ LSCALE( * ), RESULT( 4 ), RSCALE( * ), S( * ),
+ $ VL( LDA, * ), VR( LDA, * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DDRGVX checks the nonsymmetric generalized eigenvalue problem
+* expert driver DGGEVX.
+*
+* DGGEVX computes the generalized eigenvalues, (optionally) the left
+* and/or right eigenvectors, (optionally) computes a balancing
+* transformation to improve the conditioning, and (optionally)
+* reciprocal condition numbers for the eigenvalues and eigenvectors.
+*
+* When DDRGVX is called with NSIZE > 0, two types of test matrix pairs
+* are generated by the subroutine DLATM6 and test the driver DGGEVX.
+* The test matrices have the known exact condition numbers for
+* eigenvalues. For the condition numbers of the eigenvectors
+* corresponding the first and last eigenvalues are also know
+* ``exactly'' (see DLATM6).
+*
+* For each matrix pair, the following tests will be performed and
+* compared with the threshhold THRESH.
+*
+* (1) max over all left eigenvalue/-vector pairs (beta/alpha,l) of
+*
+* | l**H * (beta A - alpha B) | / ( ulp max( |beta A|, |alpha B| ) )
+*
+* where l**H is the conjugate tranpose of l.
+*
+* (2) max over all right eigenvalue/-vector pairs (beta/alpha,r) of
+*
+* | (beta A - alpha B) r | / ( ulp max( |beta A|, |alpha B| ) )
+*
+* (3) The condition number S(i) of eigenvalues computed by DGGEVX
+* differs less than a factor THRESH from the exact S(i) (see
+* DLATM6).
+*
+* (4) DIF(i) computed by DTGSNA differs less than a factor 10*THRESH
+* from the exact value (for the 1st and 5th vectors only).
+*
+* Test Matrices
+* =============
+*
+* Two kinds of test matrix pairs
+*
+* (A, B) = inverse(YH) * (Da, Db) * inverse(X)
+*
+* are used in the tests:
+*
+* 1: Da = 1+a 0 0 0 0 Db = 1 0 0 0 0
+* 0 2+a 0 0 0 0 1 0 0 0
+* 0 0 3+a 0 0 0 0 1 0 0
+* 0 0 0 4+a 0 0 0 0 1 0
+* 0 0 0 0 5+a , 0 0 0 0 1 , and
+*
+* 2: Da = 1 -1 0 0 0 Db = 1 0 0 0 0
+* 1 1 0 0 0 0 1 0 0 0
+* 0 0 1 0 0 0 0 1 0 0
+* 0 0 0 1+a 1+b 0 0 0 1 0
+* 0 0 0 -1-b 1+a , 0 0 0 0 1 .
+*
+* In both cases the same inverse(YH) and inverse(X) are used to compute
+* (A, B), giving the exact eigenvectors to (A,B) as (YH, X):
+*
+* YH: = 1 0 -y y -y X = 1 0 -x -x x
+* 0 1 -y y -y 0 1 x -x -x
+* 0 0 1 0 0 0 0 1 0 0
+* 0 0 0 1 0 0 0 0 1 0
+* 0 0 0 0 1, 0 0 0 0 1 , where
+*
+* a, b, x and y will have all values independently of each other from
+* { sqrt(sqrt(ULP)), 0.1, 1, 10, 1/sqrt(sqrt(ULP)) }.
+*
+* Arguments
+* =========
+*
+* NSIZE (input) INTEGER
+* The number of sizes of matrices to use. NSIZE must be at
+* least zero. If it is zero, no randomly generated matrices
+* are tested, but any test matrices read from NIN will be
+* tested.
+*
+* THRESH (input) DOUBLE PRECISION
+* A test will count as "failed" if the "error", computed as
+* described above, exceeds THRESH. Note that the error
+* is scaled to be O(1), so THRESH should be a reasonably
+* small multiple of 1, e.g., 10 or 100. In particular,
+* it should not depend on the precision (single vs. double)
+* or the size of the matrix. It must be at least zero.
+*
+* NIN (input) INTEGER
+* The FORTRAN unit number for reading in the data file of
+* problems to solve.
+*
+* NOUT (input) INTEGER
+* The FORTRAN unit number for printing out error messages
+* (e.g., if a routine returns IINFO not equal to 0.)
+*
+* A (workspace) DOUBLE PRECISION array, dimension (LDA, NSIZE)
+* Used to hold the matrix whose eigenvalues are to be
+* computed. On exit, A contains the last matrix actually used.
+*
+* LDA (input) INTEGER
+* The leading dimension of A, B, AI, BI, Ao, and Bo.
+* It must be at least 1 and at least NSIZE.
+*
+* B (workspace) DOUBLE PRECISION array, dimension (LDA, NSIZE)
+* Used to hold the matrix whose eigenvalues are to be
+* computed. On exit, B contains the last matrix actually used.
+*
+* AI (workspace) DOUBLE PRECISION array, dimension (LDA, NSIZE)
+* Copy of A, modified by DGGEVX.
+*
+* BI (workspace) DOUBLE PRECISION array, dimension (LDA, NSIZE)
+* Copy of B, modified by DGGEVX.
+*
+* ALPHAR (workspace) DOUBLE PRECISION array, dimension (NSIZE)
+* ALPHAI (workspace) DOUBLE PRECISION array, dimension (NSIZE)
+* BETA (workspace) DOUBLE PRECISION array, dimension (NSIZE)
+* On exit, (ALPHAR + ALPHAI*i)/BETA are the eigenvalues.
+*
+* VL (workspace) DOUBLE PRECISION array, dimension (LDA, NSIZE)
+* VL holds the left eigenvectors computed by DGGEVX.
+*
+* VR (workspace) DOUBLE PRECISION array, dimension (LDA, NSIZE)
+* VR holds the right eigenvectors computed by DGGEVX.
+*
+* ILO (output/workspace) INTEGER
+*
+* IHI (output/workspace) INTEGER
+*
+* LSCALE (output/workspace) DOUBLE PRECISION array, dimension (N)
+*
+* RSCALE (output/workspace) DOUBLE PRECISION array, dimension (N)
+*
+* S (output/workspace) DOUBLE PRECISION array, dimension (N)
+*
+* DTRU (output/workspace) DOUBLE PRECISION array, dimension (N)
+*
+* DIF (output/workspace) DOUBLE PRECISION array, dimension (N)
+*
+* DIFTRU (output/workspace) DOUBLE PRECISION array, dimension (N)
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK)
+*
+* LWORK (input) INTEGER
+* Leading dimension of WORK. LWORK >= 2*N*N+12*N+16.
+*
+* IWORK (workspace) INTEGER array, dimension (LIWORK)
+*
+* LIWORK (input) INTEGER
+* Leading dimension of IWORK. Must be at least N+6.
+*
+* RESULT (output/workspace) DOUBLE PRECISION array, dimension (4)
+*
+* BWORK (workspace) LOGICAL array, dimension (N)
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value.
+* > 0: A routine returned an error code.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE, TEN, TNTH
+ PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TEN = 1.0D+1,
+ $ TNTH = 1.0D-1 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, IPTYPE, IWA, IWB, IWX, IWY, J, LINFO,
+ $ MAXWRK, MINWRK, N, NERRS, NMAX, NPTKNT, NTESTT
+ DOUBLE PRECISION ABNORM, ANORM, BNORM, RATIO1, RATIO2, THRSH2,
+ $ ULP, ULPINV
+* ..
+* .. Local Arrays ..
+ DOUBLE PRECISION WEIGHT( 5 )
+* ..
+* .. External Functions ..
+ INTEGER ILAENV
+ DOUBLE PRECISION DLAMCH, DLANGE
+ EXTERNAL ILAENV, DLAMCH, DLANGE
+* ..
+* .. External Subroutines ..
+ EXTERNAL ALASVM, DGET52, DGGEVX, DLACPY, DLATM6, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, SQRT
+* ..
+* .. Executable Statements ..
+*
+* Check for errors
+*
+ INFO = 0
+*
+ NMAX = 5
+*
+ IF( NSIZE.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( THRESH.LT.ZERO ) THEN
+ INFO = -2
+ ELSE IF( NIN.LE.0 ) THEN
+ INFO = -3
+ ELSE IF( NOUT.LE.0 ) THEN
+ INFO = -4
+ ELSE IF( LDA.LT.1 .OR. LDA.LT.NMAX ) THEN
+ INFO = -6
+ ELSE IF( LIWORK.LT.NMAX+6 ) THEN
+ INFO = -26
+ END IF
+*
+* Compute workspace
+* (Note: Comments in the code beginning "Workspace:" describe the
+* minimal amount of workspace needed at that point in the code,
+* as well as the preferred amount for good performance.
+* NB refers to the optimal block size for the immediately
+* following subroutine, as returned by ILAENV.)
+*
+ MINWRK = 1
+ IF( INFO.EQ.0 .AND. LWORK.GE.1 ) THEN
+ MINWRK = 2*NMAX*NMAX + 12*NMAX + 16
+ MAXWRK = 6*NMAX + NMAX*ILAENV( 1, 'DGEQRF', ' ', NMAX, 1, NMAX,
+ $ 0 )
+ MAXWRK = MAX( MAXWRK, 2*NMAX*NMAX+12*NMAX+16 )
+ WORK( 1 ) = MAXWRK
+ END IF
+*
+ IF( LWORK.LT.MINWRK )
+ $ INFO = -24
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DDRGVX', -INFO )
+ RETURN
+ END IF
+*
+ N = 5
+ ULP = DLAMCH( 'P' )
+ ULPINV = ONE / ULP
+ THRSH2 = TEN*THRESH
+ NERRS = 0
+ NPTKNT = 0
+ NTESTT = 0
+*
+ IF( NSIZE.EQ.0 )
+ $ GO TO 90
+*
+* Parameters used for generating test matrices.
+*
+ WEIGHT( 1 ) = SQRT( SQRT( ULP ) )
+ WEIGHT( 2 ) = TNTH
+ WEIGHT( 3 ) = ONE
+ WEIGHT( 4 ) = ONE / WEIGHT( 2 )
+ WEIGHT( 5 ) = ONE / WEIGHT( 1 )
+*
+ DO 80 IPTYPE = 1, 2
+ DO 70 IWA = 1, 5
+ DO 60 IWB = 1, 5
+ DO 50 IWX = 1, 5
+ DO 40 IWY = 1, 5
+*
+* generated a test matrix pair
+*
+ CALL DLATM6( IPTYPE, 5, A, LDA, B, VR, LDA, VL,
+ $ LDA, WEIGHT( IWA ), WEIGHT( IWB ),
+ $ WEIGHT( IWX ), WEIGHT( IWY ), DTRU,
+ $ DIFTRU )
+*
+* Compute eigenvalues/eigenvectors of (A, B).
+* Compute eigenvalue/eigenvector condition numbers
+* using computed eigenvectors.
+*
+ CALL DLACPY( 'F', N, N, A, LDA, AI, LDA )
+ CALL DLACPY( 'F', N, N, B, LDA, BI, LDA )
+*
+ CALL DGGEVX( 'N', 'V', 'V', 'B', N, AI, LDA, BI,
+ $ LDA, ALPHAR, ALPHAI, BETA, VL, LDA,
+ $ VR, LDA, ILO, IHI, LSCALE, RSCALE,
+ $ ANORM, BNORM, S, DIF, WORK, LWORK,
+ $ IWORK, BWORK, LINFO )
+ IF( LINFO.NE.0 ) THEN
+ RESULT( 1 ) = ULPINV
+ WRITE( NOUT, FMT = 9999 )'DGGEVX', LINFO, N,
+ $ IPTYPE
+ GO TO 30
+ END IF
+*
+* Compute the norm(A, B)
+*
+ CALL DLACPY( 'Full', N, N, AI, LDA, WORK, N )
+ CALL DLACPY( 'Full', N, N, BI, LDA, WORK( N*N+1 ),
+ $ N )
+ ABNORM = DLANGE( 'Fro', N, 2*N, WORK, N, WORK )
+*
+* Tests (1) and (2)
+*
+ RESULT( 1 ) = ZERO
+ CALL DGET52( .TRUE., N, A, LDA, B, LDA, VL, LDA,
+ $ ALPHAR, ALPHAI, BETA, WORK,
+ $ RESULT( 1 ) )
+ IF( RESULT( 2 ).GT.THRESH ) THEN
+ WRITE( NOUT, FMT = 9998 )'Left', 'DGGEVX',
+ $ RESULT( 2 ), N, IPTYPE, IWA, IWB, IWX, IWY
+ END IF
+*
+ RESULT( 2 ) = ZERO
+ CALL DGET52( .FALSE., N, A, LDA, B, LDA, VR, LDA,
+ $ ALPHAR, ALPHAI, BETA, WORK,
+ $ RESULT( 2 ) )
+ IF( RESULT( 3 ).GT.THRESH ) THEN
+ WRITE( NOUT, FMT = 9998 )'Right', 'DGGEVX',
+ $ RESULT( 3 ), N, IPTYPE, IWA, IWB, IWX, IWY
+ END IF
+*
+* Test (3)
+*
+ RESULT( 3 ) = ZERO
+ DO 10 I = 1, N
+ IF( S( I ).EQ.ZERO ) THEN
+ IF( DTRU( I ).GT.ABNORM*ULP )
+ $ RESULT( 3 ) = ULPINV
+ ELSE IF( DTRU( I ).EQ.ZERO ) THEN
+ IF( S( I ).GT.ABNORM*ULP )
+ $ RESULT( 3 ) = ULPINV
+ ELSE
+ WORK( I ) = MAX( ABS( DTRU( I ) / S( I ) ),
+ $ ABS( S( I ) / DTRU( I ) ) )
+ RESULT( 3 ) = MAX( RESULT( 3 ), WORK( I ) )
+ END IF
+ 10 CONTINUE
+*
+* Test (4)
+*
+ RESULT( 4 ) = ZERO
+ IF( DIF( 1 ).EQ.ZERO ) THEN
+ IF( DIFTRU( 1 ).GT.ABNORM*ULP )
+ $ RESULT( 4 ) = ULPINV
+ ELSE IF( DIFTRU( 1 ).EQ.ZERO ) THEN
+ IF( DIF( 1 ).GT.ABNORM*ULP )
+ $ RESULT( 4 ) = ULPINV
+ ELSE IF( DIF( 5 ).EQ.ZERO ) THEN
+ IF( DIFTRU( 5 ).GT.ABNORM*ULP )
+ $ RESULT( 4 ) = ULPINV
+ ELSE IF( DIFTRU( 5 ).EQ.ZERO ) THEN
+ IF( DIF( 5 ).GT.ABNORM*ULP )
+ $ RESULT( 4 ) = ULPINV
+ ELSE
+ RATIO1 = MAX( ABS( DIFTRU( 1 ) / DIF( 1 ) ),
+ $ ABS( DIF( 1 ) / DIFTRU( 1 ) ) )
+ RATIO2 = MAX( ABS( DIFTRU( 5 ) / DIF( 5 ) ),
+ $ ABS( DIF( 5 ) / DIFTRU( 5 ) ) )
+ RESULT( 4 ) = MAX( RATIO1, RATIO2 )
+ END IF
+*
+ NTESTT = NTESTT + 4
+*
+* Print out tests which fail.
+*
+ DO 20 J = 1, 4
+ IF( ( RESULT( J ).GE.THRSH2 .AND. J.GE.4 ) .OR.
+ $ ( RESULT( J ).GE.THRESH .AND. J.LE.3 ) )
+ $ THEN
+*
+* If this is the first test to fail,
+* print a header to the data file.
+*
+ IF( NERRS.EQ.0 ) THEN
+ WRITE( NOUT, FMT = 9997 )'DXV'
+*
+* Print out messages for built-in examples
+*
+* Matrix types
+*
+ WRITE( NOUT, FMT = 9995 )
+ WRITE( NOUT, FMT = 9994 )
+ WRITE( NOUT, FMT = 9993 )
+*
+* Tests performed
+*
+ WRITE( NOUT, FMT = 9992 )'''',
+ $ 'transpose', ''''
+*
+ END IF
+ NERRS = NERRS + 1
+ IF( RESULT( J ).LT.10000.0D0 ) THEN
+ WRITE( NOUT, FMT = 9991 )IPTYPE, IWA,
+ $ IWB, IWX, IWY, J, RESULT( J )
+ ELSE
+ WRITE( NOUT, FMT = 9990 )IPTYPE, IWA,
+ $ IWB, IWX, IWY, J, RESULT( J )
+ END IF
+ END IF
+ 20 CONTINUE
+*
+ 30 CONTINUE
+*
+ 40 CONTINUE
+ 50 CONTINUE
+ 60 CONTINUE
+ 70 CONTINUE
+ 80 CONTINUE
+*
+ GO TO 150
+*
+ 90 CONTINUE
+*
+* Read in data from file to check accuracy of condition estimation
+* Read input data until N=0
+*
+ READ( NIN, FMT = *, END = 150 )N
+ IF( N.EQ.0 )
+ $ GO TO 150
+ DO 100 I = 1, N
+ READ( NIN, FMT = * )( A( I, J ), J = 1, N )
+ 100 CONTINUE
+ DO 110 I = 1, N
+ READ( NIN, FMT = * )( B( I, J ), J = 1, N )
+ 110 CONTINUE
+ READ( NIN, FMT = * )( DTRU( I ), I = 1, N )
+ READ( NIN, FMT = * )( DIFTRU( I ), I = 1, N )
+*
+ NPTKNT = NPTKNT + 1
+*
+* Compute eigenvalues/eigenvectors of (A, B).
+* Compute eigenvalue/eigenvector condition numbers
+* using computed eigenvectors.
+*
+ CALL DLACPY( 'F', N, N, A, LDA, AI, LDA )
+ CALL DLACPY( 'F', N, N, B, LDA, BI, LDA )
+*
+ CALL DGGEVX( 'N', 'V', 'V', 'B', N, AI, LDA, BI, LDA, ALPHAR,
+ $ ALPHAI, BETA, VL, LDA, VR, LDA, ILO, IHI, LSCALE,
+ $ RSCALE, ANORM, BNORM, S, DIF, WORK, LWORK, IWORK,
+ $ BWORK, LINFO )
+*
+ IF( LINFO.NE.0 ) THEN
+ RESULT( 1 ) = ULPINV
+ WRITE( NOUT, FMT = 9987 )'DGGEVX', LINFO, N, NPTKNT
+ GO TO 140
+ END IF
+*
+* Compute the norm(A, B)
+*
+ CALL DLACPY( 'Full', N, N, AI, LDA, WORK, N )
+ CALL DLACPY( 'Full', N, N, BI, LDA, WORK( N*N+1 ), N )
+ ABNORM = DLANGE( 'Fro', N, 2*N, WORK, N, WORK )
+*
+* Tests (1) and (2)
+*
+ RESULT( 1 ) = ZERO
+ CALL DGET52( .TRUE., N, A, LDA, B, LDA, VL, LDA, ALPHAR, ALPHAI,
+ $ BETA, WORK, RESULT( 1 ) )
+ IF( RESULT( 2 ).GT.THRESH ) THEN
+ WRITE( NOUT, FMT = 9986 )'Left', 'DGGEVX', RESULT( 2 ), N,
+ $ NPTKNT
+ END IF
+*
+ RESULT( 2 ) = ZERO
+ CALL DGET52( .FALSE., N, A, LDA, B, LDA, VR, LDA, ALPHAR, ALPHAI,
+ $ BETA, WORK, RESULT( 2 ) )
+ IF( RESULT( 3 ).GT.THRESH ) THEN
+ WRITE( NOUT, FMT = 9986 )'Right', 'DGGEVX', RESULT( 3 ), N,
+ $ NPTKNT
+ END IF
+*
+* Test (3)
+*
+ RESULT( 3 ) = ZERO
+ DO 120 I = 1, N
+ IF( S( I ).EQ.ZERO ) THEN
+ IF( DTRU( I ).GT.ABNORM*ULP )
+ $ RESULT( 3 ) = ULPINV
+ ELSE IF( DTRU( I ).EQ.ZERO ) THEN
+ IF( S( I ).GT.ABNORM*ULP )
+ $ RESULT( 3 ) = ULPINV
+ ELSE
+ WORK( I ) = MAX( ABS( DTRU( I ) / S( I ) ),
+ $ ABS( S( I ) / DTRU( I ) ) )
+ RESULT( 3 ) = MAX( RESULT( 3 ), WORK( I ) )
+ END IF
+ 120 CONTINUE
+*
+* Test (4)
+*
+ RESULT( 4 ) = ZERO
+ IF( DIF( 1 ).EQ.ZERO ) THEN
+ IF( DIFTRU( 1 ).GT.ABNORM*ULP )
+ $ RESULT( 4 ) = ULPINV
+ ELSE IF( DIFTRU( 1 ).EQ.ZERO ) THEN
+ IF( DIF( 1 ).GT.ABNORM*ULP )
+ $ RESULT( 4 ) = ULPINV
+ ELSE IF( DIF( 5 ).EQ.ZERO ) THEN
+ IF( DIFTRU( 5 ).GT.ABNORM*ULP )
+ $ RESULT( 4 ) = ULPINV
+ ELSE IF( DIFTRU( 5 ).EQ.ZERO ) THEN
+ IF( DIF( 5 ).GT.ABNORM*ULP )
+ $ RESULT( 4 ) = ULPINV
+ ELSE
+ RATIO1 = MAX( ABS( DIFTRU( 1 ) / DIF( 1 ) ),
+ $ ABS( DIF( 1 ) / DIFTRU( 1 ) ) )
+ RATIO2 = MAX( ABS( DIFTRU( 5 ) / DIF( 5 ) ),
+ $ ABS( DIF( 5 ) / DIFTRU( 5 ) ) )
+ RESULT( 4 ) = MAX( RATIO1, RATIO2 )
+ END IF
+*
+ NTESTT = NTESTT + 4
+*
+* Print out tests which fail.
+*
+ DO 130 J = 1, 4
+ IF( RESULT( J ).GE.THRSH2 ) THEN
+*
+* If this is the first test to fail,
+* print a header to the data file.
+*
+ IF( NERRS.EQ.0 ) THEN
+ WRITE( NOUT, FMT = 9997 )'DXV'
+*
+* Print out messages for built-in examples
+*
+* Matrix types
+*
+ WRITE( NOUT, FMT = 9996 )
+*
+* Tests performed
+*
+ WRITE( NOUT, FMT = 9992 )'''', 'transpose', ''''
+*
+ END IF
+ NERRS = NERRS + 1
+ IF( RESULT( J ).LT.10000.0D0 ) THEN
+ WRITE( NOUT, FMT = 9989 )NPTKNT, N, J, RESULT( J )
+ ELSE
+ WRITE( NOUT, FMT = 9988 )NPTKNT, N, J, RESULT( J )
+ END IF
+ END IF
+ 130 CONTINUE
+*
+ 140 CONTINUE
+*
+ GO TO 90
+ 150 CONTINUE
+*
+* Summary
+*
+ CALL ALASVM( 'DXV', NOUT, NERRS, NTESTT, 0 )
+*
+ WORK( 1 ) = MAXWRK
+*
+ RETURN
+*
+ 9999 FORMAT( ' DDRGVX: ', A, ' returned INFO=', I6, '.', / 9X, 'N=',
+ $ I6, ', JTYPE=', I6, ')' )
+*
+ 9998 FORMAT( ' DDRGVX: ', A, ' Eigenvectors from ', A, ' incorrectly ',
+ $ 'normalized.', / ' Bits of error=', 0P, G10.3, ',', 9X,
+ $ 'N=', I6, ', JTYPE=', I6, ', IWA=', I5, ', IWB=', I5,
+ $ ', IWX=', I5, ', IWY=', I5 )
+*
+ 9997 FORMAT( / 1X, A3, ' -- Real Expert Eigenvalue/vector',
+ $ ' problem driver' )
+*
+ 9996 FORMAT( ' Input Example' )
+*
+ 9995 FORMAT( ' Matrix types: ', / )
+*
+ 9994 FORMAT( ' TYPE 1: Da is diagonal, Db is identity, ',
+ $ / ' A = Y^(-H) Da X^(-1), B = Y^(-H) Db X^(-1) ',
+ $ / ' YH and X are left and right eigenvectors. ', / )
+*
+ 9993 FORMAT( ' TYPE 2: Da is quasi-diagonal, Db is identity, ',
+ $ / ' A = Y^(-H) Da X^(-1), B = Y^(-H) Db X^(-1) ',
+ $ / ' YH and X are left and right eigenvectors. ', / )
+*
+ 9992 FORMAT( / ' Tests performed: ', / 4X,
+ $ ' a is alpha, b is beta, l is a left eigenvector, ', / 4X,
+ $ ' r is a right eigenvector and ', A, ' means ', A, '.',
+ $ / ' 1 = max | ( b A - a B )', A, ' l | / const.',
+ $ / ' 2 = max | ( b A - a B ) r | / const.',
+ $ / ' 3 = max ( Sest/Stru, Stru/Sest ) ',
+ $ ' over all eigenvalues', /
+ $ ' 4 = max( DIFest/DIFtru, DIFtru/DIFest ) ',
+ $ ' over the 1st and 5th eigenvectors', / )
+*
+ 9991 FORMAT( ' Type=', I2, ',', ' IWA=', I2, ', IWB=', I2, ', IWX=',
+ $ I2, ', IWY=', I2, ', result ', I2, ' is', 0P, F8.2 )
+ 9990 FORMAT( ' Type=', I2, ',', ' IWA=', I2, ', IWB=', I2, ', IWX=',
+ $ I2, ', IWY=', I2, ', result ', I2, ' is', 1P, D10.3 )
+ 9989 FORMAT( ' Input example #', I2, ', matrix order=', I4, ',',
+ $ ' result ', I2, ' is', 0P, F8.2 )
+ 9988 FORMAT( ' Input example #', I2, ', matrix order=', I4, ',',
+ $ ' result ', I2, ' is', 1P, D10.3 )
+ 9987 FORMAT( ' DDRGVX: ', A, ' returned INFO=', I6, '.', / 9X, 'N=',
+ $ I6, ', Input example #', I2, ')' )
+*
+ 9986 FORMAT( ' DDRGVX: ', A, ' Eigenvectors from ', A, ' incorrectly ',
+ $ 'normalized.', / ' Bits of error=', 0P, G10.3, ',', 9X,
+ $ 'N=', I6, ', Input Example #', I2, ')' )
+*
+*
+* End of DDRGVX
+*
+ END
+ SUBROUTINE DDRVBD( NSIZES, MM, NN, NTYPES, DOTYPE, ISEED, THRESH,
+ $ A, LDA, U, LDU, VT, LDVT, ASAV, USAV, VTSAV, S,
+ $ SSAV, E, WORK, LWORK, IWORK, NOUT, INFO )
+*
+* -- LAPACK test routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LDA, LDU, LDVT, LWORK, NOUT, NSIZES,
+ $ NTYPES
+ DOUBLE PRECISION THRESH
+* ..
+* .. Array Arguments ..
+ LOGICAL DOTYPE( * )
+ INTEGER ISEED( 4 ), IWORK( * ), MM( * ), NN( * )
+ DOUBLE PRECISION A( LDA, * ), ASAV( LDA, * ), E( * ), S( * ),
+ $ SSAV( * ), U( LDU, * ), USAV( LDU, * ),
+ $ VT( LDVT, * ), VTSAV( LDVT, * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DDRVBD checks the singular value decomposition (SVD) drivers
+* DGESVD and SGESDD.
+* Both DGESVD and SGESDD factor A = U diag(S) VT, where U and VT are
+* orthogonal and diag(S) is diagonal with the entries of the array S
+* on its diagonal. The entries of S are the singular values,
+* nonnegative and stored in decreasing order. U and VT can be
+* optionally not computed, overwritten on A, or computed partially.
+*
+* A is M by N. Let MNMIN = min( M, N ). S has dimension MNMIN.
+* U can be M by M or M by MNMIN. VT can be N by N or MNMIN by N.
+*
+* When DDRVBD is called, a number of matrix "sizes" (M's and N's)
+* and a number of matrix "types" are specified. For each size (M,N)
+* and each type of matrix, and for the minimal workspace as well as
+* workspace adequate to permit blocking, an M x N matrix "A" will be
+* generated and used to test the SVD routines. For each matrix, A will
+* be factored as A = U diag(S) VT and the following 12 tests computed:
+*
+* Test for DGESVD:
+*
+* (1) | A - U diag(S) VT | / ( |A| max(M,N) ulp )
+*
+* (2) | I - U'U | / ( M ulp )
+*
+* (3) | I - VT VT' | / ( N ulp )
+*
+* (4) S contains MNMIN nonnegative values in decreasing order.
+* (Return 0 if true, 1/ULP if false.)
+*
+* (5) | U - Upartial | / ( M ulp ) where Upartial is a partially
+* computed U.
+*
+* (6) | VT - VTpartial | / ( N ulp ) where VTpartial is a partially
+* computed VT.
+*
+* (7) | S - Spartial | / ( MNMIN ulp |S| ) where Spartial is the
+* vector of singular values from the partial SVD
+*
+* Test for DGESDD:
+*
+* (8) | A - U diag(S) VT | / ( |A| max(M,N) ulp )
+*
+* (9) | I - U'U | / ( M ulp )
+*
+* (10) | I - VT VT' | / ( N ulp )
+*
+* (11) S contains MNMIN nonnegative values in decreasing order.
+* (Return 0 if true, 1/ULP if false.)
+*
+* (12) | U - Upartial | / ( M ulp ) where Upartial is a partially
+* computed U.
+*
+* (13) | VT - VTpartial | / ( N ulp ) where VTpartial is a partially
+* computed VT.
+*
+* (14) | S - Spartial | / ( MNMIN ulp |S| ) where Spartial is the
+* vector of singular values from the partial SVD
+*
+* The "sizes" are specified by the arrays MM(1:NSIZES) and
+* NN(1:NSIZES); the value of each element pair (MM(j),NN(j))
+* specifies one size. The "types" are specified by a logical array
+* DOTYPE( 1:NTYPES ); if DOTYPE(j) is .TRUE., then matrix type "j"
+* will be generated.
+* Currently, the list of possible types is:
+*
+* (1) The zero matrix.
+* (2) The identity matrix.
+* (3) A matrix of the form U D V, where U and V are orthogonal and
+* D has evenly spaced entries 1, ..., ULP with random signs
+* on the diagonal.
+* (4) Same as (3), but multiplied by the underflow-threshold / ULP.
+* (5) Same as (3), but multiplied by the overflow-threshold * ULP.
+*
+* Arguments
+* ==========
+*
+* NSIZES (input) INTEGER
+* The number of matrix sizes (M,N) contained in the vectors
+* MM and NN.
+*
+* MM (input) INTEGER array, dimension (NSIZES)
+* The values of the matrix row dimension M.
+*
+* NN (input) INTEGER array, dimension (NSIZES)
+* The values of the matrix column dimension N.
+*
+* NTYPES (input) INTEGER
+* The number of elements in DOTYPE. If it is zero, DDRVBD
+* does nothing. It must be at least zero. If it is MAXTYP+1
+* and NSIZES is 1, then an additional type, MAXTYP+1 is
+* defined, which is to use whatever matrices are in A and B.
+* This is only useful if DOTYPE(1:MAXTYP) is .FALSE. and
+* DOTYPE(MAXTYP+1) is .TRUE. .
+*
+* DOTYPE (input) LOGICAL array, dimension (NTYPES)
+* If DOTYPE(j) is .TRUE., then for each size (m,n), a matrix
+* of type j will be generated. If NTYPES is smaller than the
+* maximum number of types defined (PARAMETER MAXTYP), then
+* types NTYPES+1 through MAXTYP will not be generated. If
+* NTYPES is larger than MAXTYP, DOTYPE(MAXTYP+1) through
+* DOTYPE(NTYPES) will be ignored.
+*
+* ISEED (input/output) INTEGER array, dimension (4)
+* On entry, the seed of the random number generator. The array
+* elements should be between 0 and 4095; if not they will be
+* reduced mod 4096. Also, ISEED(4) must be odd.
+* On exit, ISEED is changed and can be used in the next call to
+* DDRVBD to continue the same random number sequence.
+*
+* THRESH (input) DOUBLE PRECISION
+* The threshold value for the test ratios. A result is
+* included in the output file if RESULT >= THRESH. The test
+* ratios are scaled to be O(1), so THRESH should be a small
+* multiple of 1, e.g., 10 or 100. To have every test ratio
+* printed, use THRESH = 0.
+*
+* A (workspace) DOUBLE PRECISION array, dimension (LDA,NMAX)
+* where NMAX is the maximum value of N in NN.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,MMAX),
+* where MMAX is the maximum value of M in MM.
+*
+* U (workspace) DOUBLE PRECISION array, dimension (LDU,MMAX)
+*
+* LDU (input) INTEGER
+* The leading dimension of the array U. LDU >= max(1,MMAX).
+*
+* VT (workspace) DOUBLE PRECISION array, dimension (LDVT,NMAX)
+*
+* LDVT (input) INTEGER
+* The leading dimension of the array VT. LDVT >= max(1,NMAX).
+*
+* ASAV (workspace) DOUBLE PRECISION array, dimension (LDA,NMAX)
+*
+* USAV (workspace) DOUBLE PRECISION array, dimension (LDU,MMAX)
+*
+* VTSAV (workspace) DOUBLE PRECISION array, dimension (LDVT,NMAX)
+*
+* S (workspace) DOUBLE PRECISION array, dimension
+* (max(min(MM,NN)))
+*
+* SSAV (workspace) DOUBLE PRECISION array, dimension
+* (max(min(MM,NN)))
+*
+* E (workspace) DOUBLE PRECISION array, dimension
+* (max(min(MM,NN)))
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK)
+*
+* LWORK (input) INTEGER
+* The number of entries in WORK. This must be at least
+* max(3*MN+MX,5*MN-4)+2*MN**2 for all pairs
+* pairs (MN,MX)=( min(MM(j),NN(j), max(MM(j),NN(j)) )
+*
+* IWORK (workspace) INTEGER array, dimension at least 8*min(M,N)
+*
+* NOUT (input) INTEGER
+* The FORTRAN unit number for printing out error messages
+* (e.g., if a routine returns IINFO not equal to 0.)
+*
+* INFO (output) INTEGER
+* If 0, then everything ran OK.
+* -1: NSIZES < 0
+* -2: Some MM(j) < 0
+* -3: Some NN(j) < 0
+* -4: NTYPES < 0
+* -7: THRESH < 0
+* -10: LDA < 1 or LDA < MMAX, where MMAX is max( MM(j) ).
+* -12: LDU < 1 or LDU < MMAX.
+* -14: LDVT < 1 or LDVT < NMAX, where NMAX is max( NN(j) ).
+* -21: LWORK too small.
+* If DLATMS, or DGESVD returns an error code, the
+* absolute value of it is returned.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
+ INTEGER MAXTYP
+ PARAMETER ( MAXTYP = 5 )
+* ..
+* .. Local Scalars ..
+ LOGICAL BADMM, BADNN
+ CHARACTER JOBQ, JOBU, JOBVT
+ CHARACTER*3 PATH
+ INTEGER I, IINFO, IJQ, IJU, IJVT, IWS, IWTMP, J, JSIZE,
+ $ JTYPE, LSWORK, M, MINWRK, MMAX, MNMAX, MNMIN,
+ $ MTYPES, N, NFAIL, NMAX, NTEST
+ DOUBLE PRECISION ANORM, DIF, DIV, OVFL, ULP, ULPINV, UNFL
+* ..
+* .. Local Arrays ..
+ CHARACTER CJOB( 4 )
+ INTEGER IOLDSD( 4 )
+ DOUBLE PRECISION RESULT( 14 )
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DLAMCH
+ EXTERNAL DLAMCH
+* ..
+* .. External Subroutines ..
+ EXTERNAL ALASVM, DBDT01, DGESDD, DGESVD, DLABAD, DLACPY,
+ $ DLASET, DLATMS, DORT01, DORT03, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, DBLE, MAX, MIN
+* ..
+* .. Scalars in Common ..
+ LOGICAL LERR, OK
+ CHARACTER*6 SRNAMT
+ INTEGER INFOT, NUNIT
+* ..
+* .. Common blocks ..
+ COMMON / INFOC / INFOT, NUNIT, OK, LERR
+ COMMON / SRNAMC / SRNAMT
+* ..
+* .. Data statements ..
+ DATA CJOB / 'N', 'O', 'S', 'A' /
+* ..
+* .. Executable Statements ..
+*
+* Check for errors
+*
+ INFO = 0
+ BADMM = .FALSE.
+ BADNN = .FALSE.
+ MMAX = 1
+ NMAX = 1
+ MNMAX = 1
+ MINWRK = 1
+ DO 10 J = 1, NSIZES
+ MMAX = MAX( MMAX, MM( J ) )
+ IF( MM( J ).LT.0 )
+ $ BADMM = .TRUE.
+ NMAX = MAX( NMAX, NN( J ) )
+ IF( NN( J ).LT.0 )
+ $ BADNN = .TRUE.
+ MNMAX = MAX( MNMAX, MIN( MM( J ), NN( J ) ) )
+ MINWRK = MAX( MINWRK, MAX( 3*MIN( MM( J ),
+ $ NN( J ) )+MAX( MM( J ), NN( J ) ), 5*MIN( MM( J ),
+ $ NN( J )-4 ) )+2*MIN( MM( J ), NN( J ) )**2 )
+ 10 CONTINUE
+*
+* Check for errors
+*
+ IF( NSIZES.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( BADMM ) THEN
+ INFO = -2
+ ELSE IF( BADNN ) THEN
+ INFO = -3
+ ELSE IF( NTYPES.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( LDA.LT.MAX( 1, MMAX ) ) THEN
+ INFO = -10
+ ELSE IF( LDU.LT.MAX( 1, MMAX ) ) THEN
+ INFO = -12
+ ELSE IF( LDVT.LT.MAX( 1, NMAX ) ) THEN
+ INFO = -14
+ ELSE IF( MINWRK.GT.LWORK ) THEN
+ INFO = -21
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DDRVBD', -INFO )
+ RETURN
+ END IF
+*
+* Initialize constants
+*
+ PATH( 1: 1 ) = 'Double precision'
+ PATH( 2: 3 ) = 'BD'
+ NFAIL = 0
+ NTEST = 0
+ UNFL = DLAMCH( 'Safe minimum' )
+ OVFL = ONE / UNFL
+ CALL DLABAD( UNFL, OVFL )
+ ULP = DLAMCH( 'Precision' )
+ ULPINV = ONE / ULP
+ INFOT = 0
+*
+* Loop over sizes, types
+*
+ DO 150 JSIZE = 1, NSIZES
+ M = MM( JSIZE )
+ N = NN( JSIZE )
+ MNMIN = MIN( M, N )
+*
+ IF( NSIZES.NE.1 ) THEN
+ MTYPES = MIN( MAXTYP, NTYPES )
+ ELSE
+ MTYPES = MIN( MAXTYP+1, NTYPES )
+ END IF
+*
+ DO 140 JTYPE = 1, MTYPES
+ IF( .NOT.DOTYPE( JTYPE ) )
+ $ GO TO 140
+*
+ DO 20 J = 1, 4
+ IOLDSD( J ) = ISEED( J )
+ 20 CONTINUE
+*
+* Compute "A"
+*
+ IF( MTYPES.GT.MAXTYP )
+ $ GO TO 30
+*
+ IF( JTYPE.EQ.1 ) THEN
+*
+* Zero matrix
+*
+ CALL DLASET( 'Full', M, N, ZERO, ZERO, A, LDA )
+*
+ ELSE IF( JTYPE.EQ.2 ) THEN
+*
+* Identity matrix
+*
+ CALL DLASET( 'Full', M, N, ZERO, ONE, A, LDA )
+*
+ ELSE
+*
+* (Scaled) random matrix
+*
+ IF( JTYPE.EQ.3 )
+ $ ANORM = ONE
+ IF( JTYPE.EQ.4 )
+ $ ANORM = UNFL / ULP
+ IF( JTYPE.EQ.5 )
+ $ ANORM = OVFL*ULP
+ CALL DLATMS( M, N, 'U', ISEED, 'N', S, 4, DBLE( MNMIN ),
+ $ ANORM, M-1, N-1, 'N', A, LDA, WORK, IINFO )
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUT, FMT = 9996 )'Generator', IINFO, M, N,
+ $ JTYPE, IOLDSD
+ INFO = ABS( IINFO )
+ RETURN
+ END IF
+ END IF
+*
+ 30 CONTINUE
+ CALL DLACPY( 'F', M, N, A, LDA, ASAV, LDA )
+*
+* Do for minimal and adequate (for blocking) workspace
+*
+ DO 130 IWS = 1, 4
+*
+ DO 40 J = 1, 14
+ RESULT( J ) = -ONE
+ 40 CONTINUE
+*
+* Test DGESVD: Factorize A
+*
+ IWTMP = MAX( 3*MIN( M, N )+MAX( M, N ), 5*MIN( M, N ) )
+ LSWORK = IWTMP + ( IWS-1 )*( LWORK-IWTMP ) / 3
+ LSWORK = MIN( LSWORK, LWORK )
+ LSWORK = MAX( LSWORK, 1 )
+ IF( IWS.EQ.4 )
+ $ LSWORK = LWORK
+*
+ IF( IWS.GT.1 )
+ $ CALL DLACPY( 'F', M, N, ASAV, LDA, A, LDA )
+ SRNAMT = 'DGESVD'
+ CALL DGESVD( 'A', 'A', M, N, A, LDA, SSAV, USAV, LDU,
+ $ VTSAV, LDVT, WORK, LSWORK, IINFO )
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUT, FMT = 9995 )'GESVD', IINFO, M, N, JTYPE,
+ $ LSWORK, IOLDSD
+ INFO = ABS( IINFO )
+ RETURN
+ END IF
+*
+* Do tests 1--4
+*
+ CALL DBDT01( M, N, 0, ASAV, LDA, USAV, LDU, SSAV, E,
+ $ VTSAV, LDVT, WORK, RESULT( 1 ) )
+ IF( M.NE.0 .AND. N.NE.0 ) THEN
+ CALL DORT01( 'Columns', M, M, USAV, LDU, WORK, LWORK,
+ $ RESULT( 2 ) )
+ CALL DORT01( 'Rows', N, N, VTSAV, LDVT, WORK, LWORK,
+ $ RESULT( 3 ) )
+ END IF
+ RESULT( 4 ) = ZERO
+ DO 50 I = 1, MNMIN - 1
+ IF( SSAV( I ).LT.SSAV( I+1 ) )
+ $ RESULT( 4 ) = ULPINV
+ IF( SSAV( I ).LT.ZERO )
+ $ RESULT( 4 ) = ULPINV
+ 50 CONTINUE
+ IF( MNMIN.GE.1 ) THEN
+ IF( SSAV( MNMIN ).LT.ZERO )
+ $ RESULT( 4 ) = ULPINV
+ END IF
+*
+* Do partial SVDs, comparing to SSAV, USAV, and VTSAV
+*
+ RESULT( 5 ) = ZERO
+ RESULT( 6 ) = ZERO
+ RESULT( 7 ) = ZERO
+ DO 80 IJU = 0, 3
+ DO 70 IJVT = 0, 3
+ IF( ( IJU.EQ.3 .AND. IJVT.EQ.3 ) .OR.
+ $ ( IJU.EQ.1 .AND. IJVT.EQ.1 ) )GO TO 70
+ JOBU = CJOB( IJU+1 )
+ JOBVT = CJOB( IJVT+1 )
+ CALL DLACPY( 'F', M, N, ASAV, LDA, A, LDA )
+ SRNAMT = 'DGESVD'
+ CALL DGESVD( JOBU, JOBVT, M, N, A, LDA, S, U, LDU,
+ $ VT, LDVT, WORK, LSWORK, IINFO )
+*
+* Compare U
+*
+ DIF = ZERO
+ IF( M.GT.0 .AND. N.GT.0 ) THEN
+ IF( IJU.EQ.1 ) THEN
+ CALL DORT03( 'C', M, MNMIN, M, MNMIN, USAV,
+ $ LDU, A, LDA, WORK, LWORK, DIF,
+ $ IINFO )
+ ELSE IF( IJU.EQ.2 ) THEN
+ CALL DORT03( 'C', M, MNMIN, M, MNMIN, USAV,
+ $ LDU, U, LDU, WORK, LWORK, DIF,
+ $ IINFO )
+ ELSE IF( IJU.EQ.3 ) THEN
+ CALL DORT03( 'C', M, M, M, MNMIN, USAV, LDU,
+ $ U, LDU, WORK, LWORK, DIF,
+ $ IINFO )
+ END IF
+ END IF
+ RESULT( 5 ) = MAX( RESULT( 5 ), DIF )
+*
+* Compare VT
+*
+ DIF = ZERO
+ IF( M.GT.0 .AND. N.GT.0 ) THEN
+ IF( IJVT.EQ.1 ) THEN
+ CALL DORT03( 'R', N, MNMIN, N, MNMIN, VTSAV,
+ $ LDVT, A, LDA, WORK, LWORK, DIF,
+ $ IINFO )
+ ELSE IF( IJVT.EQ.2 ) THEN
+ CALL DORT03( 'R', N, MNMIN, N, MNMIN, VTSAV,
+ $ LDVT, VT, LDVT, WORK, LWORK,
+ $ DIF, IINFO )
+ ELSE IF( IJVT.EQ.3 ) THEN
+ CALL DORT03( 'R', N, N, N, MNMIN, VTSAV,
+ $ LDVT, VT, LDVT, WORK, LWORK,
+ $ DIF, IINFO )
+ END IF
+ END IF
+ RESULT( 6 ) = MAX( RESULT( 6 ), DIF )
+*
+* Compare S
+*
+ DIF = ZERO
+ DIV = MAX( DBLE( MNMIN )*ULP*S( 1 ), UNFL )
+ DO 60 I = 1, MNMIN - 1
+ IF( SSAV( I ).LT.SSAV( I+1 ) )
+ $ DIF = ULPINV
+ IF( SSAV( I ).LT.ZERO )
+ $ DIF = ULPINV
+ DIF = MAX( DIF, ABS( SSAV( I )-S( I ) ) / DIV )
+ 60 CONTINUE
+ RESULT( 7 ) = MAX( RESULT( 7 ), DIF )
+ 70 CONTINUE
+ 80 CONTINUE
+*
+* Test DGESDD: Factorize A
+*
+ IWTMP = 5*MNMIN*MNMIN + 9*MNMIN + MAX( M, N )
+ LSWORK = IWTMP + ( IWS-1 )*( LWORK-IWTMP ) / 3
+ LSWORK = MIN( LSWORK, LWORK )
+ LSWORK = MAX( LSWORK, 1 )
+ IF( IWS.EQ.4 )
+ $ LSWORK = LWORK
+*
+ CALL DLACPY( 'F', M, N, ASAV, LDA, A, LDA )
+ SRNAMT = 'DGESDD'
+ CALL DGESDD( 'A', M, N, A, LDA, SSAV, USAV, LDU, VTSAV,
+ $ LDVT, WORK, LSWORK, IWORK, IINFO )
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUT, FMT = 9995 )'GESDD', IINFO, M, N, JTYPE,
+ $ LSWORK, IOLDSD
+ INFO = ABS( IINFO )
+ RETURN
+ END IF
+*
+* Do tests 8--11
+*
+ CALL DBDT01( M, N, 0, ASAV, LDA, USAV, LDU, SSAV, E,
+ $ VTSAV, LDVT, WORK, RESULT( 8 ) )
+ IF( M.NE.0 .AND. N.NE.0 ) THEN
+ CALL DORT01( 'Columns', M, M, USAV, LDU, WORK, LWORK,
+ $ RESULT( 9 ) )
+ CALL DORT01( 'Rows', N, N, VTSAV, LDVT, WORK, LWORK,
+ $ RESULT( 10 ) )
+ END IF
+ RESULT( 11 ) = ZERO
+ DO 90 I = 1, MNMIN - 1
+ IF( SSAV( I ).LT.SSAV( I+1 ) )
+ $ RESULT( 11 ) = ULPINV
+ IF( SSAV( I ).LT.ZERO )
+ $ RESULT( 11 ) = ULPINV
+ 90 CONTINUE
+ IF( MNMIN.GE.1 ) THEN
+ IF( SSAV( MNMIN ).LT.ZERO )
+ $ RESULT( 11 ) = ULPINV
+ END IF
+*
+* Do partial SVDs, comparing to SSAV, USAV, and VTSAV
+*
+ RESULT( 12 ) = ZERO
+ RESULT( 13 ) = ZERO
+ RESULT( 14 ) = ZERO
+ DO 110 IJQ = 0, 2
+ JOBQ = CJOB( IJQ+1 )
+ CALL DLACPY( 'F', M, N, ASAV, LDA, A, LDA )
+ SRNAMT = 'DGESDD'
+ CALL DGESDD( JOBQ, M, N, A, LDA, S, U, LDU, VT, LDVT,
+ $ WORK, LSWORK, IWORK, IINFO )
+*
+* Compare U
+*
+ DIF = ZERO
+ IF( M.GT.0 .AND. N.GT.0 ) THEN
+ IF( IJQ.EQ.1 ) THEN
+ IF( M.GE.N ) THEN
+ CALL DORT03( 'C', M, MNMIN, M, MNMIN, USAV,
+ $ LDU, A, LDA, WORK, LWORK, DIF,
+ $ INFO )
+ ELSE
+ CALL DORT03( 'C', M, MNMIN, M, MNMIN, USAV,
+ $ LDU, U, LDU, WORK, LWORK, DIF,
+ $ INFO )
+ END IF
+ ELSE IF( IJQ.EQ.2 ) THEN
+ CALL DORT03( 'C', M, MNMIN, M, MNMIN, USAV, LDU,
+ $ U, LDU, WORK, LWORK, DIF, INFO )
+ END IF
+ END IF
+ RESULT( 12 ) = MAX( RESULT( 12 ), DIF )
+*
+* Compare VT
+*
+ DIF = ZERO
+ IF( M.GT.0 .AND. N.GT.0 ) THEN
+ IF( IJQ.EQ.1 ) THEN
+ IF( M.GE.N ) THEN
+ CALL DORT03( 'R', N, MNMIN, N, MNMIN, VTSAV,
+ $ LDVT, VT, LDVT, WORK, LWORK,
+ $ DIF, INFO )
+ ELSE
+ CALL DORT03( 'R', N, MNMIN, N, MNMIN, VTSAV,
+ $ LDVT, A, LDA, WORK, LWORK, DIF,
+ $ INFO )
+ END IF
+ ELSE IF( IJQ.EQ.2 ) THEN
+ CALL DORT03( 'R', N, MNMIN, N, MNMIN, VTSAV,
+ $ LDVT, VT, LDVT, WORK, LWORK, DIF,
+ $ INFO )
+ END IF
+ END IF
+ RESULT( 13 ) = MAX( RESULT( 13 ), DIF )
+*
+* Compare S
+*
+ DIF = ZERO
+ DIV = MAX( DBLE( MNMIN )*ULP*S( 1 ), UNFL )
+ DO 100 I = 1, MNMIN - 1
+ IF( SSAV( I ).LT.SSAV( I+1 ) )
+ $ DIF = ULPINV
+ IF( SSAV( I ).LT.ZERO )
+ $ DIF = ULPINV
+ DIF = MAX( DIF, ABS( SSAV( I )-S( I ) ) / DIV )
+ 100 CONTINUE
+ RESULT( 14 ) = MAX( RESULT( 14 ), DIF )
+ 110 CONTINUE
+*
+* End of Loop -- Check for RESULT(j) > THRESH
+*
+ DO 120 J = 1, 14
+ IF( RESULT( J ).GE.THRESH ) THEN
+ IF( NFAIL.EQ.0 ) THEN
+ WRITE( NOUT, FMT = 9999 )
+ WRITE( NOUT, FMT = 9998 )
+ END IF
+ WRITE( NOUT, FMT = 9997 )M, N, JTYPE, IWS, IOLDSD,
+ $ J, RESULT( J )
+ NFAIL = NFAIL + 1
+ END IF
+ 120 CONTINUE
+ NTEST = NTEST + 14
+*
+ 130 CONTINUE
+ 140 CONTINUE
+ 150 CONTINUE
+*
+* Summary
+*
+ CALL ALASVM( PATH, NOUT, NFAIL, NTEST, 0 )
+*
+ 9999 FORMAT( ' SVD -- Real Singular Value Decomposition Driver ',
+ $ / ' Matrix types (see DDRVBD for details):',
+ $ / / ' 1 = Zero matrix', / ' 2 = Identity matrix',
+ $ / ' 3 = Evenly spaced singular values near 1',
+ $ / ' 4 = Evenly spaced singular values near underflow',
+ $ / ' 5 = Evenly spaced singular values near overflow', / /
+ $ ' Tests performed: ( A is dense, U and V are orthogonal,',
+ $ / 19X, ' S is an array, and Upartial, VTpartial, and',
+ $ / 19X, ' Spartial are partially computed U, VT and S),', / )
+ 9998 FORMAT( ' 1 = | A - U diag(S) VT | / ( |A| max(M,N) ulp ) ',
+ $ / ' 2 = | I - U**T U | / ( M ulp ) ',
+ $ / ' 3 = | I - VT VT**T | / ( N ulp ) ',
+ $ / ' 4 = 0 if S contains min(M,N) nonnegative values in',
+ $ ' decreasing order, else 1/ulp',
+ $ / ' 5 = | U - Upartial | / ( M ulp )',
+ $ / ' 6 = | VT - VTpartial | / ( N ulp )',
+ $ / ' 7 = | S - Spartial | / ( min(M,N) ulp |S| )',
+ $ / ' 8 = | A - U diag(S) VT | / ( |A| max(M,N) ulp ) ',
+ $ / ' 9 = | I - U**T U | / ( M ulp ) ',
+ $ / '10 = | I - VT VT**T | / ( N ulp ) ',
+ $ / '11 = 0 if S contains min(M,N) nonnegative values in',
+ $ ' decreasing order, else 1/ulp',
+ $ / '12 = | U - Upartial | / ( M ulp )',
+ $ / '13 = | VT - VTpartial | / ( N ulp )',
+ $ / '14 = | S - Spartial | / ( min(M,N) ulp |S| )', / / )
+ 9997 FORMAT( ' M=', I5, ', N=', I5, ', type ', I1, ', IWS=', I1,
+ $ ', seed=', 4( I4, ',' ), ' test(', I2, ')=', G11.4 )
+ 9996 FORMAT( ' DDRVBD: ', A, ' returned INFO=', I6, '.', / 9X, 'M=',
+ $ I6, ', N=', I6, ', JTYPE=', I6, ', ISEED=(', 3( I5, ',' ),
+ $ I5, ')' )
+ 9995 FORMAT( ' DDRVBD: ', A, ' returned INFO=', I6, '.', / 9X, 'M=',
+ $ I6, ', N=', I6, ', JTYPE=', I6, ', LSWORK=', I6, / 9X,
+ $ 'ISEED=(', 3( I5, ',' ), I5, ')' )
+*
+ RETURN
+*
+* End of DDRVBD
+*
+ END
+ SUBROUTINE DDRVES( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH,
+ $ NOUNIT, A, LDA, H, HT, WR, WI, WRT, WIT, VS,
+ $ LDVS, RESULT, WORK, NWORK, IWORK, BWORK, INFO )
+*
+* -- LAPACK test routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LDA, LDVS, NOUNIT, NSIZES, NTYPES, NWORK
+ DOUBLE PRECISION THRESH
+* ..
+* .. Array Arguments ..
+ LOGICAL BWORK( * ), DOTYPE( * )
+ INTEGER ISEED( 4 ), IWORK( * ), NN( * )
+ DOUBLE PRECISION A( LDA, * ), H( LDA, * ), HT( LDA, * ),
+ $ RESULT( 13 ), VS( LDVS, * ), WI( * ), WIT( * ),
+ $ WORK( * ), WR( * ), WRT( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DDRVES checks the nonsymmetric eigenvalue (Schur form) problem
+* driver DGEES.
+*
+* When DDRVES is called, a number of matrix "sizes" ("n's") and a
+* number of matrix "types" are specified. For each size ("n")
+* and each type of matrix, one matrix will be generated and used
+* to test the nonsymmetric eigenroutines. For each matrix, 13
+* tests will be performed:
+*
+* (1) 0 if T is in Schur form, 1/ulp otherwise
+* (no sorting of eigenvalues)
+*
+* (2) | A - VS T VS' | / ( n |A| ulp )
+*
+* Here VS is the matrix of Schur eigenvectors, and T is in Schur
+* form (no sorting of eigenvalues).
+*
+* (3) | I - VS VS' | / ( n ulp ) (no sorting of eigenvalues).
+*
+* (4) 0 if WR+sqrt(-1)*WI are eigenvalues of T
+* 1/ulp otherwise
+* (no sorting of eigenvalues)
+*
+* (5) 0 if T(with VS) = T(without VS),
+* 1/ulp otherwise
+* (no sorting of eigenvalues)
+*
+* (6) 0 if eigenvalues(with VS) = eigenvalues(without VS),
+* 1/ulp otherwise
+* (no sorting of eigenvalues)
+*
+* (7) 0 if T is in Schur form, 1/ulp otherwise
+* (with sorting of eigenvalues)
+*
+* (8) | A - VS T VS' | / ( n |A| ulp )
+*
+* Here VS is the matrix of Schur eigenvectors, and T is in Schur
+* form (with sorting of eigenvalues).
+*
+* (9) | I - VS VS' | / ( n ulp ) (with sorting of eigenvalues).
+*
+* (10) 0 if WR+sqrt(-1)*WI are eigenvalues of T
+* 1/ulp otherwise
+* (with sorting of eigenvalues)
+*
+* (11) 0 if T(with VS) = T(without VS),
+* 1/ulp otherwise
+* (with sorting of eigenvalues)
+*
+* (12) 0 if eigenvalues(with VS) = eigenvalues(without VS),
+* 1/ulp otherwise
+* (with sorting of eigenvalues)
+*
+* (13) if sorting worked and SDIM is the number of
+* eigenvalues which were SELECTed
+*
+* The "sizes" are specified by an array NN(1:NSIZES); the value of
+* each element NN(j) specifies one size.
+* The "types" are specified by a logical array DOTYPE( 1:NTYPES );
+* if DOTYPE(j) is .TRUE., then matrix type "j" will be generated.
+* Currently, the list of possible types is:
+*
+* (1) The zero matrix.
+* (2) The identity matrix.
+* (3) A (transposed) Jordan block, with 1's on the diagonal.
+*
+* (4) A diagonal matrix with evenly spaced entries
+* 1, ..., ULP and random signs.
+* (ULP = (first number larger than 1) - 1 )
+* (5) A diagonal matrix with geometrically spaced entries
+* 1, ..., ULP and random signs.
+* (6) A diagonal matrix with "clustered" entries 1, ULP, ..., ULP
+* and random signs.
+*
+* (7) Same as (4), but multiplied by a constant near
+* the overflow threshold
+* (8) Same as (4), but multiplied by a constant near
+* the underflow threshold
+*
+* (9) A matrix of the form U' T U, where U is orthogonal and
+* T has evenly spaced entries 1, ..., ULP with random signs
+* on the diagonal and random O(1) entries in the upper
+* triangle.
+*
+* (10) A matrix of the form U' T U, where U is orthogonal and
+* T has geometrically spaced entries 1, ..., ULP with random
+* signs on the diagonal and random O(1) entries in the upper
+* triangle.
+*
+* (11) A matrix of the form U' T U, where U is orthogonal and
+* T has "clustered" entries 1, ULP,..., ULP with random
+* signs on the diagonal and random O(1) entries in the upper
+* triangle.
+*
+* (12) A matrix of the form U' T U, where U is orthogonal and
+* T has real or complex conjugate paired eigenvalues randomly
+* chosen from ( ULP, 1 ) and random O(1) entries in the upper
+* triangle.
+*
+* (13) A matrix of the form X' T X, where X has condition
+* SQRT( ULP ) and T has evenly spaced entries 1, ..., ULP
+* with random signs on the diagonal and random O(1) entries
+* in the upper triangle.
+*
+* (14) A matrix of the form X' T X, where X has condition
+* SQRT( ULP ) and T has geometrically spaced entries
+* 1, ..., ULP with random signs on the diagonal and random
+* O(1) entries in the upper triangle.
+*
+* (15) A matrix of the form X' T X, where X has condition
+* SQRT( ULP ) and T has "clustered" entries 1, ULP,..., ULP
+* with random signs on the diagonal and random O(1) entries
+* in the upper triangle.
+*
+* (16) A matrix of the form X' T X, where X has condition
+* SQRT( ULP ) and T has real or complex conjugate paired
+* eigenvalues randomly chosen from ( ULP, 1 ) and random
+* O(1) entries in the upper triangle.
+*
+* (17) Same as (16), but multiplied by a constant
+* near the overflow threshold
+* (18) Same as (16), but multiplied by a constant
+* near the underflow threshold
+*
+* (19) Nonsymmetric matrix with random entries chosen from (-1,1).
+* If N is at least 4, all entries in first two rows and last
+* row, and first column and last two columns are zero.
+* (20) Same as (19), but multiplied by a constant
+* near the overflow threshold
+* (21) Same as (19), but multiplied by a constant
+* near the underflow threshold
+*
+* Arguments
+* =========
+*
+* NSIZES (input) INTEGER
+* The number of sizes of matrices to use. If it is zero,
+* DDRVES does nothing. It must be at least zero.
+*
+* NN (input) INTEGER array, dimension (NSIZES)
+* An array containing the sizes to be used for the matrices.
+* Zero values will be skipped. The values must be at least
+* zero.
+*
+* NTYPES (input) INTEGER
+* The number of elements in DOTYPE. If it is zero, DDRVES
+* does nothing. It must be at least zero. If it is MAXTYP+1
+* and NSIZES is 1, then an additional type, MAXTYP+1 is
+* defined, which is to use whatever matrix is in A. This
+* is only useful if DOTYPE(1:MAXTYP) is .FALSE. and
+* DOTYPE(MAXTYP+1) is .TRUE. .
+*
+* DOTYPE (input) LOGICAL array, dimension (NTYPES)
+* If DOTYPE(j) is .TRUE., then for each size in NN a
+* matrix of that size and of type j will be generated.
+* If NTYPES is smaller than the maximum number of types
+* defined (PARAMETER MAXTYP), then types NTYPES+1 through
+* MAXTYP will not be generated. If NTYPES is larger
+* than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES)
+* will be ignored.
+*
+* ISEED (input/output) INTEGER array, dimension (4)
+* On entry ISEED specifies the seed of the random number
+* generator. The array elements should be between 0 and 4095;
+* if not they will be reduced mod 4096. Also, ISEED(4) must
+* be odd. The random number generator uses a linear
+* congruential sequence limited to small integers, and so
+* should produce machine independent random numbers. The
+* values of ISEED are changed on exit, and can be used in the
+* next call to DDRVES to continue the same random number
+* sequence.
+*
+* THRESH (input) DOUBLE PRECISION
+* A test will count as "failed" if the "error", computed as
+* described above, exceeds THRESH. Note that the error
+* is scaled to be O(1), so THRESH should be a reasonably
+* small multiple of 1, e.g., 10 or 100. In particular,
+* it should not depend on the precision (single vs. double)
+* or the size of the matrix. It must be at least zero.
+*
+* NOUNIT (input) INTEGER
+* The FORTRAN unit number for printing out error messages
+* (e.g., if a routine returns INFO not equal to 0.)
+*
+* A (workspace) DOUBLE PRECISION array, dimension (LDA, max(NN))
+* Used to hold the matrix whose eigenvalues are to be
+* computed. On exit, A contains the last matrix actually used.
+*
+* LDA (input) INTEGER
+* The leading dimension of A, and H. LDA must be at
+* least 1 and at least max(NN).
+*
+* H (workspace) DOUBLE PRECISION array, dimension (LDA, max(NN))
+* Another copy of the test matrix A, modified by DGEES.
+*
+* HT (workspace) DOUBLE PRECISION array, dimension (LDA, max(NN))
+* Yet another copy of the test matrix A, modified by DGEES.
+*
+* WR (workspace) DOUBLE PRECISION array, dimension (max(NN))
+* WI (workspace) DOUBLE PRECISION array, dimension (max(NN))
+* The real and imaginary parts of the eigenvalues of A.
+* On exit, WR + WI*i are the eigenvalues of the matrix in A.
+*
+* WRT (workspace) DOUBLE PRECISION array, dimension (max(NN))
+* WIT (workspace) DOUBLE PRECISION array, dimension (max(NN))
+* Like WR, WI, these arrays contain the eigenvalues of A,
+* but those computed when DGEES only computes a partial
+* eigendecomposition, i.e. not Schur vectors
+*
+* VS (workspace) DOUBLE PRECISION array, dimension (LDVS, max(NN))
+* VS holds the computed Schur vectors.
+*
+* LDVS (input) INTEGER
+* Leading dimension of VS. Must be at least max(1,max(NN)).
+*
+* RESULT (output) DOUBLE PRECISION array, dimension (13)
+* The values computed by the 13 tests described above.
+* The values are currently limited to 1/ulp, to avoid overflow.
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (NWORK)
+*
+* NWORK (input) INTEGER
+* The number of entries in WORK. This must be at least
+* 5*NN(j)+2*NN(j)**2 for all j.
+*
+* IWORK (workspace) INTEGER array, dimension (max(NN))
+*
+* INFO (output) INTEGER
+* If 0, then everything ran OK.
+* -1: NSIZES < 0
+* -2: Some NN(j) < 0
+* -3: NTYPES < 0
+* -6: THRESH < 0
+* -9: LDA < 1 or LDA < NMAX, where NMAX is max( NN(j) ).
+* -17: LDVS < 1 or LDVS < NMAX, where NMAX is max( NN(j) ).
+* -20: NWORK too small.
+* If DLATMR, SLATMS, SLATME or DGEES returns an error code,
+* the absolute value of it is returned.
+*
+*-----------------------------------------------------------------------
+*
+* Some Local Variables and Parameters:
+* ---- ----- --------- --- ----------
+*
+* ZERO, ONE Real 0 and 1.
+* MAXTYP The number of types defined.
+* NMAX Largest value in NN.
+* NERRS The number of tests which have exceeded THRESH
+* COND, CONDS,
+* IMODE Values to be passed to the matrix generators.
+* ANORM Norm of A; passed to matrix generators.
+*
+* OVFL, UNFL Overflow and underflow thresholds.
+* ULP, ULPINV Finest relative precision and its inverse.
+* RTULP, RTULPI Square roots of the previous 4 values.
+*
+* The following four arrays decode JTYPE:
+* KTYPE(j) The general type (1-10) for type "j".
+* KMODE(j) The MODE value to be passed to the matrix
+* generator for type "j".
+* KMAGN(j) The order of magnitude ( O(1),
+* O(overflow^(1/2) ), O(underflow^(1/2) )
+* KCONDS(j) Selectw whether CONDS is to be 1 or
+* 1/sqrt(ulp). (0 means irrelevant.)
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
+ INTEGER MAXTYP
+ PARAMETER ( MAXTYP = 21 )
+* ..
+* .. Local Scalars ..
+ LOGICAL BADNN
+ CHARACTER SORT
+ CHARACTER*3 PATH
+ INTEGER I, IINFO, IMODE, ISORT, ITYPE, IWK, J, JCOL,
+ $ JSIZE, JTYPE, KNTEIG, LWORK, MTYPES, N, NERRS,
+ $ NFAIL, NMAX, NNWORK, NTEST, NTESTF, NTESTT,
+ $ RSUB, SDIM
+ DOUBLE PRECISION ANORM, COND, CONDS, OVFL, RTULP, RTULPI, TMP,
+ $ ULP, ULPINV, UNFL
+* ..
+* .. Local Arrays ..
+ CHARACTER ADUMMA( 1 )
+ INTEGER IDUMMA( 1 ), IOLDSD( 4 ), KCONDS( MAXTYP ),
+ $ KMAGN( MAXTYP ), KMODE( MAXTYP ),
+ $ KTYPE( MAXTYP )
+ DOUBLE PRECISION RES( 2 )
+* ..
+* .. Arrays in Common ..
+ LOGICAL SELVAL( 20 )
+ DOUBLE PRECISION SELWI( 20 ), SELWR( 20 )
+* ..
+* .. Scalars in Common ..
+ INTEGER SELDIM, SELOPT
+* ..
+* .. Common blocks ..
+ COMMON / SSLCT / SELOPT, SELDIM, SELVAL, SELWR, SELWI
+* ..
+* .. External Functions ..
+ LOGICAL DSLECT
+ DOUBLE PRECISION DLAMCH
+ EXTERNAL DSLECT, DLAMCH
+* ..
+* .. External Subroutines ..
+ EXTERNAL DGEES, DHST01, DLABAD, DLACPY, DLASET, DLASUM,
+ $ DLATME, DLATMR, DLATMS, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, SIGN, SQRT
+* ..
+* .. Data statements ..
+ DATA KTYPE / 1, 2, 3, 5*4, 4*6, 6*6, 3*9 /
+ DATA KMAGN / 3*1, 1, 1, 1, 2, 3, 4*1, 1, 1, 1, 1, 2,
+ $ 3, 1, 2, 3 /
+ DATA KMODE / 3*0, 4, 3, 1, 4, 4, 4, 3, 1, 5, 4, 3,
+ $ 1, 5, 5, 5, 4, 3, 1 /
+ DATA KCONDS / 3*0, 5*0, 4*1, 6*2, 3*0 /
+* ..
+* .. Executable Statements ..
+*
+ PATH( 1: 1 ) = 'Double precision'
+ PATH( 2: 3 ) = 'ES'
+*
+* Check for errors
+*
+ NTESTT = 0
+ NTESTF = 0
+ INFO = 0
+ SELOPT = 0
+*
+* Important constants
+*
+ BADNN = .FALSE.
+ NMAX = 0
+ DO 10 J = 1, NSIZES
+ NMAX = MAX( NMAX, NN( J ) )
+ IF( NN( J ).LT.0 )
+ $ BADNN = .TRUE.
+ 10 CONTINUE
+*
+* Check for errors
+*
+ IF( NSIZES.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( BADNN ) THEN
+ INFO = -2
+ ELSE IF( NTYPES.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( THRESH.LT.ZERO ) THEN
+ INFO = -6
+ ELSE IF( NOUNIT.LE.0 ) THEN
+ INFO = -7
+ ELSE IF( LDA.LT.1 .OR. LDA.LT.NMAX ) THEN
+ INFO = -9
+ ELSE IF( LDVS.LT.1 .OR. LDVS.LT.NMAX ) THEN
+ INFO = -17
+ ELSE IF( 5*NMAX+2*NMAX**2.GT.NWORK ) THEN
+ INFO = -20
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DDRVES', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if nothing to do
+*
+ IF( NSIZES.EQ.0 .OR. NTYPES.EQ.0 )
+ $ RETURN
+*
+* More Important constants
+*
+ UNFL = DLAMCH( 'Safe minimum' )
+ OVFL = ONE / UNFL
+ CALL DLABAD( UNFL, OVFL )
+ ULP = DLAMCH( 'Precision' )
+ ULPINV = ONE / ULP
+ RTULP = SQRT( ULP )
+ RTULPI = ONE / RTULP
+*
+* Loop over sizes, types
+*
+ NERRS = 0
+*
+ DO 270 JSIZE = 1, NSIZES
+ N = NN( JSIZE )
+ MTYPES = MAXTYP
+ IF( NSIZES.EQ.1 .AND. NTYPES.EQ.MAXTYP+1 )
+ $ MTYPES = MTYPES + 1
+*
+ DO 260 JTYPE = 1, MTYPES
+ IF( .NOT.DOTYPE( JTYPE ) )
+ $ GO TO 260
+*
+* Save ISEED in case of an error.
+*
+ DO 20 J = 1, 4
+ IOLDSD( J ) = ISEED( J )
+ 20 CONTINUE
+*
+* Compute "A"
+*
+* Control parameters:
+*
+* KMAGN KCONDS KMODE KTYPE
+* =1 O(1) 1 clustered 1 zero
+* =2 large large clustered 2 identity
+* =3 small exponential Jordan
+* =4 arithmetic diagonal, (w/ eigenvalues)
+* =5 random log symmetric, w/ eigenvalues
+* =6 random general, w/ eigenvalues
+* =7 random diagonal
+* =8 random symmetric
+* =9 random general
+* =10 random triangular
+*
+ IF( MTYPES.GT.MAXTYP )
+ $ GO TO 90
+*
+ ITYPE = KTYPE( JTYPE )
+ IMODE = KMODE( JTYPE )
+*
+* Compute norm
+*
+ GO TO ( 30, 40, 50 )KMAGN( JTYPE )
+*
+ 30 CONTINUE
+ ANORM = ONE
+ GO TO 60
+*
+ 40 CONTINUE
+ ANORM = OVFL*ULP
+ GO TO 60
+*
+ 50 CONTINUE
+ ANORM = UNFL*ULPINV
+ GO TO 60
+*
+ 60 CONTINUE
+*
+ CALL DLASET( 'Full', LDA, N, ZERO, ZERO, A, LDA )
+ IINFO = 0
+ COND = ULPINV
+*
+* Special Matrices -- Identity & Jordan block
+*
+* Zero
+*
+ IF( ITYPE.EQ.1 ) THEN
+ IINFO = 0
+*
+ ELSE IF( ITYPE.EQ.2 ) THEN
+*
+* Identity
+*
+ DO 70 JCOL = 1, N
+ A( JCOL, JCOL ) = ANORM
+ 70 CONTINUE
+*
+ ELSE IF( ITYPE.EQ.3 ) THEN
+*
+* Jordan Block
+*
+ DO 80 JCOL = 1, N
+ A( JCOL, JCOL ) = ANORM
+ IF( JCOL.GT.1 )
+ $ A( JCOL, JCOL-1 ) = ONE
+ 80 CONTINUE
+*
+ ELSE IF( ITYPE.EQ.4 ) THEN
+*
+* Diagonal Matrix, [Eigen]values Specified
+*
+ CALL DLATMS( N, N, 'S', ISEED, 'S', WORK, IMODE, COND,
+ $ ANORM, 0, 0, 'N', A, LDA, WORK( N+1 ),
+ $ IINFO )
+*
+ ELSE IF( ITYPE.EQ.5 ) THEN
+*
+* Symmetric, eigenvalues specified
+*
+ CALL DLATMS( N, N, 'S', ISEED, 'S', WORK, IMODE, COND,
+ $ ANORM, N, N, 'N', A, LDA, WORK( N+1 ),
+ $ IINFO )
+*
+ ELSE IF( ITYPE.EQ.6 ) THEN
+*
+* General, eigenvalues specified
+*
+ IF( KCONDS( JTYPE ).EQ.1 ) THEN
+ CONDS = ONE
+ ELSE IF( KCONDS( JTYPE ).EQ.2 ) THEN
+ CONDS = RTULPI
+ ELSE
+ CONDS = ZERO
+ END IF
+*
+ ADUMMA( 1 ) = ' '
+ CALL DLATME( N, 'S', ISEED, WORK, IMODE, COND, ONE,
+ $ ADUMMA, 'T', 'T', 'T', WORK( N+1 ), 4,
+ $ CONDS, N, N, ANORM, A, LDA, WORK( 2*N+1 ),
+ $ IINFO )
+*
+ ELSE IF( ITYPE.EQ.7 ) THEN
+*
+* Diagonal, random eigenvalues
+*
+ CALL DLATMR( N, N, 'S', ISEED, 'S', WORK, 6, ONE, ONE,
+ $ 'T', 'N', WORK( N+1 ), 1, ONE,
+ $ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, 0, 0,
+ $ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO )
+*
+ ELSE IF( ITYPE.EQ.8 ) THEN
+*
+* Symmetric, random eigenvalues
+*
+ CALL DLATMR( N, N, 'S', ISEED, 'S', WORK, 6, ONE, ONE,
+ $ 'T', 'N', WORK( N+1 ), 1, ONE,
+ $ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, N, N,
+ $ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO )
+*
+ ELSE IF( ITYPE.EQ.9 ) THEN
+*
+* General, random eigenvalues
+*
+ CALL DLATMR( N, N, 'S', ISEED, 'N', WORK, 6, ONE, ONE,
+ $ 'T', 'N', WORK( N+1 ), 1, ONE,
+ $ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, N, N,
+ $ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO )
+ IF( N.GE.4 ) THEN
+ CALL DLASET( 'Full', 2, N, ZERO, ZERO, A, LDA )
+ CALL DLASET( 'Full', N-3, 1, ZERO, ZERO, A( 3, 1 ),
+ $ LDA )
+ CALL DLASET( 'Full', N-3, 2, ZERO, ZERO, A( 3, N-1 ),
+ $ LDA )
+ CALL DLASET( 'Full', 1, N, ZERO, ZERO, A( N, 1 ),
+ $ LDA )
+ END IF
+*
+ ELSE IF( ITYPE.EQ.10 ) THEN
+*
+* Triangular, random eigenvalues
+*
+ CALL DLATMR( N, N, 'S', ISEED, 'N', WORK, 6, ONE, ONE,
+ $ 'T', 'N', WORK( N+1 ), 1, ONE,
+ $ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, N, 0,
+ $ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO )
+*
+ ELSE
+*
+ IINFO = 1
+ END IF
+*
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUNIT, FMT = 9992 )'Generator', IINFO, N, JTYPE,
+ $ IOLDSD
+ INFO = ABS( IINFO )
+ RETURN
+ END IF
+*
+ 90 CONTINUE
+*
+* Test for minimal and generous workspace
+*
+ DO 250 IWK = 1, 2
+ IF( IWK.EQ.1 ) THEN
+ NNWORK = 3*N
+ ELSE
+ NNWORK = 5*N + 2*N**2
+ END IF
+ NNWORK = MAX( NNWORK, 1 )
+*
+* Initialize RESULT
+*
+ DO 100 J = 1, 13
+ RESULT( J ) = -ONE
+ 100 CONTINUE
+*
+* Test with and without sorting of eigenvalues
+*
+ DO 210 ISORT = 0, 1
+ IF( ISORT.EQ.0 ) THEN
+ SORT = 'N'
+ RSUB = 0
+ ELSE
+ SORT = 'S'
+ RSUB = 6
+ END IF
+*
+* Compute Schur form and Schur vectors, and test them
+*
+ CALL DLACPY( 'F', N, N, A, LDA, H, LDA )
+ CALL DGEES( 'V', SORT, DSLECT, N, H, LDA, SDIM, WR,
+ $ WI, VS, LDVS, WORK, NNWORK, BWORK, IINFO )
+ IF( IINFO.NE.0 .AND. IINFO.NE.N+2 ) THEN
+ RESULT( 1+RSUB ) = ULPINV
+ WRITE( NOUNIT, FMT = 9992 )'DGEES1', IINFO, N,
+ $ JTYPE, IOLDSD
+ INFO = ABS( IINFO )
+ GO TO 220
+ END IF
+*
+* Do Test (1) or Test (7)
+*
+ RESULT( 1+RSUB ) = ZERO
+ DO 120 J = 1, N - 2
+ DO 110 I = J + 2, N
+ IF( H( I, J ).NE.ZERO )
+ $ RESULT( 1+RSUB ) = ULPINV
+ 110 CONTINUE
+ 120 CONTINUE
+ DO 130 I = 1, N - 2
+ IF( H( I+1, I ).NE.ZERO .AND. H( I+2, I+1 ).NE.
+ $ ZERO )RESULT( 1+RSUB ) = ULPINV
+ 130 CONTINUE
+ DO 140 I = 1, N - 1
+ IF( H( I+1, I ).NE.ZERO ) THEN
+ IF( H( I, I ).NE.H( I+1, I+1 ) .OR.
+ $ H( I, I+1 ).EQ.ZERO .OR.
+ $ SIGN( ONE, H( I+1, I ) ).EQ.
+ $ SIGN( ONE, H( I, I+1 ) ) )RESULT( 1+RSUB )
+ $ = ULPINV
+ END IF
+ 140 CONTINUE
+*
+* Do Tests (2) and (3) or Tests (8) and (9)
+*
+ LWORK = MAX( 1, 2*N*N )
+ CALL DHST01( N, 1, N, A, LDA, H, LDA, VS, LDVS, WORK,
+ $ LWORK, RES )
+ RESULT( 2+RSUB ) = RES( 1 )
+ RESULT( 3+RSUB ) = RES( 2 )
+*
+* Do Test (4) or Test (10)
+*
+ RESULT( 4+RSUB ) = ZERO
+ DO 150 I = 1, N
+ IF( H( I, I ).NE.WR( I ) )
+ $ RESULT( 4+RSUB ) = ULPINV
+ 150 CONTINUE
+ IF( N.GT.1 ) THEN
+ IF( H( 2, 1 ).EQ.ZERO .AND. WI( 1 ).NE.ZERO )
+ $ RESULT( 4+RSUB ) = ULPINV
+ IF( H( N, N-1 ).EQ.ZERO .AND. WI( N ).NE.ZERO )
+ $ RESULT( 4+RSUB ) = ULPINV
+ END IF
+ DO 160 I = 1, N - 1
+ IF( H( I+1, I ).NE.ZERO ) THEN
+ TMP = SQRT( ABS( H( I+1, I ) ) )*
+ $ SQRT( ABS( H( I, I+1 ) ) )
+ RESULT( 4+RSUB ) = MAX( RESULT( 4+RSUB ),
+ $ ABS( WI( I )-TMP ) /
+ $ MAX( ULP*TMP, UNFL ) )
+ RESULT( 4+RSUB ) = MAX( RESULT( 4+RSUB ),
+ $ ABS( WI( I+1 )+TMP ) /
+ $ MAX( ULP*TMP, UNFL ) )
+ ELSE IF( I.GT.1 ) THEN
+ IF( H( I+1, I ).EQ.ZERO .AND. H( I, I-1 ).EQ.
+ $ ZERO .AND. WI( I ).NE.ZERO )RESULT( 4+RSUB )
+ $ = ULPINV
+ END IF
+ 160 CONTINUE
+*
+* Do Test (5) or Test (11)
+*
+ CALL DLACPY( 'F', N, N, A, LDA, HT, LDA )
+ CALL DGEES( 'N', SORT, DSLECT, N, HT, LDA, SDIM, WRT,
+ $ WIT, VS, LDVS, WORK, NNWORK, BWORK,
+ $ IINFO )
+ IF( IINFO.NE.0 .AND. IINFO.NE.N+2 ) THEN
+ RESULT( 5+RSUB ) = ULPINV
+ WRITE( NOUNIT, FMT = 9992 )'DGEES2', IINFO, N,
+ $ JTYPE, IOLDSD
+ INFO = ABS( IINFO )
+ GO TO 220
+ END IF
+*
+ RESULT( 5+RSUB ) = ZERO
+ DO 180 J = 1, N
+ DO 170 I = 1, N
+ IF( H( I, J ).NE.HT( I, J ) )
+ $ RESULT( 5+RSUB ) = ULPINV
+ 170 CONTINUE
+ 180 CONTINUE
+*
+* Do Test (6) or Test (12)
+*
+ RESULT( 6+RSUB ) = ZERO
+ DO 190 I = 1, N
+ IF( WR( I ).NE.WRT( I ) .OR. WI( I ).NE.WIT( I ) )
+ $ RESULT( 6+RSUB ) = ULPINV
+ 190 CONTINUE
+*
+* Do Test (13)
+*
+ IF( ISORT.EQ.1 ) THEN
+ RESULT( 13 ) = ZERO
+ KNTEIG = 0
+ DO 200 I = 1, N
+ IF( DSLECT( WR( I ), WI( I ) ) .OR.
+ $ DSLECT( WR( I ), -WI( I ) ) )
+ $ KNTEIG = KNTEIG + 1
+ IF( I.LT.N ) THEN
+ IF( ( DSLECT( WR( I+1 ),
+ $ WI( I+1 ) ) .OR. DSLECT( WR( I+1 ),
+ $ -WI( I+1 ) ) ) .AND.
+ $ ( .NOT.( DSLECT( WR( I ),
+ $ WI( I ) ) .OR. DSLECT( WR( I ),
+ $ -WI( I ) ) ) ) .AND. IINFO.NE.N+2 )
+ $ RESULT( 13 ) = ULPINV
+ END IF
+ 200 CONTINUE
+ IF( SDIM.NE.KNTEIG ) THEN
+ RESULT( 13 ) = ULPINV
+ END IF
+ END IF
+*
+ 210 CONTINUE
+*
+* End of Loop -- Check for RESULT(j) > THRESH
+*
+ 220 CONTINUE
+*
+ NTEST = 0
+ NFAIL = 0
+ DO 230 J = 1, 13
+ IF( RESULT( J ).GE.ZERO )
+ $ NTEST = NTEST + 1
+ IF( RESULT( J ).GE.THRESH )
+ $ NFAIL = NFAIL + 1
+ 230 CONTINUE
+*
+ IF( NFAIL.GT.0 )
+ $ NTESTF = NTESTF + 1
+ IF( NTESTF.EQ.1 ) THEN
+ WRITE( NOUNIT, FMT = 9999 )PATH
+ WRITE( NOUNIT, FMT = 9998 )
+ WRITE( NOUNIT, FMT = 9997 )
+ WRITE( NOUNIT, FMT = 9996 )
+ WRITE( NOUNIT, FMT = 9995 )THRESH
+ WRITE( NOUNIT, FMT = 9994 )
+ NTESTF = 2
+ END IF
+*
+ DO 240 J = 1, 13
+ IF( RESULT( J ).GE.THRESH ) THEN
+ WRITE( NOUNIT, FMT = 9993 )N, IWK, IOLDSD, JTYPE,
+ $ J, RESULT( J )
+ END IF
+ 240 CONTINUE
+*
+ NERRS = NERRS + NFAIL
+ NTESTT = NTESTT + NTEST
+*
+ 250 CONTINUE
+ 260 CONTINUE
+ 270 CONTINUE
+*
+* Summary
+*
+ CALL DLASUM( PATH, NOUNIT, NERRS, NTESTT )
+*
+ 9999 FORMAT( / 1X, A3, ' -- Real Schur Form Decomposition Driver',
+ $ / ' Matrix types (see DDRVES for details): ' )
+*
+ 9998 FORMAT( / ' Special Matrices:', / ' 1=Zero matrix. ',
+ $ ' ', ' 5=Diagonal: geometr. spaced entries.',
+ $ / ' 2=Identity matrix. ', ' 6=Diagona',
+ $ 'l: clustered entries.', / ' 3=Transposed Jordan block. ',
+ $ ' ', ' 7=Diagonal: large, evenly spaced.', / ' ',
+ $ '4=Diagonal: evenly spaced entries. ', ' 8=Diagonal: s',
+ $ 'mall, evenly spaced.' )
+ 9997 FORMAT( ' Dense, Non-Symmetric Matrices:', / ' 9=Well-cond., ev',
+ $ 'enly spaced eigenvals.', ' 14=Ill-cond., geomet. spaced e',
+ $ 'igenals.', / ' 10=Well-cond., geom. spaced eigenvals. ',
+ $ ' 15=Ill-conditioned, clustered e.vals.', / ' 11=Well-cond',
+ $ 'itioned, clustered e.vals. ', ' 16=Ill-cond., random comp',
+ $ 'lex ', / ' 12=Well-cond., random complex ', 6X, ' ',
+ $ ' 17=Ill-cond., large rand. complx ', / ' 13=Ill-condi',
+ $ 'tioned, evenly spaced. ', ' 18=Ill-cond., small rand.',
+ $ ' complx ' )
+ 9996 FORMAT( ' 19=Matrix with random O(1) entries. ', ' 21=Matrix ',
+ $ 'with small random entries.', / ' 20=Matrix with large ran',
+ $ 'dom entries. ', / )
+ 9995 FORMAT( ' Tests performed with test threshold =', F8.2,
+ $ / ' ( A denotes A on input and T denotes A on output)',
+ $ / / ' 1 = 0 if T in Schur form (no sort), ',
+ $ ' 1/ulp otherwise', /
+ $ ' 2 = | A - VS T transpose(VS) | / ( n |A| ulp ) (no sort)',
+ $ / ' 3 = | I - VS transpose(VS) | / ( n ulp ) (no sort) ', /
+ $ ' 4 = 0 if WR+sqrt(-1)*WI are eigenvalues of T (no sort),',
+ $ ' 1/ulp otherwise', /
+ $ ' 5 = 0 if T same no matter if VS computed (no sort),',
+ $ ' 1/ulp otherwise', /
+ $ ' 6 = 0 if WR, WI same no matter if VS computed (no sort)',
+ $ ', 1/ulp otherwise' )
+ 9994 FORMAT( ' 7 = 0 if T in Schur form (sort), ', ' 1/ulp otherwise',
+ $ / ' 8 = | A - VS T transpose(VS) | / ( n |A| ulp ) (sort)',
+ $ / ' 9 = | I - VS transpose(VS) | / ( n ulp ) (sort) ',
+ $ / ' 10 = 0 if WR+sqrt(-1)*WI are eigenvalues of T (sort),',
+ $ ' 1/ulp otherwise', /
+ $ ' 11 = 0 if T same no matter if VS computed (sort),',
+ $ ' 1/ulp otherwise', /
+ $ ' 12 = 0 if WR, WI same no matter if VS computed (sort),',
+ $ ' 1/ulp otherwise', /
+ $ ' 13 = 0 if sorting succesful, 1/ulp otherwise', / )
+ 9993 FORMAT( ' N=', I5, ', IWK=', I2, ', seed=', 4( I4, ',' ),
+ $ ' type ', I2, ', test(', I2, ')=', G10.3 )
+ 9992 FORMAT( ' DDRVES: ', A, ' returned INFO=', I6, '.', / 9X, 'N=',
+ $ I6, ', JTYPE=', I6, ', ISEED=(', 3( I5, ',' ), I5, ')' )
+*
+ RETURN
+*
+* End of DDRVES
+*
+ END
+ SUBROUTINE DDRVEV( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH,
+ $ NOUNIT, A, LDA, H, WR, WI, WR1, WI1, VL, LDVL,
+ $ VR, LDVR, LRE, LDLRE, RESULT, WORK, NWORK,
+ $ IWORK, INFO )
+*
+* -- LAPACK test routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LDA, LDLRE, LDVL, LDVR, NOUNIT, NSIZES,
+ $ NTYPES, NWORK
+ DOUBLE PRECISION THRESH
+* ..
+* .. Array Arguments ..
+ LOGICAL DOTYPE( * )
+ INTEGER ISEED( 4 ), IWORK( * ), NN( * )
+ DOUBLE PRECISION A( LDA, * ), H( LDA, * ), LRE( LDLRE, * ),
+ $ RESULT( 7 ), VL( LDVL, * ), VR( LDVR, * ),
+ $ WI( * ), WI1( * ), WORK( * ), WR( * ), WR1( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DDRVEV checks the nonsymmetric eigenvalue problem driver DGEEV.
+*
+* When DDRVEV is called, a number of matrix "sizes" ("n's") and a
+* number of matrix "types" are specified. For each size ("n")
+* and each type of matrix, one matrix will be generated and used
+* to test the nonsymmetric eigenroutines. For each matrix, 7
+* tests will be performed:
+*
+* (1) | A * VR - VR * W | / ( n |A| ulp )
+*
+* Here VR is the matrix of unit right eigenvectors.
+* W is a block diagonal matrix, with a 1x1 block for each
+* real eigenvalue and a 2x2 block for each complex conjugate
+* pair. If eigenvalues j and j+1 are a complex conjugate pair,
+* so WR(j) = WR(j+1) = wr and WI(j) = - WI(j+1) = wi, then the
+* 2 x 2 block corresponding to the pair will be:
+*
+* ( wr wi )
+* ( -wi wr )
+*
+* Such a block multiplying an n x 2 matrix ( ur ui ) on the
+* right will be the same as multiplying ur + i*ui by wr + i*wi.
+*
+* (2) | A**H * VL - VL * W**H | / ( n |A| ulp )
+*
+* Here VL is the matrix of unit left eigenvectors, A**H is the
+* conjugate transpose of A, and W is as above.
+*
+* (3) | |VR(i)| - 1 | / ulp and whether largest component real
+*
+* VR(i) denotes the i-th column of VR.
+*
+* (4) | |VL(i)| - 1 | / ulp and whether largest component real
+*
+* VL(i) denotes the i-th column of VL.
+*
+* (5) W(full) = W(partial)
+*
+* W(full) denotes the eigenvalues computed when both VR and VL
+* are also computed, and W(partial) denotes the eigenvalues
+* computed when only W, only W and VR, or only W and VL are
+* computed.
+*
+* (6) VR(full) = VR(partial)
+*
+* VR(full) denotes the right eigenvectors computed when both VR
+* and VL are computed, and VR(partial) denotes the result
+* when only VR is computed.
+*
+* (7) VL(full) = VL(partial)
+*
+* VL(full) denotes the left eigenvectors computed when both VR
+* and VL are also computed, and VL(partial) denotes the result
+* when only VL is computed.
+*
+* The "sizes" are specified by an array NN(1:NSIZES); the value of
+* each element NN(j) specifies one size.
+* The "types" are specified by a logical array DOTYPE( 1:NTYPES );
+* if DOTYPE(j) is .TRUE., then matrix type "j" will be generated.
+* Currently, the list of possible types is:
+*
+* (1) The zero matrix.
+* (2) The identity matrix.
+* (3) A (transposed) Jordan block, with 1's on the diagonal.
+*
+* (4) A diagonal matrix with evenly spaced entries
+* 1, ..., ULP and random signs.
+* (ULP = (first number larger than 1) - 1 )
+* (5) A diagonal matrix with geometrically spaced entries
+* 1, ..., ULP and random signs.
+* (6) A diagonal matrix with "clustered" entries 1, ULP, ..., ULP
+* and random signs.
+*
+* (7) Same as (4), but multiplied by a constant near
+* the overflow threshold
+* (8) Same as (4), but multiplied by a constant near
+* the underflow threshold
+*
+* (9) A matrix of the form U' T U, where U is orthogonal and
+* T has evenly spaced entries 1, ..., ULP with random signs
+* on the diagonal and random O(1) entries in the upper
+* triangle.
+*
+* (10) A matrix of the form U' T U, where U is orthogonal and
+* T has geometrically spaced entries 1, ..., ULP with random
+* signs on the diagonal and random O(1) entries in the upper
+* triangle.
+*
+* (11) A matrix of the form U' T U, where U is orthogonal and
+* T has "clustered" entries 1, ULP,..., ULP with random
+* signs on the diagonal and random O(1) entries in the upper
+* triangle.
+*
+* (12) A matrix of the form U' T U, where U is orthogonal and
+* T has real or complex conjugate paired eigenvalues randomly
+* chosen from ( ULP, 1 ) and random O(1) entries in the upper
+* triangle.
+*
+* (13) A matrix of the form X' T X, where X has condition
+* SQRT( ULP ) and T has evenly spaced entries 1, ..., ULP
+* with random signs on the diagonal and random O(1) entries
+* in the upper triangle.
+*
+* (14) A matrix of the form X' T X, where X has condition
+* SQRT( ULP ) and T has geometrically spaced entries
+* 1, ..., ULP with random signs on the diagonal and random
+* O(1) entries in the upper triangle.
+*
+* (15) A matrix of the form X' T X, where X has condition
+* SQRT( ULP ) and T has "clustered" entries 1, ULP,..., ULP
+* with random signs on the diagonal and random O(1) entries
+* in the upper triangle.
+*
+* (16) A matrix of the form X' T X, where X has condition
+* SQRT( ULP ) and T has real or complex conjugate paired
+* eigenvalues randomly chosen from ( ULP, 1 ) and random
+* O(1) entries in the upper triangle.
+*
+* (17) Same as (16), but multiplied by a constant
+* near the overflow threshold
+* (18) Same as (16), but multiplied by a constant
+* near the underflow threshold
+*
+* (19) Nonsymmetric matrix with random entries chosen from (-1,1).
+* If N is at least 4, all entries in first two rows and last
+* row, and first column and last two columns are zero.
+* (20) Same as (19), but multiplied by a constant
+* near the overflow threshold
+* (21) Same as (19), but multiplied by a constant
+* near the underflow threshold
+*
+* Arguments
+* ==========
+*
+* NSIZES (input) INTEGER
+* The number of sizes of matrices to use. If it is zero,
+* DDRVEV does nothing. It must be at least zero.
+*
+* NN (input) INTEGER array, dimension (NSIZES)
+* An array containing the sizes to be used for the matrices.
+* Zero values will be skipped. The values must be at least
+* zero.
+*
+* NTYPES (input) INTEGER
+* The number of elements in DOTYPE. If it is zero, DDRVEV
+* does nothing. It must be at least zero. If it is MAXTYP+1
+* and NSIZES is 1, then an additional type, MAXTYP+1 is
+* defined, which is to use whatever matrix is in A. This
+* is only useful if DOTYPE(1:MAXTYP) is .FALSE. and
+* DOTYPE(MAXTYP+1) is .TRUE. .
+*
+* DOTYPE (input) LOGICAL array, dimension (NTYPES)
+* If DOTYPE(j) is .TRUE., then for each size in NN a
+* matrix of that size and of type j will be generated.
+* If NTYPES is smaller than the maximum number of types
+* defined (PARAMETER MAXTYP), then types NTYPES+1 through
+* MAXTYP will not be generated. If NTYPES is larger
+* than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES)
+* will be ignored.
+*
+* ISEED (input/output) INTEGER array, dimension (4)
+* On entry ISEED specifies the seed of the random number
+* generator. The array elements should be between 0 and 4095;
+* if not they will be reduced mod 4096. Also, ISEED(4) must
+* be odd. The random number generator uses a linear
+* congruential sequence limited to small integers, and so
+* should produce machine independent random numbers. The
+* values of ISEED are changed on exit, and can be used in the
+* next call to DDRVEV to continue the same random number
+* sequence.
+*
+* THRESH (input) DOUBLE PRECISION
+* A test will count as "failed" if the "error", computed as
+* described above, exceeds THRESH. Note that the error
+* is scaled to be O(1), so THRESH should be a reasonably
+* small multiple of 1, e.g., 10 or 100. In particular,
+* it should not depend on the precision (single vs. double)
+* or the size of the matrix. It must be at least zero.
+*
+* NOUNIT (input) INTEGER
+* The FORTRAN unit number for printing out error messages
+* (e.g., if a routine returns INFO not equal to 0.)
+*
+* A (workspace) DOUBLE PRECISION array, dimension (LDA, max(NN))
+* Used to hold the matrix whose eigenvalues are to be
+* computed. On exit, A contains the last matrix actually used.
+*
+* LDA (input) INTEGER
+* The leading dimension of A, and H. LDA must be at
+* least 1 and at least max(NN).
+*
+* H (workspace) DOUBLE PRECISION array, dimension (LDA, max(NN))
+* Another copy of the test matrix A, modified by DGEEV.
+*
+* WR (workspace) DOUBLE PRECISION array, dimension (max(NN))
+* WI (workspace) DOUBLE PRECISION array, dimension (max(NN))
+* The real and imaginary parts of the eigenvalues of A.
+* On exit, WR + WI*i are the eigenvalues of the matrix in A.
+*
+* WR1 (workspace) DOUBLE PRECISION array, dimension (max(NN))
+* WI1 (workspace) DOUBLE PRECISION array, dimension (max(NN))
+* Like WR, WI, these arrays contain the eigenvalues of A,
+* but those computed when DGEEV only computes a partial
+* eigendecomposition, i.e. not the eigenvalues and left
+* and right eigenvectors.
+*
+* VL (workspace) DOUBLE PRECISION array, dimension (LDVL, max(NN))
+* VL holds the computed left eigenvectors.
+*
+* LDVL (input) INTEGER
+* Leading dimension of VL. Must be at least max(1,max(NN)).
+*
+* VR (workspace) DOUBLE PRECISION array, dimension (LDVR, max(NN))
+* VR holds the computed right eigenvectors.
+*
+* LDVR (input) INTEGER
+* Leading dimension of VR. Must be at least max(1,max(NN)).
+*
+* LRE (workspace) DOUBLE PRECISION array, dimension (LDLRE,max(NN))
+* LRE holds the computed right or left eigenvectors.
+*
+* LDLRE (input) INTEGER
+* Leading dimension of LRE. Must be at least max(1,max(NN)).
+*
+* RESULT (output) DOUBLE PRECISION array, dimension (7)
+* The values computed by the seven tests described above.
+* The values are currently limited to 1/ulp, to avoid overflow.
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (NWORK)
+*
+* NWORK (input) INTEGER
+* The number of entries in WORK. This must be at least
+* 5*NN(j)+2*NN(j)**2 for all j.
+*
+* IWORK (workspace) INTEGER array, dimension (max(NN))
+*
+* INFO (output) INTEGER
+* If 0, then everything ran OK.
+* -1: NSIZES < 0
+* -2: Some NN(j) < 0
+* -3: NTYPES < 0
+* -6: THRESH < 0
+* -9: LDA < 1 or LDA < NMAX, where NMAX is max( NN(j) ).
+* -16: LDVL < 1 or LDVL < NMAX, where NMAX is max( NN(j) ).
+* -18: LDVR < 1 or LDVR < NMAX, where NMAX is max( NN(j) ).
+* -20: LDLRE < 1 or LDLRE < NMAX, where NMAX is max( NN(j) ).
+* -23: NWORK too small.
+* If DLATMR, SLATMS, SLATME or DGEEV returns an error code,
+* the absolute value of it is returned.
+*
+*-----------------------------------------------------------------------
+*
+* Some Local Variables and Parameters:
+* ---- ----- --------- --- ----------
+*
+* ZERO, ONE Real 0 and 1.
+* MAXTYP The number of types defined.
+* NMAX Largest value in NN.
+* NERRS The number of tests which have exceeded THRESH
+* COND, CONDS,
+* IMODE Values to be passed to the matrix generators.
+* ANORM Norm of A; passed to matrix generators.
+*
+* OVFL, UNFL Overflow and underflow thresholds.
+* ULP, ULPINV Finest relative precision and its inverse.
+* RTULP, RTULPI Square roots of the previous 4 values.
+*
+* The following four arrays decode JTYPE:
+* KTYPE(j) The general type (1-10) for type "j".
+* KMODE(j) The MODE value to be passed to the matrix
+* generator for type "j".
+* KMAGN(j) The order of magnitude ( O(1),
+* O(overflow^(1/2) ), O(underflow^(1/2) )
+* KCONDS(j) Selectw whether CONDS is to be 1 or
+* 1/sqrt(ulp). (0 means irrelevant.)
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
+ DOUBLE PRECISION TWO
+ PARAMETER ( TWO = 2.0D0 )
+ INTEGER MAXTYP
+ PARAMETER ( MAXTYP = 21 )
+* ..
+* .. Local Scalars ..
+ LOGICAL BADNN
+ CHARACTER*3 PATH
+ INTEGER IINFO, IMODE, ITYPE, IWK, J, JCOL, JJ, JSIZE,
+ $ JTYPE, MTYPES, N, NERRS, NFAIL, NMAX, NNWORK,
+ $ NTEST, NTESTF, NTESTT
+ DOUBLE PRECISION ANORM, COND, CONDS, OVFL, RTULP, RTULPI, TNRM,
+ $ ULP, ULPINV, UNFL, VMX, VRMX, VTST
+* ..
+* .. Local Arrays ..
+ CHARACTER ADUMMA( 1 )
+ INTEGER IDUMMA( 1 ), IOLDSD( 4 ), KCONDS( MAXTYP ),
+ $ KMAGN( MAXTYP ), KMODE( MAXTYP ),
+ $ KTYPE( MAXTYP )
+ DOUBLE PRECISION DUM( 1 ), RES( 2 )
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DLAMCH, DLAPY2, DNRM2
+ EXTERNAL DLAMCH, DLAPY2, DNRM2
+* ..
+* .. External Subroutines ..
+ EXTERNAL DGEEV, DGET22, DLABAD, DLACPY, DLASET, DLASUM,
+ $ DLATME, DLATMR, DLATMS, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, MIN, SQRT
+* ..
+* .. Data statements ..
+ DATA KTYPE / 1, 2, 3, 5*4, 4*6, 6*6, 3*9 /
+ DATA KMAGN / 3*1, 1, 1, 1, 2, 3, 4*1, 1, 1, 1, 1, 2,
+ $ 3, 1, 2, 3 /
+ DATA KMODE / 3*0, 4, 3, 1, 4, 4, 4, 3, 1, 5, 4, 3,
+ $ 1, 5, 5, 5, 4, 3, 1 /
+ DATA KCONDS / 3*0, 5*0, 4*1, 6*2, 3*0 /
+* ..
+* .. Executable Statements ..
+*
+ PATH( 1: 1 ) = 'Double precision'
+ PATH( 2: 3 ) = 'EV'
+*
+* Check for errors
+*
+ NTESTT = 0
+ NTESTF = 0
+ INFO = 0
+*
+* Important constants
+*
+ BADNN = .FALSE.
+ NMAX = 0
+ DO 10 J = 1, NSIZES
+ NMAX = MAX( NMAX, NN( J ) )
+ IF( NN( J ).LT.0 )
+ $ BADNN = .TRUE.
+ 10 CONTINUE
+*
+* Check for errors
+*
+ IF( NSIZES.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( BADNN ) THEN
+ INFO = -2
+ ELSE IF( NTYPES.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( THRESH.LT.ZERO ) THEN
+ INFO = -6
+ ELSE IF( NOUNIT.LE.0 ) THEN
+ INFO = -7
+ ELSE IF( LDA.LT.1 .OR. LDA.LT.NMAX ) THEN
+ INFO = -9
+ ELSE IF( LDVL.LT.1 .OR. LDVL.LT.NMAX ) THEN
+ INFO = -16
+ ELSE IF( LDVR.LT.1 .OR. LDVR.LT.NMAX ) THEN
+ INFO = -18
+ ELSE IF( LDLRE.LT.1 .OR. LDLRE.LT.NMAX ) THEN
+ INFO = -20
+ ELSE IF( 5*NMAX+2*NMAX**2.GT.NWORK ) THEN
+ INFO = -23
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DDRVEV', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if nothing to do
+*
+ IF( NSIZES.EQ.0 .OR. NTYPES.EQ.0 )
+ $ RETURN
+*
+* More Important constants
+*
+ UNFL = DLAMCH( 'Safe minimum' )
+ OVFL = ONE / UNFL
+ CALL DLABAD( UNFL, OVFL )
+ ULP = DLAMCH( 'Precision' )
+ ULPINV = ONE / ULP
+ RTULP = SQRT( ULP )
+ RTULPI = ONE / RTULP
+*
+* Loop over sizes, types
+*
+ NERRS = 0
+*
+ DO 270 JSIZE = 1, NSIZES
+ N = NN( JSIZE )
+ IF( NSIZES.NE.1 ) THEN
+ MTYPES = MIN( MAXTYP, NTYPES )
+ ELSE
+ MTYPES = MIN( MAXTYP+1, NTYPES )
+ END IF
+*
+ DO 260 JTYPE = 1, MTYPES
+ IF( .NOT.DOTYPE( JTYPE ) )
+ $ GO TO 260
+*
+* Save ISEED in case of an error.
+*
+ DO 20 J = 1, 4
+ IOLDSD( J ) = ISEED( J )
+ 20 CONTINUE
+*
+* Compute "A"
+*
+* Control parameters:
+*
+* KMAGN KCONDS KMODE KTYPE
+* =1 O(1) 1 clustered 1 zero
+* =2 large large clustered 2 identity
+* =3 small exponential Jordan
+* =4 arithmetic diagonal, (w/ eigenvalues)
+* =5 random log symmetric, w/ eigenvalues
+* =6 random general, w/ eigenvalues
+* =7 random diagonal
+* =8 random symmetric
+* =9 random general
+* =10 random triangular
+*
+ IF( MTYPES.GT.MAXTYP )
+ $ GO TO 90
+*
+ ITYPE = KTYPE( JTYPE )
+ IMODE = KMODE( JTYPE )
+*
+* Compute norm
+*
+ GO TO ( 30, 40, 50 )KMAGN( JTYPE )
+*
+ 30 CONTINUE
+ ANORM = ONE
+ GO TO 60
+*
+ 40 CONTINUE
+ ANORM = OVFL*ULP
+ GO TO 60
+*
+ 50 CONTINUE
+ ANORM = UNFL*ULPINV
+ GO TO 60
+*
+ 60 CONTINUE
+*
+ CALL DLASET( 'Full', LDA, N, ZERO, ZERO, A, LDA )
+ IINFO = 0
+ COND = ULPINV
+*
+* Special Matrices -- Identity & Jordan block
+*
+* Zero
+*
+ IF( ITYPE.EQ.1 ) THEN
+ IINFO = 0
+*
+ ELSE IF( ITYPE.EQ.2 ) THEN
+*
+* Identity
+*
+ DO 70 JCOL = 1, N
+ A( JCOL, JCOL ) = ANORM
+ 70 CONTINUE
+*
+ ELSE IF( ITYPE.EQ.3 ) THEN
+*
+* Jordan Block
+*
+ DO 80 JCOL = 1, N
+ A( JCOL, JCOL ) = ANORM
+ IF( JCOL.GT.1 )
+ $ A( JCOL, JCOL-1 ) = ONE
+ 80 CONTINUE
+*
+ ELSE IF( ITYPE.EQ.4 ) THEN
+*
+* Diagonal Matrix, [Eigen]values Specified
+*
+ CALL DLATMS( N, N, 'S', ISEED, 'S', WORK, IMODE, COND,
+ $ ANORM, 0, 0, 'N', A, LDA, WORK( N+1 ),
+ $ IINFO )
+*
+ ELSE IF( ITYPE.EQ.5 ) THEN
+*
+* Symmetric, eigenvalues specified
+*
+ CALL DLATMS( N, N, 'S', ISEED, 'S', WORK, IMODE, COND,
+ $ ANORM, N, N, 'N', A, LDA, WORK( N+1 ),
+ $ IINFO )
+*
+ ELSE IF( ITYPE.EQ.6 ) THEN
+*
+* General, eigenvalues specified
+*
+ IF( KCONDS( JTYPE ).EQ.1 ) THEN
+ CONDS = ONE
+ ELSE IF( KCONDS( JTYPE ).EQ.2 ) THEN
+ CONDS = RTULPI
+ ELSE
+ CONDS = ZERO
+ END IF
+*
+ ADUMMA( 1 ) = ' '
+ CALL DLATME( N, 'S', ISEED, WORK, IMODE, COND, ONE,
+ $ ADUMMA, 'T', 'T', 'T', WORK( N+1 ), 4,
+ $ CONDS, N, N, ANORM, A, LDA, WORK( 2*N+1 ),
+ $ IINFO )
+*
+ ELSE IF( ITYPE.EQ.7 ) THEN
+*
+* Diagonal, random eigenvalues
+*
+ CALL DLATMR( N, N, 'S', ISEED, 'S', WORK, 6, ONE, ONE,
+ $ 'T', 'N', WORK( N+1 ), 1, ONE,
+ $ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, 0, 0,
+ $ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO )
+*
+ ELSE IF( ITYPE.EQ.8 ) THEN
+*
+* Symmetric, random eigenvalues
+*
+ CALL DLATMR( N, N, 'S', ISEED, 'S', WORK, 6, ONE, ONE,
+ $ 'T', 'N', WORK( N+1 ), 1, ONE,
+ $ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, N, N,
+ $ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO )
+*
+ ELSE IF( ITYPE.EQ.9 ) THEN
+*
+* General, random eigenvalues
+*
+ CALL DLATMR( N, N, 'S', ISEED, 'N', WORK, 6, ONE, ONE,
+ $ 'T', 'N', WORK( N+1 ), 1, ONE,
+ $ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, N, N,
+ $ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO )
+ IF( N.GE.4 ) THEN
+ CALL DLASET( 'Full', 2, N, ZERO, ZERO, A, LDA )
+ CALL DLASET( 'Full', N-3, 1, ZERO, ZERO, A( 3, 1 ),
+ $ LDA )
+ CALL DLASET( 'Full', N-3, 2, ZERO, ZERO, A( 3, N-1 ),
+ $ LDA )
+ CALL DLASET( 'Full', 1, N, ZERO, ZERO, A( N, 1 ),
+ $ LDA )
+ END IF
+*
+ ELSE IF( ITYPE.EQ.10 ) THEN
+*
+* Triangular, random eigenvalues
+*
+ CALL DLATMR( N, N, 'S', ISEED, 'N', WORK, 6, ONE, ONE,
+ $ 'T', 'N', WORK( N+1 ), 1, ONE,
+ $ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, N, 0,
+ $ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO )
+*
+ ELSE
+*
+ IINFO = 1
+ END IF
+*
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUNIT, FMT = 9993 )'Generator', IINFO, N, JTYPE,
+ $ IOLDSD
+ INFO = ABS( IINFO )
+ RETURN
+ END IF
+*
+ 90 CONTINUE
+*
+* Test for minimal and generous workspace
+*
+ DO 250 IWK = 1, 2
+ IF( IWK.EQ.1 ) THEN
+ NNWORK = 4*N
+ ELSE
+ NNWORK = 5*N + 2*N**2
+ END IF
+ NNWORK = MAX( NNWORK, 1 )
+*
+* Initialize RESULT
+*
+ DO 100 J = 1, 7
+ RESULT( J ) = -ONE
+ 100 CONTINUE
+*
+* Compute eigenvalues and eigenvectors, and test them
+*
+ CALL DLACPY( 'F', N, N, A, LDA, H, LDA )
+ CALL DGEEV( 'V', 'V', N, H, LDA, WR, WI, VL, LDVL, VR,
+ $ LDVR, WORK, NNWORK, IINFO )
+ IF( IINFO.NE.0 ) THEN
+ RESULT( 1 ) = ULPINV
+ WRITE( NOUNIT, FMT = 9993 )'DGEEV1', IINFO, N, JTYPE,
+ $ IOLDSD
+ INFO = ABS( IINFO )
+ GO TO 220
+ END IF
+*
+* Do Test (1)
+*
+ CALL DGET22( 'N', 'N', 'N', N, A, LDA, VR, LDVR, WR, WI,
+ $ WORK, RES )
+ RESULT( 1 ) = RES( 1 )
+*
+* Do Test (2)
+*
+ CALL DGET22( 'T', 'N', 'T', N, A, LDA, VL, LDVL, WR, WI,
+ $ WORK, RES )
+ RESULT( 2 ) = RES( 1 )
+*
+* Do Test (3)
+*
+ DO 120 J = 1, N
+ TNRM = ONE
+ IF( WI( J ).EQ.ZERO ) THEN
+ TNRM = DNRM2( N, VR( 1, J ), 1 )
+ ELSE IF( WI( J ).GT.ZERO ) THEN
+ TNRM = DLAPY2( DNRM2( N, VR( 1, J ), 1 ),
+ $ DNRM2( N, VR( 1, J+1 ), 1 ) )
+ END IF
+ RESULT( 3 ) = MAX( RESULT( 3 ),
+ $ MIN( ULPINV, ABS( TNRM-ONE ) / ULP ) )
+ IF( WI( J ).GT.ZERO ) THEN
+ VMX = ZERO
+ VRMX = ZERO
+ DO 110 JJ = 1, N
+ VTST = DLAPY2( VR( JJ, J ), VR( JJ, J+1 ) )
+ IF( VTST.GT.VMX )
+ $ VMX = VTST
+ IF( VR( JJ, J+1 ).EQ.ZERO .AND.
+ $ ABS( VR( JJ, J ) ).GT.VRMX )
+ $ VRMX = ABS( VR( JJ, J ) )
+ 110 CONTINUE
+ IF( VRMX / VMX.LT.ONE-TWO*ULP )
+ $ RESULT( 3 ) = ULPINV
+ END IF
+ 120 CONTINUE
+*
+* Do Test (4)
+*
+ DO 140 J = 1, N
+ TNRM = ONE
+ IF( WI( J ).EQ.ZERO ) THEN
+ TNRM = DNRM2( N, VL( 1, J ), 1 )
+ ELSE IF( WI( J ).GT.ZERO ) THEN
+ TNRM = DLAPY2( DNRM2( N, VL( 1, J ), 1 ),
+ $ DNRM2( N, VL( 1, J+1 ), 1 ) )
+ END IF
+ RESULT( 4 ) = MAX( RESULT( 4 ),
+ $ MIN( ULPINV, ABS( TNRM-ONE ) / ULP ) )
+ IF( WI( J ).GT.ZERO ) THEN
+ VMX = ZERO
+ VRMX = ZERO
+ DO 130 JJ = 1, N
+ VTST = DLAPY2( VL( JJ, J ), VL( JJ, J+1 ) )
+ IF( VTST.GT.VMX )
+ $ VMX = VTST
+ IF( VL( JJ, J+1 ).EQ.ZERO .AND.
+ $ ABS( VL( JJ, J ) ).GT.VRMX )
+ $ VRMX = ABS( VL( JJ, J ) )
+ 130 CONTINUE
+ IF( VRMX / VMX.LT.ONE-TWO*ULP )
+ $ RESULT( 4 ) = ULPINV
+ END IF
+ 140 CONTINUE
+*
+* Compute eigenvalues only, and test them
+*
+ CALL DLACPY( 'F', N, N, A, LDA, H, LDA )
+ CALL DGEEV( 'N', 'N', N, H, LDA, WR1, WI1, DUM, 1, DUM,
+ $ 1, WORK, NNWORK, IINFO )
+ IF( IINFO.NE.0 ) THEN
+ RESULT( 1 ) = ULPINV
+ WRITE( NOUNIT, FMT = 9993 )'DGEEV2', IINFO, N, JTYPE,
+ $ IOLDSD
+ INFO = ABS( IINFO )
+ GO TO 220
+ END IF
+*
+* Do Test (5)
+*
+ DO 150 J = 1, N
+ IF( WR( J ).NE.WR1( J ) .OR. WI( J ).NE.WI1( J ) )
+ $ RESULT( 5 ) = ULPINV
+ 150 CONTINUE
+*
+* Compute eigenvalues and right eigenvectors, and test them
+*
+ CALL DLACPY( 'F', N, N, A, LDA, H, LDA )
+ CALL DGEEV( 'N', 'V', N, H, LDA, WR1, WI1, DUM, 1, LRE,
+ $ LDLRE, WORK, NNWORK, IINFO )
+ IF( IINFO.NE.0 ) THEN
+ RESULT( 1 ) = ULPINV
+ WRITE( NOUNIT, FMT = 9993 )'DGEEV3', IINFO, N, JTYPE,
+ $ IOLDSD
+ INFO = ABS( IINFO )
+ GO TO 220
+ END IF
+*
+* Do Test (5) again
+*
+ DO 160 J = 1, N
+ IF( WR( J ).NE.WR1( J ) .OR. WI( J ).NE.WI1( J ) )
+ $ RESULT( 5 ) = ULPINV
+ 160 CONTINUE
+*
+* Do Test (6)
+*
+ DO 180 J = 1, N
+ DO 170 JJ = 1, N
+ IF( VR( J, JJ ).NE.LRE( J, JJ ) )
+ $ RESULT( 6 ) = ULPINV
+ 170 CONTINUE
+ 180 CONTINUE
+*
+* Compute eigenvalues and left eigenvectors, and test them
+*
+ CALL DLACPY( 'F', N, N, A, LDA, H, LDA )
+ CALL DGEEV( 'V', 'N', N, H, LDA, WR1, WI1, LRE, LDLRE,
+ $ DUM, 1, WORK, NNWORK, IINFO )
+ IF( IINFO.NE.0 ) THEN
+ RESULT( 1 ) = ULPINV
+ WRITE( NOUNIT, FMT = 9993 )'DGEEV4', IINFO, N, JTYPE,
+ $ IOLDSD
+ INFO = ABS( IINFO )
+ GO TO 220
+ END IF
+*
+* Do Test (5) again
+*
+ DO 190 J = 1, N
+ IF( WR( J ).NE.WR1( J ) .OR. WI( J ).NE.WI1( J ) )
+ $ RESULT( 5 ) = ULPINV
+ 190 CONTINUE
+*
+* Do Test (7)
+*
+ DO 210 J = 1, N
+ DO 200 JJ = 1, N
+ IF( VL( J, JJ ).NE.LRE( J, JJ ) )
+ $ RESULT( 7 ) = ULPINV
+ 200 CONTINUE
+ 210 CONTINUE
+*
+* End of Loop -- Check for RESULT(j) > THRESH
+*
+ 220 CONTINUE
+*
+ NTEST = 0
+ NFAIL = 0
+ DO 230 J = 1, 7
+ IF( RESULT( J ).GE.ZERO )
+ $ NTEST = NTEST + 1
+ IF( RESULT( J ).GE.THRESH )
+ $ NFAIL = NFAIL + 1
+ 230 CONTINUE
+*
+ IF( NFAIL.GT.0 )
+ $ NTESTF = NTESTF + 1
+ IF( NTESTF.EQ.1 ) THEN
+ WRITE( NOUNIT, FMT = 9999 )PATH
+ WRITE( NOUNIT, FMT = 9998 )
+ WRITE( NOUNIT, FMT = 9997 )
+ WRITE( NOUNIT, FMT = 9996 )
+ WRITE( NOUNIT, FMT = 9995 )THRESH
+ NTESTF = 2
+ END IF
+*
+ DO 240 J = 1, 7
+ IF( RESULT( J ).GE.THRESH ) THEN
+ WRITE( NOUNIT, FMT = 9994 )N, IWK, IOLDSD, JTYPE,
+ $ J, RESULT( J )
+ END IF
+ 240 CONTINUE
+*
+ NERRS = NERRS + NFAIL
+ NTESTT = NTESTT + NTEST
+*
+ 250 CONTINUE
+ 260 CONTINUE
+ 270 CONTINUE
+*
+* Summary
+*
+ CALL DLASUM( PATH, NOUNIT, NERRS, NTESTT )
+*
+ 9999 FORMAT( / 1X, A3, ' -- Real Eigenvalue-Eigenvector Decomposition',
+ $ ' Driver', / ' Matrix types (see DDRVEV for details): ' )
+*
+ 9998 FORMAT( / ' Special Matrices:', / ' 1=Zero matrix. ',
+ $ ' ', ' 5=Diagonal: geometr. spaced entries.',
+ $ / ' 2=Identity matrix. ', ' 6=Diagona',
+ $ 'l: clustered entries.', / ' 3=Transposed Jordan block. ',
+ $ ' ', ' 7=Diagonal: large, evenly spaced.', / ' ',
+ $ '4=Diagonal: evenly spaced entries. ', ' 8=Diagonal: s',
+ $ 'mall, evenly spaced.' )
+ 9997 FORMAT( ' Dense, Non-Symmetric Matrices:', / ' 9=Well-cond., ev',
+ $ 'enly spaced eigenvals.', ' 14=Ill-cond., geomet. spaced e',
+ $ 'igenals.', / ' 10=Well-cond., geom. spaced eigenvals. ',
+ $ ' 15=Ill-conditioned, clustered e.vals.', / ' 11=Well-cond',
+ $ 'itioned, clustered e.vals. ', ' 16=Ill-cond., random comp',
+ $ 'lex ', / ' 12=Well-cond., random complex ', 6X, ' ',
+ $ ' 17=Ill-cond., large rand. complx ', / ' 13=Ill-condi',
+ $ 'tioned, evenly spaced. ', ' 18=Ill-cond., small rand.',
+ $ ' complx ' )
+ 9996 FORMAT( ' 19=Matrix with random O(1) entries. ', ' 21=Matrix ',
+ $ 'with small random entries.', / ' 20=Matrix with large ran',
+ $ 'dom entries. ', / )
+ 9995 FORMAT( ' Tests performed with test threshold =', F8.2,
+ $ / / ' 1 = | A VR - VR W | / ( n |A| ulp ) ',
+ $ / ' 2 = | transpose(A) VL - VL W | / ( n |A| ulp ) ',
+ $ / ' 3 = | |VR(i)| - 1 | / ulp ',
+ $ / ' 4 = | |VL(i)| - 1 | / ulp ',
+ $ / ' 5 = 0 if W same no matter if VR or VL computed,',
+ $ ' 1/ulp otherwise', /
+ $ ' 6 = 0 if VR same no matter if VL computed,',
+ $ ' 1/ulp otherwise', /
+ $ ' 7 = 0 if VL same no matter if VR computed,',
+ $ ' 1/ulp otherwise', / )
+ 9994 FORMAT( ' N=', I5, ', IWK=', I2, ', seed=', 4( I4, ',' ),
+ $ ' type ', I2, ', test(', I2, ')=', G10.3 )
+ 9993 FORMAT( ' DDRVEV: ', A, ' returned INFO=', I6, '.', / 9X, 'N=',
+ $ I6, ', JTYPE=', I6, ', ISEED=(', 3( I5, ',' ), I5, ')' )
+*
+ RETURN
+*
+* End of DDRVEV
+*
+ END
+ SUBROUTINE DDRVGG( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH,
+ $ THRSHN, NOUNIT, A, LDA, B, S, T, S2, T2, Q,
+ $ LDQ, Z, ALPHR1, ALPHI1, BETA1, ALPHR2, ALPHI2,
+ $ BETA2, VL, VR, WORK, LWORK, RESULT, INFO )
+*
+* -- LAPACK test routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LDA, LDQ, LWORK, NOUNIT, NSIZES, NTYPES
+ DOUBLE PRECISION THRESH, THRSHN
+* ..
+* .. Array Arguments ..
+ LOGICAL DOTYPE( * )
+ INTEGER ISEED( 4 ), NN( * )
+ DOUBLE PRECISION A( LDA, * ), ALPHI1( * ), ALPHI2( * ),
+ $ ALPHR1( * ), ALPHR2( * ), B( LDA, * ),
+ $ BETA1( * ), BETA2( * ), Q( LDQ, * ),
+ $ RESULT( * ), S( LDA, * ), S2( LDA, * ),
+ $ T( LDA, * ), T2( LDA, * ), VL( LDQ, * ),
+ $ VR( LDQ, * ), WORK( * ), Z( LDQ, * )
+* ..
+*
+* Purpose
+* =======
+*
+* DDRVGG checks the nonsymmetric generalized eigenvalue driver
+* routines.
+* T T T
+* DGEGS factors A and B as Q S Z and Q T Z , where means
+* transpose, T is upper triangular, S is in generalized Schur form
+* (block upper triangular, with 1x1 and 2x2 blocks on the diagonal,
+* the 2x2 blocks corresponding to complex conjugate pairs of
+* generalized eigenvalues), and Q and Z are orthogonal. It also
+* computes the generalized eigenvalues (alpha(1),beta(1)), ...,
+* (alpha(n),beta(n)), where alpha(j)=S(j,j) and beta(j)=P(j,j) --
+* thus, w(j) = alpha(j)/beta(j) is a root of the generalized
+* eigenvalue problem
+*
+* det( A - w(j) B ) = 0
+*
+* and m(j) = beta(j)/alpha(j) is a root of the essentially equivalent
+* problem
+*
+* det( m(j) A - B ) = 0
+*
+* DGEGV computes the generalized eigenvalues (alpha(1),beta(1)), ...,
+* (alpha(n),beta(n)), the matrix L whose columns contain the
+* generalized left eigenvectors l, and the matrix R whose columns
+* contain the generalized right eigenvectors r for the pair (A,B).
+*
+* When DDRVGG is called, a number of matrix "sizes" ("n's") and a
+* number of matrix "types" are specified. For each size ("n")
+* and each type of matrix, one matrix will be generated and used
+* to test the nonsymmetric eigenroutines. For each matrix, 7
+* tests will be performed and compared with the threshhold THRESH:
+*
+* Results from DGEGS:
+*
+* T
+* (1) | A - Q S Z | / ( |A| n ulp )
+*
+* T
+* (2) | B - Q T Z | / ( |B| n ulp )
+*
+* T
+* (3) | I - QQ | / ( n ulp )
+*
+* T
+* (4) | I - ZZ | / ( n ulp )
+*
+* (5) maximum over j of D(j) where:
+*
+* if alpha(j) is real:
+* |alpha(j) - S(j,j)| |beta(j) - T(j,j)|
+* D(j) = ------------------------ + -----------------------
+* max(|alpha(j)|,|S(j,j)|) max(|beta(j)|,|T(j,j)|)
+*
+* if alpha(j) is complex:
+* | det( s S - w T ) |
+* D(j) = ---------------------------------------------------
+* ulp max( s norm(S), |w| norm(T) )*norm( s S - w T )
+*
+* and S and T are here the 2 x 2 diagonal blocks of S and T
+* corresponding to the j-th eigenvalue.
+*
+* Results from DGEGV:
+*
+* (6) max over all left eigenvalue/-vector pairs (beta/alpha,l) of
+*
+* | l**H * (beta A - alpha B) | / ( ulp max( |beta A|, |alpha B| ) )
+*
+* where l**H is the conjugate tranpose of l.
+*
+* (7) max over all right eigenvalue/-vector pairs (beta/alpha,r) of
+*
+* | (beta A - alpha B) r | / ( ulp max( |beta A|, |alpha B| ) )
+*
+* Test Matrices
+* ---- --------
+*
+* The sizes of the test matrices are specified by an array
+* NN(1:NSIZES); the value of each element NN(j) specifies one size.
+* The "types" are specified by a logical array DOTYPE( 1:NTYPES ); if
+* DOTYPE(j) is .TRUE., then matrix type "j" will be generated.
+* Currently, the list of possible types is:
+*
+* (1) ( 0, 0 ) (a pair of zero matrices)
+*
+* (2) ( I, 0 ) (an identity and a zero matrix)
+*
+* (3) ( 0, I ) (an identity and a zero matrix)
+*
+* (4) ( I, I ) (a pair of identity matrices)
+*
+* t t
+* (5) ( J , J ) (a pair of transposed Jordan blocks)
+*
+* t ( I 0 )
+* (6) ( X, Y ) where X = ( J 0 ) and Y = ( t )
+* ( 0 I ) ( 0 J )
+* and I is a k x k identity and J a (k+1)x(k+1)
+* Jordan block; k=(N-1)/2
+*
+* (7) ( D, I ) where D is diag( 0, 1,..., N-1 ) (a diagonal
+* matrix with those diagonal entries.)
+* (8) ( I, D )
+*
+* (9) ( big*D, small*I ) where "big" is near overflow and small=1/big
+*
+* (10) ( small*D, big*I )
+*
+* (11) ( big*I, small*D )
+*
+* (12) ( small*I, big*D )
+*
+* (13) ( big*D, big*I )
+*
+* (14) ( small*D, small*I )
+*
+* (15) ( D1, D2 ) where D1 is diag( 0, 0, 1, ..., N-3, 0 ) and
+* D2 is diag( 0, N-3, N-4,..., 1, 0, 0 )
+* t t
+* (16) Q ( J , J ) Z where Q and Z are random orthogonal matrices.
+*
+* (17) Q ( T1, T2 ) Z where T1 and T2 are upper triangular matrices
+* with random O(1) entries above the diagonal
+* and diagonal entries diag(T1) =
+* ( 0, 0, 1, ..., N-3, 0 ) and diag(T2) =
+* ( 0, N-3, N-4,..., 1, 0, 0 )
+*
+* (18) Q ( T1, T2 ) Z diag(T1) = ( 0, 0, 1, 1, s, ..., s, 0 )
+* diag(T2) = ( 0, 1, 0, 1,..., 1, 0 )
+* s = machine precision.
+*
+* (19) Q ( T1, T2 ) Z diag(T1)=( 0,0,1,1, 1-d, ..., 1-(N-5)*d=s, 0 )
+* diag(T2) = ( 0, 1, 0, 1, ..., 1, 0 )
+*
+* N-5
+* (20) Q ( T1, T2 ) Z diag(T1)=( 0, 0, 1, 1, a, ..., a =s, 0 )
+* diag(T2) = ( 0, 1, 0, 1, ..., 1, 0, 0 )
+*
+* (21) Q ( T1, T2 ) Z diag(T1)=( 0, 0, 1, r1, r2, ..., r(N-4), 0 )
+* diag(T2) = ( 0, 1, 0, 1, ..., 1, 0, 0 )
+* where r1,..., r(N-4) are random.
+*
+* (22) Q ( big*T1, small*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 )
+* diag(T2) = ( 0, 1, ..., 1, 0, 0 )
+*
+* (23) Q ( small*T1, big*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 )
+* diag(T2) = ( 0, 1, ..., 1, 0, 0 )
+*
+* (24) Q ( small*T1, small*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 )
+* diag(T2) = ( 0, 1, ..., 1, 0, 0 )
+*
+* (25) Q ( big*T1, big*T2 ) Z diag(T1) = ( 0, 0, 1, ..., N-3, 0 )
+* diag(T2) = ( 0, 1, ..., 1, 0, 0 )
+*
+* (26) Q ( T1, T2 ) Z where T1 and T2 are random upper-triangular
+* matrices.
+*
+* Arguments
+* =========
+*
+* NSIZES (input) INTEGER
+* The number of sizes of matrices to use. If it is zero,
+* DDRVGG does nothing. It must be at least zero.
+*
+* NN (input) INTEGER array, dimension (NSIZES)
+* An array containing the sizes to be used for the matrices.
+* Zero values will be skipped. The values must be at least
+* zero.
+*
+* NTYPES (input) INTEGER
+* The number of elements in DOTYPE. If it is zero, DDRVGG
+* does nothing. It must be at least zero. If it is MAXTYP+1
+* and NSIZES is 1, then an additional type, MAXTYP+1 is
+* defined, which is to use whatever matrix is in A. This
+* is only useful if DOTYPE(1:MAXTYP) is .FALSE. and
+* DOTYPE(MAXTYP+1) is .TRUE. .
+*
+* DOTYPE (input) LOGICAL array, dimension (NTYPES)
+* If DOTYPE(j) is .TRUE., then for each size in NN a
+* matrix of that size and of type j will be generated.
+* If NTYPES is smaller than the maximum number of types
+* defined (PARAMETER MAXTYP), then types NTYPES+1 through
+* MAXTYP will not be generated. If NTYPES is larger
+* than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES)
+* will be ignored.
+*
+* ISEED (input/output) INTEGER array, dimension (4)
+* On entry ISEED specifies the seed of the random number
+* generator. The array elements should be between 0 and 4095;
+* if not they will be reduced mod 4096. Also, ISEED(4) must
+* be odd. The random number generator uses a linear
+* congruential sequence limited to small integers, and so
+* should produce machine independent random numbers. The
+* values of ISEED are changed on exit, and can be used in the
+* next call to DDRVGG to continue the same random number
+* sequence.
+*
+* THRESH (input) DOUBLE PRECISION
+* A test will count as "failed" if the "error", computed as
+* described above, exceeds THRESH. Note that the error is
+* scaled to be O(1), so THRESH should be a reasonably small
+* multiple of 1, e.g., 10 or 100. In particular, it should
+* not depend on the precision (single vs. double) or the size
+* of the matrix. It must be at least zero.
+*
+* THRSHN (input) DOUBLE PRECISION
+* Threshhold for reporting eigenvector normalization error.
+* If the normalization of any eigenvector differs from 1 by
+* more than THRSHN*ulp, then a special error message will be
+* printed. (This is handled separately from the other tests,
+* since only a compiler or programming error should cause an
+* error message, at least if THRSHN is at least 5--10.)
+*
+* NOUNIT (input) INTEGER
+* The FORTRAN unit number for printing out error messages
+* (e.g., if a routine returns IINFO not equal to 0.)
+*
+* A (input/workspace) DOUBLE PRECISION array, dimension
+* (LDA, max(NN))
+* Used to hold the original A matrix. Used as input only
+* if NTYPES=MAXTYP+1, DOTYPE(1:MAXTYP)=.FALSE., and
+* DOTYPE(MAXTYP+1)=.TRUE.
+*
+* LDA (input) INTEGER
+* The leading dimension of A, B, S, T, S2, and T2.
+* It must be at least 1 and at least max( NN ).
+*
+* B (input/workspace) DOUBLE PRECISION array, dimension
+* (LDA, max(NN))
+* Used to hold the original B matrix. Used as input only
+* if NTYPES=MAXTYP+1, DOTYPE(1:MAXTYP)=.FALSE., and
+* DOTYPE(MAXTYP+1)=.TRUE.
+*
+* S (workspace) DOUBLE PRECISION array, dimension (LDA, max(NN))
+* The Schur form matrix computed from A by DGEGS. On exit, S
+* contains the Schur form matrix corresponding to the matrix
+* in A.
+*
+* T (workspace) DOUBLE PRECISION array, dimension (LDA, max(NN))
+* The upper triangular matrix computed from B by DGEGS.
+*
+* S2 (workspace) DOUBLE PRECISION array, dimension (LDA, max(NN))
+* The matrix computed from A by DGEGV. This will be the
+* Schur form of some matrix related to A, but will not, in
+* general, be the same as S.
+*
+* T2 (workspace) DOUBLE PRECISION array, dimension (LDA, max(NN))
+* The matrix computed from B by DGEGV. This will be the
+* Schur form of some matrix related to B, but will not, in
+* general, be the same as T.
+*
+* Q (workspace) DOUBLE PRECISION array, dimension (LDQ, max(NN))
+* The (left) orthogonal matrix computed by DGEGS.
+*
+* LDQ (input) INTEGER
+* The leading dimension of Q, Z, VL, and VR. It must
+* be at least 1 and at least max( NN ).
+*
+* Z (workspace) DOUBLE PRECISION array of
+* dimension( LDQ, max(NN) )
+* The (right) orthogonal matrix computed by DGEGS.
+*
+* ALPHR1 (workspace) DOUBLE PRECISION array, dimension (max(NN))
+* ALPHI1 (workspace) DOUBLE PRECISION array, dimension (max(NN))
+* BETA1 (workspace) DOUBLE PRECISION array, dimension (max(NN))
+*
+* The generalized eigenvalues of (A,B) computed by DGEGS.
+* ( ALPHR1(k)+ALPHI1(k)*i ) / BETA1(k) is the k-th
+* generalized eigenvalue of the matrices in A and B.
+*
+* ALPHR2 (workspace) DOUBLE PRECISION array, dimension (max(NN))
+* ALPHI2 (workspace) DOUBLE PRECISION array, dimension (max(NN))
+* BETA2 (workspace) DOUBLE PRECISION array, dimension (max(NN))
+*
+* The generalized eigenvalues of (A,B) computed by DGEGV.
+* ( ALPHR2(k)+ALPHI2(k)*i ) / BETA2(k) is the k-th
+* generalized eigenvalue of the matrices in A and B.
+*
+* VL (workspace) DOUBLE PRECISION array, dimension (LDQ, max(NN))
+* The (block lower triangular) left eigenvector matrix for
+* the matrices in A and B. (See DTGEVC for the format.)
+*
+* VR (workspace) DOUBLE PRECISION array, dimension (LDQ, max(NN))
+* The (block upper triangular) right eigenvector matrix for
+* the matrices in A and B. (See DTGEVC for the format.)
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK)
+*
+* LWORK (input) INTEGER
+* The number of entries in WORK. This must be at least
+* 2*N + MAX( 6*N, N*(NB+1), (k+1)*(2*k+N+1) ), where
+* "k" is the sum of the blocksize and number-of-shifts for
+* DHGEQZ, and NB is the greatest of the blocksizes for
+* DGEQRF, DORMQR, and DORGQR. (The blocksizes and the
+* number-of-shifts are retrieved through calls to ILAENV.)
+*
+* RESULT (output) DOUBLE PRECISION array, dimension (15)
+* The values computed by the tests described above.
+* The values are currently limited to 1/ulp, to avoid
+* overflow.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value.
+* > 0: A routine returned an error code. INFO is the
+* absolute value of the INFO value returned.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
+ INTEGER MAXTYP
+ PARAMETER ( MAXTYP = 26 )
+* ..
+* .. Local Scalars ..
+ LOGICAL BADNN, ILABAD
+ INTEGER I1, IADD, IINFO, IN, J, JC, JR, JSIZE, JTYPE,
+ $ LWKOPT, MTYPES, N, N1, NB, NBZ, NERRS, NMATS,
+ $ NMAX, NS, NTEST, NTESTT
+ DOUBLE PRECISION SAFMAX, SAFMIN, TEMP1, TEMP2, ULP, ULPINV
+* ..
+* .. Local Arrays ..
+ INTEGER IASIGN( MAXTYP ), IBSIGN( MAXTYP ),
+ $ IOLDSD( 4 ), KADD( 6 ), KAMAGN( MAXTYP ),
+ $ KATYPE( MAXTYP ), KAZERO( MAXTYP ),
+ $ KBMAGN( MAXTYP ), KBTYPE( MAXTYP ),
+ $ KBZERO( MAXTYP ), KCLASS( MAXTYP ),
+ $ KTRIAN( MAXTYP ), KZ1( 6 ), KZ2( 6 )
+ DOUBLE PRECISION DUMMA( 4 ), RMAGN( 0: 3 )
+* ..
+* .. External Functions ..
+ INTEGER ILAENV
+ DOUBLE PRECISION DLAMCH, DLARND
+ EXTERNAL ILAENV, DLAMCH, DLARND
+* ..
+* .. External Subroutines ..
+ EXTERNAL ALASVM, DGEGS, DGEGV, DGET51, DGET52, DGET53,
+ $ DLABAD, DLACPY, DLARFG, DLASET, DLATM4, DORM2R,
+ $ XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, DBLE, MAX, MIN, SIGN
+* ..
+* .. Data statements ..
+ DATA KCLASS / 15*1, 10*2, 1*3 /
+ DATA KZ1 / 0, 1, 2, 1, 3, 3 /
+ DATA KZ2 / 0, 0, 1, 2, 1, 1 /
+ DATA KADD / 0, 0, 0, 0, 3, 2 /
+ DATA KATYPE / 0, 1, 0, 1, 2, 3, 4, 1, 4, 4, 1, 1, 4,
+ $ 4, 4, 2, 4, 5, 8, 7, 9, 4*4, 0 /
+ DATA KBTYPE / 0, 0, 1, 1, 2, -3, 1, 4, 1, 1, 4, 4,
+ $ 1, 1, -4, 2, -4, 8*8, 0 /
+ DATA KAZERO / 6*1, 2, 1, 2*2, 2*1, 2*2, 3, 1, 3,
+ $ 4*5, 4*3, 1 /
+ DATA KBZERO / 6*1, 1, 2, 2*1, 2*2, 2*1, 4, 1, 4,
+ $ 4*6, 4*4, 1 /
+ DATA KAMAGN / 8*1, 2, 3, 2, 3, 2, 3, 7*1, 2, 3, 3,
+ $ 2, 1 /
+ DATA KBMAGN / 8*1, 3, 2, 3, 2, 2, 3, 7*1, 3, 2, 3,
+ $ 2, 1 /
+ DATA KTRIAN / 16*0, 10*1 /
+ DATA IASIGN / 6*0, 2, 0, 2*2, 2*0, 3*2, 0, 2, 3*0,
+ $ 5*2, 0 /
+ DATA IBSIGN / 7*0, 2, 2*0, 2*2, 2*0, 2, 0, 2, 9*0 /
+* ..
+* .. Executable Statements ..
+*
+* Check for errors
+*
+ INFO = 0
+*
+ BADNN = .FALSE.
+ NMAX = 1
+ DO 10 J = 1, NSIZES
+ NMAX = MAX( NMAX, NN( J ) )
+ IF( NN( J ).LT.0 )
+ $ BADNN = .TRUE.
+ 10 CONTINUE
+*
+* Maximum blocksize and shift -- we assume that blocksize and number
+* of shifts are monotone increasing functions of N.
+*
+ NB = MAX( 1, ILAENV( 1, 'DGEQRF', ' ', NMAX, NMAX, -1, -1 ),
+ $ ILAENV( 1, 'DORMQR', 'LT', NMAX, NMAX, NMAX, -1 ),
+ $ ILAENV( 1, 'DORGQR', ' ', NMAX, NMAX, NMAX, -1 ) )
+ NBZ = ILAENV( 1, 'DHGEQZ', 'SII', NMAX, 1, NMAX, 0 )
+ NS = ILAENV( 4, 'DHGEQZ', 'SII', NMAX, 1, NMAX, 0 )
+ I1 = NBZ + NS
+ LWKOPT = 2*NMAX + MAX( 6*NMAX, NMAX*( NB+1 ),
+ $ ( 2*I1+NMAX+1 )*( I1+1 ) )
+*
+* Check for errors
+*
+ IF( NSIZES.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( BADNN ) THEN
+ INFO = -2
+ ELSE IF( NTYPES.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( THRESH.LT.ZERO ) THEN
+ INFO = -6
+ ELSE IF( LDA.LE.1 .OR. LDA.LT.NMAX ) THEN
+ INFO = -10
+ ELSE IF( LDQ.LE.1 .OR. LDQ.LT.NMAX ) THEN
+ INFO = -19
+ ELSE IF( LWKOPT.GT.LWORK ) THEN
+ INFO = -30
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DDRVGG', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( NSIZES.EQ.0 .OR. NTYPES.EQ.0 )
+ $ RETURN
+*
+ SAFMIN = DLAMCH( 'Safe minimum' )
+ ULP = DLAMCH( 'Epsilon' )*DLAMCH( 'Base' )
+ SAFMIN = SAFMIN / ULP
+ SAFMAX = ONE / SAFMIN
+ CALL DLABAD( SAFMIN, SAFMAX )
+ ULPINV = ONE / ULP
+*
+* The values RMAGN(2:3) depend on N, see below.
+*
+ RMAGN( 0 ) = ZERO
+ RMAGN( 1 ) = ONE
+*
+* Loop over sizes, types
+*
+ NTESTT = 0
+ NERRS = 0
+ NMATS = 0
+*
+ DO 170 JSIZE = 1, NSIZES
+ N = NN( JSIZE )
+ N1 = MAX( 1, N )
+ RMAGN( 2 ) = SAFMAX*ULP / DBLE( N1 )
+ RMAGN( 3 ) = SAFMIN*ULPINV*N1
+*
+ IF( NSIZES.NE.1 ) THEN
+ MTYPES = MIN( MAXTYP, NTYPES )
+ ELSE
+ MTYPES = MIN( MAXTYP+1, NTYPES )
+ END IF
+*
+ DO 160 JTYPE = 1, MTYPES
+ IF( .NOT.DOTYPE( JTYPE ) )
+ $ GO TO 160
+ NMATS = NMATS + 1
+ NTEST = 0
+*
+* Save ISEED in case of an error.
+*
+ DO 20 J = 1, 4
+ IOLDSD( J ) = ISEED( J )
+ 20 CONTINUE
+*
+* Initialize RESULT
+*
+ DO 30 J = 1, 15
+ RESULT( J ) = ZERO
+ 30 CONTINUE
+*
+* Compute A and B
+*
+* Description of control parameters:
+*
+* KZLASS: =1 means w/o rotation, =2 means w/ rotation,
+* =3 means random.
+* KATYPE: the "type" to be passed to DLATM4 for computing A.
+* KAZERO: the pattern of zeros on the diagonal for A:
+* =1: ( xxx ), =2: (0, xxx ) =3: ( 0, 0, xxx, 0 ),
+* =4: ( 0, xxx, 0, 0 ), =5: ( 0, 0, 1, xxx, 0 ),
+* =6: ( 0, 1, 0, xxx, 0 ). (xxx means a string of
+* non-zero entries.)
+* KAMAGN: the magnitude of the matrix: =0: zero, =1: O(1),
+* =2: large, =3: small.
+* IASIGN: 1 if the diagonal elements of A are to be
+* multiplied by a random magnitude 1 number, =2 if
+* randomly chosen diagonal blocks are to be rotated
+* to form 2x2 blocks.
+* KBTYPE, KBZERO, KBMAGN, IBSIGN: the same, but for B.
+* KTRIAN: =0: don't fill in the upper triangle, =1: do.
+* KZ1, KZ2, KADD: used to implement KAZERO and KBZERO.
+* RMAGN: used to implement KAMAGN and KBMAGN.
+*
+ IF( MTYPES.GT.MAXTYP )
+ $ GO TO 110
+ IINFO = 0
+ IF( KCLASS( JTYPE ).LT.3 ) THEN
+*
+* Generate A (w/o rotation)
+*
+ IF( ABS( KATYPE( JTYPE ) ).EQ.3 ) THEN
+ IN = 2*( ( N-1 ) / 2 ) + 1
+ IF( IN.NE.N )
+ $ CALL DLASET( 'Full', N, N, ZERO, ZERO, A, LDA )
+ ELSE
+ IN = N
+ END IF
+ CALL DLATM4( KATYPE( JTYPE ), IN, KZ1( KAZERO( JTYPE ) ),
+ $ KZ2( KAZERO( JTYPE ) ), IASIGN( JTYPE ),
+ $ RMAGN( KAMAGN( JTYPE ) ), ULP,
+ $ RMAGN( KTRIAN( JTYPE )*KAMAGN( JTYPE ) ), 2,
+ $ ISEED, A, LDA )
+ IADD = KADD( KAZERO( JTYPE ) )
+ IF( IADD.GT.0 .AND. IADD.LE.N )
+ $ A( IADD, IADD ) = ONE
+*
+* Generate B (w/o rotation)
+*
+ IF( ABS( KBTYPE( JTYPE ) ).EQ.3 ) THEN
+ IN = 2*( ( N-1 ) / 2 ) + 1
+ IF( IN.NE.N )
+ $ CALL DLASET( 'Full', N, N, ZERO, ZERO, B, LDA )
+ ELSE
+ IN = N
+ END IF
+ CALL DLATM4( KBTYPE( JTYPE ), IN, KZ1( KBZERO( JTYPE ) ),
+ $ KZ2( KBZERO( JTYPE ) ), IBSIGN( JTYPE ),
+ $ RMAGN( KBMAGN( JTYPE ) ), ONE,
+ $ RMAGN( KTRIAN( JTYPE )*KBMAGN( JTYPE ) ), 2,
+ $ ISEED, B, LDA )
+ IADD = KADD( KBZERO( JTYPE ) )
+ IF( IADD.NE.0 .AND. IADD.LE.N )
+ $ B( IADD, IADD ) = ONE
+*
+ IF( KCLASS( JTYPE ).EQ.2 .AND. N.GT.0 ) THEN
+*
+* Include rotations
+*
+* Generate Q, Z as Householder transformations times
+* a diagonal matrix.
+*
+ DO 50 JC = 1, N - 1
+ DO 40 JR = JC, N
+ Q( JR, JC ) = DLARND( 3, ISEED )
+ Z( JR, JC ) = DLARND( 3, ISEED )
+ 40 CONTINUE
+ CALL DLARFG( N+1-JC, Q( JC, JC ), Q( JC+1, JC ), 1,
+ $ WORK( JC ) )
+ WORK( 2*N+JC ) = SIGN( ONE, Q( JC, JC ) )
+ Q( JC, JC ) = ONE
+ CALL DLARFG( N+1-JC, Z( JC, JC ), Z( JC+1, JC ), 1,
+ $ WORK( N+JC ) )
+ WORK( 3*N+JC ) = SIGN( ONE, Z( JC, JC ) )
+ Z( JC, JC ) = ONE
+ 50 CONTINUE
+ Q( N, N ) = ONE
+ WORK( N ) = ZERO
+ WORK( 3*N ) = SIGN( ONE, DLARND( 2, ISEED ) )
+ Z( N, N ) = ONE
+ WORK( 2*N ) = ZERO
+ WORK( 4*N ) = SIGN( ONE, DLARND( 2, ISEED ) )
+*
+* Apply the diagonal matrices
+*
+ DO 70 JC = 1, N
+ DO 60 JR = 1, N
+ A( JR, JC ) = WORK( 2*N+JR )*WORK( 3*N+JC )*
+ $ A( JR, JC )
+ B( JR, JC ) = WORK( 2*N+JR )*WORK( 3*N+JC )*
+ $ B( JR, JC )
+ 60 CONTINUE
+ 70 CONTINUE
+ CALL DORM2R( 'L', 'N', N, N, N-1, Q, LDQ, WORK, A,
+ $ LDA, WORK( 2*N+1 ), IINFO )
+ IF( IINFO.NE.0 )
+ $ GO TO 100
+ CALL DORM2R( 'R', 'T', N, N, N-1, Z, LDQ, WORK( N+1 ),
+ $ A, LDA, WORK( 2*N+1 ), IINFO )
+ IF( IINFO.NE.0 )
+ $ GO TO 100
+ CALL DORM2R( 'L', 'N', N, N, N-1, Q, LDQ, WORK, B,
+ $ LDA, WORK( 2*N+1 ), IINFO )
+ IF( IINFO.NE.0 )
+ $ GO TO 100
+ CALL DORM2R( 'R', 'T', N, N, N-1, Z, LDQ, WORK( N+1 ),
+ $ B, LDA, WORK( 2*N+1 ), IINFO )
+ IF( IINFO.NE.0 )
+ $ GO TO 100
+ END IF
+ ELSE
+*
+* Random matrices
+*
+ DO 90 JC = 1, N
+ DO 80 JR = 1, N
+ A( JR, JC ) = RMAGN( KAMAGN( JTYPE ) )*
+ $ DLARND( 2, ISEED )
+ B( JR, JC ) = RMAGN( KBMAGN( JTYPE ) )*
+ $ DLARND( 2, ISEED )
+ 80 CONTINUE
+ 90 CONTINUE
+ END IF
+*
+ 100 CONTINUE
+*
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUNIT, FMT = 9999 )'Generator', IINFO, N, JTYPE,
+ $ IOLDSD
+ INFO = ABS( IINFO )
+ RETURN
+ END IF
+*
+ 110 CONTINUE
+*
+* Call DGEGS to compute H, T, Q, Z, alpha, and beta.
+*
+ CALL DLACPY( ' ', N, N, A, LDA, S, LDA )
+ CALL DLACPY( ' ', N, N, B, LDA, T, LDA )
+ NTEST = 1
+ RESULT( 1 ) = ULPINV
+*
+ CALL DGEGS( 'V', 'V', N, S, LDA, T, LDA, ALPHR1, ALPHI1,
+ $ BETA1, Q, LDQ, Z, LDQ, WORK, LWORK, IINFO )
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUNIT, FMT = 9999 )'DGEGS', IINFO, N, JTYPE,
+ $ IOLDSD
+ INFO = ABS( IINFO )
+ GO TO 140
+ END IF
+*
+ NTEST = 4
+*
+* Do tests 1--4
+*
+ CALL DGET51( 1, N, A, LDA, S, LDA, Q, LDQ, Z, LDQ, WORK,
+ $ RESULT( 1 ) )
+ CALL DGET51( 1, N, B, LDA, T, LDA, Q, LDQ, Z, LDQ, WORK,
+ $ RESULT( 2 ) )
+ CALL DGET51( 3, N, B, LDA, T, LDA, Q, LDQ, Q, LDQ, WORK,
+ $ RESULT( 3 ) )
+ CALL DGET51( 3, N, B, LDA, T, LDA, Z, LDQ, Z, LDQ, WORK,
+ $ RESULT( 4 ) )
+*
+* Do test 5: compare eigenvalues with diagonals.
+* Also check Schur form of A.
+*
+ TEMP1 = ZERO
+*
+ DO 120 J = 1, N
+ ILABAD = .FALSE.
+ IF( ALPHI1( J ).EQ.ZERO ) THEN
+ TEMP2 = ( ABS( ALPHR1( J )-S( J, J ) ) /
+ $ MAX( SAFMIN, ABS( ALPHR1( J ) ), ABS( S( J,
+ $ J ) ) )+ABS( BETA1( J )-T( J, J ) ) /
+ $ MAX( SAFMIN, ABS( BETA1( J ) ), ABS( T( J,
+ $ J ) ) ) ) / ULP
+ IF( J.LT.N ) THEN
+ IF( S( J+1, J ).NE.ZERO )
+ $ ILABAD = .TRUE.
+ END IF
+ IF( J.GT.1 ) THEN
+ IF( S( J, J-1 ).NE.ZERO )
+ $ ILABAD = .TRUE.
+ END IF
+ ELSE
+ IF( ALPHI1( J ).GT.ZERO ) THEN
+ I1 = J
+ ELSE
+ I1 = J - 1
+ END IF
+ IF( I1.LE.0 .OR. I1.GE.N ) THEN
+ ILABAD = .TRUE.
+ ELSE IF( I1.LT.N-1 ) THEN
+ IF( S( I1+2, I1+1 ).NE.ZERO )
+ $ ILABAD = .TRUE.
+ ELSE IF( I1.GT.1 ) THEN
+ IF( S( I1, I1-1 ).NE.ZERO )
+ $ ILABAD = .TRUE.
+ END IF
+ IF( .NOT.ILABAD ) THEN
+ CALL DGET53( S( I1, I1 ), LDA, T( I1, I1 ), LDA,
+ $ BETA1( J ), ALPHR1( J ), ALPHI1( J ),
+ $ TEMP2, IINFO )
+ IF( IINFO.GE.3 ) THEN
+ WRITE( NOUNIT, FMT = 9997 )IINFO, J, N, JTYPE,
+ $ IOLDSD
+ INFO = ABS( IINFO )
+ END IF
+ ELSE
+ TEMP2 = ULPINV
+ END IF
+ END IF
+ TEMP1 = MAX( TEMP1, TEMP2 )
+ IF( ILABAD ) THEN
+ WRITE( NOUNIT, FMT = 9996 )J, N, JTYPE, IOLDSD
+ END IF
+ 120 CONTINUE
+ RESULT( 5 ) = TEMP1
+*
+* Call DGEGV to compute S2, T2, VL, and VR, do tests.
+*
+* Eigenvalues and Eigenvectors
+*
+ CALL DLACPY( ' ', N, N, A, LDA, S2, LDA )
+ CALL DLACPY( ' ', N, N, B, LDA, T2, LDA )
+ NTEST = 6
+ RESULT( 6 ) = ULPINV
+*
+ CALL DGEGV( 'V', 'V', N, S2, LDA, T2, LDA, ALPHR2, ALPHI2,
+ $ BETA2, VL, LDQ, VR, LDQ, WORK, LWORK, IINFO )
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUNIT, FMT = 9999 )'DGEGV', IINFO, N, JTYPE,
+ $ IOLDSD
+ INFO = ABS( IINFO )
+ GO TO 140
+ END IF
+*
+ NTEST = 7
+*
+* Do Tests 6 and 7
+*
+ CALL DGET52( .TRUE., N, A, LDA, B, LDA, VL, LDQ, ALPHR2,
+ $ ALPHI2, BETA2, WORK, DUMMA( 1 ) )
+ RESULT( 6 ) = DUMMA( 1 )
+ IF( DUMMA( 2 ).GT.THRSHN ) THEN
+ WRITE( NOUNIT, FMT = 9998 )'Left', 'DGEGV', DUMMA( 2 ),
+ $ N, JTYPE, IOLDSD
+ END IF
+*
+ CALL DGET52( .FALSE., N, A, LDA, B, LDA, VR, LDQ, ALPHR2,
+ $ ALPHI2, BETA2, WORK, DUMMA( 1 ) )
+ RESULT( 7 ) = DUMMA( 1 )
+ IF( DUMMA( 2 ).GT.THRESH ) THEN
+ WRITE( NOUNIT, FMT = 9998 )'Right', 'DGEGV', DUMMA( 2 ),
+ $ N, JTYPE, IOLDSD
+ END IF
+*
+* Check form of Complex eigenvalues.
+*
+ DO 130 J = 1, N
+ ILABAD = .FALSE.
+ IF( ALPHI2( J ).GT.ZERO ) THEN
+ IF( J.EQ.N ) THEN
+ ILABAD = .TRUE.
+ ELSE IF( ALPHI2( J+1 ).GE.ZERO ) THEN
+ ILABAD = .TRUE.
+ END IF
+ ELSE IF( ALPHI2( J ).LT.ZERO ) THEN
+ IF( J.EQ.1 ) THEN
+ ILABAD = .TRUE.
+ ELSE IF( ALPHI2( J-1 ).LE.ZERO ) THEN
+ ILABAD = .TRUE.
+ END IF
+ END IF
+ IF( ILABAD ) THEN
+ WRITE( NOUNIT, FMT = 9996 )J, N, JTYPE, IOLDSD
+ END IF
+ 130 CONTINUE
+*
+* End of Loop -- Check for RESULT(j) > THRESH
+*
+ 140 CONTINUE
+*
+ NTESTT = NTESTT + NTEST
+*
+* Print out tests which fail.
+*
+ DO 150 JR = 1, NTEST
+ IF( RESULT( JR ).GE.THRESH ) THEN
+*
+* If this is the first test to fail,
+* print a header to the data file.
+*
+ IF( NERRS.EQ.0 ) THEN
+ WRITE( NOUNIT, FMT = 9995 )'DGG'
+*
+* Matrix types
+*
+ WRITE( NOUNIT, FMT = 9994 )
+ WRITE( NOUNIT, FMT = 9993 )
+ WRITE( NOUNIT, FMT = 9992 )'Orthogonal'
+*
+* Tests performed
+*
+ WRITE( NOUNIT, FMT = 9991 )'orthogonal', '''',
+ $ 'transpose', ( '''', J = 1, 5 )
+*
+ END IF
+ NERRS = NERRS + 1
+ IF( RESULT( JR ).LT.10000.0D0 ) THEN
+ WRITE( NOUNIT, FMT = 9990 )N, JTYPE, IOLDSD, JR,
+ $ RESULT( JR )
+ ELSE
+ WRITE( NOUNIT, FMT = 9989 )N, JTYPE, IOLDSD, JR,
+ $ RESULT( JR )
+ END IF
+ END IF
+ 150 CONTINUE
+*
+ 160 CONTINUE
+ 170 CONTINUE
+*
+* Summary
+*
+ CALL ALASVM( 'DGG', NOUNIT, NERRS, NTESTT, 0 )
+ RETURN
+*
+ 9999 FORMAT( ' DDRVGG: ', A, ' returned INFO=', I6, '.', / 9X, 'N=',
+ $ I6, ', JTYPE=', I6, ', ISEED=(', 3( I5, ',' ), I5, ')' )
+*
+ 9998 FORMAT( ' DDRVGG: ', A, ' Eigenvectors from ', A, ' incorrectly ',
+ $ 'normalized.', / ' Bits of error=', 0P, G10.3, ',', 9X,
+ $ 'N=', I6, ', JTYPE=', I6, ', ISEED=(', 3( I5, ',' ), I5,
+ $ ')' )
+*
+ 9997 FORMAT( ' DDRVGG: DGET53 returned INFO=', I1, ' for eigenvalue ',
+ $ I6, '.', / 9X, 'N=', I6, ', JTYPE=', I6, ', ISEED=(',
+ $ 3( I5, ',' ), I5, ')' )
+*
+ 9996 FORMAT( ' DDRVGG: S not in Schur form at eigenvalue ', I6, '.',
+ $ / 9X, 'N=', I6, ', JTYPE=', I6, ', ISEED=(', 3( I5, ',' ),
+ $ I5, ')' )
+*
+ 9995 FORMAT( / 1X, A3, ' -- Real Generalized eigenvalue problem driver'
+ $ )
+*
+ 9994 FORMAT( ' Matrix types (see DDRVGG for details): ' )
+*
+ 9993 FORMAT( ' Special Matrices:', 23X,
+ $ '(J''=transposed Jordan block)',
+ $ / ' 1=(0,0) 2=(I,0) 3=(0,I) 4=(I,I) 5=(J'',J'') ',
+ $ '6=(diag(J'',I), diag(I,J''))', / ' Diagonal Matrices: ( ',
+ $ 'D=diag(0,1,2,...) )', / ' 7=(D,I) 9=(large*D, small*I',
+ $ ') 11=(large*I, small*D) 13=(large*D, large*I)', /
+ $ ' 8=(I,D) 10=(small*D, large*I) 12=(small*I, large*D) ',
+ $ ' 14=(small*D, small*I)', / ' 15=(D, reversed D)' )
+ 9992 FORMAT( ' Matrices Rotated by Random ', A, ' Matrices U, V:',
+ $ / ' 16=Transposed Jordan Blocks 19=geometric ',
+ $ 'alpha, beta=0,1', / ' 17=arithm. alpha&beta ',
+ $ ' 20=arithmetic alpha, beta=0,1', / ' 18=clustered ',
+ $ 'alpha, beta=0,1 21=random alpha, beta=0,1',
+ $ / ' Large & Small Matrices:', / ' 22=(large, small) ',
+ $ '23=(small,large) 24=(small,small) 25=(large,large)',
+ $ / ' 26=random O(1) matrices.' )
+*
+ 9991 FORMAT( / ' Tests performed: (S is Schur, T is triangular, ',
+ $ 'Q and Z are ', A, ',', / 20X,
+ $ 'l and r are the appropriate left and right', / 19X,
+ $ 'eigenvectors, resp., a is alpha, b is beta, and', / 19X, A,
+ $ ' means ', A, '.)', / ' 1 = | A - Q S Z', A,
+ $ ' | / ( |A| n ulp ) 2 = | B - Q T Z', A,
+ $ ' | / ( |B| n ulp )', / ' 3 = | I - QQ', A,
+ $ ' | / ( n ulp ) 4 = | I - ZZ', A,
+ $ ' | / ( n ulp )', /
+ $ ' 5 = difference between (alpha,beta) and diagonals of',
+ $ ' (S,T)', / ' 6 = max | ( b A - a B )', A,
+ $ ' l | / const. 7 = max | ( b A - a B ) r | / const.',
+ $ / 1X )
+ 9990 FORMAT( ' Matrix order=', I5, ', type=', I2, ', seed=',
+ $ 4( I4, ',' ), ' result ', I3, ' is', 0P, F8.2 )
+ 9989 FORMAT( ' Matrix order=', I5, ', type=', I2, ', seed=',
+ $ 4( I4, ',' ), ' result ', I3, ' is', 1P, D10.3 )
+*
+* End of DDRVGG
+*
+ END
+ SUBROUTINE DDRVSG( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH,
+ $ NOUNIT, A, LDA, B, LDB, D, Z, LDZ, AB, BB, AP,
+ $ BP, WORK, NWORK, IWORK, LIWORK, RESULT, INFO )
+*
+* -- LAPACK test routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+*******************************************************************
+*
+* modified August 1997, a new parameter LIWORK is added
+* in the calling sequence.
+*
+* test routine DDGT01 is also modified
+*
+*******************************************************************
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LDA, LDB, LDZ, LIWORK, NOUNIT, NSIZES,
+ $ NTYPES, NWORK
+ DOUBLE PRECISION THRESH
+* ..
+* .. Array Arguments ..
+ LOGICAL DOTYPE( * )
+ INTEGER ISEED( 4 ), IWORK( * ), NN( * )
+ DOUBLE PRECISION A( LDA, * ), AB( LDA, * ), AP( * ),
+ $ B( LDB, * ), BB( LDB, * ), BP( * ), D( * ),
+ $ RESULT( * ), WORK( * ), Z( LDZ, * )
+* ..
+*
+* Purpose
+* =======
+*
+* DDRVSG checks the real symmetric generalized eigenproblem
+* drivers.
+*
+* DSYGV computes all eigenvalues and, optionally,
+* eigenvectors of a real symmetric-definite generalized
+* eigenproblem.
+*
+* DSYGVD computes all eigenvalues and, optionally,
+* eigenvectors of a real symmetric-definite generalized
+* eigenproblem using a divide and conquer algorithm.
+*
+* DSYGVX computes selected eigenvalues and, optionally,
+* eigenvectors of a real symmetric-definite generalized
+* eigenproblem.
+*
+* DSPGV computes all eigenvalues and, optionally,
+* eigenvectors of a real symmetric-definite generalized
+* eigenproblem in packed storage.
+*
+* DSPGVD computes all eigenvalues and, optionally,
+* eigenvectors of a real symmetric-definite generalized
+* eigenproblem in packed storage using a divide and
+* conquer algorithm.
+*
+* DSPGVX computes selected eigenvalues and, optionally,
+* eigenvectors of a real symmetric-definite generalized
+* eigenproblem in packed storage.
+*
+* DSBGV computes all eigenvalues and, optionally,
+* eigenvectors of a real symmetric-definite banded
+* generalized eigenproblem.
+*
+* DSBGVD computes all eigenvalues and, optionally,
+* eigenvectors of a real symmetric-definite banded
+* generalized eigenproblem using a divide and conquer
+* algorithm.
+*
+* DSBGVX computes selected eigenvalues and, optionally,
+* eigenvectors of a real symmetric-definite banded
+* generalized eigenproblem.
+*
+* When DDRVSG is called, a number of matrix "sizes" ("n's") and a
+* number of matrix "types" are specified. For each size ("n")
+* and each type of matrix, one matrix A of the given type will be
+* generated; a random well-conditioned matrix B is also generated
+* and the pair (A,B) is used to test the drivers.
+*
+* For each pair (A,B), the following tests are performed:
+*
+* (1) DSYGV with ITYPE = 1 and UPLO ='U':
+*
+* | A Z - B Z D | / ( |A| |Z| n ulp )
+*
+* (2) as (1) but calling DSPGV
+* (3) as (1) but calling DSBGV
+* (4) as (1) but with UPLO = 'L'
+* (5) as (4) but calling DSPGV
+* (6) as (4) but calling DSBGV
+*
+* (7) DSYGV with ITYPE = 2 and UPLO ='U':
+*
+* | A B Z - Z D | / ( |A| |Z| n ulp )
+*
+* (8) as (7) but calling DSPGV
+* (9) as (7) but with UPLO = 'L'
+* (10) as (9) but calling DSPGV
+*
+* (11) DSYGV with ITYPE = 3 and UPLO ='U':
+*
+* | B A Z - Z D | / ( |A| |Z| n ulp )
+*
+* (12) as (11) but calling DSPGV
+* (13) as (11) but with UPLO = 'L'
+* (14) as (13) but calling DSPGV
+*
+* DSYGVD, DSPGVD and DSBGVD performed the same 14 tests.
+*
+* DSYGVX, DSPGVX and DSBGVX performed the above 14 tests with
+* the parameter RANGE = 'A', 'N' and 'I', respectively.
+*
+* The "sizes" are specified by an array NN(1:NSIZES); the value
+* of each element NN(j) specifies one size.
+* The "types" are specified by a logical array DOTYPE( 1:NTYPES );
+* if DOTYPE(j) is .TRUE., then matrix type "j" will be generated.
+* This type is used for the matrix A which has half-bandwidth KA.
+* B is generated as a well-conditioned positive definite matrix
+* with half-bandwidth KB (<= KA).
+* Currently, the list of possible types for A is:
+*
+* (1) The zero matrix.
+* (2) The identity matrix.
+*
+* (3) A diagonal matrix with evenly spaced entries
+* 1, ..., ULP and random signs.
+* (ULP = (first number larger than 1) - 1 )
+* (4) A diagonal matrix with geometrically spaced entries
+* 1, ..., ULP and random signs.
+* (5) A diagonal matrix with "clustered" entries
+* 1, ULP, ..., ULP and random signs.
+*
+* (6) Same as (4), but multiplied by SQRT( overflow threshold )
+* (7) Same as (4), but multiplied by SQRT( underflow threshold )
+*
+* (8) A matrix of the form U* D U, where U is orthogonal and
+* D has evenly spaced entries 1, ..., ULP with random signs
+* on the diagonal.
+*
+* (9) A matrix of the form U* D U, where U is orthogonal and
+* D has geometrically spaced entries 1, ..., ULP with random
+* signs on the diagonal.
+*
+* (10) A matrix of the form U* D U, where U is orthogonal and
+* D has "clustered" entries 1, ULP,..., ULP with random
+* signs on the diagonal.
+*
+* (11) Same as (8), but multiplied by SQRT( overflow threshold )
+* (12) Same as (8), but multiplied by SQRT( underflow threshold )
+*
+* (13) symmetric matrix with random entries chosen from (-1,1).
+* (14) Same as (13), but multiplied by SQRT( overflow threshold )
+* (15) Same as (13), but multiplied by SQRT( underflow threshold)
+*
+* (16) Same as (8), but with KA = 1 and KB = 1
+* (17) Same as (8), but with KA = 2 and KB = 1
+* (18) Same as (8), but with KA = 2 and KB = 2
+* (19) Same as (8), but with KA = 3 and KB = 1
+* (20) Same as (8), but with KA = 3 and KB = 2
+* (21) Same as (8), but with KA = 3 and KB = 3
+*
+* Arguments
+* =========
+*
+* NSIZES INTEGER
+* The number of sizes of matrices to use. If it is zero,
+* DDRVSG does nothing. It must be at least zero.
+* Not modified.
+*
+* NN INTEGER array, dimension (NSIZES)
+* An array containing the sizes to be used for the matrices.
+* Zero values will be skipped. The values must be at least
+* zero.
+* Not modified.
+*
+* NTYPES INTEGER
+* The number of elements in DOTYPE. If it is zero, DDRVSG
+* does nothing. It must be at least zero. If it is MAXTYP+1
+* and NSIZES is 1, then an additional type, MAXTYP+1 is
+* defined, which is to use whatever matrix is in A. This
+* is only useful if DOTYPE(1:MAXTYP) is .FALSE. and
+* DOTYPE(MAXTYP+1) is .TRUE. .
+* Not modified.
+*
+* DOTYPE LOGICAL array, dimension (NTYPES)
+* If DOTYPE(j) is .TRUE., then for each size in NN a
+* matrix of that size and of type j will be generated.
+* If NTYPES is smaller than the maximum number of types
+* defined (PARAMETER MAXTYP), then types NTYPES+1 through
+* MAXTYP will not be generated. If NTYPES is larger
+* than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES)
+* will be ignored.
+* Not modified.
+*
+* ISEED INTEGER array, dimension (4)
+* On entry ISEED specifies the seed of the random number
+* generator. The array elements should be between 0 and 4095;
+* if not they will be reduced mod 4096. Also, ISEED(4) must
+* be odd. The random number generator uses a linear
+* congruential sequence limited to small integers, and so
+* should produce machine independent random numbers. The
+* values of ISEED are changed on exit, and can be used in the
+* next call to DDRVSG to continue the same random number
+* sequence.
+* Modified.
+*
+* THRESH DOUBLE PRECISION
+* A test will count as "failed" if the "error", computed as
+* described above, exceeds THRESH. Note that the error
+* is scaled to be O(1), so THRESH should be a reasonably
+* small multiple of 1, e.g., 10 or 100. In particular,
+* it should not depend on the precision (single vs. double)
+* or the size of the matrix. It must be at least zero.
+* Not modified.
+*
+* NOUNIT INTEGER
+* The FORTRAN unit number for printing out error messages
+* (e.g., if a routine returns IINFO not equal to 0.)
+* Not modified.
+*
+* A DOUBLE PRECISION array, dimension (LDA , max(NN))
+* Used to hold the matrix whose eigenvalues are to be
+* computed. On exit, A contains the last matrix actually
+* used.
+* Modified.
+*
+* LDA INTEGER
+* The leading dimension of A and AB. It must be at
+* least 1 and at least max( NN ).
+* Not modified.
+*
+* B DOUBLE PRECISION array, dimension (LDB , max(NN))
+* Used to hold the symmetric positive definite matrix for
+* the generailzed problem.
+* On exit, B contains the last matrix actually
+* used.
+* Modified.
+*
+* LDB INTEGER
+* The leading dimension of B and BB. It must be at
+* least 1 and at least max( NN ).
+* Not modified.
+*
+* D DOUBLE PRECISION array, dimension (max(NN))
+* The eigenvalues of A. On exit, the eigenvalues in D
+* correspond with the matrix in A.
+* Modified.
+*
+* Z DOUBLE PRECISION array, dimension (LDZ, max(NN))
+* The matrix of eigenvectors.
+* Modified.
+*
+* LDZ INTEGER
+* The leading dimension of Z. It must be at least 1 and
+* at least max( NN ).
+* Not modified.
+*
+* AB DOUBLE PRECISION array, dimension (LDA, max(NN))
+* Workspace.
+* Modified.
+*
+* BB DOUBLE PRECISION array, dimension (LDB, max(NN))
+* Workspace.
+* Modified.
+*
+* AP DOUBLE PRECISION array, dimension (max(NN)**2)
+* Workspace.
+* Modified.
+*
+* BP DOUBLE PRECISION array, dimension (max(NN)**2)
+* Workspace.
+* Modified.
+*
+* WORK DOUBLE PRECISION array, dimension (NWORK)
+* Workspace.
+* Modified.
+*
+* NWORK INTEGER
+* The number of entries in WORK. This must be at least
+* 1+5*N+2*N*lg(N)+3*N**2 where N = max( NN(j) ) and
+* lg( N ) = smallest integer k such that 2**k >= N.
+* Not modified.
+*
+* IWORK INTEGER array, dimension (LIWORK)
+* Workspace.
+* Modified.
+*
+* LIWORK INTEGER
+* The number of entries in WORK. This must be at least 6*N.
+* Not modified.
+*
+* RESULT DOUBLE PRECISION array, dimension (70)
+* The values computed by the 70 tests described above.
+* Modified.
+*
+* INFO INTEGER
+* If 0, then everything ran OK.
+* -1: NSIZES < 0
+* -2: Some NN(j) < 0
+* -3: NTYPES < 0
+* -5: THRESH < 0
+* -9: LDA < 1 or LDA < NMAX, where NMAX is max( NN(j) ).
+* -16: LDZ < 1 or LDZ < NMAX.
+* -21: NWORK too small.
+* -23: LIWORK too small.
+* If DLATMR, SLATMS, DSYGV, DSPGV, DSBGV, SSYGVD, SSPGVD,
+* DSBGVD, DSYGVX, DSPGVX or SSBGVX returns an error code,
+* the absolute value of it is returned.
+* Modified.
+*
+* ----------------------------------------------------------------------
+*
+* Some Local Variables and Parameters:
+* ---- ----- --------- --- ----------
+* ZERO, ONE Real 0 and 1.
+* MAXTYP The number of types defined.
+* NTEST The number of tests that have been run
+* on this matrix.
+* NTESTT The total number of tests for this call.
+* NMAX Largest value in NN.
+* NMATS The number of matrices generated so far.
+* NERRS The number of tests which have exceeded THRESH
+* so far (computed by DLAFTS).
+* COND, IMODE Values to be passed to the matrix generators.
+* ANORM Norm of A; passed to matrix generators.
+*
+* OVFL, UNFL Overflow and underflow thresholds.
+* ULP, ULPINV Finest relative precision and its inverse.
+* RTOVFL, RTUNFL Square roots of the previous 2 values.
+* The following four arrays decode JTYPE:
+* KTYPE(j) The general type (1-10) for type "j".
+* KMODE(j) The MODE value to be passed to the matrix
+* generator for type "j".
+* KMAGN(j) The order of magnitude ( O(1),
+* O(overflow^(1/2) ), O(underflow^(1/2) )
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE, TEN
+ PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TEN = 10.0D0 )
+ INTEGER MAXTYP
+ PARAMETER ( MAXTYP = 21 )
+* ..
+* .. Local Scalars ..
+ LOGICAL BADNN
+ CHARACTER UPLO
+ INTEGER I, IBTYPE, IBUPLO, IINFO, IJ, IL, IMODE, ITEMP,
+ $ ITYPE, IU, J, JCOL, JSIZE, JTYPE, KA, KA9, KB,
+ $ KB9, M, MTYPES, N, NERRS, NMATS, NMAX, NTEST,
+ $ NTESTT
+ DOUBLE PRECISION ABSTOL, ANINV, ANORM, COND, OVFL, RTOVFL,
+ $ RTUNFL, ULP, ULPINV, UNFL, VL, VU
+* ..
+* .. Local Arrays ..
+ INTEGER IDUMMA( 1 ), IOLDSD( 4 ), ISEED2( 4 ),
+ $ KMAGN( MAXTYP ), KMODE( MAXTYP ),
+ $ KTYPE( MAXTYP )
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ DOUBLE PRECISION DLAMCH, DLARND
+ EXTERNAL LSAME, DLAMCH, DLARND
+* ..
+* .. External Subroutines ..
+ EXTERNAL DLABAD, DLACPY, DLAFTS, DLASET, DLASUM, DLATMR,
+ $ DLATMS, DSBGV, DSBGVD, DSBGVX, DSGT01, DSPGV,
+ $ DSPGVD, DSPGVX, DSYGV, DSYGVD, DSYGVX, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, DBLE, MAX, MIN, SQRT
+* ..
+* .. Data statements ..
+ DATA KTYPE / 1, 2, 5*4, 5*5, 3*8, 6*9 /
+ DATA KMAGN / 2*1, 1, 1, 1, 2, 3, 1, 1, 1, 2, 3, 1,
+ $ 2, 3, 6*1 /
+ DATA KMODE / 2*0, 4, 3, 1, 4, 4, 4, 3, 1, 4, 4, 0,
+ $ 0, 0, 6*4 /
+* ..
+* .. Executable Statements ..
+*
+* 1) Check for errors
+*
+ NTESTT = 0
+ INFO = 0
+*
+ BADNN = .FALSE.
+ NMAX = 0
+ DO 10 J = 1, NSIZES
+ NMAX = MAX( NMAX, NN( J ) )
+ IF( NN( J ).LT.0 )
+ $ BADNN = .TRUE.
+ 10 CONTINUE
+*
+* Check for errors
+*
+ IF( NSIZES.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( BADNN ) THEN
+ INFO = -2
+ ELSE IF( NTYPES.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( LDA.LE.1 .OR. LDA.LT.NMAX ) THEN
+ INFO = -9
+ ELSE IF( LDZ.LE.1 .OR. LDZ.LT.NMAX ) THEN
+ INFO = -16
+ ELSE IF( 2*MAX( NMAX, 3 )**2.GT.NWORK ) THEN
+ INFO = -21
+ ELSE IF( 2*MAX( NMAX, 3 )**2.GT.LIWORK ) THEN
+ INFO = -23
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DDRVSG', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if possible
+*
+ IF( NSIZES.EQ.0 .OR. NTYPES.EQ.0 )
+ $ RETURN
+*
+* More Important constants
+*
+ UNFL = DLAMCH( 'Safe minimum' )
+ OVFL = DLAMCH( 'Overflow' )
+ CALL DLABAD( UNFL, OVFL )
+ ULP = DLAMCH( 'Epsilon' )*DLAMCH( 'Base' )
+ ULPINV = ONE / ULP
+ RTUNFL = SQRT( UNFL )
+ RTOVFL = SQRT( OVFL )
+*
+ DO 20 I = 1, 4
+ ISEED2( I ) = ISEED( I )
+ 20 CONTINUE
+*
+* Loop over sizes, types
+*
+ NERRS = 0
+ NMATS = 0
+*
+ DO 650 JSIZE = 1, NSIZES
+ N = NN( JSIZE )
+ ANINV = ONE / DBLE( MAX( 1, N ) )
+*
+ IF( NSIZES.NE.1 ) THEN
+ MTYPES = MIN( MAXTYP, NTYPES )
+ ELSE
+ MTYPES = MIN( MAXTYP+1, NTYPES )
+ END IF
+*
+ KA9 = 0
+ KB9 = 0
+ DO 640 JTYPE = 1, MTYPES
+ IF( .NOT.DOTYPE( JTYPE ) )
+ $ GO TO 640
+ NMATS = NMATS + 1
+ NTEST = 0
+*
+ DO 30 J = 1, 4
+ IOLDSD( J ) = ISEED( J )
+ 30 CONTINUE
+*
+* 2) Compute "A"
+*
+* Control parameters:
+*
+* KMAGN KMODE KTYPE
+* =1 O(1) clustered 1 zero
+* =2 large clustered 2 identity
+* =3 small exponential (none)
+* =4 arithmetic diagonal, w/ eigenvalues
+* =5 random log hermitian, w/ eigenvalues
+* =6 random (none)
+* =7 random diagonal
+* =8 random hermitian
+* =9 banded, w/ eigenvalues
+*
+ IF( MTYPES.GT.MAXTYP )
+ $ GO TO 90
+*
+ ITYPE = KTYPE( JTYPE )
+ IMODE = KMODE( JTYPE )
+*
+* Compute norm
+*
+ GO TO ( 40, 50, 60 )KMAGN( JTYPE )
+*
+ 40 CONTINUE
+ ANORM = ONE
+ GO TO 70
+*
+ 50 CONTINUE
+ ANORM = ( RTOVFL*ULP )*ANINV
+ GO TO 70
+*
+ 60 CONTINUE
+ ANORM = RTUNFL*N*ULPINV
+ GO TO 70
+*
+ 70 CONTINUE
+*
+ IINFO = 0
+ COND = ULPINV
+*
+* Special Matrices -- Identity & Jordan block
+*
+ IF( ITYPE.EQ.1 ) THEN
+*
+* Zero
+*
+ KA = 0
+ KB = 0
+ CALL DLASET( 'Full', LDA, N, ZERO, ZERO, A, LDA )
+*
+ ELSE IF( ITYPE.EQ.2 ) THEN
+*
+* Identity
+*
+ KA = 0
+ KB = 0
+ CALL DLASET( 'Full', LDA, N, ZERO, ZERO, A, LDA )
+ DO 80 JCOL = 1, N
+ A( JCOL, JCOL ) = ANORM
+ 80 CONTINUE
+*
+ ELSE IF( ITYPE.EQ.4 ) THEN
+*
+* Diagonal Matrix, [Eigen]values Specified
+*
+ KA = 0
+ KB = 0
+ CALL DLATMS( N, N, 'S', ISEED, 'S', WORK, IMODE, COND,
+ $ ANORM, 0, 0, 'N', A, LDA, WORK( N+1 ),
+ $ IINFO )
+*
+ ELSE IF( ITYPE.EQ.5 ) THEN
+*
+* symmetric, eigenvalues specified
+*
+ KA = MAX( 0, N-1 )
+ KB = KA
+ CALL DLATMS( N, N, 'S', ISEED, 'S', WORK, IMODE, COND,
+ $ ANORM, N, N, 'N', A, LDA, WORK( N+1 ),
+ $ IINFO )
+*
+ ELSE IF( ITYPE.EQ.7 ) THEN
+*
+* Diagonal, random eigenvalues
+*
+ KA = 0
+ KB = 0
+ CALL DLATMR( N, N, 'S', ISEED, 'S', WORK, 6, ONE, ONE,
+ $ 'T', 'N', WORK( N+1 ), 1, ONE,
+ $ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, 0, 0,
+ $ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO )
+*
+ ELSE IF( ITYPE.EQ.8 ) THEN
+*
+* symmetric, random eigenvalues
+*
+ KA = MAX( 0, N-1 )
+ KB = KA
+ CALL DLATMR( N, N, 'S', ISEED, 'H', WORK, 6, ONE, ONE,
+ $ 'T', 'N', WORK( N+1 ), 1, ONE,
+ $ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, N, N,
+ $ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO )
+*
+ ELSE IF( ITYPE.EQ.9 ) THEN
+*
+* symmetric banded, eigenvalues specified
+*
+* The following values are used for the half-bandwidths:
+*
+* ka = 1 kb = 1
+* ka = 2 kb = 1
+* ka = 2 kb = 2
+* ka = 3 kb = 1
+* ka = 3 kb = 2
+* ka = 3 kb = 3
+*
+ KB9 = KB9 + 1
+ IF( KB9.GT.KA9 ) THEN
+ KA9 = KA9 + 1
+ KB9 = 1
+ END IF
+ KA = MAX( 0, MIN( N-1, KA9 ) )
+ KB = MAX( 0, MIN( N-1, KB9 ) )
+ CALL DLATMS( N, N, 'S', ISEED, 'S', WORK, IMODE, COND,
+ $ ANORM, KA, KA, 'N', A, LDA, WORK( N+1 ),
+ $ IINFO )
+*
+ ELSE
+*
+ IINFO = 1
+ END IF
+*
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUNIT, FMT = 9999 )'Generator', IINFO, N, JTYPE,
+ $ IOLDSD
+ INFO = ABS( IINFO )
+ RETURN
+ END IF
+*
+ 90 CONTINUE
+*
+ ABSTOL = UNFL + UNFL
+ IF( N.LE.1 ) THEN
+ IL = 1
+ IU = N
+ ELSE
+ IL = 1 + ( N-1 )*DLARND( 1, ISEED2 )
+ IU = 1 + ( N-1 )*DLARND( 1, ISEED2 )
+ IF( IL.GT.IU ) THEN
+ ITEMP = IL
+ IL = IU
+ IU = ITEMP
+ END IF
+ END IF
+*
+* 3) Call DSYGV, DSPGV, DSBGV, SSYGVD, SSPGVD, SSBGVD,
+* DSYGVX, DSPGVX, and DSBGVX, do tests.
+*
+* loop over the three generalized problems
+* IBTYPE = 1: A*x = (lambda)*B*x
+* IBTYPE = 2: A*B*x = (lambda)*x
+* IBTYPE = 3: B*A*x = (lambda)*x
+*
+ DO 630 IBTYPE = 1, 3
+*
+* loop over the setting UPLO
+*
+ DO 620 IBUPLO = 1, 2
+ IF( IBUPLO.EQ.1 )
+ $ UPLO = 'U'
+ IF( IBUPLO.EQ.2 )
+ $ UPLO = 'L'
+*
+* Generate random well-conditioned positive definite
+* matrix B, of bandwidth not greater than that of A.
+*
+ CALL DLATMS( N, N, 'U', ISEED, 'P', WORK, 5, TEN, ONE,
+ $ KB, KB, UPLO, B, LDB, WORK( N+1 ),
+ $ IINFO )
+*
+* Test DSYGV
+*
+ NTEST = NTEST + 1
+*
+ CALL DLACPY( ' ', N, N, A, LDA, Z, LDZ )
+ CALL DLACPY( UPLO, N, N, B, LDB, BB, LDB )
+*
+ CALL DSYGV( IBTYPE, 'V', UPLO, N, Z, LDZ, BB, LDB, D,
+ $ WORK, NWORK, IINFO )
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUNIT, FMT = 9999 )'DSYGV(V,' // UPLO //
+ $ ')', IINFO, N, JTYPE, IOLDSD
+ INFO = ABS( IINFO )
+ IF( IINFO.LT.0 ) THEN
+ RETURN
+ ELSE
+ RESULT( NTEST ) = ULPINV
+ GO TO 100
+ END IF
+ END IF
+*
+* Do Test
+*
+ CALL DSGT01( IBTYPE, UPLO, N, N, A, LDA, B, LDB, Z,
+ $ LDZ, D, WORK, RESULT( NTEST ) )
+*
+* Test DSYGVD
+*
+ NTEST = NTEST + 1
+*
+ CALL DLACPY( ' ', N, N, A, LDA, Z, LDZ )
+ CALL DLACPY( UPLO, N, N, B, LDB, BB, LDB )
+*
+ CALL DSYGVD( IBTYPE, 'V', UPLO, N, Z, LDZ, BB, LDB, D,
+ $ WORK, NWORK, IWORK, LIWORK, IINFO )
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUNIT, FMT = 9999 )'DSYGVD(V,' // UPLO //
+ $ ')', IINFO, N, JTYPE, IOLDSD
+ INFO = ABS( IINFO )
+ IF( IINFO.LT.0 ) THEN
+ RETURN
+ ELSE
+ RESULT( NTEST ) = ULPINV
+ GO TO 100
+ END IF
+ END IF
+*
+* Do Test
+*
+ CALL DSGT01( IBTYPE, UPLO, N, N, A, LDA, B, LDB, Z,
+ $ LDZ, D, WORK, RESULT( NTEST ) )
+*
+* Test DSYGVX
+*
+ NTEST = NTEST + 1
+*
+ CALL DLACPY( ' ', N, N, A, LDA, AB, LDA )
+ CALL DLACPY( UPLO, N, N, B, LDB, BB, LDB )
+*
+ CALL DSYGVX( IBTYPE, 'V', 'A', UPLO, N, AB, LDA, BB,
+ $ LDB, VL, VU, IL, IU, ABSTOL, M, D, Z,
+ $ LDZ, WORK, NWORK, IWORK( N+1 ), IWORK,
+ $ IINFO )
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUNIT, FMT = 9999 )'DSYGVX(V,A' // UPLO //
+ $ ')', IINFO, N, JTYPE, IOLDSD
+ INFO = ABS( IINFO )
+ IF( IINFO.LT.0 ) THEN
+ RETURN
+ ELSE
+ RESULT( NTEST ) = ULPINV
+ GO TO 100
+ END IF
+ END IF
+*
+* Do Test
+*
+ CALL DSGT01( IBTYPE, UPLO, N, N, A, LDA, B, LDB, Z,
+ $ LDZ, D, WORK, RESULT( NTEST ) )
+*
+ NTEST = NTEST + 1
+*
+ CALL DLACPY( ' ', N, N, A, LDA, AB, LDA )
+ CALL DLACPY( UPLO, N, N, B, LDB, BB, LDB )
+*
+* since we do not know the exact eigenvalues of this
+* eigenpair, we just set VL and VU as constants.
+* It is quite possible that there are no eigenvalues
+* in this interval.
+*
+ VL = ZERO
+ VU = ANORM
+ CALL DSYGVX( IBTYPE, 'V', 'V', UPLO, N, AB, LDA, BB,
+ $ LDB, VL, VU, IL, IU, ABSTOL, M, D, Z,
+ $ LDZ, WORK, NWORK, IWORK( N+1 ), IWORK,
+ $ IINFO )
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUNIT, FMT = 9999 )'DSYGVX(V,V,' //
+ $ UPLO // ')', IINFO, N, JTYPE, IOLDSD
+ INFO = ABS( IINFO )
+ IF( IINFO.LT.0 ) THEN
+ RETURN
+ ELSE
+ RESULT( NTEST ) = ULPINV
+ GO TO 100
+ END IF
+ END IF
+*
+* Do Test
+*
+ CALL DSGT01( IBTYPE, UPLO, N, M, A, LDA, B, LDB, Z,
+ $ LDZ, D, WORK, RESULT( NTEST ) )
+*
+ NTEST = NTEST + 1
+*
+ CALL DLACPY( ' ', N, N, A, LDA, AB, LDA )
+ CALL DLACPY( UPLO, N, N, B, LDB, BB, LDB )
+*
+ CALL DSYGVX( IBTYPE, 'V', 'I', UPLO, N, AB, LDA, BB,
+ $ LDB, VL, VU, IL, IU, ABSTOL, M, D, Z,
+ $ LDZ, WORK, NWORK, IWORK( N+1 ), IWORK,
+ $ IINFO )
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUNIT, FMT = 9999 )'DSYGVX(V,I,' //
+ $ UPLO // ')', IINFO, N, JTYPE, IOLDSD
+ INFO = ABS( IINFO )
+ IF( IINFO.LT.0 ) THEN
+ RETURN
+ ELSE
+ RESULT( NTEST ) = ULPINV
+ GO TO 100
+ END IF
+ END IF
+*
+* Do Test
+*
+ CALL DSGT01( IBTYPE, UPLO, N, M, A, LDA, B, LDB, Z,
+ $ LDZ, D, WORK, RESULT( NTEST ) )
+*
+ 100 CONTINUE
+*
+* Test DSPGV
+*
+ NTEST = NTEST + 1
+*
+* Copy the matrices into packed storage.
+*
+ IF( LSAME( UPLO, 'U' ) ) THEN
+ IJ = 1
+ DO 120 J = 1, N
+ DO 110 I = 1, J
+ AP( IJ ) = A( I, J )
+ BP( IJ ) = B( I, J )
+ IJ = IJ + 1
+ 110 CONTINUE
+ 120 CONTINUE
+ ELSE
+ IJ = 1
+ DO 140 J = 1, N
+ DO 130 I = J, N
+ AP( IJ ) = A( I, J )
+ BP( IJ ) = B( I, J )
+ IJ = IJ + 1
+ 130 CONTINUE
+ 140 CONTINUE
+ END IF
+*
+ CALL DSPGV( IBTYPE, 'V', UPLO, N, AP, BP, D, Z, LDZ,
+ $ WORK, IINFO )
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUNIT, FMT = 9999 )'DSPGV(V,' // UPLO //
+ $ ')', IINFO, N, JTYPE, IOLDSD
+ INFO = ABS( IINFO )
+ IF( IINFO.LT.0 ) THEN
+ RETURN
+ ELSE
+ RESULT( NTEST ) = ULPINV
+ GO TO 310
+ END IF
+ END IF
+*
+* Do Test
+*
+ CALL DSGT01( IBTYPE, UPLO, N, N, A, LDA, B, LDB, Z,
+ $ LDZ, D, WORK, RESULT( NTEST ) )
+*
+* Test DSPGVD
+*
+ NTEST = NTEST + 1
+*
+* Copy the matrices into packed storage.
+*
+ IF( LSAME( UPLO, 'U' ) ) THEN
+ IJ = 1
+ DO 160 J = 1, N
+ DO 150 I = 1, J
+ AP( IJ ) = A( I, J )
+ BP( IJ ) = B( I, J )
+ IJ = IJ + 1
+ 150 CONTINUE
+ 160 CONTINUE
+ ELSE
+ IJ = 1
+ DO 180 J = 1, N
+ DO 170 I = J, N
+ AP( IJ ) = A( I, J )
+ BP( IJ ) = B( I, J )
+ IJ = IJ + 1
+ 170 CONTINUE
+ 180 CONTINUE
+ END IF
+*
+ CALL DSPGVD( IBTYPE, 'V', UPLO, N, AP, BP, D, Z, LDZ,
+ $ WORK, NWORK, IWORK, LIWORK, IINFO )
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUNIT, FMT = 9999 )'DSPGVD(V,' // UPLO //
+ $ ')', IINFO, N, JTYPE, IOLDSD
+ INFO = ABS( IINFO )
+ IF( IINFO.LT.0 ) THEN
+ RETURN
+ ELSE
+ RESULT( NTEST ) = ULPINV
+ GO TO 310
+ END IF
+ END IF
+*
+* Do Test
+*
+ CALL DSGT01( IBTYPE, UPLO, N, N, A, LDA, B, LDB, Z,
+ $ LDZ, D, WORK, RESULT( NTEST ) )
+*
+* Test DSPGVX
+*
+ NTEST = NTEST + 1
+*
+* Copy the matrices into packed storage.
+*
+ IF( LSAME( UPLO, 'U' ) ) THEN
+ IJ = 1
+ DO 200 J = 1, N
+ DO 190 I = 1, J
+ AP( IJ ) = A( I, J )
+ BP( IJ ) = B( I, J )
+ IJ = IJ + 1
+ 190 CONTINUE
+ 200 CONTINUE
+ ELSE
+ IJ = 1
+ DO 220 J = 1, N
+ DO 210 I = J, N
+ AP( IJ ) = A( I, J )
+ BP( IJ ) = B( I, J )
+ IJ = IJ + 1
+ 210 CONTINUE
+ 220 CONTINUE
+ END IF
+*
+ CALL DSPGVX( IBTYPE, 'V', 'A', UPLO, N, AP, BP, VL,
+ $ VU, IL, IU, ABSTOL, M, D, Z, LDZ, WORK,
+ $ IWORK( N+1 ), IWORK, INFO )
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUNIT, FMT = 9999 )'DSPGVX(V,A' // UPLO //
+ $ ')', IINFO, N, JTYPE, IOLDSD
+ INFO = ABS( IINFO )
+ IF( IINFO.LT.0 ) THEN
+ RETURN
+ ELSE
+ RESULT( NTEST ) = ULPINV
+ GO TO 310
+ END IF
+ END IF
+*
+* Do Test
+*
+ CALL DSGT01( IBTYPE, UPLO, N, M, A, LDA, B, LDB, Z,
+ $ LDZ, D, WORK, RESULT( NTEST ) )
+*
+ NTEST = NTEST + 1
+*
+* Copy the matrices into packed storage.
+*
+ IF( LSAME( UPLO, 'U' ) ) THEN
+ IJ = 1
+ DO 240 J = 1, N
+ DO 230 I = 1, J
+ AP( IJ ) = A( I, J )
+ BP( IJ ) = B( I, J )
+ IJ = IJ + 1
+ 230 CONTINUE
+ 240 CONTINUE
+ ELSE
+ IJ = 1
+ DO 260 J = 1, N
+ DO 250 I = J, N
+ AP( IJ ) = A( I, J )
+ BP( IJ ) = B( I, J )
+ IJ = IJ + 1
+ 250 CONTINUE
+ 260 CONTINUE
+ END IF
+*
+ VL = ZERO
+ VU = ANORM
+ CALL DSPGVX( IBTYPE, 'V', 'V', UPLO, N, AP, BP, VL,
+ $ VU, IL, IU, ABSTOL, M, D, Z, LDZ, WORK,
+ $ IWORK( N+1 ), IWORK, INFO )
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUNIT, FMT = 9999 )'DSPGVX(V,V' // UPLO //
+ $ ')', IINFO, N, JTYPE, IOLDSD
+ INFO = ABS( IINFO )
+ IF( IINFO.LT.0 ) THEN
+ RETURN
+ ELSE
+ RESULT( NTEST ) = ULPINV
+ GO TO 310
+ END IF
+ END IF
+*
+* Do Test
+*
+ CALL DSGT01( IBTYPE, UPLO, N, M, A, LDA, B, LDB, Z,
+ $ LDZ, D, WORK, RESULT( NTEST ) )
+*
+ NTEST = NTEST + 1
+*
+* Copy the matrices into packed storage.
+*
+ IF( LSAME( UPLO, 'U' ) ) THEN
+ IJ = 1
+ DO 280 J = 1, N
+ DO 270 I = 1, J
+ AP( IJ ) = A( I, J )
+ BP( IJ ) = B( I, J )
+ IJ = IJ + 1
+ 270 CONTINUE
+ 280 CONTINUE
+ ELSE
+ IJ = 1
+ DO 300 J = 1, N
+ DO 290 I = J, N
+ AP( IJ ) = A( I, J )
+ BP( IJ ) = B( I, J )
+ IJ = IJ + 1
+ 290 CONTINUE
+ 300 CONTINUE
+ END IF
+*
+ CALL DSPGVX( IBTYPE, 'V', 'I', UPLO, N, AP, BP, VL,
+ $ VU, IL, IU, ABSTOL, M, D, Z, LDZ, WORK,
+ $ IWORK( N+1 ), IWORK, INFO )
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUNIT, FMT = 9999 )'DSPGVX(V,I' // UPLO //
+ $ ')', IINFO, N, JTYPE, IOLDSD
+ INFO = ABS( IINFO )
+ IF( IINFO.LT.0 ) THEN
+ RETURN
+ ELSE
+ RESULT( NTEST ) = ULPINV
+ GO TO 310
+ END IF
+ END IF
+*
+* Do Test
+*
+ CALL DSGT01( IBTYPE, UPLO, N, M, A, LDA, B, LDB, Z,
+ $ LDZ, D, WORK, RESULT( NTEST ) )
+*
+ 310 CONTINUE
+*
+ IF( IBTYPE.EQ.1 ) THEN
+*
+* TEST DSBGV
+*
+ NTEST = NTEST + 1
+*
+* Copy the matrices into band storage.
+*
+ IF( LSAME( UPLO, 'U' ) ) THEN
+ DO 340 J = 1, N
+ DO 320 I = MAX( 1, J-KA ), J
+ AB( KA+1+I-J, J ) = A( I, J )
+ 320 CONTINUE
+ DO 330 I = MAX( 1, J-KB ), J
+ BB( KB+1+I-J, J ) = B( I, J )
+ 330 CONTINUE
+ 340 CONTINUE
+ ELSE
+ DO 370 J = 1, N
+ DO 350 I = J, MIN( N, J+KA )
+ AB( 1+I-J, J ) = A( I, J )
+ 350 CONTINUE
+ DO 360 I = J, MIN( N, J+KB )
+ BB( 1+I-J, J ) = B( I, J )
+ 360 CONTINUE
+ 370 CONTINUE
+ END IF
+*
+ CALL DSBGV( 'V', UPLO, N, KA, KB, AB, LDA, BB, LDB,
+ $ D, Z, LDZ, WORK, IINFO )
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUNIT, FMT = 9999 )'DSBGV(V,' //
+ $ UPLO // ')', IINFO, N, JTYPE, IOLDSD
+ INFO = ABS( IINFO )
+ IF( IINFO.LT.0 ) THEN
+ RETURN
+ ELSE
+ RESULT( NTEST ) = ULPINV
+ GO TO 620
+ END IF
+ END IF
+*
+* Do Test
+*
+ CALL DSGT01( IBTYPE, UPLO, N, N, A, LDA, B, LDB, Z,
+ $ LDZ, D, WORK, RESULT( NTEST ) )
+*
+* TEST DSBGVD
+*
+ NTEST = NTEST + 1
+*
+* Copy the matrices into band storage.
+*
+ IF( LSAME( UPLO, 'U' ) ) THEN
+ DO 400 J = 1, N
+ DO 380 I = MAX( 1, J-KA ), J
+ AB( KA+1+I-J, J ) = A( I, J )
+ 380 CONTINUE
+ DO 390 I = MAX( 1, J-KB ), J
+ BB( KB+1+I-J, J ) = B( I, J )
+ 390 CONTINUE
+ 400 CONTINUE
+ ELSE
+ DO 430 J = 1, N
+ DO 410 I = J, MIN( N, J+KA )
+ AB( 1+I-J, J ) = A( I, J )
+ 410 CONTINUE
+ DO 420 I = J, MIN( N, J+KB )
+ BB( 1+I-J, J ) = B( I, J )
+ 420 CONTINUE
+ 430 CONTINUE
+ END IF
+*
+ CALL DSBGVD( 'V', UPLO, N, KA, KB, AB, LDA, BB,
+ $ LDB, D, Z, LDZ, WORK, NWORK, IWORK,
+ $ LIWORK, IINFO )
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUNIT, FMT = 9999 )'DSBGVD(V,' //
+ $ UPLO // ')', IINFO, N, JTYPE, IOLDSD
+ INFO = ABS( IINFO )
+ IF( IINFO.LT.0 ) THEN
+ RETURN
+ ELSE
+ RESULT( NTEST ) = ULPINV
+ GO TO 620
+ END IF
+ END IF
+*
+* Do Test
+*
+ CALL DSGT01( IBTYPE, UPLO, N, N, A, LDA, B, LDB, Z,
+ $ LDZ, D, WORK, RESULT( NTEST ) )
+*
+* Test DSBGVX
+*
+ NTEST = NTEST + 1
+*
+* Copy the matrices into band storage.
+*
+ IF( LSAME( UPLO, 'U' ) ) THEN
+ DO 460 J = 1, N
+ DO 440 I = MAX( 1, J-KA ), J
+ AB( KA+1+I-J, J ) = A( I, J )
+ 440 CONTINUE
+ DO 450 I = MAX( 1, J-KB ), J
+ BB( KB+1+I-J, J ) = B( I, J )
+ 450 CONTINUE
+ 460 CONTINUE
+ ELSE
+ DO 490 J = 1, N
+ DO 470 I = J, MIN( N, J+KA )
+ AB( 1+I-J, J ) = A( I, J )
+ 470 CONTINUE
+ DO 480 I = J, MIN( N, J+KB )
+ BB( 1+I-J, J ) = B( I, J )
+ 480 CONTINUE
+ 490 CONTINUE
+ END IF
+*
+ CALL DSBGVX( 'V', 'A', UPLO, N, KA, KB, AB, LDA,
+ $ BB, LDB, BP, MAX( 1, N ), VL, VU, IL,
+ $ IU, ABSTOL, M, D, Z, LDZ, WORK,
+ $ IWORK( N+1 ), IWORK, IINFO )
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUNIT, FMT = 9999 )'DSBGVX(V,A' //
+ $ UPLO // ')', IINFO, N, JTYPE, IOLDSD
+ INFO = ABS( IINFO )
+ IF( IINFO.LT.0 ) THEN
+ RETURN
+ ELSE
+ RESULT( NTEST ) = ULPINV
+ GO TO 620
+ END IF
+ END IF
+*
+* Do Test
+*
+ CALL DSGT01( IBTYPE, UPLO, N, M, A, LDA, B, LDB, Z,
+ $ LDZ, D, WORK, RESULT( NTEST ) )
+*
+*
+ NTEST = NTEST + 1
+*
+* Copy the matrices into band storage.
+*
+ IF( LSAME( UPLO, 'U' ) ) THEN
+ DO 520 J = 1, N
+ DO 500 I = MAX( 1, J-KA ), J
+ AB( KA+1+I-J, J ) = A( I, J )
+ 500 CONTINUE
+ DO 510 I = MAX( 1, J-KB ), J
+ BB( KB+1+I-J, J ) = B( I, J )
+ 510 CONTINUE
+ 520 CONTINUE
+ ELSE
+ DO 550 J = 1, N
+ DO 530 I = J, MIN( N, J+KA )
+ AB( 1+I-J, J ) = A( I, J )
+ 530 CONTINUE
+ DO 540 I = J, MIN( N, J+KB )
+ BB( 1+I-J, J ) = B( I, J )
+ 540 CONTINUE
+ 550 CONTINUE
+ END IF
+*
+ VL = ZERO
+ VU = ANORM
+ CALL DSBGVX( 'V', 'V', UPLO, N, KA, KB, AB, LDA,
+ $ BB, LDB, BP, MAX( 1, N ), VL, VU, IL,
+ $ IU, ABSTOL, M, D, Z, LDZ, WORK,
+ $ IWORK( N+1 ), IWORK, IINFO )
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUNIT, FMT = 9999 )'DSBGVX(V,V' //
+ $ UPLO // ')', IINFO, N, JTYPE, IOLDSD
+ INFO = ABS( IINFO )
+ IF( IINFO.LT.0 ) THEN
+ RETURN
+ ELSE
+ RESULT( NTEST ) = ULPINV
+ GO TO 620
+ END IF
+ END IF
+*
+* Do Test
+*
+ CALL DSGT01( IBTYPE, UPLO, N, M, A, LDA, B, LDB, Z,
+ $ LDZ, D, WORK, RESULT( NTEST ) )
+*
+ NTEST = NTEST + 1
+*
+* Copy the matrices into band storage.
+*
+ IF( LSAME( UPLO, 'U' ) ) THEN
+ DO 580 J = 1, N
+ DO 560 I = MAX( 1, J-KA ), J
+ AB( KA+1+I-J, J ) = A( I, J )
+ 560 CONTINUE
+ DO 570 I = MAX( 1, J-KB ), J
+ BB( KB+1+I-J, J ) = B( I, J )
+ 570 CONTINUE
+ 580 CONTINUE
+ ELSE
+ DO 610 J = 1, N
+ DO 590 I = J, MIN( N, J+KA )
+ AB( 1+I-J, J ) = A( I, J )
+ 590 CONTINUE
+ DO 600 I = J, MIN( N, J+KB )
+ BB( 1+I-J, J ) = B( I, J )
+ 600 CONTINUE
+ 610 CONTINUE
+ END IF
+*
+ CALL DSBGVX( 'V', 'I', UPLO, N, KA, KB, AB, LDA,
+ $ BB, LDB, BP, MAX( 1, N ), VL, VU, IL,
+ $ IU, ABSTOL, M, D, Z, LDZ, WORK,
+ $ IWORK( N+1 ), IWORK, IINFO )
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUNIT, FMT = 9999 )'DSBGVX(V,I' //
+ $ UPLO // ')', IINFO, N, JTYPE, IOLDSD
+ INFO = ABS( IINFO )
+ IF( IINFO.LT.0 ) THEN
+ RETURN
+ ELSE
+ RESULT( NTEST ) = ULPINV
+ GO TO 620
+ END IF
+ END IF
+*
+* Do Test
+*
+ CALL DSGT01( IBTYPE, UPLO, N, M, A, LDA, B, LDB, Z,
+ $ LDZ, D, WORK, RESULT( NTEST ) )
+*
+ END IF
+*
+ 620 CONTINUE
+ 630 CONTINUE
+*
+* End of Loop -- Check for RESULT(j) > THRESH
+*
+ NTESTT = NTESTT + NTEST
+ CALL DLAFTS( 'DSG', N, N, JTYPE, NTEST, RESULT, IOLDSD,
+ $ THRESH, NOUNIT, NERRS )
+ 640 CONTINUE
+ 650 CONTINUE
+*
+* Summary
+*
+ CALL DLASUM( 'DSG', NOUNIT, NERRS, NTESTT )
+*
+ RETURN
+*
+* End of DDRVSG
+*
+ 9999 FORMAT( ' DDRVSG: ', A, ' returned INFO=', I6, '.', / 9X, 'N=',
+ $ I6, ', JTYPE=', I6, ', ISEED=(', 3( I5, ',' ), I5, ')' )
+ END
+ SUBROUTINE DDRVST( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH,
+ $ NOUNIT, A, LDA, D1, D2, D3, D4, EVEIGS, WA1,
+ $ WA2, WA3, U, LDU, V, TAU, Z, WORK, LWORK,
+ $ IWORK, LIWORK, RESULT, INFO )
+*
+* -- LAPACK test routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LDA, LDU, LIWORK, LWORK, NOUNIT, NSIZES,
+ $ NTYPES
+ DOUBLE PRECISION THRESH
+* ..
+* .. Array Arguments ..
+ LOGICAL DOTYPE( * )
+ INTEGER ISEED( 4 ), IWORK( * ), NN( * )
+ DOUBLE PRECISION A( LDA, * ), D1( * ), D2( * ), D3( * ),
+ $ D4( * ), EVEIGS( * ), RESULT( * ), TAU( * ),
+ $ U( LDU, * ), V( LDU, * ), WA1( * ), WA2( * ),
+ $ WA3( * ), WORK( * ), Z( LDU, * )
+* ..
+*
+* Purpose
+* =======
+*
+* DDRVST checks the symmetric eigenvalue problem drivers.
+*
+* DSTEV computes all eigenvalues and, optionally,
+* eigenvectors of a real symmetric tridiagonal matrix.
+*
+* DSTEVX computes selected eigenvalues and, optionally,
+* eigenvectors of a real symmetric tridiagonal matrix.
+*
+* DSTEVR computes selected eigenvalues and, optionally,
+* eigenvectors of a real symmetric tridiagonal matrix
+* using the Relatively Robust Representation where it can.
+*
+* DSYEV computes all eigenvalues and, optionally,
+* eigenvectors of a real symmetric matrix.
+*
+* DSYEVX computes selected eigenvalues and, optionally,
+* eigenvectors of a real symmetric matrix.
+*
+* DSYEVR computes selected eigenvalues and, optionally,
+* eigenvectors of a real symmetric matrix
+* using the Relatively Robust Representation where it can.
+*
+* DSPEV computes all eigenvalues and, optionally,
+* eigenvectors of a real symmetric matrix in packed
+* storage.
+*
+* DSPEVX computes selected eigenvalues and, optionally,
+* eigenvectors of a real symmetric matrix in packed
+* storage.
+*
+* DSBEV computes all eigenvalues and, optionally,
+* eigenvectors of a real symmetric band matrix.
+*
+* DSBEVX computes selected eigenvalues and, optionally,
+* eigenvectors of a real symmetric band matrix.
+*
+* DSYEVD computes all eigenvalues and, optionally,
+* eigenvectors of a real symmetric matrix using
+* a divide and conquer algorithm.
+*
+* DSPEVD computes all eigenvalues and, optionally,
+* eigenvectors of a real symmetric matrix in packed
+* storage, using a divide and conquer algorithm.
+*
+* DSBEVD computes all eigenvalues and, optionally,
+* eigenvectors of a real symmetric band matrix,
+* using a divide and conquer algorithm.
+*
+* When DDRVST is called, a number of matrix "sizes" ("n's") and a
+* number of matrix "types" are specified. For each size ("n")
+* and each type of matrix, one matrix will be generated and used
+* to test the appropriate drivers. For each matrix and each
+* driver routine called, the following tests will be performed:
+*
+* (1) | A - Z D Z' | / ( |A| n ulp )
+*
+* (2) | I - Z Z' | / ( n ulp )
+*
+* (3) | D1 - D2 | / ( |D1| ulp )
+*
+* where Z is the matrix of eigenvectors returned when the
+* eigenvector option is given and D1 and D2 are the eigenvalues
+* returned with and without the eigenvector option.
+*
+* The "sizes" are specified by an array NN(1:NSIZES); the value of
+* each element NN(j) specifies one size.
+* The "types" are specified by a logical array DOTYPE( 1:NTYPES );
+* if DOTYPE(j) is .TRUE., then matrix type "j" will be generated.
+* Currently, the list of possible types is:
+*
+* (1) The zero matrix.
+* (2) The identity matrix.
+*
+* (3) A diagonal matrix with evenly spaced eigenvalues
+* 1, ..., ULP and random signs.
+* (ULP = (first number larger than 1) - 1 )
+* (4) A diagonal matrix with geometrically spaced eigenvalues
+* 1, ..., ULP and random signs.
+* (5) A diagonal matrix with "clustered" eigenvalues
+* 1, ULP, ..., ULP and random signs.
+*
+* (6) Same as (4), but multiplied by SQRT( overflow threshold )
+* (7) Same as (4), but multiplied by SQRT( underflow threshold )
+*
+* (8) A matrix of the form U' D U, where U is orthogonal and
+* D has evenly spaced entries 1, ..., ULP with random signs
+* on the diagonal.
+*
+* (9) A matrix of the form U' D U, where U is orthogonal and
+* D has geometrically spaced entries 1, ..., ULP with random
+* signs on the diagonal.
+*
+* (10) A matrix of the form U' D U, where U is orthogonal and
+* D has "clustered" entries 1, ULP,..., ULP with random
+* signs on the diagonal.
+*
+* (11) Same as (8), but multiplied by SQRT( overflow threshold )
+* (12) Same as (8), but multiplied by SQRT( underflow threshold )
+*
+* (13) Symmetric matrix with random entries chosen from (-1,1).
+* (14) Same as (13), but multiplied by SQRT( overflow threshold )
+* (15) Same as (13), but multiplied by SQRT( underflow threshold )
+* (16) A band matrix with half bandwidth randomly chosen between
+* 0 and N-1, with evenly spaced eigenvalues 1, ..., ULP
+* with random signs.
+* (17) Same as (16), but multiplied by SQRT( overflow threshold )
+* (18) Same as (16), but multiplied by SQRT( underflow threshold )
+*
+* Arguments
+* =========
+*
+* NSIZES INTEGER
+* The number of sizes of matrices to use. If it is zero,
+* DDRVST does nothing. It must be at least zero.
+* Not modified.
+*
+* NN INTEGER array, dimension (NSIZES)
+* An array containing the sizes to be used for the matrices.
+* Zero values will be skipped. The values must be at least
+* zero.
+* Not modified.
+*
+* NTYPES INTEGER
+* The number of elements in DOTYPE. If it is zero, DDRVST
+* does nothing. It must be at least zero. If it is MAXTYP+1
+* and NSIZES is 1, then an additional type, MAXTYP+1 is
+* defined, which is to use whatever matrix is in A. This
+* is only useful if DOTYPE(1:MAXTYP) is .FALSE. and
+* DOTYPE(MAXTYP+1) is .TRUE. .
+* Not modified.
+*
+* DOTYPE LOGICAL array, dimension (NTYPES)
+* If DOTYPE(j) is .TRUE., then for each size in NN a
+* matrix of that size and of type j will be generated.
+* If NTYPES is smaller than the maximum number of types
+* defined (PARAMETER MAXTYP), then types NTYPES+1 through
+* MAXTYP will not be generated. If NTYPES is larger
+* than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES)
+* will be ignored.
+* Not modified.
+*
+* ISEED INTEGER array, dimension (4)
+* On entry ISEED specifies the seed of the random number
+* generator. The array elements should be between 0 and 4095;
+* if not they will be reduced mod 4096. Also, ISEED(4) must
+* be odd. The random number generator uses a linear
+* congruential sequence limited to small integers, and so
+* should produce machine independent random numbers. The
+* values of ISEED are changed on exit, and can be used in the
+* next call to DDRVST to continue the same random number
+* sequence.
+* Modified.
+*
+* THRESH DOUBLE PRECISION
+* A test will count as "failed" if the "error", computed as
+* described above, exceeds THRESH. Note that the error
+* is scaled to be O(1), so THRESH should be a reasonably
+* small multiple of 1, e.g., 10 or 100. In particular,
+* it should not depend on the precision (single vs. double)
+* or the size of the matrix. It must be at least zero.
+* Not modified.
+*
+* NOUNIT INTEGER
+* The FORTRAN unit number for printing out error messages
+* (e.g., if a routine returns IINFO not equal to 0.)
+* Not modified.
+*
+* A DOUBLE PRECISION array, dimension (LDA , max(NN))
+* Used to hold the matrix whose eigenvalues are to be
+* computed. On exit, A contains the last matrix actually
+* used.
+* Modified.
+*
+* LDA INTEGER
+* The leading dimension of A. It must be at
+* least 1 and at least max( NN ).
+* Not modified.
+*
+* D1 DOUBLE PRECISION array, dimension (max(NN))
+* The eigenvalues of A, as computed by DSTEQR simlutaneously
+* with Z. On exit, the eigenvalues in D1 correspond with the
+* matrix in A.
+* Modified.
+*
+* D2 DOUBLE PRECISION array, dimension (max(NN))
+* The eigenvalues of A, as computed by DSTEQR if Z is not
+* computed. On exit, the eigenvalues in D2 correspond with
+* the matrix in A.
+* Modified.
+*
+* D3 DOUBLE PRECISION array, dimension (max(NN))
+* The eigenvalues of A, as computed by DSTERF. On exit, the
+* eigenvalues in D3 correspond with the matrix in A.
+* Modified.
+*
+* D4 DOUBLE PRECISION array, dimension
+*
+* EVEIGS DOUBLE PRECISION array, dimension (max(NN))
+* The eigenvalues as computed by DSTEV('N', ... )
+* (I reserve the right to change this to the output of
+* whichever algorithm computes the most accurate eigenvalues).
+*
+* WA1 DOUBLE PRECISION array, dimension
+*
+* WA2 DOUBLE PRECISION array, dimension
+*
+* WA3 DOUBLE PRECISION array, dimension
+*
+* U DOUBLE PRECISION array, dimension (LDU, max(NN))
+* The orthogonal matrix computed by DSYTRD + DORGTR.
+* Modified.
+*
+* LDU INTEGER
+* The leading dimension of U, Z, and V. It must be at
+* least 1 and at least max( NN ).
+* Not modified.
+*
+* V DOUBLE PRECISION array, dimension (LDU, max(NN))
+* The Housholder vectors computed by DSYTRD in reducing A to
+* tridiagonal form.
+* Modified.
+*
+* TAU DOUBLE PRECISION array, dimension (max(NN))
+* The Householder factors computed by DSYTRD in reducing A
+* to tridiagonal form.
+* Modified.
+*
+* Z DOUBLE PRECISION array, dimension (LDU, max(NN))
+* The orthogonal matrix of eigenvectors computed by DSTEQR,
+* DPTEQR, and DSTEIN.
+* Modified.
+*
+* WORK DOUBLE PRECISION array, dimension (LWORK)
+* Workspace.
+* Modified.
+*
+* LWORK INTEGER
+* The number of entries in WORK. This must be at least
+* 1 + 4 * Nmax + 2 * Nmax * lg Nmax + 4 * Nmax**2
+* where Nmax = max( NN(j), 2 ) and lg = log base 2.
+* Not modified.
+*
+* IWORK INTEGER array,
+* dimension (6 + 6*Nmax + 5 * Nmax * lg Nmax )
+* where Nmax = max( NN(j), 2 ) and lg = log base 2.
+* Workspace.
+* Modified.
+*
+* RESULT DOUBLE PRECISION array, dimension (105)
+* The values computed by the tests described above.
+* The values are currently limited to 1/ulp, to avoid
+* overflow.
+* Modified.
+*
+* INFO INTEGER
+* If 0, then everything ran OK.
+* -1: NSIZES < 0
+* -2: Some NN(j) < 0
+* -3: NTYPES < 0
+* -5: THRESH < 0
+* -9: LDA < 1 or LDA < NMAX, where NMAX is max( NN(j) ).
+* -16: LDU < 1 or LDU < NMAX.
+* -21: LWORK too small.
+* If DLATMR, DLATMS, DSYTRD, DORGTR, DSTEQR, DSTERF,
+* or DORMTR returns an error code, the
+* absolute value of it is returned.
+* Modified.
+*
+*-----------------------------------------------------------------------
+*
+* Some Local Variables and Parameters:
+* ---- ----- --------- --- ----------
+* ZERO, ONE Real 0 and 1.
+* MAXTYP The number of types defined.
+* NTEST The number of tests performed, or which can
+* be performed so far, for the current matrix.
+* NTESTT The total number of tests performed so far.
+* NMAX Largest value in NN.
+* NMATS The number of matrices generated so far.
+* NERRS The number of tests which have exceeded THRESH
+* so far (computed by DLAFTS).
+* COND, IMODE Values to be passed to the matrix generators.
+* ANORM Norm of A; passed to matrix generators.
+*
+* OVFL, UNFL Overflow and underflow thresholds.
+* ULP, ULPINV Finest relative precision and its inverse.
+* RTOVFL, RTUNFL Square roots of the previous 2 values.
+* The following four arrays decode JTYPE:
+* KTYPE(j) The general type (1-10) for type "j".
+* KMODE(j) The MODE value to be passed to the matrix
+* generator for type "j".
+* KMAGN(j) The order of magnitude ( O(1),
+* O(overflow^(1/2) ), O(underflow^(1/2) )
+*
+* The tests performed are: Routine tested
+* 1= | A - U S U' | / ( |A| n ulp ) DSTEV('V', ... )
+* 2= | I - U U' | / ( n ulp ) DSTEV('V', ... )
+* 3= |D(with Z) - D(w/o Z)| / (|D| ulp) DSTEV('N', ... )
+* 4= | A - U S U' | / ( |A| n ulp ) DSTEVX('V','A', ... )
+* 5= | I - U U' | / ( n ulp ) DSTEVX('V','A', ... )
+* 6= |D(with Z) - EVEIGS| / (|D| ulp) DSTEVX('N','A', ... )
+* 7= | A - U S U' | / ( |A| n ulp ) DSTEVR('V','A', ... )
+* 8= | I - U U' | / ( n ulp ) DSTEVR('V','A', ... )
+* 9= |D(with Z) - EVEIGS| / (|D| ulp) DSTEVR('N','A', ... )
+* 10= | A - U S U' | / ( |A| n ulp ) DSTEVX('V','I', ... )
+* 11= | I - U U' | / ( n ulp ) DSTEVX('V','I', ... )
+* 12= |D(with Z) - D(w/o Z)| / (|D| ulp) DSTEVX('N','I', ... )
+* 13= | A - U S U' | / ( |A| n ulp ) DSTEVX('V','V', ... )
+* 14= | I - U U' | / ( n ulp ) DSTEVX('V','V', ... )
+* 15= |D(with Z) - D(w/o Z)| / (|D| ulp) DSTEVX('N','V', ... )
+* 16= | A - U S U' | / ( |A| n ulp ) DSTEVD('V', ... )
+* 17= | I - U U' | / ( n ulp ) DSTEVD('V', ... )
+* 18= |D(with Z) - EVEIGS| / (|D| ulp) DSTEVD('N', ... )
+* 19= | A - U S U' | / ( |A| n ulp ) DSTEVR('V','I', ... )
+* 20= | I - U U' | / ( n ulp ) DSTEVR('V','I', ... )
+* 21= |D(with Z) - D(w/o Z)| / (|D| ulp) DSTEVR('N','I', ... )
+* 22= | A - U S U' | / ( |A| n ulp ) DSTEVR('V','V', ... )
+* 23= | I - U U' | / ( n ulp ) DSTEVR('V','V', ... )
+* 24= |D(with Z) - D(w/o Z)| / (|D| ulp) DSTEVR('N','V', ... )
+*
+* 25= | A - U S U' | / ( |A| n ulp ) DSYEV('L','V', ... )
+* 26= | I - U U' | / ( n ulp ) DSYEV('L','V', ... )
+* 27= |D(with Z) - D(w/o Z)| / (|D| ulp) DSYEV('L','N', ... )
+* 28= | A - U S U' | / ( |A| n ulp ) DSYEVX('L','V','A', ... )
+* 29= | I - U U' | / ( n ulp ) DSYEVX('L','V','A', ... )
+* 30= |D(with Z) - D(w/o Z)| / (|D| ulp) DSYEVX('L','N','A', ... )
+* 31= | A - U S U' | / ( |A| n ulp ) DSYEVX('L','V','I', ... )
+* 32= | I - U U' | / ( n ulp ) DSYEVX('L','V','I', ... )
+* 33= |D(with Z) - D(w/o Z)| / (|D| ulp) DSYEVX('L','N','I', ... )
+* 34= | A - U S U' | / ( |A| n ulp ) DSYEVX('L','V','V', ... )
+* 35= | I - U U' | / ( n ulp ) DSYEVX('L','V','V', ... )
+* 36= |D(with Z) - D(w/o Z)| / (|D| ulp) DSYEVX('L','N','V', ... )
+* 37= | A - U S U' | / ( |A| n ulp ) DSPEV('L','V', ... )
+* 38= | I - U U' | / ( n ulp ) DSPEV('L','V', ... )
+* 39= |D(with Z) - D(w/o Z)| / (|D| ulp) DSPEV('L','N', ... )
+* 40= | A - U S U' | / ( |A| n ulp ) DSPEVX('L','V','A', ... )
+* 41= | I - U U' | / ( n ulp ) DSPEVX('L','V','A', ... )
+* 42= |D(with Z) - D(w/o Z)| / (|D| ulp) DSPEVX('L','N','A', ... )
+* 43= | A - U S U' | / ( |A| n ulp ) DSPEVX('L','V','I', ... )
+* 44= | I - U U' | / ( n ulp ) DSPEVX('L','V','I', ... )
+* 45= |D(with Z) - D(w/o Z)| / (|D| ulp) DSPEVX('L','N','I', ... )
+* 46= | A - U S U' | / ( |A| n ulp ) DSPEVX('L','V','V', ... )
+* 47= | I - U U' | / ( n ulp ) DSPEVX('L','V','V', ... )
+* 48= |D(with Z) - D(w/o Z)| / (|D| ulp) DSPEVX('L','N','V', ... )
+* 49= | A - U S U' | / ( |A| n ulp ) DSBEV('L','V', ... )
+* 50= | I - U U' | / ( n ulp ) DSBEV('L','V', ... )
+* 51= |D(with Z) - D(w/o Z)| / (|D| ulp) DSBEV('L','N', ... )
+* 52= | A - U S U' | / ( |A| n ulp ) DSBEVX('L','V','A', ... )
+* 53= | I - U U' | / ( n ulp ) DSBEVX('L','V','A', ... )
+* 54= |D(with Z) - D(w/o Z)| / (|D| ulp) DSBEVX('L','N','A', ... )
+* 55= | A - U S U' | / ( |A| n ulp ) DSBEVX('L','V','I', ... )
+* 56= | I - U U' | / ( n ulp ) DSBEVX('L','V','I', ... )
+* 57= |D(with Z) - D(w/o Z)| / (|D| ulp) DSBEVX('L','N','I', ... )
+* 58= | A - U S U' | / ( |A| n ulp ) DSBEVX('L','V','V', ... )
+* 59= | I - U U' | / ( n ulp ) DSBEVX('L','V','V', ... )
+* 60= |D(with Z) - D(w/o Z)| / (|D| ulp) DSBEVX('L','N','V', ... )
+* 61= | A - U S U' | / ( |A| n ulp ) DSYEVD('L','V', ... )
+* 62= | I - U U' | / ( n ulp ) DSYEVD('L','V', ... )
+* 63= |D(with Z) - D(w/o Z)| / (|D| ulp) DSYEVD('L','N', ... )
+* 64= | A - U S U' | / ( |A| n ulp ) DSPEVD('L','V', ... )
+* 65= | I - U U' | / ( n ulp ) DSPEVD('L','V', ... )
+* 66= |D(with Z) - D(w/o Z)| / (|D| ulp) DSPEVD('L','N', ... )
+* 67= | A - U S U' | / ( |A| n ulp ) DSBEVD('L','V', ... )
+* 68= | I - U U' | / ( n ulp ) DSBEVD('L','V', ... )
+* 69= |D(with Z) - D(w/o Z)| / (|D| ulp) DSBEVD('L','N', ... )
+* 70= | A - U S U' | / ( |A| n ulp ) DSYEVR('L','V','A', ... )
+* 71= | I - U U' | / ( n ulp ) DSYEVR('L','V','A', ... )
+* 72= |D(with Z) - D(w/o Z)| / (|D| ulp) DSYEVR('L','N','A', ... )
+* 73= | A - U S U' | / ( |A| n ulp ) DSYEVR('L','V','I', ... )
+* 74= | I - U U' | / ( n ulp ) DSYEVR('L','V','I', ... )
+* 75= |D(with Z) - D(w/o Z)| / (|D| ulp) DSYEVR('L','N','I', ... )
+* 76= | A - U S U' | / ( |A| n ulp ) DSYEVR('L','V','V', ... )
+* 77= | I - U U' | / ( n ulp ) DSYEVR('L','V','V', ... )
+* 78= |D(with Z) - D(w/o Z)| / (|D| ulp) DSYEVR('L','N','V', ... )
+*
+* Tests 25 through 78 are repeated (as tests 79 through 132)
+* with UPLO='U'
+*
+* To be added in 1999
+*
+* 79= | A - U S U' | / ( |A| n ulp ) DSPEVR('L','V','A', ... )
+* 80= | I - U U' | / ( n ulp ) DSPEVR('L','V','A', ... )
+* 81= |D(with Z) - D(w/o Z)| / (|D| ulp) DSPEVR('L','N','A', ... )
+* 82= | A - U S U' | / ( |A| n ulp ) DSPEVR('L','V','I', ... )
+* 83= | I - U U' | / ( n ulp ) DSPEVR('L','V','I', ... )
+* 84= |D(with Z) - D(w/o Z)| / (|D| ulp) DSPEVR('L','N','I', ... )
+* 85= | A - U S U' | / ( |A| n ulp ) DSPEVR('L','V','V', ... )
+* 86= | I - U U' | / ( n ulp ) DSPEVR('L','V','V', ... )
+* 87= |D(with Z) - D(w/o Z)| / (|D| ulp) DSPEVR('L','N','V', ... )
+* 88= | A - U S U' | / ( |A| n ulp ) DSBEVR('L','V','A', ... )
+* 89= | I - U U' | / ( n ulp ) DSBEVR('L','V','A', ... )
+* 90= |D(with Z) - D(w/o Z)| / (|D| ulp) DSBEVR('L','N','A', ... )
+* 91= | A - U S U' | / ( |A| n ulp ) DSBEVR('L','V','I', ... )
+* 92= | I - U U' | / ( n ulp ) DSBEVR('L','V','I', ... )
+* 93= |D(with Z) - D(w/o Z)| / (|D| ulp) DSBEVR('L','N','I', ... )
+* 94= | A - U S U' | / ( |A| n ulp ) DSBEVR('L','V','V', ... )
+* 95= | I - U U' | / ( n ulp ) DSBEVR('L','V','V', ... )
+* 96= |D(with Z) - D(w/o Z)| / (|D| ulp) DSBEVR('L','N','V', ... )
+*
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE, TWO, TEN
+ PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0,
+ $ TEN = 10.0D0 )
+ DOUBLE PRECISION HALF
+ PARAMETER ( HALF = 0.5D0 )
+ INTEGER MAXTYP
+ PARAMETER ( MAXTYP = 18 )
+* ..
+* .. Local Scalars ..
+ LOGICAL BADNN
+ CHARACTER UPLO
+ INTEGER I, IDIAG, IHBW, IINFO, IL, IMODE, INDX, IROW,
+ $ ITEMP, ITYPE, IU, IUPLO, J, J1, J2, JCOL,
+ $ JSIZE, JTYPE, KD, LGN, LIWEDC, LWEDC, M, M2,
+ $ M3, MTYPES, N, NERRS, NMATS, NMAX, NTEST,
+ $ NTESTT
+ DOUBLE PRECISION ABSTOL, ANINV, ANORM, COND, OVFL, RTOVFL,
+ $ RTUNFL, TEMP1, TEMP2, TEMP3, ULP, ULPINV, UNFL,
+ $ VL, VU
+* ..
+* .. Local Arrays ..
+ INTEGER IDUMMA( 1 ), IOLDSD( 4 ), ISEED2( 4 ),
+ $ ISEED3( 4 ), KMAGN( MAXTYP ), KMODE( MAXTYP ),
+ $ KTYPE( MAXTYP )
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DLAMCH, DLARND, DSXT1
+ EXTERNAL DLAMCH, DLARND, DSXT1
+* ..
+* .. External Subroutines ..
+ EXTERNAL ALASVM, DLABAD, DLACPY, DLAFTS, DLASET, DLATMR,
+ $ DLATMS, DSBEV, DSBEVD, DSBEVX, DSPEV, DSPEVD,
+ $ DSPEVX, DSTEV, DSTEVD, DSTEVR, DSTEVX, DSTT21,
+ $ DSTT22, DSYEV, DSYEVD, DSYEVR, DSYEVX, DSYT21,
+ $ DSYT22, XERBLA
+* ..
+* .. Scalars in Common ..
+ CHARACTER*6 SRNAMT
+* ..
+* .. Common blocks ..
+ COMMON / SRNAMC / SRNAMT
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, DBLE, INT, LOG, MAX, MIN, SQRT
+* ..
+* .. Data statements ..
+ DATA KTYPE / 1, 2, 5*4, 5*5, 3*8, 3*9 /
+ DATA KMAGN / 2*1, 1, 1, 1, 2, 3, 1, 1, 1, 2, 3, 1,
+ $ 2, 3, 1, 2, 3 /
+ DATA KMODE / 2*0, 4, 3, 1, 4, 4, 4, 3, 1, 4, 4, 0,
+ $ 0, 0, 4, 4, 4 /
+* ..
+* .. Executable Statements ..
+*
+* Keep ftrnchek happy
+*
+ VL = ZERO
+ VU = ZERO
+*
+* 1) Check for errors
+*
+ NTESTT = 0
+ INFO = 0
+*
+ BADNN = .FALSE.
+ NMAX = 1
+ DO 10 J = 1, NSIZES
+ NMAX = MAX( NMAX, NN( J ) )
+ IF( NN( J ).LT.0 )
+ $ BADNN = .TRUE.
+ 10 CONTINUE
+*
+* Check for errors
+*
+ IF( NSIZES.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( BADNN ) THEN
+ INFO = -2
+ ELSE IF( NTYPES.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( LDA.LT.NMAX ) THEN
+ INFO = -9
+ ELSE IF( LDU.LT.NMAX ) THEN
+ INFO = -16
+ ELSE IF( 2*MAX( 2, NMAX )**2.GT.LWORK ) THEN
+ INFO = -21
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DDRVST', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if nothing to do
+*
+ IF( NSIZES.EQ.0 .OR. NTYPES.EQ.0 )
+ $ RETURN
+*
+* More Important constants
+*
+ UNFL = DLAMCH( 'Safe minimum' )
+ OVFL = DLAMCH( 'Overflow' )
+ CALL DLABAD( UNFL, OVFL )
+ ULP = DLAMCH( 'Epsilon' )*DLAMCH( 'Base' )
+ ULPINV = ONE / ULP
+ RTUNFL = SQRT( UNFL )
+ RTOVFL = SQRT( OVFL )
+*
+* Loop over sizes, types
+*
+ DO 20 I = 1, 4
+ ISEED2( I ) = ISEED( I )
+ ISEED3( I ) = ISEED( I )
+ 20 CONTINUE
+*
+ NERRS = 0
+ NMATS = 0
+*
+*
+ DO 1740 JSIZE = 1, NSIZES
+ N = NN( JSIZE )
+ IF( N.GT.0 ) THEN
+ LGN = INT( LOG( DBLE( N ) ) / LOG( TWO ) )
+ IF( 2**LGN.LT.N )
+ $ LGN = LGN + 1
+ IF( 2**LGN.LT.N )
+ $ LGN = LGN + 1
+ LWEDC = 1 + 4*N + 2*N*LGN + 4*N**2
+c LIWEDC = 6 + 6*N + 5*N*LGN
+ LIWEDC = 3 + 5*N
+ ELSE
+ LWEDC = 9
+c LIWEDC = 12
+ LIWEDC = 8
+ END IF
+ ANINV = ONE / DBLE( MAX( 1, N ) )
+*
+ IF( NSIZES.NE.1 ) THEN
+ MTYPES = MIN( MAXTYP, NTYPES )
+ ELSE
+ MTYPES = MIN( MAXTYP+1, NTYPES )
+ END IF
+*
+ DO 1730 JTYPE = 1, MTYPES
+*
+ IF( .NOT.DOTYPE( JTYPE ) )
+ $ GO TO 1730
+ NMATS = NMATS + 1
+ NTEST = 0
+*
+ DO 30 J = 1, 4
+ IOLDSD( J ) = ISEED( J )
+ 30 CONTINUE
+*
+* 2) Compute "A"
+*
+* Control parameters:
+*
+* KMAGN KMODE KTYPE
+* =1 O(1) clustered 1 zero
+* =2 large clustered 2 identity
+* =3 small exponential (none)
+* =4 arithmetic diagonal, (w/ eigenvalues)
+* =5 random log symmetric, w/ eigenvalues
+* =6 random (none)
+* =7 random diagonal
+* =8 random symmetric
+* =9 band symmetric, w/ eigenvalues
+*
+ IF( MTYPES.GT.MAXTYP )
+ $ GO TO 110
+*
+ ITYPE = KTYPE( JTYPE )
+ IMODE = KMODE( JTYPE )
+*
+* Compute norm
+*
+ GO TO ( 40, 50, 60 )KMAGN( JTYPE )
+*
+ 40 CONTINUE
+ ANORM = ONE
+ GO TO 70
+*
+ 50 CONTINUE
+ ANORM = ( RTOVFL*ULP )*ANINV
+ GO TO 70
+*
+ 60 CONTINUE
+ ANORM = RTUNFL*N*ULPINV
+ GO TO 70
+*
+ 70 CONTINUE
+*
+ CALL DLASET( 'Full', LDA, N, ZERO, ZERO, A, LDA )
+ IINFO = 0
+ COND = ULPINV
+*
+* Special Matrices -- Identity & Jordan block
+*
+* Zero
+*
+ IF( ITYPE.EQ.1 ) THEN
+ IINFO = 0
+*
+ ELSE IF( ITYPE.EQ.2 ) THEN
+*
+* Identity
+*
+ DO 80 JCOL = 1, N
+ A( JCOL, JCOL ) = ANORM
+ 80 CONTINUE
+*
+ ELSE IF( ITYPE.EQ.4 ) THEN
+*
+* Diagonal Matrix, [Eigen]values Specified
+*
+ CALL DLATMS( N, N, 'S', ISEED, 'S', WORK, IMODE, COND,
+ $ ANORM, 0, 0, 'N', A, LDA, WORK( N+1 ),
+ $ IINFO )
+*
+ ELSE IF( ITYPE.EQ.5 ) THEN
+*
+* Symmetric, eigenvalues specified
+*
+ CALL DLATMS( N, N, 'S', ISEED, 'S', WORK, IMODE, COND,
+ $ ANORM, N, N, 'N', A, LDA, WORK( N+1 ),
+ $ IINFO )
+*
+ ELSE IF( ITYPE.EQ.7 ) THEN
+*
+* Diagonal, random eigenvalues
+*
+ IDUMMA( 1 ) = 1
+ CALL DLATMR( N, N, 'S', ISEED, 'S', WORK, 6, ONE, ONE,
+ $ 'T', 'N', WORK( N+1 ), 1, ONE,
+ $ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, 0, 0,
+ $ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO )
+*
+ ELSE IF( ITYPE.EQ.8 ) THEN
+*
+* Symmetric, random eigenvalues
+*
+ IDUMMA( 1 ) = 1
+ CALL DLATMR( N, N, 'S', ISEED, 'S', WORK, 6, ONE, ONE,
+ $ 'T', 'N', WORK( N+1 ), 1, ONE,
+ $ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, N, N,
+ $ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO )
+*
+ ELSE IF( ITYPE.EQ.9 ) THEN
+*
+* Symmetric banded, eigenvalues specified
+*
+ IHBW = INT( ( N-1 )*DLARND( 1, ISEED3 ) )
+ CALL DLATMS( N, N, 'S', ISEED, 'S', WORK, IMODE, COND,
+ $ ANORM, IHBW, IHBW, 'Z', U, LDU, WORK( N+1 ),
+ $ IINFO )
+*
+* Store as dense matrix for most routines.
+*
+ CALL DLASET( 'Full', LDA, N, ZERO, ZERO, A, LDA )
+ DO 100 IDIAG = -IHBW, IHBW
+ IROW = IHBW - IDIAG + 1
+ J1 = MAX( 1, IDIAG+1 )
+ J2 = MIN( N, N+IDIAG )
+ DO 90 J = J1, J2
+ I = J - IDIAG
+ A( I, J ) = U( IROW, J )
+ 90 CONTINUE
+ 100 CONTINUE
+ ELSE
+ IINFO = 1
+ END IF
+*
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUNIT, FMT = 9999 )'Generator', IINFO, N, JTYPE,
+ $ IOLDSD
+ INFO = ABS( IINFO )
+ RETURN
+ END IF
+*
+ 110 CONTINUE
+*
+ ABSTOL = UNFL + UNFL
+ IF( N.LE.1 ) THEN
+ IL = 1
+ IU = N
+ ELSE
+ IL = 1 + ( N-1 )*INT( DLARND( 1, ISEED2 ) )
+ IU = 1 + ( N-1 )*INT( DLARND( 1, ISEED2 ) )
+ IF( IL.GT.IU ) THEN
+ ITEMP = IL
+ IL = IU
+ IU = ITEMP
+ END IF
+ END IF
+*
+* 3) If matrix is tridiagonal, call DSTEV and DSTEVX.
+*
+ IF( JTYPE.LE.7 ) THEN
+ NTEST = 1
+ DO 120 I = 1, N
+ D1( I ) = DBLE( A( I, I ) )
+ 120 CONTINUE
+ DO 130 I = 1, N - 1
+ D2( I ) = DBLE( A( I+1, I ) )
+ 130 CONTINUE
+ SRNAMT = 'DSTEV'
+ CALL DSTEV( 'V', N, D1, D2, Z, LDU, WORK, IINFO )
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUNIT, FMT = 9999 )'DSTEV(V)', IINFO, N,
+ $ JTYPE, IOLDSD
+ INFO = ABS( IINFO )
+ IF( IINFO.LT.0 ) THEN
+ RETURN
+ ELSE
+ RESULT( 1 ) = ULPINV
+ RESULT( 2 ) = ULPINV
+ RESULT( 3 ) = ULPINV
+ GO TO 180
+ END IF
+ END IF
+*
+* Do tests 1 and 2.
+*
+ DO 140 I = 1, N
+ D3( I ) = DBLE( A( I, I ) )
+ 140 CONTINUE
+ DO 150 I = 1, N - 1
+ D4( I ) = DBLE( A( I+1, I ) )
+ 150 CONTINUE
+ CALL DSTT21( N, 0, D3, D4, D1, D2, Z, LDU, WORK,
+ $ RESULT( 1 ) )
+*
+ NTEST = 3
+ DO 160 I = 1, N - 1
+ D4( I ) = DBLE( A( I+1, I ) )
+ 160 CONTINUE
+ SRNAMT = 'DSTEV'
+ CALL DSTEV( 'N', N, D3, D4, Z, LDU, WORK, IINFO )
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUNIT, FMT = 9999 )'DSTEV(N)', IINFO, N,
+ $ JTYPE, IOLDSD
+ INFO = ABS( IINFO )
+ IF( IINFO.LT.0 ) THEN
+ RETURN
+ ELSE
+ RESULT( 3 ) = ULPINV
+ GO TO 180
+ END IF
+ END IF
+*
+* Do test 3.
+*
+ TEMP1 = ZERO
+ TEMP2 = ZERO
+ DO 170 J = 1, N
+ TEMP1 = MAX( TEMP1, ABS( D1( J ) ), ABS( D3( J ) ) )
+ TEMP2 = MAX( TEMP2, ABS( D1( J )-D3( J ) ) )
+ 170 CONTINUE
+ RESULT( 3 ) = TEMP2 / MAX( UNFL,
+ $ ULP*MAX( TEMP1, TEMP2 ) )
+*
+ 180 CONTINUE
+*
+ NTEST = 4
+ DO 190 I = 1, N
+ EVEIGS( I ) = D3( I )
+ D1( I ) = DBLE( A( I, I ) )
+ 190 CONTINUE
+ DO 200 I = 1, N - 1
+ D2( I ) = DBLE( A( I+1, I ) )
+ 200 CONTINUE
+ SRNAMT = 'DSTEVX'
+ CALL DSTEVX( 'V', 'A', N, D1, D2, VL, VU, IL, IU, ABSTOL,
+ $ M, WA1, Z, LDU, WORK, IWORK, IWORK( 5*N+1 ),
+ $ IINFO )
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUNIT, FMT = 9999 )'DSTEVX(V,A)', IINFO, N,
+ $ JTYPE, IOLDSD
+ INFO = ABS( IINFO )
+ IF( IINFO.LT.0 ) THEN
+ RETURN
+ ELSE
+ RESULT( 4 ) = ULPINV
+ RESULT( 5 ) = ULPINV
+ RESULT( 6 ) = ULPINV
+ GO TO 250
+ END IF
+ END IF
+ IF( N.GT.0 ) THEN
+ TEMP3 = MAX( ABS( WA1( 1 ) ), ABS( WA1( N ) ) )
+ ELSE
+ TEMP3 = ZERO
+ END IF
+*
+* Do tests 4 and 5.
+*
+ DO 210 I = 1, N
+ D3( I ) = DBLE( A( I, I ) )
+ 210 CONTINUE
+ DO 220 I = 1, N - 1
+ D4( I ) = DBLE( A( I+1, I ) )
+ 220 CONTINUE
+ CALL DSTT21( N, 0, D3, D4, WA1, D2, Z, LDU, WORK,
+ $ RESULT( 4 ) )
+*
+ NTEST = 6
+ DO 230 I = 1, N - 1
+ D4( I ) = DBLE( A( I+1, I ) )
+ 230 CONTINUE
+ SRNAMT = 'DSTEVX'
+ CALL DSTEVX( 'N', 'A', N, D3, D4, VL, VU, IL, IU, ABSTOL,
+ $ M2, WA2, Z, LDU, WORK, IWORK,
+ $ IWORK( 5*N+1 ), IINFO )
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUNIT, FMT = 9999 )'DSTEVX(N,A)', IINFO, N,
+ $ JTYPE, IOLDSD
+ INFO = ABS( IINFO )
+ IF( IINFO.LT.0 ) THEN
+ RETURN
+ ELSE
+ RESULT( 6 ) = ULPINV
+ GO TO 250
+ END IF
+ END IF
+*
+* Do test 6.
+*
+ TEMP1 = ZERO
+ TEMP2 = ZERO
+ DO 240 J = 1, N
+ TEMP1 = MAX( TEMP1, ABS( WA2( J ) ),
+ $ ABS( EVEIGS( J ) ) )
+ TEMP2 = MAX( TEMP2, ABS( WA2( J )-EVEIGS( J ) ) )
+ 240 CONTINUE
+ RESULT( 6 ) = TEMP2 / MAX( UNFL,
+ $ ULP*MAX( TEMP1, TEMP2 ) )
+*
+ 250 CONTINUE
+*
+ NTEST = 7
+ DO 260 I = 1, N
+ D1( I ) = DBLE( A( I, I ) )
+ 260 CONTINUE
+ DO 270 I = 1, N - 1
+ D2( I ) = DBLE( A( I+1, I ) )
+ 270 CONTINUE
+ SRNAMT = 'DSTEVR'
+ CALL DSTEVR( 'V', 'A', N, D1, D2, VL, VU, IL, IU, ABSTOL,
+ $ M, WA1, Z, LDU, IWORK, WORK, LWORK,
+ $ IWORK(2*N+1), LIWORK-2*N, IINFO )
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUNIT, FMT = 9999 )'DSTEVR(V,A)', IINFO, N,
+ $ JTYPE, IOLDSD
+ INFO = ABS( IINFO )
+ IF( IINFO.LT.0 ) THEN
+ RETURN
+ ELSE
+ RESULT( 7 ) = ULPINV
+ RESULT( 8 ) = ULPINV
+ GO TO 320
+ END IF
+ END IF
+ IF( N.GT.0 ) THEN
+ TEMP3 = MAX( ABS( WA1( 1 ) ), ABS( WA1( N ) ) )
+ ELSE
+ TEMP3 = ZERO
+ END IF
+*
+* Do tests 7 and 8.
+*
+ DO 280 I = 1, N
+ D3( I ) = DBLE( A( I, I ) )
+ 280 CONTINUE
+ DO 290 I = 1, N - 1
+ D4( I ) = DBLE( A( I+1, I ) )
+ 290 CONTINUE
+ CALL DSTT21( N, 0, D3, D4, WA1, D2, Z, LDU, WORK,
+ $ RESULT( 7 ) )
+*
+ NTEST = 9
+ DO 300 I = 1, N - 1
+ D4( I ) = DBLE( A( I+1, I ) )
+ 300 CONTINUE
+ SRNAMT = 'DSTEVR'
+ CALL DSTEVR( 'N', 'A', N, D3, D4, VL, VU, IL, IU, ABSTOL,
+ $ M2, WA2, Z, LDU, IWORK, WORK, LWORK,
+ $ IWORK(2*N+1), LIWORK-2*N, IINFO )
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUNIT, FMT = 9999 )'DSTEVR(N,A)', IINFO, N,
+ $ JTYPE, IOLDSD
+ INFO = ABS( IINFO )
+ IF( IINFO.LT.0 ) THEN
+ RETURN
+ ELSE
+ RESULT( 9 ) = ULPINV
+ GO TO 320
+ END IF
+ END IF
+*
+* Do test 9.
+*
+ TEMP1 = ZERO
+ TEMP2 = ZERO
+ DO 310 J = 1, N
+ TEMP1 = MAX( TEMP1, ABS( WA2( J ) ),
+ $ ABS( EVEIGS( J ) ) )
+ TEMP2 = MAX( TEMP2, ABS( WA2( J )-EVEIGS( J ) ) )
+ 310 CONTINUE
+ RESULT( 9 ) = TEMP2 / MAX( UNFL,
+ $ ULP*MAX( TEMP1, TEMP2 ) )
+*
+ 320 CONTINUE
+*
+*
+ NTEST = 10
+ DO 330 I = 1, N
+ D1( I ) = DBLE( A( I, I ) )
+ 330 CONTINUE
+ DO 340 I = 1, N - 1
+ D2( I ) = DBLE( A( I+1, I ) )
+ 340 CONTINUE
+ SRNAMT = 'DSTEVX'
+ CALL DSTEVX( 'V', 'I', N, D1, D2, VL, VU, IL, IU, ABSTOL,
+ $ M2, WA2, Z, LDU, WORK, IWORK,
+ $ IWORK( 5*N+1 ), IINFO )
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUNIT, FMT = 9999 )'DSTEVX(V,I)', IINFO, N,
+ $ JTYPE, IOLDSD
+ INFO = ABS( IINFO )
+ IF( IINFO.LT.0 ) THEN
+ RETURN
+ ELSE
+ RESULT( 10 ) = ULPINV
+ RESULT( 11 ) = ULPINV
+ RESULT( 12 ) = ULPINV
+ GO TO 380
+ END IF
+ END IF
+*
+* Do tests 10 and 11.
+*
+ DO 350 I = 1, N
+ D3( I ) = DBLE( A( I, I ) )
+ 350 CONTINUE
+ DO 360 I = 1, N - 1
+ D4( I ) = DBLE( A( I+1, I ) )
+ 360 CONTINUE
+ CALL DSTT22( N, M2, 0, D3, D4, WA2, D2, Z, LDU, WORK,
+ $ MAX( 1, M2 ), RESULT( 10 ) )
+*
+*
+ NTEST = 12
+ DO 370 I = 1, N - 1
+ D4( I ) = DBLE( A( I+1, I ) )
+ 370 CONTINUE
+ SRNAMT = 'DSTEVX'
+ CALL DSTEVX( 'N', 'I', N, D3, D4, VL, VU, IL, IU, ABSTOL,
+ $ M3, WA3, Z, LDU, WORK, IWORK,
+ $ IWORK( 5*N+1 ), IINFO )
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUNIT, FMT = 9999 )'DSTEVX(N,I)', IINFO, N,
+ $ JTYPE, IOLDSD
+ INFO = ABS( IINFO )
+ IF( IINFO.LT.0 ) THEN
+ RETURN
+ ELSE
+ RESULT( 12 ) = ULPINV
+ GO TO 380
+ END IF
+ END IF
+*
+* Do test 12.
+*
+ TEMP1 = DSXT1( 1, WA2, M2, WA3, M3, ABSTOL, ULP, UNFL )
+ TEMP2 = DSXT1( 1, WA3, M3, WA2, M2, ABSTOL, ULP, UNFL )
+ RESULT( 12 ) = ( TEMP1+TEMP2 ) / MAX( UNFL, ULP*TEMP3 )
+*
+ 380 CONTINUE
+*
+ NTEST = 12
+ IF( N.GT.0 ) THEN
+ IF( IL.NE.1 ) THEN
+ VL = WA1( IL ) - MAX( HALF*
+ $ ( WA1( IL )-WA1( IL-1 ) ), TEN*ULP*TEMP3,
+ $ TEN*RTUNFL )
+ ELSE
+ VL = WA1( 1 ) - MAX( HALF*( WA1( N )-WA1( 1 ) ),
+ $ TEN*ULP*TEMP3, TEN*RTUNFL )
+ END IF
+ IF( IU.NE.N ) THEN
+ VU = WA1( IU ) + MAX( HALF*
+ $ ( WA1( IU+1 )-WA1( IU ) ), TEN*ULP*TEMP3,
+ $ TEN*RTUNFL )
+ ELSE
+ VU = WA1( N ) + MAX( HALF*( WA1( N )-WA1( 1 ) ),
+ $ TEN*ULP*TEMP3, TEN*RTUNFL )
+ END IF
+ ELSE
+ VL = ZERO
+ VU = ONE
+ END IF
+*
+ DO 390 I = 1, N
+ D1( I ) = DBLE( A( I, I ) )
+ 390 CONTINUE
+ DO 400 I = 1, N - 1
+ D2( I ) = DBLE( A( I+1, I ) )
+ 400 CONTINUE
+ SRNAMT = 'DSTEVX'
+ CALL DSTEVX( 'V', 'V', N, D1, D2, VL, VU, IL, IU, ABSTOL,
+ $ M2, WA2, Z, LDU, WORK, IWORK,
+ $ IWORK( 5*N+1 ), IINFO )
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUNIT, FMT = 9999 )'DSTEVX(V,V)', IINFO, N,
+ $ JTYPE, IOLDSD
+ INFO = ABS( IINFO )
+ IF( IINFO.LT.0 ) THEN
+ RETURN
+ ELSE
+ RESULT( 13 ) = ULPINV
+ RESULT( 14 ) = ULPINV
+ RESULT( 15 ) = ULPINV
+ GO TO 440
+ END IF
+ END IF
+*
+ IF( M2.EQ.0 .AND. N.GT.0 ) THEN
+ RESULT( 13 ) = ULPINV
+ RESULT( 14 ) = ULPINV
+ RESULT( 15 ) = ULPINV
+ GO TO 440
+ END IF
+*
+* Do tests 13 and 14.
+*
+ DO 410 I = 1, N
+ D3( I ) = DBLE( A( I, I ) )
+ 410 CONTINUE
+ DO 420 I = 1, N - 1
+ D4( I ) = DBLE( A( I+1, I ) )
+ 420 CONTINUE
+ CALL DSTT22( N, M2, 0, D3, D4, WA2, D2, Z, LDU, WORK,
+ $ MAX( 1, M2 ), RESULT( 13 ) )
+*
+ NTEST = 15
+ DO 430 I = 1, N - 1
+ D4( I ) = DBLE( A( I+1, I ) )
+ 430 CONTINUE
+ SRNAMT = 'DSTEVX'
+ CALL DSTEVX( 'N', 'V', N, D3, D4, VL, VU, IL, IU, ABSTOL,
+ $ M3, WA3, Z, LDU, WORK, IWORK,
+ $ IWORK( 5*N+1 ), IINFO )
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUNIT, FMT = 9999 )'DSTEVX(N,V)', IINFO, N,
+ $ JTYPE, IOLDSD
+ INFO = ABS( IINFO )
+ IF( IINFO.LT.0 ) THEN
+ RETURN
+ ELSE
+ RESULT( 15 ) = ULPINV
+ GO TO 440
+ END IF
+ END IF
+*
+* Do test 15.
+*
+ TEMP1 = DSXT1( 1, WA2, M2, WA3, M3, ABSTOL, ULP, UNFL )
+ TEMP2 = DSXT1( 1, WA3, M3, WA2, M2, ABSTOL, ULP, UNFL )
+ RESULT( 15 ) = ( TEMP1+TEMP2 ) / MAX( UNFL, TEMP3*ULP )
+*
+ 440 CONTINUE
+*
+ NTEST = 16
+ DO 450 I = 1, N
+ D1( I ) = DBLE( A( I, I ) )
+ 450 CONTINUE
+ DO 460 I = 1, N - 1
+ D2( I ) = DBLE( A( I+1, I ) )
+ 460 CONTINUE
+ SRNAMT = 'DSTEVD'
+ CALL DSTEVD( 'V', N, D1, D2, Z, LDU, WORK, LWEDC, IWORK,
+ $ LIWEDC, IINFO )
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUNIT, FMT = 9999 )'DSTEVD(V)', IINFO, N,
+ $ JTYPE, IOLDSD
+ INFO = ABS( IINFO )
+ IF( IINFO.LT.0 ) THEN
+ RETURN
+ ELSE
+ RESULT( 16 ) = ULPINV
+ RESULT( 17 ) = ULPINV
+ RESULT( 18 ) = ULPINV
+ GO TO 510
+ END IF
+ END IF
+*
+* Do tests 16 and 17.
+*
+ DO 470 I = 1, N
+ D3( I ) = DBLE( A( I, I ) )
+ 470 CONTINUE
+ DO 480 I = 1, N - 1
+ D4( I ) = DBLE( A( I+1, I ) )
+ 480 CONTINUE
+ CALL DSTT21( N, 0, D3, D4, D1, D2, Z, LDU, WORK,
+ $ RESULT( 16 ) )
+*
+ NTEST = 18
+ DO 490 I = 1, N - 1
+ D4( I ) = DBLE( A( I+1, I ) )
+ 490 CONTINUE
+ SRNAMT = 'DSTEVD'
+ CALL DSTEVD( 'N', N, D3, D4, Z, LDU, WORK, LWEDC, IWORK,
+ $ LIWEDC, IINFO )
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUNIT, FMT = 9999 )'DSTEVD(N)', IINFO, N,
+ $ JTYPE, IOLDSD
+ INFO = ABS( IINFO )
+ IF( IINFO.LT.0 ) THEN
+ RETURN
+ ELSE
+ RESULT( 18 ) = ULPINV
+ GO TO 510
+ END IF
+ END IF
+*
+* Do test 18.
+*
+ TEMP1 = ZERO
+ TEMP2 = ZERO
+ DO 500 J = 1, N
+ TEMP1 = MAX( TEMP1, ABS( EVEIGS( J ) ),
+ $ ABS( D3( J ) ) )
+ TEMP2 = MAX( TEMP2, ABS( EVEIGS( J )-D3( J ) ) )
+ 500 CONTINUE
+ RESULT( 18 ) = TEMP2 / MAX( UNFL,
+ $ ULP*MAX( TEMP1, TEMP2 ) )
+*
+ 510 CONTINUE
+*
+ NTEST = 19
+ DO 520 I = 1, N
+ D1( I ) = DBLE( A( I, I ) )
+ 520 CONTINUE
+ DO 530 I = 1, N - 1
+ D2( I ) = DBLE( A( I+1, I ) )
+ 530 CONTINUE
+ SRNAMT = 'DSTEVR'
+ CALL DSTEVR( 'V', 'I', N, D1, D2, VL, VU, IL, IU, ABSTOL,
+ $ M2, WA2, Z, LDU, IWORK, WORK, LWORK,
+ $ IWORK(2*N+1), LIWORK-2*N, IINFO )
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUNIT, FMT = 9999 )'DSTEVR(V,I)', IINFO, N,
+ $ JTYPE, IOLDSD
+ INFO = ABS( IINFO )
+ IF( IINFO.LT.0 ) THEN
+ RETURN
+ ELSE
+ RESULT( 19 ) = ULPINV
+ RESULT( 20 ) = ULPINV
+ RESULT( 21 ) = ULPINV
+ GO TO 570
+ END IF
+ END IF
+*
+* DO tests 19 and 20.
+*
+ DO 540 I = 1, N
+ D3( I ) = DBLE( A( I, I ) )
+ 540 CONTINUE
+ DO 550 I = 1, N - 1
+ D4( I ) = DBLE( A( I+1, I ) )
+ 550 CONTINUE
+ CALL DSTT22( N, M2, 0, D3, D4, WA2, D2, Z, LDU, WORK,
+ $ MAX( 1, M2 ), RESULT( 19 ) )
+*
+*
+ NTEST = 21
+ DO 560 I = 1, N - 1
+ D4( I ) = DBLE( A( I+1, I ) )
+ 560 CONTINUE
+ SRNAMT = 'DSTEVR'
+ CALL DSTEVR( 'N', 'I', N, D3, D4, VL, VU, IL, IU, ABSTOL,
+ $ M3, WA3, Z, LDU, IWORK, WORK, LWORK,
+ $ IWORK(2*N+1), LIWORK-2*N, IINFO )
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUNIT, FMT = 9999 )'DSTEVR(N,I)', IINFO, N,
+ $ JTYPE, IOLDSD
+ INFO = ABS( IINFO )
+ IF( IINFO.LT.0 ) THEN
+ RETURN
+ ELSE
+ RESULT( 21 ) = ULPINV
+ GO TO 570
+ END IF
+ END IF
+*
+* Do test 21.
+*
+ TEMP1 = DSXT1( 1, WA2, M2, WA3, M3, ABSTOL, ULP, UNFL )
+ TEMP2 = DSXT1( 1, WA3, M3, WA2, M2, ABSTOL, ULP, UNFL )
+ RESULT( 21 ) = ( TEMP1+TEMP2 ) / MAX( UNFL, ULP*TEMP3 )
+*
+ 570 CONTINUE
+*
+ NTEST = 21
+ IF( N.GT.0 ) THEN
+ IF( IL.NE.1 ) THEN
+ VL = WA1( IL ) - MAX( HALF*
+ $ ( WA1( IL )-WA1( IL-1 ) ), TEN*ULP*TEMP3,
+ $ TEN*RTUNFL )
+ ELSE
+ VL = WA1( 1 ) - MAX( HALF*( WA1( N )-WA1( 1 ) ),
+ $ TEN*ULP*TEMP3, TEN*RTUNFL )
+ END IF
+ IF( IU.NE.N ) THEN
+ VU = WA1( IU ) + MAX( HALF*
+ $ ( WA1( IU+1 )-WA1( IU ) ), TEN*ULP*TEMP3,
+ $ TEN*RTUNFL )
+ ELSE
+ VU = WA1( N ) + MAX( HALF*( WA1( N )-WA1( 1 ) ),
+ $ TEN*ULP*TEMP3, TEN*RTUNFL )
+ END IF
+ ELSE
+ VL = ZERO
+ VU = ONE
+ END IF
+*
+ DO 580 I = 1, N
+ D1( I ) = DBLE( A( I, I ) )
+ 580 CONTINUE
+ DO 590 I = 1, N - 1
+ D2( I ) = DBLE( A( I+1, I ) )
+ 590 CONTINUE
+ SRNAMT = 'DSTEVR'
+ CALL DSTEVR( 'V', 'V', N, D1, D2, VL, VU, IL, IU, ABSTOL,
+ $ M2, WA2, Z, LDU, IWORK, WORK, LWORK,
+ $ IWORK(2*N+1), LIWORK-2*N, IINFO )
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUNIT, FMT = 9999 )'DSTEVR(V,V)', IINFO, N,
+ $ JTYPE, IOLDSD
+ INFO = ABS( IINFO )
+ IF( IINFO.LT.0 ) THEN
+ RETURN
+ ELSE
+ RESULT( 22 ) = ULPINV
+ RESULT( 23 ) = ULPINV
+ RESULT( 24 ) = ULPINV
+ GO TO 630
+ END IF
+ END IF
+*
+ IF( M2.EQ.0 .AND. N.GT.0 ) THEN
+ RESULT( 22 ) = ULPINV
+ RESULT( 23 ) = ULPINV
+ RESULT( 24 ) = ULPINV
+ GO TO 630
+ END IF
+*
+* Do tests 22 and 23.
+*
+ DO 600 I = 1, N
+ D3( I ) = DBLE( A( I, I ) )
+ 600 CONTINUE
+ DO 610 I = 1, N - 1
+ D4( I ) = DBLE( A( I+1, I ) )
+ 610 CONTINUE
+ CALL DSTT22( N, M2, 0, D3, D4, WA2, D2, Z, LDU, WORK,
+ $ MAX( 1, M2 ), RESULT( 22 ) )
+*
+ NTEST = 24
+ DO 620 I = 1, N - 1
+ D4( I ) = DBLE( A( I+1, I ) )
+ 620 CONTINUE
+ SRNAMT = 'DSTEVR'
+ CALL DSTEVR( 'N', 'V', N, D3, D4, VL, VU, IL, IU, ABSTOL,
+ $ M3, WA3, Z, LDU, IWORK, WORK, LWORK,
+ $ IWORK(2*N+1), LIWORK-2*N, IINFO )
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUNIT, FMT = 9999 )'DSTEVR(N,V)', IINFO, N,
+ $ JTYPE, IOLDSD
+ INFO = ABS( IINFO )
+ IF( IINFO.LT.0 ) THEN
+ RETURN
+ ELSE
+ RESULT( 24 ) = ULPINV
+ GO TO 630
+ END IF
+ END IF
+*
+* Do test 24.
+*
+ TEMP1 = DSXT1( 1, WA2, M2, WA3, M3, ABSTOL, ULP, UNFL )
+ TEMP2 = DSXT1( 1, WA3, M3, WA2, M2, ABSTOL, ULP, UNFL )
+ RESULT( 24 ) = ( TEMP1+TEMP2 ) / MAX( UNFL, TEMP3*ULP )
+*
+ 630 CONTINUE
+*
+*
+*
+ ELSE
+*
+ DO 640 I = 1, 24
+ RESULT( I ) = ZERO
+ 640 CONTINUE
+ NTEST = 24
+ END IF
+*
+* Perform remaining tests storing upper or lower triangular
+* part of matrix.
+*
+ DO 1720 IUPLO = 0, 1
+ IF( IUPLO.EQ.0 ) THEN
+ UPLO = 'L'
+ ELSE
+ UPLO = 'U'
+ END IF
+*
+* 4) Call DSYEV and DSYEVX.
+*
+ CALL DLACPY( ' ', N, N, A, LDA, V, LDU )
+*
+ NTEST = NTEST + 1
+ SRNAMT = 'DSYEV'
+ CALL DSYEV( 'V', UPLO, N, A, LDU, D1, WORK, LWORK,
+ $ IINFO )
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUNIT, FMT = 9999 )'DSYEV(V,' // UPLO // ')',
+ $ IINFO, N, JTYPE, IOLDSD
+ INFO = ABS( IINFO )
+ IF( IINFO.LT.0 ) THEN
+ RETURN
+ ELSE
+ RESULT( NTEST ) = ULPINV
+ RESULT( NTEST+1 ) = ULPINV
+ RESULT( NTEST+2 ) = ULPINV
+ GO TO 660
+ END IF
+ END IF
+*
+* Do tests 25 and 26 (or +54)
+*
+ CALL DSYT21( 1, UPLO, N, 0, V, LDU, D1, D2, A, LDU, Z,
+ $ LDU, TAU, WORK, RESULT( NTEST ) )
+*
+ CALL DLACPY( ' ', N, N, V, LDU, A, LDA )
+*
+ NTEST = NTEST + 2
+ SRNAMT = 'DSYEV'
+ CALL DSYEV( 'N', UPLO, N, A, LDU, D3, WORK, LWORK,
+ $ IINFO )
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUNIT, FMT = 9999 )'DSYEV(N,' // UPLO // ')',
+ $ IINFO, N, JTYPE, IOLDSD
+ INFO = ABS( IINFO )
+ IF( IINFO.LT.0 ) THEN
+ RETURN
+ ELSE
+ RESULT( NTEST ) = ULPINV
+ GO TO 660
+ END IF
+ END IF
+*
+* Do test 27 (or +54)
+*
+ TEMP1 = ZERO
+ TEMP2 = ZERO
+ DO 650 J = 1, N
+ TEMP1 = MAX( TEMP1, ABS( D1( J ) ), ABS( D3( J ) ) )
+ TEMP2 = MAX( TEMP2, ABS( D1( J )-D3( J ) ) )
+ 650 CONTINUE
+ RESULT( NTEST ) = TEMP2 / MAX( UNFL,
+ $ ULP*MAX( TEMP1, TEMP2 ) )
+*
+ 660 CONTINUE
+ CALL DLACPY( ' ', N, N, V, LDU, A, LDA )
+*
+ NTEST = NTEST + 1
+*
+ IF( N.GT.0 ) THEN
+ TEMP3 = MAX( ABS( D1( 1 ) ), ABS( D1( N ) ) )
+ IF( IL.NE.1 ) THEN
+ VL = D1( IL ) - MAX( HALF*( D1( IL )-D1( IL-1 ) ),
+ $ TEN*ULP*TEMP3, TEN*RTUNFL )
+ ELSE IF( N.GT.0 ) THEN
+ VL = D1( 1 ) - MAX( HALF*( D1( N )-D1( 1 ) ),
+ $ TEN*ULP*TEMP3, TEN*RTUNFL )
+ END IF
+ IF( IU.NE.N ) THEN
+ VU = D1( IU ) + MAX( HALF*( D1( IU+1 )-D1( IU ) ),
+ $ TEN*ULP*TEMP3, TEN*RTUNFL )
+ ELSE IF( N.GT.0 ) THEN
+ VU = D1( N ) + MAX( HALF*( D1( N )-D1( 1 ) ),
+ $ TEN*ULP*TEMP3, TEN*RTUNFL )
+ END IF
+ ELSE
+ TEMP3 = ZERO
+ VL = ZERO
+ VU = ONE
+ END IF
+*
+ SRNAMT = 'DSYEVX'
+ CALL DSYEVX( 'V', 'A', UPLO, N, A, LDU, VL, VU, IL, IU,
+ $ ABSTOL, M, WA1, Z, LDU, WORK, LWORK, IWORK,
+ $ IWORK( 5*N+1 ), IINFO )
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUNIT, FMT = 9999 )'DSYEVX(V,A,' // UPLO //
+ $ ')', IINFO, N, JTYPE, IOLDSD
+ INFO = ABS( IINFO )
+ IF( IINFO.LT.0 ) THEN
+ RETURN
+ ELSE
+ RESULT( NTEST ) = ULPINV
+ RESULT( NTEST+1 ) = ULPINV
+ RESULT( NTEST+2 ) = ULPINV
+ GO TO 680
+ END IF
+ END IF
+*
+* Do tests 28 and 29 (or +54)
+*
+ CALL DLACPY( ' ', N, N, V, LDU, A, LDA )
+*
+ CALL DSYT21( 1, UPLO, N, 0, A, LDU, D1, D2, Z, LDU, V,
+ $ LDU, TAU, WORK, RESULT( NTEST ) )
+*
+ NTEST = NTEST + 2
+ SRNAMT = 'DSYEVX'
+ CALL DSYEVX( 'N', 'A', UPLO, N, A, LDU, VL, VU, IL, IU,
+ $ ABSTOL, M2, WA2, Z, LDU, WORK, LWORK, IWORK,
+ $ IWORK( 5*N+1 ), IINFO )
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUNIT, FMT = 9999 )'DSYEVX(N,A,' // UPLO //
+ $ ')', IINFO, N, JTYPE, IOLDSD
+ INFO = ABS( IINFO )
+ IF( IINFO.LT.0 ) THEN
+ RETURN
+ ELSE
+ RESULT( NTEST ) = ULPINV
+ GO TO 680
+ END IF
+ END IF
+*
+* Do test 30 (or +54)
+*
+ TEMP1 = ZERO
+ TEMP2 = ZERO
+ DO 670 J = 1, N
+ TEMP1 = MAX( TEMP1, ABS( WA1( J ) ), ABS( WA2( J ) ) )
+ TEMP2 = MAX( TEMP2, ABS( WA1( J )-WA2( J ) ) )
+ 670 CONTINUE
+ RESULT( NTEST ) = TEMP2 / MAX( UNFL,
+ $ ULP*MAX( TEMP1, TEMP2 ) )
+*
+ 680 CONTINUE
+*
+ NTEST = NTEST + 1
+ CALL DLACPY( ' ', N, N, V, LDU, A, LDA )
+ SRNAMT = 'DSYEVX'
+ CALL DSYEVX( 'V', 'I', UPLO, N, A, LDU, VL, VU, IL, IU,
+ $ ABSTOL, M2, WA2, Z, LDU, WORK, LWORK, IWORK,
+ $ IWORK( 5*N+1 ), IINFO )
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUNIT, FMT = 9999 )'DSYEVX(V,I,' // UPLO //
+ $ ')', IINFO, N, JTYPE, IOLDSD
+ INFO = ABS( IINFO )
+ IF( IINFO.LT.0 ) THEN
+ RETURN
+ ELSE
+ RESULT( NTEST ) = ULPINV
+ RESULT( NTEST+1 ) = ULPINV
+ RESULT( NTEST+2 ) = ULPINV
+ GO TO 690
+ END IF
+ END IF
+*
+* Do tests 31 and 32 (or +54)
+*
+ CALL DLACPY( ' ', N, N, V, LDU, A, LDA )
+*
+ CALL DSYT22( 1, UPLO, N, M2, 0, A, LDU, WA2, D2, Z, LDU,
+ $ V, LDU, TAU, WORK, RESULT( NTEST ) )
+*
+ NTEST = NTEST + 2
+ CALL DLACPY( ' ', N, N, V, LDU, A, LDA )
+ SRNAMT = 'DSYEVX'
+ CALL DSYEVX( 'N', 'I', UPLO, N, A, LDU, VL, VU, IL, IU,
+ $ ABSTOL, M3, WA3, Z, LDU, WORK, LWORK, IWORK,
+ $ IWORK( 5*N+1 ), IINFO )
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUNIT, FMT = 9999 )'DSYEVX(N,I,' // UPLO //
+ $ ')', IINFO, N, JTYPE, IOLDSD
+ INFO = ABS( IINFO )
+ IF( IINFO.LT.0 ) THEN
+ RETURN
+ ELSE
+ RESULT( NTEST ) = ULPINV
+ GO TO 690
+ END IF
+ END IF
+*
+* Do test 33 (or +54)
+*
+ TEMP1 = DSXT1( 1, WA2, M2, WA3, M3, ABSTOL, ULP, UNFL )
+ TEMP2 = DSXT1( 1, WA3, M3, WA2, M2, ABSTOL, ULP, UNFL )
+ RESULT( NTEST ) = ( TEMP1+TEMP2 ) /
+ $ MAX( UNFL, ULP*TEMP3 )
+ 690 CONTINUE
+*
+ NTEST = NTEST + 1
+ CALL DLACPY( ' ', N, N, V, LDU, A, LDA )
+ SRNAMT = 'DSYEVX'
+ CALL DSYEVX( 'V', 'V', UPLO, N, A, LDU, VL, VU, IL, IU,
+ $ ABSTOL, M2, WA2, Z, LDU, WORK, LWORK, IWORK,
+ $ IWORK( 5*N+1 ), IINFO )
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUNIT, FMT = 9999 )'DSYEVX(V,V,' // UPLO //
+ $ ')', IINFO, N, JTYPE, IOLDSD
+ INFO = ABS( IINFO )
+ IF( IINFO.LT.0 ) THEN
+ RETURN
+ ELSE
+ RESULT( NTEST ) = ULPINV
+ RESULT( NTEST+1 ) = ULPINV
+ RESULT( NTEST+2 ) = ULPINV
+ GO TO 700
+ END IF
+ END IF
+*
+* Do tests 34 and 35 (or +54)
+*
+ CALL DLACPY( ' ', N, N, V, LDU, A, LDA )
+*
+ CALL DSYT22( 1, UPLO, N, M2, 0, A, LDU, WA2, D2, Z, LDU,
+ $ V, LDU, TAU, WORK, RESULT( NTEST ) )
+*
+ NTEST = NTEST + 2
+ CALL DLACPY( ' ', N, N, V, LDU, A, LDA )
+ SRNAMT = 'DSYEVX'
+ CALL DSYEVX( 'N', 'V', UPLO, N, A, LDU, VL, VU, IL, IU,
+ $ ABSTOL, M3, WA3, Z, LDU, WORK, LWORK, IWORK,
+ $ IWORK( 5*N+1 ), IINFO )
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUNIT, FMT = 9999 )'DSYEVX(N,V,' // UPLO //
+ $ ')', IINFO, N, JTYPE, IOLDSD
+ INFO = ABS( IINFO )
+ IF( IINFO.LT.0 ) THEN
+ RETURN
+ ELSE
+ RESULT( NTEST ) = ULPINV
+ GO TO 700
+ END IF
+ END IF
+*
+ IF( M3.EQ.0 .AND. N.GT.0 ) THEN
+ RESULT( NTEST ) = ULPINV
+ GO TO 700
+ END IF
+*
+* Do test 36 (or +54)
+*
+ TEMP1 = DSXT1( 1, WA2, M2, WA3, M3, ABSTOL, ULP, UNFL )
+ TEMP2 = DSXT1( 1, WA3, M3, WA2, M2, ABSTOL, ULP, UNFL )
+ IF( N.GT.0 ) THEN
+ TEMP3 = MAX( ABS( WA1( 1 ) ), ABS( WA1( N ) ) )
+ ELSE
+ TEMP3 = ZERO
+ END IF
+ RESULT( NTEST ) = ( TEMP1+TEMP2 ) /
+ $ MAX( UNFL, TEMP3*ULP )
+*
+ 700 CONTINUE
+*
+* 5) Call DSPEV and DSPEVX.
+*
+ CALL DLACPY( ' ', N, N, V, LDU, A, LDA )
+*
+* Load array WORK with the upper or lower triangular
+* part of the matrix in packed form.
+*
+ IF( IUPLO.EQ.1 ) THEN
+ INDX = 1
+ DO 720 J = 1, N
+ DO 710 I = 1, J
+ WORK( INDX ) = A( I, J )
+ INDX = INDX + 1
+ 710 CONTINUE
+ 720 CONTINUE
+ ELSE
+ INDX = 1
+ DO 740 J = 1, N
+ DO 730 I = J, N
+ WORK( INDX ) = A( I, J )
+ INDX = INDX + 1
+ 730 CONTINUE
+ 740 CONTINUE
+ END IF
+*
+ NTEST = NTEST + 1
+ SRNAMT = 'DSPEV'
+ CALL DSPEV( 'V', UPLO, N, WORK, D1, Z, LDU, V, IINFO )
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUNIT, FMT = 9999 )'DSPEV(V,' // UPLO // ')',
+ $ IINFO, N, JTYPE, IOLDSD
+ INFO = ABS( IINFO )
+ IF( IINFO.LT.0 ) THEN
+ RETURN
+ ELSE
+ RESULT( NTEST ) = ULPINV
+ RESULT( NTEST+1 ) = ULPINV
+ RESULT( NTEST+2 ) = ULPINV
+ GO TO 800
+ END IF
+ END IF
+*
+* Do tests 37 and 38 (or +54)
+*
+ CALL DSYT21( 1, UPLO, N, 0, A, LDA, D1, D2, Z, LDU, V,
+ $ LDU, TAU, WORK, RESULT( NTEST ) )
+*
+ IF( IUPLO.EQ.1 ) THEN
+ INDX = 1
+ DO 760 J = 1, N
+ DO 750 I = 1, J
+ WORK( INDX ) = A( I, J )
+ INDX = INDX + 1
+ 750 CONTINUE
+ 760 CONTINUE
+ ELSE
+ INDX = 1
+ DO 780 J = 1, N
+ DO 770 I = J, N
+ WORK( INDX ) = A( I, J )
+ INDX = INDX + 1
+ 770 CONTINUE
+ 780 CONTINUE
+ END IF
+*
+ NTEST = NTEST + 2
+ SRNAMT = 'DSPEV'
+ CALL DSPEV( 'N', UPLO, N, WORK, D3, Z, LDU, V, IINFO )
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUNIT, FMT = 9999 )'DSPEV(N,' // UPLO // ')',
+ $ IINFO, N, JTYPE, IOLDSD
+ INFO = ABS( IINFO )
+ IF( IINFO.LT.0 ) THEN
+ RETURN
+ ELSE
+ RESULT( NTEST ) = ULPINV
+ GO TO 800
+ END IF
+ END IF
+*
+* Do test 39 (or +54)
+*
+ TEMP1 = ZERO
+ TEMP2 = ZERO
+ DO 790 J = 1, N
+ TEMP1 = MAX( TEMP1, ABS( D1( J ) ), ABS( D3( J ) ) )
+ TEMP2 = MAX( TEMP2, ABS( D1( J )-D3( J ) ) )
+ 790 CONTINUE
+ RESULT( NTEST ) = TEMP2 / MAX( UNFL,
+ $ ULP*MAX( TEMP1, TEMP2 ) )
+*
+* Load array WORK with the upper or lower triangular part
+* of the matrix in packed form.
+*
+ 800 CONTINUE
+ IF( IUPLO.EQ.1 ) THEN
+ INDX = 1
+ DO 820 J = 1, N
+ DO 810 I = 1, J
+ WORK( INDX ) = A( I, J )
+ INDX = INDX + 1
+ 810 CONTINUE
+ 820 CONTINUE
+ ELSE
+ INDX = 1
+ DO 840 J = 1, N
+ DO 830 I = J, N
+ WORK( INDX ) = A( I, J )
+ INDX = INDX + 1
+ 830 CONTINUE
+ 840 CONTINUE
+ END IF
+*
+ NTEST = NTEST + 1
+*
+ IF( N.GT.0 ) THEN
+ TEMP3 = MAX( ABS( D1( 1 ) ), ABS( D1( N ) ) )
+ IF( IL.NE.1 ) THEN
+ VL = D1( IL ) - MAX( HALF*( D1( IL )-D1( IL-1 ) ),
+ $ TEN*ULP*TEMP3, TEN*RTUNFL )
+ ELSE IF( N.GT.0 ) THEN
+ VL = D1( 1 ) - MAX( HALF*( D1( N )-D1( 1 ) ),
+ $ TEN*ULP*TEMP3, TEN*RTUNFL )
+ END IF
+ IF( IU.NE.N ) THEN
+ VU = D1( IU ) + MAX( HALF*( D1( IU+1 )-D1( IU ) ),
+ $ TEN*ULP*TEMP3, TEN*RTUNFL )
+ ELSE IF( N.GT.0 ) THEN
+ VU = D1( N ) + MAX( HALF*( D1( N )-D1( 1 ) ),
+ $ TEN*ULP*TEMP3, TEN*RTUNFL )
+ END IF
+ ELSE
+ TEMP3 = ZERO
+ VL = ZERO
+ VU = ONE
+ END IF
+*
+ SRNAMT = 'DSPEVX'
+ CALL DSPEVX( 'V', 'A', UPLO, N, WORK, VL, VU, IL, IU,
+ $ ABSTOL, M, WA1, Z, LDU, V, IWORK,
+ $ IWORK( 5*N+1 ), IINFO )
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUNIT, FMT = 9999 )'DSPEVX(V,A,' // UPLO //
+ $ ')', IINFO, N, JTYPE, IOLDSD
+ INFO = ABS( IINFO )
+ IF( IINFO.LT.0 ) THEN
+ RETURN
+ ELSE
+ RESULT( NTEST ) = ULPINV
+ RESULT( NTEST+1 ) = ULPINV
+ RESULT( NTEST+2 ) = ULPINV
+ GO TO 900
+ END IF
+ END IF
+*
+* Do tests 40 and 41 (or +54)
+*
+ CALL DSYT21( 1, UPLO, N, 0, A, LDU, WA1, D2, Z, LDU, V,
+ $ LDU, TAU, WORK, RESULT( NTEST ) )
+*
+ NTEST = NTEST + 2
+*
+ IF( IUPLO.EQ.1 ) THEN
+ INDX = 1
+ DO 860 J = 1, N
+ DO 850 I = 1, J
+ WORK( INDX ) = A( I, J )
+ INDX = INDX + 1
+ 850 CONTINUE
+ 860 CONTINUE
+ ELSE
+ INDX = 1
+ DO 880 J = 1, N
+ DO 870 I = J, N
+ WORK( INDX ) = A( I, J )
+ INDX = INDX + 1
+ 870 CONTINUE
+ 880 CONTINUE
+ END IF
+*
+ SRNAMT = 'DSPEVX'
+ CALL DSPEVX( 'N', 'A', UPLO, N, WORK, VL, VU, IL, IU,
+ $ ABSTOL, M2, WA2, Z, LDU, V, IWORK,
+ $ IWORK( 5*N+1 ), IINFO )
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUNIT, FMT = 9999 )'DSPEVX(N,A,' // UPLO //
+ $ ')', IINFO, N, JTYPE, IOLDSD
+ INFO = ABS( IINFO )
+ IF( IINFO.LT.0 ) THEN
+ RETURN
+ ELSE
+ RESULT( NTEST ) = ULPINV
+ GO TO 900
+ END IF
+ END IF
+*
+* Do test 42 (or +54)
+*
+ TEMP1 = ZERO
+ TEMP2 = ZERO
+ DO 890 J = 1, N
+ TEMP1 = MAX( TEMP1, ABS( WA1( J ) ), ABS( WA2( J ) ) )
+ TEMP2 = MAX( TEMP2, ABS( WA1( J )-WA2( J ) ) )
+ 890 CONTINUE
+ RESULT( NTEST ) = TEMP2 / MAX( UNFL,
+ $ ULP*MAX( TEMP1, TEMP2 ) )
+*
+ 900 CONTINUE
+ IF( IUPLO.EQ.1 ) THEN
+ INDX = 1
+ DO 920 J = 1, N
+ DO 910 I = 1, J
+ WORK( INDX ) = A( I, J )
+ INDX = INDX + 1
+ 910 CONTINUE
+ 920 CONTINUE
+ ELSE
+ INDX = 1
+ DO 940 J = 1, N
+ DO 930 I = J, N
+ WORK( INDX ) = A( I, J )
+ INDX = INDX + 1
+ 930 CONTINUE
+ 940 CONTINUE
+ END IF
+*
+ NTEST = NTEST + 1
+*
+ SRNAMT = 'DSPEVX'
+ CALL DSPEVX( 'V', 'I', UPLO, N, WORK, VL, VU, IL, IU,
+ $ ABSTOL, M2, WA2, Z, LDU, V, IWORK,
+ $ IWORK( 5*N+1 ), IINFO )
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUNIT, FMT = 9999 )'DSPEVX(V,I,' // UPLO //
+ $ ')', IINFO, N, JTYPE, IOLDSD
+ INFO = ABS( IINFO )
+ IF( IINFO.LT.0 ) THEN
+ RETURN
+ ELSE
+ RESULT( NTEST ) = ULPINV
+ RESULT( NTEST+1 ) = ULPINV
+ RESULT( NTEST+2 ) = ULPINV
+ GO TO 990
+ END IF
+ END IF
+*
+* Do tests 43 and 44 (or +54)
+*
+ CALL DSYT22( 1, UPLO, N, M2, 0, A, LDU, WA2, D2, Z, LDU,
+ $ V, LDU, TAU, WORK, RESULT( NTEST ) )
+*
+ NTEST = NTEST + 2
+*
+ IF( IUPLO.EQ.1 ) THEN
+ INDX = 1
+ DO 960 J = 1, N
+ DO 950 I = 1, J
+ WORK( INDX ) = A( I, J )
+ INDX = INDX + 1
+ 950 CONTINUE
+ 960 CONTINUE
+ ELSE
+ INDX = 1
+ DO 980 J = 1, N
+ DO 970 I = J, N
+ WORK( INDX ) = A( I, J )
+ INDX = INDX + 1
+ 970 CONTINUE
+ 980 CONTINUE
+ END IF
+*
+ SRNAMT = 'DSPEVX'
+ CALL DSPEVX( 'N', 'I', UPLO, N, WORK, VL, VU, IL, IU,
+ $ ABSTOL, M3, WA3, Z, LDU, V, IWORK,
+ $ IWORK( 5*N+1 ), IINFO )
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUNIT, FMT = 9999 )'DSPEVX(N,I,' // UPLO //
+ $ ')', IINFO, N, JTYPE, IOLDSD
+ INFO = ABS( IINFO )
+ IF( IINFO.LT.0 ) THEN
+ RETURN
+ ELSE
+ RESULT( NTEST ) = ULPINV
+ GO TO 990
+ END IF
+ END IF
+*
+ IF( M3.EQ.0 .AND. N.GT.0 ) THEN
+ RESULT( NTEST ) = ULPINV
+ GO TO 990
+ END IF
+*
+* Do test 45 (or +54)
+*
+ TEMP1 = DSXT1( 1, WA2, M2, WA3, M3, ABSTOL, ULP, UNFL )
+ TEMP2 = DSXT1( 1, WA3, M3, WA2, M2, ABSTOL, ULP, UNFL )
+ IF( N.GT.0 ) THEN
+ TEMP3 = MAX( ABS( WA1( 1 ) ), ABS( WA1( N ) ) )
+ ELSE
+ TEMP3 = ZERO
+ END IF
+ RESULT( NTEST ) = ( TEMP1+TEMP2 ) /
+ $ MAX( UNFL, TEMP3*ULP )
+*
+ 990 CONTINUE
+ IF( IUPLO.EQ.1 ) THEN
+ INDX = 1
+ DO 1010 J = 1, N
+ DO 1000 I = 1, J
+ WORK( INDX ) = A( I, J )
+ INDX = INDX + 1
+ 1000 CONTINUE
+ 1010 CONTINUE
+ ELSE
+ INDX = 1
+ DO 1030 J = 1, N
+ DO 1020 I = J, N
+ WORK( INDX ) = A( I, J )
+ INDX = INDX + 1
+ 1020 CONTINUE
+ 1030 CONTINUE
+ END IF
+*
+ NTEST = NTEST + 1
+*
+ SRNAMT = 'DSPEVX'
+ CALL DSPEVX( 'V', 'V', UPLO, N, WORK, VL, VU, IL, IU,
+ $ ABSTOL, M2, WA2, Z, LDU, V, IWORK,
+ $ IWORK( 5*N+1 ), IINFO )
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUNIT, FMT = 9999 )'DSPEVX(V,V,' // UPLO //
+ $ ')', IINFO, N, JTYPE, IOLDSD
+ INFO = ABS( IINFO )
+ IF( IINFO.LT.0 ) THEN
+ RETURN
+ ELSE
+ RESULT( NTEST ) = ULPINV
+ RESULT( NTEST+1 ) = ULPINV
+ RESULT( NTEST+2 ) = ULPINV
+ GO TO 1080
+ END IF
+ END IF
+*
+* Do tests 46 and 47 (or +54)
+*
+ CALL DSYT22( 1, UPLO, N, M2, 0, A, LDU, WA2, D2, Z, LDU,
+ $ V, LDU, TAU, WORK, RESULT( NTEST ) )
+*
+ NTEST = NTEST + 2
+*
+ IF( IUPLO.EQ.1 ) THEN
+ INDX = 1
+ DO 1050 J = 1, N
+ DO 1040 I = 1, J
+ WORK( INDX ) = A( I, J )
+ INDX = INDX + 1
+ 1040 CONTINUE
+ 1050 CONTINUE
+ ELSE
+ INDX = 1
+ DO 1070 J = 1, N
+ DO 1060 I = J, N
+ WORK( INDX ) = A( I, J )
+ INDX = INDX + 1
+ 1060 CONTINUE
+ 1070 CONTINUE
+ END IF
+*
+ SRNAMT = 'DSPEVX'
+ CALL DSPEVX( 'N', 'V', UPLO, N, WORK, VL, VU, IL, IU,
+ $ ABSTOL, M3, WA3, Z, LDU, V, IWORK,
+ $ IWORK( 5*N+1 ), IINFO )
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUNIT, FMT = 9999 )'DSPEVX(N,V,' // UPLO //
+ $ ')', IINFO, N, JTYPE, IOLDSD
+ INFO = ABS( IINFO )
+ IF( IINFO.LT.0 ) THEN
+ RETURN
+ ELSE
+ RESULT( NTEST ) = ULPINV
+ GO TO 1080
+ END IF
+ END IF
+*
+ IF( M3.EQ.0 .AND. N.GT.0 ) THEN
+ RESULT( NTEST ) = ULPINV
+ GO TO 1080
+ END IF
+*
+* Do test 48 (or +54)
+*
+ TEMP1 = DSXT1( 1, WA2, M2, WA3, M3, ABSTOL, ULP, UNFL )
+ TEMP2 = DSXT1( 1, WA3, M3, WA2, M2, ABSTOL, ULP, UNFL )
+ IF( N.GT.0 ) THEN
+ TEMP3 = MAX( ABS( WA1( 1 ) ), ABS( WA1( N ) ) )
+ ELSE
+ TEMP3 = ZERO
+ END IF
+ RESULT( NTEST ) = ( TEMP1+TEMP2 ) /
+ $ MAX( UNFL, TEMP3*ULP )
+*
+ 1080 CONTINUE
+*
+* 6) Call DSBEV and DSBEVX.
+*
+ IF( JTYPE.LE.7 ) THEN
+ KD = 1
+ ELSE IF( JTYPE.GE.8 .AND. JTYPE.LE.15 ) THEN
+ KD = MAX( N-1, 0 )
+ ELSE
+ KD = IHBW
+ END IF
+*
+* Load array V with the upper or lower triangular part
+* of the matrix in band form.
+*
+ IF( IUPLO.EQ.1 ) THEN
+ DO 1100 J = 1, N
+ DO 1090 I = MAX( 1, J-KD ), J
+ V( KD+1+I-J, J ) = A( I, J )
+ 1090 CONTINUE
+ 1100 CONTINUE
+ ELSE
+ DO 1120 J = 1, N
+ DO 1110 I = J, MIN( N, J+KD )
+ V( 1+I-J, J ) = A( I, J )
+ 1110 CONTINUE
+ 1120 CONTINUE
+ END IF
+*
+ NTEST = NTEST + 1
+ SRNAMT = 'DSBEV'
+ CALL DSBEV( 'V', UPLO, N, KD, V, LDU, D1, Z, LDU, WORK,
+ $ IINFO )
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUNIT, FMT = 9999 )'DSBEV(V,' // UPLO // ')',
+ $ IINFO, N, JTYPE, IOLDSD
+ INFO = ABS( IINFO )
+ IF( IINFO.LT.0 ) THEN
+ RETURN
+ ELSE
+ RESULT( NTEST ) = ULPINV
+ RESULT( NTEST+1 ) = ULPINV
+ RESULT( NTEST+2 ) = ULPINV
+ GO TO 1180
+ END IF
+ END IF
+*
+* Do tests 49 and 50 (or ... )
+*
+ CALL DSYT21( 1, UPLO, N, 0, A, LDA, D1, D2, Z, LDU, V,
+ $ LDU, TAU, WORK, RESULT( NTEST ) )
+*
+ IF( IUPLO.EQ.1 ) THEN
+ DO 1140 J = 1, N
+ DO 1130 I = MAX( 1, J-KD ), J
+ V( KD+1+I-J, J ) = A( I, J )
+ 1130 CONTINUE
+ 1140 CONTINUE
+ ELSE
+ DO 1160 J = 1, N
+ DO 1150 I = J, MIN( N, J+KD )
+ V( 1+I-J, J ) = A( I, J )
+ 1150 CONTINUE
+ 1160 CONTINUE
+ END IF
+*
+ NTEST = NTEST + 2
+ SRNAMT = 'DSBEV'
+ CALL DSBEV( 'N', UPLO, N, KD, V, LDU, D3, Z, LDU, WORK,
+ $ IINFO )
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUNIT, FMT = 9999 )'DSBEV(N,' // UPLO // ')',
+ $ IINFO, N, JTYPE, IOLDSD
+ INFO = ABS( IINFO )
+ IF( IINFO.LT.0 ) THEN
+ RETURN
+ ELSE
+ RESULT( NTEST ) = ULPINV
+ GO TO 1180
+ END IF
+ END IF
+*
+* Do test 51 (or +54)
+*
+ TEMP1 = ZERO
+ TEMP2 = ZERO
+ DO 1170 J = 1, N
+ TEMP1 = MAX( TEMP1, ABS( D1( J ) ), ABS( D3( J ) ) )
+ TEMP2 = MAX( TEMP2, ABS( D1( J )-D3( J ) ) )
+ 1170 CONTINUE
+ RESULT( NTEST ) = TEMP2 / MAX( UNFL,
+ $ ULP*MAX( TEMP1, TEMP2 ) )
+*
+* Load array V with the upper or lower triangular part
+* of the matrix in band form.
+*
+ 1180 CONTINUE
+ IF( IUPLO.EQ.1 ) THEN
+ DO 1200 J = 1, N
+ DO 1190 I = MAX( 1, J-KD ), J
+ V( KD+1+I-J, J ) = A( I, J )
+ 1190 CONTINUE
+ 1200 CONTINUE
+ ELSE
+ DO 1220 J = 1, N
+ DO 1210 I = J, MIN( N, J+KD )
+ V( 1+I-J, J ) = A( I, J )
+ 1210 CONTINUE
+ 1220 CONTINUE
+ END IF
+*
+ NTEST = NTEST + 1
+ SRNAMT = 'DSBEVX'
+ CALL DSBEVX( 'V', 'A', UPLO, N, KD, V, LDU, U, LDU, VL,
+ $ VU, IL, IU, ABSTOL, M, WA2, Z, LDU, WORK,
+ $ IWORK, IWORK( 5*N+1 ), IINFO )
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUNIT, FMT = 9999 )'DSBEVX(V,A,' // UPLO //
+ $ ')', IINFO, N, JTYPE, IOLDSD
+ INFO = ABS( IINFO )
+ IF( IINFO.LT.0 ) THEN
+ RETURN
+ ELSE
+ RESULT( NTEST ) = ULPINV
+ RESULT( NTEST+1 ) = ULPINV
+ RESULT( NTEST+2 ) = ULPINV
+ GO TO 1280
+ END IF
+ END IF
+*
+* Do tests 52 and 53 (or +54)
+*
+ CALL DSYT21( 1, UPLO, N, 0, A, LDU, WA2, D2, Z, LDU, V,
+ $ LDU, TAU, WORK, RESULT( NTEST ) )
+*
+ NTEST = NTEST + 2
+*
+ IF( IUPLO.EQ.1 ) THEN
+ DO 1240 J = 1, N
+ DO 1230 I = MAX( 1, J-KD ), J
+ V( KD+1+I-J, J ) = A( I, J )
+ 1230 CONTINUE
+ 1240 CONTINUE
+ ELSE
+ DO 1260 J = 1, N
+ DO 1250 I = J, MIN( N, J+KD )
+ V( 1+I-J, J ) = A( I, J )
+ 1250 CONTINUE
+ 1260 CONTINUE
+ END IF
+*
+ SRNAMT = 'DSBEVX'
+ CALL DSBEVX( 'N', 'A', UPLO, N, KD, V, LDU, U, LDU, VL,
+ $ VU, IL, IU, ABSTOL, M3, WA3, Z, LDU, WORK,
+ $ IWORK, IWORK( 5*N+1 ), IINFO )
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUNIT, FMT = 9999 )'DSBEVX(N,A,' // UPLO //
+ $ ')', IINFO, N, JTYPE, IOLDSD
+ INFO = ABS( IINFO )
+ IF( IINFO.LT.0 ) THEN
+ RETURN
+ ELSE
+ RESULT( NTEST ) = ULPINV
+ GO TO 1280
+ END IF
+ END IF
+*
+* Do test 54 (or +54)
+*
+ TEMP1 = ZERO
+ TEMP2 = ZERO
+ DO 1270 J = 1, N
+ TEMP1 = MAX( TEMP1, ABS( WA2( J ) ), ABS( WA3( J ) ) )
+ TEMP2 = MAX( TEMP2, ABS( WA2( J )-WA3( J ) ) )
+ 1270 CONTINUE
+ RESULT( NTEST ) = TEMP2 / MAX( UNFL,
+ $ ULP*MAX( TEMP1, TEMP2 ) )
+*
+ 1280 CONTINUE
+ NTEST = NTEST + 1
+ IF( IUPLO.EQ.1 ) THEN
+ DO 1300 J = 1, N
+ DO 1290 I = MAX( 1, J-KD ), J
+ V( KD+1+I-J, J ) = A( I, J )
+ 1290 CONTINUE
+ 1300 CONTINUE
+ ELSE
+ DO 1320 J = 1, N
+ DO 1310 I = J, MIN( N, J+KD )
+ V( 1+I-J, J ) = A( I, J )
+ 1310 CONTINUE
+ 1320 CONTINUE
+ END IF
+*
+ SRNAMT = 'DSBEVX'
+ CALL DSBEVX( 'V', 'I', UPLO, N, KD, V, LDU, U, LDU, VL,
+ $ VU, IL, IU, ABSTOL, M2, WA2, Z, LDU, WORK,
+ $ IWORK, IWORK( 5*N+1 ), IINFO )
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUNIT, FMT = 9999 )'DSBEVX(V,I,' // UPLO //
+ $ ')', IINFO, N, JTYPE, IOLDSD
+ INFO = ABS( IINFO )
+ IF( IINFO.LT.0 ) THEN
+ RETURN
+ ELSE
+ RESULT( NTEST ) = ULPINV
+ RESULT( NTEST+1 ) = ULPINV
+ RESULT( NTEST+2 ) = ULPINV
+ GO TO 1370
+ END IF
+ END IF
+*
+* Do tests 55 and 56 (or +54)
+*
+ CALL DSYT22( 1, UPLO, N, M2, 0, A, LDU, WA2, D2, Z, LDU,
+ $ V, LDU, TAU, WORK, RESULT( NTEST ) )
+*
+ NTEST = NTEST + 2
+*
+ IF( IUPLO.EQ.1 ) THEN
+ DO 1340 J = 1, N
+ DO 1330 I = MAX( 1, J-KD ), J
+ V( KD+1+I-J, J ) = A( I, J )
+ 1330 CONTINUE
+ 1340 CONTINUE
+ ELSE
+ DO 1360 J = 1, N
+ DO 1350 I = J, MIN( N, J+KD )
+ V( 1+I-J, J ) = A( I, J )
+ 1350 CONTINUE
+ 1360 CONTINUE
+ END IF
+*
+ SRNAMT = 'DSBEVX'
+ CALL DSBEVX( 'N', 'I', UPLO, N, KD, V, LDU, U, LDU, VL,
+ $ VU, IL, IU, ABSTOL, M3, WA3, Z, LDU, WORK,
+ $ IWORK, IWORK( 5*N+1 ), IINFO )
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUNIT, FMT = 9999 )'DSBEVX(N,I,' // UPLO //
+ $ ')', IINFO, N, JTYPE, IOLDSD
+ INFO = ABS( IINFO )
+ IF( IINFO.LT.0 ) THEN
+ RETURN
+ ELSE
+ RESULT( NTEST ) = ULPINV
+ GO TO 1370
+ END IF
+ END IF
+*
+* Do test 57 (or +54)
+*
+ TEMP1 = DSXT1( 1, WA2, M2, WA3, M3, ABSTOL, ULP, UNFL )
+ TEMP2 = DSXT1( 1, WA3, M3, WA2, M2, ABSTOL, ULP, UNFL )
+ IF( N.GT.0 ) THEN
+ TEMP3 = MAX( ABS( WA1( 1 ) ), ABS( WA1( N ) ) )
+ ELSE
+ TEMP3 = ZERO
+ END IF
+ RESULT( NTEST ) = ( TEMP1+TEMP2 ) /
+ $ MAX( UNFL, TEMP3*ULP )
+*
+ 1370 CONTINUE
+ NTEST = NTEST + 1
+ IF( IUPLO.EQ.1 ) THEN
+ DO 1390 J = 1, N
+ DO 1380 I = MAX( 1, J-KD ), J
+ V( KD+1+I-J, J ) = A( I, J )
+ 1380 CONTINUE
+ 1390 CONTINUE
+ ELSE
+ DO 1410 J = 1, N
+ DO 1400 I = J, MIN( N, J+KD )
+ V( 1+I-J, J ) = A( I, J )
+ 1400 CONTINUE
+ 1410 CONTINUE
+ END IF
+*
+ SRNAMT = 'DSBEVX'
+ CALL DSBEVX( 'V', 'V', UPLO, N, KD, V, LDU, U, LDU, VL,
+ $ VU, IL, IU, ABSTOL, M2, WA2, Z, LDU, WORK,
+ $ IWORK, IWORK( 5*N+1 ), IINFO )
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUNIT, FMT = 9999 )'DSBEVX(V,V,' // UPLO //
+ $ ')', IINFO, N, JTYPE, IOLDSD
+ INFO = ABS( IINFO )
+ IF( IINFO.LT.0 ) THEN
+ RETURN
+ ELSE
+ RESULT( NTEST ) = ULPINV
+ RESULT( NTEST+1 ) = ULPINV
+ RESULT( NTEST+2 ) = ULPINV
+ GO TO 1460
+ END IF
+ END IF
+*
+* Do tests 58 and 59 (or +54)
+*
+ CALL DSYT22( 1, UPLO, N, M2, 0, A, LDU, WA2, D2, Z, LDU,
+ $ V, LDU, TAU, WORK, RESULT( NTEST ) )
+*
+ NTEST = NTEST + 2
+*
+ IF( IUPLO.EQ.1 ) THEN
+ DO 1430 J = 1, N
+ DO 1420 I = MAX( 1, J-KD ), J
+ V( KD+1+I-J, J ) = A( I, J )
+ 1420 CONTINUE
+ 1430 CONTINUE
+ ELSE
+ DO 1450 J = 1, N
+ DO 1440 I = J, MIN( N, J+KD )
+ V( 1+I-J, J ) = A( I, J )
+ 1440 CONTINUE
+ 1450 CONTINUE
+ END IF
+*
+ SRNAMT = 'DSBEVX'
+ CALL DSBEVX( 'N', 'V', UPLO, N, KD, V, LDU, U, LDU, VL,
+ $ VU, IL, IU, ABSTOL, M3, WA3, Z, LDU, WORK,
+ $ IWORK, IWORK( 5*N+1 ), IINFO )
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUNIT, FMT = 9999 )'DSBEVX(N,V,' // UPLO //
+ $ ')', IINFO, N, JTYPE, IOLDSD
+ INFO = ABS( IINFO )
+ IF( IINFO.LT.0 ) THEN
+ RETURN
+ ELSE
+ RESULT( NTEST ) = ULPINV
+ GO TO 1460
+ END IF
+ END IF
+*
+ IF( M3.EQ.0 .AND. N.GT.0 ) THEN
+ RESULT( NTEST ) = ULPINV
+ GO TO 1460
+ END IF
+*
+* Do test 60 (or +54)
+*
+ TEMP1 = DSXT1( 1, WA2, M2, WA3, M3, ABSTOL, ULP, UNFL )
+ TEMP2 = DSXT1( 1, WA3, M3, WA2, M2, ABSTOL, ULP, UNFL )
+ IF( N.GT.0 ) THEN
+ TEMP3 = MAX( ABS( WA1( 1 ) ), ABS( WA1( N ) ) )
+ ELSE
+ TEMP3 = ZERO
+ END IF
+ RESULT( NTEST ) = ( TEMP1+TEMP2 ) /
+ $ MAX( UNFL, TEMP3*ULP )
+*
+ 1460 CONTINUE
+*
+* 7) Call DSYEVD
+*
+ CALL DLACPY( ' ', N, N, A, LDA, V, LDU )
+*
+ NTEST = NTEST + 1
+ SRNAMT = 'DSYEVD'
+ CALL DSYEVD( 'V', UPLO, N, A, LDU, D1, WORK, LWEDC,
+ $ IWORK, LIWEDC, IINFO )
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUNIT, FMT = 9999 )'DSYEVD(V,' // UPLO //
+ $ ')', IINFO, N, JTYPE, IOLDSD
+ INFO = ABS( IINFO )
+ IF( IINFO.LT.0 ) THEN
+ RETURN
+ ELSE
+ RESULT( NTEST ) = ULPINV
+ RESULT( NTEST+1 ) = ULPINV
+ RESULT( NTEST+2 ) = ULPINV
+ GO TO 1480
+ END IF
+ END IF
+*
+* Do tests 61 and 62 (or +54)
+*
+ CALL DSYT21( 1, UPLO, N, 0, V, LDU, D1, D2, A, LDU, Z,
+ $ LDU, TAU, WORK, RESULT( NTEST ) )
+*
+ CALL DLACPY( ' ', N, N, V, LDU, A, LDA )
+*
+ NTEST = NTEST + 2
+ SRNAMT = 'DSYEVD'
+ CALL DSYEVD( 'N', UPLO, N, A, LDU, D3, WORK, LWEDC,
+ $ IWORK, LIWEDC, IINFO )
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUNIT, FMT = 9999 )'DSYEVD(N,' // UPLO //
+ $ ')', IINFO, N, JTYPE, IOLDSD
+ INFO = ABS( IINFO )
+ IF( IINFO.LT.0 ) THEN
+ RETURN
+ ELSE
+ RESULT( NTEST ) = ULPINV
+ GO TO 1480
+ END IF
+ END IF
+*
+* Do test 63 (or +54)
+*
+ TEMP1 = ZERO
+ TEMP2 = ZERO
+ DO 1470 J = 1, N
+ TEMP1 = MAX( TEMP1, ABS( D1( J ) ), ABS( D3( J ) ) )
+ TEMP2 = MAX( TEMP2, ABS( D1( J )-D3( J ) ) )
+ 1470 CONTINUE
+ RESULT( NTEST ) = TEMP2 / MAX( UNFL,
+ $ ULP*MAX( TEMP1, TEMP2 ) )
+*
+ 1480 CONTINUE
+*
+* 8) Call DSPEVD.
+*
+ CALL DLACPY( ' ', N, N, V, LDU, A, LDA )
+*
+* Load array WORK with the upper or lower triangular
+* part of the matrix in packed form.
+*
+ IF( IUPLO.EQ.1 ) THEN
+ INDX = 1
+ DO 1500 J = 1, N
+ DO 1490 I = 1, J
+ WORK( INDX ) = A( I, J )
+ INDX = INDX + 1
+ 1490 CONTINUE
+ 1500 CONTINUE
+ ELSE
+ INDX = 1
+ DO 1520 J = 1, N
+ DO 1510 I = J, N
+ WORK( INDX ) = A( I, J )
+ INDX = INDX + 1
+ 1510 CONTINUE
+ 1520 CONTINUE
+ END IF
+*
+ NTEST = NTEST + 1
+ SRNAMT = 'DSPEVD'
+ CALL DSPEVD( 'V', UPLO, N, WORK, D1, Z, LDU,
+ $ WORK( INDX ), LWEDC-INDX+1, IWORK, LIWEDC,
+ $ IINFO )
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUNIT, FMT = 9999 )'DSPEVD(V,' // UPLO //
+ $ ')', IINFO, N, JTYPE, IOLDSD
+ INFO = ABS( IINFO )
+ IF( IINFO.LT.0 ) THEN
+ RETURN
+ ELSE
+ RESULT( NTEST ) = ULPINV
+ RESULT( NTEST+1 ) = ULPINV
+ RESULT( NTEST+2 ) = ULPINV
+ GO TO 1580
+ END IF
+ END IF
+*
+* Do tests 64 and 65 (or +54)
+*
+ CALL DSYT21( 1, UPLO, N, 0, A, LDA, D1, D2, Z, LDU, V,
+ $ LDU, TAU, WORK, RESULT( NTEST ) )
+*
+ IF( IUPLO.EQ.1 ) THEN
+ INDX = 1
+ DO 1540 J = 1, N
+ DO 1530 I = 1, J
+*
+ WORK( INDX ) = A( I, J )
+ INDX = INDX + 1
+ 1530 CONTINUE
+ 1540 CONTINUE
+ ELSE
+ INDX = 1
+ DO 1560 J = 1, N
+ DO 1550 I = J, N
+ WORK( INDX ) = A( I, J )
+ INDX = INDX + 1
+ 1550 CONTINUE
+ 1560 CONTINUE
+ END IF
+*
+ NTEST = NTEST + 2
+ SRNAMT = 'DSPEVD'
+ CALL DSPEVD( 'N', UPLO, N, WORK, D3, Z, LDU,
+ $ WORK( INDX ), LWEDC-INDX+1, IWORK, LIWEDC,
+ $ IINFO )
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUNIT, FMT = 9999 )'DSPEVD(N,' // UPLO //
+ $ ')', IINFO, N, JTYPE, IOLDSD
+ INFO = ABS( IINFO )
+ IF( IINFO.LT.0 ) THEN
+ RETURN
+ ELSE
+ RESULT( NTEST ) = ULPINV
+ GO TO 1580
+ END IF
+ END IF
+*
+* Do test 66 (or +54)
+*
+ TEMP1 = ZERO
+ TEMP2 = ZERO
+ DO 1570 J = 1, N
+ TEMP1 = MAX( TEMP1, ABS( D1( J ) ), ABS( D3( J ) ) )
+ TEMP2 = MAX( TEMP2, ABS( D1( J )-D3( J ) ) )
+ 1570 CONTINUE
+ RESULT( NTEST ) = TEMP2 / MAX( UNFL,
+ $ ULP*MAX( TEMP1, TEMP2 ) )
+ 1580 CONTINUE
+*
+* 9) Call DSBEVD.
+*
+ IF( JTYPE.LE.7 ) THEN
+ KD = 1
+ ELSE IF( JTYPE.GE.8 .AND. JTYPE.LE.15 ) THEN
+ KD = MAX( N-1, 0 )
+ ELSE
+ KD = IHBW
+ END IF
+*
+* Load array V with the upper or lower triangular part
+* of the matrix in band form.
+*
+ IF( IUPLO.EQ.1 ) THEN
+ DO 1600 J = 1, N
+ DO 1590 I = MAX( 1, J-KD ), J
+ V( KD+1+I-J, J ) = A( I, J )
+ 1590 CONTINUE
+ 1600 CONTINUE
+ ELSE
+ DO 1620 J = 1, N
+ DO 1610 I = J, MIN( N, J+KD )
+ V( 1+I-J, J ) = A( I, J )
+ 1610 CONTINUE
+ 1620 CONTINUE
+ END IF
+*
+ NTEST = NTEST + 1
+ SRNAMT = 'DSBEVD'
+ CALL DSBEVD( 'V', UPLO, N, KD, V, LDU, D1, Z, LDU, WORK,
+ $ LWEDC, IWORK, LIWEDC, IINFO )
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUNIT, FMT = 9999 )'DSBEVD(V,' // UPLO //
+ $ ')', IINFO, N, JTYPE, IOLDSD
+ INFO = ABS( IINFO )
+ IF( IINFO.LT.0 ) THEN
+ RETURN
+ ELSE
+ RESULT( NTEST ) = ULPINV
+ RESULT( NTEST+1 ) = ULPINV
+ RESULT( NTEST+2 ) = ULPINV
+ GO TO 1680
+ END IF
+ END IF
+*
+* Do tests 67 and 68 (or +54)
+*
+ CALL DSYT21( 1, UPLO, N, 0, A, LDA, D1, D2, Z, LDU, V,
+ $ LDU, TAU, WORK, RESULT( NTEST ) )
+*
+ IF( IUPLO.EQ.1 ) THEN
+ DO 1640 J = 1, N
+ DO 1630 I = MAX( 1, J-KD ), J
+ V( KD+1+I-J, J ) = A( I, J )
+ 1630 CONTINUE
+ 1640 CONTINUE
+ ELSE
+ DO 1660 J = 1, N
+ DO 1650 I = J, MIN( N, J+KD )
+ V( 1+I-J, J ) = A( I, J )
+ 1650 CONTINUE
+ 1660 CONTINUE
+ END IF
+*
+ NTEST = NTEST + 2
+ SRNAMT = 'DSBEVD'
+ CALL DSBEVD( 'N', UPLO, N, KD, V, LDU, D3, Z, LDU, WORK,
+ $ LWEDC, IWORK, LIWEDC, IINFO )
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUNIT, FMT = 9999 )'DSBEVD(N,' // UPLO //
+ $ ')', IINFO, N, JTYPE, IOLDSD
+ INFO = ABS( IINFO )
+ IF( IINFO.LT.0 ) THEN
+ RETURN
+ ELSE
+ RESULT( NTEST ) = ULPINV
+ GO TO 1680
+ END IF
+ END IF
+*
+* Do test 69 (or +54)
+*
+ TEMP1 = ZERO
+ TEMP2 = ZERO
+ DO 1670 J = 1, N
+ TEMP1 = MAX( TEMP1, ABS( D1( J ) ), ABS( D3( J ) ) )
+ TEMP2 = MAX( TEMP2, ABS( D1( J )-D3( J ) ) )
+ 1670 CONTINUE
+ RESULT( NTEST ) = TEMP2 / MAX( UNFL,
+ $ ULP*MAX( TEMP1, TEMP2 ) )
+*
+ 1680 CONTINUE
+*
+*
+ CALL DLACPY( ' ', N, N, A, LDA, V, LDU )
+ NTEST = NTEST + 1
+ SRNAMT = 'DSYEVR'
+ CALL DSYEVR( 'V', 'A', UPLO, N, A, LDU, VL, VU, IL, IU,
+ $ ABSTOL, M, WA1, Z, LDU, IWORK, WORK, LWORK,
+ $ IWORK(2*N+1), LIWORK-2*N, IINFO )
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUNIT, FMT = 9999 )'DSYEVR(V,A,' // UPLO //
+ $ ')', IINFO, N, JTYPE, IOLDSD
+ INFO = ABS( IINFO )
+ IF( IINFO.LT.0 ) THEN
+ RETURN
+ ELSE
+ RESULT( NTEST ) = ULPINV
+ RESULT( NTEST+1 ) = ULPINV
+ RESULT( NTEST+2 ) = ULPINV
+ GO TO 1700
+ END IF
+ END IF
+*
+* Do tests 70 and 71 (or ... )
+*
+ CALL DLACPY( ' ', N, N, V, LDU, A, LDA )
+*
+ CALL DSYT21( 1, UPLO, N, 0, A, LDU, WA1, D2, Z, LDU, V,
+ $ LDU, TAU, WORK, RESULT( NTEST ) )
+*
+ NTEST = NTEST + 2
+ SRNAMT = 'DSYEVR'
+ CALL DSYEVR( 'N', 'A', UPLO, N, A, LDU, VL, VU, IL, IU,
+ $ ABSTOL, M2, WA2, Z, LDU, IWORK, WORK, LWORK,
+ $ IWORK(2*N+1), LIWORK-2*N, IINFO )
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUNIT, FMT = 9999 )'DSYEVR(N,A,' // UPLO //
+ $ ')', IINFO, N, JTYPE, IOLDSD
+ INFO = ABS( IINFO )
+ IF( IINFO.LT.0 ) THEN
+ RETURN
+ ELSE
+ RESULT( NTEST ) = ULPINV
+ GO TO 1700
+ END IF
+ END IF
+*
+* Do test 72 (or ... )
+*
+ TEMP1 = ZERO
+ TEMP2 = ZERO
+ DO 1690 J = 1, N
+ TEMP1 = MAX( TEMP1, ABS( WA1( J ) ), ABS( WA2( J ) ) )
+ TEMP2 = MAX( TEMP2, ABS( WA1( J )-WA2( J ) ) )
+ 1690 CONTINUE
+ RESULT( NTEST ) = TEMP2 / MAX( UNFL,
+ $ ULP*MAX( TEMP1, TEMP2 ) )
+*
+ 1700 CONTINUE
+*
+ NTEST = NTEST + 1
+ CALL DLACPY( ' ', N, N, V, LDU, A, LDA )
+ SRNAMT = 'DSYEVR'
+ CALL DSYEVR( 'V', 'I', UPLO, N, A, LDU, VL, VU, IL, IU,
+ $ ABSTOL, M2, WA2, Z, LDU, IWORK, WORK, LWORK,
+ $ IWORK(2*N+1), LIWORK-2*N, IINFO )
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUNIT, FMT = 9999 )'DSYEVR(V,I,' // UPLO //
+ $ ')', IINFO, N, JTYPE, IOLDSD
+ INFO = ABS( IINFO )
+ IF( IINFO.LT.0 ) THEN
+ RETURN
+ ELSE
+ RESULT( NTEST ) = ULPINV
+ RESULT( NTEST+1 ) = ULPINV
+ RESULT( NTEST+2 ) = ULPINV
+ GO TO 1710
+ END IF
+ END IF
+*
+* Do tests 73 and 74 (or +54)
+*
+ CALL DLACPY( ' ', N, N, V, LDU, A, LDA )
+*
+ CALL DSYT22( 1, UPLO, N, M2, 0, A, LDU, WA2, D2, Z, LDU,
+ $ V, LDU, TAU, WORK, RESULT( NTEST ) )
+*
+ NTEST = NTEST + 2
+ CALL DLACPY( ' ', N, N, V, LDU, A, LDA )
+ SRNAMT = 'DSYEVR'
+ CALL DSYEVR( 'N', 'I', UPLO, N, A, LDU, VL, VU, IL, IU,
+ $ ABSTOL, M3, WA3, Z, LDU, IWORK, WORK, LWORK,
+ $ IWORK(2*N+1), LIWORK-2*N, IINFO )
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUNIT, FMT = 9999 )'DSYEVR(N,I,' // UPLO //
+ $ ')', IINFO, N, JTYPE, IOLDSD
+ INFO = ABS( IINFO )
+ IF( IINFO.LT.0 ) THEN
+ RETURN
+ ELSE
+ RESULT( NTEST ) = ULPINV
+ GO TO 1710
+ END IF
+ END IF
+*
+* Do test 75 (or +54)
+*
+ TEMP1 = DSXT1( 1, WA2, M2, WA3, M3, ABSTOL, ULP, UNFL )
+ TEMP2 = DSXT1( 1, WA3, M3, WA2, M2, ABSTOL, ULP, UNFL )
+ RESULT( NTEST ) = ( TEMP1+TEMP2 ) /
+ $ MAX( UNFL, ULP*TEMP3 )
+ 1710 CONTINUE
+*
+ NTEST = NTEST + 1
+ CALL DLACPY( ' ', N, N, V, LDU, A, LDA )
+ SRNAMT = 'DSYEVR'
+ CALL DSYEVR( 'V', 'V', UPLO, N, A, LDU, VL, VU, IL, IU,
+ $ ABSTOL, M2, WA2, Z, LDU, IWORK, WORK, LWORK,
+ $ IWORK(2*N+1), LIWORK-2*N, IINFO )
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUNIT, FMT = 9999 )'DSYEVR(V,V,' // UPLO //
+ $ ')', IINFO, N, JTYPE, IOLDSD
+ INFO = ABS( IINFO )
+ IF( IINFO.LT.0 ) THEN
+ RETURN
+ ELSE
+ RESULT( NTEST ) = ULPINV
+ RESULT( NTEST+1 ) = ULPINV
+ RESULT( NTEST+2 ) = ULPINV
+ GO TO 700
+ END IF
+ END IF
+*
+* Do tests 76 and 77 (or +54)
+*
+ CALL DLACPY( ' ', N, N, V, LDU, A, LDA )
+*
+ CALL DSYT22( 1, UPLO, N, M2, 0, A, LDU, WA2, D2, Z, LDU,
+ $ V, LDU, TAU, WORK, RESULT( NTEST ) )
+*
+ NTEST = NTEST + 2
+ CALL DLACPY( ' ', N, N, V, LDU, A, LDA )
+ SRNAMT = 'DSYEVR'
+ CALL DSYEVR( 'N', 'V', UPLO, N, A, LDU, VL, VU, IL, IU,
+ $ ABSTOL, M3, WA3, Z, LDU, IWORK, WORK, LWORK,
+ $ IWORK(2*N+1), LIWORK-2*N, IINFO )
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUNIT, FMT = 9999 )'DSYEVR(N,V,' // UPLO //
+ $ ')', IINFO, N, JTYPE, IOLDSD
+ INFO = ABS( IINFO )
+ IF( IINFO.LT.0 ) THEN
+ RETURN
+ ELSE
+ RESULT( NTEST ) = ULPINV
+ GO TO 700
+ END IF
+ END IF
+*
+ IF( M3.EQ.0 .AND. N.GT.0 ) THEN
+ RESULT( NTEST ) = ULPINV
+ GO TO 700
+ END IF
+*
+* Do test 78 (or +54)
+*
+ TEMP1 = DSXT1( 1, WA2, M2, WA3, M3, ABSTOL, ULP, UNFL )
+ TEMP2 = DSXT1( 1, WA3, M3, WA2, M2, ABSTOL, ULP, UNFL )
+ IF( N.GT.0 ) THEN
+ TEMP3 = MAX( ABS( WA1( 1 ) ), ABS( WA1( N ) ) )
+ ELSE
+ TEMP3 = ZERO
+ END IF
+ RESULT( NTEST ) = ( TEMP1+TEMP2 ) /
+ $ MAX( UNFL, TEMP3*ULP )
+*
+ CALL DLACPY( ' ', N, N, V, LDU, A, LDA )
+*
+ 1720 CONTINUE
+*
+* End of Loop -- Check for RESULT(j) > THRESH
+*
+ NTESTT = NTESTT + NTEST
+*
+ CALL DLAFTS( 'DST', N, N, JTYPE, NTEST, RESULT, IOLDSD,
+ $ THRESH, NOUNIT, NERRS )
+*
+ 1730 CONTINUE
+ 1740 CONTINUE
+*
+* Summary
+*
+ CALL ALASVM( 'DST', NOUNIT, NERRS, NTESTT, 0 )
+*
+ 9999 FORMAT( ' DDRVST: ', A, ' returned INFO=', I6, '.', / 9X, 'N=',
+ $ I6, ', JTYPE=', I6, ', ISEED=(', 3( I5, ',' ), I5, ')' )
+*
+ RETURN
+*
+* End of DDRVST
+*
+ END
+ SUBROUTINE DDRVSX( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH,
+ $ NIUNIT, NOUNIT, A, LDA, H, HT, WR, WI, WRT,
+ $ WIT, WRTMP, WITMP, VS, LDVS, VS1, RESULT, WORK,
+ $ LWORK, IWORK, BWORK, INFO )
+*
+* -- LAPACK test routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LDA, LDVS, LWORK, NIUNIT, NOUNIT, NSIZES,
+ $ NTYPES
+ DOUBLE PRECISION THRESH
+* ..
+* .. Array Arguments ..
+ LOGICAL BWORK( * ), DOTYPE( * )
+ INTEGER ISEED( 4 ), IWORK( * ), NN( * )
+ DOUBLE PRECISION A( LDA, * ), H( LDA, * ), HT( LDA, * ),
+ $ RESULT( 17 ), VS( LDVS, * ), VS1( LDVS, * ),
+ $ WI( * ), WIT( * ), WITMP( * ), WORK( * ),
+ $ WR( * ), WRT( * ), WRTMP( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DDRVSX checks the nonsymmetric eigenvalue (Schur form) problem
+* expert driver DGEESX.
+*
+* DDRVSX uses both test matrices generated randomly depending on
+* data supplied in the calling sequence, as well as on data
+* read from an input file and including precomputed condition
+* numbers to which it compares the ones it computes.
+*
+* When DDRVSX is called, a number of matrix "sizes" ("n's") and a
+* number of matrix "types" are specified. For each size ("n")
+* and each type of matrix, one matrix will be generated and used
+* to test the nonsymmetric eigenroutines. For each matrix, 15
+* tests will be performed:
+*
+* (1) 0 if T is in Schur form, 1/ulp otherwise
+* (no sorting of eigenvalues)
+*
+* (2) | A - VS T VS' | / ( n |A| ulp )
+*
+* Here VS is the matrix of Schur eigenvectors, and T is in Schur
+* form (no sorting of eigenvalues).
+*
+* (3) | I - VS VS' | / ( n ulp ) (no sorting of eigenvalues).
+*
+* (4) 0 if WR+sqrt(-1)*WI are eigenvalues of T
+* 1/ulp otherwise
+* (no sorting of eigenvalues)
+*
+* (5) 0 if T(with VS) = T(without VS),
+* 1/ulp otherwise
+* (no sorting of eigenvalues)
+*
+* (6) 0 if eigenvalues(with VS) = eigenvalues(without VS),
+* 1/ulp otherwise
+* (no sorting of eigenvalues)
+*
+* (7) 0 if T is in Schur form, 1/ulp otherwise
+* (with sorting of eigenvalues)
+*
+* (8) | A - VS T VS' | / ( n |A| ulp )
+*
+* Here VS is the matrix of Schur eigenvectors, and T is in Schur
+* form (with sorting of eigenvalues).
+*
+* (9) | I - VS VS' | / ( n ulp ) (with sorting of eigenvalues).
+*
+* (10) 0 if WR+sqrt(-1)*WI are eigenvalues of T
+* 1/ulp otherwise
+* If workspace sufficient, also compare WR, WI with and
+* without reciprocal condition numbers
+* (with sorting of eigenvalues)
+*
+* (11) 0 if T(with VS) = T(without VS),
+* 1/ulp otherwise
+* If workspace sufficient, also compare T with and without
+* reciprocal condition numbers
+* (with sorting of eigenvalues)
+*
+* (12) 0 if eigenvalues(with VS) = eigenvalues(without VS),
+* 1/ulp otherwise
+* If workspace sufficient, also compare VS with and without
+* reciprocal condition numbers
+* (with sorting of eigenvalues)
+*
+* (13) if sorting worked and SDIM is the number of
+* eigenvalues which were SELECTed
+* If workspace sufficient, also compare SDIM with and
+* without reciprocal condition numbers
+*
+* (14) if RCONDE the same no matter if VS and/or RCONDV computed
+*
+* (15) if RCONDV the same no matter if VS and/or RCONDE computed
+*
+* The "sizes" are specified by an array NN(1:NSIZES); the value of
+* each element NN(j) specifies one size.
+* The "types" are specified by a logical array DOTYPE( 1:NTYPES );
+* if DOTYPE(j) is .TRUE., then matrix type "j" will be generated.
+* Currently, the list of possible types is:
+*
+* (1) The zero matrix.
+* (2) The identity matrix.
+* (3) A (transposed) Jordan block, with 1's on the diagonal.
+*
+* (4) A diagonal matrix with evenly spaced entries
+* 1, ..., ULP and random signs.
+* (ULP = (first number larger than 1) - 1 )
+* (5) A diagonal matrix with geometrically spaced entries
+* 1, ..., ULP and random signs.
+* (6) A diagonal matrix with "clustered" entries 1, ULP, ..., ULP
+* and random signs.
+*
+* (7) Same as (4), but multiplied by a constant near
+* the overflow threshold
+* (8) Same as (4), but multiplied by a constant near
+* the underflow threshold
+*
+* (9) A matrix of the form U' T U, where U is orthogonal and
+* T has evenly spaced entries 1, ..., ULP with random signs
+* on the diagonal and random O(1) entries in the upper
+* triangle.
+*
+* (10) A matrix of the form U' T U, where U is orthogonal and
+* T has geometrically spaced entries 1, ..., ULP with random
+* signs on the diagonal and random O(1) entries in the upper
+* triangle.
+*
+* (11) A matrix of the form U' T U, where U is orthogonal and
+* T has "clustered" entries 1, ULP,..., ULP with random
+* signs on the diagonal and random O(1) entries in the upper
+* triangle.
+*
+* (12) A matrix of the form U' T U, where U is orthogonal and
+* T has real or complex conjugate paired eigenvalues randomly
+* chosen from ( ULP, 1 ) and random O(1) entries in the upper
+* triangle.
+*
+* (13) A matrix of the form X' T X, where X has condition
+* SQRT( ULP ) and T has evenly spaced entries 1, ..., ULP
+* with random signs on the diagonal and random O(1) entries
+* in the upper triangle.
+*
+* (14) A matrix of the form X' T X, where X has condition
+* SQRT( ULP ) and T has geometrically spaced entries
+* 1, ..., ULP with random signs on the diagonal and random
+* O(1) entries in the upper triangle.
+*
+* (15) A matrix of the form X' T X, where X has condition
+* SQRT( ULP ) and T has "clustered" entries 1, ULP,..., ULP
+* with random signs on the diagonal and random O(1) entries
+* in the upper triangle.
+*
+* (16) A matrix of the form X' T X, where X has condition
+* SQRT( ULP ) and T has real or complex conjugate paired
+* eigenvalues randomly chosen from ( ULP, 1 ) and random
+* O(1) entries in the upper triangle.
+*
+* (17) Same as (16), but multiplied by a constant
+* near the overflow threshold
+* (18) Same as (16), but multiplied by a constant
+* near the underflow threshold
+*
+* (19) Nonsymmetric matrix with random entries chosen from (-1,1).
+* If N is at least 4, all entries in first two rows and last
+* row, and first column and last two columns are zero.
+* (20) Same as (19), but multiplied by a constant
+* near the overflow threshold
+* (21) Same as (19), but multiplied by a constant
+* near the underflow threshold
+*
+* In addition, an input file will be read from logical unit number
+* NIUNIT. The file contains matrices along with precomputed
+* eigenvalues and reciprocal condition numbers for the eigenvalue
+* average and right invariant subspace. For these matrices, in
+* addition to tests (1) to (15) we will compute the following two
+* tests:
+*
+* (16) |RCONDE - RCDEIN| / cond(RCONDE)
+*
+* RCONDE is the reciprocal average eigenvalue condition number
+* computed by DGEESX and RCDEIN (the precomputed true value)
+* is supplied as input. cond(RCONDE) is the condition number
+* of RCONDE, and takes errors in computing RCONDE into account,
+* so that the resulting quantity should be O(ULP). cond(RCONDE)
+* is essentially given by norm(A)/RCONDV.
+*
+* (17) |RCONDV - RCDVIN| / cond(RCONDV)
+*
+* RCONDV is the reciprocal right invariant subspace condition
+* number computed by DGEESX and RCDVIN (the precomputed true
+* value) is supplied as input. cond(RCONDV) is the condition
+* number of RCONDV, and takes errors in computing RCONDV into
+* account, so that the resulting quantity should be O(ULP).
+* cond(RCONDV) is essentially given by norm(A)/RCONDE.
+*
+* Arguments
+* =========
+*
+* NSIZES (input) INTEGER
+* The number of sizes of matrices to use. NSIZES must be at
+* least zero. If it is zero, no randomly generated matrices
+* are tested, but any test matrices read from NIUNIT will be
+* tested.
+*
+* NN (input) INTEGER array, dimension (NSIZES)
+* An array containing the sizes to be used for the matrices.
+* Zero values will be skipped. The values must be at least
+* zero.
+*
+* NTYPES (input) INTEGER
+* The number of elements in DOTYPE. NTYPES must be at least
+* zero. If it is zero, no randomly generated test matrices
+* are tested, but and test matrices read from NIUNIT will be
+* tested. If it is MAXTYP+1 and NSIZES is 1, then an
+* additional type, MAXTYP+1 is defined, which is to use
+* whatever matrix is in A. This is only useful if
+* DOTYPE(1:MAXTYP) is .FALSE. and DOTYPE(MAXTYP+1) is .TRUE. .
+*
+* DOTYPE (input) LOGICAL array, dimension (NTYPES)
+* If DOTYPE(j) is .TRUE., then for each size in NN a
+* matrix of that size and of type j will be generated.
+* If NTYPES is smaller than the maximum number of types
+* defined (PARAMETER MAXTYP), then types NTYPES+1 through
+* MAXTYP will not be generated. If NTYPES is larger
+* than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES)
+* will be ignored.
+*
+* ISEED (input/output) INTEGER array, dimension (4)
+* On entry ISEED specifies the seed of the random number
+* generator. The array elements should be between 0 and 4095;
+* if not they will be reduced mod 4096. Also, ISEED(4) must
+* be odd. The random number generator uses a linear
+* congruential sequence limited to small integers, and so
+* should produce machine independent random numbers. The
+* values of ISEED are changed on exit, and can be used in the
+* next call to DDRVSX to continue the same random number
+* sequence.
+*
+* THRESH (input) DOUBLE PRECISION
+* A test will count as "failed" if the "error", computed as
+* described above, exceeds THRESH. Note that the error
+* is scaled to be O(1), so THRESH should be a reasonably
+* small multiple of 1, e.g., 10 or 100. In particular,
+* it should not depend on the precision (single vs. double)
+* or the size of the matrix. It must be at least zero.
+*
+* NIUNIT (input) INTEGER
+* The FORTRAN unit number for reading in the data file of
+* problems to solve.
+*
+* NOUNIT (input) INTEGER
+* The FORTRAN unit number for printing out error messages
+* (e.g., if a routine returns INFO not equal to 0.)
+*
+* A (workspace) DOUBLE PRECISION array, dimension (LDA, max(NN))
+* Used to hold the matrix whose eigenvalues are to be
+* computed. On exit, A contains the last matrix actually used.
+*
+* LDA (input) INTEGER
+* The leading dimension of A, and H. LDA must be at
+* least 1 and at least max( NN ).
+*
+* H (workspace) DOUBLE PRECISION array, dimension (LDA, max(NN))
+* Another copy of the test matrix A, modified by DGEESX.
+*
+* HT (workspace) DOUBLE PRECISION array, dimension (LDA, max(NN))
+* Yet another copy of the test matrix A, modified by DGEESX.
+*
+* WR (workspace) DOUBLE PRECISION array, dimension (max(NN))
+* WI (workspace) DOUBLE PRECISION array, dimension (max(NN))
+* The real and imaginary parts of the eigenvalues of A.
+* On exit, WR + WI*i are the eigenvalues of the matrix in A.
+*
+* WRT (workspace) DOUBLE PRECISION array, dimension (max(NN))
+* WIT (workspace) DOUBLE PRECISION array, dimension (max(NN))
+* Like WR, WI, these arrays contain the eigenvalues of A,
+* but those computed when DGEESX only computes a partial
+* eigendecomposition, i.e. not Schur vectors
+*
+* WRTMP (workspace) DOUBLE PRECISION array, dimension (max(NN))
+* WITMP (workspace) DOUBLE PRECISION array, dimension (max(NN))
+* More temporary storage for eigenvalues.
+*
+* VS (workspace) DOUBLE PRECISION array, dimension (LDVS, max(NN))
+* VS holds the computed Schur vectors.
+*
+* LDVS (input) INTEGER
+* Leading dimension of VS. Must be at least max(1,max(NN)).
+*
+* VS1 (workspace) DOUBLE PRECISION array, dimension (LDVS, max(NN))
+* VS1 holds another copy of the computed Schur vectors.
+*
+* RESULT (output) DOUBLE PRECISION array, dimension (17)
+* The values computed by the 17 tests described above.
+* The values are currently limited to 1/ulp, to avoid overflow.
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK)
+*
+* LWORK (input) INTEGER
+* The number of entries in WORK. This must be at least
+* max(3*NN(j),2*NN(j)**2) for all j.
+*
+* IWORK (workspace) INTEGER array, dimension (max(NN)*max(NN))
+*
+* INFO (output) INTEGER
+* If 0, successful exit.
+* <0, input parameter -INFO is incorrect
+* >0, DLATMR, SLATMS, SLATME or DGET24 returned an error
+* code and INFO is its absolute value
+*
+*-----------------------------------------------------------------------
+*
+* Some Local Variables and Parameters:
+* ---- ----- --------- --- ----------
+* ZERO, ONE Real 0 and 1.
+* MAXTYP The number of types defined.
+* NMAX Largest value in NN.
+* NERRS The number of tests which have exceeded THRESH
+* COND, CONDS,
+* IMODE Values to be passed to the matrix generators.
+* ANORM Norm of A; passed to matrix generators.
+*
+* OVFL, UNFL Overflow and underflow thresholds.
+* ULP, ULPINV Finest relative precision and its inverse.
+* RTULP, RTULPI Square roots of the previous 4 values.
+* The following four arrays decode JTYPE:
+* KTYPE(j) The general type (1-10) for type "j".
+* KMODE(j) The MODE value to be passed to the matrix
+* generator for type "j".
+* KMAGN(j) The order of magnitude ( O(1),
+* O(overflow^(1/2) ), O(underflow^(1/2) )
+* KCONDS(j) Selectw whether CONDS is to be 1 or
+* 1/sqrt(ulp). (0 means irrelevant.)
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
+ INTEGER MAXTYP
+ PARAMETER ( MAXTYP = 21 )
+* ..
+* .. Local Scalars ..
+ LOGICAL BADNN
+ CHARACTER*3 PATH
+ INTEGER I, IINFO, IMODE, ITYPE, IWK, J, JCOL, JSIZE,
+ $ JTYPE, MTYPES, N, NERRS, NFAIL, NMAX, NNWORK,
+ $ NSLCT, NTEST, NTESTF, NTESTT
+ DOUBLE PRECISION ANORM, COND, CONDS, OVFL, RCDEIN, RCDVIN,
+ $ RTULP, RTULPI, ULP, ULPINV, UNFL
+* ..
+* .. Local Arrays ..
+ CHARACTER ADUMMA( 1 )
+ INTEGER IDUMMA( 1 ), IOLDSD( 4 ), ISLCT( 20 ),
+ $ KCONDS( MAXTYP ), KMAGN( MAXTYP ),
+ $ KMODE( MAXTYP ), KTYPE( MAXTYP )
+* ..
+* .. Arrays in Common ..
+ LOGICAL SELVAL( 20 )
+ DOUBLE PRECISION SELWI( 20 ), SELWR( 20 )
+* ..
+* .. Scalars in Common ..
+ INTEGER SELDIM, SELOPT
+* ..
+* .. Common blocks ..
+ COMMON / SSLCT / SELOPT, SELDIM, SELVAL, SELWR, SELWI
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DLAMCH
+ EXTERNAL DLAMCH
+* ..
+* .. External Subroutines ..
+ EXTERNAL DGET24, DLABAD, DLASET, DLASUM, DLATME, DLATMR,
+ $ DLATMS, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, MIN, SQRT
+* ..
+* .. Data statements ..
+ DATA KTYPE / 1, 2, 3, 5*4, 4*6, 6*6, 3*9 /
+ DATA KMAGN / 3*1, 1, 1, 1, 2, 3, 4*1, 1, 1, 1, 1, 2,
+ $ 3, 1, 2, 3 /
+ DATA KMODE / 3*0, 4, 3, 1, 4, 4, 4, 3, 1, 5, 4, 3,
+ $ 1, 5, 5, 5, 4, 3, 1 /
+ DATA KCONDS / 3*0, 5*0, 4*1, 6*2, 3*0 /
+* ..
+* .. Executable Statements ..
+*
+ PATH( 1: 1 ) = 'Double precision'
+ PATH( 2: 3 ) = 'SX'
+*
+* Check for errors
+*
+ NTESTT = 0
+ NTESTF = 0
+ INFO = 0
+*
+* Important constants
+*
+ BADNN = .FALSE.
+*
+* 12 is the largest dimension in the input file of precomputed
+* problems
+*
+ NMAX = 12
+ DO 10 J = 1, NSIZES
+ NMAX = MAX( NMAX, NN( J ) )
+ IF( NN( J ).LT.0 )
+ $ BADNN = .TRUE.
+ 10 CONTINUE
+*
+* Check for errors
+*
+ IF( NSIZES.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( BADNN ) THEN
+ INFO = -2
+ ELSE IF( NTYPES.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( THRESH.LT.ZERO ) THEN
+ INFO = -6
+ ELSE IF( NIUNIT.LE.0 ) THEN
+ INFO = -7
+ ELSE IF( NOUNIT.LE.0 ) THEN
+ INFO = -8
+ ELSE IF( LDA.LT.1 .OR. LDA.LT.NMAX ) THEN
+ INFO = -10
+ ELSE IF( LDVS.LT.1 .OR. LDVS.LT.NMAX ) THEN
+ INFO = -20
+ ELSE IF( MAX( 3*NMAX, 2*NMAX**2 ).GT.LWORK ) THEN
+ INFO = -24
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DDRVSX', -INFO )
+ RETURN
+ END IF
+*
+* If nothing to do check on NIUNIT
+*
+ IF( NSIZES.EQ.0 .OR. NTYPES.EQ.0 )
+ $ GO TO 150
+*
+* More Important constants
+*
+ UNFL = DLAMCH( 'Safe minimum' )
+ OVFL = ONE / UNFL
+ CALL DLABAD( UNFL, OVFL )
+ ULP = DLAMCH( 'Precision' )
+ ULPINV = ONE / ULP
+ RTULP = SQRT( ULP )
+ RTULPI = ONE / RTULP
+*
+* Loop over sizes, types
+*
+ NERRS = 0
+*
+ DO 140 JSIZE = 1, NSIZES
+ N = NN( JSIZE )
+ IF( NSIZES.NE.1 ) THEN
+ MTYPES = MIN( MAXTYP, NTYPES )
+ ELSE
+ MTYPES = MIN( MAXTYP+1, NTYPES )
+ END IF
+*
+ DO 130 JTYPE = 1, MTYPES
+ IF( .NOT.DOTYPE( JTYPE ) )
+ $ GO TO 130
+*
+* Save ISEED in case of an error.
+*
+ DO 20 J = 1, 4
+ IOLDSD( J ) = ISEED( J )
+ 20 CONTINUE
+*
+* Compute "A"
+*
+* Control parameters:
+*
+* KMAGN KCONDS KMODE KTYPE
+* =1 O(1) 1 clustered 1 zero
+* =2 large large clustered 2 identity
+* =3 small exponential Jordan
+* =4 arithmetic diagonal, (w/ eigenvalues)
+* =5 random log symmetric, w/ eigenvalues
+* =6 random general, w/ eigenvalues
+* =7 random diagonal
+* =8 random symmetric
+* =9 random general
+* =10 random triangular
+*
+ IF( MTYPES.GT.MAXTYP )
+ $ GO TO 90
+*
+ ITYPE = KTYPE( JTYPE )
+ IMODE = KMODE( JTYPE )
+*
+* Compute norm
+*
+ GO TO ( 30, 40, 50 )KMAGN( JTYPE )
+*
+ 30 CONTINUE
+ ANORM = ONE
+ GO TO 60
+*
+ 40 CONTINUE
+ ANORM = OVFL*ULP
+ GO TO 60
+*
+ 50 CONTINUE
+ ANORM = UNFL*ULPINV
+ GO TO 60
+*
+ 60 CONTINUE
+*
+ CALL DLASET( 'Full', LDA, N, ZERO, ZERO, A, LDA )
+ IINFO = 0
+ COND = ULPINV
+*
+* Special Matrices -- Identity & Jordan block
+*
+* Zero
+*
+ IF( ITYPE.EQ.1 ) THEN
+ IINFO = 0
+*
+ ELSE IF( ITYPE.EQ.2 ) THEN
+*
+* Identity
+*
+ DO 70 JCOL = 1, N
+ A( JCOL, JCOL ) = ANORM
+ 70 CONTINUE
+*
+ ELSE IF( ITYPE.EQ.3 ) THEN
+*
+* Jordan Block
+*
+ DO 80 JCOL = 1, N
+ A( JCOL, JCOL ) = ANORM
+ IF( JCOL.GT.1 )
+ $ A( JCOL, JCOL-1 ) = ONE
+ 80 CONTINUE
+*
+ ELSE IF( ITYPE.EQ.4 ) THEN
+*
+* Diagonal Matrix, [Eigen]values Specified
+*
+ CALL DLATMS( N, N, 'S', ISEED, 'S', WORK, IMODE, COND,
+ $ ANORM, 0, 0, 'N', A, LDA, WORK( N+1 ),
+ $ IINFO )
+*
+ ELSE IF( ITYPE.EQ.5 ) THEN
+*
+* Symmetric, eigenvalues specified
+*
+ CALL DLATMS( N, N, 'S', ISEED, 'S', WORK, IMODE, COND,
+ $ ANORM, N, N, 'N', A, LDA, WORK( N+1 ),
+ $ IINFO )
+*
+ ELSE IF( ITYPE.EQ.6 ) THEN
+*
+* General, eigenvalues specified
+*
+ IF( KCONDS( JTYPE ).EQ.1 ) THEN
+ CONDS = ONE
+ ELSE IF( KCONDS( JTYPE ).EQ.2 ) THEN
+ CONDS = RTULPI
+ ELSE
+ CONDS = ZERO
+ END IF
+*
+ ADUMMA( 1 ) = ' '
+ CALL DLATME( N, 'S', ISEED, WORK, IMODE, COND, ONE,
+ $ ADUMMA, 'T', 'T', 'T', WORK( N+1 ), 4,
+ $ CONDS, N, N, ANORM, A, LDA, WORK( 2*N+1 ),
+ $ IINFO )
+*
+ ELSE IF( ITYPE.EQ.7 ) THEN
+*
+* Diagonal, random eigenvalues
+*
+ CALL DLATMR( N, N, 'S', ISEED, 'S', WORK, 6, ONE, ONE,
+ $ 'T', 'N', WORK( N+1 ), 1, ONE,
+ $ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, 0, 0,
+ $ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO )
+*
+ ELSE IF( ITYPE.EQ.8 ) THEN
+*
+* Symmetric, random eigenvalues
+*
+ CALL DLATMR( N, N, 'S', ISEED, 'S', WORK, 6, ONE, ONE,
+ $ 'T', 'N', WORK( N+1 ), 1, ONE,
+ $ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, N, N,
+ $ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO )
+*
+ ELSE IF( ITYPE.EQ.9 ) THEN
+*
+* General, random eigenvalues
+*
+ CALL DLATMR( N, N, 'S', ISEED, 'N', WORK, 6, ONE, ONE,
+ $ 'T', 'N', WORK( N+1 ), 1, ONE,
+ $ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, N, N,
+ $ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO )
+ IF( N.GE.4 ) THEN
+ CALL DLASET( 'Full', 2, N, ZERO, ZERO, A, LDA )
+ CALL DLASET( 'Full', N-3, 1, ZERO, ZERO, A( 3, 1 ),
+ $ LDA )
+ CALL DLASET( 'Full', N-3, 2, ZERO, ZERO, A( 3, N-1 ),
+ $ LDA )
+ CALL DLASET( 'Full', 1, N, ZERO, ZERO, A( N, 1 ),
+ $ LDA )
+ END IF
+*
+ ELSE IF( ITYPE.EQ.10 ) THEN
+*
+* Triangular, random eigenvalues
+*
+ CALL DLATMR( N, N, 'S', ISEED, 'N', WORK, 6, ONE, ONE,
+ $ 'T', 'N', WORK( N+1 ), 1, ONE,
+ $ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, N, 0,
+ $ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO )
+*
+ ELSE
+*
+ IINFO = 1
+ END IF
+*
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUNIT, FMT = 9991 )'Generator', IINFO, N, JTYPE,
+ $ IOLDSD
+ INFO = ABS( IINFO )
+ RETURN
+ END IF
+*
+ 90 CONTINUE
+*
+* Test for minimal and generous workspace
+*
+ DO 120 IWK = 1, 2
+ IF( IWK.EQ.1 ) THEN
+ NNWORK = 3*N
+ ELSE
+ NNWORK = MAX( 3*N, 2*N*N )
+ END IF
+ NNWORK = MAX( NNWORK, 1 )
+*
+ CALL DGET24( .FALSE., JTYPE, THRESH, IOLDSD, NOUNIT, N,
+ $ A, LDA, H, HT, WR, WI, WRT, WIT, WRTMP,
+ $ WITMP, VS, LDVS, VS1, RCDEIN, RCDVIN, NSLCT,
+ $ ISLCT, RESULT, WORK, NNWORK, IWORK, BWORK,
+ $ INFO )
+*
+* Check for RESULT(j) > THRESH
+*
+ NTEST = 0
+ NFAIL = 0
+ DO 100 J = 1, 15
+ IF( RESULT( J ).GE.ZERO )
+ $ NTEST = NTEST + 1
+ IF( RESULT( J ).GE.THRESH )
+ $ NFAIL = NFAIL + 1
+ 100 CONTINUE
+*
+ IF( NFAIL.GT.0 )
+ $ NTESTF = NTESTF + 1
+ IF( NTESTF.EQ.1 ) THEN
+ WRITE( NOUNIT, FMT = 9999 )PATH
+ WRITE( NOUNIT, FMT = 9998 )
+ WRITE( NOUNIT, FMT = 9997 )
+ WRITE( NOUNIT, FMT = 9996 )
+ WRITE( NOUNIT, FMT = 9995 )THRESH
+ WRITE( NOUNIT, FMT = 9994 )
+ NTESTF = 2
+ END IF
+*
+ DO 110 J = 1, 15
+ IF( RESULT( J ).GE.THRESH ) THEN
+ WRITE( NOUNIT, FMT = 9993 )N, IWK, IOLDSD, JTYPE,
+ $ J, RESULT( J )
+ END IF
+ 110 CONTINUE
+*
+ NERRS = NERRS + NFAIL
+ NTESTT = NTESTT + NTEST
+*
+ 120 CONTINUE
+ 130 CONTINUE
+ 140 CONTINUE
+*
+ 150 CONTINUE
+*
+* Read in data from file to check accuracy of condition estimation
+* Read input data until N=0
+*
+ JTYPE = 0
+ 160 CONTINUE
+ READ( NIUNIT, FMT = *, END = 200 )N, NSLCT
+ IF( N.EQ.0 )
+ $ GO TO 200
+ JTYPE = JTYPE + 1
+ ISEED( 1 ) = JTYPE
+ IF( NSLCT.GT.0 )
+ $ READ( NIUNIT, FMT = * )( ISLCT( I ), I = 1, NSLCT )
+ DO 170 I = 1, N
+ READ( NIUNIT, FMT = * )( A( I, J ), J = 1, N )
+ 170 CONTINUE
+ READ( NIUNIT, FMT = * )RCDEIN, RCDVIN
+*
+ CALL DGET24( .TRUE., 22, THRESH, ISEED, NOUNIT, N, A, LDA, H, HT,
+ $ WR, WI, WRT, WIT, WRTMP, WITMP, VS, LDVS, VS1,
+ $ RCDEIN, RCDVIN, NSLCT, ISLCT, RESULT, WORK, LWORK,
+ $ IWORK, BWORK, INFO )
+*
+* Check for RESULT(j) > THRESH
+*
+ NTEST = 0
+ NFAIL = 0
+ DO 180 J = 1, 17
+ IF( RESULT( J ).GE.ZERO )
+ $ NTEST = NTEST + 1
+ IF( RESULT( J ).GE.THRESH )
+ $ NFAIL = NFAIL + 1
+ 180 CONTINUE
+*
+ IF( NFAIL.GT.0 )
+ $ NTESTF = NTESTF + 1
+ IF( NTESTF.EQ.1 ) THEN
+ WRITE( NOUNIT, FMT = 9999 )PATH
+ WRITE( NOUNIT, FMT = 9998 )
+ WRITE( NOUNIT, FMT = 9997 )
+ WRITE( NOUNIT, FMT = 9996 )
+ WRITE( NOUNIT, FMT = 9995 )THRESH
+ WRITE( NOUNIT, FMT = 9994 )
+ NTESTF = 2
+ END IF
+ DO 190 J = 1, 17
+ IF( RESULT( J ).GE.THRESH ) THEN
+ WRITE( NOUNIT, FMT = 9992 )N, JTYPE, J, RESULT( J )
+ END IF
+ 190 CONTINUE
+*
+ NERRS = NERRS + NFAIL
+ NTESTT = NTESTT + NTEST
+ GO TO 160
+ 200 CONTINUE
+*
+* Summary
+*
+ CALL DLASUM( PATH, NOUNIT, NERRS, NTESTT )
+*
+ 9999 FORMAT( / 1X, A3, ' -- Real Schur Form Decomposition Expert ',
+ $ 'Driver', / ' Matrix types (see DDRVSX for details):' )
+*
+ 9998 FORMAT( / ' Special Matrices:', / ' 1=Zero matrix. ',
+ $ ' ', ' 5=Diagonal: geometr. spaced entries.',
+ $ / ' 2=Identity matrix. ', ' 6=Diagona',
+ $ 'l: clustered entries.', / ' 3=Transposed Jordan block. ',
+ $ ' ', ' 7=Diagonal: large, evenly spaced.', / ' ',
+ $ '4=Diagonal: evenly spaced entries. ', ' 8=Diagonal: s',
+ $ 'mall, evenly spaced.' )
+ 9997 FORMAT( ' Dense, Non-Symmetric Matrices:', / ' 9=Well-cond., ev',
+ $ 'enly spaced eigenvals.', ' 14=Ill-cond., geomet. spaced e',
+ $ 'igenals.', / ' 10=Well-cond., geom. spaced eigenvals. ',
+ $ ' 15=Ill-conditioned, clustered e.vals.', / ' 11=Well-cond',
+ $ 'itioned, clustered e.vals. ', ' 16=Ill-cond., random comp',
+ $ 'lex ', / ' 12=Well-cond., random complex ', ' ',
+ $ ' 17=Ill-cond., large rand. complx ', / ' 13=Ill-condi',
+ $ 'tioned, evenly spaced. ', ' 18=Ill-cond., small rand.',
+ $ ' complx ' )
+ 9996 FORMAT( ' 19=Matrix with random O(1) entries. ', ' 21=Matrix ',
+ $ 'with small random entries.', / ' 20=Matrix with large ran',
+ $ 'dom entries. ', / )
+ 9995 FORMAT( ' Tests performed with test threshold =', F8.2,
+ $ / ' ( A denotes A on input and T denotes A on output)',
+ $ / / ' 1 = 0 if T in Schur form (no sort), ',
+ $ ' 1/ulp otherwise', /
+ $ ' 2 = | A - VS T transpose(VS) | / ( n |A| ulp ) (no sort)',
+ $ / ' 3 = | I - VS transpose(VS) | / ( n ulp ) (no sort) ', /
+ $ ' 4 = 0 if WR+sqrt(-1)*WI are eigenvalues of T (no sort),',
+ $ ' 1/ulp otherwise', /
+ $ ' 5 = 0 if T same no matter if VS computed (no sort),',
+ $ ' 1/ulp otherwise', /
+ $ ' 6 = 0 if WR, WI same no matter if VS computed (no sort)',
+ $ ', 1/ulp otherwise' )
+ 9994 FORMAT( ' 7 = 0 if T in Schur form (sort), ', ' 1/ulp otherwise',
+ $ / ' 8 = | A - VS T transpose(VS) | / ( n |A| ulp ) (sort)',
+ $ / ' 9 = | I - VS transpose(VS) | / ( n ulp ) (sort) ',
+ $ / ' 10 = 0 if WR+sqrt(-1)*WI are eigenvalues of T (sort),',
+ $ ' 1/ulp otherwise', /
+ $ ' 11 = 0 if T same no matter what else computed (sort),',
+ $ ' 1/ulp otherwise', /
+ $ ' 12 = 0 if WR, WI same no matter what else computed ',
+ $ '(sort), 1/ulp otherwise', /
+ $ ' 13 = 0 if sorting succesful, 1/ulp otherwise',
+ $ / ' 14 = 0 if RCONDE same no matter what else computed,',
+ $ ' 1/ulp otherwise', /
+ $ ' 15 = 0 if RCONDv same no matter what else computed,',
+ $ ' 1/ulp otherwise', /
+ $ ' 16 = | RCONDE - RCONDE(precomputed) | / cond(RCONDE),',
+ $ / ' 17 = | RCONDV - RCONDV(precomputed) | / cond(RCONDV),' )
+ 9993 FORMAT( ' N=', I5, ', IWK=', I2, ', seed=', 4( I4, ',' ),
+ $ ' type ', I2, ', test(', I2, ')=', G10.3 )
+ 9992 FORMAT( ' N=', I5, ', input example =', I3, ', test(', I2, ')=',
+ $ G10.3 )
+ 9991 FORMAT( ' DDRVSX: ', A, ' returned INFO=', I6, '.', / 9X, 'N=',
+ $ I6, ', JTYPE=', I6, ', ISEED=(', 3( I5, ',' ), I5, ')' )
+*
+ RETURN
+*
+* End of DDRVSX
+*
+ END
+ SUBROUTINE DDRVVX( NSIZES, NN, NTYPES, DOTYPE, ISEED, THRESH,
+ $ NIUNIT, NOUNIT, A, LDA, H, WR, WI, WR1, WI1,
+ $ VL, LDVL, VR, LDVR, LRE, LDLRE, RCONDV, RCNDV1,
+ $ RCDVIN, RCONDE, RCNDE1, RCDEIN, SCALE, SCALE1,
+ $ RESULT, WORK, NWORK, IWORK, INFO )
+*
+* -- LAPACK test routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LDA, LDLRE, LDVL, LDVR, NIUNIT, NOUNIT,
+ $ NSIZES, NTYPES, NWORK
+ DOUBLE PRECISION THRESH
+* ..
+* .. Array Arguments ..
+ LOGICAL DOTYPE( * )
+ INTEGER ISEED( 4 ), IWORK( * ), NN( * )
+ DOUBLE PRECISION A( LDA, * ), H( LDA, * ), LRE( LDLRE, * ),
+ $ RCDEIN( * ), RCDVIN( * ), RCNDE1( * ),
+ $ RCNDV1( * ), RCONDE( * ), RCONDV( * ),
+ $ RESULT( 11 ), SCALE( * ), SCALE1( * ),
+ $ VL( LDVL, * ), VR( LDVR, * ), WI( * ),
+ $ WI1( * ), WORK( * ), WR( * ), WR1( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DDRVVX checks the nonsymmetric eigenvalue problem expert driver
+* DGEEVX.
+*
+* DDRVVX uses both test matrices generated randomly depending on
+* data supplied in the calling sequence, as well as on data
+* read from an input file and including precomputed condition
+* numbers to which it compares the ones it computes.
+*
+* When DDRVVX is called, a number of matrix "sizes" ("n's") and a
+* number of matrix "types" are specified in the calling sequence.
+* For each size ("n") and each type of matrix, one matrix will be
+* generated and used to test the nonsymmetric eigenroutines. For
+* each matrix, 9 tests will be performed:
+*
+* (1) | A * VR - VR * W | / ( n |A| ulp )
+*
+* Here VR is the matrix of unit right eigenvectors.
+* W is a block diagonal matrix, with a 1x1 block for each
+* real eigenvalue and a 2x2 block for each complex conjugate
+* pair. If eigenvalues j and j+1 are a complex conjugate pair,
+* so WR(j) = WR(j+1) = wr and WI(j) = - WI(j+1) = wi, then the
+* 2 x 2 block corresponding to the pair will be:
+*
+* ( wr wi )
+* ( -wi wr )
+*
+* Such a block multiplying an n x 2 matrix ( ur ui ) on the
+* right will be the same as multiplying ur + i*ui by wr + i*wi.
+*
+* (2) | A**H * VL - VL * W**H | / ( n |A| ulp )
+*
+* Here VL is the matrix of unit left eigenvectors, A**H is the
+* conjugate transpose of A, and W is as above.
+*
+* (3) | |VR(i)| - 1 | / ulp and largest component real
+*
+* VR(i) denotes the i-th column of VR.
+*
+* (4) | |VL(i)| - 1 | / ulp and largest component real
+*
+* VL(i) denotes the i-th column of VL.
+*
+* (5) W(full) = W(partial)
+*
+* W(full) denotes the eigenvalues computed when VR, VL, RCONDV
+* and RCONDE are also computed, and W(partial) denotes the
+* eigenvalues computed when only some of VR, VL, RCONDV, and
+* RCONDE are computed.
+*
+* (6) VR(full) = VR(partial)
+*
+* VR(full) denotes the right eigenvectors computed when VL, RCONDV
+* and RCONDE are computed, and VR(partial) denotes the result
+* when only some of VL and RCONDV are computed.
+*
+* (7) VL(full) = VL(partial)
+*
+* VL(full) denotes the left eigenvectors computed when VR, RCONDV
+* and RCONDE are computed, and VL(partial) denotes the result
+* when only some of VR and RCONDV are computed.
+*
+* (8) 0 if SCALE, ILO, IHI, ABNRM (full) =
+* SCALE, ILO, IHI, ABNRM (partial)
+* 1/ulp otherwise
+*
+* SCALE, ILO, IHI and ABNRM describe how the matrix is balanced.
+* (full) is when VR, VL, RCONDE and RCONDV are also computed, and
+* (partial) is when some are not computed.
+*
+* (9) RCONDV(full) = RCONDV(partial)
+*
+* RCONDV(full) denotes the reciprocal condition numbers of the
+* right eigenvectors computed when VR, VL and RCONDE are also
+* computed. RCONDV(partial) denotes the reciprocal condition
+* numbers when only some of VR, VL and RCONDE are computed.
+*
+* The "sizes" are specified by an array NN(1:NSIZES); the value of
+* each element NN(j) specifies one size.
+* The "types" are specified by a logical array DOTYPE( 1:NTYPES );
+* if DOTYPE(j) is .TRUE., then matrix type "j" will be generated.
+* Currently, the list of possible types is:
+*
+* (1) The zero matrix.
+* (2) The identity matrix.
+* (3) A (transposed) Jordan block, with 1's on the diagonal.
+*
+* (4) A diagonal matrix with evenly spaced entries
+* 1, ..., ULP and random signs.
+* (ULP = (first number larger than 1) - 1 )
+* (5) A diagonal matrix with geometrically spaced entries
+* 1, ..., ULP and random signs.
+* (6) A diagonal matrix with "clustered" entries 1, ULP, ..., ULP
+* and random signs.
+*
+* (7) Same as (4), but multiplied by a constant near
+* the overflow threshold
+* (8) Same as (4), but multiplied by a constant near
+* the underflow threshold
+*
+* (9) A matrix of the form U' T U, where U is orthogonal and
+* T has evenly spaced entries 1, ..., ULP with random signs
+* on the diagonal and random O(1) entries in the upper
+* triangle.
+*
+* (10) A matrix of the form U' T U, where U is orthogonal and
+* T has geometrically spaced entries 1, ..., ULP with random
+* signs on the diagonal and random O(1) entries in the upper
+* triangle.
+*
+* (11) A matrix of the form U' T U, where U is orthogonal and
+* T has "clustered" entries 1, ULP,..., ULP with random
+* signs on the diagonal and random O(1) entries in the upper
+* triangle.
+*
+* (12) A matrix of the form U' T U, where U is orthogonal and
+* T has real or complex conjugate paired eigenvalues randomly
+* chosen from ( ULP, 1 ) and random O(1) entries in the upper
+* triangle.
+*
+* (13) A matrix of the form X' T X, where X has condition
+* SQRT( ULP ) and T has evenly spaced entries 1, ..., ULP
+* with random signs on the diagonal and random O(1) entries
+* in the upper triangle.
+*
+* (14) A matrix of the form X' T X, where X has condition
+* SQRT( ULP ) and T has geometrically spaced entries
+* 1, ..., ULP with random signs on the diagonal and random
+* O(1) entries in the upper triangle.
+*
+* (15) A matrix of the form X' T X, where X has condition
+* SQRT( ULP ) and T has "clustered" entries 1, ULP,..., ULP
+* with random signs on the diagonal and random O(1) entries
+* in the upper triangle.
+*
+* (16) A matrix of the form X' T X, where X has condition
+* SQRT( ULP ) and T has real or complex conjugate paired
+* eigenvalues randomly chosen from ( ULP, 1 ) and random
+* O(1) entries in the upper triangle.
+*
+* (17) Same as (16), but multiplied by a constant
+* near the overflow threshold
+* (18) Same as (16), but multiplied by a constant
+* near the underflow threshold
+*
+* (19) Nonsymmetric matrix with random entries chosen from (-1,1).
+* If N is at least 4, all entries in first two rows and last
+* row, and first column and last two columns are zero.
+* (20) Same as (19), but multiplied by a constant
+* near the overflow threshold
+* (21) Same as (19), but multiplied by a constant
+* near the underflow threshold
+*
+* In addition, an input file will be read from logical unit number
+* NIUNIT. The file contains matrices along with precomputed
+* eigenvalues and reciprocal condition numbers for the eigenvalues
+* and right eigenvectors. For these matrices, in addition to tests
+* (1) to (9) we will compute the following two tests:
+*
+* (10) |RCONDV - RCDVIN| / cond(RCONDV)
+*
+* RCONDV is the reciprocal right eigenvector condition number
+* computed by DGEEVX and RCDVIN (the precomputed true value)
+* is supplied as input. cond(RCONDV) is the condition number of
+* RCONDV, and takes errors in computing RCONDV into account, so
+* that the resulting quantity should be O(ULP). cond(RCONDV) is
+* essentially given by norm(A)/RCONDE.
+*
+* (11) |RCONDE - RCDEIN| / cond(RCONDE)
+*
+* RCONDE is the reciprocal eigenvalue condition number
+* computed by DGEEVX and RCDEIN (the precomputed true value)
+* is supplied as input. cond(RCONDE) is the condition number
+* of RCONDE, and takes errors in computing RCONDE into account,
+* so that the resulting quantity should be O(ULP). cond(RCONDE)
+* is essentially given by norm(A)/RCONDV.
+*
+* Arguments
+* ==========
+*
+* NSIZES (input) INTEGER
+* The number of sizes of matrices to use. NSIZES must be at
+* least zero. If it is zero, no randomly generated matrices
+* are tested, but any test matrices read from NIUNIT will be
+* tested.
+*
+* NN (input) INTEGER array, dimension (NSIZES)
+* An array containing the sizes to be used for the matrices.
+* Zero values will be skipped. The values must be at least
+* zero.
+*
+* NTYPES (input) INTEGER
+* The number of elements in DOTYPE. NTYPES must be at least
+* zero. If it is zero, no randomly generated test matrices
+* are tested, but and test matrices read from NIUNIT will be
+* tested. If it is MAXTYP+1 and NSIZES is 1, then an
+* additional type, MAXTYP+1 is defined, which is to use
+* whatever matrix is in A. This is only useful if
+* DOTYPE(1:MAXTYP) is .FALSE. and DOTYPE(MAXTYP+1) is .TRUE. .
+*
+* DOTYPE (input) LOGICAL array, dimension (NTYPES)
+* If DOTYPE(j) is .TRUE., then for each size in NN a
+* matrix of that size and of type j will be generated.
+* If NTYPES is smaller than the maximum number of types
+* defined (PARAMETER MAXTYP), then types NTYPES+1 through
+* MAXTYP will not be generated. If NTYPES is larger
+* than MAXTYP, DOTYPE(MAXTYP+1) through DOTYPE(NTYPES)
+* will be ignored.
+*
+* ISEED (input/output) INTEGER array, dimension (4)
+* On entry ISEED specifies the seed of the random number
+* generator. The array elements should be between 0 and 4095;
+* if not they will be reduced mod 4096. Also, ISEED(4) must
+* be odd. The random number generator uses a linear
+* congruential sequence limited to small integers, and so
+* should produce machine independent random numbers. The
+* values of ISEED are changed on exit, and can be used in the
+* next call to DDRVVX to continue the same random number
+* sequence.
+*
+* THRESH (input) DOUBLE PRECISION
+* A test will count as "failed" if the "error", computed as
+* described above, exceeds THRESH. Note that the error
+* is scaled to be O(1), so THRESH should be a reasonably
+* small multiple of 1, e.g., 10 or 100. In particular,
+* it should not depend on the precision (single vs. double)
+* or the size of the matrix. It must be at least zero.
+*
+* NIUNIT (input) INTEGER
+* The FORTRAN unit number for reading in the data file of
+* problems to solve.
+*
+* NOUNIT (input) INTEGER
+* The FORTRAN unit number for printing out error messages
+* (e.g., if a routine returns INFO not equal to 0.)
+*
+* A (workspace) DOUBLE PRECISION array, dimension
+* (LDA, max(NN,12))
+* Used to hold the matrix whose eigenvalues are to be
+* computed. On exit, A contains the last matrix actually used.
+*
+* LDA (input) INTEGER
+* The leading dimension of the arrays A and H.
+* LDA >= max(NN,12), since 12 is the dimension of the largest
+* matrix in the precomputed input file.
+*
+* H (workspace) DOUBLE PRECISION array, dimension
+* (LDA, max(NN,12))
+* Another copy of the test matrix A, modified by DGEEVX.
+*
+* WR (workspace) DOUBLE PRECISION array, dimension (max(NN))
+* WI (workspace) DOUBLE PRECISION array, dimension (max(NN))
+* The real and imaginary parts of the eigenvalues of A.
+* On exit, WR + WI*i are the eigenvalues of the matrix in A.
+*
+* WR1 (workspace) DOUBLE PRECISION array, dimension (max(NN,12))
+* WI1 (workspace) DOUBLE PRECISION array, dimension (max(NN,12))
+* Like WR, WI, these arrays contain the eigenvalues of A,
+* but those computed when DGEEVX only computes a partial
+* eigendecomposition, i.e. not the eigenvalues and left
+* and right eigenvectors.
+*
+* VL (workspace) DOUBLE PRECISION array, dimension
+* (LDVL, max(NN,12))
+* VL holds the computed left eigenvectors.
+*
+* LDVL (input) INTEGER
+* Leading dimension of VL. Must be at least max(1,max(NN,12)).
+*
+* VR (workspace) DOUBLE PRECISION array, dimension
+* (LDVR, max(NN,12))
+* VR holds the computed right eigenvectors.
+*
+* LDVR (input) INTEGER
+* Leading dimension of VR. Must be at least max(1,max(NN,12)).
+*
+* LRE (workspace) DOUBLE PRECISION array, dimension
+* (LDLRE, max(NN,12))
+* LRE holds the computed right or left eigenvectors.
+*
+* LDLRE (input) INTEGER
+* Leading dimension of LRE. Must be at least max(1,max(NN,12))
+*
+* RCONDV (workspace) DOUBLE PRECISION array, dimension (N)
+* RCONDV holds the computed reciprocal condition numbers
+* for eigenvectors.
+*
+* RCNDV1 (workspace) DOUBLE PRECISION array, dimension (N)
+* RCNDV1 holds more computed reciprocal condition numbers
+* for eigenvectors.
+*
+* RCDVIN (workspace) DOUBLE PRECISION array, dimension (N)
+* When COMP = .TRUE. RCDVIN holds the precomputed reciprocal
+* condition numbers for eigenvectors to be compared with
+* RCONDV.
+*
+* RCONDE (workspace) DOUBLE PRECISION array, dimension (N)
+* RCONDE holds the computed reciprocal condition numbers
+* for eigenvalues.
+*
+* RCNDE1 (workspace) DOUBLE PRECISION array, dimension (N)
+* RCNDE1 holds more computed reciprocal condition numbers
+* for eigenvalues.
+*
+* RCDEIN (workspace) DOUBLE PRECISION array, dimension (N)
+* When COMP = .TRUE. RCDEIN holds the precomputed reciprocal
+* condition numbers for eigenvalues to be compared with
+* RCONDE.
+*
+* RESULT (output) DOUBLE PRECISION array, dimension (11)
+* The values computed by the seven tests described above.
+* The values are currently limited to 1/ulp, to avoid overflow.
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (NWORK)
+*
+* NWORK (input) INTEGER
+* The number of entries in WORK. This must be at least
+* max(6*12+2*12**2,6*NN(j)+2*NN(j)**2) =
+* max( 360 ,6*NN(j)+2*NN(j)**2) for all j.
+*
+* IWORK (workspace) INTEGER array, dimension (2*max(NN,12))
+*
+* INFO (output) INTEGER
+* If 0, then successful exit.
+* If <0, then input paramter -INFO is incorrect.
+* If >0, DLATMR, SLATMS, SLATME or DGET23 returned an error
+* code, and INFO is its absolute value.
+*
+*-----------------------------------------------------------------------
+*
+* Some Local Variables and Parameters:
+* ---- ----- --------- --- ----------
+*
+* ZERO, ONE Real 0 and 1.
+* MAXTYP The number of types defined.
+* NMAX Largest value in NN or 12.
+* NERRS The number of tests which have exceeded THRESH
+* COND, CONDS,
+* IMODE Values to be passed to the matrix generators.
+* ANORM Norm of A; passed to matrix generators.
+*
+* OVFL, UNFL Overflow and underflow thresholds.
+* ULP, ULPINV Finest relative precision and its inverse.
+* RTULP, RTULPI Square roots of the previous 4 values.
+*
+* The following four arrays decode JTYPE:
+* KTYPE(j) The general type (1-10) for type "j".
+* KMODE(j) The MODE value to be passed to the matrix
+* generator for type "j".
+* KMAGN(j) The order of magnitude ( O(1),
+* O(overflow^(1/2) ), O(underflow^(1/2) )
+* KCONDS(j) Selectw whether CONDS is to be 1 or
+* 1/sqrt(ulp). (0 means irrelevant.)
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
+ INTEGER MAXTYP
+ PARAMETER ( MAXTYP = 21 )
+* ..
+* .. Local Scalars ..
+ LOGICAL BADNN
+ CHARACTER BALANC
+ CHARACTER*3 PATH
+ INTEGER I, IBAL, IINFO, IMODE, ITYPE, IWK, J, JCOL,
+ $ JSIZE, JTYPE, MTYPES, N, NERRS, NFAIL, NMAX,
+ $ NNWORK, NTEST, NTESTF, NTESTT
+ DOUBLE PRECISION ANORM, COND, CONDS, OVFL, RTULP, RTULPI, ULP,
+ $ ULPINV, UNFL
+* ..
+* .. Local Arrays ..
+ CHARACTER ADUMMA( 1 ), BAL( 4 )
+ INTEGER IDUMMA( 1 ), IOLDSD( 4 ), KCONDS( MAXTYP ),
+ $ KMAGN( MAXTYP ), KMODE( MAXTYP ),
+ $ KTYPE( MAXTYP )
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DLAMCH
+ EXTERNAL DLAMCH
+* ..
+* .. External Subroutines ..
+ EXTERNAL DGET23, DLABAD, DLASET, DLASUM, DLATME, DLATMR,
+ $ DLATMS, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, MIN, SQRT
+* ..
+* .. Data statements ..
+ DATA KTYPE / 1, 2, 3, 5*4, 4*6, 6*6, 3*9 /
+ DATA KMAGN / 3*1, 1, 1, 1, 2, 3, 4*1, 1, 1, 1, 1, 2,
+ $ 3, 1, 2, 3 /
+ DATA KMODE / 3*0, 4, 3, 1, 4, 4, 4, 3, 1, 5, 4, 3,
+ $ 1, 5, 5, 5, 4, 3, 1 /
+ DATA KCONDS / 3*0, 5*0, 4*1, 6*2, 3*0 /
+ DATA BAL / 'N', 'P', 'S', 'B' /
+* ..
+* .. Executable Statements ..
+*
+ PATH( 1: 1 ) = 'Double precision'
+ PATH( 2: 3 ) = 'VX'
+*
+* Check for errors
+*
+ NTESTT = 0
+ NTESTF = 0
+ INFO = 0
+*
+* Important constants
+*
+ BADNN = .FALSE.
+*
+* 12 is the largest dimension in the input file of precomputed
+* problems
+*
+ NMAX = 12
+ DO 10 J = 1, NSIZES
+ NMAX = MAX( NMAX, NN( J ) )
+ IF( NN( J ).LT.0 )
+ $ BADNN = .TRUE.
+ 10 CONTINUE
+*
+* Check for errors
+*
+ IF( NSIZES.LT.0 ) THEN
+ INFO = -1
+ ELSE IF( BADNN ) THEN
+ INFO = -2
+ ELSE IF( NTYPES.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( THRESH.LT.ZERO ) THEN
+ INFO = -6
+ ELSE IF( LDA.LT.1 .OR. LDA.LT.NMAX ) THEN
+ INFO = -10
+ ELSE IF( LDVL.LT.1 .OR. LDVL.LT.NMAX ) THEN
+ INFO = -17
+ ELSE IF( LDVR.LT.1 .OR. LDVR.LT.NMAX ) THEN
+ INFO = -19
+ ELSE IF( LDLRE.LT.1 .OR. LDLRE.LT.NMAX ) THEN
+ INFO = -21
+ ELSE IF( 6*NMAX+2*NMAX**2.GT.NWORK ) THEN
+ INFO = -32
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DDRVVX', -INFO )
+ RETURN
+ END IF
+*
+* If nothing to do check on NIUNIT
+*
+ IF( NSIZES.EQ.0 .OR. NTYPES.EQ.0 )
+ $ GO TO 160
+*
+* More Important constants
+*
+ UNFL = DLAMCH( 'Safe minimum' )
+ OVFL = ONE / UNFL
+ CALL DLABAD( UNFL, OVFL )
+ ULP = DLAMCH( 'Precision' )
+ ULPINV = ONE / ULP
+ RTULP = SQRT( ULP )
+ RTULPI = ONE / RTULP
+*
+* Loop over sizes, types
+*
+ NERRS = 0
+*
+ DO 150 JSIZE = 1, NSIZES
+ N = NN( JSIZE )
+ IF( NSIZES.NE.1 ) THEN
+ MTYPES = MIN( MAXTYP, NTYPES )
+ ELSE
+ MTYPES = MIN( MAXTYP+1, NTYPES )
+ END IF
+*
+ DO 140 JTYPE = 1, MTYPES
+ IF( .NOT.DOTYPE( JTYPE ) )
+ $ GO TO 140
+*
+* Save ISEED in case of an error.
+*
+ DO 20 J = 1, 4
+ IOLDSD( J ) = ISEED( J )
+ 20 CONTINUE
+*
+* Compute "A"
+*
+* Control parameters:
+*
+* KMAGN KCONDS KMODE KTYPE
+* =1 O(1) 1 clustered 1 zero
+* =2 large large clustered 2 identity
+* =3 small exponential Jordan
+* =4 arithmetic diagonal, (w/ eigenvalues)
+* =5 random log symmetric, w/ eigenvalues
+* =6 random general, w/ eigenvalues
+* =7 random diagonal
+* =8 random symmetric
+* =9 random general
+* =10 random triangular
+*
+ IF( MTYPES.GT.MAXTYP )
+ $ GO TO 90
+*
+ ITYPE = KTYPE( JTYPE )
+ IMODE = KMODE( JTYPE )
+*
+* Compute norm
+*
+ GO TO ( 30, 40, 50 )KMAGN( JTYPE )
+*
+ 30 CONTINUE
+ ANORM = ONE
+ GO TO 60
+*
+ 40 CONTINUE
+ ANORM = OVFL*ULP
+ GO TO 60
+*
+ 50 CONTINUE
+ ANORM = UNFL*ULPINV
+ GO TO 60
+*
+ 60 CONTINUE
+*
+ CALL DLASET( 'Full', LDA, N, ZERO, ZERO, A, LDA )
+ IINFO = 0
+ COND = ULPINV
+*
+* Special Matrices -- Identity & Jordan block
+*
+* Zero
+*
+ IF( ITYPE.EQ.1 ) THEN
+ IINFO = 0
+*
+ ELSE IF( ITYPE.EQ.2 ) THEN
+*
+* Identity
+*
+ DO 70 JCOL = 1, N
+ A( JCOL, JCOL ) = ANORM
+ 70 CONTINUE
+*
+ ELSE IF( ITYPE.EQ.3 ) THEN
+*
+* Jordan Block
+*
+ DO 80 JCOL = 1, N
+ A( JCOL, JCOL ) = ANORM
+ IF( JCOL.GT.1 )
+ $ A( JCOL, JCOL-1 ) = ONE
+ 80 CONTINUE
+*
+ ELSE IF( ITYPE.EQ.4 ) THEN
+*
+* Diagonal Matrix, [Eigen]values Specified
+*
+ CALL DLATMS( N, N, 'S', ISEED, 'S', WORK, IMODE, COND,
+ $ ANORM, 0, 0, 'N', A, LDA, WORK( N+1 ),
+ $ IINFO )
+*
+ ELSE IF( ITYPE.EQ.5 ) THEN
+*
+* Symmetric, eigenvalues specified
+*
+ CALL DLATMS( N, N, 'S', ISEED, 'S', WORK, IMODE, COND,
+ $ ANORM, N, N, 'N', A, LDA, WORK( N+1 ),
+ $ IINFO )
+*
+ ELSE IF( ITYPE.EQ.6 ) THEN
+*
+* General, eigenvalues specified
+*
+ IF( KCONDS( JTYPE ).EQ.1 ) THEN
+ CONDS = ONE
+ ELSE IF( KCONDS( JTYPE ).EQ.2 ) THEN
+ CONDS = RTULPI
+ ELSE
+ CONDS = ZERO
+ END IF
+*
+ ADUMMA( 1 ) = ' '
+ CALL DLATME( N, 'S', ISEED, WORK, IMODE, COND, ONE,
+ $ ADUMMA, 'T', 'T', 'T', WORK( N+1 ), 4,
+ $ CONDS, N, N, ANORM, A, LDA, WORK( 2*N+1 ),
+ $ IINFO )
+*
+ ELSE IF( ITYPE.EQ.7 ) THEN
+*
+* Diagonal, random eigenvalues
+*
+ CALL DLATMR( N, N, 'S', ISEED, 'S', WORK, 6, ONE, ONE,
+ $ 'T', 'N', WORK( N+1 ), 1, ONE,
+ $ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, 0, 0,
+ $ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO )
+*
+ ELSE IF( ITYPE.EQ.8 ) THEN
+*
+* Symmetric, random eigenvalues
+*
+ CALL DLATMR( N, N, 'S', ISEED, 'S', WORK, 6, ONE, ONE,
+ $ 'T', 'N', WORK( N+1 ), 1, ONE,
+ $ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, N, N,
+ $ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO )
+*
+ ELSE IF( ITYPE.EQ.9 ) THEN
+*
+* General, random eigenvalues
+*
+ CALL DLATMR( N, N, 'S', ISEED, 'N', WORK, 6, ONE, ONE,
+ $ 'T', 'N', WORK( N+1 ), 1, ONE,
+ $ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, N, N,
+ $ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO )
+ IF( N.GE.4 ) THEN
+ CALL DLASET( 'Full', 2, N, ZERO, ZERO, A, LDA )
+ CALL DLASET( 'Full', N-3, 1, ZERO, ZERO, A( 3, 1 ),
+ $ LDA )
+ CALL DLASET( 'Full', N-3, 2, ZERO, ZERO, A( 3, N-1 ),
+ $ LDA )
+ CALL DLASET( 'Full', 1, N, ZERO, ZERO, A( N, 1 ),
+ $ LDA )
+ END IF
+*
+ ELSE IF( ITYPE.EQ.10 ) THEN
+*
+* Triangular, random eigenvalues
+*
+ CALL DLATMR( N, N, 'S', ISEED, 'N', WORK, 6, ONE, ONE,
+ $ 'T', 'N', WORK( N+1 ), 1, ONE,
+ $ WORK( 2*N+1 ), 1, ONE, 'N', IDUMMA, N, 0,
+ $ ZERO, ANORM, 'NO', A, LDA, IWORK, IINFO )
+*
+ ELSE
+*
+ IINFO = 1
+ END IF
+*
+ IF( IINFO.NE.0 ) THEN
+ WRITE( NOUNIT, FMT = 9992 )'Generator', IINFO, N, JTYPE,
+ $ IOLDSD
+ INFO = ABS( IINFO )
+ RETURN
+ END IF
+*
+ 90 CONTINUE
+*
+* Test for minimal and generous workspace
+*
+ DO 130 IWK = 1, 3
+ IF( IWK.EQ.1 ) THEN
+ NNWORK = 3*N
+ ELSE IF( IWK.EQ.2 ) THEN
+ NNWORK = 6*N + N**2
+ ELSE
+ NNWORK = 6*N + 2*N**2
+ END IF
+ NNWORK = MAX( NNWORK, 1 )
+*
+* Test for all balancing options
+*
+ DO 120 IBAL = 1, 4
+ BALANC = BAL( IBAL )
+*
+* Perform tests
+*
+ CALL DGET23( .FALSE., BALANC, JTYPE, THRESH, IOLDSD,
+ $ NOUNIT, N, A, LDA, H, WR, WI, WR1, WI1,
+ $ VL, LDVL, VR, LDVR, LRE, LDLRE, RCONDV,
+ $ RCNDV1, RCDVIN, RCONDE, RCNDE1, RCDEIN,
+ $ SCALE, SCALE1, RESULT, WORK, NNWORK,
+ $ IWORK, INFO )
+*
+* Check for RESULT(j) > THRESH
+*
+ NTEST = 0
+ NFAIL = 0
+ DO 100 J = 1, 9
+ IF( RESULT( J ).GE.ZERO )
+ $ NTEST = NTEST + 1
+ IF( RESULT( J ).GE.THRESH )
+ $ NFAIL = NFAIL + 1
+ 100 CONTINUE
+*
+ IF( NFAIL.GT.0 )
+ $ NTESTF = NTESTF + 1
+ IF( NTESTF.EQ.1 ) THEN
+ WRITE( NOUNIT, FMT = 9999 )PATH
+ WRITE( NOUNIT, FMT = 9998 )
+ WRITE( NOUNIT, FMT = 9997 )
+ WRITE( NOUNIT, FMT = 9996 )
+ WRITE( NOUNIT, FMT = 9995 )THRESH
+ NTESTF = 2
+ END IF
+*
+ DO 110 J = 1, 9
+ IF( RESULT( J ).GE.THRESH ) THEN
+ WRITE( NOUNIT, FMT = 9994 )BALANC, N, IWK,
+ $ IOLDSD, JTYPE, J, RESULT( J )
+ END IF
+ 110 CONTINUE
+*
+ NERRS = NERRS + NFAIL
+ NTESTT = NTESTT + NTEST
+*
+ 120 CONTINUE
+ 130 CONTINUE
+ 140 CONTINUE
+ 150 CONTINUE
+*
+ 160 CONTINUE
+*
+* Read in data from file to check accuracy of condition estimation.
+* Assume input eigenvalues are sorted lexicographically (increasing
+* by real part, then decreasing by imaginary part)
+*
+ JTYPE = 0
+ 170 CONTINUE
+ READ( NIUNIT, FMT = *, END = 220 )N
+*
+* Read input data until N=0
+*
+ IF( N.EQ.0 )
+ $ GO TO 220
+ JTYPE = JTYPE + 1
+ ISEED( 1 ) = JTYPE
+ DO 180 I = 1, N
+ READ( NIUNIT, FMT = * )( A( I, J ), J = 1, N )
+ 180 CONTINUE
+ DO 190 I = 1, N
+ READ( NIUNIT, FMT = * )WR1( I ), WI1( I ), RCDEIN( I ),
+ $ RCDVIN( I )
+ 190 CONTINUE
+ CALL DGET23( .TRUE., 'N', 22, THRESH, ISEED, NOUNIT, N, A, LDA, H,
+ $ WR, WI, WR1, WI1, VL, LDVL, VR, LDVR, LRE, LDLRE,
+ $ RCONDV, RCNDV1, RCDVIN, RCONDE, RCNDE1, RCDEIN,
+ $ SCALE, SCALE1, RESULT, WORK, 6*N+2*N**2, IWORK,
+ $ INFO )
+*
+* Check for RESULT(j) > THRESH
+*
+ NTEST = 0
+ NFAIL = 0
+ DO 200 J = 1, 11
+ IF( RESULT( J ).GE.ZERO )
+ $ NTEST = NTEST + 1
+ IF( RESULT( J ).GE.THRESH )
+ $ NFAIL = NFAIL + 1
+ 200 CONTINUE
+*
+ IF( NFAIL.GT.0 )
+ $ NTESTF = NTESTF + 1
+ IF( NTESTF.EQ.1 ) THEN
+ WRITE( NOUNIT, FMT = 9999 )PATH
+ WRITE( NOUNIT, FMT = 9998 )
+ WRITE( NOUNIT, FMT = 9997 )
+ WRITE( NOUNIT, FMT = 9996 )
+ WRITE( NOUNIT, FMT = 9995 )THRESH
+ NTESTF = 2
+ END IF
+*
+ DO 210 J = 1, 11
+ IF( RESULT( J ).GE.THRESH ) THEN
+ WRITE( NOUNIT, FMT = 9993 )N, JTYPE, J, RESULT( J )
+ END IF
+ 210 CONTINUE
+*
+ NERRS = NERRS + NFAIL
+ NTESTT = NTESTT + NTEST
+ GO TO 170
+ 220 CONTINUE
+*
+* Summary
+*
+ CALL DLASUM( PATH, NOUNIT, NERRS, NTESTT )
+*
+ 9999 FORMAT( / 1X, A3, ' -- Real Eigenvalue-Eigenvector Decomposition',
+ $ ' Expert Driver', /
+ $ ' Matrix types (see DDRVVX for details): ' )
+*
+ 9998 FORMAT( / ' Special Matrices:', / ' 1=Zero matrix. ',
+ $ ' ', ' 5=Diagonal: geometr. spaced entries.',
+ $ / ' 2=Identity matrix. ', ' 6=Diagona',
+ $ 'l: clustered entries.', / ' 3=Transposed Jordan block. ',
+ $ ' ', ' 7=Diagonal: large, evenly spaced.', / ' ',
+ $ '4=Diagonal: evenly spaced entries. ', ' 8=Diagonal: s',
+ $ 'mall, evenly spaced.' )
+ 9997 FORMAT( ' Dense, Non-Symmetric Matrices:', / ' 9=Well-cond., ev',
+ $ 'enly spaced eigenvals.', ' 14=Ill-cond., geomet. spaced e',
+ $ 'igenals.', / ' 10=Well-cond., geom. spaced eigenvals. ',
+ $ ' 15=Ill-conditioned, clustered e.vals.', / ' 11=Well-cond',
+ $ 'itioned, clustered e.vals. ', ' 16=Ill-cond., random comp',
+ $ 'lex ', / ' 12=Well-cond., random complex ', ' ',
+ $ ' 17=Ill-cond., large rand. complx ', / ' 13=Ill-condi',
+ $ 'tioned, evenly spaced. ', ' 18=Ill-cond., small rand.',
+ $ ' complx ' )
+ 9996 FORMAT( ' 19=Matrix with random O(1) entries. ', ' 21=Matrix ',
+ $ 'with small random entries.', / ' 20=Matrix with large ran',
+ $ 'dom entries. ', ' 22=Matrix read from input file', / )
+ 9995 FORMAT( ' Tests performed with test threshold =', F8.2,
+ $ / / ' 1 = | A VR - VR W | / ( n |A| ulp ) ',
+ $ / ' 2 = | transpose(A) VL - VL W | / ( n |A| ulp ) ',
+ $ / ' 3 = | |VR(i)| - 1 | / ulp ',
+ $ / ' 4 = | |VL(i)| - 1 | / ulp ',
+ $ / ' 5 = 0 if W same no matter if VR or VL computed,',
+ $ ' 1/ulp otherwise', /
+ $ ' 6 = 0 if VR same no matter what else computed,',
+ $ ' 1/ulp otherwise', /
+ $ ' 7 = 0 if VL same no matter what else computed,',
+ $ ' 1/ulp otherwise', /
+ $ ' 8 = 0 if RCONDV same no matter what else computed,',
+ $ ' 1/ulp otherwise', /
+ $ ' 9 = 0 if SCALE, ILO, IHI, ABNRM same no matter what else',
+ $ ' computed, 1/ulp otherwise',
+ $ / ' 10 = | RCONDV - RCONDV(precomputed) | / cond(RCONDV),',
+ $ / ' 11 = | RCONDE - RCONDE(precomputed) | / cond(RCONDE),' )
+ 9994 FORMAT( ' BALANC=''', A1, ''',N=', I4, ',IWK=', I1, ', seed=',
+ $ 4( I4, ',' ), ' type ', I2, ', test(', I2, ')=', G10.3 )
+ 9993 FORMAT( ' N=', I5, ', input example =', I3, ', test(', I2, ')=',
+ $ G10.3 )
+ 9992 FORMAT( ' DDRVVX: ', A, ' returned INFO=', I6, '.', / 9X, 'N=',
+ $ I6, ', JTYPE=', I6, ', ISEED=(', 3( I5, ',' ), I5, ')' )
+*
+ RETURN
+*
+* End of DDRVVX
+*
+ END
+ SUBROUTINE DERRBD( PATH, NUNIT )
+*
+* -- LAPACK test routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER*3 PATH
+ INTEGER NUNIT
+* ..
+*
+* Purpose
+* =======
+*
+* DERRBD tests the error exits for DGEBRD, DORGBR, DORMBR, DBDSQR and
+* DBDSDC.
+*
+* Arguments
+* =========
+*
+* PATH (input) CHARACTER*3
+* The LAPACK path name for the routines to be tested.
+*
+* NUNIT (input) INTEGER
+* The unit number for output.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ INTEGER NMAX, LW
+ PARAMETER ( NMAX = 4, LW = NMAX )
+* ..
+* .. Local Scalars ..
+ CHARACTER*2 C2
+ INTEGER I, INFO, J, NT
+* ..
+* .. Local Arrays ..
+ INTEGER IQ( NMAX, NMAX ), IW( NMAX )
+ DOUBLE PRECISION A( NMAX, NMAX ), D( NMAX ), E( NMAX ),
+ $ Q( NMAX, NMAX ), TP( NMAX ), TQ( NMAX ),
+ $ U( NMAX, NMAX ), V( NMAX, NMAX ), W( LW )
+* ..
+* .. External Functions ..
+ LOGICAL LSAMEN
+ EXTERNAL LSAMEN
+* ..
+* .. External Subroutines ..
+ EXTERNAL CHKXER, DBDSDC, DBDSQR, DGEBD2, DGEBRD, DORGBR,
+ $ DORMBR
+* ..
+* .. Scalars in Common ..
+ LOGICAL LERR, OK
+ CHARACTER*6 SRNAMT
+ INTEGER INFOT, NOUT
+* ..
+* .. Common blocks ..
+ COMMON / INFOC / INFOT, NOUT, OK, LERR
+ COMMON / SRNAMC / SRNAMT
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC DBLE
+* ..
+* .. Executable Statements ..
+*
+ NOUT = NUNIT
+ WRITE( NOUT, FMT = * )
+ C2 = PATH( 2: 3 )
+*
+* Set the variables to innocuous values.
+*
+ DO 20 J = 1, NMAX
+ DO 10 I = 1, NMAX
+ A( I, J ) = 1.D0 / DBLE( I+J )
+ 10 CONTINUE
+ 20 CONTINUE
+ OK = .TRUE.
+ NT = 0
+*
+* Test error exits of the SVD routines.
+*
+ IF( LSAMEN( 2, C2, 'BD' ) ) THEN
+*
+* DGEBRD
+*
+ SRNAMT = 'DGEBRD'
+ INFOT = 1
+ CALL DGEBRD( -1, 0, A, 1, D, E, TQ, TP, W, 1, INFO )
+ CALL CHKXER( 'DGEBRD', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL DGEBRD( 0, -1, A, 1, D, E, TQ, TP, W, 1, INFO )
+ CALL CHKXER( 'DGEBRD', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL DGEBRD( 2, 1, A, 1, D, E, TQ, TP, W, 2, INFO )
+ CALL CHKXER( 'DGEBRD', INFOT, NOUT, LERR, OK )
+ INFOT = 10
+ CALL DGEBRD( 2, 1, A, 2, D, E, TQ, TP, W, 1, INFO )
+ CALL CHKXER( 'DGEBRD', INFOT, NOUT, LERR, OK )
+ NT = NT + 4
+*
+* DGEBD2
+*
+ SRNAMT = 'DGEBD2'
+ INFOT = 1
+ CALL DGEBD2( -1, 0, A, 1, D, E, TQ, TP, W, INFO )
+ CALL CHKXER( 'DGEBD2', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL DGEBD2( 0, -1, A, 1, D, E, TQ, TP, W, INFO )
+ CALL CHKXER( 'DGEBD2', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL DGEBD2( 2, 1, A, 1, D, E, TQ, TP, W, INFO )
+ CALL CHKXER( 'DGEBD2', INFOT, NOUT, LERR, OK )
+ NT = NT + 3
+*
+* DORGBR
+*
+ SRNAMT = 'DORGBR'
+ INFOT = 1
+ CALL DORGBR( '/', 0, 0, 0, A, 1, TQ, W, 1, INFO )
+ CALL CHKXER( 'DORGBR', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL DORGBR( 'Q', -1, 0, 0, A, 1, TQ, W, 1, INFO )
+ CALL CHKXER( 'DORGBR', INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL DORGBR( 'Q', 0, -1, 0, A, 1, TQ, W, 1, INFO )
+ CALL CHKXER( 'DORGBR', INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL DORGBR( 'Q', 0, 1, 0, A, 1, TQ, W, 1, INFO )
+ CALL CHKXER( 'DORGBR', INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL DORGBR( 'Q', 1, 0, 1, A, 1, TQ, W, 1, INFO )
+ CALL CHKXER( 'DORGBR', INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL DORGBR( 'P', 1, 0, 0, A, 1, TQ, W, 1, INFO )
+ CALL CHKXER( 'DORGBR', INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL DORGBR( 'P', 0, 1, 1, A, 1, TQ, W, 1, INFO )
+ CALL CHKXER( 'DORGBR', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL DORGBR( 'Q', 0, 0, -1, A, 1, TQ, W, 1, INFO )
+ CALL CHKXER( 'DORGBR', INFOT, NOUT, LERR, OK )
+ INFOT = 6
+ CALL DORGBR( 'Q', 2, 1, 1, A, 1, TQ, W, 1, INFO )
+ CALL CHKXER( 'DORGBR', INFOT, NOUT, LERR, OK )
+ INFOT = 9
+ CALL DORGBR( 'Q', 2, 2, 1, A, 2, TQ, W, 1, INFO )
+ CALL CHKXER( 'DORGBR', INFOT, NOUT, LERR, OK )
+ NT = NT + 10
+*
+* DORMBR
+*
+ SRNAMT = 'DORMBR'
+ INFOT = 1
+ CALL DORMBR( '/', 'L', 'T', 0, 0, 0, A, 1, TQ, U, 1, W, 1,
+ $ INFO )
+ CALL CHKXER( 'DORMBR', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL DORMBR( 'Q', '/', 'T', 0, 0, 0, A, 1, TQ, U, 1, W, 1,
+ $ INFO )
+ CALL CHKXER( 'DORMBR', INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL DORMBR( 'Q', 'L', '/', 0, 0, 0, A, 1, TQ, U, 1, W, 1,
+ $ INFO )
+ CALL CHKXER( 'DORMBR', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL DORMBR( 'Q', 'L', 'T', -1, 0, 0, A, 1, TQ, U, 1, W, 1,
+ $ INFO )
+ CALL CHKXER( 'DORMBR', INFOT, NOUT, LERR, OK )
+ INFOT = 5
+ CALL DORMBR( 'Q', 'L', 'T', 0, -1, 0, A, 1, TQ, U, 1, W, 1,
+ $ INFO )
+ CALL CHKXER( 'DORMBR', INFOT, NOUT, LERR, OK )
+ INFOT = 6
+ CALL DORMBR( 'Q', 'L', 'T', 0, 0, -1, A, 1, TQ, U, 1, W, 1,
+ $ INFO )
+ CALL CHKXER( 'DORMBR', INFOT, NOUT, LERR, OK )
+ INFOT = 8
+ CALL DORMBR( 'Q', 'L', 'T', 2, 0, 0, A, 1, TQ, U, 2, W, 1,
+ $ INFO )
+ CALL CHKXER( 'DORMBR', INFOT, NOUT, LERR, OK )
+ INFOT = 8
+ CALL DORMBR( 'Q', 'R', 'T', 0, 2, 0, A, 1, TQ, U, 1, W, 1,
+ $ INFO )
+ CALL CHKXER( 'DORMBR', INFOT, NOUT, LERR, OK )
+ INFOT = 8
+ CALL DORMBR( 'P', 'L', 'T', 2, 0, 2, A, 1, TQ, U, 2, W, 1,
+ $ INFO )
+ CALL CHKXER( 'DORMBR', INFOT, NOUT, LERR, OK )
+ INFOT = 8
+ CALL DORMBR( 'P', 'R', 'T', 0, 2, 2, A, 1, TQ, U, 1, W, 1,
+ $ INFO )
+ CALL CHKXER( 'DORMBR', INFOT, NOUT, LERR, OK )
+ INFOT = 11
+ CALL DORMBR( 'Q', 'R', 'T', 2, 0, 0, A, 1, TQ, U, 1, W, 1,
+ $ INFO )
+ CALL CHKXER( 'DORMBR', INFOT, NOUT, LERR, OK )
+ INFOT = 13
+ CALL DORMBR( 'Q', 'L', 'T', 0, 2, 0, A, 1, TQ, U, 1, W, 1,
+ $ INFO )
+ CALL CHKXER( 'DORMBR', INFOT, NOUT, LERR, OK )
+ INFOT = 13
+ CALL DORMBR( 'Q', 'R', 'T', 2, 0, 0, A, 1, TQ, U, 2, W, 1,
+ $ INFO )
+ CALL CHKXER( 'DORMBR', INFOT, NOUT, LERR, OK )
+ NT = NT + 13
+*
+* DBDSQR
+*
+ SRNAMT = 'DBDSQR'
+ INFOT = 1
+ CALL DBDSQR( '/', 0, 0, 0, 0, D, E, V, 1, U, 1, A, 1, W, INFO )
+ CALL CHKXER( 'DBDSQR', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL DBDSQR( 'U', -1, 0, 0, 0, D, E, V, 1, U, 1, A, 1, W,
+ $ INFO )
+ CALL CHKXER( 'DBDSQR', INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL DBDSQR( 'U', 0, -1, 0, 0, D, E, V, 1, U, 1, A, 1, W,
+ $ INFO )
+ CALL CHKXER( 'DBDSQR', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL DBDSQR( 'U', 0, 0, -1, 0, D, E, V, 1, U, 1, A, 1, W,
+ $ INFO )
+ CALL CHKXER( 'DBDSQR', INFOT, NOUT, LERR, OK )
+ INFOT = 5
+ CALL DBDSQR( 'U', 0, 0, 0, -1, D, E, V, 1, U, 1, A, 1, W,
+ $ INFO )
+ CALL CHKXER( 'DBDSQR', INFOT, NOUT, LERR, OK )
+ INFOT = 9
+ CALL DBDSQR( 'U', 2, 1, 0, 0, D, E, V, 1, U, 1, A, 1, W, INFO )
+ CALL CHKXER( 'DBDSQR', INFOT, NOUT, LERR, OK )
+ INFOT = 11
+ CALL DBDSQR( 'U', 0, 0, 2, 0, D, E, V, 1, U, 1, A, 1, W, INFO )
+ CALL CHKXER( 'DBDSQR', INFOT, NOUT, LERR, OK )
+ INFOT = 13
+ CALL DBDSQR( 'U', 2, 0, 0, 1, D, E, V, 1, U, 1, A, 1, W, INFO )
+ CALL CHKXER( 'DBDSQR', INFOT, NOUT, LERR, OK )
+ NT = NT + 8
+*
+* DBDSDC
+*
+ SRNAMT = 'DBDSDC'
+ INFOT = 1
+ CALL DBDSDC( '/', 'N', 0, D, E, U, 1, V, 1, Q, IQ, W, IW,
+ $ INFO )
+ CALL CHKXER( 'DBDSDC', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL DBDSDC( 'U', '/', 0, D, E, U, 1, V, 1, Q, IQ, W, IW,
+ $ INFO )
+ CALL CHKXER( 'DBDSDC', INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL DBDSDC( 'U', 'N', -1, D, E, U, 1, V, 1, Q, IQ, W, IW,
+ $ INFO )
+ CALL CHKXER( 'DBDSDC', INFOT, NOUT, LERR, OK )
+ INFOT = 7
+ CALL DBDSDC( 'U', 'I', 2, D, E, U, 1, V, 1, Q, IQ, W, IW,
+ $ INFO )
+ CALL CHKXER( 'DBDSDC', INFOT, NOUT, LERR, OK )
+ INFOT = 9
+ CALL DBDSDC( 'U', 'I', 2, D, E, U, 2, V, 1, Q, IQ, W, IW,
+ $ INFO )
+ CALL CHKXER( 'DBDSDC', INFOT, NOUT, LERR, OK )
+ NT = NT + 5
+ END IF
+*
+* Print a summary line.
+*
+ IF( OK ) THEN
+ WRITE( NOUT, FMT = 9999 )PATH, NT
+ ELSE
+ WRITE( NOUT, FMT = 9998 )PATH
+ END IF
+*
+ 9999 FORMAT( 1X, A3, ' routines passed the tests of the error exits',
+ $ ' (', I3, ' tests done)' )
+ 9998 FORMAT( ' *** ', A3, ' routines failed the tests of the error ',
+ $ 'exits ***' )
+*
+ RETURN
+*
+* End of DERRBD
+*
+ END
+ SUBROUTINE DERREC( PATH, NUNIT )
+*
+* -- LAPACK test routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER*3 PATH
+ INTEGER NUNIT
+* ..
+*
+* Purpose
+* =======
+*
+* DERREC tests the error exits for the routines for eigen- condition
+* estimation for DOUBLE PRECISION matrices:
+* DTRSYL, STREXC, STRSNA and STRSEN.
+*
+* Arguments
+* =========
+*
+* PATH (input) CHARACTER*3
+* The LAPACK path name for the routines to be tested.
+*
+* NUNIT (input) INTEGER
+* The unit number for output.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ INTEGER NMAX
+ DOUBLE PRECISION ONE, ZERO
+ PARAMETER ( NMAX = 4, ONE = 1.0D0, ZERO = 0.0D0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, IFST, ILST, INFO, J, M, NT
+ DOUBLE PRECISION SCALE
+* ..
+* .. Local Arrays ..
+ LOGICAL SEL( NMAX )
+ INTEGER IWORK( NMAX )
+ DOUBLE PRECISION A( NMAX, NMAX ), B( NMAX, NMAX ),
+ $ C( NMAX, NMAX ), S( NMAX ), SEP( NMAX ),
+ $ WI( NMAX ), WORK( NMAX ), WR( NMAX )
+* ..
+* .. External Subroutines ..
+ EXTERNAL CHKXER, DTREXC, DTRSEN, DTRSNA, DTRSYL
+* ..
+* .. Scalars in Common ..
+ LOGICAL LERR, OK
+ CHARACTER*6 SRNAMT
+ INTEGER INFOT, NOUT
+* ..
+* .. Common blocks ..
+ COMMON / INFOC / INFOT, NOUT, OK, LERR
+ COMMON / SRNAMC / SRNAMT
+* ..
+* .. Executable Statements ..
+*
+ NOUT = NUNIT
+ OK = .TRUE.
+ NT = 0
+*
+* Initialize A, B and SEL
+*
+ DO 20 J = 1, NMAX
+ DO 10 I = 1, NMAX
+ A( I, J ) = ZERO
+ B( I, J ) = ZERO
+ 10 CONTINUE
+ 20 CONTINUE
+ DO 30 I = 1, NMAX
+ A( I, I ) = ONE
+ SEL( I ) = .TRUE.
+ 30 CONTINUE
+*
+* Test DTRSYL
+*
+ SRNAMT = 'DTRSYL'
+ INFOT = 1
+ CALL DTRSYL( 'X', 'N', 1, 0, 0, A, 1, B, 1, C, 1, SCALE, INFO )
+ CALL CHKXER( 'DTRSYL', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL DTRSYL( 'N', 'X', 1, 0, 0, A, 1, B, 1, C, 1, SCALE, INFO )
+ CALL CHKXER( 'DTRSYL', INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL DTRSYL( 'N', 'N', 0, 0, 0, A, 1, B, 1, C, 1, SCALE, INFO )
+ CALL CHKXER( 'DTRSYL', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL DTRSYL( 'N', 'N', 1, -1, 0, A, 1, B, 1, C, 1, SCALE, INFO )
+ CALL CHKXER( 'DTRSYL', INFOT, NOUT, LERR, OK )
+ INFOT = 5
+ CALL DTRSYL( 'N', 'N', 1, 0, -1, A, 1, B, 1, C, 1, SCALE, INFO )
+ CALL CHKXER( 'DTRSYL', INFOT, NOUT, LERR, OK )
+ INFOT = 7
+ CALL DTRSYL( 'N', 'N', 1, 2, 0, A, 1, B, 1, C, 2, SCALE, INFO )
+ CALL CHKXER( 'DTRSYL', INFOT, NOUT, LERR, OK )
+ INFOT = 9
+ CALL DTRSYL( 'N', 'N', 1, 0, 2, A, 1, B, 1, C, 1, SCALE, INFO )
+ CALL CHKXER( 'DTRSYL', INFOT, NOUT, LERR, OK )
+ INFOT = 11
+ CALL DTRSYL( 'N', 'N', 1, 2, 0, A, 2, B, 1, C, 1, SCALE, INFO )
+ CALL CHKXER( 'DTRSYL', INFOT, NOUT, LERR, OK )
+ NT = NT + 8
+*
+* Test DTREXC
+*
+ SRNAMT = 'DTREXC'
+ IFST = 1
+ ILST = 1
+ INFOT = 1
+ CALL DTREXC( 'X', 1, A, 1, B, 1, IFST, ILST, WORK, INFO )
+ CALL CHKXER( 'DTREXC', INFOT, NOUT, LERR, OK )
+ INFOT = 7
+ CALL DTREXC( 'N', 0, A, 1, B, 1, IFST, ILST, WORK, INFO )
+ CALL CHKXER( 'DTREXC', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ ILST = 2
+ CALL DTREXC( 'N', 2, A, 1, B, 1, IFST, ILST, WORK, INFO )
+ CALL CHKXER( 'DTREXC', INFOT, NOUT, LERR, OK )
+ INFOT = 6
+ CALL DTREXC( 'V', 2, A, 2, B, 1, IFST, ILST, WORK, INFO )
+ CALL CHKXER( 'DTREXC', INFOT, NOUT, LERR, OK )
+ INFOT = 7
+ IFST = 0
+ ILST = 1
+ CALL DTREXC( 'V', 1, A, 1, B, 1, IFST, ILST, WORK, INFO )
+ CALL CHKXER( 'DTREXC', INFOT, NOUT, LERR, OK )
+ INFOT = 7
+ IFST = 2
+ CALL DTREXC( 'V', 1, A, 1, B, 1, IFST, ILST, WORK, INFO )
+ CALL CHKXER( 'DTREXC', INFOT, NOUT, LERR, OK )
+ INFOT = 8
+ IFST = 1
+ ILST = 0
+ CALL DTREXC( 'V', 1, A, 1, B, 1, IFST, ILST, WORK, INFO )
+ CALL CHKXER( 'DTREXC', INFOT, NOUT, LERR, OK )
+ INFOT = 8
+ ILST = 2
+ CALL DTREXC( 'V', 1, A, 1, B, 1, IFST, ILST, WORK, INFO )
+ CALL CHKXER( 'DTREXC', INFOT, NOUT, LERR, OK )
+ NT = NT + 8
+*
+* Test DTRSNA
+*
+ SRNAMT = 'DTRSNA'
+ INFOT = 1
+ CALL DTRSNA( 'X', 'A', SEL, 0, A, 1, B, 1, C, 1, S, SEP, 1, M,
+ $ WORK, 1, IWORK, INFO )
+ CALL CHKXER( 'DTRSNA', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL DTRSNA( 'B', 'X', SEL, 0, A, 1, B, 1, C, 1, S, SEP, 1, M,
+ $ WORK, 1, IWORK, INFO )
+ CALL CHKXER( 'DTRSNA', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL DTRSNA( 'B', 'A', SEL, -1, A, 1, B, 1, C, 1, S, SEP, 1, M,
+ $ WORK, 1, IWORK, INFO )
+ CALL CHKXER( 'DTRSNA', INFOT, NOUT, LERR, OK )
+ INFOT = 6
+ CALL DTRSNA( 'V', 'A', SEL, 2, A, 1, B, 1, C, 1, S, SEP, 2, M,
+ $ WORK, 2, IWORK, INFO )
+ CALL CHKXER( 'DTRSNA', INFOT, NOUT, LERR, OK )
+ INFOT = 8
+ CALL DTRSNA( 'B', 'A', SEL, 2, A, 2, B, 1, C, 2, S, SEP, 2, M,
+ $ WORK, 2, IWORK, INFO )
+ CALL CHKXER( 'DTRSNA', INFOT, NOUT, LERR, OK )
+ INFOT = 10
+ CALL DTRSNA( 'B', 'A', SEL, 2, A, 2, B, 2, C, 1, S, SEP, 2, M,
+ $ WORK, 2, IWORK, INFO )
+ CALL CHKXER( 'DTRSNA', INFOT, NOUT, LERR, OK )
+ INFOT = 13
+ CALL DTRSNA( 'B', 'A', SEL, 1, A, 1, B, 1, C, 1, S, SEP, 0, M,
+ $ WORK, 1, IWORK, INFO )
+ CALL CHKXER( 'DTRSNA', INFOT, NOUT, LERR, OK )
+ INFOT = 13
+ CALL DTRSNA( 'B', 'S', SEL, 2, A, 2, B, 2, C, 2, S, SEP, 1, M,
+ $ WORK, 2, IWORK, INFO )
+ CALL CHKXER( 'DTRSNA', INFOT, NOUT, LERR, OK )
+ INFOT = 16
+ CALL DTRSNA( 'B', 'A', SEL, 2, A, 2, B, 2, C, 2, S, SEP, 2, M,
+ $ WORK, 1, IWORK, INFO )
+ CALL CHKXER( 'DTRSNA', INFOT, NOUT, LERR, OK )
+ NT = NT + 9
+*
+* Test DTRSEN
+*
+ SEL( 1 ) = .FALSE.
+ SRNAMT = 'DTRSEN'
+ INFOT = 1
+ CALL DTRSEN( 'X', 'N', SEL, 0, A, 1, B, 1, WR, WI, M, S( 1 ),
+ $ SEP( 1 ), WORK, 1, IWORK, 1, INFO )
+ CALL CHKXER( 'DTRSEN', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL DTRSEN( 'N', 'X', SEL, 0, A, 1, B, 1, WR, WI, M, S( 1 ),
+ $ SEP( 1 ), WORK, 1, IWORK, 1, INFO )
+ CALL CHKXER( 'DTRSEN', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL DTRSEN( 'N', 'N', SEL, -1, A, 1, B, 1, WR, WI, M, S( 1 ),
+ $ SEP( 1 ), WORK, 1, IWORK, 1, INFO )
+ CALL CHKXER( 'DTRSEN', INFOT, NOUT, LERR, OK )
+ INFOT = 6
+ CALL DTRSEN( 'N', 'N', SEL, 2, A, 1, B, 1, WR, WI, M, S( 1 ),
+ $ SEP( 1 ), WORK, 2, IWORK, 1, INFO )
+ CALL CHKXER( 'DTRSEN', INFOT, NOUT, LERR, OK )
+ INFOT = 8
+ CALL DTRSEN( 'N', 'V', SEL, 2, A, 2, B, 1, WR, WI, M, S( 1 ),
+ $ SEP( 1 ), WORK, 1, IWORK, 1, INFO )
+ CALL CHKXER( 'DTRSEN', INFOT, NOUT, LERR, OK )
+ INFOT = 15
+ CALL DTRSEN( 'N', 'V', SEL, 2, A, 2, B, 2, WR, WI, M, S( 1 ),
+ $ SEP( 1 ), WORK, 0, IWORK, 1, INFO )
+ CALL CHKXER( 'DTRSEN', INFOT, NOUT, LERR, OK )
+ INFOT = 15
+ CALL DTRSEN( 'E', 'V', SEL, 3, A, 3, B, 3, WR, WI, M, S( 1 ),
+ $ SEP( 1 ), WORK, 1, IWORK, 1, INFO )
+ CALL CHKXER( 'DTRSEN', INFOT, NOUT, LERR, OK )
+ INFOT = 15
+ CALL DTRSEN( 'V', 'V', SEL, 3, A, 3, B, 3, WR, WI, M, S( 1 ),
+ $ SEP( 1 ), WORK, 3, IWORK, 2, INFO )
+ CALL CHKXER( 'DTRSEN', INFOT, NOUT, LERR, OK )
+ INFOT = 17
+ CALL DTRSEN( 'E', 'V', SEL, 2, A, 2, B, 2, WR, WI, M, S( 1 ),
+ $ SEP( 1 ), WORK, 1, IWORK, 0, INFO )
+ CALL CHKXER( 'DTRSEN', INFOT, NOUT, LERR, OK )
+ INFOT = 17
+ CALL DTRSEN( 'V', 'V', SEL, 3, A, 3, B, 3, WR, WI, M, S( 1 ),
+ $ SEP( 1 ), WORK, 4, IWORK, 1, INFO )
+ CALL CHKXER( 'DTRSEN', INFOT, NOUT, LERR, OK )
+ NT = NT + 10
+*
+* Print a summary line.
+*
+ IF( OK ) THEN
+ WRITE( NOUT, FMT = 9999 )PATH, NT
+ ELSE
+ WRITE( NOUT, FMT = 9998 )PATH
+ END IF
+*
+ RETURN
+ 9999 FORMAT( 1X, A3, ' routines passed the tests of the error exits (',
+ $ I3, ' tests done)' )
+ 9998 FORMAT( ' *** ', A3, ' routines failed the tests of the error ex',
+ $ 'its ***' )
+*
+* End of DERREC
+*
+ END
+ SUBROUTINE DERRED( PATH, NUNIT )
+*
+* -- LAPACK test routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER*3 PATH
+ INTEGER NUNIT
+* ..
+*
+* Purpose
+* =======
+*
+* DERRED tests the error exits for the eigenvalue driver routines for
+* DOUBLE PRECISION matrices:
+*
+* PATH driver description
+* ---- ------ -----------
+* SEV DGEEV find eigenvalues/eigenvectors for nonsymmetric A
+* SES DGEES find eigenvalues/Schur form for nonsymmetric A
+* SVX DGEEVX SGEEV + balancing and condition estimation
+* SSX DGEESX SGEES + balancing and condition estimation
+* DBD DGESVD compute SVD of an M-by-N matrix A
+* DGESDD compute SVD of an M-by-N matrix A (by divide and
+* conquer)
+*
+* Arguments
+* =========
+*
+* PATH (input) CHARACTER*3
+* The LAPACK path name for the routines to be tested.
+*
+* NUNIT (input) INTEGER
+* The unit number for output.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ INTEGER NMAX
+ DOUBLE PRECISION ONE, ZERO
+ PARAMETER ( NMAX = 4, ONE = 1.0D0, ZERO = 0.0D0 )
+* ..
+* .. Local Scalars ..
+ CHARACTER*2 C2
+ INTEGER I, IHI, ILO, INFO, J, NT, SDIM
+ DOUBLE PRECISION ABNRM
+* ..
+* .. Local Arrays ..
+ LOGICAL B( NMAX )
+ INTEGER IW( 2*NMAX )
+ DOUBLE PRECISION A( NMAX, NMAX ), R1( NMAX ), R2( NMAX ),
+ $ S( NMAX ), U( NMAX, NMAX ), VL( NMAX, NMAX ),
+ $ VR( NMAX, NMAX ), VT( NMAX, NMAX ),
+ $ W( 4*NMAX ), WI( NMAX ), WR( NMAX )
+* ..
+* .. External Subroutines ..
+ EXTERNAL CHKXER, DGEES, DGEESX, DGEEV, DGEEVX, DGESDD,
+ $ DGESVD
+* ..
+* .. External Functions ..
+ LOGICAL DSLECT, LSAMEN
+ EXTERNAL DSLECT, LSAMEN
+* ..
+* .. Arrays in Common ..
+ LOGICAL SELVAL( 20 )
+ DOUBLE PRECISION SELWI( 20 ), SELWR( 20 )
+* ..
+* .. Scalars in Common ..
+ LOGICAL LERR, OK
+ CHARACTER*6 SRNAMT
+ INTEGER INFOT, NOUT, SELDIM, SELOPT
+* ..
+* .. Common blocks ..
+ COMMON / INFOC / INFOT, NOUT, OK, LERR
+ COMMON / SRNAMC / SRNAMT
+ COMMON / SSLCT / SELOPT, SELDIM, SELVAL, SELWR, SELWI
+* ..
+* .. Executable Statements ..
+*
+ NOUT = NUNIT
+ WRITE( NOUT, FMT = * )
+ C2 = PATH( 2: 3 )
+*
+* Initialize A
+*
+ DO 20 J = 1, NMAX
+ DO 10 I = 1, NMAX
+ A( I, J ) = ZERO
+ 10 CONTINUE
+ 20 CONTINUE
+ DO 30 I = 1, NMAX
+ A( I, I ) = ONE
+ 30 CONTINUE
+ OK = .TRUE.
+ NT = 0
+*
+ IF( LSAMEN( 2, C2, 'EV' ) ) THEN
+*
+* Test DGEEV
+*
+ SRNAMT = 'DGEEV '
+ INFOT = 1
+ CALL DGEEV( 'X', 'N', 0, A, 1, WR, WI, VL, 1, VR, 1, W, 1,
+ $ INFO )
+ CALL CHKXER( 'DGEEV ', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL DGEEV( 'N', 'X', 0, A, 1, WR, WI, VL, 1, VR, 1, W, 1,
+ $ INFO )
+ CALL CHKXER( 'DGEEV ', INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL DGEEV( 'N', 'N', -1, A, 1, WR, WI, VL, 1, VR, 1, W, 1,
+ $ INFO )
+ CALL CHKXER( 'DGEEV ', INFOT, NOUT, LERR, OK )
+ INFOT = 5
+ CALL DGEEV( 'N', 'N', 2, A, 1, WR, WI, VL, 1, VR, 1, W, 6,
+ $ INFO )
+ CALL CHKXER( 'DGEEV ', INFOT, NOUT, LERR, OK )
+ INFOT = 9
+ CALL DGEEV( 'V', 'N', 2, A, 2, WR, WI, VL, 1, VR, 1, W, 8,
+ $ INFO )
+ CALL CHKXER( 'DGEEV ', INFOT, NOUT, LERR, OK )
+ INFOT = 11
+ CALL DGEEV( 'N', 'V', 2, A, 2, WR, WI, VL, 1, VR, 1, W, 8,
+ $ INFO )
+ CALL CHKXER( 'DGEEV ', INFOT, NOUT, LERR, OK )
+ INFOT = 13
+ CALL DGEEV( 'V', 'V', 1, A, 1, WR, WI, VL, 1, VR, 1, W, 3,
+ $ INFO )
+ CALL CHKXER( 'DGEEV ', INFOT, NOUT, LERR, OK )
+ NT = NT + 7
+*
+ ELSE IF( LSAMEN( 2, C2, 'ES' ) ) THEN
+*
+* Test DGEES
+*
+ SRNAMT = 'DGEES '
+ INFOT = 1
+ CALL DGEES( 'X', 'N', DSLECT, 0, A, 1, SDIM, WR, WI, VL, 1, W,
+ $ 1, B, INFO )
+ CALL CHKXER( 'DGEES ', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL DGEES( 'N', 'X', DSLECT, 0, A, 1, SDIM, WR, WI, VL, 1, W,
+ $ 1, B, INFO )
+ CALL CHKXER( 'DGEES ', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL DGEES( 'N', 'S', DSLECT, -1, A, 1, SDIM, WR, WI, VL, 1, W,
+ $ 1, B, INFO )
+ CALL CHKXER( 'DGEES ', INFOT, NOUT, LERR, OK )
+ INFOT = 6
+ CALL DGEES( 'N', 'S', DSLECT, 2, A, 1, SDIM, WR, WI, VL, 1, W,
+ $ 6, B, INFO )
+ CALL CHKXER( 'DGEES ', INFOT, NOUT, LERR, OK )
+ INFOT = 11
+ CALL DGEES( 'V', 'S', DSLECT, 2, A, 2, SDIM, WR, WI, VL, 1, W,
+ $ 6, B, INFO )
+ CALL CHKXER( 'DGEES ', INFOT, NOUT, LERR, OK )
+ INFOT = 13
+ CALL DGEES( 'N', 'S', DSLECT, 1, A, 1, SDIM, WR, WI, VL, 1, W,
+ $ 2, B, INFO )
+ CALL CHKXER( 'DGEES ', INFOT, NOUT, LERR, OK )
+ NT = NT + 6
+*
+ ELSE IF( LSAMEN( 2, C2, 'VX' ) ) THEN
+*
+* Test DGEEVX
+*
+ SRNAMT = 'DGEEVX'
+ INFOT = 1
+ CALL DGEEVX( 'X', 'N', 'N', 'N', 0, A, 1, WR, WI, VL, 1, VR, 1,
+ $ ILO, IHI, S, ABNRM, R1, R2, W, 1, IW, INFO )
+ CALL CHKXER( 'DGEEVX', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL DGEEVX( 'N', 'X', 'N', 'N', 0, A, 1, WR, WI, VL, 1, VR, 1,
+ $ ILO, IHI, S, ABNRM, R1, R2, W, 1, IW, INFO )
+ CALL CHKXER( 'DGEEVX', INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL DGEEVX( 'N', 'N', 'X', 'N', 0, A, 1, WR, WI, VL, 1, VR, 1,
+ $ ILO, IHI, S, ABNRM, R1, R2, W, 1, IW, INFO )
+ CALL CHKXER( 'DGEEVX', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL DGEEVX( 'N', 'N', 'N', 'X', 0, A, 1, WR, WI, VL, 1, VR, 1,
+ $ ILO, IHI, S, ABNRM, R1, R2, W, 1, IW, INFO )
+ CALL CHKXER( 'DGEEVX', INFOT, NOUT, LERR, OK )
+ INFOT = 5
+ CALL DGEEVX( 'N', 'N', 'N', 'N', -1, A, 1, WR, WI, VL, 1, VR,
+ $ 1, ILO, IHI, S, ABNRM, R1, R2, W, 1, IW, INFO )
+ CALL CHKXER( 'DGEEVX', INFOT, NOUT, LERR, OK )
+ INFOT = 7
+ CALL DGEEVX( 'N', 'N', 'N', 'N', 2, A, 1, WR, WI, VL, 1, VR, 1,
+ $ ILO, IHI, S, ABNRM, R1, R2, W, 1, IW, INFO )
+ CALL CHKXER( 'DGEEVX', INFOT, NOUT, LERR, OK )
+ INFOT = 11
+ CALL DGEEVX( 'N', 'V', 'N', 'N', 2, A, 2, WR, WI, VL, 1, VR, 1,
+ $ ILO, IHI, S, ABNRM, R1, R2, W, 6, IW, INFO )
+ CALL CHKXER( 'DGEEVX', INFOT, NOUT, LERR, OK )
+ INFOT = 13
+ CALL DGEEVX( 'N', 'N', 'V', 'N', 2, A, 2, WR, WI, VL, 1, VR, 1,
+ $ ILO, IHI, S, ABNRM, R1, R2, W, 6, IW, INFO )
+ CALL CHKXER( 'DGEEVX', INFOT, NOUT, LERR, OK )
+ INFOT = 21
+ CALL DGEEVX( 'N', 'N', 'N', 'N', 1, A, 1, WR, WI, VL, 1, VR, 1,
+ $ ILO, IHI, S, ABNRM, R1, R2, W, 1, IW, INFO )
+ CALL CHKXER( 'DGEEVX', INFOT, NOUT, LERR, OK )
+ INFOT = 21
+ CALL DGEEVX( 'N', 'V', 'N', 'N', 1, A, 1, WR, WI, VL, 1, VR, 1,
+ $ ILO, IHI, S, ABNRM, R1, R2, W, 2, IW, INFO )
+ CALL CHKXER( 'DGEEVX', INFOT, NOUT, LERR, OK )
+ INFOT = 21
+ CALL DGEEVX( 'N', 'N', 'V', 'V', 1, A, 1, WR, WI, VL, 1, VR, 1,
+ $ ILO, IHI, S, ABNRM, R1, R2, W, 3, IW, INFO )
+ CALL CHKXER( 'DGEEVX', INFOT, NOUT, LERR, OK )
+ NT = NT + 11
+*
+ ELSE IF( LSAMEN( 2, C2, 'SX' ) ) THEN
+*
+* Test DGEESX
+*
+ SRNAMT = 'DGEESX'
+ INFOT = 1
+ CALL DGEESX( 'X', 'N', DSLECT, 'N', 0, A, 1, SDIM, WR, WI, VL,
+ $ 1, R1( 1 ), R2( 1 ), W, 1, IW, 1, B, INFO )
+ CALL CHKXER( 'DGEESX', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL DGEESX( 'N', 'X', DSLECT, 'N', 0, A, 1, SDIM, WR, WI, VL,
+ $ 1, R1( 1 ), R2( 1 ), W, 1, IW, 1, B, INFO )
+ CALL CHKXER( 'DGEESX', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL DGEESX( 'N', 'N', DSLECT, 'X', 0, A, 1, SDIM, WR, WI, VL,
+ $ 1, R1( 1 ), R2( 1 ), W, 1, IW, 1, B, INFO )
+ CALL CHKXER( 'DGEESX', INFOT, NOUT, LERR, OK )
+ INFOT = 5
+ CALL DGEESX( 'N', 'N', DSLECT, 'N', -1, A, 1, SDIM, WR, WI, VL,
+ $ 1, R1( 1 ), R2( 1 ), W, 1, IW, 1, B, INFO )
+ CALL CHKXER( 'DGEESX', INFOT, NOUT, LERR, OK )
+ INFOT = 7
+ CALL DGEESX( 'N', 'N', DSLECT, 'N', 2, A, 1, SDIM, WR, WI, VL,
+ $ 1, R1( 1 ), R2( 1 ), W, 6, IW, 1, B, INFO )
+ CALL CHKXER( 'DGEESX', INFOT, NOUT, LERR, OK )
+ INFOT = 12
+ CALL DGEESX( 'V', 'N', DSLECT, 'N', 2, A, 2, SDIM, WR, WI, VL,
+ $ 1, R1( 1 ), R2( 1 ), W, 6, IW, 1, B, INFO )
+ CALL CHKXER( 'DGEESX', INFOT, NOUT, LERR, OK )
+ INFOT = 16
+ CALL DGEESX( 'N', 'N', DSLECT, 'N', 1, A, 1, SDIM, WR, WI, VL,
+ $ 1, R1( 1 ), R2( 1 ), W, 2, IW, 1, B, INFO )
+ CALL CHKXER( 'DGEESX', INFOT, NOUT, LERR, OK )
+ NT = NT + 7
+*
+ ELSE IF( LSAMEN( 2, C2, 'BD' ) ) THEN
+*
+* Test DGESVD
+*
+ SRNAMT = 'DGESVD'
+ INFOT = 1
+ CALL DGESVD( 'X', 'N', 0, 0, A, 1, S, U, 1, VT, 1, W, 1, INFO )
+ CALL CHKXER( 'DGESVD', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL DGESVD( 'N', 'X', 0, 0, A, 1, S, U, 1, VT, 1, W, 1, INFO )
+ CALL CHKXER( 'DGESVD', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL DGESVD( 'O', 'O', 0, 0, A, 1, S, U, 1, VT, 1, W, 1, INFO )
+ CALL CHKXER( 'DGESVD', INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL DGESVD( 'N', 'N', -1, 0, A, 1, S, U, 1, VT, 1, W, 1,
+ $ INFO )
+ CALL CHKXER( 'DGESVD', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL DGESVD( 'N', 'N', 0, -1, A, 1, S, U, 1, VT, 1, W, 1,
+ $ INFO )
+ CALL CHKXER( 'DGESVD', INFOT, NOUT, LERR, OK )
+ INFOT = 6
+ CALL DGESVD( 'N', 'N', 2, 1, A, 1, S, U, 1, VT, 1, W, 5, INFO )
+ CALL CHKXER( 'DGESVD', INFOT, NOUT, LERR, OK )
+ INFOT = 9
+ CALL DGESVD( 'A', 'N', 2, 1, A, 2, S, U, 1, VT, 1, W, 5, INFO )
+ CALL CHKXER( 'DGESVD', INFOT, NOUT, LERR, OK )
+ INFOT = 11
+ CALL DGESVD( 'N', 'A', 1, 2, A, 1, S, U, 1, VT, 1, W, 5, INFO )
+ CALL CHKXER( 'DGESVD', INFOT, NOUT, LERR, OK )
+ NT = NT + 8
+ IF( OK ) THEN
+ WRITE( NOUT, FMT = 9999 )SRNAMT, NT
+ ELSE
+ WRITE( NOUT, FMT = 9998 )
+ END IF
+*
+* Test DGESDD
+*
+ SRNAMT = 'DGESDD'
+ INFOT = 1
+ CALL DGESDD( 'X', 0, 0, A, 1, S, U, 1, VT, 1, W, 1, IW, INFO )
+ CALL CHKXER( 'DGESDD', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL DGESDD( 'N', -1, 0, A, 1, S, U, 1, VT, 1, W, 1, IW, INFO )
+ CALL CHKXER( 'DGESDD', INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL DGESDD( 'N', 0, -1, A, 1, S, U, 1, VT, 1, W, 1, IW, INFO )
+ CALL CHKXER( 'DGESDD', INFOT, NOUT, LERR, OK )
+ INFOT = 5
+ CALL DGESDD( 'N', 2, 1, A, 1, S, U, 1, VT, 1, W, 5, IW, INFO )
+ CALL CHKXER( 'DGESDD', INFOT, NOUT, LERR, OK )
+ INFOT = 8
+ CALL DGESDD( 'A', 2, 1, A, 2, S, U, 1, VT, 1, W, 5, IW, INFO )
+ CALL CHKXER( 'DGESDD', INFOT, NOUT, LERR, OK )
+ INFOT = 10
+ CALL DGESDD( 'A', 1, 2, A, 1, S, U, 1, VT, 1, W, 5, IW, INFO )
+ CALL CHKXER( 'DGESDD', INFOT, NOUT, LERR, OK )
+ NT = NT - 2
+ IF( OK ) THEN
+ WRITE( NOUT, FMT = 9999 )SRNAMT, NT
+ ELSE
+ WRITE( NOUT, FMT = 9998 )
+ END IF
+ END IF
+*
+* Print a summary line.
+*
+ IF( .NOT.LSAMEN( 2, C2, 'BD' ) ) THEN
+ IF( OK ) THEN
+ WRITE( NOUT, FMT = 9999 )SRNAMT, NT
+ ELSE
+ WRITE( NOUT, FMT = 9998 )
+ END IF
+ END IF
+*
+ 9999 FORMAT( 1X, A6, ' passed the tests of the error exits (', I3,
+ $ ' tests done)' )
+ 9998 FORMAT( ' *** ', A6, ' failed the tests of the error exits ***' )
+ RETURN
+*
+* End of DERRED
+ END
+ SUBROUTINE DERRGG( PATH, NUNIT )
+*
+* -- LAPACK test routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER*3 PATH
+ INTEGER NUNIT
+* ..
+*
+* Purpose
+* =======
+*
+* DERRGG tests the error exits for DGGES, DGGESX, DGGEV, DGGEVX,
+* DGGGLM, DGGHRD, DGGLSE, DGGQRF, DGGRQF, DGGSVD, DGGSVP, DHGEQZ,
+* DTGEVC, DTGEXC, DTGSEN, DTGSJA, DTGSNA, and DTGSYL.
+*
+* Arguments
+* =========
+*
+* PATH (input) CHARACTER*3
+* The LAPACK path name for the routines to be tested.
+*
+* NUNIT (input) INTEGER
+* The unit number for output.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ INTEGER NMAX, LW
+ PARAMETER ( NMAX = 3, LW = 6*NMAX )
+ DOUBLE PRECISION ONE, ZERO
+ PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
+* ..
+* .. Local Scalars ..
+ CHARACTER*2 C2
+ INTEGER DUMMYK, DUMMYL, I, IFST, ILST, INFO, J, M,
+ $ NCYCLE, NT, SDIM
+ DOUBLE PRECISION ANRM, BNRM, DIF, SCALE, TOLA, TOLB
+* ..
+* .. Local Arrays ..
+ LOGICAL BW( NMAX ), SEL( NMAX )
+ INTEGER IW( NMAX )
+ DOUBLE PRECISION A( NMAX, NMAX ), B( NMAX, NMAX ), LS( NMAX ),
+ $ Q( NMAX, NMAX ), R1( NMAX ), R2( NMAX ),
+ $ R3( NMAX ), RCE( 2 ), RCV( 2 ), RS( NMAX ),
+ $ TAU( NMAX ), U( NMAX, NMAX ), V( NMAX, NMAX ),
+ $ W( LW ), Z( NMAX, NMAX )
+* ..
+* .. External Functions ..
+ LOGICAL DLCTES, DLCTSX, LSAMEN
+ EXTERNAL DLCTES, DLCTSX, LSAMEN
+* ..
+* .. External Subroutines ..
+ EXTERNAL CHKXER, DGGES, DGGESX, DGGEV, DGGEVX, DGGGLM,
+ $ DGGHRD, DGGLSE, DGGQRF, DGGRQF, DGGSVD, DGGSVP,
+ $ DHGEQZ, DTGEVC, DTGEXC, DTGSEN, DTGSJA, DTGSNA,
+ $ DTGSYL
+* ..
+* .. Scalars in Common ..
+ LOGICAL LERR, OK
+ CHARACTER*6 SRNAMT
+ INTEGER INFOT, NOUT
+* ..
+* .. Common blocks ..
+ COMMON / INFOC / INFOT, NOUT, OK, LERR
+ COMMON / SRNAMC / SRNAMT
+* ..
+* .. Executable Statements ..
+*
+ NOUT = NUNIT
+ WRITE( NOUT, FMT = * )
+ C2 = PATH( 2: 3 )
+*
+* Set the variables to innocuous values.
+*
+ DO 20 J = 1, NMAX
+ SEL( J ) = .TRUE.
+ DO 10 I = 1, NMAX
+ A( I, J ) = ZERO
+ B( I, J ) = ZERO
+ 10 CONTINUE
+ 20 CONTINUE
+ DO 30 I = 1, NMAX
+ A( I, I ) = ONE
+ B( I, I ) = ONE
+ 30 CONTINUE
+ OK = .TRUE.
+ TOLA = 1.0D0
+ TOLB = 1.0D0
+ IFST = 1
+ ILST = 1
+ NT = 0
+*
+* Test error exits for the GG path.
+*
+ IF( LSAMEN( 2, C2, 'GG' ) ) THEN
+*
+* DGGHRD
+*
+ SRNAMT = 'DGGHRD'
+ INFOT = 1
+ CALL DGGHRD( '/', 'N', 0, 1, 0, A, 1, B, 1, Q, 1, Z, 1, INFO )
+ CALL CHKXER( 'DGGHRD', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL DGGHRD( 'N', '/', 0, 1, 0, A, 1, B, 1, Q, 1, Z, 1, INFO )
+ CALL CHKXER( 'DGGHRD', INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL DGGHRD( 'N', 'N', -1, 0, 0, A, 1, B, 1, Q, 1, Z, 1, INFO )
+ CALL CHKXER( 'DGGHRD', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL DGGHRD( 'N', 'N', 0, 0, 0, A, 1, B, 1, Q, 1, Z, 1, INFO )
+ CALL CHKXER( 'DGGHRD', INFOT, NOUT, LERR, OK )
+ INFOT = 5
+ CALL DGGHRD( 'N', 'N', 0, 1, 1, A, 1, B, 1, Q, 1, Z, 1, INFO )
+ CALL CHKXER( 'DGGHRD', INFOT, NOUT, LERR, OK )
+ INFOT = 7
+ CALL DGGHRD( 'N', 'N', 2, 1, 1, A, 1, B, 2, Q, 1, Z, 1, INFO )
+ CALL CHKXER( 'DGGHRD', INFOT, NOUT, LERR, OK )
+ INFOT = 9
+ CALL DGGHRD( 'N', 'N', 2, 1, 1, A, 2, B, 1, Q, 1, Z, 1, INFO )
+ CALL CHKXER( 'DGGHRD', INFOT, NOUT, LERR, OK )
+ INFOT = 11
+ CALL DGGHRD( 'V', 'N', 2, 1, 1, A, 2, B, 2, Q, 1, Z, 1, INFO )
+ CALL CHKXER( 'DGGHRD', INFOT, NOUT, LERR, OK )
+ INFOT = 13
+ CALL DGGHRD( 'N', 'V', 2, 1, 1, A, 2, B, 2, Q, 1, Z, 1, INFO )
+ CALL CHKXER( 'DGGHRD', INFOT, NOUT, LERR, OK )
+ NT = NT + 9
+*
+* DHGEQZ
+*
+ SRNAMT = 'DHGEQZ'
+ INFOT = 1
+ CALL DHGEQZ( '/', 'N', 'N', 0, 1, 0, A, 1, B, 1, R1, R2, R3, Q,
+ $ 1, Z, 1, W, LW, INFO )
+ CALL CHKXER( 'DHGEQZ', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL DHGEQZ( 'E', '/', 'N', 0, 1, 0, A, 1, B, 1, R1, R2, R3, Q,
+ $ 1, Z, 1, W, LW, INFO )
+ CALL CHKXER( 'DHGEQZ', INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL DHGEQZ( 'E', 'N', '/', 0, 1, 0, A, 1, B, 1, R1, R2, R3, Q,
+ $ 1, Z, 1, W, LW, INFO )
+ CALL CHKXER( 'DHGEQZ', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL DHGEQZ( 'E', 'N', 'N', -1, 0, 0, A, 1, B, 1, R1, R2, R3,
+ $ Q, 1, Z, 1, W, LW, INFO )
+ CALL CHKXER( 'DHGEQZ', INFOT, NOUT, LERR, OK )
+ INFOT = 5
+ CALL DHGEQZ( 'E', 'N', 'N', 0, 0, 0, A, 1, B, 1, R1, R2, R3, Q,
+ $ 1, Z, 1, W, LW, INFO )
+ CALL CHKXER( 'DHGEQZ', INFOT, NOUT, LERR, OK )
+ INFOT = 6
+ CALL DHGEQZ( 'E', 'N', 'N', 0, 1, 1, A, 1, B, 1, R1, R2, R3, Q,
+ $ 1, Z, 1, W, LW, INFO )
+ CALL CHKXER( 'DHGEQZ', INFOT, NOUT, LERR, OK )
+ INFOT = 8
+ CALL DHGEQZ( 'E', 'N', 'N', 2, 1, 1, A, 1, B, 2, R1, R2, R3, Q,
+ $ 1, Z, 1, W, LW, INFO )
+ CALL CHKXER( 'DHGEQZ', INFOT, NOUT, LERR, OK )
+ INFOT = 10
+ CALL DHGEQZ( 'E', 'N', 'N', 2, 1, 1, A, 2, B, 1, R1, R2, R3, Q,
+ $ 1, Z, 1, W, LW, INFO )
+ CALL CHKXER( 'DHGEQZ', INFOT, NOUT, LERR, OK )
+ INFOT = 15
+ CALL DHGEQZ( 'E', 'V', 'N', 2, 1, 1, A, 2, B, 2, R1, R2, R3, Q,
+ $ 1, Z, 1, W, LW, INFO )
+ CALL CHKXER( 'DHGEQZ', INFOT, NOUT, LERR, OK )
+ INFOT = 17
+ CALL DHGEQZ( 'E', 'N', 'V', 2, 1, 1, A, 2, B, 2, R1, R2, R3, Q,
+ $ 1, Z, 1, W, LW, INFO )
+ CALL CHKXER( 'DHGEQZ', INFOT, NOUT, LERR, OK )
+ NT = NT + 10
+*
+* DTGEVC
+*
+ SRNAMT = 'DTGEVC'
+ INFOT = 1
+ CALL DTGEVC( '/', 'A', SEL, 0, A, 1, B, 1, Q, 1, Z, 1, 0, M, W,
+ $ INFO )
+ CALL CHKXER( 'DTGEVC', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL DTGEVC( 'R', '/', SEL, 0, A, 1, B, 1, Q, 1, Z, 1, 0, M, W,
+ $ INFO )
+ CALL CHKXER( 'DTGEVC', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL DTGEVC( 'R', 'A', SEL, -1, A, 1, B, 1, Q, 1, Z, 1, 0, M,
+ $ W, INFO )
+ CALL CHKXER( 'DTGEVC', INFOT, NOUT, LERR, OK )
+ INFOT = 6
+ CALL DTGEVC( 'R', 'A', SEL, 2, A, 1, B, 2, Q, 1, Z, 2, 0, M, W,
+ $ INFO )
+ CALL CHKXER( 'DTGEVC', INFOT, NOUT, LERR, OK )
+ INFOT = 8
+ CALL DTGEVC( 'R', 'A', SEL, 2, A, 2, B, 1, Q, 1, Z, 2, 0, M, W,
+ $ INFO )
+ CALL CHKXER( 'DTGEVC', INFOT, NOUT, LERR, OK )
+ INFOT = 10
+ CALL DTGEVC( 'L', 'A', SEL, 2, A, 2, B, 2, Q, 1, Z, 1, 0, M, W,
+ $ INFO )
+ CALL CHKXER( 'DTGEVC', INFOT, NOUT, LERR, OK )
+ INFOT = 12
+ CALL DTGEVC( 'R', 'A', SEL, 2, A, 2, B, 2, Q, 1, Z, 1, 0, M, W,
+ $ INFO )
+ CALL CHKXER( 'DTGEVC', INFOT, NOUT, LERR, OK )
+ INFOT = 13
+ CALL DTGEVC( 'R', 'A', SEL, 2, A, 2, B, 2, Q, 1, Z, 2, 1, M, W,
+ $ INFO )
+ CALL CHKXER( 'DTGEVC', INFOT, NOUT, LERR, OK )
+ NT = NT + 8
+*
+* Test error exits for the GSV path.
+*
+ ELSE IF( LSAMEN( 3, PATH, 'GSV' ) ) THEN
+*
+* DGGSVD
+*
+ SRNAMT = 'DGGSVD'
+ INFOT = 1
+ CALL DGGSVD( '/', 'N', 'N', 0, 0, 0, DUMMYK, DUMMYL, A, 1, B,
+ $ 1, R1, R2, U, 1, V, 1, Q, 1, W, IW, INFO )
+ CALL CHKXER( 'DGGSVD', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL DGGSVD( 'N', '/', 'N', 0, 0, 0, DUMMYK, DUMMYL, A, 1, B,
+ $ 1, R1, R2, U, 1, V, 1, Q, 1, W, IW, INFO )
+ CALL CHKXER( 'DGGSVD', INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL DGGSVD( 'N', 'N', '/', 0, 0, 0, DUMMYK, DUMMYL, A, 1, B,
+ $ 1, R1, R2, U, 1, V, 1, Q, 1, W, IW, INFO )
+ CALL CHKXER( 'DGGSVD', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL DGGSVD( 'N', 'N', 'N', -1, 0, 0, DUMMYK, DUMMYL, A, 1, B,
+ $ 1, R1, R2, U, 1, V, 1, Q, 1, W, IW, INFO )
+ CALL CHKXER( 'DGGSVD', INFOT, NOUT, LERR, OK )
+ INFOT = 5
+ CALL DGGSVD( 'N', 'N', 'N', 0, -1, 0, DUMMYK, DUMMYL, A, 1, B,
+ $ 1, R1, R2, U, 1, V, 1, Q, 1, W, IW, INFO )
+ CALL CHKXER( 'DGGSVD', INFOT, NOUT, LERR, OK )
+ INFOT = 6
+ CALL DGGSVD( 'N', 'N', 'N', 0, 0, -1, DUMMYK, DUMMYL, A, 1, B,
+ $ 1, R1, R2, U, 1, V, 1, Q, 1, W, IW, INFO )
+ CALL CHKXER( 'DGGSVD', INFOT, NOUT, LERR, OK )
+ INFOT = 10
+ CALL DGGSVD( 'N', 'N', 'N', 2, 1, 1, DUMMYK, DUMMYL, A, 1, B,
+ $ 1, R1, R2, U, 1, V, 1, Q, 1, W, IW, INFO )
+ CALL CHKXER( 'DGGSVD', INFOT, NOUT, LERR, OK )
+ INFOT = 12
+ CALL DGGSVD( 'N', 'N', 'N', 1, 1, 2, DUMMYK, DUMMYL, A, 1, B,
+ $ 1, R1, R2, U, 1, V, 1, Q, 1, W, IW, INFO )
+ CALL CHKXER( 'DGGSVD', INFOT, NOUT, LERR, OK )
+ INFOT = 16
+ CALL DGGSVD( 'U', 'N', 'N', 2, 2, 2, DUMMYK, DUMMYL, A, 2, B,
+ $ 2, R1, R2, U, 1, V, 1, Q, 1, W, IW, INFO )
+ CALL CHKXER( 'DGGSVD', INFOT, NOUT, LERR, OK )
+ INFOT = 18
+ CALL DGGSVD( 'N', 'V', 'N', 1, 1, 2, DUMMYK, DUMMYL, A, 1, B,
+ $ 2, R1, R2, U, 1, V, 1, Q, 1, W, IW, INFO )
+ CALL CHKXER( 'DGGSVD', INFOT, NOUT, LERR, OK )
+ INFOT = 20
+ CALL DGGSVD( 'N', 'N', 'Q', 1, 2, 1, DUMMYK, DUMMYL, A, 1, B,
+ $ 1, R1, R2, U, 1, V, 1, Q, 1, W, IW, INFO )
+ CALL CHKXER( 'DGGSVD', INFOT, NOUT, LERR, OK )
+ NT = NT + 11
+*
+* DGGSVP
+*
+ SRNAMT = 'DGGSVP'
+ INFOT = 1
+ CALL DGGSVP( '/', 'N', 'N', 0, 0, 0, A, 1, B, 1, TOLA, TOLB,
+ $ DUMMYK, DUMMYL, U, 1, V, 1, Q, 1, IW, TAU, W,
+ $ INFO )
+ CALL CHKXER( 'DGGSVP', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL DGGSVP( 'N', '/', 'N', 0, 0, 0, A, 1, B, 1, TOLA, TOLB,
+ $ DUMMYK, DUMMYL, U, 1, V, 1, Q, 1, IW, TAU, W,
+ $ INFO )
+ CALL CHKXER( 'DGGSVP', INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL DGGSVP( 'N', 'N', '/', 0, 0, 0, A, 1, B, 1, TOLA, TOLB,
+ $ DUMMYK, DUMMYL, U, 1, V, 1, Q, 1, IW, TAU, W,
+ $ INFO )
+ CALL CHKXER( 'DGGSVP', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL DGGSVP( 'N', 'N', 'N', -1, 0, 0, A, 1, B, 1, TOLA, TOLB,
+ $ DUMMYK, DUMMYL, U, 1, V, 1, Q, 1, IW, TAU, W,
+ $ INFO )
+ CALL CHKXER( 'DGGSVP', INFOT, NOUT, LERR, OK )
+ INFOT = 5
+ CALL DGGSVP( 'N', 'N', 'N', 0, -1, 0, A, 1, B, 1, TOLA, TOLB,
+ $ DUMMYK, DUMMYL, U, 1, V, 1, Q, 1, IW, TAU, W,
+ $ INFO )
+ CALL CHKXER( 'DGGSVP', INFOT, NOUT, LERR, OK )
+ INFOT = 6
+ CALL DGGSVP( 'N', 'N', 'N', 0, 0, -1, A, 1, B, 1, TOLA, TOLB,
+ $ DUMMYK, DUMMYL, U, 1, V, 1, Q, 1, IW, TAU, W,
+ $ INFO )
+ CALL CHKXER( 'DGGSVP', INFOT, NOUT, LERR, OK )
+ INFOT = 8
+ CALL DGGSVP( 'N', 'N', 'N', 2, 1, 1, A, 1, B, 1, TOLA, TOLB,
+ $ DUMMYK, DUMMYL, U, 1, V, 1, Q, 1, IW, TAU, W,
+ $ INFO )
+ CALL CHKXER( 'DGGSVP', INFOT, NOUT, LERR, OK )
+ INFOT = 10
+ CALL DGGSVP( 'N', 'N', 'N', 1, 2, 1, A, 1, B, 1, TOLA, TOLB,
+ $ DUMMYK, DUMMYL, U, 1, V, 1, Q, 1, IW, TAU, W,
+ $ INFO )
+ CALL CHKXER( 'DGGSVP', INFOT, NOUT, LERR, OK )
+ INFOT = 16
+ CALL DGGSVP( 'U', 'N', 'N', 2, 2, 2, A, 2, B, 2, TOLA, TOLB,
+ $ DUMMYK, DUMMYL, U, 1, V, 1, Q, 1, IW, TAU, W,
+ $ INFO )
+ CALL CHKXER( 'DGGSVP', INFOT, NOUT, LERR, OK )
+ INFOT = 18
+ CALL DGGSVP( 'N', 'V', 'N', 1, 2, 1, A, 1, B, 2, TOLA, TOLB,
+ $ DUMMYK, DUMMYL, U, 1, V, 1, Q, 1, IW, TAU, W,
+ $ INFO )
+ CALL CHKXER( 'DGGSVP', INFOT, NOUT, LERR, OK )
+ INFOT = 20
+ CALL DGGSVP( 'N', 'N', 'Q', 1, 1, 2, A, 1, B, 1, TOLA, TOLB,
+ $ DUMMYK, DUMMYL, U, 1, V, 1, Q, 1, IW, TAU, W,
+ $ INFO )
+ CALL CHKXER( 'DGGSVP', INFOT, NOUT, LERR, OK )
+ NT = NT + 11
+*
+* DTGSJA
+*
+ SRNAMT = 'DTGSJA'
+ INFOT = 1
+ CALL DTGSJA( '/', 'N', 'N', 0, 0, 0, DUMMYK, DUMMYL, A, 1, B,
+ $ 1, TOLA, TOLB, R1, R2, U, 1, V, 1, Q, 1, W,
+ $ NCYCLE, INFO )
+ CALL CHKXER( 'DTGSJA', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL DTGSJA( 'N', '/', 'N', 0, 0, 0, DUMMYK, DUMMYL, A, 1, B,
+ $ 1, TOLA, TOLB, R1, R2, U, 1, V, 1, Q, 1, W,
+ $ NCYCLE, INFO )
+ CALL CHKXER( 'DTGSJA', INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL DTGSJA( 'N', 'N', '/', 0, 0, 0, DUMMYK, DUMMYL, A, 1, B,
+ $ 1, TOLA, TOLB, R1, R2, U, 1, V, 1, Q, 1, W,
+ $ NCYCLE, INFO )
+ CALL CHKXER( 'DTGSJA', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL DTGSJA( 'N', 'N', 'N', -1, 0, 0, DUMMYK, DUMMYL, A, 1, B,
+ $ 1, TOLA, TOLB, R1, R2, U, 1, V, 1, Q, 1, W,
+ $ NCYCLE, INFO )
+ CALL CHKXER( 'DTGSJA', INFOT, NOUT, LERR, OK )
+ INFOT = 5
+ CALL DTGSJA( 'N', 'N', 'N', 0, -1, 0, DUMMYK, DUMMYL, A, 1, B,
+ $ 1, TOLA, TOLB, R1, R2, U, 1, V, 1, Q, 1, W,
+ $ NCYCLE, INFO )
+ CALL CHKXER( 'DTGSJA', INFOT, NOUT, LERR, OK )
+ INFOT = 6
+ CALL DTGSJA( 'N', 'N', 'N', 0, 0, -1, DUMMYK, DUMMYL, A, 1, B,
+ $ 1, TOLA, TOLB, R1, R2, U, 1, V, 1, Q, 1, W,
+ $ NCYCLE, INFO )
+ CALL CHKXER( 'DTGSJA', INFOT, NOUT, LERR, OK )
+ INFOT = 10
+ CALL DTGSJA( 'N', 'N', 'N', 0, 0, 0, DUMMYK, DUMMYL, A, 0, B,
+ $ 1, TOLA, TOLB, R1, R2, U, 1, V, 1, Q, 1, W,
+ $ NCYCLE, INFO )
+ CALL CHKXER( 'DTGSJA', INFOT, NOUT, LERR, OK )
+ INFOT = 12
+ CALL DTGSJA( 'N', 'N', 'N', 0, 0, 0, DUMMYK, DUMMYL, A, 1, B,
+ $ 0, TOLA, TOLB, R1, R2, U, 1, V, 1, Q, 1, W,
+ $ NCYCLE, INFO )
+ CALL CHKXER( 'DTGSJA', INFOT, NOUT, LERR, OK )
+ INFOT = 18
+ CALL DTGSJA( 'U', 'N', 'N', 0, 0, 0, DUMMYK, DUMMYL, A, 1, B,
+ $ 1, TOLA, TOLB, R1, R2, U, 0, V, 1, Q, 1, W,
+ $ NCYCLE, INFO )
+ CALL CHKXER( 'DTGSJA', INFOT, NOUT, LERR, OK )
+ INFOT = 20
+ CALL DTGSJA( 'N', 'V', 'N', 0, 0, 0, DUMMYK, DUMMYL, A, 1, B,
+ $ 1, TOLA, TOLB, R1, R2, U, 1, V, 0, Q, 1, W,
+ $ NCYCLE, INFO )
+ CALL CHKXER( 'DTGSJA', INFOT, NOUT, LERR, OK )
+ INFOT = 22
+ CALL DTGSJA( 'N', 'N', 'Q', 0, 0, 0, DUMMYK, DUMMYL, A, 1, B,
+ $ 1, TOLA, TOLB, R1, R2, U, 1, V, 1, Q, 0, W,
+ $ NCYCLE, INFO )
+ CALL CHKXER( 'DTGSJA', INFOT, NOUT, LERR, OK )
+ NT = NT + 11
+*
+* Test error exits for the GLM path.
+*
+ ELSE IF( LSAMEN( 3, PATH, 'GLM' ) ) THEN
+*
+* DGGGLM
+*
+ SRNAMT = 'DGGGLM'
+ INFOT = 1
+ CALL DGGGLM( -1, 0, 0, A, 1, B, 1, R1, R2, R3, W, LW, INFO )
+ CALL CHKXER( 'DGGGLM', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL DGGGLM( 0, -1, 0, A, 1, B, 1, R1, R2, R3, W, LW, INFO )
+ CALL CHKXER( 'DGGGLM', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL DGGGLM( 0, 1, 0, A, 1, B, 1, R1, R2, R3, W, LW, INFO )
+ CALL CHKXER( 'DGGGLM', INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL DGGGLM( 0, 0, -1, A, 1, B, 1, R1, R2, R3, W, LW, INFO )
+ CALL CHKXER( 'DGGGLM', INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL DGGGLM( 1, 0, 0, A, 1, B, 1, R1, R2, R3, W, LW, INFO )
+ CALL CHKXER( 'DGGGLM', INFOT, NOUT, LERR, OK )
+ INFOT = 5
+ CALL DGGGLM( 0, 0, 0, A, 0, B, 1, R1, R2, R3, W, LW, INFO )
+ CALL CHKXER( 'DGGGLM', INFOT, NOUT, LERR, OK )
+ INFOT = 7
+ CALL DGGGLM( 0, 0, 0, A, 1, B, 0, R1, R2, R3, W, LW, INFO )
+ CALL CHKXER( 'DGGGLM', INFOT, NOUT, LERR, OK )
+ INFOT = 12
+ CALL DGGGLM( 1, 1, 1, A, 1, B, 1, R1, R2, R3, W, 1, INFO )
+ CALL CHKXER( 'DGGGLM', INFOT, NOUT, LERR, OK )
+ NT = NT + 8
+*
+* Test error exits for the LSE path.
+*
+ ELSE IF( LSAMEN( 3, PATH, 'LSE' ) ) THEN
+*
+* DGGLSE
+*
+ SRNAMT = 'DGGLSE'
+ INFOT = 1
+ CALL DGGLSE( -1, 0, 0, A, 1, B, 1, R1, R2, R3, W, LW, INFO )
+ CALL CHKXER( 'DGGLSE', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL DGGLSE( 0, -1, 0, A, 1, B, 1, R1, R2, R3, W, LW, INFO )
+ CALL CHKXER( 'DGGLSE', INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL DGGLSE( 0, 0, -1, A, 1, B, 1, R1, R2, R3, W, LW, INFO )
+ CALL CHKXER( 'DGGLSE', INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL DGGLSE( 0, 0, 1, A, 1, B, 1, R1, R2, R3, W, LW, INFO )
+ CALL CHKXER( 'DGGLSE', INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL DGGLSE( 0, 1, 0, A, 1, B, 1, R1, R2, R3, W, LW, INFO )
+ CALL CHKXER( 'DGGLSE', INFOT, NOUT, LERR, OK )
+ INFOT = 5
+ CALL DGGLSE( 0, 0, 0, A, 0, B, 1, R1, R2, R3, W, LW, INFO )
+ CALL CHKXER( 'DGGLSE', INFOT, NOUT, LERR, OK )
+ INFOT = 7
+ CALL DGGLSE( 0, 0, 0, A, 1, B, 0, R1, R2, R3, W, LW, INFO )
+ CALL CHKXER( 'DGGLSE', INFOT, NOUT, LERR, OK )
+ INFOT = 12
+ CALL DGGLSE( 1, 1, 1, A, 1, B, 1, R1, R2, R3, W, 1, INFO )
+ CALL CHKXER( 'DGGLSE', INFOT, NOUT, LERR, OK )
+ NT = NT + 8
+*
+* Test error exits for the GQR path.
+*
+ ELSE IF( LSAMEN( 3, PATH, 'GQR' ) ) THEN
+*
+* DGGQRF
+*
+ SRNAMT = 'DGGQRF'
+ INFOT = 1
+ CALL DGGQRF( -1, 0, 0, A, 1, R1, B, 1, R2, W, LW, INFO )
+ CALL CHKXER( 'DGGQRF', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL DGGQRF( 0, -1, 0, A, 1, R1, B, 1, R2, W, LW, INFO )
+ CALL CHKXER( 'DGGQRF', INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL DGGQRF( 0, 0, -1, A, 1, R1, B, 1, R2, W, LW, INFO )
+ CALL CHKXER( 'DGGQRF', INFOT, NOUT, LERR, OK )
+ INFOT = 5
+ CALL DGGQRF( 0, 0, 0, A, 0, R1, B, 1, R2, W, LW, INFO )
+ CALL CHKXER( 'DGGQRF', INFOT, NOUT, LERR, OK )
+ INFOT = 8
+ CALL DGGQRF( 0, 0, 0, A, 1, R1, B, 0, R2, W, LW, INFO )
+ CALL CHKXER( 'DGGQRF', INFOT, NOUT, LERR, OK )
+ INFOT = 11
+ CALL DGGQRF( 1, 1, 2, A, 1, R1, B, 1, R2, W, 1, INFO )
+ CALL CHKXER( 'DGGQRF', INFOT, NOUT, LERR, OK )
+ NT = NT + 6
+*
+* DGGRQF
+*
+ SRNAMT = 'DGGRQF'
+ INFOT = 1
+ CALL DGGRQF( -1, 0, 0, A, 1, R1, B, 1, R2, W, LW, INFO )
+ CALL CHKXER( 'DGGRQF', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL DGGRQF( 0, -1, 0, A, 1, R1, B, 1, R2, W, LW, INFO )
+ CALL CHKXER( 'DGGRQF', INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL DGGRQF( 0, 0, -1, A, 1, R1, B, 1, R2, W, LW, INFO )
+ CALL CHKXER( 'DGGRQF', INFOT, NOUT, LERR, OK )
+ INFOT = 5
+ CALL DGGRQF( 0, 0, 0, A, 0, R1, B, 1, R2, W, LW, INFO )
+ CALL CHKXER( 'DGGRQF', INFOT, NOUT, LERR, OK )
+ INFOT = 8
+ CALL DGGRQF( 0, 0, 0, A, 1, R1, B, 0, R2, W, LW, INFO )
+ CALL CHKXER( 'DGGRQF', INFOT, NOUT, LERR, OK )
+ INFOT = 11
+ CALL DGGRQF( 1, 1, 2, A, 1, R1, B, 1, R2, W, 1, INFO )
+ CALL CHKXER( 'DGGRQF', INFOT, NOUT, LERR, OK )
+ NT = NT + 6
+*
+* Test error exits for the DGS, DGV, DGX, and DXV paths.
+*
+ ELSE IF( LSAMEN( 3, PATH, 'DGS' ) .OR.
+ $ LSAMEN( 3, PATH, 'DGV' ) .OR.
+ $ LSAMEN( 3, PATH, 'DGX' ) .OR. LSAMEN( 3, PATH, 'DXV' ) )
+ $ THEN
+*
+* DGGES
+*
+ SRNAMT = 'DGGES '
+ INFOT = 1
+ CALL DGGES( '/', 'N', 'S', DLCTES, 1, A, 1, B, 1, SDIM, R1, R2,
+ $ R3, Q, 1, U, 1, W, 1, BW, INFO )
+ CALL CHKXER( 'DGGES ', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL DGGES( 'N', '/', 'S', DLCTES, 1, A, 1, B, 1, SDIM, R1, R2,
+ $ R3, Q, 1, U, 1, W, 1, BW, INFO )
+ CALL CHKXER( 'DGGES ', INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL DGGES( 'N', 'V', '/', DLCTES, 1, A, 1, B, 1, SDIM, R1, R2,
+ $ R3, Q, 1, U, 1, W, 1, BW, INFO )
+ CALL CHKXER( 'DGGES ', INFOT, NOUT, LERR, OK )
+ INFOT = 5
+ CALL DGGES( 'N', 'V', 'S', DLCTES, -1, A, 1, B, 1, SDIM, R1,
+ $ R2, R3, Q, 1, U, 1, W, 1, BW, INFO )
+ CALL CHKXER( 'DGGES ', INFOT, NOUT, LERR, OK )
+ INFOT = 7
+ CALL DGGES( 'N', 'V', 'S', DLCTES, 1, A, 0, B, 1, SDIM, R1, R2,
+ $ R3, Q, 1, U, 1, W, 1, BW, INFO )
+ CALL CHKXER( 'DGGES ', INFOT, NOUT, LERR, OK )
+ INFOT = 9
+ CALL DGGES( 'N', 'V', 'S', DLCTES, 1, A, 1, B, 0, SDIM, R1, R2,
+ $ R3, Q, 1, U, 1, W, 1, BW, INFO )
+ CALL CHKXER( 'DGGES ', INFOT, NOUT, LERR, OK )
+ INFOT = 15
+ CALL DGGES( 'N', 'V', 'S', DLCTES, 1, A, 1, B, 1, SDIM, R1, R2,
+ $ R3, Q, 0, U, 1, W, 1, BW, INFO )
+ CALL CHKXER( 'DGGES ', INFOT, NOUT, LERR, OK )
+ INFOT = 15
+ CALL DGGES( 'V', 'V', 'S', DLCTES, 2, A, 2, B, 2, SDIM, R1, R2,
+ $ R3, Q, 1, U, 2, W, 1, BW, INFO )
+ CALL CHKXER( 'DGGES ', INFOT, NOUT, LERR, OK )
+ INFOT = 17
+ CALL DGGES( 'N', 'V', 'S', DLCTES, 1, A, 1, B, 1, SDIM, R1, R2,
+ $ R3, Q, 1, U, 0, W, 1, BW, INFO )
+ CALL CHKXER( 'DGGES ', INFOT, NOUT, LERR, OK )
+ INFOT = 17
+ CALL DGGES( 'V', 'V', 'S', DLCTES, 2, A, 2, B, 2, SDIM, R1, R2,
+ $ R3, Q, 2, U, 1, W, 1, BW, INFO )
+ CALL CHKXER( 'DGGES ', INFOT, NOUT, LERR, OK )
+ INFOT = 19
+ CALL DGGES( 'V', 'V', 'S', DLCTES, 2, A, 2, B, 2, SDIM, R1, R2,
+ $ R3, Q, 2, U, 2, W, 1, BW, INFO )
+ CALL CHKXER( 'DGGES ', INFOT, NOUT, LERR, OK )
+ NT = NT + 11
+*
+* DGGESX
+*
+ SRNAMT = 'DGGESX'
+ INFOT = 1
+ CALL DGGESX( '/', 'N', 'S', DLCTSX, 'N', 1, A, 1, B, 1, SDIM,
+ $ R1, R2, R3, Q, 1, U, 1, RCE, RCV, W, 1, IW, 1, BW,
+ $ INFO )
+ CALL CHKXER( 'DGGESX', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL DGGESX( 'N', '/', 'S', DLCTSX, 'N', 1, A, 1, B, 1, SDIM,
+ $ R1, R2, R3, Q, 1, U, 1, RCE, RCV, W, 1, IW, 1, BW,
+ $ INFO )
+ CALL CHKXER( 'DGGESX', INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL DGGESX( 'V', 'V', '/', DLCTSX, 'N', 1, A, 1, B, 1, SDIM,
+ $ R1, R2, R3, Q, 1, U, 1, RCE, RCV, W, 1, IW, 1, BW,
+ $ INFO )
+ CALL CHKXER( 'DGGESX', INFOT, NOUT, LERR, OK )
+ INFOT = 5
+ CALL DGGESX( 'V', 'V', 'S', DLCTSX, '/', 1, A, 1, B, 1, SDIM,
+ $ R1, R2, R3, Q, 1, U, 1, RCE, RCV, W, 1, IW, 1, BW,
+ $ INFO )
+ CALL CHKXER( 'DGGESX', INFOT, NOUT, LERR, OK )
+ INFOT = 6
+ CALL DGGESX( 'V', 'V', 'S', DLCTSX, 'B', -1, A, 1, B, 1, SDIM,
+ $ R1, R2, R3, Q, 1, U, 1, RCE, RCV, W, 1, IW, 1, BW,
+ $ INFO )
+ CALL CHKXER( 'DGGESX', INFOT, NOUT, LERR, OK )
+ INFOT = 8
+ CALL DGGESX( 'V', 'V', 'S', DLCTSX, 'B', 1, A, 0, B, 1, SDIM,
+ $ R1, R2, R3, Q, 1, U, 1, RCE, RCV, W, 1, IW, 1, BW,
+ $ INFO )
+ CALL CHKXER( 'DGGESX', INFOT, NOUT, LERR, OK )
+ INFOT = 10
+ CALL DGGESX( 'V', 'V', 'S', DLCTSX, 'B', 1, A, 1, B, 0, SDIM,
+ $ R1, R2, R3, Q, 1, U, 1, RCE, RCV, W, 1, IW, 1, BW,
+ $ INFO )
+ CALL CHKXER( 'DGGESX', INFOT, NOUT, LERR, OK )
+ INFOT = 16
+ CALL DGGESX( 'V', 'V', 'S', DLCTSX, 'B', 1, A, 1, B, 1, SDIM,
+ $ R1, R2, R3, Q, 0, U, 1, RCE, RCV, W, 1, IW, 1, BW,
+ $ INFO )
+ CALL CHKXER( 'DGGESX', INFOT, NOUT, LERR, OK )
+ INFOT = 16
+ CALL DGGESX( 'V', 'V', 'S', DLCTSX, 'B', 2, A, 2, B, 2, SDIM,
+ $ R1, R2, R3, Q, 1, U, 1, RCE, RCV, W, 1, IW, 1, BW,
+ $ INFO )
+ CALL CHKXER( 'DGGESX', INFOT, NOUT, LERR, OK )
+ INFOT = 18
+ CALL DGGESX( 'V', 'V', 'S', DLCTSX, 'B', 1, A, 1, B, 1, SDIM,
+ $ R1, R2, R3, Q, 1, U, 0, RCE, RCV, W, 1, IW, 1, BW,
+ $ INFO )
+ CALL CHKXER( 'DGGESX', INFOT, NOUT, LERR, OK )
+ INFOT = 18
+ CALL DGGESX( 'V', 'V', 'S', DLCTSX, 'B', 2, A, 2, B, 2, SDIM,
+ $ R1, R2, R3, Q, 2, U, 1, RCE, RCV, W, 1, IW, 1, BW,
+ $ INFO )
+ CALL CHKXER( 'DGGESX', INFOT, NOUT, LERR, OK )
+ INFOT = 22
+ CALL DGGESX( 'V', 'V', 'S', DLCTSX, 'B', 2, A, 2, B, 2, SDIM,
+ $ R1, R2, R3, Q, 2, U, 2, RCE, RCV, W, 1, IW, 1, BW,
+ $ INFO )
+ CALL CHKXER( 'DGGESX', INFOT, NOUT, LERR, OK )
+ INFOT = 24
+ CALL DGGESX( 'V', 'V', 'S', DLCTSX, 'V', 1, A, 1, B, 1, SDIM,
+ $ R1, R2, R3, Q, 1, U, 1, RCE, RCV, W, 32, IW, 0,
+ $ BW, INFO )
+ CALL CHKXER( 'DGGESX', INFOT, NOUT, LERR, OK )
+ NT = NT + 13
+*
+* DGGEV
+*
+ SRNAMT = 'DGGEV '
+ INFOT = 1
+ CALL DGGEV( '/', 'N', 1, A, 1, B, 1, R1, R2, R3, Q, 1, U, 1, W,
+ $ 1, INFO )
+ CALL CHKXER( 'DGGEV ', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL DGGEV( 'N', '/', 1, A, 1, B, 1, R1, R2, R3, Q, 1, U, 1, W,
+ $ 1, INFO )
+ CALL CHKXER( 'DGGEV ', INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL DGGEV( 'V', 'V', -1, A, 1, B, 1, R1, R2, R3, Q, 1, U, 1,
+ $ W, 1, INFO )
+ CALL CHKXER( 'DGGEV ', INFOT, NOUT, LERR, OK )
+ INFOT = 5
+ CALL DGGEV( 'V', 'V', 1, A, 0, B, 1, R1, R2, R3, Q, 1, U, 1, W,
+ $ 1, INFO )
+ CALL CHKXER( 'DGGEV ', INFOT, NOUT, LERR, OK )
+ INFOT = 7
+ CALL DGGEV( 'V', 'V', 1, A, 1, B, 0, R1, R2, R3, Q, 1, U, 1, W,
+ $ 1, INFO )
+ CALL CHKXER( 'DGGEV ', INFOT, NOUT, LERR, OK )
+ INFOT = 12
+ CALL DGGEV( 'N', 'V', 1, A, 1, B, 1, R1, R2, R3, Q, 0, U, 1, W,
+ $ 1, INFO )
+ CALL CHKXER( 'DGGEV ', INFOT, NOUT, LERR, OK )
+ INFOT = 12
+ CALL DGGEV( 'V', 'V', 2, A, 2, B, 2, R1, R2, R3, Q, 1, U, 2, W,
+ $ 1, INFO )
+ CALL CHKXER( 'DGGEV ', INFOT, NOUT, LERR, OK )
+ INFOT = 14
+ CALL DGGEV( 'V', 'N', 2, A, 2, B, 2, R1, R2, R3, Q, 2, U, 0, W,
+ $ 1, INFO )
+ CALL CHKXER( 'DGGEV ', INFOT, NOUT, LERR, OK )
+ INFOT = 14
+ CALL DGGEV( 'V', 'V', 2, A, 2, B, 2, R1, R2, R3, Q, 2, U, 1, W,
+ $ 1, INFO )
+ CALL CHKXER( 'DGGEV ', INFOT, NOUT, LERR, OK )
+ INFOT = 16
+ CALL DGGEV( 'V', 'V', 1, A, 1, B, 1, R1, R2, R3, Q, 1, U, 1, W,
+ $ 1, INFO )
+ CALL CHKXER( 'DGGEV ', INFOT, NOUT, LERR, OK )
+ NT = NT + 10
+*
+* DGGEVX
+*
+ SRNAMT = 'DGGEVX'
+ INFOT = 1
+ CALL DGGEVX( '/', 'N', 'N', 'N', 1, A, 1, B, 1, R1, R2, R3, Q,
+ $ 1, U, 1, 1, 1, LS, RS, ANRM, BNRM, RCE, RCV, W, 1,
+ $ IW, BW, INFO )
+ CALL CHKXER( 'DGGEVX', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL DGGEVX( 'N', '/', 'N', 'N', 1, A, 1, B, 1, R1, R2, R3, Q,
+ $ 1, U, 1, 1, 1, LS, RS, ANRM, BNRM, RCE, RCV, W, 1,
+ $ IW, BW, INFO )
+ CALL CHKXER( 'DGGEVX', INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL DGGEVX( 'N', 'N', '/', 'N', 1, A, 1, B, 1, R1, R2, R3, Q,
+ $ 1, U, 1, 1, 1, LS, RS, ANRM, BNRM, RCE, RCV, W, 1,
+ $ IW, BW, INFO )
+ CALL CHKXER( 'DGGEVX', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL DGGEVX( 'N', 'N', 'N', '/', 1, A, 1, B, 1, R1, R2, R3, Q,
+ $ 1, U, 1, 1, 1, LS, RS, ANRM, BNRM, RCE, RCV, W, 1,
+ $ IW, BW, INFO )
+ CALL CHKXER( 'DGGEVX', INFOT, NOUT, LERR, OK )
+ INFOT = 5
+ CALL DGGEVX( 'N', 'N', 'N', 'N', -1, A, 1, B, 1, R1, R2, R3, Q,
+ $ 1, U, 1, 1, 1, LS, RS, ANRM, BNRM, RCE, RCV, W, 1,
+ $ IW, BW, INFO )
+ CALL CHKXER( 'DGGEVX', INFOT, NOUT, LERR, OK )
+ INFOT = 7
+ CALL DGGEVX( 'N', 'N', 'N', 'N', 1, A, 0, B, 1, R1, R2, R3, Q,
+ $ 1, U, 1, 1, 1, LS, RS, ANRM, BNRM, RCE, RCV, W, 1,
+ $ IW, BW, INFO )
+ CALL CHKXER( 'DGGEVX', INFOT, NOUT, LERR, OK )
+ INFOT = 9
+ CALL DGGEVX( 'N', 'N', 'N', 'N', 1, A, 1, B, 0, R1, R2, R3, Q,
+ $ 1, U, 1, 1, 1, LS, RS, ANRM, BNRM, RCE, RCV, W, 1,
+ $ IW, BW, INFO )
+ CALL CHKXER( 'DGGEVX', INFOT, NOUT, LERR, OK )
+ INFOT = 14
+ CALL DGGEVX( 'N', 'N', 'N', 'N', 1, A, 1, B, 1, R1, R2, R3, Q,
+ $ 0, U, 1, 1, 1, LS, RS, ANRM, BNRM, RCE, RCV, W, 1,
+ $ IW, BW, INFO )
+ CALL CHKXER( 'DGGEVX', INFOT, NOUT, LERR, OK )
+ INFOT = 14
+ CALL DGGEVX( 'N', 'V', 'N', 'N', 2, A, 2, B, 2, R1, R2, R3, Q,
+ $ 1, U, 2, 1, 2, LS, RS, ANRM, BNRM, RCE, RCV, W, 1,
+ $ IW, BW, INFO )
+ CALL CHKXER( 'DGGEVX', INFOT, NOUT, LERR, OK )
+ INFOT = 16
+ CALL DGGEVX( 'N', 'N', 'N', 'N', 1, A, 1, B, 1, R1, R2, R3, Q,
+ $ 1, U, 0, 1, 1, LS, RS, ANRM, BNRM, RCE, RCV, W, 1,
+ $ IW, BW, INFO )
+ CALL CHKXER( 'DGGEVX', INFOT, NOUT, LERR, OK )
+ INFOT = 16
+ CALL DGGEVX( 'N', 'N', 'V', 'N', 2, A, 2, B, 2, R1, R2, R3, Q,
+ $ 2, U, 1, 1, 2, LS, RS, ANRM, BNRM, RCE, RCV, W, 1,
+ $ IW, BW, INFO )
+ CALL CHKXER( 'DGGEVX', INFOT, NOUT, LERR, OK )
+ INFOT = 26
+ CALL DGGEVX( 'N', 'N', 'V', 'N', 2, A, 2, B, 2, R1, R2, R3, Q,
+ $ 2, U, 2, 1, 2, LS, RS, ANRM, BNRM, RCE, RCV, W, 1,
+ $ IW, BW, INFO )
+ CALL CHKXER( 'DGGEVX', INFOT, NOUT, LERR, OK )
+ NT = NT + 12
+*
+* DTGEXC
+*
+ SRNAMT = 'DTGEXC'
+ INFOT = 3
+ CALL DTGEXC( .TRUE., .TRUE., -1, A, 1, B, 1, Q, 1, Z, 1, IFST,
+ $ ILST, W, 1, INFO )
+ CALL CHKXER( 'DTGEXC', INFOT, NOUT, LERR, OK )
+ INFOT = 5
+ CALL DTGEXC( .TRUE., .TRUE., 1, A, 0, B, 1, Q, 1, Z, 1, IFST,
+ $ ILST, W, 1, INFO )
+ CALL CHKXER( 'DTGEXC', INFOT, NOUT, LERR, OK )
+ INFOT = 7
+ CALL DTGEXC( .TRUE., .TRUE., 1, A, 1, B, 0, Q, 1, Z, 1, IFST,
+ $ ILST, W, 1, INFO )
+ CALL CHKXER( 'DTGEXC', INFOT, NOUT, LERR, OK )
+ INFOT = 9
+ CALL DTGEXC( .FALSE., .TRUE., 1, A, 1, B, 1, Q, 0, Z, 1, IFST,
+ $ ILST, W, 1, INFO )
+ CALL CHKXER( 'DTGEXC', INFOT, NOUT, LERR, OK )
+ INFOT = 9
+ CALL DTGEXC( .TRUE., .TRUE., 1, A, 1, B, 1, Q, 0, Z, 1, IFST,
+ $ ILST, W, 1, INFO )
+ CALL CHKXER( 'DTGEXC', INFOT, NOUT, LERR, OK )
+ INFOT = 11
+ CALL DTGEXC( .TRUE., .FALSE., 1, A, 1, B, 1, Q, 1, Z, 0, IFST,
+ $ ILST, W, 1, INFO )
+ CALL CHKXER( 'DTGEXC', INFOT, NOUT, LERR, OK )
+ INFOT = 11
+ CALL DTGEXC( .TRUE., .TRUE., 1, A, 1, B, 1, Q, 1, Z, 0, IFST,
+ $ ILST, W, 1, INFO )
+ CALL CHKXER( 'DTGEXC', INFOT, NOUT, LERR, OK )
+ INFOT = 15
+ CALL DTGEXC( .TRUE., .TRUE., 1, A, 1, B, 1, Q, 1, Z, 1, IFST,
+ $ ILST, W, 0, INFO )
+ CALL CHKXER( 'DTGEXC', INFOT, NOUT, LERR, OK )
+ NT = NT + 8
+*
+* DTGSEN
+*
+ SRNAMT = 'DTGSEN'
+ INFOT = 1
+ CALL DTGSEN( -1, .TRUE., .TRUE., SEL, 1, A, 1, B, 1, R1, R2,
+ $ R3, Q, 1, Z, 1, M, TOLA, TOLB, RCV, W, 1, IW, 1,
+ $ INFO )
+ CALL CHKXER( 'DTGSEN', INFOT, NOUT, LERR, OK )
+ INFOT = 5
+ CALL DTGSEN( 1, .TRUE., .TRUE., SEL, -1, A, 1, B, 1, R1, R2,
+ $ R3, Q, 1, Z, 1, M, TOLA, TOLB, RCV, W, 1, IW, 1,
+ $ INFO )
+ CALL CHKXER( 'DTGSEN', INFOT, NOUT, LERR, OK )
+ INFOT = 7
+ CALL DTGSEN( 1, .TRUE., .TRUE., SEL, 1, A, 0, B, 1, R1, R2, R3,
+ $ Q, 1, Z, 1, M, TOLA, TOLB, RCV, W, 1, IW, 1,
+ $ INFO )
+ CALL CHKXER( 'DTGSEN', INFOT, NOUT, LERR, OK )
+ INFOT = 9
+ CALL DTGSEN( 1, .TRUE., .TRUE., SEL, 1, A, 1, B, 0, R1, R2, R3,
+ $ Q, 1, Z, 1, M, TOLA, TOLB, RCV, W, 1, IW, 1,
+ $ INFO )
+ CALL CHKXER( 'DTGSEN', INFOT, NOUT, LERR, OK )
+ INFOT = 14
+ CALL DTGSEN( 1, .TRUE., .TRUE., SEL, 1, A, 1, B, 1, R1, R2, R3,
+ $ Q, 0, Z, 1, M, TOLA, TOLB, RCV, W, 1, IW, 1,
+ $ INFO )
+ CALL CHKXER( 'DTGSEN', INFOT, NOUT, LERR, OK )
+ INFOT = 16
+ CALL DTGSEN( 1, .TRUE., .TRUE., SEL, 1, A, 1, B, 1, R1, R2, R3,
+ $ Q, 1, Z, 0, M, TOLA, TOLB, RCV, W, 1, IW, 1,
+ $ INFO )
+ CALL CHKXER( 'DTGSEN', INFOT, NOUT, LERR, OK )
+ INFOT = 22
+ CALL DTGSEN( 0, .TRUE., .TRUE., SEL, 1, A, 1, B, 1, R1, R2, R3,
+ $ Q, 1, Z, 1, M, TOLA, TOLB, RCV, W, 1, IW, 1,
+ $ INFO )
+ CALL CHKXER( 'DTGSEN', INFOT, NOUT, LERR, OK )
+ INFOT = 22
+ CALL DTGSEN( 1, .TRUE., .TRUE., SEL, 1, A, 1, B, 1, R1, R2, R3,
+ $ Q, 1, Z, 1, M, TOLA, TOLB, RCV, W, 1, IW, 1,
+ $ INFO )
+ CALL CHKXER( 'DTGSEN', INFOT, NOUT, LERR, OK )
+ INFOT = 22
+ CALL DTGSEN( 2, .TRUE., .TRUE., SEL, 1, A, 1, B, 1, R1, R2, R3,
+ $ Q, 1, Z, 1, M, TOLA, TOLB, RCV, W, 1, IW, 1,
+ $ INFO )
+ CALL CHKXER( 'DTGSEN', INFOT, NOUT, LERR, OK )
+ INFOT = 24
+ CALL DTGSEN( 0, .TRUE., .TRUE., SEL, 1, A, 1, B, 1, R1, R2, R3,
+ $ Q, 1, Z, 1, M, TOLA, TOLB, RCV, W, 20, IW, 0,
+ $ INFO )
+ CALL CHKXER( 'DTGSEN', INFOT, NOUT, LERR, OK )
+ INFOT = 24
+ CALL DTGSEN( 1, .TRUE., .TRUE., SEL, 1, A, 1, B, 1, R1, R2, R3,
+ $ Q, 1, Z, 1, M, TOLA, TOLB, RCV, W, 20, IW, 0,
+ $ INFO )
+ CALL CHKXER( 'DTGSEN', INFOT, NOUT, LERR, OK )
+ INFOT = 24
+ CALL DTGSEN( 2, .TRUE., .TRUE., SEL, 1, A, 1, B, 1, R1, R2, R3,
+ $ Q, 1, Z, 1, M, TOLA, TOLB, RCV, W, 20, IW, 1,
+ $ INFO )
+ CALL CHKXER( 'DTGSEN', INFOT, NOUT, LERR, OK )
+ NT = NT + 12
+*
+* DTGSNA
+*
+ SRNAMT = 'DTGSNA'
+ INFOT = 1
+ CALL DTGSNA( '/', 'A', SEL, 1, A, 1, B, 1, Q, 1, U, 1, R1, R2,
+ $ 1, M, W, 1, IW, INFO )
+ CALL CHKXER( 'DTGSNA', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL DTGSNA( 'B', '/', SEL, 1, A, 1, B, 1, Q, 1, U, 1, R1, R2,
+ $ 1, M, W, 1, IW, INFO )
+ CALL CHKXER( 'DTGSNA', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL DTGSNA( 'B', 'A', SEL, -1, A, 1, B, 1, Q, 1, U, 1, R1, R2,
+ $ 1, M, W, 1, IW, INFO )
+ CALL CHKXER( 'DTGSNA', INFOT, NOUT, LERR, OK )
+ INFOT = 6
+ CALL DTGSNA( 'B', 'A', SEL, 1, A, 0, B, 1, Q, 1, U, 1, R1, R2,
+ $ 1, M, W, 1, IW, INFO )
+ CALL CHKXER( 'DTGSNA', INFOT, NOUT, LERR, OK )
+ INFOT = 8
+ CALL DTGSNA( 'B', 'A', SEL, 1, A, 1, B, 0, Q, 1, U, 1, R1, R2,
+ $ 1, M, W, 1, IW, INFO )
+ CALL CHKXER( 'DTGSNA', INFOT, NOUT, LERR, OK )
+ INFOT = 10
+ CALL DTGSNA( 'E', 'A', SEL, 1, A, 1, B, 1, Q, 0, U, 1, R1, R2,
+ $ 1, M, W, 1, IW, INFO )
+ CALL CHKXER( 'DTGSNA', INFOT, NOUT, LERR, OK )
+ INFOT = 12
+ CALL DTGSNA( 'E', 'A', SEL, 1, A, 1, B, 1, Q, 1, U, 0, R1, R2,
+ $ 1, M, W, 1, IW, INFO )
+ CALL CHKXER( 'DTGSNA', INFOT, NOUT, LERR, OK )
+ INFOT = 15
+ CALL DTGSNA( 'E', 'A', SEL, 1, A, 1, B, 1, Q, 1, U, 1, R1, R2,
+ $ 0, M, W, 1, IW, INFO )
+ CALL CHKXER( 'DTGSNA', INFOT, NOUT, LERR, OK )
+ INFOT = 18
+ CALL DTGSNA( 'E', 'A', SEL, 1, A, 1, B, 1, Q, 1, U, 1, R1, R2,
+ $ 1, M, W, 0, IW, INFO )
+ CALL CHKXER( 'DTGSNA', INFOT, NOUT, LERR, OK )
+ NT = NT + 9
+*
+* DTGSYL
+*
+ SRNAMT = 'DTGSYL'
+ INFOT = 1
+ CALL DTGSYL( '/', 0, 1, 1, A, 1, B, 1, Q, 1, U, 1, V, 1, Z, 1,
+ $ SCALE, DIF, W, 1, IW, INFO )
+ CALL CHKXER( 'DTGSYL', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL DTGSYL( 'N', -1, 1, 1, A, 1, B, 1, Q, 1, U, 1, V, 1, Z, 1,
+ $ SCALE, DIF, W, 1, IW, INFO )
+ CALL CHKXER( 'DTGSYL', INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL DTGSYL( 'N', 0, 0, 1, A, 1, B, 1, Q, 1, U, 1, V, 1, Z, 1,
+ $ SCALE, DIF, W, 1, IW, INFO )
+ CALL CHKXER( 'DTGSYL', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL DTGSYL( 'N', 0, 1, 0, A, 1, B, 1, Q, 1, U, 1, V, 1, Z, 1,
+ $ SCALE, DIF, W, 1, IW, INFO )
+ CALL CHKXER( 'DTGSYL', INFOT, NOUT, LERR, OK )
+ INFOT = 6
+ CALL DTGSYL( 'N', 0, 1, 1, A, 0, B, 1, Q, 1, U, 1, V, 1, Z, 1,
+ $ SCALE, DIF, W, 1, IW, INFO )
+ CALL CHKXER( 'DTGSYL', INFOT, NOUT, LERR, OK )
+ INFOT = 8
+ CALL DTGSYL( 'N', 0, 1, 1, A, 1, B, 0, Q, 1, U, 1, V, 1, Z, 1,
+ $ SCALE, DIF, W, 1, IW, INFO )
+ CALL CHKXER( 'DTGSYL', INFOT, NOUT, LERR, OK )
+ INFOT = 10
+ CALL DTGSYL( 'N', 0, 1, 1, A, 1, B, 1, Q, 0, U, 1, V, 1, Z, 1,
+ $ SCALE, DIF, W, 1, IW, INFO )
+ CALL CHKXER( 'DTGSYL', INFOT, NOUT, LERR, OK )
+ INFOT = 12
+ CALL DTGSYL( 'N', 0, 1, 1, A, 1, B, 1, Q, 1, U, 0, V, 1, Z, 1,
+ $ SCALE, DIF, W, 1, IW, INFO )
+ CALL CHKXER( 'DTGSYL', INFOT, NOUT, LERR, OK )
+ INFOT = 14
+ CALL DTGSYL( 'N', 0, 1, 1, A, 1, B, 1, Q, 1, U, 1, V, 0, Z, 1,
+ $ SCALE, DIF, W, 1, IW, INFO )
+ CALL CHKXER( 'DTGSYL', INFOT, NOUT, LERR, OK )
+ INFOT = 16
+ CALL DTGSYL( 'N', 0, 1, 1, A, 1, B, 1, Q, 1, U, 1, V, 1, Z, 0,
+ $ SCALE, DIF, W, 1, IW, INFO )
+ CALL CHKXER( 'DTGSYL', INFOT, NOUT, LERR, OK )
+ INFOT = 20
+ CALL DTGSYL( 'N', 1, 1, 1, A, 1, B, 1, Q, 1, U, 1, V, 1, Z, 1,
+ $ SCALE, DIF, W, 1, IW, INFO )
+ CALL CHKXER( 'DTGSYL', INFOT, NOUT, LERR, OK )
+ INFOT = 20
+ CALL DTGSYL( 'N', 2, 1, 1, A, 1, B, 1, Q, 1, U, 1, V, 1, Z, 1,
+ $ SCALE, DIF, W, 1, IW, INFO )
+ CALL CHKXER( 'DTGSYL', INFOT, NOUT, LERR, OK )
+ NT = NT + 12
+ END IF
+*
+* Print a summary line.
+*
+ IF( OK ) THEN
+ WRITE( NOUT, FMT = 9999 )PATH, NT
+ ELSE
+ WRITE( NOUT, FMT = 9998 )PATH
+ END IF
+*
+ 9999 FORMAT( 1X, A3, ' routines passed the tests of the error exits (',
+ $ I3, ' tests done)' )
+ 9998 FORMAT( ' *** ', A3, ' routines failed the tests of the error ',
+ $ 'exits ***' )
+*
+ RETURN
+*
+* End of DERRGG
+*
+ END
+ SUBROUTINE DERRHS( PATH, NUNIT )
+*
+* -- LAPACK test routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER*3 PATH
+ INTEGER NUNIT
+* ..
+*
+* Purpose
+* =======
+*
+* DERRHS tests the error exits for DGEBAK, SGEBAL, SGEHRD, DORGHR,
+* DORMHR, DHSEQR, SHSEIN, and DTREVC.
+*
+* Arguments
+* =========
+*
+* PATH (input) CHARACTER*3
+* The LAPACK path name for the routines to be tested.
+*
+* NUNIT (input) INTEGER
+* The unit number for output.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ INTEGER NMAX, LW
+ PARAMETER ( NMAX = 3, LW = ( NMAX+2 )*( NMAX+2 )+NMAX )
+* ..
+* .. Local Scalars ..
+ CHARACTER*2 C2
+ INTEGER I, IHI, ILO, INFO, J, M, NT
+* ..
+* .. Local Arrays ..
+ LOGICAL SEL( NMAX )
+ INTEGER IFAILL( NMAX ), IFAILR( NMAX )
+ DOUBLE PRECISION A( NMAX, NMAX ), C( NMAX, NMAX ), S( NMAX ),
+ $ TAU( NMAX ), VL( NMAX, NMAX ),
+ $ VR( NMAX, NMAX ), W( LW ), WI( NMAX ),
+ $ WR( NMAX )
+* ..
+* .. External Functions ..
+ LOGICAL LSAMEN
+ EXTERNAL LSAMEN
+* ..
+* .. External Subroutines ..
+ EXTERNAL CHKXER, DGEBAK, DGEBAL, DGEHRD, DHSEIN, DHSEQR,
+ $ DORGHR, DORMHR, DTREVC
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC DBLE
+* ..
+* .. Scalars in Common ..
+ LOGICAL LERR, OK
+ CHARACTER*6 SRNAMT
+ INTEGER INFOT, NOUT
+* ..
+* .. Common blocks ..
+ COMMON / INFOC / INFOT, NOUT, OK, LERR
+ COMMON / SRNAMC / SRNAMT
+* ..
+* .. Executable Statements ..
+*
+ NOUT = NUNIT
+ WRITE( NOUT, FMT = * )
+ C2 = PATH( 2: 3 )
+*
+* Set the variables to innocuous values.
+*
+ DO 20 J = 1, NMAX
+ DO 10 I = 1, NMAX
+ A( I, J ) = 1.D0 / DBLE( I+J )
+ 10 CONTINUE
+ WI( J ) = DBLE( J )
+ SEL( J ) = .TRUE.
+ 20 CONTINUE
+ OK = .TRUE.
+ NT = 0
+*
+* Test error exits of the nonsymmetric eigenvalue routines.
+*
+ IF( LSAMEN( 2, C2, 'HS' ) ) THEN
+*
+* DGEBAL
+*
+ SRNAMT = 'DGEBAL'
+ INFOT = 1
+ CALL DGEBAL( '/', 0, A, 1, ILO, IHI, S, INFO )
+ CALL CHKXER( 'DGEBAL', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL DGEBAL( 'N', -1, A, 1, ILO, IHI, S, INFO )
+ CALL CHKXER( 'DGEBAL', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL DGEBAL( 'N', 2, A, 1, ILO, IHI, S, INFO )
+ CALL CHKXER( 'DGEBAL', INFOT, NOUT, LERR, OK )
+ NT = NT + 3
+*
+* DGEBAK
+*
+ SRNAMT = 'DGEBAK'
+ INFOT = 1
+ CALL DGEBAK( '/', 'R', 0, 1, 0, S, 0, A, 1, INFO )
+ CALL CHKXER( 'DGEBAK', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL DGEBAK( 'N', '/', 0, 1, 0, S, 0, A, 1, INFO )
+ CALL CHKXER( 'DGEBAK', INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL DGEBAK( 'N', 'R', -1, 1, 0, S, 0, A, 1, INFO )
+ CALL CHKXER( 'DGEBAK', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL DGEBAK( 'N', 'R', 0, 0, 0, S, 0, A, 1, INFO )
+ CALL CHKXER( 'DGEBAK', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL DGEBAK( 'N', 'R', 0, 2, 0, S, 0, A, 1, INFO )
+ CALL CHKXER( 'DGEBAK', INFOT, NOUT, LERR, OK )
+ INFOT = 5
+ CALL DGEBAK( 'N', 'R', 2, 2, 1, S, 0, A, 2, INFO )
+ CALL CHKXER( 'DGEBAK', INFOT, NOUT, LERR, OK )
+ INFOT = 5
+ CALL DGEBAK( 'N', 'R', 0, 1, 1, S, 0, A, 1, INFO )
+ CALL CHKXER( 'DGEBAK', INFOT, NOUT, LERR, OK )
+ INFOT = 7
+ CALL DGEBAK( 'N', 'R', 0, 1, 0, S, -1, A, 1, INFO )
+ CALL CHKXER( 'DGEBAK', INFOT, NOUT, LERR, OK )
+ INFOT = 9
+ CALL DGEBAK( 'N', 'R', 2, 1, 2, S, 0, A, 1, INFO )
+ CALL CHKXER( 'DGEBAK', INFOT, NOUT, LERR, OK )
+ NT = NT + 9
+*
+* DGEHRD
+*
+ SRNAMT = 'DGEHRD'
+ INFOT = 1
+ CALL DGEHRD( -1, 1, 1, A, 1, TAU, W, 1, INFO )
+ CALL CHKXER( 'DGEHRD', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL DGEHRD( 0, 0, 0, A, 1, TAU, W, 1, INFO )
+ CALL CHKXER( 'DGEHRD', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL DGEHRD( 0, 2, 0, A, 1, TAU, W, 1, INFO )
+ CALL CHKXER( 'DGEHRD', INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL DGEHRD( 1, 1, 0, A, 1, TAU, W, 1, INFO )
+ CALL CHKXER( 'DGEHRD', INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL DGEHRD( 0, 1, 1, A, 1, TAU, W, 1, INFO )
+ CALL CHKXER( 'DGEHRD', INFOT, NOUT, LERR, OK )
+ INFOT = 5
+ CALL DGEHRD( 2, 1, 1, A, 1, TAU, W, 2, INFO )
+ CALL CHKXER( 'DGEHRD', INFOT, NOUT, LERR, OK )
+ INFOT = 8
+ CALL DGEHRD( 2, 1, 2, A, 2, TAU, W, 1, INFO )
+ CALL CHKXER( 'DGEHRD', INFOT, NOUT, LERR, OK )
+ NT = NT + 7
+*
+* DORGHR
+*
+ SRNAMT = 'DORGHR'
+ INFOT = 1
+ CALL DORGHR( -1, 1, 1, A, 1, TAU, W, 1, INFO )
+ CALL CHKXER( 'DORGHR', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL DORGHR( 0, 0, 0, A, 1, TAU, W, 1, INFO )
+ CALL CHKXER( 'DORGHR', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL DORGHR( 0, 2, 0, A, 1, TAU, W, 1, INFO )
+ CALL CHKXER( 'DORGHR', INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL DORGHR( 1, 1, 0, A, 1, TAU, W, 1, INFO )
+ CALL CHKXER( 'DORGHR', INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL DORGHR( 0, 1, 1, A, 1, TAU, W, 1, INFO )
+ CALL CHKXER( 'DORGHR', INFOT, NOUT, LERR, OK )
+ INFOT = 5
+ CALL DORGHR( 2, 1, 1, A, 1, TAU, W, 1, INFO )
+ CALL CHKXER( 'DORGHR', INFOT, NOUT, LERR, OK )
+ INFOT = 8
+ CALL DORGHR( 3, 1, 3, A, 3, TAU, W, 1, INFO )
+ CALL CHKXER( 'DORGHR', INFOT, NOUT, LERR, OK )
+ NT = NT + 7
+*
+* DORMHR
+*
+ SRNAMT = 'DORMHR'
+ INFOT = 1
+ CALL DORMHR( '/', 'N', 0, 0, 1, 0, A, 1, TAU, C, 1, W, 1,
+ $ INFO )
+ CALL CHKXER( 'DORMHR', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL DORMHR( 'L', '/', 0, 0, 1, 0, A, 1, TAU, C, 1, W, 1,
+ $ INFO )
+ CALL CHKXER( 'DORMHR', INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL DORMHR( 'L', 'N', -1, 0, 1, 0, A, 1, TAU, C, 1, W, 1,
+ $ INFO )
+ CALL CHKXER( 'DORMHR', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL DORMHR( 'L', 'N', 0, -1, 1, 0, A, 1, TAU, C, 1, W, 1,
+ $ INFO )
+ CALL CHKXER( 'DORMHR', INFOT, NOUT, LERR, OK )
+ INFOT = 5
+ CALL DORMHR( 'L', 'N', 0, 0, 0, 0, A, 1, TAU, C, 1, W, 1,
+ $ INFO )
+ CALL CHKXER( 'DORMHR', INFOT, NOUT, LERR, OK )
+ INFOT = 5
+ CALL DORMHR( 'L', 'N', 0, 0, 2, 0, A, 1, TAU, C, 1, W, 1,
+ $ INFO )
+ CALL CHKXER( 'DORMHR', INFOT, NOUT, LERR, OK )
+ INFOT = 5
+ CALL DORMHR( 'L', 'N', 1, 2, 2, 1, A, 1, TAU, C, 1, W, 2,
+ $ INFO )
+ CALL CHKXER( 'DORMHR', INFOT, NOUT, LERR, OK )
+ INFOT = 5
+ CALL DORMHR( 'R', 'N', 2, 1, 2, 1, A, 1, TAU, C, 2, W, 2,
+ $ INFO )
+ CALL CHKXER( 'DORMHR', INFOT, NOUT, LERR, OK )
+ INFOT = 6
+ CALL DORMHR( 'L', 'N', 1, 1, 1, 0, A, 1, TAU, C, 1, W, 1,
+ $ INFO )
+ CALL CHKXER( 'DORMHR', INFOT, NOUT, LERR, OK )
+ INFOT = 6
+ CALL DORMHR( 'L', 'N', 0, 1, 1, 1, A, 1, TAU, C, 1, W, 1,
+ $ INFO )
+ CALL CHKXER( 'DORMHR', INFOT, NOUT, LERR, OK )
+ INFOT = 6
+ CALL DORMHR( 'R', 'N', 1, 0, 1, 1, A, 1, TAU, C, 1, W, 1,
+ $ INFO )
+ CALL CHKXER( 'DORMHR', INFOT, NOUT, LERR, OK )
+ INFOT = 8
+ CALL DORMHR( 'L', 'N', 2, 1, 1, 1, A, 1, TAU, C, 2, W, 1,
+ $ INFO )
+ CALL CHKXER( 'DORMHR', INFOT, NOUT, LERR, OK )
+ INFOT = 8
+ CALL DORMHR( 'R', 'N', 1, 2, 1, 1, A, 1, TAU, C, 1, W, 1,
+ $ INFO )
+ CALL CHKXER( 'DORMHR', INFOT, NOUT, LERR, OK )
+ INFOT = 11
+ CALL DORMHR( 'L', 'N', 2, 1, 1, 1, A, 2, TAU, C, 1, W, 1,
+ $ INFO )
+ CALL CHKXER( 'DORMHR', INFOT, NOUT, LERR, OK )
+ INFOT = 13
+ CALL DORMHR( 'L', 'N', 1, 2, 1, 1, A, 1, TAU, C, 1, W, 1,
+ $ INFO )
+ CALL CHKXER( 'DORMHR', INFOT, NOUT, LERR, OK )
+ INFOT = 13
+ CALL DORMHR( 'R', 'N', 2, 1, 1, 1, A, 1, TAU, C, 2, W, 1,
+ $ INFO )
+ CALL CHKXER( 'DORMHR', INFOT, NOUT, LERR, OK )
+ NT = NT + 16
+*
+* DHSEQR
+*
+ SRNAMT = 'DHSEQR'
+ INFOT = 1
+ CALL DHSEQR( '/', 'N', 0, 1, 0, A, 1, WR, WI, C, 1, W, 1,
+ $ INFO )
+ CALL CHKXER( 'DHSEQR', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL DHSEQR( 'E', '/', 0, 1, 0, A, 1, WR, WI, C, 1, W, 1,
+ $ INFO )
+ CALL CHKXER( 'DHSEQR', INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL DHSEQR( 'E', 'N', -1, 1, 0, A, 1, WR, WI, C, 1, W, 1,
+ $ INFO )
+ CALL CHKXER( 'DHSEQR', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL DHSEQR( 'E', 'N', 0, 0, 0, A, 1, WR, WI, C, 1, W, 1,
+ $ INFO )
+ CALL CHKXER( 'DHSEQR', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL DHSEQR( 'E', 'N', 0, 2, 0, A, 1, WR, WI, C, 1, W, 1,
+ $ INFO )
+ CALL CHKXER( 'DHSEQR', INFOT, NOUT, LERR, OK )
+ INFOT = 5
+ CALL DHSEQR( 'E', 'N', 1, 1, 0, A, 1, WR, WI, C, 1, W, 1,
+ $ INFO )
+ CALL CHKXER( 'DHSEQR', INFOT, NOUT, LERR, OK )
+ INFOT = 5
+ CALL DHSEQR( 'E', 'N', 1, 1, 2, A, 1, WR, WI, C, 1, W, 1,
+ $ INFO )
+ CALL CHKXER( 'DHSEQR', INFOT, NOUT, LERR, OK )
+ INFOT = 7
+ CALL DHSEQR( 'E', 'N', 2, 1, 2, A, 1, WR, WI, C, 2, W, 1,
+ $ INFO )
+ CALL CHKXER( 'DHSEQR', INFOT, NOUT, LERR, OK )
+ INFOT = 11
+ CALL DHSEQR( 'E', 'V', 2, 1, 2, A, 2, WR, WI, C, 1, W, 1,
+ $ INFO )
+ CALL CHKXER( 'DHSEQR', INFOT, NOUT, LERR, OK )
+ NT = NT + 9
+*
+* DHSEIN
+*
+ SRNAMT = 'DHSEIN'
+ INFOT = 1
+ CALL DHSEIN( '/', 'N', 'N', SEL, 0, A, 1, WR, WI, VL, 1, VR, 1,
+ $ 0, M, W, IFAILL, IFAILR, INFO )
+ CALL CHKXER( 'DHSEIN', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL DHSEIN( 'R', '/', 'N', SEL, 0, A, 1, WR, WI, VL, 1, VR, 1,
+ $ 0, M, W, IFAILL, IFAILR, INFO )
+ CALL CHKXER( 'DHSEIN', INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL DHSEIN( 'R', 'N', '/', SEL, 0, A, 1, WR, WI, VL, 1, VR, 1,
+ $ 0, M, W, IFAILL, IFAILR, INFO )
+ CALL CHKXER( 'DHSEIN', INFOT, NOUT, LERR, OK )
+ INFOT = 5
+ CALL DHSEIN( 'R', 'N', 'N', SEL, -1, A, 1, WR, WI, VL, 1, VR,
+ $ 1, 0, M, W, IFAILL, IFAILR, INFO )
+ CALL CHKXER( 'DHSEIN', INFOT, NOUT, LERR, OK )
+ INFOT = 7
+ CALL DHSEIN( 'R', 'N', 'N', SEL, 2, A, 1, WR, WI, VL, 1, VR, 2,
+ $ 4, M, W, IFAILL, IFAILR, INFO )
+ CALL CHKXER( 'DHSEIN', INFOT, NOUT, LERR, OK )
+ INFOT = 11
+ CALL DHSEIN( 'L', 'N', 'N', SEL, 2, A, 2, WR, WI, VL, 1, VR, 1,
+ $ 4, M, W, IFAILL, IFAILR, INFO )
+ CALL CHKXER( 'DHSEIN', INFOT, NOUT, LERR, OK )
+ INFOT = 13
+ CALL DHSEIN( 'R', 'N', 'N', SEL, 2, A, 2, WR, WI, VL, 1, VR, 1,
+ $ 4, M, W, IFAILL, IFAILR, INFO )
+ CALL CHKXER( 'DHSEIN', INFOT, NOUT, LERR, OK )
+ INFOT = 14
+ CALL DHSEIN( 'R', 'N', 'N', SEL, 2, A, 2, WR, WI, VL, 1, VR, 2,
+ $ 1, M, W, IFAILL, IFAILR, INFO )
+ CALL CHKXER( 'DHSEIN', INFOT, NOUT, LERR, OK )
+ NT = NT + 8
+*
+* DTREVC
+*
+ SRNAMT = 'DTREVC'
+ INFOT = 1
+ CALL DTREVC( '/', 'A', SEL, 0, A, 1, VL, 1, VR, 1, 0, M, W,
+ $ INFO )
+ CALL CHKXER( 'DTREVC', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL DTREVC( 'L', '/', SEL, 0, A, 1, VL, 1, VR, 1, 0, M, W,
+ $ INFO )
+ CALL CHKXER( 'DTREVC', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL DTREVC( 'L', 'A', SEL, -1, A, 1, VL, 1, VR, 1, 0, M, W,
+ $ INFO )
+ CALL CHKXER( 'DTREVC', INFOT, NOUT, LERR, OK )
+ INFOT = 6
+ CALL DTREVC( 'L', 'A', SEL, 2, A, 1, VL, 2, VR, 1, 4, M, W,
+ $ INFO )
+ CALL CHKXER( 'DTREVC', INFOT, NOUT, LERR, OK )
+ INFOT = 8
+ CALL DTREVC( 'L', 'A', SEL, 2, A, 2, VL, 1, VR, 1, 4, M, W,
+ $ INFO )
+ CALL CHKXER( 'DTREVC', INFOT, NOUT, LERR, OK )
+ INFOT = 10
+ CALL DTREVC( 'R', 'A', SEL, 2, A, 2, VL, 1, VR, 1, 4, M, W,
+ $ INFO )
+ CALL CHKXER( 'DTREVC', INFOT, NOUT, LERR, OK )
+ INFOT = 11
+ CALL DTREVC( 'L', 'A', SEL, 2, A, 2, VL, 2, VR, 1, 1, M, W,
+ $ INFO )
+ CALL CHKXER( 'DTREVC', INFOT, NOUT, LERR, OK )
+ NT = NT + 7
+ END IF
+*
+* Print a summary line.
+*
+ IF( OK ) THEN
+ WRITE( NOUT, FMT = 9999 )PATH, NT
+ ELSE
+ WRITE( NOUT, FMT = 9998 )PATH
+ END IF
+*
+ 9999 FORMAT( 1X, A3, ' routines passed the tests of the error exits',
+ $ ' (', I3, ' tests done)' )
+ 9998 FORMAT( ' *** ', A3, ' routines failed the tests of the error ',
+ $ 'exits ***' )
+*
+ RETURN
+*
+* End of DERRHS
+*
+ END
+ SUBROUTINE DERRST( PATH, NUNIT )
+*
+* -- LAPACK test routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER*3 PATH
+ INTEGER NUNIT
+* ..
+*
+* Purpose
+* =======
+*
+* DERRST tests the error exits for DSYTRD, DORGTR, DORMTR, DSPTRD,
+* DOPGTR, DOPMTR, DSTEQR, SSTERF, SSTEBZ, SSTEIN, DPTEQR, DSBTRD,
+* DSYEV, SSYEVX, SSYEVD, DSBEV, SSBEVX, SSBEVD,
+* DSPEV, SSPEVX, SSPEVD, DSTEV, SSTEVX, SSTEVD, and SSTEDC.
+*
+* Arguments
+* =========
+*
+* PATH (input) CHARACTER*3
+* The LAPACK path name for the routines to be tested.
+*
+* NUNIT (input) INTEGER
+* The unit number for output.
+*
+* =====================================================================
+*
+* NMAX has to be at least 3 or LIW may be too small
+* .. Parameters ..
+ INTEGER NMAX, LIW, LW
+ PARAMETER ( NMAX = 3, LIW = 12*NMAX, LW = 20*NMAX )
+* ..
+* .. Local Scalars ..
+ CHARACTER*2 C2
+ INTEGER I, INFO, J, M, N, NSPLIT, NT
+* ..
+* .. Local Arrays ..
+ INTEGER I1( NMAX ), I2( NMAX ), I3( NMAX ), IW( LIW )
+ DOUBLE PRECISION A( NMAX, NMAX ), C( NMAX, NMAX ), D( NMAX ),
+ $ E( NMAX ), Q( NMAX, NMAX ), R( NMAX ),
+ $ TAU( NMAX ), W( LW ), X( NMAX ),
+ $ Z( NMAX, NMAX )
+* ..
+* .. External Functions ..
+ LOGICAL LSAMEN
+ EXTERNAL LSAMEN
+* ..
+* .. External Subroutines ..
+ EXTERNAL CHKXER, DOPGTR, DOPMTR, DORGTR, DORMTR, DPTEQR,
+ $ DSBEV, DSBEVD, DSBEVX, DSBTRD, DSPEV, DSPEVD,
+ $ DSPEVX, DSPTRD, DSTEBZ, DSTEDC, DSTEIN, DSTEQR,
+ $ DSTERF, DSTEV, DSTEVD, DSTEVR, DSTEVX, DSYEV,
+ $ DSYEVD, DSYEVR, DSYEVX, DSYTRD
+* ..
+* .. Scalars in Common ..
+ LOGICAL LERR, OK
+ CHARACTER*6 SRNAMT
+ INTEGER INFOT, NOUT
+* ..
+* .. Common blocks ..
+ COMMON / INFOC / INFOT, NOUT, OK, LERR
+ COMMON / SRNAMC / SRNAMT
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC DBLE
+* ..
+* .. Executable Statements ..
+*
+ NOUT = NUNIT
+ WRITE( NOUT, FMT = * )
+ C2 = PATH( 2: 3 )
+*
+* Set the variables to innocuous values.
+*
+ DO 20 J = 1, NMAX
+ DO 10 I = 1, NMAX
+ A( I, J ) = 1.D0 / DBLE( I+J )
+ 10 CONTINUE
+ 20 CONTINUE
+ DO 30 J = 1, NMAX
+ D( J ) = DBLE( J )
+ E( J ) = 0.0D0
+ I1( J ) = J
+ I2( J ) = J
+ TAU( J ) = 1.D0
+ 30 CONTINUE
+ OK = .TRUE.
+ NT = 0
+*
+* Test error exits for the ST path.
+*
+ IF( LSAMEN( 2, C2, 'ST' ) ) THEN
+*
+* DSYTRD
+*
+ SRNAMT = 'DSYTRD'
+ INFOT = 1
+ CALL DSYTRD( '/', 0, A, 1, D, E, TAU, W, 1, INFO )
+ CALL CHKXER( 'DSYTRD', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL DSYTRD( 'U', -1, A, 1, D, E, TAU, W, 1, INFO )
+ CALL CHKXER( 'DSYTRD', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL DSYTRD( 'U', 2, A, 1, D, E, TAU, W, 1, INFO )
+ CALL CHKXER( 'DSYTRD', INFOT, NOUT, LERR, OK )
+ INFOT = 9
+ CALL DSYTRD( 'U', 0, A, 1, D, E, TAU, W, 0, INFO )
+ CALL CHKXER( 'DSYTRD', INFOT, NOUT, LERR, OK )
+ NT = NT + 4
+*
+* DORGTR
+*
+ SRNAMT = 'DORGTR'
+ INFOT = 1
+ CALL DORGTR( '/', 0, A, 1, TAU, W, 1, INFO )
+ CALL CHKXER( 'DORGTR', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL DORGTR( 'U', -1, A, 1, TAU, W, 1, INFO )
+ CALL CHKXER( 'DORGTR', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL DORGTR( 'U', 2, A, 1, TAU, W, 1, INFO )
+ CALL CHKXER( 'DORGTR', INFOT, NOUT, LERR, OK )
+ INFOT = 7
+ CALL DORGTR( 'U', 3, A, 3, TAU, W, 1, INFO )
+ CALL CHKXER( 'DORGTR', INFOT, NOUT, LERR, OK )
+ NT = NT + 4
+*
+* DORMTR
+*
+ SRNAMT = 'DORMTR'
+ INFOT = 1
+ CALL DORMTR( '/', 'U', 'N', 0, 0, A, 1, TAU, C, 1, W, 1, INFO )
+ CALL CHKXER( 'DORMTR', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL DORMTR( 'L', '/', 'N', 0, 0, A, 1, TAU, C, 1, W, 1, INFO )
+ CALL CHKXER( 'DORMTR', INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL DORMTR( 'L', 'U', '/', 0, 0, A, 1, TAU, C, 1, W, 1, INFO )
+ CALL CHKXER( 'DORMTR', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL DORMTR( 'L', 'U', 'N', -1, 0, A, 1, TAU, C, 1, W, 1,
+ $ INFO )
+ CALL CHKXER( 'DORMTR', INFOT, NOUT, LERR, OK )
+ INFOT = 5
+ CALL DORMTR( 'L', 'U', 'N', 0, -1, A, 1, TAU, C, 1, W, 1,
+ $ INFO )
+ CALL CHKXER( 'DORMTR', INFOT, NOUT, LERR, OK )
+ INFOT = 7
+ CALL DORMTR( 'L', 'U', 'N', 2, 0, A, 1, TAU, C, 2, W, 1, INFO )
+ CALL CHKXER( 'DORMTR', INFOT, NOUT, LERR, OK )
+ INFOT = 7
+ CALL DORMTR( 'R', 'U', 'N', 0, 2, A, 1, TAU, C, 1, W, 1, INFO )
+ CALL CHKXER( 'DORMTR', INFOT, NOUT, LERR, OK )
+ INFOT = 10
+ CALL DORMTR( 'L', 'U', 'N', 2, 0, A, 2, TAU, C, 1, W, 1, INFO )
+ CALL CHKXER( 'DORMTR', INFOT, NOUT, LERR, OK )
+ INFOT = 12
+ CALL DORMTR( 'L', 'U', 'N', 0, 2, A, 1, TAU, C, 1, W, 1, INFO )
+ CALL CHKXER( 'DORMTR', INFOT, NOUT, LERR, OK )
+ INFOT = 12
+ CALL DORMTR( 'R', 'U', 'N', 2, 0, A, 1, TAU, C, 2, W, 1, INFO )
+ CALL CHKXER( 'DORMTR', INFOT, NOUT, LERR, OK )
+ NT = NT + 10
+*
+* DSPTRD
+*
+ SRNAMT = 'DSPTRD'
+ INFOT = 1
+ CALL DSPTRD( '/', 0, A, D, E, TAU, INFO )
+ CALL CHKXER( 'DSPTRD', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL DSPTRD( 'U', -1, A, D, E, TAU, INFO )
+ CALL CHKXER( 'DSPTRD', INFOT, NOUT, LERR, OK )
+ NT = NT + 2
+*
+* DOPGTR
+*
+ SRNAMT = 'DOPGTR'
+ INFOT = 1
+ CALL DOPGTR( '/', 0, A, TAU, Z, 1, W, INFO )
+ CALL CHKXER( 'DOPGTR', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL DOPGTR( 'U', -1, A, TAU, Z, 1, W, INFO )
+ CALL CHKXER( 'DOPGTR', INFOT, NOUT, LERR, OK )
+ INFOT = 6
+ CALL DOPGTR( 'U', 2, A, TAU, Z, 1, W, INFO )
+ CALL CHKXER( 'DOPGTR', INFOT, NOUT, LERR, OK )
+ NT = NT + 3
+*
+* DOPMTR
+*
+ SRNAMT = 'DOPMTR'
+ INFOT = 1
+ CALL DOPMTR( '/', 'U', 'N', 0, 0, A, TAU, C, 1, W, INFO )
+ CALL CHKXER( 'DOPMTR', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL DOPMTR( 'L', '/', 'N', 0, 0, A, TAU, C, 1, W, INFO )
+ CALL CHKXER( 'DOPMTR', INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL DOPMTR( 'L', 'U', '/', 0, 0, A, TAU, C, 1, W, INFO )
+ CALL CHKXER( 'DOPMTR', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL DOPMTR( 'L', 'U', 'N', -1, 0, A, TAU, C, 1, W, INFO )
+ CALL CHKXER( 'DOPMTR', INFOT, NOUT, LERR, OK )
+ INFOT = 5
+ CALL DOPMTR( 'L', 'U', 'N', 0, -1, A, TAU, C, 1, W, INFO )
+ CALL CHKXER( 'DOPMTR', INFOT, NOUT, LERR, OK )
+ INFOT = 9
+ CALL DOPMTR( 'L', 'U', 'N', 2, 0, A, TAU, C, 1, W, INFO )
+ CALL CHKXER( 'DOPMTR', INFOT, NOUT, LERR, OK )
+ NT = NT + 6
+*
+* DPTEQR
+*
+ SRNAMT = 'DPTEQR'
+ INFOT = 1
+ CALL DPTEQR( '/', 0, D, E, Z, 1, W, INFO )
+ CALL CHKXER( 'DPTEQR', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL DPTEQR( 'N', -1, D, E, Z, 1, W, INFO )
+ CALL CHKXER( 'DPTEQR', INFOT, NOUT, LERR, OK )
+ INFOT = 6
+ CALL DPTEQR( 'V', 2, D, E, Z, 1, W, INFO )
+ CALL CHKXER( 'DPTEQR', INFOT, NOUT, LERR, OK )
+ NT = NT + 3
+*
+* DSTEBZ
+*
+ SRNAMT = 'DSTEBZ'
+ INFOT = 1
+ CALL DSTEBZ( '/', 'E', 0, 0.0D0, 1.0D0, 1, 0, 0.0D0, D, E, M,
+ $ NSPLIT, X, I1, I2, W, IW, INFO )
+ CALL CHKXER( 'DSTEBZ', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL DSTEBZ( 'A', '/', 0, 0.0D0, 0.0D0, 0, 0, 0.0D0, D, E, M,
+ $ NSPLIT, X, I1, I2, W, IW, INFO )
+ CALL CHKXER( 'DSTEBZ', INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL DSTEBZ( 'A', 'E', -1, 0.0D0, 0.0D0, 0, 0, 0.0D0, D, E, M,
+ $ NSPLIT, X, I1, I2, W, IW, INFO )
+ CALL CHKXER( 'DSTEBZ', INFOT, NOUT, LERR, OK )
+ INFOT = 5
+ CALL DSTEBZ( 'V', 'E', 0, 0.0D0, 0.0D0, 0, 0, 0.0D0, D, E, M,
+ $ NSPLIT, X, I1, I2, W, IW, INFO )
+ CALL CHKXER( 'DSTEBZ', INFOT, NOUT, LERR, OK )
+ INFOT = 6
+ CALL DSTEBZ( 'I', 'E', 0, 0.0D0, 0.0D0, 0, 0, 0.0D0, D, E, M,
+ $ NSPLIT, X, I1, I2, W, IW, INFO )
+ CALL CHKXER( 'DSTEBZ', INFOT, NOUT, LERR, OK )
+ INFOT = 6
+ CALL DSTEBZ( 'I', 'E', 1, 0.0D0, 0.0D0, 2, 1, 0.0D0, D, E, M,
+ $ NSPLIT, X, I1, I2, W, IW, INFO )
+ CALL CHKXER( 'DSTEBZ', INFOT, NOUT, LERR, OK )
+ INFOT = 7
+ CALL DSTEBZ( 'I', 'E', 1, 0.0D0, 0.0D0, 1, 0, 0.0D0, D, E, M,
+ $ NSPLIT, X, I1, I2, W, IW, INFO )
+ CALL CHKXER( 'DSTEBZ', INFOT, NOUT, LERR, OK )
+ INFOT = 7
+ CALL DSTEBZ( 'I', 'E', 1, 0.0D0, 0.0D0, 1, 2, 0.0D0, D, E, M,
+ $ NSPLIT, X, I1, I2, W, IW, INFO )
+ CALL CHKXER( 'DSTEBZ', INFOT, NOUT, LERR, OK )
+ NT = NT + 8
+*
+* DSTEIN
+*
+ SRNAMT = 'DSTEIN'
+ INFOT = 1
+ CALL DSTEIN( -1, D, E, 0, X, I1, I2, Z, 1, W, IW, I3, INFO )
+ CALL CHKXER( 'DSTEIN', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL DSTEIN( 0, D, E, -1, X, I1, I2, Z, 1, W, IW, I3, INFO )
+ CALL CHKXER( 'DSTEIN', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL DSTEIN( 0, D, E, 1, X, I1, I2, Z, 1, W, IW, I3, INFO )
+ CALL CHKXER( 'DSTEIN', INFOT, NOUT, LERR, OK )
+ INFOT = 9
+ CALL DSTEIN( 2, D, E, 0, X, I1, I2, Z, 1, W, IW, I3, INFO )
+ CALL CHKXER( 'DSTEIN', INFOT, NOUT, LERR, OK )
+ NT = NT + 4
+*
+* DSTEQR
+*
+ SRNAMT = 'DSTEQR'
+ INFOT = 1
+ CALL DSTEQR( '/', 0, D, E, Z, 1, W, INFO )
+ CALL CHKXER( 'DSTEQR', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL DSTEQR( 'N', -1, D, E, Z, 1, W, INFO )
+ CALL CHKXER( 'DSTEQR', INFOT, NOUT, LERR, OK )
+ INFOT = 6
+ CALL DSTEQR( 'V', 2, D, E, Z, 1, W, INFO )
+ CALL CHKXER( 'DSTEQR', INFOT, NOUT, LERR, OK )
+ NT = NT + 3
+*
+* DSTERF
+*
+ SRNAMT = 'DSTERF'
+ INFOT = 1
+ CALL DSTERF( -1, D, E, INFO )
+ CALL CHKXER( 'DSTERF', INFOT, NOUT, LERR, OK )
+ NT = NT + 1
+*
+* DSTEDC
+*
+ SRNAMT = 'DSTEDC'
+ INFOT = 1
+ CALL DSTEDC( '/', 0, D, E, Z, 1, W, 1, IW, 1, INFO )
+ CALL CHKXER( 'DSTEDC', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL DSTEDC( 'N', -1, D, E, Z, 1, W, 1, IW, 1, INFO )
+ CALL CHKXER( 'DSTEDC', INFOT, NOUT, LERR, OK )
+ INFOT = 6
+ CALL DSTEDC( 'V', 2, D, E, Z, 1, W, 23, IW, 28, INFO )
+ CALL CHKXER( 'DSTEDC', INFOT, NOUT, LERR, OK )
+ INFOT = 8
+ CALL DSTEDC( 'N', 1, D, E, Z, 1, W, 0, IW, 1, INFO )
+ CALL CHKXER( 'DSTEDC', INFOT, NOUT, LERR, OK )
+ INFOT = 8
+ CALL DSTEDC( 'I', 2, D, E, Z, 2, W, 0, IW, 12, INFO )
+ CALL CHKXER( 'DSTEDC', INFOT, NOUT, LERR, OK )
+ INFOT = 8
+ CALL DSTEDC( 'V', 2, D, E, Z, 2, W, 0, IW, 28, INFO )
+ CALL CHKXER( 'DSTEDC', INFOT, NOUT, LERR, OK )
+ INFOT = 10
+ CALL DSTEDC( 'N', 1, D, E, Z, 1, W, 1, IW, 0, INFO )
+ CALL CHKXER( 'DSTEDC', INFOT, NOUT, LERR, OK )
+ INFOT = 10
+ CALL DSTEDC( 'I', 2, D, E, Z, 2, W, 19, IW, 0, INFO )
+ CALL CHKXER( 'DSTEDC', INFOT, NOUT, LERR, OK )
+ INFOT = 10
+ CALL DSTEDC( 'V', 2, D, E, Z, 2, W, 23, IW, 0, INFO )
+ CALL CHKXER( 'DSTEDC', INFOT, NOUT, LERR, OK )
+ NT = NT + 9
+*
+* DSTEVD
+*
+ SRNAMT = 'DSTEVD'
+ INFOT = 1
+ CALL DSTEVD( '/', 0, D, E, Z, 1, W, 1, IW, 1, INFO )
+ CALL CHKXER( 'DSTEVD', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL DSTEVD( 'N', -1, D, E, Z, 1, W, 1, IW, 1, INFO )
+ CALL CHKXER( 'DSTEVD', INFOT, NOUT, LERR, OK )
+ INFOT = 6
+ CALL DSTEVD( 'V', 2, D, E, Z, 1, W, 19, IW, 12, INFO )
+ CALL CHKXER( 'DSTEVD', INFOT, NOUT, LERR, OK )
+ INFOT = 8
+ CALL DSTEVD( 'N', 1, D, E, Z, 1, W, 0, IW, 1, INFO )
+ CALL CHKXER( 'DSTEVD', INFOT, NOUT, LERR, OK )
+ INFOT = 8
+ CALL DSTEVD( 'V', 2, D, E, Z, 2, W, 12, IW, 12, INFO )
+ CALL CHKXER( 'DSTEVD', INFOT, NOUT, LERR, OK )
+ INFOT = 10
+ CALL DSTEVD( 'N', 0, D, E, Z, 1, W, 1, IW, 0, INFO )
+ CALL CHKXER( 'DSTEVD', INFOT, NOUT, LERR, OK )
+ INFOT = 10
+ CALL DSTEVD( 'V', 2, D, E, Z, 2, W, 19, IW, 11, INFO )
+ CALL CHKXER( 'DSTEVD', INFOT, NOUT, LERR, OK )
+ NT = NT + 7
+*
+* DSTEV
+*
+ SRNAMT = 'DSTEV '
+ INFOT = 1
+ CALL DSTEV( '/', 0, D, E, Z, 1, W, INFO )
+ CALL CHKXER( 'DSTEV ', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL DSTEV( 'N', -1, D, E, Z, 1, W, INFO )
+ CALL CHKXER( 'DSTEV ', INFOT, NOUT, LERR, OK )
+ INFOT = 6
+ CALL DSTEV( 'V', 2, D, E, Z, 1, W, INFO )
+ CALL CHKXER( 'DSTEV ', INFOT, NOUT, LERR, OK )
+ NT = NT + 3
+*
+* DSTEVX
+*
+ SRNAMT = 'DSTEVX'
+ INFOT = 1
+ CALL DSTEVX( '/', 'A', 0, D, E, 0.0D0, 0.0D0, 0, 0, 0.0D0, M,
+ $ X, Z, 1, W, IW, I3, INFO )
+ CALL CHKXER( 'DSTEVX', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL DSTEVX( 'N', '/', 0, D, E, 0.0D0, 1.0D0, 1, 0, 0.0D0, M,
+ $ X, Z, 1, W, IW, I3, INFO )
+ CALL CHKXER( 'DSTEVX', INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL DSTEVX( 'N', 'A', -1, D, E, 0.0D0, 0.0D0, 0, 0, 0.0D0, M,
+ $ X, Z, 1, W, IW, I3, INFO )
+ CALL CHKXER( 'DSTEVX', INFOT, NOUT, LERR, OK )
+ INFOT = 7
+ CALL DSTEVX( 'N', 'V', 1, D, E, 0.0D0, 0.0D0, 0, 0, 0.0D0, M,
+ $ X, Z, 1, W, IW, I3, INFO )
+ CALL CHKXER( 'DSTEVX', INFOT, NOUT, LERR, OK )
+ INFOT = 8
+ CALL DSTEVX( 'N', 'I', 1, D, E, 0.0D0, 0.0D0, 0, 0, 0.0D0, M,
+ $ X, Z, 1, W, IW, I3, INFO )
+ CALL CHKXER( 'DSTEVX', INFOT, NOUT, LERR, OK )
+ INFOT = 8
+ CALL DSTEVX( 'N', 'I', 1, D, E, 0.0D0, 0.0D0, 2, 1, 0.0D0, M,
+ $ X, Z, 1, W, IW, I3, INFO )
+ CALL CHKXER( 'DSTEVX', INFOT, NOUT, LERR, OK )
+ INFOT = 9
+ CALL DSTEVX( 'N', 'I', 2, D, E, 0.0D0, 0.0D0, 2, 1, 0.0D0, M,
+ $ X, Z, 1, W, IW, I3, INFO )
+ CALL CHKXER( 'DSTEVX', INFOT, NOUT, LERR, OK )
+ INFOT = 9
+ CALL DSTEVX( 'N', 'I', 1, D, E, 0.0D0, 0.0D0, 1, 2, 0.0D0, M,
+ $ X, Z, 1, W, IW, I3, INFO )
+ CALL CHKXER( 'DSTEVX', INFOT, NOUT, LERR, OK )
+ INFOT = 14
+ CALL DSTEVX( 'V', 'A', 2, D, E, 0.0D0, 0.0D0, 0, 0, 0.0D0, M,
+ $ X, Z, 1, W, IW, I3, INFO )
+ CALL CHKXER( 'DSTEVX', INFOT, NOUT, LERR, OK )
+ NT = NT + 9
+*
+* DSTEVR
+*
+ N = 1
+ SRNAMT = 'DSTEVR'
+ INFOT = 1
+ CALL DSTEVR( '/', 'A', 0, D, E, 0.0D0, 0.0D0, 1, 1, 0.0D0, M,
+ $ R, Z, 1, IW, X, 20*N, IW( 2*N+1 ), 10*N, INFO )
+ CALL CHKXER( 'DSTEVR', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL DSTEVR( 'V', '/', 0, D, E, 0.0D0, 0.0D0, 1, 1, 0.0D0, M,
+ $ R, Z, 1, IW, X, 20*N, IW( 2*N+1 ), 10*N, INFO )
+ CALL CHKXER( 'DSTEVR', INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL DSTEVR( 'V', 'A', -1, D, E, 0.0D0, 0.0D0, 1, 1, 0.0D0, M,
+ $ R, Z, 1, IW, X, 20*N, IW( 2*N+1 ), 10*N, INFO )
+ CALL CHKXER( 'DSTEVR', INFOT, NOUT, LERR, OK )
+ INFOT = 7
+ CALL DSTEVR( 'V', 'V', 1, D, E, 0.0D0, 0.0D0, 1, 1, 0.0D0, M,
+ $ R, Z, 1, IW, X, 20*N, IW( 2*N+1 ), 10*N, INFO )
+ CALL CHKXER( 'DSTEVR', INFOT, NOUT, LERR, OK )
+ INFOT = 8
+ CALL DSTEVR( 'V', 'I', 1, D, E, 0.0D0, 0.0D0, 0, 1, 0.0D0, M,
+ $ W, Z, 1, IW, X, 20*N, IW( 2*N+1 ), 10*N, INFO )
+ CALL CHKXER( 'DSTEVR', INFOT, NOUT, LERR, OK )
+ INFOT = 9
+ N = 2
+ CALL DSTEVR( 'V', 'I', 2, D, E, 0.0D0, 0.0D0, 2, 1, 0.0D0, M,
+ $ W, Z, 1, IW, X, 20*N, IW( 2*N+1 ), 10*N, INFO )
+ CALL CHKXER( 'DSTEVR', INFOT, NOUT, LERR, OK )
+ INFOT = 14
+ N = 1
+ CALL DSTEVR( 'V', 'I', 1, D, E, 0.0D0, 0.0D0, 1, 1, 0.0D0, M,
+ $ W, Z, 0, IW, X, 20*N, IW( 2*N+1 ), 10*N, INFO )
+ CALL CHKXER( 'DSTEVR', INFOT, NOUT, LERR, OK )
+ INFOT = 17
+ CALL DSTEVR( 'V', 'I', 1, D, E, 0.0D0, 0.0D0, 1, 1, 0.0D0, M,
+ $ W, Z, 1, IW, X, 20*N-1, IW( 2*N+1 ), 10*N, INFO )
+ CALL CHKXER( 'DSTEVR', INFOT, NOUT, LERR, OK )
+ INFOT = 19
+ CALL DSTEVR( 'V', 'I', 1, D, E, 0.0D0, 0.0D0, 1, 1, 0.0D0, M,
+ $ W, Z, 1, IW, X, 20*N, IW( 2*N+1 ), 10*N-1, INFO )
+ CALL CHKXER( 'DSTEVR', INFOT, NOUT, LERR, OK )
+ NT = NT + 9
+*
+* DSYEVD
+*
+ SRNAMT = 'DSYEVD'
+ INFOT = 1
+ CALL DSYEVD( '/', 'U', 0, A, 1, X, W, 1, IW, 1, INFO )
+ CALL CHKXER( 'DSYEVD', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL DSYEVD( 'N', '/', 0, A, 1, X, W, 1, IW, 1, INFO )
+ CALL CHKXER( 'DSYEVD', INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL DSYEVD( 'N', 'U', -1, A, 1, X, W, 1, IW, 1, INFO )
+ CALL CHKXER( 'DSYEVD', INFOT, NOUT, LERR, OK )
+ INFOT = 5
+ CALL DSYEVD( 'N', 'U', 2, A, 1, X, W, 3, IW, 1, INFO )
+ CALL CHKXER( 'DSYEVD', INFOT, NOUT, LERR, OK )
+ INFOT = 8
+ CALL DSYEVD( 'N', 'U', 1, A, 1, X, W, 0, IW, 1, INFO )
+ CALL CHKXER( 'DSYEVD', INFOT, NOUT, LERR, OK )
+ INFOT = 8
+ CALL DSYEVD( 'N', 'U', 2, A, 2, X, W, 4, IW, 1, INFO )
+ CALL CHKXER( 'DSYEVD', INFOT, NOUT, LERR, OK )
+ INFOT = 8
+ CALL DSYEVD( 'V', 'U', 2, A, 2, X, W, 20, IW, 12, INFO )
+ CALL CHKXER( 'DSYEVD', INFOT, NOUT, LERR, OK )
+ INFOT = 10
+ CALL DSYEVD( 'N', 'U', 1, A, 1, X, W, 1, IW, 0, INFO )
+ CALL CHKXER( 'DSYEVD', INFOT, NOUT, LERR, OK )
+ INFOT = 10
+ CALL DSYEVD( 'N', 'U', 2, A, 2, X, W, 5, IW, 0, INFO )
+ CALL CHKXER( 'DSYEVD', INFOT, NOUT, LERR, OK )
+ INFOT = 10
+ CALL DSYEVD( 'V', 'U', 2, A, 2, X, W, 27, IW, 11, INFO )
+ CALL CHKXER( 'DSYEVD', INFOT, NOUT, LERR, OK )
+ NT = NT + 10
+*
+* DSYEVR
+*
+ SRNAMT = 'DSYEVR'
+ N = 1
+ INFOT = 1
+ CALL DSYEVR( '/', 'A', 'U', 0, A, 1, 0.0D0, 0.0D0, 1, 1, 0.0D0,
+ $ M, R, Z, 1, IW, Q, 26*N, IW( 2*N+1 ), 10*N, INFO )
+ CALL CHKXER( 'DSYEVR', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL DSYEVR( 'V', '/', 'U', 0, A, 1, 0.0D0, 0.0D0, 1, 1, 0.0D0,
+ $ M, R, Z, 1, IW, Q, 26*N, IW( 2*N+1 ), 10*N, INFO )
+ CALL CHKXER( 'DSYEVR', INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL DSYEVR( 'V', 'A', '/', -1, A, 1, 0.0D0, 0.0D0, 1, 1,
+ $ 0.0D0, M, R, Z, 1, IW, Q, 26*N, IW( 2*N+1 ), 10*N,
+ $ INFO )
+ CALL CHKXER( 'DSYEVR', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL DSYEVR( 'V', 'A', 'U', -1, A, 1, 0.0D0, 0.0D0, 1, 1,
+ $ 0.0D0, M, R, Z, 1, IW, Q, 26*N, IW( 2*N+1 ), 10*N,
+ $ INFO )
+ CALL CHKXER( 'DSYEVR', INFOT, NOUT, LERR, OK )
+ INFOT = 6
+ CALL DSYEVR( 'V', 'A', 'U', 2, A, 1, 0.0D0, 0.0D0, 1, 1, 0.0D0,
+ $ M, R, Z, 1, IW, Q, 26*N, IW( 2*N+1 ), 10*N, INFO )
+ CALL CHKXER( 'DSYEVR', INFOT, NOUT, LERR, OK )
+ INFOT = 8
+ CALL DSYEVR( 'V', 'V', 'U', 1, A, 1, 0.0D0, 0.0D0, 1, 1, 0.0D0,
+ $ M, R, Z, 1, IW, Q, 26*N, IW( 2*N+1 ), 10*N, INFO )
+ CALL CHKXER( 'DSYEVR', INFOT, NOUT, LERR, OK )
+ INFOT = 9
+ CALL DSYEVR( 'V', 'I', 'U', 1, A, 1, 0.0D0, 0.0D0, 0, 1, 0.0D0,
+ $ M, R, Z, 1, IW, Q, 26*N, IW( 2*N+1 ), 10*N, INFO )
+ CALL CHKXER( 'DSYEVR', INFOT, NOUT, LERR, OK )
+ INFOT = 10
+*
+ CALL DSYEVR( 'V', 'I', 'U', 2, A, 2, 0.0D0, 0.0D0, 2, 1, 0.0D0,
+ $ M, R, Z, 1, IW, Q, 26*N, IW( 2*N+1 ), 10*N, INFO )
+ CALL CHKXER( 'DSYEVR', INFOT, NOUT, LERR, OK )
+ INFOT = 15
+ CALL DSYEVR( 'V', 'I', 'U', 1, A, 1, 0.0D0, 0.0D0, 1, 1, 0.0D0,
+ $ M, R, Z, 0, IW, Q, 26*N, IW( 2*N+1 ), 10*N, INFO )
+ CALL CHKXER( 'DSYEVR', INFOT, NOUT, LERR, OK )
+ INFOT = 18
+ CALL DSYEVR( 'V', 'I', 'U', 1, A, 1, 0.0D0, 0.0D0, 1, 1, 0.0D0,
+ $ M, R, Z, 1, IW, Q, 26*N-1, IW( 2*N+1 ), 10*N,
+ $ INFO )
+ CALL CHKXER( 'DSYEVR', INFOT, NOUT, LERR, OK )
+ INFOT = 20
+ CALL DSYEVR( 'V', 'I', 'U', 1, A, 1, 0.0D0, 0.0D0, 1, 1, 0.0D0,
+ $ M, R, Z, 1, IW, Q, 26*N, IW( 2*N+1 ), 10*N-1,
+ $ INFO )
+ CALL CHKXER( 'DSYEVR', INFOT, NOUT, LERR, OK )
+ NT = NT + 11
+*
+* DSYEV
+*
+ SRNAMT = 'DSYEV '
+ INFOT = 1
+ CALL DSYEV( '/', 'U', 0, A, 1, X, W, 1, INFO )
+ CALL CHKXER( 'DSYEV ', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL DSYEV( 'N', '/', 0, A, 1, X, W, 1, INFO )
+ CALL CHKXER( 'DSYEV ', INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL DSYEV( 'N', 'U', -1, A, 1, X, W, 1, INFO )
+ CALL CHKXER( 'DSYEV ', INFOT, NOUT, LERR, OK )
+ INFOT = 5
+ CALL DSYEV( 'N', 'U', 2, A, 1, X, W, 3, INFO )
+ CALL CHKXER( 'DSYEV ', INFOT, NOUT, LERR, OK )
+ INFOT = 8
+ CALL DSYEV( 'N', 'U', 1, A, 1, X, W, 1, INFO )
+ CALL CHKXER( 'DSYEV ', INFOT, NOUT, LERR, OK )
+ NT = NT + 5
+*
+* DSYEVX
+*
+ SRNAMT = 'DSYEVX'
+ INFOT = 1
+ CALL DSYEVX( '/', 'A', 'U', 0, A, 1, 0.0D0, 0.0D0, 0, 0, 0.0D0,
+ $ M, X, Z, 1, W, 1, IW, I3, INFO )
+ CALL CHKXER( 'DSYEVX', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL DSYEVX( 'N', '/', 'U', 0, A, 1, 0.0D0, 1.0D0, 1, 0, 0.0D0,
+ $ M, X, Z, 1, W, 1, IW, I3, INFO )
+ CALL CHKXER( 'DSYEVX', INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL DSYEVX( 'N', 'A', '/', 0, A, 1, 0.0D0, 0.0D0, 0, 0, 0.0D0,
+ $ M, X, Z, 1, W, 1, IW, I3, INFO )
+ INFOT = 4
+ CALL DSYEVX( 'N', 'A', 'U', -1, A, 1, 0.0D0, 0.0D0, 0, 0,
+ $ 0.0D0, M, X, Z, 1, W, 1, IW, I3, INFO )
+ CALL CHKXER( 'DSYEVX', INFOT, NOUT, LERR, OK )
+ INFOT = 6
+ CALL DSYEVX( 'N', 'A', 'U', 2, A, 1, 0.0D0, 0.0D0, 0, 0, 0.0D0,
+ $ M, X, Z, 1, W, 16, IW, I3, INFO )
+ CALL CHKXER( 'DSYEVX', INFOT, NOUT, LERR, OK )
+ INFOT = 8
+ CALL DSYEVX( 'N', 'V', 'U', 1, A, 1, 0.0D0, 0.0D0, 0, 0, 0.0D0,
+ $ M, X, Z, 1, W, 8, IW, I3, INFO )
+ CALL CHKXER( 'DSYEVX', INFOT, NOUT, LERR, OK )
+ INFOT = 9
+ CALL DSYEVX( 'N', 'I', 'U', 1, A, 1, 0.0D0, 0.0D0, 0, 0, 0.0D0,
+ $ M, X, Z, 1, W, 8, IW, I3, INFO )
+ CALL CHKXER( 'DSYEVX', INFOT, NOUT, LERR, OK )
+ INFOT = 9
+ CALL DSYEVX( 'N', 'I', 'U', 1, A, 1, 0.0D0, 0.0D0, 2, 1, 0.0D0,
+ $ M, X, Z, 1, W, 8, IW, I3, INFO )
+ CALL CHKXER( 'DSYEVX', INFOT, NOUT, LERR, OK )
+ INFOT = 10
+ CALL DSYEVX( 'N', 'I', 'U', 2, A, 2, 0.0D0, 0.0D0, 2, 1, 0.0D0,
+ $ M, X, Z, 1, W, 16, IW, I3, INFO )
+ CALL CHKXER( 'DSYEVX', INFOT, NOUT, LERR, OK )
+ INFOT = 10
+ CALL DSYEVX( 'N', 'I', 'U', 1, A, 1, 0.0D0, 0.0D0, 1, 2, 0.0D0,
+ $ M, X, Z, 1, W, 8, IW, I3, INFO )
+ CALL CHKXER( 'DSYEVX', INFOT, NOUT, LERR, OK )
+ INFOT = 15
+ CALL DSYEVX( 'V', 'A', 'U', 2, A, 2, 0.0D0, 0.0D0, 0, 0, 0.0D0,
+ $ M, X, Z, 1, W, 16, IW, I3, INFO )
+ CALL CHKXER( 'DSYEVX', INFOT, NOUT, LERR, OK )
+ INFOT = 17
+ CALL DSYEVX( 'V', 'A', 'U', 1, A, 1, 0.0D0, 0.0D0, 0, 0, 0.0D0,
+ $ M, X, Z, 1, W, 0, IW, I3, INFO )
+ CALL CHKXER( 'DSYEVX', INFOT, NOUT, LERR, OK )
+ NT = NT + 12
+*
+* DSPEVD
+*
+ SRNAMT = 'DSPEVD'
+ INFOT = 1
+ CALL DSPEVD( '/', 'U', 0, A, X, Z, 1, W, 1, IW, 1, INFO )
+ CALL CHKXER( 'DSPEVD', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL DSPEVD( 'N', '/', 0, A, X, Z, 1, W, 1, IW, 1, INFO )
+ CALL CHKXER( 'DSPEVD', INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL DSPEVD( 'N', 'U', -1, A, X, Z, 1, W, 1, IW, 1, INFO )
+ CALL CHKXER( 'DSPEVD', INFOT, NOUT, LERR, OK )
+ INFOT = 7
+ CALL DSPEVD( 'V', 'U', 2, A, X, Z, 1, W, 23, IW, 12, INFO )
+ CALL CHKXER( 'DSPEVD', INFOT, NOUT, LERR, OK )
+ INFOT = 9
+ CALL DSPEVD( 'N', 'U', 1, A, X, Z, 1, W, 0, IW, 1, INFO )
+ CALL CHKXER( 'DSPEVD', INFOT, NOUT, LERR, OK )
+ INFOT = 9
+ CALL DSPEVD( 'N', 'U', 2, A, X, Z, 1, W, 3, IW, 1, INFO )
+ CALL CHKXER( 'DSPEVD', INFOT, NOUT, LERR, OK )
+ INFOT = 9
+ CALL DSPEVD( 'V', 'U', 2, A, X, Z, 2, W, 16, IW, 12, INFO )
+ CALL CHKXER( 'DSPEVD', INFOT, NOUT, LERR, OK )
+ INFOT = 11
+ CALL DSPEVD( 'N', 'U', 1, A, X, Z, 1, W, 1, IW, 0, INFO )
+ CALL CHKXER( 'DSPEVD', INFOT, NOUT, LERR, OK )
+ INFOT = 11
+ CALL DSPEVD( 'N', 'U', 2, A, X, Z, 1, W, 4, IW, 0, INFO )
+ CALL CHKXER( 'DSPEVD', INFOT, NOUT, LERR, OK )
+ INFOT = 11
+ CALL DSPEVD( 'V', 'U', 2, A, X, Z, 2, W, 23, IW, 11, INFO )
+ CALL CHKXER( 'DSPEVD', INFOT, NOUT, LERR, OK )
+ NT = NT + 10
+*
+* DSPEV
+*
+ SRNAMT = 'DSPEV '
+ INFOT = 1
+ CALL DSPEV( '/', 'U', 0, A, W, Z, 1, X, INFO )
+ CALL CHKXER( 'DSPEV ', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL DSPEV( 'N', '/', 0, A, W, Z, 1, X, INFO )
+ CALL CHKXER( 'DSPEV ', INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL DSPEV( 'N', 'U', -1, A, W, Z, 1, X, INFO )
+ CALL CHKXER( 'DSPEV ', INFOT, NOUT, LERR, OK )
+ INFOT = 7
+ CALL DSPEV( 'V', 'U', 2, A, W, Z, 1, X, INFO )
+ CALL CHKXER( 'DSPEV ', INFOT, NOUT, LERR, OK )
+ NT = NT + 4
+*
+* DSPEVX
+*
+ SRNAMT = 'DSPEVX'
+ INFOT = 1
+ CALL DSPEVX( '/', 'A', 'U', 0, A, 0.0D0, 0.0D0, 0, 0, 0.0D0, M,
+ $ X, Z, 1, W, IW, I3, INFO )
+ CALL CHKXER( 'DSPEVX', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL DSPEVX( 'N', '/', 'U', 0, A, 0.0D0, 0.0D0, 0, 0, 0.0D0, M,
+ $ X, Z, 1, W, IW, I3, INFO )
+ CALL CHKXER( 'DSPEVX', INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL DSPEVX( 'N', 'A', '/', 0, A, 0.0D0, 0.0D0, 0, 0, 0.0D0, M,
+ $ X, Z, 1, W, IW, I3, INFO )
+ INFOT = 4
+ CALL DSPEVX( 'N', 'A', 'U', -1, A, 0.0D0, 0.0D0, 0, 0, 0.0D0,
+ $ M, X, Z, 1, W, IW, I3, INFO )
+ CALL CHKXER( 'DSPEVX', INFOT, NOUT, LERR, OK )
+ INFOT = 7
+ CALL DSPEVX( 'N', 'V', 'U', 1, A, 0.0D0, 0.0D0, 0, 0, 0.0D0, M,
+ $ X, Z, 1, W, IW, I3, INFO )
+ CALL CHKXER( 'DSPEVX', INFOT, NOUT, LERR, OK )
+ INFOT = 8
+ CALL DSPEVX( 'N', 'I', 'U', 1, A, 0.0D0, 0.0D0, 0, 0, 0.0D0, M,
+ $ X, Z, 1, W, IW, I3, INFO )
+ CALL CHKXER( 'DSPEVX', INFOT, NOUT, LERR, OK )
+ INFOT = 8
+ CALL DSPEVX( 'N', 'I', 'U', 1, A, 0.0D0, 0.0D0, 2, 1, 0.0D0, M,
+ $ X, Z, 1, W, IW, I3, INFO )
+ CALL CHKXER( 'DSPEVX', INFOT, NOUT, LERR, OK )
+ INFOT = 9
+ CALL DSPEVX( 'N', 'I', 'U', 2, A, 0.0D0, 0.0D0, 2, 1, 0.0D0, M,
+ $ X, Z, 1, W, IW, I3, INFO )
+ CALL CHKXER( 'DSPEVX', INFOT, NOUT, LERR, OK )
+ INFOT = 9
+ CALL DSPEVX( 'N', 'I', 'U', 1, A, 0.0D0, 0.0D0, 1, 2, 0.0D0, M,
+ $ X, Z, 1, W, IW, I3, INFO )
+ CALL CHKXER( 'DSPEVX', INFOT, NOUT, LERR, OK )
+ INFOT = 14
+ CALL DSPEVX( 'V', 'A', 'U', 2, A, 0.0D0, 0.0D0, 0, 0, 0.0D0, M,
+ $ X, Z, 1, W, IW, I3, INFO )
+ CALL CHKXER( 'DSPEVX', INFOT, NOUT, LERR, OK )
+ NT = NT + 10
+*
+* Test error exits for the SB path.
+*
+ ELSE IF( LSAMEN( 2, C2, 'SB' ) ) THEN
+*
+* DSBTRD
+*
+ SRNAMT = 'DSBTRD'
+ INFOT = 1
+ CALL DSBTRD( '/', 'U', 0, 0, A, 1, D, E, Z, 1, W, INFO )
+ CALL CHKXER( 'DSBTRD', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL DSBTRD( 'N', '/', 0, 0, A, 1, D, E, Z, 1, W, INFO )
+ CALL CHKXER( 'DSBTRD', INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL DSBTRD( 'N', 'U', -1, 0, A, 1, D, E, Z, 1, W, INFO )
+ CALL CHKXER( 'DSBTRD', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL DSBTRD( 'N', 'U', 0, -1, A, 1, D, E, Z, 1, W, INFO )
+ CALL CHKXER( 'DSBTRD', INFOT, NOUT, LERR, OK )
+ INFOT = 6
+ CALL DSBTRD( 'N', 'U', 1, 1, A, 1, D, E, Z, 1, W, INFO )
+ CALL CHKXER( 'DSBTRD', INFOT, NOUT, LERR, OK )
+ INFOT = 10
+ CALL DSBTRD( 'V', 'U', 2, 0, A, 1, D, E, Z, 1, W, INFO )
+ CALL CHKXER( 'DSBTRD', INFOT, NOUT, LERR, OK )
+ NT = NT + 6
+*
+* DSBEVD
+*
+ SRNAMT = 'DSBEVD'
+ INFOT = 1
+ CALL DSBEVD( '/', 'U', 0, 0, A, 1, X, Z, 1, W, 1, IW, 1, INFO )
+ CALL CHKXER( 'DSBEVD', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL DSBEVD( 'N', '/', 0, 0, A, 1, X, Z, 1, W, 1, IW, 1, INFO )
+ CALL CHKXER( 'DSBEVD', INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL DSBEVD( 'N', 'U', -1, 0, A, 1, X, Z, 1, W, 1, IW, 1,
+ $ INFO )
+ CALL CHKXER( 'DSBEVD', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL DSBEVD( 'N', 'U', 0, -1, A, 1, X, Z, 1, W, 1, IW, 1,
+ $ INFO )
+ CALL CHKXER( 'DSBEVD', INFOT, NOUT, LERR, OK )
+ INFOT = 6
+ CALL DSBEVD( 'N', 'U', 2, 1, A, 1, X, Z, 1, W, 4, IW, 1, INFO )
+ CALL CHKXER( 'DSBEVD', INFOT, NOUT, LERR, OK )
+ INFOT = 9
+ CALL DSBEVD( 'V', 'U', 2, 1, A, 2, X, Z, 1, W, 25, IW, 12,
+ $ INFO )
+ CALL CHKXER( 'DSBEVD', INFOT, NOUT, LERR, OK )
+ INFOT = 11
+ CALL DSBEVD( 'N', 'U', 1, 0, A, 1, X, Z, 1, W, 0, IW, 1, INFO )
+ CALL CHKXER( 'DSBEVD', INFOT, NOUT, LERR, OK )
+ INFOT = 11
+ CALL DSBEVD( 'N', 'U', 2, 0, A, 1, X, Z, 1, W, 3, IW, 1, INFO )
+ CALL CHKXER( 'DSBEVD', INFOT, NOUT, LERR, OK )
+ INFOT = 11
+ CALL DSBEVD( 'V', 'U', 2, 0, A, 1, X, Z, 2, W, 18, IW, 12,
+ $ INFO )
+ CALL CHKXER( 'DSBEVD', INFOT, NOUT, LERR, OK )
+ INFOT = 13
+ CALL DSBEVD( 'N', 'U', 1, 0, A, 1, X, Z, 1, W, 1, IW, 0, INFO )
+ CALL CHKXER( 'DSBEVD', INFOT, NOUT, LERR, OK )
+ INFOT = 13
+ CALL DSBEVD( 'V', 'U', 2, 0, A, 1, X, Z, 2, W, 25, IW, 11,
+ $ INFO )
+ CALL CHKXER( 'DSBEVD', INFOT, NOUT, LERR, OK )
+ NT = NT + 11
+*
+* DSBEV
+*
+ SRNAMT = 'DSBEV '
+ INFOT = 1
+ CALL DSBEV( '/', 'U', 0, 0, A, 1, X, Z, 1, W, INFO )
+ CALL CHKXER( 'DSBEV ', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL DSBEV( 'N', '/', 0, 0, A, 1, X, Z, 1, W, INFO )
+ CALL CHKXER( 'DSBEV ', INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL DSBEV( 'N', 'U', -1, 0, A, 1, X, Z, 1, W, INFO )
+ CALL CHKXER( 'DSBEV ', INFOT, NOUT, LERR, OK )
+ INFOT = 4
+ CALL DSBEV( 'N', 'U', 0, -1, A, 1, X, Z, 1, W, INFO )
+ CALL CHKXER( 'DSBEV ', INFOT, NOUT, LERR, OK )
+ INFOT = 6
+ CALL DSBEV( 'N', 'U', 2, 1, A, 1, X, Z, 1, W, INFO )
+ CALL CHKXER( 'DSBEV ', INFOT, NOUT, LERR, OK )
+ INFOT = 9
+ CALL DSBEV( 'V', 'U', 2, 0, A, 1, X, Z, 1, W, INFO )
+ CALL CHKXER( 'DSBEV ', INFOT, NOUT, LERR, OK )
+ NT = NT + 6
+*
+* DSBEVX
+*
+ SRNAMT = 'DSBEVX'
+ INFOT = 1
+ CALL DSBEVX( '/', 'A', 'U', 0, 0, A, 1, Q, 1, 0.0D0, 0.0D0, 0,
+ $ 0, 0.0D0, M, X, Z, 1, W, IW, I3, INFO )
+ CALL CHKXER( 'DSBEVX', INFOT, NOUT, LERR, OK )
+ INFOT = 2
+ CALL DSBEVX( 'N', '/', 'U', 0, 0, A, 1, Q, 1, 0.0D0, 0.0D0, 0,
+ $ 0, 0.0D0, M, X, Z, 1, W, IW, I3, INFO )
+ CALL CHKXER( 'DSBEVX', INFOT, NOUT, LERR, OK )
+ INFOT = 3
+ CALL DSBEVX( 'N', 'A', '/', 0, 0, A, 1, Q, 1, 0.0D0, 0.0D0, 0,
+ $ 0, 0.0D0, M, X, Z, 1, W, IW, I3, INFO )
+ INFOT = 4
+ CALL DSBEVX( 'N', 'A', 'U', -1, 0, A, 1, Q, 1, 0.0D0, 0.0D0, 0,
+ $ 0, 0.0D0, M, X, Z, 1, W, IW, I3, INFO )
+ CALL CHKXER( 'DSBEVX', INFOT, NOUT, LERR, OK )
+ INFOT = 5
+ CALL DSBEVX( 'N', 'A', 'U', 0, -1, A, 1, Q, 1, 0.0D0, 0.0D0, 0,
+ $ 0, 0.0D0, M, X, Z, 1, W, IW, I3, INFO )
+ CALL CHKXER( 'DSBEVX', INFOT, NOUT, LERR, OK )
+ INFOT = 7
+ CALL DSBEVX( 'N', 'A', 'U', 2, 1, A, 1, Q, 1, 0.0D0, 0.0D0, 0,
+ $ 0, 0.0D0, M, X, Z, 1, W, IW, I3, INFO )
+ CALL CHKXER( 'DSBEVX', INFOT, NOUT, LERR, OK )
+ INFOT = 9
+ CALL DSBEVX( 'V', 'A', 'U', 2, 0, A, 1, Q, 1, 0.0D0, 0.0D0, 0,
+ $ 0, 0.0D0, M, X, Z, 2, W, IW, I3, INFO )
+ CALL CHKXER( 'DSBEVX', INFOT, NOUT, LERR, OK )
+ INFOT = 11
+ CALL DSBEVX( 'N', 'V', 'U', 1, 0, A, 1, Q, 1, 0.0D0, 0.0D0, 0,
+ $ 0, 0.0D0, M, X, Z, 1, W, IW, I3, INFO )
+ CALL CHKXER( 'DSBEVX', INFOT, NOUT, LERR, OK )
+ INFOT = 12
+ CALL DSBEVX( 'N', 'I', 'U', 1, 0, A, 1, Q, 1, 0.0D0, 0.0D0, 0,
+ $ 0, 0.0D0, M, X, Z, 1, W, IW, I3, INFO )
+ CALL CHKXER( 'DSBEVX', INFOT, NOUT, LERR, OK )
+ INFOT = 12
+ CALL DSBEVX( 'N', 'I', 'U', 1, 0, A, 1, Q, 1, 0.0D0, 0.0D0, 2,
+ $ 1, 0.0D0, M, X, Z, 1, W, IW, I3, INFO )
+ CALL CHKXER( 'DSBEVX', INFOT, NOUT, LERR, OK )
+ INFOT = 13
+ CALL DSBEVX( 'N', 'I', 'U', 2, 0, A, 1, Q, 1, 0.0D0, 0.0D0, 2,
+ $ 1, 0.0D0, M, X, Z, 1, W, IW, I3, INFO )
+ CALL CHKXER( 'DSBEVX', INFOT, NOUT, LERR, OK )
+ INFOT = 13
+ CALL DSBEVX( 'N', 'I', 'U', 1, 0, A, 1, Q, 1, 0.0D0, 0.0D0, 1,
+ $ 2, 0.0D0, M, X, Z, 1, W, IW, I3, INFO )
+ CALL CHKXER( 'DSBEVX', INFOT, NOUT, LERR, OK )
+ INFOT = 18
+ CALL DSBEVX( 'V', 'A', 'U', 2, 0, A, 1, Q, 2, 0.0D0, 0.0D0, 0,
+ $ 0, 0.0D0, M, X, Z, 1, W, IW, I3, INFO )
+ CALL CHKXER( 'DSBEVX', INFOT, NOUT, LERR, OK )
+ NT = NT + 13
+ END IF
+*
+* Print a summary line.
+*
+ IF( OK ) THEN
+ WRITE( NOUT, FMT = 9999 )PATH, NT
+ ELSE
+ WRITE( NOUT, FMT = 9998 )PATH
+ END IF
+*
+ 9999 FORMAT( 1X, A3, ' routines passed the tests of the error exits',
+ $ ' (', I3, ' tests done)' )
+ 9998 FORMAT( ' *** ', A3, ' routines failed the tests of the error ',
+ $ 'exits ***' )
+*
+ RETURN
+*
+* End of DERRST
+*
+ END
+ SUBROUTINE DGET02( TRANS, M, N, NRHS, A, LDA, X, LDX, B, LDB,
+ $ RWORK, RESID )
+*
+* -- LAPACK test routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER TRANS
+ INTEGER LDA, LDB, LDX, M, N, NRHS
+ DOUBLE PRECISION RESID
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION A( LDA, * ), B( LDB, * ), RWORK( * ),
+ $ X( LDX, * )
+* ..
+*
+* Purpose
+* =======
+*
+* DGET02 computes the residual for a solution of a system of linear
+* equations A*x = b or A'*x = b:
+* RESID = norm(B - A*X) / ( norm(A) * norm(X) * EPS ),
+* where EPS is the machine epsilon.
+*
+* Arguments
+* =========
+*
+* TRANS (input) CHARACTER*1
+* Specifies the form of the system of equations:
+* = 'N': A *x = b
+* = 'T': A'*x = b, where A' is the transpose of A
+* = 'C': A'*x = b, where A' is the transpose of A
+*
+* M (input) INTEGER
+* The number of rows of the matrix A. M >= 0.
+*
+* N (input) INTEGER
+* The number of columns of the matrix A. N >= 0.
+*
+* NRHS (input) INTEGER
+* The number of columns of B, the matrix of right hand sides.
+* NRHS >= 0.
+*
+* A (input) DOUBLE PRECISION array, dimension (LDA,N)
+* The original M x N matrix A.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,M).
+*
+* X (input) DOUBLE PRECISION array, dimension (LDX,NRHS)
+* The computed solution vectors for the system of linear
+* equations.
+*
+* LDX (input) INTEGER
+* The leading dimension of the array X. If TRANS = 'N',
+* LDX >= max(1,N); if TRANS = 'T' or 'C', LDX >= max(1,M).
+*
+* B (input/output) DOUBLE PRECISION array, dimension (LDB,NRHS)
+* On entry, the right hand side vectors for the system of
+* linear equations.
+* On exit, B is overwritten with the difference B - A*X.
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. IF TRANS = 'N',
+* LDB >= max(1,M); if TRANS = 'T' or 'C', LDB >= max(1,N).
+*
+* RWORK (workspace) DOUBLE PRECISION array, dimension (M)
+*
+* RESID (output) DOUBLE PRECISION
+* The maximum over the number of right hand sides of
+* norm(B - A*X) / ( norm(A) * norm(X) * EPS ).
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER J, N1, N2
+ DOUBLE PRECISION ANORM, BNORM, EPS, XNORM
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ DOUBLE PRECISION DASUM, DLAMCH, DLANGE
+ EXTERNAL LSAME, DASUM, DLAMCH, DLANGE
+* ..
+* .. External Subroutines ..
+ EXTERNAL DGEMM
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+* Quick exit if M = 0 or N = 0 or NRHS = 0
+*
+ IF( M.LE.0 .OR. N.LE.0 .OR. NRHS.EQ.0 ) THEN
+ RESID = ZERO
+ RETURN
+ END IF
+*
+ IF( LSAME( TRANS, 'T' ) .OR. LSAME( TRANS, 'C' ) ) THEN
+ N1 = N
+ N2 = M
+ ELSE
+ N1 = M
+ N2 = N
+ END IF
+*
+* Exit with RESID = 1/EPS if ANORM = 0.
+*
+ EPS = DLAMCH( 'Epsilon' )
+ ANORM = DLANGE( '1', N1, N2, A, LDA, RWORK )
+ IF( ANORM.LE.ZERO ) THEN
+ RESID = ONE / EPS
+ RETURN
+ END IF
+*
+* Compute B - A*X (or B - A'*X ) and store in B.
+*
+ CALL DGEMM( TRANS, 'No transpose', N1, NRHS, N2, -ONE, A, LDA, X,
+ $ LDX, ONE, B, LDB )
+*
+* Compute the maximum over the number of right hand sides of
+* norm(B - A*X) / ( norm(A) * norm(X) * EPS ) .
+*
+ RESID = ZERO
+ DO 10 J = 1, NRHS
+ BNORM = DASUM( N1, B( 1, J ), 1 )
+ XNORM = DASUM( N2, X( 1, J ), 1 )
+ IF( XNORM.LE.ZERO ) THEN
+ RESID = ONE / EPS
+ ELSE
+ RESID = MAX( RESID, ( ( BNORM / ANORM ) / XNORM ) / EPS )
+ END IF
+ 10 CONTINUE
+*
+ RETURN
+*
+* End of DGET02
+*
+ END
+ SUBROUTINE DGET10( M, N, A, LDA, B, LDB, WORK, RESULT )
+*
+* -- LAPACK test routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER LDA, LDB, M, N
+ DOUBLE PRECISION RESULT
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION A( LDA, * ), B( LDB, * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DGET10 compares two matrices A and B and computes the ratio
+* RESULT = norm( A - B ) / ( norm(A) * M * EPS )
+*
+* Arguments
+* =========
+*
+* M (input) INTEGER
+* The number of rows of the matrices A and B.
+*
+* N (input) INTEGER
+* The number of columns of the matrices A and B.
+*
+* A (input) DOUBLE PRECISION array, dimension (LDA,N)
+* The m by n matrix A.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,M).
+*
+* B (input) DOUBLE PRECISION array, dimension (LDB,N)
+* The m by n matrix B.
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. LDB >= max(1,M).
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (M)
+*
+* RESULT (output) DOUBLE PRECISION
+* RESULT = norm( A - B ) / ( norm(A) * M * EPS )
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE, ZERO
+ PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER J
+ DOUBLE PRECISION ANORM, EPS, UNFL, WNORM
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DASUM, DLAMCH, DLANGE
+ EXTERNAL DASUM, DLAMCH, DLANGE
+* ..
+* .. External Subroutines ..
+ EXTERNAL DAXPY, DCOPY
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC DBLE, MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+* Quick return if possible
+*
+ IF( M.LE.0 .OR. N.LE.0 ) THEN
+ RESULT = ZERO
+ RETURN
+ END IF
+*
+ UNFL = DLAMCH( 'Safe minimum' )
+ EPS = DLAMCH( 'Precision' )
+*
+ WNORM = ZERO
+ DO 10 J = 1, N
+ CALL DCOPY( M, A( 1, J ), 1, WORK, 1 )
+ CALL DAXPY( M, -ONE, B( 1, J ), 1, WORK, 1 )
+ WNORM = MAX( WNORM, DASUM( N, WORK, 1 ) )
+ 10 CONTINUE
+*
+ ANORM = MAX( DLANGE( '1', M, N, A, LDA, WORK ), UNFL )
+*
+ IF( ANORM.GT.WNORM ) THEN
+ RESULT = ( WNORM / ANORM ) / ( M*EPS )
+ ELSE
+ IF( ANORM.LT.ONE ) THEN
+ RESULT = ( MIN( WNORM, M*ANORM ) / ANORM ) / ( M*EPS )
+ ELSE
+ RESULT = MIN( WNORM / ANORM, DBLE( M ) ) / ( M*EPS )
+ END IF
+ END IF
+*
+ RETURN
+*
+* End of DGET10
+*
+ END
+ SUBROUTINE DGET22( TRANSA, TRANSE, TRANSW, N, A, LDA, E, LDE, WR,
+ $ WI, WORK, RESULT )
+*
+* -- LAPACK test routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER TRANSA, TRANSE, TRANSW
+ INTEGER LDA, LDE, N
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION A( LDA, * ), E( LDE, * ), RESULT( 2 ), WI( * ),
+ $ WORK( * ), WR( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DGET22 does an eigenvector check.
+*
+* The basic test is:
+*
+* RESULT(1) = | A E - E W | / ( |A| |E| ulp )
+*
+* using the 1-norm. It also tests the normalization of E:
+*
+* RESULT(2) = max | m-norm(E(j)) - 1 | / ( n ulp )
+* j
+*
+* where E(j) is the j-th eigenvector, and m-norm is the max-norm of a
+* vector. If an eigenvector is complex, as determined from WI(j)
+* nonzero, then the max-norm of the vector ( er + i*ei ) is the maximum
+* of
+* |er(1)| + |ei(1)|, ... , |er(n)| + |ei(n)|
+*
+* W is a block diagonal matrix, with a 1 by 1 block for each real
+* eigenvalue and a 2 by 2 block for each complex conjugate pair.
+* If eigenvalues j and j+1 are a complex conjugate pair, so that
+* WR(j) = WR(j+1) = wr and WI(j) = - WI(j+1) = wi, then the 2 by 2
+* block corresponding to the pair will be:
+*
+* ( wr wi )
+* ( -wi wr )
+*
+* Such a block multiplying an n by 2 matrix ( ur ui ) on the right
+* will be the same as multiplying ur + i*ui by wr + i*wi.
+*
+* To handle various schemes for storage of left eigenvectors, there are
+* options to use A-transpose instead of A, E-transpose instead of E,
+* and/or W-transpose instead of W.
+*
+* Arguments
+* ==========
+*
+* TRANSA (input) CHARACTER*1
+* Specifies whether or not A is transposed.
+* = 'N': No transpose
+* = 'T': Transpose
+* = 'C': Conjugate transpose (= Transpose)
+*
+* TRANSE (input) CHARACTER*1
+* Specifies whether or not E is transposed.
+* = 'N': No transpose, eigenvectors are in columns of E
+* = 'T': Transpose, eigenvectors are in rows of E
+* = 'C': Conjugate transpose (= Transpose)
+*
+* TRANSW (input) CHARACTER*1
+* Specifies whether or not W is transposed.
+* = 'N': No transpose
+* = 'T': Transpose, use -WI(j) instead of WI(j)
+* = 'C': Conjugate transpose, use -WI(j) instead of WI(j)
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* A (input) DOUBLE PRECISION array, dimension (LDA,N)
+* The matrix whose eigenvectors are in E.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,N).
+*
+* E (input) DOUBLE PRECISION array, dimension (LDE,N)
+* The matrix of eigenvectors. If TRANSE = 'N', the eigenvectors
+* are stored in the columns of E, if TRANSE = 'T' or 'C', the
+* eigenvectors are stored in the rows of E.
+*
+* LDE (input) INTEGER
+* The leading dimension of the array E. LDE >= max(1,N).
+*
+* WR (input) DOUBLE PRECISION array, dimension (N)
+* WI (input) DOUBLE PRECISION array, dimension (N)
+* The real and imaginary parts of the eigenvalues of A.
+* Purely real eigenvalues are indicated by WI(j) = 0.
+* Complex conjugate pairs are indicated by WR(j)=WR(j+1) and
+* WI(j) = - WI(j+1) non-zero; the real part is assumed to be
+* stored in the j-th row/column and the imaginary part in
+* the (j+1)-th row/column.
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (N*(N+1))
+*
+* RESULT (output) DOUBLE PRECISION array, dimension (2)
+* RESULT(1) = | A E - E W | / ( |A| |E| ulp )
+* RESULT(2) = max | m-norm(E(j)) - 1 | / ( n ulp )
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
+* ..
+* .. Local Scalars ..
+ CHARACTER NORMA, NORME
+ INTEGER IECOL, IEROW, INCE, IPAIR, ITRNSE, J, JCOL,
+ $ JVEC
+ DOUBLE PRECISION ANORM, ENORM, ENRMAX, ENRMIN, ERRNRM, TEMP1,
+ $ ULP, UNFL
+* ..
+* .. Local Arrays ..
+ DOUBLE PRECISION WMAT( 2, 2 )
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ DOUBLE PRECISION DLAMCH, DLANGE
+ EXTERNAL LSAME, DLAMCH, DLANGE
+* ..
+* .. External Subroutines ..
+ EXTERNAL DAXPY, DGEMM, DLASET
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, DBLE, MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+* Initialize RESULT (in case N=0)
+*
+ RESULT( 1 ) = ZERO
+ RESULT( 2 ) = ZERO
+ IF( N.LE.0 )
+ $ RETURN
+*
+ UNFL = DLAMCH( 'Safe minimum' )
+ ULP = DLAMCH( 'Precision' )
+*
+ ITRNSE = 0
+ INCE = 1
+ NORMA = 'O'
+ NORME = 'O'
+*
+ IF( LSAME( TRANSA, 'T' ) .OR. LSAME( TRANSA, 'C' ) ) THEN
+ NORMA = 'I'
+ END IF
+ IF( LSAME( TRANSE, 'T' ) .OR. LSAME( TRANSE, 'C' ) ) THEN
+ NORME = 'I'
+ ITRNSE = 1
+ INCE = LDE
+ END IF
+*
+* Check normalization of E
+*
+ ENRMIN = ONE / ULP
+ ENRMAX = ZERO
+ IF( ITRNSE.EQ.0 ) THEN
+*
+* Eigenvectors are column vectors.
+*
+ IPAIR = 0
+ DO 30 JVEC = 1, N
+ TEMP1 = ZERO
+ IF( IPAIR.EQ.0 .AND. JVEC.LT.N .AND. WI( JVEC ).NE.ZERO )
+ $ IPAIR = 1
+ IF( IPAIR.EQ.1 ) THEN
+*
+* Complex eigenvector
+*
+ DO 10 J = 1, N
+ TEMP1 = MAX( TEMP1, ABS( E( J, JVEC ) )+
+ $ ABS( E( J, JVEC+1 ) ) )
+ 10 CONTINUE
+ ENRMIN = MIN( ENRMIN, TEMP1 )
+ ENRMAX = MAX( ENRMAX, TEMP1 )
+ IPAIR = 2
+ ELSE IF( IPAIR.EQ.2 ) THEN
+ IPAIR = 0
+ ELSE
+*
+* Real eigenvector
+*
+ DO 20 J = 1, N
+ TEMP1 = MAX( TEMP1, ABS( E( J, JVEC ) ) )
+ 20 CONTINUE
+ ENRMIN = MIN( ENRMIN, TEMP1 )
+ ENRMAX = MAX( ENRMAX, TEMP1 )
+ IPAIR = 0
+ END IF
+ 30 CONTINUE
+*
+ ELSE
+*
+* Eigenvectors are row vectors.
+*
+ DO 40 JVEC = 1, N
+ WORK( JVEC ) = ZERO
+ 40 CONTINUE
+*
+ DO 60 J = 1, N
+ IPAIR = 0
+ DO 50 JVEC = 1, N
+ IF( IPAIR.EQ.0 .AND. JVEC.LT.N .AND. WI( JVEC ).NE.ZERO )
+ $ IPAIR = 1
+ IF( IPAIR.EQ.1 ) THEN
+ WORK( JVEC ) = MAX( WORK( JVEC ),
+ $ ABS( E( J, JVEC ) )+ABS( E( J,
+ $ JVEC+1 ) ) )
+ WORK( JVEC+1 ) = WORK( JVEC )
+ ELSE IF( IPAIR.EQ.2 ) THEN
+ IPAIR = 0
+ ELSE
+ WORK( JVEC ) = MAX( WORK( JVEC ),
+ $ ABS( E( J, JVEC ) ) )
+ IPAIR = 0
+ END IF
+ 50 CONTINUE
+ 60 CONTINUE
+*
+ DO 70 JVEC = 1, N
+ ENRMIN = MIN( ENRMIN, WORK( JVEC ) )
+ ENRMAX = MAX( ENRMAX, WORK( JVEC ) )
+ 70 CONTINUE
+ END IF
+*
+* Norm of A:
+*
+ ANORM = MAX( DLANGE( NORMA, N, N, A, LDA, WORK ), UNFL )
+*
+* Norm of E:
+*
+ ENORM = MAX( DLANGE( NORME, N, N, E, LDE, WORK ), ULP )
+*
+* Norm of error:
+*
+* Error = AE - EW
+*
+ CALL DLASET( 'Full', N, N, ZERO, ZERO, WORK, N )
+*
+ IPAIR = 0
+ IEROW = 1
+ IECOL = 1
+*
+ DO 80 JCOL = 1, N
+ IF( ITRNSE.EQ.1 ) THEN
+ IEROW = JCOL
+ ELSE
+ IECOL = JCOL
+ END IF
+*
+ IF( IPAIR.EQ.0 .AND. WI( JCOL ).NE.ZERO )
+ $ IPAIR = 1
+*
+ IF( IPAIR.EQ.1 ) THEN
+ WMAT( 1, 1 ) = WR( JCOL )
+ WMAT( 2, 1 ) = -WI( JCOL )
+ WMAT( 1, 2 ) = WI( JCOL )
+ WMAT( 2, 2 ) = WR( JCOL )
+ CALL DGEMM( TRANSE, TRANSW, N, 2, 2, ONE, E( IEROW, IECOL ),
+ $ LDE, WMAT, 2, ZERO, WORK( N*( JCOL-1 )+1 ), N )
+ IPAIR = 2
+ ELSE IF( IPAIR.EQ.2 ) THEN
+ IPAIR = 0
+*
+ ELSE
+*
+ CALL DAXPY( N, WR( JCOL ), E( IEROW, IECOL ), INCE,
+ $ WORK( N*( JCOL-1 )+1 ), 1 )
+ IPAIR = 0
+ END IF
+*
+ 80 CONTINUE
+*
+ CALL DGEMM( TRANSA, TRANSE, N, N, N, ONE, A, LDA, E, LDE, -ONE,
+ $ WORK, N )
+*
+ ERRNRM = DLANGE( 'One', N, N, WORK, N, WORK( N*N+1 ) ) / ENORM
+*
+* Compute RESULT(1) (avoiding under/overflow)
+*
+ IF( ANORM.GT.ERRNRM ) THEN
+ RESULT( 1 ) = ( ERRNRM / ANORM ) / ULP
+ ELSE
+ IF( ANORM.LT.ONE ) THEN
+ RESULT( 1 ) = ( MIN( ERRNRM, ANORM ) / ANORM ) / ULP
+ ELSE
+ RESULT( 1 ) = MIN( ERRNRM / ANORM, ONE ) / ULP
+ END IF
+ END IF
+*
+* Compute RESULT(2) : the normalization error in E.
+*
+ RESULT( 2 ) = MAX( ABS( ENRMAX-ONE ), ABS( ENRMIN-ONE ) ) /
+ $ ( DBLE( N )*ULP )
+*
+ RETURN
+*
+* End of DGET22
+*
+ END
+ SUBROUTINE DGET23( COMP, BALANC, JTYPE, THRESH, ISEED, NOUNIT, N,
+ $ A, LDA, H, WR, WI, WR1, WI1, VL, LDVL, VR,
+ $ LDVR, LRE, LDLRE, RCONDV, RCNDV1, RCDVIN,
+ $ RCONDE, RCNDE1, RCDEIN, SCALE, SCALE1, RESULT,
+ $ WORK, LWORK, IWORK, INFO )
+*
+* -- LAPACK test routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ LOGICAL COMP
+ CHARACTER BALANC
+ INTEGER INFO, JTYPE, LDA, LDLRE, LDVL, LDVR, LWORK, N,
+ $ NOUNIT
+ DOUBLE PRECISION THRESH
+* ..
+* .. Array Arguments ..
+ INTEGER ISEED( 4 ), IWORK( * )
+ DOUBLE PRECISION A( LDA, * ), H( LDA, * ), LRE( LDLRE, * ),
+ $ RCDEIN( * ), RCDVIN( * ), RCNDE1( * ),
+ $ RCNDV1( * ), RCONDE( * ), RCONDV( * ),
+ $ RESULT( 11 ), SCALE( * ), SCALE1( * ),
+ $ VL( LDVL, * ), VR( LDVR, * ), WI( * ),
+ $ WI1( * ), WORK( * ), WR( * ), WR1( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DGET23 checks the nonsymmetric eigenvalue problem driver SGEEVX.
+* If COMP = .FALSE., the first 8 of the following tests will be
+* performed on the input matrix A, and also test 9 if LWORK is
+* sufficiently large.
+* if COMP is .TRUE. all 11 tests will be performed.
+*
+* (1) | A * VR - VR * W | / ( n |A| ulp )
+*
+* Here VR is the matrix of unit right eigenvectors.
+* W is a block diagonal matrix, with a 1x1 block for each
+* real eigenvalue and a 2x2 block for each complex conjugate
+* pair. If eigenvalues j and j+1 are a complex conjugate pair,
+* so WR(j) = WR(j+1) = wr and WI(j) = - WI(j+1) = wi, then the
+* 2 x 2 block corresponding to the pair will be:
+*
+* ( wr wi )
+* ( -wi wr )
+*
+* Such a block multiplying an n x 2 matrix ( ur ui ) on the
+* right will be the same as multiplying ur + i*ui by wr + i*wi.
+*
+* (2) | A**H * VL - VL * W**H | / ( n |A| ulp )
+*
+* Here VL is the matrix of unit left eigenvectors, A**H is the
+* conjugate transpose of A, and W is as above.
+*
+* (3) | |VR(i)| - 1 | / ulp and largest component real
+*
+* VR(i) denotes the i-th column of VR.
+*
+* (4) | |VL(i)| - 1 | / ulp and largest component real
+*
+* VL(i) denotes the i-th column of VL.
+*
+* (5) 0 if W(full) = W(partial), 1/ulp otherwise
+*
+* W(full) denotes the eigenvalues computed when VR, VL, RCONDV
+* and RCONDE are also computed, and W(partial) denotes the
+* eigenvalues computed when only some of VR, VL, RCONDV, and
+* RCONDE are computed.
+*
+* (6) 0 if VR(full) = VR(partial), 1/ulp otherwise
+*
+* VR(full) denotes the right eigenvectors computed when VL, RCONDV
+* and RCONDE are computed, and VR(partial) denotes the result
+* when only some of VL and RCONDV are computed.
+*
+* (7) 0 if VL(full) = VL(partial), 1/ulp otherwise
+*
+* VL(full) denotes the left eigenvectors computed when VR, RCONDV
+* and RCONDE are computed, and VL(partial) denotes the result
+* when only some of VR and RCONDV are computed.
+*
+* (8) 0 if SCALE, ILO, IHI, ABNRM (full) =
+* SCALE, ILO, IHI, ABNRM (partial)
+* 1/ulp otherwise
+*
+* SCALE, ILO, IHI and ABNRM describe how the matrix is balanced.
+* (full) is when VR, VL, RCONDE and RCONDV are also computed, and
+* (partial) is when some are not computed.
+*
+* (9) 0 if RCONDV(full) = RCONDV(partial), 1/ulp otherwise
+*
+* RCONDV(full) denotes the reciprocal condition numbers of the
+* right eigenvectors computed when VR, VL and RCONDE are also
+* computed. RCONDV(partial) denotes the reciprocal condition
+* numbers when only some of VR, VL and RCONDE are computed.
+*
+* (10) |RCONDV - RCDVIN| / cond(RCONDV)
+*
+* RCONDV is the reciprocal right eigenvector condition number
+* computed by DGEEVX and RCDVIN (the precomputed true value)
+* is supplied as input. cond(RCONDV) is the condition number of
+* RCONDV, and takes errors in computing RCONDV into account, so
+* that the resulting quantity should be O(ULP). cond(RCONDV) is
+* essentially given by norm(A)/RCONDE.
+*
+* (11) |RCONDE - RCDEIN| / cond(RCONDE)
+*
+* RCONDE is the reciprocal eigenvalue condition number
+* computed by DGEEVX and RCDEIN (the precomputed true value)
+* is supplied as input. cond(RCONDE) is the condition number
+* of RCONDE, and takes errors in computing RCONDE into account,
+* so that the resulting quantity should be O(ULP). cond(RCONDE)
+* is essentially given by norm(A)/RCONDV.
+*
+* Arguments
+* =========
+*
+* COMP (input) LOGICAL
+* COMP describes which input tests to perform:
+* = .FALSE. if the computed condition numbers are not to
+* be tested against RCDVIN and RCDEIN
+* = .TRUE. if they are to be compared
+*
+* BALANC (input) CHARACTER
+* Describes the balancing option to be tested.
+* = 'N' for no permuting or diagonal scaling
+* = 'P' for permuting but no diagonal scaling
+* = 'S' for no permuting but diagonal scaling
+* = 'B' for permuting and diagonal scaling
+*
+* JTYPE (input) INTEGER
+* Type of input matrix. Used to label output if error occurs.
+*
+* THRESH (input) DOUBLE PRECISION
+* A test will count as "failed" if the "error", computed as
+* described above, exceeds THRESH. Note that the error
+* is scaled to be O(1), so THRESH should be a reasonably
+* small multiple of 1, e.g., 10 or 100. In particular,
+* it should not depend on the precision (single vs. double)
+* or the size of the matrix. It must be at least zero.
+*
+* ISEED (input) INTEGER array, dimension (4)
+* If COMP = .FALSE., the random number generator seed
+* used to produce matrix.
+* If COMP = .TRUE., ISEED(1) = the number of the example.
+* Used to label output if error occurs.
+*
+* NOUNIT (input) INTEGER
+* The FORTRAN unit number for printing out error messages
+* (e.g., if a routine returns INFO not equal to 0.)
+*
+* N (input) INTEGER
+* The dimension of A. N must be at least 0.
+*
+* A (input/output) DOUBLE PRECISION array, dimension (LDA,N)
+* Used to hold the matrix whose eigenvalues are to be
+* computed.
+*
+* LDA (input) INTEGER
+* The leading dimension of A, and H. LDA must be at
+* least 1 and at least N.
+*
+* H (workspace) DOUBLE PRECISION array, dimension (LDA,N)
+* Another copy of the test matrix A, modified by DGEEVX.
+*
+* WR (workspace) DOUBLE PRECISION array, dimension (N)
+* WI (workspace) DOUBLE PRECISION array, dimension (N)
+* The real and imaginary parts of the eigenvalues of A.
+* On exit, WR + WI*i are the eigenvalues of the matrix in A.
+*
+* WR1 (workspace) DOUBLE PRECISION array, dimension (N)
+* WI1 (workspace) DOUBLE PRECISION array, dimension (N)
+* Like WR, WI, these arrays contain the eigenvalues of A,
+* but those computed when DGEEVX only computes a partial
+* eigendecomposition, i.e. not the eigenvalues and left
+* and right eigenvectors.
+*
+* VL (workspace) DOUBLE PRECISION array, dimension (LDVL,N)
+* VL holds the computed left eigenvectors.
+*
+* LDVL (input) INTEGER
+* Leading dimension of VL. Must be at least max(1,N).
+*
+* VR (workspace) DOUBLE PRECISION array, dimension (LDVR,N)
+* VR holds the computed right eigenvectors.
+*
+* LDVR (input) INTEGER
+* Leading dimension of VR. Must be at least max(1,N).
+*
+* LRE (workspace) DOUBLE PRECISION array, dimension (LDLRE,N)
+* LRE holds the computed right or left eigenvectors.
+*
+* LDLRE (input) INTEGER
+* Leading dimension of LRE. Must be at least max(1,N).
+*
+* RCONDV (workspace) DOUBLE PRECISION array, dimension (N)
+* RCONDV holds the computed reciprocal condition numbers
+* for eigenvectors.
+*
+* RCNDV1 (workspace) DOUBLE PRECISION array, dimension (N)
+* RCNDV1 holds more computed reciprocal condition numbers
+* for eigenvectors.
+*
+* RCDVIN (input) DOUBLE PRECISION array, dimension (N)
+* When COMP = .TRUE. RCDVIN holds the precomputed reciprocal
+* condition numbers for eigenvectors to be compared with
+* RCONDV.
+*
+* RCONDE (workspace) DOUBLE PRECISION array, dimension (N)
+* RCONDE holds the computed reciprocal condition numbers
+* for eigenvalues.
+*
+* RCNDE1 (workspace) DOUBLE PRECISION array, dimension (N)
+* RCNDE1 holds more computed reciprocal condition numbers
+* for eigenvalues.
+*
+* RCDEIN (input) DOUBLE PRECISION array, dimension (N)
+* When COMP = .TRUE. RCDEIN holds the precomputed reciprocal
+* condition numbers for eigenvalues to be compared with
+* RCONDE.
+*
+* SCALE (workspace) DOUBLE PRECISION array, dimension (N)
+* Holds information describing balancing of matrix.
+*
+* SCALE1 (workspace) DOUBLE PRECISION array, dimension (N)
+* Holds information describing balancing of matrix.
+*
+* RESULT (output) DOUBLE PRECISION array, dimension (11)
+* The values computed by the 11 tests described above.
+* The values are currently limited to 1/ulp, to avoid
+* overflow.
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK)
+*
+* LWORK (input) INTEGER
+* The number of entries in WORK. This must be at least
+* 3*N, and 6*N+N**2 if tests 9, 10 or 11 are to be performed.
+*
+* IWORK (workspace) INTEGER array, dimension (2*N)
+*
+* INFO (output) INTEGER
+* If 0, successful exit.
+* If <0, input parameter -INFO had an incorrect value.
+* If >0, DGEEVX returned an error code, the absolute
+* value of which is returned.
+*
+* =====================================================================
+*
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE, TWO
+ PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 )
+ DOUBLE PRECISION EPSIN
+ PARAMETER ( EPSIN = 5.9605D-8 )
+* ..
+* .. Local Scalars ..
+ LOGICAL BALOK, NOBAL
+ CHARACTER SENSE
+ INTEGER I, IHI, IHI1, IINFO, ILO, ILO1, ISENS, ISENSM,
+ $ J, JJ, KMIN
+ DOUBLE PRECISION ABNRM, ABNRM1, EPS, SMLNUM, TNRM, TOL, TOLIN,
+ $ ULP, ULPINV, V, VIMIN, VMAX, VMX, VRMIN, VRMX,
+ $ VTST
+* ..
+* .. Local Arrays ..
+ CHARACTER SENS( 2 )
+ DOUBLE PRECISION DUM( 1 ), RES( 2 )
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ DOUBLE PRECISION DLAMCH, DLAPY2, DNRM2
+ EXTERNAL LSAME, DLAMCH, DLAPY2, DNRM2
+* ..
+* .. External Subroutines ..
+ EXTERNAL DGEEVX, DGET22, DLACPY, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, DBLE, MAX, MIN
+* ..
+* .. Data statements ..
+ DATA SENS / 'N', 'V' /
+* ..
+* .. Executable Statements ..
+*
+* Check for errors
+*
+ NOBAL = LSAME( BALANC, 'N' )
+ BALOK = NOBAL .OR. LSAME( BALANC, 'P' ) .OR.
+ $ LSAME( BALANC, 'S' ) .OR. LSAME( BALANC, 'B' )
+ INFO = 0
+ IF( .NOT.BALOK ) THEN
+ INFO = -2
+ ELSE IF( THRESH.LT.ZERO ) THEN
+ INFO = -4
+ ELSE IF( NOUNIT.LE.0 ) THEN
+ INFO = -6
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -7
+ ELSE IF( LDA.LT.1 .OR. LDA.LT.N ) THEN
+ INFO = -9
+ ELSE IF( LDVL.LT.1 .OR. LDVL.LT.N ) THEN
+ INFO = -16
+ ELSE IF( LDVR.LT.1 .OR. LDVR.LT.N ) THEN
+ INFO = -18
+ ELSE IF( LDLRE.LT.1 .OR. LDLRE.LT.N ) THEN
+ INFO = -20
+ ELSE IF( LWORK.LT.3*N .OR. ( COMP .AND. LWORK.LT.6*N+N*N ) ) THEN
+ INFO = -31
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DGET23', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if nothing to do
+*
+ DO 10 I = 1, 11
+ RESULT( I ) = -ONE
+ 10 CONTINUE
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+* More Important constants
+*
+ ULP = DLAMCH( 'Precision' )
+ SMLNUM = DLAMCH( 'S' )
+ ULPINV = ONE / ULP
+*
+* Compute eigenvalues and eigenvectors, and test them
+*
+ IF( LWORK.GE.6*N+N*N ) THEN
+ SENSE = 'B'
+ ISENSM = 2
+ ELSE
+ SENSE = 'E'
+ ISENSM = 1
+ END IF
+ CALL DLACPY( 'F', N, N, A, LDA, H, LDA )
+ CALL DGEEVX( BALANC, 'V', 'V', SENSE, N, H, LDA, WR, WI, VL, LDVL,
+ $ VR, LDVR, ILO, IHI, SCALE, ABNRM, RCONDE, RCONDV,
+ $ WORK, LWORK, IWORK, IINFO )
+ IF( IINFO.NE.0 ) THEN
+ RESULT( 1 ) = ULPINV
+ IF( JTYPE.NE.22 ) THEN
+ WRITE( NOUNIT, FMT = 9998 )'DGEEVX1', IINFO, N, JTYPE,
+ $ BALANC, ISEED
+ ELSE
+ WRITE( NOUNIT, FMT = 9999 )'DGEEVX1', IINFO, N, ISEED( 1 )
+ END IF
+ INFO = ABS( IINFO )
+ RETURN
+ END IF
+*
+* Do Test (1)
+*
+ CALL DGET22( 'N', 'N', 'N', N, A, LDA, VR, LDVR, WR, WI, WORK,
+ $ RES )
+ RESULT( 1 ) = RES( 1 )
+*
+* Do Test (2)
+*
+ CALL DGET22( 'T', 'N', 'T', N, A, LDA, VL, LDVL, WR, WI, WORK,
+ $ RES )
+ RESULT( 2 ) = RES( 1 )
+*
+* Do Test (3)
+*
+ DO 30 J = 1, N
+ TNRM = ONE
+ IF( WI( J ).EQ.ZERO ) THEN
+ TNRM = DNRM2( N, VR( 1, J ), 1 )
+ ELSE IF( WI( J ).GT.ZERO ) THEN
+ TNRM = DLAPY2( DNRM2( N, VR( 1, J ), 1 ),
+ $ DNRM2( N, VR( 1, J+1 ), 1 ) )
+ END IF
+ RESULT( 3 ) = MAX( RESULT( 3 ),
+ $ MIN( ULPINV, ABS( TNRM-ONE ) / ULP ) )
+ IF( WI( J ).GT.ZERO ) THEN
+ VMX = ZERO
+ VRMX = ZERO
+ DO 20 JJ = 1, N
+ VTST = DLAPY2( VR( JJ, J ), VR( JJ, J+1 ) )
+ IF( VTST.GT.VMX )
+ $ VMX = VTST
+ IF( VR( JJ, J+1 ).EQ.ZERO .AND. ABS( VR( JJ, J ) ).GT.
+ $ VRMX )VRMX = ABS( VR( JJ, J ) )
+ 20 CONTINUE
+ IF( VRMX / VMX.LT.ONE-TWO*ULP )
+ $ RESULT( 3 ) = ULPINV
+ END IF
+ 30 CONTINUE
+*
+* Do Test (4)
+*
+ DO 50 J = 1, N
+ TNRM = ONE
+ IF( WI( J ).EQ.ZERO ) THEN
+ TNRM = DNRM2( N, VL( 1, J ), 1 )
+ ELSE IF( WI( J ).GT.ZERO ) THEN
+ TNRM = DLAPY2( DNRM2( N, VL( 1, J ), 1 ),
+ $ DNRM2( N, VL( 1, J+1 ), 1 ) )
+ END IF
+ RESULT( 4 ) = MAX( RESULT( 4 ),
+ $ MIN( ULPINV, ABS( TNRM-ONE ) / ULP ) )
+ IF( WI( J ).GT.ZERO ) THEN
+ VMX = ZERO
+ VRMX = ZERO
+ DO 40 JJ = 1, N
+ VTST = DLAPY2( VL( JJ, J ), VL( JJ, J+1 ) )
+ IF( VTST.GT.VMX )
+ $ VMX = VTST
+ IF( VL( JJ, J+1 ).EQ.ZERO .AND. ABS( VL( JJ, J ) ).GT.
+ $ VRMX )VRMX = ABS( VL( JJ, J ) )
+ 40 CONTINUE
+ IF( VRMX / VMX.LT.ONE-TWO*ULP )
+ $ RESULT( 4 ) = ULPINV
+ END IF
+ 50 CONTINUE
+*
+* Test for all options of computing condition numbers
+*
+ DO 200 ISENS = 1, ISENSM
+*
+ SENSE = SENS( ISENS )
+*
+* Compute eigenvalues only, and test them
+*
+ CALL DLACPY( 'F', N, N, A, LDA, H, LDA )
+ CALL DGEEVX( BALANC, 'N', 'N', SENSE, N, H, LDA, WR1, WI1, DUM,
+ $ 1, DUM, 1, ILO1, IHI1, SCALE1, ABNRM1, RCNDE1,
+ $ RCNDV1, WORK, LWORK, IWORK, IINFO )
+ IF( IINFO.NE.0 ) THEN
+ RESULT( 1 ) = ULPINV
+ IF( JTYPE.NE.22 ) THEN
+ WRITE( NOUNIT, FMT = 9998 )'DGEEVX2', IINFO, N, JTYPE,
+ $ BALANC, ISEED
+ ELSE
+ WRITE( NOUNIT, FMT = 9999 )'DGEEVX2', IINFO, N,
+ $ ISEED( 1 )
+ END IF
+ INFO = ABS( IINFO )
+ GO TO 190
+ END IF
+*
+* Do Test (5)
+*
+ DO 60 J = 1, N
+ IF( WR( J ).NE.WR1( J ) .OR. WI( J ).NE.WI1( J ) )
+ $ RESULT( 5 ) = ULPINV
+ 60 CONTINUE
+*
+* Do Test (8)
+*
+ IF( .NOT.NOBAL ) THEN
+ DO 70 J = 1, N
+ IF( SCALE( J ).NE.SCALE1( J ) )
+ $ RESULT( 8 ) = ULPINV
+ 70 CONTINUE
+ IF( ILO.NE.ILO1 )
+ $ RESULT( 8 ) = ULPINV
+ IF( IHI.NE.IHI1 )
+ $ RESULT( 8 ) = ULPINV
+ IF( ABNRM.NE.ABNRM1 )
+ $ RESULT( 8 ) = ULPINV
+ END IF
+*
+* Do Test (9)
+*
+ IF( ISENS.EQ.2 .AND. N.GT.1 ) THEN
+ DO 80 J = 1, N
+ IF( RCONDV( J ).NE.RCNDV1( J ) )
+ $ RESULT( 9 ) = ULPINV
+ 80 CONTINUE
+ END IF
+*
+* Compute eigenvalues and right eigenvectors, and test them
+*
+ CALL DLACPY( 'F', N, N, A, LDA, H, LDA )
+ CALL DGEEVX( BALANC, 'N', 'V', SENSE, N, H, LDA, WR1, WI1, DUM,
+ $ 1, LRE, LDLRE, ILO1, IHI1, SCALE1, ABNRM1, RCNDE1,
+ $ RCNDV1, WORK, LWORK, IWORK, IINFO )
+ IF( IINFO.NE.0 ) THEN
+ RESULT( 1 ) = ULPINV
+ IF( JTYPE.NE.22 ) THEN
+ WRITE( NOUNIT, FMT = 9998 )'DGEEVX3', IINFO, N, JTYPE,
+ $ BALANC, ISEED
+ ELSE
+ WRITE( NOUNIT, FMT = 9999 )'DGEEVX3', IINFO, N,
+ $ ISEED( 1 )
+ END IF
+ INFO = ABS( IINFO )
+ GO TO 190
+ END IF
+*
+* Do Test (5) again
+*
+ DO 90 J = 1, N
+ IF( WR( J ).NE.WR1( J ) .OR. WI( J ).NE.WI1( J ) )
+ $ RESULT( 5 ) = ULPINV
+ 90 CONTINUE
+*
+* Do Test (6)
+*
+ DO 110 J = 1, N
+ DO 100 JJ = 1, N
+ IF( VR( J, JJ ).NE.LRE( J, JJ ) )
+ $ RESULT( 6 ) = ULPINV
+ 100 CONTINUE
+ 110 CONTINUE
+*
+* Do Test (8) again
+*
+ IF( .NOT.NOBAL ) THEN
+ DO 120 J = 1, N
+ IF( SCALE( J ).NE.SCALE1( J ) )
+ $ RESULT( 8 ) = ULPINV
+ 120 CONTINUE
+ IF( ILO.NE.ILO1 )
+ $ RESULT( 8 ) = ULPINV
+ IF( IHI.NE.IHI1 )
+ $ RESULT( 8 ) = ULPINV
+ IF( ABNRM.NE.ABNRM1 )
+ $ RESULT( 8 ) = ULPINV
+ END IF
+*
+* Do Test (9) again
+*
+ IF( ISENS.EQ.2 .AND. N.GT.1 ) THEN
+ DO 130 J = 1, N
+ IF( RCONDV( J ).NE.RCNDV1( J ) )
+ $ RESULT( 9 ) = ULPINV
+ 130 CONTINUE
+ END IF
+*
+* Compute eigenvalues and left eigenvectors, and test them
+*
+ CALL DLACPY( 'F', N, N, A, LDA, H, LDA )
+ CALL DGEEVX( BALANC, 'V', 'N', SENSE, N, H, LDA, WR1, WI1, LRE,
+ $ LDLRE, DUM, 1, ILO1, IHI1, SCALE1, ABNRM1, RCNDE1,
+ $ RCNDV1, WORK, LWORK, IWORK, IINFO )
+ IF( IINFO.NE.0 ) THEN
+ RESULT( 1 ) = ULPINV
+ IF( JTYPE.NE.22 ) THEN
+ WRITE( NOUNIT, FMT = 9998 )'DGEEVX4', IINFO, N, JTYPE,
+ $ BALANC, ISEED
+ ELSE
+ WRITE( NOUNIT, FMT = 9999 )'DGEEVX4', IINFO, N,
+ $ ISEED( 1 )
+ END IF
+ INFO = ABS( IINFO )
+ GO TO 190
+ END IF
+*
+* Do Test (5) again
+*
+ DO 140 J = 1, N
+ IF( WR( J ).NE.WR1( J ) .OR. WI( J ).NE.WI1( J ) )
+ $ RESULT( 5 ) = ULPINV
+ 140 CONTINUE
+*
+* Do Test (7)
+*
+ DO 160 J = 1, N
+ DO 150 JJ = 1, N
+ IF( VL( J, JJ ).NE.LRE( J, JJ ) )
+ $ RESULT( 7 ) = ULPINV
+ 150 CONTINUE
+ 160 CONTINUE
+*
+* Do Test (8) again
+*
+ IF( .NOT.NOBAL ) THEN
+ DO 170 J = 1, N
+ IF( SCALE( J ).NE.SCALE1( J ) )
+ $ RESULT( 8 ) = ULPINV
+ 170 CONTINUE
+ IF( ILO.NE.ILO1 )
+ $ RESULT( 8 ) = ULPINV
+ IF( IHI.NE.IHI1 )
+ $ RESULT( 8 ) = ULPINV
+ IF( ABNRM.NE.ABNRM1 )
+ $ RESULT( 8 ) = ULPINV
+ END IF
+*
+* Do Test (9) again
+*
+ IF( ISENS.EQ.2 .AND. N.GT.1 ) THEN
+ DO 180 J = 1, N
+ IF( RCONDV( J ).NE.RCNDV1( J ) )
+ $ RESULT( 9 ) = ULPINV
+ 180 CONTINUE
+ END IF
+*
+ 190 CONTINUE
+*
+ 200 CONTINUE
+*
+* If COMP, compare condition numbers to precomputed ones
+*
+ IF( COMP ) THEN
+ CALL DLACPY( 'F', N, N, A, LDA, H, LDA )
+ CALL DGEEVX( 'N', 'V', 'V', 'B', N, H, LDA, WR, WI, VL, LDVL,
+ $ VR, LDVR, ILO, IHI, SCALE, ABNRM, RCONDE, RCONDV,
+ $ WORK, LWORK, IWORK, IINFO )
+ IF( IINFO.NE.0 ) THEN
+ RESULT( 1 ) = ULPINV
+ WRITE( NOUNIT, FMT = 9999 )'DGEEVX5', IINFO, N, ISEED( 1 )
+ INFO = ABS( IINFO )
+ GO TO 250
+ END IF
+*
+* Sort eigenvalues and condition numbers lexicographically
+* to compare with inputs
+*
+ DO 220 I = 1, N - 1
+ KMIN = I
+ VRMIN = WR( I )
+ VIMIN = WI( I )
+ DO 210 J = I + 1, N
+ IF( WR( J ).LT.VRMIN ) THEN
+ KMIN = J
+ VRMIN = WR( J )
+ VIMIN = WI( J )
+ END IF
+ 210 CONTINUE
+ WR( KMIN ) = WR( I )
+ WI( KMIN ) = WI( I )
+ WR( I ) = VRMIN
+ WI( I ) = VIMIN
+ VRMIN = RCONDE( KMIN )
+ RCONDE( KMIN ) = RCONDE( I )
+ RCONDE( I ) = VRMIN
+ VRMIN = RCONDV( KMIN )
+ RCONDV( KMIN ) = RCONDV( I )
+ RCONDV( I ) = VRMIN
+ 220 CONTINUE
+*
+* Compare condition numbers for eigenvectors
+* taking their condition numbers into account
+*
+ RESULT( 10 ) = ZERO
+ EPS = MAX( EPSIN, ULP )
+ V = MAX( DBLE( N )*EPS*ABNRM, SMLNUM )
+ IF( ABNRM.EQ.ZERO )
+ $ V = ONE
+ DO 230 I = 1, N
+ IF( V.GT.RCONDV( I )*RCONDE( I ) ) THEN
+ TOL = RCONDV( I )
+ ELSE
+ TOL = V / RCONDE( I )
+ END IF
+ IF( V.GT.RCDVIN( I )*RCDEIN( I ) ) THEN
+ TOLIN = RCDVIN( I )
+ ELSE
+ TOLIN = V / RCDEIN( I )
+ END IF
+ TOL = MAX( TOL, SMLNUM / EPS )
+ TOLIN = MAX( TOLIN, SMLNUM / EPS )
+ IF( EPS*( RCDVIN( I )-TOLIN ).GT.RCONDV( I )+TOL ) THEN
+ VMAX = ONE / EPS
+ ELSE IF( RCDVIN( I )-TOLIN.GT.RCONDV( I )+TOL ) THEN
+ VMAX = ( RCDVIN( I )-TOLIN ) / ( RCONDV( I )+TOL )
+ ELSE IF( RCDVIN( I )+TOLIN.LT.EPS*( RCONDV( I )-TOL ) ) THEN
+ VMAX = ONE / EPS
+ ELSE IF( RCDVIN( I )+TOLIN.LT.RCONDV( I )-TOL ) THEN
+ VMAX = ( RCONDV( I )-TOL ) / ( RCDVIN( I )+TOLIN )
+ ELSE
+ VMAX = ONE
+ END IF
+ RESULT( 10 ) = MAX( RESULT( 10 ), VMAX )
+ 230 CONTINUE
+*
+* Compare condition numbers for eigenvalues
+* taking their condition numbers into account
+*
+ RESULT( 11 ) = ZERO
+ DO 240 I = 1, N
+ IF( V.GT.RCONDV( I ) ) THEN
+ TOL = ONE
+ ELSE
+ TOL = V / RCONDV( I )
+ END IF
+ IF( V.GT.RCDVIN( I ) ) THEN
+ TOLIN = ONE
+ ELSE
+ TOLIN = V / RCDVIN( I )
+ END IF
+ TOL = MAX( TOL, SMLNUM / EPS )
+ TOLIN = MAX( TOLIN, SMLNUM / EPS )
+ IF( EPS*( RCDEIN( I )-TOLIN ).GT.RCONDE( I )+TOL ) THEN
+ VMAX = ONE / EPS
+ ELSE IF( RCDEIN( I )-TOLIN.GT.RCONDE( I )+TOL ) THEN
+ VMAX = ( RCDEIN( I )-TOLIN ) / ( RCONDE( I )+TOL )
+ ELSE IF( RCDEIN( I )+TOLIN.LT.EPS*( RCONDE( I )-TOL ) ) THEN
+ VMAX = ONE / EPS
+ ELSE IF( RCDEIN( I )+TOLIN.LT.RCONDE( I )-TOL ) THEN
+ VMAX = ( RCONDE( I )-TOL ) / ( RCDEIN( I )+TOLIN )
+ ELSE
+ VMAX = ONE
+ END IF
+ RESULT( 11 ) = MAX( RESULT( 11 ), VMAX )
+ 240 CONTINUE
+ 250 CONTINUE
+*
+ END IF
+*
+ 9999 FORMAT( ' DGET23: ', A, ' returned INFO=', I6, '.', / 9X, 'N=',
+ $ I6, ', INPUT EXAMPLE NUMBER = ', I4 )
+ 9998 FORMAT( ' DGET23: ', A, ' returned INFO=', I6, '.', / 9X, 'N=',
+ $ I6, ', JTYPE=', I6, ', BALANC = ', A, ', ISEED=(',
+ $ 3( I5, ',' ), I5, ')' )
+*
+ RETURN
+*
+* End of DGET23
+*
+ END
+ SUBROUTINE DGET24( COMP, JTYPE, THRESH, ISEED, NOUNIT, N, A, LDA,
+ $ H, HT, WR, WI, WRT, WIT, WRTMP, WITMP, VS,
+ $ LDVS, VS1, RCDEIN, RCDVIN, NSLCT, ISLCT,
+ $ RESULT, WORK, LWORK, IWORK, BWORK, INFO )
+*
+* -- LAPACK test routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ LOGICAL COMP
+ INTEGER INFO, JTYPE, LDA, LDVS, LWORK, N, NOUNIT, NSLCT
+ DOUBLE PRECISION RCDEIN, RCDVIN, THRESH
+* ..
+* .. Array Arguments ..
+ LOGICAL BWORK( * )
+ INTEGER ISEED( 4 ), ISLCT( * ), IWORK( * )
+ DOUBLE PRECISION A( LDA, * ), H( LDA, * ), HT( LDA, * ),
+ $ RESULT( 17 ), VS( LDVS, * ), VS1( LDVS, * ),
+ $ WI( * ), WIT( * ), WITMP( * ), WORK( * ),
+ $ WR( * ), WRT( * ), WRTMP( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DGET24 checks the nonsymmetric eigenvalue (Schur form) problem
+* expert driver DGEESX.
+*
+* If COMP = .FALSE., the first 13 of the following tests will be
+* be performed on the input matrix A, and also tests 14 and 15
+* if LWORK is sufficiently large.
+* If COMP = .TRUE., all 17 test will be performed.
+*
+* (1) 0 if T is in Schur form, 1/ulp otherwise
+* (no sorting of eigenvalues)
+*
+* (2) | A - VS T VS' | / ( n |A| ulp )
+*
+* Here VS is the matrix of Schur eigenvectors, and T is in Schur
+* form (no sorting of eigenvalues).
+*
+* (3) | I - VS VS' | / ( n ulp ) (no sorting of eigenvalues).
+*
+* (4) 0 if WR+sqrt(-1)*WI are eigenvalues of T
+* 1/ulp otherwise
+* (no sorting of eigenvalues)
+*
+* (5) 0 if T(with VS) = T(without VS),
+* 1/ulp otherwise
+* (no sorting of eigenvalues)
+*
+* (6) 0 if eigenvalues(with VS) = eigenvalues(without VS),
+* 1/ulp otherwise
+* (no sorting of eigenvalues)
+*
+* (7) 0 if T is in Schur form, 1/ulp otherwise
+* (with sorting of eigenvalues)
+*
+* (8) | A - VS T VS' | / ( n |A| ulp )
+*
+* Here VS is the matrix of Schur eigenvectors, and T is in Schur
+* form (with sorting of eigenvalues).
+*
+* (9) | I - VS VS' | / ( n ulp ) (with sorting of eigenvalues).
+*
+* (10) 0 if WR+sqrt(-1)*WI are eigenvalues of T
+* 1/ulp otherwise
+* If workspace sufficient, also compare WR, WI with and
+* without reciprocal condition numbers
+* (with sorting of eigenvalues)
+*
+* (11) 0 if T(with VS) = T(without VS),
+* 1/ulp otherwise
+* If workspace sufficient, also compare T with and without
+* reciprocal condition numbers
+* (with sorting of eigenvalues)
+*
+* (12) 0 if eigenvalues(with VS) = eigenvalues(without VS),
+* 1/ulp otherwise
+* If workspace sufficient, also compare VS with and without
+* reciprocal condition numbers
+* (with sorting of eigenvalues)
+*
+* (13) if sorting worked and SDIM is the number of
+* eigenvalues which were SELECTed
+* If workspace sufficient, also compare SDIM with and
+* without reciprocal condition numbers
+*
+* (14) if RCONDE the same no matter if VS and/or RCONDV computed
+*
+* (15) if RCONDV the same no matter if VS and/or RCONDE computed
+*
+* (16) |RCONDE - RCDEIN| / cond(RCONDE)
+*
+* RCONDE is the reciprocal average eigenvalue condition number
+* computed by DGEESX and RCDEIN (the precomputed true value)
+* is supplied as input. cond(RCONDE) is the condition number
+* of RCONDE, and takes errors in computing RCONDE into account,
+* so that the resulting quantity should be O(ULP). cond(RCONDE)
+* is essentially given by norm(A)/RCONDV.
+*
+* (17) |RCONDV - RCDVIN| / cond(RCONDV)
+*
+* RCONDV is the reciprocal right invariant subspace condition
+* number computed by DGEESX and RCDVIN (the precomputed true
+* value) is supplied as input. cond(RCONDV) is the condition
+* number of RCONDV, and takes errors in computing RCONDV into
+* account, so that the resulting quantity should be O(ULP).
+* cond(RCONDV) is essentially given by norm(A)/RCONDE.
+*
+* Arguments
+* =========
+*
+* COMP (input) LOGICAL
+* COMP describes which input tests to perform:
+* = .FALSE. if the computed condition numbers are not to
+* be tested against RCDVIN and RCDEIN
+* = .TRUE. if they are to be compared
+*
+* JTYPE (input) INTEGER
+* Type of input matrix. Used to label output if error occurs.
+*
+* ISEED (input) INTEGER array, dimension (4)
+* If COMP = .FALSE., the random number generator seed
+* used to produce matrix.
+* If COMP = .TRUE., ISEED(1) = the number of the example.
+* Used to label output if error occurs.
+*
+* THRESH (input) DOUBLE PRECISION
+* A test will count as "failed" if the "error", computed as
+* described above, exceeds THRESH. Note that the error
+* is scaled to be O(1), so THRESH should be a reasonably
+* small multiple of 1, e.g., 10 or 100. In particular,
+* it should not depend on the precision (single vs. double)
+* or the size of the matrix. It must be at least zero.
+*
+* NOUNIT (input) INTEGER
+* The FORTRAN unit number for printing out error messages
+* (e.g., if a routine returns INFO not equal to 0.)
+*
+* N (input) INTEGER
+* The dimension of A. N must be at least 0.
+*
+* A (input/output) DOUBLE PRECISION array, dimension (LDA, N)
+* Used to hold the matrix whose eigenvalues are to be
+* computed.
+*
+* LDA (input) INTEGER
+* The leading dimension of A, and H. LDA must be at
+* least 1 and at least N.
+*
+* H (workspace) DOUBLE PRECISION array, dimension (LDA, N)
+* Another copy of the test matrix A, modified by DGEESX.
+*
+* HT (workspace) DOUBLE PRECISION array, dimension (LDA, N)
+* Yet another copy of the test matrix A, modified by DGEESX.
+*
+* WR (workspace) DOUBLE PRECISION array, dimension (N)
+* WI (workspace) DOUBLE PRECISION array, dimension (N)
+* The real and imaginary parts of the eigenvalues of A.
+* On exit, WR + WI*i are the eigenvalues of the matrix in A.
+*
+* WRT (workspace) DOUBLE PRECISION array, dimension (N)
+* WIT (workspace) DOUBLE PRECISION array, dimension (N)
+* Like WR, WI, these arrays contain the eigenvalues of A,
+* but those computed when DGEESX only computes a partial
+* eigendecomposition, i.e. not Schur vectors
+*
+* WRTMP (workspace) DOUBLE PRECISION array, dimension (N)
+* WITMP (workspace) DOUBLE PRECISION array, dimension (N)
+* Like WR, WI, these arrays contain the eigenvalues of A,
+* but sorted by increasing real part.
+*
+* VS (workspace) DOUBLE PRECISION array, dimension (LDVS, N)
+* VS holds the computed Schur vectors.
+*
+* LDVS (input) INTEGER
+* Leading dimension of VS. Must be at least max(1, N).
+*
+* VS1 (workspace) DOUBLE PRECISION array, dimension (LDVS, N)
+* VS1 holds another copy of the computed Schur vectors.
+*
+* RCDEIN (input) DOUBLE PRECISION
+* When COMP = .TRUE. RCDEIN holds the precomputed reciprocal
+* condition number for the average of selected eigenvalues.
+*
+* RCDVIN (input) DOUBLE PRECISION
+* When COMP = .TRUE. RCDVIN holds the precomputed reciprocal
+* condition number for the selected right invariant subspace.
+*
+* NSLCT (input) INTEGER
+* When COMP = .TRUE. the number of selected eigenvalues
+* corresponding to the precomputed values RCDEIN and RCDVIN.
+*
+* ISLCT (input) INTEGER array, dimension (NSLCT)
+* When COMP = .TRUE. ISLCT selects the eigenvalues of the
+* input matrix corresponding to the precomputed values RCDEIN
+* and RCDVIN. For I=1, ... ,NSLCT, if ISLCT(I) = J, then the
+* eigenvalue with the J-th largest real part is selected.
+* Not referenced if COMP = .FALSE.
+*
+* RESULT (output) DOUBLE PRECISION array, dimension (17)
+* The values computed by the 17 tests described above.
+* The values are currently limited to 1/ulp, to avoid
+* overflow.
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK)
+*
+* LWORK (input) INTEGER
+* The number of entries in WORK to be passed to DGEESX. This
+* must be at least 3*N, and N+N**2 if tests 14--16 are to
+* be performed.
+*
+* IWORK (workspace) INTEGER array, dimension (N*N)
+*
+* BWORK (workspace) LOGICAL array, dimension (N)
+*
+* INFO (output) INTEGER
+* If 0, successful exit.
+* If <0, input parameter -INFO had an incorrect value.
+* If >0, DGEESX returned an error code, the absolute
+* value of which is returned.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
+ DOUBLE PRECISION EPSIN
+ PARAMETER ( EPSIN = 5.9605D-8 )
+* ..
+* .. Local Scalars ..
+ CHARACTER SORT
+ INTEGER I, IINFO, ISORT, ITMP, J, KMIN, KNTEIG, LIWORK,
+ $ RSUB, SDIM, SDIM1
+ DOUBLE PRECISION ANORM, EPS, RCNDE1, RCNDV1, RCONDE, RCONDV,
+ $ SMLNUM, TMP, TOL, TOLIN, ULP, ULPINV, V, VIMIN,
+ $ VRMIN, WNORM
+* ..
+* .. Local Arrays ..
+ INTEGER IPNT( 20 )
+* ..
+* .. Arrays in Common ..
+ LOGICAL SELVAL( 20 )
+ DOUBLE PRECISION SELWI( 20 ), SELWR( 20 )
+* ..
+* .. Scalars in Common ..
+ INTEGER SELDIM, SELOPT
+* ..
+* .. Common blocks ..
+ COMMON / SSLCT / SELOPT, SELDIM, SELVAL, SELWR, SELWI
+* ..
+* .. External Functions ..
+ LOGICAL DSLECT
+ DOUBLE PRECISION DLAMCH, DLANGE
+ EXTERNAL DSLECT, DLAMCH, DLANGE
+* ..
+* .. External Subroutines ..
+ EXTERNAL DCOPY, DGEESX, DGEMM, DLACPY, DORT01, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, DBLE, MAX, MIN, SIGN, SQRT
+* ..
+* .. Executable Statements ..
+*
+* Check for errors
+*
+ INFO = 0
+ IF( THRESH.LT.ZERO ) THEN
+ INFO = -3
+ ELSE IF( NOUNIT.LE.0 ) THEN
+ INFO = -5
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -6
+ ELSE IF( LDA.LT.1 .OR. LDA.LT.N ) THEN
+ INFO = -8
+ ELSE IF( LDVS.LT.1 .OR. LDVS.LT.N ) THEN
+ INFO = -18
+ ELSE IF( LWORK.LT.3*N ) THEN
+ INFO = -26
+ END IF
+*
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DGET24', -INFO )
+ RETURN
+ END IF
+*
+* Quick return if nothing to do
+*
+ DO 10 I = 1, 17
+ RESULT( I ) = -ONE
+ 10 CONTINUE
+*
+ IF( N.EQ.0 )
+ $ RETURN
+*
+* Important constants
+*
+ SMLNUM = DLAMCH( 'Safe minimum' )
+ ULP = DLAMCH( 'Precision' )
+ ULPINV = ONE / ULP
+*
+* Perform tests (1)-(13)
+*
+ SELOPT = 0
+ LIWORK = N*N
+ DO 120 ISORT = 0, 1
+ IF( ISORT.EQ.0 ) THEN
+ SORT = 'N'
+ RSUB = 0
+ ELSE
+ SORT = 'S'
+ RSUB = 6
+ END IF
+*
+* Compute Schur form and Schur vectors, and test them
+*
+ CALL DLACPY( 'F', N, N, A, LDA, H, LDA )
+ CALL DGEESX( 'V', SORT, DSLECT, 'N', N, H, LDA, SDIM, WR, WI,
+ $ VS, LDVS, RCONDE, RCONDV, WORK, LWORK, IWORK,
+ $ LIWORK, BWORK, IINFO )
+ IF( IINFO.NE.0 .AND. IINFO.NE.N+2 ) THEN
+ RESULT( 1+RSUB ) = ULPINV
+ IF( JTYPE.NE.22 ) THEN
+ WRITE( NOUNIT, FMT = 9998 )'DGEESX1', IINFO, N, JTYPE,
+ $ ISEED
+ ELSE
+ WRITE( NOUNIT, FMT = 9999 )'DGEESX1', IINFO, N,
+ $ ISEED( 1 )
+ END IF
+ INFO = ABS( IINFO )
+ RETURN
+ END IF
+ IF( ISORT.EQ.0 ) THEN
+ CALL DCOPY( N, WR, 1, WRTMP, 1 )
+ CALL DCOPY( N, WI, 1, WITMP, 1 )
+ END IF
+*
+* Do Test (1) or Test (7)
+*
+ RESULT( 1+RSUB ) = ZERO
+ DO 30 J = 1, N - 2
+ DO 20 I = J + 2, N
+ IF( H( I, J ).NE.ZERO )
+ $ RESULT( 1+RSUB ) = ULPINV
+ 20 CONTINUE
+ 30 CONTINUE
+ DO 40 I = 1, N - 2
+ IF( H( I+1, I ).NE.ZERO .AND. H( I+2, I+1 ).NE.ZERO )
+ $ RESULT( 1+RSUB ) = ULPINV
+ 40 CONTINUE
+ DO 50 I = 1, N - 1
+ IF( H( I+1, I ).NE.ZERO ) THEN
+ IF( H( I, I ).NE.H( I+1, I+1 ) .OR. H( I, I+1 ).EQ.
+ $ ZERO .OR. SIGN( ONE, H( I+1, I ) ).EQ.
+ $ SIGN( ONE, H( I, I+1 ) ) )RESULT( 1+RSUB ) = ULPINV
+ END IF
+ 50 CONTINUE
+*
+* Test (2) or (8): Compute norm(A - Q*H*Q') / (norm(A) * N * ULP)
+*
+* Copy A to VS1, used as workspace
+*
+ CALL DLACPY( ' ', N, N, A, LDA, VS1, LDVS )
+*
+* Compute Q*H and store in HT.
+*
+ CALL DGEMM( 'No transpose', 'No transpose', N, N, N, ONE, VS,
+ $ LDVS, H, LDA, ZERO, HT, LDA )
+*
+* Compute A - Q*H*Q'
+*
+ CALL DGEMM( 'No transpose', 'Transpose', N, N, N, -ONE, HT,
+ $ LDA, VS, LDVS, ONE, VS1, LDVS )
+*
+ ANORM = MAX( DLANGE( '1', N, N, A, LDA, WORK ), SMLNUM )
+ WNORM = DLANGE( '1', N, N, VS1, LDVS, WORK )
+*
+ IF( ANORM.GT.WNORM ) THEN
+ RESULT( 2+RSUB ) = ( WNORM / ANORM ) / ( N*ULP )
+ ELSE
+ IF( ANORM.LT.ONE ) THEN
+ RESULT( 2+RSUB ) = ( MIN( WNORM, N*ANORM ) / ANORM ) /
+ $ ( N*ULP )
+ ELSE
+ RESULT( 2+RSUB ) = MIN( WNORM / ANORM, DBLE( N ) ) /
+ $ ( N*ULP )
+ END IF
+ END IF
+*
+* Test (3) or (9): Compute norm( I - Q'*Q ) / ( N * ULP )
+*
+ CALL DORT01( 'Columns', N, N, VS, LDVS, WORK, LWORK,
+ $ RESULT( 3+RSUB ) )
+*
+* Do Test (4) or Test (10)
+*
+ RESULT( 4+RSUB ) = ZERO
+ DO 60 I = 1, N
+ IF( H( I, I ).NE.WR( I ) )
+ $ RESULT( 4+RSUB ) = ULPINV
+ 60 CONTINUE
+ IF( N.GT.1 ) THEN
+ IF( H( 2, 1 ).EQ.ZERO .AND. WI( 1 ).NE.ZERO )
+ $ RESULT( 4+RSUB ) = ULPINV
+ IF( H( N, N-1 ).EQ.ZERO .AND. WI( N ).NE.ZERO )
+ $ RESULT( 4+RSUB ) = ULPINV
+ END IF
+ DO 70 I = 1, N - 1
+ IF( H( I+1, I ).NE.ZERO ) THEN
+ TMP = SQRT( ABS( H( I+1, I ) ) )*
+ $ SQRT( ABS( H( I, I+1 ) ) )
+ RESULT( 4+RSUB ) = MAX( RESULT( 4+RSUB ),
+ $ ABS( WI( I )-TMP ) /
+ $ MAX( ULP*TMP, SMLNUM ) )
+ RESULT( 4+RSUB ) = MAX( RESULT( 4+RSUB ),
+ $ ABS( WI( I+1 )+TMP ) /
+ $ MAX( ULP*TMP, SMLNUM ) )
+ ELSE IF( I.GT.1 ) THEN
+ IF( H( I+1, I ).EQ.ZERO .AND. H( I, I-1 ).EQ.ZERO .AND.
+ $ WI( I ).NE.ZERO )RESULT( 4+RSUB ) = ULPINV
+ END IF
+ 70 CONTINUE
+*
+* Do Test (5) or Test (11)
+*
+ CALL DLACPY( 'F', N, N, A, LDA, HT, LDA )
+ CALL DGEESX( 'N', SORT, DSLECT, 'N', N, HT, LDA, SDIM, WRT,
+ $ WIT, VS, LDVS, RCONDE, RCONDV, WORK, LWORK, IWORK,
+ $ LIWORK, BWORK, IINFO )
+ IF( IINFO.NE.0 .AND. IINFO.NE.N+2 ) THEN
+ RESULT( 5+RSUB ) = ULPINV
+ IF( JTYPE.NE.22 ) THEN
+ WRITE( NOUNIT, FMT = 9998 )'DGEESX2', IINFO, N, JTYPE,
+ $ ISEED
+ ELSE
+ WRITE( NOUNIT, FMT = 9999 )'DGEESX2', IINFO, N,
+ $ ISEED( 1 )
+ END IF
+ INFO = ABS( IINFO )
+ GO TO 250
+ END IF
+*
+ RESULT( 5+RSUB ) = ZERO
+ DO 90 J = 1, N
+ DO 80 I = 1, N
+ IF( H( I, J ).NE.HT( I, J ) )
+ $ RESULT( 5+RSUB ) = ULPINV
+ 80 CONTINUE
+ 90 CONTINUE
+*
+* Do Test (6) or Test (12)
+*
+ RESULT( 6+RSUB ) = ZERO
+ DO 100 I = 1, N
+ IF( WR( I ).NE.WRT( I ) .OR. WI( I ).NE.WIT( I ) )
+ $ RESULT( 6+RSUB ) = ULPINV
+ 100 CONTINUE
+*
+* Do Test (13)
+*
+ IF( ISORT.EQ.1 ) THEN
+ RESULT( 13 ) = ZERO
+ KNTEIG = 0
+ DO 110 I = 1, N
+ IF( DSLECT( WR( I ), WI( I ) ) .OR.
+ $ DSLECT( WR( I ), -WI( I ) ) )KNTEIG = KNTEIG + 1
+ IF( I.LT.N ) THEN
+ IF( ( DSLECT( WR( I+1 ), WI( I+1 ) ) .OR.
+ $ DSLECT( WR( I+1 ), -WI( I+1 ) ) ) .AND.
+ $ ( .NOT.( DSLECT( WR( I ),
+ $ WI( I ) ) .OR. DSLECT( WR( I ),
+ $ -WI( I ) ) ) ) .AND. IINFO.NE.N+2 )RESULT( 13 )
+ $ = ULPINV
+ END IF
+ 110 CONTINUE
+ IF( SDIM.NE.KNTEIG )
+ $ RESULT( 13 ) = ULPINV
+ END IF
+*
+ 120 CONTINUE
+*
+* If there is enough workspace, perform tests (14) and (15)
+* as well as (10) through (13)
+*
+ IF( LWORK.GE.N+( N*N ) / 2 ) THEN
+*
+* Compute both RCONDE and RCONDV with VS
+*
+ SORT = 'S'
+ RESULT( 14 ) = ZERO
+ RESULT( 15 ) = ZERO
+ CALL DLACPY( 'F', N, N, A, LDA, HT, LDA )
+ CALL DGEESX( 'V', SORT, DSLECT, 'B', N, HT, LDA, SDIM1, WRT,
+ $ WIT, VS1, LDVS, RCONDE, RCONDV, WORK, LWORK,
+ $ IWORK, LIWORK, BWORK, IINFO )
+ IF( IINFO.NE.0 .AND. IINFO.NE.N+2 ) THEN
+ RESULT( 14 ) = ULPINV
+ RESULT( 15 ) = ULPINV
+ IF( JTYPE.NE.22 ) THEN
+ WRITE( NOUNIT, FMT = 9998 )'DGEESX3', IINFO, N, JTYPE,
+ $ ISEED
+ ELSE
+ WRITE( NOUNIT, FMT = 9999 )'DGEESX3', IINFO, N,
+ $ ISEED( 1 )
+ END IF
+ INFO = ABS( IINFO )
+ GO TO 250
+ END IF
+*
+* Perform tests (10), (11), (12), and (13)
+*
+ DO 140 I = 1, N
+ IF( WR( I ).NE.WRT( I ) .OR. WI( I ).NE.WIT( I ) )
+ $ RESULT( 10 ) = ULPINV
+ DO 130 J = 1, N
+ IF( H( I, J ).NE.HT( I, J ) )
+ $ RESULT( 11 ) = ULPINV
+ IF( VS( I, J ).NE.VS1( I, J ) )
+ $ RESULT( 12 ) = ULPINV
+ 130 CONTINUE
+ 140 CONTINUE
+ IF( SDIM.NE.SDIM1 )
+ $ RESULT( 13 ) = ULPINV
+*
+* Compute both RCONDE and RCONDV without VS, and compare
+*
+ CALL DLACPY( 'F', N, N, A, LDA, HT, LDA )
+ CALL DGEESX( 'N', SORT, DSLECT, 'B', N, HT, LDA, SDIM1, WRT,
+ $ WIT, VS1, LDVS, RCNDE1, RCNDV1, WORK, LWORK,
+ $ IWORK, LIWORK, BWORK, IINFO )
+ IF( IINFO.NE.0 .AND. IINFO.NE.N+2 ) THEN
+ RESULT( 14 ) = ULPINV
+ RESULT( 15 ) = ULPINV
+ IF( JTYPE.NE.22 ) THEN
+ WRITE( NOUNIT, FMT = 9998 )'DGEESX4', IINFO, N, JTYPE,
+ $ ISEED
+ ELSE
+ WRITE( NOUNIT, FMT = 9999 )'DGEESX4', IINFO, N,
+ $ ISEED( 1 )
+ END IF
+ INFO = ABS( IINFO )
+ GO TO 250
+ END IF
+*
+* Perform tests (14) and (15)
+*
+ IF( RCNDE1.NE.RCONDE )
+ $ RESULT( 14 ) = ULPINV
+ IF( RCNDV1.NE.RCONDV )
+ $ RESULT( 15 ) = ULPINV
+*
+* Perform tests (10), (11), (12), and (13)
+*
+ DO 160 I = 1, N
+ IF( WR( I ).NE.WRT( I ) .OR. WI( I ).NE.WIT( I ) )
+ $ RESULT( 10 ) = ULPINV
+ DO 150 J = 1, N
+ IF( H( I, J ).NE.HT( I, J ) )
+ $ RESULT( 11 ) = ULPINV
+ IF( VS( I, J ).NE.VS1( I, J ) )
+ $ RESULT( 12 ) = ULPINV
+ 150 CONTINUE
+ 160 CONTINUE
+ IF( SDIM.NE.SDIM1 )
+ $ RESULT( 13 ) = ULPINV
+*
+* Compute RCONDE with VS, and compare
+*
+ CALL DLACPY( 'F', N, N, A, LDA, HT, LDA )
+ CALL DGEESX( 'V', SORT, DSLECT, 'E', N, HT, LDA, SDIM1, WRT,
+ $ WIT, VS1, LDVS, RCNDE1, RCNDV1, WORK, LWORK,
+ $ IWORK, LIWORK, BWORK, IINFO )
+ IF( IINFO.NE.0 .AND. IINFO.NE.N+2 ) THEN
+ RESULT( 14 ) = ULPINV
+ IF( JTYPE.NE.22 ) THEN
+ WRITE( NOUNIT, FMT = 9998 )'DGEESX5', IINFO, N, JTYPE,
+ $ ISEED
+ ELSE
+ WRITE( NOUNIT, FMT = 9999 )'DGEESX5', IINFO, N,
+ $ ISEED( 1 )
+ END IF
+ INFO = ABS( IINFO )
+ GO TO 250
+ END IF
+*
+* Perform test (14)
+*
+ IF( RCNDE1.NE.RCONDE )
+ $ RESULT( 14 ) = ULPINV
+*
+* Perform tests (10), (11), (12), and (13)
+*
+ DO 180 I = 1, N
+ IF( WR( I ).NE.WRT( I ) .OR. WI( I ).NE.WIT( I ) )
+ $ RESULT( 10 ) = ULPINV
+ DO 170 J = 1, N
+ IF( H( I, J ).NE.HT( I, J ) )
+ $ RESULT( 11 ) = ULPINV
+ IF( VS( I, J ).NE.VS1( I, J ) )
+ $ RESULT( 12 ) = ULPINV
+ 170 CONTINUE
+ 180 CONTINUE
+ IF( SDIM.NE.SDIM1 )
+ $ RESULT( 13 ) = ULPINV
+*
+* Compute RCONDE without VS, and compare
+*
+ CALL DLACPY( 'F', N, N, A, LDA, HT, LDA )
+ CALL DGEESX( 'N', SORT, DSLECT, 'E', N, HT, LDA, SDIM1, WRT,
+ $ WIT, VS1, LDVS, RCNDE1, RCNDV1, WORK, LWORK,
+ $ IWORK, LIWORK, BWORK, IINFO )
+ IF( IINFO.NE.0 .AND. IINFO.NE.N+2 ) THEN
+ RESULT( 14 ) = ULPINV
+ IF( JTYPE.NE.22 ) THEN
+ WRITE( NOUNIT, FMT = 9998 )'DGEESX6', IINFO, N, JTYPE,
+ $ ISEED
+ ELSE
+ WRITE( NOUNIT, FMT = 9999 )'DGEESX6', IINFO, N,
+ $ ISEED( 1 )
+ END IF
+ INFO = ABS( IINFO )
+ GO TO 250
+ END IF
+*
+* Perform test (14)
+*
+ IF( RCNDE1.NE.RCONDE )
+ $ RESULT( 14 ) = ULPINV
+*
+* Perform tests (10), (11), (12), and (13)
+*
+ DO 200 I = 1, N
+ IF( WR( I ).NE.WRT( I ) .OR. WI( I ).NE.WIT( I ) )
+ $ RESULT( 10 ) = ULPINV
+ DO 190 J = 1, N
+ IF( H( I, J ).NE.HT( I, J ) )
+ $ RESULT( 11 ) = ULPINV
+ IF( VS( I, J ).NE.VS1( I, J ) )
+ $ RESULT( 12 ) = ULPINV
+ 190 CONTINUE
+ 200 CONTINUE
+ IF( SDIM.NE.SDIM1 )
+ $ RESULT( 13 ) = ULPINV
+*
+* Compute RCONDV with VS, and compare
+*
+ CALL DLACPY( 'F', N, N, A, LDA, HT, LDA )
+ CALL DGEESX( 'V', SORT, DSLECT, 'V', N, HT, LDA, SDIM1, WRT,
+ $ WIT, VS1, LDVS, RCNDE1, RCNDV1, WORK, LWORK,
+ $ IWORK, LIWORK, BWORK, IINFO )
+ IF( IINFO.NE.0 .AND. IINFO.NE.N+2 ) THEN
+ RESULT( 15 ) = ULPINV
+ IF( JTYPE.NE.22 ) THEN
+ WRITE( NOUNIT, FMT = 9998 )'DGEESX7', IINFO, N, JTYPE,
+ $ ISEED
+ ELSE
+ WRITE( NOUNIT, FMT = 9999 )'DGEESX7', IINFO, N,
+ $ ISEED( 1 )
+ END IF
+ INFO = ABS( IINFO )
+ GO TO 250
+ END IF
+*
+* Perform test (15)
+*
+ IF( RCNDV1.NE.RCONDV )
+ $ RESULT( 15 ) = ULPINV
+*
+* Perform tests (10), (11), (12), and (13)
+*
+ DO 220 I = 1, N
+ IF( WR( I ).NE.WRT( I ) .OR. WI( I ).NE.WIT( I ) )
+ $ RESULT( 10 ) = ULPINV
+ DO 210 J = 1, N
+ IF( H( I, J ).NE.HT( I, J ) )
+ $ RESULT( 11 ) = ULPINV
+ IF( VS( I, J ).NE.VS1( I, J ) )
+ $ RESULT( 12 ) = ULPINV
+ 210 CONTINUE
+ 220 CONTINUE
+ IF( SDIM.NE.SDIM1 )
+ $ RESULT( 13 ) = ULPINV
+*
+* Compute RCONDV without VS, and compare
+*
+ CALL DLACPY( 'F', N, N, A, LDA, HT, LDA )
+ CALL DGEESX( 'N', SORT, DSLECT, 'V', N, HT, LDA, SDIM1, WRT,
+ $ WIT, VS1, LDVS, RCNDE1, RCNDV1, WORK, LWORK,
+ $ IWORK, LIWORK, BWORK, IINFO )
+ IF( IINFO.NE.0 .AND. IINFO.NE.N+2 ) THEN
+ RESULT( 15 ) = ULPINV
+ IF( JTYPE.NE.22 ) THEN
+ WRITE( NOUNIT, FMT = 9998 )'DGEESX8', IINFO, N, JTYPE,
+ $ ISEED
+ ELSE
+ WRITE( NOUNIT, FMT = 9999 )'DGEESX8', IINFO, N,
+ $ ISEED( 1 )
+ END IF
+ INFO = ABS( IINFO )
+ GO TO 250
+ END IF
+*
+* Perform test (15)
+*
+ IF( RCNDV1.NE.RCONDV )
+ $ RESULT( 15 ) = ULPINV
+*
+* Perform tests (10), (11), (12), and (13)
+*
+ DO 240 I = 1, N
+ IF( WR( I ).NE.WRT( I ) .OR. WI( I ).NE.WIT( I ) )
+ $ RESULT( 10 ) = ULPINV
+ DO 230 J = 1, N
+ IF( H( I, J ).NE.HT( I, J ) )
+ $ RESULT( 11 ) = ULPINV
+ IF( VS( I, J ).NE.VS1( I, J ) )
+ $ RESULT( 12 ) = ULPINV
+ 230 CONTINUE
+ 240 CONTINUE
+ IF( SDIM.NE.SDIM1 )
+ $ RESULT( 13 ) = ULPINV
+*
+ END IF
+*
+ 250 CONTINUE
+*
+* If there are precomputed reciprocal condition numbers, compare
+* computed values with them.
+*
+ IF( COMP ) THEN
+*
+* First set up SELOPT, SELDIM, SELVAL, SELWR, and SELWI so that
+* the logical function DSLECT selects the eigenvalues specified
+* by NSLCT and ISLCT.
+*
+ SELDIM = N
+ SELOPT = 1
+ EPS = MAX( ULP, EPSIN )
+ DO 260 I = 1, N
+ IPNT( I ) = I
+ SELVAL( I ) = .FALSE.
+ SELWR( I ) = WRTMP( I )
+ SELWI( I ) = WITMP( I )
+ 260 CONTINUE
+ DO 280 I = 1, N - 1
+ KMIN = I
+ VRMIN = WRTMP( I )
+ VIMIN = WITMP( I )
+ DO 270 J = I + 1, N
+ IF( WRTMP( J ).LT.VRMIN ) THEN
+ KMIN = J
+ VRMIN = WRTMP( J )
+ VIMIN = WITMP( J )
+ END IF
+ 270 CONTINUE
+ WRTMP( KMIN ) = WRTMP( I )
+ WITMP( KMIN ) = WITMP( I )
+ WRTMP( I ) = VRMIN
+ WITMP( I ) = VIMIN
+ ITMP = IPNT( I )
+ IPNT( I ) = IPNT( KMIN )
+ IPNT( KMIN ) = ITMP
+ 280 CONTINUE
+ DO 290 I = 1, NSLCT
+ SELVAL( IPNT( ISLCT( I ) ) ) = .TRUE.
+ 290 CONTINUE
+*
+* Compute condition numbers
+*
+ CALL DLACPY( 'F', N, N, A, LDA, HT, LDA )
+ CALL DGEESX( 'N', 'S', DSLECT, 'B', N, HT, LDA, SDIM1, WRT,
+ $ WIT, VS1, LDVS, RCONDE, RCONDV, WORK, LWORK,
+ $ IWORK, LIWORK, BWORK, IINFO )
+ IF( IINFO.NE.0 .AND. IINFO.NE.N+2 ) THEN
+ RESULT( 16 ) = ULPINV
+ RESULT( 17 ) = ULPINV
+ WRITE( NOUNIT, FMT = 9999 )'DGEESX9', IINFO, N, ISEED( 1 )
+ INFO = ABS( IINFO )
+ GO TO 300
+ END IF
+*
+* Compare condition number for average of selected eigenvalues
+* taking its condition number into account
+*
+ ANORM = DLANGE( '1', N, N, A, LDA, WORK )
+ V = MAX( DBLE( N )*EPS*ANORM, SMLNUM )
+ IF( ANORM.EQ.ZERO )
+ $ V = ONE
+ IF( V.GT.RCONDV ) THEN
+ TOL = ONE
+ ELSE
+ TOL = V / RCONDV
+ END IF
+ IF( V.GT.RCDVIN ) THEN
+ TOLIN = ONE
+ ELSE
+ TOLIN = V / RCDVIN
+ END IF
+ TOL = MAX( TOL, SMLNUM / EPS )
+ TOLIN = MAX( TOLIN, SMLNUM / EPS )
+ IF( EPS*( RCDEIN-TOLIN ).GT.RCONDE+TOL ) THEN
+ RESULT( 16 ) = ULPINV
+ ELSE IF( RCDEIN-TOLIN.GT.RCONDE+TOL ) THEN
+ RESULT( 16 ) = ( RCDEIN-TOLIN ) / ( RCONDE+TOL )
+ ELSE IF( RCDEIN+TOLIN.LT.EPS*( RCONDE-TOL ) ) THEN
+ RESULT( 16 ) = ULPINV
+ ELSE IF( RCDEIN+TOLIN.LT.RCONDE-TOL ) THEN
+ RESULT( 16 ) = ( RCONDE-TOL ) / ( RCDEIN+TOLIN )
+ ELSE
+ RESULT( 16 ) = ONE
+ END IF
+*
+* Compare condition numbers for right invariant subspace
+* taking its condition number into account
+*
+ IF( V.GT.RCONDV*RCONDE ) THEN
+ TOL = RCONDV
+ ELSE
+ TOL = V / RCONDE
+ END IF
+ IF( V.GT.RCDVIN*RCDEIN ) THEN
+ TOLIN = RCDVIN
+ ELSE
+ TOLIN = V / RCDEIN
+ END IF
+ TOL = MAX( TOL, SMLNUM / EPS )
+ TOLIN = MAX( TOLIN, SMLNUM / EPS )
+ IF( EPS*( RCDVIN-TOLIN ).GT.RCONDV+TOL ) THEN
+ RESULT( 17 ) = ULPINV
+ ELSE IF( RCDVIN-TOLIN.GT.RCONDV+TOL ) THEN
+ RESULT( 17 ) = ( RCDVIN-TOLIN ) / ( RCONDV+TOL )
+ ELSE IF( RCDVIN+TOLIN.LT.EPS*( RCONDV-TOL ) ) THEN
+ RESULT( 17 ) = ULPINV
+ ELSE IF( RCDVIN+TOLIN.LT.RCONDV-TOL ) THEN
+ RESULT( 17 ) = ( RCONDV-TOL ) / ( RCDVIN+TOLIN )
+ ELSE
+ RESULT( 17 ) = ONE
+ END IF
+*
+ 300 CONTINUE
+*
+ END IF
+*
+ 9999 FORMAT( ' DGET24: ', A, ' returned INFO=', I6, '.', / 9X, 'N=',
+ $ I6, ', INPUT EXAMPLE NUMBER = ', I4 )
+ 9998 FORMAT( ' DGET24: ', A, ' returned INFO=', I6, '.', / 9X, 'N=',
+ $ I6, ', JTYPE=', I6, ', ISEED=(', 3( I5, ',' ), I5, ')' )
+*
+ RETURN
+*
+* End of DGET24
+*
+ END
+ SUBROUTINE DGET31( RMAX, LMAX, NINFO, KNT )
+*
+* -- LAPACK test routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER KNT, LMAX
+ DOUBLE PRECISION RMAX
+* ..
+* .. Array Arguments ..
+ INTEGER NINFO( 2 )
+* ..
+*
+* Purpose
+* =======
+*
+* DGET31 tests DLALN2, a routine for solving
+*
+* (ca A - w D)X = sB
+*
+* where A is an NA by NA matrix (NA=1 or 2 only), w is a real (NW=1) or
+* complex (NW=2) constant, ca is a real constant, D is an NA by NA real
+* diagonal matrix, and B is an NA by NW matrix (when NW=2 the second
+* column of B contains the imaginary part of the solution). The code
+* returns X and s, where s is a scale factor, less than or equal to 1,
+* which is chosen to avoid overflow in X.
+*
+* If any singular values of ca A-w D are less than another input
+* parameter SMIN, they are perturbed up to SMIN.
+*
+* The test condition is that the scaled residual
+*
+* norm( (ca A-w D)*X - s*B ) /
+* ( max( ulp*norm(ca A-w D), SMIN )*norm(X) )
+*
+* should be on the order of 1. Here, ulp is the machine precision.
+* Also, it is verified that SCALE is less than or equal to 1, and that
+* XNORM = infinity-norm(X).
+*
+* Arguments
+* ==========
+*
+* RMAX (output) DOUBLE PRECISION
+* Value of the largest test ratio.
+*
+* LMAX (output) INTEGER
+* Example number where largest test ratio achieved.
+*
+* NINFO (output) INTEGER array, dimension (3)
+* NINFO(1) = number of examples with INFO less than 0
+* NINFO(2) = number of examples with INFO greater than 0
+*
+* KNT (output) INTEGER
+* Total number of examples tested.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, HALF, ONE
+ PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0 )
+ DOUBLE PRECISION TWO, THREE, FOUR
+ PARAMETER ( TWO = 2.0D0, THREE = 3.0D0, FOUR = 4.0D0 )
+ DOUBLE PRECISION SEVEN, TEN
+ PARAMETER ( SEVEN = 7.0D0, TEN = 10.0D0 )
+ DOUBLE PRECISION TWNONE
+ PARAMETER ( TWNONE = 21.0D0 )
+* ..
+* .. Local Scalars ..
+ INTEGER IA, IB, ICA, ID1, ID2, INFO, ISMIN, ITRANS,
+ $ IWI, IWR, NA, NW
+ DOUBLE PRECISION BIGNUM, CA, D1, D2, DEN, EPS, RES, SCALE, SMIN,
+ $ SMLNUM, TMP, UNFL, WI, WR, XNORM
+* ..
+* .. Local Arrays ..
+ LOGICAL LTRANS( 0: 1 )
+ DOUBLE PRECISION A( 2, 2 ), B( 2, 2 ), VAB( 3 ), VCA( 5 ),
+ $ VDD( 4 ), VSMIN( 4 ), VWI( 4 ), VWR( 4 ),
+ $ X( 2, 2 )
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DLAMCH
+ EXTERNAL DLAMCH
+* ..
+* .. External Subroutines ..
+ EXTERNAL DLABAD, DLALN2
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, SQRT
+* ..
+* .. Data statements ..
+ DATA LTRANS / .FALSE., .TRUE. /
+* ..
+* .. Executable Statements ..
+*
+* Get machine parameters
+*
+ EPS = DLAMCH( 'P' )
+ UNFL = DLAMCH( 'U' )
+ SMLNUM = DLAMCH( 'S' ) / EPS
+ BIGNUM = ONE / SMLNUM
+ CALL DLABAD( SMLNUM, BIGNUM )
+*
+* Set up test case parameters
+*
+ VSMIN( 1 ) = SMLNUM
+ VSMIN( 2 ) = EPS
+ VSMIN( 3 ) = ONE / ( TEN*TEN )
+ VSMIN( 4 ) = ONE / EPS
+ VAB( 1 ) = SQRT( SMLNUM )
+ VAB( 2 ) = ONE
+ VAB( 3 ) = SQRT( BIGNUM )
+ VWR( 1 ) = ZERO
+ VWR( 2 ) = HALF
+ VWR( 3 ) = TWO
+ VWR( 4 ) = ONE
+ VWI( 1 ) = SMLNUM
+ VWI( 2 ) = EPS
+ VWI( 3 ) = ONE
+ VWI( 4 ) = TWO
+ VDD( 1 ) = SQRT( SMLNUM )
+ VDD( 2 ) = ONE
+ VDD( 3 ) = TWO
+ VDD( 4 ) = SQRT( BIGNUM )
+ VCA( 1 ) = ZERO
+ VCA( 2 ) = SQRT( SMLNUM )
+ VCA( 3 ) = EPS
+ VCA( 4 ) = HALF
+ VCA( 5 ) = ONE
+*
+ KNT = 0
+ NINFO( 1 ) = 0
+ NINFO( 2 ) = 0
+ LMAX = 0
+ RMAX = ZERO
+*
+* Begin test loop
+*
+ DO 190 ID1 = 1, 4
+ D1 = VDD( ID1 )
+ DO 180 ID2 = 1, 4
+ D2 = VDD( ID2 )
+ DO 170 ICA = 1, 5
+ CA = VCA( ICA )
+ DO 160 ITRANS = 0, 1
+ DO 150 ISMIN = 1, 4
+ SMIN = VSMIN( ISMIN )
+*
+ NA = 1
+ NW = 1
+ DO 30 IA = 1, 3
+ A( 1, 1 ) = VAB( IA )
+ DO 20 IB = 1, 3
+ B( 1, 1 ) = VAB( IB )
+ DO 10 IWR = 1, 4
+ IF( D1.EQ.ONE .AND. D2.EQ.ONE .AND. CA.EQ.
+ $ ONE ) THEN
+ WR = VWR( IWR )*A( 1, 1 )
+ ELSE
+ WR = VWR( IWR )
+ END IF
+ WI = ZERO
+ CALL DLALN2( LTRANS( ITRANS ), NA, NW,
+ $ SMIN, CA, A, 2, D1, D2, B, 2,
+ $ WR, WI, X, 2, SCALE, XNORM,
+ $ INFO )
+ IF( INFO.LT.0 )
+ $ NINFO( 1 ) = NINFO( 1 ) + 1
+ IF( INFO.GT.0 )
+ $ NINFO( 2 ) = NINFO( 2 ) + 1
+ RES = ABS( ( CA*A( 1, 1 )-WR*D1 )*
+ $ X( 1, 1 )-SCALE*B( 1, 1 ) )
+ IF( INFO.EQ.0 ) THEN
+ DEN = MAX( EPS*( ABS( ( CA*A( 1,
+ $ 1 )-WR*D1 )*X( 1, 1 ) ) ),
+ $ SMLNUM )
+ ELSE
+ DEN = MAX( SMIN*ABS( X( 1, 1 ) ),
+ $ SMLNUM )
+ END IF
+ RES = RES / DEN
+ IF( ABS( X( 1, 1 ) ).LT.UNFL .AND.
+ $ ABS( B( 1, 1 ) ).LE.SMLNUM*
+ $ ABS( CA*A( 1, 1 )-WR*D1 ) )RES = ZERO
+ IF( SCALE.GT.ONE )
+ $ RES = RES + ONE / EPS
+ RES = RES + ABS( XNORM-ABS( X( 1, 1 ) ) )
+ $ / MAX( SMLNUM, XNORM ) / EPS
+ IF( INFO.NE.0 .AND. INFO.NE.1 )
+ $ RES = RES + ONE / EPS
+ KNT = KNT + 1
+ IF( RES.GT.RMAX ) THEN
+ LMAX = KNT
+ RMAX = RES
+ END IF
+ 10 CONTINUE
+ 20 CONTINUE
+ 30 CONTINUE
+*
+ NA = 1
+ NW = 2
+ DO 70 IA = 1, 3
+ A( 1, 1 ) = VAB( IA )
+ DO 60 IB = 1, 3
+ B( 1, 1 ) = VAB( IB )
+ B( 1, 2 ) = -HALF*VAB( IB )
+ DO 50 IWR = 1, 4
+ IF( D1.EQ.ONE .AND. D2.EQ.ONE .AND. CA.EQ.
+ $ ONE ) THEN
+ WR = VWR( IWR )*A( 1, 1 )
+ ELSE
+ WR = VWR( IWR )
+ END IF
+ DO 40 IWI = 1, 4
+ IF( D1.EQ.ONE .AND. D2.EQ.ONE .AND.
+ $ CA.EQ.ONE ) THEN
+ WI = VWI( IWI )*A( 1, 1 )
+ ELSE
+ WI = VWI( IWI )
+ END IF
+ CALL DLALN2( LTRANS( ITRANS ), NA, NW,
+ $ SMIN, CA, A, 2, D1, D2, B,
+ $ 2, WR, WI, X, 2, SCALE,
+ $ XNORM, INFO )
+ IF( INFO.LT.0 )
+ $ NINFO( 1 ) = NINFO( 1 ) + 1
+ IF( INFO.GT.0 )
+ $ NINFO( 2 ) = NINFO( 2 ) + 1
+ RES = ABS( ( CA*A( 1, 1 )-WR*D1 )*
+ $ X( 1, 1 )+( WI*D1 )*X( 1, 2 )-
+ $ SCALE*B( 1, 1 ) )
+ RES = RES + ABS( ( -WI*D1 )*X( 1, 1 )+
+ $ ( CA*A( 1, 1 )-WR*D1 )*X( 1, 2 )-
+ $ SCALE*B( 1, 2 ) )
+ IF( INFO.EQ.0 ) THEN
+ DEN = MAX( EPS*( MAX( ABS( CA*A( 1,
+ $ 1 )-WR*D1 ), ABS( D1*WI ) )*
+ $ ( ABS( X( 1, 1 ) )+ABS( X( 1,
+ $ 2 ) ) ) ), SMLNUM )
+ ELSE
+ DEN = MAX( SMIN*( ABS( X( 1,
+ $ 1 ) )+ABS( X( 1, 2 ) ) ),
+ $ SMLNUM )
+ END IF
+ RES = RES / DEN
+ IF( ABS( X( 1, 1 ) ).LT.UNFL .AND.
+ $ ABS( X( 1, 2 ) ).LT.UNFL .AND.
+ $ ABS( B( 1, 1 ) ).LE.SMLNUM*
+ $ ABS( CA*A( 1, 1 )-WR*D1 ) )
+ $ RES = ZERO
+ IF( SCALE.GT.ONE )
+ $ RES = RES + ONE / EPS
+ RES = RES + ABS( XNORM-
+ $ ABS( X( 1, 1 ) )-
+ $ ABS( X( 1, 2 ) ) ) /
+ $ MAX( SMLNUM, XNORM ) / EPS
+ IF( INFO.NE.0 .AND. INFO.NE.1 )
+ $ RES = RES + ONE / EPS
+ KNT = KNT + 1
+ IF( RES.GT.RMAX ) THEN
+ LMAX = KNT
+ RMAX = RES
+ END IF
+ 40 CONTINUE
+ 50 CONTINUE
+ 60 CONTINUE
+ 70 CONTINUE
+*
+ NA = 2
+ NW = 1
+ DO 100 IA = 1, 3
+ A( 1, 1 ) = VAB( IA )
+ A( 1, 2 ) = -THREE*VAB( IA )
+ A( 2, 1 ) = -SEVEN*VAB( IA )
+ A( 2, 2 ) = TWNONE*VAB( IA )
+ DO 90 IB = 1, 3
+ B( 1, 1 ) = VAB( IB )
+ B( 2, 1 ) = -TWO*VAB( IB )
+ DO 80 IWR = 1, 4
+ IF( D1.EQ.ONE .AND. D2.EQ.ONE .AND. CA.EQ.
+ $ ONE ) THEN
+ WR = VWR( IWR )*A( 1, 1 )
+ ELSE
+ WR = VWR( IWR )
+ END IF
+ WI = ZERO
+ CALL DLALN2( LTRANS( ITRANS ), NA, NW,
+ $ SMIN, CA, A, 2, D1, D2, B, 2,
+ $ WR, WI, X, 2, SCALE, XNORM,
+ $ INFO )
+ IF( INFO.LT.0 )
+ $ NINFO( 1 ) = NINFO( 1 ) + 1
+ IF( INFO.GT.0 )
+ $ NINFO( 2 ) = NINFO( 2 ) + 1
+ IF( ITRANS.EQ.1 ) THEN
+ TMP = A( 1, 2 )
+ A( 1, 2 ) = A( 2, 1 )
+ A( 2, 1 ) = TMP
+ END IF
+ RES = ABS( ( CA*A( 1, 1 )-WR*D1 )*
+ $ X( 1, 1 )+( CA*A( 1, 2 ) )*
+ $ X( 2, 1 )-SCALE*B( 1, 1 ) )
+ RES = RES + ABS( ( CA*A( 2, 1 ) )*
+ $ X( 1, 1 )+( CA*A( 2, 2 )-WR*D2 )*
+ $ X( 2, 1 )-SCALE*B( 2, 1 ) )
+ IF( INFO.EQ.0 ) THEN
+ DEN = MAX( EPS*( MAX( ABS( CA*A( 1,
+ $ 1 )-WR*D1 )+ABS( CA*A( 1, 2 ) ),
+ $ ABS( CA*A( 2, 1 ) )+ABS( CA*A( 2,
+ $ 2 )-WR*D2 ) )*MAX( ABS( X( 1,
+ $ 1 ) ), ABS( X( 2, 1 ) ) ) ),
+ $ SMLNUM )
+ ELSE
+ DEN = MAX( EPS*( MAX( SMIN / EPS,
+ $ MAX( ABS( CA*A( 1,
+ $ 1 )-WR*D1 )+ABS( CA*A( 1, 2 ) ),
+ $ ABS( CA*A( 2, 1 ) )+ABS( CA*A( 2,
+ $ 2 )-WR*D2 ) ) )*MAX( ABS( X( 1,
+ $ 1 ) ), ABS( X( 2, 1 ) ) ) ),
+ $ SMLNUM )
+ END IF
+ RES = RES / DEN
+ IF( ABS( X( 1, 1 ) ).LT.UNFL .AND.
+ $ ABS( X( 2, 1 ) ).LT.UNFL .AND.
+ $ ABS( B( 1, 1 ) )+ABS( B( 2, 1 ) ).LE.
+ $ SMLNUM*( ABS( CA*A( 1,
+ $ 1 )-WR*D1 )+ABS( CA*A( 1,
+ $ 2 ) )+ABS( CA*A( 2,
+ $ 1 ) )+ABS( CA*A( 2, 2 )-WR*D2 ) ) )
+ $ RES = ZERO
+ IF( SCALE.GT.ONE )
+ $ RES = RES + ONE / EPS
+ RES = RES + ABS( XNORM-
+ $ MAX( ABS( X( 1, 1 ) ), ABS( X( 2,
+ $ 1 ) ) ) ) / MAX( SMLNUM, XNORM ) /
+ $ EPS
+ IF( INFO.NE.0 .AND. INFO.NE.1 )
+ $ RES = RES + ONE / EPS
+ KNT = KNT + 1
+ IF( RES.GT.RMAX ) THEN
+ LMAX = KNT
+ RMAX = RES
+ END IF
+ 80 CONTINUE
+ 90 CONTINUE
+ 100 CONTINUE
+*
+ NA = 2
+ NW = 2
+ DO 140 IA = 1, 3
+ A( 1, 1 ) = VAB( IA )*TWO
+ A( 1, 2 ) = -THREE*VAB( IA )
+ A( 2, 1 ) = -SEVEN*VAB( IA )
+ A( 2, 2 ) = TWNONE*VAB( IA )
+ DO 130 IB = 1, 3
+ B( 1, 1 ) = VAB( IB )
+ B( 2, 1 ) = -TWO*VAB( IB )
+ B( 1, 2 ) = FOUR*VAB( IB )
+ B( 2, 2 ) = -SEVEN*VAB( IB )
+ DO 120 IWR = 1, 4
+ IF( D1.EQ.ONE .AND. D2.EQ.ONE .AND. CA.EQ.
+ $ ONE ) THEN
+ WR = VWR( IWR )*A( 1, 1 )
+ ELSE
+ WR = VWR( IWR )
+ END IF
+ DO 110 IWI = 1, 4
+ IF( D1.EQ.ONE .AND. D2.EQ.ONE .AND.
+ $ CA.EQ.ONE ) THEN
+ WI = VWI( IWI )*A( 1, 1 )
+ ELSE
+ WI = VWI( IWI )
+ END IF
+ CALL DLALN2( LTRANS( ITRANS ), NA, NW,
+ $ SMIN, CA, A, 2, D1, D2, B,
+ $ 2, WR, WI, X, 2, SCALE,
+ $ XNORM, INFO )
+ IF( INFO.LT.0 )
+ $ NINFO( 1 ) = NINFO( 1 ) + 1
+ IF( INFO.GT.0 )
+ $ NINFO( 2 ) = NINFO( 2 ) + 1
+ IF( ITRANS.EQ.1 ) THEN
+ TMP = A( 1, 2 )
+ A( 1, 2 ) = A( 2, 1 )
+ A( 2, 1 ) = TMP
+ END IF
+ RES = ABS( ( CA*A( 1, 1 )-WR*D1 )*
+ $ X( 1, 1 )+( CA*A( 1, 2 ) )*
+ $ X( 2, 1 )+( WI*D1 )*X( 1, 2 )-
+ $ SCALE*B( 1, 1 ) )
+ RES = RES + ABS( ( CA*A( 1,
+ $ 1 )-WR*D1 )*X( 1, 2 )+
+ $ ( CA*A( 1, 2 ) )*X( 2, 2 )-
+ $ ( WI*D1 )*X( 1, 1 )-SCALE*
+ $ B( 1, 2 ) )
+ RES = RES + ABS( ( CA*A( 2, 1 ) )*
+ $ X( 1, 1 )+( CA*A( 2, 2 )-WR*D2 )*
+ $ X( 2, 1 )+( WI*D2 )*X( 2, 2 )-
+ $ SCALE*B( 2, 1 ) )
+ RES = RES + ABS( ( CA*A( 2, 1 ) )*
+ $ X( 1, 2 )+( CA*A( 2, 2 )-WR*D2 )*
+ $ X( 2, 2 )-( WI*D2 )*X( 2, 1 )-
+ $ SCALE*B( 2, 2 ) )
+ IF( INFO.EQ.0 ) THEN
+ DEN = MAX( EPS*( MAX( ABS( CA*A( 1,
+ $ 1 )-WR*D1 )+ABS( CA*A( 1,
+ $ 2 ) )+ABS( WI*D1 ),
+ $ ABS( CA*A( 2,
+ $ 1 ) )+ABS( CA*A( 2,
+ $ 2 )-WR*D2 )+ABS( WI*D2 ) )*
+ $ MAX( ABS( X( 1,
+ $ 1 ) )+ABS( X( 2, 1 ) ),
+ $ ABS( X( 1, 2 ) )+ABS( X( 2,
+ $ 2 ) ) ) ), SMLNUM )
+ ELSE
+ DEN = MAX( EPS*( MAX( SMIN / EPS,
+ $ MAX( ABS( CA*A( 1,
+ $ 1 )-WR*D1 )+ABS( CA*A( 1,
+ $ 2 ) )+ABS( WI*D1 ),
+ $ ABS( CA*A( 2,
+ $ 1 ) )+ABS( CA*A( 2,
+ $ 2 )-WR*D2 )+ABS( WI*D2 ) ) )*
+ $ MAX( ABS( X( 1,
+ $ 1 ) )+ABS( X( 2, 1 ) ),
+ $ ABS( X( 1, 2 ) )+ABS( X( 2,
+ $ 2 ) ) ) ), SMLNUM )
+ END IF
+ RES = RES / DEN
+ IF( ABS( X( 1, 1 ) ).LT.UNFL .AND.
+ $ ABS( X( 2, 1 ) ).LT.UNFL .AND.
+ $ ABS( X( 1, 2 ) ).LT.UNFL .AND.
+ $ ABS( X( 2, 2 ) ).LT.UNFL .AND.
+ $ ABS( B( 1, 1 ) )+
+ $ ABS( B( 2, 1 ) ).LE.SMLNUM*
+ $ ( ABS( CA*A( 1, 1 )-WR*D1 )+
+ $ ABS( CA*A( 1, 2 ) )+ABS( CA*A( 2,
+ $ 1 ) )+ABS( CA*A( 2,
+ $ 2 )-WR*D2 )+ABS( WI*D2 )+ABS( WI*
+ $ D1 ) ) )RES = ZERO
+ IF( SCALE.GT.ONE )
+ $ RES = RES + ONE / EPS
+ RES = RES + ABS( XNORM-
+ $ MAX( ABS( X( 1, 1 ) )+ABS( X( 1,
+ $ 2 ) ), ABS( X( 2,
+ $ 1 ) )+ABS( X( 2, 2 ) ) ) ) /
+ $ MAX( SMLNUM, XNORM ) / EPS
+ IF( INFO.NE.0 .AND. INFO.NE.1 )
+ $ RES = RES + ONE / EPS
+ KNT = KNT + 1
+ IF( RES.GT.RMAX ) THEN
+ LMAX = KNT
+ RMAX = RES
+ END IF
+ 110 CONTINUE
+ 120 CONTINUE
+ 130 CONTINUE
+ 140 CONTINUE
+ 150 CONTINUE
+ 160 CONTINUE
+ 170 CONTINUE
+ 180 CONTINUE
+ 190 CONTINUE
+*
+ RETURN
+*
+* End of DGET31
+*
+ END
+ SUBROUTINE DGET32( RMAX, LMAX, NINFO, KNT )
+*
+* -- LAPACK test routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER KNT, LMAX, NINFO
+ DOUBLE PRECISION RMAX
+* ..
+*
+* Purpose
+* =======
+*
+* DGET32 tests DLASY2, a routine for solving
+*
+* op(TL)*X + ISGN*X*op(TR) = SCALE*B
+*
+* where TL is N1 by N1, TR is N2 by N2, and N1,N2 =1 or 2 only.
+* X and B are N1 by N2, op() is an optional transpose, an
+* ISGN = 1 or -1. SCALE is chosen less than or equal to 1 to
+* avoid overflow in X.
+*
+* The test condition is that the scaled residual
+*
+* norm( op(TL)*X + ISGN*X*op(TR) = SCALE*B )
+* / ( max( ulp*norm(TL), ulp*norm(TR)) * norm(X), SMLNUM )
+*
+* should be on the order of 1. Here, ulp is the machine precision.
+* Also, it is verified that SCALE is less than or equal to 1, and
+* that XNORM = infinity-norm(X).
+*
+* Arguments
+* ==========
+*
+* RMAX (output) DOUBLE PRECISION
+* Value of the largest test ratio.
+*
+* LMAX (output) INTEGER
+* Example number where largest test ratio achieved.
+*
+* NINFO (output) INTEGER
+* Number of examples returned with INFO.NE.0.
+*
+* KNT (output) INTEGER
+* Total number of examples tested.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
+ DOUBLE PRECISION TWO, FOUR, EIGHT
+ PARAMETER ( TWO = 2.0D0, FOUR = 4.0D0, EIGHT = 8.0D0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL LTRANL, LTRANR
+ INTEGER IB, IB1, IB2, IB3, INFO, ISGN, ITL, ITLSCL,
+ $ ITR, ITRANL, ITRANR, ITRSCL, N1, N2
+ DOUBLE PRECISION BIGNUM, DEN, EPS, RES, SCALE, SGN, SMLNUM, TMP,
+ $ TNRM, XNORM, XNRM
+* ..
+* .. Local Arrays ..
+ INTEGER ITVAL( 2, 2, 8 )
+ DOUBLE PRECISION B( 2, 2 ), TL( 2, 2 ), TR( 2, 2 ), VAL( 3 ),
+ $ X( 2, 2 )
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DLAMCH
+ EXTERNAL DLAMCH
+* ..
+* .. External Subroutines ..
+ EXTERNAL DLABAD, DLASY2
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, MIN, SQRT
+* ..
+* .. Data statements ..
+ DATA ITVAL / 8, 4, 2, 1, 4, 8, 1, 2, 2, 1, 8, 4, 1,
+ $ 2, 4, 8, 9, 4, 2, 1, 4, 9, 1, 2, 2, 1, 9, 4, 1,
+ $ 2, 4, 9 /
+* ..
+* .. Executable Statements ..
+*
+* Get machine parameters
+*
+ EPS = DLAMCH( 'P' )
+ SMLNUM = DLAMCH( 'S' ) / EPS
+ BIGNUM = ONE / SMLNUM
+ CALL DLABAD( SMLNUM, BIGNUM )
+*
+* Set up test case parameters
+*
+ VAL( 1 ) = SQRT( SMLNUM )
+ VAL( 2 ) = ONE
+ VAL( 3 ) = SQRT( BIGNUM )
+*
+ KNT = 0
+ NINFO = 0
+ LMAX = 0
+ RMAX = ZERO
+*
+* Begin test loop
+*
+ DO 230 ITRANL = 0, 1
+ DO 220 ITRANR = 0, 1
+ DO 210 ISGN = -1, 1, 2
+ SGN = ISGN
+ LTRANL = ITRANL.EQ.1
+ LTRANR = ITRANR.EQ.1
+*
+ N1 = 1
+ N2 = 1
+ DO 30 ITL = 1, 3
+ DO 20 ITR = 1, 3
+ DO 10 IB = 1, 3
+ TL( 1, 1 ) = VAL( ITL )
+ TR( 1, 1 ) = VAL( ITR )
+ B( 1, 1 ) = VAL( IB )
+ KNT = KNT + 1
+ CALL DLASY2( LTRANL, LTRANR, ISGN, N1, N2, TL,
+ $ 2, TR, 2, B, 2, SCALE, X, 2, XNORM,
+ $ INFO )
+ IF( INFO.NE.0 )
+ $ NINFO = NINFO + 1
+ RES = ABS( ( TL( 1, 1 )+SGN*TR( 1, 1 ) )*
+ $ X( 1, 1 )-SCALE*B( 1, 1 ) )
+ IF( INFO.EQ.0 ) THEN
+ DEN = MAX( EPS*( ( ABS( TR( 1,
+ $ 1 ) )+ABS( TL( 1, 1 ) ) )*ABS( X( 1,
+ $ 1 ) ) ), SMLNUM )
+ ELSE
+ DEN = SMLNUM*MAX( ABS( X( 1, 1 ) ), ONE )
+ END IF
+ RES = RES / DEN
+ IF( SCALE.GT.ONE )
+ $ RES = RES + ONE / EPS
+ RES = RES + ABS( XNORM-ABS( X( 1, 1 ) ) ) /
+ $ MAX( SMLNUM, XNORM ) / EPS
+ IF( INFO.NE.0 .AND. INFO.NE.1 )
+ $ RES = RES + ONE / EPS
+ IF( RES.GT.RMAX ) THEN
+ LMAX = KNT
+ RMAX = RES
+ END IF
+ 10 CONTINUE
+ 20 CONTINUE
+ 30 CONTINUE
+*
+ N1 = 2
+ N2 = 1
+ DO 80 ITL = 1, 8
+ DO 70 ITLSCL = 1, 3
+ DO 60 ITR = 1, 3
+ DO 50 IB1 = 1, 3
+ DO 40 IB2 = 1, 3
+ B( 1, 1 ) = VAL( IB1 )
+ B( 2, 1 ) = -FOUR*VAL( IB2 )
+ TL( 1, 1 ) = ITVAL( 1, 1, ITL )*
+ $ VAL( ITLSCL )
+ TL( 2, 1 ) = ITVAL( 2, 1, ITL )*
+ $ VAL( ITLSCL )
+ TL( 1, 2 ) = ITVAL( 1, 2, ITL )*
+ $ VAL( ITLSCL )
+ TL( 2, 2 ) = ITVAL( 2, 2, ITL )*
+ $ VAL( ITLSCL )
+ TR( 1, 1 ) = VAL( ITR )
+ KNT = KNT + 1
+ CALL DLASY2( LTRANL, LTRANR, ISGN, N1, N2,
+ $ TL, 2, TR, 2, B, 2, SCALE, X,
+ $ 2, XNORM, INFO )
+ IF( INFO.NE.0 )
+ $ NINFO = NINFO + 1
+ IF( LTRANL ) THEN
+ TMP = TL( 1, 2 )
+ TL( 1, 2 ) = TL( 2, 1 )
+ TL( 2, 1 ) = TMP
+ END IF
+ RES = ABS( ( TL( 1, 1 )+SGN*TR( 1, 1 ) )*
+ $ X( 1, 1 )+TL( 1, 2 )*X( 2, 1 )-
+ $ SCALE*B( 1, 1 ) )
+ RES = RES + ABS( ( TL( 2, 2 )+SGN*TR( 1,
+ $ 1 ) )*X( 2, 1 )+TL( 2, 1 )*
+ $ X( 1, 1 )-SCALE*B( 2, 1 ) )
+ TNRM = ABS( TR( 1, 1 ) ) +
+ $ ABS( TL( 1, 1 ) ) +
+ $ ABS( TL( 1, 2 ) ) +
+ $ ABS( TL( 2, 1 ) ) +
+ $ ABS( TL( 2, 2 ) )
+ XNRM = MAX( ABS( X( 1, 1 ) ),
+ $ ABS( X( 2, 1 ) ) )
+ DEN = MAX( SMLNUM, SMLNUM*XNRM,
+ $ ( TNRM*EPS )*XNRM )
+ RES = RES / DEN
+ IF( SCALE.GT.ONE )
+ $ RES = RES + ONE / EPS
+ RES = RES + ABS( XNORM-XNRM ) /
+ $ MAX( SMLNUM, XNORM ) / EPS
+ IF( RES.GT.RMAX ) THEN
+ LMAX = KNT
+ RMAX = RES
+ END IF
+ 40 CONTINUE
+ 50 CONTINUE
+ 60 CONTINUE
+ 70 CONTINUE
+ 80 CONTINUE
+*
+ N1 = 1
+ N2 = 2
+ DO 130 ITR = 1, 8
+ DO 120 ITRSCL = 1, 3
+ DO 110 ITL = 1, 3
+ DO 100 IB1 = 1, 3
+ DO 90 IB2 = 1, 3
+ B( 1, 1 ) = VAL( IB1 )
+ B( 1, 2 ) = -TWO*VAL( IB2 )
+ TR( 1, 1 ) = ITVAL( 1, 1, ITR )*
+ $ VAL( ITRSCL )
+ TR( 2, 1 ) = ITVAL( 2, 1, ITR )*
+ $ VAL( ITRSCL )
+ TR( 1, 2 ) = ITVAL( 1, 2, ITR )*
+ $ VAL( ITRSCL )
+ TR( 2, 2 ) = ITVAL( 2, 2, ITR )*
+ $ VAL( ITRSCL )
+ TL( 1, 1 ) = VAL( ITL )
+ KNT = KNT + 1
+ CALL DLASY2( LTRANL, LTRANR, ISGN, N1, N2,
+ $ TL, 2, TR, 2, B, 2, SCALE, X,
+ $ 2, XNORM, INFO )
+ IF( INFO.NE.0 )
+ $ NINFO = NINFO + 1
+ IF( LTRANR ) THEN
+ TMP = TR( 1, 2 )
+ TR( 1, 2 ) = TR( 2, 1 )
+ TR( 2, 1 ) = TMP
+ END IF
+ TNRM = ABS( TL( 1, 1 ) ) +
+ $ ABS( TR( 1, 1 ) ) +
+ $ ABS( TR( 1, 2 ) ) +
+ $ ABS( TR( 2, 2 ) ) +
+ $ ABS( TR( 2, 1 ) )
+ XNRM = ABS( X( 1, 1 ) ) + ABS( X( 1, 2 ) )
+ RES = ABS( ( ( TL( 1, 1 )+SGN*TR( 1,
+ $ 1 ) ) )*( X( 1, 1 ) )+
+ $ ( SGN*TR( 2, 1 ) )*( X( 1, 2 ) )-
+ $ ( SCALE*B( 1, 1 ) ) )
+ RES = RES + ABS( ( ( TL( 1, 1 )+SGN*TR( 2,
+ $ 2 ) ) )*( X( 1, 2 ) )+
+ $ ( SGN*TR( 1, 2 ) )*( X( 1, 1 ) )-
+ $ ( SCALE*B( 1, 2 ) ) )
+ DEN = MAX( SMLNUM, SMLNUM*XNRM,
+ $ ( TNRM*EPS )*XNRM )
+ RES = RES / DEN
+ IF( SCALE.GT.ONE )
+ $ RES = RES + ONE / EPS
+ RES = RES + ABS( XNORM-XNRM ) /
+ $ MAX( SMLNUM, XNORM ) / EPS
+ IF( RES.GT.RMAX ) THEN
+ LMAX = KNT
+ RMAX = RES
+ END IF
+ 90 CONTINUE
+ 100 CONTINUE
+ 110 CONTINUE
+ 120 CONTINUE
+ 130 CONTINUE
+*
+ N1 = 2
+ N2 = 2
+ DO 200 ITR = 1, 8
+ DO 190 ITRSCL = 1, 3
+ DO 180 ITL = 1, 8
+ DO 170 ITLSCL = 1, 3
+ DO 160 IB1 = 1, 3
+ DO 150 IB2 = 1, 3
+ DO 140 IB3 = 1, 3
+ B( 1, 1 ) = VAL( IB1 )
+ B( 2, 1 ) = -FOUR*VAL( IB2 )
+ B( 1, 2 ) = -TWO*VAL( IB3 )
+ B( 2, 2 ) = EIGHT*
+ $ MIN( VAL( IB1 ), VAL
+ $ ( IB2 ), VAL( IB3 ) )
+ TR( 1, 1 ) = ITVAL( 1, 1, ITR )*
+ $ VAL( ITRSCL )
+ TR( 2, 1 ) = ITVAL( 2, 1, ITR )*
+ $ VAL( ITRSCL )
+ TR( 1, 2 ) = ITVAL( 1, 2, ITR )*
+ $ VAL( ITRSCL )
+ TR( 2, 2 ) = ITVAL( 2, 2, ITR )*
+ $ VAL( ITRSCL )
+ TL( 1, 1 ) = ITVAL( 1, 1, ITL )*
+ $ VAL( ITLSCL )
+ TL( 2, 1 ) = ITVAL( 2, 1, ITL )*
+ $ VAL( ITLSCL )
+ TL( 1, 2 ) = ITVAL( 1, 2, ITL )*
+ $ VAL( ITLSCL )
+ TL( 2, 2 ) = ITVAL( 2, 2, ITL )*
+ $ VAL( ITLSCL )
+ KNT = KNT + 1
+ CALL DLASY2( LTRANL, LTRANR, ISGN,
+ $ N1, N2, TL, 2, TR, 2,
+ $ B, 2, SCALE, X, 2,
+ $ XNORM, INFO )
+ IF( INFO.NE.0 )
+ $ NINFO = NINFO + 1
+ IF( LTRANR ) THEN
+ TMP = TR( 1, 2 )
+ TR( 1, 2 ) = TR( 2, 1 )
+ TR( 2, 1 ) = TMP
+ END IF
+ IF( LTRANL ) THEN
+ TMP = TL( 1, 2 )
+ TL( 1, 2 ) = TL( 2, 1 )
+ TL( 2, 1 ) = TMP
+ END IF
+ TNRM = ABS( TR( 1, 1 ) ) +
+ $ ABS( TR( 2, 1 ) ) +
+ $ ABS( TR( 1, 2 ) ) +
+ $ ABS( TR( 2, 2 ) ) +
+ $ ABS( TL( 1, 1 ) ) +
+ $ ABS( TL( 2, 1 ) ) +
+ $ ABS( TL( 1, 2 ) ) +
+ $ ABS( TL( 2, 2 ) )
+ XNRM = MAX( ABS( X( 1, 1 ) )+
+ $ ABS( X( 1, 2 ) ),
+ $ ABS( X( 2, 1 ) )+
+ $ ABS( X( 2, 2 ) ) )
+ RES = ABS( ( ( TL( 1, 1 )+SGN*TR( 1,
+ $ 1 ) ) )*( X( 1, 1 ) )+
+ $ ( SGN*TR( 2, 1 ) )*
+ $ ( X( 1, 2 ) )+( TL( 1, 2 ) )*
+ $ ( X( 2, 1 ) )-
+ $ ( SCALE*B( 1, 1 ) ) )
+ RES = RES + ABS( ( TL( 1, 1 ) )*
+ $ ( X( 1, 2 ) )+
+ $ ( SGN*TR( 1, 2 ) )*
+ $ ( X( 1, 1 ) )+
+ $ ( SGN*TR( 2, 2 ) )*
+ $ ( X( 1, 2 ) )+( TL( 1, 2 ) )*
+ $ ( X( 2, 2 ) )-
+ $ ( SCALE*B( 1, 2 ) ) )
+ RES = RES + ABS( ( TL( 2, 1 ) )*
+ $ ( X( 1, 1 ) )+
+ $ ( SGN*TR( 1, 1 ) )*
+ $ ( X( 2, 1 ) )+
+ $ ( SGN*TR( 2, 1 ) )*
+ $ ( X( 2, 2 ) )+( TL( 2, 2 ) )*
+ $ ( X( 2, 1 ) )-
+ $ ( SCALE*B( 2, 1 ) ) )
+ RES = RES + ABS( ( ( TL( 2,
+ $ 2 )+SGN*TR( 2, 2 ) ) )*
+ $ ( X( 2, 2 ) )+
+ $ ( SGN*TR( 1, 2 ) )*
+ $ ( X( 2, 1 ) )+( TL( 2, 1 ) )*
+ $ ( X( 1, 2 ) )-
+ $ ( SCALE*B( 2, 2 ) ) )
+ DEN = MAX( SMLNUM, SMLNUM*XNRM,
+ $ ( TNRM*EPS )*XNRM )
+ RES = RES / DEN
+ IF( SCALE.GT.ONE )
+ $ RES = RES + ONE / EPS
+ RES = RES + ABS( XNORM-XNRM ) /
+ $ MAX( SMLNUM, XNORM ) / EPS
+ IF( RES.GT.RMAX ) THEN
+ LMAX = KNT
+ RMAX = RES
+ END IF
+ 140 CONTINUE
+ 150 CONTINUE
+ 160 CONTINUE
+ 170 CONTINUE
+ 180 CONTINUE
+ 190 CONTINUE
+ 200 CONTINUE
+ 210 CONTINUE
+ 220 CONTINUE
+ 230 CONTINUE
+*
+ RETURN
+*
+* End of DGET32
+*
+ END
+ SUBROUTINE DGET33( RMAX, LMAX, NINFO, KNT )
+*
+* -- LAPACK test routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER KNT, LMAX, NINFO
+ DOUBLE PRECISION RMAX
+* ..
+*
+* Purpose
+* =======
+*
+* DGET33 tests DLANV2, a routine for putting 2 by 2 blocks into
+* standard form. In other words, it computes a two by two rotation
+* [[C,S];[-S,C]] where in
+*
+* [ C S ][T(1,1) T(1,2)][ C -S ] = [ T11 T12 ]
+* [-S C ][T(2,1) T(2,2)][ S C ] [ T21 T22 ]
+*
+* either
+* 1) T21=0 (real eigenvalues), or
+* 2) T11=T22 and T21*T12<0 (complex conjugate eigenvalues).
+* We also verify that the residual is small.
+*
+* Arguments
+* ==========
+*
+* RMAX (output) DOUBLE PRECISION
+* Value of the largest test ratio.
+*
+* LMAX (output) INTEGER
+* Example number where largest test ratio achieved.
+*
+* NINFO (output) INTEGER
+* Number of examples returned with INFO .NE. 0.
+*
+* KNT (output) INTEGER
+* Total number of examples tested.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
+ DOUBLE PRECISION TWO, FOUR
+ PARAMETER ( TWO = 2.0D0, FOUR = 4.0D0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I1, I2, I3, I4, IM1, IM2, IM3, IM4, J1, J2, J3
+ DOUBLE PRECISION BIGNUM, CS, EPS, RES, SMLNUM, SN, SUM, TNRM,
+ $ WI1, WI2, WR1, WR2
+* ..
+* .. Local Arrays ..
+ DOUBLE PRECISION Q( 2, 2 ), T( 2, 2 ), T1( 2, 2 ), T2( 2, 2 ),
+ $ VAL( 4 ), VM( 3 )
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DLAMCH
+ EXTERNAL DLAMCH
+* ..
+* .. External Subroutines ..
+ EXTERNAL DLABAD, DLANV2
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, SIGN
+* ..
+* .. Executable Statements ..
+*
+* Get machine parameters
+*
+ EPS = DLAMCH( 'P' )
+ SMLNUM = DLAMCH( 'S' ) / EPS
+ BIGNUM = ONE / SMLNUM
+ CALL DLABAD( SMLNUM, BIGNUM )
+*
+* Set up test case parameters
+*
+ VAL( 1 ) = ONE
+ VAL( 2 ) = ONE + TWO*EPS
+ VAL( 3 ) = TWO
+ VAL( 4 ) = TWO - FOUR*EPS
+ VM( 1 ) = SMLNUM
+ VM( 2 ) = ONE
+ VM( 3 ) = BIGNUM
+*
+ KNT = 0
+ NINFO = 0
+ LMAX = 0
+ RMAX = ZERO
+*
+* Begin test loop
+*
+ DO 150 I1 = 1, 4
+ DO 140 I2 = 1, 4
+ DO 130 I3 = 1, 4
+ DO 120 I4 = 1, 4
+ DO 110 IM1 = 1, 3
+ DO 100 IM2 = 1, 3
+ DO 90 IM3 = 1, 3
+ DO 80 IM4 = 1, 3
+ T( 1, 1 ) = VAL( I1 )*VM( IM1 )
+ T( 1, 2 ) = VAL( I2 )*VM( IM2 )
+ T( 2, 1 ) = -VAL( I3 )*VM( IM3 )
+ T( 2, 2 ) = VAL( I4 )*VM( IM4 )
+ TNRM = MAX( ABS( T( 1, 1 ) ),
+ $ ABS( T( 1, 2 ) ), ABS( T( 2, 1 ) ),
+ $ ABS( T( 2, 2 ) ) )
+ T1( 1, 1 ) = T( 1, 1 )
+ T1( 1, 2 ) = T( 1, 2 )
+ T1( 2, 1 ) = T( 2, 1 )
+ T1( 2, 2 ) = T( 2, 2 )
+ Q( 1, 1 ) = ONE
+ Q( 1, 2 ) = ZERO
+ Q( 2, 1 ) = ZERO
+ Q( 2, 2 ) = ONE
+*
+ CALL DLANV2( T( 1, 1 ), T( 1, 2 ),
+ $ T( 2, 1 ), T( 2, 2 ), WR1,
+ $ WI1, WR2, WI2, CS, SN )
+ DO 10 J1 = 1, 2
+ RES = Q( J1, 1 )*CS + Q( J1, 2 )*SN
+ Q( J1, 2 ) = -Q( J1, 1 )*SN +
+ $ Q( J1, 2 )*CS
+ Q( J1, 1 ) = RES
+ 10 CONTINUE
+*
+ RES = ZERO
+ RES = RES + ABS( Q( 1, 1 )**2+
+ $ Q( 1, 2 )**2-ONE ) / EPS
+ RES = RES + ABS( Q( 2, 2 )**2+
+ $ Q( 2, 1 )**2-ONE ) / EPS
+ RES = RES + ABS( Q( 1, 1 )*Q( 2, 1 )+
+ $ Q( 1, 2 )*Q( 2, 2 ) ) / EPS
+ DO 40 J1 = 1, 2
+ DO 30 J2 = 1, 2
+ T2( J1, J2 ) = ZERO
+ DO 20 J3 = 1, 2
+ T2( J1, J2 ) = T2( J1, J2 ) +
+ $ T1( J1, J3 )*
+ $ Q( J3, J2 )
+ 20 CONTINUE
+ 30 CONTINUE
+ 40 CONTINUE
+ DO 70 J1 = 1, 2
+ DO 60 J2 = 1, 2
+ SUM = T( J1, J2 )
+ DO 50 J3 = 1, 2
+ SUM = SUM - Q( J3, J1 )*
+ $ T2( J3, J2 )
+ 50 CONTINUE
+ RES = RES + ABS( SUM ) / EPS / TNRM
+ 60 CONTINUE
+ 70 CONTINUE
+ IF( T( 2, 1 ).NE.ZERO .AND.
+ $ ( T( 1, 1 ).NE.T( 2,
+ $ 2 ) .OR. SIGN( ONE, T( 1,
+ $ 2 ) )*SIGN( ONE, T( 2,
+ $ 1 ) ).GT.ZERO ) )RES = RES + ONE / EPS
+ KNT = KNT + 1
+ IF( RES.GT.RMAX ) THEN
+ LMAX = KNT
+ RMAX = RES
+ END IF
+ 80 CONTINUE
+ 90 CONTINUE
+ 100 CONTINUE
+ 110 CONTINUE
+ 120 CONTINUE
+ 130 CONTINUE
+ 140 CONTINUE
+ 150 CONTINUE
+*
+ RETURN
+*
+* End of DGET33
+*
+ END
+ SUBROUTINE DGET34( RMAX, LMAX, NINFO, KNT )
+*
+* -- LAPACK test routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER KNT, LMAX
+ DOUBLE PRECISION RMAX
+* ..
+* .. Array Arguments ..
+ INTEGER NINFO( 2 )
+* ..
+*
+* Purpose
+* =======
+*
+* DGET34 tests DLAEXC, a routine for swapping adjacent blocks (either
+* 1 by 1 or 2 by 2) on the diagonal of a matrix in real Schur form.
+* Thus, DLAEXC computes an orthogonal matrix Q such that
+*
+* Q' * [ A B ] * Q = [ C1 B1 ]
+* [ 0 C ] [ 0 A1 ]
+*
+* where C1 is similar to C and A1 is similar to A. Both A and C are
+* assumed to be in standard form (equal diagonal entries and
+* offdiagonal with differing signs) and A1 and C1 are returned with the
+* same properties.
+*
+* The test code verifies these last last assertions, as well as that
+* the residual in the above equation is small.
+*
+* Arguments
+* ==========
+*
+* RMAX (output) DOUBLE PRECISION
+* Value of the largest test ratio.
+*
+* LMAX (output) INTEGER
+* Example number where largest test ratio achieved.
+*
+* NINFO (output) INTEGER array, dimension (2)
+* NINFO(J) is the number of examples where INFO=J occurred.
+*
+* KNT (output) INTEGER
+* Total number of examples tested.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, HALF, ONE
+ PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0 )
+ DOUBLE PRECISION TWO, THREE
+ PARAMETER ( TWO = 2.0D0, THREE = 3.0D0 )
+ INTEGER LWORK
+ PARAMETER ( LWORK = 32 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, IA, IA11, IA12, IA21, IA22, IAM, IB, IC,
+ $ IC11, IC12, IC21, IC22, ICM, INFO, J
+ DOUBLE PRECISION BIGNUM, EPS, RES, SMLNUM, TNRM
+* ..
+* .. Local Arrays ..
+ DOUBLE PRECISION Q( 4, 4 ), RESULT( 2 ), T( 4, 4 ), T1( 4, 4 ),
+ $ VAL( 9 ), VM( 2 ), WORK( LWORK )
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DLAMCH
+ EXTERNAL DLAMCH
+* ..
+* .. External Subroutines ..
+ EXTERNAL DCOPY, DHST01, DLABAD, DLAEXC
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, DBLE, MAX, SIGN, SQRT
+* ..
+* .. Executable Statements ..
+*
+* Get machine parameters
+*
+ EPS = DLAMCH( 'P' )
+ SMLNUM = DLAMCH( 'S' ) / EPS
+ BIGNUM = ONE / SMLNUM
+ CALL DLABAD( SMLNUM, BIGNUM )
+*
+* Set up test case parameters
+*
+ VAL( 1 ) = ZERO
+ VAL( 2 ) = SQRT( SMLNUM )
+ VAL( 3 ) = ONE
+ VAL( 4 ) = TWO
+ VAL( 5 ) = SQRT( BIGNUM )
+ VAL( 6 ) = -SQRT( SMLNUM )
+ VAL( 7 ) = -ONE
+ VAL( 8 ) = -TWO
+ VAL( 9 ) = -SQRT( BIGNUM )
+ VM( 1 ) = ONE
+ VM( 2 ) = ONE + TWO*EPS
+ CALL DCOPY( 16, VAL( 4 ), 0, T( 1, 1 ), 1 )
+*
+ NINFO( 1 ) = 0
+ NINFO( 2 ) = 0
+ KNT = 0
+ LMAX = 0
+ RMAX = ZERO
+*
+* Begin test loop
+*
+ DO 40 IA = 1, 9
+ DO 30 IAM = 1, 2
+ DO 20 IB = 1, 9
+ DO 10 IC = 1, 9
+ T( 1, 1 ) = VAL( IA )*VM( IAM )
+ T( 2, 2 ) = VAL( IC )
+ T( 1, 2 ) = VAL( IB )
+ T( 2, 1 ) = ZERO
+ TNRM = MAX( ABS( T( 1, 1 ) ), ABS( T( 2, 2 ) ),
+ $ ABS( T( 1, 2 ) ) )
+ CALL DCOPY( 16, T, 1, T1, 1 )
+ CALL DCOPY( 16, VAL( 1 ), 0, Q, 1 )
+ CALL DCOPY( 4, VAL( 3 ), 0, Q, 5 )
+ CALL DLAEXC( .TRUE., 2, T, 4, Q, 4, 1, 1, 1, WORK,
+ $ INFO )
+ IF( INFO.NE.0 )
+ $ NINFO( INFO ) = NINFO( INFO ) + 1
+ CALL DHST01( 2, 1, 2, T1, 4, T, 4, Q, 4, WORK, LWORK,
+ $ RESULT )
+ RES = RESULT( 1 ) + RESULT( 2 )
+ IF( INFO.NE.0 )
+ $ RES = RES + ONE / EPS
+ IF( T( 1, 1 ).NE.T1( 2, 2 ) )
+ $ RES = RES + ONE / EPS
+ IF( T( 2, 2 ).NE.T1( 1, 1 ) )
+ $ RES = RES + ONE / EPS
+ IF( T( 2, 1 ).NE.ZERO )
+ $ RES = RES + ONE / EPS
+ KNT = KNT + 1
+ IF( RES.GT.RMAX ) THEN
+ LMAX = KNT
+ RMAX = RES
+ END IF
+ 10 CONTINUE
+ 20 CONTINUE
+ 30 CONTINUE
+ 40 CONTINUE
+*
+ DO 110 IA = 1, 5
+ DO 100 IAM = 1, 2
+ DO 90 IB = 1, 5
+ DO 80 IC11 = 1, 5
+ DO 70 IC12 = 2, 5
+ DO 60 IC21 = 2, 4
+ DO 50 IC22 = -1, 1, 2
+ T( 1, 1 ) = VAL( IA )*VM( IAM )
+ T( 1, 2 ) = VAL( IB )
+ T( 1, 3 ) = -TWO*VAL( IB )
+ T( 2, 1 ) = ZERO
+ T( 2, 2 ) = VAL( IC11 )
+ T( 2, 3 ) = VAL( IC12 )
+ T( 3, 1 ) = ZERO
+ T( 3, 2 ) = -VAL( IC21 )
+ T( 3, 3 ) = VAL( IC11 )*DBLE( IC22 )
+ TNRM = MAX( ABS( T( 1, 1 ) ),
+ $ ABS( T( 1, 2 ) ), ABS( T( 1, 3 ) ),
+ $ ABS( T( 2, 2 ) ), ABS( T( 2, 3 ) ),
+ $ ABS( T( 3, 2 ) ), ABS( T( 3, 3 ) ) )
+ CALL DCOPY( 16, T, 1, T1, 1 )
+ CALL DCOPY( 16, VAL( 1 ), 0, Q, 1 )
+ CALL DCOPY( 4, VAL( 3 ), 0, Q, 5 )
+ CALL DLAEXC( .TRUE., 3, T, 4, Q, 4, 1, 1, 2,
+ $ WORK, INFO )
+ IF( INFO.NE.0 )
+ $ NINFO( INFO ) = NINFO( INFO ) + 1
+ CALL DHST01( 3, 1, 3, T1, 4, T, 4, Q, 4,
+ $ WORK, LWORK, RESULT )
+ RES = RESULT( 1 ) + RESULT( 2 )
+ IF( INFO.EQ.0 ) THEN
+ IF( T1( 1, 1 ).NE.T( 3, 3 ) )
+ $ RES = RES + ONE / EPS
+ IF( T( 3, 1 ).NE.ZERO )
+ $ RES = RES + ONE / EPS
+ IF( T( 3, 2 ).NE.ZERO )
+ $ RES = RES + ONE / EPS
+ IF( T( 2, 1 ).NE.0 .AND.
+ $ ( T( 1, 1 ).NE.T( 2,
+ $ 2 ) .OR. SIGN( ONE, T( 1,
+ $ 2 ) ).EQ.SIGN( ONE, T( 2, 1 ) ) ) )
+ $ RES = RES + ONE / EPS
+ END IF
+ KNT = KNT + 1
+ IF( RES.GT.RMAX ) THEN
+ LMAX = KNT
+ RMAX = RES
+ END IF
+ 50 CONTINUE
+ 60 CONTINUE
+ 70 CONTINUE
+ 80 CONTINUE
+ 90 CONTINUE
+ 100 CONTINUE
+ 110 CONTINUE
+*
+ DO 180 IA11 = 1, 5
+ DO 170 IA12 = 2, 5
+ DO 160 IA21 = 2, 4
+ DO 150 IA22 = -1, 1, 2
+ DO 140 ICM = 1, 2
+ DO 130 IB = 1, 5
+ DO 120 IC = 1, 5
+ T( 1, 1 ) = VAL( IA11 )
+ T( 1, 2 ) = VAL( IA12 )
+ T( 1, 3 ) = -TWO*VAL( IB )
+ T( 2, 1 ) = -VAL( IA21 )
+ T( 2, 2 ) = VAL( IA11 )*DBLE( IA22 )
+ T( 2, 3 ) = VAL( IB )
+ T( 3, 1 ) = ZERO
+ T( 3, 2 ) = ZERO
+ T( 3, 3 ) = VAL( IC )*VM( ICM )
+ TNRM = MAX( ABS( T( 1, 1 ) ),
+ $ ABS( T( 1, 2 ) ), ABS( T( 1, 3 ) ),
+ $ ABS( T( 2, 2 ) ), ABS( T( 2, 3 ) ),
+ $ ABS( T( 3, 2 ) ), ABS( T( 3, 3 ) ) )
+ CALL DCOPY( 16, T, 1, T1, 1 )
+ CALL DCOPY( 16, VAL( 1 ), 0, Q, 1 )
+ CALL DCOPY( 4, VAL( 3 ), 0, Q, 5 )
+ CALL DLAEXC( .TRUE., 3, T, 4, Q, 4, 1, 2, 1,
+ $ WORK, INFO )
+ IF( INFO.NE.0 )
+ $ NINFO( INFO ) = NINFO( INFO ) + 1
+ CALL DHST01( 3, 1, 3, T1, 4, T, 4, Q, 4,
+ $ WORK, LWORK, RESULT )
+ RES = RESULT( 1 ) + RESULT( 2 )
+ IF( INFO.EQ.0 ) THEN
+ IF( T1( 3, 3 ).NE.T( 1, 1 ) )
+ $ RES = RES + ONE / EPS
+ IF( T( 2, 1 ).NE.ZERO )
+ $ RES = RES + ONE / EPS
+ IF( T( 3, 1 ).NE.ZERO )
+ $ RES = RES + ONE / EPS
+ IF( T( 3, 2 ).NE.0 .AND.
+ $ ( T( 2, 2 ).NE.T( 3,
+ $ 3 ) .OR. SIGN( ONE, T( 2,
+ $ 3 ) ).EQ.SIGN( ONE, T( 3, 2 ) ) ) )
+ $ RES = RES + ONE / EPS
+ END IF
+ KNT = KNT + 1
+ IF( RES.GT.RMAX ) THEN
+ LMAX = KNT
+ RMAX = RES
+ END IF
+ 120 CONTINUE
+ 130 CONTINUE
+ 140 CONTINUE
+ 150 CONTINUE
+ 160 CONTINUE
+ 170 CONTINUE
+ 180 CONTINUE
+*
+ DO 300 IA11 = 1, 5
+ DO 290 IA12 = 2, 5
+ DO 280 IA21 = 2, 4
+ DO 270 IA22 = -1, 1, 2
+ DO 260 IB = 1, 5
+ DO 250 IC11 = 3, 4
+ DO 240 IC12 = 3, 4
+ DO 230 IC21 = 3, 4
+ DO 220 IC22 = -1, 1, 2
+ DO 210 ICM = 5, 7
+ IAM = 1
+ T( 1, 1 ) = VAL( IA11 )*VM( IAM )
+ T( 1, 2 ) = VAL( IA12 )*VM( IAM )
+ T( 1, 3 ) = -TWO*VAL( IB )
+ T( 1, 4 ) = HALF*VAL( IB )
+ T( 2, 1 ) = -T( 1, 2 )*VAL( IA21 )
+ T( 2, 2 ) = VAL( IA11 )*
+ $ DBLE( IA22 )*VM( IAM )
+ T( 2, 3 ) = VAL( IB )
+ T( 2, 4 ) = THREE*VAL( IB )
+ T( 3, 1 ) = ZERO
+ T( 3, 2 ) = ZERO
+ T( 3, 3 ) = VAL( IC11 )*
+ $ ABS( VAL( ICM ) )
+ T( 3, 4 ) = VAL( IC12 )*
+ $ ABS( VAL( ICM ) )
+ T( 4, 1 ) = ZERO
+ T( 4, 2 ) = ZERO
+ T( 4, 3 ) = -T( 3, 4 )*VAL( IC21 )*
+ $ ABS( VAL( ICM ) )
+ T( 4, 4 ) = VAL( IC11 )*
+ $ DBLE( IC22 )*
+ $ ABS( VAL( ICM ) )
+ TNRM = ZERO
+ DO 200 I = 1, 4
+ DO 190 J = 1, 4
+ TNRM = MAX( TNRM,
+ $ ABS( T( I, J ) ) )
+ 190 CONTINUE
+ 200 CONTINUE
+ CALL DCOPY( 16, T, 1, T1, 1 )
+ CALL DCOPY( 16, VAL( 1 ), 0, Q, 1 )
+ CALL DCOPY( 4, VAL( 3 ), 0, Q, 5 )
+ CALL DLAEXC( .TRUE., 4, T, 4, Q, 4,
+ $ 1, 2, 2, WORK, INFO )
+ IF( INFO.NE.0 )
+ $ NINFO( INFO ) = NINFO( INFO ) + 1
+ CALL DHST01( 4, 1, 4, T1, 4, T, 4,
+ $ Q, 4, WORK, LWORK,
+ $ RESULT )
+ RES = RESULT( 1 ) + RESULT( 2 )
+ IF( INFO.EQ.0 ) THEN
+ IF( T( 3, 1 ).NE.ZERO )
+ $ RES = RES + ONE / EPS
+ IF( T( 4, 1 ).NE.ZERO )
+ $ RES = RES + ONE / EPS
+ IF( T( 3, 2 ).NE.ZERO )
+ $ RES = RES + ONE / EPS
+ IF( T( 4, 2 ).NE.ZERO )
+ $ RES = RES + ONE / EPS
+ IF( T( 2, 1 ).NE.0 .AND.
+ $ ( T( 1, 1 ).NE.T( 2,
+ $ 2 ) .OR. SIGN( ONE, T( 1,
+ $ 2 ) ).EQ.SIGN( ONE, T( 2,
+ $ 1 ) ) ) )RES = RES +
+ $ ONE / EPS
+ IF( T( 4, 3 ).NE.0 .AND.
+ $ ( T( 3, 3 ).NE.T( 4,
+ $ 4 ) .OR. SIGN( ONE, T( 3,
+ $ 4 ) ).EQ.SIGN( ONE, T( 4,
+ $ 3 ) ) ) )RES = RES +
+ $ ONE / EPS
+ END IF
+ KNT = KNT + 1
+ IF( RES.GT.RMAX ) THEN
+ LMAX = KNT
+ RMAX = RES
+ END IF
+ 210 CONTINUE
+ 220 CONTINUE
+ 230 CONTINUE
+ 240 CONTINUE
+ 250 CONTINUE
+ 260 CONTINUE
+ 270 CONTINUE
+ 280 CONTINUE
+ 290 CONTINUE
+ 300 CONTINUE
+*
+ RETURN
+*
+* End of DGET34
+*
+ END
+ SUBROUTINE DGET35( RMAX, LMAX, NINFO, KNT )
+*
+* -- LAPACK test routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER KNT, LMAX, NINFO
+ DOUBLE PRECISION RMAX
+* ..
+*
+* Purpose
+* =======
+*
+* DGET35 tests DTRSYL, a routine for solving the Sylvester matrix
+* equation
+*
+* op(A)*X + ISGN*X*op(B) = scale*C,
+*
+* A and B are assumed to be in Schur canonical form, op() represents an
+* optional transpose, and ISGN can be -1 or +1. Scale is an output
+* less than or equal to 1, chosen to avoid overflow in X.
+*
+* The test code verifies that the following residual is order 1:
+*
+* norm(op(A)*X + ISGN*X*op(B) - scale*C) /
+* (EPS*max(norm(A),norm(B))*norm(X))
+*
+* Arguments
+* ==========
+*
+* RMAX (output) DOUBLE PRECISION
+* Value of the largest test ratio.
+*
+* LMAX (output) INTEGER
+* Example number where largest test ratio achieved.
+*
+* NINFO (output) INTEGER
+* Number of examples where INFO is nonzero.
+*
+* KNT (output) INTEGER
+* Total number of examples tested.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
+ DOUBLE PRECISION TWO, FOUR
+ PARAMETER ( TWO = 2.0D0, FOUR = 4.0D0 )
+* ..
+* .. Local Scalars ..
+ CHARACTER TRANA, TRANB
+ INTEGER I, IMA, IMB, IMLDA1, IMLDA2, IMLDB1, IMLOFF,
+ $ INFO, ISGN, ITRANA, ITRANB, J, M, N
+ DOUBLE PRECISION BIGNUM, CNRM, EPS, RES, RES1, RMUL, SCALE,
+ $ SMLNUM, TNRM, XNRM
+* ..
+* .. Local Arrays ..
+ INTEGER IDIM( 8 ), IVAL( 6, 6, 8 )
+ DOUBLE PRECISION A( 6, 6 ), B( 6, 6 ), C( 6, 6 ), CC( 6, 6 ),
+ $ DUM( 1 ), VM1( 3 ), VM2( 3 )
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DLAMCH, DLANGE
+ EXTERNAL DLAMCH, DLANGE
+* ..
+* .. External Subroutines ..
+ EXTERNAL DGEMM, DLABAD, DTRSYL
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, DBLE, MAX, SIN, SQRT
+* ..
+* .. Data statements ..
+ DATA IDIM / 1, 2, 3, 4, 3, 3, 6, 4 /
+ DATA IVAL / 1, 35*0, 1, 2, 4*0, -2, 0, 28*0, 1, 5*0,
+ $ 5, 1, 2, 3*0, -8, -2, 1, 21*0, 3, 4, 4*0, -5,
+ $ 3, 4*0, 1, 2, 1, 4, 2*0, -3, -9, -1, 1, 14*0,
+ $ 1, 5*0, 2, 3, 4*0, 5, 6, 7, 21*0, 1, 5*0, 1, 3,
+ $ -4, 3*0, 2, 5, 2, 21*0, 1, 2, 4*0, -2, 0, 4*0,
+ $ 5, 6, 3, 4, 2*0, -1, -9, -5, 2, 2*0, 4*8, 5, 6,
+ $ 4*9, -7, 5, 1, 5*0, 1, 5, 2, 3*0, 2, -21, 5,
+ $ 3*0, 1, 2, 3, 4, 14*0 /
+* ..
+* .. Executable Statements ..
+*
+* Get machine parameters
+*
+ EPS = DLAMCH( 'P' )
+ SMLNUM = DLAMCH( 'S' )*FOUR / EPS
+ BIGNUM = ONE / SMLNUM
+ CALL DLABAD( SMLNUM, BIGNUM )
+*
+* Set up test case parameters
+*
+ VM1( 1 ) = SQRT( SMLNUM )
+ VM1( 2 ) = ONE
+ VM1( 3 ) = SQRT( BIGNUM )
+ VM2( 1 ) = ONE
+ VM2( 2 ) = ONE + TWO*EPS
+ VM2( 3 ) = TWO
+*
+ KNT = 0
+ NINFO = 0
+ LMAX = 0
+ RMAX = ZERO
+*
+* Begin test loop
+*
+ DO 150 ITRANA = 1, 2
+ DO 140 ITRANB = 1, 2
+ DO 130 ISGN = -1, 1, 2
+ DO 120 IMA = 1, 8
+ DO 110 IMLDA1 = 1, 3
+ DO 100 IMLDA2 = 1, 3
+ DO 90 IMLOFF = 1, 2
+ DO 80 IMB = 1, 8
+ DO 70 IMLDB1 = 1, 3
+ IF( ITRANA.EQ.1 )
+ $ TRANA = 'N'
+ IF( ITRANA.EQ.2 )
+ $ TRANA = 'T'
+ IF( ITRANB.EQ.1 )
+ $ TRANB = 'N'
+ IF( ITRANB.EQ.2 )
+ $ TRANB = 'T'
+ M = IDIM( IMA )
+ N = IDIM( IMB )
+ TNRM = ZERO
+ DO 20 I = 1, M
+ DO 10 J = 1, M
+ A( I, J ) = IVAL( I, J, IMA )
+ IF( ABS( I-J ).LE.1 ) THEN
+ A( I, J ) = A( I, J )*
+ $ VM1( IMLDA1 )
+ A( I, J ) = A( I, J )*
+ $ VM2( IMLDA2 )
+ ELSE
+ A( I, J ) = A( I, J )*
+ $ VM1( IMLOFF )
+ END IF
+ TNRM = MAX( TNRM,
+ $ ABS( A( I, J ) ) )
+ 10 CONTINUE
+ 20 CONTINUE
+ DO 40 I = 1, N
+ DO 30 J = 1, N
+ B( I, J ) = IVAL( I, J, IMB )
+ IF( ABS( I-J ).LE.1 ) THEN
+ B( I, J ) = B( I, J )*
+ $ VM1( IMLDB1 )
+ ELSE
+ B( I, J ) = B( I, J )*
+ $ VM1( IMLOFF )
+ END IF
+ TNRM = MAX( TNRM,
+ $ ABS( B( I, J ) ) )
+ 30 CONTINUE
+ 40 CONTINUE
+ CNRM = ZERO
+ DO 60 I = 1, M
+ DO 50 J = 1, N
+ C( I, J ) = SIN( DBLE( I*J ) )
+ CNRM = MAX( CNRM, C( I, J ) )
+ CC( I, J ) = C( I, J )
+ 50 CONTINUE
+ 60 CONTINUE
+ KNT = KNT + 1
+ CALL DTRSYL( TRANA, TRANB, ISGN, M, N,
+ $ A, 6, B, 6, C, 6, SCALE,
+ $ INFO )
+ IF( INFO.NE.0 )
+ $ NINFO = NINFO + 1
+ XNRM = DLANGE( 'M', M, N, C, 6, DUM )
+ RMUL = ONE
+ IF( XNRM.GT.ONE .AND. TNRM.GT.ONE )
+ $ THEN
+ IF( XNRM.GT.BIGNUM / TNRM ) THEN
+ RMUL = ONE / MAX( XNRM, TNRM )
+ END IF
+ END IF
+ CALL DGEMM( TRANA, 'N', M, N, M, RMUL,
+ $ A, 6, C, 6, -SCALE*RMUL,
+ $ CC, 6 )
+ CALL DGEMM( 'N', TRANB, M, N, N,
+ $ DBLE( ISGN )*RMUL, C, 6, B,
+ $ 6, ONE, CC, 6 )
+ RES1 = DLANGE( 'M', M, N, CC, 6, DUM )
+ RES = RES1 / MAX( SMLNUM, SMLNUM*XNRM,
+ $ ( ( RMUL*TNRM )*EPS )*XNRM )
+ IF( RES.GT.RMAX ) THEN
+ LMAX = KNT
+ RMAX = RES
+ END IF
+ 70 CONTINUE
+ 80 CONTINUE
+ 90 CONTINUE
+ 100 CONTINUE
+ 110 CONTINUE
+ 120 CONTINUE
+ 130 CONTINUE
+ 140 CONTINUE
+ 150 CONTINUE
+*
+ RETURN
+*
+* End of DGET35
+*
+ END
+ SUBROUTINE DGET36( RMAX, LMAX, NINFO, KNT, NIN )
+*
+* -- LAPACK test routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER KNT, LMAX, NIN
+ DOUBLE PRECISION RMAX
+* ..
+* .. Array Arguments ..
+ INTEGER NINFO( 3 )
+* ..
+*
+* Purpose
+* =======
+*
+* DGET36 tests DTREXC, a routine for moving blocks (either 1 by 1 or
+* 2 by 2) on the diagonal of a matrix in real Schur form. Thus, DLAEXC
+* computes an orthogonal matrix Q such that
+*
+* Q' * T1 * Q = T2
+*
+* and where one of the diagonal blocks of T1 (the one at row IFST) has
+* been moved to position ILST.
+*
+* The test code verifies that the residual Q'*T1*Q-T2 is small, that T2
+* is in Schur form, and that the final position of the IFST block is
+* ILST (within +-1).
+*
+* The test matrices are read from a file with logical unit number NIN.
+*
+* Arguments
+* ==========
+*
+* RMAX (output) DOUBLE PRECISION
+* Value of the largest test ratio.
+*
+* LMAX (output) INTEGER
+* Example number where largest test ratio achieved.
+*
+* NINFO (output) INTEGER array, dimension (3)
+* NINFO(J) is the number of examples where INFO=J.
+*
+* KNT (output) INTEGER
+* Total number of examples tested.
+*
+* NIN (input) INTEGER
+* Input logical unit number.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
+ INTEGER LDT, LWORK
+ PARAMETER ( LDT = 10, LWORK = 2*LDT*LDT )
+* ..
+* .. Local Scalars ..
+ INTEGER I, IFST, IFST1, IFST2, IFSTSV, ILST, ILST1,
+ $ ILST2, ILSTSV, INFO1, INFO2, J, LOC, N
+ DOUBLE PRECISION EPS, RES
+* ..
+* .. Local Arrays ..
+ DOUBLE PRECISION Q( LDT, LDT ), RESULT( 2 ), T1( LDT, LDT ),
+ $ T2( LDT, LDT ), TMP( LDT, LDT ), WORK( LWORK )
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DLAMCH
+ EXTERNAL DLAMCH
+* ..
+* .. External Subroutines ..
+ EXTERNAL DHST01, DLACPY, DLASET, DTREXC
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, SIGN
+* ..
+* .. Executable Statements ..
+*
+ EPS = DLAMCH( 'P' )
+ RMAX = ZERO
+ LMAX = 0
+ KNT = 0
+ NINFO( 1 ) = 0
+ NINFO( 2 ) = 0
+ NINFO( 3 ) = 0
+*
+* Read input data until N=0
+*
+ 10 CONTINUE
+ READ( NIN, FMT = * )N, IFST, ILST
+ IF( N.EQ.0 )
+ $ RETURN
+ KNT = KNT + 1
+ DO 20 I = 1, N
+ READ( NIN, FMT = * )( TMP( I, J ), J = 1, N )
+ 20 CONTINUE
+ CALL DLACPY( 'F', N, N, TMP, LDT, T1, LDT )
+ CALL DLACPY( 'F', N, N, TMP, LDT, T2, LDT )
+ IFSTSV = IFST
+ ILSTSV = ILST
+ IFST1 = IFST
+ ILST1 = ILST
+ IFST2 = IFST
+ ILST2 = ILST
+ RES = ZERO
+*
+* Test without accumulating Q
+*
+ CALL DLASET( 'Full', N, N, ZERO, ONE, Q, LDT )
+ CALL DTREXC( 'N', N, T1, LDT, Q, LDT, IFST1, ILST1, WORK, INFO1 )
+ DO 40 I = 1, N
+ DO 30 J = 1, N
+ IF( I.EQ.J .AND. Q( I, J ).NE.ONE )
+ $ RES = RES + ONE / EPS
+ IF( I.NE.J .AND. Q( I, J ).NE.ZERO )
+ $ RES = RES + ONE / EPS
+ 30 CONTINUE
+ 40 CONTINUE
+*
+* Test with accumulating Q
+*
+ CALL DLASET( 'Full', N, N, ZERO, ONE, Q, LDT )
+ CALL DTREXC( 'V', N, T2, LDT, Q, LDT, IFST2, ILST2, WORK, INFO2 )
+*
+* Compare T1 with T2
+*
+ DO 60 I = 1, N
+ DO 50 J = 1, N
+ IF( T1( I, J ).NE.T2( I, J ) )
+ $ RES = RES + ONE / EPS
+ 50 CONTINUE
+ 60 CONTINUE
+ IF( IFST1.NE.IFST2 )
+ $ RES = RES + ONE / EPS
+ IF( ILST1.NE.ILST2 )
+ $ RES = RES + ONE / EPS
+ IF( INFO1.NE.INFO2 )
+ $ RES = RES + ONE / EPS
+*
+* Test for successful reordering of T2
+*
+ IF( INFO2.NE.0 ) THEN
+ NINFO( INFO2 ) = NINFO( INFO2 ) + 1
+ ELSE
+ IF( ABS( IFST2-IFSTSV ).GT.1 )
+ $ RES = RES + ONE / EPS
+ IF( ABS( ILST2-ILSTSV ).GT.1 )
+ $ RES = RES + ONE / EPS
+ END IF
+*
+* Test for small residual, and orthogonality of Q
+*
+ CALL DHST01( N, 1, N, TMP, LDT, T2, LDT, Q, LDT, WORK, LWORK,
+ $ RESULT )
+ RES = RES + RESULT( 1 ) + RESULT( 2 )
+*
+* Test for T2 being in Schur form
+*
+ LOC = 1
+ 70 CONTINUE
+ IF( T2( LOC+1, LOC ).NE.ZERO ) THEN
+*
+* 2 by 2 block
+*
+ IF( T2( LOC, LOC+1 ).EQ.ZERO .OR. T2( LOC, LOC ).NE.
+ $ T2( LOC+1, LOC+1 ) .OR. SIGN( ONE, T2( LOC, LOC+1 ) ).EQ.
+ $ SIGN( ONE, T2( LOC+1, LOC ) ) )RES = RES + ONE / EPS
+ DO 80 I = LOC + 2, N
+ IF( T2( I, LOC ).NE.ZERO )
+ $ RES = RES + ONE / RES
+ IF( T2( I, LOC+1 ).NE.ZERO )
+ $ RES = RES + ONE / RES
+ 80 CONTINUE
+ LOC = LOC + 2
+ ELSE
+*
+* 1 by 1 block
+*
+ DO 90 I = LOC + 1, N
+ IF( T2( I, LOC ).NE.ZERO )
+ $ RES = RES + ONE / RES
+ 90 CONTINUE
+ LOC = LOC + 1
+ END IF
+ IF( LOC.LT.N )
+ $ GO TO 70
+ IF( RES.GT.RMAX ) THEN
+ RMAX = RES
+ LMAX = KNT
+ END IF
+ GO TO 10
+*
+* End of DGET36
+*
+ END
+ SUBROUTINE DGET37( RMAX, LMAX, NINFO, KNT, NIN )
+*
+* -- LAPACK test routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER KNT, NIN
+* ..
+* .. Array Arguments ..
+ INTEGER LMAX( 3 ), NINFO( 3 )
+ DOUBLE PRECISION RMAX( 3 )
+* ..
+*
+* Purpose
+* =======
+*
+* DGET37 tests DTRSNA, a routine for estimating condition numbers of
+* eigenvalues and/or right eigenvectors of a matrix.
+*
+* The test matrices are read from a file with logical unit number NIN.
+*
+* Arguments
+* ==========
+*
+* RMAX (output) DOUBLE PRECISION array, dimension (3)
+* Value of the largest test ratio.
+* RMAX(1) = largest ratio comparing different calls to DTRSNA
+* RMAX(2) = largest error in reciprocal condition
+* numbers taking their conditioning into account
+* RMAX(3) = largest error in reciprocal condition
+* numbers not taking their conditioning into
+* account (may be larger than RMAX(2))
+*
+* LMAX (output) INTEGER array, dimension (3)
+* LMAX(i) is example number where largest test ratio
+* RMAX(i) is achieved. Also:
+* If DGEHRD returns INFO nonzero on example i, LMAX(1)=i
+* If DHSEQR returns INFO nonzero on example i, LMAX(2)=i
+* If DTRSNA returns INFO nonzero on example i, LMAX(3)=i
+*
+* NINFO (output) INTEGER array, dimension (3)
+* NINFO(1) = No. of times DGEHRD returned INFO nonzero
+* NINFO(2) = No. of times DHSEQR returned INFO nonzero
+* NINFO(3) = No. of times DTRSNA returned INFO nonzero
+*
+* KNT (output) INTEGER
+* Total number of examples tested.
+*
+* NIN (input) INTEGER
+* Input logical unit number
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE, TWO
+ PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 )
+ DOUBLE PRECISION EPSIN
+ PARAMETER ( EPSIN = 5.9605D-8 )
+ INTEGER LDT, LWORK
+ PARAMETER ( LDT = 20, LWORK = 2*LDT*( 10+LDT ) )
+* ..
+* .. Local Scalars ..
+ INTEGER I, ICMP, IFND, INFO, ISCL, J, KMIN, M, N
+ DOUBLE PRECISION BIGNUM, EPS, SMLNUM, TNRM, TOL, TOLIN, V,
+ $ VIMIN, VMAX, VMUL, VRMIN
+* ..
+* .. Local Arrays ..
+ LOGICAL SELECT( LDT )
+ INTEGER IWORK( 2*LDT ), LCMP( 3 )
+ DOUBLE PRECISION DUM( 1 ), LE( LDT, LDT ), RE( LDT, LDT ),
+ $ S( LDT ), SEP( LDT ), SEPIN( LDT ),
+ $ SEPTMP( LDT ), SIN( LDT ), STMP( LDT ),
+ $ T( LDT, LDT ), TMP( LDT, LDT ), VAL( 3 ),
+ $ WI( LDT ), WIIN( LDT ), WITMP( LDT ),
+ $ WORK( LWORK ), WR( LDT ), WRIN( LDT ),
+ $ WRTMP( LDT )
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DLAMCH, DLANGE
+ EXTERNAL DLAMCH, DLANGE
+* ..
+* .. External Subroutines ..
+ EXTERNAL DCOPY, DGEHRD, DHSEQR, DLABAD, DLACPY, DSCAL,
+ $ DTREVC, DTRSNA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC DBLE, MAX, SQRT
+* ..
+* .. Executable Statements ..
+*
+ EPS = DLAMCH( 'P' )
+ SMLNUM = DLAMCH( 'S' ) / EPS
+ BIGNUM = ONE / SMLNUM
+ CALL DLABAD( SMLNUM, BIGNUM )
+*
+* EPSIN = 2**(-24) = precision to which input data computed
+*
+ EPS = MAX( EPS, EPSIN )
+ RMAX( 1 ) = ZERO
+ RMAX( 2 ) = ZERO
+ RMAX( 3 ) = ZERO
+ LMAX( 1 ) = 0
+ LMAX( 2 ) = 0
+ LMAX( 3 ) = 0
+ KNT = 0
+ NINFO( 1 ) = 0
+ NINFO( 2 ) = 0
+ NINFO( 3 ) = 0
+*
+ VAL( 1 ) = SQRT( SMLNUM )
+ VAL( 2 ) = ONE
+ VAL( 3 ) = SQRT( BIGNUM )
+*
+* Read input data until N=0. Assume input eigenvalues are sorted
+* lexicographically (increasing by real part, then decreasing by
+* imaginary part)
+*
+ 10 CONTINUE
+ READ( NIN, FMT = * )N
+ IF( N.EQ.0 )
+ $ RETURN
+ DO 20 I = 1, N
+ READ( NIN, FMT = * )( TMP( I, J ), J = 1, N )
+ 20 CONTINUE
+ DO 30 I = 1, N
+ READ( NIN, FMT = * )WRIN( I ), WIIN( I ), SIN( I ), SEPIN( I )
+ 30 CONTINUE
+ TNRM = DLANGE( 'M', N, N, TMP, LDT, WORK )
+*
+* Begin test
+*
+ DO 240 ISCL = 1, 3
+*
+* Scale input matrix
+*
+ KNT = KNT + 1
+ CALL DLACPY( 'F', N, N, TMP, LDT, T, LDT )
+ VMUL = VAL( ISCL )
+ DO 40 I = 1, N
+ CALL DSCAL( N, VMUL, T( 1, I ), 1 )
+ 40 CONTINUE
+ IF( TNRM.EQ.ZERO )
+ $ VMUL = ONE
+*
+* Compute eigenvalues and eigenvectors
+*
+ CALL DGEHRD( N, 1, N, T, LDT, WORK( 1 ), WORK( N+1 ), LWORK-N,
+ $ INFO )
+ IF( INFO.NE.0 ) THEN
+ LMAX( 1 ) = KNT
+ NINFO( 1 ) = NINFO( 1 ) + 1
+ GO TO 240
+ END IF
+ DO 60 J = 1, N - 2
+ DO 50 I = J + 2, N
+ T( I, J ) = ZERO
+ 50 CONTINUE
+ 60 CONTINUE
+*
+* Compute Schur form
+*
+ CALL DHSEQR( 'S', 'N', N, 1, N, T, LDT, WR, WI, DUM, 1, WORK,
+ $ LWORK, INFO )
+ IF( INFO.NE.0 ) THEN
+ LMAX( 2 ) = KNT
+ NINFO( 2 ) = NINFO( 2 ) + 1
+ GO TO 240
+ END IF
+*
+* Compute eigenvectors
+*
+ CALL DTREVC( 'Both', 'All', SELECT, N, T, LDT, LE, LDT, RE,
+ $ LDT, N, M, WORK, INFO )
+*
+* Compute condition numbers
+*
+ CALL DTRSNA( 'Both', 'All', SELECT, N, T, LDT, LE, LDT, RE,
+ $ LDT, S, SEP, N, M, WORK, N, IWORK, INFO )
+ IF( INFO.NE.0 ) THEN
+ LMAX( 3 ) = KNT
+ NINFO( 3 ) = NINFO( 3 ) + 1
+ GO TO 240
+ END IF
+*
+* Sort eigenvalues and condition numbers lexicographically
+* to compare with inputs
+*
+ CALL DCOPY( N, WR, 1, WRTMP, 1 )
+ CALL DCOPY( N, WI, 1, WITMP, 1 )
+ CALL DCOPY( N, S, 1, STMP, 1 )
+ CALL DCOPY( N, SEP, 1, SEPTMP, 1 )
+ CALL DSCAL( N, ONE / VMUL, SEPTMP, 1 )
+ DO 80 I = 1, N - 1
+ KMIN = I
+ VRMIN = WRTMP( I )
+ VIMIN = WITMP( I )
+ DO 70 J = I + 1, N
+ IF( WRTMP( J ).LT.VRMIN ) THEN
+ KMIN = J
+ VRMIN = WRTMP( J )
+ VIMIN = WITMP( J )
+ END IF
+ 70 CONTINUE
+ WRTMP( KMIN ) = WRTMP( I )
+ WITMP( KMIN ) = WITMP( I )
+ WRTMP( I ) = VRMIN
+ WITMP( I ) = VIMIN
+ VRMIN = STMP( KMIN )
+ STMP( KMIN ) = STMP( I )
+ STMP( I ) = VRMIN
+ VRMIN = SEPTMP( KMIN )
+ SEPTMP( KMIN ) = SEPTMP( I )
+ SEPTMP( I ) = VRMIN
+ 80 CONTINUE
+*
+* Compare condition numbers for eigenvalues
+* taking their condition numbers into account
+*
+ V = MAX( TWO*DBLE( N )*EPS*TNRM, SMLNUM )
+ IF( TNRM.EQ.ZERO )
+ $ V = ONE
+ DO 90 I = 1, N
+ IF( V.GT.SEPTMP( I ) ) THEN
+ TOL = ONE
+ ELSE
+ TOL = V / SEPTMP( I )
+ END IF
+ IF( V.GT.SEPIN( I ) ) THEN
+ TOLIN = ONE
+ ELSE
+ TOLIN = V / SEPIN( I )
+ END IF
+ TOL = MAX( TOL, SMLNUM / EPS )
+ TOLIN = MAX( TOLIN, SMLNUM / EPS )
+ IF( EPS*( SIN( I )-TOLIN ).GT.STMP( I )+TOL ) THEN
+ VMAX = ONE / EPS
+ ELSE IF( SIN( I )-TOLIN.GT.STMP( I )+TOL ) THEN
+ VMAX = ( SIN( I )-TOLIN ) / ( STMP( I )+TOL )
+ ELSE IF( SIN( I )+TOLIN.LT.EPS*( STMP( I )-TOL ) ) THEN
+ VMAX = ONE / EPS
+ ELSE IF( SIN( I )+TOLIN.LT.STMP( I )-TOL ) THEN
+ VMAX = ( STMP( I )-TOL ) / ( SIN( I )+TOLIN )
+ ELSE
+ VMAX = ONE
+ END IF
+ IF( VMAX.GT.RMAX( 2 ) ) THEN
+ RMAX( 2 ) = VMAX
+ IF( NINFO( 2 ).EQ.0 )
+ $ LMAX( 2 ) = KNT
+ END IF
+ 90 CONTINUE
+*
+* Compare condition numbers for eigenvectors
+* taking their condition numbers into account
+*
+ DO 100 I = 1, N
+ IF( V.GT.SEPTMP( I )*STMP( I ) ) THEN
+ TOL = SEPTMP( I )
+ ELSE
+ TOL = V / STMP( I )
+ END IF
+ IF( V.GT.SEPIN( I )*SIN( I ) ) THEN
+ TOLIN = SEPIN( I )
+ ELSE
+ TOLIN = V / SIN( I )
+ END IF
+ TOL = MAX( TOL, SMLNUM / EPS )
+ TOLIN = MAX( TOLIN, SMLNUM / EPS )
+ IF( EPS*( SEPIN( I )-TOLIN ).GT.SEPTMP( I )+TOL ) THEN
+ VMAX = ONE / EPS
+ ELSE IF( SEPIN( I )-TOLIN.GT.SEPTMP( I )+TOL ) THEN
+ VMAX = ( SEPIN( I )-TOLIN ) / ( SEPTMP( I )+TOL )
+ ELSE IF( SEPIN( I )+TOLIN.LT.EPS*( SEPTMP( I )-TOL ) ) THEN
+ VMAX = ONE / EPS
+ ELSE IF( SEPIN( I )+TOLIN.LT.SEPTMP( I )-TOL ) THEN
+ VMAX = ( SEPTMP( I )-TOL ) / ( SEPIN( I )+TOLIN )
+ ELSE
+ VMAX = ONE
+ END IF
+ IF( VMAX.GT.RMAX( 2 ) ) THEN
+ RMAX( 2 ) = VMAX
+ IF( NINFO( 2 ).EQ.0 )
+ $ LMAX( 2 ) = KNT
+ END IF
+ 100 CONTINUE
+*
+* Compare condition numbers for eigenvalues
+* without taking their condition numbers into account
+*
+ DO 110 I = 1, N
+ IF( SIN( I ).LE.DBLE( 2*N )*EPS .AND. STMP( I ).LE.
+ $ DBLE( 2*N )*EPS ) THEN
+ VMAX = ONE
+ ELSE IF( EPS*SIN( I ).GT.STMP( I ) ) THEN
+ VMAX = ONE / EPS
+ ELSE IF( SIN( I ).GT.STMP( I ) ) THEN
+ VMAX = SIN( I ) / STMP( I )
+ ELSE IF( SIN( I ).LT.EPS*STMP( I ) ) THEN
+ VMAX = ONE / EPS
+ ELSE IF( SIN( I ).LT.STMP( I ) ) THEN
+ VMAX = STMP( I ) / SIN( I )
+ ELSE
+ VMAX = ONE
+ END IF
+ IF( VMAX.GT.RMAX( 3 ) ) THEN
+ RMAX( 3 ) = VMAX
+ IF( NINFO( 3 ).EQ.0 )
+ $ LMAX( 3 ) = KNT
+ END IF
+ 110 CONTINUE
+*
+* Compare condition numbers for eigenvectors
+* without taking their condition numbers into account
+*
+ DO 120 I = 1, N
+ IF( SEPIN( I ).LE.V .AND. SEPTMP( I ).LE.V ) THEN
+ VMAX = ONE
+ ELSE IF( EPS*SEPIN( I ).GT.SEPTMP( I ) ) THEN
+ VMAX = ONE / EPS
+ ELSE IF( SEPIN( I ).GT.SEPTMP( I ) ) THEN
+ VMAX = SEPIN( I ) / SEPTMP( I )
+ ELSE IF( SEPIN( I ).LT.EPS*SEPTMP( I ) ) THEN
+ VMAX = ONE / EPS
+ ELSE IF( SEPIN( I ).LT.SEPTMP( I ) ) THEN
+ VMAX = SEPTMP( I ) / SEPIN( I )
+ ELSE
+ VMAX = ONE
+ END IF
+ IF( VMAX.GT.RMAX( 3 ) ) THEN
+ RMAX( 3 ) = VMAX
+ IF( NINFO( 3 ).EQ.0 )
+ $ LMAX( 3 ) = KNT
+ END IF
+ 120 CONTINUE
+*
+* Compute eigenvalue condition numbers only and compare
+*
+ VMAX = ZERO
+ DUM( 1 ) = -ONE
+ CALL DCOPY( N, DUM, 0, STMP, 1 )
+ CALL DCOPY( N, DUM, 0, SEPTMP, 1 )
+ CALL DTRSNA( 'Eigcond', 'All', SELECT, N, T, LDT, LE, LDT, RE,
+ $ LDT, STMP, SEPTMP, N, M, WORK, N, IWORK, INFO )
+ IF( INFO.NE.0 ) THEN
+ LMAX( 3 ) = KNT
+ NINFO( 3 ) = NINFO( 3 ) + 1
+ GO TO 240
+ END IF
+ DO 130 I = 1, N
+ IF( STMP( I ).NE.S( I ) )
+ $ VMAX = ONE / EPS
+ IF( SEPTMP( I ).NE.DUM( 1 ) )
+ $ VMAX = ONE / EPS
+ 130 CONTINUE
+*
+* Compute eigenvector condition numbers only and compare
+*
+ CALL DCOPY( N, DUM, 0, STMP, 1 )
+ CALL DCOPY( N, DUM, 0, SEPTMP, 1 )
+ CALL DTRSNA( 'Veccond', 'All', SELECT, N, T, LDT, LE, LDT, RE,
+ $ LDT, STMP, SEPTMP, N, M, WORK, N, IWORK, INFO )
+ IF( INFO.NE.0 ) THEN
+ LMAX( 3 ) = KNT
+ NINFO( 3 ) = NINFO( 3 ) + 1
+ GO TO 240
+ END IF
+ DO 140 I = 1, N
+ IF( STMP( I ).NE.DUM( 1 ) )
+ $ VMAX = ONE / EPS
+ IF( SEPTMP( I ).NE.SEP( I ) )
+ $ VMAX = ONE / EPS
+ 140 CONTINUE
+*
+* Compute all condition numbers using SELECT and compare
+*
+ DO 150 I = 1, N
+ SELECT( I ) = .TRUE.
+ 150 CONTINUE
+ CALL DCOPY( N, DUM, 0, STMP, 1 )
+ CALL DCOPY( N, DUM, 0, SEPTMP, 1 )
+ CALL DTRSNA( 'Bothcond', 'Some', SELECT, N, T, LDT, LE, LDT,
+ $ RE, LDT, STMP, SEPTMP, N, M, WORK, N, IWORK,
+ $ INFO )
+ IF( INFO.NE.0 ) THEN
+ LMAX( 3 ) = KNT
+ NINFO( 3 ) = NINFO( 3 ) + 1
+ GO TO 240
+ END IF
+ DO 160 I = 1, N
+ IF( SEPTMP( I ).NE.SEP( I ) )
+ $ VMAX = ONE / EPS
+ IF( STMP( I ).NE.S( I ) )
+ $ VMAX = ONE / EPS
+ 160 CONTINUE
+*
+* Compute eigenvalue condition numbers using SELECT and compare
+*
+ CALL DCOPY( N, DUM, 0, STMP, 1 )
+ CALL DCOPY( N, DUM, 0, SEPTMP, 1 )
+ CALL DTRSNA( 'Eigcond', 'Some', SELECT, N, T, LDT, LE, LDT, RE,
+ $ LDT, STMP, SEPTMP, N, M, WORK, N, IWORK, INFO )
+ IF( INFO.NE.0 ) THEN
+ LMAX( 3 ) = KNT
+ NINFO( 3 ) = NINFO( 3 ) + 1
+ GO TO 240
+ END IF
+ DO 170 I = 1, N
+ IF( STMP( I ).NE.S( I ) )
+ $ VMAX = ONE / EPS
+ IF( SEPTMP( I ).NE.DUM( 1 ) )
+ $ VMAX = ONE / EPS
+ 170 CONTINUE
+*
+* Compute eigenvector condition numbers using SELECT and compare
+*
+ CALL DCOPY( N, DUM, 0, STMP, 1 )
+ CALL DCOPY( N, DUM, 0, SEPTMP, 1 )
+ CALL DTRSNA( 'Veccond', 'Some', SELECT, N, T, LDT, LE, LDT, RE,
+ $ LDT, STMP, SEPTMP, N, M, WORK, N, IWORK, INFO )
+ IF( INFO.NE.0 ) THEN
+ LMAX( 3 ) = KNT
+ NINFO( 3 ) = NINFO( 3 ) + 1
+ GO TO 240
+ END IF
+ DO 180 I = 1, N
+ IF( STMP( I ).NE.DUM( 1 ) )
+ $ VMAX = ONE / EPS
+ IF( SEPTMP( I ).NE.SEP( I ) )
+ $ VMAX = ONE / EPS
+ 180 CONTINUE
+ IF( VMAX.GT.RMAX( 1 ) ) THEN
+ RMAX( 1 ) = VMAX
+ IF( NINFO( 1 ).EQ.0 )
+ $ LMAX( 1 ) = KNT
+ END IF
+*
+* Select first real and first complex eigenvalue
+*
+ IF( WI( 1 ).EQ.ZERO ) THEN
+ LCMP( 1 ) = 1
+ IFND = 0
+ DO 190 I = 2, N
+ IF( IFND.EQ.1 .OR. WI( I ).EQ.ZERO ) THEN
+ SELECT( I ) = .FALSE.
+ ELSE
+ IFND = 1
+ LCMP( 2 ) = I
+ LCMP( 3 ) = I + 1
+ CALL DCOPY( N, RE( 1, I ), 1, RE( 1, 2 ), 1 )
+ CALL DCOPY( N, RE( 1, I+1 ), 1, RE( 1, 3 ), 1 )
+ CALL DCOPY( N, LE( 1, I ), 1, LE( 1, 2 ), 1 )
+ CALL DCOPY( N, LE( 1, I+1 ), 1, LE( 1, 3 ), 1 )
+ END IF
+ 190 CONTINUE
+ IF( IFND.EQ.0 ) THEN
+ ICMP = 1
+ ELSE
+ ICMP = 3
+ END IF
+ ELSE
+ LCMP( 1 ) = 1
+ LCMP( 2 ) = 2
+ IFND = 0
+ DO 200 I = 3, N
+ IF( IFND.EQ.1 .OR. WI( I ).NE.ZERO ) THEN
+ SELECT( I ) = .FALSE.
+ ELSE
+ LCMP( 3 ) = I
+ IFND = 1
+ CALL DCOPY( N, RE( 1, I ), 1, RE( 1, 3 ), 1 )
+ CALL DCOPY( N, LE( 1, I ), 1, LE( 1, 3 ), 1 )
+ END IF
+ 200 CONTINUE
+ IF( IFND.EQ.0 ) THEN
+ ICMP = 2
+ ELSE
+ ICMP = 3
+ END IF
+ END IF
+*
+* Compute all selected condition numbers
+*
+ CALL DCOPY( ICMP, DUM, 0, STMP, 1 )
+ CALL DCOPY( ICMP, DUM, 0, SEPTMP, 1 )
+ CALL DTRSNA( 'Bothcond', 'Some', SELECT, N, T, LDT, LE, LDT,
+ $ RE, LDT, STMP, SEPTMP, N, M, WORK, N, IWORK,
+ $ INFO )
+ IF( INFO.NE.0 ) THEN
+ LMAX( 3 ) = KNT
+ NINFO( 3 ) = NINFO( 3 ) + 1
+ GO TO 240
+ END IF
+ DO 210 I = 1, ICMP
+ J = LCMP( I )
+ IF( SEPTMP( I ).NE.SEP( J ) )
+ $ VMAX = ONE / EPS
+ IF( STMP( I ).NE.S( J ) )
+ $ VMAX = ONE / EPS
+ 210 CONTINUE
+*
+* Compute selected eigenvalue condition numbers
+*
+ CALL DCOPY( ICMP, DUM, 0, STMP, 1 )
+ CALL DCOPY( ICMP, DUM, 0, SEPTMP, 1 )
+ CALL DTRSNA( 'Eigcond', 'Some', SELECT, N, T, LDT, LE, LDT, RE,
+ $ LDT, STMP, SEPTMP, N, M, WORK, N, IWORK, INFO )
+ IF( INFO.NE.0 ) THEN
+ LMAX( 3 ) = KNT
+ NINFO( 3 ) = NINFO( 3 ) + 1
+ GO TO 240
+ END IF
+ DO 220 I = 1, ICMP
+ J = LCMP( I )
+ IF( STMP( I ).NE.S( J ) )
+ $ VMAX = ONE / EPS
+ IF( SEPTMP( I ).NE.DUM( 1 ) )
+ $ VMAX = ONE / EPS
+ 220 CONTINUE
+*
+* Compute selected eigenvector condition numbers
+*
+ CALL DCOPY( ICMP, DUM, 0, STMP, 1 )
+ CALL DCOPY( ICMP, DUM, 0, SEPTMP, 1 )
+ CALL DTRSNA( 'Veccond', 'Some', SELECT, N, T, LDT, LE, LDT, RE,
+ $ LDT, STMP, SEPTMP, N, M, WORK, N, IWORK, INFO )
+ IF( INFO.NE.0 ) THEN
+ LMAX( 3 ) = KNT
+ NINFO( 3 ) = NINFO( 3 ) + 1
+ GO TO 240
+ END IF
+ DO 230 I = 1, ICMP
+ J = LCMP( I )
+ IF( STMP( I ).NE.DUM( 1 ) )
+ $ VMAX = ONE / EPS
+ IF( SEPTMP( I ).NE.SEP( J ) )
+ $ VMAX = ONE / EPS
+ 230 CONTINUE
+ IF( VMAX.GT.RMAX( 1 ) ) THEN
+ RMAX( 1 ) = VMAX
+ IF( NINFO( 1 ).EQ.0 )
+ $ LMAX( 1 ) = KNT
+ END IF
+ 240 CONTINUE
+ GO TO 10
+*
+* End of DGET37
+*
+ END
+ SUBROUTINE DGET38( RMAX, LMAX, NINFO, KNT, NIN )
+*
+* -- LAPACK test routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER KNT, NIN
+* ..
+* .. Array Arguments ..
+ INTEGER LMAX( 3 ), NINFO( 3 )
+ DOUBLE PRECISION RMAX( 3 )
+* ..
+*
+* Purpose
+* =======
+*
+* DGET38 tests DTRSEN, a routine for estimating condition numbers of a
+* cluster of eigenvalues and/or its associated right invariant subspace
+*
+* The test matrices are read from a file with logical unit number NIN.
+*
+* Arguments
+* ==========
+*
+* RMAX (output) DOUBLE PRECISION array, dimension (3)
+* Values of the largest test ratios.
+* RMAX(1) = largest residuals from DHST01 or comparing
+* different calls to DTRSEN
+* RMAX(2) = largest error in reciprocal condition
+* numbers taking their conditioning into account
+* RMAX(3) = largest error in reciprocal condition
+* numbers not taking their conditioning into
+* account (may be larger than RMAX(2))
+*
+* LMAX (output) INTEGER array, dimension (3)
+* LMAX(i) is example number where largest test ratio
+* RMAX(i) is achieved. Also:
+* If DGEHRD returns INFO nonzero on example i, LMAX(1)=i
+* If DHSEQR returns INFO nonzero on example i, LMAX(2)=i
+* If DTRSEN returns INFO nonzero on example i, LMAX(3)=i
+*
+* NINFO (output) INTEGER array, dimension (3)
+* NINFO(1) = No. of times DGEHRD returned INFO nonzero
+* NINFO(2) = No. of times DHSEQR returned INFO nonzero
+* NINFO(3) = No. of times DTRSEN returned INFO nonzero
+*
+* KNT (output) INTEGER
+* Total number of examples tested.
+*
+* NIN (input) INTEGER
+* Input logical unit number.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE, TWO
+ PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 )
+ DOUBLE PRECISION EPSIN
+ PARAMETER ( EPSIN = 5.9605D-8 )
+ INTEGER LDT, LWORK
+ PARAMETER ( LDT = 20, LWORK = 2*LDT*( 10+LDT ) )
+ INTEGER LIWORK
+ PARAMETER ( LIWORK = LDT*LDT )
+* ..
+* .. Local Scalars ..
+ INTEGER I, INFO, ISCL, ITMP, J, KMIN, M, N, NDIM
+ DOUBLE PRECISION BIGNUM, EPS, S, SEP, SEPIN, SEPTMP, SIN,
+ $ SMLNUM, STMP, TNRM, TOL, TOLIN, V, VIMIN, VMAX,
+ $ VMUL, VRMIN
+* ..
+* .. Local Arrays ..
+ LOGICAL SELECT( LDT )
+ INTEGER IPNT( LDT ), ISELEC( LDT ), IWORK( LIWORK )
+ DOUBLE PRECISION Q( LDT, LDT ), QSAV( LDT, LDT ),
+ $ QTMP( LDT, LDT ), RESULT( 2 ), T( LDT, LDT ),
+ $ TMP( LDT, LDT ), TSAV( LDT, LDT ),
+ $ TSAV1( LDT, LDT ), TTMP( LDT, LDT ), VAL( 3 ),
+ $ WI( LDT ), WITMP( LDT ), WORK( LWORK ),
+ $ WR( LDT ), WRTMP( LDT )
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DLAMCH, DLANGE
+ EXTERNAL DLAMCH, DLANGE
+* ..
+* .. External Subroutines ..
+ EXTERNAL DCOPY, DGEHRD, DHSEQR, DHST01, DLABAD, DLACPY,
+ $ DORGHR, DSCAL, DTRSEN
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC DBLE, MAX, SQRT
+* ..
+* .. Executable Statements ..
+*
+ EPS = DLAMCH( 'P' )
+ SMLNUM = DLAMCH( 'S' ) / EPS
+ BIGNUM = ONE / SMLNUM
+ CALL DLABAD( SMLNUM, BIGNUM )
+*
+* EPSIN = 2**(-24) = precision to which input data computed
+*
+ EPS = MAX( EPS, EPSIN )
+ RMAX( 1 ) = ZERO
+ RMAX( 2 ) = ZERO
+ RMAX( 3 ) = ZERO
+ LMAX( 1 ) = 0
+ LMAX( 2 ) = 0
+ LMAX( 3 ) = 0
+ KNT = 0
+ NINFO( 1 ) = 0
+ NINFO( 2 ) = 0
+ NINFO( 3 ) = 0
+*
+ VAL( 1 ) = SQRT( SMLNUM )
+ VAL( 2 ) = ONE
+ VAL( 3 ) = SQRT( SQRT( BIGNUM ) )
+*
+* Read input data until N=0. Assume input eigenvalues are sorted
+* lexicographically (increasing by real part, then decreasing by
+* imaginary part)
+*
+ 10 CONTINUE
+ READ( NIN, FMT = * )N, NDIM
+ IF( N.EQ.0 )
+ $ RETURN
+ READ( NIN, FMT = * )( ISELEC( I ), I = 1, NDIM )
+ DO 20 I = 1, N
+ READ( NIN, FMT = * )( TMP( I, J ), J = 1, N )
+ 20 CONTINUE
+ READ( NIN, FMT = * )SIN, SEPIN
+*
+ TNRM = DLANGE( 'M', N, N, TMP, LDT, WORK )
+ DO 160 ISCL = 1, 3
+*
+* Scale input matrix
+*
+ KNT = KNT + 1
+ CALL DLACPY( 'F', N, N, TMP, LDT, T, LDT )
+ VMUL = VAL( ISCL )
+ DO 30 I = 1, N
+ CALL DSCAL( N, VMUL, T( 1, I ), 1 )
+ 30 CONTINUE
+ IF( TNRM.EQ.ZERO )
+ $ VMUL = ONE
+ CALL DLACPY( 'F', N, N, T, LDT, TSAV, LDT )
+*
+* Compute Schur form
+*
+ CALL DGEHRD( N, 1, N, T, LDT, WORK( 1 ), WORK( N+1 ), LWORK-N,
+ $ INFO )
+ IF( INFO.NE.0 ) THEN
+ LMAX( 1 ) = KNT
+ NINFO( 1 ) = NINFO( 1 ) + 1
+ GO TO 160
+ END IF
+*
+* Generate orthogonal matrix
+*
+ CALL DLACPY( 'L', N, N, T, LDT, Q, LDT )
+ CALL DORGHR( N, 1, N, Q, LDT, WORK( 1 ), WORK( N+1 ), LWORK-N,
+ $ INFO )
+*
+* Compute Schur form
+*
+ CALL DHSEQR( 'S', 'V', N, 1, N, T, LDT, WR, WI, Q, LDT, WORK,
+ $ LWORK, INFO )
+ IF( INFO.NE.0 ) THEN
+ LMAX( 2 ) = KNT
+ NINFO( 2 ) = NINFO( 2 ) + 1
+ GO TO 160
+ END IF
+*
+* Sort, select eigenvalues
+*
+ DO 40 I = 1, N
+ IPNT( I ) = I
+ SELECT( I ) = .FALSE.
+ 40 CONTINUE
+ CALL DCOPY( N, WR, 1, WRTMP, 1 )
+ CALL DCOPY( N, WI, 1, WITMP, 1 )
+ DO 60 I = 1, N - 1
+ KMIN = I
+ VRMIN = WRTMP( I )
+ VIMIN = WITMP( I )
+ DO 50 J = I + 1, N
+ IF( WRTMP( J ).LT.VRMIN ) THEN
+ KMIN = J
+ VRMIN = WRTMP( J )
+ VIMIN = WITMP( J )
+ END IF
+ 50 CONTINUE
+ WRTMP( KMIN ) = WRTMP( I )
+ WITMP( KMIN ) = WITMP( I )
+ WRTMP( I ) = VRMIN
+ WITMP( I ) = VIMIN
+ ITMP = IPNT( I )
+ IPNT( I ) = IPNT( KMIN )
+ IPNT( KMIN ) = ITMP
+ 60 CONTINUE
+ DO 70 I = 1, NDIM
+ SELECT( IPNT( ISELEC( I ) ) ) = .TRUE.
+ 70 CONTINUE
+*
+* Compute condition numbers
+*
+ CALL DLACPY( 'F', N, N, Q, LDT, QSAV, LDT )
+ CALL DLACPY( 'F', N, N, T, LDT, TSAV1, LDT )
+ CALL DTRSEN( 'B', 'V', SELECT, N, T, LDT, Q, LDT, WRTMP, WITMP,
+ $ M, S, SEP, WORK, LWORK, IWORK, LIWORK, INFO )
+ IF( INFO.NE.0 ) THEN
+ LMAX( 3 ) = KNT
+ NINFO( 3 ) = NINFO( 3 ) + 1
+ GO TO 160
+ END IF
+ SEPTMP = SEP / VMUL
+ STMP = S
+*
+* Compute residuals
+*
+ CALL DHST01( N, 1, N, TSAV, LDT, T, LDT, Q, LDT, WORK, LWORK,
+ $ RESULT )
+ VMAX = MAX( RESULT( 1 ), RESULT( 2 ) )
+ IF( VMAX.GT.RMAX( 1 ) ) THEN
+ RMAX( 1 ) = VMAX
+ IF( NINFO( 1 ).EQ.0 )
+ $ LMAX( 1 ) = KNT
+ END IF
+*
+* Compare condition number for eigenvalue cluster
+* taking its condition number into account
+*
+ V = MAX( TWO*DBLE( N )*EPS*TNRM, SMLNUM )
+ IF( TNRM.EQ.ZERO )
+ $ V = ONE
+ IF( V.GT.SEPTMP ) THEN
+ TOL = ONE
+ ELSE
+ TOL = V / SEPTMP
+ END IF
+ IF( V.GT.SEPIN ) THEN
+ TOLIN = ONE
+ ELSE
+ TOLIN = V / SEPIN
+ END IF
+ TOL = MAX( TOL, SMLNUM / EPS )
+ TOLIN = MAX( TOLIN, SMLNUM / EPS )
+ IF( EPS*( SIN-TOLIN ).GT.STMP+TOL ) THEN
+ VMAX = ONE / EPS
+ ELSE IF( SIN-TOLIN.GT.STMP+TOL ) THEN
+ VMAX = ( SIN-TOLIN ) / ( STMP+TOL )
+ ELSE IF( SIN+TOLIN.LT.EPS*( STMP-TOL ) ) THEN
+ VMAX = ONE / EPS
+ ELSE IF( SIN+TOLIN.LT.STMP-TOL ) THEN
+ VMAX = ( STMP-TOL ) / ( SIN+TOLIN )
+ ELSE
+ VMAX = ONE
+ END IF
+ IF( VMAX.GT.RMAX( 2 ) ) THEN
+ RMAX( 2 ) = VMAX
+ IF( NINFO( 2 ).EQ.0 )
+ $ LMAX( 2 ) = KNT
+ END IF
+*
+* Compare condition numbers for invariant subspace
+* taking its condition number into account
+*
+ IF( V.GT.SEPTMP*STMP ) THEN
+ TOL = SEPTMP
+ ELSE
+ TOL = V / STMP
+ END IF
+ IF( V.GT.SEPIN*SIN ) THEN
+ TOLIN = SEPIN
+ ELSE
+ TOLIN = V / SIN
+ END IF
+ TOL = MAX( TOL, SMLNUM / EPS )
+ TOLIN = MAX( TOLIN, SMLNUM / EPS )
+ IF( EPS*( SEPIN-TOLIN ).GT.SEPTMP+TOL ) THEN
+ VMAX = ONE / EPS
+ ELSE IF( SEPIN-TOLIN.GT.SEPTMP+TOL ) THEN
+ VMAX = ( SEPIN-TOLIN ) / ( SEPTMP+TOL )
+ ELSE IF( SEPIN+TOLIN.LT.EPS*( SEPTMP-TOL ) ) THEN
+ VMAX = ONE / EPS
+ ELSE IF( SEPIN+TOLIN.LT.SEPTMP-TOL ) THEN
+ VMAX = ( SEPTMP-TOL ) / ( SEPIN+TOLIN )
+ ELSE
+ VMAX = ONE
+ END IF
+ IF( VMAX.GT.RMAX( 2 ) ) THEN
+ RMAX( 2 ) = VMAX
+ IF( NINFO( 2 ).EQ.0 )
+ $ LMAX( 2 ) = KNT
+ END IF
+*
+* Compare condition number for eigenvalue cluster
+* without taking its condition number into account
+*
+ IF( SIN.LE.DBLE( 2*N )*EPS .AND. STMP.LE.DBLE( 2*N )*EPS ) THEN
+ VMAX = ONE
+ ELSE IF( EPS*SIN.GT.STMP ) THEN
+ VMAX = ONE / EPS
+ ELSE IF( SIN.GT.STMP ) THEN
+ VMAX = SIN / STMP
+ ELSE IF( SIN.LT.EPS*STMP ) THEN
+ VMAX = ONE / EPS
+ ELSE IF( SIN.LT.STMP ) THEN
+ VMAX = STMP / SIN
+ ELSE
+ VMAX = ONE
+ END IF
+ IF( VMAX.GT.RMAX( 3 ) ) THEN
+ RMAX( 3 ) = VMAX
+ IF( NINFO( 3 ).EQ.0 )
+ $ LMAX( 3 ) = KNT
+ END IF
+*
+* Compare condition numbers for invariant subspace
+* without taking its condition number into account
+*
+ IF( SEPIN.LE.V .AND. SEPTMP.LE.V ) THEN
+ VMAX = ONE
+ ELSE IF( EPS*SEPIN.GT.SEPTMP ) THEN
+ VMAX = ONE / EPS
+ ELSE IF( SEPIN.GT.SEPTMP ) THEN
+ VMAX = SEPIN / SEPTMP
+ ELSE IF( SEPIN.LT.EPS*SEPTMP ) THEN
+ VMAX = ONE / EPS
+ ELSE IF( SEPIN.LT.SEPTMP ) THEN
+ VMAX = SEPTMP / SEPIN
+ ELSE
+ VMAX = ONE
+ END IF
+ IF( VMAX.GT.RMAX( 3 ) ) THEN
+ RMAX( 3 ) = VMAX
+ IF( NINFO( 3 ).EQ.0 )
+ $ LMAX( 3 ) = KNT
+ END IF
+*
+* Compute eigenvalue condition number only and compare
+* Update Q
+*
+ VMAX = ZERO
+ CALL DLACPY( 'F', N, N, TSAV1, LDT, TTMP, LDT )
+ CALL DLACPY( 'F', N, N, QSAV, LDT, QTMP, LDT )
+ SEPTMP = -ONE
+ STMP = -ONE
+ CALL DTRSEN( 'E', 'V', SELECT, N, TTMP, LDT, QTMP, LDT, WRTMP,
+ $ WITMP, M, STMP, SEPTMP, WORK, LWORK, IWORK,
+ $ LIWORK, INFO )
+ IF( INFO.NE.0 ) THEN
+ LMAX( 3 ) = KNT
+ NINFO( 3 ) = NINFO( 3 ) + 1
+ GO TO 160
+ END IF
+ IF( S.NE.STMP )
+ $ VMAX = ONE / EPS
+ IF( -ONE.NE.SEPTMP )
+ $ VMAX = ONE / EPS
+ DO 90 I = 1, N
+ DO 80 J = 1, N
+ IF( TTMP( I, J ).NE.T( I, J ) )
+ $ VMAX = ONE / EPS
+ IF( QTMP( I, J ).NE.Q( I, J ) )
+ $ VMAX = ONE / EPS
+ 80 CONTINUE
+ 90 CONTINUE
+*
+* Compute invariant subspace condition number only and compare
+* Update Q
+*
+ CALL DLACPY( 'F', N, N, TSAV1, LDT, TTMP, LDT )
+ CALL DLACPY( 'F', N, N, QSAV, LDT, QTMP, LDT )
+ SEPTMP = -ONE
+ STMP = -ONE
+ CALL DTRSEN( 'V', 'V', SELECT, N, TTMP, LDT, QTMP, LDT, WRTMP,
+ $ WITMP, M, STMP, SEPTMP, WORK, LWORK, IWORK,
+ $ LIWORK, INFO )
+ IF( INFO.NE.0 ) THEN
+ LMAX( 3 ) = KNT
+ NINFO( 3 ) = NINFO( 3 ) + 1
+ GO TO 160
+ END IF
+ IF( -ONE.NE.STMP )
+ $ VMAX = ONE / EPS
+ IF( SEP.NE.SEPTMP )
+ $ VMAX = ONE / EPS
+ DO 110 I = 1, N
+ DO 100 J = 1, N
+ IF( TTMP( I, J ).NE.T( I, J ) )
+ $ VMAX = ONE / EPS
+ IF( QTMP( I, J ).NE.Q( I, J ) )
+ $ VMAX = ONE / EPS
+ 100 CONTINUE
+ 110 CONTINUE
+*
+* Compute eigenvalue condition number only and compare
+* Do not update Q
+*
+ CALL DLACPY( 'F', N, N, TSAV1, LDT, TTMP, LDT )
+ CALL DLACPY( 'F', N, N, QSAV, LDT, QTMP, LDT )
+ SEPTMP = -ONE
+ STMP = -ONE
+ CALL DTRSEN( 'E', 'N', SELECT, N, TTMP, LDT, QTMP, LDT, WRTMP,
+ $ WITMP, M, STMP, SEPTMP, WORK, LWORK, IWORK,
+ $ LIWORK, INFO )
+ IF( INFO.NE.0 ) THEN
+ LMAX( 3 ) = KNT
+ NINFO( 3 ) = NINFO( 3 ) + 1
+ GO TO 160
+ END IF
+ IF( S.NE.STMP )
+ $ VMAX = ONE / EPS
+ IF( -ONE.NE.SEPTMP )
+ $ VMAX = ONE / EPS
+ DO 130 I = 1, N
+ DO 120 J = 1, N
+ IF( TTMP( I, J ).NE.T( I, J ) )
+ $ VMAX = ONE / EPS
+ IF( QTMP( I, J ).NE.QSAV( I, J ) )
+ $ VMAX = ONE / EPS
+ 120 CONTINUE
+ 130 CONTINUE
+*
+* Compute invariant subspace condition number only and compare
+* Do not update Q
+*
+ CALL DLACPY( 'F', N, N, TSAV1, LDT, TTMP, LDT )
+ CALL DLACPY( 'F', N, N, QSAV, LDT, QTMP, LDT )
+ SEPTMP = -ONE
+ STMP = -ONE
+ CALL DTRSEN( 'V', 'N', SELECT, N, TTMP, LDT, QTMP, LDT, WRTMP,
+ $ WITMP, M, STMP, SEPTMP, WORK, LWORK, IWORK,
+ $ LIWORK, INFO )
+ IF( INFO.NE.0 ) THEN
+ LMAX( 3 ) = KNT
+ NINFO( 3 ) = NINFO( 3 ) + 1
+ GO TO 160
+ END IF
+ IF( -ONE.NE.STMP )
+ $ VMAX = ONE / EPS
+ IF( SEP.NE.SEPTMP )
+ $ VMAX = ONE / EPS
+ DO 150 I = 1, N
+ DO 140 J = 1, N
+ IF( TTMP( I, J ).NE.T( I, J ) )
+ $ VMAX = ONE / EPS
+ IF( QTMP( I, J ).NE.QSAV( I, J ) )
+ $ VMAX = ONE / EPS
+ 140 CONTINUE
+ 150 CONTINUE
+ IF( VMAX.GT.RMAX( 1 ) ) THEN
+ RMAX( 1 ) = VMAX
+ IF( NINFO( 1 ).EQ.0 )
+ $ LMAX( 1 ) = KNT
+ END IF
+ 160 CONTINUE
+ GO TO 10
+*
+* End of DGET38
+*
+ END
+ SUBROUTINE DGET39( RMAX, LMAX, NINFO, KNT )
+*
+* -- LAPACK test routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER KNT, LMAX, NINFO
+ DOUBLE PRECISION RMAX
+* ..
+*
+* Purpose
+* =======
+*
+* DGET39 tests DLAQTR, a routine for solving the real or
+* special complex quasi upper triangular system
+*
+* op(T)*p = scale*c,
+* or
+* op(T + iB)*(p+iq) = scale*(c+id),
+*
+* in real arithmetic. T is upper quasi-triangular.
+* If it is complex, then the first diagonal block of T must be
+* 1 by 1, B has the special structure
+*
+* B = [ b(1) b(2) ... b(n) ]
+* [ w ]
+* [ w ]
+* [ . ]
+* [ w ]
+*
+* op(A) = A or A', where A' denotes the conjugate transpose of
+* the matrix A.
+*
+* On input, X = [ c ]. On output, X = [ p ].
+* [ d ] [ q ]
+*
+* Scale is an output less than or equal to 1, chosen to avoid
+* overflow in X.
+* This subroutine is specially designed for the condition number
+* estimation in the eigenproblem routine DTRSNA.
+*
+* The test code verifies that the following residual is order 1:
+*
+* ||(T+i*B)*(x1+i*x2) - scale*(d1+i*d2)||
+* -----------------------------------------
+* max(ulp*(||T||+||B||)*(||x1||+||x2||),
+* (||T||+||B||)*smlnum/ulp,
+* smlnum)
+*
+* (The (||T||+||B||)*smlnum/ulp term accounts for possible
+* (gradual or nongradual) underflow in x1 and x2.)
+*
+* Arguments
+* ==========
+*
+* RMAX (output) DOUBLE PRECISION
+* Value of the largest test ratio.
+*
+* LMAX (output) INTEGER
+* Example number where largest test ratio achieved.
+*
+* NINFO (output) INTEGER
+* Number of examples where INFO is nonzero.
+*
+* KNT (output) INTEGER
+* Total number of examples tested.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ INTEGER LDT, LDT2
+ PARAMETER ( LDT = 10, LDT2 = 2*LDT )
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, INFO, IVM1, IVM2, IVM3, IVM4, IVM5, J, K, N,
+ $ NDIM
+ DOUBLE PRECISION BIGNUM, DOMIN, DUMM, EPS, NORM, NORMTB, RESID,
+ $ SCALE, SMLNUM, W, XNORM
+* ..
+* .. External Functions ..
+ INTEGER IDAMAX
+ DOUBLE PRECISION DASUM, DDOT, DLAMCH, DLANGE
+ EXTERNAL IDAMAX, DASUM, DDOT, DLAMCH, DLANGE
+* ..
+* .. External Subroutines ..
+ EXTERNAL DCOPY, DGEMV, DLABAD, DLAQTR
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, COS, DBLE, MAX, SIN, SQRT
+* ..
+* .. Local Arrays ..
+ INTEGER IDIM( 6 ), IVAL( 5, 5, 6 )
+ DOUBLE PRECISION B( LDT ), D( LDT2 ), DUM( 1 ), T( LDT, LDT ),
+ $ VM1( 5 ), VM2( 5 ), VM3( 5 ), VM4( 5 ),
+ $ VM5( 3 ), WORK( LDT ), X( LDT2 ), Y( LDT2 )
+* ..
+* .. Data statements ..
+ DATA IDIM / 4, 5*5 /
+ DATA IVAL / 3, 4*0, 1, 1, -1, 0, 0, 3, 2, 1, 0, 0,
+ $ 4, 3, 2, 2, 0, 5*0, 1, 4*0, 2, 2, 3*0, 3, 3, 4,
+ $ 0, 0, 4, 2, 2, 3, 0, 4*1, 5, 1, 4*0, 2, 4, -2,
+ $ 0, 0, 3, 3, 4, 0, 0, 4, 2, 2, 3, 0, 5*1, 1,
+ $ 4*0, 2, 1, -1, 0, 0, 9, 8, 1, 0, 0, 4, 9, 1, 2,
+ $ -1, 5*2, 9, 4*0, 6, 4, 0, 0, 0, 3, 2, 1, 1, 0,
+ $ 5, 1, -1, 1, 0, 5*2, 4, 4*0, 2, 2, 0, 0, 0, 1,
+ $ 4, 4, 0, 0, 2, 4, 2, 2, -1, 5*2 /
+* ..
+* .. Executable Statements ..
+*
+* Get machine parameters
+*
+ EPS = DLAMCH( 'P' )
+ SMLNUM = DLAMCH( 'S' )
+ BIGNUM = ONE / SMLNUM
+ CALL DLABAD( SMLNUM, BIGNUM )
+*
+* Set up test case parameters
+*
+ VM1( 1 ) = ONE
+ VM1( 2 ) = SQRT( SMLNUM )
+ VM1( 3 ) = SQRT( VM1( 2 ) )
+ VM1( 4 ) = SQRT( BIGNUM )
+ VM1( 5 ) = SQRT( VM1( 4 ) )
+*
+ VM2( 1 ) = ONE
+ VM2( 2 ) = SQRT( SMLNUM )
+ VM2( 3 ) = SQRT( VM2( 2 ) )
+ VM2( 4 ) = SQRT( BIGNUM )
+ VM2( 5 ) = SQRT( VM2( 4 ) )
+*
+ VM3( 1 ) = ONE
+ VM3( 2 ) = SQRT( SMLNUM )
+ VM3( 3 ) = SQRT( VM3( 2 ) )
+ VM3( 4 ) = SQRT( BIGNUM )
+ VM3( 5 ) = SQRT( VM3( 4 ) )
+*
+ VM4( 1 ) = ONE
+ VM4( 2 ) = SQRT( SMLNUM )
+ VM4( 3 ) = SQRT( VM4( 2 ) )
+ VM4( 4 ) = SQRT( BIGNUM )
+ VM4( 5 ) = SQRT( VM4( 4 ) )
+*
+ VM5( 1 ) = ONE
+ VM5( 2 ) = EPS
+ VM5( 3 ) = SQRT( SMLNUM )
+*
+* Initalization
+*
+ KNT = 0
+ RMAX = ZERO
+ NINFO = 0
+ SMLNUM = SMLNUM / EPS
+*
+* Begin test loop
+*
+ DO 140 IVM5 = 1, 3
+ DO 130 IVM4 = 1, 5
+ DO 120 IVM3 = 1, 5
+ DO 110 IVM2 = 1, 5
+ DO 100 IVM1 = 1, 5
+ DO 90 NDIM = 1, 6
+*
+ N = IDIM( NDIM )
+ DO 20 I = 1, N
+ DO 10 J = 1, N
+ T( I, J ) = DBLE( IVAL( I, J, NDIM ) )*
+ $ VM1( IVM1 )
+ IF( I.GE.J )
+ $ T( I, J ) = T( I, J )*VM5( IVM5 )
+ 10 CONTINUE
+ 20 CONTINUE
+*
+ W = ONE*VM2( IVM2 )
+*
+ DO 30 I = 1, N
+ B( I ) = COS( DBLE( I ) )*VM3( IVM3 )
+ 30 CONTINUE
+*
+ DO 40 I = 1, 2*N
+ D( I ) = SIN( DBLE( I ) )*VM4( IVM4 )
+ 40 CONTINUE
+*
+ NORM = DLANGE( '1', N, N, T, LDT, WORK )
+ K = IDAMAX( N, B, 1 )
+ NORMTB = NORM + ABS( B( K ) ) + ABS( W )
+*
+ CALL DCOPY( N, D, 1, X, 1 )
+ KNT = KNT + 1
+ CALL DLAQTR( .FALSE., .TRUE., N, T, LDT, DUM,
+ $ DUMM, SCALE, X, WORK, INFO )
+ IF( INFO.NE.0 )
+ $ NINFO = NINFO + 1
+*
+* || T*x - scale*d || /
+* max(ulp*||T||*||x||,smlnum/ulp*||T||,smlnum)
+*
+ CALL DCOPY( N, D, 1, Y, 1 )
+ CALL DGEMV( 'No transpose', N, N, ONE, T, LDT,
+ $ X, 1, -SCALE, Y, 1 )
+ XNORM = DASUM( N, X, 1 )
+ RESID = DASUM( N, Y, 1 )
+ DOMIN = MAX( SMLNUM, ( SMLNUM / EPS )*NORM,
+ $ ( NORM*EPS )*XNORM )
+ RESID = RESID / DOMIN
+ IF( RESID.GT.RMAX ) THEN
+ RMAX = RESID
+ LMAX = KNT
+ END IF
+*
+ CALL DCOPY( N, D, 1, X, 1 )
+ KNT = KNT + 1
+ CALL DLAQTR( .TRUE., .TRUE., N, T, LDT, DUM,
+ $ DUMM, SCALE, X, WORK, INFO )
+ IF( INFO.NE.0 )
+ $ NINFO = NINFO + 1
+*
+* || T*x - scale*d || /
+* max(ulp*||T||*||x||,smlnum/ulp*||T||,smlnum)
+*
+ CALL DCOPY( N, D, 1, Y, 1 )
+ CALL DGEMV( 'Transpose', N, N, ONE, T, LDT, X,
+ $ 1, -SCALE, Y, 1 )
+ XNORM = DASUM( N, X, 1 )
+ RESID = DASUM( N, Y, 1 )
+ DOMIN = MAX( SMLNUM, ( SMLNUM / EPS )*NORM,
+ $ ( NORM*EPS )*XNORM )
+ RESID = RESID / DOMIN
+ IF( RESID.GT.RMAX ) THEN
+ RMAX = RESID
+ LMAX = KNT
+ END IF
+*
+ CALL DCOPY( 2*N, D, 1, X, 1 )
+ KNT = KNT + 1
+ CALL DLAQTR( .FALSE., .FALSE., N, T, LDT, B, W,
+ $ SCALE, X, WORK, INFO )
+ IF( INFO.NE.0 )
+ $ NINFO = NINFO + 1
+*
+* ||(T+i*B)*(x1+i*x2) - scale*(d1+i*d2)|| /
+* max(ulp*(||T||+||B||)*(||x1||+||x2||),
+* smlnum/ulp * (||T||+||B||), smlnum )
+*
+*
+ CALL DCOPY( 2*N, D, 1, Y, 1 )
+ Y( 1 ) = DDOT( N, B, 1, X( 1+N ), 1 ) +
+ $ SCALE*Y( 1 )
+ DO 50 I = 2, N
+ Y( I ) = W*X( I+N ) + SCALE*Y( I )
+ 50 CONTINUE
+ CALL DGEMV( 'No transpose', N, N, ONE, T, LDT,
+ $ X, 1, -ONE, Y, 1 )
+*
+ Y( 1+N ) = DDOT( N, B, 1, X, 1 ) -
+ $ SCALE*Y( 1+N )
+ DO 60 I = 2, N
+ Y( I+N ) = W*X( I ) - SCALE*Y( I+N )
+ 60 CONTINUE
+ CALL DGEMV( 'No transpose', N, N, ONE, T, LDT,
+ $ X( 1+N ), 1, ONE, Y( 1+N ), 1 )
+*
+ RESID = DASUM( 2*N, Y, 1 )
+ DOMIN = MAX( SMLNUM, ( SMLNUM / EPS )*NORMTB,
+ $ EPS*( NORMTB*DASUM( 2*N, X, 1 ) ) )
+ RESID = RESID / DOMIN
+ IF( RESID.GT.RMAX ) THEN
+ RMAX = RESID
+ LMAX = KNT
+ END IF
+*
+ CALL DCOPY( 2*N, D, 1, X, 1 )
+ KNT = KNT + 1
+ CALL DLAQTR( .TRUE., .FALSE., N, T, LDT, B, W,
+ $ SCALE, X, WORK, INFO )
+ IF( INFO.NE.0 )
+ $ NINFO = NINFO + 1
+*
+* ||(T+i*B)*(x1+i*x2) - scale*(d1+i*d2)|| /
+* max(ulp*(||T||+||B||)*(||x1||+||x2||),
+* smlnum/ulp * (||T||+||B||), smlnum )
+*
+ CALL DCOPY( 2*N, D, 1, Y, 1 )
+ Y( 1 ) = B( 1 )*X( 1+N ) - SCALE*Y( 1 )
+ DO 70 I = 2, N
+ Y( I ) = B( I )*X( 1+N ) + W*X( I+N ) -
+ $ SCALE*Y( I )
+ 70 CONTINUE
+ CALL DGEMV( 'Transpose', N, N, ONE, T, LDT, X,
+ $ 1, ONE, Y, 1 )
+*
+ Y( 1+N ) = B( 1 )*X( 1 ) + SCALE*Y( 1+N )
+ DO 80 I = 2, N
+ Y( I+N ) = B( I )*X( 1 ) + W*X( I ) +
+ $ SCALE*Y( I+N )
+ 80 CONTINUE
+ CALL DGEMV( 'Transpose', N, N, ONE, T, LDT,
+ $ X( 1+N ), 1, -ONE, Y( 1+N ), 1 )
+*
+ RESID = DASUM( 2*N, Y, 1 )
+ DOMIN = MAX( SMLNUM, ( SMLNUM / EPS )*NORMTB,
+ $ EPS*( NORMTB*DASUM( 2*N, X, 1 ) ) )
+ RESID = RESID / DOMIN
+ IF( RESID.GT.RMAX ) THEN
+ RMAX = RESID
+ LMAX = KNT
+ END IF
+*
+ 90 CONTINUE
+ 100 CONTINUE
+ 110 CONTINUE
+ 120 CONTINUE
+ 130 CONTINUE
+ 140 CONTINUE
+*
+ RETURN
+*
+* End of DGET39
+*
+ END
+ SUBROUTINE DGET51( ITYPE, N, A, LDA, B, LDB, U, LDU, V, LDV, WORK,
+ $ RESULT )
+*
+* -- LAPACK test routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER ITYPE, LDA, LDB, LDU, LDV, N
+ DOUBLE PRECISION RESULT
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION A( LDA, * ), B( LDB, * ), U( LDU, * ),
+ $ V( LDV, * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DGET51 generally checks a decomposition of the form
+*
+* A = U B V'
+*
+* where ' means transpose and U and V are orthogonal.
+*
+* Specifically, if ITYPE=1
+*
+* RESULT = | A - U B V' | / ( |A| n ulp )
+*
+* If ITYPE=2, then:
+*
+* RESULT = | A - B | / ( |A| n ulp )
+*
+* If ITYPE=3, then:
+*
+* RESULT = | I - UU' | / ( n ulp )
+*
+* Arguments
+* =========
+*
+* ITYPE (input) INTEGER
+* Specifies the type of tests to be performed.
+* =1: RESULT = | A - U B V' | / ( |A| n ulp )
+* =2: RESULT = | A - B | / ( |A| n ulp )
+* =3: RESULT = | I - UU' | / ( n ulp )
+*
+* N (input) INTEGER
+* The size of the matrix. If it is zero, DGET51 does nothing.
+* It must be at least zero.
+*
+* A (input) DOUBLE PRECISION array, dimension (LDA, N)
+* The original (unfactored) matrix.
+*
+* LDA (input) INTEGER
+* The leading dimension of A. It must be at least 1
+* and at least N.
+*
+* B (input) DOUBLE PRECISION array, dimension (LDB, N)
+* The factored matrix.
+*
+* LDB (input) INTEGER
+* The leading dimension of B. It must be at least 1
+* and at least N.
+*
+* U (input) DOUBLE PRECISION array, dimension (LDU, N)
+* The orthogonal matrix on the left-hand side in the
+* decomposition.
+* Not referenced if ITYPE=2
+*
+* LDU (input) INTEGER
+* The leading dimension of U. LDU must be at least N and
+* at least 1.
+*
+* V (input) DOUBLE PRECISION array, dimension (LDV, N)
+* The orthogonal matrix on the left-hand side in the
+* decomposition.
+* Not referenced if ITYPE=2
+*
+* LDV (input) INTEGER
+* The leading dimension of V. LDV must be at least N and
+* at least 1.
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (2*N**2)
+*
+* RESULT (output) DOUBLE PRECISION
+* The values computed by the test specified by ITYPE. The
+* value is currently limited to 1/ulp, to avoid overflow.
+* Errors are flagged by RESULT=10/ulp.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE, TEN
+ PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TEN = 10.0D0 )
+* ..
+* .. Local Scalars ..
+ INTEGER JCOL, JDIAG, JROW
+ DOUBLE PRECISION ANORM, ULP, UNFL, WNORM
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DLAMCH, DLANGE
+ EXTERNAL DLAMCH, DLANGE
+* ..
+* .. External Subroutines ..
+ EXTERNAL DGEMM, DLACPY
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC DBLE, MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+ RESULT = ZERO
+ IF( N.LE.0 )
+ $ RETURN
+*
+* Constants
+*
+ UNFL = DLAMCH( 'Safe minimum' )
+ ULP = DLAMCH( 'Epsilon' )*DLAMCH( 'Base' )
+*
+* Some Error Checks
+*
+ IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN
+ RESULT = TEN / ULP
+ RETURN
+ END IF
+*
+ IF( ITYPE.LE.2 ) THEN
+*
+* Tests scaled by the norm(A)
+*
+ ANORM = MAX( DLANGE( '1', N, N, A, LDA, WORK ), UNFL )
+*
+ IF( ITYPE.EQ.1 ) THEN
+*
+* ITYPE=1: Compute W = A - UBV'
+*
+ CALL DLACPY( ' ', N, N, A, LDA, WORK, N )
+ CALL DGEMM( 'N', 'N', N, N, N, ONE, U, LDU, B, LDB, ZERO,
+ $ WORK( N**2+1 ), N )
+*
+ CALL DGEMM( 'N', 'C', N, N, N, -ONE, WORK( N**2+1 ), N, V,
+ $ LDV, ONE, WORK, N )
+*
+ ELSE
+*
+* ITYPE=2: Compute W = A - B
+*
+ CALL DLACPY( ' ', N, N, B, LDB, WORK, N )
+*
+ DO 20 JCOL = 1, N
+ DO 10 JROW = 1, N
+ WORK( JROW+N*( JCOL-1 ) ) = WORK( JROW+N*( JCOL-1 ) )
+ $ - A( JROW, JCOL )
+ 10 CONTINUE
+ 20 CONTINUE
+ END IF
+*
+* Compute norm(W)/ ( ulp*norm(A) )
+*
+ WNORM = DLANGE( '1', N, N, WORK, N, WORK( N**2+1 ) )
+*
+ IF( ANORM.GT.WNORM ) THEN
+ RESULT = ( WNORM / ANORM ) / ( N*ULP )
+ ELSE
+ IF( ANORM.LT.ONE ) THEN
+ RESULT = ( MIN( WNORM, N*ANORM ) / ANORM ) / ( N*ULP )
+ ELSE
+ RESULT = MIN( WNORM / ANORM, DBLE( N ) ) / ( N*ULP )
+ END IF
+ END IF
+*
+ ELSE
+*
+* Tests not scaled by norm(A)
+*
+* ITYPE=3: Compute UU' - I
+*
+ CALL DGEMM( 'N', 'C', N, N, N, ONE, U, LDU, U, LDU, ZERO, WORK,
+ $ N )
+*
+ DO 30 JDIAG = 1, N
+ WORK( ( N+1 )*( JDIAG-1 )+1 ) = WORK( ( N+1 )*( JDIAG-1 )+
+ $ 1 ) - ONE
+ 30 CONTINUE
+*
+ RESULT = MIN( DLANGE( '1', N, N, WORK, N, WORK( N**2+1 ) ),
+ $ DBLE( N ) ) / ( N*ULP )
+ END IF
+*
+ RETURN
+*
+* End of DGET51
+*
+ END
+ SUBROUTINE DGET52( LEFT, N, A, LDA, B, LDB, E, LDE, ALPHAR,
+ $ ALPHAI, BETA, WORK, RESULT )
+*
+* -- LAPACK test routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ LOGICAL LEFT
+ INTEGER LDA, LDB, LDE, N
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION A( LDA, * ), ALPHAI( * ), ALPHAR( * ),
+ $ B( LDB, * ), BETA( * ), E( LDE, * ),
+ $ RESULT( 2 ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DGET52 does an eigenvector check for the generalized eigenvalue
+* problem.
+*
+* The basic test for right eigenvectors is:
+*
+* | b(j) A E(j) - a(j) B E(j) |
+* RESULT(1) = max -------------------------------
+* j n ulp max( |b(j) A|, |a(j) B| )
+*
+* using the 1-norm. Here, a(j)/b(j) = w is the j-th generalized
+* eigenvalue of A - w B, or, equivalently, b(j)/a(j) = m is the j-th
+* generalized eigenvalue of m A - B.
+*
+* For real eigenvalues, the test is straightforward. For complex
+* eigenvalues, E(j) and a(j) are complex, represented by
+* Er(j) + i*Ei(j) and ar(j) + i*ai(j), resp., so the test for that
+* eigenvector becomes
+*
+* max( |Wr|, |Wi| )
+* --------------------------------------------
+* n ulp max( |b(j) A|, (|ar(j)|+|ai(j)|) |B| )
+*
+* where
+*
+* Wr = b(j) A Er(j) - ar(j) B Er(j) + ai(j) B Ei(j)
+*
+* Wi = b(j) A Ei(j) - ai(j) B Er(j) - ar(j) B Ei(j)
+*
+* T T _
+* For left eigenvectors, A , B , a, and b are used.
+*
+* DGET52 also tests the normalization of E. Each eigenvector is
+* supposed to be normalized so that the maximum "absolute value"
+* of its elements is 1, where in this case, "absolute value"
+* of a complex value x is |Re(x)| + |Im(x)| ; let us call this
+* maximum "absolute value" norm of a vector v M(v).
+* if a(j)=b(j)=0, then the eigenvector is set to be the jth coordinate
+* vector. The normalization test is:
+*
+* RESULT(2) = max | M(v(j)) - 1 | / ( n ulp )
+* eigenvectors v(j)
+*
+* Arguments
+* =========
+*
+* LEFT (input) LOGICAL
+* =.TRUE.: The eigenvectors in the columns of E are assumed
+* to be *left* eigenvectors.
+* =.FALSE.: The eigenvectors in the columns of E are assumed
+* to be *right* eigenvectors.
+*
+* N (input) INTEGER
+* The size of the matrices. If it is zero, DGET52 does
+* nothing. It must be at least zero.
+*
+* A (input) DOUBLE PRECISION array, dimension (LDA, N)
+* The matrix A.
+*
+* LDA (input) INTEGER
+* The leading dimension of A. It must be at least 1
+* and at least N.
+*
+* B (input) DOUBLE PRECISION array, dimension (LDB, N)
+* The matrix B.
+*
+* LDB (input) INTEGER
+* The leading dimension of B. It must be at least 1
+* and at least N.
+*
+* E (input) DOUBLE PRECISION array, dimension (LDE, N)
+* The matrix of eigenvectors. It must be O( 1 ). Complex
+* eigenvalues and eigenvectors always come in pairs, the
+* eigenvalue and its conjugate being stored in adjacent
+* elements of ALPHAR, ALPHAI, and BETA. Thus, if a(j)/b(j)
+* and a(j+1)/b(j+1) are a complex conjugate pair of
+* generalized eigenvalues, then E(,j) contains the real part
+* of the eigenvector and E(,j+1) contains the imaginary part.
+* Note that whether E(,j) is a real eigenvector or part of a
+* complex one is specified by whether ALPHAI(j) is zero or not.
+*
+* LDE (input) INTEGER
+* The leading dimension of E. It must be at least 1 and at
+* least N.
+*
+* ALPHAR (input) DOUBLE PRECISION array, dimension (N)
+* The real parts of the values a(j) as described above, which,
+* along with b(j), define the generalized eigenvalues.
+* Complex eigenvalues always come in complex conjugate pairs
+* a(j)/b(j) and a(j+1)/b(j+1), which are stored in adjacent
+* elements in ALPHAR, ALPHAI, and BETA. Thus, if the j-th
+* and (j+1)-st eigenvalues form a pair, ALPHAR(j+1)/BETA(j+1)
+* is assumed to be equal to ALPHAR(j)/BETA(j).
+*
+* ALPHAI (input) DOUBLE PRECISION array, dimension (N)
+* The imaginary parts of the values a(j) as described above,
+* which, along with b(j), define the generalized eigenvalues.
+* If ALPHAI(j)=0, then the eigenvalue is real, otherwise it
+* is part of a complex conjugate pair. Complex eigenvalues
+* always come in complex conjugate pairs a(j)/b(j) and
+* a(j+1)/b(j+1), which are stored in adjacent elements in
+* ALPHAR, ALPHAI, and BETA. Thus, if the j-th and (j+1)-st
+* eigenvalues form a pair, ALPHAI(j+1)/BETA(j+1) is assumed to
+* be equal to -ALPHAI(j)/BETA(j). Also, nonzero values in
+* ALPHAI are assumed to always come in adjacent pairs.
+*
+* BETA (input) DOUBLE PRECISION array, dimension (N)
+* The values b(j) as described above, which, along with a(j),
+* define the generalized eigenvalues.
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (N**2+N)
+*
+* RESULT (output) DOUBLE PRECISION array, dimension (2)
+* The values computed by the test described above. If A E or
+* B E is likely to overflow, then RESULT(1:2) is set to
+* 10 / ulp.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE, TEN
+ PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TEN = 10.0D0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL ILCPLX
+ CHARACTER NORMAB, TRANS
+ INTEGER J, JVEC
+ DOUBLE PRECISION ABMAX, ACOEF, ALFMAX, ANORM, BCOEFI, BCOEFR,
+ $ BETMAX, BNORM, ENORM, ENRMER, ERRNRM, SAFMAX,
+ $ SAFMIN, SALFI, SALFR, SBETA, SCALE, TEMP1, ULP
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DLAMCH, DLANGE
+ EXTERNAL DLAMCH, DLANGE
+* ..
+* .. External Subroutines ..
+ EXTERNAL DGEMV
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, DBLE, MAX
+* ..
+* .. Executable Statements ..
+*
+ RESULT( 1 ) = ZERO
+ RESULT( 2 ) = ZERO
+ IF( N.LE.0 )
+ $ RETURN
+*
+ SAFMIN = DLAMCH( 'Safe minimum' )
+ SAFMAX = ONE / SAFMIN
+ ULP = DLAMCH( 'Epsilon' )*DLAMCH( 'Base' )
+*
+ IF( LEFT ) THEN
+ TRANS = 'T'
+ NORMAB = 'I'
+ ELSE
+ TRANS = 'N'
+ NORMAB = 'O'
+ END IF
+*
+* Norm of A, B, and E:
+*
+ ANORM = MAX( DLANGE( NORMAB, N, N, A, LDA, WORK ), SAFMIN )
+ BNORM = MAX( DLANGE( NORMAB, N, N, B, LDB, WORK ), SAFMIN )
+ ENORM = MAX( DLANGE( 'O', N, N, E, LDE, WORK ), ULP )
+ ALFMAX = SAFMAX / MAX( ONE, BNORM )
+ BETMAX = SAFMAX / MAX( ONE, ANORM )
+*
+* Compute error matrix.
+* Column i = ( b(i) A - a(i) B ) E(i) / max( |a(i) B| |b(i) A| )
+*
+ ILCPLX = .FALSE.
+ DO 10 JVEC = 1, N
+ IF( ILCPLX ) THEN
+*
+* 2nd Eigenvalue/-vector of pair -- do nothing
+*
+ ILCPLX = .FALSE.
+ ELSE
+ SALFR = ALPHAR( JVEC )
+ SALFI = ALPHAI( JVEC )
+ SBETA = BETA( JVEC )
+ IF( SALFI.EQ.ZERO ) THEN
+*
+* Real eigenvalue and -vector
+*
+ ABMAX = MAX( ABS( SALFR ), ABS( SBETA ) )
+ IF( ABS( SALFR ).GT.ALFMAX .OR. ABS( SBETA ).GT.
+ $ BETMAX .OR. ABMAX.LT.ONE ) THEN
+ SCALE = ONE / MAX( ABMAX, SAFMIN )
+ SALFR = SCALE*SALFR
+ SBETA = SCALE*SBETA
+ END IF
+ SCALE = ONE / MAX( ABS( SALFR )*BNORM,
+ $ ABS( SBETA )*ANORM, SAFMIN )
+ ACOEF = SCALE*SBETA
+ BCOEFR = SCALE*SALFR
+ CALL DGEMV( TRANS, N, N, ACOEF, A, LDA, E( 1, JVEC ), 1,
+ $ ZERO, WORK( N*( JVEC-1 )+1 ), 1 )
+ CALL DGEMV( TRANS, N, N, -BCOEFR, B, LDA, E( 1, JVEC ),
+ $ 1, ONE, WORK( N*( JVEC-1 )+1 ), 1 )
+ ELSE
+*
+* Complex conjugate pair
+*
+ ILCPLX = .TRUE.
+ IF( JVEC.EQ.N ) THEN
+ RESULT( 1 ) = TEN / ULP
+ RETURN
+ END IF
+ ABMAX = MAX( ABS( SALFR )+ABS( SALFI ), ABS( SBETA ) )
+ IF( ABS( SALFR )+ABS( SALFI ).GT.ALFMAX .OR.
+ $ ABS( SBETA ).GT.BETMAX .OR. ABMAX.LT.ONE ) THEN
+ SCALE = ONE / MAX( ABMAX, SAFMIN )
+ SALFR = SCALE*SALFR
+ SALFI = SCALE*SALFI
+ SBETA = SCALE*SBETA
+ END IF
+ SCALE = ONE / MAX( ( ABS( SALFR )+ABS( SALFI ) )*BNORM,
+ $ ABS( SBETA )*ANORM, SAFMIN )
+ ACOEF = SCALE*SBETA
+ BCOEFR = SCALE*SALFR
+ BCOEFI = SCALE*SALFI
+ IF( LEFT ) THEN
+ BCOEFI = -BCOEFI
+ END IF
+*
+ CALL DGEMV( TRANS, N, N, ACOEF, A, LDA, E( 1, JVEC ), 1,
+ $ ZERO, WORK( N*( JVEC-1 )+1 ), 1 )
+ CALL DGEMV( TRANS, N, N, -BCOEFR, B, LDA, E( 1, JVEC ),
+ $ 1, ONE, WORK( N*( JVEC-1 )+1 ), 1 )
+ CALL DGEMV( TRANS, N, N, BCOEFI, B, LDA, E( 1, JVEC+1 ),
+ $ 1, ONE, WORK( N*( JVEC-1 )+1 ), 1 )
+*
+ CALL DGEMV( TRANS, N, N, ACOEF, A, LDA, E( 1, JVEC+1 ),
+ $ 1, ZERO, WORK( N*JVEC+1 ), 1 )
+ CALL DGEMV( TRANS, N, N, -BCOEFI, B, LDA, E( 1, JVEC ),
+ $ 1, ONE, WORK( N*JVEC+1 ), 1 )
+ CALL DGEMV( TRANS, N, N, -BCOEFR, B, LDA, E( 1, JVEC+1 ),
+ $ 1, ONE, WORK( N*JVEC+1 ), 1 )
+ END IF
+ END IF
+ 10 CONTINUE
+*
+ ERRNRM = DLANGE( 'One', N, N, WORK, N, WORK( N**2+1 ) ) / ENORM
+*
+* Compute RESULT(1)
+*
+ RESULT( 1 ) = ERRNRM / ULP
+*
+* Normalization of E:
+*
+ ENRMER = ZERO
+ ILCPLX = .FALSE.
+ DO 40 JVEC = 1, N
+ IF( ILCPLX ) THEN
+ ILCPLX = .FALSE.
+ ELSE
+ TEMP1 = ZERO
+ IF( ALPHAI( JVEC ).EQ.ZERO ) THEN
+ DO 20 J = 1, N
+ TEMP1 = MAX( TEMP1, ABS( E( J, JVEC ) ) )
+ 20 CONTINUE
+ ENRMER = MAX( ENRMER, TEMP1-ONE )
+ ELSE
+ ILCPLX = .TRUE.
+ DO 30 J = 1, N
+ TEMP1 = MAX( TEMP1, ABS( E( J, JVEC ) )+
+ $ ABS( E( J, JVEC+1 ) ) )
+ 30 CONTINUE
+ ENRMER = MAX( ENRMER, TEMP1-ONE )
+ END IF
+ END IF
+ 40 CONTINUE
+*
+* Compute RESULT(2) : the normalization error in E.
+*
+ RESULT( 2 ) = ENRMER / ( DBLE( N )*ULP )
+*
+ RETURN
+*
+* End of DGET52
+*
+ END
+ SUBROUTINE DGET53( A, LDA, B, LDB, SCALE, WR, WI, RESULT, INFO )
+*
+* -- LAPACK test routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, LDA, LDB
+ DOUBLE PRECISION RESULT, SCALE, WI, WR
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION A( LDA, * ), B( LDB, * )
+* ..
+*
+* Purpose
+* =======
+*
+* DGET53 checks the generalized eigenvalues computed by DLAG2.
+*
+* The basic test for an eigenvalue is:
+*
+* | det( s A - w B ) |
+* RESULT = ---------------------------------------------------
+* ulp max( s norm(A), |w| norm(B) )*norm( s A - w B )
+*
+* Two "safety checks" are performed:
+*
+* (1) ulp*max( s*norm(A), |w|*norm(B) ) must be at least
+* safe_minimum. This insures that the test performed is
+* not essentially det(0*A + 0*B)=0.
+*
+* (2) s*norm(A) + |w|*norm(B) must be less than 1/safe_minimum.
+* This insures that s*A - w*B will not overflow.
+*
+* If these tests are not passed, then s and w are scaled and
+* tested anyway, if this is possible.
+*
+* Arguments
+* =========
+*
+* A (input) DOUBLE PRECISION array, dimension (LDA, 2)
+* The 2x2 matrix A.
+*
+* LDA (input) INTEGER
+* The leading dimension of A. It must be at least 2.
+*
+* B (input) DOUBLE PRECISION array, dimension (LDB, N)
+* The 2x2 upper-triangular matrix B.
+*
+* LDB (input) INTEGER
+* The leading dimension of B. It must be at least 2.
+*
+* SCALE (input) DOUBLE PRECISION
+* The "scale factor" s in the formula s A - w B . It is
+* assumed to be non-negative.
+*
+* WR (input) DOUBLE PRECISION
+* The real part of the eigenvalue w in the formula
+* s A - w B .
+*
+* WI (input) DOUBLE PRECISION
+* The imaginary part of the eigenvalue w in the formula
+* s A - w B .
+*
+* RESULT (output) DOUBLE PRECISION
+* If INFO is 2 or less, the value computed by the test
+* described above.
+* If INFO=3, this will just be 1/ulp.
+*
+* INFO (output) INTEGER
+* =0: The input data pass the "safety checks".
+* =1: s*norm(A) + |w|*norm(B) > 1/safe_minimum.
+* =2: ulp*max( s*norm(A), |w|*norm(B) ) < safe_minimum
+* =3: same as INFO=2, but s and w could not be scaled so
+* as to compute the test.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
+* ..
+* .. Local Scalars ..
+ DOUBLE PRECISION ABSW, ANORM, BNORM, CI11, CI12, CI22, CNORM,
+ $ CR11, CR12, CR21, CR22, CSCALE, DETI, DETR, S1,
+ $ SAFMIN, SCALES, SIGMIN, TEMP, ULP, WIS, WRS
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DLAMCH
+ EXTERNAL DLAMCH
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, SQRT
+* ..
+* .. Executable Statements ..
+*
+* Initialize
+*
+ INFO = 0
+ RESULT = ZERO
+ SCALES = SCALE
+ WRS = WR
+ WIS = WI
+*
+* Machine constants and norms
+*
+ SAFMIN = DLAMCH( 'Safe minimum' )
+ ULP = DLAMCH( 'Epsilon' )*DLAMCH( 'Base' )
+ ABSW = ABS( WRS ) + ABS( WIS )
+ ANORM = MAX( ABS( A( 1, 1 ) )+ABS( A( 2, 1 ) ),
+ $ ABS( A( 1, 2 ) )+ABS( A( 2, 2 ) ), SAFMIN )
+ BNORM = MAX( ABS( B( 1, 1 ) ), ABS( B( 1, 2 ) )+ABS( B( 2, 2 ) ),
+ $ SAFMIN )
+*
+* Check for possible overflow.
+*
+ TEMP = ( SAFMIN*BNORM )*ABSW + ( SAFMIN*ANORM )*SCALES
+ IF( TEMP.GE.ONE ) THEN
+*
+* Scale down to avoid overflow
+*
+ INFO = 1
+ TEMP = ONE / TEMP
+ SCALES = SCALES*TEMP
+ WRS = WRS*TEMP
+ WIS = WIS*TEMP
+ ABSW = ABS( WRS ) + ABS( WIS )
+ END IF
+ S1 = MAX( ULP*MAX( SCALES*ANORM, ABSW*BNORM ),
+ $ SAFMIN*MAX( SCALES, ABSW ) )
+*
+* Check for W and SCALE essentially zero.
+*
+ IF( S1.LT.SAFMIN ) THEN
+ INFO = 2
+ IF( SCALES.LT.SAFMIN .AND. ABSW.LT.SAFMIN ) THEN
+ INFO = 3
+ RESULT = ONE / ULP
+ RETURN
+ END IF
+*
+* Scale up to avoid underflow
+*
+ TEMP = ONE / MAX( SCALES*ANORM+ABSW*BNORM, SAFMIN )
+ SCALES = SCALES*TEMP
+ WRS = WRS*TEMP
+ WIS = WIS*TEMP
+ ABSW = ABS( WRS ) + ABS( WIS )
+ S1 = MAX( ULP*MAX( SCALES*ANORM, ABSW*BNORM ),
+ $ SAFMIN*MAX( SCALES, ABSW ) )
+ IF( S1.LT.SAFMIN ) THEN
+ INFO = 3
+ RESULT = ONE / ULP
+ RETURN
+ END IF
+ END IF
+*
+* Compute C = s A - w B
+*
+ CR11 = SCALES*A( 1, 1 ) - WRS*B( 1, 1 )
+ CI11 = -WIS*B( 1, 1 )
+ CR21 = SCALES*A( 2, 1 )
+ CR12 = SCALES*A( 1, 2 ) - WRS*B( 1, 2 )
+ CI12 = -WIS*B( 1, 2 )
+ CR22 = SCALES*A( 2, 2 ) - WRS*B( 2, 2 )
+ CI22 = -WIS*B( 2, 2 )
+*
+* Compute the smallest singular value of s A - w B:
+*
+* |det( s A - w B )|
+* sigma_min = ------------------
+* norm( s A - w B )
+*
+ CNORM = MAX( ABS( CR11 )+ABS( CI11 )+ABS( CR21 ),
+ $ ABS( CR12 )+ABS( CI12 )+ABS( CR22 )+ABS( CI22 ), SAFMIN )
+ CSCALE = ONE / SQRT( CNORM )
+ DETR = ( CSCALE*CR11 )*( CSCALE*CR22 ) -
+ $ ( CSCALE*CI11 )*( CSCALE*CI22 ) -
+ $ ( CSCALE*CR12 )*( CSCALE*CR21 )
+ DETI = ( CSCALE*CR11 )*( CSCALE*CI22 ) +
+ $ ( CSCALE*CI11 )*( CSCALE*CR22 ) -
+ $ ( CSCALE*CI12 )*( CSCALE*CR21 )
+ SIGMIN = ABS( DETR ) + ABS( DETI )
+ RESULT = SIGMIN / S1
+ RETURN
+*
+* End of DGET53
+*
+ END
+ SUBROUTINE DGET54( N, A, LDA, B, LDB, S, LDS, T, LDT, U, LDU, V,
+ $ LDV, WORK, RESULT )
+*
+* -- LAPACK test routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER LDA, LDB, LDS, LDT, LDU, LDV, N
+ DOUBLE PRECISION RESULT
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION A( LDA, * ), B( LDB, * ), S( LDS, * ),
+ $ T( LDT, * ), U( LDU, * ), V( LDV, * ),
+ $ WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DGET54 checks a generalized decomposition of the form
+*
+* A = U*S*V' and B = U*T* V'
+*
+* where ' means transpose and U and V are orthogonal.
+*
+* Specifically,
+*
+* RESULT = ||( A - U*S*V', B - U*T*V' )|| / (||( A, B )||*n*ulp )
+*
+* Arguments
+* =========
+*
+* N (input) INTEGER
+* The size of the matrix. If it is zero, DGET54 does nothing.
+* It must be at least zero.
+*
+* A (input) DOUBLE PRECISION array, dimension (LDA, N)
+* The original (unfactored) matrix A.
+*
+* LDA (input) INTEGER
+* The leading dimension of A. It must be at least 1
+* and at least N.
+*
+* B (input) DOUBLE PRECISION array, dimension (LDB, N)
+* The original (unfactored) matrix B.
+*
+* LDB (input) INTEGER
+* The leading dimension of B. It must be at least 1
+* and at least N.
+*
+* S (input) DOUBLE PRECISION array, dimension (LDS, N)
+* The factored matrix S.
+*
+* LDS (input) INTEGER
+* The leading dimension of S. It must be at least 1
+* and at least N.
+*
+* T (input) DOUBLE PRECISION array, dimension (LDT, N)
+* The factored matrix T.
+*
+* LDT (input) INTEGER
+* The leading dimension of T. It must be at least 1
+* and at least N.
+*
+* U (input) DOUBLE PRECISION array, dimension (LDU, N)
+* The orthogonal matrix on the left-hand side in the
+* decomposition.
+*
+* LDU (input) INTEGER
+* The leading dimension of U. LDU must be at least N and
+* at least 1.
+*
+* V (input) DOUBLE PRECISION array, dimension (LDV, N)
+* The orthogonal matrix on the left-hand side in the
+* decomposition.
+*
+* LDV (input) INTEGER
+* The leading dimension of V. LDV must be at least N and
+* at least 1.
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (3*N**2)
+*
+* RESULT (output) DOUBLE PRECISION
+* The value RESULT, It is currently limited to 1/ulp, to
+* avoid overflow. Errors are flagged by RESULT=10/ulp.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+* ..
+* .. Local Scalars ..
+ DOUBLE PRECISION ABNORM, ULP, UNFL, WNORM
+* ..
+* .. Local Arrays ..
+ DOUBLE PRECISION DUM( 1 )
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DLAMCH, DLANGE
+ EXTERNAL DLAMCH, DLANGE
+* ..
+* .. External Subroutines ..
+ EXTERNAL DGEMM, DLACPY
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC DBLE, MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+ RESULT = ZERO
+ IF( N.LE.0 )
+ $ RETURN
+*
+* Constants
+*
+ UNFL = DLAMCH( 'Safe minimum' )
+ ULP = DLAMCH( 'Epsilon' )*DLAMCH( 'Base' )
+*
+* compute the norm of (A,B)
+*
+ CALL DLACPY( 'Full', N, N, A, LDA, WORK, N )
+ CALL DLACPY( 'Full', N, N, B, LDB, WORK( N*N+1 ), N )
+ ABNORM = MAX( DLANGE( '1', N, 2*N, WORK, N, DUM ), UNFL )
+*
+* Compute W1 = A - U*S*V', and put in the array WORK(1:N*N)
+*
+ CALL DLACPY( ' ', N, N, A, LDA, WORK, N )
+ CALL DGEMM( 'N', 'N', N, N, N, ONE, U, LDU, S, LDS, ZERO,
+ $ WORK( N*N+1 ), N )
+*
+ CALL DGEMM( 'N', 'C', N, N, N, -ONE, WORK( N*N+1 ), N, V, LDV,
+ $ ONE, WORK, N )
+*
+* Compute W2 = B - U*T*V', and put in the workarray W(N*N+1:2*N*N)
+*
+ CALL DLACPY( ' ', N, N, B, LDB, WORK( N*N+1 ), N )
+ CALL DGEMM( 'N', 'N', N, N, N, ONE, U, LDU, T, LDT, ZERO,
+ $ WORK( 2*N*N+1 ), N )
+*
+ CALL DGEMM( 'N', 'C', N, N, N, -ONE, WORK( 2*N*N+1 ), N, V, LDV,
+ $ ONE, WORK( N*N+1 ), N )
+*
+* Compute norm(W)/ ( ulp*norm((A,B)) )
+*
+ WNORM = DLANGE( '1', N, 2*N, WORK, N, DUM )
+*
+ IF( ABNORM.GT.WNORM ) THEN
+ RESULT = ( WNORM / ABNORM ) / ( 2*N*ULP )
+ ELSE
+ IF( ABNORM.LT.ONE ) THEN
+ RESULT = ( MIN( WNORM, 2*N*ABNORM ) / ABNORM ) / ( 2*N*ULP )
+ ELSE
+ RESULT = MIN( WNORM / ABNORM, DBLE( 2*N ) ) / ( 2*N*ULP )
+ END IF
+ END IF
+*
+ RETURN
+*
+* End of DGET54
+*
+ END
+ SUBROUTINE DGLMTS( N, M, P, A, AF, LDA, B, BF, LDB, D, DF, X, U,
+ $ WORK, LWORK, RWORK, RESULT )
+*
+* -- LAPACK test routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER LDA, LDB, LWORK, M, N, P
+ DOUBLE PRECISION RESULT
+* ..
+* .. Array Arguments ..
+*
+* Purpose
+* =======
+*
+* DGLMTS tests DGGGLM - a subroutine for solving the generalized
+* linear model problem.
+*
+* Arguments
+* =========
+*
+* N (input) INTEGER
+* The number of rows of the matrices A and B. N >= 0.
+*
+* M (input) INTEGER
+* The number of columns of the matrix A. M >= 0.
+*
+* P (input) INTEGER
+* The number of columns of the matrix B. P >= 0.
+*
+* A (input) DOUBLE PRECISION array, dimension (LDA,M)
+* The N-by-M matrix A.
+*
+* AF (workspace) DOUBLE PRECISION array, dimension (LDA,M)
+*
+* LDA (input) INTEGER
+* The leading dimension of the arrays A, AF. LDA >= max(M,N).
+*
+* B (input) DOUBLE PRECISION array, dimension (LDB,P)
+* The N-by-P matrix A.
+*
+* BF (workspace) DOUBLE PRECISION array, dimension (LDB,P)
+*
+* LDB (input) INTEGER
+* The leading dimension of the arrays B, BF. LDB >= max(P,N).
+*
+* D (input) DOUBLE PRECISION array, dimension( N )
+* On input, the left hand side of the GLM.
+*
+* DF (workspace) DOUBLE PRECISION array, dimension( N )
+*
+* X (output) DOUBLE PRECISION array, dimension( M )
+* solution vector X in the GLM problem.
+*
+* U (output) DOUBLE PRECISION array, dimension( P )
+* solution vector U in the GLM problem.
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK)
+*
+* LWORK (input) INTEGER
+* The dimension of the array WORK.
+*
+* RWORK (workspace) DOUBLE PRECISION array, dimension (M)
+*
+* RESULT (output) DOUBLE PRECISION
+* The test ratio:
+* norm( d - A*x - B*u )
+* RESULT = -----------------------------------------
+* (norm(A)+norm(B))*(norm(x)+norm(u))*EPS
+*
+* ====================================================================
+*
+ DOUBLE PRECISION A( LDA, * ), AF( LDA, * ), B( LDB, * ),
+ $ BF( LDB, * ), D( * ), DF( * ), RWORK( * ),
+ $ U( * ), WORK( LWORK ), X( * )
+* ..
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER INFO
+ DOUBLE PRECISION ANORM, BNORM, DNORM, EPS, UNFL, XNORM, YNORM
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DASUM, DLAMCH, DLANGE
+ EXTERNAL DASUM, DLAMCH, DLANGE
+* ..
+* .. External Subroutines ..
+*
+ EXTERNAL DCOPY, DGEMV, DGGGLM, DLACPY
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+ EPS = DLAMCH( 'Epsilon' )
+ UNFL = DLAMCH( 'Safe minimum' )
+ ANORM = MAX( DLANGE( '1', N, M, A, LDA, RWORK ), UNFL )
+ BNORM = MAX( DLANGE( '1', N, P, B, LDB, RWORK ), UNFL )
+*
+* Copy the matrices A and B to the arrays AF and BF,
+* and the vector D the array DF.
+*
+ CALL DLACPY( 'Full', N, M, A, LDA, AF, LDA )
+ CALL DLACPY( 'Full', N, P, B, LDB, BF, LDB )
+ CALL DCOPY( N, D, 1, DF, 1 )
+*
+* Solve GLM problem
+*
+ CALL DGGGLM( N, M, P, AF, LDA, BF, LDB, DF, X, U, WORK, LWORK,
+ $ INFO )
+*
+* Test the residual for the solution of LSE
+*
+* norm( d - A*x - B*u )
+* RESULT = -----------------------------------------
+* (norm(A)+norm(B))*(norm(x)+norm(u))*EPS
+*
+ CALL DCOPY( N, D, 1, DF, 1 )
+ CALL DGEMV( 'No transpose', N, M, -ONE, A, LDA, X, 1, ONE, DF, 1 )
+*
+ CALL DGEMV( 'No transpose', N, P, -ONE, B, LDB, U, 1, ONE, DF, 1 )
+*
+ DNORM = DASUM( N, DF, 1 )
+ XNORM = DASUM( M, X, 1 ) + DASUM( P, U, 1 )
+ YNORM = ANORM + BNORM
+*
+ IF( XNORM.LE.ZERO ) THEN
+ RESULT = ZERO
+ ELSE
+ RESULT = ( ( DNORM / YNORM ) / XNORM ) / EPS
+ END IF
+*
+ RETURN
+*
+* End of DGLMTS
+*
+ END
+ SUBROUTINE DGQRTS( N, M, P, A, AF, Q, R, LDA, TAUA, B, BF, Z, T,
+ $ BWK, LDB, TAUB, WORK, LWORK, RWORK, RESULT )
+*
+* -- LAPACK test routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER LDA, LDB, LWORK, M, N, P
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION A( LDA, * ), AF( LDA, * ), B( LDB, * ),
+ $ BF( LDB, * ), BWK( LDB, * ), Q( LDA, * ),
+ $ R( LDA, * ), RESULT( 4 ), RWORK( * ),
+ $ T( LDB, * ), TAUA( * ), TAUB( * ),
+ $ WORK( LWORK ), Z( LDB, * )
+* ..
+*
+* Purpose
+* =======
+*
+* DGQRTS tests DGGQRF, which computes the GQR factorization of an
+* N-by-M matrix A and a N-by-P matrix B: A = Q*R and B = Q*T*Z.
+*
+* Arguments
+* =========
+*
+* N (input) INTEGER
+* The number of rows of the matrices A and B. N >= 0.
+*
+* M (input) INTEGER
+* The number of columns of the matrix A. M >= 0.
+*
+* P (input) INTEGER
+* The number of columns of the matrix B. P >= 0.
+*
+* A (input) DOUBLE PRECISION array, dimension (LDA,M)
+* The N-by-M matrix A.
+*
+* AF (output) DOUBLE PRECISION array, dimension (LDA,N)
+* Details of the GQR factorization of A and B, as returned
+* by DGGQRF, see SGGQRF for further details.
+*
+* Q (output) DOUBLE PRECISION array, dimension (LDA,N)
+* The M-by-M orthogonal matrix Q.
+*
+* R (workspace) DOUBLE PRECISION array, dimension (LDA,MAX(M,N))
+*
+* LDA (input) INTEGER
+* The leading dimension of the arrays A, AF, R and Q.
+* LDA >= max(M,N).
+*
+* TAUA (output) DOUBLE PRECISION array, dimension (min(M,N))
+* The scalar factors of the elementary reflectors, as returned
+* by DGGQRF.
+*
+* B (input) DOUBLE PRECISION array, dimension (LDB,P)
+* On entry, the N-by-P matrix A.
+*
+* BF (output) DOUBLE PRECISION array, dimension (LDB,N)
+* Details of the GQR factorization of A and B, as returned
+* by DGGQRF, see SGGQRF for further details.
+*
+* Z (output) DOUBLE PRECISION array, dimension (LDB,P)
+* The P-by-P orthogonal matrix Z.
+*
+* T (workspace) DOUBLE PRECISION array, dimension (LDB,max(P,N))
+*
+* BWK (workspace) DOUBLE PRECISION array, dimension (LDB,N)
+*
+* LDB (input) INTEGER
+* The leading dimension of the arrays B, BF, Z and T.
+* LDB >= max(P,N).
+*
+* TAUB (output) DOUBLE PRECISION array, dimension (min(P,N))
+* The scalar factors of the elementary reflectors, as returned
+* by DGGRQF.
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK)
+*
+* LWORK (input) INTEGER
+* The dimension of the array WORK, LWORK >= max(N,M,P)**2.
+*
+* RWORK (workspace) DOUBLE PRECISION array, dimension (max(N,M,P))
+*
+* RESULT (output) DOUBLE PRECISION array, dimension (4)
+* The test ratios:
+* RESULT(1) = norm( R - Q'*A ) / ( MAX(M,N)*norm(A)*ULP)
+* RESULT(2) = norm( T*Z - Q'*B ) / (MAX(P,N)*norm(B)*ULP)
+* RESULT(3) = norm( I - Q'*Q ) / ( M*ULP )
+* RESULT(4) = norm( I - Z'*Z ) / ( P*ULP )
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+ DOUBLE PRECISION ROGUE
+ PARAMETER ( ROGUE = -1.0D+10 )
+* ..
+* .. Local Scalars ..
+ INTEGER INFO
+ DOUBLE PRECISION ANORM, BNORM, RESID, ULP, UNFL
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DLAMCH, DLANGE, DLANSY
+ EXTERNAL DLAMCH, DLANGE, DLANSY
+* ..
+* .. External Subroutines ..
+ EXTERNAL DGEMM, DGGQRF, DLACPY, DLASET, DORGQR, DORGRQ,
+ $ DSYRK
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC DBLE, MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+ ULP = DLAMCH( 'Precision' )
+ UNFL = DLAMCH( 'Safe minimum' )
+*
+* Copy the matrix A to the array AF.
+*
+ CALL DLACPY( 'Full', N, M, A, LDA, AF, LDA )
+ CALL DLACPY( 'Full', N, P, B, LDB, BF, LDB )
+*
+ ANORM = MAX( DLANGE( '1', N, M, A, LDA, RWORK ), UNFL )
+ BNORM = MAX( DLANGE( '1', N, P, B, LDB, RWORK ), UNFL )
+*
+* Factorize the matrices A and B in the arrays AF and BF.
+*
+ CALL DGGQRF( N, M, P, AF, LDA, TAUA, BF, LDB, TAUB, WORK, LWORK,
+ $ INFO )
+*
+* Generate the N-by-N matrix Q
+*
+ CALL DLASET( 'Full', N, N, ROGUE, ROGUE, Q, LDA )
+ CALL DLACPY( 'Lower', N-1, M, AF( 2, 1 ), LDA, Q( 2, 1 ), LDA )
+ CALL DORGQR( N, N, MIN( N, M ), Q, LDA, TAUA, WORK, LWORK, INFO )
+*
+* Generate the P-by-P matrix Z
+*
+ CALL DLASET( 'Full', P, P, ROGUE, ROGUE, Z, LDB )
+ IF( N.LE.P ) THEN
+ IF( N.GT.0 .AND. N.LT.P )
+ $ CALL DLACPY( 'Full', N, P-N, BF, LDB, Z( P-N+1, 1 ), LDB )
+ IF( N.GT.1 )
+ $ CALL DLACPY( 'Lower', N-1, N-1, BF( 2, P-N+1 ), LDB,
+ $ Z( P-N+2, P-N+1 ), LDB )
+ ELSE
+ IF( P.GT.1 )
+ $ CALL DLACPY( 'Lower', P-1, P-1, BF( N-P+2, 1 ), LDB,
+ $ Z( 2, 1 ), LDB )
+ END IF
+ CALL DORGRQ( P, P, MIN( N, P ), Z, LDB, TAUB, WORK, LWORK, INFO )
+*
+* Copy R
+*
+ CALL DLASET( 'Full', N, M, ZERO, ZERO, R, LDA )
+ CALL DLACPY( 'Upper', N, M, AF, LDA, R, LDA )
+*
+* Copy T
+*
+ CALL DLASET( 'Full', N, P, ZERO, ZERO, T, LDB )
+ IF( N.LE.P ) THEN
+ CALL DLACPY( 'Upper', N, N, BF( 1, P-N+1 ), LDB, T( 1, P-N+1 ),
+ $ LDB )
+ ELSE
+ CALL DLACPY( 'Full', N-P, P, BF, LDB, T, LDB )
+ CALL DLACPY( 'Upper', P, P, BF( N-P+1, 1 ), LDB, T( N-P+1, 1 ),
+ $ LDB )
+ END IF
+*
+* Compute R - Q'*A
+*
+ CALL DGEMM( 'Transpose', 'No transpose', N, M, N, -ONE, Q, LDA, A,
+ $ LDA, ONE, R, LDA )
+*
+* Compute norm( R - Q'*A ) / ( MAX(M,N)*norm(A)*ULP ) .
+*
+ RESID = DLANGE( '1', N, M, R, LDA, RWORK )
+ IF( ANORM.GT.ZERO ) THEN
+ RESULT( 1 ) = ( ( RESID / DBLE( MAX( 1, M, N ) ) ) / ANORM ) /
+ $ ULP
+ ELSE
+ RESULT( 1 ) = ZERO
+ END IF
+*
+* Compute T*Z - Q'*B
+*
+ CALL DGEMM( 'No Transpose', 'No transpose', N, P, P, ONE, T, LDB,
+ $ Z, LDB, ZERO, BWK, LDB )
+ CALL DGEMM( 'Transpose', 'No transpose', N, P, N, -ONE, Q, LDA, B,
+ $ LDB, ONE, BWK, LDB )
+*
+* Compute norm( T*Z - Q'*B ) / ( MAX(P,N)*norm(A)*ULP ) .
+*
+ RESID = DLANGE( '1', N, P, BWK, LDB, RWORK )
+ IF( BNORM.GT.ZERO ) THEN
+ RESULT( 2 ) = ( ( RESID / DBLE( MAX( 1, P, N ) ) ) / BNORM ) /
+ $ ULP
+ ELSE
+ RESULT( 2 ) = ZERO
+ END IF
+*
+* Compute I - Q'*Q
+*
+ CALL DLASET( 'Full', N, N, ZERO, ONE, R, LDA )
+ CALL DSYRK( 'Upper', 'Transpose', N, N, -ONE, Q, LDA, ONE, R,
+ $ LDA )
+*
+* Compute norm( I - Q'*Q ) / ( N * ULP ) .
+*
+ RESID = DLANSY( '1', 'Upper', N, R, LDA, RWORK )
+ RESULT( 3 ) = ( RESID / DBLE( MAX( 1, N ) ) ) / ULP
+*
+* Compute I - Z'*Z
+*
+ CALL DLASET( 'Full', P, P, ZERO, ONE, T, LDB )
+ CALL DSYRK( 'Upper', 'Transpose', P, P, -ONE, Z, LDB, ONE, T,
+ $ LDB )
+*
+* Compute norm( I - Z'*Z ) / ( P*ULP ) .
+*
+ RESID = DLANSY( '1', 'Upper', P, T, LDB, RWORK )
+ RESULT( 4 ) = ( RESID / DBLE( MAX( 1, P ) ) ) / ULP
+*
+ RETURN
+*
+* End of DGQRTS
+*
+ END
+ SUBROUTINE DGRQTS( M, P, N, A, AF, Q, R, LDA, TAUA, B, BF, Z, T,
+ $ BWK, LDB, TAUB, WORK, LWORK, RWORK, RESULT )
+*
+* -- LAPACK test routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER LDA, LDB, LWORK, M, N, P
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION A( LDA, * ), AF( LDA, * ), B( LDB, * ),
+ $ BF( LDB, * ), BWK( LDB, * ), Q( LDA, * ),
+ $ R( LDA, * ), RESULT( 4 ), RWORK( * ),
+ $ T( LDB, * ), TAUA( * ), TAUB( * ),
+ $ WORK( LWORK ), Z( LDB, * )
+* ..
+*
+* Purpose
+* =======
+*
+* DGRQTS tests DGGRQF, which computes the GRQ factorization of an
+* M-by-N matrix A and a P-by-N matrix B: A = R*Q and B = Z*T*Q.
+*
+* Arguments
+* =========
+*
+* M (input) INTEGER
+* The number of rows of the matrix A. M >= 0.
+*
+* P (input) INTEGER
+* The number of rows of the matrix B. P >= 0.
+*
+* N (input) INTEGER
+* The number of columns of the matrices A and B. N >= 0.
+*
+* A (input) DOUBLE PRECISION array, dimension (LDA,N)
+* The M-by-N matrix A.
+*
+* AF (output) DOUBLE PRECISION array, dimension (LDA,N)
+* Details of the GRQ factorization of A and B, as returned
+* by DGGRQF, see SGGRQF for further details.
+*
+* Q (output) DOUBLE PRECISION array, dimension (LDA,N)
+* The N-by-N orthogonal matrix Q.
+*
+* R (workspace) DOUBLE PRECISION array, dimension (LDA,MAX(M,N))
+*
+* LDA (input) INTEGER
+* The leading dimension of the arrays A, AF, R and Q.
+* LDA >= max(M,N).
+*
+* TAUA (output) DOUBLE PRECISION array, dimension (min(M,N))
+* The scalar factors of the elementary reflectors, as returned
+* by DGGQRC.
+*
+* B (input) DOUBLE PRECISION array, dimension (LDB,N)
+* On entry, the P-by-N matrix A.
+*
+* BF (output) DOUBLE PRECISION array, dimension (LDB,N)
+* Details of the GQR factorization of A and B, as returned
+* by DGGRQF, see SGGRQF for further details.
+*
+* Z (output) DOUBLE PRECISION array, dimension (LDB,P)
+* The P-by-P orthogonal matrix Z.
+*
+* T (workspace) DOUBLE PRECISION array, dimension (LDB,max(P,N))
+*
+* BWK (workspace) DOUBLE PRECISION array, dimension (LDB,N)
+*
+* LDB (input) INTEGER
+* The leading dimension of the arrays B, BF, Z and T.
+* LDB >= max(P,N).
+*
+* TAUB (output) DOUBLE PRECISION array, dimension (min(P,N))
+* The scalar factors of the elementary reflectors, as returned
+* by DGGRQF.
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK)
+*
+* LWORK (input) INTEGER
+* The dimension of the array WORK, LWORK >= max(M,P,N)**2.
+*
+* RWORK (workspace) DOUBLE PRECISION array, dimension (M)
+*
+* RESULT (output) DOUBLE PRECISION array, dimension (4)
+* The test ratios:
+* RESULT(1) = norm( R - A*Q' ) / ( MAX(M,N)*norm(A)*ULP)
+* RESULT(2) = norm( T*Q - Z'*B ) / (MAX(P,N)*norm(B)*ULP)
+* RESULT(3) = norm( I - Q'*Q ) / ( N*ULP )
+* RESULT(4) = norm( I - Z'*Z ) / ( P*ULP )
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+ DOUBLE PRECISION ROGUE
+ PARAMETER ( ROGUE = -1.0D+10 )
+* ..
+* .. Local Scalars ..
+ INTEGER INFO
+ DOUBLE PRECISION ANORM, BNORM, RESID, ULP, UNFL
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DLAMCH, DLANGE, DLANSY
+ EXTERNAL DLAMCH, DLANGE, DLANSY
+* ..
+* .. External Subroutines ..
+ EXTERNAL DGEMM, DGGRQF, DLACPY, DLASET, DORGQR, DORGRQ,
+ $ DSYRK
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC DBLE, MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+ ULP = DLAMCH( 'Precision' )
+ UNFL = DLAMCH( 'Safe minimum' )
+*
+* Copy the matrix A to the array AF.
+*
+ CALL DLACPY( 'Full', M, N, A, LDA, AF, LDA )
+ CALL DLACPY( 'Full', P, N, B, LDB, BF, LDB )
+*
+ ANORM = MAX( DLANGE( '1', M, N, A, LDA, RWORK ), UNFL )
+ BNORM = MAX( DLANGE( '1', P, N, B, LDB, RWORK ), UNFL )
+*
+* Factorize the matrices A and B in the arrays AF and BF.
+*
+ CALL DGGRQF( M, P, N, AF, LDA, TAUA, BF, LDB, TAUB, WORK, LWORK,
+ $ INFO )
+*
+* Generate the N-by-N matrix Q
+*
+ CALL DLASET( 'Full', N, N, ROGUE, ROGUE, Q, LDA )
+ IF( M.LE.N ) THEN
+ IF( M.GT.0 .AND. M.LT.N )
+ $ CALL DLACPY( 'Full', M, N-M, AF, LDA, Q( N-M+1, 1 ), LDA )
+ IF( M.GT.1 )
+ $ CALL DLACPY( 'Lower', M-1, M-1, AF( 2, N-M+1 ), LDA,
+ $ Q( N-M+2, N-M+1 ), LDA )
+ ELSE
+ IF( N.GT.1 )
+ $ CALL DLACPY( 'Lower', N-1, N-1, AF( M-N+2, 1 ), LDA,
+ $ Q( 2, 1 ), LDA )
+ END IF
+ CALL DORGRQ( N, N, MIN( M, N ), Q, LDA, TAUA, WORK, LWORK, INFO )
+*
+* Generate the P-by-P matrix Z
+*
+ CALL DLASET( 'Full', P, P, ROGUE, ROGUE, Z, LDB )
+ IF( P.GT.1 )
+ $ CALL DLACPY( 'Lower', P-1, N, BF( 2, 1 ), LDB, Z( 2, 1 ), LDB )
+ CALL DORGQR( P, P, MIN( P, N ), Z, LDB, TAUB, WORK, LWORK, INFO )
+*
+* Copy R
+*
+ CALL DLASET( 'Full', M, N, ZERO, ZERO, R, LDA )
+ IF( M.LE.N ) THEN
+ CALL DLACPY( 'Upper', M, M, AF( 1, N-M+1 ), LDA, R( 1, N-M+1 ),
+ $ LDA )
+ ELSE
+ CALL DLACPY( 'Full', M-N, N, AF, LDA, R, LDA )
+ CALL DLACPY( 'Upper', N, N, AF( M-N+1, 1 ), LDA, R( M-N+1, 1 ),
+ $ LDA )
+ END IF
+*
+* Copy T
+*
+ CALL DLASET( 'Full', P, N, ZERO, ZERO, T, LDB )
+ CALL DLACPY( 'Upper', P, N, BF, LDB, T, LDB )
+*
+* Compute R - A*Q'
+*
+ CALL DGEMM( 'No transpose', 'Transpose', M, N, N, -ONE, A, LDA, Q,
+ $ LDA, ONE, R, LDA )
+*
+* Compute norm( R - A*Q' ) / ( MAX(M,N)*norm(A)*ULP ) .
+*
+ RESID = DLANGE( '1', M, N, R, LDA, RWORK )
+ IF( ANORM.GT.ZERO ) THEN
+ RESULT( 1 ) = ( ( RESID / DBLE( MAX( 1, M, N ) ) ) / ANORM ) /
+ $ ULP
+ ELSE
+ RESULT( 1 ) = ZERO
+ END IF
+*
+* Compute T*Q - Z'*B
+*
+ CALL DGEMM( 'Transpose', 'No transpose', P, N, P, ONE, Z, LDB, B,
+ $ LDB, ZERO, BWK, LDB )
+ CALL DGEMM( 'No transpose', 'No transpose', P, N, N, ONE, T, LDB,
+ $ Q, LDA, -ONE, BWK, LDB )
+*
+* Compute norm( T*Q - Z'*B ) / ( MAX(P,N)*norm(A)*ULP ) .
+*
+ RESID = DLANGE( '1', P, N, BWK, LDB, RWORK )
+ IF( BNORM.GT.ZERO ) THEN
+ RESULT( 2 ) = ( ( RESID / DBLE( MAX( 1, P, M ) ) ) / BNORM ) /
+ $ ULP
+ ELSE
+ RESULT( 2 ) = ZERO
+ END IF
+*
+* Compute I - Q*Q'
+*
+ CALL DLASET( 'Full', N, N, ZERO, ONE, R, LDA )
+ CALL DSYRK( 'Upper', 'No Transpose', N, N, -ONE, Q, LDA, ONE, R,
+ $ LDA )
+*
+* Compute norm( I - Q'*Q ) / ( N * ULP ) .
+*
+ RESID = DLANSY( '1', 'Upper', N, R, LDA, RWORK )
+ RESULT( 3 ) = ( RESID / DBLE( MAX( 1, N ) ) ) / ULP
+*
+* Compute I - Z'*Z
+*
+ CALL DLASET( 'Full', P, P, ZERO, ONE, T, LDB )
+ CALL DSYRK( 'Upper', 'Transpose', P, P, -ONE, Z, LDB, ONE, T,
+ $ LDB )
+*
+* Compute norm( I - Z'*Z ) / ( P*ULP ) .
+*
+ RESID = DLANSY( '1', 'Upper', P, T, LDB, RWORK )
+ RESULT( 4 ) = ( RESID / DBLE( MAX( 1, P ) ) ) / ULP
+*
+ RETURN
+*
+* End of DGRQTS
+*
+ END
+ SUBROUTINE DGSVTS( M, P, N, A, AF, LDA, B, BF, LDB, U, LDU, V,
+ $ LDV, Q, LDQ, ALPHA, BETA, R, LDR, IWORK, WORK,
+ $ LWORK, RWORK, RESULT )
+*
+* -- LAPACK test routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER LDA, LDB, LDQ, LDR, LDU, LDV, LWORK, M, N, P
+* ..
+* .. Array Arguments ..
+ INTEGER IWORK( * )
+ DOUBLE PRECISION A( LDA, * ), AF( LDA, * ), ALPHA( * ),
+ $ B( LDB, * ), BETA( * ), BF( LDB, * ),
+ $ Q( LDQ, * ), R( LDR, * ), RESULT( 6 ),
+ $ RWORK( * ), U( LDU, * ), V( LDV, * ),
+ $ WORK( LWORK )
+* ..
+*
+* Purpose
+* =======
+*
+* DGSVTS tests DGGSVD, which computes the GSVD of an M-by-N matrix A
+* and a P-by-N matrix B:
+* U'*A*Q = D1*R and V'*B*Q = D2*R.
+*
+* Arguments
+* =========
+*
+* M (input) INTEGER
+* The number of rows of the matrix A. M >= 0.
+*
+* P (input) INTEGER
+* The number of rows of the matrix B. P >= 0.
+*
+* N (input) INTEGER
+* The number of columns of the matrices A and B. N >= 0.
+*
+* A (input) DOUBLE PRECISION array, dimension (LDA,M)
+* The M-by-N matrix A.
+*
+* AF (output) DOUBLE PRECISION array, dimension (LDA,N)
+* Details of the GSVD of A and B, as returned by DGGSVD,
+* see DGGSVD for further details.
+*
+* LDA (input) INTEGER
+* The leading dimension of the arrays A and AF.
+* LDA >= max( 1,M ).
+*
+* B (input) DOUBLE PRECISION array, dimension (LDB,P)
+* On entry, the P-by-N matrix B.
+*
+* BF (output) DOUBLE PRECISION array, dimension (LDB,N)
+* Details of the GSVD of A and B, as returned by DGGSVD,
+* see DGGSVD for further details.
+*
+* LDB (input) INTEGER
+* The leading dimension of the arrays B and BF.
+* LDB >= max(1,P).
+*
+* U (output) DOUBLE PRECISION array, dimension(LDU,M)
+* The M by M orthogonal matrix U.
+*
+* LDU (input) INTEGER
+* The leading dimension of the array U. LDU >= max(1,M).
+*
+* V (output) DOUBLE PRECISION array, dimension(LDV,M)
+* The P by P orthogonal matrix V.
+*
+* LDV (input) INTEGER
+* The leading dimension of the array V. LDV >= max(1,P).
+*
+* Q (output) DOUBLE PRECISION array, dimension(LDQ,N)
+* The N by N orthogonal matrix Q.
+*
+* LDQ (input) INTEGER
+* The leading dimension of the array Q. LDQ >= max(1,N).
+*
+* ALPHA (output) DOUBLE PRECISION array, dimension (N)
+* BETA (output) DOUBLE PRECISION array, dimension (N)
+* The generalized singular value pairs of A and B, the
+* ``diagonal'' matrices D1 and D2 are constructed from
+* ALPHA and BETA, see subroutine DGGSVD for details.
+*
+* R (output) DOUBLE PRECISION array, dimension(LDQ,N)
+* The upper triangular matrix R.
+*
+* LDR (input) INTEGER
+* The leading dimension of the array R. LDR >= max(1,N).
+*
+* IWORK (workspace) INTEGER array, dimension (N)
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK)
+*
+* LWORK (input) INTEGER
+* The dimension of the array WORK,
+* LWORK >= max(M,P,N)*max(M,P,N).
+*
+* RWORK (workspace) DOUBLE PRECISION array, dimension (max(M,P,N))
+*
+* RESULT (output) DOUBLE PRECISION array, dimension (6)
+* The test ratios:
+* RESULT(1) = norm( U'*A*Q - D1*R ) / ( MAX(M,N)*norm(A)*ULP)
+* RESULT(2) = norm( V'*B*Q - D2*R ) / ( MAX(P,N)*norm(B)*ULP)
+* RESULT(3) = norm( I - U'*U ) / ( M*ULP )
+* RESULT(4) = norm( I - V'*V ) / ( P*ULP )
+* RESULT(5) = norm( I - Q'*Q ) / ( N*ULP )
+* RESULT(6) = 0 if ALPHA is in decreasing order;
+* = ULPINV otherwise.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, INFO, J, K, L
+ DOUBLE PRECISION ANORM, BNORM, RESID, TEMP, ULP, ULPINV, UNFL
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DLAMCH, DLANGE, DLANSY
+ EXTERNAL DLAMCH, DLANGE, DLANSY
+* ..
+* .. External Subroutines ..
+ EXTERNAL DCOPY, DGEMM, DGGSVD, DLACPY, DLASET, DSYRK
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC DBLE, MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+ ULP = DLAMCH( 'Precision' )
+ ULPINV = ONE / ULP
+ UNFL = DLAMCH( 'Safe minimum' )
+*
+* Copy the matrix A to the array AF.
+*
+ CALL DLACPY( 'Full', M, N, A, LDA, AF, LDA )
+ CALL DLACPY( 'Full', P, N, B, LDB, BF, LDB )
+*
+ ANORM = MAX( DLANGE( '1', M, N, A, LDA, RWORK ), UNFL )
+ BNORM = MAX( DLANGE( '1', P, N, B, LDB, RWORK ), UNFL )
+*
+* Factorize the matrices A and B in the arrays AF and BF.
+*
+ CALL DGGSVD( 'U', 'V', 'Q', M, N, P, K, L, AF, LDA, BF, LDB,
+ $ ALPHA, BETA, U, LDU, V, LDV, Q, LDQ, WORK, IWORK,
+ $ INFO )
+*
+* Copy R
+*
+ DO 20 I = 1, MIN( K+L, M )
+ DO 10 J = I, K + L
+ R( I, J ) = AF( I, N-K-L+J )
+ 10 CONTINUE
+ 20 CONTINUE
+*
+ IF( M-K-L.LT.0 ) THEN
+ DO 40 I = M + 1, K + L
+ DO 30 J = I, K + L
+ R( I, J ) = BF( I-K, N-K-L+J )
+ 30 CONTINUE
+ 40 CONTINUE
+ END IF
+*
+* Compute A:= U'*A*Q - D1*R
+*
+ CALL DGEMM( 'No transpose', 'No transpose', M, N, N, ONE, A, LDA,
+ $ Q, LDQ, ZERO, WORK, LDA )
+*
+ CALL DGEMM( 'Transpose', 'No transpose', M, N, M, ONE, U, LDU,
+ $ WORK, LDA, ZERO, A, LDA )
+*
+ DO 60 I = 1, K
+ DO 50 J = I, K + L
+ A( I, N-K-L+J ) = A( I, N-K-L+J ) - R( I, J )
+ 50 CONTINUE
+ 60 CONTINUE
+*
+ DO 80 I = K + 1, MIN( K+L, M )
+ DO 70 J = I, K + L
+ A( I, N-K-L+J ) = A( I, N-K-L+J ) - ALPHA( I )*R( I, J )
+ 70 CONTINUE
+ 80 CONTINUE
+*
+* Compute norm( U'*A*Q - D1*R ) / ( MAX(1,M,N)*norm(A)*ULP ) .
+*
+ RESID = DLANGE( '1', M, N, A, LDA, RWORK )
+*
+ IF( ANORM.GT.ZERO ) THEN
+ RESULT( 1 ) = ( ( RESID / DBLE( MAX( 1, M, N ) ) ) / ANORM ) /
+ $ ULP
+ ELSE
+ RESULT( 1 ) = ZERO
+ END IF
+*
+* Compute B := V'*B*Q - D2*R
+*
+ CALL DGEMM( 'No transpose', 'No transpose', P, N, N, ONE, B, LDB,
+ $ Q, LDQ, ZERO, WORK, LDB )
+*
+ CALL DGEMM( 'Transpose', 'No transpose', P, N, P, ONE, V, LDV,
+ $ WORK, LDB, ZERO, B, LDB )
+*
+ DO 100 I = 1, L
+ DO 90 J = I, L
+ B( I, N-L+J ) = B( I, N-L+J ) - BETA( K+I )*R( K+I, K+J )
+ 90 CONTINUE
+ 100 CONTINUE
+*
+* Compute norm( V'*B*Q - D2*R ) / ( MAX(P,N)*norm(B)*ULP ) .
+*
+ RESID = DLANGE( '1', P, N, B, LDB, RWORK )
+ IF( BNORM.GT.ZERO ) THEN
+ RESULT( 2 ) = ( ( RESID / DBLE( MAX( 1, P, N ) ) ) / BNORM ) /
+ $ ULP
+ ELSE
+ RESULT( 2 ) = ZERO
+ END IF
+*
+* Compute I - U'*U
+*
+ CALL DLASET( 'Full', M, M, ZERO, ONE, WORK, LDQ )
+ CALL DSYRK( 'Upper', 'Transpose', M, M, -ONE, U, LDU, ONE, WORK,
+ $ LDU )
+*
+* Compute norm( I - U'*U ) / ( M * ULP ) .
+*
+ RESID = DLANSY( '1', 'Upper', M, WORK, LDU, RWORK )
+ RESULT( 3 ) = ( RESID / DBLE( MAX( 1, M ) ) ) / ULP
+*
+* Compute I - V'*V
+*
+ CALL DLASET( 'Full', P, P, ZERO, ONE, WORK, LDV )
+ CALL DSYRK( 'Upper', 'Transpose', P, P, -ONE, V, LDV, ONE, WORK,
+ $ LDV )
+*
+* Compute norm( I - V'*V ) / ( P * ULP ) .
+*
+ RESID = DLANSY( '1', 'Upper', P, WORK, LDV, RWORK )
+ RESULT( 4 ) = ( RESID / DBLE( MAX( 1, P ) ) ) / ULP
+*
+* Compute I - Q'*Q
+*
+ CALL DLASET( 'Full', N, N, ZERO, ONE, WORK, LDQ )
+ CALL DSYRK( 'Upper', 'Transpose', N, N, -ONE, Q, LDQ, ONE, WORK,
+ $ LDQ )
+*
+* Compute norm( I - Q'*Q ) / ( N * ULP ) .
+*
+ RESID = DLANSY( '1', 'Upper', N, WORK, LDQ, RWORK )
+ RESULT( 5 ) = ( RESID / DBLE( MAX( 1, N ) ) ) / ULP
+*
+* Check sorting
+*
+ CALL DCOPY( N, ALPHA, 1, WORK, 1 )
+ DO 110 I = K + 1, MIN( K+L, M )
+ J = IWORK( I )
+ IF( I.NE.J ) THEN
+ TEMP = WORK( I )
+ WORK( I ) = WORK( J )
+ WORK( J ) = TEMP
+ END IF
+ 110 CONTINUE
+*
+ RESULT( 6 ) = ZERO
+ DO 120 I = K + 1, MIN( K+L, M ) - 1
+ IF( WORK( I ).LT.WORK( I+1 ) )
+ $ RESULT( 6 ) = ULPINV
+ 120 CONTINUE
+*
+ RETURN
+*
+* End of DGSVTS
+*
+ END
+ SUBROUTINE DHST01( N, ILO, IHI, A, LDA, H, LDH, Q, LDQ, WORK,
+ $ LWORK, RESULT )
+*
+* -- LAPACK test routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER IHI, ILO, LDA, LDH, LDQ, LWORK, N
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION A( LDA, * ), H( LDH, * ), Q( LDQ, * ),
+ $ RESULT( 2 ), WORK( LWORK )
+* ..
+*
+* Purpose
+* =======
+*
+* DHST01 tests the reduction of a general matrix A to upper Hessenberg
+* form: A = Q*H*Q'. Two test ratios are computed;
+*
+* RESULT(1) = norm( A - Q*H*Q' ) / ( norm(A) * N * EPS )
+* RESULT(2) = norm( I - Q'*Q ) / ( N * EPS )
+*
+* The matrix Q is assumed to be given explicitly as it would be
+* following DGEHRD + DORGHR.
+*
+* In this version, ILO and IHI are not used and are assumed to be 1 and
+* N, respectively.
+*
+* Arguments
+* =========
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* ILO (input) INTEGER
+* IHI (input) INTEGER
+* A is assumed to be upper triangular in rows and columns
+* 1:ILO-1 and IHI+1:N, so Q differs from the identity only in
+* rows and columns ILO+1:IHI.
+*
+* A (input) DOUBLE PRECISION array, dimension (LDA,N)
+* The original n by n matrix A.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,N).
+*
+* H (input) DOUBLE PRECISION array, dimension (LDH,N)
+* The upper Hessenberg matrix H from the reduction A = Q*H*Q'
+* as computed by DGEHRD. H is assumed to be zero below the
+* first subdiagonal.
+*
+* LDH (input) INTEGER
+* The leading dimension of the array H. LDH >= max(1,N).
+*
+* Q (input) DOUBLE PRECISION array, dimension (LDQ,N)
+* The orthogonal matrix Q from the reduction A = Q*H*Q' as
+* computed by DGEHRD + DORGHR.
+*
+* LDQ (input) INTEGER
+* The leading dimension of the array Q. LDQ >= max(1,N).
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK)
+*
+* LWORK (input) INTEGER
+* The length of the array WORK. LWORK >= 2*N*N.
+*
+* RESULT (output) DOUBLE PRECISION array, dimension (2)
+* RESULT(1) = norm( A - Q*H*Q' ) / ( norm(A) * N * EPS )
+* RESULT(2) = norm( I - Q'*Q ) / ( N * EPS )
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE, ZERO
+ PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
+* ..
+* .. Local Scalars ..
+ INTEGER LDWORK
+ DOUBLE PRECISION ANORM, EPS, OVFL, SMLNUM, UNFL, WNORM
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DLAMCH, DLANGE
+ EXTERNAL DLAMCH, DLANGE
+* ..
+* .. External Subroutines ..
+ EXTERNAL DGEMM, DLABAD, DLACPY, DORT01
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+* Quick return if possible
+*
+ IF( N.LE.0 ) THEN
+ RESULT( 1 ) = ZERO
+ RESULT( 2 ) = ZERO
+ RETURN
+ END IF
+*
+ UNFL = DLAMCH( 'Safe minimum' )
+ EPS = DLAMCH( 'Precision' )
+ OVFL = ONE / UNFL
+ CALL DLABAD( UNFL, OVFL )
+ SMLNUM = UNFL*N / EPS
+*
+* Test 1: Compute norm( A - Q*H*Q' ) / ( norm(A) * N * EPS )
+*
+* Copy A to WORK
+*
+ LDWORK = MAX( 1, N )
+ CALL DLACPY( ' ', N, N, A, LDA, WORK, LDWORK )
+*
+* Compute Q*H
+*
+ CALL DGEMM( 'No transpose', 'No transpose', N, N, N, ONE, Q, LDQ,
+ $ H, LDH, ZERO, WORK( LDWORK*N+1 ), LDWORK )
+*
+* Compute A - Q*H*Q'
+*
+ CALL DGEMM( 'No transpose', 'Transpose', N, N, N, -ONE,
+ $ WORK( LDWORK*N+1 ), LDWORK, Q, LDQ, ONE, WORK,
+ $ LDWORK )
+*
+ ANORM = MAX( DLANGE( '1', N, N, A, LDA, WORK( LDWORK*N+1 ) ),
+ $ UNFL )
+ WNORM = DLANGE( '1', N, N, WORK, LDWORK, WORK( LDWORK*N+1 ) )
+*
+* Note that RESULT(1) cannot overflow and is bounded by 1/(N*EPS)
+*
+ RESULT( 1 ) = MIN( WNORM, ANORM ) / MAX( SMLNUM, ANORM*EPS ) / N
+*
+* Test 2: Compute norm( I - Q'*Q ) / ( N * EPS )
+*
+ CALL DORT01( 'Columns', N, N, Q, LDQ, WORK, LWORK, RESULT( 2 ) )
+*
+ RETURN
+*
+* End of DHST01
+*
+ END
+ SUBROUTINE DLAFTS( TYPE, M, N, IMAT, NTESTS, RESULT, ISEED,
+ $ THRESH, IOUNIT, IE )
+*
+* -- LAPACK auxiliary test routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER*3 TYPE
+ INTEGER IE, IMAT, IOUNIT, M, N, NTESTS
+ DOUBLE PRECISION THRESH
+* ..
+* .. Array Arguments ..
+ INTEGER ISEED( 4 )
+ DOUBLE PRECISION RESULT( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DLAFTS tests the result vector against the threshold value to
+* see which tests for this matrix type failed to pass the threshold.
+* Output is to the file given by unit IOUNIT.
+*
+* Arguments
+* =========
+*
+* TYPE - CHARACTER*3
+* On entry, TYPE specifies the matrix type to be used in the
+* printed messages.
+* Not modified.
+*
+* N - INTEGER
+* On entry, N specifies the order of the test matrix.
+* Not modified.
+*
+* IMAT - INTEGER
+* On entry, IMAT specifies the type of the test matrix.
+* A listing of the different types is printed by DLAHD2
+* to the output file if a test fails to pass the threshold.
+* Not modified.
+*
+* NTESTS - INTEGER
+* On entry, NTESTS is the number of tests performed on the
+* subroutines in the path given by TYPE.
+* Not modified.
+*
+* RESULT - DOUBLE PRECISION array of dimension( NTESTS )
+* On entry, RESULT contains the test ratios from the tests
+* performed in the calling program.
+* Not modified.
+*
+* ISEED - INTEGER array of dimension( 4 )
+* Contains the random seed that generated the matrix used
+* for the tests whose ratios are in RESULT.
+* Not modified.
+*
+* THRESH - DOUBLE PRECISION
+* On entry, THRESH specifies the acceptable threshold of the
+* test ratios. If RESULT( K ) > THRESH, then the K-th test
+* did not pass the threshold and a message will be printed.
+* Not modified.
+*
+* IOUNIT - INTEGER
+* On entry, IOUNIT specifies the unit number of the file
+* to which the messages are printed.
+* Not modified.
+*
+* IE - INTEGER
+* On entry, IE contains the number of tests which have
+* failed to pass the threshold so far.
+* Updated on exit if any of the ratios in RESULT also fail.
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ INTEGER K
+* ..
+* .. External Subroutines ..
+ EXTERNAL DLAHD2
+* ..
+* .. Executable Statements ..
+*
+ IF( M.EQ.N ) THEN
+*
+* Output for square matrices:
+*
+ DO 10 K = 1, NTESTS
+ IF( RESULT( K ).GE.THRESH ) THEN
+*
+* If this is the first test to fail, call DLAHD2
+* to print a header to the data file.
+*
+ IF( IE.EQ.0 )
+ $ CALL DLAHD2( IOUNIT, TYPE )
+ IE = IE + 1
+*** WRITE( IOUNIT, 15 )' Matrix of order', N,
+*** $ ', type ', IMAT,
+*** $ ', test ', K,
+*** $ ', ratio = ', RESULT( K )
+*** 15 FORMAT( A16, I5, 2( A8, I2 ), A11, G13.6 )
+ IF( RESULT( K ).LT.10000.0D0 ) THEN
+ WRITE( IOUNIT, FMT = 9999 )N, IMAT, ISEED, K,
+ $ RESULT( K )
+ 9999 FORMAT( ' Matrix order=', I5, ', type=', I2,
+ $ ', seed=', 4( I4, ',' ), ' result ', I3, ' is',
+ $ 0P, F8.2 )
+ ELSE
+ WRITE( IOUNIT, FMT = 9998 )N, IMAT, ISEED, K,
+ $ RESULT( K )
+ 9998 FORMAT( ' Matrix order=', I5, ', type=', I2,
+ $ ', seed=', 4( I4, ',' ), ' result ', I3, ' is',
+ $ 1P, D10.3 )
+ END IF
+ END IF
+ 10 CONTINUE
+ ELSE
+*
+* Output for rectangular matrices
+*
+ DO 20 K = 1, NTESTS
+ IF( RESULT( K ).GE.THRESH ) THEN
+*
+* If this is the first test to fail, call DLAHD2
+* to print a header to the data file.
+*
+ IF( IE.EQ.0 )
+ $ CALL DLAHD2( IOUNIT, TYPE )
+ IE = IE + 1
+*** WRITE( IOUNIT, FMT = 9997 )' Matrix of size', M, ' x',
+*** $ N, ', type ', IMAT, ', test ', K, ', ratio = ',
+*** $ RESULT( K )
+*** 9997 FORMAT( A10, I5, A2, I5, A7, I2, A8, I2, A11, G13.6 )
+ IF( RESULT( K ).LT.10000.0D0 ) THEN
+ WRITE( IOUNIT, FMT = 9997 )M, N, IMAT, ISEED, K,
+ $ RESULT( K )
+ 9997 FORMAT( 1X, I5, ' x', I5, ' matrix, type=', I2, ', s',
+ $ 'eed=', 3( I4, ',' ), I4, ': result ', I3,
+ $ ' is', 0P, F8.2 )
+ ELSE
+ WRITE( IOUNIT, FMT = 9996 )M, N, IMAT, ISEED, K,
+ $ RESULT( K )
+ 9996 FORMAT( 1X, I5, ' x', I5, ' matrix, type=', I2, ', s',
+ $ 'eed=', 3( I4, ',' ), I4, ': result ', I3,
+ $ ' is', 1P, D10.3 )
+ END IF
+ END IF
+ 20 CONTINUE
+*
+ END IF
+ RETURN
+*
+* End of DLAFTS
+*
+ END
+ SUBROUTINE DLAHD2( IOUNIT, PATH )
+*
+* -- LAPACK auxiliary test routine (version 2.0) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER*3 PATH
+ INTEGER IOUNIT
+* ..
+*
+* Purpose
+* =======
+*
+* DLAHD2 prints header information for the different test paths.
+*
+* Arguments
+* =========
+*
+* IOUNIT (input) INTEGER.
+* On entry, IOUNIT specifies the unit number to which the
+* header information should be printed.
+*
+* PATH (input) CHARACTER*3.
+* On entry, PATH contains the name of the path for which the
+* header information is to be printed. Current paths are
+*
+* DHS, ZHS: Non-symmetric eigenproblem.
+* DST, ZST: Symmetric eigenproblem.
+* DSG, ZSG: Symmetric Generalized eigenproblem.
+* DBD, ZBD: Singular Value Decomposition (SVD)
+* DBB, ZBB: General Banded reduction to bidiagonal form
+*
+* These paths also are supplied in double precision (replace
+* leading S by D and leading C by Z in path names).
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ LOGICAL CORZ, SORD
+ CHARACTER*2 C2
+ INTEGER J
+* ..
+* .. External Functions ..
+ LOGICAL LSAME, LSAMEN
+ EXTERNAL LSAME, LSAMEN
+* ..
+* .. Executable Statements ..
+*
+ IF( IOUNIT.LE.0 )
+ $ RETURN
+ SORD = LSAME( PATH, 'S' ) .OR. LSAME( PATH, 'D' )
+ CORZ = LSAME( PATH, 'C' ) .OR. LSAME( PATH, 'Z' )
+ IF( .NOT.SORD .AND. .NOT.CORZ ) THEN
+ WRITE( IOUNIT, FMT = 9999 )PATH
+ END IF
+ C2 = PATH( 2: 3 )
+*
+ IF( LSAMEN( 2, C2, 'HS' ) ) THEN
+ IF( SORD ) THEN
+*
+* Real Non-symmetric Eigenvalue Problem:
+*
+ WRITE( IOUNIT, FMT = 9998 )PATH
+*
+* Matrix types
+*
+ WRITE( IOUNIT, FMT = 9988 )
+ WRITE( IOUNIT, FMT = 9987 )
+ WRITE( IOUNIT, FMT = 9986 )'pairs ', 'pairs ', 'prs.',
+ $ 'prs.'
+ WRITE( IOUNIT, FMT = 9985 )
+*
+* Tests performed
+*
+ WRITE( IOUNIT, FMT = 9984 )'orthogonal', '''=transpose',
+ $ ( '''', J = 1, 6 )
+*
+ ELSE
+*
+* Complex Non-symmetric Eigenvalue Problem:
+*
+ WRITE( IOUNIT, FMT = 9997 )PATH
+*
+* Matrix types
+*
+ WRITE( IOUNIT, FMT = 9988 )
+ WRITE( IOUNIT, FMT = 9987 )
+ WRITE( IOUNIT, FMT = 9986 )'e.vals', 'e.vals', 'e.vs',
+ $ 'e.vs'
+ WRITE( IOUNIT, FMT = 9985 )
+*
+* Tests performed
+*
+ WRITE( IOUNIT, FMT = 9984 )'unitary', '*=conj.transp.',
+ $ ( '*', J = 1, 6 )
+ END IF
+*
+ ELSE IF( LSAMEN( 2, C2, 'ST' ) ) THEN
+*
+ IF( SORD ) THEN
+*
+* Real Symmetric Eigenvalue Problem:
+*
+ WRITE( IOUNIT, FMT = 9996 )PATH
+*
+* Matrix types
+*
+ WRITE( IOUNIT, FMT = 9983 )
+ WRITE( IOUNIT, FMT = 9982 )
+ WRITE( IOUNIT, FMT = 9981 )'Symmetric'
+*
+* Tests performed
+*
+ WRITE( IOUNIT, FMT = 9968 )
+*
+ ELSE
+*
+* Complex Hermitian Eigenvalue Problem:
+*
+ WRITE( IOUNIT, FMT = 9995 )PATH
+*
+* Matrix types
+*
+ WRITE( IOUNIT, FMT = 9983 )
+ WRITE( IOUNIT, FMT = 9982 )
+ WRITE( IOUNIT, FMT = 9981 )'Hermitian'
+*
+* Tests performed
+*
+ WRITE( IOUNIT, FMT = 9967 )
+ END IF
+*
+ ELSE IF( LSAMEN( 2, C2, 'SG' ) ) THEN
+*
+ IF( SORD ) THEN
+*
+* Real Symmetric Generalized Eigenvalue Problem:
+*
+ WRITE( IOUNIT, FMT = 9992 )PATH
+*
+* Matrix types
+*
+ WRITE( IOUNIT, FMT = 9980 )
+ WRITE( IOUNIT, FMT = 9979 )
+ WRITE( IOUNIT, FMT = 9978 )'Symmetric'
+*
+* Tests performed
+*
+ WRITE( IOUNIT, FMT = 9977 )
+ WRITE( IOUNIT, FMT = 9976 )
+*
+ ELSE
+*
+* Complex Hermitian Generalized Eigenvalue Problem:
+*
+ WRITE( IOUNIT, FMT = 9991 )PATH
+*
+* Matrix types
+*
+ WRITE( IOUNIT, FMT = 9980 )
+ WRITE( IOUNIT, FMT = 9979 )
+ WRITE( IOUNIT, FMT = 9978 )'Hermitian'
+*
+* Tests performed
+*
+ WRITE( IOUNIT, FMT = 9975 )
+ WRITE( IOUNIT, FMT = 9974 )
+*
+ END IF
+*
+ ELSE IF( LSAMEN( 2, C2, 'BD' ) ) THEN
+*
+ IF( SORD ) THEN
+*
+* Real Singular Value Decomposition:
+*
+ WRITE( IOUNIT, FMT = 9994 )PATH
+*
+* Matrix types
+*
+ WRITE( IOUNIT, FMT = 9973 )
+*
+* Tests performed
+*
+ WRITE( IOUNIT, FMT = 9972 )'orthogonal'
+ WRITE( IOUNIT, FMT = 9971 )
+ ELSE
+*
+* Complex Singular Value Decomposition:
+*
+ WRITE( IOUNIT, FMT = 9993 )PATH
+*
+* Matrix types
+*
+ WRITE( IOUNIT, FMT = 9973 )
+*
+* Tests performed
+*
+ WRITE( IOUNIT, FMT = 9972 )'unitary '
+ WRITE( IOUNIT, FMT = 9971 )
+ END IF
+*
+ ELSE IF( LSAMEN( 2, C2, 'BB' ) ) THEN
+*
+ IF( SORD ) THEN
+*
+* Real General Band reduction to bidiagonal form:
+*
+ WRITE( IOUNIT, FMT = 9990 )PATH
+*
+* Matrix types
+*
+ WRITE( IOUNIT, FMT = 9970 )
+*
+* Tests performed
+*
+ WRITE( IOUNIT, FMT = 9969 )'orthogonal'
+ ELSE
+*
+* Complex Band reduction to bidiagonal form:
+*
+ WRITE( IOUNIT, FMT = 9989 )PATH
+*
+* Matrix types
+*
+ WRITE( IOUNIT, FMT = 9970 )
+*
+* Tests performed
+*
+ WRITE( IOUNIT, FMT = 9969 )'unitary '
+ END IF
+*
+ ELSE
+*
+ WRITE( IOUNIT, FMT = 9999 )PATH
+ RETURN
+ END IF
+*
+ RETURN
+*
+ 9999 FORMAT( 1X, A3, ': no header available' )
+ 9998 FORMAT( / 1X, A3, ' -- Real Non-symmetric eigenvalue problem' )
+ 9997 FORMAT( / 1X, A3, ' -- Complex Non-symmetric eigenvalue problem' )
+ 9996 FORMAT( / 1X, A3, ' -- Real Symmetric eigenvalue problem' )
+ 9995 FORMAT( / 1X, A3, ' -- Complex Hermitian eigenvalue problem' )
+ 9994 FORMAT( / 1X, A3, ' -- Real Singular Value Decomposition' )
+ 9993 FORMAT( / 1X, A3, ' -- Complex Singular Value Decomposition' )
+ 9992 FORMAT( / 1X, A3, ' -- Real Symmetric Generalized eigenvalue ',
+ $ 'problem' )
+ 9991 FORMAT( / 1X, A3, ' -- Complex Hermitian Generalized eigenvalue ',
+ $ 'problem' )
+ 9990 FORMAT( / 1X, A3, ' -- Real Band reduc. to bidiagonal form' )
+ 9989 FORMAT( / 1X, A3, ' -- Complex Band reduc. to bidiagonal form' )
+*
+ 9988 FORMAT( ' Matrix types (see xCHKHS for details): ' )
+*
+ 9987 FORMAT( / ' Special Matrices:', / ' 1=Zero matrix. ',
+ $ ' ', ' 5=Diagonal: geometr. spaced entries.',
+ $ / ' 2=Identity matrix. ', ' 6=Diagona',
+ $ 'l: clustered entries.', / ' 3=Transposed Jordan block. ',
+ $ ' ', ' 7=Diagonal: large, evenly spaced.', / ' ',
+ $ '4=Diagonal: evenly spaced entries. ', ' 8=Diagonal: s',
+ $ 'mall, evenly spaced.' )
+ 9986 FORMAT( ' Dense, Non-Symmetric Matrices:', / ' 9=Well-cond., ev',
+ $ 'enly spaced eigenvals.', ' 14=Ill-cond., geomet. spaced e',
+ $ 'igenals.', / ' 10=Well-cond., geom. spaced eigenvals. ',
+ $ ' 15=Ill-conditioned, clustered e.vals.', / ' 11=Well-cond',
+ $ 'itioned, clustered e.vals. ', ' 16=Ill-cond., random comp',
+ $ 'lex ', A6, / ' 12=Well-cond., random complex ', A6, ' ',
+ $ ' 17=Ill-cond., large rand. complx ', A4, / ' 13=Ill-condi',
+ $ 'tioned, evenly spaced. ', ' 18=Ill-cond., small rand.',
+ $ ' complx ', A4 )
+ 9985 FORMAT( ' 19=Matrix with random O(1) entries. ', ' 21=Matrix ',
+ $ 'with small random entries.', / ' 20=Matrix with large ran',
+ $ 'dom entries. ' )
+ 9984 FORMAT( / ' Tests performed: ', '(H is Hessenberg, T is Schur,',
+ $ ' U and Z are ', A, ',', / 20X, A, ', W is a diagonal matr',
+ $ 'ix of eigenvalues,', / 20X, 'L and R are the left and rig',
+ $ 'ht eigenvector matrices)', / ' 1 = | A - U H U', A1, ' |',
+ $ ' / ( |A| n ulp ) ', ' 2 = | I - U U', A1, ' | / ',
+ $ '( n ulp )', / ' 3 = | H - Z T Z', A1, ' | / ( |H| n ulp ',
+ $ ') ', ' 4 = | I - Z Z', A1, ' | / ( n ulp )',
+ $ / ' 5 = | A - UZ T (UZ)', A1, ' | / ( |A| n ulp ) ',
+ $ ' 6 = | I - UZ (UZ)', A1, ' | / ( n ulp )', / ' 7 = | T(',
+ $ 'e.vects.) - T(no e.vects.) | / ( |T| ulp )', / ' 8 = | W',
+ $ '(e.vects.) - W(no e.vects.) | / ( |W| ulp )', / ' 9 = | ',
+ $ 'TR - RW | / ( |T| |R| ulp ) ', ' 10 = | LT - WL | / (',
+ $ ' |T| |L| ulp )', / ' 11= |HX - XW| / (|H| |X| ulp) (inv.',
+ $ 'it)', ' 12= |YH - WY| / (|H| |Y| ulp) (inv.it)' )
+*
+* Symmetric/Hermitian eigenproblem
+*
+ 9983 FORMAT( ' Matrix types (see xDRVST for details): ' )
+*
+ 9982 FORMAT( / ' Special Matrices:', / ' 1=Zero matrix. ',
+ $ ' ', ' 5=Diagonal: clustered entries.', / ' 2=',
+ $ 'Identity matrix. ', ' 6=Diagonal: lar',
+ $ 'ge, evenly spaced.', / ' 3=Diagonal: evenly spaced entri',
+ $ 'es. ', ' 7=Diagonal: small, evenly spaced.', / ' 4=D',
+ $ 'iagonal: geometr. spaced entries.' )
+ 9981 FORMAT( ' Dense ', A, ' Matrices:', / ' 8=Evenly spaced eigen',
+ $ 'vals. ', ' 12=Small, evenly spaced eigenvals.',
+ $ / ' 9=Geometrically spaced eigenvals. ', ' 13=Matrix ',
+ $ 'with random O(1) entries.', / ' 10=Clustered eigenvalues.',
+ $ ' ', ' 14=Matrix with large random entries.',
+ $ / ' 11=Large, evenly spaced eigenvals. ', ' 15=Matrix ',
+ $ 'with small random entries.' )
+*
+* Symmetric/Hermitian Generalized eigenproblem
+*
+ 9980 FORMAT( ' Matrix types (see xDRVSG for details): ' )
+*
+ 9979 FORMAT( / ' Special Matrices:', / ' 1=Zero matrix. ',
+ $ ' ', ' 5=Diagonal: clustered entries.', / ' 2=',
+ $ 'Identity matrix. ', ' 6=Diagonal: lar',
+ $ 'ge, evenly spaced.', / ' 3=Diagonal: evenly spaced entri',
+ $ 'es. ', ' 7=Diagonal: small, evenly spaced.', / ' 4=D',
+ $ 'iagonal: geometr. spaced entries.' )
+ 9978 FORMAT( ' Dense or Banded ', A, ' Matrices: ',
+ $ / ' 8=Evenly spaced eigenvals. ',
+ $ ' 15=Matrix with small random entries.',
+ $ / ' 9=Geometrically spaced eigenvals. ',
+ $ ' 16=Evenly spaced eigenvals, KA=1, KB=1.',
+ $ / ' 10=Clustered eigenvalues. ',
+ $ ' 17=Evenly spaced eigenvals, KA=2, KB=1.',
+ $ / ' 11=Large, evenly spaced eigenvals. ',
+ $ ' 18=Evenly spaced eigenvals, KA=2, KB=2.',
+ $ / ' 12=Small, evenly spaced eigenvals. ',
+ $ ' 19=Evenly spaced eigenvals, KA=3, KB=1.',
+ $ / ' 13=Matrix with random O(1) entries. ',
+ $ ' 20=Evenly spaced eigenvals, KA=3, KB=2.',
+ $ / ' 14=Matrix with large random entries.',
+ $ ' 21=Evenly spaced eigenvals, KA=3, KB=3.' )
+ 9977 FORMAT( / ' Tests performed: ',
+ $ / '( For each pair (A,B), where A is of the given type ',
+ $ / ' and B is a random well-conditioned matrix. D is ',
+ $ / ' diagonal, and Z is orthogonal. )',
+ $ / ' 1 = DSYGV, with ITYPE=1 and UPLO=''U'':',
+ $ ' | A Z - B Z D | / ( |A| |Z| n ulp ) ',
+ $ / ' 2 = DSPGV, with ITYPE=1 and UPLO=''U'':',
+ $ ' | A Z - B Z D | / ( |A| |Z| n ulp ) ',
+ $ / ' 3 = DSBGV, with ITYPE=1 and UPLO=''U'':',
+ $ ' | A Z - B Z D | / ( |A| |Z| n ulp ) ',
+ $ / ' 4 = DSYGV, with ITYPE=1 and UPLO=''L'':',
+ $ ' | A Z - B Z D | / ( |A| |Z| n ulp ) ',
+ $ / ' 5 = DSPGV, with ITYPE=1 and UPLO=''L'':',
+ $ ' | A Z - B Z D | / ( |A| |Z| n ulp ) ',
+ $ / ' 6 = DSBGV, with ITYPE=1 and UPLO=''L'':',
+ $ ' | A Z - B Z D | / ( |A| |Z| n ulp ) ' )
+ 9976 FORMAT( ' 7 = DSYGV, with ITYPE=2 and UPLO=''U'':',
+ $ ' | A B Z - Z D | / ( |A| |Z| n ulp ) ',
+ $ / ' 8 = DSPGV, with ITYPE=2 and UPLO=''U'':',
+ $ ' | A B Z - Z D | / ( |A| |Z| n ulp ) ',
+ $ / ' 9 = DSPGV, with ITYPE=2 and UPLO=''L'':',
+ $ ' | A B Z - Z D | / ( |A| |Z| n ulp ) ',
+ $ / '10 = DSPGV, with ITYPE=2 and UPLO=''L'':',
+ $ ' | A B Z - Z D | / ( |A| |Z| n ulp ) ',
+ $ / '11 = DSYGV, with ITYPE=3 and UPLO=''U'':',
+ $ ' | B A Z - Z D | / ( |A| |Z| n ulp ) ',
+ $ / '12 = DSPGV, with ITYPE=3 and UPLO=''U'':',
+ $ ' | B A Z - Z D | / ( |A| |Z| n ulp ) ',
+ $ / '13 = DSYGV, with ITYPE=3 and UPLO=''L'':',
+ $ ' | B A Z - Z D | / ( |A| |Z| n ulp ) ',
+ $ / '14 = DSPGV, with ITYPE=3 and UPLO=''L'':',
+ $ ' | B A Z - Z D | / ( |A| |Z| n ulp ) ' )
+ 9975 FORMAT( / ' Tests performed: ',
+ $ / '( For each pair (A,B), where A is of the given type ',
+ $ / ' and B is a random well-conditioned matrix. D is ',
+ $ / ' diagonal, and Z is unitary. )',
+ $ / ' 1 = ZHEGV, with ITYPE=1 and UPLO=''U'':',
+ $ ' | A Z - B Z D | / ( |A| |Z| n ulp ) ',
+ $ / ' 2 = ZHPGV, with ITYPE=1 and UPLO=''U'':',
+ $ ' | A Z - B Z D | / ( |A| |Z| n ulp ) ',
+ $ / ' 3 = ZHBGV, with ITYPE=1 and UPLO=''U'':',
+ $ ' | A Z - B Z D | / ( |A| |Z| n ulp ) ',
+ $ / ' 4 = ZHEGV, with ITYPE=1 and UPLO=''L'':',
+ $ ' | A Z - B Z D | / ( |A| |Z| n ulp ) ',
+ $ / ' 5 = ZHPGV, with ITYPE=1 and UPLO=''L'':',
+ $ ' | A Z - B Z D | / ( |A| |Z| n ulp ) ',
+ $ / ' 6 = ZHBGV, with ITYPE=1 and UPLO=''L'':',
+ $ ' | A Z - B Z D | / ( |A| |Z| n ulp ) ' )
+ 9974 FORMAT( ' 7 = ZHEGV, with ITYPE=2 and UPLO=''U'':',
+ $ ' | A B Z - Z D | / ( |A| |Z| n ulp ) ',
+ $ / ' 8 = ZHPGV, with ITYPE=2 and UPLO=''U'':',
+ $ ' | A B Z - Z D | / ( |A| |Z| n ulp ) ',
+ $ / ' 9 = ZHPGV, with ITYPE=2 and UPLO=''L'':',
+ $ ' | A B Z - Z D | / ( |A| |Z| n ulp ) ',
+ $ / '10 = ZHPGV, with ITYPE=2 and UPLO=''L'':',
+ $ ' | A B Z - Z D | / ( |A| |Z| n ulp ) ',
+ $ / '11 = ZHEGV, with ITYPE=3 and UPLO=''U'':',
+ $ ' | B A Z - Z D | / ( |A| |Z| n ulp ) ',
+ $ / '12 = ZHPGV, with ITYPE=3 and UPLO=''U'':',
+ $ ' | B A Z - Z D | / ( |A| |Z| n ulp ) ',
+ $ / '13 = ZHEGV, with ITYPE=3 and UPLO=''L'':',
+ $ ' | B A Z - Z D | / ( |A| |Z| n ulp ) ',
+ $ / '14 = ZHPGV, with ITYPE=3 and UPLO=''L'':',
+ $ ' | B A Z - Z D | / ( |A| |Z| n ulp ) ' )
+*
+* Singular Value Decomposition
+*
+ 9973 FORMAT( ' Matrix types (see xCHKBD for details):',
+ $ / ' Diagonal matrices:', / ' 1: Zero', 28X,
+ $ ' 5: Clustered entries', / ' 2: Identity', 24X,
+ $ ' 6: Large, evenly spaced entries',
+ $ / ' 3: Evenly spaced entries', 11X,
+ $ ' 7: Small, evenly spaced entries',
+ $ / ' 4: Geometrically spaced entries',
+ $ / ' General matrices:', / ' 8: Evenly spaced sing. vals.',
+ $ 7X, '12: Small, evenly spaced sing vals',
+ $ / ' 9: Geometrically spaced sing vals ',
+ $ '13: Random, O(1) entries', / ' 10: Clustered sing. vals.',
+ $ 11X, '14: Random, scaled near overflow',
+ $ / ' 11: Large, evenly spaced sing vals ',
+ $ '15: Random, scaled near underflow' )
+*
+ 9972 FORMAT( / ' Test ratios: ',
+ $ '(B: bidiagonal, S: diagonal, Q, P, U, and V: ', A10, / 16X,
+ $ 'X: m x nrhs, Y = Q'' X, and Z = U'' Y)',
+ $ / ' 1: norm( A - Q B P'' ) / ( norm(A) max(m,n) ulp )',
+ $ / ' 2: norm( I - Q'' Q ) / ( m ulp )',
+ $ / ' 3: norm( I - P'' P ) / ( n ulp )',
+ $ / ' 4: norm( B - U S V'' ) / ( norm(B) min(m,n) ulp )', /
+ $ ' 5: norm( Y - U Z ) / ( norm(Z) max(min(m,n),k) ulp )'
+ $ , / ' 6: norm( I - U'' U ) / ( min(m,n) ulp )',
+ $ / ' 7: norm( I - V'' V ) / ( min(m,n) ulp )' )
+ 9971 FORMAT( ' 8: Test ordering of S (0 if nondecreasing, 1/ulp ',
+ $ ' otherwise)', /
+ $ ' 9: norm( S - S2 ) / ( norm(S) ulp ),',
+ $ ' where S2 is computed', / 44X,
+ $ 'without computing U and V''',
+ $ / ' 10: Sturm sequence test ',
+ $ '(0 if sing. vals of B within THRESH of S)',
+ $ / ' 11: norm( A - (QU) S (V'' P'') ) / ',
+ $ '( norm(A) max(m,n) ulp )', /
+ $ ' 12: norm( X - (QU) Z ) / ( |X| max(M,k) ulp )',
+ $ / ' 13: norm( I - (QU)''(QU) ) / ( M ulp )',
+ $ / ' 14: norm( I - (V'' P'') (P V) ) / ( N ulp )' )
+*
+* Band reduction to bidiagonal form
+*
+ 9970 FORMAT( ' Matrix types (see xCHKBB for details):',
+ $ / ' Diagonal matrices:', / ' 1: Zero', 28X,
+ $ ' 5: Clustered entries', / ' 2: Identity', 24X,
+ $ ' 6: Large, evenly spaced entries',
+ $ / ' 3: Evenly spaced entries', 11X,
+ $ ' 7: Small, evenly spaced entries',
+ $ / ' 4: Geometrically spaced entries',
+ $ / ' General matrices:', / ' 8: Evenly spaced sing. vals.',
+ $ 7X, '12: Small, evenly spaced sing vals',
+ $ / ' 9: Geometrically spaced sing vals ',
+ $ '13: Random, O(1) entries', / ' 10: Clustered sing. vals.',
+ $ 11X, '14: Random, scaled near overflow',
+ $ / ' 11: Large, evenly spaced sing vals ',
+ $ '15: Random, scaled near underflow' )
+*
+ 9969 FORMAT( / ' Test ratios: ', '(B: upper bidiagonal, Q and P: ',
+ $ A10, / 16X, 'C: m x nrhs, PT = P'', Y = Q'' C)',
+ $ / ' 1: norm( A - Q B PT ) / ( norm(A) max(m,n) ulp )',
+ $ / ' 2: norm( I - Q'' Q ) / ( m ulp )',
+ $ / ' 3: norm( I - PT PT'' ) / ( n ulp )',
+ $ / ' 4: norm( Y - Q'' C ) / ( norm(Y) max(m,nrhs) ulp )' )
+ 9968 FORMAT( / ' Tests performed: See sdrvst.f' )
+ 9967 FORMAT( / ' Tests performed: See cdrvst.f' )
+*
+* End of DLAHD2
+*
+ END
+ SUBROUTINE DLARFY( UPLO, N, V, INCV, TAU, C, LDC, WORK )
+*
+* -- LAPACK auxiliary test routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER INCV, LDC, N
+ DOUBLE PRECISION TAU
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION C( LDC, * ), V( * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DLARFY applies an elementary reflector, or Householder matrix, H,
+* to an n x n symmetric matrix C, from both the left and the right.
+*
+* H is represented in the form
+*
+* H = I - tau * v * v'
+*
+* where tau is a scalar and v is a vector.
+*
+* If tau is zero, then H is taken to be the unit matrix.
+*
+* Arguments
+* =========
+*
+* UPLO (input) CHARACTER*1
+* Specifies whether the upper or lower triangular part of the
+* symmetric matrix C is stored.
+* = 'U': Upper triangle
+* = 'L': Lower triangle
+*
+* N (input) INTEGER
+* The number of rows and columns of the matrix C. N >= 0.
+*
+* V (input) DOUBLE PRECISION array, dimension
+* (1 + (N-1)*abs(INCV))
+* The vector v as described above.
+*
+* INCV (input) INTEGER
+* The increment between successive elements of v. INCV must
+* not be zero.
+*
+* TAU (input) DOUBLE PRECISION
+* The value tau as described above.
+*
+* C (input/output) DOUBLE PRECISION array, dimension (LDC, N)
+* On entry, the matrix C.
+* On exit, C is overwritten by H * C * H'.
+*
+* LDC (input) INTEGER
+* The leading dimension of the array C. LDC >= max( 1, N ).
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (N)
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE, ZERO, HALF
+ PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0, HALF = 0.5D+0 )
+* ..
+* .. Local Scalars ..
+ DOUBLE PRECISION ALPHA
+* ..
+* .. External Subroutines ..
+ EXTERNAL DAXPY, DSYMV, DSYR2
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DDOT
+ EXTERNAL DDOT
+* ..
+* .. Executable Statements ..
+*
+ IF( TAU.EQ.ZERO )
+ $ RETURN
+*
+* Form w:= C * v
+*
+ CALL DSYMV( UPLO, N, ONE, C, LDC, V, INCV, ZERO, WORK, 1 )
+*
+ ALPHA = -HALF*TAU*DDOT( N, WORK, 1, V, INCV )
+ CALL DAXPY( N, ALPHA, V, INCV, WORK, 1 )
+*
+* C := C - v * w' - w * v'
+*
+ CALL DSYR2( UPLO, N, -TAU, V, INCV, WORK, 1, C, LDC )
+*
+ RETURN
+*
+* End of DLARFY
+*
+ END
+ SUBROUTINE DLARHS( PATH, XTYPE, UPLO, TRANS, M, N, KL, KU, NRHS,
+ $ A, LDA, X, LDX, B, LDB, ISEED, INFO )
+*
+* -- LAPACK test routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER TRANS, UPLO, XTYPE
+ CHARACTER*3 PATH
+ INTEGER INFO, KL, KU, LDA, LDB, LDX, M, N, NRHS
+* ..
+* .. Array Arguments ..
+ INTEGER ISEED( 4 )
+ DOUBLE PRECISION A( LDA, * ), B( LDB, * ), X( LDX, * )
+* ..
+*
+* Purpose
+* =======
+*
+* DLARHS chooses a set of NRHS random solution vectors and sets
+* up the right hand sides for the linear system
+* op( A ) * X = B,
+* where op( A ) may be A or A' (transpose of A).
+*
+* Arguments
+* =========
+*
+* PATH (input) CHARACTER*3
+* The type of the real matrix A. PATH may be given in any
+* combination of upper and lower case. Valid types include
+* xGE: General m x n matrix
+* xGB: General banded matrix
+* xPO: Symmetric positive definite, 2-D storage
+* xPP: Symmetric positive definite packed
+* xPB: Symmetric positive definite banded
+* xSY: Symmetric indefinite, 2-D storage
+* xSP: Symmetric indefinite packed
+* xSB: Symmetric indefinite banded
+* xTR: Triangular
+* xTP: Triangular packed
+* xTB: Triangular banded
+* xQR: General m x n matrix
+* xLQ: General m x n matrix
+* xQL: General m x n matrix
+* xRQ: General m x n matrix
+* where the leading character indicates the precision.
+*
+* XTYPE (input) CHARACTER*1
+* Specifies how the exact solution X will be determined:
+* = 'N': New solution; generate a random X.
+* = 'C': Computed; use value of X on entry.
+*
+* UPLO (input) CHARACTER*1
+* Specifies whether the upper or lower triangular part of the
+* matrix A is stored, if A is symmetric.
+* = 'U': Upper triangular
+* = 'L': Lower triangular
+*
+* TRANS (input) CHARACTER*1
+* Specifies the operation applied to the matrix A.
+* = 'N': System is A * x = b
+* = 'T': System is A'* x = b
+* = 'C': System is A'* x = b
+*
+* M (input) INTEGER
+* The number or rows of the matrix A. M >= 0.
+*
+* N (input) INTEGER
+* The number of columns of the matrix A. N >= 0.
+*
+* KL (input) INTEGER
+* Used only if A is a band matrix; specifies the number of
+* subdiagonals of A if A is a general band matrix or if A is
+* symmetric or triangular and UPLO = 'L'; specifies the number
+* of superdiagonals of A if A is symmetric or triangular and
+* UPLO = 'U'. 0 <= KL <= M-1.
+*
+* KU (input) INTEGER
+* Used only if A is a general band matrix or if A is
+* triangular.
+*
+* If PATH = xGB, specifies the number of superdiagonals of A,
+* and 0 <= KU <= N-1.
+*
+* If PATH = xTR, xTP, or xTB, specifies whether or not the
+* matrix has unit diagonal:
+* = 1: matrix has non-unit diagonal (default)
+* = 2: matrix has unit diagonal
+*
+* NRHS (input) INTEGER
+* The number of right hand side vectors in the system A*X = B.
+*
+* A (input) DOUBLE PRECISION array, dimension (LDA,N)
+* The test matrix whose type is given by PATH.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A.
+* If PATH = xGB, LDA >= KL+KU+1.
+* If PATH = xPB, xSB, xHB, or xTB, LDA >= KL+1.
+* Otherwise, LDA >= max(1,M).
+*
+* X (input or output) DOUBLE PRECISION array, dimension(LDX,NRHS)
+* On entry, if XTYPE = 'C' (for 'Computed'), then X contains
+* the exact solution to the system of linear equations.
+* On exit, if XTYPE = 'N' (for 'New'), then X is initialized
+* with random values.
+*
+* LDX (input) INTEGER
+* The leading dimension of the array X. If TRANS = 'N',
+* LDX >= max(1,N); if TRANS = 'T', LDX >= max(1,M).
+*
+* B (output) DOUBLE PRECISION array, dimension (LDB,NRHS)
+* The right hand side vector(s) for the system of equations,
+* computed from B = op(A) * X, where op(A) is determined by
+* TRANS.
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. If TRANS = 'N',
+* LDB >= max(1,M); if TRANS = 'T', LDB >= max(1,N).
+*
+* ISEED (input/output) INTEGER array, dimension (4)
+* The seed vector for the random number generator (used in
+* DLATMS). Modified on exit.
+*
+* INFO (output) INTEGER
+* = 0: successful exit
+* < 0: if INFO = -i, the i-th argument had an illegal value
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE, ZERO
+ PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL BAND, GEN, NOTRAN, QRS, SYM, TRAN, TRI
+ CHARACTER C1, DIAG
+ CHARACTER*2 C2
+ INTEGER J, MB, NX
+* ..
+* .. External Functions ..
+ LOGICAL LSAME, LSAMEN
+ EXTERNAL LSAME, LSAMEN
+* ..
+* .. External Subroutines ..
+ EXTERNAL DGBMV, DGEMM, DLACPY, DLARNV, DSBMV, DSPMV,
+ $ DSYMM, DTBMV, DTPMV, DTRMM, XERBLA
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX
+* ..
+* .. Executable Statements ..
+*
+* Test the input parameters.
+*
+ INFO = 0
+ C1 = PATH( 1: 1 )
+ C2 = PATH( 2: 3 )
+ TRAN = LSAME( TRANS, 'T' ) .OR. LSAME( TRANS, 'C' )
+ NOTRAN = .NOT.TRAN
+ GEN = LSAME( PATH( 2: 2 ), 'G' )
+ QRS = LSAME( PATH( 2: 2 ), 'Q' ) .OR. LSAME( PATH( 3: 3 ), 'Q' )
+ SYM = LSAME( PATH( 2: 2 ), 'P' ) .OR. LSAME( PATH( 2: 2 ), 'S' )
+ TRI = LSAME( PATH( 2: 2 ), 'T' )
+ BAND = LSAME( PATH( 3: 3 ), 'B' )
+ IF( .NOT.LSAME( C1, 'Double precision' ) ) THEN
+ INFO = -1
+ ELSE IF( .NOT.( LSAME( XTYPE, 'N' ) .OR. LSAME( XTYPE, 'C' ) ) )
+ $ THEN
+ INFO = -2
+ ELSE IF( ( SYM .OR. TRI ) .AND. .NOT.
+ $ ( LSAME( UPLO, 'U' ) .OR. LSAME( UPLO, 'L' ) ) ) THEN
+ INFO = -3
+ ELSE IF( ( GEN .OR. QRS ) .AND. .NOT.
+ $ ( TRAN .OR. LSAME( TRANS, 'N' ) ) ) THEN
+ INFO = -4
+ ELSE IF( M.LT.0 ) THEN
+ INFO = -5
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -6
+ ELSE IF( BAND .AND. KL.LT.0 ) THEN
+ INFO = -7
+ ELSE IF( BAND .AND. KU.LT.0 ) THEN
+ INFO = -8
+ ELSE IF( NRHS.LT.0 ) THEN
+ INFO = -9
+ ELSE IF( ( .NOT.BAND .AND. LDA.LT.MAX( 1, M ) ) .OR.
+ $ ( BAND .AND. ( SYM .OR. TRI ) .AND. LDA.LT.KL+1 ) .OR.
+ $ ( BAND .AND. GEN .AND. LDA.LT.KL+KU+1 ) ) THEN
+ INFO = -11
+ ELSE IF( ( NOTRAN .AND. LDX.LT.MAX( 1, N ) ) .OR.
+ $ ( TRAN .AND. LDX.LT.MAX( 1, M ) ) ) THEN
+ INFO = -13
+ ELSE IF( ( NOTRAN .AND. LDB.LT.MAX( 1, M ) ) .OR.
+ $ ( TRAN .AND. LDB.LT.MAX( 1, N ) ) ) THEN
+ INFO = -15
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DLARHS', -INFO )
+ RETURN
+ END IF
+*
+* Initialize X to NRHS random vectors unless XTYPE = 'C'.
+*
+ IF( TRAN ) THEN
+ NX = M
+ MB = N
+ ELSE
+ NX = N
+ MB = M
+ END IF
+ IF( .NOT.LSAME( XTYPE, 'C' ) ) THEN
+ DO 10 J = 1, NRHS
+ CALL DLARNV( 2, ISEED, N, X( 1, J ) )
+ 10 CONTINUE
+ END IF
+*
+* Multiply X by op( A ) using an appropriate
+* matrix multiply routine.
+*
+ IF( LSAMEN( 2, C2, 'GE' ) .OR. LSAMEN( 2, C2, 'QR' ) .OR.
+ $ LSAMEN( 2, C2, 'LQ' ) .OR. LSAMEN( 2, C2, 'QL' ) .OR.
+ $ LSAMEN( 2, C2, 'RQ' ) ) THEN
+*
+* General matrix
+*
+ CALL DGEMM( TRANS, 'N', MB, NRHS, NX, ONE, A, LDA, X, LDX,
+ $ ZERO, B, LDB )
+*
+ ELSE IF( LSAMEN( 2, C2, 'PO' ) .OR. LSAMEN( 2, C2, 'SY' ) ) THEN
+*
+* Symmetric matrix, 2-D storage
+*
+ CALL DSYMM( 'Left', UPLO, N, NRHS, ONE, A, LDA, X, LDX, ZERO,
+ $ B, LDB )
+*
+ ELSE IF( LSAMEN( 2, C2, 'GB' ) ) THEN
+*
+* General matrix, band storage
+*
+ DO 20 J = 1, NRHS
+ CALL DGBMV( TRANS, MB, NX, KL, KU, ONE, A, LDA, X( 1, J ),
+ $ 1, ZERO, B( 1, J ), 1 )
+ 20 CONTINUE
+*
+ ELSE IF( LSAMEN( 2, C2, 'PB' ) ) THEN
+*
+* Symmetric matrix, band storage
+*
+ DO 30 J = 1, NRHS
+ CALL DSBMV( UPLO, N, KL, ONE, A, LDA, X( 1, J ), 1, ZERO,
+ $ B( 1, J ), 1 )
+ 30 CONTINUE
+*
+ ELSE IF( LSAMEN( 2, C2, 'PP' ) .OR. LSAMEN( 2, C2, 'SP' ) ) THEN
+*
+* Symmetric matrix, packed storage
+*
+ DO 40 J = 1, NRHS
+ CALL DSPMV( UPLO, N, ONE, A, X( 1, J ), 1, ZERO, B( 1, J ),
+ $ 1 )
+ 40 CONTINUE
+*
+ ELSE IF( LSAMEN( 2, C2, 'TR' ) ) THEN
+*
+* Triangular matrix. Note that for triangular matrices,
+* KU = 1 => non-unit triangular
+* KU = 2 => unit triangular
+*
+ CALL DLACPY( 'Full', N, NRHS, X, LDX, B, LDB )
+ IF( KU.EQ.2 ) THEN
+ DIAG = 'U'
+ ELSE
+ DIAG = 'N'
+ END IF
+ CALL DTRMM( 'Left', UPLO, TRANS, DIAG, N, NRHS, ONE, A, LDA, B,
+ $ LDB )
+*
+ ELSE IF( LSAMEN( 2, C2, 'TP' ) ) THEN
+*
+* Triangular matrix, packed storage
+*
+ CALL DLACPY( 'Full', N, NRHS, X, LDX, B, LDB )
+ IF( KU.EQ.2 ) THEN
+ DIAG = 'U'
+ ELSE
+ DIAG = 'N'
+ END IF
+ DO 50 J = 1, NRHS
+ CALL DTPMV( UPLO, TRANS, DIAG, N, A, B( 1, J ), 1 )
+ 50 CONTINUE
+*
+ ELSE IF( LSAMEN( 2, C2, 'TB' ) ) THEN
+*
+* Triangular matrix, banded storage
+*
+ CALL DLACPY( 'Full', N, NRHS, X, LDX, B, LDB )
+ IF( KU.EQ.2 ) THEN
+ DIAG = 'U'
+ ELSE
+ DIAG = 'N'
+ END IF
+ DO 60 J = 1, NRHS
+ CALL DTBMV( UPLO, TRANS, DIAG, N, KL, A, LDA, B( 1, J ), 1 )
+ 60 CONTINUE
+*
+ ELSE
+*
+* If PATH is none of the above, return with an error code.
+*
+ INFO = -1
+ CALL XERBLA( 'DLARHS', -INFO )
+ END IF
+*
+ RETURN
+*
+* End of DLARHS
+*
+ END
+ SUBROUTINE DLASUM( TYPE, IOUNIT, IE, NRUN )
+*
+* -- LAPACK auxiliary test routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER*3 TYPE
+ INTEGER IE, IOUNIT, NRUN
+* ..
+*
+* Purpose
+* =======
+*
+* DLASUM prints a summary of the results from one of the test routines.
+*
+* =====================================================================
+*
+* .. Executable Statements ..
+*
+ IF( IE.GT.0 ) THEN
+ WRITE( IOUNIT, FMT = 9999 )TYPE, ': ', IE, ' out of ', NRUN,
+ $ ' tests failed to pass the threshold'
+ ELSE
+ WRITE( IOUNIT, FMT = 9998 )'All tests for ', TYPE,
+ $ ' passed the threshold (', NRUN, ' tests run)'
+ END IF
+ 9999 FORMAT( 1X, A3, A2, I4, A8, I5, A35 )
+ 9998 FORMAT( / 1X, A14, A3, A23, I5, A11 )
+ RETURN
+*
+* End of DLASUM
+*
+ END
+ SUBROUTINE DLATB9( PATH, IMAT, M, P, N, TYPE, KLA, KUA, KLB, KUB,
+ $ ANORM, BNORM, MODEA, MODEB, CNDNMA, CNDNMB,
+ $ DISTA, DISTB )
+*
+* -- LAPACK test routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER DISTA, DISTB, TYPE
+ CHARACTER*3 PATH
+ INTEGER IMAT, KLA, KLB, KUA, KUB, M, MODEA, MODEB, N, P
+ DOUBLE PRECISION ANORM, BNORM, CNDNMA, CNDNMB
+* ..
+*
+* Purpose
+* =======
+*
+* DLATB9 sets parameters for the matrix generator based on the type of
+* matrix to be generated.
+*
+* Arguments
+* =========
+*
+* PATH (input) CHARACTER*3
+* The LAPACK path name.
+*
+* IMAT (input) INTEGER
+* An integer key describing which matrix to generate for this
+* path.
+*
+* M (input) INTEGER
+* The number of rows in the matrix to be generated.
+*
+* N (input) INTEGER
+* The number of columns in the matrix to be generated.
+*
+* TYPE (output) CHARACTER*1
+* The type of the matrix to be generated:
+* = 'S': symmetric matrix;
+* = 'P': symmetric positive (semi)definite matrix;
+* = 'N': nonsymmetric matrix.
+*
+* KL (output) INTEGER
+* The lower band width of the matrix to be generated.
+*
+* KU (output) INTEGER
+* The upper band width of the matrix to be generated.
+*
+* ANORM (output) DOUBLE PRECISION
+* The desired norm of the matrix to be generated. The diagonal
+* matrix of singular values or eigenvalues is scaled by this
+* value.
+*
+* MODE (output) INTEGER
+* A key indicating how to choose the vector of eigenvalues.
+*
+* CNDNUM (output) DOUBLE PRECISION
+* The desired condition number.
+*
+* DIST (output) CHARACTER*1
+* The type of distribution to be used by the random number
+* generator.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION SHRINK, TENTH
+ PARAMETER ( SHRINK = 0.25D0, TENTH = 0.1D+0 )
+ DOUBLE PRECISION ONE, TEN
+ PARAMETER ( ONE = 1.0D+0, TEN = 1.0D+1 )
+* ..
+* .. Local Scalars ..
+ LOGICAL FIRST
+ DOUBLE PRECISION BADC1, BADC2, EPS, LARGE, SMALL
+* ..
+* .. External Functions ..
+ LOGICAL LSAMEN
+ DOUBLE PRECISION DLAMCH
+ EXTERNAL LSAMEN, DLAMCH
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, SQRT
+* ..
+* .. External Subroutines ..
+ EXTERNAL DLABAD
+* ..
+* .. Save statement ..
+ SAVE EPS, SMALL, LARGE, BADC1, BADC2, FIRST
+* ..
+* .. Data statements ..
+ DATA FIRST / .TRUE. /
+* ..
+* .. Executable Statements ..
+*
+* Set some constants for use in the subroutine.
+*
+ IF( FIRST ) THEN
+ FIRST = .FALSE.
+ EPS = DLAMCH( 'Precision' )
+ BADC2 = TENTH / EPS
+ BADC1 = SQRT( BADC2 )
+ SMALL = DLAMCH( 'Safe minimum' )
+ LARGE = ONE / SMALL
+*
+* If it looks like we're on a Cray, take the square root of
+* SMALL and LARGE to avoid overflow and underflow problems.
+*
+ CALL DLABAD( SMALL, LARGE )
+ SMALL = SHRINK*( SMALL / EPS )
+ LARGE = ONE / SMALL
+ END IF
+*
+* Set some parameters we don't plan to change.
+*
+ TYPE = 'N'
+ DISTA = 'S'
+ DISTB = 'S'
+ MODEA = 3
+ MODEB = 4
+*
+* Set the lower and upper bandwidths.
+*
+ IF( LSAMEN( 3, PATH, 'GRQ' ) .OR. LSAMEN( 3, PATH, 'LSE' ) .OR.
+ $ LSAMEN( 3, PATH, 'GSV' ) ) THEN
+*
+* A: M by N, B: P by N
+*
+ IF( IMAT.EQ.1 ) THEN
+*
+* A: diagonal, B: upper triangular
+*
+ KLA = 0
+ KUA = 0
+ KLB = 0
+ KUB = MAX( N-1, 0 )
+*
+ ELSE IF( IMAT.EQ.2 ) THEN
+*
+* A: upper triangular, B: upper triangular
+*
+ KLA = 0
+ KUA = MAX( N-1, 0 )
+ KLB = 0
+ KUB = MAX( N-1, 0 )
+*
+ ELSE IF( IMAT.EQ.3 ) THEN
+*
+* A: lower triangular, B: upper triangular
+*
+ KLA = MAX( M-1, 0 )
+ KUA = 0
+ KLB = 0
+ KUB = MAX( N-1, 0 )
+*
+ ELSE
+*
+* A: general dense, B: general dense
+*
+ KLA = MAX( M-1, 0 )
+ KUA = MAX( N-1, 0 )
+ KLB = MAX( P-1, 0 )
+ KUB = MAX( N-1, 0 )
+*
+ END IF
+*
+ ELSE IF( LSAMEN( 3, PATH, 'GQR' ) .OR. LSAMEN( 3, PATH, 'GLM' ) )
+ $ THEN
+*
+* A: N by M, B: N by P
+*
+ IF( IMAT.EQ.1 ) THEN
+*
+* A: diagonal, B: lower triangular
+*
+ KLA = 0
+ KUA = 0
+ KLB = MAX( N-1, 0 )
+ KUB = 0
+ ELSE IF( IMAT.EQ.2 ) THEN
+*
+* A: lower triangular, B: diagonal
+*
+ KLA = MAX( N-1, 0 )
+ KUA = 0
+ KLB = 0
+ KUB = 0
+*
+ ELSE IF( IMAT.EQ.3 ) THEN
+*
+* A: lower triangular, B: upper triangular
+*
+ KLA = MAX( N-1, 0 )
+ KUA = 0
+ KLB = 0
+ KUB = MAX( P-1, 0 )
+*
+ ELSE
+*
+* A: general dense, B: general dense
+*
+ KLA = MAX( N-1, 0 )
+ KUA = MAX( M-1, 0 )
+ KLB = MAX( N-1, 0 )
+ KUB = MAX( P-1, 0 )
+ END IF
+*
+ END IF
+*
+* Set the condition number and norm.
+*
+ CNDNMA = TEN*TEN
+ CNDNMB = TEN
+ IF( LSAMEN( 3, PATH, 'GQR' ) .OR. LSAMEN( 3, PATH, 'GRQ' ) .OR.
+ $ LSAMEN( 3, PATH, 'GSV' ) ) THEN
+ IF( IMAT.EQ.5 ) THEN
+ CNDNMA = BADC1
+ CNDNMB = BADC1
+ ELSE IF( IMAT.EQ.6 ) THEN
+ CNDNMA = BADC2
+ CNDNMB = BADC2
+ ELSE IF( IMAT.EQ.7 ) THEN
+ CNDNMA = BADC1
+ CNDNMB = BADC2
+ ELSE IF( IMAT.EQ.8 ) THEN
+ CNDNMA = BADC2
+ CNDNMB = BADC1
+ END IF
+ END IF
+*
+ ANORM = TEN
+ BNORM = TEN*TEN*TEN
+ IF( LSAMEN( 3, PATH, 'GQR' ) .OR. LSAMEN( 3, PATH, 'GRQ' ) ) THEN
+ IF( IMAT.EQ.7 ) THEN
+ ANORM = SMALL
+ BNORM = LARGE
+ ELSE IF( IMAT.EQ.8 ) THEN
+ ANORM = LARGE
+ BNORM = SMALL
+ END IF
+ END IF
+*
+ IF( N.LE.1 ) THEN
+ CNDNMA = ONE
+ CNDNMB = ONE
+ END IF
+*
+ RETURN
+*
+* End of DLATB9
+*
+ END
+ SUBROUTINE DLATM4( ITYPE, N, NZ1, NZ2, ISIGN, AMAGN, RCOND,
+ $ TRIANG, IDIST, ISEED, A, LDA )
+*
+* -- LAPACK auxiliary test routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER IDIST, ISIGN, ITYPE, LDA, N, NZ1, NZ2
+ DOUBLE PRECISION AMAGN, RCOND, TRIANG
+* ..
+* .. Array Arguments ..
+ INTEGER ISEED( 4 )
+ DOUBLE PRECISION A( LDA, * )
+* ..
+*
+* Purpose
+* =======
+*
+* DLATM4 generates basic square matrices, which may later be
+* multiplied by others in order to produce test matrices. It is
+* intended mainly to be used to test the generalized eigenvalue
+* routines.
+*
+* It first generates the diagonal and (possibly) subdiagonal,
+* according to the value of ITYPE, NZ1, NZ2, ISIGN, AMAGN, and RCOND.
+* It then fills in the upper triangle with random numbers, if TRIANG is
+* non-zero.
+*
+* Arguments
+* =========
+*
+* ITYPE (input) INTEGER
+* The "type" of matrix on the diagonal and sub-diagonal.
+* If ITYPE < 0, then type abs(ITYPE) is generated and then
+* swapped end for end (A(I,J) := A'(N-J,N-I).) See also
+* the description of AMAGN and ISIGN.
+*
+* Special types:
+* = 0: the zero matrix.
+* = 1: the identity.
+* = 2: a transposed Jordan block.
+* = 3: If N is odd, then a k+1 x k+1 transposed Jordan block
+* followed by a k x k identity block, where k=(N-1)/2.
+* If N is even, then k=(N-2)/2, and a zero diagonal entry
+* is tacked onto the end.
+*
+* Diagonal types. The diagonal consists of NZ1 zeros, then
+* k=N-NZ1-NZ2 nonzeros. The subdiagonal is zero. ITYPE
+* specifies the nonzero diagonal entries as follows:
+* = 4: 1, ..., k
+* = 5: 1, RCOND, ..., RCOND
+* = 6: 1, ..., 1, RCOND
+* = 7: 1, a, a^2, ..., a^(k-1)=RCOND
+* = 8: 1, 1-d, 1-2*d, ..., 1-(k-1)*d=RCOND
+* = 9: random numbers chosen from (RCOND,1)
+* = 10: random numbers with distribution IDIST (see DLARND.)
+*
+* N (input) INTEGER
+* The order of the matrix.
+*
+* NZ1 (input) INTEGER
+* If abs(ITYPE) > 3, then the first NZ1 diagonal entries will
+* be zero.
+*
+* NZ2 (input) INTEGER
+* If abs(ITYPE) > 3, then the last NZ2 diagonal entries will
+* be zero.
+*
+* ISIGN (input) INTEGER
+* = 0: The sign of the diagonal and subdiagonal entries will
+* be left unchanged.
+* = 1: The diagonal and subdiagonal entries will have their
+* sign changed at random.
+* = 2: If ITYPE is 2 or 3, then the same as ISIGN=1.
+* Otherwise, with probability 0.5, odd-even pairs of
+* diagonal entries A(2*j-1,2*j-1), A(2*j,2*j) will be
+* converted to a 2x2 block by pre- and post-multiplying
+* by distinct random orthogonal rotations. The remaining
+* diagonal entries will have their sign changed at random.
+*
+* AMAGN (input) DOUBLE PRECISION
+* The diagonal and subdiagonal entries will be multiplied by
+* AMAGN.
+*
+* RCOND (input) DOUBLE PRECISION
+* If abs(ITYPE) > 4, then the smallest diagonal entry will be
+* entry will be RCOND. RCOND must be between 0 and 1.
+*
+* TRIANG (input) DOUBLE PRECISION
+* The entries above the diagonal will be random numbers with
+* magnitude bounded by TRIANG (i.e., random numbers multiplied
+* by TRIANG.)
+*
+* IDIST (input) INTEGER
+* Specifies the type of distribution to be used to generate a
+* random matrix.
+* = 1: UNIFORM( 0, 1 )
+* = 2: UNIFORM( -1, 1 )
+* = 3: NORMAL ( 0, 1 )
+*
+* ISEED (input/output) INTEGER array, dimension (4)
+* On entry ISEED specifies the seed of the random number
+* generator. The values of ISEED are changed on exit, and can
+* be used in the next call to DLATM4 to continue the same
+* random number sequence.
+* Note: ISEED(4) should be odd, for the random number generator
+* used at present.
+*
+* A (output) DOUBLE PRECISION array, dimension (LDA, N)
+* Array to be computed.
+*
+* LDA (input) INTEGER
+* Leading dimension of A. Must be at least 1 and at least N.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE, TWO
+ PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 )
+ DOUBLE PRECISION HALF
+ PARAMETER ( HALF = ONE / TWO )
+* ..
+* .. Local Scalars ..
+ INTEGER I, IOFF, ISDB, ISDE, JC, JD, JR, K, KBEG, KEND,
+ $ KLEN
+ DOUBLE PRECISION ALPHA, CL, CR, SAFMIN, SL, SR, SV1, SV2, TEMP
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DLAMCH, DLARAN, DLARND
+ EXTERNAL DLAMCH, DLARAN, DLARND
+* ..
+* .. External Subroutines ..
+ EXTERNAL DLASET
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, DBLE, EXP, LOG, MAX, MIN, MOD, SQRT
+* ..
+* .. Executable Statements ..
+*
+ IF( N.LE.0 )
+ $ RETURN
+ CALL DLASET( 'Full', N, N, ZERO, ZERO, A, LDA )
+*
+* Insure a correct ISEED
+*
+ IF( MOD( ISEED( 4 ), 2 ).NE.1 )
+ $ ISEED( 4 ) = ISEED( 4 ) + 1
+*
+* Compute diagonal and subdiagonal according to ITYPE, NZ1, NZ2,
+* and RCOND
+*
+ IF( ITYPE.NE.0 ) THEN
+ IF( ABS( ITYPE ).GE.4 ) THEN
+ KBEG = MAX( 1, MIN( N, NZ1+1 ) )
+ KEND = MAX( KBEG, MIN( N, N-NZ2 ) )
+ KLEN = KEND + 1 - KBEG
+ ELSE
+ KBEG = 1
+ KEND = N
+ KLEN = N
+ END IF
+ ISDB = 1
+ ISDE = 0
+ GO TO ( 10, 30, 50, 80, 100, 120, 140, 160,
+ $ 180, 200 )ABS( ITYPE )
+*
+* abs(ITYPE) = 1: Identity
+*
+ 10 CONTINUE
+ DO 20 JD = 1, N
+ A( JD, JD ) = ONE
+ 20 CONTINUE
+ GO TO 220
+*
+* abs(ITYPE) = 2: Transposed Jordan block
+*
+ 30 CONTINUE
+ DO 40 JD = 1, N - 1
+ A( JD+1, JD ) = ONE
+ 40 CONTINUE
+ ISDB = 1
+ ISDE = N - 1
+ GO TO 220
+*
+* abs(ITYPE) = 3: Transposed Jordan block, followed by the
+* identity.
+*
+ 50 CONTINUE
+ K = ( N-1 ) / 2
+ DO 60 JD = 1, K
+ A( JD+1, JD ) = ONE
+ 60 CONTINUE
+ ISDB = 1
+ ISDE = K
+ DO 70 JD = K + 2, 2*K + 1
+ A( JD, JD ) = ONE
+ 70 CONTINUE
+ GO TO 220
+*
+* abs(ITYPE) = 4: 1,...,k
+*
+ 80 CONTINUE
+ DO 90 JD = KBEG, KEND
+ A( JD, JD ) = DBLE( JD-NZ1 )
+ 90 CONTINUE
+ GO TO 220
+*
+* abs(ITYPE) = 5: One large D value:
+*
+ 100 CONTINUE
+ DO 110 JD = KBEG + 1, KEND
+ A( JD, JD ) = RCOND
+ 110 CONTINUE
+ A( KBEG, KBEG ) = ONE
+ GO TO 220
+*
+* abs(ITYPE) = 6: One small D value:
+*
+ 120 CONTINUE
+ DO 130 JD = KBEG, KEND - 1
+ A( JD, JD ) = ONE
+ 130 CONTINUE
+ A( KEND, KEND ) = RCOND
+ GO TO 220
+*
+* abs(ITYPE) = 7: Exponentially distributed D values:
+*
+ 140 CONTINUE
+ A( KBEG, KBEG ) = ONE
+ IF( KLEN.GT.1 ) THEN
+ ALPHA = RCOND**( ONE / DBLE( KLEN-1 ) )
+ DO 150 I = 2, KLEN
+ A( NZ1+I, NZ1+I ) = ALPHA**DBLE( I-1 )
+ 150 CONTINUE
+ END IF
+ GO TO 220
+*
+* abs(ITYPE) = 8: Arithmetically distributed D values:
+*
+ 160 CONTINUE
+ A( KBEG, KBEG ) = ONE
+ IF( KLEN.GT.1 ) THEN
+ ALPHA = ( ONE-RCOND ) / DBLE( KLEN-1 )
+ DO 170 I = 2, KLEN
+ A( NZ1+I, NZ1+I ) = DBLE( KLEN-I )*ALPHA + RCOND
+ 170 CONTINUE
+ END IF
+ GO TO 220
+*
+* abs(ITYPE) = 9: Randomly distributed D values on ( RCOND, 1):
+*
+ 180 CONTINUE
+ ALPHA = LOG( RCOND )
+ DO 190 JD = KBEG, KEND
+ A( JD, JD ) = EXP( ALPHA*DLARAN( ISEED ) )
+ 190 CONTINUE
+ GO TO 220
+*
+* abs(ITYPE) = 10: Randomly distributed D values from DIST
+*
+ 200 CONTINUE
+ DO 210 JD = KBEG, KEND
+ A( JD, JD ) = DLARND( IDIST, ISEED )
+ 210 CONTINUE
+*
+ 220 CONTINUE
+*
+* Scale by AMAGN
+*
+ DO 230 JD = KBEG, KEND
+ A( JD, JD ) = AMAGN*DBLE( A( JD, JD ) )
+ 230 CONTINUE
+ DO 240 JD = ISDB, ISDE
+ A( JD+1, JD ) = AMAGN*DBLE( A( JD+1, JD ) )
+ 240 CONTINUE
+*
+* If ISIGN = 1 or 2, assign random signs to diagonal and
+* subdiagonal
+*
+ IF( ISIGN.GT.0 ) THEN
+ DO 250 JD = KBEG, KEND
+ IF( DBLE( A( JD, JD ) ).NE.ZERO ) THEN
+ IF( DLARAN( ISEED ).GT.HALF )
+ $ A( JD, JD ) = -A( JD, JD )
+ END IF
+ 250 CONTINUE
+ DO 260 JD = ISDB, ISDE
+ IF( DBLE( A( JD+1, JD ) ).NE.ZERO ) THEN
+ IF( DLARAN( ISEED ).GT.HALF )
+ $ A( JD+1, JD ) = -A( JD+1, JD )
+ END IF
+ 260 CONTINUE
+ END IF
+*
+* Reverse if ITYPE < 0
+*
+ IF( ITYPE.LT.0 ) THEN
+ DO 270 JD = KBEG, ( KBEG+KEND-1 ) / 2
+ TEMP = A( JD, JD )
+ A( JD, JD ) = A( KBEG+KEND-JD, KBEG+KEND-JD )
+ A( KBEG+KEND-JD, KBEG+KEND-JD ) = TEMP
+ 270 CONTINUE
+ DO 280 JD = 1, ( N-1 ) / 2
+ TEMP = A( JD+1, JD )
+ A( JD+1, JD ) = A( N+1-JD, N-JD )
+ A( N+1-JD, N-JD ) = TEMP
+ 280 CONTINUE
+ END IF
+*
+* If ISIGN = 2, and no subdiagonals already, then apply
+* random rotations to make 2x2 blocks.
+*
+ IF( ISIGN.EQ.2 .AND. ITYPE.NE.2 .AND. ITYPE.NE.3 ) THEN
+ SAFMIN = DLAMCH( 'S' )
+ DO 290 JD = KBEG, KEND - 1, 2
+ IF( DLARAN( ISEED ).GT.HALF ) THEN
+*
+* Rotation on left.
+*
+ CL = TWO*DLARAN( ISEED ) - ONE
+ SL = TWO*DLARAN( ISEED ) - ONE
+ TEMP = ONE / MAX( SAFMIN, SQRT( CL**2+SL**2 ) )
+ CL = CL*TEMP
+ SL = SL*TEMP
+*
+* Rotation on right.
+*
+ CR = TWO*DLARAN( ISEED ) - ONE
+ SR = TWO*DLARAN( ISEED ) - ONE
+ TEMP = ONE / MAX( SAFMIN, SQRT( CR**2+SR**2 ) )
+ CR = CR*TEMP
+ SR = SR*TEMP
+*
+* Apply
+*
+ SV1 = A( JD, JD )
+ SV2 = A( JD+1, JD+1 )
+ A( JD, JD ) = CL*CR*SV1 + SL*SR*SV2
+ A( JD+1, JD ) = -SL*CR*SV1 + CL*SR*SV2
+ A( JD, JD+1 ) = -CL*SR*SV1 + SL*CR*SV2
+ A( JD+1, JD+1 ) = SL*SR*SV1 + CL*CR*SV2
+ END IF
+ 290 CONTINUE
+ END IF
+*
+ END IF
+*
+* Fill in upper triangle (except for 2x2 blocks)
+*
+ IF( TRIANG.NE.ZERO ) THEN
+ IF( ISIGN.NE.2 .OR. ITYPE.EQ.2 .OR. ITYPE.EQ.3 ) THEN
+ IOFF = 1
+ ELSE
+ IOFF = 2
+ DO 300 JR = 1, N - 1
+ IF( A( JR+1, JR ).EQ.ZERO )
+ $ A( JR, JR+1 ) = TRIANG*DLARND( IDIST, ISEED )
+ 300 CONTINUE
+ END IF
+*
+ DO 320 JC = 2, N
+ DO 310 JR = 1, JC - IOFF
+ A( JR, JC ) = TRIANG*DLARND( IDIST, ISEED )
+ 310 CONTINUE
+ 320 CONTINUE
+ END IF
+*
+ RETURN
+*
+* End of DLATM4
+*
+ END
+ LOGICAL FUNCTION DLCTES( ZR, ZI, D )
+*
+* -- LAPACK test routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ DOUBLE PRECISION D, ZI, ZR
+* ..
+*
+* Purpose
+* =======
+*
+* DLCTES returns .TRUE. if the eigenvalue (ZR/D) + sqrt(-1)*(ZI/D)
+* is to be selected (specifically, in this subroutine, if the real
+* part of the eigenvalue is negative), and otherwise it returns
+* .FALSE..
+*
+* It is used by the test routine DDRGES to test whether the driver
+* routine DGGES succesfully sorts eigenvalues.
+*
+* Arguments
+* =========
+*
+* ZR (input) DOUBLE PRECISION
+* The numerator of the real part of a complex eigenvalue
+* (ZR/D) + i*(ZI/D).
+*
+* ZI (input) DOUBLE PRECISION
+* The numerator of the imaginary part of a complex eigenvalue
+* (ZR/D) + i*(ZI).
+*
+* D (input) DOUBLE PRECISION
+* The denominator part of a complex eigenvalue
+* (ZR/D) + i*(ZI/D).
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC SIGN
+* ..
+* .. Executable Statements ..
+*
+ IF( D.EQ.ZERO ) THEN
+ DLCTES = ( ZR.LT.ZERO )
+ ELSE
+ DLCTES = ( SIGN( ONE, ZR ).NE.SIGN( ONE, D ) )
+ END IF
+*
+ RETURN
+*
+* End of DLCTES
+*
+ END
+ LOGICAL FUNCTION DLCTSX( AR, AI, BETA )
+*
+* -- LAPACK test routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ DOUBLE PRECISION AI, AR, BETA
+* ..
+*
+* Purpose
+* =======
+*
+* This function is used to determine what eigenvalues will be
+* selected. If this is part of the test driver DDRGSX, do not
+* change the code UNLESS you are testing input examples and not
+* using the built-in examples.
+*
+* Arguments
+* =========
+*
+* AR (input) DOUBLE PRECISION
+* The numerator of the real part of a complex eigenvalue
+* (AR/BETA) + i*(AI/BETA).
+*
+* AI (input) DOUBLE PRECISION
+* The numerator of the imaginary part of a complex eigenvalue
+* (AR/BETA) + i*(AI).
+*
+* BETA (input) DOUBLE PRECISION
+* The denominator part of a complex eigenvalue
+* (AR/BETA) + i*(AI/BETA).
+*
+* =====================================================================
+*
+* .. Scalars in Common ..
+ LOGICAL FS
+ INTEGER I, M, MPLUSN, N
+* ..
+* .. Common blocks ..
+ COMMON / MN / M, N, MPLUSN, I, FS
+* ..
+* .. Save statement ..
+ SAVE
+* ..
+* .. Executable Statements ..
+*
+ IF( FS ) THEN
+ I = I + 1
+ IF( I.LE.M ) THEN
+ DLCTSX = .FALSE.
+ ELSE
+ DLCTSX = .TRUE.
+ END IF
+ IF( I.EQ.MPLUSN ) THEN
+ FS = .FALSE.
+ I = 0
+ END IF
+ ELSE
+ I = I + 1
+ IF( I.LE.N ) THEN
+ DLCTSX = .TRUE.
+ ELSE
+ DLCTSX = .FALSE.
+ END IF
+ IF( I.EQ.MPLUSN ) THEN
+ FS = .TRUE.
+ I = 0
+ END IF
+ END IF
+*
+* IF( AR/BETA.GT.0.0 )THEN
+* DLCTSX = .TRUE.
+* ELSE
+* DLCTSX = .FALSE.
+* END IF
+*
+ RETURN
+*
+* End of DLCTSX
+*
+ END
+ SUBROUTINE DLSETS( M, P, N, A, AF, LDA, B, BF, LDB, C, CF, D, DF,
+ $ X, WORK, LWORK, RWORK, RESULT )
+*
+* -- LAPACK test routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER LDA, LDB, LWORK, M, N, P
+* ..
+* .. Array Arguments ..
+*
+* Purpose
+* =======
+*
+* DLSETS tests DGGLSE - a subroutine for solving linear equality
+* constrained least square problem (LSE).
+*
+* Arguments
+* =========
+*
+* M (input) INTEGER
+* The number of rows of the matrix A. M >= 0.
+*
+* P (input) INTEGER
+* The number of rows of the matrix B. P >= 0.
+*
+* N (input) INTEGER
+* The number of columns of the matrices A and B. N >= 0.
+*
+* A (input) DOUBLE PRECISION array, dimension (LDA,N)
+* The M-by-N matrix A.
+*
+* AF (workspace) DOUBLE PRECISION array, dimension (LDA,N)
+*
+* LDA (input) INTEGER
+* The leading dimension of the arrays A, AF, Q and R.
+* LDA >= max(M,N).
+*
+* B (input) DOUBLE PRECISION array, dimension (LDB,N)
+* The P-by-N matrix A.
+*
+* BF (workspace) DOUBLE PRECISION array, dimension (LDB,N)
+*
+* LDB (input) INTEGER
+* The leading dimension of the arrays B, BF, V and S.
+* LDB >= max(P,N).
+*
+* C (input) DOUBLE PRECISION array, dimension( M )
+* the vector C in the LSE problem.
+*
+* CF (workspace) DOUBLE PRECISION array, dimension( M )
+*
+* D (input) DOUBLE PRECISION array, dimension( P )
+* the vector D in the LSE problem.
+*
+* DF (workspace) DOUBLE PRECISION array, dimension( P )
+*
+* X (output) DOUBLE PRECISION array, dimension( N )
+* solution vector X in the LSE problem.
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK)
+*
+* LWORK (input) INTEGER
+* The dimension of the array WORK.
+*
+* RWORK (workspace) DOUBLE PRECISION array, dimension (M)
+*
+* RESULT (output) DOUBLE PRECISION array, dimension (2)
+* The test ratios:
+* RESULT(1) = norm( A*x - c )/ norm(A)*norm(X)*EPS
+* RESULT(2) = norm( B*x - d )/ norm(B)*norm(X)*EPS
+*
+* ====================================================================
+*
+ DOUBLE PRECISION A( LDA, * ), AF( LDA, * ), B( LDB, * ),
+ $ BF( LDB, * ), C( * ), CF( * ), D( * ), DF( * ),
+ $ RESULT( 2 ), RWORK( * ), WORK( LWORK ), X( * )
+* ..
+* .. Local Scalars ..
+ INTEGER INFO
+* ..
+* .. External Subroutines ..
+ EXTERNAL DCOPY, DGET02, DGGLSE, DLACPY
+* ..
+* .. Executable Statements ..
+*
+* Copy the matrices A and B to the arrays AF and BF,
+* and the vectors C and D to the arrays CF and DF,
+*
+ CALL DLACPY( 'Full', M, N, A, LDA, AF, LDA )
+ CALL DLACPY( 'Full', P, N, B, LDB, BF, LDB )
+ CALL DCOPY( M, C, 1, CF, 1 )
+ CALL DCOPY( P, D, 1, DF, 1 )
+*
+* Solve LSE problem
+*
+ CALL DGGLSE( M, N, P, AF, LDA, BF, LDB, CF, DF, X, WORK, LWORK,
+ $ INFO )
+*
+* Test the residual for the solution of LSE
+*
+* Compute RESULT(1) = norm( A*x - c ) / norm(A)*norm(X)*EPS
+*
+ CALL DCOPY( M, C, 1, CF, 1 )
+ CALL DCOPY( P, D, 1, DF, 1 )
+ CALL DGET02( 'No transpose', M, N, 1, A, LDA, X, N, CF, M, RWORK,
+ $ RESULT( 1 ) )
+*
+* Compute result(2) = norm( B*x - d ) / norm(B)*norm(X)*EPS
+*
+ CALL DGET02( 'No transpose', P, N, 1, B, LDB, X, N, DF, P, RWORK,
+ $ RESULT( 2 ) )
+*
+ RETURN
+*
+* End of DLSETS
+*
+ END
+ SUBROUTINE DORT01( ROWCOL, M, N, U, LDU, WORK, LWORK, RESID )
+*
+* -- LAPACK test routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER ROWCOL
+ INTEGER LDU, LWORK, M, N
+ DOUBLE PRECISION RESID
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION U( LDU, * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DORT01 checks that the matrix U is orthogonal by computing the ratio
+*
+* RESID = norm( I - U*U' ) / ( n * EPS ), if ROWCOL = 'R',
+* or
+* RESID = norm( I - U'*U ) / ( m * EPS ), if ROWCOL = 'C'.
+*
+* Alternatively, if there isn't sufficient workspace to form
+* I - U*U' or I - U'*U, the ratio is computed as
+*
+* RESID = abs( I - U*U' ) / ( n * EPS ), if ROWCOL = 'R',
+* or
+* RESID = abs( I - U'*U ) / ( m * EPS ), if ROWCOL = 'C'.
+*
+* where EPS is the machine precision. ROWCOL is used only if m = n;
+* if m > n, ROWCOL is assumed to be 'C', and if m < n, ROWCOL is
+* assumed to be 'R'.
+*
+* Arguments
+* =========
+*
+* ROWCOL (input) CHARACTER
+* Specifies whether the rows or columns of U should be checked
+* for orthogonality. Used only if M = N.
+* = 'R': Check for orthogonal rows of U
+* = 'C': Check for orthogonal columns of U
+*
+* M (input) INTEGER
+* The number of rows of the matrix U.
+*
+* N (input) INTEGER
+* The number of columns of the matrix U.
+*
+* U (input) DOUBLE PRECISION array, dimension (LDU,N)
+* The orthogonal matrix U. U is checked for orthogonal columns
+* if m > n or if m = n and ROWCOL = 'C'. U is checked for
+* orthogonal rows if m < n or if m = n and ROWCOL = 'R'.
+*
+* LDU (input) INTEGER
+* The leading dimension of the array U. LDU >= max(1,M).
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK)
+*
+* LWORK (input) INTEGER
+* The length of the array WORK. For best performance, LWORK
+* should be at least N*(N+1) if ROWCOL = 'C' or M*(M+1) if
+* ROWCOL = 'R', but the test will be done even if LWORK is 0.
+*
+* RESID (output) DOUBLE PRECISION
+* RESID = norm( I - U * U' ) / ( n * EPS ), if ROWCOL = 'R', or
+* RESID = norm( I - U' * U ) / ( m * EPS ), if ROWCOL = 'C'.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
+* ..
+* .. Local Scalars ..
+ CHARACTER TRANSU
+ INTEGER I, J, K, LDWORK, MNMIN
+ DOUBLE PRECISION EPS, TMP
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ DOUBLE PRECISION DDOT, DLAMCH, DLANSY
+ EXTERNAL LSAME, DDOT, DLAMCH, DLANSY
+* ..
+* .. External Subroutines ..
+ EXTERNAL DLASET, DSYRK
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, DBLE, MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+ RESID = ZERO
+*
+* Quick return if possible
+*
+ IF( M.LE.0 .OR. N.LE.0 )
+ $ RETURN
+*
+ EPS = DLAMCH( 'Precision' )
+ IF( M.LT.N .OR. ( M.EQ.N .AND. LSAME( ROWCOL, 'R' ) ) ) THEN
+ TRANSU = 'N'
+ K = N
+ ELSE
+ TRANSU = 'T'
+ K = M
+ END IF
+ MNMIN = MIN( M, N )
+*
+ IF( ( MNMIN+1 )*MNMIN.LE.LWORK ) THEN
+ LDWORK = MNMIN
+ ELSE
+ LDWORK = 0
+ END IF
+ IF( LDWORK.GT.0 ) THEN
+*
+* Compute I - U*U' or I - U'*U.
+*
+ CALL DLASET( 'Upper', MNMIN, MNMIN, ZERO, ONE, WORK, LDWORK )
+ CALL DSYRK( 'Upper', TRANSU, MNMIN, K, -ONE, U, LDU, ONE, WORK,
+ $ LDWORK )
+*
+* Compute norm( I - U*U' ) / ( K * EPS ) .
+*
+ RESID = DLANSY( '1', 'Upper', MNMIN, WORK, LDWORK,
+ $ WORK( LDWORK*MNMIN+1 ) )
+ RESID = ( RESID / DBLE( K ) ) / EPS
+ ELSE IF( TRANSU.EQ.'T' ) THEN
+*
+* Find the maximum element in abs( I - U'*U ) / ( m * EPS )
+*
+ DO 20 J = 1, N
+ DO 10 I = 1, J
+ IF( I.NE.J ) THEN
+ TMP = ZERO
+ ELSE
+ TMP = ONE
+ END IF
+ TMP = TMP - DDOT( M, U( 1, I ), 1, U( 1, J ), 1 )
+ RESID = MAX( RESID, ABS( TMP ) )
+ 10 CONTINUE
+ 20 CONTINUE
+ RESID = ( RESID / DBLE( M ) ) / EPS
+ ELSE
+*
+* Find the maximum element in abs( I - U*U' ) / ( n * EPS )
+*
+ DO 40 J = 1, M
+ DO 30 I = 1, J
+ IF( I.NE.J ) THEN
+ TMP = ZERO
+ ELSE
+ TMP = ONE
+ END IF
+ TMP = TMP - DDOT( N, U( J, 1 ), LDU, U( I, 1 ), LDU )
+ RESID = MAX( RESID, ABS( TMP ) )
+ 30 CONTINUE
+ 40 CONTINUE
+ RESID = ( RESID / DBLE( N ) ) / EPS
+ END IF
+ RETURN
+*
+* End of DORT01
+*
+ END
+ SUBROUTINE DORT03( RC, MU, MV, N, K, U, LDU, V, LDV, WORK, LWORK,
+ $ RESULT, INFO )
+*
+* -- LAPACK test routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER*( * ) RC
+ INTEGER INFO, K, LDU, LDV, LWORK, MU, MV, N
+ DOUBLE PRECISION RESULT
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION U( LDU, * ), V( LDV, * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DORT03 compares two orthogonal matrices U and V to see if their
+* corresponding rows or columns span the same spaces. The rows are
+* checked if RC = 'R', and the columns are checked if RC = 'C'.
+*
+* RESULT is the maximum of
+*
+* | V*V' - I | / ( MV ulp ), if RC = 'R', or
+*
+* | V'*V - I | / ( MV ulp ), if RC = 'C',
+*
+* and the maximum over rows (or columns) 1 to K of
+*
+* | U(i) - S*V(i) |/ ( N ulp )
+*
+* where S is +-1 (chosen to minimize the expression), U(i) is the i-th
+* row (column) of U, and V(i) is the i-th row (column) of V.
+*
+* Arguments
+* ==========
+*
+* RC (input) CHARACTER*1
+* If RC = 'R' the rows of U and V are to be compared.
+* If RC = 'C' the columns of U and V are to be compared.
+*
+* MU (input) INTEGER
+* The number of rows of U if RC = 'R', and the number of
+* columns if RC = 'C'. If MU = 0 DORT03 does nothing.
+* MU must be at least zero.
+*
+* MV (input) INTEGER
+* The number of rows of V if RC = 'R', and the number of
+* columns if RC = 'C'. If MV = 0 DORT03 does nothing.
+* MV must be at least zero.
+*
+* N (input) INTEGER
+* If RC = 'R', the number of columns in the matrices U and V,
+* and if RC = 'C', the number of rows in U and V. If N = 0
+* DORT03 does nothing. N must be at least zero.
+*
+* K (input) INTEGER
+* The number of rows or columns of U and V to compare.
+* 0 <= K <= max(MU,MV).
+*
+* U (input) DOUBLE PRECISION array, dimension (LDU,N)
+* The first matrix to compare. If RC = 'R', U is MU by N, and
+* if RC = 'C', U is N by MU.
+*
+* LDU (input) INTEGER
+* The leading dimension of U. If RC = 'R', LDU >= max(1,MU),
+* and if RC = 'C', LDU >= max(1,N).
+*
+* V (input) DOUBLE PRECISION array, dimension (LDV,N)
+* The second matrix to compare. If RC = 'R', V is MV by N, and
+* if RC = 'C', V is N by MV.
+*
+* LDV (input) INTEGER
+* The leading dimension of V. If RC = 'R', LDV >= max(1,MV),
+* and if RC = 'C', LDV >= max(1,N).
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK)
+*
+* LWORK (input) INTEGER
+* The length of the array WORK. For best performance, LWORK
+* should be at least N*N if RC = 'C' or M*M if RC = 'R', but
+* the tests will be done even if LWORK is 0.
+*
+* RESULT (output) DOUBLE PRECISION
+* The value computed by the test described above. RESULT is
+* limited to 1/ulp to avoid overflow.
+*
+* INFO (output) INTEGER
+* 0 indicates a successful exit
+* -k indicates the k-th parameter had an illegal value
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, IRC, J, LMX
+ DOUBLE PRECISION RES1, RES2, S, ULP
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ INTEGER IDAMAX
+ DOUBLE PRECISION DLAMCH
+ EXTERNAL LSAME, IDAMAX, DLAMCH
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, DBLE, MAX, MIN, SIGN
+* ..
+* .. External Subroutines ..
+ EXTERNAL DORT01, XERBLA
+* ..
+* .. Executable Statements ..
+*
+* Check inputs
+*
+ INFO = 0
+ IF( LSAME( RC, 'R' ) ) THEN
+ IRC = 0
+ ELSE IF( LSAME( RC, 'C' ) ) THEN
+ IRC = 1
+ ELSE
+ IRC = -1
+ END IF
+ IF( IRC.EQ.-1 ) THEN
+ INFO = -1
+ ELSE IF( MU.LT.0 ) THEN
+ INFO = -2
+ ELSE IF( MV.LT.0 ) THEN
+ INFO = -3
+ ELSE IF( N.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( K.LT.0 .OR. K.GT.MAX( MU, MV ) ) THEN
+ INFO = -5
+ ELSE IF( ( IRC.EQ.0 .AND. LDU.LT.MAX( 1, MU ) ) .OR.
+ $ ( IRC.EQ.1 .AND. LDU.LT.MAX( 1, N ) ) ) THEN
+ INFO = -7
+ ELSE IF( ( IRC.EQ.0 .AND. LDV.LT.MAX( 1, MV ) ) .OR.
+ $ ( IRC.EQ.1 .AND. LDV.LT.MAX( 1, N ) ) ) THEN
+ INFO = -9
+ END IF
+ IF( INFO.NE.0 ) THEN
+ CALL XERBLA( 'DORT03', -INFO )
+ RETURN
+ END IF
+*
+* Initialize result
+*
+ RESULT = ZERO
+ IF( MU.EQ.0 .OR. MV.EQ.0 .OR. N.EQ.0 )
+ $ RETURN
+*
+* Machine constants
+*
+ ULP = DLAMCH( 'Precision' )
+*
+ IF( IRC.EQ.0 ) THEN
+*
+* Compare rows
+*
+ RES1 = ZERO
+ DO 20 I = 1, K
+ LMX = IDAMAX( N, U( I, 1 ), LDU )
+ S = SIGN( ONE, U( I, LMX ) )*SIGN( ONE, V( I, LMX ) )
+ DO 10 J = 1, N
+ RES1 = MAX( RES1, ABS( U( I, J )-S*V( I, J ) ) )
+ 10 CONTINUE
+ 20 CONTINUE
+ RES1 = RES1 / ( DBLE( N )*ULP )
+*
+* Compute orthogonality of rows of V.
+*
+ CALL DORT01( 'Rows', MV, N, V, LDV, WORK, LWORK, RES2 )
+*
+ ELSE
+*
+* Compare columns
+*
+ RES1 = ZERO
+ DO 40 I = 1, K
+ LMX = IDAMAX( N, U( 1, I ), 1 )
+ S = SIGN( ONE, U( LMX, I ) )*SIGN( ONE, V( LMX, I ) )
+ DO 30 J = 1, N
+ RES1 = MAX( RES1, ABS( U( J, I )-S*V( J, I ) ) )
+ 30 CONTINUE
+ 40 CONTINUE
+ RES1 = RES1 / ( DBLE( N )*ULP )
+*
+* Compute orthogonality of columns of V.
+*
+ CALL DORT01( 'Columns', N, MV, V, LDV, WORK, LWORK, RES2 )
+ END IF
+*
+ RESULT = MIN( MAX( RES1, RES2 ), ONE / ULP )
+ RETURN
+*
+* End of DORT03
+*
+ END
+ SUBROUTINE DSBT21( UPLO, N, KA, KS, A, LDA, D, E, U, LDU, WORK,
+ $ RESULT )
+*
+* -- LAPACK test routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER KA, KS, LDA, LDU, N
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION A( LDA, * ), D( * ), E( * ), RESULT( 2 ),
+ $ U( LDU, * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DSBT21 generally checks a decomposition of the form
+*
+* A = U S U'
+*
+* where ' means transpose, A is symmetric banded, U is
+* orthogonal, and S is diagonal (if KS=0) or symmetric
+* tridiagonal (if KS=1).
+*
+* Specifically:
+*
+* RESULT(1) = | A - U S U' | / ( |A| n ulp ) *and*
+* RESULT(2) = | I - UU' | / ( n ulp )
+*
+* Arguments
+* =========
+*
+* UPLO (input) CHARACTER
+* If UPLO='U', the upper triangle of A and V will be used and
+* the (strictly) lower triangle will not be referenced.
+* If UPLO='L', the lower triangle of A and V will be used and
+* the (strictly) upper triangle will not be referenced.
+*
+* N (input) INTEGER
+* The size of the matrix. If it is zero, DSBT21 does nothing.
+* It must be at least zero.
+*
+* KA (input) INTEGER
+* The bandwidth of the matrix A. It must be at least zero. If
+* it is larger than N-1, then max( 0, N-1 ) will be used.
+*
+* KS (input) INTEGER
+* The bandwidth of the matrix S. It may only be zero or one.
+* If zero, then S is diagonal, and E is not referenced. If
+* one, then S is symmetric tri-diagonal.
+*
+* A (input) DOUBLE PRECISION array, dimension (LDA, N)
+* The original (unfactored) matrix. It is assumed to be
+* symmetric, and only the upper (UPLO='U') or only the lower
+* (UPLO='L') will be referenced.
+*
+* LDA (input) INTEGER
+* The leading dimension of A. It must be at least 1
+* and at least min( KA, N-1 ).
+*
+* D (input) DOUBLE PRECISION array, dimension (N)
+* The diagonal of the (symmetric tri-) diagonal matrix S.
+*
+* E (input) DOUBLE PRECISION array, dimension (N-1)
+* The off-diagonal of the (symmetric tri-) diagonal matrix S.
+* E(1) is the (1,2) and (2,1) element, E(2) is the (2,3) and
+* (3,2) element, etc.
+* Not referenced if KS=0.
+*
+* U (input) DOUBLE PRECISION array, dimension (LDU, N)
+* The orthogonal matrix in the decomposition, expressed as a
+* dense matrix (i.e., not as a product of Householder
+* transformations, Givens transformations, etc.)
+*
+* LDU (input) INTEGER
+* The leading dimension of U. LDU must be at least N and
+* at least 1.
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (N**2+N)
+*
+* RESULT (output) DOUBLE PRECISION array, dimension (2)
+* The values computed by the two tests described above. The
+* values are currently limited to 1/ulp, to avoid overflow.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL LOWER
+ CHARACTER CUPLO
+ INTEGER IKA, J, JC, JR, LW
+ DOUBLE PRECISION ANORM, ULP, UNFL, WNORM
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ DOUBLE PRECISION DLAMCH, DLANGE, DLANSB, DLANSP
+ EXTERNAL LSAME, DLAMCH, DLANGE, DLANSB, DLANSP
+* ..
+* .. External Subroutines ..
+ EXTERNAL DGEMM, DSPR, DSPR2
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC DBLE, MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+* Constants
+*
+ RESULT( 1 ) = ZERO
+ RESULT( 2 ) = ZERO
+ IF( N.LE.0 )
+ $ RETURN
+*
+ IKA = MAX( 0, MIN( N-1, KA ) )
+ LW = ( N*( N+1 ) ) / 2
+*
+ IF( LSAME( UPLO, 'U' ) ) THEN
+ LOWER = .FALSE.
+ CUPLO = 'U'
+ ELSE
+ LOWER = .TRUE.
+ CUPLO = 'L'
+ END IF
+*
+ UNFL = DLAMCH( 'Safe minimum' )
+ ULP = DLAMCH( 'Epsilon' )*DLAMCH( 'Base' )
+*
+* Some Error Checks
+*
+* Do Test 1
+*
+* Norm of A:
+*
+ ANORM = MAX( DLANSB( '1', CUPLO, N, IKA, A, LDA, WORK ), UNFL )
+*
+* Compute error matrix: Error = A - U S U'
+*
+* Copy A from SB to SP storage format.
+*
+ J = 0
+ DO 50 JC = 1, N
+ IF( LOWER ) THEN
+ DO 10 JR = 1, MIN( IKA+1, N+1-JC )
+ J = J + 1
+ WORK( J ) = A( JR, JC )
+ 10 CONTINUE
+ DO 20 JR = IKA + 2, N + 1 - JC
+ J = J + 1
+ WORK( J ) = ZERO
+ 20 CONTINUE
+ ELSE
+ DO 30 JR = IKA + 2, JC
+ J = J + 1
+ WORK( J ) = ZERO
+ 30 CONTINUE
+ DO 40 JR = MIN( IKA, JC-1 ), 0, -1
+ J = J + 1
+ WORK( J ) = A( IKA+1-JR, JC )
+ 40 CONTINUE
+ END IF
+ 50 CONTINUE
+*
+ DO 60 J = 1, N
+ CALL DSPR( CUPLO, N, -D( J ), U( 1, J ), 1, WORK )
+ 60 CONTINUE
+*
+ IF( N.GT.1 .AND. KS.EQ.1 ) THEN
+ DO 70 J = 1, N - 1
+ CALL DSPR2( CUPLO, N, -E( J ), U( 1, J ), 1, U( 1, J+1 ), 1,
+ $ WORK )
+ 70 CONTINUE
+ END IF
+ WNORM = DLANSP( '1', CUPLO, N, WORK, WORK( LW+1 ) )
+*
+ IF( ANORM.GT.WNORM ) THEN
+ RESULT( 1 ) = ( WNORM / ANORM ) / ( N*ULP )
+ ELSE
+ IF( ANORM.LT.ONE ) THEN
+ RESULT( 1 ) = ( MIN( WNORM, N*ANORM ) / ANORM ) / ( N*ULP )
+ ELSE
+ RESULT( 1 ) = MIN( WNORM / ANORM, DBLE( N ) ) / ( N*ULP )
+ END IF
+ END IF
+*
+* Do Test 2
+*
+* Compute UU' - I
+*
+ CALL DGEMM( 'N', 'C', N, N, N, ONE, U, LDU, U, LDU, ZERO, WORK,
+ $ N )
+*
+ DO 80 J = 1, N
+ WORK( ( N+1 )*( J-1 )+1 ) = WORK( ( N+1 )*( J-1 )+1 ) - ONE
+ 80 CONTINUE
+*
+ RESULT( 2 ) = MIN( DLANGE( '1', N, N, WORK, N, WORK( N**2+1 ) ),
+ $ DBLE( N ) ) / ( N*ULP )
+*
+ RETURN
+*
+* End of DSBT21
+*
+ END
+ SUBROUTINE DSGT01( ITYPE, UPLO, N, M, A, LDA, B, LDB, Z, LDZ, D,
+ $ WORK, RESULT )
+*
+* -- LAPACK test routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* modified August 1997, a new parameter M is added to the calling
+* sequence.
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER ITYPE, LDA, LDB, LDZ, M, N
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION A( LDA, * ), B( LDB, * ), D( * ), RESULT( * ),
+ $ WORK( * ), Z( LDZ, * )
+* ..
+*
+* Purpose
+* =======
+*
+* DDGT01 checks a decomposition of the form
+*
+* A Z = B Z D or
+* A B Z = Z D or
+* B A Z = Z D
+*
+* where A is a symmetric matrix, B is
+* symmetric positive definite, Z is orthogonal, and D is diagonal.
+*
+* One of the following test ratios is computed:
+*
+* ITYPE = 1: RESULT(1) = | A Z - B Z D | / ( |A| |Z| n ulp )
+*
+* ITYPE = 2: RESULT(1) = | A B Z - Z D | / ( |A| |Z| n ulp )
+*
+* ITYPE = 3: RESULT(1) = | B A Z - Z D | / ( |A| |Z| n ulp )
+*
+* Arguments
+* =========
+*
+* ITYPE (input) INTEGER
+* The form of the symmetric generalized eigenproblem.
+* = 1: A*z = (lambda)*B*z
+* = 2: A*B*z = (lambda)*z
+* = 3: B*A*z = (lambda)*z
+*
+* UPLO (input) CHARACTER*1
+* Specifies whether the upper or lower triangular part of the
+* symmetric matrices A and B is stored.
+* = 'U': Upper triangular
+* = 'L': Lower triangular
+*
+* N (input) INTEGER
+* The order of the matrix A. N >= 0.
+*
+* M (input) INTEGER
+* The number of eigenvalues found. 0 <= M <= N.
+*
+* A (input) DOUBLE PRECISION array, dimension (LDA, N)
+* The original symmetric matrix A.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,N).
+*
+* B (input) DOUBLE PRECISION array, dimension (LDB, N)
+* The original symmetric positive definite matrix B.
+*
+* LDB (input) INTEGER
+* The leading dimension of the array B. LDB >= max(1,N).
+*
+* Z (input) DOUBLE PRECISION array, dimension (LDZ, M)
+* The computed eigenvectors of the generalized eigenproblem.
+*
+* LDZ (input) INTEGER
+* The leading dimension of the array Z. LDZ >= max(1,N).
+*
+* D (input) DOUBLE PRECISION array, dimension (M)
+* The computed eigenvalues of the generalized eigenproblem.
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (N*N)
+*
+* RESULT (output) DOUBLE PRECISION array, dimension (1)
+* The test ratio as described above.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I
+ DOUBLE PRECISION ANORM, ULP
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DLAMCH, DLANGE, DLANSY
+ EXTERNAL DLAMCH, DLANGE, DLANSY
+* ..
+* .. External Subroutines ..
+ EXTERNAL DSCAL, DSYMM
+* ..
+* .. Executable Statements ..
+*
+ RESULT( 1 ) = ZERO
+ IF( N.LE.0 )
+ $ RETURN
+*
+ ULP = DLAMCH( 'Epsilon' )
+*
+* Compute product of 1-norms of A and Z.
+*
+ ANORM = DLANSY( '1', UPLO, N, A, LDA, WORK )*
+ $ DLANGE( '1', N, M, Z, LDZ, WORK )
+ IF( ANORM.EQ.ZERO )
+ $ ANORM = ONE
+*
+ IF( ITYPE.EQ.1 ) THEN
+*
+* Norm of AZ - BZD
+*
+ CALL DSYMM( 'Left', UPLO, N, M, ONE, A, LDA, Z, LDZ, ZERO,
+ $ WORK, N )
+ DO 10 I = 1, M
+ CALL DSCAL( N, D( I ), Z( 1, I ), 1 )
+ 10 CONTINUE
+ CALL DSYMM( 'Left', UPLO, N, M, ONE, B, LDB, Z, LDZ, -ONE,
+ $ WORK, N )
+*
+ RESULT( 1 ) = ( DLANGE( '1', N, M, WORK, N, WORK ) / ANORM ) /
+ $ ( N*ULP )
+*
+ ELSE IF( ITYPE.EQ.2 ) THEN
+*
+* Norm of ABZ - ZD
+*
+ CALL DSYMM( 'Left', UPLO, N, M, ONE, B, LDB, Z, LDZ, ZERO,
+ $ WORK, N )
+ DO 20 I = 1, M
+ CALL DSCAL( N, D( I ), Z( 1, I ), 1 )
+ 20 CONTINUE
+ CALL DSYMM( 'Left', UPLO, N, M, ONE, A, LDA, WORK, N, -ONE, Z,
+ $ LDZ )
+*
+ RESULT( 1 ) = ( DLANGE( '1', N, M, Z, LDZ, WORK ) / ANORM ) /
+ $ ( N*ULP )
+*
+ ELSE IF( ITYPE.EQ.3 ) THEN
+*
+* Norm of BAZ - ZD
+*
+ CALL DSYMM( 'Left', UPLO, N, M, ONE, A, LDA, Z, LDZ, ZERO,
+ $ WORK, N )
+ DO 30 I = 1, M
+ CALL DSCAL( N, D( I ), Z( 1, I ), 1 )
+ 30 CONTINUE
+ CALL DSYMM( 'Left', UPLO, N, M, ONE, B, LDB, WORK, N, -ONE, Z,
+ $ LDZ )
+*
+ RESULT( 1 ) = ( DLANGE( '1', N, M, Z, LDZ, WORK ) / ANORM ) /
+ $ ( N*ULP )
+ END IF
+*
+ RETURN
+*
+* End of DDGT01
+*
+ END
+ LOGICAL FUNCTION DSLECT( ZR, ZI )
+*
+* -- LAPACK test routine (version 3.1.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* February 2007
+*
+* .. Scalar Arguments ..
+ DOUBLE PRECISION ZI, ZR
+* ..
+*
+* Purpose
+* =======
+*
+* DSLECT returns .TRUE. if the eigenvalue ZR+sqrt(-1)*ZI is to be
+* selected, and otherwise it returns .FALSE.
+* It is used by DCHK41 to test if DGEES succesfully sorts eigenvalues,
+* and by DCHK43 to test if DGEESX succesfully sorts eigenvalues.
+*
+* The common block /SSLCT/ controls how eigenvalues are selected.
+* If SELOPT = 0, then DSLECT return .TRUE. when ZR is less than zero,
+* and .FALSE. otherwise.
+* If SELOPT is at least 1, DSLECT returns SELVAL(SELOPT) and adds 1
+* to SELOPT, cycling back to 1 at SELMAX.
+*
+* Arguments
+* =========
+*
+* ZR (input) DOUBLE PRECISION
+* The real part of a complex eigenvalue ZR + i*ZI.
+*
+* ZI (input) DOUBLE PRECISION
+* The imaginary part of a complex eigenvalue ZR + i*ZI.
+*
+* =====================================================================
+*
+* .. Arrays in Common ..
+ LOGICAL SELVAL( 20 )
+ DOUBLE PRECISION SELWI( 20 ), SELWR( 20 )
+* ..
+* .. Scalars in Common ..
+ INTEGER SELDIM, SELOPT
+* ..
+* .. Common blocks ..
+ COMMON / SSLCT / SELOPT, SELDIM, SELVAL, SELWR, SELWI
+* ..
+* .. Local Scalars ..
+ INTEGER I
+ DOUBLE PRECISION RMIN, X
+* ..
+* .. Parameters ..
+ DOUBLE PRECISION ZERO
+ PARAMETER ( ZERO = 0.0D0 )
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DLAPY2
+ EXTERNAL DLAPY2
+* ..
+* .. Executable Statements ..
+*
+ IF( SELOPT.EQ.0 ) THEN
+ DSLECT = ( ZR.LT.ZERO )
+ ELSE
+ RMIN = DLAPY2( ZR-SELWR( 1 ), ZI-SELWI( 1 ) )
+ DSLECT = SELVAL( 1 )
+ DO 10 I = 2, SELDIM
+ X = DLAPY2( ZR-SELWR( I ), ZI-SELWI( I ) )
+ IF( X.LE.RMIN ) THEN
+ RMIN = X
+ DSLECT = SELVAL( I )
+ END IF
+ 10 CONTINUE
+ END IF
+ RETURN
+*
+* End of DSLECT
+*
+ END
+ SUBROUTINE DSPT21( ITYPE, UPLO, N, KBAND, AP, D, E, U, LDU, VP,
+ $ TAU, WORK, RESULT )
+*
+* -- LAPACK test routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER ITYPE, KBAND, LDU, N
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION AP( * ), D( * ), E( * ), RESULT( 2 ), TAU( * ),
+ $ U( LDU, * ), VP( * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DSPT21 generally checks a decomposition of the form
+*
+* A = U S U'
+*
+* where ' means transpose, A is symmetric (stored in packed format), U
+* is orthogonal, and S is diagonal (if KBAND=0) or symmetric
+* tridiagonal (if KBAND=1). If ITYPE=1, then U is represented as a
+* dense matrix, otherwise the U is expressed as a product of
+* Householder transformations, whose vectors are stored in the array
+* "V" and whose scaling constants are in "TAU"; we shall use the
+* letter "V" to refer to the product of Householder transformations
+* (which should be equal to U).
+*
+* Specifically, if ITYPE=1, then:
+*
+* RESULT(1) = | A - U S U' | / ( |A| n ulp ) *and*
+* RESULT(2) = | I - UU' | / ( n ulp )
+*
+* If ITYPE=2, then:
+*
+* RESULT(1) = | A - V S V' | / ( |A| n ulp )
+*
+* If ITYPE=3, then:
+*
+* RESULT(1) = | I - VU' | / ( n ulp )
+*
+* Packed storage means that, for example, if UPLO='U', then the columns
+* of the upper triangle of A are stored one after another, so that
+* A(1,j+1) immediately follows A(j,j) in the array AP. Similarly, if
+* UPLO='L', then the columns of the lower triangle of A are stored one
+* after another in AP, so that A(j+1,j+1) immediately follows A(n,j)
+* in the array AP. This means that A(i,j) is stored in:
+*
+* AP( i + j*(j-1)/2 ) if UPLO='U'
+*
+* AP( i + (2*n-j)*(j-1)/2 ) if UPLO='L'
+*
+* The array VP bears the same relation to the matrix V that A does to
+* AP.
+*
+* For ITYPE > 1, the transformation U is expressed as a product
+* of Householder transformations:
+*
+* If UPLO='U', then V = H(n-1)...H(1), where
+*
+* H(j) = I - tau(j) v(j) v(j)'
+*
+* and the first j-1 elements of v(j) are stored in V(1:j-1,j+1),
+* (i.e., VP( j*(j+1)/2 + 1 : j*(j+1)/2 + j-1 ) ),
+* the j-th element is 1, and the last n-j elements are 0.
+*
+* If UPLO='L', then V = H(1)...H(n-1), where
+*
+* H(j) = I - tau(j) v(j) v(j)'
+*
+* and the first j elements of v(j) are 0, the (j+1)-st is 1, and the
+* (j+2)-nd through n-th elements are stored in V(j+2:n,j) (i.e.,
+* in VP( (2*n-j)*(j-1)/2 + j+2 : (2*n-j)*(j-1)/2 + n ) .)
+*
+* Arguments
+* =========
+*
+* ITYPE (input) INTEGER
+* Specifies the type of tests to be performed.
+* 1: U expressed as a dense orthogonal matrix:
+* RESULT(1) = | A - U S U' | / ( |A| n ulp ) *and*
+* RESULT(2) = | I - UU' | / ( n ulp )
+*
+* 2: U expressed as a product V of Housholder transformations:
+* RESULT(1) = | A - V S V' | / ( |A| n ulp )
+*
+* 3: U expressed both as a dense orthogonal matrix and
+* as a product of Housholder transformations:
+* RESULT(1) = | I - VU' | / ( n ulp )
+*
+* UPLO (input) CHARACTER
+* If UPLO='U', AP and VP are considered to contain the upper
+* triangle of A and V.
+* If UPLO='L', AP and VP are considered to contain the lower
+* triangle of A and V.
+*
+* N (input) INTEGER
+* The size of the matrix. If it is zero, DSPT21 does nothing.
+* It must be at least zero.
+*
+* KBAND (input) INTEGER
+* The bandwidth of the matrix. It may only be zero or one.
+* If zero, then S is diagonal, and E is not referenced. If
+* one, then S is symmetric tri-diagonal.
+*
+* AP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)
+* The original (unfactored) matrix. It is assumed to be
+* symmetric, and contains the columns of just the upper
+* triangle (UPLO='U') or only the lower triangle (UPLO='L'),
+* packed one after another.
+*
+* D (input) DOUBLE PRECISION array, dimension (N)
+* The diagonal of the (symmetric tri-) diagonal matrix.
+*
+* E (input) DOUBLE PRECISION array, dimension (N-1)
+* The off-diagonal of the (symmetric tri-) diagonal matrix.
+* E(1) is the (1,2) and (2,1) element, E(2) is the (2,3) and
+* (3,2) element, etc.
+* Not referenced if KBAND=0.
+*
+* U (input) DOUBLE PRECISION array, dimension (LDU, N)
+* If ITYPE=1 or 3, this contains the orthogonal matrix in
+* the decomposition, expressed as a dense matrix. If ITYPE=2,
+* then it is not referenced.
+*
+* LDU (input) INTEGER
+* The leading dimension of U. LDU must be at least N and
+* at least 1.
+*
+* VP (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)
+* If ITYPE=2 or 3, the columns of this array contain the
+* Householder vectors used to describe the orthogonal matrix
+* in the decomposition, as described in purpose.
+* *NOTE* If ITYPE=2 or 3, V is modified and restored. The
+* subdiagonal (if UPLO='L') or the superdiagonal (if UPLO='U')
+* is set to one, and later reset to its original value, during
+* the course of the calculation.
+* If ITYPE=1, then it is neither referenced nor modified.
+*
+* TAU (input) DOUBLE PRECISION array, dimension (N)
+* If ITYPE >= 2, then TAU(j) is the scalar factor of
+* v(j) v(j)' in the Householder transformation H(j) of
+* the product U = H(1)...H(n-2)
+* If ITYPE < 2, then TAU is not referenced.
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (N**2+N)
+* Workspace.
+*
+* RESULT (output) DOUBLE PRECISION array, dimension (2)
+* The values computed by the two tests described above. The
+* values are currently limited to 1/ulp, to avoid overflow.
+* RESULT(1) is always modified. RESULT(2) is modified only
+* if ITYPE=1.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE, TEN
+ PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TEN = 10.0D0 )
+ DOUBLE PRECISION HALF
+ PARAMETER ( HALF = 1.0D+0 / 2.0D+0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL LOWER
+ CHARACTER CUPLO
+ INTEGER IINFO, J, JP, JP1, JR, LAP
+ DOUBLE PRECISION ANORM, TEMP, ULP, UNFL, VSAVE, WNORM
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ DOUBLE PRECISION DDOT, DLAMCH, DLANGE, DLANSP
+ EXTERNAL LSAME, DDOT, DLAMCH, DLANGE, DLANSP
+* ..
+* .. External Subroutines ..
+ EXTERNAL DAXPY, DCOPY, DGEMM, DLACPY, DLASET, DOPMTR,
+ $ DSPMV, DSPR, DSPR2
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC DBLE, MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+* 1) Constants
+*
+ RESULT( 1 ) = ZERO
+ IF( ITYPE.EQ.1 )
+ $ RESULT( 2 ) = ZERO
+ IF( N.LE.0 )
+ $ RETURN
+*
+ LAP = ( N*( N+1 ) ) / 2
+*
+ IF( LSAME( UPLO, 'U' ) ) THEN
+ LOWER = .FALSE.
+ CUPLO = 'U'
+ ELSE
+ LOWER = .TRUE.
+ CUPLO = 'L'
+ END IF
+*
+ UNFL = DLAMCH( 'Safe minimum' )
+ ULP = DLAMCH( 'Epsilon' )*DLAMCH( 'Base' )
+*
+* Some Error Checks
+*
+ IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN
+ RESULT( 1 ) = TEN / ULP
+ RETURN
+ END IF
+*
+* Do Test 1
+*
+* Norm of A:
+*
+ IF( ITYPE.EQ.3 ) THEN
+ ANORM = ONE
+ ELSE
+ ANORM = MAX( DLANSP( '1', CUPLO, N, AP, WORK ), UNFL )
+ END IF
+*
+* Compute error matrix:
+*
+ IF( ITYPE.EQ.1 ) THEN
+*
+* ITYPE=1: error = A - U S U'
+*
+ CALL DLASET( 'Full', N, N, ZERO, ZERO, WORK, N )
+ CALL DCOPY( LAP, AP, 1, WORK, 1 )
+*
+ DO 10 J = 1, N
+ CALL DSPR( CUPLO, N, -D( J ), U( 1, J ), 1, WORK )
+ 10 CONTINUE
+*
+ IF( N.GT.1 .AND. KBAND.EQ.1 ) THEN
+ DO 20 J = 1, N - 1
+ CALL DSPR2( CUPLO, N, -E( J ), U( 1, J ), 1, U( 1, J+1 ),
+ $ 1, WORK )
+ 20 CONTINUE
+ END IF
+ WNORM = DLANSP( '1', CUPLO, N, WORK, WORK( N**2+1 ) )
+*
+ ELSE IF( ITYPE.EQ.2 ) THEN
+*
+* ITYPE=2: error = V S V' - A
+*
+ CALL DLASET( 'Full', N, N, ZERO, ZERO, WORK, N )
+*
+ IF( LOWER ) THEN
+ WORK( LAP ) = D( N )
+ DO 40 J = N - 1, 1, -1
+ JP = ( ( 2*N-J )*( J-1 ) ) / 2
+ JP1 = JP + N - J
+ IF( KBAND.EQ.1 ) THEN
+ WORK( JP+J+1 ) = ( ONE-TAU( J ) )*E( J )
+ DO 30 JR = J + 2, N
+ WORK( JP+JR ) = -TAU( J )*E( J )*VP( JP+JR )
+ 30 CONTINUE
+ END IF
+*
+ IF( TAU( J ).NE.ZERO ) THEN
+ VSAVE = VP( JP+J+1 )
+ VP( JP+J+1 ) = ONE
+ CALL DSPMV( 'L', N-J, ONE, WORK( JP1+J+1 ),
+ $ VP( JP+J+1 ), 1, ZERO, WORK( LAP+1 ), 1 )
+ TEMP = -HALF*TAU( J )*DDOT( N-J, WORK( LAP+1 ), 1,
+ $ VP( JP+J+1 ), 1 )
+ CALL DAXPY( N-J, TEMP, VP( JP+J+1 ), 1, WORK( LAP+1 ),
+ $ 1 )
+ CALL DSPR2( 'L', N-J, -TAU( J ), VP( JP+J+1 ), 1,
+ $ WORK( LAP+1 ), 1, WORK( JP1+J+1 ) )
+ VP( JP+J+1 ) = VSAVE
+ END IF
+ WORK( JP+J ) = D( J )
+ 40 CONTINUE
+ ELSE
+ WORK( 1 ) = D( 1 )
+ DO 60 J = 1, N - 1
+ JP = ( J*( J-1 ) ) / 2
+ JP1 = JP + J
+ IF( KBAND.EQ.1 ) THEN
+ WORK( JP1+J ) = ( ONE-TAU( J ) )*E( J )
+ DO 50 JR = 1, J - 1
+ WORK( JP1+JR ) = -TAU( J )*E( J )*VP( JP1+JR )
+ 50 CONTINUE
+ END IF
+*
+ IF( TAU( J ).NE.ZERO ) THEN
+ VSAVE = VP( JP1+J )
+ VP( JP1+J ) = ONE
+ CALL DSPMV( 'U', J, ONE, WORK, VP( JP1+1 ), 1, ZERO,
+ $ WORK( LAP+1 ), 1 )
+ TEMP = -HALF*TAU( J )*DDOT( J, WORK( LAP+1 ), 1,
+ $ VP( JP1+1 ), 1 )
+ CALL DAXPY( J, TEMP, VP( JP1+1 ), 1, WORK( LAP+1 ),
+ $ 1 )
+ CALL DSPR2( 'U', J, -TAU( J ), VP( JP1+1 ), 1,
+ $ WORK( LAP+1 ), 1, WORK )
+ VP( JP1+J ) = VSAVE
+ END IF
+ WORK( JP1+J+1 ) = D( J+1 )
+ 60 CONTINUE
+ END IF
+*
+ DO 70 J = 1, LAP
+ WORK( J ) = WORK( J ) - AP( J )
+ 70 CONTINUE
+ WNORM = DLANSP( '1', CUPLO, N, WORK, WORK( LAP+1 ) )
+*
+ ELSE IF( ITYPE.EQ.3 ) THEN
+*
+* ITYPE=3: error = U V' - I
+*
+ IF( N.LT.2 )
+ $ RETURN
+ CALL DLACPY( ' ', N, N, U, LDU, WORK, N )
+ CALL DOPMTR( 'R', CUPLO, 'T', N, N, VP, TAU, WORK, N,
+ $ WORK( N**2+1 ), IINFO )
+ IF( IINFO.NE.0 ) THEN
+ RESULT( 1 ) = TEN / ULP
+ RETURN
+ END IF
+*
+ DO 80 J = 1, N
+ WORK( ( N+1 )*( J-1 )+1 ) = WORK( ( N+1 )*( J-1 )+1 ) - ONE
+ 80 CONTINUE
+*
+ WNORM = DLANGE( '1', N, N, WORK, N, WORK( N**2+1 ) )
+ END IF
+*
+ IF( ANORM.GT.WNORM ) THEN
+ RESULT( 1 ) = ( WNORM / ANORM ) / ( N*ULP )
+ ELSE
+ IF( ANORM.LT.ONE ) THEN
+ RESULT( 1 ) = ( MIN( WNORM, N*ANORM ) / ANORM ) / ( N*ULP )
+ ELSE
+ RESULT( 1 ) = MIN( WNORM / ANORM, DBLE( N ) ) / ( N*ULP )
+ END IF
+ END IF
+*
+* Do Test 2
+*
+* Compute UU' - I
+*
+ IF( ITYPE.EQ.1 ) THEN
+ CALL DGEMM( 'N', 'C', N, N, N, ONE, U, LDU, U, LDU, ZERO, WORK,
+ $ N )
+*
+ DO 90 J = 1, N
+ WORK( ( N+1 )*( J-1 )+1 ) = WORK( ( N+1 )*( J-1 )+1 ) - ONE
+ 90 CONTINUE
+*
+ RESULT( 2 ) = MIN( DLANGE( '1', N, N, WORK, N,
+ $ WORK( N**2+1 ) ), DBLE( N ) ) / ( N*ULP )
+ END IF
+*
+ RETURN
+*
+* End of DSPT21
+*
+ END
+ SUBROUTINE DSTECH( N, A, B, EIG, TOL, WORK, INFO )
+*
+* -- LAPACK test routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, N
+ DOUBLE PRECISION TOL
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION A( * ), B( * ), EIG( * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* Let T be the tridiagonal matrix with diagonal entries A(1) ,...,
+* A(N) and offdiagonal entries B(1) ,..., B(N-1)). DSTECH checks to
+* see if EIG(1) ,..., EIG(N) are indeed accurate eigenvalues of T.
+* It does this by expanding each EIG(I) into an interval
+* [SVD(I) - EPS, SVD(I) + EPS], merging overlapping intervals if
+* any, and using Sturm sequences to count and verify whether each
+* resulting interval has the correct number of eigenvalues (using
+* DSTECT). Here EPS = TOL*MAZHEPS*MAXEIG, where MACHEPS is the
+* machine precision and MAXEIG is the absolute value of the largest
+* eigenvalue. If each interval contains the correct number of
+* eigenvalues, INFO = 0 is returned, otherwise INFO is the index of
+* the first eigenvalue in the first bad interval.
+*
+* Arguments
+* =========
+*
+* N (input) INTEGER
+* The dimension of the tridiagonal matrix T.
+*
+* A (input) DOUBLE PRECISION array, dimension (N)
+* The diagonal entries of the tridiagonal matrix T.
+*
+* B (input) DOUBLE PRECISION array, dimension (N-1)
+* The offdiagonal entries of the tridiagonal matrix T.
+*
+* EIG (input) DOUBLE PRECISION array, dimension (N)
+* The purported eigenvalues to be checked.
+*
+* TOL (input) DOUBLE PRECISION
+* Error tolerance for checking, a multiple of the
+* machine precision.
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (N)
+*
+* INFO (output) INTEGER
+* 0 if the eigenvalues are all correct (to within
+* 1 +- TOL*MAZHEPS*MAXEIG)
+* >0 if the interval containing the INFO-th eigenvalue
+* contains the incorrect number of eigenvalues.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO
+ PARAMETER ( ZERO = 0.0D0 )
+* ..
+* .. Local Scalars ..
+ INTEGER BPNT, COUNT, I, ISUB, J, NUML, NUMU, TPNT
+ DOUBLE PRECISION EMIN, EPS, LOWER, MX, TUPPR, UNFLEP, UPPER
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DLAMCH
+ EXTERNAL DLAMCH
+* ..
+* .. External Subroutines ..
+ EXTERNAL DSTECT
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX
+* ..
+* .. Executable Statements ..
+*
+* Check input parameters
+*
+ INFO = 0
+ IF( N.EQ.0 )
+ $ RETURN
+ IF( N.LT.0 ) THEN
+ INFO = -1
+ RETURN
+ END IF
+ IF( TOL.LT.ZERO ) THEN
+ INFO = -5
+ RETURN
+ END IF
+*
+* Get machine constants
+*
+ EPS = DLAMCH( 'Epsilon' )*DLAMCH( 'Base' )
+ UNFLEP = DLAMCH( 'Safe minimum' ) / EPS
+ EPS = TOL*EPS
+*
+* Compute maximum absolute eigenvalue, error tolerance
+*
+ MX = ABS( EIG( 1 ) )
+ DO 10 I = 2, N
+ MX = MAX( MX, ABS( EIG( I ) ) )
+ 10 CONTINUE
+ EPS = MAX( EPS*MX, UNFLEP )
+*
+* Sort eigenvalues from EIG into WORK
+*
+ DO 20 I = 1, N
+ WORK( I ) = EIG( I )
+ 20 CONTINUE
+ DO 40 I = 1, N - 1
+ ISUB = 1
+ EMIN = WORK( 1 )
+ DO 30 J = 2, N + 1 - I
+ IF( WORK( J ).LT.EMIN ) THEN
+ ISUB = J
+ EMIN = WORK( J )
+ END IF
+ 30 CONTINUE
+ IF( ISUB.NE.N+1-I ) THEN
+ WORK( ISUB ) = WORK( N+1-I )
+ WORK( N+1-I ) = EMIN
+ END IF
+ 40 CONTINUE
+*
+* TPNT points to singular value at right endpoint of interval
+* BPNT points to singular value at left endpoint of interval
+*
+ TPNT = 1
+ BPNT = 1
+*
+* Begin loop over all intervals
+*
+ 50 CONTINUE
+ UPPER = WORK( TPNT ) + EPS
+ LOWER = WORK( BPNT ) - EPS
+*
+* Begin loop merging overlapping intervals
+*
+ 60 CONTINUE
+ IF( BPNT.EQ.N )
+ $ GO TO 70
+ TUPPR = WORK( BPNT+1 ) + EPS
+ IF( TUPPR.LT.LOWER )
+ $ GO TO 70
+*
+* Merge
+*
+ BPNT = BPNT + 1
+ LOWER = WORK( BPNT ) - EPS
+ GO TO 60
+ 70 CONTINUE
+*
+* Count singular values in interval [ LOWER, UPPER ]
+*
+ CALL DSTECT( N, A, B, LOWER, NUML )
+ CALL DSTECT( N, A, B, UPPER, NUMU )
+ COUNT = NUMU - NUML
+ IF( COUNT.NE.BPNT-TPNT+1 ) THEN
+*
+* Wrong number of singular values in interval
+*
+ INFO = TPNT
+ GO TO 80
+ END IF
+ TPNT = BPNT + 1
+ BPNT = TPNT
+ IF( TPNT.LE.N )
+ $ GO TO 50
+ 80 CONTINUE
+ RETURN
+*
+* End of DSTECH
+*
+ END
+ SUBROUTINE DSTECT( N, A, B, SHIFT, NUM )
+*
+* -- LAPACK test routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER N, NUM
+ DOUBLE PRECISION SHIFT
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION A( * ), B( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DSTECT counts the number NUM of eigenvalues of a tridiagonal
+* matrix T which are less than or equal to SHIFT. T has
+* diagonal entries A(1), ... , A(N), and offdiagonal entries
+* B(1), ..., B(N-1).
+* See W. Kahan "Accurate Eigenvalues of a Symmetric Tridiagonal
+* Matrix", Report CS41, Computer Science Dept., Stanford
+* University, July 21, 1966
+*
+* Arguments
+* =========
+*
+* N (input) INTEGER
+* The dimension of the tridiagonal matrix T.
+*
+* A (input) DOUBLE PRECISION array, dimension (N)
+* The diagonal entries of the tridiagonal matrix T.
+*
+* B (input) DOUBLE PRECISION array, dimension (N-1)
+* The offdiagonal entries of the tridiagonal matrix T.
+*
+* SHIFT (input) DOUBLE PRECISION
+* The shift, used as described under Purpose.
+*
+* NUM (output) INTEGER
+* The number of eigenvalues of T less than or equal
+* to SHIFT.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE, THREE
+ PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, THREE = 3.0D0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I
+ DOUBLE PRECISION M1, M2, MX, OVFL, SOV, SSHIFT, SSUN, SUN, TMP,
+ $ TOM, U, UNFL
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DLAMCH
+ EXTERNAL DLAMCH
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, SQRT
+* ..
+* .. Executable Statements ..
+*
+* Get machine constants
+*
+ UNFL = DLAMCH( 'Safe minimum' )
+ OVFL = DLAMCH( 'Overflow' )
+*
+* Find largest entry
+*
+ MX = ABS( A( 1 ) )
+ DO 10 I = 1, N - 1
+ MX = MAX( MX, ABS( A( I+1 ) ), ABS( B( I ) ) )
+ 10 CONTINUE
+*
+* Handle easy cases, including zero matrix
+*
+ IF( SHIFT.GE.THREE*MX ) THEN
+ NUM = N
+ RETURN
+ END IF
+ IF( SHIFT.LT.-THREE*MX ) THEN
+ NUM = 0
+ RETURN
+ END IF
+*
+* Compute scale factors as in Kahan's report
+* At this point, MX .NE. 0 so we can divide by it
+*
+ SUN = SQRT( UNFL )
+ SSUN = SQRT( SUN )
+ SOV = SQRT( OVFL )
+ TOM = SSUN*SOV
+ IF( MX.LE.ONE ) THEN
+ M1 = ONE / MX
+ M2 = TOM
+ ELSE
+ M1 = ONE
+ M2 = TOM / MX
+ END IF
+*
+* Begin counting
+*
+ NUM = 0
+ SSHIFT = ( SHIFT*M1 )*M2
+ U = ( A( 1 )*M1 )*M2 - SSHIFT
+ IF( U.LE.SUN ) THEN
+ IF( U.LE.ZERO ) THEN
+ NUM = NUM + 1
+ IF( U.GT.-SUN )
+ $ U = -SUN
+ ELSE
+ U = SUN
+ END IF
+ END IF
+ DO 20 I = 2, N
+ TMP = ( B( I-1 )*M1 )*M2
+ U = ( ( A( I )*M1 )*M2-TMP*( TMP / U ) ) - SSHIFT
+ IF( U.LE.SUN ) THEN
+ IF( U.LE.ZERO ) THEN
+ NUM = NUM + 1
+ IF( U.GT.-SUN )
+ $ U = -SUN
+ ELSE
+ U = SUN
+ END IF
+ END IF
+ 20 CONTINUE
+ RETURN
+*
+* End of DSTECT
+*
+ END
+ SUBROUTINE DSTT21( N, KBAND, AD, AE, SD, SE, U, LDU, WORK,
+ $ RESULT )
+*
+* -- LAPACK test routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER KBAND, LDU, N
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION AD( * ), AE( * ), RESULT( 2 ), SD( * ),
+ $ SE( * ), U( LDU, * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DSTT21 checks a decomposition of the form
+*
+* A = U S U'
+*
+* where ' means transpose, A is symmetric tridiagonal, U is orthogonal,
+* and S is diagonal (if KBAND=0) or symmetric tridiagonal (if KBAND=1).
+* Two tests are performed:
+*
+* RESULT(1) = | A - U S U' | / ( |A| n ulp )
+*
+* RESULT(2) = | I - UU' | / ( n ulp )
+*
+* Arguments
+* =========
+*
+* N (input) INTEGER
+* The size of the matrix. If it is zero, DSTT21 does nothing.
+* It must be at least zero.
+*
+* KBAND (input) INTEGER
+* The bandwidth of the matrix S. It may only be zero or one.
+* If zero, then S is diagonal, and SE is not referenced. If
+* one, then S is symmetric tri-diagonal.
+*
+* AD (input) DOUBLE PRECISION array, dimension (N)
+* The diagonal of the original (unfactored) matrix A. A is
+* assumed to be symmetric tridiagonal.
+*
+* AE (input) DOUBLE PRECISION array, dimension (N-1)
+* The off-diagonal of the original (unfactored) matrix A. A
+* is assumed to be symmetric tridiagonal. AE(1) is the (1,2)
+* and (2,1) element, AE(2) is the (2,3) and (3,2) element, etc.
+*
+* SD (input) DOUBLE PRECISION array, dimension (N)
+* The diagonal of the (symmetric tri-) diagonal matrix S.
+*
+* SE (input) DOUBLE PRECISION array, dimension (N-1)
+* The off-diagonal of the (symmetric tri-) diagonal matrix S.
+* Not referenced if KBSND=0. If KBAND=1, then AE(1) is the
+* (1,2) and (2,1) element, SE(2) is the (2,3) and (3,2)
+* element, etc.
+*
+* U (input) DOUBLE PRECISION array, dimension (LDU, N)
+* The orthogonal matrix in the decomposition.
+*
+* LDU (input) INTEGER
+* The leading dimension of U. LDU must be at least N.
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (N*(N+1))
+*
+* RESULT (output) DOUBLE PRECISION array, dimension (2)
+* The values computed by the two tests described above. The
+* values are currently limited to 1/ulp, to avoid overflow.
+* RESULT(1) is always modified.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
+* ..
+* .. Local Scalars ..
+ INTEGER J
+ DOUBLE PRECISION ANORM, TEMP1, TEMP2, ULP, UNFL, WNORM
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DLAMCH, DLANGE, DLANSY
+ EXTERNAL DLAMCH, DLANGE, DLANSY
+* ..
+* .. External Subroutines ..
+ EXTERNAL DGEMM, DLASET, DSYR, DSYR2
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, DBLE, MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+* 1) Constants
+*
+ RESULT( 1 ) = ZERO
+ RESULT( 2 ) = ZERO
+ IF( N.LE.0 )
+ $ RETURN
+*
+ UNFL = DLAMCH( 'Safe minimum' )
+ ULP = DLAMCH( 'Precision' )
+*
+* Do Test 1
+*
+* Copy A & Compute its 1-Norm:
+*
+ CALL DLASET( 'Full', N, N, ZERO, ZERO, WORK, N )
+*
+ ANORM = ZERO
+ TEMP1 = ZERO
+*
+ DO 10 J = 1, N - 1
+ WORK( ( N+1 )*( J-1 )+1 ) = AD( J )
+ WORK( ( N+1 )*( J-1 )+2 ) = AE( J )
+ TEMP2 = ABS( AE( J ) )
+ ANORM = MAX( ANORM, ABS( AD( J ) )+TEMP1+TEMP2 )
+ TEMP1 = TEMP2
+ 10 CONTINUE
+*
+ WORK( N**2 ) = AD( N )
+ ANORM = MAX( ANORM, ABS( AD( N ) )+TEMP1, UNFL )
+*
+* Norm of A - USU'
+*
+ DO 20 J = 1, N
+ CALL DSYR( 'L', N, -SD( J ), U( 1, J ), 1, WORK, N )
+ 20 CONTINUE
+*
+ IF( N.GT.1 .AND. KBAND.EQ.1 ) THEN
+ DO 30 J = 1, N - 1
+ CALL DSYR2( 'L', N, -SE( J ), U( 1, J ), 1, U( 1, J+1 ), 1,
+ $ WORK, N )
+ 30 CONTINUE
+ END IF
+*
+ WNORM = DLANSY( '1', 'L', N, WORK, N, WORK( N**2+1 ) )
+*
+ IF( ANORM.GT.WNORM ) THEN
+ RESULT( 1 ) = ( WNORM / ANORM ) / ( N*ULP )
+ ELSE
+ IF( ANORM.LT.ONE ) THEN
+ RESULT( 1 ) = ( MIN( WNORM, N*ANORM ) / ANORM ) / ( N*ULP )
+ ELSE
+ RESULT( 1 ) = MIN( WNORM / ANORM, DBLE( N ) ) / ( N*ULP )
+ END IF
+ END IF
+*
+* Do Test 2
+*
+* Compute UU' - I
+*
+ CALL DGEMM( 'N', 'C', N, N, N, ONE, U, LDU, U, LDU, ZERO, WORK,
+ $ N )
+*
+ DO 40 J = 1, N
+ WORK( ( N+1 )*( J-1 )+1 ) = WORK( ( N+1 )*( J-1 )+1 ) - ONE
+ 40 CONTINUE
+*
+ RESULT( 2 ) = MIN( DBLE( N ), DLANGE( '1', N, N, WORK, N,
+ $ WORK( N**2+1 ) ) ) / ( N*ULP )
+*
+ RETURN
+*
+* End of DSTT21
+*
+ END
+ SUBROUTINE DSTT22( N, M, KBAND, AD, AE, SD, SE, U, LDU, WORK,
+ $ LDWORK, RESULT )
+*
+* -- LAPACK test routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER KBAND, LDU, LDWORK, M, N
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION AD( * ), AE( * ), RESULT( 2 ), SD( * ),
+ $ SE( * ), U( LDU, * ), WORK( LDWORK, * )
+* ..
+*
+* Purpose
+* =======
+*
+* DSTT22 checks a set of M eigenvalues and eigenvectors,
+*
+* A U = U S
+*
+* where A is symmetric tridiagonal, the columns of U are orthogonal,
+* and S is diagonal (if KBAND=0) or symmetric tridiagonal (if KBAND=1).
+* Two tests are performed:
+*
+* RESULT(1) = | U' A U - S | / ( |A| m ulp )
+*
+* RESULT(2) = | I - U'U | / ( m ulp )
+*
+* Arguments
+* =========
+*
+* N (input) INTEGER
+* The size of the matrix. If it is zero, DSTT22 does nothing.
+* It must be at least zero.
+*
+* M (input) INTEGER
+* The number of eigenpairs to check. If it is zero, DSTT22
+* does nothing. It must be at least zero.
+*
+* KBAND (input) INTEGER
+* The bandwidth of the matrix S. It may only be zero or one.
+* If zero, then S is diagonal, and SE is not referenced. If
+* one, then S is symmetric tri-diagonal.
+*
+* AD (input) DOUBLE PRECISION array, dimension (N)
+* The diagonal of the original (unfactored) matrix A. A is
+* assumed to be symmetric tridiagonal.
+*
+* AE (input) DOUBLE PRECISION array, dimension (N)
+* The off-diagonal of the original (unfactored) matrix A. A
+* is assumed to be symmetric tridiagonal. AE(1) is ignored,
+* AE(2) is the (1,2) and (2,1) element, etc.
+*
+* SD (input) DOUBLE PRECISION array, dimension (N)
+* The diagonal of the (symmetric tri-) diagonal matrix S.
+*
+* SE (input) DOUBLE PRECISION array, dimension (N)
+* The off-diagonal of the (symmetric tri-) diagonal matrix S.
+* Not referenced if KBSND=0. If KBAND=1, then AE(1) is
+* ignored, SE(2) is the (1,2) and (2,1) element, etc.
+*
+* U (input) DOUBLE PRECISION array, dimension (LDU, N)
+* The orthogonal matrix in the decomposition.
+*
+* LDU (input) INTEGER
+* The leading dimension of U. LDU must be at least N.
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (LDWORK, M+1)
+*
+* LDWORK (input) INTEGER
+* The leading dimension of WORK. LDWORK must be at least
+* max(1,M).
+*
+* RESULT (output) DOUBLE PRECISION array, dimension (2)
+* The values computed by the two tests described above. The
+* values are currently limited to 1/ulp, to avoid overflow.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, J, K
+ DOUBLE PRECISION ANORM, AUKJ, ULP, UNFL, WNORM
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DLAMCH, DLANGE, DLANSY
+ EXTERNAL DLAMCH, DLANGE, DLANSY
+* ..
+* .. External Subroutines ..
+ EXTERNAL DGEMM
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, DBLE, MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+ RESULT( 1 ) = ZERO
+ RESULT( 2 ) = ZERO
+ IF( N.LE.0 .OR. M.LE.0 )
+ $ RETURN
+*
+ UNFL = DLAMCH( 'Safe minimum' )
+ ULP = DLAMCH( 'Epsilon' )
+*
+* Do Test 1
+*
+* Compute the 1-norm of A.
+*
+ IF( N.GT.1 ) THEN
+ ANORM = ABS( AD( 1 ) ) + ABS( AE( 1 ) )
+ DO 10 J = 2, N - 1
+ ANORM = MAX( ANORM, ABS( AD( J ) )+ABS( AE( J ) )+
+ $ ABS( AE( J-1 ) ) )
+ 10 CONTINUE
+ ANORM = MAX( ANORM, ABS( AD( N ) )+ABS( AE( N-1 ) ) )
+ ELSE
+ ANORM = ABS( AD( 1 ) )
+ END IF
+ ANORM = MAX( ANORM, UNFL )
+*
+* Norm of U'AU - S
+*
+ DO 40 I = 1, M
+ DO 30 J = 1, M
+ WORK( I, J ) = ZERO
+ DO 20 K = 1, N
+ AUKJ = AD( K )*U( K, J )
+ IF( K.NE.N )
+ $ AUKJ = AUKJ + AE( K )*U( K+1, J )
+ IF( K.NE.1 )
+ $ AUKJ = AUKJ + AE( K-1 )*U( K-1, J )
+ WORK( I, J ) = WORK( I, J ) + U( K, I )*AUKJ
+ 20 CONTINUE
+ 30 CONTINUE
+ WORK( I, I ) = WORK( I, I ) - SD( I )
+ IF( KBAND.EQ.1 ) THEN
+ IF( I.NE.1 )
+ $ WORK( I, I-1 ) = WORK( I, I-1 ) - SE( I-1 )
+ IF( I.NE.N )
+ $ WORK( I, I+1 ) = WORK( I, I+1 ) - SE( I )
+ END IF
+ 40 CONTINUE
+*
+ WNORM = DLANSY( '1', 'L', M, WORK, M, WORK( 1, M+1 ) )
+*
+ IF( ANORM.GT.WNORM ) THEN
+ RESULT( 1 ) = ( WNORM / ANORM ) / ( M*ULP )
+ ELSE
+ IF( ANORM.LT.ONE ) THEN
+ RESULT( 1 ) = ( MIN( WNORM, M*ANORM ) / ANORM ) / ( M*ULP )
+ ELSE
+ RESULT( 1 ) = MIN( WNORM / ANORM, DBLE( M ) ) / ( M*ULP )
+ END IF
+ END IF
+*
+* Do Test 2
+*
+* Compute U'U - I
+*
+ CALL DGEMM( 'T', 'N', M, M, N, ONE, U, LDU, U, LDU, ZERO, WORK,
+ $ M )
+*
+ DO 50 J = 1, M
+ WORK( J, J ) = WORK( J, J ) - ONE
+ 50 CONTINUE
+*
+ RESULT( 2 ) = MIN( DBLE( M ), DLANGE( '1', M, M, WORK, M, WORK( 1,
+ $ M+1 ) ) ) / ( M*ULP )
+*
+ RETURN
+*
+* End of DSTT22
+*
+ END
+ SUBROUTINE DSVDCH( N, S, E, SVD, TOL, INFO )
+*
+* -- LAPACK test routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER INFO, N
+ DOUBLE PRECISION TOL
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION E( * ), S( * ), SVD( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DSVDCH checks to see if SVD(1) ,..., SVD(N) are accurate singular
+* values of the bidiagonal matrix B with diagonal entries
+* S(1) ,..., S(N) and superdiagonal entries E(1) ,..., E(N-1)).
+* It does this by expanding each SVD(I) into an interval
+* [SVD(I) * (1-EPS) , SVD(I) * (1+EPS)], merging overlapping intervals
+* if any, and using Sturm sequences to count and verify whether each
+* resulting interval has the correct number of singular values (using
+* DSVDCT). Here EPS=TOL*MAX(N/10,1)*MAZHEP, where MACHEP is the
+* machine precision. The routine assumes the singular values are sorted
+* with SVD(1) the largest and SVD(N) smallest. If each interval
+* contains the correct number of singular values, INFO = 0 is returned,
+* otherwise INFO is the index of the first singular value in the first
+* bad interval.
+*
+* Arguments
+* ==========
+*
+* N (input) INTEGER
+* The dimension of the bidiagonal matrix B.
+*
+* S (input) DOUBLE PRECISION array, dimension (N)
+* The diagonal entries of the bidiagonal matrix B.
+*
+* E (input) DOUBLE PRECISION array, dimension (N-1)
+* The superdiagonal entries of the bidiagonal matrix B.
+*
+* SVD (input) DOUBLE PRECISION array, dimension (N)
+* The computed singular values to be checked.
+*
+* TOL (input) DOUBLE PRECISION
+* Error tolerance for checking, a multiplier of the
+* machine precision.
+*
+* INFO (output) INTEGER
+* =0 if the singular values are all correct (to within
+* 1 +- TOL*MAZHEPS)
+* >0 if the interval containing the INFO-th singular value
+* contains the incorrect number of singular values.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE
+ PARAMETER ( ONE = 1.0D0 )
+ DOUBLE PRECISION ZERO
+ PARAMETER ( ZERO = 0.0D0 )
+* ..
+* .. Local Scalars ..
+ INTEGER BPNT, COUNT, NUML, NUMU, TPNT
+ DOUBLE PRECISION EPS, LOWER, OVFL, TUPPR, UNFL, UNFLEP, UPPER
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DLAMCH
+ EXTERNAL DLAMCH
+* ..
+* .. External Subroutines ..
+ EXTERNAL DSVDCT
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, SQRT
+* ..
+* .. Executable Statements ..
+*
+* Get machine constants
+*
+ INFO = 0
+ IF( N.LE.0 )
+ $ RETURN
+ UNFL = DLAMCH( 'Safe minimum' )
+ OVFL = DLAMCH( 'Overflow' )
+ EPS = DLAMCH( 'Epsilon' )*DLAMCH( 'Base' )
+*
+* UNFLEP is chosen so that when an eigenvalue is multiplied by the
+* scale factor sqrt(OVFL)*sqrt(sqrt(UNFL))/MX in DSVDCT, it exceeds
+* sqrt(UNFL), which is the lower limit for DSVDCT.
+*
+ UNFLEP = ( SQRT( SQRT( UNFL ) ) / SQRT( OVFL ) )*SVD( 1 ) +
+ $ UNFL / EPS
+*
+* The value of EPS works best when TOL .GE. 10.
+*
+ EPS = TOL*MAX( N / 10, 1 )*EPS
+*
+* TPNT points to singular value at right endpoint of interval
+* BPNT points to singular value at left endpoint of interval
+*
+ TPNT = 1
+ BPNT = 1
+*
+* Begin loop over all intervals
+*
+ 10 CONTINUE
+ UPPER = ( ONE+EPS )*SVD( TPNT ) + UNFLEP
+ LOWER = ( ONE-EPS )*SVD( BPNT ) - UNFLEP
+ IF( LOWER.LE.UNFLEP )
+ $ LOWER = -UPPER
+*
+* Begin loop merging overlapping intervals
+*
+ 20 CONTINUE
+ IF( BPNT.EQ.N )
+ $ GO TO 30
+ TUPPR = ( ONE+EPS )*SVD( BPNT+1 ) + UNFLEP
+ IF( TUPPR.LT.LOWER )
+ $ GO TO 30
+*
+* Merge
+*
+ BPNT = BPNT + 1
+ LOWER = ( ONE-EPS )*SVD( BPNT ) - UNFLEP
+ IF( LOWER.LE.UNFLEP )
+ $ LOWER = -UPPER
+ GO TO 20
+ 30 CONTINUE
+*
+* Count singular values in interval [ LOWER, UPPER ]
+*
+ CALL DSVDCT( N, S, E, LOWER, NUML )
+ CALL DSVDCT( N, S, E, UPPER, NUMU )
+ COUNT = NUMU - NUML
+ IF( LOWER.LT.ZERO )
+ $ COUNT = COUNT / 2
+ IF( COUNT.NE.BPNT-TPNT+1 ) THEN
+*
+* Wrong number of singular values in interval
+*
+ INFO = TPNT
+ GO TO 40
+ END IF
+ TPNT = BPNT + 1
+ BPNT = TPNT
+ IF( TPNT.LE.N )
+ $ GO TO 10
+ 40 CONTINUE
+ RETURN
+*
+* End of DSVDCH
+*
+ END
+ SUBROUTINE DSVDCT( N, S, E, SHIFT, NUM )
+*
+* -- LAPACK test routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER N, NUM
+ DOUBLE PRECISION SHIFT
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION E( * ), S( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DSVDCT counts the number NUM of eigenvalues of a 2*N by 2*N
+* tridiagonal matrix T which are less than or equal to SHIFT. T is
+* formed by putting zeros on the diagonal and making the off-diagonals
+* equal to S(1), E(1), S(2), E(2), ... , E(N-1), S(N). If SHIFT is
+* positive, NUM is equal to N plus the number of singular values of a
+* bidiagonal matrix B less than or equal to SHIFT. Here B has diagonal
+* entries S(1), ..., S(N) and superdiagonal entries E(1), ... E(N-1).
+* If SHIFT is negative, NUM is equal to the number of singular values
+* of B greater than or equal to -SHIFT.
+*
+* See W. Kahan "Accurate Eigenvalues of a Symmetric Tridiagonal
+* Matrix", Report CS41, Computer Science Dept., Stanford University,
+* July 21, 1966
+*
+* Arguments
+* =========
+*
+* N (input) INTEGER
+* The dimension of the bidiagonal matrix B.
+*
+* S (input) DOUBLE PRECISION array, dimension (N)
+* The diagonal entries of the bidiagonal matrix B.
+*
+* E (input) DOUBLE PRECISION array of dimension (N-1)
+* The superdiagonal entries of the bidiagonal matrix B.
+*
+* SHIFT (input) DOUBLE PRECISION
+* The shift, used as described under Purpose.
+*
+* NUM (output) INTEGER
+* The number of eigenvalues of T less than or equal to SHIFT.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE
+ PARAMETER ( ONE = 1.0D0 )
+ DOUBLE PRECISION ZERO
+ PARAMETER ( ZERO = 0.0D0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I
+ DOUBLE PRECISION M1, M2, MX, OVFL, SOV, SSHIFT, SSUN, SUN, TMP,
+ $ TOM, U, UNFL
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DLAMCH
+ EXTERNAL DLAMCH
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, SQRT
+* ..
+* .. Executable Statements ..
+*
+* Get machine constants
+*
+ UNFL = 2*DLAMCH( 'Safe minimum' )
+ OVFL = ONE / UNFL
+*
+* Find largest entry
+*
+ MX = ABS( S( 1 ) )
+ DO 10 I = 1, N - 1
+ MX = MAX( MX, ABS( S( I+1 ) ), ABS( E( I ) ) )
+ 10 CONTINUE
+*
+ IF( MX.EQ.ZERO ) THEN
+ IF( SHIFT.LT.ZERO ) THEN
+ NUM = 0
+ ELSE
+ NUM = 2*N
+ END IF
+ RETURN
+ END IF
+*
+* Compute scale factors as in Kahan's report
+*
+ SUN = SQRT( UNFL )
+ SSUN = SQRT( SUN )
+ SOV = SQRT( OVFL )
+ TOM = SSUN*SOV
+ IF( MX.LE.ONE ) THEN
+ M1 = ONE / MX
+ M2 = TOM
+ ELSE
+ M1 = ONE
+ M2 = TOM / MX
+ END IF
+*
+* Begin counting
+*
+ U = ONE
+ NUM = 0
+ SSHIFT = ( SHIFT*M1 )*M2
+ U = -SSHIFT
+ IF( U.LE.SUN ) THEN
+ IF( U.LE.ZERO ) THEN
+ NUM = NUM + 1
+ IF( U.GT.-SUN )
+ $ U = -SUN
+ ELSE
+ U = SUN
+ END IF
+ END IF
+ TMP = ( S( 1 )*M1 )*M2
+ U = -TMP*( TMP / U ) - SSHIFT
+ IF( U.LE.SUN ) THEN
+ IF( U.LE.ZERO ) THEN
+ NUM = NUM + 1
+ IF( U.GT.-SUN )
+ $ U = -SUN
+ ELSE
+ U = SUN
+ END IF
+ END IF
+ DO 20 I = 1, N - 1
+ TMP = ( E( I )*M1 )*M2
+ U = -TMP*( TMP / U ) - SSHIFT
+ IF( U.LE.SUN ) THEN
+ IF( U.LE.ZERO ) THEN
+ NUM = NUM + 1
+ IF( U.GT.-SUN )
+ $ U = -SUN
+ ELSE
+ U = SUN
+ END IF
+ END IF
+ TMP = ( S( I+1 )*M1 )*M2
+ U = -TMP*( TMP / U ) - SSHIFT
+ IF( U.LE.SUN ) THEN
+ IF( U.LE.ZERO ) THEN
+ NUM = NUM + 1
+ IF( U.GT.-SUN )
+ $ U = -SUN
+ ELSE
+ U = SUN
+ END IF
+ END IF
+ 20 CONTINUE
+ RETURN
+*
+* End of DSVDCT
+*
+ END
+ DOUBLE PRECISION FUNCTION DSXT1( IJOB, D1, N1, D2, N2, ABSTOL,
+ $ ULP, UNFL )
+*
+* -- LAPACK test routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER IJOB, N1, N2
+ DOUBLE PRECISION ABSTOL, ULP, UNFL
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION D1( * ), D2( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DSXT1 computes the difference between a set of eigenvalues.
+* The result is returned as the function value.
+*
+* IJOB = 1: Computes max { min | D1(i)-D2(j) | }
+* i j
+*
+* IJOB = 2: Computes max { min | D1(i)-D2(j) | /
+* i j
+* ( ABSTOL + |D1(i)|*ULP ) }
+*
+* Arguments
+* =========
+*
+* ITYPE (input) INTEGER
+* Specifies the type of tests to be performed. (See above.)
+*
+* D1 (input) DOUBLE PRECISION array, dimension (N1)
+* The first array. D1 should be in increasing order, i.e.,
+* D1(j) <= D1(j+1).
+*
+* N1 (input) INTEGER
+* The length of D1.
+*
+* D2 (input) DOUBLE PRECISION array, dimension (N2)
+* The second array. D2 should be in increasing order, i.e.,
+* D2(j) <= D2(j+1).
+*
+* N2 (input) INTEGER
+* The length of D2.
+*
+* ABSTOL (input) DOUBLE PRECISION
+* The absolute tolerance, used as a measure of the error.
+*
+* ULP (input) DOUBLE PRECISION
+* Machine precision.
+*
+* UNFL (input) DOUBLE PRECISION
+* The smallest positive number whose reciprocal does not
+* overflow.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO
+ PARAMETER ( ZERO = 0.0D0 )
+* ..
+* .. Local Scalars ..
+ INTEGER I, J
+ DOUBLE PRECISION TEMP1, TEMP2
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+ TEMP1 = ZERO
+*
+ J = 1
+ DO 20 I = 1, N1
+ 10 CONTINUE
+ IF( D2( J ).LT.D1( I ) .AND. J.LT.N2 ) THEN
+ J = J + 1
+ GO TO 10
+ END IF
+ IF( J.EQ.1 ) THEN
+ TEMP2 = ABS( D2( J )-D1( I ) )
+ IF( IJOB.EQ.2 )
+ $ TEMP2 = TEMP2 / MAX( UNFL, ABSTOL+ULP*ABS( D1( I ) ) )
+ ELSE
+ TEMP2 = MIN( ABS( D2( J )-D1( I ) ),
+ $ ABS( D1( I )-D2( J-1 ) ) )
+ IF( IJOB.EQ.2 )
+ $ TEMP2 = TEMP2 / MAX( UNFL, ABSTOL+ULP*ABS( D1( I ) ) )
+ END IF
+ TEMP1 = MAX( TEMP1, TEMP2 )
+ 20 CONTINUE
+*
+ DSXT1 = TEMP1
+ RETURN
+*
+* End of DSXT1
+*
+ END
+ SUBROUTINE DSYT21( ITYPE, UPLO, N, KBAND, A, LDA, D, E, U, LDU, V,
+ $ LDV, TAU, WORK, RESULT )
+*
+* -- LAPACK test routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER ITYPE, KBAND, LDA, LDU, LDV, N
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION A( LDA, * ), D( * ), E( * ), RESULT( 2 ),
+ $ TAU( * ), U( LDU, * ), V( LDV, * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DSYT21 generally checks a decomposition of the form
+*
+* A = U S U'
+*
+* where ' means transpose, A is symmetric, U is orthogonal, and S is
+* diagonal (if KBAND=0) or symmetric tridiagonal (if KBAND=1).
+*
+* If ITYPE=1, then U is represented as a dense matrix; otherwise U is
+* expressed as a product of Householder transformations, whose vectors
+* are stored in the array "V" and whose scaling constants are in "TAU".
+* We shall use the letter "V" to refer to the product of Householder
+* transformations (which should be equal to U).
+*
+* Specifically, if ITYPE=1, then:
+*
+* RESULT(1) = | A - U S U' | / ( |A| n ulp ) *and*
+* RESULT(2) = | I - UU' | / ( n ulp )
+*
+* If ITYPE=2, then:
+*
+* RESULT(1) = | A - V S V' | / ( |A| n ulp )
+*
+* If ITYPE=3, then:
+*
+* RESULT(1) = | I - VU' | / ( n ulp )
+*
+* For ITYPE > 1, the transformation U is expressed as a product
+* V = H(1)...H(n-2), where H(j) = I - tau(j) v(j) v(j)' and each
+* vector v(j) has its first j elements 0 and the remaining n-j elements
+* stored in V(j+1:n,j).
+*
+* Arguments
+* =========
+*
+* ITYPE (input) INTEGER
+* Specifies the type of tests to be performed.
+* 1: U expressed as a dense orthogonal matrix:
+* RESULT(1) = | A - U S U' | / ( |A| n ulp ) *and*
+* RESULT(2) = | I - UU' | / ( n ulp )
+*
+* 2: U expressed as a product V of Housholder transformations:
+* RESULT(1) = | A - V S V' | / ( |A| n ulp )
+*
+* 3: U expressed both as a dense orthogonal matrix and
+* as a product of Housholder transformations:
+* RESULT(1) = | I - VU' | / ( n ulp )
+*
+* UPLO (input) CHARACTER
+* If UPLO='U', the upper triangle of A and V will be used and
+* the (strictly) lower triangle will not be referenced.
+* If UPLO='L', the lower triangle of A and V will be used and
+* the (strictly) upper triangle will not be referenced.
+*
+* N (input) INTEGER
+* The size of the matrix. If it is zero, DSYT21 does nothing.
+* It must be at least zero.
+*
+* KBAND (input) INTEGER
+* The bandwidth of the matrix. It may only be zero or one.
+* If zero, then S is diagonal, and E is not referenced. If
+* one, then S is symmetric tri-diagonal.
+*
+* A (input) DOUBLE PRECISION array, dimension (LDA, N)
+* The original (unfactored) matrix. It is assumed to be
+* symmetric, and only the upper (UPLO='U') or only the lower
+* (UPLO='L') will be referenced.
+*
+* LDA (input) INTEGER
+* The leading dimension of A. It must be at least 1
+* and at least N.
+*
+* D (input) DOUBLE PRECISION array, dimension (N)
+* The diagonal of the (symmetric tri-) diagonal matrix.
+*
+* E (input) DOUBLE PRECISION array, dimension (N-1)
+* The off-diagonal of the (symmetric tri-) diagonal matrix.
+* E(1) is the (1,2) and (2,1) element, E(2) is the (2,3) and
+* (3,2) element, etc.
+* Not referenced if KBAND=0.
+*
+* U (input) DOUBLE PRECISION array, dimension (LDU, N)
+* If ITYPE=1 or 3, this contains the orthogonal matrix in
+* the decomposition, expressed as a dense matrix. If ITYPE=2,
+* then it is not referenced.
+*
+* LDU (input) INTEGER
+* The leading dimension of U. LDU must be at least N and
+* at least 1.
+*
+* V (input) DOUBLE PRECISION array, dimension (LDV, N)
+* If ITYPE=2 or 3, the columns of this array contain the
+* Householder vectors used to describe the orthogonal matrix
+* in the decomposition. If UPLO='L', then the vectors are in
+* the lower triangle, if UPLO='U', then in the upper
+* triangle.
+* *NOTE* If ITYPE=2 or 3, V is modified and restored. The
+* subdiagonal (if UPLO='L') or the superdiagonal (if UPLO='U')
+* is set to one, and later reset to its original value, during
+* the course of the calculation.
+* If ITYPE=1, then it is neither referenced nor modified.
+*
+* LDV (input) INTEGER
+* The leading dimension of V. LDV must be at least N and
+* at least 1.
+*
+* TAU (input) DOUBLE PRECISION array, dimension (N)
+* If ITYPE >= 2, then TAU(j) is the scalar factor of
+* v(j) v(j)' in the Householder transformation H(j) of
+* the product U = H(1)...H(n-2)
+* If ITYPE < 2, then TAU is not referenced.
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension (2*N**2)
+*
+* RESULT (output) DOUBLE PRECISION array, dimension (2)
+* The values computed by the two tests described above. The
+* values are currently limited to 1/ulp, to avoid overflow.
+* RESULT(1) is always modified. RESULT(2) is modified only
+* if ITYPE=1.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE, TEN
+ PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0, TEN = 10.0D0 )
+* ..
+* .. Local Scalars ..
+ LOGICAL LOWER
+ CHARACTER CUPLO
+ INTEGER IINFO, J, JCOL, JR, JROW
+ DOUBLE PRECISION ANORM, ULP, UNFL, VSAVE, WNORM
+* ..
+* .. External Functions ..
+ LOGICAL LSAME
+ DOUBLE PRECISION DLAMCH, DLANGE, DLANSY
+ EXTERNAL LSAME, DLAMCH, DLANGE, DLANSY
+* ..
+* .. External Subroutines ..
+ EXTERNAL DGEMM, DLACPY, DLARFY, DLASET, DORM2L, DORM2R,
+ $ DSYR, DSYR2
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC DBLE, MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+ RESULT( 1 ) = ZERO
+ IF( ITYPE.EQ.1 )
+ $ RESULT( 2 ) = ZERO
+ IF( N.LE.0 )
+ $ RETURN
+*
+ IF( LSAME( UPLO, 'U' ) ) THEN
+ LOWER = .FALSE.
+ CUPLO = 'U'
+ ELSE
+ LOWER = .TRUE.
+ CUPLO = 'L'
+ END IF
+*
+ UNFL = DLAMCH( 'Safe minimum' )
+ ULP = DLAMCH( 'Epsilon' )*DLAMCH( 'Base' )
+*
+* Some Error Checks
+*
+ IF( ITYPE.LT.1 .OR. ITYPE.GT.3 ) THEN
+ RESULT( 1 ) = TEN / ULP
+ RETURN
+ END IF
+*
+* Do Test 1
+*
+* Norm of A:
+*
+ IF( ITYPE.EQ.3 ) THEN
+ ANORM = ONE
+ ELSE
+ ANORM = MAX( DLANSY( '1', CUPLO, N, A, LDA, WORK ), UNFL )
+ END IF
+*
+* Compute error matrix:
+*
+ IF( ITYPE.EQ.1 ) THEN
+*
+* ITYPE=1: error = A - U S U'
+*
+ CALL DLASET( 'Full', N, N, ZERO, ZERO, WORK, N )
+ CALL DLACPY( CUPLO, N, N, A, LDA, WORK, N )
+*
+ DO 10 J = 1, N
+ CALL DSYR( CUPLO, N, -D( J ), U( 1, J ), 1, WORK, N )
+ 10 CONTINUE
+*
+ IF( N.GT.1 .AND. KBAND.EQ.1 ) THEN
+ DO 20 J = 1, N - 1
+ CALL DSYR2( CUPLO, N, -E( J ), U( 1, J ), 1, U( 1, J+1 ),
+ $ 1, WORK, N )
+ 20 CONTINUE
+ END IF
+ WNORM = DLANSY( '1', CUPLO, N, WORK, N, WORK( N**2+1 ) )
+*
+ ELSE IF( ITYPE.EQ.2 ) THEN
+*
+* ITYPE=2: error = V S V' - A
+*
+ CALL DLASET( 'Full', N, N, ZERO, ZERO, WORK, N )
+*
+ IF( LOWER ) THEN
+ WORK( N**2 ) = D( N )
+ DO 40 J = N - 1, 1, -1
+ IF( KBAND.EQ.1 ) THEN
+ WORK( ( N+1 )*( J-1 )+2 ) = ( ONE-TAU( J ) )*E( J )
+ DO 30 JR = J + 2, N
+ WORK( ( J-1 )*N+JR ) = -TAU( J )*E( J )*V( JR, J )
+ 30 CONTINUE
+ END IF
+*
+ VSAVE = V( J+1, J )
+ V( J+1, J ) = ONE
+ CALL DLARFY( 'L', N-J, V( J+1, J ), 1, TAU( J ),
+ $ WORK( ( N+1 )*J+1 ), N, WORK( N**2+1 ) )
+ V( J+1, J ) = VSAVE
+ WORK( ( N+1 )*( J-1 )+1 ) = D( J )
+ 40 CONTINUE
+ ELSE
+ WORK( 1 ) = D( 1 )
+ DO 60 J = 1, N - 1
+ IF( KBAND.EQ.1 ) THEN
+ WORK( ( N+1 )*J ) = ( ONE-TAU( J ) )*E( J )
+ DO 50 JR = 1, J - 1
+ WORK( J*N+JR ) = -TAU( J )*E( J )*V( JR, J+1 )
+ 50 CONTINUE
+ END IF
+*
+ VSAVE = V( J, J+1 )
+ V( J, J+1 ) = ONE
+ CALL DLARFY( 'U', J, V( 1, J+1 ), 1, TAU( J ), WORK, N,
+ $ WORK( N**2+1 ) )
+ V( J, J+1 ) = VSAVE
+ WORK( ( N+1 )*J+1 ) = D( J+1 )
+ 60 CONTINUE
+ END IF
+*
+ DO 90 JCOL = 1, N
+ IF( LOWER ) THEN
+ DO 70 JROW = JCOL, N
+ WORK( JROW+N*( JCOL-1 ) ) = WORK( JROW+N*( JCOL-1 ) )
+ $ - A( JROW, JCOL )
+ 70 CONTINUE
+ ELSE
+ DO 80 JROW = 1, JCOL
+ WORK( JROW+N*( JCOL-1 ) ) = WORK( JROW+N*( JCOL-1 ) )
+ $ - A( JROW, JCOL )
+ 80 CONTINUE
+ END IF
+ 90 CONTINUE
+ WNORM = DLANSY( '1', CUPLO, N, WORK, N, WORK( N**2+1 ) )
+*
+ ELSE IF( ITYPE.EQ.3 ) THEN
+*
+* ITYPE=3: error = U V' - I
+*
+ IF( N.LT.2 )
+ $ RETURN
+ CALL DLACPY( ' ', N, N, U, LDU, WORK, N )
+ IF( LOWER ) THEN
+ CALL DORM2R( 'R', 'T', N, N-1, N-1, V( 2, 1 ), LDV, TAU,
+ $ WORK( N+1 ), N, WORK( N**2+1 ), IINFO )
+ ELSE
+ CALL DORM2L( 'R', 'T', N, N-1, N-1, V( 1, 2 ), LDV, TAU,
+ $ WORK, N, WORK( N**2+1 ), IINFO )
+ END IF
+ IF( IINFO.NE.0 ) THEN
+ RESULT( 1 ) = TEN / ULP
+ RETURN
+ END IF
+*
+ DO 100 J = 1, N
+ WORK( ( N+1 )*( J-1 )+1 ) = WORK( ( N+1 )*( J-1 )+1 ) - ONE
+ 100 CONTINUE
+*
+ WNORM = DLANGE( '1', N, N, WORK, N, WORK( N**2+1 ) )
+ END IF
+*
+ IF( ANORM.GT.WNORM ) THEN
+ RESULT( 1 ) = ( WNORM / ANORM ) / ( N*ULP )
+ ELSE
+ IF( ANORM.LT.ONE ) THEN
+ RESULT( 1 ) = ( MIN( WNORM, N*ANORM ) / ANORM ) / ( N*ULP )
+ ELSE
+ RESULT( 1 ) = MIN( WNORM / ANORM, DBLE( N ) ) / ( N*ULP )
+ END IF
+ END IF
+*
+* Do Test 2
+*
+* Compute UU' - I
+*
+ IF( ITYPE.EQ.1 ) THEN
+ CALL DGEMM( 'N', 'C', N, N, N, ONE, U, LDU, U, LDU, ZERO, WORK,
+ $ N )
+*
+ DO 110 J = 1, N
+ WORK( ( N+1 )*( J-1 )+1 ) = WORK( ( N+1 )*( J-1 )+1 ) - ONE
+ 110 CONTINUE
+*
+ RESULT( 2 ) = MIN( DLANGE( '1', N, N, WORK, N,
+ $ WORK( N**2+1 ) ), DBLE( N ) ) / ( N*ULP )
+ END IF
+*
+ RETURN
+*
+* End of DSYT21
+*
+ END
+ SUBROUTINE DSYT22( ITYPE, UPLO, N, M, KBAND, A, LDA, D, E, U, LDU,
+ $ V, LDV, TAU, WORK, RESULT )
+*
+* -- LAPACK test routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER UPLO
+ INTEGER ITYPE, KBAND, LDA, LDU, LDV, M, N
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION A( LDA, * ), D( * ), E( * ), RESULT( 2 ),
+ $ TAU( * ), U( LDU, * ), V( LDV, * ), WORK( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DSYT22 generally checks a decomposition of the form
+*
+* A U = U S
+*
+* where A is symmetric, the columns of U are orthonormal, and S
+* is diagonal (if KBAND=0) or symmetric tridiagonal (if
+* KBAND=1). If ITYPE=1, then U is represented as a dense matrix,
+* otherwise the U is expressed as a product of Householder
+* transformations, whose vectors are stored in the array "V" and
+* whose scaling constants are in "TAU"; we shall use the letter
+* "V" to refer to the product of Householder transformations
+* (which should be equal to U).
+*
+* Specifically, if ITYPE=1, then:
+*
+* RESULT(1) = | U' A U - S | / ( |A| m ulp ) *and*
+* RESULT(2) = | I - U'U | / ( m ulp )
+*
+* Arguments
+* =========
+*
+* ITYPE INTEGER
+* Specifies the type of tests to be performed.
+* 1: U expressed as a dense orthogonal matrix:
+* RESULT(1) = | A - U S U' | / ( |A| n ulp ) *and*
+* RESULT(2) = | I - UU' | / ( n ulp )
+*
+* UPLO CHARACTER
+* If UPLO='U', the upper triangle of A will be used and the
+* (strictly) lower triangle will not be referenced. If
+* UPLO='L', the lower triangle of A will be used and the
+* (strictly) upper triangle will not be referenced.
+* Not modified.
+*
+* N INTEGER
+* The size of the matrix. If it is zero, DSYT22 does nothing.
+* It must be at least zero.
+* Not modified.
+*
+* M INTEGER
+* The number of columns of U. If it is zero, DSYT22 does
+* nothing. It must be at least zero.
+* Not modified.
+*
+* KBAND INTEGER
+* The bandwidth of the matrix. It may only be zero or one.
+* If zero, then S is diagonal, and E is not referenced. If
+* one, then S is symmetric tri-diagonal.
+* Not modified.
+*
+* A DOUBLE PRECISION array, dimension (LDA , N)
+* The original (unfactored) matrix. It is assumed to be
+* symmetric, and only the upper (UPLO='U') or only the lower
+* (UPLO='L') will be referenced.
+* Not modified.
+*
+* LDA INTEGER
+* The leading dimension of A. It must be at least 1
+* and at least N.
+* Not modified.
+*
+* D DOUBLE PRECISION array, dimension (N)
+* The diagonal of the (symmetric tri-) diagonal matrix.
+* Not modified.
+*
+* E DOUBLE PRECISION array, dimension (N)
+* The off-diagonal of the (symmetric tri-) diagonal matrix.
+* E(1) is ignored, E(2) is the (1,2) and (2,1) element, etc.
+* Not referenced if KBAND=0.
+* Not modified.
+*
+* U DOUBLE PRECISION array, dimension (LDU, N)
+* If ITYPE=1 or 3, this contains the orthogonal matrix in
+* the decomposition, expressed as a dense matrix. If ITYPE=2,
+* then it is not referenced.
+* Not modified.
+*
+* LDU INTEGER
+* The leading dimension of U. LDU must be at least N and
+* at least 1.
+* Not modified.
+*
+* V DOUBLE PRECISION array, dimension (LDV, N)
+* If ITYPE=2 or 3, the lower triangle of this array contains
+* the Householder vectors used to describe the orthogonal
+* matrix in the decomposition. If ITYPE=1, then it is not
+* referenced.
+* Not modified.
+*
+* LDV INTEGER
+* The leading dimension of V. LDV must be at least N and
+* at least 1.
+* Not modified.
+*
+* TAU DOUBLE PRECISION array, dimension (N)
+* If ITYPE >= 2, then TAU(j) is the scalar factor of
+* v(j) v(j)' in the Householder transformation H(j) of
+* the product U = H(1)...H(n-2)
+* If ITYPE < 2, then TAU is not referenced.
+* Not modified.
+*
+* WORK DOUBLE PRECISION array, dimension (2*N**2)
+* Workspace.
+* Modified.
+*
+* RESULT DOUBLE PRECISION array, dimension (2)
+* The values computed by the two tests described above. The
+* values are currently limited to 1/ulp, to avoid overflow.
+* RESULT(1) is always modified. RESULT(2) is modified only
+* if LDU is at least N.
+* Modified.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE
+ PARAMETER ( ZERO = 0.0D0, ONE = 1.0D0 )
+* ..
+* .. Local Scalars ..
+ INTEGER J, JJ, JJ1, JJ2, NN, NNP1
+ DOUBLE PRECISION ANORM, ULP, UNFL, WNORM
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DLAMCH, DLANSY
+ EXTERNAL DLAMCH, DLANSY
+* ..
+* .. External Subroutines ..
+ EXTERNAL DGEMM, DORT01, DSYMM
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC DBLE, MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+ RESULT( 1 ) = ZERO
+ RESULT( 2 ) = ZERO
+ IF( N.LE.0 .OR. M.LE.0 )
+ $ RETURN
+*
+ UNFL = DLAMCH( 'Safe minimum' )
+ ULP = DLAMCH( 'Precision' )
+*
+* Do Test 1
+*
+* Norm of A:
+*
+ ANORM = MAX( DLANSY( '1', UPLO, N, A, LDA, WORK ), UNFL )
+*
+* Compute error matrix:
+*
+* ITYPE=1: error = U' A U - S
+*
+ CALL DSYMM( 'L', UPLO, N, M, ONE, A, LDA, U, LDU, ZERO, WORK, N )
+ NN = N*N
+ NNP1 = NN + 1
+ CALL DGEMM( 'T', 'N', M, M, N, ONE, U, LDU, WORK, N, ZERO,
+ $ WORK( NNP1 ), N )
+ DO 10 J = 1, M
+ JJ = NN + ( J-1 )*N + J
+ WORK( JJ ) = WORK( JJ ) - D( J )
+ 10 CONTINUE
+ IF( KBAND.EQ.1 .AND. N.GT.1 ) THEN
+ DO 20 J = 2, M
+ JJ1 = NN + ( J-1 )*N + J - 1
+ JJ2 = NN + ( J-2 )*N + J
+ WORK( JJ1 ) = WORK( JJ1 ) - E( J-1 )
+ WORK( JJ2 ) = WORK( JJ2 ) - E( J-1 )
+ 20 CONTINUE
+ END IF
+ WNORM = DLANSY( '1', UPLO, M, WORK( NNP1 ), N, WORK( 1 ) )
+*
+ IF( ANORM.GT.WNORM ) THEN
+ RESULT( 1 ) = ( WNORM / ANORM ) / ( M*ULP )
+ ELSE
+ IF( ANORM.LT.ONE ) THEN
+ RESULT( 1 ) = ( MIN( WNORM, M*ANORM ) / ANORM ) / ( M*ULP )
+ ELSE
+ RESULT( 1 ) = MIN( WNORM / ANORM, DBLE( M ) ) / ( M*ULP )
+ END IF
+ END IF
+*
+* Do Test 2
+*
+* Compute U'U - I
+*
+ IF( ITYPE.EQ.1 )
+ $ CALL DORT01( 'Columns', N, M, U, LDU, WORK, 2*N*N,
+ $ RESULT( 2 ) )
+*
+ RETURN
+*
+* End of DSYT22
+*
+ END
+ INTEGER FUNCTION ILAENV( ISPEC, NAME, OPTS, N1, N2, N3,
+ $ N4 )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER*( * ) NAME, OPTS
+ INTEGER ISPEC, N1, N2, N3, N4
+* ..
+*
+* Purpose
+* =======
+*
+* ILAENV returns problem-dependent parameters for the local
+* environment. See ISPEC for a description of the parameters.
+*
+* In this version, the problem-dependent parameters are contained in
+* the integer array IPARMS in the common block CLAENV and the value
+* with index ISPEC is copied to ILAENV. This version of ILAENV is
+* to be used in conjunction with XLAENV in TESTING and TIMING.
+*
+* Arguments
+* =========
+*
+* ISPEC (input) INTEGER
+* Specifies the parameter to be returned as the value of
+* ILAENV.
+* = 1: the optimal blocksize; if this value is 1, an unblocked
+* algorithm will give the best performance.
+* = 2: the minimum block size for which the block routine
+* should be used; if the usable block size is less than
+* this value, an unblocked routine should be used.
+* = 3: the crossover point (in a block routine, for N less
+* than this value, an unblocked routine should be used)
+* = 4: the number of shifts, used in the nonsymmetric
+* eigenvalue routines
+* = 5: the minimum column dimension for blocking to be used;
+* rectangular blocks must have dimension at least k by m,
+* where k is given by ILAENV(2,...) and m by ILAENV(5,...)
+* = 6: the crossover point for the SVD (when reducing an m by n
+* matrix to bidiagonal form, if max(m,n)/min(m,n) exceeds
+* this value, a QR factorization is used first to reduce
+* the matrix to a triangular form.)
+* = 7: the number of processors
+* = 8: the crossover point for the multishift QR and QZ methods
+* for nonsymmetric eigenvalue problems.
+* = 9: maximum size of the subproblems at the bottom of the
+* computation tree in the divide-and-conquer algorithm
+* =10: ieee NaN arithmetic can be trusted not to trap
+* =11: infinity arithmetic can be trusted not to trap
+* 12 <= ISPEC <= 16:
+* xHSEQR or one of its subroutines,
+* see IPARMQ for detailed explanation
+*
+* Other specifications (up to 100) can be added later.
+*
+* NAME (input) CHARACTER*(*)
+* The name of the calling subroutine.
+*
+* OPTS (input) CHARACTER*(*)
+* The character options to the subroutine NAME, concatenated
+* into a single character string. For example, UPLO = 'U',
+* TRANS = 'T', and DIAG = 'N' for a triangular routine would
+* be specified as OPTS = 'UTN'.
+*
+* N1 (input) INTEGER
+* N2 (input) INTEGER
+* N3 (input) INTEGER
+* N4 (input) INTEGER
+* Problem dimensions for the subroutine NAME; these may not all
+* be required.
+*
+* (ILAENV) (output) INTEGER
+* >= 0: the value of the parameter specified by ISPEC
+* < 0: if ILAENV = -k, the k-th argument had an illegal value.
+*
+* Further Details
+* ===============
+*
+* The following conventions have been used when calling ILAENV from the
+* LAPACK routines:
+* 1) OPTS is a concatenation of all of the character options to
+* subroutine NAME, in the same order that they appear in the
+* argument list for NAME, even if they are not used in determining
+* the value of the parameter specified by ISPEC.
+* 2) The problem dimensions N1, N2, N3, N4 are specified in the order
+* that they appear in the argument list for NAME. N1 is used
+* first, N2 second, and so on, and unused problem dimensions are
+* passed a value of -1.
+* 3) The parameter value returned by ILAENV is checked for validity in
+* the calling subroutine. For example, ILAENV is used to retrieve
+* the optimal blocksize for STRTRI as follows:
+*
+* NB = ILAENV( 1, 'STRTRI', UPLO // DIAG, N, -1, -1, -1 )
+* IF( NB.LE.1 ) NB = MAX( 1, N )
+*
+* =====================================================================
+*
+* .. Intrinsic Functions ..
+ INTRINSIC INT, MIN, REAL
+* ..
+* .. External Functions ..
+ INTEGER IEEECK
+ EXTERNAL IEEECK
+* ..
+* .. Arrays in Common ..
+ INTEGER IPARMS( 100 )
+* ..
+* .. Common blocks ..
+ COMMON / CLAENV / IPARMS
+* ..
+* .. Save statement ..
+ SAVE / CLAENV /
+* ..
+* .. Executable Statements ..
+*
+ IF( ISPEC.GE.1 .AND. ISPEC.LE.5 ) THEN
+*
+* Return a value from the common block.
+*
+ ILAENV = IPARMS( ISPEC )
+*
+ ELSE IF( ISPEC.EQ.6 ) THEN
+*
+* Compute SVD crossover point.
+*
+ ILAENV = INT( REAL( MIN( N1, N2 ) )*1.6E0 )
+*
+ ELSE IF( ISPEC.GE.7 .AND. ISPEC.LE.9 ) THEN
+*
+* Return a value from the common block.
+*
+ ILAENV = IPARMS( ISPEC )
+*
+ ELSE IF( ISPEC.EQ.10 ) THEN
+*
+* IEEE NaN arithmetic can be trusted not to trap
+*
+C ILAENV = 0
+ ILAENV = 1
+ IF( ILAENV.EQ.1 ) THEN
+ ILAENV = IEEECK( 0, 0.0, 1.0 )
+ END IF
+*
+ ELSE IF( ISPEC.EQ.11 ) THEN
+*
+* Infinity arithmetic can be trusted not to trap
+*
+C ILAENV = 0
+ ILAENV = 1
+ IF( ILAENV.EQ.1 ) THEN
+ ILAENV = IEEECK( 1, 0.0, 1.0 )
+ END IF
+*
+ ELSE IF(( ISPEC.GE.12 ) .AND. (ISPEC.LE.16)) THEN
+*
+* 12 <= ISPEC <= 16: xHSEQR or one of its subroutines.
+*
+ ILAENV = IPARMS( ISPEC )
+* WRITE(*,*) 'ISPEC = ',ISPEC,' ILAENV =',ILAENV
+* ILAENV = IPARMQ( ISPEC, NAME, OPTS, N1, N2, N3, N4 )
+*
+ ELSE
+*
+* Invalid value for ISPEC
+*
+ ILAENV = -1
+ END IF
+*
+ RETURN
+*
+* End of ILAENV
+*
+ END
+ INTEGER FUNCTION IPARMQ( ISPEC, NAME, OPTS, N, ILO, IHI, LWORK )
+*
+ INTEGER INMIN, INWIN, INIBL, ISHFTS, IACC22
+ PARAMETER ( INMIN = 12, INWIN = 13, INIBL = 14,
+ $ ISHFTS = 15, IACC22 = 16 )
+ INTEGER NMIN, K22MIN, KACMIN, NIBBLE, KNWSWP
+ PARAMETER ( NMIN = 11, K22MIN = 14, KACMIN = 14,
+ $ NIBBLE = 14, KNWSWP = 500 )
+ REAL TWO
+ PARAMETER ( TWO = 2.0 )
+* ..
+* .. Scalar Arguments ..
+ INTEGER IHI, ILO, ISPEC, LWORK, N
+ CHARACTER NAME*( * ), OPTS*( * )
+* ..
+* .. Local Scalars ..
+ INTEGER NH, NS
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC LOG, MAX, MOD, NINT, REAL
+* ..
+* .. Executable Statements ..
+ IF( ( ISPEC.EQ.ISHFTS ) .OR. ( ISPEC.EQ.INWIN ) .OR.
+ $ ( ISPEC.EQ.IACC22 ) ) THEN
+*
+* ==== Set the number simultaneous shifts ====
+*
+ NH = IHI - ILO + 1
+ NS = 2
+ IF( NH.GE.30 )
+ $ NS = 4
+ IF( NH.GE.60 )
+ $ NS = 10
+ IF( NH.GE.150 )
+ $ NS = MAX( 10, NH / NINT( LOG( REAL( NH ) ) / LOG( TWO ) ) )
+ IF( NH.GE.590 )
+ $ NS = 64
+ IF( NH.GE.3000 )
+ $ NS = 128
+ IF( NH.GE.6000 )
+ $ NS = 256
+ NS = MAX( 2, NS-MOD( NS, 2 ) )
+ END IF
+*
+ IF( ISPEC.EQ.INMIN ) THEN
+*
+*
+* ===== Matrices of order smaller than NMIN get sent
+* . to LAHQR, the classic double shift algorithm.
+* . This must be at least 11. ====
+*
+ IPARMQ = NMIN
+*
+ ELSE IF( ISPEC.EQ.INIBL ) THEN
+*
+* ==== INIBL: skip a multi-shift qr iteration and
+* . whenever aggressive early deflation finds
+* . at least (NIBBLE*(window size)/100) deflations. ====
+*
+ IPARMQ = NIBBLE
+*
+ ELSE IF( ISPEC.EQ.ISHFTS ) THEN
+*
+* ==== NSHFTS: The number of simultaneous shifts =====
+*
+ IPARMQ = NS
+*
+ ELSE IF( ISPEC.EQ.INWIN ) THEN
+*
+* ==== NW: deflation window size. ====
+*
+ IF( NH.LE.KNWSWP ) THEN
+ IPARMQ = NS
+ ELSE
+ IPARMQ = 3*NS / 2
+ END IF
+*
+ ELSE IF( ISPEC.EQ.IACC22 ) THEN
+*
+* ==== IACC22: Whether to accumulate reflections
+* . before updating the far-from-diagonal elements
+* . and whether to use 2-by-2 block structure while
+* . doing it. A small amount of work could be saved
+* . by making this choice dependent also upon the
+* . NH=IHI-ILO+1.
+*
+ IPARMQ = 0
+ IF( NS.GE.KACMIN )
+ $ IPARMQ = 1
+ IF( NS.GE.K22MIN )
+ $ IPARMQ = 2
+*
+ ELSE
+* ===== invalid value of ispec =====
+ IPARMQ = -1
+*
+ END IF
+*
+* ==== End of IPARMQ ====
+*
+ END
+ SUBROUTINE XLAENV( ISPEC, NVALUE )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER ISPEC, NVALUE
+* ..
+*
+* Purpose
+* =======
+*
+* XLAENV sets certain machine- and problem-dependent quantities
+* which will later be retrieved by ILAENV.
+*
+* Arguments
+* =========
+*
+* ISPEC (input) INTEGER
+* Specifies the parameter to be set in the COMMON array IPARMS.
+* = 1: the optimal blocksize; if this value is 1, an unblocked
+* algorithm will give the best performance.
+* = 2: the minimum block size for which the block routine
+* should be used; if the usable block size is less than
+* this value, an unblocked routine should be used.
+* = 3: the crossover point (in a block routine, for N less
+* than this value, an unblocked routine should be used)
+* = 4: the number of shifts, used in the nonsymmetric
+* eigenvalue routines
+* = 5: the minimum column dimension for blocking to be used;
+* rectangular blocks must have dimension at least k by m,
+* where k is given by ILAENV(2,...) and m by ILAENV(5,...)
+* = 6: the crossover point for the SVD (when reducing an m by n
+* matrix to bidiagonal form, if max(m,n)/min(m,n) exceeds
+* this value, a QR factorization is used first to reduce
+* the matrix to a triangular form)
+* = 7: the number of processors
+* = 8: another crossover point, for the multishift QR and QZ
+* methods for nonsymmetric eigenvalue problems.
+* = 9: maximum size of the subproblems at the bottom of the
+* computation tree in the divide-and-conquer algorithm
+* (used by xGELSD and xGESDD)
+* =10: ieee NaN arithmetic can be trusted not to trap
+* =11: infinity arithmetic can be trusted not to trap
+* 12 <= ISPEC <= 16:
+* xHSEQR or one of its subroutines,
+* see IPARMQ for detailed explanation
+*
+* NVALUE (input) INTEGER
+* The value of the parameter specified by ISPEC.
+*
+* =====================================================================
+*
+* .. Arrays in Common ..
+ INTEGER IPARMS( 100 )
+* ..
+* .. Common blocks ..
+ COMMON / CLAENV / IPARMS
+* ..
+* .. Save statement ..
+ SAVE / CLAENV /
+* ..
+* .. Executable Statements ..
+*
+ IF( ISPEC.GE.1 .AND. ISPEC.LE.16 ) THEN
+ IPARMS( ISPEC ) = NVALUE
+ END IF
+*
+ RETURN
+*
+* End of XLAENV
+*
+ END
diff --git a/jlapack-3.1.1/src/testing/eig/glm.in b/jlapack-3.1.1/src/testing/eig/glm.in
new file mode 100644
index 0000000..4fddc61
--- /dev/null
+++ b/jlapack-3.1.1/src/testing/eig/glm.in
@@ -0,0 +1,9 @@
+GLM: Data file for testing Generalized Linear Regression Model routines
+6 Number of values of M, P, and N
+0 5 8 15 20 40 Values of M (row dimension)
+9 0 15 12 15 30 Values of P (row dimension)
+5 5 10 25 30 40 Values of N (col dimension), M <= N <= M+P
+20.0 Threshold value of test ratio
+T Put T to test the error exits
+1 Code to interpret the seed
+GLM 8 List types on next line if 0 < NTYPES < 8
diff --git a/jlapack-3.1.1/src/testing/eig/gqr.in b/jlapack-3.1.1/src/testing/eig/gqr.in
new file mode 100644
index 0000000..ccd861c
--- /dev/null
+++ b/jlapack-3.1.1/src/testing/eig/gqr.in
@@ -0,0 +1,9 @@
+GQR: Data file for testing Generalized QR and RQ routines
+3 Number of values of M, P and N
+0 3 10 Values of M
+0 5 20 Values of P
+0 3 30 Values of N
+20.0 Threshold value of test ratio
+T Put T to test the error exits
+1 Code to interpret the seed
+GQR 8 List types on next line if 0 < NTYPES < 8
diff --git a/jlapack-3.1.1/src/testing/eig/gsv.in b/jlapack-3.1.1/src/testing/eig/gsv.in
new file mode 100644
index 0000000..e97211d
--- /dev/null
+++ b/jlapack-3.1.1/src/testing/eig/gsv.in
@@ -0,0 +1,9 @@
+GSV: Data file for testing Generalized SVD routines
+8 Number of values of M, P, N
+0 5 9 10 20 12 12 40 Values of M (row dimension)
+4 0 12 14 10 10 20 15 Values of P (row dimension)
+3 10 15 12 8 20 8 20 Values of N (column dimension)
+20.0 Threshold value of test ratio
+T Put T to test the error exits
+1 Code to interpret the seed
+GSV 8 List types on next line if 0 < NTYPES < 8
diff --git a/jlapack-3.1.1/src/testing/eig/lse.in b/jlapack-3.1.1/src/testing/eig/lse.in
new file mode 100644
index 0000000..5959854
--- /dev/null
+++ b/jlapack-3.1.1/src/testing/eig/lse.in
@@ -0,0 +1,9 @@
+LSE: Data file for testing Constrained Linear Least Squares routines
+6 Number of values of M, P, and N
+6 0 5 8 10 30 Values of M
+0 5 5 5 8 20 Values of P
+5 5 6 8 12 40 Values of N, note P<= N <= P+M
+20.0 Threshold value of test ratio
+T Put T to test the error exits
+1 Code to interpret the seed
+LSE 8 List types on next line if 0 < NTYPES < 8
diff --git a/jlapack-3.1.1/src/testing/eig/nep.in b/jlapack-3.1.1/src/testing/eig/nep.in
new file mode 100644
index 0000000..c4a4149
--- /dev/null
+++ b/jlapack-3.1.1/src/testing/eig/nep.in
@@ -0,0 +1,16 @@
+NEP: Data file for testing Nonsymmetric Eigenvalue Problem routines
+7 Number of values of N
+0 1 2 3 5 10 16 Values of N (dimension)
+5 Number of values of NB, NBMIN, NX, INMIN, IN WIN, INIBL, ISHFTS, and IACC22
+ 1 3 3 3 20 Values of NB (blocksize)
+ 2 2 2 2 2 Values of NBMIN (minimum blocksize)
+ 1 0 5 9 1 Values of NX (crossover point)
+ 11 12 11 15 11 Values of INMIN (LAHQR vs TTQRE crossover point, >= 11)
+ 2 3 5 3 2 Values of INWIN (recommended deflation window size)
+ 0 5 7 3 200 Values of INIBL (nibble crossover point)
+ 1 2 4 2 1 Values of ISHFTS (number of simultaneous shifts)
+ 0 1 2 0 1 Values of IACC22 (select structured matrix multiply: 0, 1 or 2)
+20.0 Threshold value
+T Put T to test the error exits
+1 Code to interpret the seed
+NEP 21
diff --git a/jlapack-3.1.1/src/testing/eig/sep.in b/jlapack-3.1.1/src/testing/eig/sep.in
new file mode 100644
index 0000000..24fae47
--- /dev/null
+++ b/jlapack-3.1.1/src/testing/eig/sep.in
@@ -0,0 +1,13 @@
+SEP: Data file for testing Symmetric Eigenvalue Problem routines
+6 Number of values of N
+0 1 2 3 5 20 Values of N (dimension)
+5 Number of values of NB
+1 3 3 3 10 Values of NB (blocksize)
+2 2 2 2 2 Values of NBMIN (minimum blocksize)
+1 0 5 9 1 Values of NX (crossover point)
+50.0 Threshold value
+T Put T to test the LAPACK routines
+T Put T to test the driver routines
+T Put T to test the error exits
+1 Code to interpret the seed
+SEP 21
diff --git a/jlapack-3.1.1/src/testing/eig/svd.in b/jlapack-3.1.1/src/testing/eig/svd.in
new file mode 100644
index 0000000..fb8e069
--- /dev/null
+++ b/jlapack-3.1.1/src/testing/eig/svd.in
@@ -0,0 +1,15 @@
+SVD: Data file for testing Singular Value Decomposition routines
+19 Number of values of M
+0 0 0 1 1 1 2 2 3 3 3 10 10 16 16 30 30 40 40 Values of M
+0 1 3 0 1 2 0 1 0 1 3 10 16 10 16 30 40 30 40 Values of N
+5 Number of parameter values
+1 3 3 3 20 Values of NB (blocksize)
+2 2 2 2 2 Values of NBMIN (minimum blocksize)
+1 0 5 9 1 Values of NX (crossover point)
+2 0 2 2 2 Values of NRHS
+35.0 Threshold value
+T Put T to test the LAPACK routines
+T Put T to test the driver routines
+T Put T to test the error exits
+1 Code to interpret the seed
+SVD 16
diff --git a/jlapack-3.1.1/src/testing/eig/xerbla.f b/jlapack-3.1.1/src/testing/eig/xerbla.f
new file mode 100644
index 0000000..5e1f541
--- /dev/null
+++ b/jlapack-3.1.1/src/testing/eig/xerbla.f
@@ -0,0 +1,80 @@
+ SUBROUTINE XERBLA( SRNAME, INFO )
+*
+* -- LAPACK auxiliary routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER*6 SRNAME
+ INTEGER INFO
+* ..
+*
+* Purpose
+* =======
+*
+* This is a special version of XERBLA to be used only as part of
+* the test program for testing error exits from the LAPACK routines.
+* Error messages are printed if INFO.NE.INFOT or if SRNAME.NE.SRNAMT,
+* where INFOT and SRNAMT are values stored in COMMON.
+*
+* Arguments
+* =========
+*
+* SRNAME (input) CHARACTER*6
+* The name of the subroutine calling XERBLA. This name should
+* match the COMMON variable SRNAMT.
+*
+* INFO (input) INTEGER
+* The error return code from the calling subroutine. INFO
+* should equal the COMMON variable INFOT.
+*
+* Further Details
+* ======= =======
+*
+* The following variables are passed via the common blocks INFOC and
+* SRNAMC:
+*
+* INFOT INTEGER Expected integer return code
+* NOUT INTEGER Unit number for printing error messages
+* OK LOGICAL Set to .TRUE. if INFO = INFOT and
+* SRNAME = SRNAMT, otherwise set to .FALSE.
+* LERR LOGICAL Set to .TRUE., indicating that XERBLA was called
+* SRNAMT CHARACTER*6 Expected name of calling subroutine
+*
+*
+* .. Scalars in Common ..
+ LOGICAL LERR, OK
+ CHARACTER*6 SRNAMT
+ INTEGER INFOT, NOUT
+* ..
+* .. Common blocks ..
+ COMMON / INFOC / INFOT, NOUT, OK, LERR
+ COMMON / SRNAMC / SRNAMT
+* ..
+* .. Executable Statements ..
+*
+ LERR = .TRUE.
+ IF( INFO.NE.INFOT ) THEN
+ IF( INFOT.NE.0 ) THEN
+ WRITE( NOUT, FMT = 9999 )SRNAMT, INFO, INFOT
+ ELSE
+ WRITE( NOUT, FMT = 9997 )SRNAME, INFO
+ END IF
+ OK = .FALSE.
+ END IF
+ IF( SRNAME.NE.SRNAMT ) THEN
+ WRITE( NOUT, FMT = 9998 )SRNAME, SRNAMT
+ OK = .FALSE.
+ END IF
+ RETURN
+*
+ 9999 FORMAT( ' *** XERBLA was called from ', A6, ' with INFO = ', I6,
+ $ ' instead of ', I2, ' ***' )
+ 9998 FORMAT( ' *** XERBLA was called with SRNAME = ', A6,
+ $ ' instead of ', A6, ' ***' )
+ 9997 FORMAT( ' *** On entry to ', A6, ' parameter number ', I6,
+ $ ' had an illegal value ***' )
+*
+* End of XERBLA
+*
+ END
diff --git a/jlapack-3.1.1/src/testing/lin/Makefile b/jlapack-3.1.1/src/testing/lin/Makefile
new file mode 100644
index 0000000..3f01cc6
--- /dev/null
+++ b/jlapack-3.1.1/src/testing/lin/Makefile
@@ -0,0 +1,47 @@
+.SUFFIXES: .f .java
+
+ROOT=../../..
+include $(ROOT)/make.def
+
+BLAS=$(ROOT)/$(BLAS_DIR)/$(BLAS_JAR)
+LAPACK=$(ROOT)/$(LAPACK_DIR)/$(LAPACK_JAR)
+MATGEN=$(ROOT)/$(MATGEN_DIR)/$(MATGEN_JAR)
+
+XERBLAFLAGS= -c .:$(ROOT)/$(BLAS_OBJ) -p $(ERR_PACKAGE)
+F2JFLAGS=-c .:$(ROOT)/$(BLAS_OBJ):$(ROOT)/$(LAPACK_OBJ):$(ROOT)/$(MATGEN_OBJ) -p $(LINTEST_PACKAGE) -o $(OUTDIR) $(STATIC)
+
+tester: $(BLAS) $(LAPACK) $(MATGEN) $(ROOT)/$(LINTEST_IDX) util
+ /bin/rm -f $(LINTEST_JAR)
+ cd $(OUTDIR); $(JAR) cvf ../$(LINTEST_JAR) `find . -name "*.class"`
+ $(JAR) uvf $(LINTEST_JAR) `find org -name "*.class"`
+
+nojar: $(BLAS) $(LAPACK) $(MATGEN) $(ROOT)/$(LINTEST_IDX) util
+
+$(ROOT)/$(LINTEST_IDX): lintest.f
+ $(F2J) $(XERBLAFLAGS) xerbla.f > /dev/null
+ $(F2J) $(F2JFLAGS) $< > /dev/null
+
+$(BLAS):
+ cd $(ROOT)/$(BLAS_DIR); $(MAKE)
+
+$(LAPACK):
+ cd $(ROOT)/$(LAPACK_DIR); $(MAKE)
+
+$(MATGEN):
+ cd $(ROOT)/$(MATGEN_DIR); $(MAKE)
+
+util:
+ cd $(ROOT)/$(UTIL_DIR); $(MAKE)
+
+runtest: tester
+ $(JAVA) $(JFLAGS) -cp .:$(LINTEST_JAR):$(MATGEN):$(BLAS):$(LAPACK):$(ROOT)/$(UTIL_DIR)/$(UTIL_JAR) $(LINTEST_PACKAGE).Dchkaa < dtest.in
+
+srctest:
+ $(MAKE) -f Makefile_javasrc runtest
+
+verify: $(ROOT)/$(LINTEST_IDX)
+ cd $(OUTDIR); $(JAVA) $(MORE_MEM_FLAG) -classpath .:..:$(JUSTICE):$(BCEL):$(ROOT)/../$(UTIL_DIR)/$(UTIL_JAR):$(ROOT)/../$(ERR_DIR)/$(ERR_JAR):$(ROOT)/../$(MATGEN_DIR)/$(MATGEN_JAR):$(ROOT)/../$(BLAS_DIR)/$(BLAS_JAR):$(ROOT)/../$(LAPACK_DIR)/$(LAPACK_JAR) $(VERIFY) $(LINTEST_PDIR)/*.class
+
+
+clean:
+ /bin/rm -rf *.java *.class *.f2j org $(JAVASRC_OUTDIR) $(OUTDIR) $(LINTEST_JAR)
diff --git a/jlapack-3.1.1/src/testing/lin/Makefile_javasrc b/jlapack-3.1.1/src/testing/lin/Makefile_javasrc
new file mode 100644
index 0000000..fa5aba5
--- /dev/null
+++ b/jlapack-3.1.1/src/testing/lin/Makefile_javasrc
@@ -0,0 +1,42 @@
+.SUFFIXES: .f .java
+
+ROOT=../../..
+include $(ROOT)/make.def
+
+BLAS=$(ROOT)/$(BLAS_DIR)/$(BLAS_JAR)
+LAPACK=$(ROOT)/$(LAPACK_DIR)/$(LAPACK_JAR)
+MATGEN=$(ROOT)/$(MATGEN_DIR)/$(MATGEN_JAR)
+
+tester: $(BLAS) $(LAPACK) $(MATGEN) $(OUTDIR)/Lintest.f2j util
+ /bin/rm -f `find $(OUTDIR) -name "*.class"`
+ mkdir -p $(JAVASRC_OUTDIR)
+ $(JAVAC) -classpath .:$(JAVASRC_OUTDIR):$(ROOT)/$(UTIL_DIR)/$(UTIL_JAR):$(MATGEN):$(BLAS):$(LAPACK) -d $(JAVASRC_OUTDIR) $(OUTDIR)/$(LINTEST_PDIR)/*.java
+ /bin/rm -f $(JAVASRC_OUTDIR)/$(LINTEST_PDIR)/*.old
+ $(JAVAB) $(JAVASRC_OUTDIR)/$(LINTEST_PDIR)/*.class
+ /bin/rm -f $(LINTEST_JAR)
+ cd $(JAVASRC_OUTDIR); $(JAR) cvf ../$(LINTEST_JAR) `find . -name "*.class"`
+ $(JAR) uvf $(LINTEST_JAR) `find org -name "*.class"`
+
+$(OUTDIR)/Lintest.f2j: lintest.f
+ $(MAKE) nojar
+
+$(BLAS):
+ cd $(ROOT)/$(BLAS_DIR); $(MAKE) -f Makefile_javasrc
+
+$(LAPACK):
+ cd $(ROOT)/$(LAPACK_DIR); $(MAKE) -f Makefile_javasrc
+
+$(MATGEN):
+ cd $(ROOT)/$(MATGEN_DIR); $(MAKE) -f Makefile_javasrc
+
+util:
+ cd $(ROOT)/$(UTIL_DIR); $(MAKE)
+
+runtest: tester
+ $(JAVA) $(JFLAGS) -cp .:$(LINTEST_JAR):$(MATGEN):$(BLAS):$(LAPACK):$(ROOT)/$(UTIL_DIR)/$(UTIL_JAR) $(LINTEST_PACKAGE).Dchkaa < dtest.in
+
+verify: $(ROOT)/$(LINTEST_IDX)
+ cd $(JAVASRC_OUTDIR); $(JAVA) $(MORE_MEM_FLAG) -classpath .:..:$(JUSTICE):$(BCEL):$(ROOT)/../$(UTIL_DIR)/$(UTIL_JAR):$(ROOT)/../$(ERR_DIR)/$(ERR_JAR):$(ROOT)/../$(MATGEN_DIR)/$(MATGEN_JAR):$(ROOT)/../$(BLAS_DIR)/$(BLAS_JAR):$(ROOT)/../$(LAPACK_DIR)/$(LAPACK_JAR) $(VERIFY) $(LINTEST_PDIR)/*.class
+
+clean:
+ /bin/rm -rf *.java *.class *.f2j org $(JAVASRC_OUTDIR) $(OUTDIR) $(LINTEST_JAR)
diff --git a/jlapack-3.1.1/src/testing/lin/dtest.in b/jlapack-3.1.1/src/testing/lin/dtest.in
new file mode 100644
index 0000000..7ad8b94
--- /dev/null
+++ b/jlapack-3.1.1/src/testing/lin/dtest.in
@@ -0,0 +1,34 @@
+Data file for testing DOUBLE PRECISION LAPACK linear eqn. routines
+7 Number of values of M
+0 1 2 3 5 10 50 Values of M (row dimension)
+7 Number of values of N
+0 1 2 3 5 10 50 Values of N (column dimension)
+3 Number of values of NRHS
+1 2 15 Values of NRHS (number of right hand sides)
+5 Number of values of NB
+1 3 3 3 20 Values of NB (the blocksize)
+1 0 5 9 1 Values of NX (crossover point)
+30.0 Threshold value of test ratio
+T Put T to test the LAPACK routines
+T Put T to test the driver routines
+T Put T to test the error exits
+DGE 11 List types on next line if 0 < NTYPES < 11
+DGB 8 List types on next line if 0 < NTYPES < 8
+DGT 12 List types on next line if 0 < NTYPES < 12
+DPO 9 List types on next line if 0 < NTYPES < 9
+DPP 9 List types on next line if 0 < NTYPES < 9
+DPB 8 List types on next line if 0 < NTYPES < 8
+DPT 12 List types on next line if 0 < NTYPES < 12
+DSY 10 List types on next line if 0 < NTYPES < 10
+DSP 10 List types on next line if 0 < NTYPES < 10
+DTR 18 List types on next line if 0 < NTYPES < 18
+DTP 18 List types on next line if 0 < NTYPES < 18
+DTB 17 List types on next line if 0 < NTYPES < 17
+DQR 8 List types on next line if 0 < NTYPES < 8
+DRQ 8 List types on next line if 0 < NTYPES < 8
+DLQ 8 List types on next line if 0 < NTYPES < 8
+DQL 8 List types on next line if 0 < NTYPES < 8
+DQP 6 List types on next line if 0 < NTYPES < 6
+DTZ 3 List types on next line if 0 < NTYPES < 3
+DLS 6 List types on next line if 0 < NTYPES < 6
+DEQ
diff --git a/jlapack-3.1.1/src/testing/lin/lintest.f b/jlapack-3.1.1/src/testing/lin/lintest.f
new file mode 100644
index 0000000..b78516a
--- /dev/null
+++ b/jlapack-3.1.1/src/testing/lin/lintest.f
@@ -0,0 +1,36290 @@
+ SUBROUTINE ALADHD( IOUNIT, PATH )
+*
+* -- LAPACK test routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER*3 PATH
+ INTEGER IOUNIT
+* ..
+*
+* Purpose
+* =======
+*
+* ALADHD prints header information for the driver routines test paths.
+*
+* Arguments
+* =========
+*
+* IOUNIT (input) INTEGER
+* The unit number to which the header information should be
+* printed.
+*
+* PATH (input) CHARACTER*3
+* The name of the path for which the header information is to
+* be printed. Current paths are
+* _GE: General matrices
+* _GB: General band
+* _GT: General Tridiagonal
+* _PO: Symmetric or Hermitian positive definite
+* _PP: Symmetric or Hermitian positive definite packed
+* _PB: Symmetric or Hermitian positive definite band
+* _PT: Symmetric or Hermitian positive definite tridiagonal
+* _SY: Symmetric indefinite
+* _SP: Symmetric indefinite packed
+* _HE: (complex) Hermitian indefinite
+* _HP: (complex) Hermitian indefinite packed
+* The first character must be one of S, D, C, or Z (C or Z only
+* if complex).
+*
+* .. Local Scalars ..
+ LOGICAL CORZ, SORD
+ CHARACTER C1, C3
+ CHARACTER*2 P2
+ CHARACTER*9 SYM
+* ..
+* .. External Functions ..
+ LOGICAL LSAME, LSAMEN
+ EXTERNAL LSAME, LSAMEN
+* ..
+* .. Executable Statements ..
+*
+ IF( IOUNIT.LE.0 )
+ $ RETURN
+ C1 = PATH( 1: 1 )
+ C3 = PATH( 3: 3 )
+ P2 = PATH( 2: 3 )
+ SORD = LSAME( C1, 'S' ) .OR. LSAME( C1, 'D' )
+ CORZ = LSAME( C1, 'C' ) .OR. LSAME( C1, 'Z' )
+ IF( .NOT.( SORD .OR. CORZ ) )
+ $ RETURN
+*
+ IF( LSAMEN( 2, P2, 'GE' ) ) THEN
+*
+* GE: General dense
+*
+ WRITE( IOUNIT, FMT = 9999 )PATH
+ WRITE( IOUNIT, FMT = '( '' Matrix types:'' )' )
+ WRITE( IOUNIT, FMT = 9989 )
+ WRITE( IOUNIT, FMT = '( '' Test ratios:'' )' )
+ WRITE( IOUNIT, FMT = 9981 )1
+ WRITE( IOUNIT, FMT = 9980 )2
+ WRITE( IOUNIT, FMT = 9979 )3
+ WRITE( IOUNIT, FMT = 9978 )4
+ WRITE( IOUNIT, FMT = 9977 )5
+ WRITE( IOUNIT, FMT = 9976 )6
+ WRITE( IOUNIT, FMT = 9972 )7
+ WRITE( IOUNIT, FMT = '( '' Messages:'' )' )
+*
+ ELSE IF( LSAMEN( 2, P2, 'GB' ) ) THEN
+*
+* GB: General band
+*
+ WRITE( IOUNIT, FMT = 9998 )PATH
+ WRITE( IOUNIT, FMT = '( '' Matrix types:'' )' )
+ WRITE( IOUNIT, FMT = 9988 )
+ WRITE( IOUNIT, FMT = '( '' Test ratios:'' )' )
+ WRITE( IOUNIT, FMT = 9981 )1
+ WRITE( IOUNIT, FMT = 9980 )2
+ WRITE( IOUNIT, FMT = 9979 )3
+ WRITE( IOUNIT, FMT = 9978 )4
+ WRITE( IOUNIT, FMT = 9977 )5
+ WRITE( IOUNIT, FMT = 9976 )6
+ WRITE( IOUNIT, FMT = 9972 )7
+ WRITE( IOUNIT, FMT = '( '' Messages:'' )' )
+*
+ ELSE IF( LSAMEN( 2, P2, 'GT' ) ) THEN
+*
+* GT: General tridiagonal
+*
+ WRITE( IOUNIT, FMT = 9997 )PATH
+ WRITE( IOUNIT, FMT = 9987 )
+ WRITE( IOUNIT, FMT = '( '' Test ratios:'' )' )
+ WRITE( IOUNIT, FMT = 9981 )1
+ WRITE( IOUNIT, FMT = 9980 )2
+ WRITE( IOUNIT, FMT = 9979 )3
+ WRITE( IOUNIT, FMT = 9978 )4
+ WRITE( IOUNIT, FMT = 9977 )5
+ WRITE( IOUNIT, FMT = 9976 )6
+ WRITE( IOUNIT, FMT = '( '' Messages:'' )' )
+*
+ ELSE IF( LSAMEN( 2, P2, 'PO' ) .OR. LSAMEN( 2, P2, 'PP' ) ) THEN
+*
+* PO: Positive definite full
+* PP: Positive definite packed
+*
+ IF( SORD ) THEN
+ SYM = 'Symmetric'
+ ELSE
+ SYM = 'Hermitian'
+ END IF
+ IF( LSAME( C3, 'O' ) ) THEN
+ WRITE( IOUNIT, FMT = 9996 )PATH, SYM
+ ELSE
+ WRITE( IOUNIT, FMT = 9995 )PATH, SYM
+ END IF
+ WRITE( IOUNIT, FMT = '( '' Matrix types:'' )' )
+ WRITE( IOUNIT, FMT = 9985 )PATH
+ WRITE( IOUNIT, FMT = '( '' Test ratios:'' )' )
+ WRITE( IOUNIT, FMT = 9975 )1
+ WRITE( IOUNIT, FMT = 9980 )2
+ WRITE( IOUNIT, FMT = 9979 )3
+ WRITE( IOUNIT, FMT = 9978 )4
+ WRITE( IOUNIT, FMT = 9977 )5
+ WRITE( IOUNIT, FMT = 9976 )6
+ WRITE( IOUNIT, FMT = '( '' Messages:'' )' )
+*
+ ELSE IF( LSAMEN( 2, P2, 'PB' ) ) THEN
+*
+* PB: Positive definite band
+*
+ IF( SORD ) THEN
+ WRITE( IOUNIT, FMT = 9994 )PATH, 'Symmetric'
+ ELSE
+ WRITE( IOUNIT, FMT = 9994 )PATH, 'Hermitian'
+ END IF
+ WRITE( IOUNIT, FMT = '( '' Matrix types:'' )' )
+ WRITE( IOUNIT, FMT = 9984 )PATH
+ WRITE( IOUNIT, FMT = '( '' Test ratios:'' )' )
+ WRITE( IOUNIT, FMT = 9975 )1
+ WRITE( IOUNIT, FMT = 9980 )2
+ WRITE( IOUNIT, FMT = 9979 )3
+ WRITE( IOUNIT, FMT = 9978 )4
+ WRITE( IOUNIT, FMT = 9977 )5
+ WRITE( IOUNIT, FMT = 9976 )6
+ WRITE( IOUNIT, FMT = '( '' Messages:'' )' )
+*
+ ELSE IF( LSAMEN( 2, P2, 'PT' ) ) THEN
+*
+* PT: Positive definite tridiagonal
+*
+ IF( SORD ) THEN
+ WRITE( IOUNIT, FMT = 9993 )PATH, 'Symmetric'
+ ELSE
+ WRITE( IOUNIT, FMT = 9993 )PATH, 'Hermitian'
+ END IF
+ WRITE( IOUNIT, FMT = 9986 )
+ WRITE( IOUNIT, FMT = '( '' Test ratios:'' )' )
+ WRITE( IOUNIT, FMT = 9973 )1
+ WRITE( IOUNIT, FMT = 9980 )2
+ WRITE( IOUNIT, FMT = 9979 )3
+ WRITE( IOUNIT, FMT = 9978 )4
+ WRITE( IOUNIT, FMT = 9977 )5
+ WRITE( IOUNIT, FMT = 9976 )6
+ WRITE( IOUNIT, FMT = '( '' Messages:'' )' )
+*
+ ELSE IF( LSAMEN( 2, P2, 'SY' ) .OR. LSAMEN( 2, P2, 'SP' ) ) THEN
+*
+* SY: Symmetric indefinite full
+* SP: Symmetric indefinite packed
+*
+ IF( LSAME( C3, 'Y' ) ) THEN
+ WRITE( IOUNIT, FMT = 9992 )PATH, 'Symmetric'
+ ELSE
+ WRITE( IOUNIT, FMT = 9991 )PATH, 'Symmetric'
+ END IF
+ WRITE( IOUNIT, FMT = '( '' Matrix types:'' )' )
+ IF( SORD ) THEN
+ WRITE( IOUNIT, FMT = 9983 )
+ ELSE
+ WRITE( IOUNIT, FMT = 9982 )
+ END IF
+ WRITE( IOUNIT, FMT = '( '' Test ratios:'' )' )
+ WRITE( IOUNIT, FMT = 9974 )1
+ WRITE( IOUNIT, FMT = 9980 )2
+ WRITE( IOUNIT, FMT = 9979 )3
+ WRITE( IOUNIT, FMT = 9977 )4
+ WRITE( IOUNIT, FMT = 9978 )5
+ WRITE( IOUNIT, FMT = 9976 )6
+ WRITE( IOUNIT, FMT = '( '' Messages:'' )' )
+*
+ ELSE IF( LSAMEN( 2, P2, 'HE' ) .OR. LSAMEN( 2, P2, 'HP' ) ) THEN
+*
+* HE: Hermitian indefinite full
+* HP: Hermitian indefinite packed
+*
+ IF( LSAME( C3, 'E' ) ) THEN
+ WRITE( IOUNIT, FMT = 9992 )PATH, 'Hermitian'
+ ELSE
+ WRITE( IOUNIT, FMT = 9991 )PATH, 'Hermitian'
+ END IF
+ WRITE( IOUNIT, FMT = '( '' Matrix types:'' )' )
+ WRITE( IOUNIT, FMT = 9983 )
+ WRITE( IOUNIT, FMT = '( '' Test ratios:'' )' )
+ WRITE( IOUNIT, FMT = 9974 )1
+ WRITE( IOUNIT, FMT = 9980 )2
+ WRITE( IOUNIT, FMT = 9979 )3
+ WRITE( IOUNIT, FMT = 9977 )4
+ WRITE( IOUNIT, FMT = 9978 )5
+ WRITE( IOUNIT, FMT = 9976 )6
+ WRITE( IOUNIT, FMT = '( '' Messages:'' )' )
+*
+ ELSE
+*
+* Print error message if no header is available.
+*
+ WRITE( IOUNIT, FMT = 9990 )PATH
+ END IF
+*
+* First line of header
+*
+ 9999 FORMAT( / 1X, A3, ' drivers: General dense matrices' )
+ 9998 FORMAT( / 1X, A3, ' drivers: General band matrices' )
+ 9997 FORMAT( / 1X, A3, ' drivers: General tridiagonal' )
+ 9996 FORMAT( / 1X, A3, ' drivers: ', A9,
+ $ ' positive definite matrices' )
+ 9995 FORMAT( / 1X, A3, ' drivers: ', A9,
+ $ ' positive definite packed matrices' )
+ 9994 FORMAT( / 1X, A3, ' drivers: ', A9,
+ $ ' positive definite band matrices' )
+ 9993 FORMAT( / 1X, A3, ' drivers: ', A9,
+ $ ' positive definite tridiagonal' )
+ 9992 FORMAT( / 1X, A3, ' drivers: ', A9, ' indefinite matrices' )
+ 9991 FORMAT( / 1X, A3, ' drivers: ', A9,
+ $ ' indefinite packed matrices' )
+ 9990 FORMAT( / 1X, A3, ': No header available' )
+*
+* GE matrix types
+*
+ 9989 FORMAT( 4X, '1. Diagonal', 24X, '7. Last n/2 columns zero', / 4X,
+ $ '2. Upper triangular', 16X,
+ $ '8. Random, CNDNUM = sqrt(0.1/EPS)', / 4X,
+ $ '3. Lower triangular', 16X, '9. Random, CNDNUM = 0.1/EPS',
+ $ / 4X, '4. Random, CNDNUM = 2', 13X,
+ $ '10. Scaled near underflow', / 4X, '5. First column zero',
+ $ 14X, '11. Scaled near overflow', / 4X,
+ $ '6. Last column zero' )
+*
+* GB matrix types
+*
+ 9988 FORMAT( 4X, '1. Random, CNDNUM = 2', 14X,
+ $ '5. Random, CNDNUM = sqrt(0.1/EPS)', / 4X,
+ $ '2. First column zero', 15X, '6. Random, CNDNUM = 0.1/EPS',
+ $ / 4X, '3. Last column zero', 16X,
+ $ '7. Scaled near underflow', / 4X,
+ $ '4. Last n/2 columns zero', 11X, '8. Scaled near overflow' )
+*
+* GT matrix types
+*
+ 9987 FORMAT( ' Matrix types (1-6 have specified condition numbers):',
+ $ / 4X, '1. Diagonal', 24X, '7. Random, unspecified CNDNUM',
+ $ / 4X, '2. Random, CNDNUM = 2', 14X, '8. First column zero',
+ $ / 4X, '3. Random, CNDNUM = sqrt(0.1/EPS)', 2X,
+ $ '9. Last column zero', / 4X, '4. Random, CNDNUM = 0.1/EPS',
+ $ 7X, '10. Last n/2 columns zero', / 4X,
+ $ '5. Scaled near underflow', 10X,
+ $ '11. Scaled near underflow', / 4X,
+ $ '6. Scaled near overflow', 11X, '12. Scaled near overflow' )
+*
+* PT matrix types
+*
+ 9986 FORMAT( ' Matrix types (1-6 have specified condition numbers):',
+ $ / 4X, '1. Diagonal', 24X, '7. Random, unspecified CNDNUM',
+ $ / 4X, '2. Random, CNDNUM = 2', 14X,
+ $ '8. First row and column zero', / 4X,
+ $ '3. Random, CNDNUM = sqrt(0.1/EPS)', 2X,
+ $ '9. Last row and column zero', / 4X,
+ $ '4. Random, CNDNUM = 0.1/EPS', 7X,
+ $ '10. Middle row and column zero', / 4X,
+ $ '5. Scaled near underflow', 10X,
+ $ '11. Scaled near underflow', / 4X,
+ $ '6. Scaled near overflow', 11X, '12. Scaled near overflow' )
+*
+* PO, PP matrix types
+*
+ 9985 FORMAT( 4X, '1. Diagonal', 24X,
+ $ '6. Random, CNDNUM = sqrt(0.1/EPS)', / 4X,
+ $ '2. Random, CNDNUM = 2', 14X, '7. Random, CNDNUM = 0.1/EPS',
+ $ / 3X, '*3. First row and column zero', 7X,
+ $ '8. Scaled near underflow', / 3X,
+ $ '*4. Last row and column zero', 8X,
+ $ '9. Scaled near overflow', / 3X,
+ $ '*5. Middle row and column zero', / 3X,
+ $ '(* - tests error exits from ', A3,
+ $ 'TRF, no test ratios are computed)' )
+*
+* PB matrix types
+*
+ 9984 FORMAT( 4X, '1. Random, CNDNUM = 2', 14X,
+ $ '5. Random, CNDNUM = sqrt(0.1/EPS)', / 3X,
+ $ '*2. First row and column zero', 7X,
+ $ '6. Random, CNDNUM = 0.1/EPS', / 3X,
+ $ '*3. Last row and column zero', 8X,
+ $ '7. Scaled near underflow', / 3X,
+ $ '*4. Middle row and column zero', 6X,
+ $ '8. Scaled near overflow', / 3X,
+ $ '(* - tests error exits from ', A3,
+ $ 'TRF, no test ratios are computed)' )
+*
+* SSY, SSP, CHE, CHP matrix types
+*
+ 9983 FORMAT( 4X, '1. Diagonal', 24X,
+ $ '6. Last n/2 rows and columns zero', / 4X,
+ $ '2. Random, CNDNUM = 2', 14X,
+ $ '7. Random, CNDNUM = sqrt(0.1/EPS)', / 4X,
+ $ '3. First row and column zero', 7X,
+ $ '8. Random, CNDNUM = 0.1/EPS', / 4X,
+ $ '4. Last row and column zero', 8X,
+ $ '9. Scaled near underflow', / 4X,
+ $ '5. Middle row and column zero', 5X,
+ $ '10. Scaled near overflow' )
+*
+* CSY, CSP matrix types
+*
+ 9982 FORMAT( 4X, '1. Diagonal', 24X,
+ $ '7. Random, CNDNUM = sqrt(0.1/EPS)', / 4X,
+ $ '2. Random, CNDNUM = 2', 14X, '8. Random, CNDNUM = 0.1/EPS',
+ $ / 4X, '3. First row and column zero', 7X,
+ $ '9. Scaled near underflow', / 4X,
+ $ '4. Last row and column zero', 7X,
+ $ '10. Scaled near overflow', / 4X,
+ $ '5. Middle row and column zero', 5X,
+ $ '11. Block diagonal matrix', / 4X,
+ $ '6. Last n/2 rows and columns zero' )
+*
+* Test ratios
+*
+ 9981 FORMAT( 3X, I2, ': norm( L * U - A ) / ( N * norm(A) * EPS )' )
+ 9980 FORMAT( 3X, I2, ': norm( B - A * X ) / ',
+ $ '( norm(A) * norm(X) * EPS )' )
+ 9979 FORMAT( 3X, I2, ': norm( X - XACT ) / ',
+ $ '( norm(XACT) * CNDNUM * EPS )' )
+ 9978 FORMAT( 3X, I2, ': norm( X - XACT ) / ',
+ $ '( norm(XACT) * (error bound) )' )
+ 9977 FORMAT( 3X, I2, ': (backward error) / EPS' )
+ 9976 FORMAT( 3X, I2, ': RCOND * CNDNUM - 1.0' )
+ 9975 FORMAT( 3X, I2, ': norm( U'' * U - A ) / ( N * norm(A) * EPS )',
+ $ ', or', / 7X, 'norm( L * L'' - A ) / ( N * norm(A) * EPS )'
+ $ )
+ 9974 FORMAT( 3X, I2, ': norm( U*D*U'' - A ) / ( N * norm(A) * EPS )',
+ $ ', or', / 7X, 'norm( L*D*L'' - A ) / ( N * norm(A) * EPS )'
+ $ )
+ 9973 FORMAT( 3X, I2, ': norm( U''*D*U - A ) / ( N * norm(A) * EPS )',
+ $ ', or', / 7X, 'norm( L*D*L'' - A ) / ( N * norm(A) * EPS )'
+ $ )
+ 9972 FORMAT( 3X, I2, ': abs( WORK(1) - RPVGRW ) /',
+ $ ' ( max( WORK(1), RPVGRW ) * EPS )' )
+*
+ RETURN
+*
+* End of ALADHD
+*
+ END
+ SUBROUTINE ALAERH( PATH, SUBNAM, INFO, INFOE, OPTS, M, N, KL, KU,
+ $ N5, IMAT, NFAIL, NERRS, NOUT )
+*
+* -- LAPACK auxiliary test routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER*3 PATH
+ CHARACTER*6 SUBNAM
+ CHARACTER*( * ) OPTS
+ INTEGER IMAT, INFO, INFOE, KL, KU, M, N, N5, NERRS,
+ $ NFAIL, NOUT
+* ..
+*
+* Purpose
+* =======
+*
+* ALAERH is an error handler for the LAPACK routines. It prints the
+* header if this is the first error message and prints the error code
+* and form of recovery, if any. The character evaluations in this
+* routine may make it slow, but it should not be called once the LAPACK
+* routines are fully debugged.
+*
+* Arguments
+* =========
+*
+* PATH (input) CHARACTER*3
+* The LAPACK path name of subroutine SUBNAM.
+*
+* SUBNAM (input) CHARACTER*6
+* The name of the subroutine that returned an error code.
+*
+* INFO (input) INTEGER
+* The error code returned from routine SUBNAM.
+*
+* INFOE (input) INTEGER
+* The expected error code from routine SUBNAM, if SUBNAM were
+* error-free. If INFOE = 0, an error message is printed, but
+* if INFOE.NE.0, we assume only the return code INFO is wrong.
+*
+* OPTS (input) CHARACTER*(*)
+* The character options to the subroutine SUBNAM, concatenated
+* into a single character string. For example, UPLO = 'U',
+* TRANS = 'T', and DIAG = 'N' for a triangular routine would
+* be specified as OPTS = 'UTN'.
+*
+* M (input) INTEGER
+* The matrix row dimension.
+*
+* N (input) INTEGER
+* The matrix column dimension. Accessed only if PATH = xGE or
+* xGB.
+*
+* KL (input) INTEGER
+* The number of sub-diagonals of the matrix. Accessed only if
+* PATH = xGB, xPB, or xTB. Also used for NRHS for PATH = xLS.
+*
+* KU (input) INTEGER
+* The number of super-diagonals of the matrix. Accessed only
+* if PATH = xGB.
+*
+* N5 (input) INTEGER
+* A fifth integer parameter, may be the blocksize NB or the
+* number of right hand sides NRHS.
+*
+* IMAT (input) INTEGER
+* The matrix type.
+*
+* NFAIL (input) INTEGER
+* The number of prior tests that did not pass the threshold;
+* used to determine if the header should be printed.
+*
+* NERRS (input/output) INTEGER
+* On entry, the number of errors already detected; used to
+* determine if the header should be printed.
+* On exit, NERRS is increased by 1.
+*
+* NOUT (input) INTEGER
+* The unit number on which results are to be printed.
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ CHARACTER UPLO
+ CHARACTER*2 P2
+ CHARACTER*3 C3
+* ..
+* .. External Functions ..
+ LOGICAL LSAME, LSAMEN
+ EXTERNAL LSAME, LSAMEN
+* ..
+* .. External Subroutines ..
+ EXTERNAL ALADHD, ALAHD
+* ..
+* .. Executable Statements ..
+*
+ IF( INFO.EQ.0 )
+ $ RETURN
+ P2 = PATH( 2: 3 )
+ C3 = SUBNAM( 4: 6 )
+*
+* Print the header if this is the first error message.
+*
+ IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 ) THEN
+ IF( LSAMEN( 3, C3, 'SV ' ) .OR. LSAMEN( 3, C3, 'SVX' ) ) THEN
+ CALL ALADHD( NOUT, PATH )
+ ELSE
+ CALL ALAHD( NOUT, PATH )
+ END IF
+ END IF
+ NERRS = NERRS + 1
+*
+* Print the message detailing the error and form of recovery,
+* if any.
+*
+ IF( LSAMEN( 2, P2, 'GE' ) ) THEN
+*
+* xGE: General matrices
+*
+ IF( LSAMEN( 3, C3, 'TRF' ) ) THEN
+ IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN
+ WRITE( NOUT, FMT = 9988 )SUBNAM, INFO, INFOE, M, N, N5,
+ $ IMAT
+ ELSE
+ WRITE( NOUT, FMT = 9975 )SUBNAM, INFO, M, N, N5, IMAT
+ END IF
+ IF( INFO.NE.0 )
+ $ WRITE( NOUT, FMT = 9949 )
+*
+ ELSE IF( LSAMEN( 3, C3, 'SV ' ) ) THEN
+*
+ IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN
+ WRITE( NOUT, FMT = 9984 )SUBNAM, INFO, INFOE, N, N5,
+ $ IMAT
+ ELSE
+ WRITE( NOUT, FMT = 9970 )SUBNAM, INFO, N, N5, IMAT
+ END IF
+*
+ ELSE IF( LSAMEN( 3, C3, 'SVX' ) ) THEN
+*
+ IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN
+ WRITE( NOUT, FMT = 9992 )SUBNAM, INFO, INFOE,
+ $ OPTS( 1: 1 ), OPTS( 2: 2 ), N, N5, IMAT
+ ELSE
+ WRITE( NOUT, FMT = 9997 )SUBNAM, INFO, OPTS( 1: 1 ),
+ $ OPTS( 2: 2 ), N, N5, IMAT
+ END IF
+*
+ ELSE IF( LSAMEN( 3, C3, 'TRI' ) ) THEN
+*
+ WRITE( NOUT, FMT = 9971 )SUBNAM, INFO, N, N5, IMAT
+*
+ ELSE IF( LSAMEN( 5, SUBNAM( 2: 6 ), 'LATMS' ) ) THEN
+*
+ WRITE( NOUT, FMT = 9978 )SUBNAM, INFO, M, N, IMAT
+*
+ ELSE IF( LSAMEN( 3, C3, 'CON' ) ) THEN
+*
+ WRITE( NOUT, FMT = 9969 )SUBNAM, INFO, OPTS( 1: 1 ), M,
+ $ IMAT
+*
+ ELSE IF( LSAMEN( 3, C3, 'LS ' ) ) THEN
+*
+ WRITE( NOUT, FMT = 9965 )SUBNAM, INFO, OPTS( 1: 1 ), M, N,
+ $ KL, N5, IMAT
+*
+ ELSE IF( LSAMEN( 3, C3, 'LSX' ) .OR. LSAMEN( 3, C3, 'LSS' ) )
+ $ THEN
+*
+ WRITE( NOUT, FMT = 9974 )SUBNAM, INFO, M, N, KL, N5, IMAT
+*
+ ELSE
+*
+ WRITE( NOUT, FMT = 9963 )SUBNAM, INFO, OPTS( 1: 1 ), M, N5,
+ $ IMAT
+ END IF
+*
+ ELSE IF( LSAMEN( 2, P2, 'GB' ) ) THEN
+*
+* xGB: General band matrices
+*
+ IF( LSAMEN( 3, C3, 'TRF' ) ) THEN
+ IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN
+ WRITE( NOUT, FMT = 9989 )SUBNAM, INFO, INFOE, M, N, KL,
+ $ KU, N5, IMAT
+ ELSE
+ WRITE( NOUT, FMT = 9976 )SUBNAM, INFO, M, N, KL, KU, N5,
+ $ IMAT
+ END IF
+ IF( INFO.NE.0 )
+ $ WRITE( NOUT, FMT = 9949 )
+*
+ ELSE IF( LSAMEN( 3, C3, 'SV ' ) ) THEN
+*
+ IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN
+ WRITE( NOUT, FMT = 9986 )SUBNAM, INFO, INFOE, N, KL, KU,
+ $ N5, IMAT
+ ELSE
+ WRITE( NOUT, FMT = 9972 )SUBNAM, INFO, N, KL, KU, N5,
+ $ IMAT
+ END IF
+*
+ ELSE IF( LSAMEN( 3, C3, 'SVX' ) ) THEN
+*
+ IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN
+ WRITE( NOUT, FMT = 9993 )SUBNAM, INFO, INFOE,
+ $ OPTS( 1: 1 ), OPTS( 2: 2 ), N, KL, KU, N5, IMAT
+ ELSE
+ WRITE( NOUT, FMT = 9998 )SUBNAM, INFO, OPTS( 1: 1 ),
+ $ OPTS( 2: 2 ), N, KL, KU, N5, IMAT
+ END IF
+*
+ ELSE IF( LSAMEN( 5, SUBNAM( 2: 6 ), 'LATMS' ) ) THEN
+*
+ WRITE( NOUT, FMT = 9977 )SUBNAM, INFO, M, N, KL, KU, IMAT
+*
+ ELSE IF( LSAMEN( 3, C3, 'CON' ) ) THEN
+*
+ WRITE( NOUT, FMT = 9968 )SUBNAM, INFO, OPTS( 1: 1 ), M, KL,
+ $ KU, IMAT
+*
+ ELSE
+*
+ WRITE( NOUT, FMT = 9964 )SUBNAM, INFO, OPTS( 1: 1 ), M, KL,
+ $ KU, N5, IMAT
+ END IF
+*
+ ELSE IF( LSAMEN( 2, P2, 'GT' ) ) THEN
+*
+* xGT: General tridiagonal matrices
+*
+ IF( LSAMEN( 3, C3, 'TRF' ) ) THEN
+ IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN
+ WRITE( NOUT, FMT = 9987 )SUBNAM, INFO, INFOE, N, IMAT
+ ELSE
+ WRITE( NOUT, FMT = 9973 )SUBNAM, INFO, N, IMAT
+ END IF
+ IF( INFO.NE.0 )
+ $ WRITE( NOUT, FMT = 9949 )
+*
+ ELSE IF( LSAMEN( 3, C3, 'SV ' ) ) THEN
+*
+ IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN
+ WRITE( NOUT, FMT = 9984 )SUBNAM, INFO, INFOE, N, N5,
+ $ IMAT
+ ELSE
+ WRITE( NOUT, FMT = 9970 )SUBNAM, INFO, N, N5, IMAT
+ END IF
+*
+ ELSE IF( LSAMEN( 3, C3, 'SVX' ) ) THEN
+*
+ IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN
+ WRITE( NOUT, FMT = 9992 )SUBNAM, INFO, INFOE,
+ $ OPTS( 1: 1 ), OPTS( 2: 2 ), N, N5, IMAT
+ ELSE
+ WRITE( NOUT, FMT = 9997 )SUBNAM, INFO, OPTS( 1: 1 ),
+ $ OPTS( 2: 2 ), N, N5, IMAT
+ END IF
+*
+ ELSE IF( LSAMEN( 3, C3, 'CON' ) ) THEN
+*
+ WRITE( NOUT, FMT = 9969 )SUBNAM, INFO, OPTS( 1: 1 ), M,
+ $ IMAT
+*
+ ELSE
+*
+ WRITE( NOUT, FMT = 9963 )SUBNAM, INFO, OPTS( 1: 1 ), M, N5,
+ $ IMAT
+ END IF
+*
+ ELSE IF( LSAMEN( 2, P2, 'PO' ) ) THEN
+*
+* xPO: Symmetric or Hermitian positive definite matrices
+*
+ UPLO = OPTS( 1: 1 )
+ IF( LSAMEN( 3, C3, 'TRF' ) ) THEN
+ IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN
+ WRITE( NOUT, FMT = 9980 )SUBNAM, INFO, INFOE, UPLO, M,
+ $ N5, IMAT
+ ELSE
+ WRITE( NOUT, FMT = 9956 )SUBNAM, INFO, UPLO, M, N5, IMAT
+ END IF
+ IF( INFO.NE.0 )
+ $ WRITE( NOUT, FMT = 9949 )
+*
+ ELSE IF( LSAMEN( 3, C3, 'SV ' ) ) THEN
+*
+ IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN
+ WRITE( NOUT, FMT = 9979 )SUBNAM, INFO, INFOE, UPLO, N,
+ $ N5, IMAT
+ ELSE
+ WRITE( NOUT, FMT = 9955 )SUBNAM, INFO, UPLO, N, N5, IMAT
+ END IF
+*
+ ELSE IF( LSAMEN( 3, C3, 'SVX' ) ) THEN
+*
+ IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN
+ WRITE( NOUT, FMT = 9990 )SUBNAM, INFO, INFOE,
+ $ OPTS( 1: 1 ), OPTS( 2: 2 ), N, N5, IMAT
+ ELSE
+ WRITE( NOUT, FMT = 9995 )SUBNAM, INFO, OPTS( 1: 1 ),
+ $ OPTS( 2: 2 ), N, N5, IMAT
+ END IF
+*
+ ELSE IF( LSAMEN( 3, C3, 'TRI' ) ) THEN
+*
+ WRITE( NOUT, FMT = 9956 )SUBNAM, INFO, UPLO, M, N5, IMAT
+*
+ ELSE IF( LSAMEN( 5, SUBNAM( 2: 6 ), 'LATMS' ) .OR.
+ $ LSAMEN( 3, C3, 'CON' ) ) THEN
+*
+ WRITE( NOUT, FMT = 9960 )SUBNAM, INFO, UPLO, M, IMAT
+*
+ ELSE
+*
+ WRITE( NOUT, FMT = 9955 )SUBNAM, INFO, UPLO, M, N5, IMAT
+ END IF
+*
+ ELSE IF( LSAMEN( 2, P2, 'SY' ) .OR. LSAMEN( 2, P2, 'HE' ) ) THEN
+*
+* xHE, or xSY: Symmetric or Hermitian indefinite matrices
+*
+ UPLO = OPTS( 1: 1 )
+ IF( LSAMEN( 3, C3, 'TRF' ) ) THEN
+ IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN
+ WRITE( NOUT, FMT = 9980 )SUBNAM, INFO, INFOE, UPLO, M,
+ $ N5, IMAT
+ ELSE
+ WRITE( NOUT, FMT = 9956 )SUBNAM, INFO, UPLO, M, N5, IMAT
+ END IF
+ IF( INFO.NE.0 )
+ $ WRITE( NOUT, FMT = 9949 )
+*
+ ELSE IF( LSAMEN( 3, C3, 'SV ' ) ) THEN
+*
+ IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN
+ WRITE( NOUT, FMT = 9979 )SUBNAM, INFO, INFOE, UPLO, N,
+ $ N5, IMAT
+ ELSE
+ WRITE( NOUT, FMT = 9955 )SUBNAM, INFO, UPLO, N, N5, IMAT
+ END IF
+*
+ ELSE IF( LSAMEN( 3, C3, 'SVX' ) ) THEN
+*
+ IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN
+ WRITE( NOUT, FMT = 9990 )SUBNAM, INFO, INFOE,
+ $ OPTS( 1: 1 ), OPTS( 2: 2 ), N, N5, IMAT
+ ELSE
+ WRITE( NOUT, FMT = 9995 )SUBNAM, INFO, OPTS( 1: 1 ),
+ $ OPTS( 2: 2 ), N, N5, IMAT
+ END IF
+*
+ ELSE IF( LSAMEN( 5, SUBNAM( 2: 6 ), 'LATMS' ) .OR.
+ $ LSAMEN( 3, C3, 'TRI' ) .OR. LSAMEN( 3, C3, 'CON' ) )
+ $ THEN
+*
+ WRITE( NOUT, FMT = 9960 )SUBNAM, INFO, UPLO, M, IMAT
+*
+ ELSE
+*
+ WRITE( NOUT, FMT = 9955 )SUBNAM, INFO, UPLO, M, N5, IMAT
+ END IF
+*
+ ELSE IF( LSAMEN( 2, P2, 'PP' ) .OR. LSAMEN( 2, P2, 'SP' ) .OR.
+ $ LSAMEN( 2, P2, 'HP' ) ) THEN
+*
+* xPP, xHP, or xSP: Symmetric or Hermitian packed matrices
+*
+ UPLO = OPTS( 1: 1 )
+ IF( LSAMEN( 3, C3, 'TRF' ) ) THEN
+ IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN
+ WRITE( NOUT, FMT = 9983 )SUBNAM, INFO, INFOE, UPLO, M,
+ $ IMAT
+ ELSE
+ WRITE( NOUT, FMT = 9960 )SUBNAM, INFO, UPLO, M, IMAT
+ END IF
+ IF( INFO.NE.0 )
+ $ WRITE( NOUT, FMT = 9949 )
+*
+ ELSE IF( LSAMEN( 3, C3, 'SV ' ) ) THEN
+*
+ IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN
+ WRITE( NOUT, FMT = 9979 )SUBNAM, INFO, INFOE, UPLO, N,
+ $ N5, IMAT
+ ELSE
+ WRITE( NOUT, FMT = 9955 )SUBNAM, INFO, UPLO, N, N5, IMAT
+ END IF
+*
+ ELSE IF( LSAMEN( 3, C3, 'SVX' ) ) THEN
+*
+ IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN
+ WRITE( NOUT, FMT = 9990 )SUBNAM, INFO, INFOE,
+ $ OPTS( 1: 1 ), OPTS( 2: 2 ), N, N5, IMAT
+ ELSE
+ WRITE( NOUT, FMT = 9995 )SUBNAM, INFO, OPTS( 1: 1 ),
+ $ OPTS( 2: 2 ), N, N5, IMAT
+ END IF
+*
+ ELSE IF( LSAMEN( 5, SUBNAM( 2: 6 ), 'LATMS' ) .OR.
+ $ LSAMEN( 3, C3, 'TRI' ) .OR. LSAMEN( 3, C3, 'CON' ) )
+ $ THEN
+*
+ WRITE( NOUT, FMT = 9960 )SUBNAM, INFO, UPLO, M, IMAT
+*
+ ELSE
+*
+ WRITE( NOUT, FMT = 9955 )SUBNAM, INFO, UPLO, M, N5, IMAT
+ END IF
+*
+ ELSE IF( LSAMEN( 2, P2, 'PB' ) ) THEN
+*
+* xPB: Symmetric (Hermitian) positive definite band matrix
+*
+ UPLO = OPTS( 1: 1 )
+ IF( LSAMEN( 3, C3, 'TRF' ) ) THEN
+ IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN
+ WRITE( NOUT, FMT = 9982 )SUBNAM, INFO, INFOE, UPLO, M,
+ $ KL, N5, IMAT
+ ELSE
+ WRITE( NOUT, FMT = 9958 )SUBNAM, INFO, UPLO, M, KL, N5,
+ $ IMAT
+ END IF
+ IF( INFO.NE.0 )
+ $ WRITE( NOUT, FMT = 9949 )
+*
+ ELSE IF( LSAMEN( 3, C3, 'SV ' ) ) THEN
+*
+ IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN
+ WRITE( NOUT, FMT = 9981 )SUBNAM, INFO, INFOE, UPLO, N,
+ $ KL, N5, IMAT
+ ELSE
+ WRITE( NOUT, FMT = 9957 )SUBNAM, INFO, UPLO, N, KL, N5,
+ $ IMAT
+ END IF
+*
+ ELSE IF( LSAMEN( 3, C3, 'SVX' ) ) THEN
+*
+ IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN
+ WRITE( NOUT, FMT = 9991 )SUBNAM, INFO, INFOE,
+ $ OPTS( 1: 1 ), OPTS( 2: 2 ), N, KL, N5, IMAT
+ ELSE
+ WRITE( NOUT, FMT = 9996 )SUBNAM, INFO, OPTS( 1: 1 ),
+ $ OPTS( 2: 2 ), N, KL, N5, IMAT
+ END IF
+*
+ ELSE IF( LSAMEN( 5, SUBNAM( 2: 6 ), 'LATMS' ) .OR.
+ $ LSAMEN( 3, C3, 'CON' ) ) THEN
+*
+ WRITE( NOUT, FMT = 9959 )SUBNAM, INFO, UPLO, M, KL, IMAT
+*
+ ELSE
+*
+ WRITE( NOUT, FMT = 9957 )SUBNAM, INFO, UPLO, M, KL, N5,
+ $ IMAT
+ END IF
+*
+ ELSE IF( LSAMEN( 2, P2, 'PT' ) ) THEN
+*
+* xPT: Positive definite tridiagonal matrices
+*
+ IF( LSAMEN( 3, C3, 'TRF' ) ) THEN
+ IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN
+ WRITE( NOUT, FMT = 9987 )SUBNAM, INFO, INFOE, N, IMAT
+ ELSE
+ WRITE( NOUT, FMT = 9973 )SUBNAM, INFO, N, IMAT
+ END IF
+ IF( INFO.NE.0 )
+ $ WRITE( NOUT, FMT = 9949 )
+*
+ ELSE IF( LSAMEN( 3, C3, 'SV ' ) ) THEN
+*
+ IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN
+ WRITE( NOUT, FMT = 9984 )SUBNAM, INFO, INFOE, N, N5,
+ $ IMAT
+ ELSE
+ WRITE( NOUT, FMT = 9970 )SUBNAM, INFO, N, N5, IMAT
+ END IF
+*
+ ELSE IF( LSAMEN( 3, C3, 'SVX' ) ) THEN
+*
+ IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN
+ WRITE( NOUT, FMT = 9994 )SUBNAM, INFO, INFOE,
+ $ OPTS( 1: 1 ), N, N5, IMAT
+ ELSE
+ WRITE( NOUT, FMT = 9999 )SUBNAM, INFO, OPTS( 1: 1 ), N,
+ $ N5, IMAT
+ END IF
+*
+ ELSE IF( LSAMEN( 3, C3, 'CON' ) ) THEN
+*
+ IF( LSAME( SUBNAM( 1: 1 ), 'S' ) .OR.
+ $ LSAME( SUBNAM( 1: 1 ), 'D' ) ) THEN
+ WRITE( NOUT, FMT = 9973 )SUBNAM, INFO, M, IMAT
+ ELSE
+ WRITE( NOUT, FMT = 9969 )SUBNAM, INFO, OPTS( 1: 1 ), M,
+ $ IMAT
+ END IF
+*
+ ELSE
+*
+ WRITE( NOUT, FMT = 9963 )SUBNAM, INFO, OPTS( 1: 1 ), M, N5,
+ $ IMAT
+ END IF
+*
+ ELSE IF( LSAMEN( 2, P2, 'TR' ) ) THEN
+*
+* xTR: Triangular matrix
+*
+ IF( LSAMEN( 3, C3, 'TRI' ) ) THEN
+ WRITE( NOUT, FMT = 9961 )SUBNAM, INFO, OPTS( 1: 1 ),
+ $ OPTS( 2: 2 ), M, N5, IMAT
+ ELSE IF( LSAMEN( 3, C3, 'CON' ) ) THEN
+ WRITE( NOUT, FMT = 9967 )SUBNAM, INFO, OPTS( 1: 1 ),
+ $ OPTS( 2: 2 ), OPTS( 3: 3 ), M, IMAT
+ ELSE IF( LSAMEN( 5, SUBNAM( 2: 6 ), 'LATRS' ) ) THEN
+ WRITE( NOUT, FMT = 9952 )SUBNAM, INFO, OPTS( 1: 1 ),
+ $ OPTS( 2: 2 ), OPTS( 3: 3 ), OPTS( 4: 4 ), M, IMAT
+ ELSE
+ WRITE( NOUT, FMT = 9953 )SUBNAM, INFO, OPTS( 1: 1 ),
+ $ OPTS( 2: 2 ), OPTS( 3: 3 ), M, N5, IMAT
+ END IF
+*
+ ELSE IF( LSAMEN( 2, P2, 'TP' ) ) THEN
+*
+* xTP: Triangular packed matrix
+*
+ IF( LSAMEN( 3, C3, 'TRI' ) ) THEN
+ WRITE( NOUT, FMT = 9962 )SUBNAM, INFO, OPTS( 1: 1 ),
+ $ OPTS( 2: 2 ), M, IMAT
+ ELSE IF( LSAMEN( 3, C3, 'CON' ) ) THEN
+ WRITE( NOUT, FMT = 9967 )SUBNAM, INFO, OPTS( 1: 1 ),
+ $ OPTS( 2: 2 ), OPTS( 3: 3 ), M, IMAT
+ ELSE IF( LSAMEN( 5, SUBNAM( 2: 6 ), 'LATPS' ) ) THEN
+ WRITE( NOUT, FMT = 9952 )SUBNAM, INFO, OPTS( 1: 1 ),
+ $ OPTS( 2: 2 ), OPTS( 3: 3 ), OPTS( 4: 4 ), M, IMAT
+ ELSE
+ WRITE( NOUT, FMT = 9953 )SUBNAM, INFO, OPTS( 1: 1 ),
+ $ OPTS( 2: 2 ), OPTS( 3: 3 ), M, N5, IMAT
+ END IF
+*
+ ELSE IF( LSAMEN( 2, P2, 'TB' ) ) THEN
+*
+* xTB: Triangular band matrix
+*
+ IF( LSAMEN( 3, C3, 'CON' ) ) THEN
+ WRITE( NOUT, FMT = 9966 )SUBNAM, INFO, OPTS( 1: 1 ),
+ $ OPTS( 2: 2 ), OPTS( 3: 3 ), M, KL, IMAT
+ ELSE IF( LSAMEN( 5, SUBNAM( 2: 6 ), 'LATBS' ) ) THEN
+ WRITE( NOUT, FMT = 9951 )SUBNAM, INFO, OPTS( 1: 1 ),
+ $ OPTS( 2: 2 ), OPTS( 3: 3 ), OPTS( 4: 4 ), M, KL, IMAT
+ ELSE
+ WRITE( NOUT, FMT = 9954 )SUBNAM, INFO, OPTS( 1: 1 ),
+ $ OPTS( 2: 2 ), OPTS( 3: 3 ), M, KL, N5, IMAT
+ END IF
+*
+ ELSE IF( LSAMEN( 2, P2, 'QR' ) ) THEN
+*
+* xQR: QR factorization
+*
+ IF( LSAMEN( 3, C3, 'QRS' ) ) THEN
+ WRITE( NOUT, FMT = 9974 )SUBNAM, INFO, M, N, KL, N5, IMAT
+ ELSE IF( LSAMEN( 5, SUBNAM( 2: 6 ), 'LATMS' ) ) THEN
+ WRITE( NOUT, FMT = 9978 )SUBNAM, INFO, M, N, IMAT
+ END IF
+*
+ ELSE IF( LSAMEN( 2, P2, 'LQ' ) ) THEN
+*
+* xLQ: LQ factorization
+*
+ IF( LSAMEN( 3, C3, 'LQS' ) ) THEN
+ WRITE( NOUT, FMT = 9974 )SUBNAM, INFO, M, N, KL, N5, IMAT
+ ELSE IF( LSAMEN( 5, SUBNAM( 2: 6 ), 'LATMS' ) ) THEN
+ WRITE( NOUT, FMT = 9978 )SUBNAM, INFO, M, N, IMAT
+ END IF
+*
+ ELSE IF( LSAMEN( 2, P2, 'QL' ) ) THEN
+*
+* xQL: QL factorization
+*
+ IF( LSAMEN( 3, C3, 'QLS' ) ) THEN
+ WRITE( NOUT, FMT = 9974 )SUBNAM, INFO, M, N, KL, N5, IMAT
+ ELSE IF( LSAMEN( 5, SUBNAM( 2: 6 ), 'LATMS' ) ) THEN
+ WRITE( NOUT, FMT = 9978 )SUBNAM, INFO, M, N, IMAT
+ END IF
+*
+ ELSE IF( LSAMEN( 2, P2, 'RQ' ) ) THEN
+*
+* xRQ: RQ factorization
+*
+ IF( LSAMEN( 3, C3, 'RQS' ) ) THEN
+ WRITE( NOUT, FMT = 9974 )SUBNAM, INFO, M, N, KL, N5, IMAT
+ ELSE IF( LSAMEN( 5, SUBNAM( 2: 6 ), 'LATMS' ) ) THEN
+ WRITE( NOUT, FMT = 9978 )SUBNAM, INFO, M, N, IMAT
+ END IF
+*
+ ELSE IF( LSAMEN( 2, P2, 'LU' ) ) THEN
+*
+ IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN
+ WRITE( NOUT, FMT = 9988 )SUBNAM, INFO, INFOE, M, N, N5,
+ $ IMAT
+ ELSE
+ WRITE( NOUT, FMT = 9975 )SUBNAM, INFO, M, N, N5, IMAT
+ END IF
+*
+ ELSE IF( LSAMEN( 2, P2, 'CH' ) ) THEN
+*
+ IF( INFO.NE.INFOE .AND. INFOE.NE.0 ) THEN
+ WRITE( NOUT, FMT = 9985 )SUBNAM, INFO, INFOE, M, N5, IMAT
+ ELSE
+ WRITE( NOUT, FMT = 9971 )SUBNAM, INFO, M, N5, IMAT
+ END IF
+*
+ ELSE
+*
+* Print a generic message if the path is unknown.
+*
+ WRITE( NOUT, FMT = 9950 )SUBNAM, INFO
+ END IF
+*
+* Description of error message (alphabetical, left to right)
+*
+* SUBNAM, INFO, FACT, N, NRHS, IMAT
+*
+ 9999 FORMAT( ' *** Error code from ', A6, '=', I5, ', FACT=''', A1,
+ $ ''', N=', I5, ', NRHS=', I4, ', type ', I2 )
+*
+* SUBNAM, INFO, FACT, TRANS, N, KL, KU, NRHS, IMAT
+*
+ 9998 FORMAT( ' *** Error code from ', A6, ' =', I5, / ' ==> FACT=''',
+ $ A1, ''', TRANS=''', A1, ''', N=', I5, ', KL=', I5, ', KU=',
+ $ I5, ', NRHS=', I4, ', type ', I1 )
+*
+* SUBNAM, INFO, FACT, TRANS, N, NRHS, IMAT
+*
+ 9997 FORMAT( ' *** Error code from ', A6, ' =', I5, / ' ==> FACT=''',
+ $ A1, ''', TRANS=''', A1, ''', N =', I5, ', NRHS =', I4,
+ $ ', type ', I2 )
+*
+* SUBNAM, INFO, FACT, UPLO, N, KD, NRHS, IMAT
+*
+ 9996 FORMAT( ' *** Error code from ', A6, ' =', I5, / ' ==> FACT=''',
+ $ A1, ''', UPLO=''', A1, ''', N=', I5, ', KD=', I5, ', NRHS=',
+ $ I4, ', type ', I2 )
+*
+* SUBNAM, INFO, FACT, UPLO, N, NRHS, IMAT
+*
+ 9995 FORMAT( ' *** Error code from ', A6, ' =', I5, / ' ==> FACT=''',
+ $ A1, ''', UPLO=''', A1, ''', N =', I5, ', NRHS =', I4,
+ $ ', type ', I2 )
+*
+* SUBNAM, INFO, INFOE, FACT, N, NRHS, IMAT
+*
+ 9994 FORMAT( ' *** ', A6, ' returned with INFO =', I5, ' instead of ',
+ $ I2, / ' ==> FACT=''', A1, ''', N =', I5, ', NRHS =', I4,
+ $ ', type ', I2 )
+*
+* SUBNAM, INFO, INFOE, FACT, TRANS, N, KL, KU, NRHS, IMAT
+*
+ 9993 FORMAT( ' *** ', A6, ' returned with INFO =', I5, ' instead of ',
+ $ I2, / ' ==> FACT=''', A1, ''', TRANS=''', A1, ''', N=', I5,
+ $ ', KL=', I5, ', KU=', I5, ', NRHS=', I4, ', type ', I1 )
+*
+* SUBNAM, INFO, INFOE, FACT, TRANS, N, NRHS, IMAT
+*
+ 9992 FORMAT( ' *** ', A6, ' returned with INFO =', I5, ' instead of ',
+ $ I2, / ' ==> FACT=''', A1, ''', TRANS=''', A1, ''', N =', I5,
+ $ ', NRHS =', I4, ', type ', I2 )
+*
+* SUBNAM, INFO, INFOE, FACT, UPLO, N, KD, NRHS, IMAT
+*
+ 9991 FORMAT( ' *** ', A6, ' returned with INFO =', I5, ' instead of ',
+ $ I2, / ' ==> FACT=''', A1, ''', UPLO=''', A1, ''', N=', I5,
+ $ ', KD=', I5, ', NRHS=', I4, ', type ', I2 )
+*
+* SUBNAM, INFO, INFOE, FACT, UPLO, N, NRHS, IMAT
+*
+ 9990 FORMAT( ' *** ', A6, ' returned with INFO =', I5, ' instead of ',
+ $ I2, / ' ==> FACT=''', A1, ''', UPLO=''', A1, ''', N =', I5,
+ $ ', NRHS =', I4, ', type ', I2 )
+*
+* SUBNAM, INFO, INFOE, M, N, KL, KU, NB, IMAT
+*
+ 9989 FORMAT( ' *** ', A6, ' returned with INFO =', I5, ' instead of ',
+ $ I2, / ' ==> M = ', I5, ', N =', I5, ', KL =', I5, ', KU =',
+ $ I5, ', NB =', I4, ', type ', I2 )
+*
+* SUBNAM, INFO, INFOE, M, N, NB, IMAT
+*
+ 9988 FORMAT( ' *** ', A6, ' returned with INFO =', I5, ' instead of ',
+ $ I2, / ' ==> M =', I5, ', N =', I5, ', NB =', I4, ', type ',
+ $ I2 )
+*
+* SUBNAM, INFO, INFOE, N, IMAT
+*
+ 9987 FORMAT( ' *** ', A6, ' returned with INFO =', I5, ' instead of ',
+ $ I2, ' for N=', I5, ', type ', I2 )
+*
+* SUBNAM, INFO, INFOE, N, KL, KU, NRHS, IMAT
+*
+ 9986 FORMAT( ' *** ', A6, ' returned with INFO =', I5, ' instead of ',
+ $ I2, / ' ==> N =', I5, ', KL =', I5, ', KU =', I5,
+ $ ', NRHS =', I4, ', type ', I2 )
+*
+* SUBNAM, INFO, INFOE, N, NB, IMAT
+*
+ 9985 FORMAT( ' *** ', A6, ' returned with INFO =', I5, ' instead of ',
+ $ I2, / ' ==> N =', I5, ', NB =', I4, ', type ', I2 )
+*
+* SUBNAM, INFO, INFOE, N, NRHS, IMAT
+*
+ 9984 FORMAT( ' *** ', A6, ' returned with INFO =', I5, ' instead of ',
+ $ I2, / ' ==> N =', I5, ', NRHS =', I4, ', type ', I2 )
+*
+* SUBNAM, INFO, INFOE, UPLO, N, IMAT
+*
+ 9983 FORMAT( ' *** ', A6, ' returned with INFO =', I5, ' instead of ',
+ $ I2, / ' ==> UPLO = ''', A1, ''', N =', I5, ', type ', I2 )
+*
+* SUBNAM, INFO, INFOE, UPLO, N, KD, NB, IMAT
+*
+ 9982 FORMAT( ' *** ', A6, ' returned with INFO =', I5, ' instead of ',
+ $ I2, / ' ==> UPLO = ''', A1, ''', N =', I5, ', KD =', I5,
+ $ ', NB =', I4, ', type ', I2 )
+*
+* SUBNAM, INFO, INFOE, UPLO, N, KD, NRHS, IMAT
+*
+ 9981 FORMAT( ' *** ', A6, ' returned with INFO =', I5, ' instead of ',
+ $ I2, / ' ==> UPLO=''', A1, ''', N =', I5, ', KD =', I5,
+ $ ', NRHS =', I4, ', type ', I2 )
+*
+* SUBNAM, INFO, INFOE, UPLO, N, NB, IMAT
+*
+ 9980 FORMAT( ' *** ', A6, ' returned with INFO =', I5, ' instead of ',
+ $ I2, / ' ==> UPLO = ''', A1, ''', N =', I5, ', NB =', I4,
+ $ ', type ', I2 )
+*
+* SUBNAM, INFO, INFOE, UPLO, N, NRHS, IMAT
+*
+ 9979 FORMAT( ' *** ', A6, ' returned with INFO =', I5, ' instead of ',
+ $ I2, / ' ==> UPLO = ''', A1, ''', N =', I5, ', NRHS =', I4,
+ $ ', type ', I2 )
+*
+* SUBNAM, INFO, M, N, IMAT
+*
+ 9978 FORMAT( ' *** Error code from ', A6, ' =', I5, ' for M =', I5,
+ $ ', N =', I5, ', type ', I2 )
+*
+* SUBNAM, INFO, M, N, KL, KU, IMAT
+*
+ 9977 FORMAT( ' *** Error code from ', A6, ' =', I5, / ' ==> M = ', I5,
+ $ ', N =', I5, ', KL =', I5, ', KU =', I5, ', type ', I2 )
+*
+* SUBNAM, INFO, M, N, KL, KU, NB, IMAT
+*
+ 9976 FORMAT( ' *** Error code from ', A6, ' =', I5, / ' ==> M = ', I5,
+ $ ', N =', I5, ', KL =', I5, ', KU =', I5, ', NB =', I4,
+ $ ', type ', I2 )
+*
+* SUBNAM, INFO, M, N, NB, IMAT
+*
+ 9975 FORMAT( ' *** Error code from ', A6, '=', I5, ' for M=', I5,
+ $ ', N=', I5, ', NB=', I4, ', type ', I2 )
+*
+* SUBNAM, INFO, M, N, NRHS, NB, IMAT
+*
+ 9974 FORMAT( ' *** Error code from ', A6, '=', I5, / ' ==> M =', I5,
+ $ ', N =', I5, ', NRHS =', I4, ', NB =', I4, ', type ', I2 )
+*
+* SUBNAM, INFO, N, IMAT
+*
+ 9973 FORMAT( ' *** Error code from ', A6, ' =', I5, ' for N =', I5,
+ $ ', type ', I2 )
+*
+* SUBNAM, INFO, N, KL, KU, NRHS, IMAT
+*
+ 9972 FORMAT( ' *** Error code from ', A6, ' =', I5, / ' ==> N =', I5,
+ $ ', KL =', I5, ', KU =', I5, ', NRHS =', I4, ', type ', I2 )
+*
+* SUBNAM, INFO, N, NB, IMAT
+*
+ 9971 FORMAT( ' *** Error code from ', A6, '=', I5, ' for N=', I5,
+ $ ', NB=', I4, ', type ', I2 )
+*
+* SUBNAM, INFO, N, NRHS, IMAT
+*
+ 9970 FORMAT( ' *** Error code from ', A6, ' =', I5, ' for N =', I5,
+ $ ', NRHS =', I4, ', type ', I2 )
+*
+* SUBNAM, INFO, NORM, N, IMAT
+*
+ 9969 FORMAT( ' *** Error code from ', A6, ' =', I5, ' for NORM = ''',
+ $ A1, ''', N =', I5, ', type ', I2 )
+*
+* SUBNAM, INFO, NORM, N, KL, KU, IMAT
+*
+ 9968 FORMAT( ' *** Error code from ', A6, ' =', I5, / ' ==> NORM =''',
+ $ A1, ''', N =', I5, ', KL =', I5, ', KU =', I5, ', type ',
+ $ I2 )
+*
+* SUBNAM, INFO, NORM, UPLO, DIAG, N, IMAT
+*
+ 9967 FORMAT( ' *** Error code from ', A6, ' =', I5, / ' ==> NORM=''',
+ $ A1, ''', UPLO =''', A1, ''', DIAG=''', A1, ''', N =', I5,
+ $ ', type ', I2 )
+*
+* SUBNAM, INFO, NORM, UPLO, DIAG, N, KD, IMAT
+*
+ 9966 FORMAT( ' *** Error code from ', A6, ' =', I5, / ' ==> NORM=''',
+ $ A1, ''', UPLO =''', A1, ''', DIAG=''', A1, ''', N=', I5,
+ $ ', KD=', I5, ', type ', I2 )
+*
+* SUBNAM, INFO, TRANS, M, N, NRHS, NB, IMAT
+*
+ 9965 FORMAT( ' *** Error code from ', A6, ' =', I5,
+ $ / ' ==> TRANS = ''', A1, ''', M =', I5, ', N =', I5,
+ $ ', NRHS =', I4, ', NB =', I4, ', type ', I2 )
+*
+* SUBNAM, INFO, TRANS, N, KL, KU, NRHS, IMAT
+*
+ 9964 FORMAT( ' *** Error code from ', A6, '=', I5, / ' ==> TRANS=''',
+ $ A1, ''', N =', I5, ', KL =', I5, ', KU =', I5, ', NRHS =',
+ $ I4, ', type ', I2 )
+*
+* SUBNAM, INFO, TRANS, N, NRHS, IMAT
+*
+ 9963 FORMAT( ' *** Error code from ', A6, ' =', I5,
+ $ / ' ==> TRANS = ''', A1, ''', N =', I5, ', NRHS =', I4,
+ $ ', type ', I2 )
+*
+* SUBNAM, INFO, UPLO, DIAG, N, IMAT
+*
+ 9962 FORMAT( ' *** Error code from ', A6, ' =', I5, / ' ==> UPLO=''',
+ $ A1, ''', DIAG =''', A1, ''', N =', I5, ', type ', I2 )
+*
+* SUBNAM, INFO, UPLO, DIAG, N, NB, IMAT
+*
+ 9961 FORMAT( ' *** Error code from ', A6, ' =', I5, / ' ==> UPLO=''',
+ $ A1, ''', DIAG =''', A1, ''', N =', I5, ', NB =', I4,
+ $ ', type ', I2 )
+*
+* SUBNAM, INFO, UPLO, N, IMAT
+*
+ 9960 FORMAT( ' *** Error code from ', A6, ' =', I5, ' for UPLO = ''',
+ $ A1, ''', N =', I5, ', type ', I2 )
+*
+* SUBNAM, INFO, UPLO, N, KD, IMAT
+*
+ 9959 FORMAT( ' *** Error code from ', A6, ' =', I5, / ' ==> UPLO = ''',
+ $ A1, ''', N =', I5, ', KD =', I5, ', type ', I2 )
+*
+* SUBNAM, INFO, UPLO, N, KD, NB, IMAT
+*
+ 9958 FORMAT( ' *** Error code from ', A6, ' =', I5, / ' ==> UPLO = ''',
+ $ A1, ''', N =', I5, ', KD =', I5, ', NB =', I4, ', type ',
+ $ I2 )
+*
+* SUBNAM, INFO, UPLO, N, KD, NRHS, IMAT
+*
+ 9957 FORMAT( ' *** Error code from ', A6, '=', I5, / ' ==> UPLO = ''',
+ $ A1, ''', N =', I5, ', KD =', I5, ', NRHS =', I4, ', type ',
+ $ I2 )
+*
+* SUBNAM, INFO, UPLO, N, NB, IMAT
+*
+ 9956 FORMAT( ' *** Error code from ', A6, ' =', I5, / ' ==> UPLO = ''',
+ $ A1, ''', N =', I5, ', NB =', I4, ', type ', I2 )
+*
+* SUBNAM, INFO, UPLO, N, NRHS, IMAT
+*
+ 9955 FORMAT( ' *** Error code from ', A6, ' =', I5, / ' ==> UPLO = ''',
+ $ A1, ''', N =', I5, ', NRHS =', I4, ', type ', I2 )
+*
+* SUBNAM, INFO, UPLO, TRANS, DIAG, N, KD, NRHS, IMAT
+*
+ 9954 FORMAT( ' *** Error code from ', A6, ' =', I5, / ' ==> UPLO=''',
+ $ A1, ''', TRANS=''', A1, ''', DIAG=''', A1, ''', N=', I5,
+ $ ', KD=', I5, ', NRHS=', I4, ', type ', I2 )
+*
+* SUBNAM, INFO, UPLO, TRANS, DIAG, N, NRHS, IMAT
+*
+ 9953 FORMAT( ' *** Error code from ', A6, ' =', I5, / ' ==> UPLO=''',
+ $ A1, ''', TRANS=''', A1, ''', DIAG=''', A1, ''', N =', I5,
+ $ ', NRHS =', I4, ', type ', I2 )
+*
+* SUBNAM, INFO, UPLO, TRANS, DIAG, NORMIN, N, IMAT
+*
+ 9952 FORMAT( ' *** Error code from ', A6, ' =', I5, / ' ==> UPLO=''',
+ $ A1, ''', TRANS=''', A1, ''', DIAG=''', A1, ''', NORMIN=''',
+ $ A1, ''', N =', I5, ', type ', I2 )
+*
+* SUBNAM, INFO, UPLO, TRANS, DIAG, NORMIN, N, KD, IMAT
+*
+ 9951 FORMAT( ' *** Error code from ', A6, ' =', I5, / ' ==> UPLO=''',
+ $ A1, ''', TRANS=''', A1, ''', DIAG=''', A1, ''', NORMIN=''',
+ $ A1, ''', N=', I5, ', KD=', I5, ', type ', I2 )
+*
+* Unknown type
+*
+ 9950 FORMAT( ' *** Error code from ', A6, ' =', I5 )
+*
+* What we do next
+*
+ 9949 FORMAT( ' ==> Doing only the condition estimate for this case' )
+*
+ RETURN
+*
+* End of ALAERH
+*
+ END
+ SUBROUTINE ALAESM( PATH, OK, NOUT )
+*
+* -- LAPACK test routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ LOGICAL OK
+ CHARACTER*3 PATH
+ INTEGER NOUT
+* ..
+*
+* Purpose
+* =======
+*
+* ALAESM prints a summary of results from one of the -ERR- routines.
+*
+* Arguments
+* =========
+*
+* PATH (input) CHARACTER*3
+* The LAPACK path name.
+*
+* OK (input) LOGICAL
+* The flag from CHKXER that indicates whether or not the tests
+* of error exits passed.
+*
+* NOUT (input) INTEGER
+* The unit number on which results are to be printed.
+* NOUT >= 0.
+*
+* =====================================================================
+*
+* .. Executable Statements ..
+*
+ IF( OK ) THEN
+ WRITE( NOUT, FMT = 9999 )PATH
+ ELSE
+ WRITE( NOUT, FMT = 9998 )PATH
+ END IF
+*
+ 9999 FORMAT( 1X, A3, ' routines passed the tests of the error exits'
+ $ )
+ 9998 FORMAT( ' *** ', A3, ' routines failed the tests of the error ',
+ $ 'exits ***' )
+ RETURN
+*
+* End of ALAESM
+*
+ END
+ SUBROUTINE ALAHD( IOUNIT, PATH )
+*
+* -- LAPACK test routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER*3 PATH
+ INTEGER IOUNIT
+* ..
+*
+* Purpose
+* =======
+*
+* ALAHD prints header information for the different test paths.
+*
+* Arguments
+* =========
+*
+* IOUNIT (input) INTEGER
+* The unit number to which the header information should be
+* printed.
+*
+* PATH (input) CHARACTER*3
+* The name of the path for which the header information is to
+* be printed. Current paths are
+* _GE: General matrices
+* _GB: General band
+* _GT: General Tridiagonal
+* _PO: Symmetric or Hermitian positive definite
+* _PP: Symmetric or Hermitian positive definite packed
+* _PB: Symmetric or Hermitian positive definite band
+* _PT: Symmetric or Hermitian positive definite tridiagonal
+* _SY: Symmetric indefinite
+* _SP: Symmetric indefinite packed
+* _HE: (complex) Hermitian indefinite
+* _HP: (complex) Hermitian indefinite packed
+* _TR: Triangular
+* _TP: Triangular packed
+* _TB: Triangular band
+* _QR: QR (general matrices)
+* _LQ: LQ (general matrices)
+* _QL: QL (general matrices)
+* _RQ: RQ (general matrices)
+* _QP: QR with column pivoting
+* _TZ: Trapezoidal
+* _LS: Least Squares driver routines
+* _LU: LU variants
+* _CH: Cholesky variants
+* _QS: QR variants
+* The first character must be one of S, D, C, or Z (C or Z only
+* if complex).
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ LOGICAL CORZ, SORD
+ CHARACTER C1, C3
+ CHARACTER*2 P2
+ CHARACTER*6 SUBNAM
+ CHARACTER*9 SYM
+* ..
+* .. External Functions ..
+ LOGICAL LSAME, LSAMEN
+ EXTERNAL LSAME, LSAMEN
+* ..
+* .. Executable Statements ..
+*
+ IF( IOUNIT.LE.0 )
+ $ RETURN
+ C1 = PATH( 1: 1 )
+ C3 = PATH( 3: 3 )
+ P2 = PATH( 2: 3 )
+ SORD = LSAME( C1, 'S' ) .OR. LSAME( C1, 'D' )
+ CORZ = LSAME( C1, 'C' ) .OR. LSAME( C1, 'Z' )
+ IF( .NOT.( SORD .OR. CORZ ) )
+ $ RETURN
+*
+ IF( LSAMEN( 2, P2, 'GE' ) ) THEN
+*
+* GE: General dense
+*
+ WRITE( IOUNIT, FMT = 9999 )PATH
+ WRITE( IOUNIT, FMT = '( '' Matrix types:'' )' )
+ WRITE( IOUNIT, FMT = 9979 )
+ WRITE( IOUNIT, FMT = '( '' Test ratios:'' )' )
+ WRITE( IOUNIT, FMT = 9962 )1
+ WRITE( IOUNIT, FMT = 9961 )2
+ WRITE( IOUNIT, FMT = 9960 )3
+ WRITE( IOUNIT, FMT = 9959 )4
+ WRITE( IOUNIT, FMT = 9958 )5
+ WRITE( IOUNIT, FMT = 9957 )6
+ WRITE( IOUNIT, FMT = 9956 )7
+ WRITE( IOUNIT, FMT = 9955 )8
+ WRITE( IOUNIT, FMT = '( '' Messages:'' )' )
+*
+ ELSE IF( LSAMEN( 2, P2, 'GB' ) ) THEN
+*
+* GB: General band
+*
+ WRITE( IOUNIT, FMT = 9998 )PATH
+ WRITE( IOUNIT, FMT = '( '' Matrix types:'' )' )
+ WRITE( IOUNIT, FMT = 9978 )
+ WRITE( IOUNIT, FMT = '( '' Test ratios:'' )' )
+ WRITE( IOUNIT, FMT = 9962 )1
+ WRITE( IOUNIT, FMT = 9960 )2
+ WRITE( IOUNIT, FMT = 9959 )3
+ WRITE( IOUNIT, FMT = 9958 )4
+ WRITE( IOUNIT, FMT = 9957 )5
+ WRITE( IOUNIT, FMT = 9956 )6
+ WRITE( IOUNIT, FMT = 9955 )7
+ WRITE( IOUNIT, FMT = '( '' Messages:'' )' )
+*
+ ELSE IF( LSAMEN( 2, P2, 'GT' ) ) THEN
+*
+* GT: General tridiagonal
+*
+ WRITE( IOUNIT, FMT = 9997 )PATH
+ WRITE( IOUNIT, FMT = 9977 )
+ WRITE( IOUNIT, FMT = '( '' Test ratios:'' )' )
+ WRITE( IOUNIT, FMT = 9962 )1
+ WRITE( IOUNIT, FMT = 9960 )2
+ WRITE( IOUNIT, FMT = 9959 )3
+ WRITE( IOUNIT, FMT = 9958 )4
+ WRITE( IOUNIT, FMT = 9957 )5
+ WRITE( IOUNIT, FMT = 9956 )6
+ WRITE( IOUNIT, FMT = 9955 )7
+ WRITE( IOUNIT, FMT = '( '' Messages:'' )' )
+*
+ ELSE IF( LSAMEN( 2, P2, 'PO' ) .OR. LSAMEN( 2, P2, 'PP' ) ) THEN
+*
+* PO: Positive definite full
+* PP: Positive definite packed
+*
+ IF( SORD ) THEN
+ SYM = 'Symmetric'
+ ELSE
+ SYM = 'Hermitian'
+ END IF
+ IF( LSAME( C3, 'O' ) ) THEN
+ WRITE( IOUNIT, FMT = 9996 )PATH, SYM
+ ELSE
+ WRITE( IOUNIT, FMT = 9995 )PATH, SYM
+ END IF
+ WRITE( IOUNIT, FMT = '( '' Matrix types:'' )' )
+ WRITE( IOUNIT, FMT = 9975 )PATH
+ WRITE( IOUNIT, FMT = '( '' Test ratios:'' )' )
+ WRITE( IOUNIT, FMT = 9954 )1
+ WRITE( IOUNIT, FMT = 9961 )2
+ WRITE( IOUNIT, FMT = 9960 )3
+ WRITE( IOUNIT, FMT = 9959 )4
+ WRITE( IOUNIT, FMT = 9958 )5
+ WRITE( IOUNIT, FMT = 9957 )6
+ WRITE( IOUNIT, FMT = 9956 )7
+ WRITE( IOUNIT, FMT = 9955 )8
+ WRITE( IOUNIT, FMT = '( '' Messages:'' )' )
+*
+ ELSE IF( LSAMEN( 2, P2, 'PB' ) ) THEN
+*
+* PB: Positive definite band
+*
+ IF( SORD ) THEN
+ WRITE( IOUNIT, FMT = 9994 )PATH, 'Symmetric'
+ ELSE
+ WRITE( IOUNIT, FMT = 9994 )PATH, 'Hermitian'
+ END IF
+ WRITE( IOUNIT, FMT = '( '' Matrix types:'' )' )
+ WRITE( IOUNIT, FMT = 9973 )PATH
+ WRITE( IOUNIT, FMT = '( '' Test ratios:'' )' )
+ WRITE( IOUNIT, FMT = 9954 )1
+ WRITE( IOUNIT, FMT = 9960 )2
+ WRITE( IOUNIT, FMT = 9959 )3
+ WRITE( IOUNIT, FMT = 9958 )4
+ WRITE( IOUNIT, FMT = 9957 )5
+ WRITE( IOUNIT, FMT = 9956 )6
+ WRITE( IOUNIT, FMT = 9955 )7
+ WRITE( IOUNIT, FMT = '( '' Messages:'' )' )
+*
+ ELSE IF( LSAMEN( 2, P2, 'PT' ) ) THEN
+*
+* PT: Positive definite tridiagonal
+*
+ IF( SORD ) THEN
+ WRITE( IOUNIT, FMT = 9993 )PATH, 'Symmetric'
+ ELSE
+ WRITE( IOUNIT, FMT = 9993 )PATH, 'Hermitian'
+ END IF
+ WRITE( IOUNIT, FMT = 9976 )
+ WRITE( IOUNIT, FMT = '( '' Test ratios:'' )' )
+ WRITE( IOUNIT, FMT = 9952 )1
+ WRITE( IOUNIT, FMT = 9960 )2
+ WRITE( IOUNIT, FMT = 9959 )3
+ WRITE( IOUNIT, FMT = 9958 )4
+ WRITE( IOUNIT, FMT = 9957 )5
+ WRITE( IOUNIT, FMT = 9956 )6
+ WRITE( IOUNIT, FMT = 9955 )7
+ WRITE( IOUNIT, FMT = '( '' Messages:'' )' )
+*
+ ELSE IF( LSAMEN( 2, P2, 'SY' ) .OR. LSAMEN( 2, P2, 'SP' ) ) THEN
+*
+* SY: Symmetric indefinite full
+* SP: Symmetric indefinite packed
+*
+ IF( LSAME( C3, 'Y' ) ) THEN
+ WRITE( IOUNIT, FMT = 9992 )PATH, 'Symmetric'
+ ELSE
+ WRITE( IOUNIT, FMT = 9991 )PATH, 'Symmetric'
+ END IF
+ WRITE( IOUNIT, FMT = '( '' Matrix types:'' )' )
+ IF( SORD ) THEN
+ WRITE( IOUNIT, FMT = 9972 )
+ ELSE
+ WRITE( IOUNIT, FMT = 9971 )
+ END IF
+ WRITE( IOUNIT, FMT = '( '' Test ratios:'' )' )
+ WRITE( IOUNIT, FMT = 9953 )1
+ WRITE( IOUNIT, FMT = 9961 )2
+ WRITE( IOUNIT, FMT = 9960 )3
+ WRITE( IOUNIT, FMT = 9959 )4
+ WRITE( IOUNIT, FMT = 9958 )5
+ WRITE( IOUNIT, FMT = 9956 )6
+ WRITE( IOUNIT, FMT = 9957 )7
+ WRITE( IOUNIT, FMT = 9955 )8
+ WRITE( IOUNIT, FMT = '( '' Messages:'' )' )
+*
+ ELSE IF( LSAMEN( 2, P2, 'HE' ) .OR. LSAMEN( 2, P2, 'HP' ) ) THEN
+*
+* HE: Hermitian indefinite full
+* HP: Hermitian indefinite packed
+*
+ IF( LSAME( C3, 'E' ) ) THEN
+ WRITE( IOUNIT, FMT = 9992 )PATH, 'Hermitian'
+ ELSE
+ WRITE( IOUNIT, FMT = 9991 )PATH, 'Hermitian'
+ END IF
+ WRITE( IOUNIT, FMT = '( '' Matrix types:'' )' )
+ WRITE( IOUNIT, FMT = 9972 )
+ WRITE( IOUNIT, FMT = '( '' Test ratios:'' )' )
+ WRITE( IOUNIT, FMT = 9953 )1
+ WRITE( IOUNIT, FMT = 9961 )2
+ WRITE( IOUNIT, FMT = 9960 )3
+ WRITE( IOUNIT, FMT = 9959 )4
+ WRITE( IOUNIT, FMT = 9958 )5
+ WRITE( IOUNIT, FMT = 9956 )6
+ WRITE( IOUNIT, FMT = 9957 )7
+ WRITE( IOUNIT, FMT = 9955 )8
+ WRITE( IOUNIT, FMT = '( '' Messages:'' )' )
+*
+ ELSE IF( LSAMEN( 2, P2, 'TR' ) .OR. LSAMEN( 2, P2, 'TP' ) ) THEN
+*
+* TR: Triangular full
+* TP: Triangular packed
+*
+ IF( LSAME( C3, 'R' ) ) THEN
+ WRITE( IOUNIT, FMT = 9990 )PATH
+ SUBNAM = PATH( 1: 1 ) // 'LATRS'
+ ELSE
+ WRITE( IOUNIT, FMT = 9989 )PATH
+ SUBNAM = PATH( 1: 1 ) // 'LATPS'
+ END IF
+ WRITE( IOUNIT, FMT = 9966 )PATH
+ WRITE( IOUNIT, FMT = 9965 )SUBNAM
+ WRITE( IOUNIT, FMT = '( '' Test ratios:'' )' )
+ WRITE( IOUNIT, FMT = 9961 )1
+ WRITE( IOUNIT, FMT = 9960 )2
+ WRITE( IOUNIT, FMT = 9959 )3
+ WRITE( IOUNIT, FMT = 9958 )4
+ WRITE( IOUNIT, FMT = 9957 )5
+ WRITE( IOUNIT, FMT = 9956 )6
+ WRITE( IOUNIT, FMT = 9955 )7
+ WRITE( IOUNIT, FMT = 9951 )SUBNAM, 8
+ WRITE( IOUNIT, FMT = '( '' Messages:'' )' )
+*
+ ELSE IF( LSAMEN( 2, P2, 'TB' ) ) THEN
+*
+* TB: Triangular band
+*
+ WRITE( IOUNIT, FMT = 9988 )PATH
+ SUBNAM = PATH( 1: 1 ) // 'LATBS'
+ WRITE( IOUNIT, FMT = 9964 )PATH
+ WRITE( IOUNIT, FMT = 9963 )SUBNAM
+ WRITE( IOUNIT, FMT = '( '' Test ratios:'' )' )
+ WRITE( IOUNIT, FMT = 9960 )1
+ WRITE( IOUNIT, FMT = 9959 )2
+ WRITE( IOUNIT, FMT = 9958 )3
+ WRITE( IOUNIT, FMT = 9957 )4
+ WRITE( IOUNIT, FMT = 9956 )5
+ WRITE( IOUNIT, FMT = 9955 )6
+ WRITE( IOUNIT, FMT = 9951 )SUBNAM, 7
+ WRITE( IOUNIT, FMT = '( '' Messages:'' )' )
+*
+ ELSE IF( LSAMEN( 2, P2, 'QR' ) ) THEN
+*
+* QR decomposition of rectangular matrices
+*
+ WRITE( IOUNIT, FMT = 9987 )PATH, 'QR'
+ WRITE( IOUNIT, FMT = '( '' Matrix types:'' )' )
+ WRITE( IOUNIT, FMT = 9970 )
+ WRITE( IOUNIT, FMT = '( '' Test ratios:'' )' )
+ WRITE( IOUNIT, FMT = 9950 )1
+ WRITE( IOUNIT, FMT = 9946 )2
+ WRITE( IOUNIT, FMT = 9944 )3, 'M'
+ WRITE( IOUNIT, FMT = 9943 )4, 'M'
+ WRITE( IOUNIT, FMT = 9942 )5, 'M'
+ WRITE( IOUNIT, FMT = 9941 )6, 'M'
+ WRITE( IOUNIT, FMT = 9960 )7
+ WRITE( IOUNIT, FMT = '( '' Messages:'' )' )
+*
+ ELSE IF( LSAMEN( 2, P2, 'LQ' ) ) THEN
+*
+* LQ decomposition of rectangular matrices
+*
+ WRITE( IOUNIT, FMT = 9987 )PATH, 'LQ'
+ WRITE( IOUNIT, FMT = '( '' Matrix types:'' )' )
+ WRITE( IOUNIT, FMT = 9970 )
+ WRITE( IOUNIT, FMT = '( '' Test ratios:'' )' )
+ WRITE( IOUNIT, FMT = 9949 )1
+ WRITE( IOUNIT, FMT = 9945 )2
+ WRITE( IOUNIT, FMT = 9944 )3, 'N'
+ WRITE( IOUNIT, FMT = 9943 )4, 'N'
+ WRITE( IOUNIT, FMT = 9942 )5, 'N'
+ WRITE( IOUNIT, FMT = 9941 )6, 'N'
+ WRITE( IOUNIT, FMT = 9960 )7
+ WRITE( IOUNIT, FMT = '( '' Messages:'' )' )
+*
+ ELSE IF( LSAMEN( 2, P2, 'QL' ) ) THEN
+*
+* QL decomposition of rectangular matrices
+*
+ WRITE( IOUNIT, FMT = 9987 )PATH, 'QL'
+ WRITE( IOUNIT, FMT = '( '' Matrix types:'' )' )
+ WRITE( IOUNIT, FMT = 9970 )
+ WRITE( IOUNIT, FMT = '( '' Test ratios:'' )' )
+ WRITE( IOUNIT, FMT = 9948 )1
+ WRITE( IOUNIT, FMT = 9946 )2
+ WRITE( IOUNIT, FMT = 9944 )3, 'M'
+ WRITE( IOUNIT, FMT = 9943 )4, 'M'
+ WRITE( IOUNIT, FMT = 9942 )5, 'M'
+ WRITE( IOUNIT, FMT = 9941 )6, 'M'
+ WRITE( IOUNIT, FMT = 9960 )7
+ WRITE( IOUNIT, FMT = '( '' Messages:'' )' )
+*
+ ELSE IF( LSAMEN( 2, P2, 'RQ' ) ) THEN
+*
+* RQ decomposition of rectangular matrices
+*
+ WRITE( IOUNIT, FMT = 9987 )PATH, 'RQ'
+ WRITE( IOUNIT, FMT = '( '' Matrix types:'' )' )
+ WRITE( IOUNIT, FMT = 9970 )
+ WRITE( IOUNIT, FMT = '( '' Test ratios:'' )' )
+ WRITE( IOUNIT, FMT = 9947 )1
+ WRITE( IOUNIT, FMT = 9945 )2
+ WRITE( IOUNIT, FMT = 9944 )3, 'N'
+ WRITE( IOUNIT, FMT = 9943 )4, 'N'
+ WRITE( IOUNIT, FMT = 9942 )5, 'N'
+ WRITE( IOUNIT, FMT = 9941 )6, 'N'
+ WRITE( IOUNIT, FMT = 9960 )7
+ WRITE( IOUNIT, FMT = '( '' Messages:'' )' )
+*
+ ELSE IF( LSAMEN( 2, P2, 'QP' ) ) THEN
+*
+* QR decomposition with column pivoting
+*
+ WRITE( IOUNIT, FMT = 9986 )PATH
+ WRITE( IOUNIT, FMT = 9969 )
+ WRITE( IOUNIT, FMT = '( '' Test ratios:'' )' )
+ WRITE( IOUNIT, FMT = 9940 )1
+ WRITE( IOUNIT, FMT = 9939 )2
+ WRITE( IOUNIT, FMT = 9938 )3
+ WRITE( IOUNIT, FMT = '( '' Messages:'' )' )
+*
+ ELSE IF( LSAMEN( 2, P2, 'TZ' ) ) THEN
+*
+* TZ: Trapezoidal
+*
+ WRITE( IOUNIT, FMT = 9985 )PATH
+ WRITE( IOUNIT, FMT = 9968 )
+ WRITE( IOUNIT, FMT = 9929 )C1, C1
+ WRITE( IOUNIT, FMT = '( '' Test ratios:'' )' )
+ WRITE( IOUNIT, FMT = 9940 )1
+ WRITE( IOUNIT, FMT = 9937 )2
+ WRITE( IOUNIT, FMT = 9938 )3
+ WRITE( IOUNIT, FMT = 9940 )4
+ WRITE( IOUNIT, FMT = 9937 )5
+ WRITE( IOUNIT, FMT = 9938 )6
+ WRITE( IOUNIT, FMT = '( '' Messages:'' )' )
+*
+ ELSE IF( LSAMEN( 2, P2, 'LS' ) ) THEN
+*
+* LS: Least Squares driver routines for
+* LS, LSD, LSS, LSX and LSY.
+*
+ WRITE( IOUNIT, FMT = 9984 )PATH
+ WRITE( IOUNIT, FMT = 9967 )
+ WRITE( IOUNIT, FMT = 9921 )C1, C1, C1, C1, C1
+ WRITE( IOUNIT, FMT = 9935 )1
+ WRITE( IOUNIT, FMT = 9931 )2
+ WRITE( IOUNIT, FMT = 9933 )3
+ WRITE( IOUNIT, FMT = 9935 )4
+ WRITE( IOUNIT, FMT = 9934 )5
+ WRITE( IOUNIT, FMT = 9932 )6
+ WRITE( IOUNIT, FMT = 9920 )
+ WRITE( IOUNIT, FMT = '( '' Messages:'' )' )
+*
+ ELSE IF( LSAMEN( 2, P2, 'LU' ) ) THEN
+*
+* LU factorization variants
+*
+ WRITE( IOUNIT, FMT = 9983 )PATH
+ WRITE( IOUNIT, FMT = '( '' Matrix types:'' )' )
+ WRITE( IOUNIT, FMT = 9979 )
+ WRITE( IOUNIT, FMT = '( '' Test ratio:'' )' )
+ WRITE( IOUNIT, FMT = 9962 )1
+ WRITE( IOUNIT, FMT = '( '' Messages:'' )' )
+*
+ ELSE IF( LSAMEN( 2, P2, 'CH' ) ) THEN
+*
+* Cholesky factorization variants
+*
+ WRITE( IOUNIT, FMT = 9982 )PATH
+ WRITE( IOUNIT, FMT = '( '' Matrix types:'' )' )
+ WRITE( IOUNIT, FMT = 9974 )
+ WRITE( IOUNIT, FMT = '( '' Test ratio:'' )' )
+ WRITE( IOUNIT, FMT = 9954 )1
+ WRITE( IOUNIT, FMT = '( '' Messages:'' )' )
+*
+ ELSE IF( LSAMEN( 2, P2, 'QS' ) ) THEN
+*
+* QR factorization variants
+*
+ WRITE( IOUNIT, FMT = 9981 )PATH
+ WRITE( IOUNIT, FMT = '( '' Matrix types:'' )' )
+ WRITE( IOUNIT, FMT = 9970 )
+ WRITE( IOUNIT, FMT = '( '' Test ratios:'' )' )
+*
+ ELSE
+*
+* Print error message if no header is available.
+*
+ WRITE( IOUNIT, FMT = 9980 )PATH
+ END IF
+*
+* First line of header
+*
+ 9999 FORMAT( / 1X, A3, ': General dense matrices' )
+ 9998 FORMAT( / 1X, A3, ': General band matrices' )
+ 9997 FORMAT( / 1X, A3, ': General tridiagonal' )
+ 9996 FORMAT( / 1X, A3, ': ', A9, ' positive definite matrices' )
+ 9995 FORMAT( / 1X, A3, ': ', A9, ' positive definite packed matrices'
+ $ )
+ 9994 FORMAT( / 1X, A3, ': ', A9, ' positive definite band matrices' )
+ 9993 FORMAT( / 1X, A3, ': ', A9, ' positive definite tridiagonal' )
+ 9992 FORMAT( / 1X, A3, ': ', A9, ' indefinite matrices' )
+ 9991 FORMAT( / 1X, A3, ': ', A9, ' indefinite packed matrices' )
+ 9990 FORMAT( / 1X, A3, ': Triangular matrices' )
+ 9989 FORMAT( / 1X, A3, ': Triangular packed matrices' )
+ 9988 FORMAT( / 1X, A3, ': Triangular band matrices' )
+ 9987 FORMAT( / 1X, A3, ': ', A2, ' factorization of general matrices'
+ $ )
+ 9986 FORMAT( / 1X, A3, ': QR factorization with column pivoting' )
+ 9985 FORMAT( / 1X, A3, ': RQ factorization of trapezoidal matrix' )
+ 9984 FORMAT( / 1X, A3, ': Least squares driver routines' )
+ 9983 FORMAT( / 1X, A3, ': LU factorization variants' )
+ 9982 FORMAT( / 1X, A3, ': Cholesky factorization variants' )
+ 9981 FORMAT( / 1X, A3, ': QR factorization variants' )
+ 9980 FORMAT( / 1X, A3, ': No header available' )
+*
+* GE matrix types
+*
+ 9979 FORMAT( 4X, '1. Diagonal', 24X, '7. Last n/2 columns zero', / 4X,
+ $ '2. Upper triangular', 16X,
+ $ '8. Random, CNDNUM = sqrt(0.1/EPS)', / 4X,
+ $ '3. Lower triangular', 16X, '9. Random, CNDNUM = 0.1/EPS',
+ $ / 4X, '4. Random, CNDNUM = 2', 13X,
+ $ '10. Scaled near underflow', / 4X, '5. First column zero',
+ $ 14X, '11. Scaled near overflow', / 4X,
+ $ '6. Last column zero' )
+*
+* GB matrix types
+*
+ 9978 FORMAT( 4X, '1. Random, CNDNUM = 2', 14X,
+ $ '5. Random, CNDNUM = sqrt(0.1/EPS)', / 4X,
+ $ '2. First column zero', 15X, '6. Random, CNDNUM = .01/EPS',
+ $ / 4X, '3. Last column zero', 16X,
+ $ '7. Scaled near underflow', / 4X,
+ $ '4. Last n/2 columns zero', 11X, '8. Scaled near overflow' )
+*
+* GT matrix types
+*
+ 9977 FORMAT( ' Matrix types (1-6 have specified condition numbers):',
+ $ / 4X, '1. Diagonal', 24X, '7. Random, unspecified CNDNUM',
+ $ / 4X, '2. Random, CNDNUM = 2', 14X, '8. First column zero',
+ $ / 4X, '3. Random, CNDNUM = sqrt(0.1/EPS)', 2X,
+ $ '9. Last column zero', / 4X, '4. Random, CNDNUM = 0.1/EPS',
+ $ 7X, '10. Last n/2 columns zero', / 4X,
+ $ '5. Scaled near underflow', 10X,
+ $ '11. Scaled near underflow', / 4X,
+ $ '6. Scaled near overflow', 11X, '12. Scaled near overflow' )
+*
+* PT matrix types
+*
+ 9976 FORMAT( ' Matrix types (1-6 have specified condition numbers):',
+ $ / 4X, '1. Diagonal', 24X, '7. Random, unspecified CNDNUM',
+ $ / 4X, '2. Random, CNDNUM = 2', 14X,
+ $ '8. First row and column zero', / 4X,
+ $ '3. Random, CNDNUM = sqrt(0.1/EPS)', 2X,
+ $ '9. Last row and column zero', / 4X,
+ $ '4. Random, CNDNUM = 0.1/EPS', 7X,
+ $ '10. Middle row and column zero', / 4X,
+ $ '5. Scaled near underflow', 10X,
+ $ '11. Scaled near underflow', / 4X,
+ $ '6. Scaled near overflow', 11X, '12. Scaled near overflow' )
+*
+* PO, PP matrix types
+*
+ 9975 FORMAT( 4X, '1. Diagonal', 24X,
+ $ '6. Random, CNDNUM = sqrt(0.1/EPS)', / 4X,
+ $ '2. Random, CNDNUM = 2', 14X, '7. Random, CNDNUM = 0.1/EPS',
+ $ / 3X, '*3. First row and column zero', 7X,
+ $ '8. Scaled near underflow', / 3X,
+ $ '*4. Last row and column zero', 8X,
+ $ '9. Scaled near overflow', / 3X,
+ $ '*5. Middle row and column zero', / 3X,
+ $ '(* - tests error exits from ', A3,
+ $ 'TRF, no test ratios are computed)' )
+*
+* CH matrix types
+*
+ 9974 FORMAT( 4X, '1. Diagonal', 24X,
+ $ '6. Random, CNDNUM = sqrt(0.1/EPS)', / 4X,
+ $ '2. Random, CNDNUM = 2', 14X, '7. Random, CNDNUM = 0.1/EPS',
+ $ / 3X, '*3. First row and column zero', 7X,
+ $ '8. Scaled near underflow', / 3X,
+ $ '*4. Last row and column zero', 8X,
+ $ '9. Scaled near overflow', / 3X,
+ $ '*5. Middle row and column zero', / 3X,
+ $ '(* - tests error exits, no test ratios are computed)' )
+*
+* PB matrix types
+*
+ 9973 FORMAT( 4X, '1. Random, CNDNUM = 2', 14X,
+ $ '5. Random, CNDNUM = sqrt(0.1/EPS)', / 3X,
+ $ '*2. First row and column zero', 7X,
+ $ '6. Random, CNDNUM = 0.1/EPS', / 3X,
+ $ '*3. Last row and column zero', 8X,
+ $ '7. Scaled near underflow', / 3X,
+ $ '*4. Middle row and column zero', 6X,
+ $ '8. Scaled near overflow', / 3X,
+ $ '(* - tests error exits from ', A3,
+ $ 'TRF, no test ratios are computed)' )
+*
+* SSY, SSP, CHE, CHP matrix types
+*
+ 9972 FORMAT( 4X, '1. Diagonal', 24X,
+ $ '6. Last n/2 rows and columns zero', / 4X,
+ $ '2. Random, CNDNUM = 2', 14X,
+ $ '7. Random, CNDNUM = sqrt(0.1/EPS)', / 4X,
+ $ '3. First row and column zero', 7X,
+ $ '8. Random, CNDNUM = 0.1/EPS', / 4X,
+ $ '4. Last row and column zero', 8X,
+ $ '9. Scaled near underflow', / 4X,
+ $ '5. Middle row and column zero', 5X,
+ $ '10. Scaled near overflow' )
+*
+* CSY, CSP matrix types
+*
+ 9971 FORMAT( 4X, '1. Diagonal', 24X,
+ $ '7. Random, CNDNUM = sqrt(0.1/EPS)', / 4X,
+ $ '2. Random, CNDNUM = 2', 14X, '8. Random, CNDNUM = 0.1/EPS',
+ $ / 4X, '3. First row and column zero', 7X,
+ $ '9. Scaled near underflow', / 4X,
+ $ '4. Last row and column zero', 7X,
+ $ '10. Scaled near overflow', / 4X,
+ $ '5. Middle row and column zero', 5X,
+ $ '11. Block diagonal matrix', / 4X,
+ $ '6. Last n/2 rows and columns zero' )
+*
+* QR matrix types
+*
+ 9970 FORMAT( 4X, '1. Diagonal', 24X,
+ $ '5. Random, CNDNUM = sqrt(0.1/EPS)', / 4X,
+ $ '2. Upper triangular', 16X, '6. Random, CNDNUM = 0.1/EPS',
+ $ / 4X, '3. Lower triangular', 16X,
+ $ '7. Scaled near underflow', / 4X, '4. Random, CNDNUM = 2',
+ $ 14X, '8. Scaled near overflow' )
+*
+* QP matrix types
+*
+ 9969 FORMAT( ' Matrix types (2-6 have condition 1/EPS):', / 4X,
+ $ '1. Zero matrix', 21X, '4. First n/2 columns fixed', / 4X,
+ $ '2. One small eigenvalue', 12X, '5. Last n/2 columns fixed',
+ $ / 4X, '3. Geometric distribution', 10X,
+ $ '6. Every second column fixed' )
+*
+* TZ matrix types
+*
+ 9968 FORMAT( ' Matrix types (2-3 have condition 1/EPS):', / 4X,
+ $ '1. Zero matrix', / 4X, '2. One small eigenvalue', / 4X,
+ $ '3. Geometric distribution' )
+*
+* LS matrix types
+*
+ 9967 FORMAT( ' Matrix types (1-3: full rank, 4-6: rank deficient):',
+ $ / 4X, '1 and 4. Normal scaling', / 4X,
+ $ '2 and 5. Scaled near overflow', / 4X,
+ $ '3 and 6. Scaled near underflow' )
+*
+* TR, TP matrix types
+*
+ 9966 FORMAT( ' Matrix types for ', A3, ' routines:', / 4X,
+ $ '1. Diagonal', 24X, '6. Scaled near overflow', / 4X,
+ $ '2. Random, CNDNUM = 2', 14X, '7. Identity', / 4X,
+ $ '3. Random, CNDNUM = sqrt(0.1/EPS) ',
+ $ '8. Unit triangular, CNDNUM = 2', / 4X,
+ $ '4. Random, CNDNUM = 0.1/EPS', 8X,
+ $ '9. Unit, CNDNUM = sqrt(0.1/EPS)', / 4X,
+ $ '5. Scaled near underflow', 10X,
+ $ '10. Unit, CNDNUM = 0.1/EPS' )
+ 9965 FORMAT( ' Special types for testing ', A6, ':', / 3X,
+ $ '11. Matrix elements are O(1), large right hand side', / 3X,
+ $ '12. First diagonal causes overflow,',
+ $ ' offdiagonal column norms < 1', / 3X,
+ $ '13. First diagonal causes overflow,',
+ $ ' offdiagonal column norms > 1', / 3X,
+ $ '14. Growth factor underflows, solution does not overflow',
+ $ / 3X, '15. Small diagonal causes gradual overflow', / 3X,
+ $ '16. One zero diagonal element', / 3X,
+ $ '17. Large offdiagonals cause overflow when adding a column'
+ $ , / 3X, '18. Unit triangular with large right hand side' )
+*
+* TB matrix types
+*
+ 9964 FORMAT( ' Matrix types for ', A3, ' routines:', / 4X,
+ $ '1. Random, CNDNUM = 2', 14X, '6. Identity', / 4X,
+ $ '2. Random, CNDNUM = sqrt(0.1/EPS) ',
+ $ '7. Unit triangular, CNDNUM = 2', / 4X,
+ $ '3. Random, CNDNUM = 0.1/EPS', 8X,
+ $ '8. Unit, CNDNUM = sqrt(0.1/EPS)', / 4X,
+ $ '4. Scaled near underflow', 11X,
+ $ '9. Unit, CNDNUM = 0.1/EPS', / 4X,
+ $ '5. Scaled near overflow' )
+ 9963 FORMAT( ' Special types for testing ', A6, ':', / 3X,
+ $ '10. Matrix elements are O(1), large right hand side', / 3X,
+ $ '11. First diagonal causes overflow,',
+ $ ' offdiagonal column norms < 1', / 3X,
+ $ '12. First diagonal causes overflow,',
+ $ ' offdiagonal column norms > 1', / 3X,
+ $ '13. Growth factor underflows, solution does not overflow',
+ $ / 3X, '14. Small diagonal causes gradual overflow', / 3X,
+ $ '15. One zero diagonal element', / 3X,
+ $ '16. Large offdiagonals cause overflow when adding a column'
+ $ , / 3X, '17. Unit triangular with large right hand side' )
+*
+* Test ratios
+*
+ 9962 FORMAT( 3X, I2, ': norm( L * U - A ) / ( N * norm(A) * EPS )' )
+ 9961 FORMAT( 3X, I2, ': norm( I - A*AINV ) / ',
+ $ '( N * norm(A) * norm(AINV) * EPS )' )
+ 9960 FORMAT( 3X, I2, ': norm( B - A * X ) / ',
+ $ '( norm(A) * norm(X) * EPS )' )
+ 9959 FORMAT( 3X, I2, ': norm( X - XACT ) / ',
+ $ '( norm(XACT) * CNDNUM * EPS )' )
+ 9958 FORMAT( 3X, I2, ': norm( X - XACT ) / ',
+ $ '( norm(XACT) * CNDNUM * EPS ), refined' )
+ 9957 FORMAT( 3X, I2, ': norm( X - XACT ) / ',
+ $ '( norm(XACT) * (error bound) )' )
+ 9956 FORMAT( 3X, I2, ': (backward error) / EPS' )
+ 9955 FORMAT( 3X, I2, ': RCOND * CNDNUM - 1.0' )
+ 9954 FORMAT( 3X, I2, ': norm( U'' * U - A ) / ( N * norm(A) * EPS )',
+ $ ', or', / 7X, 'norm( L * L'' - A ) / ( N * norm(A) * EPS )'
+ $ )
+ 9953 FORMAT( 3X, I2, ': norm( U*D*U'' - A ) / ( N * norm(A) * EPS )',
+ $ ', or', / 7X, 'norm( L*D*L'' - A ) / ( N * norm(A) * EPS )'
+ $ )
+ 9952 FORMAT( 3X, I2, ': norm( U''*D*U - A ) / ( N * norm(A) * EPS )',
+ $ ', or', / 7X, 'norm( L*D*L'' - A ) / ( N * norm(A) * EPS )'
+ $ )
+ 9951 FORMAT( ' Test ratio for ', A6, ':', / 3X, I2,
+ $ ': norm( s*b - A*x ) / ( norm(A) * norm(x) * EPS )' )
+ 9950 FORMAT( 3X, I2, ': norm( R - Q'' * A ) / ( M * norm(A) * EPS )' )
+ 9949 FORMAT( 3X, I2, ': norm( L - A * Q'' ) / ( N * norm(A) * EPS )' )
+ 9948 FORMAT( 3X, I2, ': norm( L - Q'' * A ) / ( M * norm(A) * EPS )' )
+ 9947 FORMAT( 3X, I2, ': norm( R - A * Q'' ) / ( N * norm(A) * EPS )' )
+ 9946 FORMAT( 3X, I2, ': norm( I - Q''*Q ) / ( M * EPS )' )
+ 9945 FORMAT( 3X, I2, ': norm( I - Q*Q'' ) / ( N * EPS )' )
+ 9944 FORMAT( 3X, I2, ': norm( Q*C - Q*C ) / ', '( ', A1,
+ $ ' * norm(C) * EPS )' )
+ 9943 FORMAT( 3X, I2, ': norm( C*Q - C*Q ) / ', '( ', A1,
+ $ ' * norm(C) * EPS )' )
+ 9942 FORMAT( 3X, I2, ': norm( Q''*C - Q''*C )/ ', '( ', A1,
+ $ ' * norm(C) * EPS )' )
+ 9941 FORMAT( 3X, I2, ': norm( C*Q'' - C*Q'' )/ ', '( ', A1,
+ $ ' * norm(C) * EPS )' )
+ 9940 FORMAT( 3X, I2, ': norm(svd(A) - svd(R)) / ',
+ $ '( M * norm(svd(R)) * EPS )' )
+ 9939 FORMAT( 3X, I2, ': norm( A*P - Q*R ) / ( M * norm(A) * EPS )'
+ $ )
+ 9938 FORMAT( 3X, I2, ': norm( I - Q''*Q ) / ( M * EPS )' )
+ 9937 FORMAT( 3X, I2, ': norm( A - R*Q ) / ( M * norm(A) * EPS )'
+ $ )
+ 9936 FORMAT( ' Test ratios (1-2: ', A1, 'GELS, 3-6: ', A1,
+ $ 'GELSS, 7-10: ', A1, 'GELSX):' )
+ 9935 FORMAT( 3X, I2, ': norm( B - A * X ) / ',
+ $ '( max(M,N) * norm(A) * norm(X) * EPS )' )
+ 9934 FORMAT( 3X, I2, ': norm( (A*X-B)'' *A ) / ',
+ $ '( max(M,N,NRHS) * norm(A) * norm(B) * EPS )' )
+ 9933 FORMAT( 3X, I2, ': norm(svd(A)-svd(R)) / ',
+ $ '( min(M,N) * norm(svd(R)) * EPS )' )
+ 9932 FORMAT( 3X, I2, ': Check if X is in the row space of A or A''' )
+ 9931 FORMAT( 3X, I2, ': norm( (A*X-B)'' *A ) / ',
+ $ '( max(M,N,NRHS) * norm(A) * norm(B) * EPS )', / 7X,
+ $ 'if TRANS=''N'' and M.GE.N or TRANS=''T'' and M.LT.N, ',
+ $ 'otherwise', / 7X,
+ $ 'check if X is in the row space of A or A'' ',
+ $ '(overdetermined case)' )
+ 9930 FORMAT( 3X, ' 7-10: same as 3-6' )
+ 9929 FORMAT( ' Test ratios (1-3: ', A1, 'TZRQF, 4-6: ', A1,
+ $ 'TZRZF):' )
+ 9920 FORMAT( 3X, ' 7-10: same as 3-6', 3X, ' 11-14: same as 3-6',
+ $ 3X, ' 15-18: same as 3-6' )
+ 9921 FORMAT( ' Test ratios:', / ' (1-2: ', A1, 'GELS, 3-6: ', A1,
+ $ 'GELSX, 7-10: ', A1, 'GELSY, 11-14: ', A1, 'GELSS, 15-18: ',
+ $ A1, 'GELSD)' )
+*
+ RETURN
+*
+* End of ALAHD
+*
+ END
+ SUBROUTINE ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT )
+*
+* -- LAPACK test routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER*3 PATH
+ INTEGER NIN, NMATS, NOUT, NTYPES
+* ..
+* .. Array Arguments ..
+ LOGICAL DOTYPE( * )
+* ..
+*
+* Purpose
+* =======
+*
+* ALAREQ handles input for the LAPACK test program. It is called
+* to evaluate the input line which requested NMATS matrix types for
+* PATH. The flow of control is as follows:
+*
+* If NMATS = NTYPES then
+* DOTYPE(1:NTYPES) = .TRUE.
+* else
+* Read the next input line for NMATS matrix types
+* Set DOTYPE(I) = .TRUE. for each valid type I
+* endif
+*
+* Arguments
+* =========
+*
+* PATH (input) CHARACTER*3
+* An LAPACK path name for testing.
+*
+* NMATS (input) INTEGER
+* The number of matrix types to be used in testing this path.
+*
+* DOTYPE (output) LOGICAL array, dimension (NTYPES)
+* The vector of flags indicating if each type will be tested.
+*
+* NTYPES (input) INTEGER
+* The maximum number of matrix types for this path.
+*
+* NIN (input) INTEGER
+* The unit number for input. NIN >= 1.
+*
+* NOUT (input) INTEGER
+* The unit number for output. NOUT >= 1.
+*
+* =====================================================================
+*
+* .. Local Scalars ..
+ LOGICAL FIRSTT
+ CHARACTER C1
+ CHARACTER*10 INTSTR
+ CHARACTER*80 LINE
+ INTEGER I, I1, IC, J, K, LENP, NT
+* ..
+* .. Local Arrays ..
+ INTEGER NREQ( 100 )
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC LEN
+* ..
+* .. Data statements ..
+ DATA INTSTR / '0123456789' /
+* ..
+* .. Executable Statements ..
+*
+ IF( NMATS.GE.NTYPES ) THEN
+*
+* Test everything if NMATS >= NTYPES.
+*
+ DO 10 I = 1, NTYPES
+ DOTYPE( I ) = .TRUE.
+ 10 CONTINUE
+ ELSE
+ DO 20 I = 1, NTYPES
+ DOTYPE( I ) = .FALSE.
+ 20 CONTINUE
+ FIRSTT = .TRUE.
+*
+* Read a line of matrix types if 0 < NMATS < NTYPES.
+*
+ IF( NMATS.GT.0 ) THEN
+ READ( NIN, FMT = '(A80)', END = 90 )LINE
+ LENP = LEN( LINE )
+ I = 0
+ DO 60 J = 1, NMATS
+ NREQ( J ) = 0
+ I1 = 0
+ 30 CONTINUE
+ I = I + 1
+ IF( I.GT.LENP ) THEN
+ IF( J.EQ.NMATS .AND. I1.GT.0 ) THEN
+ GO TO 60
+ ELSE
+ WRITE( NOUT, FMT = 9995 )LINE
+ WRITE( NOUT, FMT = 9994 )NMATS
+ GO TO 80
+ END IF
+ END IF
+ IF( LINE( I: I ).NE.' ' .AND. LINE( I: I ).NE.',' ) THEN
+ I1 = I
+ C1 = LINE( I1: I1 )
+*
+* Check that a valid integer was read
+*
+ DO 40 K = 1, 10
+ IF( C1.EQ.INTSTR( K: K ) ) THEN
+ IC = K - 1
+ GO TO 50
+ END IF
+ 40 CONTINUE
+ WRITE( NOUT, FMT = 9996 )I, LINE
+ WRITE( NOUT, FMT = 9994 )NMATS
+ GO TO 80
+ 50 CONTINUE
+ NREQ( J ) = 10*NREQ( J ) + IC
+ GO TO 30
+ ELSE IF( I1.GT.0 ) THEN
+ GO TO 60
+ ELSE
+ GO TO 30
+ END IF
+ 60 CONTINUE
+ END IF
+ DO 70 I = 1, NMATS
+ NT = NREQ( I )
+ IF( NT.GT.0 .AND. NT.LE.NTYPES ) THEN
+ IF( DOTYPE( NT ) ) THEN
+ IF( FIRSTT )
+ $ WRITE( NOUT, FMT = * )
+ FIRSTT = .FALSE.
+ WRITE( NOUT, FMT = 9997 )NT, PATH
+ END IF
+ DOTYPE( NT ) = .TRUE.
+ ELSE
+ WRITE( NOUT, FMT = 9999 )PATH, NT, NTYPES
+ 9999 FORMAT( ' *** Invalid type request for ', A3, ', type ',
+ $ I4, ': must satisfy 1 <= type <= ', I2 )
+ END IF
+ 70 CONTINUE
+ 80 CONTINUE
+ END IF
+ RETURN
+*
+ 90 CONTINUE
+ WRITE( NOUT, FMT = 9998 )PATH
+ 9998 FORMAT( /' *** End of file reached when trying to read matrix ',
+ $ 'types for ', A3, /' *** Check that you are requesting the',
+ $ ' right number of types for each path', / )
+ 9997 FORMAT( ' *** Warning: duplicate request of matrix type ', I2,
+ $ ' for ', A3 )
+ 9996 FORMAT( //' *** Invalid integer value in column ', I2,
+ $ ' of input', ' line:', /A79 )
+ 9995 FORMAT( //' *** Not enough matrix types on input line', /A79 )
+ 9994 FORMAT( ' ==> Specify ', I4, ' matrix types on this line or ',
+ $ 'adjust NTYPES on previous line' )
+ WRITE( NOUT, FMT = * )
+ STOP
+*
+* End of ALAREQ
+*
+ END
+ SUBROUTINE ALASUM( TYPE, NOUT, NFAIL, NRUN, NERRS )
+*
+* -- LAPACK test routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER*3 TYPE
+ INTEGER NFAIL, NOUT, NRUN, NERRS
+* ..
+*
+* Purpose
+* =======
+*
+* ALASUM prints a summary of results from one of the -CHK- routines.
+*
+* Arguments
+* =========
+*
+* TYPE (input) CHARACTER*3
+* The LAPACK path name.
+*
+* NOUT (input) INTEGER
+* The unit number on which results are to be printed.
+* NOUT >= 0.
+*
+* NFAIL (input) INTEGER
+* The number of tests which did not pass the threshold ratio.
+*
+* NRUN (input) INTEGER
+* The total number of tests.
+*
+* NERRS (input) INTEGER
+* The number of error messages recorded.
+*
+* =====================================================================
+*
+* .. Executable Statements ..
+*
+ IF( NFAIL.GT.0 ) THEN
+ WRITE( NOUT, FMT = 9999 )TYPE, NFAIL, NRUN
+ ELSE
+ WRITE( NOUT, FMT = 9998 )TYPE, NRUN
+ END IF
+ IF( NERRS.GT.0 ) THEN
+ WRITE( NOUT, FMT = 9997 )NERRS
+ END IF
+*
+ 9999 FORMAT( 1X, A3, ': ', I6, ' out of ', I6,
+ $ ' tests failed to pass the threshold' )
+ 9998 FORMAT( /1X, 'All tests for ', A3,
+ $ ' routines passed the threshold (', I6, ' tests run)' )
+ 9997 FORMAT( 6X, I6, ' error messages recorded' )
+ RETURN
+*
+* End of ALASUM
+*
+ END
+ SUBROUTINE ALASVM( TYPE, NOUT, NFAIL, NRUN, NERRS )
+*
+* -- LAPACK test routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ CHARACTER*3 TYPE
+ INTEGER NFAIL, NOUT, NRUN, NERRS
+* ..
+*
+* Purpose
+* =======
+*
+* ALASVM prints a summary of results from one of the -DRV- routines.
+*
+* Arguments
+* =========
+*
+* TYPE (input) CHARACTER*3
+* The LAPACK path name.
+*
+* NOUT (input) INTEGER
+* The unit number on which results are to be printed.
+* NOUT >= 0.
+*
+* NFAIL (input) INTEGER
+* The number of tests which did not pass the threshold ratio.
+*
+* NRUN (input) INTEGER
+* The total number of tests.
+*
+* NERRS (input) INTEGER
+* The number of error messages recorded.
+*
+* =====================================================================
+*
+* .. Executable Statements ..
+*
+ IF( NFAIL.GT.0 ) THEN
+ WRITE( NOUT, FMT = 9999 )TYPE, NFAIL, NRUN
+ ELSE
+ WRITE( NOUT, FMT = 9998 )TYPE, NRUN
+ END IF
+ IF( NERRS.GT.0 ) THEN
+ WRITE( NOUT, FMT = 9997 )NERRS
+ END IF
+*
+ 9999 FORMAT( 1X, A3, ' drivers: ', I6, ' out of ', I6,
+ $ ' tests failed to pass the threshold' )
+ 9998 FORMAT( /1X, 'All tests for ', A3, ' drivers passed the ',
+ $ 'threshold (', I6, ' tests run)' )
+ 9997 FORMAT( 14X, I6, ' error messages recorded' )
+ RETURN
+*
+* End of ALASVM
+*
+ END
+ SUBROUTINE CHKXER( SRNAMT, INFOT, NOUT, LERR, OK )
+*
+* Tests whether XERBLA has detected an error when it should.
+*
+* Auxiliary routine for test program for Level 2 Blas.
+*
+* -- Written on 10-August-1987.
+* Richard Hanson, Sandia National Labs.
+* Jeremy Du Croz, NAG Central Office.
+*
+* =====================================================================
+*
+* .. Scalar Arguments ..
+ LOGICAL LERR, OK
+ CHARACTER*6 SRNAMT
+ INTEGER INFOT, NOUT
+* ..
+* .. Executable Statements ..
+ IF( .NOT.LERR ) THEN
+ WRITE( NOUT, FMT = 9999 )INFOT, SRNAMT
+ OK = .FALSE.
+ END IF
+ LERR = .FALSE.
+ RETURN
+*
+ 9999 FORMAT( ' *** Illegal value of parameter number ', I2,
+ $ ' not detected by ', A6, ' ***' )
+*
+* End of CHKXER.
+*
+ END
+ PROGRAM DCHKAA
+*
+* -- LAPACK test routine (version 3.1.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* January 2007
+*
+* Purpose
+* =======
+*
+* DCHKAA is the main test program for the DOUBLE PRECISION LAPACK
+* linear equation routines
+*
+* The program must be driven by a short data file. The first 14 records
+* specify problem dimensions and program options using list-directed
+* input. The remaining lines specify the LAPACK test paths and the
+* number of matrix types to use in testing. An annotated example of a
+* data file can be obtained by deleting the first 3 characters from the
+* following 36 lines:
+* Data file for testing DOUBLE PRECISION LAPACK linear eqn. routines
+* 7 Number of values of M
+* 0 1 2 3 5 10 16 Values of M (row dimension)
+* 7 Number of values of N
+* 0 1 2 3 5 10 16 Values of N (column dimension)
+* 1 Number of values of NRHS
+* 2 Values of NRHS (number of right hand sides)
+* 5 Number of values of NB
+* 1 3 3 3 20 Values of NB (the blocksize)
+* 1 0 5 9 1 Values of NX (crossover point)
+* 20.0 Threshold value of test ratio
+* T Put T to test the LAPACK routines
+* T Put T to test the driver routines
+* T Put T to test the error exits
+* DGE 11 List types on next line if 0 < NTYPES < 11
+* DGB 8 List types on next line if 0 < NTYPES < 8
+* DGT 12 List types on next line if 0 < NTYPES < 12
+* DPO 9 List types on next line if 0 < NTYPES < 9
+* DPP 9 List types on next line if 0 < NTYPES < 9
+* DPB 8 List types on next line if 0 < NTYPES < 8
+* DPT 12 List types on next line if 0 < NTYPES < 12
+* DSY 10 List types on next line if 0 < NTYPES < 10
+* DSP 10 List types on next line if 0 < NTYPES < 10
+* DTR 18 List types on next line if 0 < NTYPES < 18
+* DTP 18 List types on next line if 0 < NTYPES < 18
+* DTB 17 List types on next line if 0 < NTYPES < 17
+* DQR 8 List types on next line if 0 < NTYPES < 8
+* DRQ 8 List types on next line if 0 < NTYPES < 8
+* DLQ 8 List types on next line if 0 < NTYPES < 8
+* DQL 8 List types on next line if 0 < NTYPES < 8
+* DQP 6 List types on next line if 0 < NTYPES < 6
+* DTZ 3 List types on next line if 0 < NTYPES < 3
+* DLS 6 List types on next line if 0 < NTYPES < 6
+* DEQ
+*
+* Internal Parameters
+* ===================
+*
+* NMAX INTEGER
+* The maximum allowable value for N
+*
+* MAXIN INTEGER
+* The number of different values that can be used for each of
+* M, N, NRHS, NB, and NX
+*
+* MAXRHS INTEGER
+* The maximum number of right hand sides
+*
+* NIN INTEGER
+* The unit number for input
+*
+* NOUT INTEGER
+* The unit number for output
+*
+* =====================================================================
+*
+* .. Parameters ..
+ INTEGER NMAX
+ PARAMETER ( NMAX = 132 )
+ INTEGER MAXIN
+ PARAMETER ( MAXIN = 12 )
+ INTEGER MAXRHS
+ PARAMETER ( MAXRHS = 16 )
+ INTEGER MATMAX
+ PARAMETER ( MATMAX = 30 )
+ INTEGER NIN, NOUT
+ PARAMETER ( NIN = 5, NOUT = 6 )
+ INTEGER KDMAX
+ PARAMETER ( KDMAX = NMAX+( NMAX+1 ) / 4 )
+* ..
+* .. Local Scalars ..
+ LOGICAL FATAL, TSTCHK, TSTDRV, TSTERR
+ CHARACTER C1
+ CHARACTER*2 C2
+ CHARACTER*3 PATH
+ CHARACTER*10 INTSTR
+ CHARACTER*72 ALINE
+ INTEGER I, IC, J, K, LA, LAFAC, LDA, NB, NM, NMATS, NN,
+ $ NNB, NNB2, NNS, NRHS, NTYPES,
+ $ VERS_MAJOR, VERS_MINOR, VERS_PATCH
+ DOUBLE PRECISION EPS, S1, S2, THREQ, THRESH
+* ..
+* .. Local Arrays ..
+ LOGICAL DOTYPE( MATMAX )
+ INTEGER IWORK( 25*NMAX ), MVAL( MAXIN ),
+ $ NBVAL( MAXIN ), NBVAL2( MAXIN ),
+ $ NSVAL( MAXIN ), NVAL( MAXIN ), NXVAL( MAXIN )
+ DOUBLE PRECISION A( ( KDMAX+1 )*NMAX, 7 ), B( NMAX*MAXRHS, 4 ),
+ $ RWORK( 5*NMAX+2*MAXRHS ), S( 2*NMAX ),
+ $ WORK( NMAX, NMAX+MAXRHS+30 )
+* ..
+* .. External Functions ..
+ LOGICAL LSAME, LSAMEN
+ DOUBLE PRECISION DLAMCH, DSECND
+ EXTERNAL LSAME, LSAMEN, DLAMCH, DSECND
+* ..
+* .. External Subroutines ..
+ EXTERNAL ALAREQ, DCHKEQ, DCHKGB, DCHKGE, DCHKGT, DCHKLQ,
+ $ DCHKPB, DCHKPO, DCHKPP, DCHKPT, DCHKQ3, DCHKQL,
+ $ DCHKQP, DCHKQR, DCHKRQ, DCHKSP, DCHKSY, DCHKTB,
+ $ DCHKTP, DCHKTR, DCHKTZ, DDRVGB, DDRVGE, DDRVGT,
+ $ DDRVLS, DDRVPB, DDRVPO, DDRVPP, DDRVPT, DDRVSP,
+ $ DDRVSY, ILAVER
+* ..
+* .. Scalars in Common ..
+ LOGICAL LERR, OK
+ CHARACTER*6 SRNAMT
+ INTEGER INFOT, NUNIT
+* ..
+* .. Arrays in Common ..
+ INTEGER IPARMS( 100 )
+* ..
+* .. Common blocks ..
+ COMMON / INFOC / INFOT, NUNIT, OK, LERR
+ COMMON / SRNAMC / SRNAMT
+ COMMON / CLAENV / IPARMS
+* ..
+* .. Data statements ..
+ DATA THREQ / 2.0D0 / , INTSTR / '0123456789' /
+* ..
+* .. Executable Statements ..
+*
+ S1 = DSECND( )
+ LDA = NMAX
+ FATAL = .FALSE.
+*
+* Read a dummy line.
+*
+ READ( NIN, FMT = * )
+*
+* Report values of parameters.
+*
+ CALL ILAVER( VERS_MAJOR, VERS_MINOR, VERS_PATCH )
+ WRITE( NOUT, FMT = 9994 ) VERS_MAJOR, VERS_MINOR, VERS_PATCH
+*
+* Read the values of M
+*
+ READ( NIN, FMT = * )NM
+ IF( NM.LT.1 ) THEN
+ WRITE( NOUT, FMT = 9996 )' NM ', NM, 1
+ NM = 0
+ FATAL = .TRUE.
+ ELSE IF( NM.GT.MAXIN ) THEN
+ WRITE( NOUT, FMT = 9995 )' NM ', NM, MAXIN
+ NM = 0
+ FATAL = .TRUE.
+ END IF
+ READ( NIN, FMT = * )( MVAL( I ), I = 1, NM )
+ DO 10 I = 1, NM
+ IF( MVAL( I ).LT.0 ) THEN
+ WRITE( NOUT, FMT = 9996 )' M ', MVAL( I ), 0
+ FATAL = .TRUE.
+ ELSE IF( MVAL( I ).GT.NMAX ) THEN
+ WRITE( NOUT, FMT = 9995 )' M ', MVAL( I ), NMAX
+ FATAL = .TRUE.
+ END IF
+ 10 CONTINUE
+ IF( NM.GT.0 )
+ $ WRITE( NOUT, FMT = 9993 )'M ', ( MVAL( I ), I = 1, NM )
+*
+* Read the values of N
+*
+ READ( NIN, FMT = * )NN
+ IF( NN.LT.1 ) THEN
+ WRITE( NOUT, FMT = 9996 )' NN ', NN, 1
+ NN = 0
+ FATAL = .TRUE.
+ ELSE IF( NN.GT.MAXIN ) THEN
+ WRITE( NOUT, FMT = 9995 )' NN ', NN, MAXIN
+ NN = 0
+ FATAL = .TRUE.
+ END IF
+ READ( NIN, FMT = * )( NVAL( I ), I = 1, NN )
+ DO 20 I = 1, NN
+ IF( NVAL( I ).LT.0 ) THEN
+ WRITE( NOUT, FMT = 9996 )' N ', NVAL( I ), 0
+ FATAL = .TRUE.
+ ELSE IF( NVAL( I ).GT.NMAX ) THEN
+ WRITE( NOUT, FMT = 9995 )' N ', NVAL( I ), NMAX
+ FATAL = .TRUE.
+ END IF
+ 20 CONTINUE
+ IF( NN.GT.0 )
+ $ WRITE( NOUT, FMT = 9993 )'N ', ( NVAL( I ), I = 1, NN )
+*
+* Read the values of NRHS
+*
+ READ( NIN, FMT = * )NNS
+ IF( NNS.LT.1 ) THEN
+ WRITE( NOUT, FMT = 9996 )' NNS', NNS, 1
+ NNS = 0
+ FATAL = .TRUE.
+ ELSE IF( NNS.GT.MAXIN ) THEN
+ WRITE( NOUT, FMT = 9995 )' NNS', NNS, MAXIN
+ NNS = 0
+ FATAL = .TRUE.
+ END IF
+ READ( NIN, FMT = * )( NSVAL( I ), I = 1, NNS )
+ DO 30 I = 1, NNS
+ IF( NSVAL( I ).LT.0 ) THEN
+ WRITE( NOUT, FMT = 9996 )'NRHS', NSVAL( I ), 0
+ FATAL = .TRUE.
+ ELSE IF( NSVAL( I ).GT.MAXRHS ) THEN
+ WRITE( NOUT, FMT = 9995 )'NRHS', NSVAL( I ), MAXRHS
+ FATAL = .TRUE.
+ END IF
+ 30 CONTINUE
+ IF( NNS.GT.0 )
+ $ WRITE( NOUT, FMT = 9993 )'NRHS', ( NSVAL( I ), I = 1, NNS )
+*
+* Read the values of NB
+*
+ READ( NIN, FMT = * )NNB
+ IF( NNB.LT.1 ) THEN
+ WRITE( NOUT, FMT = 9996 )'NNB ', NNB, 1
+ NNB = 0
+ FATAL = .TRUE.
+ ELSE IF( NNB.GT.MAXIN ) THEN
+ WRITE( NOUT, FMT = 9995 )'NNB ', NNB, MAXIN
+ NNB = 0
+ FATAL = .TRUE.
+ END IF
+ READ( NIN, FMT = * )( NBVAL( I ), I = 1, NNB )
+ DO 40 I = 1, NNB
+ IF( NBVAL( I ).LT.0 ) THEN
+ WRITE( NOUT, FMT = 9996 )' NB ', NBVAL( I ), 0
+ FATAL = .TRUE.
+ END IF
+ 40 CONTINUE
+ IF( NNB.GT.0 )
+ $ WRITE( NOUT, FMT = 9993 )'NB ', ( NBVAL( I ), I = 1, NNB )
+*
+* Set NBVAL2 to be the set of unique values of NB
+*
+ NNB2 = 0
+ DO 60 I = 1, NNB
+ NB = NBVAL( I )
+ DO 50 J = 1, NNB2
+ IF( NB.EQ.NBVAL2( J ) )
+ $ GO TO 60
+ 50 CONTINUE
+ NNB2 = NNB2 + 1
+ NBVAL2( NNB2 ) = NB
+ 60 CONTINUE
+*
+* Read the values of NX
+*
+ READ( NIN, FMT = * )( NXVAL( I ), I = 1, NNB )
+ DO 70 I = 1, NNB
+ IF( NXVAL( I ).LT.0 ) THEN
+ WRITE( NOUT, FMT = 9996 )' NX ', NXVAL( I ), 0
+ FATAL = .TRUE.
+ END IF
+ 70 CONTINUE
+ IF( NNB.GT.0 )
+ $ WRITE( NOUT, FMT = 9993 )'NX ', ( NXVAL( I ), I = 1, NNB )
+*
+* Read the threshold value for the test ratios.
+*
+ READ( NIN, FMT = * )THRESH
+ WRITE( NOUT, FMT = 9992 )THRESH
+*
+* Read the flag that indicates whether to test the LAPACK routines.
+*
+ READ( NIN, FMT = * )TSTCHK
+*
+* Read the flag that indicates whether to test the driver routines.
+*
+ READ( NIN, FMT = * )TSTDRV
+*
+* Read the flag that indicates whether to test the error exits.
+*
+ READ( NIN, FMT = * )TSTERR
+*
+ IF( FATAL ) THEN
+ WRITE( NOUT, FMT = 9999 )
+ STOP
+ END IF
+*
+* Calculate and print the machine dependent constants.
+*
+ EPS = DLAMCH( 'Underflow threshold' )
+ WRITE( NOUT, FMT = 9991 )'underflow', EPS
+ EPS = DLAMCH( 'Overflow threshold' )
+ WRITE( NOUT, FMT = 9991 )'overflow ', EPS
+ EPS = DLAMCH( 'Epsilon' )
+ WRITE( NOUT, FMT = 9991 )'precision', EPS
+ WRITE( NOUT, FMT = * )
+*
+ 80 CONTINUE
+*
+* Read a test path and the number of matrix types to use.
+*
+ READ( NIN, FMT = '(A72)', END = 140 )ALINE
+ PATH = ALINE( 1: 3 )
+ NMATS = MATMAX
+ I = 3
+ 90 CONTINUE
+ I = I + 1
+ IF( I.GT.72 ) THEN
+ NMATS = MATMAX
+ GO TO 130
+ END IF
+ IF( ALINE( I: I ).EQ.' ' )
+ $ GO TO 90
+ NMATS = 0
+ 100 CONTINUE
+ C1 = ALINE( I: I )
+ DO 110 K = 1, 10
+ IF( C1.EQ.INTSTR( K: K ) ) THEN
+ IC = K - 1
+ GO TO 120
+ END IF
+ 110 CONTINUE
+ GO TO 130
+ 120 CONTINUE
+ NMATS = NMATS*10 + IC
+ I = I + 1
+ IF( I.GT.72 )
+ $ GO TO 130
+ GO TO 100
+ 130 CONTINUE
+ C1 = PATH( 1: 1 )
+ C2 = PATH( 2: 3 )
+ NRHS = NSVAL( 1 )
+*
+* Check first character for correct precision.
+*
+ IF( .NOT.LSAME( C1, 'Double precision' ) ) THEN
+ WRITE( NOUT, FMT = 9990 )PATH
+*
+ ELSE IF( NMATS.LE.0 ) THEN
+*
+* Check for a positive number of tests requested.
+*
+ WRITE( NOUT, FMT = 9989 )PATH
+*
+ ELSE IF( LSAMEN( 2, C2, 'GE' ) ) THEN
+*
+* GE: general matrices
+*
+ NTYPES = 11
+ CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT )
+*
+ IF( TSTCHK ) THEN
+ CALL DCHKGE( DOTYPE, NM, MVAL, NN, NVAL, NNB2, NBVAL2, NNS,
+ $ NSVAL, THRESH, TSTERR, LDA, A( 1, 1 ),
+ $ A( 1, 2 ), A( 1, 3 ), B( 1, 1 ), B( 1, 2 ),
+ $ B( 1, 3 ), WORK, RWORK, IWORK, NOUT )
+ ELSE
+ WRITE( NOUT, FMT = 9989 )PATH
+ END IF
+*
+ IF( TSTDRV ) THEN
+ CALL DDRVGE( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, LDA,
+ $ A( 1, 1 ), A( 1, 2 ), A( 1, 3 ), B( 1, 1 ),
+ $ B( 1, 2 ), B( 1, 3 ), B( 1, 4 ), S, WORK,
+ $ RWORK, IWORK, NOUT )
+ ELSE
+ WRITE( NOUT, FMT = 9988 )PATH
+ END IF
+*
+ ELSE IF( LSAMEN( 2, C2, 'GB' ) ) THEN
+*
+* GB: general banded matrices
+*
+ LA = ( 2*KDMAX+1 )*NMAX
+ LAFAC = ( 3*KDMAX+1 )*NMAX
+ NTYPES = 8
+ CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT )
+*
+ IF( TSTCHK ) THEN
+ CALL DCHKGB( DOTYPE, NM, MVAL, NN, NVAL, NNB2, NBVAL2, NNS,
+ $ NSVAL, THRESH, TSTERR, A( 1, 1 ), LA,
+ $ A( 1, 3 ), LAFAC, B( 1, 1 ), B( 1, 2 ),
+ $ B( 1, 3 ), WORK, RWORK, IWORK, NOUT )
+ ELSE
+ WRITE( NOUT, FMT = 9989 )PATH
+ END IF
+*
+ IF( TSTDRV ) THEN
+ CALL DDRVGB( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR,
+ $ A( 1, 1 ), LA, A( 1, 3 ), LAFAC, A( 1, 6 ),
+ $ B( 1, 1 ), B( 1, 2 ), B( 1, 3 ), B( 1, 4 ), S,
+ $ WORK, RWORK, IWORK, NOUT )
+ ELSE
+ WRITE( NOUT, FMT = 9988 )PATH
+ END IF
+*
+ ELSE IF( LSAMEN( 2, C2, 'GT' ) ) THEN
+*
+* GT: general tridiagonal matrices
+*
+ NTYPES = 12
+ CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT )
+*
+ IF( TSTCHK ) THEN
+ CALL DCHKGT( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR,
+ $ A( 1, 1 ), A( 1, 2 ), B( 1, 1 ), B( 1, 2 ),
+ $ B( 1, 3 ), WORK, RWORK, IWORK, NOUT )
+ ELSE
+ WRITE( NOUT, FMT = 9989 )PATH
+ END IF
+*
+ IF( TSTDRV ) THEN
+ CALL DDRVGT( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR,
+ $ A( 1, 1 ), A( 1, 2 ), B( 1, 1 ), B( 1, 2 ),
+ $ B( 1, 3 ), WORK, RWORK, IWORK, NOUT )
+ ELSE
+ WRITE( NOUT, FMT = 9988 )PATH
+ END IF
+*
+ ELSE IF( LSAMEN( 2, C2, 'PO' ) ) THEN
+*
+* PO: positive definite matrices
+*
+ NTYPES = 9
+ CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT )
+*
+ IF( TSTCHK ) THEN
+ CALL DCHKPO( DOTYPE, NN, NVAL, NNB2, NBVAL2, NNS, NSVAL,
+ $ THRESH, TSTERR, LDA, A( 1, 1 ), A( 1, 2 ),
+ $ A( 1, 3 ), B( 1, 1 ), B( 1, 2 ), B( 1, 3 ),
+ $ WORK, RWORK, IWORK, NOUT )
+ ELSE
+ WRITE( NOUT, FMT = 9989 )PATH
+ END IF
+*
+ IF( TSTDRV ) THEN
+ CALL DDRVPO( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, LDA,
+ $ A( 1, 1 ), A( 1, 2 ), A( 1, 3 ), B( 1, 1 ),
+ $ B( 1, 2 ), B( 1, 3 ), B( 1, 4 ), S, WORK,
+ $ RWORK, IWORK, NOUT )
+ ELSE
+ WRITE( NOUT, FMT = 9988 )PATH
+ END IF
+*
+ ELSE IF( LSAMEN( 2, C2, 'PP' ) ) THEN
+*
+* PP: positive definite packed matrices
+*
+ NTYPES = 9
+ CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT )
+*
+ IF( TSTCHK ) THEN
+ CALL DCHKPP( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR,
+ $ LDA, A( 1, 1 ), A( 1, 2 ), A( 1, 3 ),
+ $ B( 1, 1 ), B( 1, 2 ), B( 1, 3 ), WORK, RWORK,
+ $ IWORK, NOUT )
+ ELSE
+ WRITE( NOUT, FMT = 9989 )PATH
+ END IF
+*
+ IF( TSTDRV ) THEN
+ CALL DDRVPP( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, LDA,
+ $ A( 1, 1 ), A( 1, 2 ), A( 1, 3 ), B( 1, 1 ),
+ $ B( 1, 2 ), B( 1, 3 ), B( 1, 4 ), S, WORK,
+ $ RWORK, IWORK, NOUT )
+ ELSE
+ WRITE( NOUT, FMT = 9988 )PATH
+ END IF
+*
+ ELSE IF( LSAMEN( 2, C2, 'PB' ) ) THEN
+*
+* PB: positive definite banded matrices
+*
+ NTYPES = 8
+ CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT )
+*
+ IF( TSTCHK ) THEN
+ CALL DCHKPB( DOTYPE, NN, NVAL, NNB2, NBVAL2, NNS, NSVAL,
+ $ THRESH, TSTERR, LDA, A( 1, 1 ), A( 1, 2 ),
+ $ A( 1, 3 ), B( 1, 1 ), B( 1, 2 ), B( 1, 3 ),
+ $ WORK, RWORK, IWORK, NOUT )
+ ELSE
+ WRITE( NOUT, FMT = 9989 )PATH
+ END IF
+*
+ IF( TSTDRV ) THEN
+ CALL DDRVPB( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, LDA,
+ $ A( 1, 1 ), A( 1, 2 ), A( 1, 3 ), B( 1, 1 ),
+ $ B( 1, 2 ), B( 1, 3 ), B( 1, 4 ), S, WORK,
+ $ RWORK, IWORK, NOUT )
+ ELSE
+ WRITE( NOUT, FMT = 9988 )PATH
+ END IF
+*
+ ELSE IF( LSAMEN( 2, C2, 'PT' ) ) THEN
+*
+* PT: positive definite tridiagonal matrices
+*
+ NTYPES = 12
+ CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT )
+*
+ IF( TSTCHK ) THEN
+ CALL DCHKPT( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR,
+ $ A( 1, 1 ), A( 1, 2 ), A( 1, 3 ), B( 1, 1 ),
+ $ B( 1, 2 ), B( 1, 3 ), WORK, RWORK, NOUT )
+ ELSE
+ WRITE( NOUT, FMT = 9989 )PATH
+ END IF
+*
+ IF( TSTDRV ) THEN
+ CALL DDRVPT( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR,
+ $ A( 1, 1 ), A( 1, 2 ), A( 1, 3 ), B( 1, 1 ),
+ $ B( 1, 2 ), B( 1, 3 ), WORK, RWORK, NOUT )
+ ELSE
+ WRITE( NOUT, FMT = 9988 )PATH
+ END IF
+*
+ ELSE IF( LSAMEN( 2, C2, 'SY' ) ) THEN
+*
+* SY: symmetric indefinite matrices
+*
+ NTYPES = 10
+ CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT )
+*
+ IF( TSTCHK ) THEN
+ CALL DCHKSY( DOTYPE, NN, NVAL, NNB2, NBVAL2, NNS, NSVAL,
+ $ THRESH, TSTERR, LDA, A( 1, 1 ), A( 1, 2 ),
+ $ A( 1, 3 ), B( 1, 1 ), B( 1, 2 ), B( 1, 3 ),
+ $ WORK, RWORK, IWORK, NOUT )
+ ELSE
+ WRITE( NOUT, FMT = 9989 )PATH
+ END IF
+*
+ IF( TSTDRV ) THEN
+ CALL DDRVSY( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, LDA,
+ $ A( 1, 1 ), A( 1, 2 ), A( 1, 3 ), B( 1, 1 ),
+ $ B( 1, 2 ), B( 1, 3 ), WORK, RWORK, IWORK,
+ $ NOUT )
+ ELSE
+ WRITE( NOUT, FMT = 9988 )PATH
+ END IF
+*
+ ELSE IF( LSAMEN( 2, C2, 'SP' ) ) THEN
+*
+* SP: symmetric indefinite packed matrices
+*
+ NTYPES = 10
+ CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT )
+*
+ IF( TSTCHK ) THEN
+ CALL DCHKSP( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR,
+ $ LDA, A( 1, 1 ), A( 1, 2 ), A( 1, 3 ),
+ $ B( 1, 1 ), B( 1, 2 ), B( 1, 3 ), WORK, RWORK,
+ $ IWORK, NOUT )
+ ELSE
+ WRITE( NOUT, FMT = 9989 )PATH
+ END IF
+*
+ IF( TSTDRV ) THEN
+ CALL DDRVSP( DOTYPE, NN, NVAL, NRHS, THRESH, TSTERR, LDA,
+ $ A( 1, 1 ), A( 1, 2 ), A( 1, 3 ), B( 1, 1 ),
+ $ B( 1, 2 ), B( 1, 3 ), WORK, RWORK, IWORK,
+ $ NOUT )
+ ELSE
+ WRITE( NOUT, FMT = 9988 )PATH
+ END IF
+*
+ ELSE IF( LSAMEN( 2, C2, 'TR' ) ) THEN
+*
+* TR: triangular matrices
+*
+ NTYPES = 18
+ CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT )
+*
+ IF( TSTCHK ) THEN
+ CALL DCHKTR( DOTYPE, NN, NVAL, NNB2, NBVAL2, NNS, NSVAL,
+ $ THRESH, TSTERR, LDA, A( 1, 1 ), A( 1, 2 ),
+ $ B( 1, 1 ), B( 1, 2 ), B( 1, 3 ), WORK, RWORK,
+ $ IWORK, NOUT )
+ ELSE
+ WRITE( NOUT, FMT = 9989 )PATH
+ END IF
+*
+ ELSE IF( LSAMEN( 2, C2, 'TP' ) ) THEN
+*
+* TP: triangular packed matrices
+*
+ NTYPES = 18
+ CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT )
+*
+ IF( TSTCHK ) THEN
+ CALL DCHKTP( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR,
+ $ LDA, A( 1, 1 ), A( 1, 2 ), B( 1, 1 ),
+ $ B( 1, 2 ), B( 1, 3 ), WORK, RWORK, IWORK,
+ $ NOUT )
+ ELSE
+ WRITE( NOUT, FMT = 9989 )PATH
+ END IF
+*
+ ELSE IF( LSAMEN( 2, C2, 'TB' ) ) THEN
+*
+* TB: triangular banded matrices
+*
+ NTYPES = 17
+ CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT )
+*
+ IF( TSTCHK ) THEN
+ CALL DCHKTB( DOTYPE, NN, NVAL, NNS, NSVAL, THRESH, TSTERR,
+ $ LDA, A( 1, 1 ), A( 1, 2 ), B( 1, 1 ),
+ $ B( 1, 2 ), B( 1, 3 ), WORK, RWORK, IWORK,
+ $ NOUT )
+ ELSE
+ WRITE( NOUT, FMT = 9989 )PATH
+ END IF
+*
+ ELSE IF( LSAMEN( 2, C2, 'QR' ) ) THEN
+*
+* QR: QR factorization
+*
+ NTYPES = 8
+ CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT )
+*
+ IF( TSTCHK ) THEN
+ CALL DCHKQR( DOTYPE, NM, MVAL, NN, NVAL, NNB, NBVAL, NXVAL,
+ $ NRHS, THRESH, TSTERR, NMAX, A( 1, 1 ),
+ $ A( 1, 2 ), A( 1, 3 ), A( 1, 4 ), A( 1, 5 ),
+ $ B( 1, 1 ), B( 1, 2 ), B( 1, 3 ), B( 1, 4 ),
+ $ WORK, RWORK, IWORK, NOUT )
+ ELSE
+ WRITE( NOUT, FMT = 9989 )PATH
+ END IF
+*
+ ELSE IF( LSAMEN( 2, C2, 'LQ' ) ) THEN
+*
+* LQ: LQ factorization
+*
+ NTYPES = 8
+ CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT )
+*
+ IF( TSTCHK ) THEN
+ CALL DCHKLQ( DOTYPE, NM, MVAL, NN, NVAL, NNB, NBVAL, NXVAL,
+ $ NRHS, THRESH, TSTERR, NMAX, A( 1, 1 ),
+ $ A( 1, 2 ), A( 1, 3 ), A( 1, 4 ), A( 1, 5 ),
+ $ B( 1, 1 ), B( 1, 2 ), B( 1, 3 ), B( 1, 4 ),
+ $ WORK, RWORK, IWORK, NOUT )
+ ELSE
+ WRITE( NOUT, FMT = 9989 )PATH
+ END IF
+*
+ ELSE IF( LSAMEN( 2, C2, 'QL' ) ) THEN
+*
+* QL: QL factorization
+*
+ NTYPES = 8
+ CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT )
+*
+ IF( TSTCHK ) THEN
+ CALL DCHKQL( DOTYPE, NM, MVAL, NN, NVAL, NNB, NBVAL, NXVAL,
+ $ NRHS, THRESH, TSTERR, NMAX, A( 1, 1 ),
+ $ A( 1, 2 ), A( 1, 3 ), A( 1, 4 ), A( 1, 5 ),
+ $ B( 1, 1 ), B( 1, 2 ), B( 1, 3 ), B( 1, 4 ),
+ $ WORK, RWORK, IWORK, NOUT )
+ ELSE
+ WRITE( NOUT, FMT = 9989 )PATH
+ END IF
+*
+ ELSE IF( LSAMEN( 2, C2, 'RQ' ) ) THEN
+*
+* RQ: RQ factorization
+*
+ NTYPES = 8
+ CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT )
+*
+ IF( TSTCHK ) THEN
+ CALL DCHKRQ( DOTYPE, NM, MVAL, NN, NVAL, NNB, NBVAL, NXVAL,
+ $ NRHS, THRESH, TSTERR, NMAX, A( 1, 1 ),
+ $ A( 1, 2 ), A( 1, 3 ), A( 1, 4 ), A( 1, 5 ),
+ $ B( 1, 1 ), B( 1, 2 ), B( 1, 3 ), B( 1, 4 ),
+ $ WORK, RWORK, IWORK, NOUT )
+ ELSE
+ WRITE( NOUT, FMT = 9989 )PATH
+ END IF
+*
+ ELSE IF( LSAMEN( 2, C2, 'QP' ) ) THEN
+*
+* QP: QR factorization with pivoting
+*
+ NTYPES = 6
+ CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT )
+*
+ IF( TSTCHK ) THEN
+ CALL DCHKQP( DOTYPE, NM, MVAL, NN, NVAL, THRESH, TSTERR,
+ $ A( 1, 1 ), A( 1, 2 ), B( 1, 1 ), B( 1, 2 ),
+ $ B( 1, 3 ), WORK, IWORK, NOUT )
+ CALL DCHKQ3( DOTYPE, NM, MVAL, NN, NVAL, NNB, NBVAL, NXVAL,
+ $ THRESH, A( 1, 1 ), A( 1, 2 ), B( 1, 1 ),
+ $ B( 1, 2 ), B( 1, 3 ), WORK, IWORK, NOUT )
+ ELSE
+ WRITE( NOUT, FMT = 9989 )PATH
+ END IF
+*
+ ELSE IF( LSAMEN( 2, C2, 'TZ' ) ) THEN
+*
+* TZ: Trapezoidal matrix
+*
+ NTYPES = 3
+ CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT )
+*
+ IF( TSTCHK ) THEN
+ CALL DCHKTZ( DOTYPE, NM, MVAL, NN, NVAL, THRESH, TSTERR,
+ $ A( 1, 1 ), A( 1, 2 ), B( 1, 1 ), B( 1, 2 ),
+ $ B( 1, 3 ), WORK, NOUT )
+ ELSE
+ WRITE( NOUT, FMT = 9989 )PATH
+ END IF
+*
+ ELSE IF( LSAMEN( 2, C2, 'LS' ) ) THEN
+*
+* LS: Least squares drivers
+*
+ NTYPES = 6
+ CALL ALAREQ( PATH, NMATS, DOTYPE, NTYPES, NIN, NOUT )
+*
+ IF( TSTDRV ) THEN
+ CALL DDRVLS( DOTYPE, NM, MVAL, NN, NVAL, NNS, NSVAL, NNB,
+ $ NBVAL, NXVAL, THRESH, TSTERR, A( 1, 1 ),
+ $ A( 1, 2 ), B( 1, 1 ), B( 1, 2 ), B( 1, 3 ),
+ $ RWORK, RWORK( NMAX+1 ), WORK, IWORK, NOUT )
+ ELSE
+ WRITE( NOUT, FMT = 9988 )PATH
+ END IF
+*
+ ELSE IF( LSAMEN( 2, C2, 'EQ' ) ) THEN
+*
+* EQ: Equilibration routines for general and positive definite
+* matrices (THREQ should be between 2 and 10)
+*
+ IF( TSTCHK ) THEN
+ CALL DCHKEQ( THREQ, NOUT )
+ ELSE
+ WRITE( NOUT, FMT = 9989 )PATH
+ END IF
+*
+ ELSE
+*
+ WRITE( NOUT, FMT = 9990 )PATH
+ END IF
+*
+* Go back to get another input line.
+*
+ GO TO 80
+*
+* Branch to this line when the last record is read.
+*
+ 140 CONTINUE
+ CLOSE ( NIN )
+ S2 = DSECND( )
+ WRITE( NOUT, FMT = 9998 )
+ WRITE( NOUT, FMT = 9997 )S2 - S1
+*
+ 9999 FORMAT( / ' Execution not attempted due to input errors' )
+ 9998 FORMAT( / ' End of tests' )
+ 9997 FORMAT( ' Total time used = ', F12.2, ' seconds', / )
+ 9996 FORMAT( ' Invalid input value: ', A4, '=', I6, '; must be >=',
+ $ I6 )
+ 9995 FORMAT( ' Invalid input value: ', A4, '=', I6, '; must be <=',
+ $ I6 )
+ 9994 FORMAT( ' Tests of the DOUBLE PRECISION LAPACK routines ',
+ $ / ' LAPACK VERSION ', I1, '.', I1, '.', I1,
+ $ / / ' The following parameter values will be used:' )
+ 9993 FORMAT( 4X, A4, ': ', 10I6, / 11X, 10I6 )
+ 9992 FORMAT( / ' Routines pass computational tests if test ratio is ',
+ $ 'less than', F8.2, / )
+ 9991 FORMAT( ' Relative machine ', A, ' is taken to be', D16.6 )
+ 9990 FORMAT( / 1X, A3, ': Unrecognized path name' )
+ 9989 FORMAT( / 1X, A3, ' routines were not tested' )
+ 9988 FORMAT( / 1X, A3, ' driver routines were not tested' )
+*
+* End of DCHKAA
+*
+ END
+ SUBROUTINE DCHKEQ( THRESH, NOUT )
+*
+* -- LAPACK test routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ INTEGER NOUT
+ DOUBLE PRECISION THRESH
+* ..
+*
+* Purpose
+* =======
+*
+* DCHKEQ tests DGEEQU, DGBEQU, DPOEQU, DPPEQU and DPBEQU
+*
+* Arguments
+* =========
+*
+* THRESH (input) DOUBLE PRECISION
+* Threshold for testing routines. Should be between 2 and 10.
+*
+* NOUT (input) INTEGER
+* The unit number for output.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ZERO, ONE, TEN
+ PARAMETER ( ZERO = 0.0D0, ONE = 1.0D+0, TEN = 1.0D1 )
+ INTEGER NSZ, NSZB
+ PARAMETER ( NSZ = 5, NSZB = 3*NSZ-2 )
+ INTEGER NSZP, NPOW
+ PARAMETER ( NSZP = ( NSZ*( NSZ+1 ) ) / 2,
+ $ NPOW = 2*NSZ+1 )
+* ..
+* .. Local Scalars ..
+ LOGICAL OK
+ CHARACTER*3 PATH
+ INTEGER I, INFO, J, KL, KU, M, N
+ DOUBLE PRECISION CCOND, EPS, NORM, RATIO, RCMAX, RCMIN, RCOND
+* ..
+* .. Local Arrays ..
+ DOUBLE PRECISION A( NSZ, NSZ ), AB( NSZB, NSZ ), AP( NSZP ),
+ $ C( NSZ ), POW( NPOW ), R( NSZ ), RESLTS( 5 ),
+ $ RPOW( NPOW )
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DLAMCH
+ EXTERNAL DLAMCH
+* ..
+* .. External Subroutines ..
+ EXTERNAL DGBEQU, DGEEQU, DPBEQU, DPOEQU, DPPEQU
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, MAX, MIN
+* ..
+* .. Executable Statements ..
+*
+ PATH( 1: 1 ) = 'Double precision'
+ PATH( 2: 3 ) = 'EQ'
+*
+ EPS = DLAMCH( 'P' )
+ DO 10 I = 1, 5
+ RESLTS( I ) = ZERO
+ 10 CONTINUE
+ DO 20 I = 1, NPOW
+ POW( I ) = TEN**( I-1 )
+ RPOW( I ) = ONE / POW( I )
+ 20 CONTINUE
+*
+* Test DGEEQU
+*
+ DO 80 N = 0, NSZ
+ DO 70 M = 0, NSZ
+*
+ DO 40 J = 1, NSZ
+ DO 30 I = 1, NSZ
+ IF( I.LE.M .AND. J.LE.N ) THEN
+ A( I, J ) = POW( I+J+1 )*( -1 )**( I+J )
+ ELSE
+ A( I, J ) = ZERO
+ END IF
+ 30 CONTINUE
+ 40 CONTINUE
+*
+ CALL DGEEQU( M, N, A, NSZ, R, C, RCOND, CCOND, NORM, INFO )
+*
+ IF( INFO.NE.0 ) THEN
+ RESLTS( 1 ) = ONE
+ ELSE
+ IF( N.NE.0 .AND. M.NE.0 ) THEN
+ RESLTS( 1 ) = MAX( RESLTS( 1 ),
+ $ ABS( ( RCOND-RPOW( M ) ) / RPOW( M ) ) )
+ RESLTS( 1 ) = MAX( RESLTS( 1 ),
+ $ ABS( ( CCOND-RPOW( N ) ) / RPOW( N ) ) )
+ RESLTS( 1 ) = MAX( RESLTS( 1 ),
+ $ ABS( ( NORM-POW( N+M+1 ) ) / POW( N+M+
+ $ 1 ) ) )
+ DO 50 I = 1, M
+ RESLTS( 1 ) = MAX( RESLTS( 1 ),
+ $ ABS( ( R( I )-RPOW( I+N+1 ) ) /
+ $ RPOW( I+N+1 ) ) )
+ 50 CONTINUE
+ DO 60 J = 1, N
+ RESLTS( 1 ) = MAX( RESLTS( 1 ),
+ $ ABS( ( C( J )-POW( N-J+1 ) ) /
+ $ POW( N-J+1 ) ) )
+ 60 CONTINUE
+ END IF
+ END IF
+*
+ 70 CONTINUE
+ 80 CONTINUE
+*
+* Test with zero rows and columns
+*
+ DO 90 J = 1, NSZ
+ A( MAX( NSZ-1, 1 ), J ) = ZERO
+ 90 CONTINUE
+ CALL DGEEQU( NSZ, NSZ, A, NSZ, R, C, RCOND, CCOND, NORM, INFO )
+ IF( INFO.NE.MAX( NSZ-1, 1 ) )
+ $ RESLTS( 1 ) = ONE
+*
+ DO 100 J = 1, NSZ
+ A( MAX( NSZ-1, 1 ), J ) = ONE
+ 100 CONTINUE
+ DO 110 I = 1, NSZ
+ A( I, MAX( NSZ-1, 1 ) ) = ZERO
+ 110 CONTINUE
+ CALL DGEEQU( NSZ, NSZ, A, NSZ, R, C, RCOND, CCOND, NORM, INFO )
+ IF( INFO.NE.NSZ+MAX( NSZ-1, 1 ) )
+ $ RESLTS( 1 ) = ONE
+ RESLTS( 1 ) = RESLTS( 1 ) / EPS
+*
+* Test DGBEQU
+*
+ DO 250 N = 0, NSZ
+ DO 240 M = 0, NSZ
+ DO 230 KL = 0, MAX( M-1, 0 )
+ DO 220 KU = 0, MAX( N-1, 0 )
+*
+ DO 130 J = 1, NSZ
+ DO 120 I = 1, NSZB
+ AB( I, J ) = ZERO
+ 120 CONTINUE
+ 130 CONTINUE
+ DO 150 J = 1, N
+ DO 140 I = 1, M
+ IF( I.LE.MIN( M, J+KL ) .AND. I.GE.
+ $ MAX( 1, J-KU ) .AND. J.LE.N ) THEN
+ AB( KU+1+I-J, J ) = POW( I+J+1 )*
+ $ ( -1 )**( I+J )
+ END IF
+ 140 CONTINUE
+ 150 CONTINUE
+*
+ CALL DGBEQU( M, N, KL, KU, AB, NSZB, R, C, RCOND,
+ $ CCOND, NORM, INFO )
+*
+ IF( INFO.NE.0 ) THEN
+ IF( .NOT.( ( N+KL.LT.M .AND. INFO.EQ.N+KL+1 ) .OR.
+ $ ( M+KU.LT.N .AND. INFO.EQ.2*M+KU+1 ) ) ) THEN
+ RESLTS( 2 ) = ONE
+ END IF
+ ELSE
+ IF( N.NE.0 .AND. M.NE.0 ) THEN
+*
+ RCMIN = R( 1 )
+ RCMAX = R( 1 )
+ DO 160 I = 1, M
+ RCMIN = MIN( RCMIN, R( I ) )
+ RCMAX = MAX( RCMAX, R( I ) )
+ 160 CONTINUE
+ RATIO = RCMIN / RCMAX
+ RESLTS( 2 ) = MAX( RESLTS( 2 ),
+ $ ABS( ( RCOND-RATIO ) / RATIO ) )
+*
+ RCMIN = C( 1 )
+ RCMAX = C( 1 )
+ DO 170 J = 1, N
+ RCMIN = MIN( RCMIN, C( J ) )
+ RCMAX = MAX( RCMAX, C( J ) )
+ 170 CONTINUE
+ RATIO = RCMIN / RCMAX
+ RESLTS( 2 ) = MAX( RESLTS( 2 ),
+ $ ABS( ( CCOND-RATIO ) / RATIO ) )
+*
+ RESLTS( 2 ) = MAX( RESLTS( 2 ),
+ $ ABS( ( NORM-POW( N+M+1 ) ) /
+ $ POW( N+M+1 ) ) )
+ DO 190 I = 1, M
+ RCMAX = ZERO
+ DO 180 J = 1, N
+ IF( I.LE.J+KL .AND. I.GE.J-KU ) THEN
+ RATIO = ABS( R( I )*POW( I+J+1 )*
+ $ C( J ) )
+ RCMAX = MAX( RCMAX, RATIO )
+ END IF
+ 180 CONTINUE
+ RESLTS( 2 ) = MAX( RESLTS( 2 ),
+ $ ABS( ONE-RCMAX ) )
+ 190 CONTINUE
+*
+ DO 210 J = 1, N
+ RCMAX = ZERO
+ DO 200 I = 1, M
+ IF( I.LE.J+KL .AND. I.GE.J-KU ) THEN
+ RATIO = ABS( R( I )*POW( I+J+1 )*
+ $ C( J ) )
+ RCMAX = MAX( RCMAX, RATIO )
+ END IF
+ 200 CONTINUE
+ RESLTS( 2 ) = MAX( RESLTS( 2 ),
+ $ ABS( ONE-RCMAX ) )
+ 210 CONTINUE
+ END IF
+ END IF
+*
+ 220 CONTINUE
+ 230 CONTINUE
+ 240 CONTINUE
+ 250 CONTINUE
+ RESLTS( 2 ) = RESLTS( 2 ) / EPS
+*
+* Test DPOEQU
+*
+ DO 290 N = 0, NSZ
+*
+ DO 270 I = 1, NSZ
+ DO 260 J = 1, NSZ
+ IF( I.LE.N .AND. J.EQ.I ) THEN
+ A( I, J ) = POW( I+J+1 )*( -1 )**( I+J )
+ ELSE
+ A( I, J ) = ZERO
+ END IF
+ 260 CONTINUE
+ 270 CONTINUE
+*
+ CALL DPOEQU( N, A, NSZ, R, RCOND, NORM, INFO )
+*
+ IF( INFO.NE.0 ) THEN
+ RESLTS( 3 ) = ONE
+ ELSE
+ IF( N.NE.0 ) THEN
+ RESLTS( 3 ) = MAX( RESLTS( 3 ),
+ $ ABS( ( RCOND-RPOW( N ) ) / RPOW( N ) ) )
+ RESLTS( 3 ) = MAX( RESLTS( 3 ),
+ $ ABS( ( NORM-POW( 2*N+1 ) ) / POW( 2*N+
+ $ 1 ) ) )
+ DO 280 I = 1, N
+ RESLTS( 3 ) = MAX( RESLTS( 3 ),
+ $ ABS( ( R( I )-RPOW( I+1 ) ) / RPOW( I+
+ $ 1 ) ) )
+ 280 CONTINUE
+ END IF
+ END IF
+ 290 CONTINUE
+ A( MAX( NSZ-1, 1 ), MAX( NSZ-1, 1 ) ) = -ONE
+ CALL DPOEQU( NSZ, A, NSZ, R, RCOND, NORM, INFO )
+ IF( INFO.NE.MAX( NSZ-1, 1 ) )
+ $ RESLTS( 3 ) = ONE
+ RESLTS( 3 ) = RESLTS( 3 ) / EPS
+*
+* Test DPPEQU
+*
+ DO 360 N = 0, NSZ
+*
+* Upper triangular packed storage
+*
+ DO 300 I = 1, ( N*( N+1 ) ) / 2
+ AP( I ) = ZERO
+ 300 CONTINUE
+ DO 310 I = 1, N
+ AP( ( I*( I+1 ) ) / 2 ) = POW( 2*I+1 )
+ 310 CONTINUE
+*
+ CALL DPPEQU( 'U', N, AP, R, RCOND, NORM, INFO )
+*
+ IF( INFO.NE.0 ) THEN
+ RESLTS( 4 ) = ONE
+ ELSE
+ IF( N.NE.0 ) THEN
+ RESLTS( 4 ) = MAX( RESLTS( 4 ),
+ $ ABS( ( RCOND-RPOW( N ) ) / RPOW( N ) ) )
+ RESLTS( 4 ) = MAX( RESLTS( 4 ),
+ $ ABS( ( NORM-POW( 2*N+1 ) ) / POW( 2*N+
+ $ 1 ) ) )
+ DO 320 I = 1, N
+ RESLTS( 4 ) = MAX( RESLTS( 4 ),
+ $ ABS( ( R( I )-RPOW( I+1 ) ) / RPOW( I+
+ $ 1 ) ) )
+ 320 CONTINUE
+ END IF
+ END IF
+*
+* Lower triangular packed storage
+*
+ DO 330 I = 1, ( N*( N+1 ) ) / 2
+ AP( I ) = ZERO
+ 330 CONTINUE
+ J = 1
+ DO 340 I = 1, N
+ AP( J ) = POW( 2*I+1 )
+ J = J + ( N-I+1 )
+ 340 CONTINUE
+*
+ CALL DPPEQU( 'L', N, AP, R, RCOND, NORM, INFO )
+*
+ IF( INFO.NE.0 ) THEN
+ RESLTS( 4 ) = ONE
+ ELSE
+ IF( N.NE.0 ) THEN
+ RESLTS( 4 ) = MAX( RESLTS( 4 ),
+ $ ABS( ( RCOND-RPOW( N ) ) / RPOW( N ) ) )
+ RESLTS( 4 ) = MAX( RESLTS( 4 ),
+ $ ABS( ( NORM-POW( 2*N+1 ) ) / POW( 2*N+
+ $ 1 ) ) )
+ DO 350 I = 1, N
+ RESLTS( 4 ) = MAX( RESLTS( 4 ),
+ $ ABS( ( R( I )-RPOW( I+1 ) ) / RPOW( I+
+ $ 1 ) ) )
+ 350 CONTINUE
+ END IF
+ END IF
+*
+ 360 CONTINUE
+ I = ( NSZ*( NSZ+1 ) ) / 2 - 2
+ AP( I ) = -ONE
+ CALL DPPEQU( 'L', NSZ, AP, R, RCOND, NORM, INFO )
+ IF( INFO.NE.MAX( NSZ-1, 1 ) )
+ $ RESLTS( 4 ) = ONE
+ RESLTS( 4 ) = RESLTS( 4 ) / EPS
+*
+* Test DPBEQU
+*
+ DO 460 N = 0, NSZ
+ DO 450 KL = 0, MAX( N-1, 0 )
+*
+* Test upper triangular storage
+*
+ DO 380 J = 1, NSZ
+ DO 370 I = 1, NSZB
+ AB( I, J ) = ZERO
+ 370 CONTINUE
+ 380 CONTINUE
+ DO 390 J = 1, N
+ AB( KL+1, J ) = POW( 2*J+1 )
+ 390 CONTINUE
+*
+ CALL DPBEQU( 'U', N, KL, AB, NSZB, R, RCOND, NORM, INFO )
+*
+ IF( INFO.NE.0 ) THEN
+ RESLTS( 5 ) = ONE
+ ELSE
+ IF( N.NE.0 ) THEN
+ RESLTS( 5 ) = MAX( RESLTS( 5 ),
+ $ ABS( ( RCOND-RPOW( N ) ) / RPOW( N ) ) )
+ RESLTS( 5 ) = MAX( RESLTS( 5 ),
+ $ ABS( ( NORM-POW( 2*N+1 ) ) / POW( 2*N+
+ $ 1 ) ) )
+ DO 400 I = 1, N
+ RESLTS( 5 ) = MAX( RESLTS( 5 ),
+ $ ABS( ( R( I )-RPOW( I+1 ) ) /
+ $ RPOW( I+1 ) ) )
+ 400 CONTINUE
+ END IF
+ END IF
+ IF( N.NE.0 ) THEN
+ AB( KL+1, MAX( N-1, 1 ) ) = -ONE
+ CALL DPBEQU( 'U', N, KL, AB, NSZB, R, RCOND, NORM, INFO )
+ IF( INFO.NE.MAX( N-1, 1 ) )
+ $ RESLTS( 5 ) = ONE
+ END IF
+*
+* Test lower triangular storage
+*
+ DO 420 J = 1, NSZ
+ DO 410 I = 1, NSZB
+ AB( I, J ) = ZERO
+ 410 CONTINUE
+ 420 CONTINUE
+ DO 430 J = 1, N
+ AB( 1, J ) = POW( 2*J+1 )
+ 430 CONTINUE
+*
+ CALL DPBEQU( 'L', N, KL, AB, NSZB, R, RCOND, NORM, INFO )
+*
+ IF( INFO.NE.0 ) THEN
+ RESLTS( 5 ) = ONE
+ ELSE
+ IF( N.NE.0 ) THEN
+ RESLTS( 5 ) = MAX( RESLTS( 5 ),
+ $ ABS( ( RCOND-RPOW( N ) ) / RPOW( N ) ) )
+ RESLTS( 5 ) = MAX( RESLTS( 5 ),
+ $ ABS( ( NORM-POW( 2*N+1 ) ) / POW( 2*N+
+ $ 1 ) ) )
+ DO 440 I = 1, N
+ RESLTS( 5 ) = MAX( RESLTS( 5 ),
+ $ ABS( ( R( I )-RPOW( I+1 ) ) /
+ $ RPOW( I+1 ) ) )
+ 440 CONTINUE
+ END IF
+ END IF
+ IF( N.NE.0 ) THEN
+ AB( 1, MAX( N-1, 1 ) ) = -ONE
+ CALL DPBEQU( 'L', N, KL, AB, NSZB, R, RCOND, NORM, INFO )
+ IF( INFO.NE.MAX( N-1, 1 ) )
+ $ RESLTS( 5 ) = ONE
+ END IF
+ 450 CONTINUE
+ 460 CONTINUE
+ RESLTS( 5 ) = RESLTS( 5 ) / EPS
+ OK = ( RESLTS( 1 ).LE.THRESH ) .AND.
+ $ ( RESLTS( 2 ).LE.THRESH ) .AND.
+ $ ( RESLTS( 3 ).LE.THRESH ) .AND.
+ $ ( RESLTS( 4 ).LE.THRESH ) .AND. ( RESLTS( 5 ).LE.THRESH )
+ WRITE( NOUT, FMT = * )
+ IF( OK ) THEN
+ WRITE( NOUT, FMT = 9999 )PATH
+ ELSE
+ IF( RESLTS( 1 ).GT.THRESH )
+ $ WRITE( NOUT, FMT = 9998 )RESLTS( 1 ), THRESH
+ IF( RESLTS( 2 ).GT.THRESH )
+ $ WRITE( NOUT, FMT = 9997 )RESLTS( 2 ), THRESH
+ IF( RESLTS( 3 ).GT.THRESH )
+ $ WRITE( NOUT, FMT = 9996 )RESLTS( 3 ), THRESH
+ IF( RESLTS( 4 ).GT.THRESH )
+ $ WRITE( NOUT, FMT = 9995 )RESLTS( 4 ), THRESH
+ IF( RESLTS( 5 ).GT.THRESH )
+ $ WRITE( NOUT, FMT = 9994 )RESLTS( 5 ), THRESH
+ END IF
+ 9999 FORMAT( 1X, 'All tests for ', A3,
+ $ ' routines passed the threshold' )
+ 9998 FORMAT( ' DGEEQU failed test with value ', D10.3, ' exceeding',
+ $ ' threshold ', D10.3 )
+ 9997 FORMAT( ' DGBEQU failed test with value ', D10.3, ' exceeding',
+ $ ' threshold ', D10.3 )
+ 9996 FORMAT( ' DPOEQU failed test with value ', D10.3, ' exceeding',
+ $ ' threshold ', D10.3 )
+ 9995 FORMAT( ' DPPEQU failed test with value ', D10.3, ' exceeding',
+ $ ' threshold ', D10.3 )
+ 9994 FORMAT( ' DPBEQU failed test with value ', D10.3, ' exceeding',
+ $ ' threshold ', D10.3 )
+ RETURN
+*
+* End of DCHKEQ
+*
+ END
+ SUBROUTINE DCHKGB( DOTYPE, NM, MVAL, NN, NVAL, NNB, NBVAL, NNS,
+ $ NSVAL, THRESH, TSTERR, A, LA, AFAC, LAFAC, B,
+ $ X, XACT, WORK, RWORK, IWORK, NOUT )
+*
+* -- LAPACK test routine (version 3.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* November 2006
+*
+* .. Scalar Arguments ..
+ LOGICAL TSTERR
+ INTEGER LA, LAFAC, NM, NN, NNB, NNS, NOUT
+ DOUBLE PRECISION THRESH
+* ..
+* .. Array Arguments ..
+ LOGICAL DOTYPE( * )
+ INTEGER IWORK( * ), MVAL( * ), NBVAL( * ), NSVAL( * ),
+ $ NVAL( * )
+ DOUBLE PRECISION A( * ), AFAC( * ), B( * ), RWORK( * ),
+ $ WORK( * ), X( * ), XACT( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DCHKGB tests DGBTRF, -TRS, -RFS, and -CON
+*
+* Arguments
+* =========
+*
+* DOTYPE (input) LOGICAL array, dimension (NTYPES)
+* The matrix types to be used for testing. Matrices of type j
+* (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
+* .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
+*
+* NM (input) INTEGER
+* The number of values of M contained in the vector MVAL.
+*
+* MVAL (input) INTEGER array, dimension (NM)
+* The values of the matrix row dimension M.
+*
+* NN (input) INTEGER
+* The number of values of N contained in the vector NVAL.
+*
+* NVAL (input) INTEGER array, dimension (NN)
+* The values of the matrix column dimension N.
+*
+* NNB (input) INTEGER
+* The number of values of NB contained in the vector NBVAL.
+*
+* NBVAL (input) INTEGER array, dimension (NNB)
+* The values of the blocksize NB.
+*
+* NNS (input) INTEGER
+* The number of values of NRHS contained in the vector NSVAL.
+*
+* NSVAL (input) INTEGER array, dimension (NNS)
+* The values of the number of right hand sides NRHS.
+*
+* THRESH (input) DOUBLE PRECISION
+* The threshold value for the test ratios. A result is
+* included in the output file if RESULT >= THRESH. To have
+* every test ratio printed, use THRESH = 0.
+*
+* TSTERR (input) LOGICAL
+* Flag that indicates whether error exits are to be tested.
+*
+* A (workspace) DOUBLE PRECISION array, dimension (LA)
+*
+* LA (input) INTEGER
+* The length of the array A. LA >= (KLMAX+KUMAX+1)*NMAX
+* where KLMAX is the largest entry in the local array KLVAL,
+* KUMAX is the largest entry in the local array KUVAL and
+* NMAX is the largest entry in the input array NVAL.
+*
+* AFAC (workspace) DOUBLE PRECISION array, dimension (LAFAC)
+*
+* LAFAC (input) INTEGER
+* The length of the array AFAC. LAFAC >= (2*KLMAX+KUMAX+1)*NMAX
+* where KLMAX is the largest entry in the local array KLVAL,
+* KUMAX is the largest entry in the local array KUVAL and
+* NMAX is the largest entry in the input array NVAL.
+*
+* B (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX)
+* where NSMAX is the largest entry in NSVAL.
+*
+* X (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX)
+*
+* XACT (workspace) DOUBLE PRECISION array, dimension (NMAX*NSMAX)
+*
+* WORK (workspace) DOUBLE PRECISION array, dimension
+* (NMAX*max(3,NSMAX,NMAX))
+*
+* RWORK (workspace) DOUBLE PRECISION array, dimension
+* (max(NMAX,2*NSMAX))
+*
+* IWORK (workspace) INTEGER array, dimension (2*NMAX)
+*
+* NOUT (input) INTEGER
+* The unit number for output.
+*
+* =====================================================================
+*
+* .. Parameters ..
+ DOUBLE PRECISION ONE, ZERO
+ PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
+ INTEGER NTYPES, NTESTS
+ PARAMETER ( NTYPES = 8, NTESTS = 7 )
+ INTEGER NBW, NTRAN
+ PARAMETER ( NBW = 4, NTRAN = 3 )
+* ..
+* .. Local Scalars ..
+ LOGICAL TRFCON, ZEROT
+ CHARACTER DIST, NORM, TRANS, TYPE, XTYPE
+ CHARACTER*3 PATH
+ INTEGER I, I1, I2, IKL, IKU, IM, IMAT, IN, INB, INFO,
+ $ IOFF, IRHS, ITRAN, IZERO, J, K, KL, KOFF, KU,
+ $ LDA, LDAFAC, LDB, M, MODE, N, NB, NERRS, NFAIL,
+ $ NIMAT, NKL, NKU, NRHS, NRUN
+ DOUBLE PRECISION AINVNM, ANORM, ANORMI, ANORMO, CNDNUM, RCOND,
+ $ RCONDC, RCONDI, RCONDO
+* ..
+* .. Local Arrays ..
+ CHARACTER TRANSS( NTRAN )
+ INTEGER ISEED( 4 ), ISEEDY( 4 ), KLVAL( NBW ),
+ $ KUVAL( NBW )
+ DOUBLE PRECISION RESULT( NTESTS )
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DGET06, DLANGB, DLANGE
+ EXTERNAL DGET06, DLANGB, DLANGE
+* ..
+* .. External Subroutines ..
+ EXTERNAL ALAERH, ALAHD, ALASUM, DCOPY, DERRGE, DGBCON,
+ $ DGBRFS, DGBT01, DGBT02, DGBT05, DGBTRF, DGBTRS,
+ $ DGET04, DLACPY, DLARHS, DLASET, DLATB4, DLATMS,
+ $ XLAENV
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC MAX, MIN
+* ..
+* .. Scalars in Common ..
+ LOGICAL LERR, OK
+ CHARACTER*6 SRNAMT
+ INTEGER INFOT, NUNIT
+* ..
+* .. Common blocks ..
+ COMMON / INFOC / INFOT, NUNIT, OK, LERR
+ COMMON / SRNAMC / SRNAMT
+* ..
+* .. Data statements ..
+ DATA ISEEDY / 1988, 1989, 1990, 1991 / ,
+ $ TRANSS / 'N', 'T', 'C' /
+* ..
+* .. Executable Statements ..
+*
+* Initialize constants and the random number seed.
+*
+ PATH( 1: 1 ) = 'Double precision'
+ PATH( 2: 3 ) = 'GB'
+ NRUN = 0
+ NFAIL = 0
+ NERRS = 0
+ DO 10 I = 1, 4
+ ISEED( I ) = ISEEDY( I )
+ 10 CONTINUE
+*
+* Test the error exits
+*
+ IF( TSTERR )
+ $ CALL DERRGE( PATH, NOUT )
+ INFOT = 0
+ CALL XLAENV( 2, 2 )
+*
+* Initialize the first value for the lower and upper bandwidths.
+*
+ KLVAL( 1 ) = 0
+ KUVAL( 1 ) = 0
+*
+* Do for each value of M in MVAL
+*
+ DO 160 IM = 1, NM
+ M = MVAL( IM )
+*
+* Set values to use for the lower bandwidth.
+*
+ KLVAL( 2 ) = M + ( M+1 ) / 4
+*
+* KLVAL( 2 ) = MAX( M-1, 0 )
+*
+ KLVAL( 3 ) = ( 3*M-1 ) / 4
+ KLVAL( 4 ) = ( M+1 ) / 4
+*
+* Do for each value of N in NVAL
+*
+ DO 150 IN = 1, NN
+ N = NVAL( IN )
+ XTYPE = 'N'
+*
+* Set values to use for the upper bandwidth.
+*
+ KUVAL( 2 ) = N + ( N+1 ) / 4
+*
+* KUVAL( 2 ) = MAX( N-1, 0 )
+*
+ KUVAL( 3 ) = ( 3*N-1 ) / 4
+ KUVAL( 4 ) = ( N+1 ) / 4
+*
+* Set limits on the number of loop iterations.
+*
+ NKL = MIN( M+1, 4 )
+ IF( N.EQ.0 )
+ $ NKL = 2
+ NKU = MIN( N+1, 4 )
+ IF( M.EQ.0 )
+ $ NKU = 2
+ NIMAT = NTYPES
+ IF( M.LE.0 .OR. N.LE.0 )
+ $ NIMAT = 1
+*
+ DO 140 IKL = 1, NKL
+*
+* Do for KL = 0, (5*M+1)/4, (3M-1)/4, and (M+1)/4. This
+* order makes it easier to skip redundant values for small
+* values of M.
+*
+ KL = KLVAL( IKL )
+ DO 130 IKU = 1, NKU
+*
+* Do for KU = 0, (5*N+1)/4, (3N-1)/4, and (N+1)/4. This
+* order makes it easier to skip redundant values for
+* small values of N.
+*
+ KU = KUVAL( IKU )
+*
+* Check that A and AFAC are big enough to generate this
+* matrix.
+*
+ LDA = KL + KU + 1
+ LDAFAC = 2*KL + KU + 1
+ IF( ( LDA*N ).GT.LA .OR. ( LDAFAC*N ).GT.LAFAC ) THEN
+ IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
+ $ CALL ALAHD( NOUT, PATH )
+ IF( N*( KL+KU+1 ).GT.LA ) THEN
+ WRITE( NOUT, FMT = 9999 )LA, M, N, KL, KU,
+ $ N*( KL+KU+1 )
+ NERRS = NERRS + 1
+ END IF
+ IF( N*( 2*KL+KU+1 ).GT.LAFAC ) THEN
+ WRITE( NOUT, FMT = 9998 )LAFAC, M, N, KL, KU,
+ $ N*( 2*KL+KU+1 )
+ NERRS = NERRS + 1
+ END IF
+ GO TO 130
+ END IF
+*
+ DO 120 IMAT = 1, NIMAT
+*
+* Do the tests only if DOTYPE( IMAT ) is true.
+*
+ IF( .NOT.DOTYPE( IMAT ) )
+ $ GO TO 120
+*
+* Skip types 2, 3, or 4 if the matrix size is too
+* small.
+*
+ ZEROT = IMAT.GE.2 .AND. IMAT.LE.4
+ IF( ZEROT .AND. N.LT.IMAT-1 )
+ $ GO TO 120
+*
+ IF( .NOT.ZEROT .OR. .NOT.DOTYPE( 1 ) ) THEN
+*
+* Set up parameters with DLATB4 and generate a
+* test matrix with DLATMS.
+*
+ CALL DLATB4( PATH, IMAT, M, N, TYPE, KL, KU,
+ $ ANORM, MODE, CNDNUM, DIST )
+*
+ KOFF = MAX( 1, KU+2-N )
+ DO 20 I = 1, KOFF - 1
+ A( I ) = ZERO
+ 20 CONTINUE
+ SRNAMT = 'DLATMS'
+ CALL DLATMS( M, N, DIST, ISEED, TYPE, RWORK,
+ $ MODE, CNDNUM, ANORM, KL, KU, 'Z',
+ $ A( KOFF ), LDA, WORK, INFO )
+*
+* Check the error code from DLATMS.
+*
+ IF( INFO.NE.0 ) THEN
+ CALL ALAERH( PATH, 'DLATMS', INFO, 0, ' ', M,
+ $ N, KL, KU, -1, IMAT, NFAIL,
+ $ NERRS, NOUT )
+ GO TO 120
+ END IF
+ ELSE IF( IZERO.GT.0 ) THEN
+*
+* Use the same matrix for types 3 and 4 as for
+* type 2 by copying back the zeroed out column.
+*
+ CALL DCOPY( I2-I1+1, B, 1, A( IOFF+I1 ), 1 )
+ END IF
+*
+* For types 2, 3, and 4, zero one or more columns of
+* the matrix to test that INFO is returned correctly.
+*
+ IZERO = 0
+ IF( ZEROT ) THEN
+ IF( IMAT.EQ.2 ) THEN
+ IZERO = 1
+ ELSE IF( IMAT.EQ.3 ) THEN
+ IZERO = MIN( M, N )
+ ELSE
+ IZERO = MIN( M, N ) / 2 + 1
+ END IF
+ IOFF = ( IZERO-1 )*LDA
+ IF( IMAT.LT.4 ) THEN
+*
+* Store the column to be zeroed out in B.
+*
+ I1 = MAX( 1, KU+2-IZERO )
+ I2 = MIN( KL+KU+1, KU+1+( M-IZERO ) )
+ CALL DCOPY( I2-I1+1, A( IOFF+I1 ), 1, B, 1 )
+*
+ DO 30 I = I1, I2
+ A( IOFF+I ) = ZERO
+ 30 CONTINUE
+ ELSE
+ DO 50 J = IZERO, N
+ DO 40 I = MAX( 1, KU+2-J ),
+ $ MIN( KL+KU+1, KU+1+( M-J ) )
+ A( IOFF+I ) = ZERO
+ 40 CONTINUE
+ IOFF = IOFF + LDA
+ 50 CONTINUE
+ END IF
+ END IF
+*
+* These lines, if used in place of the calls in the
+* loop over INB, cause the code to bomb on a Sun
+* SPARCstation.
+*
+* ANORMO = DLANGB( 'O', N, KL, KU, A, LDA, RWORK )
+* ANORMI = DLANGB( 'I', N, KL, KU, A, LDA, RWORK )
+*
+* Do for each blocksize in NBVAL
+*
+ DO 110 INB = 1, NNB
+ NB = NBVAL( INB )
+ CALL XLAENV( 1, NB )
+*
+* Compute the LU factorization of the band matrix.
+*
+ IF( M.GT.0 .AND. N.GT.0 )
+ $ CALL DLACPY( 'Full', KL+KU+1, N, A, LDA,
+ $ AFAC( KL+1 ), LDAFAC )
+ SRNAMT = 'DGBTRF'
+ CALL DGBTRF( M, N, KL, KU, AFAC, LDAFAC, IWORK,
+ $ INFO )
+*
+* Check error code from DGBTRF.
+*
+ IF( INFO.NE.IZERO )
+ $ CALL ALAERH( PATH, 'DGBTRF', INFO, IZERO,
+ $ ' ', M, N, KL, KU, NB, IMAT,
+ $ NFAIL, NERRS, NOUT )
+ TRFCON = .FALSE.
+*
+*+ TEST 1
+* Reconstruct matrix from factors and compute
+* residual.
+*
+ CALL DGBT01( M, N, KL, KU, A, LDA, AFAC, LDAFAC,
+ $ IWORK, WORK, RESULT( 1 ) )
+*
+* Print information about the tests so far that
+* did not pass the threshold.
+*
+ IF( RESULT( 1 ).GE.THRESH ) THEN
+ IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
+ $ CALL ALAHD( NOUT, PATH )
+ WRITE( NOUT, FMT = 9997 )M, N, KL, KU, NB,
+ $ IMAT, 1, RESULT( 1 )
+ NFAIL = NFAIL + 1
+ END IF
+ NRUN = NRUN + 1
+*
+* Skip the remaining tests if this is not the
+* first block size or if M .ne. N.
+*
+ IF( INB.GT.1 .OR. M.NE.N )
+ $ GO TO 110
+*
+ ANORMO = DLANGB( 'O', N, KL, KU, A, LDA, RWORK )
+ ANORMI = DLANGB( 'I', N, KL, KU, A, LDA, RWORK )
+*
+ IF( INFO.EQ.0 ) THEN
+*
+* Form the inverse of A so we can get a good
+* estimate of CNDNUM = norm(A) * norm(inv(A)).
+*
+ LDB = MAX( 1, N )
+ CALL DLASET( 'Full', N, N, ZERO, ONE, WORK,
+ $ LDB )
+ SRNAMT = 'DGBTRS'
+ CALL DGBTRS( 'No transpose', N, KL, KU, N,
+ $ AFAC, LDAFAC, IWORK, WORK, LDB,
+ $ INFO )
+*
+* Compute the 1-norm condition number of A.
+*
+ AINVNM = DLANGE( 'O', N, N, WORK, LDB,
+ $ RWORK )
+ IF( ANORMO.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN
+ RCONDO = ONE
+ ELSE
+ RCONDO = ( ONE / ANORMO ) / AINVNM
+ END IF
+*
+* Compute the infinity-norm condition number of
+* A.
+*
+ AINVNM = DLANGE( 'I', N, N, WORK, LDB,
+ $ RWORK )
+ IF( ANORMI.LE.ZERO .OR. AINVNM.LE.ZERO ) THEN
+ RCONDI = ONE
+ ELSE
+ RCONDI = ( ONE / ANORMI ) / AINVNM
+ END IF
+ ELSE
+*
+* Do only the condition estimate if INFO.NE.0.
+*
+ TRFCON = .TRUE.
+ RCONDO = ZERO
+ RCONDI = ZERO
+ END IF
+*
+* Skip the solve tests if the matrix is singular.
+*
+ IF( TRFCON )
+ $ GO TO 90
+*
+ DO 80 IRHS = 1, NNS
+ NRHS = NSVAL( IRHS )
+ XTYPE = 'N'
+*
+ DO 70 ITRAN = 1, NTRAN
+ TRANS = TRANSS( ITRAN )
+ IF( ITRAN.EQ.1 ) THEN
+ RCONDC = RCONDO
+ NORM = 'O'
+ ELSE
+ RCONDC = RCONDI
+ NORM = 'I'
+ END IF
+*
+*+ TEST 2:
+* Solve and compute residual for A * X = B.
+*
+ SRNAMT = 'DLARHS'
+ CALL DLARHS( PATH, XTYPE, ' ', TRANS, N,
+ $ N, KL, KU, NRHS, A, LDA,
+ $ XACT, LDB, B, LDB, ISEED,
+ $ INFO )
+ XTYPE = 'C'
+ CALL DLACPY( 'Full', N, NRHS, B, LDB, X,
+ $ LDB )
+*
+ SRNAMT = 'DGBTRS'
+ CALL DGBTRS( TRANS, N, KL, KU, NRHS, AFAC,
+ $ LDAFAC, IWORK, X, LDB, INFO )
+*
+* Check error code from DGBTRS.
+*
+ IF( INFO.NE.0 )
+ $ CALL ALAERH( PATH, 'DGBTRS', INFO, 0,
+ $ TRANS, N, N, KL, KU, -1,
+ $ IMAT, NFAIL, NERRS, NOUT )
+*
+ CALL DLACPY( 'Full', N, NRHS, B, LDB,
+ $ WORK, LDB )
+ CALL DGBT02( TRANS, M, N, KL, KU, NRHS, A,
+ $ LDA, X, LDB, WORK, LDB,
+ $ RESULT( 2 ) )
+*
+*+ TEST 3:
+* Check solution from generated exact
+* solution.
+*
+ CALL DGET04( N, NRHS, X, LDB, XACT, LDB,
+ $ RCONDC, RESULT( 3 ) )
+*
+*+ TESTS 4, 5, 6:
+* Use iterative refinement to improve the
+* solution.
+*
+ SRNAMT = 'DGBRFS'
+ CALL DGBRFS( TRANS, N, KL, KU, NRHS, A,
+ $ LDA, AFAC, LDAFAC, IWORK, B,
+ $ LDB, X, LDB, RWORK,
+ $ RWORK( NRHS+1 ), WORK,
+ $ IWORK( N+1 ), INFO )
+*
+* Check error code from DGBRFS.
+*
+ IF( INFO.NE.0 )
+ $ CALL ALAERH( PATH, 'DGBRFS', INFO, 0,
+ $ TRANS, N, N, KL, KU, NRHS,
+ $ IMAT, NFAIL, NERRS, NOUT )
+*
+ CALL DGET04( N, NRHS, X, LDB, XACT, LDB,
+ $ RCONDC, RESULT( 4 ) )
+ CALL DGBT05( TRANS, N, KL, KU, NRHS, A,
+ $ LDA, B, LDB, X, LDB, XACT,
+ $ LDB, RWORK, RWORK( NRHS+1 ),
+ $ RESULT( 5 ) )
+ DO 60 K = 2, 6
+ IF( RESULT( K ).GE.THRESH ) THEN
+ IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
+ $ CALL ALAHD( NOUT, PATH )
+ WRITE( NOUT, FMT = 9996 )TRANS, N,
+ $ KL, KU, NRHS, IMAT, K,
+ $ RESULT( K )
+ NFAIL = NFAIL + 1
+ END IF
+ 60 CONTINUE
+ NRUN = NRUN + 5
+ 70 CONTINUE
+ 80 CONTINUE
+*
+*+ TEST 7:
+* Get an estimate of RCOND = 1/CNDNUM.
+*
+ 90 CONTINUE
+ DO 100 ITRAN = 1, 2
+ IF( ITRAN.EQ.1 ) THEN
+ ANORM = ANORMO
+ RCONDC = RCONDO
+ NORM = 'O'
+ ELSE
+ ANORM = ANORMI
+ RCONDC = RCONDI
+ NORM = 'I'
+ END IF
+ SRNAMT = 'DGBCON'
+ CALL DGBCON( NORM, N, KL, KU, AFAC, LDAFAC,
+ $ IWORK, ANORM, RCOND, WORK,
+ $ IWORK( N+1 ), INFO )
+*
+* Check error code from DGBCON.
+*
+ IF( INFO.NE.0 )
+ $ CALL ALAERH( PATH, 'DGBCON', INFO, 0,
+ $ NORM, N, N, KL, KU, -1, IMAT,
+ $ NFAIL, NERRS, NOUT )
+*
+ RESULT( 7 ) = DGET06( RCOND, RCONDC )
+*
+* Print information about the tests that did
+* not pass the threshold.
+*
+ IF( RESULT( 7 ).GE.THRESH ) THEN
+ IF( NFAIL.EQ.0 .AND. NERRS.EQ.0 )
+ $ CALL ALAHD( NOUT, PATH )
+ WRITE( NOUT, FMT = 9995 )NORM, N, KL, KU,
+ $ IMAT, 7, RESULT( 7 )
+ NFAIL = NFAIL + 1
+ END IF
+ NRUN = NRUN + 1
+ 100 CONTINUE
+*
+ 110 CONTINUE
+ 120 CONTINUE
+ 130 CONTINUE
+ 140 CONTINUE
+ 150 CONTINUE
+ 160 CONTINUE
+*
+* Print a summary of the results.
+*
+ CALL ALASUM( PATH, NOUT, NFAIL, NRUN, NERRS )
+*
+ 9999 FORMAT( ' *** In DCHKGB, LA=', I5, ' is too small for M=', I5,
+ $ ', N=', I5, ', KL=', I4, ', KU=', I4,
+ $ / ' ==> Increase LA to at least ', I5 )
+ 9998 FORMAT( ' *** In DCHKGB, LAFAC=', I5, ' is too small for M=', I5,
+ $ ', N=', I5, ', KL=', I4, ', KU=', I4,
+ $ / ' ==> Increase LAFAC to at least ', I5 )
+ 9997 FORMAT( ' M =', I5, ', N =', I5, ', KL=', I5, ', KU=', I5,
+ $ ', NB =', I4, ', type ', I1, ', test(', I1, ')=', G12.5 )
+ 9996 FORMAT( ' TRANS=''', A1, ''', N=', I5, ', KL=', I5, ', KU=', I5,
+ $ ', NRHS=', I3, ', type ', I1, ', test(', I1, ')=', G12.5 )
+ 9995 FORMAT( ' NORM =''', A1, ''', N=', I5, ', KL=', I5, ', KU=', I5,
+ $ ',', 10X, ' type ', I1, ', test(', I1, ')=', G12.5 )
+*
+ RETURN
+*
+* End of DCHKGB
+*
+ END
+ SUBROUTINE DCHKGE( DOTYPE, NM, MVAL, NN, NVAL, NNB, NBVAL, NNS,
+ $ NSVAL, THRESH, TSTERR, NMAX, A, AFAC, AINV, B,
+ $ X, XACT, WORK, RWORK, IWORK, NOUT )
+*
+* -- LAPACK test routine (version 3.1.1) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* January 2007
+*
+* .. Scalar Arguments ..
+ LOGICAL TSTERR
+ INTEGER NM, NMAX, NN, NNB, NNS, NOUT
+ DOUBLE PRECISION THRESH
+* ..
+* .. Array Arguments ..
+ LOGICAL DOTYPE( * )
+ INTEGER IWORK( * ), MVAL( * ), NBVAL( * ), NSVAL( * ),
+ $ NVAL( * )
+ DOUBLE PRECISION A( * ), AFAC( * ), AINV( * ), B( * ),
+ $ RWORK( * ), WORK( * ), X( * ), XACT( * )
+* ..
+*
+* Purpose
+* =======
+*
+* DCHKGE tests DGETRF, -TRI, -TRS, -RFS, and -CON.
+*
+* Arguments
+* =========
+*
+* DOTYPE (input) LOGICAL array, dimension (NTYPES)
+* The matrix types to be used for testing. Matrices of type j
+* (for 1 <= j <= NTYPES) are used for testing if DOTYPE(j) =
+* .TRUE.; if DOTYPE(j) = .FALSE., then type j is not used.
+*
+* NM (input) INTEGER
+* The number of values of M contained in the vector MVAL.
+*
+* MVAL (input) INTEGER array, dimension (NM)
+* The values of the matrix row dimension M.
+*
+* NN (input) INTEGER
+* The number of values of N contained in the vector NVAL.
+*
+* NVAL (input) INTEGER array, dimension (NN)
+* The values of the matrix column dimension N.
+*
+* NNB (input) INTEGER
+* The number of values of NB contained in the vector NBVAL.
+*
+* NBVAL (input) INTEGER array, dimension (NBVAL)
+* The values of the blocksize NB.
+*
+* NNS (input) INTEGER
+* The number of values of NRHS contained in the vector NSVAL.
+*
+* NSVAL (input) INTEGER array, dimension (NNS)
+* The values of the number of right hand sides NRHS.
+*
+* THRESH (input) DOUBLE PRECISION
+* The threshold value for the test ratios. A result is
+* included in the output file if RESULT >